optimizer.scm

Scheme跨平台编译器

;;;; optimizer.scm - The CHICKEN Scheme compiler (optimizations)
;
; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008, The Chicken Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


(declare (unit optimizer))

(private compiler
  compiler-arguments process-command-line perform-lambda-lifting!
  default-standard-bindings default-extended-bindings side-effecting-standard-bindings
  non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings
  standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false
  installation-home decompose-lambda-list external-to-pointer
  copy-node! export-list inline-list not-inline-list
  unit-name insert-timer-checks used-units external-variables
  debug-info-index debug-info-vector-name profile-info-vector-name
  foreign-declarations emit-trace-info block-compilation line-number-database-size
  always-bound-to-procedure block-globals make-block-variable-literal block-variable-literal? block-variable-literal-name
  target-heap-size target-stack-size constant-declarations
  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables
  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants
  broken-constant-nodes inline-substitutions-enabled loop-lambda-names expand-profile-lambda
  profile-lambda-list profile-lambda-index emit-profile expand-profile-lambda
  direct-call-ids foreign-type-table first-analysis expand-debug-lambda expand-debug-assignment expand-debug-call
  initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database! scan-toplevel-assignments
  perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization!
  reorganize-recursive-bindings substitution-table simplify-named-call compiler-warning
  perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub expand-foreign-lambda*
  transform-direct-lambdas! expand-foreign-callback-lambda* debug-lambda-list debug-variable-list debugging
  debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
  string->c-identifier c-ify-string words check-and-open-input-file close-checked-input-file fold-inner constant?
  collapsable-literal? immediate? canonicalize-begin-body extract-mutable-constants string->expr get get-all
  put! collect! count! get-line get-line-2 find-lambda-container display-analysis-database varnode qnode 
  build-node-graph build-expression-tree fold-boolean inline-lambda-bindings match-node expression-has-side-effects?
  simple-lambda-node? compute-database-statistics print-program-statistics output gen gen-list 
  pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables
  topological-sort print-version print-usage initialize-analysis-database
  expand-foreign-callback-lambda default-optimization-passes default-optimization-passes-when-trying-harder
  units-used-by-default words-per-flonum rewrite
  parameter-limit eq-inline-operator optimizable-rest-argument-operators
  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
  make-random-name final-foreign-type inline-max-size simplified-ops
  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
  foreign-argument-conversion foreign-result-conversion foreign-type-convert-argument foreign-type-convert-result)


