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