optimizer.scm

Scheme跨平台编译器

	    (make-node
	     '##core#call '(#t)
	     (list cont 
		   (make-node
		    '##core#inline_allocate
		    (list (second classargs) 
			  (cond [(eq? #t w) (add1 rargc)]
				[(pair? w) (* rargc (car w))]
				[else w] ) )
		    callargs) ) ) ) ) )

    ;; (<op> ...) -> (##core#inline <iop>/<unsafe-iop> ...)
    ((17) ; classargs = (<argc> <iop-safe> [<iop-unsafe>])
     (and inline-substitutions-enabled
	  (= (length callargs) (first classargs))
	  (or (test name 'extended-binding) (test name 'standard-binding))
	  (make-node
	   '##core#call '(#t)
	   (list cont
		 (make-node '##core#inline
			    (list (if (and unsafe (pair? (cddr classargs)))
				      (third classargs)
				      (second classargs) ) )
			    callargs)) ) ) )

    ;; (<op>) -> (quote <null>)
    ((18) ; classargs = (<null>)
     (and inline-substitutions-enabled
	  (null? callargs)
	  (or (test name 'extended-binding) (test name 'standard-binding))
	  (make-node '##core#call '(#t) (list cont (qnode (first classargs))) ) ) )

    ;; (<op>) -> <id>
    ;; (<op> <x>) -> <x>
    ;; (<op> <x1> ...) -> (##core#inline <fixop> <x1> (##core#inline <fixop> ...)) [fixnum-mode]
    ;; (<op> <x1> ...) -> (##core#inline <ufixop> <x1> (##core#inline <ufixop> ...)) [fixnum-mode + unsafe]
    ;; - Remove "<id>" from arguments.
    ((19) ; classargs = (<id> <fixop> <ufixop> <fixmode>)
     (and inline-substitutions-enabled
	  (or (test name 'standard-binding) (test name 'extended-binding))
	  (let* ([id (first classargs)]
		 [fixop (if unsafe (third classargs) (second classargs))]
		 [callargs 
		  (remove
		   (lambda (x)
		     (and (eq? 'quote (node-class x))
			  (eq? id (first (node-parameters x))) ) ) 
		   callargs) ] )
	    (cond [(null? callargs) (make-node '##core#call '(#t) (list cont (qnode id)))]
		  [(null? (cdr callargs))
		   (make-node '##core#call '(#t) (list cont (first callargs))) ]
		  [(or (fourth classargs) (eq? number-type 'fixnum))
		   (make-node
		    '##core#call '(#t)
		    (list
		     cont
		     (fold-inner
		      (lambda (x y)
			(make-node '##core#inline (list fixop) (list x y)) )
		      callargs) ) ) ]
		  [else #f] ) ) ) )

    ;; (<op> ...) -> (##core#inline <iop> <arg1> ... (quote <x>) <argN>)
    ((20) ; classargs = (<argc> <iop> <x> <safe>)
     (let ([n (length callargs)])
       (and (or (fourth classargs) unsafe)
	    inline-substitutions-enabled
	    (= n (first classargs))
	    (or (test name 'standard-binding) (test name 'extended-binding))
	    (make-node
	     '##core#call '(#t)
	     (list cont
		   (make-node 
		    '##core#inline (list (second classargs))
		    (let-values ([(head tail) (split-at callargs (sub1 n))])
		      (append head
			      (list (qnode (third classargs)))
			      tail) ) ) ) ) ) ) )

    ;; (<op>) -> <id>
    ;; (<op> <x>) -> <x>
    ;; (<op> <x1> ...) -> (##core#inline_allocate (<genop> <words>) <x1> (##core#inline_allocate (<genop> <words>) ...))
    ;; (<op> <x1> ...) -> (##core#inline <[u]fixop> <x1> (##core#inline <[u]fixop> ...)) [fixnum-mode (perhaps unsafe)]
    ;; - Remove "<id>" from arguments.
    ((21) ; classargs = (<id> <fixop> <ufixop> <genop> <words>)
     (and inline-substitutions-enabled
	  (or (test name 'standard-binding) (test name 'extended-binding))
	  (let* ([id (first classargs)]
		 [words (fifth classargs)]
		 [genop (fourth classargs)]
		 [fixop (if unsafe (third classargs) (second classargs))]
		 [callargs 
		  (remove
		   (lambda (x)
		     (and (eq? 'quote (node-class x))
			  (eq? id (first (node-parameters x))) ) ) 
		   callargs) ] )
	    (cond [(null? callargs) (make-node '##core#call '(#t) (list cont (qnode id)))]
		  [(null? (cdr callargs))
		   (make-node '##core#call '(#t) (list cont (first callargs))) ]
		  [else
		   (make-node
		    '##core#call '(#t)
		    (list
		     cont
		     (fold-inner
		      (lambda (x y)
			(if (eq? number-type 'fixnum)
			    (make-node '##core#inline (list fixop) (list x y))
			    (make-node '##core#inline_allocate (list genop words) (list x y)) ) )
		      callargs) ) ) ] ) ) ) )

    ;; (<alloc-op> ...) -> (##core#inline_allocate (<aiop> <words>) ...)
    ;; (<alloc-op> ...) -> (##core#inline <fxop> ...) [fixnum mode]
    ((22) ; classargs = (<argc> <aiop> <safe> <words> <fxop>)
     (let ([argc (first classargs)]
	   [rargc (length callargs)]
	   [w (fourth classargs)] )
       (and inline-substitutions-enabled
	    (= rargc argc)
	    (or (test name 'extended-binding) (test name 'standard-binding))
	    (or (third classargs) unsafe)
	    (make-node
	     '##core#call '(#t)
	     (list cont 
		   (if (eq? number-type 'fixnum)
		       (make-node
			'##core#inline
			(list (fifth classargs))
			callargs)
		       (make-node
			'##core#inline_allocate
			(list (second classargs) w)
			callargs) ) ) ) ) ) )

    ;; (<op> <arg1> ... <argN>) -> (<primitiveop> ...)
    ;; (<op> <arg1> ... <argN-I> <defargN-I>) -> (<primitiveop> ...)
    ;; - default args in classargs should be either symbol or (optionally) 
    ;;   quoted literal
    ((23) ; classargs = (<minargc> <primitiveop> <literal1>|<varable1> ...)
     (and inline-substitutions-enabled
	  (or (test name 'standard-binding) (test name 'extended-binding))
	  (let ([argc (first classargs)])
	    (and (>= (length callargs) (first classargs))
		 (make-node 
		  '##core#call (list #t (second classargs))
		  (cons*
		   (varnode (second classargs))
		   cont
		   (let-values (((req opt) (split-at callargs argc)))
		     (append
		      req
		      (let loop ((ca opt) 
				 (da (cddr classargs)) )
			(cond ((null? ca)
			       (if (null? da)
				   '()
				   (cons (defarg (car da)) (loop '() (cdr da))) ) )
			      ((null? da) '())
			      (else (cons (car ca) (loop (cdr ca) (cdr da))))))))))))))

    (else (bomb "bad type (optimize)")) ) )


;;; Optimize direct leaf routines:

(define (transform-direct-lambdas! node db)
  (let ([dirty #f]
	[inner-ks '()] 
	[hoistable '()] 
	[allocated 0] )

    ;; Process node tree and walk lambdas that meet the following constraints:
    ;;  - Only external lambdas (no CPS redexes),
    ;;  - All calls are either to the direct continuation or (tail-) recursive calls.
    ;;  - No allocation, no rest parameter.
    ;;  - The lambda has a known container variable and all it's call-sites are known.

    (define (walk d n dn)
      (let ([params (node-parameters n)]
	    [subs (node-subexpressions n)] )
	(case (node-class n)
	  [(##core#lambda)
	   (let ([llist (third params)])
	     (if (and d
		      (second params)
		      (not (get db d 'unknown))
		      (proper-list? llist)
		      (and-let* ([val (get db d 'value)]
				 [refs (get db d 'references)]
				 [sites (get db d 'call-sites)] )
			(and (eq? n val)
			     (= (length refs) (length sites))
			     (scan (first subs) (first llist) d dn (cons d llist)) ) ) )
		 (transform n d inner-ks hoistable dn allocated) 
		 (walk #f (first subs) #f) ) ) ]
	  [(set!) (walk (first params) (first subs) #f)]
	  [(let)
	   (walk (first params) (first subs) n)
	   (walk #f (second subs) #f) ]
	  [else (for-each (lambda (x) (walk #f x #f)) subs)] ) ) )

    (define (scan n kvar fnvar destn env)
      (let ([closures '()]
	    [recursive #f] )
	(define (rec n v vn e)
	  (let ([params (node-parameters n)]
		[subs (node-subexpressions n)] )
	    (case (node-class n)
	      [(##core#variable)
	       (let ([v (first params)])
		 (or (not (get db v 'boxed))
		     (not (memq v env))
		     (and (not recursive)
			  (begin
			    (set! allocated (+ allocated 2))
			    #t) ) ) ) ]
	      [(##core#lambda)
	       (and v
		    (decompose-lambda-list
		     (third params)
		     (lambda (vars argc rest)
		       (set! closures (cons v closures))
		       (rec (first subs) #f #f (append vars e)) ) ) ) ]
	      [(##core#inline_allocate)
	       (and (not recursive)
		    (begin
		      (set! allocated (+ allocated (second params)))
		      (every (lambda (x) (rec x #f #f e)) subs) ) ) ]
	      [(##core#direct_lambda)
	       (and vn destn
		    (null? (scan-used-variables (first subs) e)) 
		    (begin
		      (set! hoistable (alist-cons v vn hoistable))
		      #t) ) ]
	      [(##core#inline_ref)
	       (and (let ([n (estimate-foreign-result-size (second params))])
		      (or (zero? n)
			  (and (not recursive)
			       (begin
				 (set! allocated (+ allocated n))
				 #t) ) ) )
		    (every (lambda (x) (rec x #f #f e)) subs) ) ]
	      [(##core#inline_loc_ref)
	       (and (let ([n (estimate-foreign-result-size (first params))])
		      (or (zero? n)
			  (and (not recursive)
			       (begin
				 (set! allocated (+ allocated n))
				 #t) ) ) )
		    (every (lambda (x) (rec x #f #f e)) subs) ) ]
	      [(##core#call)
	       (let ([fn (first subs)])
		 (and (eq? '##core#variable (node-class fn))
		      (let ([v (first (node-parameters fn))])
			(cond [(eq? v fnvar)
			       (and (zero? allocated)
				    (let ([k (second subs)])
				      (when (eq? '##core#variable (node-class k))
					(set! inner-ks (cons (first (node-parameters k)) inner-ks)) )
				      (set! recursive #t)
				      #t) ) ]
			      [else (eq? v kvar)] ) )
		      (every (lambda (x) (rec x #f #f e)) (cdr subs)) ) ) ]
	      [(##core#direct_call)
	       (let ([n (fourth params)])
		 (or (zero? n)
		     (and (not recursive)
			  (begin
			    (set! allocated (+ allocated n))
			    (every (lambda (x) (rec x #f #f e)) subs) ) ) ) ) ]
	      [(set!) (rec (first subs) (first params) #f e)]
	      [(let)
	       (and (rec (first subs) (first params) n e)
		    (rec (second subs) #f #f (append params e)) ) ]
	      [else (every (lambda (x) (rec x #f #f e)) subs)] ) ) )
	(set! inner-ks '())
	(set! hoistable '())
	(set! allocated 0)
	(and (rec n #f #f env)
	     (lset= eq? closures (delete kvar inner-ks eq?)) ) ) )

    (define (transform n fnvar ks hoistable destn allocated)
      (if (pair? hoistable)
	  (debugging 'o "direct leaf routine with hoistable closures/allocation" fnvar (delay (unzip1 hoistable)) allocated)
	  (debugging 'o "direct leaf routine/allocation" fnvar allocated) )
      (set! dirty #t)
      (let* ([params (node-parameters n)]
	     [argc (length (third params))]
	     [klambdas '()] 
	     [sites (get db fnvar 'call-sites)] 
	     [ksites '()] )
	(match params
	  [(id _ (kvar vars ...) _)
	   ;; Remove continuation argument:
	   (set-car! (cddr params) vars)
	   ;; Make "##core#direct_lambda":
	   (node-class-set! n '##core#direct_lambda)
	   ;; Transform recursive calls and remove unused continuations:

	   (let rec ([n (first (node-subexpressions n))])
	     (let ([params (node-parameters n)]
		   [subs (node-subexpressions n)] )
	       (case (node-class n)
		 [(##core#call)
		  (let* ([fn (first subs)]
			 [arg0 (second subs)]
			 [fnp (node-parameters fn)] 
			 [arg0p (node-parameters arg0)] )
		    (when (eq? '##core#variable (node-class fn))
		      (cond [(eq? fnvar (first fnp))
			     (set! ksites (alist-cons #f n ksites))
			     (cond [(eq? kvar (first arg0p))
				    (unless (= argc (length (cdr subs)))
				      (quit
				       "known procedure called recursively with wrong number of arguments: `~A'" 
				       fnvar) )
				    (node-class-set! n '##core#recurse)
				    (node-parameters-set! n (list #t id))
				    (node-subexpressions-set! n (cddr subs)) ]
				   [(assq (first arg0p) klambdas)
				    => (lambda (a)
					 (let* ([klam (cdr a)]
						[kbody (first (node-subexpressions klam))] )
					   (unless (= argc (length (cdr subs)))
					     (quit
					      "known procedure called recursively with wrong number of arguments: `~A'" 
					      fnvar) )
					   (node-class-set! n 'let)
					   (node-parameters-set! n (take (third (node-parameters klam)) 1))
					   (node-subexpressions-set!
					    n
					    (list (make-node '##core#recurse (list #f id) (cddr subs)) kbody) )
					   (rec kbody) ) ) ]
				   [else (bomb "missing kvar" arg0p)] ) ]
			    [(eq? kvar (first fnp))
			     (node-class-set! n '##core#return)
			     (node-parameters-set! n '())
			     (node-subexpressions-set! n (cdr subs)) ]
			    [else (bomb "bad call (leaf)")] ) ) ) ]
		 [(let)
		  (let ([var (first params)]
			[val (first subs)] )
		    (cond [(memq var ks)
			   (set! klambdas (alist-cons var val klambdas))
			   (copy-node! (second subs) n)
			   (rec n) ]
			  [else (for-each rec subs)] ) ) ]

		 [else (for-each rec subs)] ) ) )

	   ;; Transform call-sites:
	   (for-each
	    (lambda (site)
	      (let* ([n (cdr site)]
		     [nsubs (node-subexpressions n)] )
		(unless (= argc (length (cdr nsubs)))
		  (quit
		   "known procedure called with wrong number of arguments: `~A'"
		   fnvar) )