support.scm

Scheme跨平台编译器

      (lambda ()
	(let ((exports '()))
	  (##sys#hash-table-for-each
	   (lambda (sym plist)
	     (when (and (assq 'global plist) 
			(assq 'assigned plist)
			(or (and export-list (memq sym export-list))
			    (not (memq sym block-globals)) ) )
	       (set! exports (cons sym exports)) ) )
	   db)
	  (for-each 
	   (lambda (s)
	     (write s)
	     (newline) )
	   (sort exports
		 (lambda (s1 s2)
		   (string<? (##sys#slot s1 1) (##sys#slot s2 1)))) )
	  (export-dump-hook db file) ) ) ) ) )

(define (dump-undefined-globals db)
  (##sys#hash-table-for-each
   (lambda (sym plist)
     (when (and (assq 'global plist)
		(not (assq 'assigned plist)) )
       (write sym)
       (newline) ) )
   db) )

(define (check-global-exports db)
  (when export-list
    (let ([exps export-list])
      (##sys#hash-table-for-each
       (lambda (sym plist)
	 (when (and (memq sym exps) (not (assq 'assigned plist)))
	   (compiler-warning 'var "exported global variable `~S' is used but not defined" sym) )
	 (set! exps (delete sym exps eq?)) )
       db)
      (for-each (cut compiler-warning 'var "exported global variable `~S' is not defined" <>) exps) ) ) )

(define (check-global-imports db)
  (##sys#hash-table-for-each
   (lambda (sym plist)
     (let ((imp (##sys#hash-table-ref import-table sym))
	   (refs (assq 'references plist))
	   (assgn (assq 'assigned plist)) )
       (when (assq 'global plist)
	 (cond (assgn
		(when imp
		  (compiler-warning 'redef "redefinition of imported variable `~s' from `~s'" sym imp) ) )
	       ((and (pair? refs) (not imp) (not (keyword? sym)))
		(compiler-warning 'var "variable `~s' used but not imported" sym) ) ) ) ) )
   db) )

(define (export-import-hook x id) (void))

(define (lookup-exports-file id)
  (and-let* ((xfile (##sys#resolve-include-filename 
		     (string-append (->string id) ".exports")
		     #t #t) )
	     ((file-exists? xfile)) )
    (when verbose-mode 
      (printf "loading exports file ~a ...~%" xfile) )
    (for-each
     (lambda (exp)
       (if (symbol? exp)
	   (##sys#hash-table-set! import-table exp id) 
	   (export-import-hook exp id) ) )
     (read-file xfile)) ) )


;;; Compute general statistics from analysis database:
;
; - Returns:
;
;   current-program-size
;   original-program-size
;   number of known variables
;   number of known procedures
;   number of global variables
;   number of known call-sites
;   number of database entries
;   average bucket load

(define (compute-database-statistics db)
  (let ((nprocs 0)
	(nvars 0)
	(nglobs 0)
	(entries 0)
	(nsites 0) )
    (##sys#hash-table-for-each
     (lambda (sym plist)
       (for-each
	(lambda (prop)
	  (set! entries (+ entries 1))
	  (case (car prop)
	    ((global) (set! nglobs (+ nglobs 1)))
	    ((value)
	     (set! nvars (+ nvars 1))
	     (if (eq? '##core#lambda (node-class (cdr prop)))
		 (set! nprocs (+ nprocs 1)) ) )
	    ((call-sites) (set! nsites (+ nsites (length (cdr prop))))) ) )
	plist) )
     db)
    (values current-program-size
	    original-program-size
	    nvars
	    nprocs
	    nglobs
	    nsites
	    entries) ) )

(define (print-program-statistics db)
  (receive
   (size osize kvars kprocs globs sites entries) (compute-database-statistics db)
   (when (debugging 's "program statistics:")
     (printf ";   program size: \t~s \toriginal program size: \t~s\n" size osize)
     (printf ";   variables with known values: \t~s\n" kvars)
     (printf ";   known procedures: \t~s\n" kprocs)
     (printf ";   global variables: \t~s\n" globs)
     (printf ";   known call sites: \t~s\n" sites) 
     (printf ";   database entries: \t~s\n" entries) ) ) )


;;; Pretty-print expressions:

(define (pprint-expressions-to-file exps filename)
  (let ([port (if filename (open-output-file filename) (current-output-port))])
    (with-output-to-port port
      (lambda ()
	(for-each
	 (lambda (x)
	   (pretty-print x)
	   (newline) ) 
	 exps) ) )
    (when filename (close-output-port port)) ) )


;;; Create foreign type checking expression:

(define foreign-type-check
  (let ([tmap '((nonnull-u8vector . u8vector) (nonnull-u16vector . u16vector)
		(nonnull-s8vector . s8vector) (nonnull-s16vector . s16vector)
		(nonnull-u32vector . u32vector) (nonnull-s32vector . s32vector)
		(nonnull-f32vector . f32vector) (nonnull-f64vector . f64vector) ) ] )
    (lambda (param type)
      (follow-without-loop
       type
       (lambda (t next)
	 (let repeat ([t t])
	   (case t
	     [(char unsigned-char) (if unsafe param `(##sys#foreign-char-argument ,param))]
	     [(int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32)
	      (if unsafe param `(##sys#foreign-fixnum-argument ,param))]
	     [(float double number) (if unsafe param `(##sys#foreign-flonum-argument ,param))]
	     [(pointer byte-vector blob scheme-pointer) ; pointer and byte-vector are DEPRECATED
	      (let ([tmp (gensym)])
		`(let ([,tmp ,param])
		   (if ,tmp
		       ,(if unsafe
			    tmp
			    `(##sys#foreign-block-argument ,tmp) )
		       '#f) ) ) ]
	     [(nonnull-pointer nonnull-scheme-pointer nonnull-blob nonnull-byte-vector) ; nonnull-pointer and nonnull-byte-vector are DEPRECATED
	      (if unsafe
		  param
		  `(##sys#foreign-block-argument ,param) ) ]
	     [(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector)
	      (let ([tmp (gensym)])
		`(let ([,tmp ,param])
		   (if ,tmp
		       ,(if unsafe
			    tmp
			    `(##sys#foreign-number-vector-argument ',t ,tmp) )
		       '#f) ) ) ]
	     [(nonnull-u8vector nonnull-u16vector nonnull-s8vector nonnull-s16vector nonnull-u32vector nonnull-s32vector 
				nonnull-f32vector nonnull-f64vector)
	      (if unsafe
		  param
		  `(##sys#foreign-number-vector-argument 
		    ',(##sys#slot (assq t tmap) 1)
		    ,param) ) ]
	     [(integer long integer32) (if unsafe param `(##sys#foreign-integer-argument ,param))]
	     [(unsigned-integer unsigned-integer32 unsigned-long)
	      (if unsafe
		  param
		  `(##sys#foreign-unsigned-integer-argument ,param) ) ]
	     [(c-pointer c-string-list c-string-list*)
	      (let ([tmp (gensym)])
		`(let ([,tmp ,param])
		   (if ,tmp
		       (##sys#foreign-pointer-argument ,tmp)
		       '#f) ) ) ]
	     [(nonnull-c-pointer)
	      `(##sys#foreign-pointer-argument ,param) ]
	     [(c-string c-string* unsigned-c-string*)
	      (let ([tmp (gensym)])
		`(let ([,tmp ,param])
		   (if ,tmp
		       ,(if unsafe 
			    `(##sys#make-c-string ,tmp)
			    `(##sys#make-c-string (##sys#foreign-string-argument ,tmp)) )
		       '#f) ) ) ]
	     [(nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*)
	      (if unsafe 
		  `(##sys#make-c-string ,param)
		  `(##sys#make-c-string (##sys#foreign-string-argument ,param)) ) ]
	     [(symbol)
	      (if unsafe 
		  `(##sys#make-c-string (##sys#symbol->string ,param))
		  `(##sys#make-c-string (##sys#foreign-string-argument (##sys#symbol->string ,param))) ) ]
	     [else
	      (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
		     => (lambda (t)
			  (next (if (vector? t) (vector-ref t 0) t)) ) ]
		    [(pair? t)
		     (match t
		       [((or 'ref 'pointer 'function 'c-pointer) . _)
			(let ([tmp (gensym)])
			  `(let ([,tmp ,param])
			     (if ,tmp
				 (##sys#foreign-pointer-argument ,tmp)
				 '#f) ) )  ]
		       [((or 'instance 'instance-ref) . _)
			(let ([tmp (gensym)])
			  `(let ([,tmp ,param])
			     (if ,tmp
				 (slot-ref ,param 'this)
				 '#f) ) ) ]
		       [('nonnull-instance . _)
			`(slot-ref ,param 'this) ]
		       [('const t) (repeat t)]
		       [('enum _) 
			(if unsafe param `(##sys#foreign-integer-argument ,param))]
		       [((or 'nonnull-pointer 'nonnull-c-pointer) . _)
			`(##sys#foreign-pointer-argument ,param) ]
		       [_ param] ) ]
		    [else param] ) ] ) ) )
       (lambda () (quit "foreign type `~S' refers to itself" type)) ) ) ) )


;;; Compute foreign-type conversions:

(define (foreign-type-convert-result r t)
  (or (and-let* ([(symbol? t)]
		 [ft (##sys#hash-table-ref foreign-type-table t)] 
		 [(vector? ft)] )
	(list (vector-ref ft 2) r) )
      r) )

(define (foreign-type-convert-argument a t)
  (or (and-let* ([(symbol? t)]
		 [ft (##sys#hash-table-ref foreign-type-table t)] 
		 [(vector? ft)] )
	(list (vector-ref ft 1) a) )
      a) )

(define (final-foreign-type t0)
  (follow-without-loop
   t0
   (lambda (t next)
     (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
	    => (lambda (t2)
		 (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
	   [else t] ) )
   (lambda () (quit "foreign type `~S' refers to itself" t0)) ) )


;;; Compute foreign result size:

(define (estimate-foreign-result-size type)
  (follow-without-loop
   type
   (lambda (t next)
     (case t
       ((char int short bool void unsigned-short scheme-object unsigned-char unsigned-int byte unsigned-byte
	      int32 unsigned-int32) 
	0)
       ((c-string nonnull-c-string c-pointer nonnull-c-pointer symbol c-string* nonnull-c-string*
                  unsigned-c-string* nonnull-unsigned-c-string*
		  c-string-list c-string-list*)
	(words->bytes 3) )
       ((unsigned-integer long integer unsigned-long integer32 unsigned-integer32)
	(words->bytes 4) )
       ((float double number integer64) 
	(words->bytes 4) )		; possibly 8-byte aligned 64-bit double
       (else
	(cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
	       => (lambda (t2)
		    (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
	      [(pair? t)
	       (case (car t)
		 [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function instance instance-ref nonnull-instance) 
		  (words->bytes 3) ]
		 [else 0] ) ]
	      [else 0] ) ) ) )
   (lambda () (quit "foreign type `~S' refers to itself" type)) ) )

(define (estimate-foreign-result-location-size type)
  (define (err t) 
    (quit "can not compute size of location for foreign type `~S'" t) )
  (follow-without-loop
   type
   (lambda (t next)
     (case t
       ((char int short bool unsigned-short unsigned-char unsigned-int long unsigned-long byte unsigned-byte
	      c-pointer pointer nonnull-c-pointer unsigned-integer integer float c-string symbol
	      scheme-pointer nonnull-scheme-pointer int32 unsigned-int32 integer32 unsigned-integer32
              unsigned-c-string* nonnull-unsigned-c-string*
	      nonnull-c-string c-string* nonnull-c-string* c-string-list c-string-list*) ; pointer and nonnull-pointer are DEPRECATED
	(words->bytes 1) )
       ((double number)
	(words->bytes 2) )
       (else
	(cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
	       => (lambda (t2)
		    (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
	      [(pair? t)
	       (case (car t)
		 [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function) (words->bytes 1)]
		 [else (err t)] ) ]
	      [else (err t)] ) ) ) )
   (lambda () (quit "foreign type `~S' refers to itself" type)) ) )


;;; Convert result value, if a string:

(define (finish-foreign-result type body)
  (case type
    [(c-string) `(##sys#peek-c-string ,body '0)]
    [(nonnull-c-string) `(##sys#peek-nonnull-c-string ,body '0)]
    [(c-string* unsigned-c-string*) `(##sys#peek-and-free-c-string ,body '0)]
    [(nonnull-c-string* nonnull-unsigned-c-string*) `(##sys#peek-and-free-nonnull-c-string ,body '0)]
    [(symbol) `(##sys#intern-symbol (##sys#peek-c-string ,body '0))]
    [(c-string-list) `(##sys#peek-c-string-list ,body '#f)]
    [(c-string-list*) `(##sys#peek-and-free-c-string-list ,body '#f)]
    [else
     (match type
       [((or 'instance 'instance-ref) cname sname)
	`(##tinyclos#make-instance-from-pointer ,body ,sname) ] ;XXX eggified, needs better treatment...
       [('nonnull-instance cname sname)
	`(make ,sname 'this ,body) ]
       [_ body] ) ] ) )


;;; Scan expression-node for variable usage:

(define (scan-used-variables node vars)
  (let ([used '()])
    (let walk ([n node])
      (let ([subs (node-subexpressions n)])
	(case (node-class n)
	  [(##core#variable set!) 
	   (let ([var (first (node-parameters n))])
	     (when (and (memq var vars) (not (memq var used)))
	       (set! used (cons var used)) ) 
	     (for-each walk subs) ) ]
	  [(quote ##core#undefined ##core#primitive) #f]
	  [else (for-each walk subs)] ) ) )
    used) )


;;; Scan expression-node for free variables (that are not in env):

(define (scan-free-variables node)
  (let ((vars '()))

    (define (walk n e)
      (let ([subs (node-subexpressions n)]
	    [params (node-parameters n)] )
	(case (node-class n)
	  ((quote ##core#undefined ##core#primitive ##core#proc ##core#inline_ref) #f)
	  ((##core#variable) 
	   (let ((var (first params)))
	     (unless (memq var e) (set! vars (lset-adjoin eq? vars var))) ) )
	  ((set!)
	   (let ((var (first params)))
	     (unless (memq var e) (set! vars (lset-adjoin eq? vars var)))
	     (walk (car subs) e) ) )