(eval-when (compile eval)
  (match-error-control #:fail) )

(include "tweaks")

(define-constant maximal-number-of-free-variables-for-liftable 16)


;;; Scan toplevel expressions for assignments:

(define (scan-toplevel-assignments node)
  (let ([safe '()]
	[unsafe '()] )

    (define (mark v)
      (if (not (memq v unsafe)) (set! safe (cons v safe))) )

    (debugging 'p "scanning toplevel assignments...")
    (call-with-current-continuation
     (lambda (return)

       (define (scan-each ns e)
	 (for-each (lambda (n) (scan n e)) ns) )

       (define (scan n e)
	 (let ([params (node-parameters n)]
	       [subs (node-subexpressions n)] )
	   (case (node-class n)

	     [(##core#variable)
	      (let ([var (first params)])
		(if (and (not (memq var e)) (not (memq var safe)))
		    (set! unsafe (cons var unsafe)) ) ) ]

	     [(if ##core#cond ##core#switch)
	      (scan (first subs) e)
	      (return #f) ]

	     [(let)
	      (scan (first subs) e)
	      (scan (second subs) (append params e)) ]

	     [(lambda ##core#callunit) #f]

	     [(##core#call) (return #f)]

	     [(set!)
	      (let ([var (first params)])
		(if (not (memq var e)) (mark var))
		(scan (first subs) e) ) ]

	     [else (scan-each subs e)] ) ) )

       (scan node '()) ) )
    (debugging 'o "safe globals" safe)
    (set! always-bound (append safe always-bound)) ) )


;;; Do some optimizations:
;
; - optimize tail recursion by replacing trivial continuations.
; - perform beta-contraction (inline procedures called only once).
; - remove empty 'let' nodes.
; - evaluate constant expressions.
; - substitute variables bound to constants with the value.
; - remove variable-bindings which are never used (and which are not bound to side-effecting expressions).
; - perform simple copy-propagation.
; - remove assignments to unused variables if the assigned value is free of side-effects and the variable is
;   not global.
; - remove unused formal parameters from functions and change all call-sites accordingly.
; - rewrite calls to standard bindings into more efficient forms.
; - rewrite calls to known non-escaping procedures with rest parameter to cons up rest-list at call-site,
;   also: change procedure's lambda-list.

(define simplifications (make-vector 301 '()))
(define simplified-ops '())

(define (perform-high-level-optimizations node db)
  (let ([removed-lets 0]
	[removed-ifs 0]
	[replaced-vars 0]
	[rest-consers '()]
	[simplified-classes '()]
	[dirty #f] )

    (define (test sym item) (get db sym item))
    (define (constant-node? n) (eq? 'quote (node-class n)))
    (define (node-value n) (first (node-parameters n)))
    (define (touch) (set! dirty #t))

    (define (simplify n)
      (or (and-let* ([entry (##sys#hash-table-ref simplifications (node-class n))])
	    (any (lambda (s)
		   (and-let* ([vars (second s)]
			      [env (match-node n (first s) vars)] 
			      [n2 (apply (third s) db
					 (map (lambda (v) (cdr (assq v env))) vars) ) ] )
		     (let* ([name (caar s)]
			    [counter (assq name simplified-classes)] )
		       (if counter
			   (set-cdr! counter (add1 (cdr counter)))
			   (set! simplified-classes (alist-cons name 1 simplified-classes)) )
		       (touch)
		       (simplify n2) ) ) )
		 entry) )
	  n) )

    (define (walk n)
      (if (memq n broken-constant-nodes)
	  n
	  (simplify
	   (let* ((odirty dirty)
		  (n1 (walk1 n))
		  (subs (node-subexpressions n1)) )
	     (case (node-class n1)

	       ((if)			; (This can be done by the simplificator...)
		(cond ((constant-node? (car subs))
		       (set! removed-ifs (+ removed-ifs 1))
		       (touch)
		       (walk (if (node-value (car subs))
				 (cadr subs)
				 (caddr subs) ) ) )
		      (else n1) ) )

	       ((##core#call)
		(if (eq? '##core#variable (node-class (car subs)))
		    (let ((var (first (node-parameters (car subs)))))
		      (if (and (or (test var 'standard-binding)
				   (test var 'extended-binding) )
			       (test var 'foldable)
			       (every constant-node? (cddr subs)) )
			  (let ((form (cons var (map (lambda (arg) `(quote ,(node-value arg)))
						     (cddr subs) ) ) ) )
			    (handle-exceptions ex
				(begin
				  (unless odirty (set! dirty #f))
				  (set! broken-constant-nodes (lset-adjoin eq? broken-constant-nodes n1))
				  n1)
			      (let ((x (eval form)))
				(debugging 'o "folding constant expression" form)
				(touch)
				(make-node ; Build call to continuation with new result...
				 '##core#call
				 '(#t)
				 (list (cadr subs) (qnode x)) ) ) ) )
			  n1) )
		    n1) )

	       (else n1) ) ) ) ) )

    (define (walk1 n)
      (let ((subs (node-subexpressions n))
	    (params (node-parameters n)) 
	    (class (node-class n)) )
	(case class

	  ((##core#variable)
	   (let replace ((var (first params)))
	     (cond ((test var 'replacable) => replace)
		   ((test var 'collapsable)
		    (touch)
		    (debugging 'o "substituted constant variable" var)
		    (qnode (car (node-parameters (test var 'value)))) )
		   (else
		    (if (not (eq? var (first params)))
			(begin
			  (touch)
			  (set! replaced-vars (+ replaced-vars 1)) ) )
		    (varnode var) ) ) ) )

	  ((let)
	   (let ([var (first params)])
	     (cond [(or (test var 'replacable)
			(test var 'removable)
			(and (test var 'contractable) (not (test var 'replacing))) )
		    (touch)
		    (set! removed-lets (add1 removed-lets))
		    (walk (second subs)) ]
		   [else (make-node 'let params (map walk subs))] ) ) )

	  ((##core#lambda)
	   (let ([llist (third params)])
	     (cond [(test (first params) 'has-unused-parameters)
		    (decompose-lambda-list
		     llist
		     (lambda (vars argc rest)
		       (receive (unused used) (partition (lambda (v) (test v 'unused)) vars)
			 (touch)
			 (debugging 'o "removed unused formal parameters" unused)
			 (make-node
			  '##core#lambda
			  (list (first params) (second params)
				(cond [(and rest (test (first params) 'explicit-rest))
				       (debugging 'o "merged explicitly consed rest parameter" rest)
				       (build-lambda-list used (add1 argc) #f) ]
				      [else (build-lambda-list used argc rest)] )
				(fourth params) )
			  (list (walk (first subs))) ) ) ) ) ]
		   [(test (first params) 'explicit-rest)
		    (decompose-lambda-list
		     llist
		     (lambda (vars argc rest)
		       (touch)
		       (debugging 'o "merged explicitly consed rest parameter" rest)
		       (make-node
			'##core#lambda
			(list (first params)
			      (second params)
			      (build-lambda-list vars (add1 argc) #f)
			      (fourth params) )
			(list (walk (first subs))) ) ) ) ]
		   [else (walk-generic n class params subs)] ) ) )

	  ((##core#call)
	   (let* ([fun (car subs)]
		  [funclass (node-class fun)] )
	     (case funclass
	       [(##core#variable)
		;; Call to named procedure:
		(let* ([var (first (node-parameters fun))]
		       [lval (and (not (test var 'unknown)) (test var 'value))]
		       [args (cdr subs)] )
		  (cond [(test var 'contractable)
			 (let* ([lparams (node-parameters lval)]
				[llist (third lparams)] )
			   (check-signature var args llist)
			   (debugging 'o "contracted procedure" var)
			   (touch)
			   (walk (inline-lambda-bindings llist args (first (node-subexpressions lval)) #f)) ) ]
			[(memq var constant-declarations)
			 (or (and-let* ((k (car args))
					((eq? '##core#variable (node-class k)))
					(kvar (first (node-parameters k)))
					(lval (and (not (test kvar 'unknown)) (test kvar 'value))) 
					(eq? '##core#lambda (node-class lval))
					(llist (third (node-parameters lval)))
					((or (test (car llist) 'unused)
					     (and (not (test (car llist) 'references))
						  (not (test (car llist) 'assigned)))))
					((not (any (cut expression-has-side-effects? <> db) (cdr args) ))))
			       (debugging 'x "removed call to constant procedure with unused result" var)
			       (make-node
				'##core#call '(#t)
				(list k (make-node '##core#undefined '() '())) ) ) 
			     (walk-generic n class params subs)) ]
			[(and lval (eq? '##core#lambda (node-class lval)))
			 (let* ([lparams (node-parameters lval)]
				[llist (third lparams)] )
			   (decompose-lambda-list
			    llist
			    (lambda (vars argc rest)
			      (let ([fid (first lparams)])
				(cond [(and (test fid 'simple)
					    (test var 'inlinable)
					    (not (memq var not-inline-list))
					    (or (memq var inline-list)
						(< (fourth lparams) inline-max-size) ) )
				       (debugging 'i "procedure inlinable" var fid (fourth lparams))
				       (check-signature var args llist)
				       (debugging 'o "inlining procedure" var)
				       (touch)
				       (walk (inline-lambda-bindings llist args (first (node-subexpressions lval)) #t)) ]
				      [(test fid 'has-unused-parameters)
				       (if (< (length args) argc) ; Expression was already optimized (should this happen?)
					   (walk-generic n class params subs)
					   (let loop ((vars vars) (argc argc) (args args) (used '()))
					     (cond [(or (null? vars) (zero? argc))
						    (touch)
						    (make-node
						     '##core#call
						     params
						     (map walk (cons fun (append-reverse used args))) ) ]
						   [(test (car vars) 'unused)
						    (touch)
						    (debugging 'o "removed unused parameter to known procedure" (car vars) var)
						    (if (expression-has-side-effects? (car args) db)
							(make-node
							 'let
							 (list (gensym 't))
							 (list (walk (car args))
							       (loop (cdr vars) (sub1 argc) (cdr args) used) ) )
							(loop (cdr vars) (sub1 argc) (cdr args) used) ) ]
						   [else (loop (cdr vars)
							       (sub1 argc)
							       (cdr args)
							       (cons (car args) used) ) ] ) ) ) ]
				      [(and (test fid 'explicit-rest)
					    (not (memq n rest-consers)) ) ; make sure we haven't inlined rest-list already
				       (let ([n (length llist)])
					 (if (< (length args) n)