~ chicken-core (master) /optimizer.scm

   1;;;; optimizer.scm - The CHICKEN Scheme compiler (optimizations)
   2;
   3; Copyright (c) 2008-2022, The CHICKEN Team
   4; Copyright (c) 2000-2007, Felix L. Winkelmann
   5; All rights reserved.
   6;
   7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
   8; conditions are met:
   9;
  10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
  11;     disclaimer. 
  12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
  13;     disclaimer in the documentation and/or other materials provided with the distribution. 
  14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
  15;     products derived from this software without specific prior written permission. 
  16;
  17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
  18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
  20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  25; POSSIBILITY OF SUCH DAMAGE.
  26
  27
  28(declare
  29  (unit optimizer)
  30  (uses data-structures internal support))
  31
  32(module chicken.compiler.optimizer
  33    (scan-toplevel-assignments perform-high-level-optimizations
  34     transform-direct-lambdas! determine-loop-and-dispatch
  35     eq-inline-operator membership-test-operators membership-unfold-limit
  36     default-optimization-passes rewrite)
  37
  38(import scheme
  39	chicken.base
  40	chicken.compiler.support
  41	chicken.fixnum
  42	chicken.internal
  43	chicken.sort
  44	chicken.string)
  45(import (only (scheme base) make-parameter))
  46
  47(include "tweaks")
  48(include "mini-srfi-1.scm")
  49
  50(define-constant maximal-number-of-free-variables-for-liftable 16)
  51
  52;; These are parameterized by the platform implementation
  53(define eq-inline-operator (make-parameter #f))
  54(define membership-test-operators (make-parameter #f))
  55(define membership-unfold-limit (make-parameter #f))
  56(define default-optimization-passes (make-parameter #f))
  57
  58;;; Scan toplevel expressions for assignments:
  59
  60(define (scan-toplevel-assignments node)
  61  (let ((safe '())
  62	(unsafe '()) 
  63	(escaped #f)
  64	(previous '()))
  65
  66    (define (mark v)
  67      (when (and (not escaped)
  68		 (not (memq v unsafe)))
  69	(set! safe (cons v safe))) )
  70
  71    (define (remember v x)
  72      (set! previous (alist-update! v x previous)))
  73
  74    (define (touch)
  75      (set! escaped #t)
  76      (set! previous '()))
  77
  78    (define (scan-each ns e clear-previous?)
  79      (for-each (lambda (n)
  80		  (when clear-previous? (set! previous '()))
  81		  (scan n e))
  82		ns))
  83
  84    (define (scan n e)
  85      (let ([params (node-parameters n)]
  86	    [subs (node-subexpressions n)] )
  87	(case (node-class n)
  88
  89	  [(##core#variable)
  90	   (let ((var (first params)))
  91	     (when (and (not (memq var e)) 
  92			(not (memq var unsafe)))
  93	       (set! unsafe (cons var unsafe)) )
  94	     (set! previous (filter (lambda (p) (not (eq? (car p) var))) previous)))]
  95
  96	  [(if ##core#cond ##core#switch)
  97	   (scan (first subs) e)
  98	   (touch)
  99	   (scan-each (cdr subs) e #t)]
 100
 101	  [(let)
 102	   (scan-each (butlast subs) e #f)
 103	   (scan (last subs) (append params e)) ]
 104
 105	  [(lambda ##core#lambda) #f]
 106
 107	  [(##core#call) (touch)]
 108
 109	  [(set!)
 110	   (let ((var (first params))
 111		 (val (first subs)))
 112	     (scan val e)
 113	     (let ((p (alist-ref var previous)))
 114	       (when (and p (not (memq var unsafe)))
 115		 ;; disabled for the moment - this doesn't really look like it's helpful
 116		 #;(##sys#notice
 117		  (sprintf "dropping assignment of unused value to global variable `~s'"
 118		    var))
 119		 (debugging 'o "dropping redundant toplevel assignment" var)
 120		 (copy-node!
 121		  (make-node '##core#undefined '() '())
 122		  p))
 123	       (unless (memq var e) (mark var))
 124	       (remember var n) ) ) ]
 125
 126	  [else (scan-each subs e #f)])))
 127
 128    (debugging 'p "scanning toplevel assignments...")
 129    (scan node '())
 130    (when (pair? safe)
 131      (debugging 'o "safe globals" (delete-duplicates safe eq?)))
 132    (for-each (cut mark-variable <> '##compiler#always-bound) safe)))
 133
 134
 135;;; Do some optimizations:
 136;
 137; - optimize tail recursion by replacing trivial continuations.
 138; - perform beta-contraction (inline procedures called only once).
 139; - remove empty 'let' nodes.
 140; - evaluate constant expressions.
 141; - substitute variables bound to constants with the value.
 142; - remove variable-bindings which are never used (and which are not bound to side-effecting expressions).
 143; - perform simple copy-propagation.
 144; - remove assignments to unused variables if the assigned value is free of side-effects and the variable is
 145;   not global.
 146; - remove unused formal parameters from functions and change all call-sites accordingly.
 147; - rewrite calls to standard bindings into more efficient forms.
 148; - rewrite calls to known non-escaping procedures with rest parameter to cons up rest-list at call-site,
 149;   also: change procedure's lambda-list.
 150
 151(define simplifications (make-vector 301 '()))
 152(define simplified-ops '())
 153(define broken-constant-nodes '())
 154;; Holds a-list mapping inlined fid's to inline-target-fid for catching runaway
 155;; unrolling:
 156(define inline-history '())
 157
 158(define (perform-high-level-optimizations
 159	 node db block-compilation may-inline inline-limit max-unrolls may-rewrite)
 160  (let ((removed-lets 0)
 161	(removed-ifs 0)
 162	(replaced-vars 0)
 163	(rest-consers '())
 164	(simplified-classes '())
 165	(dirty #f) )
 166
 167    (define (test sym item) (db-get db sym item))
 168    (define (constant-node? n) (eq? 'quote (node-class n)))
 169    (define (node-value n) (first (node-parameters n)))
 170    (define (touch) (set! dirty #t))
 171
 172    (define (invalidate-gae! gae)
 173      (for-each (cut set-cdr! <> #f) gae))
 174
 175    (define (simplify n)
 176      (or (and-let* ((entry (hash-table-ref
 177			     simplifications (node-class n))))
 178	    (any (lambda (s)
 179		   (and-let* ((vars (second s))
 180			      (env (match-node n (first s) vars)) 
 181			      (n2 (apply (third s) db may-rewrite
 182					 (map (lambda (v) (cdr (assq v env))) vars) ) ) )
 183		     (let* ((name (caar s))
 184			    (counter (assq name simplified-classes)) )
 185		       (if counter
 186			   (set-cdr! counter (add1 (cdr counter)))
 187			   (set! simplified-classes (alist-cons name 1 simplified-classes)) )
 188		       (touch)
 189		       (simplify n2) ) ) )
 190		 entry) )
 191	  n) )
 192
 193
 194    (define (maybe-replace-rest-arg-calls node)
 195      ;; Ugh, we need to match on the core inlined string instead of
 196      ;; the call to the intrinsic itself, because rewrites will have
 197      ;; introduced this after the first iteration.
 198      (or (and-let* (((eq? '##core#inline (node-class node)))
 199                     (native (car (node-parameters node)))
 200                     (replacement-op (cond
 201                                      ((member native '("C_i_car" "C_u_i_car")) '##core#rest-car)
 202                                      ((member native '("C_i_cdr" "C_u_i_cdr")) '##core#rest-cdr)
 203                                      ((member native '("C_i_nullp")) '##core#rest-null?)
 204                                      ((member native '("C_i_length" "C_u_i_length")) '##core#rest-length)
 205                                      (else #f)))
 206                     (arg (first (node-subexpressions node)))
 207                     ((eq? '##core#variable (node-class arg)))
 208                     (var (first (node-parameters arg)))
 209                     ((not (db-get db var 'captured)))
 210                     ((not (db-get db var 'consed-rest-arg)))
 211                     (info (db-get db var 'rest-cdr))
 212                     (restvar (car info))
 213                     (depth (cdr info))
 214                     ((not (test var 'assigned))))
 215            ;; callee is intrinsic and accesses rest arg sublist
 216	    (debugging '(o x) "known list op on rest arg sublist"
 217		       (call-info (node-parameters node) replacement-op) var depth)
 218            (touch)
 219            (make-node replacement-op
 220	               (cons* restvar depth (cdr (node-parameters node)))
 221	               (list) ) )
 222          node) )
 223
 224    (define (walk n fids gae)
 225      (if (memq n broken-constant-nodes)
 226	  n
 227	  (simplify
 228	   (let* ((odirty dirty)
 229		  (n1 (walk1 n fids gae))
 230		  (subs (node-subexpressions n1)) )
 231	     (case (node-class n1)
 232
 233	       ((if)			; (This can be done by the simplifier...)
 234		(cond ((constant-node? (car subs))
 235		       (set! removed-ifs (add1 removed-ifs))
 236		       (touch)
 237		       (walk (if (node-value (car subs))
 238				 (cadr subs)
 239				 (caddr subs) )
 240			     fids gae) )
 241		      (else n1) ) )
 242
 243               ((##core#inline)
 244                (maybe-replace-rest-arg-calls n1))
 245
 246	       ((##core#call)
 247		(maybe-constant-fold-call
 248		 n1
 249		 (cons (car subs) (cddr subs))
 250		 (lambda (ok result constant?)
 251		   (cond ((not ok)
 252			  (when constant?
 253			    (unless odirty (set! dirty #f))
 254			    (set! broken-constant-nodes
 255				(lset-adjoin/eq? broken-constant-nodes n1)))
 256			  n1)
 257			 (else
 258			  (touch)
 259			  ;; Build call to continuation with new result...
 260			  (let ((n2 (qnode result)))
 261			    (make-node
 262			     '##core#call
 263			     (list #t)
 264			     (list (cadr subs) n2) ) ) ) ))) )
 265	       (else n1) ) ) ) ) )
 266
 267    (define (replace-var var)
 268      (cond ((test var 'replacable) =>
 269             (lambda (rvar)
 270               (let ((final-var (replace-var rvar)))
 271                 ;; Store intermediate vars to avoid recurring same chain again
 272                 (db-put! db var 'replacable final-var)
 273                 final-var)))
 274            (else var)))
 275    
 276    (define (walk1 n fids gae)
 277      (let ((subs (node-subexpressions n))
 278	    (params (node-parameters n)) 
 279	    (class (node-class n)) )
 280	(case class
 281
 282	  ((##core#variable)
 283	   (let ((var (replace-var (first params))))
 284	     (cond ((test var 'collapsable)
 285		    (touch)
 286		    (debugging 'o "substituted constant variable" var)
 287		    (qnode (car (node-parameters (test var 'value)))) )
 288		   ((not (eq? var (first params)))
 289		    (touch)
 290		    (set! replaced-vars (+ replaced-vars 1))
 291		    (varnode var))
 292		   ((assq var gae) =>
 293		    (lambda (a)
 294		      (let ((gvar (cdr a)))
 295			(cond ((and gvar
 296				    (not (eq? 'no (variable-mark gvar '##compiler#inline))))
 297			       (debugging 'o "propagated global variable" var gvar)
 298			       (varnode gvar))
 299			      (else (varnode var))))))
 300		   (else (varnode var)))))
 301
 302	  ((let)
 303	   (let ((var (first params)))
 304	     (cond ((or (test var 'removable)
 305			(and (test var 'contractable) 
 306			     (not (test var 'replacing))))
 307		    (touch)
 308		    (set! removed-lets (add1 removed-lets))
 309		    (walk (second subs) fids gae) )
 310		   (else
 311		    (let ((gae (if (and (eq? '##core#variable (node-class (first subs)))
 312					(test (first (node-parameters (first subs)))
 313					      'global))
 314				   (alist-cons var (first (node-parameters (first subs)))
 315					       gae)
 316				   gae)))
 317		      (make-node 'let params (map (cut walk <> fids gae) subs))) ) ) ))
 318
 319	  ((##core#lambda)
 320	   (let ((llist (third params))
 321		 (id (first params)))
 322	     (cond [(test id 'has-unused-parameters)
 323		    (##sys#decompose-lambda-list
 324		     llist
 325		     (lambda (vars argc rest)
 326		       (receive (unused used) (partition (lambda (v) (test v 'unused)) vars)
 327			 (touch)
 328			 (debugging 'o "removed unused formal parameters" unused)
 329			 (make-node
 330			  '##core#lambda
 331			  (list (first params) (second params)
 332				(cond [(and rest (test id 'explicit-rest))
 333				       (debugging 
 334					'o "merged explicitly consed rest parameter" rest)
 335				       (build-lambda-list used (add1 argc) #f) ]
 336				      [else (build-lambda-list used argc rest)] )
 337				(fourth params) )
 338			  (list (walk (first subs) (cons id fids) '())) ) ) ) ) ]
 339		   [(test id 'explicit-rest)
 340		    (##sys#decompose-lambda-list
 341		     llist
 342		     (lambda (vars argc rest)
 343		       (touch)
 344		       (debugging 'o "merged explicitly consed rest parameter" rest)
 345		       (make-node
 346			'##core#lambda
 347			(list (first params)
 348			      (second params)
 349			      (build-lambda-list vars (add1 argc) #f)
 350			      (fourth params) )
 351			(list (walk (first subs) (cons id fids) '())) ) ) ) ]
 352		   [else (walk-generic n class params subs (cons id fids) '() #f)] ) ) )
 353
 354	  ((##core#direct_lambda)
 355	   (walk-generic n class params subs fids '() #f))
 356
 357	  ((##core#call)
 358	   (let* ((fun (car subs))
 359		  (funclass (node-class fun)))
 360	     (case funclass
 361	       [(##core#variable)
 362		;; Call to named procedure:
 363		(let* ((var (first (node-parameters fun)))
 364		       (info (call-info params var))
 365		       (lval (and (not (test var 'unknown)) 
 366				  (or (test var 'value)
 367				      (test var 'local-value))))
 368		       (args (cdr subs)) )
 369		  (cond ((and (test var 'contractable)
 370			      (not (test var 'replacing))
 371			      ;; inlinable procedure has changed
 372			      (not (test (first (node-parameters lval)) 'inline-target)))
 373			 ;; only called once
 374			 (let* ([lparams (node-parameters lval)]
 375				[llist (third lparams)] )
 376			   (cond ((check-signature var args llist)
 377                                   (debugging 'o "contracted procedure" info)
 378                                   (touch)
 379                       	           (for-each (cut db-put! db <> 'inline-target #t) 
 380                                     fids)
 381                                   (walk
 382                                     (inline-lambda-bindings
 383			               llist args (first (node-subexpressions lval)) 
 384                                       #f db
 385			               void)
 386			             fids gae) )
 387                                 (else
 388                                   (debugging 
 389                                     'i
 390                                     "not contracting procedure because argument list does not match"
 391                                     info)
 392                                   (walk-generic n class params subs fids gae #t)))))
 393			((and-let* (((variable-mark var '##compiler#pure))
 394				    ((eq? '##core#variable (node-class (car args))))
 395				    (kvar (first (node-parameters (car args))))
 396				    (lval (and (not (test kvar 'unknown))
 397					       (test kvar 'value)))
 398				    ((eq? '##core#lambda (node-class lval)))
 399				    (llist (third (node-parameters lval)))
 400				    ((or (test (car llist) 'unused)
 401					 (and (not (test (car llist) 'references))
 402					      (not (test (car llist) 'assigned))))))
 403			   ;; callee is side-effect free
 404			   (not (any (cut expression-has-side-effects? <> db)
 405				     (cdr args))))
 406			 (debugging
 407			  'o
 408			  "removed call to pure procedure with unused result"
 409			  info)
 410			 (make-node
 411			  '##core#call (list #t)
 412			  (list (car args)
 413				(make-node '##core#undefined '() '()))))
 414			((and lval
 415			      (eq? '##core#lambda (node-class lval)))
 416			 ;; callee is a lambda
 417			 (let* ((lparams (node-parameters lval))
 418				(llist (third lparams)) )
 419			   (##sys#decompose-lambda-list
 420			    llist
 421			    (lambda (vars argc rest)
 422			      (let ((ifid (first lparams))
 423				    (external (node? (variable-mark var '##compiler#inline-global))))
 424				(cond ((and may-inline 
 425					    (test var 'inlinable)
 426					    (not (test ifid 'inline-target)) ; inlinable procedure has changed
 427					    (not (test ifid 'explicit-rest))
 428					    (case (variable-mark var '##compiler#inline) 
 429					      ((no) #f)
 430					      (else 
 431					       (or external (< (fourth lparams) inline-limit))))
 432                                            (or (within-unrolling-limit ifid (car fids) max-unrolls)
 433                                                (begin
 434                                                  (debugging 'i "not inlining as unroll-limit is exceeded"
 435                                                             info ifid (car fids))
 436                                                  #f)))
 437				       (cond ((check-signature var args llist)
 438                                               (debugging 'i
 439                                                          (if external
 440                                                              "global inlining" 	
 441                                                              "inlining")
 442                                                          info ifid (fourth lparams))
 443                                               (for-each (cut db-put! db <> 'inline-target #t) 
 444                                                 fids)
 445				               (debugging 'o "inlining procedure" info)
 446				               (call-with-current-continuation
 447                                                 (lambda (return)
 448                                                   (define (cfk cvar)
 449                                                     (debugging 
 450                                                       'i
 451                                                       "not inlining procedure because it refers to contractable"
 452                                                       info cvar)
 453                                                     (return (walk-generic n class params subs fids gae #t)))
 454                                                   (let ((n2 (inline-lambda-bindings
 455                                                                llist args (first (node-subexpressions lval))
 456                                                                #t db cfk)))
 457                                                     (set! inline-history
 458                                                       (alist-cons ifid (car fids) inline-history))
 459                                                     (touch)
 460                                                     (walk n2 fids gae)))))
 461                                             (else
 462                                               (debugging 
 463                                                 'i
 464                                                 "not inlining procedure because argument list does not match"
 465                                                 info)
 466                                               (walk-generic n class params subs fids gae #t))))
 467				      ((test ifid 'has-unused-parameters)
 468				       (if (< (length args) argc) ; Expression was already optimized (should this happen?)
 469					   (walk-generic n class params subs fids gae #t)
 470					   (let loop ((vars vars) (argc argc) (args args) (used '()))
 471					     (cond [(or (null? vars) (zero? argc))
 472						    (touch)
 473						    (let ((args
 474							   (map (cut walk <> fids gae)
 475								(cons 
 476								 fun
 477								 (append (reverse used) args))) ) )
 478						      (invalidate-gae! gae)
 479						      (make-node '##core#call params args))]
 480						   [(test (car vars) 'unused)
 481						    (touch)
 482						    (debugging
 483						     'o "removed unused parameter to known procedure" 
 484						     (car vars) info)
 485						    (if (expression-has-side-effects? (car args) db)
 486							(make-node
 487							 'let
 488							 (list (gensym 't))
 489							 (list (walk (car args) fids gae)
 490							       (loop (cdr vars) (sub1 argc) (cdr args) used) ) )
 491							(loop (cdr vars) (sub1 argc) (cdr args) used) ) ]
 492						   [else (loop (cdr vars)
 493							       (sub1 argc)
 494							       (cdr args)
 495							       (cons (car args) used) ) ] ) ) ) )
 496				      ((and (test ifid 'explicit-rest)
 497					    (not (memq n rest-consers)) ) ; make sure we haven't inlined rest-list already
 498				       (let ([n (llist-length llist)])
 499					 (if (< (length args) n)
 500					     (walk-generic n class params subs fids gae #t) 
 501					     (begin
 502					       (debugging 'o "consed rest parameter at call site" info n)
 503					       (let-values ([(args rargs) (split-at args n)])
 504						 (let ([n2 (make-node
 505							    '##core#call
 506							    params
 507							    (map (cut walk <> fids gae)
 508								 (cons fun
 509								       (append 
 510									args
 511									(list
 512									 (if (null? rargs)
 513									     (qnode '())
 514									     (make-node
 515									      '##core#inline_allocate 
 516									      (list "C_a_i_list" (* 3 (length rargs)))
 517									      rargs) ) ) ) ) ) ) ] )
 518						   (set! rest-consers (cons n2 rest-consers))
 519						   (invalidate-gae! gae)
 520						   n2) ) ) ) ) )
 521				      (else (walk-generic n class params subs fids gae #t)) ) ) ) ) ) )
 522			((and lval
 523			      (eq? '##core#variable (node-class lval))
 524			      (intrinsic? (first (node-parameters lval))))
 525			 ;; callee is intrinsic
 526			 (debugging 'i "inlining call to intrinsic alias" 
 527				    info (first (node-parameters lval)))
 528			 (walk
 529			  (make-node
 530			   '##core#call
 531			   params
 532			   (cons lval (cdr subs)))
 533			  fids gae))
 534			(else (walk-generic n class params subs fids gae #t)) ) ) ]
 535	       [(##core#lambda)
 536		(if (first params)
 537		    (walk-generic n class params subs fids gae #f)
 538		    (let ((n2 (make-node '##core#call (cons #t (cdr params))
 539					 (map (cut walk <> fids gae) subs)) ))
 540		      (invalidate-gae! gae)
 541		      n2))]
 542	       [else (walk-generic n class params subs fids gae #t)] ) ) )
 543
 544	  ((set!)
 545	   (let ([var (first params)])
 546	     (cond ((test var 'contractable)
 547		    (touch)
 548		    (when (test var 'global)
 549		      (debugging 'i "removing global contractable" var))
 550		    (make-node '##core#undefined '() '()) )
 551		   ((test var 'replacable)
 552		    (touch)
 553		    (make-node '##core#undefined '() '()) )
 554		   ((and (or (not (test var 'global))
 555			     (not (variable-visible? var block-compilation)))
 556			 (not (test var 'inline-transient))
 557			 (not (test var 'references)) 
 558			 (not (expression-has-side-effects? (first subs) db)) )
 559		    (touch)
 560		    (debugging 'o "removed side-effect free assignment to unused variable" var)
 561		    (make-node '##core#undefined '() '()) )
 562		   (else
 563		    (let ((n2 (make-node 'set! params (list (walk (car subs) fids gae)))))
 564		      (for-each
 565		       (if (test var 'global)
 566			   (lambda (a)
 567			     (when (eq? var (cdr a)) ; assignment to alias?
 568			       (set-cdr! a #f)))
 569			   (lambda (a)
 570			     (when (eq? var (car a))
 571			       (set-cdr! a #f))))
 572		       gae)
 573		      n2)))))
 574
 575          ((##core#rest-cdr ##core#rest-car ##core#rest-null? ##core#rest-length)
 576	   (let ((rest-var (first params)))
 577	     ;; If rest-arg has been replaced with regular arg which
 578	     ;; is explicitly consed at call sites, restore rest ops
 579	     ;; as regular car/cdr calls on the rest list variable.
 580	     ;; This can be improved, as it can actually introduce
 581	     ;; many more cdr calls than necessary.
 582	     (cond
 583              ((or (test rest-var 'consed-rest-arg))
 584	       (touch)
 585	       (debugging 'o "resetting rest op for explicitly consed rest parameter" rest-var class)
 586
 587	       (replace-rest-op-with-list-ops class (varnode rest-var) params))
 588
 589              (else (walk-generic n class params subs fids gae #f))) ) )
 590
 591	  (else (walk-generic n class params subs fids gae #f)) ) ) )
 592    
 593    (define (walk-generic n class params subs fids gae invgae)
 594      (let lp ((same? #t)
 595               (subs subs)
 596               (subs2 '()))
 597        (cond ((null? subs)
 598               (when invgae (invalidate-gae! gae))
 599               ;; Create new node if walk made changes, otherwise original node
 600               (if same? n (make-node class params (reverse subs2))))
 601              (else
 602               (let ((sub2 (walk (car subs) fids gae)))
 603                 (lp (and same? (eq? sub2 (car subs)))
 604                     (cdr subs) (cons sub2 subs2)))) ) ))
 605
 606    (if (perform-pre-optimization! node db)
 607	(values node #t)
 608	(begin
 609	  (debugging 'p "traversal phase...")
 610	  (set! simplified-ops '())
 611	  (let ((node2 (walk node '() '())))
 612	    (when (pair? simplified-classes) (debugging 'o "simplifications" simplified-classes))
 613	    (when (pair? simplified-ops)
 614	      (with-debugging-output
 615	       'o
 616	       (lambda ()
 617		 (print "  call simplifications:")
 618		 (for-each
 619		  (lambda (p)
 620		    (print* "    " (car p))
 621		    (if (> (cdr p) 1)
 622			(print #\tab (cdr p))
 623			(newline) ) )
 624		  simplified-ops) ) ) )
 625	    (when (> replaced-vars 0) (debugging 'o "replaced variables" replaced-vars))
 626	    (when (> removed-lets 0) (debugging 'o "removed binding forms" removed-lets))
 627	    (when (> removed-ifs 0) (debugging 'o "removed conditional forms" removed-ifs))
 628	    (values node2 dirty) ) ) ) ) )
 629
 630
 631;; Check whether inlined procedure has already been inlined in the
 632;; same target procedure and count occurrences.
 633;;
 634;; Note: This check takes O(n) time, where n is the total number of
 635;; performed inlines. This can be optimized to O(1) if high number of
 636;; inlines starts to slow down the compilation.
 637
 638(define (within-unrolling-limit fid tfid max-unrolls)
 639  (let ((p (cons fid tfid)))
 640    (let loop ((h inline-history) (n 0))
 641      (cond ((null? h))
 642            ((equal? p (car h))
 643             (and (< n max-unrolls)
 644                  (loop (cdr h) (add1 n))))
 645            (else (loop (cdr h) n))))))
 646
 647
 648;;; Pre-optimization phase:
 649;
 650; - Transform expressions of the form '(if (not <x>) <y> <z>)' into '(if <x> <z> <y>)'.
 651; - Transform expressions of the form '(if (<x> <y> ...) <z> <q>)' into '<z>' if <x> names a
 652;   standard-binding that is never #f and if it's arguments are free of side-effects.
 653
 654(define (perform-pre-optimization! node db)
 655  (let ((dirty #f)
 656	(removed-nots 0) )
 657
 658    (define (touch) (set! dirty #t) #t)
 659    (define (test sym prop) (db-get db sym prop))
 660
 661    (debugging 'p "pre-optimization phase...")
 662
 663    ;; Handle '(if (not ...) ...)':
 664    (if (intrinsic? 'not)
 665	(for-each 
 666	 (lambda (site)
 667	   (let* ((n (cdr site))
 668		  (subs (node-subexpressions n))
 669		  (kont (first (node-parameters (second subs))))
 670		  (lnode (and (not (test kont 'unknown)) (test kont 'value)))
 671		  (krefs (db-get-list db kont 'references)) )
 672	     ;; Call-site has one argument and a known continuation (which is a ##core#lambda)
 673	     ;;  that has only one use:
 674	     (when (and lnode (= 1 (length krefs)) (= 3 (length subs))
 675			(eq? '##core#lambda (node-class lnode)) )
 676	       (let* ((llist (third (node-parameters lnode)))
 677		      (body (first (node-subexpressions lnode))) 
 678		      (bodysubs (node-subexpressions body)) )
 679		 ;; Continuation has one parameter?
 680		 (if (and (list? llist) (null? (cdr llist)))
 681		     (let* ((var (car llist))
 682			    (refs (db-get-list db var 'references)) )
 683		       ;; Parameter is only used once?
 684		       (if (and (= 1 (length refs)) (eq? 'if (node-class body)))
 685			   ;; Continuation contains an 'if' node?
 686			   (let ((iftest (first (node-subexpressions body))))
 687			     ;; Parameter is used only once and is the test-argument?
 688			     (if (and (eq? '##core#variable (node-class iftest))
 689				      (eq? var (first (node-parameters iftest))) )
 690				 ;; Modify call-site to call continuation directly and swap branches
 691				 ;;  in the conditional:
 692				 (begin
 693				   (set! removed-nots (+ removed-nots 1))
 694				   (node-parameters-set! n '(#t))
 695				   (node-subexpressions-set! n (cdr subs))
 696				   (node-subexpressions-set! 
 697				    body
 698				    (cons (car bodysubs) (reverse (cdr bodysubs))) )
 699				   (touch) ) ) ) ) ) ) ) ) ) )
 700	 (or (test 'not 'call-sites) '()) ) )
 701    
 702    (when (> removed-nots 0) (debugging 'o "Removed `not' forms" removed-nots))
 703    dirty) )
 704
 705
 706;;; Simplifications:
 707
 708(define (register-simplifications class . ss)
 709  (hash-table-set! simplifications class ss))
 710
 711
 712(register-simplifications
 713 '##core#call
 714 ;; (<named-call> ...) -> (<primitive-call/inline> ...)
 715 `((##core#call d (##core#variable (a)) b . c)
 716   (a b c d)
 717   ,(lambda (db may-rewrite a b c d)
 718      (let loop ((entries (or (hash-table-ref substitution-table a) '())))
 719	(cond ((null? entries) #f)
 720	      ((simplify-named-call db may-rewrite d a b
 721				    (caar entries) (cdar entries) c)
 722	       => (lambda (r)
 723		    (let ((as (assq a simplified-ops)))
 724		      (if as 
 725			  (set-cdr! as (add1 (cdr as)))
 726			  (set! simplified-ops (alist-cons a 1 simplified-ops)) ) )
 727		    r) )
 728	      (else (loop (cdr entries))) ) ) ) ) )
 729
 730
 731(register-simplifications
 732 'let
 733
 734 ;; (let ((<var1> (##core#inline <eq-inline-operator> <var0> <const1>)))
 735 ;;   (if <var1> <body1>
 736 ;;       (let ((<var2> (##core#inline <eq-inline-operator> <var0> <const2>)))
 737 ;;         (if <var2> <body2>
 738 ;;             <etc.>
 739 ;; -> (##core#switch (2) <var0> <const1> <body1> <const2> <body2> <etc.>)
 740 ;; - <var1> and <var2> have to be referenced once only.
 741 `((let (var1) (##core#inline (op) (##core#variable (var0)) (quote (const1)))
 742	(if d1 (##core#variable (var1))
 743	    body1
 744	    (let (var2) (##core#inline (op) (##core#variable (var0)) (quote (const2)))
 745		 (if d2 (##core#variable (var2))
 746		     body2
 747		     rest) ) ) )
 748   (var0 var1 var2 op const1 const2 body1 body2 d1 d2 rest)
 749   ,(lambda (db may-rewrite var0 var1 var2 op const1 const2 body1 body2 d1 d2 rest)
 750      (and (equal? op (eq-inline-operator))
 751	   (immediate? const1)
 752	   (immediate? const2)
 753	   (= 1 (length (db-get-list db var1 'references)))
 754	   (= 1 (length (db-get-list db var2 'references)))
 755	   (make-node
 756	    '##core#switch
 757	    '(2)
 758	    (list (varnode var0)
 759		  (qnode const1)
 760		  body1
 761		  (qnode const2)
 762		  body2
 763		  rest) ) ) ) )
 764
 765 ;; (let ((<var> (##core#inline <eq-inline-operator> <var0> <const>)))
 766 ;;   (if <var>
 767 ;;       <body>
 768 ;;       (##core#switch <n> <var0> <const1> <body1> ... <rest>) ) )
 769 ;; -> (##core#switch <n+1> <var0> <const> <body> <const1> <body1> ... <rest>)
 770 ;; - <var> has to be referenced once only.
 771 `((let (var) (##core#inline (op) (##core#variable (var0)) (quote (const)))
 772	(if d (##core#variable (var))
 773	    body
 774	    (##core#switch (n) (##core#variable (var0)) . clauses) ) )
 775   (var op var0 const d body n clauses)
 776   ,(lambda (db may-rewrite var op var0 const d body n clauses)
 777      (and (equal? op (eq-inline-operator))
 778	   (immediate? const)
 779	   (= 1 (length (db-get-list db var 'references)))
 780	   (make-node
 781	    '##core#switch
 782	    (list (add1 n))
 783	    (cons* (varnode var0)
 784		   (qnode const)
 785		   body
 786		   clauses) ) ) ) )
 787	      
 788 ;; (let ((<var1> (##core#undefined)))
 789 ;;   (let ((<var2> (##core#undefined)))
 790 ;;     ...
 791 ;;     (let ((<tmp1> (set! <var1> <x1>))
 792 ;;       (let ((<tmp2> (set! <var2> <x2>)))
 793 ;;         ...
 794 ;;         <body>) ... )
 795 ;; -> <a simpler sequence of let's>
 796 ;; - <tmpI> may not be used.
 797 `((let (var1) (##core#undefined ())
 798	more)
 799   (var1 more)
 800   ,(lambda (db may-rewrite var1 more)
 801      (let loop1 ((vars (list var1)) 
 802		  (body more) )
 803	(let ((c (node-class body))
 804	      (params (node-parameters body)) 
 805	      (subs (node-subexpressions body)) )
 806	  (and (eq? c 'let)
 807	       (null? (cdr params))
 808               (not (db-get db (first params) 'inline-transient))
 809               (not (db-get db (first params) 'references))
 810	       (let* ((val (first subs))
 811		      (valparams (node-parameters val))
 812		      (valsubs (node-subexpressions val)) )
 813		 (case (node-class val)
 814		   ((##core#undefined) (loop1 (cons (first params) vars) (second subs)))
 815		   ((set!)
 816		    (let ((allvars (reverse vars)))
 817		      (and (pair? allvars)
 818			   (eq? (first valparams) (first allvars))
 819			   (let loop2 ((vals (list (first valsubs)))
 820				       (vars (cdr allvars)) 
 821				       (body (second subs)) )
 822			     (let ((c (node-class body))
 823				   (params (node-parameters body))
 824				   (subs (node-subexpressions body)) )
 825			       (cond ((and (eq? c 'let)
 826					   (null? (cdr params))
 827					   (not (db-get db (first params) 'inline-transient))
 828					   (not (db-get db (first params) 'references))
 829					   (pair? vars)
 830					   (eq? 'set! (node-class (first subs)))
 831					   (eq? (car vars) (first (node-parameters (first subs)))) )
 832				      (loop2 (cons (first (node-subexpressions (first subs))) vals)
 833					     (cdr vars)
 834					     (second subs) ) )
 835				     ((null? vars)
 836				      (receive (n progress) 
 837					  (reorganize-recursive-bindings allvars (reverse vals) body) 
 838					(and progress n) ) )
 839				     (else #f) ) ) ) ) ) )
 840		   (else #f) ) ) ) ) ) ) )
 841
 842 ;; (let ((<var1> <var2>))
 843 ;;   (<var1> ...) )
 844 ;; -> (<var2> ...)
 845 ;; - <var1> used only once
 846 #| this doesn't seem to work (Sven Hartrumpf):
 847 `((let (var1) (##core#variable (var2))
 848	(##core#call p (##core#variable (var1)) . more) ) ; `p' was `#t', bombed also
 849   (var1 var2 p more)
 850   ,(lambda (db may-rewrite var1 var2 p more)
 851      (and (= 1 (length (db-get-list db var1 'references)))
 852	   (make-node
 853	    '##core#call p
 854	    (cons (varnode var2) more) ) ) ) )
 855 |#
 856
 857 ;; (let ((<var> (##core#inline <op> ...)))
 858 ;;   (if <var> <x> <y>) )
 859 ;; -> (if (##core#inline <op> ...) <x> <y>)
 860 ;; - <op> may not be the eq-inline operator (so rewriting to "##core#switch" works).
 861 ;; - <var> has to be referenced only once.
 862 `((let (var) (##core#inline (op) . args)
 863	(if d (##core#variable (var))
 864	    x
 865	    y) ) 
 866   (var op args d x y)
 867   ,(lambda (db may-rewrite var op args d x y)
 868      (and (not (equal? op (eq-inline-operator)))
 869	   (= 1 (length (db-get-list db var 'references)))
 870	   (make-node
 871	    'if d
 872	    (list (make-node '##core#inline (list op) args)
 873		  x y) ) ) ) )
 874          
 875 ;; (let ((<var1> (##core#inline <op1> ...)))
 876 ;;   (<var2> (##core#inline <op2> ... <var1> ...)))
 877 ;; -> (<var2> (##core#inline <op2> ... (##core#inline <op2> ...)
 878 ;;                                  ...))
 879 ;; - <var1> is used only once.
 880 `((let (var) (##core#inline (op1) . args1)
 881      (##core#call p 
 882                   (##core#variable (kvar))
 883                   (##core#inline (op2) . args2)))
 884    (var op1 args1 p kvar op2 args2)
 885    ,(lambda (db may-rewrite var op1 args1 p kvar op2 args2)
 886       (and may-rewrite   ; give other optimizations a chance first
 887            (not (eq? var kvar))
 888            (not (db-get db kvar 'contractable))
 889            (= 1 (length (db-get-list db var 'references)))
 890            (let loop ((args args2) (nargs '()) (ok #f))
 891              (cond ((null? args)
 892                     (and ok
 893                          (make-node 
 894                           '##core#call p
 895                           (list (varnode kvar)
 896                                 (make-node 
 897                                   '##core#inline 
 898                                   (list op2)
 899                                 (reverse nargs))))))
 900                    ((and (eq? '##core#variable
 901                               (node-class (car args)))
 902                          (eq? var
 903                               (car (node-parameters (car args)))))
 904                     (loop (cdr args)
 905                           (cons (make-node
 906                                   '##core#inline
 907                                   (list op1)
 908                                   args1)
 909                                 nargs)
 910                           #t))
 911                    (else (loop (cdr args)
 912                                (cons (car args) nargs)
 913                                ok)))))))
 914
 915 ;; (let ((<var1> (##core#inline <op> ...)))
 916 ;;   (<var2> ... <var1> ...))
 917 ;; -> (<var2> ... (##core#inline <op> ...) ...)
 918 ;;                                  ...))
 919 ;; - <var1> is used only once.
 920 `((let (var) (##core#inline (op) . args1)
 921      (##core#call p . args2))
 922    (var op args1 p args2)
 923    ,(lambda (db may-rewrite var op args1 p args2)
 924       (and may-rewrite   ; give other optimizations a chance first
 925            (= 1 (length (db-get-list db var 'references)))
 926            (let loop ((args args2) (nargs '()) (ok #f))
 927              (cond ((null? args)
 928                     (and ok
 929                          (make-node 
 930                           '##core#call p
 931                           (reverse nargs))))
 932                    ((and (eq? '##core#variable
 933                               (node-class (car args)))
 934                          (eq? var
 935                               (car (node-parameters (car args)))))
 936                     (loop (cdr args)
 937                           (cons (make-node
 938                                   '##core#inline
 939                                   (list op)
 940                                   args1)
 941                                 nargs)
 942                           #t))
 943                    (else (loop (cdr args)
 944                                (cons (car args) nargs)
 945                                ok))))))))
 946
 947
 948(register-simplifications
 949 'if
 950
 951 ;; (if <x>
 952 ;;     (<var> <y>)
 953 ;;     (<var> <z>) )
 954 ;; -> (<var> (##core#cond <x> <y> <z>))
 955 ;; - inline-substitutions have to be enabled (so IF optimizations have already taken place).
 956 `((if d1 x
 957       (##core#call d2 (##core#variable (var)) y)
 958       (##core#call d3 (##core#variable (var)) z) )
 959   (d1 d2 d3 x y z var)
 960   ,(lambda (db may-rewrite d1 d2 d3 x y z var)
 961      (and may-rewrite
 962	   (make-node
 963	    '##core#call d2
 964	    (list (varnode var)
 965		  (make-node '##core#cond '() (list x y z)) ) ) ) ) )
 966
 967 ;; (if (##core#inline <memXXX> <x> '(<c1> ...)) ...)
 968 ;; -> (let ((<var> <x>))
 969 ;;      (if (##core#cond (##core#inline XXX? <var> '<c1>) #t ...) ...)
 970 ;; - there is a limit on the number of items in the list of constants.
 971 `((if d1 (##core#inline (op) x (quote (clist)))
 972       y
 973       z)
 974   (d1 op x clist y z)
 975   ,(lambda (db may-rewrite d1 op x clist y z)
 976      (and-let* ([opa (assoc op (membership-test-operators))]
 977		 [(list? clist)]
 978		 [(< (length clist) (membership-unfold-limit))] )
 979	(let ([var (gensym)]
 980	      [eop (list (cdr opa))] )
 981	  (make-node
 982	   'let (list var)
 983	   (list 
 984	    x
 985	    (make-node
 986	     'if d1
 987	     (list
 988	      (foldr
 989	       (lambda (c rest)
 990		 (make-node
 991		  '##core#cond '()
 992		  (list 
 993		   (make-node '##core#inline eop (list (varnode var) (qnode c)))
 994		   (qnode #t)
 995		   rest) ) )
 996	       (qnode #f)
 997	       clist)
 998	      y
 999	      z) ) ) ) ) ) ) ) )
 1000
1001
1002;;; Perform dependency-analysis and transform letrec's into simpler constructs (if possible):
1003
1004(define (reorganize-recursive-bindings vars vals body)
1005  (let ([graph '()]
1006	[valmap (map cons vars vals)] )
1007
1008    (define (find-path var1 var2)
1009      (let find ([var var1] [traversed '()])
1010	(and (not (memq var traversed))
1011	     (let ([arcs (cdr (assq var graph))])
1012	       (or (memq var2 arcs)
1013		   (let ([t2 (cons var traversed)])
1014		     (any (lambda (v) (find v t2)) arcs) ) ) ) ) ) )
1015
1016    ;; Build dependency graph:
1017    (for-each
1018     (lambda (var val) (set! graph (alist-cons var (scan-used-variables val vars) graph)))
1019     vars vals)
1020
1021    ;; Compute recursive groups:
1022    (let ([groups '()]
1023	  [done '()] )
1024      (for-each
1025       (lambda (var)
1026	 (when (not (memq var done))
1027	   (let ([g (filter
1028		     (lambda (v) (and (not (eq? v var)) (find-path var v) (find-path v var)))
1029		     vars) ] )
1030	     (set! groups (alist-cons (gensym) (cons var g) groups))
1031	     (set! done (append (list var) g done)) ) ) )
1032       vars)
1033
1034      ;; Coalesce groups into a new graph:
1035      (let ([cgraph '()])
1036	(for-each
1037	 (lambda (g)
1038	   (let ([id (car g)]
1039		 [deps
1040		  (append-map
1041		   (lambda (var) (filter (lambda (v) (find-path var v)) vars)) 
1042		   (cdr g) ) ] )
1043	     (set! cgraph
1044	       (alist-cons 
1045		id
1046		(filter-map
1047		 (lambda (g2) (and (not (eq? g2 g)) (lset<=/eq? (cdr g2) deps) (car g2)))
1048		 groups)
1049		cgraph) ) ) )
1050	 groups) 
1051
1052	;; Topologically sort secondary dependency graph:
1053	(let ([sgraph (topological-sort cgraph eq?)]
1054	      [optimized '()] )
1055
1056	  ;; Construct new bindings:
1057	  (let ((n2
1058		 (foldl
1059		  (lambda (body gn)
1060		    (let* ([svars (cdr (assq gn groups))]
1061			   [svar (car svars)] )
1062		      (cond [(and (null? (cdr svars))
1063				  (not (memq svar (cdr (assq svar graph)))) )
1064			     (set! optimized (cons svar optimized))
1065			     (make-node 'let svars (list (cdr (assq svar valmap)) body)) ]
1066			    [else
1067			     (foldr
1068			      (lambda (var rest)
1069				(make-node
1070				 'let (list var)
1071				 (list (make-node '##core#undefined '() '()) rest) ) )
1072			      (foldr
1073			       (lambda (var rest)
1074				 (make-node
1075				  'let (list (gensym))
1076				  (list (make-node 'set! (list var) (list (cdr (assq var valmap))))
1077					rest) ) )
1078			       body
1079			       svars)
1080			      svars) ] ) ) )
1081		  body
1082		  sgraph) ) )
1083	    (cond [(pair? optimized)
1084		   (debugging 'o "converted assignments to bindings" optimized)
1085		   (values n2 #t) ]
1086		  [else (values n2 #f)] ) ) ) ) ) ) )
1087
1088
1089;;;; Rewrite named calls to more primitive forms:
1090
1091(define substitution-table (make-vector 301 '()))
1092
1093(define (rewrite name . class-and-args)
1094  (let ((old (or (hash-table-ref substitution-table name) '())))
1095    (hash-table-set! substitution-table name (append old (list class-and-args)))))
1096
1097(define (simplify-named-call db may-rewrite params name cont
1098			     class classargs callargs)
1099  (define (argc-ok? argc)
1100    (or (not argc)
1101	(and (fixnum? argc)
1102	     (fx= argc (length callargs)))
1103	(and (pair? argc)
1104	     (argc-ok? (car argc))
1105	     (argc-ok? (cdr argc)))))
1106
1107  (define (defarg x)
1108    (cond ((symbol? x) (varnode x))
1109	  ((and (pair? x) (eq? 'quote (car x))) (qnode (cadr x)))
1110	  (else (qnode x))))
1111
1112  (case class
1113
1114    ;; (eq?/eqv?/equal? <var> <var>) -> (quote #t)
1115    ;; (eq?/eqv?/equal? ...) -> (##core#inline <iop> ...)
1116    ((1) ; classargs = (<argc> <iop>)
1117     (and (intrinsic? name)
1118	  (or (and (= (length callargs) (first classargs))
1119		   (let ((arg1 (first callargs))
1120			 (arg2 (second callargs)) )
1121		     (and (eq? '##core#variable (node-class arg1))
1122			  (eq? '##core#variable (node-class arg2))
1123			  (equal? (node-parameters arg1) (node-parameters arg2))
1124			  (make-node '##core#call (list #t) (list cont (qnode #t))) ) ) )
1125	      (and may-rewrite
1126		   (make-node
1127		    '##core#call (list #t) 
1128		    (list cont (make-node '##core#inline (list (second classargs)) callargs)) ) ) ) ) )
1129
1130    ;; (<op> ...) -> (##core#inline <iop> ...)
1131    ((2) ; classargs = (<argc> <iop> <safe>)
1132     ;; - <safe> may be 'specialized (see rule #16 below)
1133     (and may-rewrite
1134	  (= (length callargs) (first classargs))
1135	  (intrinsic? name)
1136	  (or (third classargs) unsafe)
1137	  (let ((arg1 (first callargs)))
1138	    (make-node
1139	     '##core#call (list #t)
1140	     (list 
1141	      cont
1142	      (make-node '##core#inline (list (second classargs)) callargs) ) ) ) ) )
1143
1144    ;; (<op> ...) -> <var>
1145    ((3) ; classargs = (<var> <argc>)
1146     ;; - <argc> may be #f
1147     (and may-rewrite
1148	  (intrinsic? name)
1149	  (or (not (second classargs)) (= (length callargs) (second classargs)))
1150	  (foldr
1151	   (lambda (val body)
1152	     (make-node 'let (list (gensym)) (list val body)) )
1153	   (make-node '##core#call (list #t) (list cont (varnode (first classargs))))
1154	   callargs)))
1155
1156    ;; (<op> a b) -> (<primitiveop> a (quote <i>) b)
1157    ((4) ; classargs = (<primitiveop> <i>)
1158     (and may-rewrite
1159	  unsafe
1160	  (= 2 (length callargs))
1161	  (intrinsic? name)
1162	  (make-node '##core#call (list #f (first classargs))
1163		     (list (varnode (first classargs))
1164			   cont
1165			   (first callargs)
1166			   (qnode (second classargs))
1167			   (second callargs) ) ) ) )
1168
1169    ;; (<op> a) -> (##core#inline <iop> a (quote <x>))
1170    ((5) ; classargs = (<iop> <x> <numtype>)
1171     ;; - <numtype> may be #f
1172     (and may-rewrite
1173	  (intrinsic? name)
1174	  (= 1 (length callargs))
1175	  (let ((ntype (third classargs)))
1176	    (or (not ntype) (eq? ntype number-type)) )
1177	  (make-node '##core#call (list #t)
1178		     (list cont
1179			   (make-node '##core#inline (list (first classargs))
1180				      (list (first callargs)
1181					    (qnode (second classargs)) ) ) ) ) ) )
1182
1183    ;; (<op> a) -> (##core#inline <iop1> (##core#inline <iop2> a))
1184    ((6) ; classargs = (<iop1> <iop2> <safe>)
1185      (and (or (third classargs) unsafe)
1186	   may-rewrite
1187	   (= 1 (length callargs))
1188	   (intrinsic? name)
1189	   (make-node '##core#call (list #t)
1190		      (list cont
1191			    (make-node '##core#inline (list (first classargs))
1192				       (list (make-node '##core#inline (list (second classargs))
1193							callargs) ) ) ) ) ) )
1194
1195    ;; (<op> ...) -> (##core#inline <iop> ... (quote <x>))
1196    ((7) ; classargs = (<argc> <iop> <x> <safe>)
1197     (and (or (fourth classargs) unsafe)
1198	  may-rewrite
1199	  (= (length callargs) (first classargs))
1200	  (intrinsic? name)
1201	  (make-node '##core#call (list #t)
1202		     (list cont
1203			   (make-node '##core#inline (list (second classargs))
1204				      (append callargs
1205					      (list (qnode (third classargs))) ) ) ) ) ) )
1206
1207    ;; (<op> ...) -> <<call procedure <proc> with <classargs>, <cont> and <callargs> >>
1208    ((8) ; classargs = (<proc> ...)
1209     (and may-rewrite
1210	  (intrinsic? name)
1211	  ((first classargs) db classargs cont callargs) ) )
1212
1213    ;; (<op> <x1> ...) -> (##core#inline "C_and" (##core#inline <iop> <x1> <x2>) ...)
1214    ;; (<op> [<x>]) -> (quote #t)
1215    ((9) ; classargs = (<iop-fixnum> <iop-flonum> <fixnum-safe> <flonum-safe>)
1216     (and may-rewrite
1217	  (intrinsic? name)
1218	  (if (< (length callargs) 2)
1219	      (make-node '##core#call (list #t) (list cont (qnode #t)))
1220	      (and (or (and unsafe (not (eq? number-type 'generic)))
1221		       (and (eq? number-type 'fixnum) (third classargs))
1222		       (and (eq? number-type 'flonum) (fourth classargs)) )
1223		   (let* ((names (map (lambda (z) (gensym)) callargs))
1224			  (vars (map varnode names)) )
1225		     (let loop ((callargs callargs)
1226				(names names))
1227		       (if (null? callargs)
1228			   (make-node
1229			    '##core#call (list #t)
1230			    (list 
1231			     cont
1232			     (let ((op (list
1233					(if (eq? number-type 'fixnum)
1234					    (first classargs)
1235					    (second classargs) ) ) ) )
1236			       (fold-boolean
1237				(lambda (x y) (make-node '##core#inline op (list x y))) 
1238				vars) ) ) )
1239			   (make-node 'let 
1240				      (list (car names))
1241				      (list (car callargs)
1242					    (loop (cdr callargs) (cdr names)))))))))))
1243
1244    ;; (<op> a [b]) -> (<primitiveop> a (quote <i>) b)
1245    ((10) ; classargs = (<primitiveop> <i> <bvar> <safe>)
1246     (and may-rewrite
1247	  (or (fourth classargs) unsafe)
1248	  (intrinsic? name)
1249	  (let ((n (length callargs)))
1250	    (and (< 0 n 3)
1251		 (make-node '##core#call (list #f (first classargs))
1252			    (list (varnode (first classargs))
1253				  cont
1254				  (first callargs)
1255				  (qnode (second classargs))
1256				  (if (null? (cdr callargs))
1257				      (varnode (third classargs))
1258				      (second callargs) ) ) ) ) ) ) )
1259
1260    ;; (<op> ...) -> (<primitiveop> ...)
1261    ((11) ; classargs = (<argc> <primitiveop> <safe>)
1262     ;; <argc> may be #f.
1263     (and may-rewrite
1264	  (or (third classargs) unsafe)
1265	  (intrinsic? name)
1266	  (let ((argc (first classargs)))
1267	    (and (or (not argc)
1268		     (= (length callargs) (first classargs)) )
1269		 (make-node '##core#call (list #t (second classargs))
1270			    (cons* (varnode (second classargs))
1271				   cont
1272				   callargs) ) ) ) ) )
1273
1274    ;; (<op> a) -> a
1275    ;; (<op> ...) -> (<primitiveop> ...)
1276    ((12) ; classargs = (<primitiveop> <safe> <maxargc>)
1277     (and may-rewrite
1278	  (intrinsic? name)
1279	  (or (second classargs) unsafe)
1280	  (let ((n (length callargs)))
1281	    (and (<= n (third classargs))
1282		 (case n
1283		   ((1) (make-node '##core#call (list #t) (cons cont callargs)))
1284		   (else (make-node '##core#call (list #t (first classargs))
1285				    (cons* (varnode (first classargs))
1286					   cont callargs) ) ) ) ) ) ) )
1287
1288    ;; (<op> ...) -> ((##core#proc <primitiveop>) ...)
1289    ((13) ; classargs = (<argc> <primitiveop> <safe>)
1290     ;; - <argc> may be #f for any number of args, or a pair specifying a range
1291     (and may-rewrite
1292	  (intrinsic? name)
1293	  (or (third classargs) unsafe)
1294	  (argc-ok? (first classargs))
1295	  (let ((pname (second classargs)))
1296	    (make-node '##core#call (if (pair? params) (cons #t (cdr params)) params)
1297		       (cons* (make-node '##core#proc (list pname #t) '())
1298			      cont callargs) ) ) ) )
1299
1300    ;; (<op> <x> ...) -> (##core#inline <iop-safe>/<iop-unsafe> <x> ...)
1301    ((14) ; classargs = (<numtype> <argc> <iop-safe> <iop-unsafe>)
1302     (and may-rewrite
1303	  (= (second classargs) (length callargs))
1304	  (intrinsic? name)
1305	  (eq? number-type (first classargs))
1306	  (or (fourth classargs) unsafe)
1307	  (make-node
1308	   '##core#call (list #t)
1309	   (list cont
1310		 (make-node
1311		  '##core#inline
1312		  (list (if unsafe (fourth classargs) (third classargs)))
1313		  callargs) ) ) ) )
1314
1315    ;; (<op> <x>) -> (<primitiveop> <x>)   - if numtype1
1316    ;;             | <x>                   - if numtype2
1317    ((15) ; classargs = (<numtype1> <numtype2> <primitiveop> <safe>)
1318     (and may-rewrite
1319	  (= 1 (length callargs))
1320	  (or unsafe (fourth classargs))
1321	  (intrinsic? name)
1322	  (cond ((eq? number-type (first classargs))
1323		 (make-node '##core#call (list #t (third classargs))
1324			    (cons* (varnode (third classargs)) cont callargs) ) )
1325		((eq? number-type (second classargs))
1326		 (make-node '##core#call (list #t) (cons cont callargs)) )
1327		(else #f) ) ) )
1328
1329    ;; (<alloc-op> ...) -> (##core#inline_allocate (<aiop> <words>) ...)
1330    ((16) ; classargs = (<argc> <aiop> <safe> <words> [<counted>])
1331     ;; - <argc> may be #f, saying that any number of arguments is allowed,
1332     ;; - <words> may be a list of two elements (the base number of words and
1333     ;;   the number of words per element), meaning that the words are to be
1334     ;;   multiplied with the number of arguments.
1335     ;; - <words> may also be #t, meaning that the number of words is the same as the
1336     ;;   number of arguments plus 1.
1337     ;; - if <counted> is given and true and <argc> is between 1-8, append "<count>"
1338     ;;   to the name of the inline routine.
1339     (let ((argc (first classargs))
1340	   (rargc (length callargs))
1341	   (safe (third classargs))
1342	   (w (fourth classargs))
1343	   (counted (and (pair? (cddddr classargs)) (fifth classargs))))
1344       (and may-rewrite
1345	    (or (not argc) (= rargc argc))
1346	    (intrinsic? name)
1347	    (or unsafe safe)
1348	    (make-node
1349	     '##core#call (list #t)
1350	     (list cont 
1351		   (make-node
1352		    '##core#inline_allocate
1353		    (list (if (and counted (positive? rargc) (<= rargc 8))
1354			      (conc (second classargs) rargc)
1355			      (second classargs) )
1356			  (cond ((eq? #t w) (add1 rargc))
1357				((pair? w) (+ (car w)
1358					      (* rargc (cadr w))))
1359				(else w) ) )
1360		    callargs) ) ) ) ) )
1361
1362    ;; (<op> ...) -> (##core#inline <iop>/<unsafe-iop> ...)
1363    ((17) ; classargs = (<argc> <iop-safe> [<iop-unsafe>])
1364     (and may-rewrite
1365	  (= (length callargs) (first classargs))
1366	  (intrinsic? name)
1367	  (make-node
1368	   '##core#call (list #t)
1369	   (list cont
1370		 (make-node '##core#inline
1371			    (list (if (and unsafe (pair? (cddr classargs)))
1372				      (third classargs)
1373				      (second classargs) ) )
1374			    callargs)) ) ) )
1375
1376    ;; (<op>) -> (quote <null>)
1377    ((18) ; classargs = (<null>)
1378     (and may-rewrite
1379	  (null? callargs)
1380	  (intrinsic? name)
1381	  (make-node '##core#call (list #t) (list cont (qnode (first classargs))) ) ) )
1382
1383    ;; (<op> <x1> ... <xn>) -> (<op> (<op> <x1> ...) <xn>) [in CPS]
1384    ((19)
1385     (and may-rewrite
1386	  (intrinsic? name)
1387	  (> (length callargs) 2)
1388	  (let ((callargs (reverse callargs)))
1389	    (let lp ((xn (car callargs))
1390		     (xn-1 (cadr callargs))
1391		     (rest (cddr callargs))
1392		     (cont cont))
1393	      (if (null? rest)
1394		  (make-node
1395		   '##core#call (list #t)
1396		   (list (varnode name) cont xn-1 xn))
1397		  (let ((r (gensym 'r))
1398			(id (gensym 'va)))
1399		    (make-node
1400		     'let (list id)
1401		     (list
1402		      (make-node
1403		       '##core#lambda (list id #t (list r) 0)
1404		       (list (make-node
1405			      '##core#call (list #t)
1406			      (list (varnode name) cont (varnode r) xn))))
1407		      (lp xn-1
1408			  (car rest)
1409			  (cdr rest)
1410			  (varnode id))))))))))
1411
1412    ;; (<op> ...) -> (##core#inline <iop> <arg1> ... (quote <x>) <argN>)
1413    ((20) ; classargs = (<argc> <iop> <x> <safe>)
1414     (let ((n (length callargs)))
1415       (and (or (fourth classargs) unsafe)
1416	    may-rewrite
1417	    (= n (first classargs))
1418	    (intrinsic? name)
1419	    (make-node
1420	     '##core#call (list #t)
1421	     (list cont
1422		   (make-node 
1423		    '##core#inline (list (second classargs))
1424		    (let-values (((head tail) (split-at callargs (sub1 n))))
1425		      (append head
1426			      (list (qnode (third classargs)))
1427			      tail) ) ) ) ) ) ) )
1428
1429    ;; (<op>) -> <id>
1430    ;; (<op> <x>) -> <x>
1431    ;; (<op> <x1> ...) -> (##core#inline_allocate (<genop> <words>) <x1> (##core#inline_allocate (<genop> <words>) ...))
1432    ;; (<op> <x1> ...) -> (##core#inline <[u]fixop> <x1> (##core#inline <[u]fixop> ...)) [fixnum-mode (perhaps unsafe)]
1433    ;; - Remove "<id>" from arguments.
1434    ((21) ; classargs = (<id> <fixop> <ufixop> <genop> <words>)
1435     (and may-rewrite
1436	  (intrinsic? name)
1437	  (let* ((id (first classargs))
1438		 (words (fifth classargs))
1439		 (genop (fourth classargs))
1440		 (fixop (if unsafe (third classargs) (second classargs)))
1441		 (callargs 
1442		  (filter
1443		   (lambda (x)
1444		     (not (and (eq? 'quote (node-class x))
1445			       (eq? id (first (node-parameters x))) ) ) )
1446		   callargs) ) )
1447	    (cond ((null? callargs) (make-node '##core#call (list #t) (list cont (qnode id))))
1448		  ((null? (cdr callargs))
1449		   (make-node '##core#call (list #t) (list cont (first callargs))) )
1450		  (else
1451		   (make-node
1452		    '##core#call (list #t)
1453		    (list
1454		     cont
1455		     (fold-inner
1456		      (lambda (x y)
1457			(if (eq? number-type 'fixnum)
1458			    (make-node '##core#inline (list fixop) (list x y))
1459			    (make-node '##core#inline_allocate (list genop words) (list x y)) ) )
1460		      callargs) ) ) ) ) ) ) )
1461
1462    ;; (<alloc-op> ...) -> (##core#inline_allocate (<aiop> <words>) ...)
1463    ;; (<alloc-op> ...) -> (##core#inline <fxop> ...) [fixnum mode]
1464    ((22) ; classargs = (<argc> <aiop> <safe> <words> <fxop>)
1465     (let ((argc (first classargs))
1466	   (rargc (length callargs))
1467	   (w (fourth classargs)) )
1468       (and may-rewrite
1469	    (= rargc argc)
1470	    (intrinsic? name)
1471	    (or (third classargs) unsafe)
1472	    (make-node
1473	     '##core#call (list #t)
1474	     (list cont 
1475		   (if (eq? number-type 'fixnum)
1476		       (make-node
1477			'##core#inline
1478			(list (fifth classargs))
1479			callargs)
1480		       (make-node
1481			'##core#inline_allocate
1482			(list (second classargs) w)
1483			callargs) ) ) ) ) ) )
1484
1485    ;; (<op> <arg1> ... <argN>) -> (<primitiveop> ...)
1486    ;; (<op> <arg1> ... <argN-I> <defargN-I>) -> (<primitiveop> ...)
1487    ;; - default args in classargs should be either symbol or (optionally) 
1488    ;;   quoted literal
1489    ((23) ; classargs = (<minargc> <primitiveop> <literal1>|<varable1> ...)
1490     (and may-rewrite
1491	  (intrinsic? name)
1492	  (let ([argc (first classargs)])
1493	    (and (>= (length callargs) (first classargs))
1494		 (make-node 
1495		  '##core#call (list #t (second classargs))
1496		  (cons*
1497		   (varnode (second classargs))
1498		   cont
1499		   (let-values (((req opt) (split-at callargs argc)))
1500		     (append
1501		      req
1502		      (let loop ((ca opt) 
1503				 (da (cddr classargs)) )
1504			(cond ((null? ca)
1505			       (if (null? da)
1506				   '()
1507				   (cons (defarg (car da)) (loop '() (cdr da))) ) )
1508			      ((null? da) '())
1509			      (else (cons (car ca) (loop (cdr ca) (cdr da))))))))))))))
1510
1511    (else (bomb "bad type (optimize)")) ) )
1512
1513
1514;;; Optimize direct leaf routines:
1515
1516(define (transform-direct-lambdas! node db)
1517  (let ((dirty #f)
1518	(inner-ks '()) 
1519	(hoistable '()) 
1520	(allocated 0) )
1521
1522    ;; Process node tree and walk lambdas that meet the following constraints:
1523    ;;  - Only external lambdas (no CPS redexes),
1524    ;;  - All calls are either to the direct continuation or (tail-) recursive calls.
1525    ;;  - No allocation, no rest parameter.
1526    ;;  - The lambda has a known container variable and all it's call-sites are known.
1527    ;;  - The lambda is not marked as a callback lambda
1528
1529    (define (walk d n dn)
1530      (let ((params (node-parameters n))
1531	    (subs (node-subexpressions n)) )
1532	(case (node-class n)
1533	  ((##core#lambda)
1534	   (let ((llist (third params)))
1535	     (if (and d
1536		      (second params)
1537		      (not (db-get db d 'unknown))
1538		      (list? llist)
1539		      (and-let* ((val (db-get db d 'value))
1540				 (refs (db-get-list db d 'references))
1541				 (sites (db-get-list db d 'call-sites)) )
1542			;; val must be lambda, since `sites' is set
1543			(and (eq? n val)
1544			     (not (variable-mark
1545				   (first (node-parameters val))
1546				   '##compiler#callback-lambda))
1547			     (= (length refs) (length sites))
1548			     (scan (first subs) (first llist) d dn (cons d llist)) ) ) )
1549		 (transform n d inner-ks hoistable dn allocated) 
1550		 (walk #f (first subs) #f) ) ) )
1551	  ((set!) (walk (first params) (first subs) #f))
1552	  ((let)
1553	   (walk (first params) (first subs) n)
1554	   (walk #f (second subs) #f) )
1555	  (else (for-each (lambda (x) (walk #f x #f)) subs)) ) ) )
1556
1557    (define (scan n kvar fnvar destn env)
1558      (let ((closures '())
1559	    (recursive #f) )
1560	(define (rec n v vn e)
1561	  (let ((params (node-parameters n))
1562		(subs (node-subexpressions n)) )
1563	    (case (node-class n)
1564	      ((##core#variable)
1565	       (let ((v (first params)))
1566		 (or (not (db-get db v 'boxed))
1567		     (not (memq v env))
1568		     (and (not recursive)
1569			  (begin
1570			    (set! allocated (+ allocated 2))
1571			    #t) ) ) ) )
1572	      ((##core#lambda)
1573	       (and v
1574		    (##sys#decompose-lambda-list
1575		     (third params)
1576		     (lambda (vars argc rest)
1577		       (set! closures (cons v closures))
1578		       (rec (first subs) #f #f (append vars e)) ) ) ) )
1579	      ((##core#inline_allocate)
1580	       (and (not recursive)
1581		    (begin
1582		      (set! allocated (+ allocated (second params)))
1583		      (every (lambda (x) (rec x #f #f e)) subs) ) ) )
1584	      ((##core#direct_lambda)
1585	       (and vn destn
1586		    (null? (scan-used-variables (first subs) e)) 
1587		    (begin
1588		      (set! hoistable (alist-cons v vn hoistable))
1589		      #t) ) )
1590	      ((##core#inline_ref)
1591	       (and (let ((n (estimate-foreign-result-size (second params))))
1592		      (or (zero? n)
1593			  (and (not recursive)
1594			       (begin
1595				 (set! allocated (+ allocated n))
1596				 #t) ) ) )
1597		    (every (lambda (x) (rec x #f #f e)) subs) ) )
1598	      ((##core#inline_loc_ref)
1599	       (and (let ((n (estimate-foreign-result-size (first params))))
1600		      (or (zero? n)
1601			  (and (not recursive)
1602			       (begin
1603				 (set! allocated (+ allocated n))
1604				 #t) ) ) )
1605		    (every (lambda (x) (rec x #f #f e)) subs) ) )
1606	      ((##core#call)
1607	       (let ((fn (first subs)))
1608		 (and (eq? '##core#variable (node-class fn))
1609		      (let ((v (first (node-parameters fn))))
1610			(cond ((eq? v fnvar)
1611			       (and (zero? allocated)
1612				    (let ((k (second subs)))
1613				      (when (eq? '##core#variable (node-class k))
1614					(set! inner-ks (cons (first (node-parameters k)) inner-ks)) )
1615				      (set! recursive #t)
1616				      #t) ) )
1617			      (else (eq? v kvar)) ) )
1618		      (every (lambda (x) (rec x #f #f e)) (cdr subs)) ) ) )
1619	      ((##core#direct_call)
1620	       (let ((n (fourth params)))
1621		 (or (zero? n)
1622		     (and (not recursive)
1623			  (begin
1624			    (set! allocated (+ allocated n))
1625			    (every (lambda (x) (rec x #f #f e)) subs) ) ) ) ) )
1626	      ((set!) (rec (first subs) (first params) #f e))
1627	      ((let)
1628	       (and (rec (first subs) (first params) n e)
1629		    (rec (second subs) #f #f (append params e)) ) )
1630	      (else (every (lambda (x) (rec x #f #f e)) subs)) ) ) )
1631	(set! inner-ks '())
1632	(set! hoistable '())
1633	(set! allocated 0)
1634	(and (rec n #f #f env)
1635	     (lset=/eq? closures (delete kvar inner-ks eq?)))))
1636
1637    (define (transform n fnvar ks hoistable destn allocated)
1638      (if (pair? hoistable)
1639	  (debugging 'o "direct leaf routine with hoistable closures/allocation" fnvar (delay (unzip1 hoistable)) allocated)
1640	  (debugging 'o "direct leaf routine/allocation" fnvar allocated) )
1641      (set! dirty #t)
1642      (let* ((params (node-parameters n))
1643	     (argc (length (third params)))
1644	     (klambdas '()) 
1645	     (sites (db-get-list db fnvar 'call-sites))
1646	     (ksites '()) )
1647	(if (and (list? params) (= (length params) 4) (list? (caddr params)))
1648	    (let ((id (car params))
1649		  (kvar (caaddr params))
1650		  (vars (cdaddr params)) )
1651	      ;; Remove continuation argument:
1652	      (set-car! (cddr params) vars)
1653	   ;; Make "##core#direct_lambda":
1654	   (node-class-set! n '##core#direct_lambda)
1655	   ;; Transform recursive calls and remove unused continuations:
1656
1657	   (let rec ([n (first (node-subexpressions n))])
1658	     (let ([params (node-parameters n)]
1659		   [subs (node-subexpressions n)] )
1660	       (case (node-class n)
1661		 [(##core#call)
1662		  (let* ([fn (first subs)]
1663			 [arg0 (second subs)]
1664			 [fnp (node-parameters fn)] 
1665			 [arg0p (node-parameters arg0)] )
1666		    (when (eq? '##core#variable (node-class fn))
1667		      (cond [(eq? fnvar (first fnp))
1668			     (set! ksites (alist-cons #f n ksites))
1669			     (cond [(eq? kvar (first arg0p))
1670				    (node-class-set! n '##core#recurse)
1671				    (node-parameters-set! n (list #t id))
1672				    (node-subexpressions-set! n (cddr subs)) ]
1673				   [(assq (first arg0p) klambdas)
1674				    => (lambda (a)
1675					 (let* ([klam (cdr a)]
1676						[kbody (first (node-subexpressions klam))] )
1677					   (node-class-set! n 'let)
1678					   (node-parameters-set! n (take (third (node-parameters klam)) 1))
1679					   (node-subexpressions-set!
1680					    n
1681					    (list (make-node '##core#recurse (list #f id) (cddr subs)) kbody) )
1682					   (rec kbody) ) ) ]
1683				   [else (bomb "missing kvar" arg0p)] ) ]
1684			    [(eq? kvar (first fnp))
1685			     (node-class-set! n '##core#return)
1686			     (node-parameters-set! n '())
1687			     (node-subexpressions-set! n (cdr subs)) ]
1688			    [else (bomb "bad call (leaf)")] ) ) ) ]
1689		 [(let)
1690		  (let ([var (first params)]
1691			[val (first subs)] )
1692		    (cond [(memq var ks)
1693			   (set! klambdas (alist-cons var val klambdas))
1694			   (copy-node! (second subs) n)
1695			   (rec n) ]
1696			  [else (for-each rec subs)] ) ) ]
1697
1698		 [else (for-each rec subs)] ) ) )
1699
1700	   ;; Transform call-sites:
1701	   (for-each
1702	    (lambda (site)
1703	      (let* ((n (cdr site))
1704		     (nsubs (node-subexpressions n))
1705		     (params (node-parameters n))
1706		     (debug-info (and (pair? (cdr params))
1707				      (second params))))
1708		(unless (= argc (length (cdr nsubs)))
1709		  (quit-compiling
1710		   "known procedure called with wrong number of arguments: `~A'"
1711		   fnvar) )
1712		(node-subexpressions-set!
1713		 n
1714		 (list (second nsubs)
1715		       (make-node
1716			'##core#direct_call
1717			(list #t debug-info id allocated)
1718			(cons (car nsubs) (cddr nsubs)) ) ) ) ) )
1719	    (filter (lambda (site)
1720		      (let ((s2 (cdr site)))
1721			(not (any (lambda (ksite) (eq? (cdr ksite) s2)) ksites))))
1722		    sites))
1723
1724	   ;; Hoist direct lambdas out of container:
1725	   (when (and destn (pair? hoistable))
1726	     (let ([destn0 (make-node #f #f #f)])
1727	       (copy-node! destn destn0) ; get copy of container binding
1728	       (let ([hoisted
1729		      (foldr	; build cascade of bindings for each hoistable direct lambda...
1730		       (lambda (h rest)
1731			 (make-node
1732			  'let (list (car h))
1733			  (let ([dlam (first (node-subexpressions (cdr h)))])
1734			    (list (make-node (node-class dlam) (node-parameters dlam) (node-subexpressions dlam))
1735				  rest) ) ) )
1736		       destn0
1737		       hoistable) ] )
1738		 (copy-node! hoisted destn) ; mutate container binding to hold hoistable bindings
1739		 (for-each 
1740		  (lambda (h)		; change old direct lambdas bindings to dummy ones...
1741		    (let ([vn (cdr h)])
1742		      (node-parameters-set! vn (list (gensym)))
1743		      (set-car! (node-subexpressions vn) (make-node '##core#undefined '() '())) ) )
1744		  hoistable) ) ) ) )
1745	    (bomb "invalid parameter list" params))))
1746
1747    (debugging 'p "direct leaf routine optimization pass...")
1748    (walk #f node #f)
1749    dirty) )
1750
1751
1752;;; turn groups of local procedures into dispatch loop ("clustering")
1753;
1754; This turns (in bodies)
1755;
1756;   :
1757;   (define (a x) (b x))
1758;   (define (b y) (a y))
1759;   (a z)))
1760;
1761; into something similar to
1762;
1763;   (letrec ((<dispatch>
1764;              (lambda (<a1> <i>)
1765;                (case <i>
1766;                  ((1) (let ((x <a1>)) (<dispatch> x 2)))
1767;                  ((2) (let ((y <a1>)) (<dispatch> y 1)))
1768;                  (else (<dispatch> z 1))))))
1769;     (<dispatch> #f 0))
1770
1771(define (determine-loop-and-dispatch node db)
1772  (let ((groups '())
1773	(outer #f)
1774	(group '()))
1775
1776    (define (close)			; "close" group of local definitions
1777      (when (pair? group)
1778	(when (> (length group) 1)
1779	  (set! groups (alist-cons outer group groups)))
1780	(set! group '())
1781	(set! outer #f)))
1782
1783    (define (user-lambda? n)
1784      (and (eq? '##core#lambda (node-class n))
1785	   (list? (third (node-parameters n))))) ; no rest argument allowed
1786
1787    (define (walk n e)
1788      (let ((subs (node-subexpressions n))
1789	    (params (node-parameters n)) 
1790	    (class (node-class n)) )
1791	(case class
1792	  ((let)
1793	   (let ((var (first params))
1794		 (val (first subs))
1795		 (body (second subs)))
1796	     (cond ((and (not outer) 
1797			 (eq? '##core#undefined (node-class val)))
1798		    ;; find outermost "(let ((VAR (##core#undefined))) ...)"
1799		    (set! outer n)
1800		    (walk body (cons var e)))
1801		   ((and outer
1802			 (eq? 'set! (node-class val))
1803			 (let ((sval (first (node-subexpressions val)))
1804			       (svar (first (node-parameters val))))
1805			   ;;XXX should we also accept "##core#direct_lambda" ?
1806			   (and (eq? '##core#lambda (node-class sval))
1807				(= (length (db-get-list db svar 'references))
1808				   (length (db-get-list db svar 'call-sites)))
1809				(memq svar e)
1810				(user-lambda? sval))))
1811		    ;; "(set! VAR (lambda ...))" - add to group
1812		    (set! group (cons val group))
1813		    (walk body (cons var e)))
1814		   (else
1815		    ;; other "let" binding, close group (if any)
1816		    (close)
1817		    (walk val e)
1818		    (walk body (cons var e))))))
1819	  ((##core#lambda ##core#direct_lambda)
1820	   (##sys#decompose-lambda-list
1821	    (third params)
1822	    (lambda (vars argc rest)
1823	      ;; walk recursively, with cleared cluster state
1824	      (fluid-let ((group '())
1825			  (outer #f))
1826		(walk (first subs) vars)))))
1827	  (else
1828	   ;; other form, close group (if any)
1829	   (close)
1830	   (for-each (cut walk <> e) subs)))))
1831
1832    (debugging 'p "collecting clusters ...")
1833
1834    ;; walk once and gather groups
1835    (walk node '())
1836
1837    ;; process found clusters
1838    (for-each
1839     (lambda (g)
1840       (let* ((outer (car g))
1841	      (group (cdr g))
1842	      (dname (gensym 'dispatch))
1843	      (i (gensym 'i))
1844	      (n 1)
1845	      (bodies
1846	       (map (lambda (assign)
1847		      ;; collect information and replace assignment
1848		      ;; with "(##core#undefined)"
1849		      (let* ((name (first (node-parameters assign)))
1850			     (proc (first (node-subexpressions assign)))
1851			     (pparams (node-parameters proc))
1852			     (llist (third pparams))
1853			     (aliases (map gensym llist)))
1854			(##sys#decompose-lambda-list
1855			 llist
1856			 (lambda (vars argc rest)
1857			   (let ((body (first (node-subexpressions proc)))
1858				 (m n))
1859			     (set! n (add1 n))
1860			     (copy-node!
1861			      (make-node '##core#undefined '() '())
1862			      assign)
1863			     (list name m llist body))))))
1864		    group))
1865	      (k (gensym 'k))
1866	      (maxargs (apply max (map (o length third) bodies)))
1867	      (dllist (append
1868		       (list-tabulate maxargs (lambda _ (gensym 'a)))
1869		       (list i))))
1870
1871	 (debugging 'x "clustering" (map first bodies)) ;XXX
1872
1873	 ;; first descend into "(let ((_ (##core#undefined))) ...)" forms
1874	 ;; to make them visible everywhere
1875
1876	 (let descend ((outer outer))
1877	   ;;(print "outer: " (node-parameters outer))
1878	   (let ((body (second (node-subexpressions outer))))
1879	     (if (and (eq? 'let (node-class body))
1880		      (let ((val (first (node-subexpressions body))))
1881			(eq? '##core#undefined (node-class val))))
1882		 (descend body)
1883		 ;; wrap cluster into dispatch procedure
1884		 (copy-node!
1885		  (make-node
1886		   'let
1887		   (list dname)
1888		   (list
1889		    (make-node '##core#undefined '() '())
1890		    (make-node
1891		     'let (list (gensym))
1892		     (list
1893		      (make-node 
1894		       'set! (list dname)
1895		       (list
1896			(make-node
1897			 '##core#lambda
1898			 (list (gensym 'f_) #t dllist 0)
1899			 (list
1900			  ;; dispatch to cluster member or main body
1901			  (make-node
1902			   '##core#switch
1903			   (list (sub1 n))
1904			   (append
1905			    (list (varnode i))
1906			    (append-map
1907			     (lambda (b)
1908			       (list (qnode (second b))
1909				     (let loop ((args dllist)
1910						(vars (third b)))
1911				       (if (null? vars)
1912					   (fourth b)
1913					   (make-node
1914					    'let (list (car vars))
1915					    (list (varnode (car args))
1916						  (loop (cdr args) (cdr vars))))))))
1917			     bodies)
1918			    (cdr (node-subexpressions outer))))))))
1919		      ;; call to enter dispatch loop - the current continuation is
1920		      ;; not used, so the first parameter is passed as "#f" (it is
1921		      ;; a tail call)
1922		      (make-node
1923		       '##core#call '(#t)
1924		       (cons* (varnode dname)
1925			      (append
1926			       (list-tabulate maxargs (lambda _ (qnode #f)))
1927			       (list (qnode 0)))))))))
1928		  outer))))
1929
1930	 ;; modify call-sites to invoke dispatch loop instead
1931	 (for-each
1932	  (lambda (b)
1933	    (let ((sites (db-get db (car b) 'call-sites)))
1934	      (for-each
1935	       (lambda (site)
1936		 (let* ((callnode (cdr site))
1937			(args (cdr (node-subexpressions callnode))))
1938		   (copy-node!
1939		    (make-node
1940		     '##core#call (node-parameters callnode)
1941		     (cons* (varnode dname)
1942			    (append
1943			     args
1944			     (list-tabulate
1945			      (- maxargs (length args))
1946			      (lambda _ (qnode #f)))
1947			     (list (qnode (second b))))))
1948		    callnode)))
1949	       sites)))
1950	  bodies)))
1951
1952     groups)
1953    (values node (pair? groups))))
1954)