optimizer.scm

Scheme跨平台编译器

       z)
   (d1 op x clist y z)
   ,(lambda (db d1 op x clist y z)
      (and-let* ([opa (assoc op membership-test-operators)]
		 [(proper-list? clist)]
		 [(< (length clist) membership-unfold-limit)] )
	(let ([var (gensym)]
	      [eop (list (cdr opa))] )
	  (make-node
	   'let (list var)
	   (list 
	    x
	    (make-node
	     'if d1
	     (list
	      (fold-right
	       (lambda (c rest)
		 (make-node
		  '##core#cond '()
		  (list 
		   (make-node '##core#inline eop (list (varnode var) (qnode c)))
		   (qnode #t)
		   rest) ) )
	       (qnode #f)
	       clist)
	      y
	      z) ) ) ) ) ) ) ) )


;;; Perform dependency-analysis and transform letrec's into simpler constructs (if possible):

(define (reorganize-recursive-bindings vars vals body)
  (let ([graph '()]
	[valmap (map cons vars vals)] )

    (define (find-path var1 var2)
      (let find ([var var1] [traversed '()])
	(and (not (memq var traversed))
	     (let ([arcs (cdr (assq var graph))])
	       (or (memq var2 arcs)
		   (let ([t2 (cons var traversed)])
		     (any (lambda (v) (find v t2)) arcs) ) ) ) ) ) )

    ;; Build dependency graph:
    (for-each
     (lambda (var val) (set! graph (alist-cons var (scan-used-variables val vars) graph)))
     vars vals)

    ;; Compute recursive groups:
    (let ([groups '()]
	  [done '()] )
      (for-each
       (lambda (var)
	 (when (not (memq var done))
	   (let ([g (filter
		     (lambda (v) (and (not (eq? v var)) (find-path var v) (find-path v var)))
		     vars) ] )
	     (set! groups (alist-cons (gensym) (cons var g) groups))
	     (set! done (append (list var) g done)) ) ) )
       vars)

      ;; Coalesce groups into a new graph:
      (let ([cgraph '()])
	(for-each
	 (lambda (g)
	   (let ([id (car g)]
		 [deps
		  (append-map
		   (lambda (var) (filter (lambda (v) (find-path var v)) vars)) 
		   (cdr g) ) ] )
	     (set! cgraph
	       (alist-cons 
		id
		(filter-map
		 (lambda (g2) (and (not (eq? g2 g)) (lset<= eq? (cdr g2) deps) (car g2))) 
		 groups)
		cgraph) ) ) )
	 groups) 

	;; Topologically sort secondary dependency graph:
	(let ([sgraph (topological-sort cgraph eq?)]
	      [optimized '()] )

	  ;; Construct new bindings:
	  (let ([n2
		 (fold
		  (lambda (gn body)
		    (let* ([svars (cdr (assq gn groups))]
			   [svar (car svars)] )
		      (cond [(and (null? (cdr svars))
				  (not (memq svar (cdr (assq svar graph)))) )
			     (set! optimized (cons svar optimized))
			     (make-node 'let svars (list (cdr (assq svar valmap)) body)) ]
			    [else
			     (fold-right
			      (lambda (var rest)
				(make-node
				 'let (list var)
				 (list (make-node '##core#undefined '() '()) rest) ) )
			      (fold-right
			       (lambda (var rest)
				 (make-node
				  'let (list (gensym))
				  (list (make-node 'set! (list var) (list (cdr (assq var valmap))))
					rest) ) )
			       body
			       svars)
			      svars) ] ) ) )
		  body
		  sgraph) ] )
	    (cond [(pair? optimized)
		   (debugging 'o "eliminated assignments" optimized)
		   (values n2 #t) ]
		  [else (values n2 #f)] ) ) ) ) ) ) )


;;;; Rewrite named calls to more primitive forms:

(define substitution-table (make-vector 301 '()))

(define (rewrite name . class-and-args)
  (let ((old (or (##sys#hash-table-ref substitution-table name) '())))
    (##sys#hash-table-set! substitution-table name (append old (list class-and-args))) ) )

(define (simplify-named-call db params name cont class classargs callargs)
  (define (test sym prop) (get db sym prop))
  (define (defarg x)
    (cond ((symbol? x) (varnode x))
	  ((and (pair? x) (eq? 'quote (car x))) (qnode (cadr x)))
	  (else (qnode x))))

  (case class

    ;; (eq?/eqv?/equal? <var> <var>) -> (quote #t)
    ;; (eq?/eqv?/equal? ...) -> (##core#inline <iop> ...)
    ((1) ; classargs = (<argc> <iop>)
     (and (test name 'standard-binding)
	  (or (and (= (length callargs) (first classargs))
		   (let ((arg1 (first callargs))
			 (arg2 (second callargs)) )
		     (and (eq? '##core#variable (node-class arg1))
			  (eq? '##core#variable (node-class arg2))
			  (equal? (node-parameters arg1) (node-parameters arg2))
			  (make-node '##core#call '(#t) (list cont (qnode #t))) ) ) )
	      (and inline-substitutions-enabled
		   (make-node
		    '##core#call '(#t) 
		    (list cont (make-node '##core#inline (list (second classargs)) callargs)) ) ) ) ) )

    ;; (<op> ...) -> (##core#inline <iop> ...)
    ;; (<op> <rest-vector>) -> (##core#inline <iopv> <rest-vector>)
    ((2) ; classargs = (<argc> <iop> <safe> <iopv>)
     (and inline-substitutions-enabled
	  (= (length callargs) (first classargs))
	  (or (test name 'extended-binding) (test name 'standard-binding))
	  (or (third classargs) unsafe)
	  (let ([arg1 (first callargs)]
		[iopv (fourth classargs)] )
	    (make-node
	     '##core#call '(#t)
	     (list 
	      cont
	      (cond [(and iopv
			  (eq? '##core#variable (node-class arg1))
			  (eq? 'vector (get db (first (node-parameters arg1)) 'rest-parameter)) )
		     (make-node '##core#inline (list iopv) callargs) ]
		    [else (make-node '##core#inline (list (second classargs)) callargs)] ) ) ) ) ) )

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

    ;; (<op> a b) -> (<primitiveop> a (quote <i>) b)
    ((4) ; classargs = (<primitiveop> <i>)
     (and inline-substitutions-enabled
	  unsafe
	  (= 2 (length callargs))
	  (test name 'standard-binding)
	  (make-node '##core#call (list #f (first classargs))
		     (list (varnode (first classargs))
			   cont
			   (first callargs)
			   (qnode (second classargs))
			   (second callargs) ) ) ) )

    ;; (<op> a) -> (##core#inline <iop> a (quote <x>))
    ((5) ; classargs = (<iop> <x> <numtype>)
     ;; - <numtype> may be #f
     (and inline-substitutions-enabled
	  (or (test name 'extended-binding)
	      (test name 'standard-binding) )
	  (= 1 (length callargs))
	  (let ((ntype (third classargs)))
	    (or (not ntype) (eq? ntype number-type)) )
	  (make-node '##core#call '(#t)
		     (list cont
			   (make-node '##core#inline (list (first classargs))
				      (list (first callargs)
					    (qnode (second classargs)) ) ) ) ) ) )

    ;; (<op> a) -> (##core#inline <iop1> (##core#inline <iop2> a))
    ((6) ; classargs = (<iop1> <iop2> <safe>)
      (and (or (third classargs) unsafe)
	   inline-substitutions-enabled
	   (= 1 (length callargs))
	   (test name 'standard-binding)
	   (make-node '##core#call '(#t)
		      (list cont
			    (make-node '##core#inline (list (first classargs))
				       (list (make-node '##core#inline (list (second classargs))
							callargs) ) ) ) ) ) )

    ;; (<op> ...) -> (##core#inline <iop> ... (quote <x>))
    ((7) ; classargs = (<argc> <iop> <x> <safe>)
     (and (or (fourth classargs) unsafe)
	  inline-substitutions-enabled
	  (= (length callargs) (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))
				      (append callargs
					      (list (qnode (third classargs))) ) ) ) ) ) )

    ;; (<op> ...) -> <<call procedure <proc> with <classargs>, <cont> and <callargs> >>
    ((8) ; classargs = (<proc> ...)
     (and inline-substitutions-enabled
	  (or (test name 'standard-binding)
	      (test name 'extended-binding) )
	  ((first classargs) db classargs cont callargs) ) )

    ;; (<op> <x1> ...) -> (##core#inline "C_and" (##core#inline <iop> <x1> <x2>) ...)
    ;; (<op> [<x>]) -> (quote #t)
    ((9) ; classargs = (<iop-fixnum> <iop-flonum> <fixnum-safe> <flonum-safe>)
     (and inline-substitutions-enabled
	  (test name 'standard-binding)
	  (if (< (length callargs) 2)
	      (make-node '##core#call '(#t) (list cont (qnode #t)))
	      (and (or (and unsafe (not (eq? number-type 'generic)))
		       (and (eq? number-type 'fixnum) (third classargs))
		       (and (eq? number-type 'flonum) (fourth classargs)) )
		   (let* ([names (map (lambda (z) (gensym)) callargs)]
			  [vars (map varnode names)] )
		     (fold-right
		      (lambda (x n y) (make-node 'let (list n) (list x y)))
		      (make-node
		       '##core#call '(#t)
		       (list 
			cont
			(let ([op (list
				   (if (eq? number-type 'fixnum)
				       (first classargs)
				       (second classargs) ) ) ] )
			  (fold-boolean
			   (lambda (x y) (make-node '##core#inline op (list x y))) 
			   vars) ) ) )
		      callargs names) ) ) ) ) )

    ;; (<op> a [b]) -> (<primitiveop> a (quote <i>) b)
    ((10) ; classargs = (<primitiveop> <i> <bvar> <safe>)
     (and inline-substitutions-enabled
	  (or (fourth classargs) unsafe)
	  (test name 'standard-binding)
	  (let ((n (length callargs)))
	    (and (< 0 n 3)
		 (make-node '##core#call (list #f (first classargs))
			    (list (varnode (first classargs))
				  cont
				  (first callargs)
				  (qnode (second classargs))
				  (if (null? (cdr callargs))
				      (varnode (third classargs))
				      (second callargs) ) ) ) ) ) ) )

    ;; (<op> ...) -> (<primitiveop> ...)
    ((11) ; classargs = (<argc> <primitiveop> <safe>)
     ;; <argc> may be #f.
     (and inline-substitutions-enabled
	  (or (third classargs) unsafe)
	  (or (test name 'standard-binding) (test name 'extended-binding))
	  (let ([argc (first classargs)])
	    (and (or (not argc)
		     (= (length callargs) (first classargs)) )
		 (make-node '##core#call (list #t (second classargs))
			    (cons* (varnode (second classargs))
				   cont
				   callargs) ) ) ) ) )

    ;; (<op> a) -> a
    ;; (<op> ...) -> (<primitiveop> ...)
    ((12) ; classargs = (<primitiveop> <safe> <maxargc>)
     (and inline-substitutions-enabled
	  (or (test name 'standard-binding) (test name 'extended-binding))
	  (or (second classargs) unsafe)
	  (let ((n (length callargs)))
	    (and (<= n (third classargs))
		 (case n
		   ((1) (make-node '##core#call '(#t) (cons cont callargs)))
		   (else (make-node '##core#call (list #t (first classargs))
				    (cons* (varnode (first classargs))
					   cont callargs) ) ) ) ) ) ) )

    ;; (<op> ...) -> ((##core#proc <primitiveop>) ...)
    ((13) ; classargs = (<primitiveop> <safe>)
     (and inline-substitutions-enabled
	  (or (test name 'extended-binding) (test name 'standard-binding))
	  (or (second classargs) unsafe)
	  (let ((pname (first classargs)))
	    (make-node '##core#call (if (pair? params) (cons #t (cdr params)) params)
		       (cons* (make-node '##core#proc (list pname #t) '())
			      cont callargs) ) ) ) )

    ;; (<op> <x> ...) -> (##core#inline <iop-safe>/<iop-unsafe> <x> ...)
    ((14) ; classargs = (<numtype> <argc> <iop-safe> <iop-unsafe>)
     (and inline-substitutions-enabled
	  (= (second classargs) (length callargs))
	  (or (test name 'extended-binding)
	      (test name 'standard-binding) )
	  (eq? number-type (first classargs))
	  (or (fourth classargs) unsafe)
	  (make-node
	   '##core#call '(#t)
	   (list cont
		 (make-node
		  '##core#inline
		  (list (if unsafe (fourth classargs) (third classargs)))
		  callargs) ) ) ) )

    ;; (<op> <x>) -> (<primitiveop> <x>)   - if numtype1
    ;;             | <x>                   - if numtype2
    ((15) ; classargs = (<numtype1> <numtype2> <primitiveop> <safe>)
     (and inline-substitutions-enabled
	  (= 1 (length callargs))
	  (or unsafe (fourth classargs))
	  (or (test name 'extended-binding)
	      (test name 'standard-binding) )
	  (cond ((eq? number-type (first classargs))
		 (make-node '##core#call (list #t (third classargs))
			    (cons* (varnode (third classargs)) cont callargs) ) )
		((eq? number-type (second classargs))
		 (make-node '##core#call '(#t) (cons cont callargs)) )
		(else #f) ) ) )

    ;; (<alloc-op> ...) -> (##core#inline_allocate (<aiop> <words>) ...)
    ((16) ; classargs = (<argc> <aiop> <safe> <words>)
     ;; - <argc> may be #f, saying that any number of arguments is allowed,
     ;; - <words> may be a list of one element (the number of words), meaning that
     ;;   the words are to be multiplied with the number of arguments.
     ;; - <words> may also be #t, meaning that the number of words is the same as the
     ;;   number of arguments plus 1.
     (let ([argc (first classargs)]
	   [rargc (length callargs)]
	   [w (fourth classargs)] )
       (and inline-substitutions-enabled
	    (or (not argc) (= rargc argc))
	    (or (test name 'extended-binding) (test name 'standard-binding))
	    (or (third classargs) unsafe)