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