optimizer.scm

Scheme跨平台编译器

					     (walk-generic n class params subs)
					     (begin
					       (debugging 'o "consed rest parameter at call site" var n)
					       (let-values ([(args rargs) (split-at args n)])
						 (let ([n2 (make-node
							    '##core#call
							    params
							    (map walk
								 (cons fun
								       (append 
									args
									(list
									 (if (null? rargs)
									     (qnode '())
									     (make-node
									      '##core#inline_allocate 
									      (list "C_a_i_list" (* 3 (length rargs)))
									      rargs) ) ) ) ) ) ) ] )
						   (set! rest-consers (cons n2 rest-consers))
						   n2) ) ) ) ) ]
				      [else (walk-generic n class params subs)] ) ) ) ) ) ]
			[else (walk-generic n class params subs)] ) ) ]
	       [(##core#lambda)
		(if (first params)
		    (walk-generic n class params subs)
		    (make-node '##core#call (cons #t (cdr params)) (map walk subs)) ) ]
	       [else (walk-generic n class params subs)] ) ) )

	  ((set!)
	   (let ([var (first params)])
	     (cond [(or (test var 'contractable) (test var 'replacable))
		    (touch)
		    (make-node '##core#undefined '() '()) ]
		   [(and (or (not (test var 'global))
			     block-compilation
			     (and export-list (not (memq var export-list))) )
			 (not (test var 'references)) 
			 (not (expression-has-side-effects? (first subs) db)) )
		    (touch)
		    (debugging 'o "removed side-effect free assignment to unused variable" var)
		    (make-node '##core#undefined '() '()) ]
		   [else (make-node 'set! params (list (walk (car subs))))] ) ) )

	  (else (walk-generic n class params subs)) ) ) )
    
    (define (walk-generic n class params subs)
      (let ((subs2 (map walk subs)))
	(if (every eq? subs subs2)
	    n
	    (make-node class params subs2) ) ) )

    (if (perform-pre-optimization! node db)
	(values node #t)
	(begin
	  (debugging 'p "traversal phase...")
	  (set! simplified-ops '())
	  (let ((node2 (walk node)))
	    (when (pair? simplified-classes) (debugging 'o "simplifications" simplified-classes))
	    (when (and (pair? simplified-ops) (debugging 'o "  call simplifications:"))
	      (for-each
	       (lambda (p)
		 (print* #\tab (car p))
		 (if (> (cdr p) 1)
		     (print #\tab (cdr p))
		     (newline) ) )
	       simplified-ops) )
	    (when (> replaced-vars 0) (debugging 'o "replaced variables" replaced-vars))
	    (when (> removed-lets 0) (debugging 'o "removed binding forms" removed-lets))
	    (when (> removed-ifs 0) (debugging 'o "removed conditional forms" removed-ifs))
	    (values node2 dirty) ) ) ) ) )


;;; Pre-optimization phase:
;
; - Transform expressions of the form '(if (not <x>) <y> <z>)' into '(if <x> <z> <y>)'.
; - Transform expressions of the form '(if (<x> <y> ...) <z> <q>)' into '<z>' if <x> names a
;   standard-binding that is never #f and if it's arguments are free of side-effects.

(define (perform-pre-optimization! node db)
  (let ((dirty #f)
	(removed-nots 0) )

    (define (touch) (set! dirty #t) #t)
    (define (test sym prop) (get db sym prop))

    (debugging 'p "pre-optimization phase...")

    ;; Handle '(if (not ...) ...)':
    (if (test 'not 'standard-binding)
	(for-each 
	 (lambda (site)
	   (let* ((n (cdr site))
		  (subs (node-subexpressions n))
		  (kont (first (node-parameters (second subs))))
		  (lnode (and (not (test kont 'unknown)) (test kont 'value)))
		  (krefs (test kont 'references)) )
	     ;; Call-site has one argument and a known continuation (which is a ##core#lambda)
	     ;;  that has only one use:
	     (if (and lnode krefs (= 1 (length krefs)) (= 3 (length subs))
		      (eq? '##core#lambda (node-class lnode)) )
		 (let* ((llist (third (node-parameters lnode)))
			(body (first (node-subexpressions lnode))) 
			(bodysubs (node-subexpressions body)) )
		   ;; Continuation has one parameter?
		   (if (and (proper-list? llist) (null? (cdr llist)))
		       (let* ((var (car llist))
			      (refs (test var 'references)) )
			 ;; Parameter is only used once?
			 (if (and refs (= 1 (length refs)) (eq? 'if (node-class body)))
			     ;; Continuation contains an 'if' node?
			     (let ((iftest (first (node-subexpressions body))))
			       ;; Parameter is used only once and is the test-argument?
			       (if (and (eq? '##core#variable (node-class iftest))
					(eq? var (first (node-parameters iftest))) )
				   ;; Modify call-site to call continuation directly and swap branches
				   ;;  in the conditional:
				   (begin
				     (set! removed-nots (+ removed-nots 1))
				     (node-parameters-set! n '(#t))
				     (node-subexpressions-set! n (cdr subs))
				     (node-subexpressions-set! 
				      body
				      (cons (car bodysubs) (reverse (cdr bodysubs))) )
				     (touch) ) ) ) ) ) ) ) ) ) )
	 (or (test 'not 'call-sites) '()) ) )
    
    ;; Handle '(if (<func> <a> ...) ...)', where <func> never returns false:
    (for-each
     (lambda (varname)
       (if (test varname 'standard-binding)
	   (for-each
	    (lambda (site)
	      (let* ((n (cdr site))
		     (subs (node-subexpressions n))
		     (kont (first (node-parameters (second subs)))) 
		     (krefs (test kont 'references)) 
		     (lnode (and (not (test kont 'unknown)) (test kont 'value))) )
		;; Call-site has side-effect-free arguments and a known continuation that has only one use?
		(if (and lnode
			 (eq? '##core#lambda (node-class lnode))
			 krefs (= 1 (length krefs))
			 (not (any (lambda (sn) (expression-has-side-effects? sn db)) (cddr subs))) )
		    (let* ((llist (third (node-parameters lnode)))
			   (body (first (node-subexpressions lnode))) )
		      ;; Continuation has one parameter and contains an 'if' node?
		      (if (and (proper-list? llist)
			       (null? (cdr llist))
			       (eq? 'if (node-class body)) )
			  (let* ((var (car llist))
				 (refs (test var 'references)) 
				 (iftest (first (node-subexpressions body))) )
			    ;; Parameter is used only once and is the test-argument?
			    (if (and refs (= 1 (length refs))
				     (eq? '##core#variable (node-class iftest))
				     (eq? var (first (node-parameters iftest))) )
				(let ((bodysubs (node-subexpressions body)))
				  ;; Modify call-site to call continuation directly and swap branches
				  ;;  in the conditional:
				  (debugging 'o "removed call in test-context" varname)
				  (node-parameters-set! n '(#t))
				  (node-subexpressions-set! n (list (second subs) (qnode #t)))
				  (touch) ) ) ) ) ) ) ) )
	    (or (test varname 'call-sites) '()) ) ) )
     side-effect-free-standard-bindings-that-never-return-false)

    (when (> removed-nots 0) (debugging 'o "Removed `not' forms" removed-nots))
    dirty) )


;;; Simplifications:

(define (register-simplifications class . ss)
  (##sys#hash-table-set! simplifications class ss) )


(register-simplifications
 '##core#call
 ;; (<named-call> ...) -> (<primitive-call/inline> ...)
 `((##core#call d (##core#variable (a)) b . c)
   (a b c d)
   ,(lambda (db a b c d)
      (let loop ((entries (or (##sys#hash-table-ref substitution-table a) '())))
	(cond ((null? entries) #f)
	      ((simplify-named-call db d a b (caar entries) (cdar entries) c)
	       => (lambda (r)
		    (let ((as (assq a simplified-ops)))
		      (if as 
			  (set-cdr! as (add1 (cdr as)))
			  (set! simplified-ops (alist-cons a 1 simplified-ops)) ) )
		    r) )
	      (else (loop (cdr entries))) ) ) ) ) )


(register-simplifications
 'let

 ;; (let ((<var1> (##core#inline <eq-inline-operator> <var0> <const1>)))
 ;;   (if <var1> <body1>
 ;;       (let ((<var2> (##core#inline <eq-inline-operator> <var0> <const2>)))
 ;;         (if <var2> <body2>
 ;;             <etc.>
 ;; -> (##core#switch (2) <var0> <const1> <body1> <const2> <body2> <etc.>)
 ;; - <var1> and <var2> have to be referenced once only.
 `((let (var1) (##core#inline (op) (##core#variable (var0)) (quote (const1)))
	(if d1 (##core#variable (var1))
	    body1
	    (let (var2) (##core#inline (op) (##core#variable (var0)) (quote (const2)))
		 (if d2 (##core#variable (var2))
		     body2
		     rest) ) ) )
   (var0 var1 var2 op const1 const2 body1 body2 d1 d2 rest)
   ,(lambda (db var0 var1 var2 op const1 const2 body1 body2 d1 d2 rest)
      (and (equal? op eq-inline-operator)
	   (immediate? const1)
	   (immediate? const2)
	   (= 1 (length (get db var1 'references)))
	   (= 1 (length (get db var2 'references)))
	   (make-node
	    '##core#switch
	    '(2)
	    (list (varnode var0)
		  (qnode const1)
		  body1
		  (qnode const2)
		  body2
		  rest) ) ) ) )

 ;; (let ((<var> (##core#inline <eq-inline-operator> <var0> <const>)))
 ;;   (if <var>
 ;;       <body>
 ;;       (##core#switch <n> <var0> <const1> <body1> ... <rest>) ) )
 ;; -> (##core#switch <n+1> <var0> <const> <body> <const1> <body1> ... <rest>)
 ;; - <var> has to be referenced once only.
 `((let (var) (##core#inline (op) (##core#variable (var0)) (quote (const)))
	(if d (##core#variable (var))
	    body
	    (##core#switch (n) (##core#variable (var0)) . clauses) ) )
   (var op var0 const d body n clauses)
   ,(lambda (db var op var0 const d body n clauses)
      (and (equal? op eq-inline-operator)
	   (immediate? const)
	   (= 1 (length (get db var 'references)))
	   (make-node
	    '##core#switch
	    (list (add1 n))
	    (cons* (varnode var0)
		   (qnode const)
		   body
		   clauses) ) ) ) )
	      
 ;; (let ((<var1> (##core#undefined)))
 ;;   (let ((<var2> (##core#undefined)))
 ;;     ...
 ;;     (let ((<tmp1> (set! <var1> <x1>))
 ;;       (let ((<tmp2> (set! <var2> <x2>)))
 ;;         ...
 ;;         <body>) ... )
 ;; -> <a simpler sequence of let's>
 ;; - <tmpI> may not be used.
 `((let (var1) (##core#undefined ())
	more)
   (var1 more)
   ,(lambda (db var1 more)
      (let loop1 ([vars (list var1)] 
		  [body more] )
	(let ([c (node-class body)]
	      [params (node-parameters body)] 
	      [subs (node-subexpressions body)] )
	  (and (eq? c 'let)
	       (null? (cdr params))
	       (let* ([val (first subs)]
		      [valparams (node-parameters val)]
		      [valsubs (node-subexpressions val)] )
		 (case (node-class val)
		   [(##core#undefined) (loop1 (cons (first params) vars) (second subs))]
		   [(set!)
		    (let ([allvars (reverse vars)])
		      (and (pair? allvars)
			   (eq? (first valparams) (first allvars))
			   (let loop2 ([vals (list (first valsubs))]
				       [vars (cdr allvars)] 
				       [body (second subs)] )
			     (let ([c (node-class body)]
				   [params (node-parameters body)]
				   [subs (node-subexpressions body)] )
			       (cond [(and (eq? c 'let)
					   (null? (cdr params))
					   (not (get db (first params) 'references))
					   (pair? vars)
					   (eq? 'set! (node-class (first subs)))
					   (eq? (car vars) (first (node-parameters (first subs)))) )
				      (loop2 (cons (first (node-subexpressions (first subs))) vals)
					     (cdr vars)
					     (second subs) ) ]
				     [(null? vars)
				      (receive (n progress) 
					  (reorganize-recursive-bindings allvars (reverse vals) body) 
					(and progress n) ) ]
				     [else #f] ) ) ) ) ) ]
		   [else #f] ) ) ) ) ) ) )

 ;; (let ((<var1> <var2>))
 ;;   (<var1> ...) )
 ;; -> (<var2> ...)
 ;; - <var1> used only once
 #| this doesn't seem to work (Sven Hartrumpf):
 `((let (var1) (##core#variable (var2))
	(##core#call p (##core#variable (var1)) . more) ) ; `p' was `#t', bombed also
   (var1 var2 p more)
   ,(lambda (db var1 var2 p more)
      (and (= 1 (length (get db var1 'references)))
	   (make-node
	    '##core#call p
	    (cons (varnode var2) more) ) ) ) )
 |#

 ;; (let ((<var> (##core#inline <op> ...)))
 ;;   (if <var> <x> <y>) )
 ;; -> (if (##core#inline <op> ...) <x> <y>)
 ;; - <op> may not be the eq-inline operator (so rewriting to "##core#switch" works).
 ;; - <var> has to be referenced only once.
 `((let (var) (##core#inline (op) . args)
	(if d (##core#variable (var))
	    x
	    y) ) 
   (var op args d x y)
   ,(lambda (db var op args d x y)
      (and (not (equal? op eq-inline-operator))
	   (= 1 (length (get db var 'references)))
	   (make-node
	    'if d
	    (list (make-node '##core#inline (list op) args)
		  x y) ) ) ) ) )


(register-simplifications
 'if

 ;; (if <x>
 ;;     (<var> <y>)
 ;;     (<var> <z>) )
 ;; -> (<var> (##core#cond <x> <y> <z>))
 ;; - inline-substitutions have to be enabled (so IF optimizations have already taken place).
 `((if d1 x
       (##core#call d2 (##core#variable (var)) y)
       (##core#call d3 (##core#variable (var)) z) )
   (d1 d2 d3 x y z var)
   ,(lambda (db d1 d2 d3 x y z var)
      (and inline-substitutions-enabled
	   (make-node
	    '##core#call d2
	    (list (varnode var)
		  (make-node '##core#cond '() (list x y z)) ) ) ) ) )

 ;; (if (##core#inline <memXXX> <x> '(<c1> ...)) ...)
 ;; -> (let ((<var> <x>))
 ;;      (if (##core#cond (##core#inline XXX? <var> '<c1>) #t ...) ...)
 ;; - there is a limit on the number of items in the list of constants.
 `((if d1 (##core#inline (op) x (quote (clist)))
       y