~ chicken-core (master) /core.scm

   1;;;; core.scm - The CHICKEN Scheme compiler (core module)
   2;
   3;
   4; "This is insane. What we clearly want to do is not exactly clear, and is rooted in NCOMPLR."
   5;
   6;
   7;--------------------------------------------------------------------------------------------
   8; Copyright (c) 2008-2022, The CHICKEN Team
   9; Copyright (c) 2000-2007, Felix L. Winkelmann
  10; All rights reserved.
  11;
  12; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
  13; conditions are met:
  14;
  15;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
  16;     disclaimer.
  17;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
  18;     disclaimer in the documentation and/or other materials provided with the distribution.
  19;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
  20;     products derived from this software without specific prior written permission.
  21;
  22; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
  23; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  24; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
  25; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  26; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  27; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  28; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  29; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  30; POSSIBILITY OF SUCH DAMAGE.
  31;
  32;
  33; Supported syntax:
  34;
  35; - Declaration specifiers:
  36;
  37; ([not] extended-bindings {<name>})
  38; ([not] inline {<var>})
  39; ([not] safe)
  40; ([not] standard-bindings {<name>})
  41; ([not] usual-integrations {<name>})
  42; (local {<name> ...})
  43; ([not] inline-global {<name>})
  44; ([number-type] <type>)
  45; (always-bound {<name>})
  46; (block)
  47; (block-global {<name>})
  48; (bound-to-procedure {<var>})
  49; (compile-syntax)
  50; (disable-interrupts)
  51; (emit-import-library {<module> | (<module> <filename>)})
  52; (emit-types-file [<filename>])
  53; (export {<name>})
  54; (fixnum-arithmetic)
  55; (foreign-declare {<string>})
  56; (hide {<name>})
  57; (inline-limit <limit>)
  58; (unroll-limit <limit>)
  59; (keep-shadowed-macros)
  60; (no-argc-checks)
  61; (no-bound-checks)
  62; (no-procedure-checks)
  63; (no-procedure-checks-for-usual-bindings)
  64; (no-procedure-checks-for-toplevel-bindings)
  65; (profile <symbol> ...)
  66; (safe-globals)
  67; (separate)
  68; (type (<symbol> <typespec>) ...)
  69; (unit <unitname>)
  70; (unsafe)
  71; (unused <symbol> ...)
  72; (uses {<unitname>})
  73; (strict-types)
  74; (specialize)
  75; (enforce-argument-types [<symbol> ...])
  76;
  77;   <type> = fixnum | generic
  78
  79; - Global symbol properties:
  80;
  81;   ##compiler#always-bound -> BOOL
  82;   ##compiler#always-bound-to-procedure -> BOOL
  83;   ##compiler#local -> BOOL
  84;   ##compiler#visibility -> #f | 'hidden | 'exported
  85;   ##compiler#constant -> BOOL                             defined as constant
  86;   ##compiler#intrinsic -> #f | 'standard | 'extended | 'internal
  87;   ##compiler#inline -> 'no | 'yes
  88;   ##compiler#inline-global -> 'yes | 'no | <node>
  89;   ##compiler#profile -> BOOL
  90;   ##compiler#unused -> BOOL
  91;   ##compiler#foldable -> BOOL
  92;   ##compiler#pure -> BOOL                                 referentially transparent
  93;   ##compiler#clean -> BOOL                                does not modify local state
  94;   ##compiler#type -> TYPE
  95;   ##compiler#type-source -> 'db | 'local | 'inference
  96
  97; - Source language:
  98;
  99; <variable>
 100; <constant>
 101; (##core#declare {<spec>})
 102; (##core#local-specialization <variable> <alias> {<spec>})
 103; (##core#immutable <exp>)
 104; (##core#quote <exp>)
 105; (##core#syntax <exp>)
 106; (##core#if <exp> <exp> [<exp>])
 107; (##core#let <variable> ({(<variable> <exp>)}) <body>)
 108; (##core#let ({(<variable> <exp>)}) <body>)
 109; (##core#letrec ({(<variable> <exp>)}) <body>)
 110; (##core#letrec* ({(<variable> <exp>)}) <body>)
 111; (##core#let-location <symbol> <type> [<init>] <exp>)
 112; (##core#lambda <variable> <body>)
 113; (##core#lambda ({<variable>}+ [. <variable>]) <body>)
 114; (##core#set! <variable> <exp>)
 115; (##core#ensure-toplevel-definition <variable>)
 116; (##core#begin <exp> ...)
 117; (##core#include <string> <string> | #f [<body>])
 118; (##core#include-ci <string> <string> | #f [<body>])
 119; (##core#loop-lambda <llist> <body>)
 120; (##core#undefined)
 121; (##core#primitive <name>)
 122; (##core#provide <id>)
 123; (##core#inline {<op>} <exp>)
 124; (##core#inline_allocate (<op> <words>) {<exp>})
 125; (##core#inline_ref (<name> <type>))
 126; (##core#inline_update (<name> <type>) <exp>)
 127; (##core#inline_loc_ref (<type>) <exp>)
 128; (##core#inline_loc_update (<type>) <exp> <exp>)
 129; (##core#compiletimetoo <exp>)
 130; (##core#compiletimeonly <exp>)
 131; (##core#elaborationtimetoo <exp>)
 132; (##core#elaborationtimeonly <exp>)
 133; (##core#define-foreign-variable <symbol> <type> [<string>])
 134; (##core#define-foreign-type <symbol> <type> [<proc1> [<proc2>]])
 135; (##core#foreign-lambda <type> <string> {<type>})
 136; (##core#foreign-lambda* <type> ({(<type> <var>)})) {<string>})
 137; (##core#foreign-safe-lambda <type> <string> {<type>})
 138; (##core#foreign-safe-lambda* <type> ({(<type> <var>)})) {<string>})
 139; (##core#foreign-primitive <type> ({(<type> <var>)}) {<string>})
 140; (##core#define-inline <name> <exp>)
 141; (##core#define-constant <name> <exp*>)
 142; (##core#foreign-callback-wrapper '<name> <qualifiers> '<type> '({<type>}) <exp>)
 143; (##core#define-external-variable <name> <type> <bool> [<symbol>])
 144; (##core#check <exp>)
 145; (##core#require-for-syntax <id>)
 146; (##core#require <id> [<id>])
 147; (##core#app <exp> {<exp>})
 148; (##core#define-syntax <symbol> <expr>)
 149; (##core#define-compiler-syntax <symbol> <expr>)
 150; (##core#let-compiler-syntax ((<symbol> <expr>) ...) <expr> ...)
 151; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
 152; (##core#let-module-alias ((<alias> <name>) ...) <body>)
 153; (##core#the <type> <strict?> <exp>)
 154; (##core#typecase <info> <exp> (<type> <body>) ... [(else <body>)])
 155; (##core#debug-event {<event> <loc>})
 156; (##core#with-forbidden-refs (<var> ...) <loc> <expr>)
 157; (<exp> {<exp>})
 158
 159; - Core language:
 160;
 161; [##core#variable {<variable>}]
 162; [##core#float-variable {<index>}]
 163; [if {} <exp> <exp> <exp>)]
 164; [quote {<const>}]
 165; [##core#float {<const>}]
 166; [let {<variable>} <exp-v> <exp>]
 167; [##core#lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>]
 168; [set! {<variable> [always-immediate?]} <exp>]
 169; [##core#undefined {}]
 170; [##core#primitive {<name>}]
 171; [##core#let_float {<index>} <exp> <exp>]
 172; [##core#box_float {} <exp>]
 173; [##core#unbox_float {} <exp>]
 174; [##core#inline {<op>} <exp>...]
 175; [##core#inline_allocate {<op> <words>} <exp>...]
 176; [##core#inline_ref {<name> <type>}]
 177; [##core#inline_update {<name> <type>} <exp>]
 178; [##core#inline_loc_ref {<type>} <exp>]
 179; [##core#inline_loc_update {<type>} <exp> <exp>]
 180; [##core#debug-event {<event> <loc> <ln>}]
 181; [##core#call {<safe-flag> [<debug-info>]} <exp-f> <exp>...]
 182; [##core#callunit {<unitname>} <exp>...]
 183; [##core#switch {<count>} <exp> <const1> <body1> ... <defaultbody>]
 184; [##core#rest-car {restvar depth [<debug-info>]}]
 185; [##core#rest-cdr {restvar depth [<debug-info>]}]
 186; [##core#rest-null? {restvar depth [<debug-info>]}]
 187; [##core#rest-length {restvar depth [<debug-info>]}]
 188; [##core#cond <exp> <exp> <exp>]
 189; [##core#provide <id>]
 190; [##core#recurse {<tail-flag>} <exp1> ...]
 191; [##core#return <exp>]
 192; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
 193; [##core#direct_lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>]
 194; [##core#the {<type> <strict>} <exp>]
 195; [##core#the/result {<typelist>} <exp>]
 196; [##core#typecase {<info> (<type> ...)} <exp> <body1> ... [<elsebody>]]
 197
 198; - Closure converted/prepared language:
 199;
 200; [if {} <exp> <exp> <exp>]
 201; [quote {<exp>}]
 202; [##core#float {<const>}]
 203; [##core#bind {<count>} <exp-v>... <exp>]
 204; [##core#float-variable {<index>}]
 205; [##core#undefined {}]
 206; [##core#let_float {<index>} <exp> <exp>]
 207; [##core#box_float {} <exp>]
 208; [##core#unbox_float {} <exp>]
 209; [##core#inline {<op>} <exp>...]
 210; [##core#inline_allocate {<op <words>} <exp>...]
 211; [##core#inline_ref {<name> <type>}]
 212; [##core#inline_update {<name> <type>} <exp>]
 213; [##core#inline_loc_ref {<type>} <exp>]
 214; [##core#inline_loc_update {<type>} <exp> <exp>]
 215; [##core#debug-event {<index> <event> <loc> <ln>}]
 216; [##core#closure {<count>} <exp>...]
 217; [##core#box {} <exp>]
 218; [##core#unbox {} <exp>]
 219; [##core#ref {<index>} <exp>]
 220; [##core#update {<index>} <exp> <exp>]
 221; [##core#updatebox {} <exp> <exp>]
 222; [##core#update_i {<index>} <exp> <exp>]
 223; [##core#updatebox_i {} <exp> <exp>]
 224; [##core#call {<dbg-info-index> <safe-flag> [<debug-info> [<call-id> <customizable-flag>]]} <exp-f> <exp>...]
 225; [##core#callunit {<unitname>} <exp>...]
 226; [##core#cond <exp> <exp> <exp>]
 227; [##core#local {<index>}]
 228; [##core#setlocal {<index>} <exp>]
 229; [##core#global {<literal> <safe-flag> <block-mode> [<name>]}]
 230; [##core#setglobal {<literal> <block-mode> <name>} <exp>]
 231; [##core#setglobal_i {<literal> <block-mode> <name>} <exp>]
 232; [##core#literal {<literal>}]
 233; [##core#immediate {<type> [<immediate>]}]     - type: bool/fix/nil/char/bwp
 234; [##core#proc {<name> [<non-internal>]}]
 235; [##core#provide <literal>]
 236; [##core#recurse {<tail-flag> <call-id>} <exp1> ...]
 237; [##core#return <exp>]
 238; [##core#direct_call {<dbg-info-index> <safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
 239
 240; Analysis database entries:
 241;
 242; <variable>:
 243;
 244;   captured -> <boolean>                    If true: variable is used outside it's home-scope
 245;   global -> <boolean>                      If true: variable does not occur in any lambda-list
 246;   call-sites -> ((<lambda-id> <node>) ...) Known call-nodes of a named procedure
 247;   home -> <lambda-id>                      Procedure which introduces this variable
 248;   unknown -> <boolean>                     If true: variable cannot have a known value
 249;   assigned -> <boolean>                    If true: variable is assigned somewhere
 250;   assigned-locally -> <boolean>            If true: variable has been assigned inside user lambda
 251;   undefined -> <boolean>                   If true: variable is unknown yet but can be known later
 252;   value -> <node>                          Variable has a known value
 253;   local-value -> <node>                    Variable is declared local and has value
 254;   potential-values -> (<node> ...)         Global variable was assigned this value (used for lambda-info)
 255;   references -> (<node> ...)               Nodes that are accesses of this variable (##core#variable nodes)
 256;   boxed -> <boolean>                       If true: variable has to be boxed after closure-conversion
 257;   contractable -> <boolean>                If true: variable names contractable procedure
 258;   inlinable -> <boolean>                   If true: variable names potentially inlinable procedure
 259;   collapsable -> <boolean>                 If true: variable refers to collapsable constant
 260;   removable -> <boolean>                   If true: variable is not used
 261;   replacable -> <variable>                 Variable can be replaced by another variable
 262;   replacing -> <boolean>                   If true: variable can replace another variable (don't remove)
 263;   standard-binding -> <boolean>            If true: variable names a standard binding
 264;   extended-binding -> <boolean>            If true: variable names an extended binding
 265;   unused -> <boolean>                      If true: variable is a formal parameter that is never used
 266;   rest-parameter -> #f | 'list             If true: variable holds rest-argument list
 267;   consed-rest-arg -> <boolean>             If true: variable is a rest variable in a procedure called with consed rest list
 268;   rest-cdr -> (rvar . n)                   Variable references the cdr of rest list rvar after n cdrs (0 = rest list itself)
 269;   rest-null? -> (rvar . n)                 Variable checks if the cdr of rest list rvar after n cdrs is empty (0 = rest list itself)
 270;   derived-rest-vars -> (v1 v2 ...)         Other variables aliasing or referencing cdrs of a rest variable
 271;   constant -> <boolean>                    If true: variable has fixed value
 272;   hidden-refs -> <boolean>                 If true: procedure that refers to hidden global variables
 273;   inline-transient -> <boolean>            If true: was introduced during inlining
 274;   has-bad-calls -> <boolean>               If true: the procedure has calls with wrong argument counts
 275;
 276; <lambda-id>:
 277;
 278;   contains -> (<lambda-id> ...)            Procedures contained in this lambda
 279;   contained-in -> <lambda-id>              Procedure containing this lambda
 280;   has-unused-parameters -> <boolean>       If true: procedure has unused formal parameters
 281;   use-expr -> (<lambda-id> ...)            Marks non-direct use-sites of common subexpression
 282;   closure-size -> <integer>                Number of free variables stored in a closure
 283;   customizable -> <boolean>                If true: all call sites are known, procedure does not escape
 284;   simple -> <boolean>                      If true: procedure only calls its continuation
 285;   explicit-rest -> <boolean>               If true: procedure is called with consed rest list
 286;   captured-variables -> (<var> ...)        List of closed over variables
 287;   inline-target -> <boolean>               If true: was target of an inlining operation
 288;   shareable-container -> <boolean>         If true: potentially may collect and share closed-over variables from (nested) contained closures
 289;   shareable-user -> <boolean>              If true: closed-over variables may potentially be shared from the containing closure
 290;   sharing-mode -> <container|user>         If container: actually collects and shares closed-over variables from (nested) contained closures. If user: receives container closure
 291;   shared-closure -> (<var> ...)            List of transitively closed over variables of the sharing-container and its sharing-user
 292
 293
 294(declare
 295 (unit compiler)
 296 (uses eval extras expand data-structures scrutinizer support))
 297
 298(module chicken.compiler.core
 299    (analyze-expression canonicalize-expression compute-database-statistics
 300     initialize-compiler perform-closure-conversion perform-cps-conversion
 301     prepare-for-code-generation build-toplevel-procedure
 302
 303     ;; Various ugly global boolean flags that get set by the (batch) driver
 304     all-import-libraries preserve-unchanged-import-libraries
 305     bootstrap-mode compiler-syntax-enabled
 306     emit-closure-info emit-profile enable-inline-files explicit-use-flag
 307     first-analysis no-bound-checks compile-module-registration
 308     optimize-leaf-routines standalone-executable undefine-shadowed-macros
 309     verbose-mode local-definitions enable-specialization block-compilation
 310     inline-locally inline-substitutions-enabled strict-variable-types
 311     merge-reusable-closures merge-shareable-closures
 312     static-extensions emit-link-file types-output-file
 313
 314     ;; These are set by the (batch) driver, and read by the (c) backend
 315     disable-stack-overflow-checking emit-trace-info external-protos-first
 316     external-variables insert-timer-checks no-argc-checks
 317     no-global-procedure-checks no-procedure-checks emit-debug-info
 318
 319     ;; Other, non-boolean, flags set by (batch) driver
 320     profiled-procedures import-libraries inline-max-size
 321     unroll-limit
 322     extended-bindings standard-bindings
 323
 324     ;; Non-booleans set and read by the (batch) driver
 325     required-extensions linked-libraries used-libraries
 326
 327     ;; non-booleans set by the (batch) driver, and read by the (c) backend
 328     target-heap-size target-stack-size unit-name used-units
 329
 330     ;; bindings, set by the (c) platform
 331     default-extended-bindings default-standard-bindings internal-bindings
 332
 333     ;; Only read or called by the (c) backend
 334     foreign-declarations foreign-lambda-stubs foreign-stub-argument-types
 335     foreign-stub-argument-names foreign-stub-body foreign-stub-callback
 336     foreign-stub-cps foreign-stub-id foreign-stub-name foreign-stub-return-type
 337     lambda-literal-id lambda-literal-external lambda-literal-argument-count
 338     lambda-literal-rest-argument lambda-literal-rest-argument-mode
 339     lambda-literal-temporaries lambda-literal-float-temporaries
 340     lambda-literal-callee-signatures lambda-literal-allocated
 341     lambda-literal-closure-size lambda-literal-looping
 342     lambda-literal-customizable lambda-literal-body lambda-literal-direct
 343
 344     ;; Tables and databases that really should not be exported
 345     constant-table immutable-constants inline-table line-number-database-2
 346     line-number-database-size)
 347
 348(import scheme
 349	(only (scheme base) open-output-string get-output-string)
 350	chicken.base
 351	chicken.condition
 352	chicken.compiler.scrutinizer
 353	chicken.compiler.support
 354	chicken.eval
 355	chicken.fixnum
 356	chicken.file
 357	chicken.foreign
 358	chicken.format
 359	chicken.internal
 360	chicken.io
 361	chicken.keyword
 362	chicken.load
 363	chicken.platform
 364	chicken.pretty-print
 365	chicken.pathname
 366	chicken.string
 367	chicken.syntax
 368	chicken.type)
 369
 370(define (d arg1 . more)
 371  (when (##sys#debug-mode?)
 372    (if (null? more)
 373	(pp arg1)
 374	(apply print arg1 more))))
 375
 376(define-syntax d (syntax-rules () ((_ . _) (void))))
 377
 378(include "tweaks")
 379(include "mini-srfi-1.scm")
 380
 381(define-inline (gensym-f-id) (gensym 'f_))
 382
 383(define-constant initial-analysis-database-size 3001)
 384(define-constant default-line-number-database-size 997)
 385(define-constant inline-table-size 301)
 386(define-constant constant-table-size 301)
 387(define-constant default-inline-max-size 20)
 388(define-constant default-unroll-limit 1)
 389
 390
 391;;; Global variables containing compilation parameters:
 392
 393(define unit-name #f)
 394(define standard-bindings '())
 395(define extended-bindings '())
 396(define insert-timer-checks #t)
 397(define used-units '())
 398(define foreign-declarations '())
 399(define emit-trace-info #f)
 400(define emit-debug-info #f)
 401(define block-compilation #f)
 402(define line-number-database-size default-line-number-database-size)
 403(define target-heap-size #f)
 404(define target-stack-size #f)
 405(define optimize-leaf-routines #f)
 406(define merge-reusable-closures #f)
 407(define merge-shareable-closures #f)
 408(define emit-profile #f)
 409(define no-bound-checks #f)
 410(define no-argc-checks #f)
 411(define no-procedure-checks #f)
 412(define no-global-procedure-checks #f)
 413(define safe-globals-flag #f)
 414(define explicit-use-flag #f)
 415(define disable-stack-overflow-checking #f)
 416(define external-protos-first #f)
 417(define inline-max-size default-inline-max-size)
 418(define unroll-limit default-unroll-limit)
 419(define emit-closure-info #t)
 420(define undefine-shadowed-macros #t)
 421(define profiled-procedures #f)
 422(define import-libraries '())
 423(define all-import-libraries #f)
 424(define preserve-unchanged-import-libraries #t)
 425(define compile-module-registration #f) ; 'no | 'yes
 426(define standalone-executable #t)
 427(define local-definitions #f)
 428(define inline-locally #f)
 429(define enable-inline-files #f)
 430(define compiler-syntax-enabled #t)
 431(define bootstrap-mode #f)
 432(define strict-variable-types #f)
 433(define enable-specialization #f)
 434(define static-extensions #f)
 435(define emit-link-file #f)
 436(define types-output-file #f) ; #t | <filename>
 437
 438;;; Other global variables:
 439
 440(define verbose-mode #f)
 441(define original-program-size #f)
 442(define current-program-size 0)
 443(define current-analysis-database-size initial-analysis-database-size)
 444(define line-number-database-2 #f)
 445(define immutable-constants '())
 446(define inline-table #f)
 447(define constant-table #f)
 448(define inline-substitutions-enabled #f)
 449(define direct-call-ids '())
 450(define first-analysis #t)
 451(define foreign-variables '())
 452(define foreign-lambda-stubs '())
 453(define external-variables '())
 454(define external-to-pointer '())
 455(define location-pointer-map '())
 456(define pending-canonicalizations '())
 457(define defconstant-bindings '())
 458(define callback-names '())
 459(define toplevel-scope #t)
 460(define toplevel-lambda-id #f)
 461(define required-extensions '())
 462(define linked-libraries '())
 463(define used-libraries '())
 464
 465(define unlikely-variables '(unquote unquote-splicing))
 466
 467;;; Initial bindings.  These are supplied (set!) by the (c-)platform
 468(define default-extended-bindings '())
 469(define default-standard-bindings '())
 470(define internal-bindings '())
 471
 472;;; Initialize globals:
 473
 474(define (initialize-compiler)
 475  (if line-number-database-2
 476      (vector-fill! line-number-database-2 '())
 477      (set! line-number-database-2 (make-vector line-number-database-size '())) )
 478  (if inline-table
 479      (vector-fill! inline-table '())
 480      (set! inline-table (make-vector inline-table-size '())) )
 481  (if constant-table
 482      (vector-fill! constant-table '())
 483      (set! constant-table (make-vector constant-table-size '())) )
 484  (reset-profile-info-vector-name!)
 485  (clear-real-name-table!)
 486  (clear-foreign-type-table!) )
 487
 488
 489;;; Compute general statistics from analysis database:
 490;
 491; - Returns:
 492;
 493;   current-program-size
 494;   original-program-size
 495;   number of known variables
 496;   number of known procedures
 497;   number of global variables
 498;   number of known call-sites
 499;   number of database entries
 500;   average bucket load
 501
 502(define (compute-database-statistics db)
 503  (let ((nprocs 0)
 504	(nvars 0)
 505	(nglobs 0)
 506	(entries 0)
 507	(nsites 0) )
 508    (hash-table-for-each
 509     (lambda (sym plist)
 510       (for-each
 511	(lambda (prop)
 512	  (set! entries (+ entries 1))
 513	  (case (car prop)
 514	    ((global) (set! nglobs (+ nglobs 1)))
 515	    ((value)
 516	     (set! nvars (+ nvars 1))
 517	     (if (eq? '##core#lambda (node-class (cdr prop)))
 518		 (set! nprocs (+ nprocs 1)) ) )
 519	    ((call-sites) (set! nsites (+ nsites (length (cdr prop))))) ) )
 520	plist) )
 521     db)
 522    (values current-program-size
 523	    original-program-size
 524	    nvars
 525	    nprocs
 526	    nglobs
 527	    nsites
 528	    entries) ) )
 529
 530;;; Expand macros and canonicalize expressions:
 531
 532(define (canonicalize-expression exp)
 533  (let ((compiler-syntax '())
 534        (forbidden-refs '()))
 535
 536  (define (find-id id se)		; ignores macro bindings
 537    (cond ((null? se) #f)
 538	  ((and (eq? id (caar se)) (symbol? (cdar se))) (cdar se))
 539	  (else (find-id id (cdr se)))))
 540
 541  (define (lookup id)
 542    (cond ((find-id id (##sys#current-environment)))
 543	  ((##sys#get id '##core#macro-alias) symbol? => values)
 544	  (else id)))
 545
 546  (define (macro-alias var)
 547    (let ((alias (gensym var)))
 548      (##sys#put! alias '##core#macro-alias (lookup var))
 549      alias) )
 550
 551  (define (handle-expansion-result outer-ln)
 552    (lambda (input output)
 553      (and-let* (((not (eq? input output)))
 554		 (ln (or (get-line-number input) outer-ln)))
 555	(##sys#update-line-number-database! output ln))
 556      output))
 557
 558  (define (canonicalize-body/ln ln body cs?)
 559    (fluid-let ((chicken.syntax#expansion-result-hook
 560		 (handle-expansion-result ln)))
 561      (##sys#canonicalize-body body (##sys#current-environment) cs?)))
 562
 563  (define (set-real-names! as ns)
 564    (for-each (lambda (a n) (set-real-name! a n)) as ns) )
 565
 566  (define (write-to-string x)
 567    (let ([out (open-output-string)])
 568      (write x out)
 569      (get-output-string out) ) )
 570
 571  (define (unquotify x)
 572    (if (and (list? x)
 573	     (= 2 (length x))
 574	     (symbol? (car x))
 575	     (eq? 'quote (lookup (car x))))
 576	(cadr x)
 577	x) )
 578
 579  (define (resolve-variable x0 e dest ldest h outer-ln)
 580    (when (memq x0 unlikely-variables)
 581      (warning
 582       (sprintf "reference to variable `~s' possibly unintended" x0) ))
 583    (let ((x (lookup x0)))
 584      (d `(RESOLVE-VARIABLE: ,x0 ,x ,(map (lambda (x) (car x)) (##sys#current-environment))))
 585      (cond ((not (symbol? x)) x0)	; syntax?
 586	    ((hash-table-ref constant-table x)
 587	     => (lambda (val) (walk val e dest ldest h #f #f)))
 588	    ((hash-table-ref inline-table x)
 589	     => (lambda (val) (walk val e dest ldest h #f #f)))
 590	    ((assq x foreign-variables)
 591	     => (lambda (fv)
 592		  (let* ((t (second fv))
 593			 (ft (final-foreign-type t))
 594			 (body `(##core#inline_ref (,(third fv) ,t))))
 595		    (walk
 596		     (foreign-type-convert-result
 597		      (finish-foreign-result ft body)
 598		      t)
 599		     e dest ldest h #f #f))))
 600	    ((assq x location-pointer-map)
 601	     => (lambda (a)
 602		  (let* ((t (third a))
 603			 (ft (final-foreign-type t))
 604			 (body `(##core#inline_loc_ref (,t) ,(second a))))
 605		    (walk
 606		     (foreign-type-convert-result
 607		      (finish-foreign-result ft body)
 608		      t)
 609		     e dest ldest h #f #f))))
 610	    ((not (memq x e)) (##sys#alias-global-hook x #f (cons h outer-ln))) ; only if global
 611            ((assq x forbidden-refs) =>
 612             (lambda (a)
 613               (let ((ln (cdr a)))
 614                 (quit-compiling
 615                   "~acyclical reference in LETREC binding for variable `~a'"
 616                   (if ln (sprintf "(~a) - " ln) "")
 617                   (get-real-name x)))))
 618	    (else x))))
 619
 620  (define (emit-import-lib name mod il)
 621    (let* ((fname (if all-import-libraries
 622		      (string-append (symbol->string name) ".import.scm")
 623		      (cdr il)))
 624	   (imps (##sys#compiled-module-registration mod #f))
 625	   (oldimps
 626	    (and (file-exists? fname)
 627		 (call-with-input-file fname read-expressions))))
 628      (cond ((and (equal? imps oldimps) preserve-unchanged-import-libraries)
 629	     (when verbose-mode
 630	       (print "not generating import library `" fname "' for module `"
 631		      name "' because imports did not change")) )
 632	    (else
 633	     (when verbose-mode
 634	       (print "generating import library `" fname "' for module `"
 635		      name "' ..."))
 636	     (with-output-to-file fname
 637	       (lambda ()
 638		 (print ";;;; " fname " - GENERATED BY CHICKEN "
 639			(chicken-version) " -*- Scheme -*-\n")
 640		 (for-each pretty-print imps)
 641		 (print "\n;; END OF FILE"))))) ) )
 642
 643   (define (include-file x ci e dest ldest h ln tl?)
 644     (##sys#include-forms-from-file
 645       (cadr x) (caddr x) ci
 646       (lambda (forms path)
 647         (let ((code (if (pair? (cdddr x)) ; body?
 648                         (canonicalize-body/ln
 649                           ln
 650                           (append forms (cadddr x))
 651                           compiler-syntax-enabled)
 652                         `(##core#begin ,@forms))))
 653           (fluid-let ((##sys#current-source-filename path))
 654             (walk code e dest ldest h ln tl?))))))
 655
 656  (define (walk x e dest ldest h outer-ln tl?)
 657    (cond ((keyword? x) `(quote ,x))
 658	  ((symbol? x) (resolve-variable x e dest ldest h outer-ln))
 659	  ((not (pair? x))
 660	   (if (constant? x)
 661	       `(quote ,x)
 662	       (##sys#syntax-error/context "illegal atomic form" x)))
 663	  ((symbol? (car x))
 664	   (let ((ln (or (get-line-number x) outer-ln)))
 665	     (emit-syntax-trace-info x #f)
 666	     (set! ##sys#syntax-error-culprit x)
 667	     (let* ((name (lookup (car x)))
 668		    (xexpanded
 669		     (fluid-let ((chicken.syntax#expansion-result-hook
 670				  (handle-expansion-result ln)))
 671		       (expand x (##sys#current-environment) compiler-syntax-enabled))))
 672	       (cond ((not (eq? x xexpanded))
 673		      (walk xexpanded e dest ldest h ln tl?))
 674
 675                     ((not (list? x))
 676                      (if ln
 677                          (##sys#syntax-error/context (sprintf "(~a) - malformed expression" ln) x)
 678                          (##sys#syntax-error/context "malformed expression" x)))
 679
 680		     ((hash-table-ref inline-table name)
 681		      => (lambda (val)
 682			   (walk (cons val (cdr x)) e dest ldest h ln #f)))
 683
 684		     (else
 685		      (case name
 686
 687			((##core#if)
 688			 `(if
 689			   ,(walk (cadr x) e #f #f h ln #f)
 690			   ,(walk (caddr x) e #f #f h ln #f)
 691			   ,(if (null? (cdddr x))
 692				'(##core#undefined)
 693				(walk (cadddr x) e #f #f h ln #f) ) ) )
 694
 695			((##core#syntax ##core#quote)
 696			 `(quote ,(strip-syntax (cadr x))))
 697
 698			((##core#check)
 699			 (if unsafe
 700			     '(quote #t)
 701			     (walk (cadr x) e dest ldest h ln tl?) ) )
 702
 703			((##core#the)
 704			 `(##core#the
 705			   ,(strip-syntax (cadr x))
 706			   ,(caddr x)
 707			   ,(walk (cadddr x) e dest ldest h ln tl?)))
 708
 709			((##core#local-specialization)
 710			 (let* ((name (resolve-variable (cadr x) e dest ldest h outer-ln))
 711				(raw-alias (caddr x))
 712				(resolved-alias (resolve-variable raw-alias e dest ldest h outer-ln))
 713				(specs (##sys#get name '##compiler#local-specializations '())))
 714			   (letrec ((resolve-alias (lambda (form)
 715						     (cond ((pair? form) (cons (resolve-alias (car form)) (resolve-alias (cdr form))))
 716							   ((eq? form raw-alias) resolved-alias)
 717							   (else form)))))
 718			     (##sys#put! name '##compiler#local-specializations (##sys#append specs (resolve-alias (cdddr x))))
 719			     '(##core#undefined))))
 720
 721			((##core#typecase)
 722			 `(##core#typecase
 723			   ,(or ln (cadr x))
 724			   ,(walk (caddr x) e #f #f h ln tl?)
 725			   ,@(map (lambda (cl)
 726				    (list (strip-syntax (car cl))
 727					  (walk (cadr cl) e dest ldest h ln tl?)))
 728				  (cdddr x))))
 729
 730			((##core#immutable)
 731			 (let ((c (cadadr x)))
 732			   (cond [(assoc c immutable-constants) => cdr]
 733				 [else
 734				  (let ([var (gensym 'c)])
 735				    (set! immutable-constants (alist-cons c var immutable-constants))
 736				    (mark-variable var '##compiler#always-bound)
 737				    (hide-variable var)
 738				    var) ] ) ) )
 739
 740			((##core#provide ##core#primitive ##core#undefined) x)
 741
 742			((##core#callunit)
 743			 (let ((unit (cadr x)))
 744			   (set! used-units (lset-adjoin/eq? used-units unit))
 745			   `(##core#callunit ,unit)))
 746
 747			((##core#inline_ref)
 748			 `(##core#inline_ref
 749			   (,(caadr x) ,(strip-syntax (cadadr x)))))
 750
 751			((##core#inline_loc_ref)
 752			 `(##core#inline_loc_ref
 753			   ,(strip-syntax (cadr x))
 754			   ,(walk (caddr x) e dest ldest h ln #f)))
 755
 756			((##core#require-for-syntax)
 757			 (chicken.load#load-extension (cadr x) #f #f)
 758			 '(##core#undefined))
 759
 760			((##core#require)
 761			 (let ((lib (cadr x))
 762			       (mod (and (pair? (cddr x)) (caddr x))))
 763			   (unless (chicken.load#core-library? lib)
 764			     (set! required-extensions (lset-adjoin/eq? required-extensions lib)))
 765			   (walk (##sys#process-require
 766				  lib mod
 767				  (if (or (memq lib linked-libraries) static-extensions)
 768				      'static
 769				      'dynamic))
 770				 e dest ldest h ln #f)))
 771
 772			((##core#let)
 773			 (let* ((bindings (cadr x))
 774				(vars (unzip1 bindings))
 775				(aliases (map gensym vars))
 776				(se2 (##sys#extend-se (##sys#current-environment) vars aliases))
 777				(ln (or (get-line-number x) outer-ln)))
 778			   (set-real-names! aliases vars)
 779			   `(let
 780			     ,(map (lambda (alias b)
 781				     (list alias (walk (cadr b) e (car b) #t h ln #f)) )
 782				   aliases bindings)
 783			     ,(parameterize ((##sys#current-environment se2))
 784				(walk (canonicalize-body/ln
 785				       ln (cddr x) compiler-syntax-enabled)
 786				      (append aliases e)
 787				      dest ldest h ln #f)) ) )  )
 788
 789			((##core#letrec*)
 790			 (let ((bindings (cadr x))
 791			       (body (cddr x)) )
 792			   (walk
 793			    `(##core#let
 794			      ,(map (lambda (b)
 795				      (list (car b) '(##core#undefined)))
 796				    bindings)
 797			      ,@(map (lambda (b)
 798				       `(##core#set! ,(car b) ,(cadr b)))
 799				     bindings)
 800			      (##core#let () ,@body) )
 801			    e dest ldest h ln #f)))
 802
 803			((##core#letrec)
 804			 (let* ((bindings (cadr x))
 805				(vars (unzip1 bindings))
 806				(tmps (map gensym vars))
 807				(body (cddr x)) )
 808			   (walk
 809			    `(##core#let
 810			      ,(map (lambda (b)
 811				      (list (car b) '(##core#undefined)))
 812				    bindings)
 813			      (##core#let
 814			       ,(map (lambda (t b)
 815                                       (list t `(##core#with-forbidden-refs
 816                                                  ,vars ,ln ,(cadr b))))
 817                                     tmps bindings)
 818			       ,@(map (lambda (v t)
 819					`(##core#set! ,v ,t))
 820				      vars tmps)
 821			       (##core#let () ,@body) ) )
 822			    e dest ldest h ln #f)))
 823
 824                        ((##core#with-forbidden-refs)
 825                         (let* ((loc (caddr x))
 826                                (vars (map (lambda (v)
 827                                             (cons (resolve-variable v e dest ldest h outer-ln)
 828                                                   loc))
 829                                        (cadr x))))
 830                           (fluid-let ((forbidden-refs
 831                                         (append vars forbidden-refs)))
 832                             (walk (cadddr x) e dest ldest h ln #f))))
 833
 834			((##core#lambda)
 835			 (let ((llist (cadr x))
 836			       (obody (cddr x)) )
 837			   (when (##sys#extended-lambda-list? llist)
 838			     (set!-values
 839			      (llist obody)
 840			      (##sys#expand-extended-lambda-list
 841			       llist obody ##sys#error (##sys#current-environment)) ) )
 842			   (##sys#decompose-lambda-list
 843			    llist
 844			    (lambda (vars argc rest)
 845			      (let* ((aliases (map gensym vars))
 846				     (ln (or (get-line-number x) outer-ln))
 847				     (se2 (##sys#extend-se (##sys#current-environment) vars aliases))
 848				     (body (parameterize ((##sys#current-environment se2))
 849					     (let ((body0 (canonicalize-body/ln
 850							   ln obody compiler-syntax-enabled)))
 851                                               (fluid-let ((forbidden-refs '()))
 852                                                 (walk
 853                                                   (if emit-debug-info
 854                                                       `(##core#begin
 855                                                          (##core#debug-event C_DEBUG_ENTRY (##core#quote ,dest))
 856                                                         ,body0)
 857                                                       body0)
 858                                                   (append aliases e)
 859                                                   #f #f dest ln #f)))))
 860				     (llist2
 861				      (build-lambda-list
 862				       aliases argc
 863				       (and rest (list-ref aliases (posq rest vars))) ) )
 864				     (l `(##core#lambda ,llist2 ,body)) )
 865				(set-real-names! aliases vars)
 866				(cond ((or (not dest)
 867					   ldest
 868					   (assq dest (##sys#current-environment))) ; not global?
 869				       l)
 870				      ((and emit-profile
 871					    (or (eq? profiled-procedures 'all)
 872						(and
 873						 (eq? profiled-procedures 'some)
 874						 (variable-mark dest '##compiler#profile))))
 875				       (expand-profile-lambda
 876					(if (memq dest e) ; should normally not be the case
 877					    e
 878					    (##sys#alias-global-hook dest #f #f))
 879					llist2 body) )
 880				      (else l)))))))
 881
 882			((##core#let-syntax)
 883			 (parameterize
 884			     ((##sys#current-environment
 885			       (append
 886				(map (lambda (b)
 887				       (list
 888					(car b)
 889					(##sys#current-environment)
 890					(##sys#ensure-transformer
 891					 (##sys#eval/meta (cadr b))
 892					 (car b))))
 893				     (cadr x) )
 894				(##sys#current-environment)) ))
 895			   (let ((ln (or (get-line-number x) outer-ln)))
 896			     (walk
 897			      (canonicalize-body/ln
 898			       ln (cddr x) compiler-syntax-enabled)
 899			      e dest ldest h ln #f)) ) )
 900
 901		       ((##core#letrec-syntax)
 902			(let* ((ms (map (lambda (b)
 903					  (list
 904					   (car b)
 905					   #f
 906					   (##sys#ensure-transformer
 907					    (##sys#eval/meta (cadr b))
 908					    (car b))))
 909					(cadr x) ) )
 910			       (se2 (append ms (##sys#current-environment)))
 911			       (ln (or (get-line-number x) outer-ln)) )
 912			  (for-each
 913			   (lambda (sb)
 914			     (set-car! (cdr sb) se2) )
 915			   ms)
 916			  (parameterize ((##sys#current-environment se2))
 917			    (walk
 918			     (canonicalize-body/ln
 919			      ln (cddr x) compiler-syntax-enabled)
 920			     e dest ldest h ln #f))))
 921
 922		       ((##core#define-syntax)
 923			(##sys#check-syntax
 924			 (car x) x
 925			 (if (pair? (cadr x))
 926			     '(_ (variable . lambda-list) . #(_ 1))
 927			     '(_ variable _) )
 928			 #f (##sys#current-environment))
 929			(let* ((var (if (pair? (cadr x)) (caadr x) (cadr x)))
 930			       (body (if (pair? (cadr x))
 931					 `(##core#lambda ,(cdadr x) ,@(cddr x))
 932					 (caddr x)))
 933			       (name (lookup var)))
 934                          (##sys#put/restore! name '##sys#override 'syntax)
 935			  (##sys#register-syntax-export name (##sys#current-module) body)
 936			  (##sys#extend-macro-environment
 937			   name
 938			   (##sys#current-environment)
 939			   (##sys#eval/meta body))
 940			  (walk
 941			   (if ##sys#enable-runtime-macros
 942			       `(##sys#extend-macro-environment
 943				 (##core#quote ,var)
 944				 (##sys#current-environment) ,body) ;XXX possibly wrong se?
 945			       '(##core#undefined) )
 946			   e dest ldest h ln #f)) )
 947
 948                       ((##core#define-compiler-syntax)
 949                        (let* ((var (cadr x))
 950                               (body (caddr x))
 951                               (name (lookup var)))
 952                          (when body
 953                            (set! compiler-syntax
 954                              (alist-cons
 955                               name
 956                               (##sys#get name '##compiler#compiler-syntax)
 957                               compiler-syntax)))
 958                          (##sys#put!
 959                           name '##compiler#compiler-syntax
 960                           (and body
 961                                (##sys#cons
 962                                 (##sys#ensure-transformer
 963                                  (##sys#eval/meta body)
 964                                  var)
 965                                 (##sys#current-environment))))
 966                          (walk
 967                           (if ##sys#enable-runtime-macros
 968                               `(##sys#put!
 969                                (##core#syntax ,name)
 970                                '##compiler#compiler-syntax
 971                                ,(and body
 972                                      `(##sys#cons
 973                                        (##sys#ensure-transformer
 974                                         ,body
 975                                         (##core#quote ,var))
 976                                        (##sys#current-environment))))
 977                               '(##core#undefined) )
 978                           e dest ldest h ln #f)))
 979
 980		       ((##core#let-compiler-syntax)
 981			(let ((bs (map
 982				   (lambda (b)
 983				     (##sys#check-syntax
 984				      'let-compiler-syntax b '(symbol . #(_ 0 1)))
 985				     (let ((name (lookup (car b))))
 986				       (list
 987					name
 988					(and (pair? (cdr b))
 989					     (cons (##sys#ensure-transformer
 990						    (##sys#eval/meta (cadr b))
 991						    (car b))
 992						   (##sys#current-environment)))
 993					(##sys#get name '##compiler#compiler-syntax) ) ) )
 994				   (cadr x)))
 995			      (ln (or (get-line-number x) outer-ln)))
 996			  (dynamic-wind
 997			      (lambda ()
 998				(for-each
 999				 (lambda (b)
 1000				   (##sys#put! (car b) '##compiler#compiler-syntax (cadr b)))
1001				 bs) )
1002			      (lambda ()
1003				(walk
1004				 (canonicalize-body/ln
1005				  ln (cddr x) compiler-syntax-enabled)
1006				 e dest ldest h ln tl?) )
1007			      (lambda ()
1008				(for-each
1009				 (lambda (b)
1010				   (##sys#put!
1011				    (car b)
1012				    '##compiler#compiler-syntax (caddr b)))
1013				 bs) ) ) ) )
1014
1015		       ((##core#include)
1016                        (include-file x #f e dest ldest h ln tl?))
1017
1018		       ((##core#include-ci)
1019                        (include-file x #t e dest ldest h ln tl?))
1020
1021		       ((##core#let-module-alias)
1022			(##sys#with-module-aliases
1023			 (map (lambda (b)
1024				(##sys#check-syntax 'functor b '(symbol symbol))
1025				(strip-syntax b))
1026			      (cadr x))
1027			 (lambda ()
1028			   (walk `(##core#begin ,@(cddr x)) e dest ldest h ln #t))))
1029
1030		       ((##core#module)
1031			(let* ((name (strip-syntax (cadr x)))
1032			       (il  (or (assq name import-libraries) all-import-libraries))
1033			       (lib (and (not standalone-executable) il (or unit-name name)))
1034			       (mod (##sys#register-module
1035				     name lib
1036				     (or (eq? #t (caddr x))
1037					 (map (lambda (exp)
1038						(cond ((symbol? exp) exp)
1039						      ((and (pair? exp)
1040							    (let loop ((exp exp))
1041							      (or (null? exp)
1042								  (and (symbol? (car exp))
1043								       (loop (cdr exp))))))
1044						       exp)
1045						      (else
1046						       (##sys#syntax-error
1047							'module
1048							"invalid export syntax" exp name))))
1049					      (strip-syntax (caddr x))))))
1050			       (csyntax compiler-syntax))
1051			  (when (##sys#current-module)
1052			    (##sys#syntax-error
1053			     'module "modules may not be nested" name))
1054			  (let ((body (parameterize ((##sys#current-module mod)
1055						     (##sys#current-environment '())
1056						     (##sys#macro-environment
1057						      ##sys#initial-macro-environment)
1058						     (##sys#module-alias-environment
1059						      (##sys#module-alias-environment)))
1060					(##sys#with-property-restore
1061					 (lambda ()
1062					   (let loop ((body (cdddr x)) (xs '()))
1063					     (if (null? body)
1064						 (handle-exceptions ex
1065						     (begin
1066						       ;; avoid backtrace
1067						       (print-error-message ex (current-error-port))
1068						       (exit 1))
1069						   (##sys#finalize-module
1070						    mod
1071						    (lambda (id)
1072						      (cond
1073							((assq id foreign-variables)
1074							 "a foreign variable")
1075							((hash-table-ref inline-table id)
1076							 "an inlined function")
1077							((hash-table-ref constant-table id)
1078							 "a constant")
1079							((##sys#get id '##compiler#type-abbreviation)
1080							 "a type abbreviation")
1081							(else #f))))
1082						   (reverse xs))
1083						 (loop
1084						  (cdr body)
1085						  (cons (walk (car body)
1086							      e #f #f
1087							      h ln #t) ; reset to toplevel!
1088							xs)))))))))
1089			    (do ((cs compiler-syntax (cdr cs)))
1090				((eq? cs csyntax) (set! compiler-syntax csyntax))
1091			      (##sys#put! (caar cs) '##compiler#compiler-syntax (cdar cs)))
1092			    (when il
1093			      (emit-import-lib name mod il)
1094			      (when (pair? il)
1095				(set! import-libraries
1096				  (delete il import-libraries equal?))))
1097			    (canonicalize-begin-body
1098			     (append
1099			      (list (list '##core#provide (module-requirement name)))
1100			      (if (or (eq? compile-module-registration 'yes)
1101				      (and (not il) ; default behaviour
1102					   (not compile-module-registration)))
1103				  (parameterize ((##sys#macro-environment
1104						  (##sys#meta-macro-environment))
1105						 (##sys#current-environment ; ???
1106						  (##sys#current-meta-environment)))
1107				    (map (lambda (x) (walk x e #f #f h ln tl?))
1108					 (##sys#compiled-module-registration
1109					  mod
1110					  (if static-extensions 'static 'dynamic))))
1111			          '())
1112			      body)))))
1113
1114		       ((##core#loop-lambda) ;XXX is this really needed?
1115			(let* ((vars (cadr x))
1116			       (obody (cddr x))
1117			       (aliases (map gensym vars))
1118			       (se2 (##sys#extend-se (##sys#current-environment) vars aliases))
1119			       (ln (or (get-line-number x) outer-ln))
1120			       (body
1121				(parameterize ((##sys#current-environment se2))
1122				  (walk
1123				   (canonicalize-body/ln ln obody compiler-syntax-enabled)
1124				   (append aliases e)
1125				   #f #f dest ln #f)) ) )
1126			  (set-real-names! aliases vars)
1127			  `(##core#lambda ,aliases ,body) ) )
1128
1129		       ((##core#ensure-toplevel-definition)
1130                         (let* ((var0 (cadr x))
1131                                (var (lookup var0)))
1132                           (unless tl?
1133                             (let ((ln (get-line-number x)))
1134                               (quit-compiling
1135                                 "~atoplevel definition of `~s' in non-toplevel context"
1136                                (if ln (sprintf "(~a) - " ln) "")
1137                                var)))
1138                           (##sys#put/restore! var '##sys#override 'value)
1139                           '(##core#undefined)))
1140
1141		       ((##core#set!)
1142			(let* ((var0 (cadr x))
1143			       (var (lookup var0))
1144			       (ln (get-line-number x))
1145			       (val (caddr x)))
1146			  (when (memq var unlikely-variables)
1147			    (warning
1148			     (sprintf "~aassignment to variable `~s' possibly unintended"
1149			       (if ln (sprintf "(~a) - " ln) "")
1150			       var)))
1151			  (cond ((assq var foreign-variables)
1152				 => (lambda (fv)
1153				      (let ((type (second fv))
1154					    (tmp (gensym)))
1155					(walk
1156					 `(##core#let ((,tmp ,(foreign-type-convert-argument val type)))
1157					    (##core#inline_update
1158					     (,(third fv) ,type)
1159					     ,(foreign-type-check tmp type)))
1160					 e #f #f h ln #f))))
1161				((assq var location-pointer-map)
1162				 => (lambda (a)
1163				      (let* ((type (third a))
1164					     (tmp (gensym)))
1165					(walk
1166					 `(##core#let ((,tmp ,(foreign-type-convert-argument val type)))
1167					    (##core#inline_loc_update
1168					     (,type)
1169					     ,(second a)
1170					     ,(foreign-type-check tmp type)))
1171					 e #f #f h ln #f))))
1172				(else
1173				 (unless (memq var e) ; global?
1174				   (set! var (##sys#alias-global-hook var #t dest))
1175				   (when safe-globals-flag
1176				     (mark-variable var '##compiler#always-bound-to-procedure)
1177				     (mark-variable var '##compiler#always-bound))
1178				   (when emit-debug-info
1179				     (set! val
1180				       `(##core#let ((,(gensym) (##core#debug-event C_DEBUG_GLOBAL_ASSIGN (##core#quote ,var))))
1181					  ,val)))
1182				   ;; We use `var0` instead of `var` because the {macro,current}-environment
1183				   ;; are keyed by the raw and unqualified name
1184				   (cond ((##sys#macro? var0 (##sys#current-environment))
1185					  (warning
1186					   (sprintf "~aassignment to syntax `~S'"
1187					    (if ln (sprintf "(~a) - " ln) "") var0))
1188					  (when undefine-shadowed-macros
1189					    (##sys#undefine-macro! var0)
1190					    (##sys#unregister-syntax-export var0 (##sys#current-module))))
1191					 ((assq var0 (##sys#current-environment))
1192					  (warning
1193					   (sprintf "~aassignment to imported value binding `~S'"
1194					    (if ln (sprintf "(~a) - " ln) "") var0)))))
1195				 `(set! ,var ,(walk val e var0 (memq var e) h ln #f))))))
1196
1197			((##core#debug-event)
1198			 `(##core#debug-event
1199			   ,(cadr x)
1200			   ,ln ; this arg is added - from this phase on ##core#debug-event has an additional argument!
1201			   ,@(map (lambda (arg)
1202				    (unquotify (walk arg e #f #f h ln tl?)))
1203				  (cddr x))))
1204
1205			((##core#inline)
1206			 `(##core#inline
1207			   ,(unquotify (cadr x)) ,@(mapwalk (cddr x) e h ln #f)))
1208
1209			((##core#inline_allocate)
1210			 `(##core#inline_allocate
1211			   ,(map unquotify (second x))
1212			   ,@(mapwalk (cddr x) e h ln #f)))
1213
1214			((##core#inline_update)
1215			 `(##core#inline_update ,(cadr x) ,(walk (caddr x) e #f #f h ln #f)) )
1216
1217			((##core#inline_loc_update)
1218			 `(##core#inline_loc_update
1219			   ,(cadr x)
1220			   ,(walk (caddr x) e #f #f h ln #f)
1221			   ,(walk (cadddr x) e #f #f h ln #f)) )
1222
1223			((##core#compiletimetoo ##core#elaborationtimetoo)
1224			 (let ((exp (cadr x)))
1225			   (##sys#eval/meta exp)
1226			   (walk exp e dest #f h ln tl?) ) )
1227
1228			((##core#compiletimeonly ##core#elaborationtimeonly)
1229			 (##sys#eval/meta (cadr x))
1230			 '(##core#undefined) )
1231
1232			((##core#begin)
1233			 (if (pair? (cdr x))
1234			     (canonicalize-begin-body
1235			      (let fold ([xs (cdr x)])
1236				(let ([x (car xs)]
1237				      [r (cdr xs)] )
1238				  (if (null? r)
1239				      (list (walk x e dest ldest h ln tl?))
1240				      (cons (walk x e #f #f h ln tl?) (fold r)) ) ) ) )
1241			     '(##core#undefined) ) )
1242
1243			((##core#foreign-lambda)
1244			 (walk (expand-foreign-lambda x #f) e dest ldest h ln #f) )
1245
1246			((##core#foreign-safe-lambda)
1247			 (walk (expand-foreign-lambda x #t) e dest ldest h ln #f) )
1248
1249			((##core#foreign-lambda*)
1250			 (walk (expand-foreign-lambda* x #f) e dest ldest h ln #f) )
1251
1252			((##core#foreign-safe-lambda*)
1253			 (walk (expand-foreign-lambda* x #t) e dest ldest h ln #f) )
1254
1255			((##core#foreign-primitive)
1256			 (walk (expand-foreign-primitive x) e dest ldest h ln #f) )
1257
1258			((##core#define-foreign-variable)
1259			 (let* ((var (strip-syntax (second x)))
1260				(type (strip-syntax (third x)))
1261				(name (if (pair? (cdddr x))
1262					  (fourth x)
1263					  (symbol->string var))))
1264			   (set! foreign-variables
1265			     (cons (list var type name)
1266				   foreign-variables))
1267			   '(##core#undefined) ) )
1268
1269			((##core#define-foreign-type)
1270			 (let ((name (second x))
1271			       (type (strip-syntax (third x)))
1272			       (conv (cdddr x)))
1273			   (unless tl?
1274			     (quit-compiling
1275			      "~adefinition of foreign type `~s' in non-toplevel context"
1276			      (if ln (sprintf "(~a) - " ln) "")
1277			      name))
1278			   (cond [(pair? conv)
1279				  (let ([arg (gensym)]
1280					[ret (gensym)] )
1281				    (register-foreign-type! name type arg ret)
1282				    (mark-variable arg '##compiler#always-bound)
1283				    (mark-variable ret '##compiler#always-bound)
1284				    (hide-variable arg)
1285				    (hide-variable ret)
1286				    ;; NOTE: Above we already check we're in toplevel context,
1287				    ;; so we can unconditionally register the export here.
1288				    ;; TODO: Remove after fixing #1615
1289				    (##sys#register-export arg (##sys#current-module))
1290				    (##sys#register-export ret (##sys#current-module))
1291				    (walk
1292				     `(##core#begin
1293					(##core#set! ,arg ,(first conv))
1294					(##core#set!
1295					 ,ret
1296					 ,(if (pair? (cdr conv)) (second conv) '##sys#values)) )
1297				     e dest ldest h ln tl?))]
1298				 [else
1299				  (register-foreign-type! name type)
1300				  '(##core#undefined) ] ) ) )
1301
1302			((##core#define-external-variable)
1303			 (let* ((sym (second x))
1304				(ln (get-line-number x))
1305				(name (symbol->string sym))
1306				(type (third x))
1307				(exported (fourth x))
1308				(rname (make-random-name)) )
1309			   (unless tl?
1310			     (quit-compiling
1311			      "~aexternal variable definition of `~s' in non-toplevel context"
1312			      (if ln (sprintf "(~a) - " ln) "")
1313			      sym))
1314			   (unless exported (set! name (symbol->string (fifth x))))
1315			   (set! external-variables (cons (vector name type exported) external-variables))
1316			   (set! foreign-variables
1317			     (cons (list rname 'c-pointer (string-append "&" name))
1318				   foreign-variables) )
1319			   (set! external-to-pointer (alist-cons sym rname external-to-pointer))
1320			   '(##core#undefined) ) )
1321
1322			((##core#let-location)
1323			 (let* ((var (second x))
1324				(type (strip-syntax (third x)))
1325				(alias (gensym))
1326				(store (gensym))
1327				(init (and (pair? (cddddr x)) (fourth x))))
1328			   (set-real-name! alias var)
1329			   (set! location-pointer-map
1330			     (cons (list alias store type) location-pointer-map) )
1331			   (parameterize ((##sys#current-environment
1332					   (alist-cons var alias (##sys#current-environment))))
1333			    (walk
1334			     `(##core#let (,(let ((size (bytes->words (estimate-foreign-result-location-size type))))
1335				       ;; Add 2 words: 1 for the header, 1 for double-alignment:
1336				       ;; Note: C_a_i_bytevector takes number of words, not bytes
1337				       (list
1338					store
1339					`(##core#inline_allocate
1340					  ("C_a_i_bytevector" ,(+ 2 size))
1341					  ',size)) ) )
1342				(##core#begin
1343				 ,@(if init
1344				       `((##core#set! ,alias ,init))
1345				       '() )
1346				 ,(if init (fifth x) (fourth x)) ) )
1347			     e
1348			     dest ldest h ln #f)) ) )
1349
1350			((##core#define-inline)
1351			 (let* ((name (second x))
1352				(val `(##core#lambda ,@(cdaddr x)))
1353				(ln (get-line-number x)))
1354			   (unless tl?
1355			     (quit-compiling
1356			      "~ainline definition of `~s' in non-toplevel context"
1357			      (if ln (sprintf "(~a) - " ln) "")
1358			      name))
1359			     (hash-table-set! inline-table name val)
1360			     '(##core#undefined)))
1361
1362			((##core#define-constant)
1363			 (let* ((name (second x))
1364				(ln (get-line-number x))
1365				(valexp (third x))
1366				(val (handle-exceptions ex
1367					 ;; could show line number here
1368					 (quit-compiling "error in constant evaluation of ~S for named constant `~S'"
1369					       valexp name)
1370				       (if (and (not (symbol? valexp))
1371						(collapsable-literal? valexp))
1372					   valexp
1373					   (eval
1374					    `(##core#let
1375					      ,defconstant-bindings ,valexp))))))
1376			   (unless tl?
1377			     (quit-compiling
1378			      "~aconstant definition of `~s' in non-toplevel context"
1379			      (if ln (sprintf "(~a) - " ln) "")
1380			      name))
1381			   (set! defconstant-bindings
1382			     (cons (list name `(##core#quote ,val)) defconstant-bindings))
1383			   (cond ((collapsable-literal? val)
1384				  (hash-table-set! constant-table name `(##core#quote ,val))
1385				  '(##core#undefined))
1386				 ((basic-literal? val)
1387				  (let ((var (gensym "constant")))
1388				    (hash-table-set! constant-table name var)
1389				    (hide-variable var)
1390				    (mark-variable var '##compiler#constant)
1391				    (mark-variable var '##compiler#always-bound)
1392				    (walk `(define ,var (##core#quote ,val)) e #f #f h ln tl?)))
1393				 (else
1394				  (quit-compiling
1395				   "~ainvalid compile-time value for named constant `~S'"
1396				   (if ln (sprintf "(~a) - " ln) "")
1397				   name)))))
1398
1399			((##core#declare)
1400			 (walk
1401			  `(##core#begin
1402			    ,@(map (lambda (d)
1403				     (process-declaration d lookup (lambda (id) (memq (lookup id) e))))
1404				   (cdr x) ) )
1405			  e #f #f h ln #f) )
1406
1407			((##core#foreign-callback-wrapper)
1408			 (let-values ([(args lam) (split-at (cdr x) 4)])
1409			   (let* ([lam (car lam)]
1410				  [raw-c-name (cadr (first args))]
1411				  [name (##sys#alias-global-hook raw-c-name #t dest)]
1412				  [rtype (cadr (third args))]
1413				  [atypes (cadr (fourth args))]
1414				  [vars (second lam)] )
1415			     (if (valid-c-identifier? raw-c-name)
1416				 (set! callback-names
1417				   (cons (cons raw-c-name name) callback-names))
1418				 (let ((ln (get-line-number x)))
1419				   (quit-compiling
1420				    "~aname `~S' of external definition is not a valid C identifier"
1421				    (if ln (sprintf "(~a) - " ln) "")
1422				    raw-c-name)))
1423			     (when (or (not (list? vars))
1424				       (not (list? atypes))
1425				       (not (= (length vars) (length atypes))) )
1426			       (##sys#syntax-error
1427				"non-matching or invalid argument list to foreign callback-wrapper"
1428				vars atypes) )
1429			     `(##core#foreign-callback-wrapper
1430			       ,@(mapwalk args e h ln #f)
1431			       ,(walk `(##core#lambda
1432					,vars
1433					(##core#let
1434					 ,(let loop ([vars vars] [types atypes])
1435					    (if (null? vars)
1436						'()
1437						(let ([var (car vars)]
1438						      [type (car types)] )
1439						  (cons
1440						   (list
1441						    var
1442						    (foreign-type-convert-result
1443						     (finish-foreign-result
1444						      (final-foreign-type type)
1445						      var)
1446						     type) )
1447						   (loop (cdr vars) (cdr types)) ) ) ) )
1448					 ,(foreign-type-convert-argument
1449					   `(##core#let
1450					     ()
1451					     ,@(cond
1452						((member
1453						  rtype
1454						  '((const nonnull-c-string)
1455						    (const nonnull-unsigned-c-string)
1456						    nonnull-unsigned-c-string
1457						    nonnull-c-string))
1458						 `((##sys#make-c-string
1459						    (##core#let
1460						     () ,@(cddr lam))
1461						    (##core#quote ,name))))
1462						((member
1463						  rtype
1464						  '((const c-string*)
1465						    (const unsigned-c-string*)
1466						    unsigned-c-string*
1467						    c-string*
1468						    c-string-list
1469						    c-string-list*))
1470						 (##sys#syntax-error
1471						  "not a valid result type for callback procedures"
1472						  rtype
1473						  name) )
1474						((member
1475						  rtype
1476						  '(c-string
1477						    (const unsigned-c-string)
1478						    unsigned-c-string
1479						    (const c-string)) )
1480						 `((##core#let
1481						    ((r (##core#let () ,@(cddr lam))))
1482						    (,(macro-alias 'and)
1483						     r
1484						     (##sys#make-c-string r (##core#quote ,name))) ) ) )
1485						(else (cddr lam)) ) )
1486					   rtype) ) )
1487				      e #f #f h ln #f) ) ) ) )
1488
1489			((##core#location)
1490			 (let ([sym (cadr x)])
1491			   (if (symbol? sym)
1492			       (cond ((assq (lookup sym) location-pointer-map)
1493				      => (lambda (a)
1494					   (walk
1495					    `(##sys#make-locative ,(second a) 0 #f (##core#quote location))
1496					    e #f #f h ln #f) ) )
1497				     ((assq sym external-to-pointer)
1498				      => (lambda (a) (walk (cdr a) e #f #f h ln #f)) )
1499				     ((assq sym callback-names)
1500				      `(##core#inline_ref (,(symbol->string sym) c-pointer)) )
1501				     (else
1502				      (walk
1503				       `(##sys#make-locative ,sym 0 #f (##core#quote location))
1504				       e #f #f h ln #f) ) )
1505			       (walk
1506				`(##sys#make-locative ,sym 0 #f (##core#quote location))
1507				e #f #f h ln #f) ) ) )
1508
1509			(else
1510			 (let* ((x2 (fluid-let ((##sys#syntax-context
1511						 (cons name ##sys#syntax-context)))
1512				      (mapwalk x e h ln tl?)))
1513				(head2 (car x2))
1514				(old (hash-table-ref line-number-database-2 head2)))
1515			   (when ln
1516			     (hash-table-set!
1517			      line-number-database-2
1518			      head2
1519			      (cons name (alist-cons x2 ln (if old (cdr old) '()))) ) )
1520			   x2))))))))
1521
1522	  ((not (list? x))
1523	   (##sys#syntax-error/context "malformed expression" x) )
1524
1525	  ((constant? (car x))
1526	   (emit-syntax-trace-info x #f)
1527	   (warning "literal in operator position" x)
1528	   (mapwalk x e h outer-ln tl?) )
1529
1530	  (else
1531	   (emit-syntax-trace-info x #f)
1532	   (let ((tmp (gensym)))
1533	     (walk
1534	      `(##core#let
1535		((,tmp ,(car x)))
1536		(,tmp ,@(cdr x)))
1537	      e dest ldest h outer-ln #f)))))
1538
1539  (define (mapwalk xs e h ln tl?)
1540    (map (lambda (x) (walk x e #f #f h ln tl?)) xs) )
1541
1542  (when (memq 'c debugging-chicken) (newline) (pretty-print exp))
1543  (foreign-code "C_clear_trace_buffer();")
1544  ;; Process visited definitions and main expression:
1545  (walk
1546   `(##core#begin
1547     ,@(let ([p (reverse pending-canonicalizations)])
1548	 (set! pending-canonicalizations '())
1549	 p)
1550     ,(begin
1551	(set! extended-bindings (append internal-bindings extended-bindings))
1552	exp) )
1553   '() #f #f #f #f #t) ) )
1554
1555
1556(define (process-declaration spec lookup local?)
1557  (define (check-decl spec minlen . maxlen)
1558    (let ([n (length (cdr spec))])
1559      (if (or (< n minlen) (> n (optional maxlen 99999)))
1560	  (##sys#syntax-error "invalid declaration" spec) ) ) )
1561  (define (globalize var)
1562    (cond ((local? var)
1563	   (note-local var)
1564	   #f)
1565	  (else (##sys#alias-global-hook (lookup var) #t #f))))
1566  (define (globalize-all vars)
1567    (filter-map globalize vars))
1568  (define (note-local var)
1569    (##sys#notice
1570     (sprintf "ignoring declaration for locally bound variable `~a'" var)))
1571  (call-with-current-continuation
1572   (lambda (return)
1573     (unless (pair? spec)
1574       (##sys#syntax-error "invalid declaration specification" spec) )
1575     (case (strip-syntax (car spec)) ; no global aliasing
1576       ((uses)
1577	(let ((units (strip-syntax (cdr spec))))
1578	  (set! used-libraries (lset-union/eq? used-libraries units))
1579	  (set! linked-libraries (lset-union/eq? linked-libraries units))))
1580       ((unit)
1581	(check-decl spec 1 1)
1582	(let ((u (strip-syntax (cadr spec))))
1583	  (when (and unit-name (not (eq? unit-name u)))
1584	    (warning "unit was already given a name (new name is ignored)"))
1585	  (set! unit-name u)
1586	  (set! standalone-executable #f)))
1587       ((standard-bindings)
1588	(if (null? (cdr spec))
1589	    (set! standard-bindings default-standard-bindings)
1590	    (set! standard-bindings (append (globalize-all (cdr spec)) standard-bindings)) ) )
1591       ((extended-bindings)
1592	(if (null? (cdr spec))
1593	    (set! extended-bindings default-extended-bindings)
1594	    (set! extended-bindings (append (globalize-all (cdr spec)) extended-bindings)) ) )
1595       ((usual-integrations)
1596	(cond [(null? (cdr spec))
1597	       (set! standard-bindings default-standard-bindings)
1598	       (set! extended-bindings default-extended-bindings) ]
1599	      [else
1600	       (let ([syms (globalize-all (cdr spec))])
1601		 (set! standard-bindings (lset-intersection/eq? syms default-standard-bindings))
1602		 (set! extended-bindings (lset-intersection/eq? syms default-extended-bindings)))]))
1603       ((number-type)
1604	(check-decl spec 1 1)
1605	(set! number-type (strip-syntax (cadr spec))))
1606       ((fixnum fixnum-arithmetic) (set! number-type 'fixnum))
1607       ((generic) (set! number-type 'generic))
1608       ((unsafe) (set! unsafe #t))
1609       ((safe) (set! unsafe #f))
1610       ((no-bound-checks) (set! no-bound-checks #t))
1611       ((no-argc-checks) (set! no-argc-checks #t))
1612       ((no-procedure-checks) (set! no-procedure-checks #t))
1613       ((disable-interrupts) (set! insert-timer-checks #f))
1614       ((always-bound)
1615	(for-each (cut mark-variable <> '##compiler#always-bound) (cdr spec)))
1616       ((safe-globals) (set! safe-globals-flag #t))
1617       ((no-procedure-checks-for-usual-bindings)
1618	(for-each
1619	 (cut mark-variable <> '##compiler#always-bound-to-procedure)
1620	 (append default-standard-bindings default-extended-bindings))
1621	(for-each
1622	 (cut mark-variable <> '##compiler#always-bound)
1623	 (append default-standard-bindings default-extended-bindings)))
1624       ((no-procedure-checks-for-toplevel-bindings)
1625	(set! no-global-procedure-checks #t))
1626       ((bound-to-procedure)
1627	(let ((vars (globalize-all (cdr spec))))
1628	  (for-each (cut mark-variable <> '##compiler#always-bound-to-procedure) vars)
1629	  (for-each (cut mark-variable <> '##compiler#always-bound) vars)))
1630       ((foreign-declare)
1631	(let ([fds (cdr spec)])
1632	  (if (every string? fds)
1633	      (set! foreign-declarations (append foreign-declarations fds))
1634	      (##sys#syntax-error 'declare "invalid declaration" spec) ) ) )
1635       ((block) (set! block-compilation #t))
1636       ((separate) (set! block-compilation #f))
1637       ((keep-shadowed-macros) (set! undefine-shadowed-macros #f))
1638       ((unused)
1639	(for-each (cut mark-variable <> '##compiler#unused) (globalize-all (cdr spec))))
1640       ((enforce-argument-types)
1641	(for-each
1642	 (cut mark-variable <> '##compiler#enforce)
1643	 (globalize-all (cdr spec))))
1644       ((not)
1645	(check-decl spec 1)
1646	(case (strip-syntax (second spec)) ; strip all
1647	  [(standard-bindings)
1648	   (if (null? (cddr spec))
1649	       (set! standard-bindings '())
1650	       (set! standard-bindings
1651		 (lset-difference/eq? default-standard-bindings
1652				      (globalize-all (cddr spec)))))]
1653	  [(extended-bindings)
1654	   (if (null? (cddr spec))
1655	       (set! extended-bindings '())
1656	       (set! extended-bindings
1657		 (lset-difference/eq? default-extended-bindings
1658				      (globalize-all (cddr spec)))))]
1659	  [(inline)
1660	   (if (null? (cddr spec))
1661	       (set! inline-locally #f)
1662	       (for-each
1663		(cut mark-variable <> '##compiler#inline 'no)
1664		(globalize-all (cddr spec)))) ]
1665	  [(usual-integrations)
1666	   (cond [(null? (cddr spec))
1667		  (set! standard-bindings '())
1668		  (set! extended-bindings '()) ]
1669		 [else
1670		  (let ([syms (globalize-all (cddr spec))])
1671		    (set! standard-bindings (lset-difference/eq? default-standard-bindings syms))
1672		    (set! extended-bindings (lset-difference/eq? default-extended-bindings syms)))])]
1673	  ((inline-global)
1674	   (set! enable-inline-files #t)
1675	   (when (pair? (cddr spec))
1676	     (for-each
1677	      (cut mark-variable <> '##compiler#inline-global 'no)
1678	      (globalize-all (cddr spec)))))
1679	  [else
1680	   (check-decl spec 1 1)
1681	   (let ((id (strip-syntax (cadr spec))))
1682	     (case id
1683	       [(safe) (set! unsafe #t)]
1684	       [else (warning "unsupported declaration specifier" id)]))]))
1685       ((compile-syntax)
1686	(set! ##sys#enable-runtime-macros #t))
1687       ((block-global hide)
1688	(let ([syms (globalize-all (cdr spec))])
1689	  (if (null? syms)
1690	      (set! block-compilation #t)
1691	      (for-each hide-variable syms))))
1692       ((export)
1693	(set! block-compilation #t)
1694	(let ((syms (globalize-all (cdr spec))))
1695	  (for-each export-variable syms)))
1696       ((emit-external-prototypes-first)
1697	(set! external-protos-first #t) )
1698       ((inline)
1699	(if (null? (cdr spec))
1700	    (set! inline-locally #t)
1701	    (for-each
1702	     (cut mark-variable <> '##compiler#local)
1703	     (globalize-all (cdr spec)))))
1704       ((inline-limit)
1705	(check-decl spec 1 1)
1706	(let ([n (cadr spec)])
1707	  (if (number? n)
1708	      (set! inline-max-size n)
1709	      (warning
1710	       "invalid argument to `inline-limit' declaration"
1711	       spec) ) ) )
1712       ((unroll-limit)
1713	(check-decl spec 1 1)
1714	(let ((n (cadr spec)))
1715	  (if (number? n)
1716	      (set! unroll-limit n)
1717	      (warning
1718	       "invalid argument to `unroll-limit' declaration"
1719	       spec) ) ) )
1720       ((pure)
1721	(let ((syms (globalize-all (cdr spec))))
1722	  (if (every symbol? syms)
1723	      (for-each
1724	       (cut mark-variable <> '##compiler#pure #t)
1725	       (globalize-all syms))
1726	      (quit-compiling
1727	       "invalid arguments to `pure' declaration: ~S" spec))))
1728       ((emit-import-library)
1729	(set! import-libraries
1730	  (append
1731	   import-libraries
1732	   (map (lambda (il)
1733		  (cond ((symbol? il)
1734			 (cons il (string-append (symbol->string il) ".import.scm")) )
1735			((and (list? il) (= 2 (length il))
1736			      (symbol? (car il)) (string? (cadr il)))
1737			 (cons (car il) (cadr il)))
1738			(else
1739			 (quit-compiling "invalid `import-library' specification: ~S" il))))
1740		(strip-syntax (cdr spec))))))
1741	((emit-types-file)
1742	 (unless types-output-file
1743	   (set! types-output-file
1744	     (or (null? (cdr spec))
1745		 (and (string? (cadr spec)) (null? (cddr spec)) (cadr spec))
1746		 (quit-compiling "invalid `emit-types-file' declaration: ~S" spec)))))
1747       ((profile)
1748	(set! emit-profile #t)
1749	(cond ((null? (cdr spec))
1750	       (set! profiled-procedures 'all) )
1751	      (else
1752	       (set! profiled-procedures 'some)
1753	       (for-each
1754		(cut mark-variable <> '##compiler#profile)
1755		(globalize-all (cdr spec))))))
1756       ((local)
1757	(cond ((null? (cdr spec))
1758	       (set! local-definitions #t) )
1759	      (else
1760	       (for-each
1761		(cut mark-variable <> '##compiler#local)
1762		(globalize-all (cdr spec))))))
1763       ((inline-global)
1764	(set! enable-inline-files #t)
1765	(set! inline-locally #t)
1766	(when (pair? (cdr spec))
1767	  (for-each
1768	   (cut mark-variable <> '##compiler#inline-global 'yes)
1769	   (globalize-all (cdr spec)))))
1770       ((type)
1771	(for-each
1772	 (lambda (spec)
1773	   (if (not (and (list? spec)
1774			 (>= (length spec) 2)
1775			 (symbol? (car spec))))
1776	       (warning "illegal type declaration" (strip-syntax spec))
1777	       (let ((name (globalize (car spec)))
1778		     (type (strip-syntax (cadr spec))))
1779		 (if (local? (car spec))
1780		     (note-local (car spec))
1781		     (let-values (((type pred pure) (validate-type type name)))
1782		       (cond (type
1783			      ;; HACK: since `:' doesn't have access to the SE, we
1784			      ;; fixup the procedure name if type is a named procedure type
1785			      ;; Quite terrible.
1786			      (when (and (pair? type)
1787					 (eq? 'procedure (car type))
1788					 (symbol? (cadr type)))
1789				(set-car! (cdr type) name))
1790			      (mark-variable name '##compiler#type type)
1791			      (mark-variable name '##compiler#type-source 'local)
1792			      (when pure
1793				(mark-variable name '##compiler#pure #t))
1794			      (when pred
1795				(mark-variable name '##compiler#predicate pred))
1796			      (when (pair? (cddr spec))
1797				(install-specializations
1798				 name
1799				 (strip-syntax (cddr spec)))))
1800			     (else
1801			      (warning
1802			       "illegal `type' declaration"
1803			       (strip-syntax spec)))))))))
1804	 (cdr spec)))
1805       ((predicate)
1806	(for-each
1807	 (lambda (spec)
1808	   (cond ((and (list? spec) (symbol? (car spec)) (= 2 (length spec)))
1809		  (let ((name (globalize (car spec)))
1810			(type (strip-syntax (cadr spec))))
1811		    (if (local? (car spec))
1812			(note-local (car spec))
1813			(let-values (((type pred pure) (validate-type type name)))
1814			  (if (and type (not pred))
1815			      (mark-variable name '##compiler#predicate type)
1816			      (warning "illegal `predicate' declaration" spec))))))
1817		 (else
1818		  (warning "illegal `type' declaration item" spec))))
1819	 (cdr spec)))
1820       ((specialize)
1821	(set! enable-specialization #t))
1822       ((strict-types)
1823	(set! strict-variable-types #t))
1824       (else (warning "unknown declaration specifier" spec)) )
1825     '(##core#undefined) ) ) )
1826
1827
1828;;; Create entry procedure:
1829
1830(define (build-toplevel-procedure node)
1831  (make-node 'lambda '(()) (list node)))
1832
1833
1834;;; Expand "foreign-lambda"/"foreign-safe-lambda" forms and add item to stub-list:
1835
1836(define-record foreign-stub
1837  id			; symbol
1838  return-type	  ; type-specifier
1839  name 		  ; string or #f
1840  argument-types ; (type-specifier...)
1841  argument-names ; #f or (symbol ...)
1842  body		       ; #f or string
1843  cps		       ; boolean
1844  callback)	       ; boolean
1845
1846(define (create-foreign-stub rtype sname argtypes argnames body callback cps)
1847  ;; try to describe a foreign-lambda type specification
1848  ;; eg. (type->symbol '(c-pointer (struct "point"))) => point*
1849  (define (type->symbol type-spec)
1850    (let loop ([type type-spec])
1851      (cond
1852       ((null? type) 'a)
1853       ((list? type)
1854	(case (car type)
1855	  ((c-pointer) (string->symbol (conc (loop (cdr type)) "*"))) ;; if pointer, append *
1856	  ((const struct) (loop (cdr type))) ;; ignore these
1857	  (else (loop (car type)))))
1858       ((or (symbol? type) (string? type)) type)
1859       (else 'a))))
1860  (let* ((rtype (strip-syntax rtype))
1861	 (argtypes (strip-syntax argtypes))
1862	 (params (if argnames
1863		     (map gensym argnames)
1864		     (map (o gensym type->symbol) argtypes)))
1865	 (f-id (gensym 'stub))
1866	 (bufvar (gensym))
1867	 (rsize (estimate-foreign-result-size rtype)))
1868    (when sname (set-real-name! f-id (string->symbol sname)))
1869    (set! foreign-lambda-stubs
1870      (cons (make-foreign-stub f-id rtype sname argtypes argnames body cps callback)
1871	    foreign-lambda-stubs) )
1872    (let ([rsize (if callback (+ rsize 24) rsize)] ; 24 -> has to hold cons on 64-bit platforms!
1873	  [head (if cps
1874		    `((##core#primitive ,f-id))
1875		    `(##core#inline ,f-id) ) ]
1876	  [rest (map (lambda (p t) 
1877                       (foreign-type-check (foreign-type-convert-argument p t) t)) 
1878                     params argtypes)] )
1879      `(##core#lambda ,params
1880	 ;; Do minor GC (if callback) to make room on stack:
1881	 ,@(if callback '((##sys#gc #f)) '())
1882	 ,(if (zero? rsize)
1883	      (foreign-type-convert-result (append head (cons '(##core#undefined) rest)) rtype)
1884	      (let ([ft (final-foreign-type rtype)]
1885		    [ws (bytes->words rsize)] )
1886		`(##core#let ([,bufvar (##core#inline_allocate ("C_a_i_bytevector" ,(+ 2 ws)) (##core#quote ,ws))])
1887		   ,(foreign-type-convert-result
1888		     (finish-foreign-result ft (append head (cons bufvar rest)))
1889		     rtype) ) ) ) ) ) ) )
1890
1891(define (expand-foreign-lambda exp callback?)
1892  (let* ((name (third exp))
1893	 (sname (cond ((symbol? name) (symbol->string (strip-syntax name)))
1894		      ((string? name) name)
1895		      (else (quit-compiling
1896			     "name `~s' of foreign procedure has wrong type"
1897			     name)) ) )
1898	 (rtype (second exp))
1899	 (argtypes (cdddr exp)) )
1900    (create-foreign-stub rtype sname argtypes #f #f callback? callback?) ) )
1901
1902(define (expand-foreign-lambda* exp callback?)
1903  (let* ((rtype (second exp))
1904	 (args (third exp))
1905	 (body (string-intersperse (cdddr exp) "\n"))
1906 	 (argtypes (map (lambda (x) (car x)) args))
1907	 ;; C identifiers aren't hygienically renamed inside body strings
1908	 (argnames (map cadr (strip-syntax args))))
1909    (create-foreign-stub rtype #f argtypes argnames body callback? callback?) ) )
1910
1911;; TODO: Try to fold this procedure into expand-foreign-lambda*
1912(define (expand-foreign-primitive exp)
1913  (let* ((hasrtype (and (pair? (cddr exp)) (not (string? (caddr exp)))))
1914	 (rtype (if hasrtype (second exp) 'void))
1915	 (args (strip-syntax (if hasrtype (third exp) (second exp))))
1916	 (body (string-intersperse (if hasrtype (cdddr exp) (cddr exp)) "\n"))
1917 	 (argtypes (map (lambda (x) (car x)) args))
1918	 ;; C identifiers aren't hygienically renamed inside body strings
1919	 (argnames (map cadr (strip-syntax args))))
1920    (create-foreign-stub rtype #f argtypes argnames body #f #t) ) )
1921
1922
1923;;; Convert canonicalized node-graph into continuation-passing-style:
1924
1925(define (perform-cps-conversion node)
1926  (let ((called-units '()))
1927
1928  (define (cps-lambda id llist subs k)
1929    (let ([t1 (gensym 'k)])
1930      (k (make-node
1931	  '##core#lambda (list id #t (cons t1 llist) 0)
1932	  (list (walk (car subs)
1933		      (lambda (r)
1934			(make-node '##core#call (list #t) (list (varnode t1) r)) ) ) ) ) ) ) )
1935
1936  (define (node-for-var? node var)
1937     (and (eq? (node-class node) '##core#variable)
1938	  (eq? (car (node-parameters node)) var)))
1939
1940  (define (walk n k)
1941    (let ((subs (node-subexpressions n))
1942	  (params (node-parameters n))
1943	  (class (node-class n)) )
1944      (case (node-class n)
1945	((##core#variable quote ##core#undefined ##core#primitive ##core#provide)
1946          (k n))
1947	((if) (let* ((t1 (gensym 'k))
1948		     (t2 (gensym 'r))
1949		     (k1 (lambda (r) (make-node '##core#call (list #t) (list (varnode t1) r)))) )
1950		(make-node
1951		 'let
1952		 (list t1)
1953		 (list (make-node '##core#lambda (list (gensym-f-id) #f (list t2) 0)
1954				  (list (k (varnode t2))) )
1955		       (walk (car subs)
1956			     (lambda (v)
1957			       (make-node 'if '()
1958					  (list v
1959						(walk (cadr subs) k1)
1960						(walk (caddr subs) k1) ) ) ) ) ) ) ) )
1961	((let)
1962	 (let loop ((vars params) (vals subs))
1963	   (if (null? vars)
1964	       (walk (car vals) k)
1965	       (walk (car vals)
1966		     (lambda (r)
1967		       (if (node-for-var? r (car vars)) ; Don't generate unneccessary lets
1968			   (loop (cdr vars) (cdr vals))
1969			   (make-node 'let
1970				      (list (car vars))
1971				      (list r (loop (cdr vars) (cdr vals))) )) ) ) ) ) )
1972	((lambda ##core#lambda) (cps-lambda (gensym-f-id) (first params) subs k))
1973	((set!) (let* ((t1 (gensym 't))
1974		       (immediate? (and (pair? (cdr params)) (cadr params)))
1975		       (new-params (list (first params) immediate?)))
1976		  (walk (car subs)
1977			(lambda (r)
1978			  (make-node 'let (list t1)
1979				     (list (make-node 'set! new-params (list r))
1980					   (k (varnode t1)) ) ) ) ) ) )
1981	((##core#foreign-callback-wrapper)
1982	 (let ((id (gensym-f-id))
1983	       (lam (first subs)) )
1984	   (register-foreign-callback-stub! id params)
1985	   (cps-lambda id (first (node-parameters lam)) (node-subexpressions lam) k) ) )
1986	((##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update ##core#inline_loc_ref
1987			##core#inline_loc_update ##core#debug-event)
1988	 (walk-inline-call class params subs k) )
1989	((##core#call) (walk-call (car subs) (cdr subs) params k))
1990	((##core#callunit)
1991	 (let ((unit (first params)))
1992	   (if (memq unit called-units)
1993	       (walk (make-node '##core#undefined '() '()) k)
1994	       (fluid-let ((called-units (cons unit called-units)))
1995		 (walk-call-unit unit k)))))
1996	((##core#the ##core#the/result)
1997	 ;; remove "the" nodes, as they are not used after scrutiny
1998	 (walk (car subs) k))
1999	((##core#typecase)
2000	 ;; same here, the last clause is chosen, exp is dropped
2001	 (walk (last subs) k))
2002	(else (bomb "bad node (cps)")) ) ) )
2003
2004  (define (walk-call fn args params k)
2005    (let ((t0 (gensym 'k))
2006	  (t3 (gensym 'r)) )
2007      (make-node
2008       'let (list t0)
2009       (list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0)
2010			(list (k (varnode t3))) )
2011	     (walk-arguments
2012	      args
2013	      (lambda (vars)
2014		(walk fn
2015		      (lambda (r)
2016			(make-node '##core#call params (cons* r (varnode t0) vars) ) ) ) ) ) ) ) ) )
2017
2018  (define (walk-call-unit unitname k)
2019    (let ((t0 (gensym 'k))
2020	  (t3 (gensym 'r)) )
2021      (make-node
2022       'let (list t0)
2023       (list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0)
2024			(list (k (varnode t3))) )
2025	     (make-node '##core#callunit (list unitname)
2026			(list (varnode t0)) ) ) ) ) )
2027
2028  (define (walk-inline-call class op args k)
2029    (walk-arguments
2030     args
2031     (lambda (vars)
2032       (k (make-node class op vars)) ) ) )
2033
2034  (define (walk-arguments args wk)
2035    (let loop ((args args) (vars '()))
2036      (cond ((null? args) (wk (reverse vars)))
2037	    ((atomic? (car args))
2038	     (loop (cdr args) (cons (car args) vars)) )
2039	    (else
2040	     (let ((t1 (gensym 'a)))
2041	       (walk (car args)
2042		     (lambda (r)
2043		       (if (node-for-var? r t1) ; Don't generate unneccessary lets
2044			   (loop (cdr args) (cons (varnode t1) vars) )
2045			   (make-node 'let (list t1)
2046				      (list r
2047					    (loop (cdr args)
2048						  (cons (varnode t1) vars) ) ) )) ) ) ) ) ) ) )
2049
2050  (define (atomic? n)
2051    (let ((class (node-class n)))
2052      (or (memq class '(quote ##core#variable ##core#undefined))
2053	  (and (memq class '(##core#inline_allocate
2054			     ##core#inline_ref ##core#inline_update
2055			     ##core#inline_loc_ref ##core#inline_loc_update))
2056	       (every atomic? (node-subexpressions n)) ) ) ) )
2057
2058  (walk node values)))
2059
2060
2061;;; Perform source-code analysis:
2062
2063(define (analyze-expression node)
2064  ;; Avoid crowded hash tables by using previous run's size as heuristic
2065  (let* ((db-size (fx* (fxmax current-analysis-database-size 1) 3))
2066	 (db (make-vector db-size '())))
2067
2068    (define (grow n)
2069      (set! current-program-size (+ current-program-size n)) )
2070
2071    ;; fullenv is constantly (append localenv env). It's there to avoid
2072    ;; exponential behaviour by APPEND calls when compiling deeply nested LETs
2073    (define (walk n env localenv fullenv here)
2074      (let ((subs (node-subexpressions n))
2075	    (params (node-parameters n))
2076	    (class (node-class n)) )
2077	(grow 1)
2078	(case class
2079	  ((quote ##core#undefined ##core#provide ##core#proc) #f)
2080
2081	  ;; Uneliminated rest-cdr calls need to hang on to rest var
2082	  ((##core#variable ##core#rest-cdr)
2083	   (let ((var (first params)))
2084	     (ref var n)
2085	     (unless (memq var localenv)
2086	       (grow 1)
2087	       (cond ((memq var env)
2088		      (db-put! db var 'captured #t))
2089		     ((not (db-get db var 'global))
2090		      (db-put! db var 'global #t) ) ) ) ) )
2091
2092	  ((##core#callunit ##core#recurse)
2093	   (grow 1)
2094	   (walkeach subs env localenv fullenv here))
2095
2096	  ((##core#call)
2097	   (grow 1)
2098	   (let ([fun (car subs)])
2099	     (when (eq? '##core#variable (node-class fun))
2100	       (let* ((name (first (node-parameters fun)))
2101                      (val (db-get db name 'value)))
2102                 (when (and val
2103                            (eq? '##core#lambda (node-class val))
2104                            (not (llist-match? (third (node-parameters val))
2105                                               (cdr subs))))
2106                   (db-put! db name 'has-bad-calls #t))
2107		 (collect! db name 'call-sites (cons here n))))
2108	     (walk (first subs) env localenv fullenv here)
2109	     (walkeach (cdr subs) env localenv fullenv here)))
2110
2111	  ((let ##core#let)
2112	   (let ([env2 (append params fullenv)])
2113	     (let loop ([vars params] [vals subs])
2114	       (if (null? vars)
2115		   (walk (car vals) env (append params localenv) env2 here)
2116		   (let ([var (car vars)]
2117			 [val (car vals)] )
2118		     (db-put! db var 'home here)
2119		     (assign var val env2 here)
2120		     (walk val env localenv fullenv here)
2121		     (loop (cdr vars) (cdr vals)) ) ) ) ) )
2122
2123	  ((lambda) ; this is an intermediate lambda, slightly different
2124	   (grow 1) ; from '##core#lambda nodes (params = (LLIST));
2125	   (##sys#decompose-lambda-list	; CPS will convert this into ##core#lambda
2126	    (first params)
2127	    (lambda (vars argc rest)
2128	      (for-each
2129	       (lambda (var) (db-put! db var 'unknown #t))
2130	       vars)
2131	      (let ([tl toplevel-scope])
2132		(set! toplevel-scope #f)
2133		(walk (car subs) fullenv vars (append vars fullenv) #f)
2134		(set! toplevel-scope tl) ) ) ) )
2135
2136	  ((##core#lambda ##core#direct_lambda)
2137	   (grow 1)
2138	   (##sys#decompose-lambda-list
2139	    (third params)
2140	    (lambda (vars argc rest)
2141	      (let ([id (first params)]
2142		    [size0 current-program-size] )
2143		(when here
2144		  (collect! db here 'contains id)
2145		  (db-put! db id 'contained-in here) )
2146		(for-each
2147		 (lambda (var)
2148		   (db-put! db var 'home here)
2149		   (db-put! db var 'unknown #t) )
2150		 vars)
2151		(when rest
2152		  (db-put! db rest 'rest-parameter 'list)
2153		  (db-put! db rest 'rest-cdr (cons rest 0)))
2154		(when (simple-lambda-node? n) (db-put! db id 'simple #t))
2155		(let ([tl toplevel-scope])
2156		  (unless toplevel-lambda-id (set! toplevel-lambda-id id))
2157		  (when (and (second params) (not (eq? toplevel-lambda-id id)))
2158		    (set! toplevel-scope #f)) ; only if non-CPS lambda
2159		  (walk (car subs) fullenv vars (append vars fullenv) id)
2160		  (set! toplevel-scope tl)
2161		  ;; decorate ##core#call node with size
2162		  (set-car! (cdddr (node-parameters n)) (- current-program-size size0)) ) ) ) ) )
2163
2164	  ((set! ##core#set!) 		;XXX ##core#set! still used?
2165	   (let* ((var (first params))
2166		  (val (car subs)) )
2167	     (when (and first-analysis (not bootstrap-mode))
2168	       (case (variable-mark var '##compiler#intrinsic)
2169		 ((standard)
2170		  (warning "redefinition of standard binding" var) )
2171		 ((extended)
2172		  (warning "redefinition of extended binding" var) ) ))
2173	     (collect! db var 'potential-values val)
2174	     (unless (memq var localenv)
2175	       (grow 1)
2176	       (cond ((memq var env)
2177		      (db-put! db var 'captured #t))
2178		     ((not (db-get db var 'global))
2179		      (db-put! db var 'global #t) ) ) )
2180	     (assign var val fullenv here)
2181	     (unless toplevel-scope (db-put! db var 'assigned-locally #t))
2182	     (db-put! db var 'assigned #t)
2183	     (walk (car subs) env localenv fullenv here)))
2184
2185	  ((##core#primitive ##core#inline)
2186	   (let ((id (first params)))
2187	     (when (and first-analysis here (symbol? id) (get-real-name id))
2188	       (set-real-name! id here) )
2189	     (walkeach subs env localenv fullenv here)))
2190
2191	  (else (walkeach subs env localenv fullenv here)))))
2192
2193    (define (walkeach xs env lenv fenv here)
2194      (for-each (lambda (x) (walk x env lenv fenv here)) xs) )
2195
2196    (define (mark-rest-cdr var rvar depth)
2197      (db-put! db var 'rest-cdr (cons rvar depth))
2198      (collect! db rvar 'derived-rest-vars var))
2199
2200    (define (mark-rest-null? var rvar depth)
2201      (db-put! db var 'rest-null? (cons rvar depth))
2202      (collect! db rvar 'derived-rest-vars var))
2203
2204    (define (assign var val env here)
2205      ;; Propagate rest-cdr and rest-null? onto aliased variables
2206      (and-let* (((eq? '##core#variable (node-class val)))
2207		 (v (db-get db (first (node-parameters val)) 'rest-cdr)))
2208	(mark-rest-cdr var (car v) (cdr v)) )
2209
2210      (and-let* (((eq? '##core#variable (node-class val)))
2211		 (v (db-get db (first (node-parameters val)) 'rest-null?)))
2212	(mark-rest-null? var (car v) (cdr v)) )
2213
2214      (cond ((eq? '##core#undefined (node-class val))
2215	     (db-put! db var 'undefined #t) )
2216	    ((and (eq? '##core#variable (node-class val)) ; assignment to itself
2217		  (eq? var (first (node-parameters val))) ) )
2218
2219	    ;; Propagate info from ##core#rest-{cdr,null?} nodes to var
2220	    ((eq? '##core#rest-cdr (node-class val))
2221	     (let ((restvar (car (node-parameters val)))
2222		   (depth (cadr (node-parameters val))))
2223	       (mark-rest-cdr var restvar (add1 depth)) ) )
2224
2225	    ((eq? '##core#rest-null? (node-class val))
2226	     (let ((restvar (car (node-parameters val)))
2227		   (depth (cadr (node-parameters val))))
2228	       (mark-rest-null? var restvar depth) ) )
2229
2230	    ;; (##core#cond (null? r) '() (cdr r)) => result is tagged as a rest-cdr var
2231	    ((and-let* ((env (match-node val '(##core#cond ()
2232							   (##core#variable (test-var))
2233							   (quote (()))
2234							   (##core#rest-cdr (rvar depth)))
2235					 '(test-var rvar depth)))
2236			((db-get db (alist-ref 'test-var env) 'rest-null?)))
2237	       env)
2238	     => (lambda (env)
2239		  (let ((rvar (alist-ref 'rvar env))
2240			(depth (alist-ref 'depth env)))
2241		    (mark-rest-cdr var rvar (add1 depth)) ) ) )
2242
2243	    ((or (memq var env)
2244		 (variable-mark var '##compiler#constant)
2245		 (not (variable-visible? var block-compilation)))
2246	     (let ((props (db-get-all db var 'unknown 'value))
2247		   (home (db-get db var 'home)) )
2248	       (unless (assq 'unknown props)
2249		 (if (assq 'value props)
2250		     (db-put! db var 'unknown #t)
2251		     (if (or (not home) (eq? here home))
2252			 (db-put! db var 'value val)
2253			 (db-put! db var 'unknown #t) ) ) ) ) )
2254	    ((and (or local-definitions
2255		      (variable-mark var '##compiler#local))
2256		  (not (db-get db var 'unknown)))
2257	     (let ((home (db-get db var 'home)))
2258	       (cond ((db-get db var 'local-value)
2259		      (db-put! db var 'unknown #t))
2260		     ((or (not home) (eq? here home))
2261		      (db-put! db var 'local-value val)	       )
2262		     (else (db-put! db var 'unknown #t)))))
2263	    (else (db-put! db var 'unknown #t)) ) )
2264
2265    (define (ref var node)
2266      (collect! db var 'references node) )
2267
2268    (define (quick-put! plist prop val)
2269      (set-cdr! plist (alist-cons prop val (cdr plist))) )
2270
2271    ;; Walk toplevel expression-node:
2272    (debugging 'p "analysis traversal phase...")
2273    (set! current-program-size 0)
2274    (walk node '() '() '() #f)
2275
2276    ;; Complete gathered database information:
2277    (debugging 'p "analysis gathering phase...")
2278    (set! current-analysis-database-size 0)
2279    (hash-table-for-each
2280     (lambda (sym plist)
2281       (let ([unknown #f]
2282	     [value #f]
2283	     [local-value #f]
2284	     [potential-values #f]
2285	     [references '()]
2286	     [captured #f]
2287	     [call-sites '()]
2288	     [assigned #f]
2289	     [assigned-locally #f]
2290	     [undefined #f]
2291	     [global #f]
2292	     [nreferences 0]
2293	     [rest-cdr #f]
2294	     [ncall-sites 0] )
2295
2296	 (set! current-analysis-database-size (fx+ current-analysis-database-size 1))
2297
2298	 (for-each
2299	  (lambda (prop)
2300	    (case (car prop)
2301	      [(unknown) (set! unknown #t)]
2302	      [(references)
2303	       (set! references (cdr prop))
2304	       (set! nreferences (length references)) ]
2305	      [(captured) (set! captured #t)]
2306	      [(potential-values)
2307	       (set! potential-values (cdr prop))]
2308	      [(call-sites)
2309	       (set! call-sites (cdr prop))
2310	       (set! ncall-sites (length call-sites)) ]
2311	      [(assigned) (set! assigned #t)]
2312	      [(assigned-locally) (set! assigned-locally #t)]
2313	      [(undefined) (set! undefined #t)]
2314	      [(global) (set! global #t)]
2315	      [(value) (set! value (cdr prop))]
2316	      [(local-value) (set! local-value (cdr prop))]
2317	      [(rest-cdr) (set! rest-cdr (cdr prop))] ) )
2318	  plist)
2319
2320	 (set! value (and (not unknown) value))
2321	 (set! local-value (and (not unknown) local-value))
2322
2323	 ;; If this is the first analysis, register known local or potentially known global
2324	 ;;  lambda-value id's along with their names:
2325         (when first-analysis
2326	   (and-let* ((vals (or (and value (list value))
2327				(and global potential-values))))
2328	     (for-each
2329	      (lambda (val)
2330		(when (eq? (node-class val) '##core#lambda)
2331		  (set-real-name! (first (node-parameters val)) sym)))
2332	      vals)))
2333
2334	 ;; If this is the first analysis and the variable is global and has no references
2335	 ;;  and is hidden then issue warning:
2336	 (when (and first-analysis
2337		    global
2338		    (null? references)
2339		    (not (variable-mark sym '##compiler#unused))
2340		    (not (variable-hidden? sym))
2341		    (not (variable-visible? sym block-compilation))
2342		    (not (variable-mark sym '##compiler#constant)) )
2343	   (##sys#notice
2344	    (sprintf "global variable `~S' is only locally visible and never used"
2345	      sym) ) )
2346
2347 	 ;; Make 'boxed, if 'assigned & 'captured:
2348	 (when (and assigned captured)
2349	   (quick-put! plist 'boxed #t) )
2350
2351	 ;; Make 'contractable, if it has a procedure as known value, has only one use
2352	 ;;  and one call-site and if the lambda has no free non-global variables
2353	 ;;  or is an internal lambda. Make 'inlinable if
2354	 ;;  use/call count is not 1:
2355	 (cond (value
2356		(let ((valparams (node-parameters value)))
2357		  (when (and (eq? '##core#lambda (node-class value))
2358			     (or (not (second valparams))
2359				 (every
2360				  (lambda (v) (db-get db v 'global))
2361				  (nth-value 0 (scan-free-variables
2362						value block-compilation)) ) ) )
2363		    (if (and (not (db-get db sym 'has-bad-calls)) (= 1 nreferences) (= 1 ncall-sites))
2364			(quick-put! plist 'contractable #t)
2365			(quick-put! plist 'inlinable #t) ) ) ) )
2366	       (local-value
2367		;; Make 'inlinable, if it is declared local and has a value
2368		(let ((valparams (node-parameters local-value)))
2369		  (when (eq? '##core#lambda (node-class local-value))
2370		    (let-values (((vars hvars) (scan-free-variables
2371						local-value block-compilation)))
2372		      (when (and (db-get db sym 'global)
2373				 (pair? hvars))
2374			(quick-put! plist 'hidden-refs #t))
2375		      (when (or (not (second valparams))
2376				(every
2377				 (lambda (v) (db-get db v 'global))
2378				 vars))
2379			(quick-put! plist 'inlinable #t) ) ) ) ) )
2380	       ((variable-mark sym '##compiler#inline-global) =>
2381		(lambda (n)
2382		  (when (node? n)
2383		    (cond (assigned
2384			   (debugging
2385			    'i
2386			    "global inlining candidate was assigned and will not be inlined"
2387			    sym)
2388			   (mark-variable sym '##compiler#inline-global 'no))
2389			  (else
2390			   (let ((lparams (node-parameters n)))
2391			     (quick-put! plist 'inlinable #t)
2392			     (quick-put! plist 'local-value n))))))))
2393
2394	 ;; Make 'collapsable, if it has a known constant value which
2395	 ;; is either collapsable or is only referenced once:
2396	 (when (and value (eq? 'quote (node-class value)) )
2397	   (let ((val (first (node-parameters value))))
2398	     (when (or (collapsable-literal? val)
2399		       (= 1 nreferences) )
2400	       (quick-put! plist 'collapsable #t) ) ) )
2401
2402         (and-let* ((val (or local-value value))
2403                    ((eq? '##core#lambda (node-class val)))
2404	            ((rassoc sym callback-names eq?)))
2405           (let ((lparams (node-parameters val)))
2406             (db-put! db (first lparams) 'callback #t)))
2407
2408	 ;; If it has a known value that is a procedure, and if the number of call-sites is equal to the
2409	 ;;  number of references (does not escape), then make all formal parameters 'unused which are
2410	 ;;  never referenced or assigned (if no rest parameter exist):
2411	 ;;  - also marks the procedure as 'has-unused-parameters (if not in `callback-names')
2412	 ;;  - if the procedure is internal (a continuation) do NOT mark unused parameters.
2413	 ;;  - also: if procedure has rest-parameter and no unused params, mark f-id as 'explicit-rest.
2414	 (when value
2415	   (let ((has #f))
2416	     (when (and (eq? '##core#lambda (node-class value))
2417			(= nreferences ncall-sites) )
2418	       (let ((lparams (node-parameters value)))
2419		 (when (second lparams)
2420		   (##sys#decompose-lambda-list
2421		    (third lparams)
2422		    (lambda (vars argc rest)
2423		      (unless rest
2424			(for-each
2425			 (lambda (var)
2426			   (cond ((and (not (db-get db var 'references))
2427				       (not (db-get db var 'assigned)) )
2428				  (db-put! db var 'unused #t)
2429				  (set! has #t)
2430				  #t)
2431				 (else #f) ) )
2432			 vars) )
2433		      (cond ((and has (not (rassoc sym callback-names eq?)))
2434			     (db-put! db (first lparams) 'has-unused-parameters #t) )
2435			    (rest
2436			     (db-put! db (first lparams) 'explicit-rest #t)
2437			     (db-put! db rest 'consed-rest-arg #t) ) ) ) ) ) ) ) ) )
2438
2439         ;; If it has a known or local value which is a procedure, and referenced only once
2440         ;; and only one call site or is an internal procedure, mark it as 'shareable-user so that
2441         ;; its closed over variables may be shared with its containing procedure.
2442         ;; Note that callbacks are exempt from this, because callback_wrapper creates an empty closure
2443         ;; manually, throwing away our carefully crafted closure. TODO: can maybe be done better?
2444         ;;
2445         ;; If furthermore it only contains a single other procedure, mark it as 'shareable-container
2446         ;; so that may share closed-over variables with that one procedure.
2447         (and-let* ((val (or local-value value))
2448                    ((eq? '##core#lambda (node-class val)))
2449                    (lparams (node-parameters val))
2450                    ((or (= 1 nreferences ncall-sites)
2451                         (not (second lparams))))
2452	            ((not (rassoc sym callback-names eq?))))
2453	   (db-put! db (first lparams) 'shareable-user #t)
2454           (and-let* ((id (first lparams))
2455                      (contains (or (db-get db id 'contains) '()))
2456                      ((= (length contains) 1)))
2457             ;; TODO: It should be possible to have escaping / global procedures be containers, but
2458             ;; they should not call themselves because then they might be setting variables in
2459             ;; the closure to different values at different times.  So for now we're extra careful
2460             ;; about which are containers.
2461             (db-put! db (first lparams) 'shareable-container #t)))
2462
2463	 ;; Make 'removable, if it has no references and is not assigned to, and one of the following:
2464	 ;; - it has either a value that does not cause any side-effects
2465	 ;; - it is 'undefined
2466	 ;; - it holds only a 'rest-cdr reference (strictly speaking, it may bomb but we don't care)
2467	 (when (and (not assigned)
2468		    (null? references)
2469		    (or (and value
2470			     (if (eq? '##core#variable (node-class value))
2471				 (let ((varname (first (node-parameters value))))
2472				   (or (not (db-get db varname 'global))
2473				       (variable-mark varname '##core#always-bound)
2474				       (intrinsic? varname)))
2475				 (not (expression-has-side-effects? value db)) ))
2476			undefined
2477			rest-cdr) )
2478	   (quick-put! plist 'removable #t) )
2479
2480	 ;; Make 'replacable, if
2481	 ;; - it has a variable as known value and
2482	 ;; - it is not a global
2483	 ;; - it is never assigned to and
2484	 ;; - if either the substitute has a known value itself or
2485	 ;;   * the substitute is never assigned to and
2486	 ;;   * we are in block-mode or the substitute is non-global
2487	 ;;
2488	 ;;  - The variable that can be substituted for the current one is marked as 'replacing.
2489	 ;;    This is done to prohibit beta-contraction of the replacing variable (It wouldn't be there, if
2490	 ;;    it was contracted).
2491	 (when (and value (not global))
2492	   (when (eq? '##core#variable (node-class value))
2493	     (let ((name (first (node-parameters value))) )
2494	       (when (and (not assigned)
2495			  (or (and (not (db-get db name 'unknown))
2496				   (db-get db name 'value))
2497			      (and (not (db-get db name 'assigned))
2498				   (or (not (variable-visible?
2499					     name block-compilation))
2500				       (not (db-get db name 'global))) ) ))
2501		 (quick-put! plist 'replacable name)
2502		 (db-put! db name 'replacing #t) ) ) ) )
2503
2504	 ;; Make 'replacable, if it has a known value of the form: '(lambda (<xvar>) (<kvar> <xvar>))' and
2505	 ;;  is an internally created procedure: (See above for 'replacing)
2506	 (when (and value (eq? '##core#lambda (node-class value)))
2507	   (let ((params (node-parameters value)))
2508	     (when (not (second params))
2509	       (let ((llist (third params))
2510		     (body (first (node-subexpressions value))) )
2511		 (when (and (pair? llist)
2512			    (null? (cdr llist))
2513			    (eq? '##core#call (node-class body)) )
2514		   (let ((subs (node-subexpressions body)))
2515		     (when (= 2 (length subs))
2516		       (let ((v1 (first subs))
2517			     (v2 (second subs)) )
2518			 (when (and (eq? '##core#variable (node-class v1))
2519				    (eq? '##core#variable (node-class v2))
2520				    (eq? (first llist) (first (node-parameters v2))) )
2521			   (let ((kvar (first (node-parameters v1))))
2522			     (quick-put! plist 'replacable kvar)
2523			     (db-put! db kvar 'replacing #t) ) ) ) ) ) ) ) ) ) ) ) )
2524
2525     db)
2526
2527    ;; Set original program-size, if this is the first analysis-pass:
2528    (unless original-program-size
2529      (set! original-program-size current-program-size) )
2530
2531    ;; return database
2532    db) )
2533
2534
2535;;; Collect unsafe global procedure calls that are assigned:
2536
2537;;; Convert closures to explicit data structures (effectively flattens function-binding
2538;   structure):
2539
2540(define (perform-closure-conversion node db)
2541  (let ((direct-calls 0)
2542        (sharing-containers 0)
2543        (sharing-users 0)
2544	(customizable '())
2545	(lexicals '())
2546        (escaping-shared-vars '()))
2547
2548    ;; O(n) version of delete-duplicates (which is O(n^2)) specific for symbols
2549    (define (delete-duplicate-symbols lst)
2550      (let ((seen (make-hash-table)))
2551        (let lp ((lst lst)
2552                 (result '()))
2553          (if (null? lst)
2554	      (reverse result)
2555	      (let ((x (car lst)))
2556	        (cond ((hash-table-ref seen x)
2557	               (lp (cdr lst) result))
2558                      (else
2559                       (hash-table-set! seen x #t)
2560	               (lp (cdr lst)
2561                           (cons x result)))))))))
2562
2563    ;; O(n+m) version of lset-difference/eq? (which is O(n*m)) specific for symbols
2564    (define (symbolset-difference ls . lss)
2565      (let ((seen (make-hash-table)))
2566        (for-each (lambda (lst)
2567                    (for-each (lambda (x) (hash-table-set! seen x #t)) lst))
2568                  lss)
2569        (remove (lambda (x) (hash-table-ref seen x)) ls)))
2570
2571    (define (symbolset= ls . lss)
2572      (every (lambda (lst)
2573               (and (null? (symbolset-difference ls lst))
2574                    (null? (symbolset-difference lst ls))))
2575             lss))
2576
2577    (define (test sym item) (db-get db sym item))
2578
2579    (define (register-customizable! var id)
2580      (set! customizable (lset-adjoin/eq? customizable var))
2581      (db-put! db id 'customizable #t) )
2582
2583    (define (register-direct-call! id)
2584      (set! direct-calls (add1 direct-calls))
2585      (set! direct-call-ids (lset-adjoin/eq? direct-call-ids id)))
2586
2587    ;; Gather free-variable information:
2588    ;; (and: - register direct calls
2589    ;;       - update (by mutation) call information in "##core#call" nodes)
2590    (define (gather n here locals)
2591      (let ((subs (node-subexpressions n))
2592	    (params (node-parameters n)) )
2593	(case (node-class n)
2594
2595	  ((##core#variable ##core#rest-cdr)
2596	   (let ((var (first params)))
2597	     (if (memq var lexicals)
2598		 (list var)
2599		 '())))
2600
2601	  ((quote ##core#undefined ##core#provide ##core#proc ##core#primitive)
2602	   '())
2603
2604	  ((let)
2605	   ;;XXX remove this test later, shouldn't be needed:
2606	   (when (pair? (cdr params)) (bomb "let-node has invalid format" params))
2607	   (let ((c (gather (first subs) here locals))
2608		 (var (first params)))
2609	     (append c (delete var (gather (second subs) here (cons var locals)) eq?))))
2610
2611	  ((set!)
2612	   (let ((var (first params))
2613		 (c (gather (first subs) here locals)))
2614	     (if (memq var lexicals)
2615		 (cons var c)
2616		 c)))
2617
2618	  ((##core#call)
2619	   (let* ([fn (first subs)]
2620		  [mode (first params)]
2621		  [name (and (pair? (cdr params)) (second params))]
2622		  [varfn (eq? '##core#variable (node-class fn))] )
2623	     (node-parameters-set!
2624	      n
2625	      (cons mode
2626		    (if (or name varfn)
2627			(cons name
2628			      (if varfn
2629				  (let* ([varname (first (node-parameters fn))]
2630					 [val (and (not (test varname 'unknown))
2631						   (not (eq?
2632							 'no
2633							 (variable-mark
2634							  varname '##compiler#inline)))
2635						   ;; May not be external, see #1665
2636						   (not (node? (variable-mark varname '##compiler#inline-global)))
2637						   (or (test varname 'value)
2638						       (test varname 'local-value)))] )
2639				    (if (and val (eq? '##core#lambda (node-class val)))
2640					(let* ([params (node-parameters val)]
2641					       [llist (third params)]
2642					       [id (first params)]
2643					       [refs (test varname 'references)]
2644					       [sites (test varname 'call-sites)]
2645					       [custom
2646						(and refs sites
2647						     (= (length refs) (length sites))
2648						     (test varname 'value)
2649						     (not (test varname 'has-bad-calls))
2650						     (list? llist) ) ] )
2651					  (cond ((and name
2652                                                      (not (llist-match? llist (cdr subs))))
2653                                                   '())
2654                                                (else
2655   					          (register-direct-call! id)
2656					          (when custom
2657					            (register-customizable! varname id))
2658					          (list id custom) ) ) )
2659					'() ) )
2660				  '() ) )
2661			'() ) ) )
2662	     (concatenate (map (lambda (n) (gather n here locals)) subs) ) ))
2663
2664	  ((##core#lambda ##core#direct_lambda)
2665	   (##sys#decompose-lambda-list
2666	    (third params)
2667	    (lambda (vars argc rest)
2668	      (let ((id (if here (first params) 'toplevel)))
2669		(fluid-let ((lexicals (append locals lexicals)))
2670		  (let ((c (delete-duplicate-symbols (gather (first subs) id vars))))
2671		    (db-put! db id 'closure-size (length c))
2672		    (db-put! db id 'captured-variables c)
2673		    (symbolset-difference c locals vars)))))))
2674
2675	  (else (concatenate (map (lambda (n) (gather n here locals)) subs)) ) ) ))
2676
2677
2678    ;; Merge shareable closures.  This allocates space for closed-over
2679    ;; variables of the longest unbroken line of sharing-users in the
2680    ;; sharing-container, mutating the database entries set up by
2681    ;; "gather" to account for this.
2682    (define (merge-shareable n shared-closure)
2683      (let ((subs (node-subexpressions n))
2684	    (params (node-parameters n)) )
2685	(case (node-class n)
2686
2687	  ((quote ##core#undefined ##core#provide ##core#proc ##core#primitive)
2688	   '())
2689
2690	  ((##core#lambda ##core#direct_lambda)
2691	   (##sys#decompose-lambda-list
2692	    (third params)
2693	    (lambda (vars argc rest)
2694	      (let* ((id (first params))
2695                     (this-closure (or (test id 'captured-variables) '())))
2696                (cond ((and shared-closure
2697                            (test id 'shareable-user)
2698                            ;; The user must close over all the shared closure vars, otherwise
2699                            ;; we risk extending the lifetime of these vars for too long.
2700                            (null? (symbolset-difference shared-closure this-closure))
2701                            ;; Minimum shared closure size - don't want to share a single var, it's extra indirection
2702                            (> (length this-closure) 1))
2703                       ;; We only pass on the container to the subs if this is also a shareable-container
2704                       (let ((sub-closure (merge-shareable (first subs) (and (test id 'shareable-container) this-closure))))
2705                         ;; Reset captured vars.  This closure only captures the container
2706                         (db-put! db id 'closure-size 1)
2707                         (db-put! db id 'captured-variables '())
2708                         (db-put! db id 'sharing-mode 'user)
2709                         (set! sharing-users (add1 sharing-users))
2710                         ;; Return the closed-over variables of this and the rest of the
2711                         ;; users in the chain to the container for allocation.
2712                         ;; Note that because the user always is a superset of the container,
2713                         ;; we can just return the "deepest" user
2714                         (if (null? sub-closure)
2715                             this-closure
2716                             sub-closure)))
2717
2718                      ((test id 'shareable-container)
2719                       ;; If we're starting a new container, any captured vars from the
2720                       ;; surrounding container will escape, like with a non-sharing closure
2721                       (set! escaping-shared-vars (lset-union/eq? escaping-shared-vars this-closure))
2722
2723                       (fluid-let ((escaping-shared-vars '()))
2724                         (let ((sub-closure (merge-shareable (first subs) this-closure)))
2725                           (unless (null? sub-closure)
2726                             ;; NOTE: We don't touch 'captured-variables, because the vars
2727                             ;; on initial entry of the sharing closures are unchanged.
2728                             ;; However, we do need to know the full closure
2729                             (db-put! db id 'closure-size (length sub-closure))
2730                             (db-put! db id 'sharing-mode 'container)
2731                             (db-put! db id 'shared-closure sub-closure)
2732                             (set! sharing-containers (add1 sharing-containers))
2733
2734                             ;; Shared vars introduced by users which don't escape don't have to be boxed
2735                             ;; because the shared closure container itself already acts as a box.
2736                             (let* ((user-introduced-vars (symbolset-difference sub-closure this-closure))
2737                                    (unboxable-vars (symbolset-difference user-introduced-vars escaping-shared-vars)))
2738                               (for-each (lambda (v)
2739                                           (when (test v 'boxed) ; Not strictly needed, but cleaner this way
2740                                             (db-put! db v 'boxed #f)))
2741                                         unboxable-vars)))))
2742                       ;; This is a new container, so do not allow higher-up containers
2743                       ;; to collect variables from this closure.
2744                       '())
2745
2746                      ;; All closed-over vars in non-user procedures "escape" the container (if any)
2747                      ;; and must remain boxed.
2748                      (else (set! escaping-shared-vars (lset-union/eq? escaping-shared-vars this-closure))
2749                            (merge-shareable (first subs) #f)
2750                            '()))))))
2751
2752	  (else (concatenate (map (lambda (n) (merge-shareable n shared-closure)) subs)) ) ) ))
2753
2754
2755    ;; Merge "reusable" closures.  The "shareable" closures above
2756    ;; require great care to be taken because variables are mutated
2757    ;; into the container closure by the user closure where they're
2758    ;; introduced, which should not be observable.  However, closures
2759    ;; where the full set of variables is already known may freely be
2760    ;; reused any number of times because they're immutable.
2761    ;; NOTE: Unboxing of non-escaping vars is not implemented yet.
2762    (define (merge-reusable n reusable-closure)
2763      (let ((subs (node-subexpressions n))
2764	    (params (node-parameters n)) )
2765	(case (node-class n)
2766
2767	  ((quote ##core#undefined ##core#provide ##core#proc ##core#primitive)
2768	   #f)
2769
2770	  ((##core#lambda ##core#direct_lambda)
2771	   (##sys#decompose-lambda-list
2772	    (third params)
2773	    (lambda (vars argc rest)
2774	      (let* ((id (first params))
2775                     (this-closure (or (test id 'shared-closure) (test id 'captured-variables) '()))
2776                     (sharing-mode (test id 'sharing-mode))
2777                     ;; Callbacks may not be reused (see TODO in analyze-expression)
2778                     (is-callback? (test id '##compiler#callback-lambda))
2779                     ;; We don't want existing containers or users' shared closures to be reused by contained closures.
2780                     ;; However, we do allow containers to be moved "up front" if there are other closures that
2781                     ;; share the same variables (which means there are no mutating assignments to closed-over vars).
2782                     (container-needed? (merge-reusable (first subs) (and (not sharing-mode)
2783                                                                          (not is-callback?)
2784                                                                          this-closure))))
2785                (cond ((and reusable-closure
2786                            (not is-callback?)
2787                            ;; The closure must match exactly with the reusable container
2788                            ;; Note that if the closure is already a container, we compare
2789                            ;; against its shared closure.  This is safe to do because
2790                            ;; if they're the same, no variables are updated via mutation.
2791                            (symbolset= reusable-closure this-closure)
2792                            ;; Minimum shared closure size - don't want to share a single var, it's extra indirection
2793                            (> (length this-closure) 1))
2794                       ;; Reset captured vars.  This closure only captures the container
2795                       (db-put! db id 'closure-size 1)
2796                       (db-put! db id 'captured-variables '())
2797                       (db-put! db id 'sharing-mode 'user)
2798                       (set! sharing-users (add1 sharing-users))
2799                       ;; If this closure was already marked as a container by merge-reusable-closures,
2800                       ;; we turn it into a user.  Adjust counter to reflect this.
2801                       (when (eq? sharing-mode 'container)
2802                         (set! sharing-containers (sub1 sharing-containers)))
2803                       ;; We'd like a container to be created in the creating closure
2804                       #t)
2805
2806                      ;; If this closure cannot be turned into a sharing user, we might need to
2807                      ;; turn it into a container if any of its subclosures were turned into a user.
2808                      (container-needed?
2809                       (db-put! db id 'sharing-mode 'container)
2810                       (db-put! db id 'shared-closure this-closure)
2811                       (set! sharing-containers (add1 sharing-containers))
2812                       ;; Its parent does not become a container
2813                       #f)
2814
2815                      ;; No reuse :'(
2816                      (else #f))))))
2817
2818	  (else (any (lambda (n) (merge-reusable n reusable-closure)) subs) ) ) ))
2819
2820
2821    ;; Create explicit closures:
2822    (define (transform n crefvar closure)
2823      (let ((subs (node-subexpressions n))
2824	    (params (node-parameters n))
2825	    (class (node-class n)) )
2826	(case class
2827
2828	  ((quote ##core#undefined ##core#provide ##core#proc ##core#float
2829           ##core#float-variable)
2830            n)
2831
2832	  ((##core#variable)
2833	   (let* ((var (first params))
2834		  (val (ref-var n crefvar closure)) )
2835	     (if (test var 'boxed)
2836		 (make-node '##core#unbox '() (list val))
2837		 val) ) )
2838
2839	  ((##core#rest-cdr ##core#rest-car ##core#rest-null? ##core#rest-length)
2840	   (let* ((val (ref-var n crefvar closure))
2841		  (rest-var (if (eq? val n) (varnode (first params)) val)))
2842	     ;; If rest-cdrs have not all been eliminated, restore
2843	     ;; them as regular cdr calls on the rest list variable.
2844	     ;; This can be improved, as it can actually introduce
2845	     ;; many more cdr calls than necessary.
2846	     (cond ((eq? class '##core#rest-cdr)
2847		    (transform (replace-rest-op-with-list-ops class rest-var params) crefvar closure))
2848
2849		   ;; If n isn't val, this node was processed and the
2850		   ;; variable got replaced by a closure access.
2851		   ((not (eq? val n))
2852		    (transform (replace-rest-op-with-list-ops class rest-var params) crefvar closure))
2853
2854		   (else val)) ) )
2855
2856	  ((if ##core#call ##core#inline ##core#inline_allocate ##core#callunit
2857	       ##core#inline_ref ##core#inline_update ##core#debug-event
2858	       ##core#switch ##core#cond ##core#direct_call ##core#recurse ##core#return
2859               ##core#let_float ##core#box_float ##core#unbox_float
2860	       ##core#inline_loc_ref
2861	       ##core#inline_loc_update)
2862	   (make-node (node-class n) params (maptransform subs crefvar closure)) )
2863
2864	  ((let)
2865	   (let* ([var (first params)]
2866		  [boxedvar (test var 'boxed)]
2867		  [boxedalias (gensym var)] )
2868	     (if boxedvar
2869		 (make-node
2870		  'let (list boxedalias)
2871		  (list (transform (first subs) crefvar closure)
2872			(make-node
2873			 'let (list var)
2874			 (list (make-node '##core#box '() (list (varnode boxedalias)))
2875			       (update-shared-closure-var var crefvar closure
2876                                                          (transform (second subs) crefvar closure))) )) )
2877		 (make-node
2878		  'let params
2879                  (list (transform (first subs) crefvar closure)
2880                        (update-shared-closure-var var crefvar closure
2881                                                   (transform (second subs) crefvar closure))) ) ) ) )
2882
2883	  ((##core#lambda ##core#direct_lambda)
2884	   (let ((llist (third params)))
2885	     (##sys#decompose-lambda-list
2886	      llist
2887	      (lambda (vars argc rest)
2888		(let* ((boxedvars (filter (lambda (v) (test v 'boxed)) vars))
2889		       (boxedaliases (map cons boxedvars (map gensym boxedvars)))
2890		       (cvar (gensym 'c))
2891                       (all-vars (if rest (cons rest vars) vars))
2892		       (id (if crefvar (first params) 'toplevel))
2893                       (sharing-mode (test id 'sharing-mode))
2894		       (capturedvars (if (eq? sharing-mode 'user)
2895					 (list #f) ; NOTE: Hacky way to indicate we want to pass on the closure
2896					 (or (test id 'captured-variables) '())))
2897		       (csize (or (test id 'closure-size) 0)) ; = (length new-closure) below
2898		       (info (and emit-closure-info (second params) (pair? llist)))
2899                       (new-crefvar (if (eq? sharing-mode 'user)
2900                                        ;; Users should not look up vars in their own closure, but in
2901                                        ;; the shared closure "container" (which is the only entry in their own closure)
2902                                        (gensym 'scc)
2903                                        cvar))
2904		       (new-closure (case sharing-mode
2905                                      ((container) (test id 'shared-closure)) ; Fresh container will hold the full shared closure
2906				      ((user)
2907                                       ;; Sharing user doesn't introduce new vars into closure, but uses shared container's closure
2908				       closure)
2909				      ;; Normal unshared closure is over its captured vars
2910				      (else capturedvars))))
2911		  ;; If rest-parameter is boxed: mark it as 'boxed-rest
2912		  ;;  (if we don't do this than preparation will think the (boxed) alias
2913		  ;;  of the rest-parameter is never used)
2914		  (and-let* ((rest)
2915			     ((test rest 'boxed))
2916			     (rp (test rest 'rest-parameter)) )
2917		    (db-put! db (cdr (assq rest boxedaliases)) 'boxed-rest #t) )
2918		  (make-node
2919		   '##core#closure (list (+ csize (if info 2 1)))
2920		   (cons
2921		    (make-node
2922		     class
2923		     (list id
2924			   (second params)
2925			   (cons
2926			    cvar
2927			    (build-lambda-list
2928			     (map (lambda (v)
2929				    (cond ((assq v boxedaliases) => cdr)
2930					  (else v) ) )
2931				  vars)
2932			     argc
2933			     (cond ((and rest (assq rest boxedaliases)) => cdr)
2934				   (else rest) ) ) )
2935			   (fourth params) )
2936		     (list (wrap-crefvar cvar new-crefvar
2937                                         (let ((body (update-shared-closure-vars all-vars new-crefvar new-closure
2938								                 (transform (car subs) new-crefvar new-closure))))
2939			                   (if (pair? boxedvars)
2940				               (let loop ((aliases (unzip1 boxedaliases))
2941					                  (values
2942					                   (map (lambda (a)
2943						                  (make-node '##core#box '() (list (varnode (cdr a)))))
2944						                boxedaliases) ))
2945				                 (if (null? aliases)
2946				                     body
2947				                     (make-node 'let (list (car aliases))
2948						                (list (car values)
2949							              (loop (cdr aliases) (cdr values))))))
2950				               body) )) ) )
2951		    (let ((cvars (map (lambda (v)
2952                                        ;; NOTE: This memq redundancy is needed because "gather" reorders lexicals
2953                                        ;; continually, so the index of the variables will differ between each user,
2954                                        ;; meaning the collected shared closure is differently ordered than the
2955                                        ;; capturedvars.  Otherwise, we could just map ref-var over capturedvars
2956                                        ;; and append a bunch of undefineds at the end.
2957                                        (cond ((not v) ; See capturedvars note above
2958                                               (varnode crefvar))
2959                                              ((memq v capturedvars)
2960                                               ;; If it's a captured var, put it in the closure at the appropriate spot
2961                                               (ref-var (varnode v) crefvar closure))
2962                                              (else
2963                                               ;; Shared closures have reserved spots which users further down will set!
2964                                               ;; to a proper value.  Init those as undefined.
2965                                               (make-node '##core#undefined '() '()))))
2966				      (if (eq? sharing-mode 'container)
2967                                          new-closure
2968                                          capturedvars))))
2969		      (if info
2970			  (append
2971			   cvars
2972			   (list
2973			    (qnode
2974			     (##sys#make-lambda-info
2975			      (->string (cons (or (real-name id) '?)
2976					      ;; this is not always correct, due to optimizations
2977					      (strip-syntax (cdr llist))))))))
2978			  cvars) ) ) ) ) ) ) ) )
2979
2980	  ((set!)
2981	   (let* ((var (first params))
2982		  (val (first subs))
2983		  (cval (node-class val))
2984		  (immf (or (and (eq? 'quote cval) (immediate? (first (node-parameters val))))
2985			    (and (pair? (cdr params)) (second params))
2986			    (eq? '##core#undefined cval))))
2987	     (cond ((posq var closure)
2988		    => (lambda (i)
2989			 (if (test var 'boxed)
2990			     (make-node
2991			      (if immf '##core#updatebox_i '##core#updatebox)
2992			      '()
2993			      (list (make-node '##core#ref (list (add1 i)) (list (varnode crefvar)))
2994				    (transform val crefvar closure) ) )
2995			     ;; Is the following actually used???
2996			     (make-node
2997			      (if immf '##core#update_i '##core#update)
2998			      (list (add1 i))
2999			      (list (varnode crefvar)
3000				    (transform val crefvar closure) ) ) ) ) )
3001		   ((test var 'boxed)
3002		    (make-node
3003		     (if immf '##core#updatebox_i '##core#updatebox)
3004		     '()
3005		     (list (varnode var)
3006			   (transform val crefvar closure) ) ) )
3007		   (else (make-node
3008			  'set! (list var immf)
3009			  (list (transform val crefvar closure) ) ) ) ) ) )
3010
3011	  ((##core#primitive)
3012	   (make-node
3013	    '##core#closure (list (if emit-closure-info 2 1))
3014	    (cons (make-node '##core#proc (list (car params) #t) '())
3015		  (if emit-closure-info
3016		      (list (qnode (##sys#make-lambda-info (->string (car params)))))
3017		      '() ) ) ) )
3018
3019	  ((##core#ref) n)
3020
3021	  (else (bomb "bad node (closure2)")) ) ) )
3022
3023    (define (maptransform xs crefvar closure)
3024      (map (lambda (x) (transform x crefvar closure)) xs) )
3025
3026    ;; If the crefvar (used by ref-var et al) differs from the
3027    ;; closure's own "cvar" because it's a shared closure, introduce a
3028    ;; let binding that obtains the shared closure from the cvar.
3029    (define (wrap-crefvar cvar crefvar node)
3030      (if (eq? cvar crefvar)
3031          node
3032          (make-node 'let (list crefvar)
3033                     (list (make-node '##core#ref (list 1)
3034			              (list (varnode cvar)) )
3035                           node) ) ) )
3036
3037    ;; If a variable is introduced for the first time, and we're in a
3038    ;; sharing user, we have to update its value in the shared container
3039    ;; closure if it occurs there, so that further users can see it.
3040    (define (update-shared-closure-var var crefvar closure node)
3041      (cond ((posq var closure)
3042	     => (lambda (i)
3043                  (make-node 'let (list (gensym var))
3044		             (list (make-node '##core#update (list (+ i 1))
3045			                      (list (varnode crefvar) (varnode var)) )
3046                                   node)) ) )
3047	    (else node) ))
3048
3049    (define (update-shared-closure-vars vars crefvar closure node)
3050      (let lp ((node node)
3051               (vars vars))
3052        (if (null? vars)
3053            node
3054            (lp (update-shared-closure-var (car vars) crefvar closure node)
3055                (cdr vars)))))
3056
3057    (define (ref-var n crefvar closure)
3058      (let ((var (first (node-parameters n))))
3059	(cond ((posq var closure)
3060	       => (lambda (i)
3061		    (make-node '##core#ref (list (+ i 1))
3062			       (list (varnode crefvar)) ) ) )
3063	      (else n) ) ) )
3064
3065    (debugging 'p "closure conversion gathering phase...")
3066    (gather node #f '())
3067    (when (pair? customizable)
3068      (debugging 'o "customizable procedures" customizable))
3069    (when merge-shareable-closures
3070      (debugging 'p "closure conversion merging of shareables phase...")
3071      (merge-shareable node #f))
3072    (when merge-reusable-closures 
3073      (debugging 'p "closure conversion merging of reusables phase...")
3074      (merge-reusable node #f))
3075    (unless (and (zero? sharing-containers)
3076                 (zero? sharing-users)) ;; Users should always be zero if containers is (but paranoia prevails, helps w/ debugging)
3077      (debugging 'o "shared closure containers" sharing-containers)
3078      (debugging 'o "shared closure users" sharing-users))
3079    (debugging 'p "closure conversion transformation phase...")
3080    (let ((node2 (transform node #f '())))
3081      (unless (zero? direct-calls)
3082	(debugging 'o "calls to known targets" direct-calls))
3083      node2) ) )
3084
3085
3086;;; Do some preparations before code-generation can commence:
3087
3088(define-record lambda-literal
3089  id 		       ; symbol
3090  external      ; boolean
3091  ;; lambda-literal-arguments is used nowhere
3092  arguments 	       ; (symbol ...)
3093  argument-count      ; integer
3094  rest-argument        ; symbol | #f
3095  temporaries      ; integer
3096  float-temporaries    ; (integer ...)
3097  callee-signatures  ; (integer ...)
3098  allocated        ; integer
3099  ;; lambda-literal-directly-called is used nowhere
3100  directly-called     ; boolean
3101  closure-size      ; integer
3102  looping      ; boolean
3103  customizable     ; boolean
3104  rest-argument-mode ; #f | LIST | NONE
3105  body				 ; expression
3106  direct)			 ; boolean
3107
3108(define (prepare-for-code-generation node db)
3109  (let ((literals '())
3110	(literal-count 0)
3111	(lambda-info-literals '())
3112	(lambda-info-literal-count 0)
3113	;; Use analysis db as optimistic heuristic for procedure table size
3114	(lambda-table (make-vector (fx* (fxmax current-analysis-database-size 1) 3) '()))
3115	(temporaries 0)
3116        (float-temporaries '())
3117	(allocated 0)
3118	(looping 0)
3119	(signatures '())
3120	(fastinits 0)
3121	(fastrefs 0)
3122	(fastsets 0)
3123	(dbg-index 0)
3124	(debug-info '()))
3125
3126    (define (walk-var var e e-count sf)
3127      (cond [(posq var e)
3128	     => (lambda (i)
3129		  (make-node '##core#local (list (fx- e-count (fx+ i 1))) '()))]
3130	    [(keyword? var) (make-node '##core#literal (list (literal var)) '())]
3131	    [else (walk-global var sf)] ) )
3132
3133    (define (walk-global var sf)
3134      (let* ([safe (or sf
3135		       no-bound-checks
3136		       unsafe
3137		       (variable-mark var '##compiler#always-bound)
3138		       (intrinsic? var))]
3139	     [blockvar (and (db-get db var 'assigned)
3140			    (not (variable-visible? var block-compilation)))])
3141	(when blockvar (set! fastrefs (add1 fastrefs)))
3142	(make-node
3143	 '##core#global
3144	 (list (if blockvar
3145		   (blockvar-literal var)
3146		   (literal var) )
3147	       safe
3148	       blockvar
3149	       var)
3150	 '() ) ) )
3151
3152    (define (walk n e e-count here boxes)
3153      (let ((subs (node-subexpressions n))
3154	    (params (node-parameters n))
3155	    (class (node-class n)) )
3156	(case class
3157
3158	  ((##core#undefined ##core#proc ##core#float) n)
3159
3160	  ((##core#variable)
3161	   (walk-var (first params) e e-count #f) )
3162
3163	  ((##core#direct_call)
3164	   (let* ((source-info (second params))
3165		  (demand (fourth params)))
3166	     (if (and emit-debug-info source-info)
3167		 (let ((info (list dbg-index 'C_DEBUG_CALL
3168				   (source-info->line source-info)
3169				   (source-info->name source-info))))
3170		   (set! params (cons dbg-index params))
3171		   (set! debug-info (cons info debug-info))
3172		   (set! dbg-index (add1 dbg-index)))
3173		 (set! params (cons #f params)))
3174	     (set! allocated (+ allocated demand))
3175	     (make-node class params (mapwalk subs e e-count here boxes))))
3176
3177	  ((##core#inline_allocate)
3178	   (set! allocated (+ allocated (second params)))
3179	   (make-node class params (mapwalk subs e e-count here boxes)) )
3180
3181          ((##core#box_float)
3182           (set! allocated (+ allocated 4)) ;; words-per-flonum
3183           (make-node class params (mapwalk subs e e-count here boxes)))
3184
3185	  ((##core#inline_ref)
3186	   (set! allocated (+ allocated (bytes->words (estimate-foreign-result-size (second params)))))
3187	   (make-node class params '()) )
3188
3189	  ((##core#inline_loc_ref)
3190	   (set! allocated (+ allocated (bytes->words (estimate-foreign-result-size (first params)))))
3191	   (make-node class params (mapwalk subs e e-count here boxes)) )
3192
3193	  ((##core#closure)
3194	   (set! allocated (+ allocated (first params) 1))
3195	   (make-node '##core#closure params (mapwalk subs e e-count here boxes)) )
3196
3197	  ((##core#box)
3198	   (set! allocated (+ allocated 2))
3199	   (make-node '##core#box params (list (walk (first subs) e e-count here boxes))) )
3200
3201	  ((##core#updatebox)
3202	   (let* ([b (first subs)]
3203		  [subs (mapwalk subs e e-count here boxes)] )
3204	     (make-node
3205	      (cond [(and (eq? '##core#variable (node-class b))
3206			  (memq (first (node-parameters b)) boxes) )
3207		     (set! fastinits (add1 fastinits))
3208		     '##core#updatebox_i]
3209		    [else class] )
3210	      '()
3211	      subs) ) )
3212
3213	  ((##core#provide)
3214	   ;; Allocate enough space for the ##core#provided property.
3215	   (let ((id (literal (first params))))
3216	     (set! allocated (+ allocated 8))
3217	     (make-node class (list id) '())))
3218
3219	  ((##core#lambda ##core#direct_lambda)
3220	   (let ((temps temporaries)
3221                 (ftemps float-temporaries)
3222		 (sigs signatures)
3223		 (lping looping)
3224		 (alc allocated)
3225		 (direct (eq? class '##core#direct_lambda)) )
3226	     (set! temporaries 0)
3227             (set! float-temporaries '())
3228	     (set! allocated 0)
3229	     (set! signatures '())
3230	     (set! looping 0)
3231	     (##sys#decompose-lambda-list
3232	      (third params)
3233	      (lambda (vars argc rest)
3234		(let* ((id (first params))
3235		       (rest-mode
3236			(and rest
3237			     (let ((rrefs (db-get db rest 'references)))
3238			       (cond ((db-get db rest 'assigned) 'list)
3239				     ((and (not (db-get db rest 'boxed-rest))
3240					   (or (not rrefs) (null? rrefs))) 'none)
3241				     (else (db-get db rest 'rest-parameter)) ) ) ) )
3242		       (body (walk
3243			      (car subs)
3244			      (##sys#fast-reverse (if (eq? 'none rest-mode)
3245						      (butlast vars)
3246						      vars))
3247			      (if (eq? 'none rest-mode)
3248				  (fx- (length vars) 1)
3249				  (length vars))
3250			      id
3251			      '()) ) )
3252		  (when (eq? rest-mode 'none)
3253		    (debugging 'o "unused rest argument" rest id))
3254		  (when (and direct rest)
3255		    (bomb "bad direct lambda" id allocated rest) )
3256		  (hash-table-set!
3257		   lambda-table
3258		   id
3259		   (make-lambda-literal
3260		    id
3261		    (second params)
3262		    vars
3263		    argc
3264		    rest
3265		    (add1 temporaries)
3266                    float-temporaries
3267		    signatures
3268		    allocated
3269		    (or direct (memq id direct-call-ids))
3270		    (or (db-get db id 'closure-size) 0)
3271		    (and (not rest)
3272			 (> looping 0)
3273			 (begin
3274			   (debugging 'o "identified direct recursive calls" id looping)
3275			   #t) )
3276		    (or direct (db-get db id 'customizable))
3277		    rest-mode
3278		    body
3279		    direct) )
3280		  (set! looping lping)
3281		  (set! temporaries temps)
3282                  (set! float-temporaries ftemps)
3283		  (set! allocated alc)
3284		  (set! signatures (lset-adjoin/eq? sigs argc))
3285		  (make-node '##core#proc (list (first params)) '()) ) ) ) ) )
3286
3287	  ((let)
3288	   (let* ([var (first params)]
3289		  [val (first subs)]
3290		  [boxvars (if (eq? '##core#box (node-class val)) (list var) '())] )
3291	     (set! temporaries (add1 temporaries))
3292	     (make-node
3293	      '##core#bind (list 1)	; is actually never used with more than 1 variable
3294	      (list (walk val e e-count here boxes)
3295		    (walk (second subs)
3296			  (append (##sys#fast-reverse params) e) (fx+ e-count 1)
3297			  here (append boxvars boxes)) ) ) ) )
3298
3299	  ((##core#let_float)
3300	   (let ((i (first params))
3301	         (val (first subs)))
3302             (set! float-temporaries (cons i float-temporaries))
3303	     (make-node
3304	      '##core#let_float params
3305	      (list (walk val e e-count here boxes)
3306		    (walk (second subs) e e-count here boxes) ) ) ) )
3307
3308	  ((set!)
3309	   (let ((var (first params))
3310		 (val (first subs)) )
3311	     (cond ((posq var e)
3312		    => (lambda (i)
3313			 (make-node '##core#setlocal
3314				    (list (fx- e-count (fx+ i 1)))
3315				    (list (walk val e e-count here boxes)) ) ) )
3316		   (else
3317		    (let* ((cval (node-class val))
3318			   (blockvar (not (variable-visible?
3319					   var block-compilation)))
3320			   (immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val))))
3321				     (and (pair? (cdr params)) (second params))
3322				     (eq? '##core#undefined cval) ) ) )
3323		      (when blockvar (set! fastsets (add1 fastsets)))
3324		      (make-node
3325		       (if immf '##core#setglobal_i '##core#setglobal)
3326		       (list (if blockvar
3327				 (blockvar-literal var)
3328				 (literal var) )
3329			     blockvar
3330			     var)
3331		       (list (walk (car subs) e e-count here boxes)) ) ) ) ) ) )
3332
3333	  ((##core#call)
3334	   (let* ((len (length (cdr subs)))
3335		  (p2 (pair? (cdr params)))
3336		  (source-info (and p2 (second params))))
3337	     (set! signatures (lset-adjoin/eq? signatures len))
3338	     (when (and (>= (length params) 3) (eq? here (third params)))
3339	       (set! looping (add1 looping)) )
3340               (if (and emit-debug-info source-info)
3341                 (let ((info (list dbg-index 'C_DEBUG_CALL
3342				   (source-info->line source-info)
3343				   (source-info->name source-info))))
3344                   (set! params (cons dbg-index params))
3345                   (set! debug-info (cons info debug-info))
3346                   (set! dbg-index (add1 dbg-index)))
3347                 (set! params (cons #f params)))
3348	     (make-node class params (mapwalk subs e e-count here boxes))))
3349
3350	  ((##core#recurse)
3351	   (when (first params) (set! looping (add1 looping)))
3352	   (make-node class params (mapwalk subs e e-count here boxes)) )
3353
3354	  ((quote)
3355	   (let ((c (first params)))
3356	     (cond ((and (fixnum? c) (not (big-fixnum? c)))
3357		    (immediate-literal c) )
3358		   ((number? c)
3359		    (cond ((eq? 'fixnum number-type)
3360			   (cond ((and (integer? c) (not (big-fixnum? c)))
3361				  (warning
3362				   (sprintf
3363				       "coerced inexact literal number `~S' to fixnum ~S"
3364				     c (inexact->exact c)))
3365				  (immediate-literal (inexact->exact c)) )
3366				 (else (quit-compiling "cannot coerce inexact literal `~S' to fixnum" c)) ) )
3367			  (else (make-node '##core#literal (list (literal c)) '())) ) )
3368		   ((immediate? c) (immediate-literal c))
3369		   (else (make-node '##core#literal (list (literal c)) '())) ) ) )
3370
3371	  ((if ##core#cond)
3372	   (let* ((test (walk (first subs) e e-count here boxes))
3373		  (t0 temporaries)
3374		  (a0 allocated)
3375		  (x1 (walk (second subs) e e-count here boxes))
3376		  (t1 temporaries)
3377		  (a1 allocated)
3378		  (x2 (walk (third subs) e e-count here boxes)))
3379	     (set! allocated (+ a0 (max (- allocated a1) (- a1 a0))))
3380	     (set! temporaries (+ t0 (max (- temporaries t1) (- t1 t0))))
3381	     (make-node class params (list test x1 x2))))
3382
3383	  ((##core#switch)
3384	   (let* ((exp (walk (first subs) e e-count here boxes))
3385		  (a0 allocated))
3386	     (make-node
3387	      class
3388	      params
3389	      (cons
3390	       exp
3391	       (let loop ((j (first params)) (subs (cdr subs)) (ma 0))
3392		 (set! allocated a0)
3393		 (if (zero? j)
3394		     (let ((def (walk (car subs) e e-count here boxes)))
3395		       (set! allocated (+ a0 (max ma (- allocated a0))))
3396		       (list def))
3397		     (let* ((const (walk (car subs) e e-count here boxes))
3398			    (body (walk (cadr subs) e e-count here boxes)))
3399		       (cons*
3400			const body
3401			(loop (sub1 j) (cddr subs) (max (- allocated a0) ma))))))))))
3402
3403	  ((##core#debug-event)
3404	   (let* ((i dbg-index)
3405		  (params (cons i params)))
3406	     (set! debug-info (cons params debug-info))
3407	     (set! dbg-index (add1 dbg-index))
3408	     (make-node class params '())))
3409
3410	  (else (make-node class params (mapwalk subs e e-count here boxes)) ) ) ) )
3411
3412    (define (mapwalk xs e e-count here boxes)
3413      (map (lambda (x) (walk x e e-count here boxes)) xs) )
3414
3415    (define (literal x)
3416      (cond [(immediate? x) (immediate-literal x)]
3417	    ;; Fixnums that don't fit in 32 bits are treated as non-immediates,
3418	    ;; that's why we do the (apparently redundant) C_blockp check here.
3419	    ((and (##core#inline "C_blockp" x) (##core#inline "C_lambdainfop" x))
3420	     (let ((i lambda-info-literal-count))
3421	       (set! lambda-info-literals (cons x lambda-info-literals))
3422	       (set! lambda-info-literal-count (add1 lambda-info-literal-count))
3423	       (vector i) ) )
3424	    [(posv x literals) => (lambda (p) (fx- literal-count (fx+ p 1)))]
3425	    [else (new-literal x)] ) )
3426
3427    (define (new-literal x)
3428      (let ([i literal-count])
3429	(set! literals (cons x literals))
3430	(set! literal-count (add1 literal-count))
3431	i) )
3432
3433    (define (blockvar-literal var)
3434      (cond
3435       ((list-index (lambda (lit)
3436		      (and (block-variable-literal? lit)
3437			   (eq? var (block-variable-literal-name lit)) ) )
3438		    literals)
3439	=> (lambda (p) (fx- literal-count (fx+ p 1))))
3440       (else (new-literal (make-block-variable-literal var))) ) )
3441
3442    (define (immediate-literal x)
3443      (if (eq? (void) x)
3444	  (make-node '##core#undefined '() '())
3445	  (make-node '##core#immediate
3446		     (cond ((fixnum? x) `(fix ,x))
3447			   ((boolean? x) `(bool ,x))
3448			   ((char? x) `(char ,x))
3449			   ((null? x) '(nil))
3450			   ((eof-object? x) '(eof))
3451			   ((bwp-object? x) '(bwp))
3452			   (else (bomb "bad immediate (prepare)")) )
3453		     '() ) ) )
3454
3455    (debugging 'p "preparation phase...")
3456    (let ((node2 (walk node '() 0 #f '())))
3457      (when (positive? fastinits)
3458	(debugging 'o "fast box initializations" fastinits))
3459      (when (positive? fastrefs)
3460	(debugging 'o "fast global references" fastrefs))
3461      (when (positive? fastsets)
3462	(debugging 'o "fast global assignments" fastsets))
3463      (values node2
3464	      (##sys#fast-reverse literals)
3465	      (##sys#fast-reverse lambda-info-literals)
3466	      lambda-table
3467	      (reverse debug-info) ) ) ))
3468)