support.scm

Scheme跨平台编译器

    (if plist
	(let ([a (assq prop plist)])
	  (cond [a (##sys#setslot a 1 val)]
		[val (##sys#setslot plist 1 (alist-cons prop val (##sys#slot plist 1)))] ) )
	(when val (##sys#hash-table-set! db key (list (cons prop val)))) ) ) )

(define (collect! db key prop val)
  (let ((plist (##sys#hash-table-ref db key)))
    (if plist
	(let ([a (assq prop plist)])
	  (cond [a (##sys#setslot a 1 (cons val (##sys#slot a 1)))]
		[else (##sys#setslot plist 1 (alist-cons prop (list val) (##sys#slot plist 1)))] ) )
	(##sys#hash-table-set! db key (list (list prop val)))) ) )

(define (count! db key prop . val)
  (let ([plist (##sys#hash-table-ref db key)]
	[n (if (pair? val) (car val) 1)] )
    (if plist
	(let ([a (assq prop plist)])
	  (cond [a (##sys#setslot a 1 (+ (##sys#slot a 1) n))]
		[else (##sys#setslot plist 1 (alist-cons prop n (##sys#slot plist 1)))] ) )
	(##sys#hash-table-set! db key (list (cons prop val)))) ) )


;;; Line-number database management:

(define (get-line exp)
  (get ##sys#line-number-database (car exp) exp) )

(define (get-line-2 exp)
  (let* ((name (car exp))
	 (lst (##sys#hash-table-ref ##sys#line-number-database name)) )
    (cond ((and lst (assq exp (cdr lst)))
	   => (lambda (a) (values (car lst) (cdr a))) )
	  (else (values name #f)) ) ) )

(define (find-lambda-container id cid db)
  (let loop ([id id])
    (or (eq? id cid)
	(let ([c (get db id 'contained-in)])
	  (and c (loop c)) ) ) ) )

(define (display-line-number-database)
  (##sys#hash-table-for-each
   (lambda (key val)
     (when val (printf "~S ~S~%" key (map cdr val))) )
   ##sys#line-number-database) )


;;; Display analysis database:

(define display-analysis-database
  (let ((names '((captured . cpt) (assigned . set) (boxed . box) (global . glo) (assigned-locally . stl)
		 (contractable . con) (standard-binding . stb) (foldable . fld) (simple . sim) (inlinable . inl)
		 (side-effecting . sef) (collapsable . col) (removable . rem) (constant . con)
		 (undefined . und) (replacing . rpg) (unused . uud) (extended-binding . xtb) (inline-export . ilx)
		 (customizable . cst) (has-unused-parameters . hup) (boxed-rest . bxr) ) ) 
	(omit #f))
    (lambda (db)
      (unless omit
	(set! omit 
	  (append default-standard-bindings
		  default-extended-bindings
		  internal-bindings) ) )
      (##sys#hash-table-for-each
       (lambda (sym plist)
	 (let ([val #f]
	       [pval #f]
	       [csites '()]
	       [refs '()] )
	   (unless (memq sym omit)
	     (write sym)
	     (let loop ((es plist))
	       (if (pair? es)
		   (begin
		     (case (caar es)
		       ((captured assigned boxed global contractable standard-binding foldable assigned-locally
				  side-effecting collapsable removable undefined replacing unused simple inlinable inline-export
				  has-unused-parameters extended-binding customizable constant boxed-rest)
			(printf "\t~a" (cdr (assq (caar es) names))) )
		       ((unknown)
			(set! val 'unknown) )
		       ((value)
			(unless (eq? val 'unknown) (set! val (cdar es))) )
		       ((potential-value)
			(set! pval (cdar es)) )
		       ((replacable home contains contained-in use-expr closure-size rest-parameter
				    o-r/access-count captured-variables explicit-rest)
			(printf "\t~a=~s" (caar es) (cdar es)) )
		       ((references)
			(set! refs (cdar es)) )
		       ((call-sites)
			(set! csites (cdar es)) )
		       (else (bomb "Illegal property" (car es))) )
		     (loop (cdr es)) ) ) )
	     (cond [(and val (not (eq? val 'unknown)))
		    (printf "\tval=~s" (cons (node-class val) (node-parameters val))) ]
		   [(and pval (not (eq? pval 'unknown)))
		    (printf "\tpval=~s" (cons (node-class pval) (node-parameters pval)))] )
	     (when (pair? refs) (printf "\trefs=~s" (length refs)))
	     (when (pair? csites) (printf "\tcss=~s" (length csites)))
	     (newline) ) ) )
       db) ) ) )       


;;; Node creation and -manipulation:

;; Note: much of this stuff will be overridden by the inline-definitions in "tweaks.scm".

(define-record node
  class					; symbol
  parameters				; (value...)
  subexpressions)			; (node...)

(define (make-node c p s)
  (##sys#make-structure 'node c p s) ) ; this kludge is for allowing the inlined `make-node'

(define (varnode var) (make-node '##core#variable (list var) '()))
(define (qnode const) (make-node 'quote (list const) '()))

(define (build-node-graph exp)
  (let ([count 0])
    (define (walk x)
      (cond ((symbol? x) (varnode x))
	    ((not-pair? x) (bomb "bad expression" x))
	    ((symbol? (car x))
	     (case (car x)
	       ((##core#global-ref) (make-node '##core#global-ref (list (cadr x)) '()))
	       ((if ##core#undefined) (make-node (car x) '() (map walk (cdr x))))
	       ((quote)
		(let ((c (cadr x)))
		  (qnode (if (and (number? c)
				  (eq? 'fixnum number-type)
				  (not (integer? c)) )
			     (begin
			       (compiler-warning
				'type
				"literal '~s' is out of range - will be truncated to integer" c)
			       (inexact->exact (truncate c)) )
			     c) ) ) )
	       ((let)
		(let ([bs (cadr x)]
		      [body (caddr x)] )
		  (if (null? bs)
		      (walk body)
		      (make-node 'let (unzip1 bs)
				 (append (map (lambda (b) (walk (cadr b))) (cadr x))
					 (list (walk body)) ) ) ) ) )
	       ((lambda) (make-node 'lambda (list (cadr x)) (list (walk (caddr x)))))
	       ((##core#primitive)
		(let ([arg (cadr x)])
		  (make-node
		   (car x)
		   (list (if (and (pair? arg) (eq? 'quote (car arg))) (cadr arg) arg))
		   (map walk (cddr x)) ) ) )
	       ((##core#inline ##core#callunit) 
		(make-node (car x) (list (cadr x)) (map walk (cddr x))) )
	       ((##core#proc)
		(make-node '##core#proc (list (cadr x) #t) '()) )
	       ((set! ##core#set!)
		(make-node
		 'set! (list (cadr x))
		 (map walk (cddr x))))
	       ((##core#foreign-callback-wrapper)
		(let ([name (cadr (second x))])
		  (make-node
		   '##core#foreign-callback-wrapper
		   (list name (cadr (third x)) (cadr (fourth x)) (cadr (fifth x)))
		   (list (walk (sixth x))) ) ) )
	       ((##core#inline_allocate ##core#inline_ref ##core#inline_update
					##core#inline_loc_ref ##core#inline_loc_update)
		(make-node (first x) (second x) (map walk (cddr x))) )
	       ((##core#app)
		(make-node '##core#call '(#t) (map walk (cdr x))) )
	       (else
		(receive (name ln) (get-line-2 x)
		  (make-node
		   '##core#call
		   (list (cond [(memq name always-bound-to-procedure)
				(set! count (add1 count))
				#t]
			       [else #f] )
			 (if ln
			     (let ([rn (real-name name)])
			       (list source-filename ln (or rn (##sys#symbol->qualified-string name))) )
			     (##sys#symbol->qualified-string name) ) )
		   (map walk x) ) ) ) ) )
	    (else (make-node '##core#call '(#f) (map walk x))) ) )
    (let ([exp2 (walk exp)])
      (debugging 'o "eliminated procedure checks" count)
      exp2) ) )

(define (build-expression-tree node)
  (let walk ((n node))
    (let ((subs (node-subexpressions n))
	  (params (node-parameters n)) 
	  (class (node-class n)) )
      (case class
	((if ##core#box ##core#cond) (cons class (map walk subs)))
	((##core#closure)
	 `(##core#closure ,params ,@(map walk subs)) )
	((##core#variable ##core#global-ref) (car params))
	((quote) `(quote ,(car params)))
	((let)
	 `(let ,(map list params (map walk (butlast subs)))
	    ,(walk (last subs)) ) )
	((##core#lambda) 
	 (list (if (second params)
		   'lambda
		   '##core#lambda)
	       (third params)
	       (walk (car subs)) ) )
	((##core#call) (map walk subs))
	((##core#callunit) (cons* '##core#callunit (car params) (map walk subs)))
	((##core#undefined) (list class))
	((##core#bind) 
	 (let loop ((n (car params)) (vals subs) (bindings '()))
	   (if (zero? n)
	       `(##core#bind ,(reverse bindings) ,(walk (car vals)))
	       (loop (- n 1) (cdr vals) (cons (walk (car vals)) bindings)) ) ) )
	((##core#unbox ##core#ref ##core#update ##core#update_i)
	 (cons* class (walk (car subs)) params (map walk (cdr subs))) ) 
	(else (cons class (append params (map walk subs)))) ) ) ) )

(define (fold-boolean proc lst)
  (let fold ([vars lst])
    (if (null? (cddr vars))
	(apply proc vars)
	(make-node 
	 '##core#inline '("C_and") 
	 (list (proc (first vars) (second vars))
	       (fold (cdr vars)) ) ) ) ) )

(define (inline-lambda-bindings llist args body copy?)
  (decompose-lambda-list
   llist
   (lambda (vars argc rest)
     (receive (largs rargs) (split-at args argc)
       (let* ([rlist (if copy? (map gensym vars) vars)]
	      [body (if copy? 
			(copy-node-tree-and-rename body vars rlist)
			body) ] )
	 (fold-right
	  (lambda (var val body) (make-node 'let (list var) (list val body)) )
	  (if rest
	      (make-node
	       'let (list (last rlist))
	       (list (if (null? rargs)
			 (qnode '())
			 (make-node '##core#inline_allocate (list "C_a_i_list" (* 3 (length rargs))) rargs) )
		     body) )
	      body)
	  (take rlist argc)
	  largs) ) ) ) ) )

(define (copy-node-tree-and-rename node vars aliases)
  (let ([rlist (map cons vars aliases)])
    (define (rename v rl) (alist-ref v rl eq? v))
    (define (walk n rl)
      (let ([subs (node-subexpressions n)]
	    [params (node-parameters n)]
	    [class (node-class n)] )
	(case class
	  [(##core#variable) (varnode (rename (first params) rl))]
	  [(set!) (make-node 'set! (list (rename (first params) rl)) (map (cut walk <> rl) subs))]
	  [(let) 
	   (let* ([v (first params)]
		  [a (gensym v)]
		  [rl2 (alist-cons v a rl)] )
	     (make-node 'let (list a) (map (cut walk <> rl2) subs)) ) ]
	  [(##core#lambda)
	   (decompose-lambda-list
	    (third params)
	    (lambda (vars argc rest)
	      (let* ([as (map gensym vars)]
		     [rl2 (append as rl)] )
		(make-node 
		 '##core#lambda
		 (list (first params) (second params) 
		       (build-lambda-list as argc (and rest (rename rest rl2)))
		       (fourth params) )
		 (map (cut walk <> rl2) subs) ) ) ) ) ]
	  [else (make-node class (tree-copy params) (map (cut walk <> rl) subs))] ) ) )
    (walk node rlist) ) )

(define (tree-copy t)
  (let rec ([t t])
    (if (pair? t)
	(cons (rec (car t)) (rec (cdr t)))
	t) ) )

(define (copy-node! from to)
  (node-class-set! to (node-class from))
  (node-parameters-set! to (node-parameters from))
  (node-subexpressions-set! to (node-subexpressions from)) 
  (let ([len-from (##sys#size from)]
	[len-to (##sys#size to)] )
    (do ([i 4 (fx+ i 1)])
	((or (fx>= i len-from) (fx>= i len-to)))
      (##sys#setslot to i (##sys#slot from i)) ) ) )


;;; Match node-structure with pattern:

(define (match-node node pat vars)
  (let ((env '()))

    (define (resolve v x)
      (cond ((assq v env) => (lambda (a) (equal? x (cdr a))))
	    ((memq v vars)
	     (set! env (alist-cons v x env))
	     #t)
	    (else (eq? v x)) ) )

    (define (match1 x p)
      (cond ((not-pair? p) (resolve p x))
	    ((not-pair? x) #f)
	    ((match1 (car x) (car p)) (match1 (cdr x) (cdr p)))
	    (else #f) ) )
    
    (define (matchn n p)
      (if (not-pair? p)
	  (resolve p n)
	  (and (eq? (node-class n) (first p))
	       (match1 (node-parameters n) (second p))
	       (let loop ((ns (node-subexpressions n))
			  (ps (cddr p)) )
		 (cond ((null? ps) (null? ns))
		       ((not-pair? ps) (resolve ps ns))
		       ((null? ns) #f)
		       (else (and (matchn (car ns) (car ps))
				  (loop (cdr ns) (cdr ps)) ) ) ) ) ) ) )

    (let ((r (matchn node pat)))
      (and r
	   (begin
	     (debugging 'a "matched" (node-class node) (node-parameters node) pat)
	     env) ) ) ) )


;;; Test nodes for certain properties:

(define (expression-has-side-effects? node db)
  (let walk ([n node])
    (let ([subs (node-subexpressions n)])
      (case (node-class n)
	[(##core#variable quote ##core#undefined ##core#proc ##core#global-ref) #f]
	[(##core#lambda) 
	 (let ([id (first (node-parameters n))])
	   (find (lambda (fs) (eq? id (foreign-callback-stub-id fs))) foreign-callback-stubs) ) ]
	[(if let) (any walk subs)]
	[else #t] ) ) ) )

(define (simple-lambda-node? node)
  (let* ([params (node-parameters node)]
	 [llist (third params)]
	 [k (and (pair? llist) (first llist))] ) ; leaf-routine has no continuation argument
    (and k 
	 (second params)
	 (let rec ([n node])
	   (case (node-class n)
	     [(##core#call)
	      (let* ([subs (node-subexpressions n)]
		     [f (first subs)] )
		(and (eq? '##core#variable (node-class f)) 
		     (eq? k (first (node-parameters f)))
		     (every rec (cdr subs)) ) ) ]
	     [(##core#callunit) #f]
	     [else (every rec (node-subexpressions n))] ) ) ) ) )


;;; Some safety checks and database dumping:

(define (export-dump-hook db file) (void))

(define (dump-exported-globals db file)
  (unless block-compilation
    (with-output-to-file file