optimizer.scm

Scheme跨平台编译器

		(node-subexpressions-set!
		 n
		 (list (second nsubs)
		       (make-node
			'##core#direct_call
			(list #t #f id allocated)
			(cons (car nsubs) (cddr nsubs)) ) ) ) ) )
	    (lset-difference (lambda (s1 s2) (eq? (cdr s1) (cdr s2))) sites ksites) )

	   ;; Hoist direct lambdas out of container:
	   (when (and destn (pair? hoistable))
	     (let ([destn0 (make-node #f #f #f)])
	       (copy-node! destn destn0) ; get copy of container binding
	       (let ([hoisted
		      (fold-right	; build cascade of bindings for each hoistable direct lambda...
		       (lambda (h rest)
			 (make-node
			  'let (list (car h))
			  (let ([dlam (first (node-subexpressions (cdr h)))])
			    (list (make-node (node-class dlam) (node-parameters dlam) (node-subexpressions dlam))
				  rest) ) ) )
		       destn0
		       hoistable) ] )
		 (copy-node! hoisted destn) ; mutate container binding to hold hoistable bindings
		 (for-each 
		  (lambda (h)		; change old direct lambdas bindings to dummy ones...
		    (let ([vn (cdr h)])
		      (node-parameters-set! vn (list (gensym)))
		      (set-car! (node-subexpressions vn) (make-node '##core#undefined '() '())) ) )
		  hoistable) ) ) ) ]
	  [_ (bomb "invalid parameter list" params)] ) ) )

    (debugging 'p "direct leaf routine optimization pass...")
    (walk #f node #f)
    dirty) )


;;; Lambda lift:
;
; - Find lambda-liftable local procedures and lift them to toplevel.
; - Pass free variables as extra parameters, including the free variables of
;   other lifted procedures. This implies that lifted procedures that call each
;   other have to be in the same scope.
; - Declare the lifted procedures (effectively) as bound-to-procedure and block-global.

(define (perform-lambda-lifting! node db)
  (let ([lambda-values '()]
	[eliminated '()] )
    
    (define (find-lifting-candidates)
      ;; Collect potentially liftable procedures and return as a list of (<name> . <value>) pairs:
      ;; - Also build a-list that maps lambda-nodes to names.
      (let ([cs '()])
	(##sys#hash-table-for-each
	 (lambda (sym plist)
	   (and-let* ([val (assq 'value plist)]
		      [refs (assq 'references plist)]
		      [css (assq 'call-sites plist)] 
		      [nrefs (length (cdr refs))] )
	     (when (and (not (assq 'unknown plist))
			(eq? 'lambda (node-class (cdr val)))
			(not (assq 'global plist)) 
			#;(> nrefs 1)
			(= nrefs (length (cdr css))) )
	       (set! lambda-values (alist-cons (cdr val) sym lambda-values))
	       (set! cs (alist-cons sym (cdr val) cs)) ) ) )
	 db)
	cs) )

    (define (build-call-graph cs)
      ;; Build call-graph of the form ((<name> (<free1> ...) <called1> ...) ...):
      (let ([g '()]
	    [free '()]
	    [called '()] )

	(define (walk n env)
	  (let ([class (node-class n)]
		[params (node-parameters n)]
		[subs (node-subexpressions n)] )
	    (case class
	      [(##core#variable set!)
	       (let ([var (first params)])
		 (unless (or (memq var env) (get db var 'global))
		   (set! free (cons var free)) )
		 (when (assq var cs) (set! called (cons var called)))
		 (for-each (lambda (n) (walk n env)) subs) ) ]
	      [(let)
	       (let loop ([vars params] [vals subs])
		 (if (null? vars)
		     (walk (car vals) (append params env))
		     (let ([var (car vars)])
		       (walk (car vals) env)
		       (loop (cdr vars) (cdr vals)) ) ) ) ]
	      [(lambda)
	       (decompose-lambda-list
		(first params)
		(lambda (vars argc rest) (walk (first subs) (append vars env))) ) ]
	      [else (for-each (lambda (n) (walk n env)) subs)] ) ) )

	(for-each
	 (lambda (cs)
	   (let* ([here (car cs)]
		  [lval (cdr cs)] 
		  [llist (car (node-parameters lval))] )
	     (set! free '())
	     (set! called '())
	     (decompose-lambda-list
	      llist
	      (lambda (vars arg rest)
		(walk (car (node-subexpressions lval)) vars) ) )
	     (set! g (alist-cons here (cons free called) g)) ) )
	 cs)
	g) )

    (define (eliminate cs graph)
      ;; Eliminate all liftables that have free variables that are assigned to (and are not liftable),
      ;;  or that have more than N free variables (including free variables of called liftables):
      (remove
       (lambda (gn)
	 (or (> (count-free-variables (car gn) graph) maximal-number-of-free-variables-for-liftable)
	     (any (lambda (v) 
		    (and (get db v 'assigned) 
			 (not (assq v cs)) ) )
		  (second gn) ) ) )
       graph) )

    (define (count-free-variables name graph)
      (let ([gnames (unzip1 graph)])
	(let count ([n name] [walked '()])
	  (let* ([a (assq n graph)]
		 [cs (lset-difference eq? (cddr a) walked gnames)]
		 [f (length (delete-duplicates (second a) eq?))]
		 [w2 (cons n (append cs walked))] )
	    (fold + f (map (lambda (c) (count c w2)) cs)) ) ) ) )

    (define (collect-accessibles graph)
      ;; Collect accessible variables for each liftable into list of the form (<name> <accessible1> ...):
      (let ([al '()])
	(let walk ([n node] [vars '()])
	  (let ([class (node-class n)]
		[params (node-parameters n)]
		[subs (node-subexpressions n)] )
	    (case class
	      [(##core#variable quote ##core#undefined ##core#primitive ##core#proc) #f]
	      [(let)
	       (let loop ([vars2 params] [vals subs])
		 (if (null? vars2)
		     (walk (car vals) (append params vars))
		     (begin
		       (walk (car vals) vars)
		       (loop (cdr vars2) (cdr vals)) ) ) ) ]
	      [(lambda)
	       (let ([lval (assq n lambda-values)])
		 (when lval
		   (let ([name (cdr lval)])
		     (when (assq name graph)
		       (set! al (alist-cons (cdr lval) vars al))) ) ) )
	       (decompose-lambda-list
		(first params)
		(lambda (vars2 argc rest)
		  (walk (car subs) (append vars2 vars)) ) ) ]
	      [else
	       (for-each (lambda (n) (walk n vars)) subs) ] ) ) )
	al) )

    (define (eliminate2 graph al)
      ;; Eliminate liftables that have call-sites without access to all free variables;
      (remove
       (lambda (gn)
	 (let* ([name (first gn)]
		[free (second gn)] )
	   (any (lambda (gn2)
		  (and (memq name (cddr gn2)) ; callee?
		       (lset<= eq? (cdr (assq (car gn2) al)) free) ) )
		graph) ) ) 
       graph) )

    (define (eliminate3 graph)
      ;; Eliminate liftables that call other eliminated liftables:
      ;; - repeat until nothing changes.
      (let loop ([graph graph] [n (length graph)])
	(let* ([g2 (filter (lambda (gn) (every (lambda (n) (assq n graph)) (cddr gn))) graph)]
	       [n2 (length g2)] )
	  (if (= n n2)
	      g2
	      (loop g2 n2) ) ) ) )

    (define (eliminate4 graph)
      ;; Eliminate liftables that have unknown call-sites which do not have access to
      ;;  any of the free variables of all callees:
      (let walk ([n node] [vars '()])
	(let ([class (node-class n)]
	      [params (node-parameters n)]
	      [subs (node-subexpressions n)] )
	  (case class
	    [(##core#variable quote ##core#undefined ##core#primitive ##core#proc) #f]
	    [(let)
	     (let loop ([vars2 params] [vals subs])
	       (if (null? vars2)
		   (walk (car vals) (append params vars))
		   (begin
		     (walk (car vals) vars)
		     (loop (cdr vars2) (cdr vals)) ) ) ) ]
	    [(lambda)
	     (decompose-lambda-list
	      (first params)
	      (lambda (vars2 argc rest)
		(walk (car subs) (append vars2 vars)) ) ) ]
	    [(##core#call)
	     (let ([fn (first subs)])
	       (call-with-current-continuation
		(lambda (return)
		  (when (eq? '##core#variable (node-class fn))
		    (let ([done '()])
		      (let loop ([name (first (node-parameters fn))])
			(unless (memq name done)
			  (set! done (cons name done))
			  (let ([gn (assq name graph)])
			    (when gn
			      (unless (lset<= eq? (second gn) vars)
				#;(print "*** " (first (node-parameters fn)) " | " name ": " vars " / " (second gn)) 
				(set! graph (delete! gn graph eq?))
				(return #f) )
			      (for-each loop (cddr gn)) ) ) ) ) ) ) ) )
	       (for-each (lambda (n) (walk n vars)) subs) ) ]
	    [else (for-each (lambda (n) (walk n vars)) subs)] ) ) )
      graph)

    (define (compute-extra-variables graph)
      ;; Gather variables that have to be passed additionally:
      ;; - do not pass variables that are defined inside the body of a liftable.
      (define (defined n)
	(let ([defd '()])
	  (let walk ([n n])
	    (let ([class (node-class n)]
		  [params (node-parameters n)]
		  [subs (node-subexpressions n)] )
	      (case class
		[(let)
		 (set! defd (append params defd))
		 (for-each walk subs) ]
		[(lambda)
		 (decompose-lambda-list
		  (first params)
		  (lambda (vars argc rest)
		    (set! defd (append vars defd))
		    (walk (first subs)) ) ) ]
		[else (for-each walk subs)] ) ) )
	  defd) )
      (let ([extras (map (lambda (gn) (cons (first gn) (second gn))) graph)]
	    [walked '()] )
	(define (walk gn)
	  (let ([name (car gn)])
	    ;; Hm. To handle liftables that are called recursively (but indirect) I use this kludge. Is it safe?
	    (unless (> (count (cut eq? name <>) walked) 1)
	      (set! walked (cons name walked))
	      (let ([callees (cddr gn)])
		(for-each (lambda (c) (walk (assq c graph))) callees)
		(let ([f (assq name extras)])
		  (set-cdr! f (append (cdr f) (concatenate (map (lambda (n2) (cdr (assq n2 extras))) callees)))) ) ) ) ) )
	(for-each walk graph)
	(map (lambda (xt)
	       (let* ([name (car xt)]
		      [defd (defined (get db name 'value))] )
		 (cons name
		       (remove 
			(lambda (v)
			  (or (assq v graph)
			      (memq v defd) ) )
			(delete-duplicates (cdr xt) eq?)) ) ) )
	     extras) ) )

    (define (reconstruct! graph extra)
      ;; Reconstruct node tree by adding global definitions:
      (node-subexpressions-set!
       node
       (list
	(fold-right
	 (lambda (gn body)
	   (let* ([name (car gn)]
		  [lval (get db name 'value)] )
	     (set! block-globals (cons name block-globals))
	     (decompose-lambda-list
	      (first (node-parameters lval))
	      (lambda (vars argc rest)
		(let* ([xvars (cdr (assq name extra))]
		       [xaliases (map gensym xvars)]
		       [xmap (map cons xvars xaliases)] )
		  (rename-extra-variables! (first (node-subexpressions lval)) xmap)
		  (make-node
		   'let (list (gensym 't))
		   (list (make-node
			  'set! (list name)
			  (list
			   (make-node
			    'lambda
			    (list (build-lambda-list (append xaliases vars) (+ argc (length xvars)) rest))
			    (node-subexpressions lval) ) ) )
			 body) ) ) ) ) ) )
	 (first (node-subexpressions node))
	 graph) ) ) )

    (define (rename-extra-variables! node xmap)
      ;; Rename variables from a given map:
      (define (rename v)
	(let ([a (assq v xmap)])
	  (if a (cdr a) v) ) )
      (let walk ([n node])
	(let ([class (node-class n)]
	      [params (node-parameters n)]
	      [subs (node-subexpressions n)] )
	  (case class
	    [(let)
	     (node-parameters-set! n (map rename params))
	     (for-each walk subs) ]
	    [(##core#variable)
	     (node-parameters-set! n (list (rename (first params)))) ]
	    [(set!)
	     (node-parameters-set! n (list (rename (first params))))
	     (for-each walk subs) ]
	    [(lambda)
	     (decompose-lambda-list
	      (first params)
	      (lambda (vars argc rest)
		(set-car! params (build-lambda-list (map rename vars) argc rest)) 
		(walk (first subs)) ) ) ]
	    [else (for-each walk subs)] ) ) ) )

    (define (extend-call-sites! extra)
      ;; Change call sites by adding extra variables:
      (let walk ([n node])
	(let ([class (node-class n)]
	      [params (node-parameters n)]
	      [subs (node-subexpressions n)] )
	  (case class
	    [(##core#call)
	     (let ([fn (first subs)])
	       (when (eq? '##core#variable (node-class fn))
		 (let ([a (assq (first (node-parameters fn)) extra)])
		   (when a
		     (set-car! params #t)
		     (node-subexpressions-set! 
		      n
		      (cons fn (append (map varnode (cdr a)) (cdr subs))) ) ) ) )
	       (for-each walk (node-subexpressions n)) ) ]
	    [else (for-each walk subs)] ) ) ) )

    (define (remove-local-bindings! graph)
      ;; Remove local definitions of lifted procedures:
      (let walk ([n node])
	(let ([class (node-class n)]
	      [params (node-parameters n)]
	      [subs (node-subexpressions n)] )
	  (case class
	    [(let)
	     (for-each walk (node-subexpressions n))
	     (let ([vars2 '()]
		   [vals2 '()] )
	       (do ([vars params (cdr vars)]