~ 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 ((,var ,val))
1178					  (##core#debug-event C_DEBUG_GLOBAL_ASSIGN (##core#quote ,var))
1179					  ,var)))
1180				   ;; We use `var0` instead of `var` because the {macro,current}-environment
1181				   ;; are keyed by the raw and unqualified name
1182				   (cond ((##sys#macro? var0 (##sys#current-environment))
1183					  (warning
1184					   (sprintf "~aassignment to syntax `~S'"
1185					    (if ln (sprintf "(~a) - " ln) "") var0))
1186					  (when undefine-shadowed-macros
1187					    (##sys#undefine-macro! var0)
1188					    (##sys#unregister-syntax-export var0 (##sys#current-module))))
1189					 ((assq var0 (##sys#current-environment))
1190					  (warning
1191					   (sprintf "~aassignment to imported value binding `~S'"
1192					    (if ln (sprintf "(~a) - " ln) "") var0)))))
1193				 `(set! ,var ,(walk val e var0 (memq var e) h ln #f))))))
1194
1195			((##core#debug-event)
1196			 `(##core#debug-event
1197			   ,(cadr x)
1198			   ,ln ; this arg is added - from this phase on ##core#debug-event has an additional argument!
1199			   ,@(map (lambda (arg)
1200				    (unquotify (walk arg e #f #f h ln tl?)))
1201				  (cddr x))))
1202
1203			((##core#inline)
1204			 `(##core#inline
1205			   ,(unquotify (cadr x)) ,@(mapwalk (cddr x) e h ln #f)))
1206
1207			((##core#inline_allocate)
1208			 `(##core#inline_allocate
1209			   ,(map unquotify (second x))
1210			   ,@(mapwalk (cddr x) e h ln #f)))
1211
1212			((##core#inline_update)
1213			 `(##core#inline_update ,(cadr x) ,(walk (caddr x) e #f #f h ln #f)) )
1214
1215			((##core#inline_loc_update)
1216			 `(##core#inline_loc_update
1217			   ,(cadr x)
1218			   ,(walk (caddr x) e #f #f h ln #f)
1219			   ,(walk (cadddr x) e #f #f h ln #f)) )
1220
1221			((##core#compiletimetoo ##core#elaborationtimetoo)
1222			 (let ((exp (cadr x)))
1223			   (##sys#eval/meta exp)
1224			   (walk exp e dest #f h ln tl?) ) )
1225
1226			((##core#compiletimeonly ##core#elaborationtimeonly)
1227			 (##sys#eval/meta (cadr x))
1228			 '(##core#undefined) )
1229
1230			((##core#begin)
1231			 (if (pair? (cdr x))
1232			     (canonicalize-begin-body
1233			      (let fold ([xs (cdr x)])
1234				(let ([x (car xs)]
1235				      [r (cdr xs)] )
1236				  (if (null? r)
1237				      (list (walk x e dest ldest h ln tl?))
1238				      (cons (walk x e #f #f h ln tl?) (fold r)) ) ) ) )
1239			     '(##core#undefined) ) )
1240
1241			((##core#foreign-lambda)
1242			 (walk (expand-foreign-lambda x #f) e dest ldest h ln #f) )
1243
1244			((##core#foreign-safe-lambda)
1245			 (walk (expand-foreign-lambda x #t) e dest ldest h ln #f) )
1246
1247			((##core#foreign-lambda*)
1248			 (walk (expand-foreign-lambda* x #f) e dest ldest h ln #f) )
1249
1250			((##core#foreign-safe-lambda*)
1251			 (walk (expand-foreign-lambda* x #t) e dest ldest h ln #f) )
1252
1253			((##core#foreign-primitive)
1254			 (walk (expand-foreign-primitive x) e dest ldest h ln #f) )
1255
1256			((##core#define-foreign-variable)
1257			 (let* ((var (strip-syntax (second x)))
1258				(type (strip-syntax (third x)))
1259				(name (if (pair? (cdddr x))
1260					  (fourth x)
1261					  (symbol->string var))))
1262			   (set! foreign-variables
1263			     (cons (list var type name)
1264				   foreign-variables))
1265			   '(##core#undefined) ) )
1266
1267			((##core#define-foreign-type)
1268			 (let ((name (second x))
1269			       (type (strip-syntax (third x)))
1270			       (conv (cdddr x)))
1271			   (unless tl?
1272			     (quit-compiling
1273			      "~adefinition of foreign type `~s' in non-toplevel context"
1274			      (if ln (sprintf "(~a) - " ln) "")
1275			      name))
1276			   (cond [(pair? conv)
1277				  (let ([arg (gensym)]
1278					[ret (gensym)] )
1279				    (register-foreign-type! name type arg ret)
1280				    (mark-variable arg '##compiler#always-bound)
1281				    (mark-variable ret '##compiler#always-bound)
1282				    (hide-variable arg)
1283				    (hide-variable ret)
1284				    ;; NOTE: Above we already check we're in toplevel context,
1285				    ;; so we can unconditionally register the export here.
1286				    ;; TODO: Remove after fixing #1615
1287				    (##sys#register-export arg (##sys#current-module))
1288				    (##sys#register-export ret (##sys#current-module))
1289				    (walk
1290				     `(##core#begin
1291					(##core#set! ,arg ,(first conv))
1292					(##core#set!
1293					 ,ret
1294					 ,(if (pair? (cdr conv)) (second conv) '##sys#values)) )
1295				     e dest ldest h ln tl?))]
1296				 [else
1297				  (register-foreign-type! name type)
1298				  '(##core#undefined) ] ) ) )
1299
1300			((##core#define-external-variable)
1301			 (let* ((sym (second x))
1302				(ln (get-line-number x))
1303				(name (symbol->string sym))
1304				(type (third x))
1305				(exported (fourth x))
1306				(rname (make-random-name)) )
1307			   (unless tl?
1308			     (quit-compiling
1309			      "~aexternal variable definition of `~s' in non-toplevel context"
1310			      (if ln (sprintf "(~a) - " ln) "")
1311			      sym))
1312			   (unless exported (set! name (symbol->string (fifth x))))
1313			   (set! external-variables (cons (vector name type exported) external-variables))
1314			   (set! foreign-variables
1315			     (cons (list rname 'c-pointer (string-append "&" name))
1316				   foreign-variables) )
1317			   (set! external-to-pointer (alist-cons sym rname external-to-pointer))
1318			   '(##core#undefined) ) )
1319
1320			((##core#let-location)
1321			 (let* ((var (second x))
1322				(type (strip-syntax (third x)))
1323				(alias (gensym))
1324				(store (gensym))
1325				(init (and (pair? (cddddr x)) (fourth x))))
1326			   (set-real-name! alias var)
1327			   (set! location-pointer-map
1328			     (cons (list alias store type) location-pointer-map) )
1329			   (parameterize ((##sys#current-environment
1330					   (alist-cons var alias (##sys#current-environment))))
1331			    (walk
1332			     `(##core#let (,(let ((size (bytes->words (estimate-foreign-result-location-size type))))
1333				       ;; Add 2 words: 1 for the header, 1 for double-alignment:
1334				       ;; Note: C_a_i_bytevector takes number of words, not bytes
1335				       (list
1336					store
1337					`(##core#inline_allocate
1338					  ("C_a_i_bytevector" ,(+ 2 size))
1339					  ',size)) ) )
1340				(##core#begin
1341				 ,@(if init
1342				       `((##core#set! ,alias ,init))
1343				       '() )
1344				 ,(if init (fifth x) (fourth x)) ) )
1345			     e
1346			     dest ldest h ln #f)) ) )
1347
1348			((##core#define-inline)
1349			 (let* ((name (second x))
1350				(val `(##core#lambda ,@(cdaddr x)))
1351				(ln (get-line-number x)))
1352			   (unless tl?
1353			     (quit-compiling
1354			      "~ainline definition of `~s' in non-toplevel context"
1355			      (if ln (sprintf "(~a) - " ln) "")
1356			      name))
1357			     (hash-table-set! inline-table name val)
1358			     '(##core#undefined)))
1359
1360			((##core#define-constant)
1361			 (let* ((name (second x))
1362				(ln (get-line-number x))
1363				(valexp (third x))
1364				(val (handle-exceptions ex
1365					 ;; could show line number here
1366					 (quit-compiling "error in constant evaluation of ~S for named constant `~S'"
1367					       valexp name)
1368				       (if (and (not (symbol? valexp))
1369						(collapsable-literal? valexp))
1370					   valexp
1371					   (eval
1372					    `(##core#let
1373					      ,defconstant-bindings ,valexp))))))
1374			   (unless tl?
1375			     (quit-compiling
1376			      "~aconstant definition of `~s' in non-toplevel context"
1377			      (if ln (sprintf "(~a) - " ln) "")
1378			      name))
1379			   (set! defconstant-bindings
1380			     (cons (list name `(##core#quote ,val)) defconstant-bindings))
1381			   (cond ((collapsable-literal? val)
1382				  (hash-table-set! constant-table name `(##core#quote ,val))
1383				  '(##core#undefined))
1384				 ((basic-literal? val)
1385				  (let ((var (gensym "constant")))
1386				    (hash-table-set! constant-table name var)
1387				    (hide-variable var)
1388				    (mark-variable var '##compiler#constant)
1389				    (mark-variable var '##compiler#always-bound)
1390				    (walk `(define ,var (##core#quote ,val)) e #f #f h ln tl?)))
1391				 (else
1392				  (quit-compiling
1393				   "~ainvalid compile-time value for named constant `~S'"
1394				   (if ln (sprintf "(~a) - " ln) "")
1395				   name)))))
1396
1397			((##core#declare)
1398			 (walk
1399			  `(##core#begin
1400			    ,@(map (lambda (d)
1401				     (process-declaration d lookup (lambda (id) (memq (lookup id) e))))
1402				   (cdr x) ) )
1403			  e #f #f h ln #f) )
1404
1405			((##core#foreign-callback-wrapper)
1406			 (let-values ([(args lam) (split-at (cdr x) 4)])
1407			   (let* ([lam (car lam)]
1408				  [raw-c-name (cadr (first args))]
1409				  [name (##sys#alias-global-hook raw-c-name #t dest)]
1410				  [rtype (cadr (third args))]
1411				  [atypes (cadr (fourth args))]
1412				  [vars (second lam)] )
1413			     (if (valid-c-identifier? raw-c-name)
1414				 (set! callback-names
1415				   (cons (cons raw-c-name name) callback-names))
1416				 (let ((ln (get-line-number x)))
1417				   (quit-compiling
1418				    "~aname `~S' of external definition is not a valid C identifier"
1419				    (if ln (sprintf "(~a) - " ln) "")
1420				    raw-c-name)))
1421			     (when (or (not (list? vars))
1422				       (not (list? atypes))
1423				       (not (= (length vars) (length atypes))) )
1424			       (##sys#syntax-error
1425				"non-matching or invalid argument list to foreign callback-wrapper"
1426				vars atypes) )
1427			     `(##core#foreign-callback-wrapper
1428			       ,@(mapwalk args e h ln #f)
1429			       ,(walk `(##core#lambda
1430					,vars
1431					(##core#let
1432					 ,(let loop ([vars vars] [types atypes])
1433					    (if (null? vars)
1434						'()
1435						(let ([var (car vars)]
1436						      [type (car types)] )
1437						  (cons
1438						   (list
1439						    var
1440						    (foreign-type-convert-result
1441						     (finish-foreign-result
1442						      (final-foreign-type type)
1443						      var)
1444						     type) )
1445						   (loop (cdr vars) (cdr types)) ) ) ) )
1446					 ,(foreign-type-convert-argument
1447					   `(##core#let
1448					     ()
1449					     ,@(cond
1450						((member
1451						  rtype
1452						  '((const nonnull-c-string)
1453						    (const nonnull-unsigned-c-string)
1454						    nonnull-unsigned-c-string
1455						    nonnull-c-string))
1456						 `((##sys#make-c-string
1457						    (##core#let
1458						     () ,@(cddr lam))
1459						    (##core#quote ,name))))
1460						((member
1461						  rtype
1462						  '((const c-string*)
1463						    (const unsigned-c-string*)
1464						    unsigned-c-string*
1465						    c-string*
1466						    c-string-list
1467						    c-string-list*))
1468						 (##sys#syntax-error
1469						  "not a valid result type for callback procedures"
1470						  rtype
1471						  name) )
1472						((member
1473						  rtype
1474						  '(c-string
1475						    (const unsigned-c-string)
1476						    unsigned-c-string
1477						    (const c-string)) )
1478						 `((##core#let
1479						    ((r (##core#let () ,@(cddr lam))))
1480						    (,(macro-alias 'and)
1481						     r
1482						     (##sys#make-c-string r (##core#quote ,name))) ) ) )
1483						(else (cddr lam)) ) )
1484					   rtype) ) )
1485				      e #f #f h ln #f) ) ) ) )
1486
1487			((##core#location)
1488			 (let ([sym (cadr x)])
1489			   (if (symbol? sym)
1490			       (cond ((assq (lookup sym) location-pointer-map)
1491				      => (lambda (a)
1492					   (walk
1493					    `(##sys#make-locative ,(second a) 0 #f (##core#quote location))
1494					    e #f #f h ln #f) ) )
1495				     ((assq sym external-to-pointer)
1496				      => (lambda (a) (walk (cdr a) e #f #f h ln #f)) )
1497				     ((assq sym callback-names)
1498				      `(##core#inline_ref (,(symbol->string sym) c-pointer)) )
1499				     (else
1500				      (walk
1501				       `(##sys#make-locative ,sym 0 #f (##core#quote location))
1502				       e #f #f h ln #f) ) )
1503			       (walk
1504				`(##sys#make-locative ,sym 0 #f (##core#quote location))
1505				e #f #f h ln #f) ) ) )
1506
1507			(else
1508			 (let* ((x2 (fluid-let ((##sys#syntax-context
1509						 (cons name ##sys#syntax-context)))
1510				      (mapwalk x e h ln tl?)))
1511				(head2 (car x2))
1512				(old (hash-table-ref line-number-database-2 head2)))
1513			   (when ln
1514			     (hash-table-set!
1515			      line-number-database-2
1516			      head2
1517			      (cons name (alist-cons x2 ln (if old (cdr old) '()))) ) )
1518			   x2))))))))
1519
1520	  ((not (list? x))
1521	   (##sys#syntax-error/context "malformed expression" x) )
1522
1523	  ((constant? (car x))
1524	   (emit-syntax-trace-info x #f)
1525	   (warning "literal in operator position" x)
1526	   (mapwalk x e h outer-ln tl?) )
1527
1528	  (else
1529	   (emit-syntax-trace-info x #f)
1530	   (let ((tmp (gensym)))
1531	     (walk
1532	      `(##core#let
1533		((,tmp ,(car x)))
1534		(,tmp ,@(cdr x)))
1535	      e dest ldest h outer-ln #f)))))
1536
1537  (define (mapwalk xs e h ln tl?)
1538    (map (lambda (x) (walk x e #f #f h ln tl?)) xs) )
1539
1540  (when (memq 'c debugging-chicken) (newline) (pretty-print exp))
1541  (foreign-code "C_clear_trace_buffer();")
1542  ;; Process visited definitions and main expression:
1543  (walk
1544   `(##core#begin
1545     ,@(let ([p (reverse pending-canonicalizations)])
1546	 (set! pending-canonicalizations '())
1547	 p)
1548     ,(begin
1549	(set! extended-bindings (append internal-bindings extended-bindings))
1550	exp) )
1551   '() #f #f #f #f #t) ) )
1552
1553
1554(define (process-declaration spec lookup local?)
1555  (define (check-decl spec minlen . maxlen)
1556    (let ([n (length (cdr spec))])
1557      (if (or (< n minlen) (> n (optional maxlen 99999)))
1558	  (##sys#syntax-error "invalid declaration" spec) ) ) )
1559  (define (globalize var)
1560    (cond ((local? var)
1561	   (note-local var)
1562	   #f)
1563	  (else (##sys#alias-global-hook (lookup var) #t #f))))
1564  (define (globalize-all vars)
1565    (filter-map globalize vars))
1566  (define (note-local var)
1567    (##sys#notice
1568     (sprintf "ignoring declaration for locally bound variable `~a'" var)))
1569  (call-with-current-continuation
1570   (lambda (return)
1571     (unless (pair? spec)
1572       (##sys#syntax-error "invalid declaration specification" spec) )
1573     (case (strip-syntax (car spec)) ; no global aliasing
1574       ((uses)
1575	(let ((units (strip-syntax (cdr spec))))
1576	  (set! used-libraries (lset-union/eq? used-libraries units))
1577	  (set! linked-libraries (lset-union/eq? linked-libraries units))))
1578       ((unit)
1579	(check-decl spec 1 1)
1580	(let ((u (strip-syntax (cadr spec))))
1581	  (when (and unit-name (not (eq? unit-name u)))
1582	    (warning "unit was already given a name (new name is ignored)"))
1583	  (set! unit-name u)
1584	  (set! standalone-executable #f)))
1585       ((standard-bindings)
1586	(if (null? (cdr spec))
1587	    (set! standard-bindings default-standard-bindings)
1588	    (set! standard-bindings (append (globalize-all (cdr spec)) standard-bindings)) ) )
1589       ((extended-bindings)
1590	(if (null? (cdr spec))
1591	    (set! extended-bindings default-extended-bindings)
1592	    (set! extended-bindings (append (globalize-all (cdr spec)) extended-bindings)) ) )
1593       ((usual-integrations)
1594	(cond [(null? (cdr spec))
1595	       (set! standard-bindings default-standard-bindings)
1596	       (set! extended-bindings default-extended-bindings) ]
1597	      [else
1598	       (let ([syms (globalize-all (cdr spec))])
1599		 (set! standard-bindings (lset-intersection/eq? syms default-standard-bindings))
1600		 (set! extended-bindings (lset-intersection/eq? syms default-extended-bindings)))]))
1601       ((number-type)
1602	(check-decl spec 1 1)
1603	(set! number-type (strip-syntax (cadr spec))))
1604       ((fixnum fixnum-arithmetic) (set! number-type 'fixnum))
1605       ((generic) (set! number-type 'generic))
1606       ((unsafe) (set! unsafe #t))
1607       ((safe) (set! unsafe #f))
1608       ((no-bound-checks) (set! no-bound-checks #t))
1609       ((no-argc-checks) (set! no-argc-checks #t))
1610       ((no-procedure-checks) (set! no-procedure-checks #t))
1611       ((disable-interrupts) (set! insert-timer-checks #f))
1612       ((always-bound)
1613	(for-each (cut mark-variable <> '##compiler#always-bound) (cdr spec)))
1614       ((safe-globals) (set! safe-globals-flag #t))
1615       ((no-procedure-checks-for-usual-bindings)
1616	(for-each
1617	 (cut mark-variable <> '##compiler#always-bound-to-procedure)
1618	 (append default-standard-bindings default-extended-bindings))
1619	(for-each
1620	 (cut mark-variable <> '##compiler#always-bound)
1621	 (append default-standard-bindings default-extended-bindings)))
1622       ((no-procedure-checks-for-toplevel-bindings)
1623	(set! no-global-procedure-checks #t))
1624       ((bound-to-procedure)
1625	(let ((vars (globalize-all (cdr spec))))
1626	  (for-each (cut mark-variable <> '##compiler#always-bound-to-procedure) vars)
1627	  (for-each (cut mark-variable <> '##compiler#always-bound) vars)))
1628       ((foreign-declare)
1629	(let ([fds (cdr spec)])
1630	  (if (every string? fds)
1631	      (set! foreign-declarations (append foreign-declarations fds))
1632	      (##sys#syntax-error 'declare "invalid declaration" spec) ) ) )
1633       ((block) (set! block-compilation #t))
1634       ((separate) (set! block-compilation #f))
1635       ((keep-shadowed-macros) (set! undefine-shadowed-macros #f))
1636       ((unused)
1637	(for-each (cut mark-variable <> '##compiler#unused) (globalize-all (cdr spec))))
1638       ((enforce-argument-types)
1639	(for-each
1640	 (cut mark-variable <> '##compiler#enforce)
1641	 (globalize-all (cdr spec))))
1642       ((not)
1643	(check-decl spec 1)
1644	(case (strip-syntax (second spec)) ; strip all
1645	  [(standard-bindings)
1646	   (if (null? (cddr spec))
1647	       (set! standard-bindings '())
1648	       (set! standard-bindings
1649		 (lset-difference/eq? default-standard-bindings
1650				      (globalize-all (cddr spec)))))]
1651	  [(extended-bindings)
1652	   (if (null? (cddr spec))
1653	       (set! extended-bindings '())
1654	       (set! extended-bindings
1655		 (lset-difference/eq? default-extended-bindings
1656				      (globalize-all (cddr spec)))))]
1657	  [(inline)
1658	   (if (null? (cddr spec))
1659	       (set! inline-locally #f)
1660	       (for-each
1661		(cut mark-variable <> '##compiler#inline 'no)
1662		(globalize-all (cddr spec)))) ]
1663	  [(usual-integrations)
1664	   (cond [(null? (cddr spec))
1665		  (set! standard-bindings '())
1666		  (set! extended-bindings '()) ]
1667		 [else
1668		  (let ([syms (globalize-all (cddr spec))])
1669		    (set! standard-bindings (lset-difference/eq? default-standard-bindings syms))
1670		    (set! extended-bindings (lset-difference/eq? default-extended-bindings syms)))])]
1671	  ((inline-global)
1672	   (set! enable-inline-files #t)
1673	   (when (pair? (cddr spec))
1674	     (for-each
1675	      (cut mark-variable <> '##compiler#inline-global 'no)
1676	      (globalize-all (cddr spec)))))
1677	  [else
1678	   (check-decl spec 1 1)
1679	   (let ((id (strip-syntax (cadr spec))))
1680	     (case id
1681	       [(safe) (set! unsafe #t)]
1682	       [else (warning "unsupported declaration specifier" id)]))]))
1683       ((compile-syntax)
1684	(set! ##sys#enable-runtime-macros #t))
1685       ((block-global hide)
1686	(let ([syms (globalize-all (cdr spec))])
1687	  (if (null? syms)
1688	      (set! block-compilation #t)
1689	      (for-each hide-variable syms))))
1690       ((export)
1691	(set! block-compilation #t)
1692	(let ((syms (globalize-all (cdr spec))))
1693	  (for-each export-variable syms)))
1694       ((emit-external-prototypes-first)
1695	(set! external-protos-first #t) )
1696       ((inline)
1697	(if (null? (cdr spec))
1698	    (set! inline-locally #t)
1699	    (for-each
1700	     (cut mark-variable <> '##compiler#local)
1701	     (globalize-all (cdr spec)))))
1702       ((inline-limit)
1703	(check-decl spec 1 1)
1704	(let ([n (cadr spec)])
1705	  (if (number? n)
1706	      (set! inline-max-size n)
1707	      (warning
1708	       "invalid argument to `inline-limit' declaration"
1709	       spec) ) ) )
1710       ((unroll-limit)
1711	(check-decl spec 1 1)
1712	(let ((n (cadr spec)))
1713	  (if (number? n)
1714	      (set! unroll-limit n)
1715	      (warning
1716	       "invalid argument to `unroll-limit' declaration"
1717	       spec) ) ) )
1718       ((pure)
1719	(let ((syms (globalize-all (cdr spec))))
1720	  (if (every symbol? syms)
1721	      (for-each
1722	       (cut mark-variable <> '##compiler#pure #t)
1723	       (globalize-all syms))
1724	      (quit-compiling
1725	       "invalid arguments to `pure' declaration: ~S" spec))))
1726       ((emit-import-library)
1727	(set! import-libraries
1728	  (append
1729	   import-libraries
1730	   (map (lambda (il)
1731		  (cond ((symbol? il)
1732			 (cons il (string-append (symbol->string il) ".import.scm")) )
1733			((and (list? il) (= 2 (length il))
1734			      (symbol? (car il)) (string? (cadr il)))
1735			 (cons (car il) (cadr il)))
1736			(else
1737			 (quit-compiling "invalid `import-library' specification: ~S" il))))
1738		(strip-syntax (cdr spec))))))
1739	((emit-types-file)
1740	 (unless types-output-file
1741	   (set! types-output-file
1742	     (or (null? (cdr spec))
1743		 (and (string? (cadr spec)) (null? (cddr spec)) (cadr spec))
1744		 (quit-compiling "invalid `emit-types-file' declaration: ~S" spec)))))
1745       ((profile)
1746	(set! emit-profile #t)
1747	(cond ((null? (cdr spec))
1748	       (set! profiled-procedures 'all) )
1749	      (else
1750	       (set! profiled-procedures 'some)
1751	       (for-each
1752		(cut mark-variable <> '##compiler#profile)
1753		(globalize-all (cdr spec))))))
1754       ((local)
1755	(cond ((null? (cdr spec))
1756	       (set! local-definitions #t) )
1757	      (else
1758	       (for-each
1759		(cut mark-variable <> '##compiler#local)
1760		(globalize-all (cdr spec))))))
1761       ((inline-global)
1762	(set! enable-inline-files #t)
1763	(set! inline-locally #t)
1764	(when (pair? (cdr spec))
1765	  (for-each
1766	   (cut mark-variable <> '##compiler#inline-global 'yes)
1767	   (globalize-all (cdr spec)))))
1768       ((type)
1769	(for-each
1770	 (lambda (spec)
1771	   (if (not (and (list? spec)
1772			 (>= (length spec) 2)
1773			 (symbol? (car spec))))
1774	       (warning "illegal type declaration" (strip-syntax spec))
1775	       (let ((name (globalize (car spec)))
1776		     (type (strip-syntax (cadr spec))))
1777		 (if (local? (car spec))
1778		     (note-local (car spec))
1779		     (let-values (((type pred pure) (validate-type type name)))
1780		       (cond (type
1781			      ;; HACK: since `:' doesn't have access to the SE, we
1782			      ;; fixup the procedure name if type is a named procedure type
1783			      ;; Quite terrible.
1784			      (when (and (pair? type)
1785					 (eq? 'procedure (car type))
1786					 (symbol? (cadr type)))
1787				(set-car! (cdr type) name))
1788			      (mark-variable name '##compiler#type type)
1789			      (mark-variable name '##compiler#type-source 'local)
1790			      (when pure
1791				(mark-variable name '##compiler#pure #t))
1792			      (when pred
1793				(mark-variable name '##compiler#predicate pred))
1794			      (when (pair? (cddr spec))
1795				(install-specializations
1796				 name
1797				 (strip-syntax (cddr spec)))))
1798			     (else
1799			      (warning
1800			       "illegal `type' declaration"
1801			       (strip-syntax spec)))))))))
1802	 (cdr spec)))
1803       ((predicate)
1804	(for-each
1805	 (lambda (spec)
1806	   (cond ((and (list? spec) (symbol? (car spec)) (= 2 (length spec)))
1807		  (let ((name (globalize (car spec)))
1808			(type (strip-syntax (cadr spec))))
1809		    (if (local? (car spec))
1810			(note-local (car spec))
1811			(let-values (((type pred pure) (validate-type type name)))
1812			  (if (and type (not pred))
1813			      (mark-variable name '##compiler#predicate type)
1814			      (warning "illegal `predicate' declaration" spec))))))
1815		 (else
1816		  (warning "illegal `type' declaration item" spec))))
1817	 (cdr spec)))
1818       ((specialize)
1819	(set! enable-specialization #t))
1820       ((strict-types)
1821	(set! strict-variable-types #t))
1822       (else (warning "unknown declaration specifier" spec)) )
1823     '(##core#undefined) ) ) )
1824
1825
1826;;; Create entry procedure:
1827
1828(define (build-toplevel-procedure node)
1829  (make-node 'lambda '(()) (list node)))
1830
1831
1832;;; Expand "foreign-lambda"/"foreign-safe-lambda" forms and add item to stub-list:
1833
1834(define-record foreign-stub
1835  id			; symbol
1836  return-type	  ; type-specifier
1837  name 		  ; string or #f
1838  argument-types ; (type-specifier...)
1839  argument-names ; #f or (symbol ...)
1840  body		       ; #f or string
1841  cps		       ; boolean
1842  callback)	       ; boolean
1843
1844(define (create-foreign-stub rtype sname argtypes argnames body callback cps)
1845  ;; try to describe a foreign-lambda type specification
1846  ;; eg. (type->symbol '(c-pointer (struct "point"))) => point*
1847  (define (type->symbol type-spec)
1848    (let loop ([type type-spec])
1849      (cond
1850       ((null? type) 'a)
1851       ((list? type)
1852	(case (car type)
1853	  ((c-pointer) (string->symbol (conc (loop (cdr type)) "*"))) ;; if pointer, append *
1854	  ((const struct) (loop (cdr type))) ;; ignore these
1855	  (else (loop (car type)))))
1856       ((or (symbol? type) (string? type)) type)
1857       (else 'a))))
1858  (let* ((rtype (strip-syntax rtype))
1859	 (argtypes (strip-syntax argtypes))
1860	 (params (if argnames
1861		     (map gensym argnames)
1862		     (map (o gensym type->symbol) argtypes)))
1863	 (f-id (gensym 'stub))
1864	 (bufvar (gensym))
1865	 (rsize (estimate-foreign-result-size rtype)))
1866    (when sname (set-real-name! f-id (string->symbol sname)))
1867    (set! foreign-lambda-stubs
1868      (cons (make-foreign-stub f-id rtype sname argtypes argnames body cps callback)
1869	    foreign-lambda-stubs) )
1870    (let ([rsize (if callback (+ rsize 24) rsize)] ; 24 -> has to hold cons on 64-bit platforms!
1871	  [head (if cps
1872		    `((##core#primitive ,f-id))
1873		    `(##core#inline ,f-id) ) ]
1874	  [rest (map (lambda (p t) (foreign-type-check (foreign-type-convert-argument p t) t)) params argtypes)] )
1875      `(##core#lambda ,params
1876	 ;; Do minor GC (if callback) to make room on stack:
1877	 ,@(if callback '((##sys#gc #f)) '())
1878	 ,(if (zero? rsize)
1879	      (foreign-type-convert-result (append head (cons '(##core#undefined) rest)) rtype)
1880	      (let ([ft (final-foreign-type rtype)]
1881		    [ws (bytes->words rsize)] )
1882		`(##core#let ([,bufvar (##core#inline_allocate ("C_a_i_bytevector" ,(+ 2 ws)) (##core#quote ,ws))])
1883		   ,(foreign-type-convert-result
1884		     (finish-foreign-result ft (append head (cons bufvar rest)))
1885		     rtype) ) ) ) ) ) ) )
1886
1887(define (expand-foreign-lambda exp callback?)
1888  (let* ((name (third exp))
1889	 (sname (cond ((symbol? name) (symbol->string (strip-syntax name)))
1890		      ((string? name) name)
1891		      (else (quit-compiling
1892			     "name `~s' of foreign procedure has wrong type"
1893			     name)) ) )
1894	 (rtype (second exp))
1895	 (argtypes (cdddr exp)) )
1896    (create-foreign-stub rtype sname argtypes #f #f callback? callback?) ) )
1897
1898(define (expand-foreign-lambda* exp callback?)
1899  (let* ((rtype (second exp))
1900	 (args (third exp))
1901	 (body (string-intersperse (cdddr exp) "\n"))
1902 	 (argtypes (map (lambda (x) (car x)) args))
1903	 ;; C identifiers aren't hygienically renamed inside body strings
1904	 (argnames (map cadr (strip-syntax args))))
1905    (create-foreign-stub rtype #f argtypes argnames body callback? callback?) ) )
1906
1907;; TODO: Try to fold this procedure into expand-foreign-lambda*
1908(define (expand-foreign-primitive exp)
1909  (let* ((hasrtype (and (pair? (cddr exp)) (not (string? (caddr exp)))))
1910	 (rtype (if hasrtype (second exp) 'void))
1911	 (args (strip-syntax (if hasrtype (third exp) (second exp))))
1912	 (body (string-intersperse (if hasrtype (cdddr exp) (cddr exp)) "\n"))
1913 	 (argtypes (map (lambda (x) (car x)) args))
1914	 ;; C identifiers aren't hygienically renamed inside body strings
1915	 (argnames (map cadr (strip-syntax args))))
1916    (create-foreign-stub rtype #f argtypes argnames body #f #t) ) )
1917
1918
1919;;; Convert canonicalized node-graph into continuation-passing-style:
1920
1921(define (perform-cps-conversion node)
1922  (let ((called-units '()))
1923
1924  (define (cps-lambda id llist subs k)
1925    (let ([t1 (gensym 'k)])
1926      (k (make-node
1927	  '##core#lambda (list id #t (cons t1 llist) 0)
1928	  (list (walk (car subs)
1929		      (lambda (r)
1930			(make-node '##core#call (list #t) (list (varnode t1) r)) ) ) ) ) ) ) )
1931
1932  (define (node-for-var? node var)
1933     (and (eq? (node-class node) '##core#variable)
1934	  (eq? (car (node-parameters node)) var)))
1935
1936  (define (walk n k)
1937    (let ((subs (node-subexpressions n))
1938	  (params (node-parameters n))
1939	  (class (node-class n)) )
1940      (case (node-class n)
1941	((##core#variable quote ##core#undefined ##core#primitive ##core#provide)
1942          (k n))
1943	((if) (let* ((t1 (gensym 'k))
1944		     (t2 (gensym 'r))
1945		     (k1 (lambda (r) (make-node '##core#call (list #t) (list (varnode t1) r)))) )
1946		(make-node
1947		 'let
1948		 (list t1)
1949		 (list (make-node '##core#lambda (list (gensym-f-id) #f (list t2) 0)
1950				  (list (k (varnode t2))) )
1951		       (walk (car subs)
1952			     (lambda (v)
1953			       (make-node 'if '()
1954					  (list v
1955						(walk (cadr subs) k1)
1956						(walk (caddr subs) k1) ) ) ) ) ) ) ) )
1957	((let)
1958	 (let loop ((vars params) (vals subs))
1959	   (if (null? vars)
1960	       (walk (car vals) k)
1961	       (walk (car vals)
1962		     (lambda (r)
1963		       (if (node-for-var? r (car vars)) ; Don't generate unneccessary lets
1964			   (loop (cdr vars) (cdr vals))
1965			   (make-node 'let
1966				      (list (car vars))
1967				      (list r (loop (cdr vars) (cdr vals))) )) ) ) ) ) )
1968	((lambda ##core#lambda) (cps-lambda (gensym-f-id) (first params) subs k))
1969	((set!) (let* ((t1 (gensym 't))
1970		       (immediate? (and (pair? (cdr params)) (cadr params)))
1971		       (new-params (list (first params) immediate?)))
1972		  (walk (car subs)
1973			(lambda (r)
1974			  (make-node 'let (list t1)
1975				     (list (make-node 'set! new-params (list r))
1976					   (k (varnode t1)) ) ) ) ) ) )
1977	((##core#foreign-callback-wrapper)
1978	 (let ((id (gensym-f-id))
1979	       (lam (first subs)) )
1980	   (register-foreign-callback-stub! id params)
1981	   (cps-lambda id (first (node-parameters lam)) (node-subexpressions lam) k) ) )
1982	((##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update ##core#inline_loc_ref
1983			##core#inline_loc_update ##core#debug-event)
1984	 (walk-inline-call class params subs k) )
1985	((##core#call) (walk-call (car subs) (cdr subs) params k))
1986	((##core#callunit)
1987	 (let ((unit (first params)))
1988	   (if (memq unit called-units)
1989	       (walk (make-node '##core#undefined '() '()) k)
1990	       (fluid-let ((called-units (cons unit called-units)))
1991		 (walk-call-unit unit k)))))
1992	((##core#the ##core#the/result)
1993	 ;; remove "the" nodes, as they are not used after scrutiny
1994	 (walk (car subs) k))
1995	((##core#typecase)
1996	 ;; same here, the last clause is chosen, exp is dropped
1997	 (walk (last subs) k))
1998	(else (bomb "bad node (cps)")) ) ) )
1999
2000  (define (walk-call fn args params k)
2001    (let ((t0 (gensym 'k))
2002	  (t3 (gensym 'r)) )
2003      (make-node
2004       'let (list t0)
2005       (list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0)
2006			(list (k (varnode t3))) )
2007	     (walk-arguments
2008	      args
2009	      (lambda (vars)
2010		(walk fn
2011		      (lambda (r)
2012			(make-node '##core#call params (cons* r (varnode t0) vars) ) ) ) ) ) ) ) ) )
2013
2014  (define (walk-call-unit unitname k)
2015    (let ((t0 (gensym 'k))
2016	  (t3 (gensym 'r)) )
2017      (make-node
2018       'let (list t0)
2019       (list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0)
2020			(list (k (varnode t3))) )
2021	     (make-node '##core#callunit (list unitname)
2022			(list (varnode t0)) ) ) ) ) )
2023
2024  (define (walk-inline-call class op args k)
2025    (walk-arguments
2026     args
2027     (lambda (vars)
2028       (k (make-node class op vars)) ) ) )
2029
2030  (define (walk-arguments args wk)
2031    (let loop ((args args) (vars '()))
2032      (cond ((null? args) (wk (reverse vars)))
2033	    ((atomic? (car args))
2034	     (loop (cdr args) (cons (car args) vars)) )
2035	    (else
2036	     (let ((t1 (gensym 'a)))
2037	       (walk (car args)
2038		     (lambda (r)
2039		       (if (node-for-var? r t1) ; Don't generate unneccessary lets
2040			   (loop (cdr args) (cons (varnode t1) vars) )
2041			   (make-node 'let (list t1)
2042				      (list r
2043					    (loop (cdr args)
2044						  (cons (varnode t1) vars) ) ) )) ) ) ) ) ) ) )
2045
2046  (define (atomic? n)
2047    (let ((class (node-class n)))
2048      (or (memq class '(quote ##core#variable ##core#undefined))
2049	  (and (memq class '(##core#inline_allocate
2050			     ##core#inline_ref ##core#inline_update
2051			     ##core#inline_loc_ref ##core#inline_loc_update))
2052	       (every atomic? (node-subexpressions n)) ) ) ) )
2053
2054  (walk node values)))
2055
2056
2057;;; Perform source-code analysis:
2058
2059(define (analyze-expression node)
2060  ;; Avoid crowded hash tables by using previous run's size as heuristic
2061  (let* ((db-size (fx* (fxmax current-analysis-database-size 1) 3))
2062	 (db (make-vector db-size '())))
2063
2064    (define (grow n)
2065      (set! current-program-size (+ current-program-size n)) )
2066
2067    ;; fullenv is constantly (append localenv env). It's there to avoid
2068    ;; exponential behaviour by APPEND calls when compiling deeply nested LETs
2069    (define (walk n env localenv fullenv here)
2070      (let ((subs (node-subexpressions n))
2071	    (params (node-parameters n))
2072	    (class (node-class n)) )
2073	(grow 1)
2074	(case class
2075	  ((quote ##core#undefined ##core#provide ##core#proc) #f)
2076
2077	  ;; Uneliminated rest-cdr calls need to hang on to rest var
2078	  ((##core#variable ##core#rest-cdr)
2079	   (let ((var (first params)))
2080	     (ref var n)
2081	     (unless (memq var localenv)
2082	       (grow 1)
2083	       (cond ((memq var env)
2084		      (db-put! db var 'captured #t))
2085		     ((not (db-get db var 'global))
2086		      (db-put! db var 'global #t) ) ) ) ) )
2087
2088	  ((##core#callunit ##core#recurse)
2089	   (grow 1)
2090	   (walkeach subs env localenv fullenv here))
2091
2092	  ((##core#call)
2093	   (grow 1)
2094	   (let ([fun (car subs)])
2095	     (when (eq? '##core#variable (node-class fun))
2096	       (let* ((name (first (node-parameters fun)))
2097                      (val (db-get db name 'value)))
2098                 (when (and val
2099                            (eq? '##core#lambda (node-class val))
2100                            (not (llist-match? (third (node-parameters val))
2101                                               (cdr subs))))
2102                   (db-put! db name 'has-bad-calls #t))
2103		 (collect! db name 'call-sites (cons here n))))
2104	     (walk (first subs) env localenv fullenv here)
2105	     (walkeach (cdr subs) env localenv fullenv here)))
2106
2107	  ((let ##core#let)
2108	   (let ([env2 (append params fullenv)])
2109	     (let loop ([vars params] [vals subs])
2110	       (if (null? vars)
2111		   (walk (car vals) env (append params localenv) env2 here)
2112		   (let ([var (car vars)]
2113			 [val (car vals)] )
2114		     (db-put! db var 'home here)
2115		     (assign var val env2 here)
2116		     (walk val env localenv fullenv here)
2117		     (loop (cdr vars) (cdr vals)) ) ) ) ) )
2118
2119	  ((lambda) ; this is an intermediate lambda, slightly different
2120	   (grow 1) ; from '##core#lambda nodes (params = (LLIST));
2121	   (##sys#decompose-lambda-list	; CPS will convert this into ##core#lambda
2122	    (first params)
2123	    (lambda (vars argc rest)
2124	      (for-each
2125	       (lambda (var) (db-put! db var 'unknown #t))
2126	       vars)
2127	      (let ([tl toplevel-scope])
2128		(set! toplevel-scope #f)
2129		(walk (car subs) fullenv vars (append vars fullenv) #f)
2130		(set! toplevel-scope tl) ) ) ) )
2131
2132	  ((##core#lambda ##core#direct_lambda)
2133	   (grow 1)
2134	   (##sys#decompose-lambda-list
2135	    (third params)
2136	    (lambda (vars argc rest)
2137	      (let ([id (first params)]
2138		    [size0 current-program-size] )
2139		(when here
2140		  (collect! db here 'contains id)
2141		  (db-put! db id 'contained-in here) )
2142		(for-each
2143		 (lambda (var)
2144		   (db-put! db var 'home here)
2145		   (db-put! db var 'unknown #t) )
2146		 vars)
2147		(when rest
2148		  (db-put! db rest 'rest-parameter 'list)
2149		  (db-put! db rest 'rest-cdr (cons rest 0)))
2150		(when (simple-lambda-node? n) (db-put! db id 'simple #t))
2151		(let ([tl toplevel-scope])
2152		  (unless toplevel-lambda-id (set! toplevel-lambda-id id))
2153		  (when (and (second params) (not (eq? toplevel-lambda-id id)))
2154		    (set! toplevel-scope #f)) ; only if non-CPS lambda
2155		  (walk (car subs) fullenv vars (append vars fullenv) id)
2156		  (set! toplevel-scope tl)
2157		  ;; decorate ##core#call node with size
2158		  (set-car! (cdddr (node-parameters n)) (- current-program-size size0)) ) ) ) ) )
2159
2160	  ((set! ##core#set!) 		;XXX ##core#set! still used?
2161	   (let* ((var (first params))
2162		  (val (car subs)) )
2163	     (when (and first-analysis (not bootstrap-mode))
2164	       (case (variable-mark var '##compiler#intrinsic)
2165		 ((standard)
2166		  (warning "redefinition of standard binding" var) )
2167		 ((extended)
2168		  (warning "redefinition of extended binding" var) ) ))
2169	     (collect! db var 'potential-values val)
2170	     (unless (memq var localenv)
2171	       (grow 1)
2172	       (cond ((memq var env)
2173		      (db-put! db var 'captured #t))
2174		     ((not (db-get db var 'global))
2175		      (db-put! db var 'global #t) ) ) )
2176	     (assign var val fullenv here)
2177	     (unless toplevel-scope (db-put! db var 'assigned-locally #t))
2178	     (db-put! db var 'assigned #t)
2179	     (walk (car subs) env localenv fullenv here)))
2180
2181	  ((##core#primitive ##core#inline)
2182	   (let ((id (first params)))
2183	     (when (and first-analysis here (symbol? id) (get-real-name id))
2184	       (set-real-name! id here) )
2185	     (walkeach subs env localenv fullenv here)))
2186
2187	  (else (walkeach subs env localenv fullenv here)))))
2188
2189    (define (walkeach xs env lenv fenv here)
2190      (for-each (lambda (x) (walk x env lenv fenv here)) xs) )
2191
2192    (define (mark-rest-cdr var rvar depth)
2193      (db-put! db var 'rest-cdr (cons rvar depth))
2194      (collect! db rvar 'derived-rest-vars var))
2195
2196    (define (mark-rest-null? var rvar depth)
2197      (db-put! db var 'rest-null? (cons rvar depth))
2198      (collect! db rvar 'derived-rest-vars var))
2199
2200    (define (assign var val env here)
2201      ;; Propagate rest-cdr and rest-null? onto aliased variables
2202      (and-let* (((eq? '##core#variable (node-class val)))
2203		 (v (db-get db (first (node-parameters val)) 'rest-cdr)))
2204	(mark-rest-cdr var (car v) (cdr v)) )
2205
2206      (and-let* (((eq? '##core#variable (node-class val)))
2207		 (v (db-get db (first (node-parameters val)) 'rest-null?)))
2208	(mark-rest-null? var (car v) (cdr v)) )
2209
2210      (cond ((eq? '##core#undefined (node-class val))
2211	     (db-put! db var 'undefined #t) )
2212	    ((and (eq? '##core#variable (node-class val)) ; assignment to itself
2213		  (eq? var (first (node-parameters val))) ) )
2214
2215	    ;; Propagate info from ##core#rest-{cdr,null?} nodes to var
2216	    ((eq? '##core#rest-cdr (node-class val))
2217	     (let ((restvar (car (node-parameters val)))
2218		   (depth (cadr (node-parameters val))))
2219	       (mark-rest-cdr var restvar (add1 depth)) ) )
2220
2221	    ((eq? '##core#rest-null? (node-class val))
2222	     (let ((restvar (car (node-parameters val)))
2223		   (depth (cadr (node-parameters val))))
2224	       (mark-rest-null? var restvar depth) ) )
2225
2226	    ;; (##core#cond (null? r) '() (cdr r)) => result is tagged as a rest-cdr var
2227	    ((and-let* ((env (match-node val '(##core#cond ()
2228							   (##core#variable (test-var))
2229							   (quote (()))
2230							   (##core#rest-cdr (rvar depth)))
2231					 '(test-var rvar depth)))
2232			((db-get db (alist-ref 'test-var env) 'rest-null?)))
2233	       env)
2234	     => (lambda (env)
2235		  (let ((rvar (alist-ref 'rvar env))
2236			(depth (alist-ref 'depth env)))
2237		    (mark-rest-cdr var rvar (add1 depth)) ) ) )
2238
2239	    ((or (memq var env)
2240		 (variable-mark var '##compiler#constant)
2241		 (not (variable-visible? var block-compilation)))
2242	     (let ((props (db-get-all db var 'unknown 'value))
2243		   (home (db-get db var 'home)) )
2244	       (unless (assq 'unknown props)
2245		 (if (assq 'value props)
2246		     (db-put! db var 'unknown #t)
2247		     (if (or (not home) (eq? here home))
2248			 (db-put! db var 'value val)
2249			 (db-put! db var 'unknown #t) ) ) ) ) )
2250	    ((and (or local-definitions
2251		      (variable-mark var '##compiler#local))
2252		  (not (db-get db var 'unknown)))
2253	     (let ((home (db-get db var 'home)))
2254	       (cond ((db-get db var 'local-value)
2255		      (db-put! db var 'unknown #t))
2256		     ((or (not home) (eq? here home))
2257		      (db-put! db var 'local-value val)	       )
2258		     (else (db-put! db var 'unknown #t)))))
2259	    (else (db-put! db var 'unknown #t)) ) )
2260
2261    (define (ref var node)
2262      (collect! db var 'references node) )
2263
2264    (define (quick-put! plist prop val)
2265      (set-cdr! plist (alist-cons prop val (cdr plist))) )
2266
2267    ;; Walk toplevel expression-node:
2268    (debugging 'p "analysis traversal phase...")
2269    (set! current-program-size 0)
2270    (walk node '() '() '() #f)
2271
2272    ;; Complete gathered database information:
2273    (debugging 'p "analysis gathering phase...")
2274    (set! current-analysis-database-size 0)
2275    (hash-table-for-each
2276     (lambda (sym plist)
2277       (let ([unknown #f]
2278	     [value #f]
2279	     [local-value #f]
2280	     [potential-values #f]
2281	     [references '()]
2282	     [captured #f]
2283	     [call-sites '()]
2284	     [assigned #f]
2285	     [assigned-locally #f]
2286	     [undefined #f]
2287	     [global #f]
2288	     [nreferences 0]
2289	     [rest-cdr #f]
2290	     [ncall-sites 0] )
2291
2292	 (set! current-analysis-database-size (fx+ current-analysis-database-size 1))
2293
2294	 (for-each
2295	  (lambda (prop)
2296	    (case (car prop)
2297	      [(unknown) (set! unknown #t)]
2298	      [(references)
2299	       (set! references (cdr prop))
2300	       (set! nreferences (length references)) ]
2301	      [(captured) (set! captured #t)]
2302	      [(potential-values)
2303	       (set! potential-values (cdr prop))]
2304	      [(call-sites)
2305	       (set! call-sites (cdr prop))
2306	       (set! ncall-sites (length call-sites)) ]
2307	      [(assigned) (set! assigned #t)]
2308	      [(assigned-locally) (set! assigned-locally #t)]
2309	      [(undefined) (set! undefined #t)]
2310	      [(global) (set! global #t)]
2311	      [(value) (set! value (cdr prop))]
2312	      [(local-value) (set! local-value (cdr prop))]
2313	      [(rest-cdr) (set! rest-cdr (cdr prop))] ) )
2314	  plist)
2315
2316	 (set! value (and (not unknown) value))
2317	 (set! local-value (and (not unknown) local-value))
2318
2319	 ;; If this is the first analysis, register known local or potentially known global
2320	 ;;  lambda-value id's along with their names:
2321         (when first-analysis
2322	   (and-let* ((vals (or (and value (list value))
2323				(and global potential-values))))
2324	     (for-each
2325	      (lambda (val)
2326		(when (eq? (node-class val) '##core#lambda)
2327		  (set-real-name! (first (node-parameters val)) sym)))
2328	      vals)))
2329
2330	 ;; If this is the first analysis and the variable is global and has no references
2331	 ;;  and is hidden then issue warning:
2332	 (when (and first-analysis
2333		    global
2334		    (null? references)
2335		    (not (variable-mark sym '##compiler#unused))
2336		    (not (variable-hidden? sym))
2337		    (not (variable-visible? sym block-compilation))
2338		    (not (variable-mark sym '##compiler#constant)) )
2339	   (##sys#notice
2340	    (sprintf "global variable `~S' is only locally visible and never used"
2341	      sym) ) )
2342
2343 	 ;; Make 'boxed, if 'assigned & 'captured:
2344	 (when (and assigned captured)
2345	   (quick-put! plist 'boxed #t) )
2346
2347	 ;; Make 'contractable, if it has a procedure as known value, has only one use
2348	 ;;  and one call-site and if the lambda has no free non-global variables
2349	 ;;  or is an internal lambda. Make 'inlinable if
2350	 ;;  use/call count is not 1:
2351	 (cond (value
2352		(let ((valparams (node-parameters value)))
2353		  (when (and (eq? '##core#lambda (node-class value))
2354			     (or (not (second valparams))
2355				 (every
2356				  (lambda (v) (db-get db v 'global))
2357				  (nth-value 0 (scan-free-variables
2358						value block-compilation)) ) ) )
2359		    (if (and (not (db-get db sym 'has-bad-calls)) (= 1 nreferences) (= 1 ncall-sites))
2360			(quick-put! plist 'contractable #t)
2361			(quick-put! plist 'inlinable #t) ) ) ) )
2362	       (local-value
2363		;; Make 'inlinable, if it is declared local and has a value
2364		(let ((valparams (node-parameters local-value)))
2365		  (when (eq? '##core#lambda (node-class local-value))
2366		    (let-values (((vars hvars) (scan-free-variables
2367						local-value block-compilation)))
2368		      (when (and (db-get db sym 'global)
2369				 (pair? hvars))
2370			(quick-put! plist 'hidden-refs #t))
2371		      (when (or (not (second valparams))
2372				(every
2373				 (lambda (v) (db-get db v 'global))
2374				 vars))
2375			(quick-put! plist 'inlinable #t) ) ) ) ) )
2376	       ((variable-mark sym '##compiler#inline-global) =>
2377		(lambda (n)
2378		  (when (node? n)
2379		    (cond (assigned
2380			   (debugging
2381			    'i
2382			    "global inlining candidate was assigned and will not be inlined"
2383			    sym)
2384			   (mark-variable sym '##compiler#inline-global 'no))
2385			  (else
2386			   (let ((lparams (node-parameters n)))
2387			     (quick-put! plist 'inlinable #t)
2388			     (quick-put! plist 'local-value n))))))))
2389
2390	 ;; Make 'collapsable, if it has a known constant value which
2391	 ;; is either collapsable or is only referenced once:
2392	 (when (and value (eq? 'quote (node-class value)) )
2393	   (let ((val (first (node-parameters value))))
2394	     (when (or (collapsable-literal? val)
2395		       (= 1 nreferences) )
2396	       (quick-put! plist 'collapsable #t) ) ) )
2397
2398         (and-let* ((val (or local-value value))
2399                    ((eq? '##core#lambda (node-class val)))
2400	            ((rassoc sym callback-names eq?)))
2401           (let ((lparams (node-parameters val)))
2402             (db-put! db (first lparams) 'callback #t)))
2403
2404	 ;; If it has a known value that is a procedure, and if the number of call-sites is equal to the
2405	 ;;  number of references (does not escape), then make all formal parameters 'unused which are
2406	 ;;  never referenced or assigned (if no rest parameter exist):
2407	 ;;  - also marks the procedure as 'has-unused-parameters (if not in `callback-names')
2408	 ;;  - if the procedure is internal (a continuation) do NOT mark unused parameters.
2409	 ;;  - also: if procedure has rest-parameter and no unused params, mark f-id as 'explicit-rest.
2410	 (when value
2411	   (let ((has #f))
2412	     (when (and (eq? '##core#lambda (node-class value))
2413			(= nreferences ncall-sites) )
2414	       (let ((lparams (node-parameters value)))
2415		 (when (second lparams)
2416		   (##sys#decompose-lambda-list
2417		    (third lparams)
2418		    (lambda (vars argc rest)
2419		      (unless rest
2420			(for-each
2421			 (lambda (var)
2422			   (cond ((and (not (db-get db var 'references))
2423				       (not (db-get db var 'assigned)) )
2424				  (db-put! db var 'unused #t)
2425				  (set! has #t)
2426				  #t)
2427				 (else #f) ) )
2428			 vars) )
2429		      (cond ((and has (not (rassoc sym callback-names eq?)))
2430			     (db-put! db (first lparams) 'has-unused-parameters #t) )
2431			    (rest
2432			     (db-put! db (first lparams) 'explicit-rest #t)
2433			     (db-put! db rest 'consed-rest-arg #t) ) ) ) ) ) ) ) ) )
2434
2435         ;; If it has a known or local value which is a procedure, and referenced only once
2436         ;; and only one call site or is an internal procedure, mark it as 'shareable-user so that
2437         ;; its closed over variables may be shared with its containing procedure.
2438         ;; Note that callbacks are exempt from this, because callback_wrapper creates an empty closure
2439         ;; manually, throwing away our carefully crafted closure. TODO: can maybe be done better?
2440         ;;
2441         ;; If furthermore it only contains a single other procedure, mark it as 'shareable-container
2442         ;; so that may share closed-over variables with that one procedure.
2443         (and-let* ((val (or local-value value))
2444                    ((eq? '##core#lambda (node-class val)))
2445                    (lparams (node-parameters val))
2446                    ((or (= 1 nreferences ncall-sites)
2447                         (not (second lparams))))
2448	            ((not (rassoc sym callback-names eq?))))
2449	   (db-put! db (first lparams) 'shareable-user #t)
2450           (and-let* ((id (first lparams))
2451                      (contains (or (db-get db id 'contains) '()))
2452                      ((= (length contains) 1)))
2453             ;; TODO: It should be possible to have escaping / global procedures be containers, but
2454             ;; they should not call themselves because then they might be setting variables in
2455             ;; the closure to different values at different times.  So for now we're extra careful
2456             ;; about which are containers.
2457             (db-put! db (first lparams) 'shareable-container #t)))
2458
2459	 ;; Make 'removable, if it has no references and is not assigned to, and one of the following:
2460	 ;; - it has either a value that does not cause any side-effects
2461	 ;; - it is 'undefined
2462	 ;; - it holds only a 'rest-cdr reference (strictly speaking, it may bomb but we don't care)
2463	 (when (and (not assigned)
2464		    (null? references)
2465		    (or (and value
2466			     (if (eq? '##core#variable (node-class value))
2467				 (let ((varname (first (node-parameters value))))
2468				   (or (not (db-get db varname 'global))
2469				       (variable-mark varname '##core#always-bound)
2470				       (intrinsic? varname)))
2471				 (not (expression-has-side-effects? value db)) ))
2472			undefined
2473			rest-cdr) )
2474	   (quick-put! plist 'removable #t) )
2475
2476	 ;; Make 'replacable, if
2477	 ;; - it has a variable as known value and
2478	 ;; - it is not a global
2479	 ;; - it is never assigned to and
2480	 ;; - if either the substitute has a known value itself or
2481	 ;;   * the substitute is never assigned to and
2482	 ;;   * we are in block-mode or the substitute is non-global
2483	 ;;
2484	 ;;  - The variable that can be substituted for the current one is marked as 'replacing.
2485	 ;;    This is done to prohibit beta-contraction of the replacing variable (It wouldn't be there, if
2486	 ;;    it was contracted).
2487	 (when (and value (not global))
2488	   (when (eq? '##core#variable (node-class value))
2489	     (let ((name (first (node-parameters value))) )
2490	       (when (and (not assigned)
2491			  (or (and (not (db-get db name 'unknown))
2492				   (db-get db name 'value))
2493			      (and (not (db-get db name 'assigned))
2494				   (or (not (variable-visible?
2495					     name block-compilation))
2496				       (not (db-get db name 'global))) ) ))
2497		 (quick-put! plist 'replacable name)
2498		 (db-put! db name 'replacing #t) ) ) ) )
2499
2500	 ;; Make 'replacable, if it has a known value of the form: '(lambda (<xvar>) (<kvar> <xvar>))' and
2501	 ;;  is an internally created procedure: (See above for 'replacing)
2502	 (when (and value (eq? '##core#lambda (node-class value)))
2503	   (let ((params (node-parameters value)))
2504	     (when (not (second params))
2505	       (let ((llist (third params))
2506		     (body (first (node-subexpressions value))) )
2507		 (when (and (pair? llist)
2508			    (null? (cdr llist))
2509			    (eq? '##core#call (node-class body)) )
2510		   (let ((subs (node-subexpressions body)))
2511		     (when (= 2 (length subs))
2512		       (let ((v1 (first subs))
2513			     (v2 (second subs)) )
2514			 (when (and (eq? '##core#variable (node-class v1))
2515				    (eq? '##core#variable (node-class v2))
2516				    (eq? (first llist) (first (node-parameters v2))) )
2517			   (let ((kvar (first (node-parameters v1))))
2518			     (quick-put! plist 'replacable kvar)
2519			     (db-put! db kvar 'replacing #t) ) ) ) ) ) ) ) ) ) ) ) )
2520
2521     db)
2522
2523    ;; Set original program-size, if this is the first analysis-pass:
2524    (unless original-program-size
2525      (set! original-program-size current-program-size) )
2526
2527    ;; return database
2528    db) )
2529
2530
2531;;; Collect unsafe global procedure calls that are assigned:
2532
2533;;; Convert closures to explicit data structures (effectively flattens function-binding
2534;   structure):
2535
2536(define (perform-closure-conversion node db)
2537  (let ((direct-calls 0)
2538        (sharing-containers 0)
2539        (sharing-users 0)
2540	(customizable '())
2541	(lexicals '())
2542        (escaping-shared-vars '()))
2543
2544    ;; O(n) version of delete-duplicates (which is O(n^2)) specific for symbols
2545    (define (delete-duplicate-symbols lst)
2546      (let ((seen (make-hash-table)))
2547        (let lp ((lst lst)
2548                 (result '()))
2549          (if (null? lst)
2550	      (reverse result)
2551	      (let ((x (car lst)))
2552	        (cond ((hash-table-ref seen x)
2553	               (lp (cdr lst) result))
2554                      (else
2555                       (hash-table-set! seen x #t)
2556	               (lp (cdr lst)
2557                           (cons x result)))))))))
2558
2559    ;; O(n+m) version of lset-difference/eq? (which is O(n*m)) specific for symbols
2560    (define (symbolset-difference ls . lss)
2561      (let ((seen (make-hash-table)))
2562        (for-each (lambda (lst)
2563                    (for-each (lambda (x) (hash-table-set! seen x #t)) lst))
2564                  lss)
2565        (remove (lambda (x) (hash-table-ref seen x)) ls)))
2566
2567    (define (symbolset= ls . lss)
2568      (every (lambda (lst)
2569               (and (null? (symbolset-difference ls lst))
2570                    (null? (symbolset-difference lst ls))))
2571             lss))
2572
2573    (define (test sym item) (db-get db sym item))
2574
2575    (define (register-customizable! var id)
2576      (set! customizable (lset-adjoin/eq? customizable var))
2577      (db-put! db id 'customizable #t) )
2578
2579    (define (register-direct-call! id)
2580      (set! direct-calls (add1 direct-calls))
2581      (set! direct-call-ids (lset-adjoin/eq? direct-call-ids id)))
2582
2583    ;; Gather free-variable information:
2584    ;; (and: - register direct calls
2585    ;;       - update (by mutation) call information in "##core#call" nodes)
2586    (define (gather n here locals)
2587      (let ((subs (node-subexpressions n))
2588	    (params (node-parameters n)) )
2589	(case (node-class n)
2590
2591	  ((##core#variable ##core#rest-cdr)
2592	   (let ((var (first params)))
2593	     (if (memq var lexicals)
2594		 (list var)
2595		 '())))
2596
2597	  ((quote ##core#undefined ##core#provide ##core#proc ##core#primitive)
2598	   '())
2599
2600	  ((let)
2601	   ;;XXX remove this test later, shouldn't be needed:
2602	   (when (pair? (cdr params)) (bomb "let-node has invalid format" params))
2603	   (let ((c (gather (first subs) here locals))
2604		 (var (first params)))
2605	     (append c (delete var (gather (second subs) here (cons var locals)) eq?))))
2606
2607	  ((set!)
2608	   (let ((var (first params))
2609		 (c (gather (first subs) here locals)))
2610	     (if (memq var lexicals)
2611		 (cons var c)
2612		 c)))
2613
2614	  ((##core#call)
2615	   (let* ([fn (first subs)]
2616		  [mode (first params)]
2617		  [name (and (pair? (cdr params)) (second params))]
2618		  [varfn (eq? '##core#variable (node-class fn))] )
2619	     (node-parameters-set!
2620	      n
2621	      (cons mode
2622		    (if (or name varfn)
2623			(cons name
2624			      (if varfn
2625				  (let* ([varname (first (node-parameters fn))]
2626					 [val (and (not (test varname 'unknown))
2627						   (not (eq?
2628							 'no
2629							 (variable-mark
2630							  varname '##compiler#inline)))
2631						   ;; May not be external, see #1665
2632						   (not (node? (variable-mark varname '##compiler#inline-global)))
2633						   (or (test varname 'value)
2634						       (test varname 'local-value)))] )
2635				    (if (and val (eq? '##core#lambda (node-class val)))
2636					(let* ([params (node-parameters val)]
2637					       [llist (third params)]
2638					       [id (first params)]
2639					       [refs (test varname 'references)]
2640					       [sites (test varname 'call-sites)]
2641					       [custom
2642						(and refs sites
2643						     (= (length refs) (length sites))
2644						     (test varname 'value)
2645						     (not (test varname 'has-bad-calls))
2646						     (list? llist) ) ] )
2647					  (cond ((and name
2648                                                      (not (llist-match? llist (cdr subs))))
2649                                                   '())
2650                                                (else
2651   					          (register-direct-call! id)
2652					          (when custom
2653					            (register-customizable! varname id))
2654					          (list id custom) ) ) )
2655					'() ) )
2656				  '() ) )
2657			'() ) ) )
2658	     (concatenate (map (lambda (n) (gather n here locals)) subs) ) ))
2659
2660	  ((##core#lambda ##core#direct_lambda)
2661	   (##sys#decompose-lambda-list
2662	    (third params)
2663	    (lambda (vars argc rest)
2664	      (let ((id (if here (first params) 'toplevel)))
2665		(fluid-let ((lexicals (append locals lexicals)))
2666		  (let ((c (delete-duplicate-symbols (gather (first subs) id vars))))
2667		    (db-put! db id 'closure-size (length c))
2668		    (db-put! db id 'captured-variables c)
2669		    (symbolset-difference c locals vars)))))))
2670
2671	  (else (concatenate (map (lambda (n) (gather n here locals)) subs)) ) ) ))
2672
2673
2674    ;; Merge shareable closures.  This allocates space for closed-over
2675    ;; variables of the longest unbroken line of sharing-users in the
2676    ;; sharing-container, mutating the database entries set up by
2677    ;; "gather" to account for this.
2678    (define (merge-shareable n shared-closure)
2679      (let ((subs (node-subexpressions n))
2680	    (params (node-parameters n)) )
2681	(case (node-class n)
2682
2683	  ((quote ##core#undefined ##core#provide ##core#proc ##core#primitive)
2684	   '())
2685
2686	  ((##core#lambda ##core#direct_lambda)
2687	   (##sys#decompose-lambda-list
2688	    (third params)
2689	    (lambda (vars argc rest)
2690	      (let* ((id (first params))
2691                     (this-closure (or (test id 'captured-variables) '())))
2692                (cond ((and shared-closure
2693                            (test id 'shareable-user)
2694                            ;; The user must close over all the shared closure vars, otherwise
2695                            ;; we risk extending the lifetime of these vars for too long.
2696                            (null? (symbolset-difference shared-closure this-closure))
2697                            ;; Minimum shared closure size - don't want to share a single var, it's extra indirection
2698                            (> (length this-closure) 1))
2699                       ;; We only pass on the container to the subs if this is also a shareable-container
2700                       (let ((sub-closure (merge-shareable (first subs) (and (test id 'shareable-container) this-closure))))
2701                         ;; Reset captured vars.  This closure only captures the container
2702                         (db-put! db id 'closure-size 1)
2703                         (db-put! db id 'captured-variables '())
2704                         (db-put! db id 'sharing-mode 'user)
2705                         (set! sharing-users (add1 sharing-users))
2706                         ;; Return the closed-over variables of this and the rest of the
2707                         ;; users in the chain to the container for allocation.
2708                         ;; Note that because the user always is a superset of the container,
2709                         ;; we can just return the "deepest" user
2710                         (if (null? sub-closure)
2711                             this-closure
2712                             sub-closure)))
2713
2714                      ((test id 'shareable-container)
2715                       ;; If we're starting a new container, any captured vars from the
2716                       ;; surrounding container will escape, like with a non-sharing closure
2717                       (set! escaping-shared-vars (lset-union/eq? escaping-shared-vars this-closure))
2718
2719                       (fluid-let ((escaping-shared-vars '()))
2720                         (let ((sub-closure (merge-shareable (first subs) this-closure)))
2721                           (unless (null? sub-closure)
2722                             ;; NOTE: We don't touch 'captured-variables, because the vars
2723                             ;; on initial entry of the sharing closures are unchanged.
2724                             ;; However, we do need to know the full closure
2725                             (db-put! db id 'closure-size (length sub-closure))
2726                             (db-put! db id 'sharing-mode 'container)
2727                             (db-put! db id 'shared-closure sub-closure)
2728                             (set! sharing-containers (add1 sharing-containers))
2729
2730                             ;; Shared vars introduced by users which don't escape don't have to be boxed
2731                             ;; because the shared closure container itself already acts as a box.
2732                             (let* ((user-introduced-vars (symbolset-difference sub-closure this-closure))
2733                                    (unboxable-vars (symbolset-difference user-introduced-vars escaping-shared-vars)))
2734                               (for-each (lambda (v)
2735                                           (when (test v 'boxed) ; Not strictly needed, but cleaner this way
2736                                             (db-put! db v 'boxed #f)))
2737                                         unboxable-vars)))))
2738                       ;; This is a new container, so do not allow higher-up containers
2739                       ;; to collect variables from this closure.
2740                       '())
2741
2742                      ;; All closed-over vars in non-user procedures "escape" the container (if any)
2743                      ;; and must remain boxed.
2744                      (else (set! escaping-shared-vars (lset-union/eq? escaping-shared-vars this-closure))
2745                            (merge-shareable (first subs) #f)
2746                            '()))))))
2747
2748	  (else (concatenate (map (lambda (n) (merge-shareable n shared-closure)) subs)) ) ) ))
2749
2750
2751    ;; Merge "reusable" closures.  The "shareable" closures above
2752    ;; require great care to be taken because variables are mutated
2753    ;; into the container closure by the user closure where they're
2754    ;; introduced, which should not be observable.  However, closures
2755    ;; where the full set of variables is already known may freely be
2756    ;; reused any number of times because they're immutable.
2757    ;; NOTE: Unboxing of non-escaping vars is not implemented yet.
2758    (define (merge-reusable n reusable-closure)
2759      (let ((subs (node-subexpressions n))
2760	    (params (node-parameters n)) )
2761	(case (node-class n)
2762
2763	  ((quote ##core#undefined ##core#provide ##core#proc ##core#primitive)
2764	   #f)
2765
2766	  ((##core#lambda ##core#direct_lambda)
2767	   (##sys#decompose-lambda-list
2768	    (third params)
2769	    (lambda (vars argc rest)
2770	      (let* ((id (first params))
2771                     (this-closure (or (test id 'shared-closure) (test id 'captured-variables) '()))
2772                     (sharing-mode (test id 'sharing-mode))
2773                     ;; Callbacks may not be reused (see TODO in analyze-expression)
2774                     (is-callback? (test id '##compiler#callback-lambda))
2775                     ;; We don't want existing containers or users' shared closures to be reused by contained closures.
2776                     ;; However, we do allow containers to be moved "up front" if there are other closures that
2777                     ;; share the same variables (which means there are no mutating assignments to closed-over vars).
2778                     (container-needed? (merge-reusable (first subs) (and (not sharing-mode)
2779                                                                          (not is-callback?)
2780                                                                          this-closure))))
2781                (cond ((and reusable-closure
2782                            (not is-callback?)
2783                            ;; The closure must match exactly with the reusable container
2784                            ;; Note that if the closure is already a container, we compare
2785                            ;; against its shared closure.  This is safe to do because
2786                            ;; if they're the same, no variables are updated via mutation.
2787                            (symbolset= reusable-closure this-closure)
2788                            ;; Minimum shared closure size - don't want to share a single var, it's extra indirection
2789                            (> (length this-closure) 1))
2790                       ;; Reset captured vars.  This closure only captures the container
2791                       (db-put! db id 'closure-size 1)
2792                       (db-put! db id 'captured-variables '())
2793                       (db-put! db id 'sharing-mode 'user)
2794                       (set! sharing-users (add1 sharing-users))
2795                       ;; If this closure was already marked as a container by merge-reusable-closures,
2796                       ;; we turn it into a user.  Adjust counter to reflect this.
2797                       (when (eq? sharing-mode 'container)
2798                         (set! sharing-containers (sub1 sharing-containers)))
2799                       ;; We'd like a container to be created in the creating closure
2800                       #t)
2801
2802                      ;; If this closure cannot be turned into a sharing user, we might need to
2803                      ;; turn it into a container if any of its subclosures were turned into a user.
2804                      (container-needed?
2805                       (db-put! db id 'sharing-mode 'container)
2806                       (db-put! db id 'shared-closure this-closure)
2807                       (set! sharing-containers (add1 sharing-containers))
2808                       ;; Its parent does not become a container
2809                       #f)
2810
2811                      ;; No reuse :'(
2812                      (else #f))))))
2813
2814	  (else (any (lambda (n) (merge-reusable n reusable-closure)) subs) ) ) ))
2815
2816
2817    ;; Create explicit closures:
2818    (define (transform n crefvar closure)
2819      (let ((subs (node-subexpressions n))
2820	    (params (node-parameters n))
2821	    (class (node-class n)) )
2822	(case class
2823
2824	  ((quote ##core#undefined ##core#provide ##core#proc ##core#float
2825           ##core#float-variable)
2826            n)
2827
2828	  ((##core#variable)
2829	   (let* ((var (first params))
2830		  (val (ref-var n crefvar closure)) )
2831	     (if (test var 'boxed)
2832		 (make-node '##core#unbox '() (list val))
2833		 val) ) )
2834
2835	  ((##core#rest-cdr ##core#rest-car ##core#rest-null? ##core#rest-length)
2836	   (let* ((val (ref-var n crefvar closure))
2837		  (rest-var (if (eq? val n) (varnode (first params)) val)))
2838	     ;; If rest-cdrs have not all been eliminated, restore
2839	     ;; them as regular cdr calls on the rest list variable.
2840	     ;; This can be improved, as it can actually introduce
2841	     ;; many more cdr calls than necessary.
2842	     (cond ((eq? class '##core#rest-cdr)
2843		    (transform (replace-rest-op-with-list-ops class rest-var params) crefvar closure))
2844
2845		   ;; If n isn't val, this node was processed and the
2846		   ;; variable got replaced by a closure access.
2847		   ((not (eq? val n))
2848		    (transform (replace-rest-op-with-list-ops class rest-var params) crefvar closure))
2849
2850		   (else val)) ) )
2851
2852	  ((if ##core#call ##core#inline ##core#inline_allocate ##core#callunit
2853	       ##core#inline_ref ##core#inline_update ##core#debug-event
2854	       ##core#switch ##core#cond ##core#direct_call ##core#recurse ##core#return
2855               ##core#let_float ##core#box_float ##core#unbox_float
2856	       ##core#inline_loc_ref
2857	       ##core#inline_loc_update)
2858	   (make-node (node-class n) params (maptransform subs crefvar closure)) )
2859
2860	  ((let)
2861	   (let* ([var (first params)]
2862		  [boxedvar (test var 'boxed)]
2863		  [boxedalias (gensym var)] )
2864	     (if boxedvar
2865		 (make-node
2866		  'let (list boxedalias)
2867		  (list (transform (first subs) crefvar closure)
2868			(make-node
2869			 'let (list var)
2870			 (list (make-node '##core#box '() (list (varnode boxedalias)))
2871			       (update-shared-closure-var var crefvar closure
2872                                                          (transform (second subs) crefvar closure))) )) )
2873		 (make-node
2874		  'let params
2875                  (list (transform (first subs) crefvar closure)
2876                        (update-shared-closure-var var crefvar closure
2877                                                   (transform (second subs) crefvar closure))) ) ) ) )
2878
2879	  ((##core#lambda ##core#direct_lambda)
2880	   (let ((llist (third params)))
2881	     (##sys#decompose-lambda-list
2882	      llist
2883	      (lambda (vars argc rest)
2884		(let* ((boxedvars (filter (lambda (v) (test v 'boxed)) vars))
2885		       (boxedaliases (map cons boxedvars (map gensym boxedvars)))
2886		       (cvar (gensym 'c))
2887                       (all-vars (if rest (cons rest vars) vars))
2888		       (id (if crefvar (first params) 'toplevel))
2889                       (sharing-mode (test id 'sharing-mode))
2890		       (capturedvars (if (eq? sharing-mode 'user)
2891					 (list #f) ; NOTE: Hacky way to indicate we want to pass on the closure
2892					 (or (test id 'captured-variables) '())))
2893		       (csize (or (test id 'closure-size) 0)) ; = (length new-closure) below
2894		       (info (and emit-closure-info (second params) (pair? llist)))
2895                       (new-crefvar (if (eq? sharing-mode 'user)
2896                                        ;; Users should not look up vars in their own closure, but in
2897                                        ;; the shared closure "container" (which is the only entry in their own closure)
2898                                        (gensym 'scc)
2899                                        cvar))
2900		       (new-closure (case sharing-mode
2901                                      ((container) (test id 'shared-closure)) ; Fresh container will hold the full shared closure
2902				      ((user)
2903                                       ;; Sharing user doesn't introduce new vars into closure, but uses shared container's closure
2904				       closure)
2905				      ;; Normal unshared closure is over its captured vars
2906				      (else capturedvars))))
2907		  ;; If rest-parameter is boxed: mark it as 'boxed-rest
2908		  ;;  (if we don't do this than preparation will think the (boxed) alias
2909		  ;;  of the rest-parameter is never used)
2910		  (and-let* ((rest)
2911			     ((test rest 'boxed))
2912			     (rp (test rest 'rest-parameter)) )
2913		    (db-put! db (cdr (assq rest boxedaliases)) 'boxed-rest #t) )
2914		  (make-node
2915		   '##core#closure (list (+ csize (if info 2 1)))
2916		   (cons
2917		    (make-node
2918		     class
2919		     (list id
2920			   (second params)
2921			   (cons
2922			    cvar
2923			    (build-lambda-list
2924			     (map (lambda (v)
2925				    (cond ((assq v boxedaliases) => cdr)
2926					  (else v) ) )
2927				  vars)
2928			     argc
2929			     (cond ((and rest (assq rest boxedaliases)) => cdr)
2930				   (else rest) ) ) )
2931			   (fourth params) )
2932		     (list (wrap-crefvar cvar new-crefvar
2933                                         (let ((body (update-shared-closure-vars all-vars new-crefvar new-closure
2934								                 (transform (car subs) new-crefvar new-closure))))
2935			                   (if (pair? boxedvars)
2936				               (let loop ((aliases (unzip1 boxedaliases))
2937					                  (values
2938					                   (map (lambda (a)
2939						                  (make-node '##core#box '() (list (varnode (cdr a)))))
2940						                boxedaliases) ))
2941				                 (if (null? aliases)
2942				                     body
2943				                     (make-node 'let (list (car aliases))
2944						                (list (car values)
2945							              (loop (cdr aliases) (cdr values))))))
2946				               body) )) ) )
2947		    (let ((cvars (map (lambda (v)
2948                                        ;; NOTE: This memq redundancy is needed because "gather" reorders lexicals
2949                                        ;; continually, so the index of the variables will differ between each user,
2950                                        ;; meaning the collected shared closure is differently ordered than the
2951                                        ;; capturedvars.  Otherwise, we could just map ref-var over capturedvars
2952                                        ;; and append a bunch of undefineds at the end.
2953                                        (cond ((not v) ; See capturedvars note above
2954                                               (varnode crefvar))
2955                                              ((memq v capturedvars)
2956                                               ;; If it's a captured var, put it in the closure at the appropriate spot
2957                                               (ref-var (varnode v) crefvar closure))
2958                                              (else
2959                                               ;; Shared closures have reserved spots which users further down will set!
2960                                               ;; to a proper value.  Init those as undefined.
2961                                               (make-node '##core#undefined '() '()))))
2962				      (if (eq? sharing-mode 'container)
2963                                          new-closure
2964                                          capturedvars))))
2965		      (if info
2966			  (append
2967			   cvars
2968			   (list
2969			    (qnode
2970			     (##sys#make-lambda-info
2971			      (->string (cons (or (real-name id) '?)
2972					      ;; this is not always correct, due to optimizations
2973					      (strip-syntax (cdr llist))))))))
2974			  cvars) ) ) ) ) ) ) ) )
2975
2976	  ((set!)
2977	   (let* ((var (first params))
2978		  (val (first subs))
2979		  (cval (node-class val))
2980		  (immf (or (and (eq? 'quote cval) (immediate? (first (node-parameters val))))
2981			    (and (pair? (cdr params)) (second params))
2982			    (eq? '##core#undefined cval))))
2983	     (cond ((posq var closure)
2984		    => (lambda (i)
2985			 (if (test var 'boxed)
2986			     (make-node
2987			      (if immf '##core#updatebox_i '##core#updatebox)
2988			      '()
2989			      (list (make-node '##core#ref (list (add1 i)) (list (varnode crefvar)))
2990				    (transform val crefvar closure) ) )
2991			     ;; Is the following actually used???
2992			     (make-node
2993			      (if immf '##core#update_i '##core#update)
2994			      (list (add1 i))
2995			      (list (varnode crefvar)
2996				    (transform val crefvar closure) ) ) ) ) )
2997		   ((test var 'boxed)
2998		    (make-node
2999		     (if immf '##core#updatebox_i '##core#updatebox)
3000		     '()
3001		     (list (varnode var)
3002			   (transform val crefvar closure) ) ) )
3003		   (else (make-node
3004			  'set! (list var immf)
3005			  (list (transform val crefvar closure) ) ) ) ) ) )
3006
3007	  ((##core#primitive)
3008	   (make-node
3009	    '##core#closure (list (if emit-closure-info 2 1))
3010	    (cons (make-node '##core#proc (list (car params) #t) '())
3011		  (if emit-closure-info
3012		      (list (qnode (##sys#make-lambda-info (->string (car params)))))
3013		      '() ) ) ) )
3014
3015	  ((##core#ref) n)
3016
3017	  (else (bomb "bad node (closure2)")) ) ) )
3018
3019    (define (maptransform xs crefvar closure)
3020      (map (lambda (x) (transform x crefvar closure)) xs) )
3021
3022    ;; If the crefvar (used by ref-var et al) differs from the
3023    ;; closure's own "cvar" because it's a shared closure, introduce a
3024    ;; let binding that obtains the shared closure from the cvar.
3025    (define (wrap-crefvar cvar crefvar node)
3026      (if (eq? cvar crefvar)
3027          node
3028          (make-node 'let (list crefvar)
3029                     (list (make-node '##core#ref (list 1)
3030			              (list (varnode cvar)) )
3031                           node) ) ) )
3032
3033    ;; If a variable is introduced for the first time, and we're in a
3034    ;; sharing user, we have to update its value in the shared container
3035    ;; closure if it occurs there, so that further users can see it.
3036    (define (update-shared-closure-var var crefvar closure node)
3037      (cond ((posq var closure)
3038	     => (lambda (i)
3039                  (make-node 'let (list (gensym var))
3040		             (list (make-node '##core#update (list (+ i 1))
3041			                      (list (varnode crefvar) (varnode var)) )
3042                                   node)) ) )
3043	    (else node) ))
3044
3045    (define (update-shared-closure-vars vars crefvar closure node)
3046      (let lp ((node node)
3047               (vars vars))
3048        (if (null? vars)
3049            node
3050            (lp (update-shared-closure-var (car vars) crefvar closure node)
3051                (cdr vars)))))
3052
3053    (define (ref-var n crefvar closure)
3054      (let ((var (first (node-parameters n))))
3055	(cond ((posq var closure)
3056	       => (lambda (i)
3057		    (make-node '##core#ref (list (+ i 1))
3058			       (list (varnode crefvar)) ) ) )
3059	      (else n) ) ) )
3060
3061    (debugging 'p "closure conversion gathering phase...")
3062    (gather node #f '())
3063    (when (pair? customizable)
3064      (debugging 'o "customizable procedures" customizable))
3065    (debugging 'p "closure conversion merging of shareables phase...")
3066    (merge-shareable node #f)
3067    (merge-reusable node #f)
3068    (unless (and (zero? sharing-containers)
3069                 (zero? sharing-users)) ;; Users should always be zero if containers is (but paranoia prevails, helps w/ debugging)
3070      (debugging 'o "shared closure containers" sharing-containers)
3071      (debugging 'o "shared closure users" sharing-users))
3072    (debugging 'p "closure conversion transformation phase...")
3073    (let ((node2 (transform node #f '())))
3074      (unless (zero? direct-calls)
3075	(debugging 'o "calls to known targets" direct-calls))
3076      node2) ) )
3077
3078
3079;;; Do some preparations before code-generation can commence:
3080
3081(define-record lambda-literal
3082  id 		       ; symbol
3083  external      ; boolean
3084  ;; lambda-literal-arguments is used nowhere
3085  arguments 	       ; (symbol ...)
3086  argument-count      ; integer
3087  rest-argument        ; symbol | #f
3088  temporaries      ; integer
3089  float-temporaries    ; (integer ...)
3090  callee-signatures  ; (integer ...)
3091  allocated        ; integer
3092  ;; lambda-literal-directly-called is used nowhere
3093  directly-called     ; boolean
3094  closure-size      ; integer
3095  looping      ; boolean
3096  customizable     ; boolean
3097  rest-argument-mode ; #f | LIST | NONE
3098  body				 ; expression
3099  direct)			 ; boolean
3100
3101(define (prepare-for-code-generation node db)
3102  (let ((literals '())
3103	(literal-count 0)
3104	(lambda-info-literals '())
3105	(lambda-info-literal-count 0)
3106	;; Use analysis db as optimistic heuristic for procedure table size
3107	(lambda-table (make-vector (fx* (fxmax current-analysis-database-size 1) 3) '()))
3108	(temporaries 0)
3109        (float-temporaries '())
3110	(allocated 0)
3111	(looping 0)
3112	(signatures '())
3113	(fastinits 0)
3114	(fastrefs 0)
3115	(fastsets 0)
3116	(dbg-index 0)
3117	(debug-info '()))
3118
3119    (define (walk-var var e e-count sf)
3120      (cond [(posq var e)
3121	     => (lambda (i)
3122		  (make-node '##core#local (list (fx- e-count (fx+ i 1))) '()))]
3123	    [(keyword? var) (make-node '##core#literal (list (literal var)) '())]
3124	    [else (walk-global var sf)] ) )
3125
3126    (define (walk-global var sf)
3127      (let* ([safe (or sf
3128		       no-bound-checks
3129		       unsafe
3130		       (variable-mark var '##compiler#always-bound)
3131		       (intrinsic? var))]
3132	     [blockvar (and (db-get db var 'assigned)
3133			    (not (variable-visible? var block-compilation)))])
3134	(when blockvar (set! fastrefs (add1 fastrefs)))
3135	(make-node
3136	 '##core#global
3137	 (list (if blockvar
3138		   (blockvar-literal var)
3139		   (literal var) )
3140	       safe
3141	       blockvar
3142	       var)
3143	 '() ) ) )
3144
3145    (define (walk n e e-count here boxes)
3146      (let ((subs (node-subexpressions n))
3147	    (params (node-parameters n))
3148	    (class (node-class n)) )
3149	(case class
3150
3151	  ((##core#undefined ##core#proc ##core#float) n)
3152
3153	  ((##core#variable)
3154	   (walk-var (first params) e e-count #f) )
3155
3156	  ((##core#direct_call)
3157	   (let* ((source-info (second params))
3158		  (demand (fourth params)))
3159	     (if (and emit-debug-info source-info)
3160		 (let ((info (list dbg-index 'C_DEBUG_CALL
3161				   (source-info->line source-info)
3162				   (source-info->name source-info))))
3163		   (set! params (cons dbg-index params))
3164		   (set! debug-info (cons info debug-info))
3165		   (set! dbg-index (add1 dbg-index)))
3166		 (set! params (cons #f params)))
3167	     (set! allocated (+ allocated demand))
3168	     (make-node class params (mapwalk subs e e-count here boxes))))
3169
3170	  ((##core#inline_allocate)
3171	   (set! allocated (+ allocated (second params)))
3172	   (make-node class params (mapwalk subs e e-count here boxes)) )
3173
3174          ((##core#box_float)
3175           (set! allocated (+ allocated 4)) ;; words-per-flonum
3176           (make-node class params (mapwalk subs e e-count here boxes)))
3177
3178	  ((##core#inline_ref)
3179	   (set! allocated (+ allocated (bytes->words (estimate-foreign-result-size (second params)))))
3180	   (make-node class params '()) )
3181
3182	  ((##core#inline_loc_ref)
3183	   (set! allocated (+ allocated (bytes->words (estimate-foreign-result-size (first params)))))
3184	   (make-node class params (mapwalk subs e e-count here boxes)) )
3185
3186	  ((##core#closure)
3187	   (set! allocated (+ allocated (first params) 1))
3188	   (make-node '##core#closure params (mapwalk subs e e-count here boxes)) )
3189
3190	  ((##core#box)
3191	   (set! allocated (+ allocated 2))
3192	   (make-node '##core#box params (list (walk (first subs) e e-count here boxes))) )
3193
3194	  ((##core#updatebox)
3195	   (let* ([b (first subs)]
3196		  [subs (mapwalk subs e e-count here boxes)] )
3197	     (make-node
3198	      (cond [(and (eq? '##core#variable (node-class b))
3199			  (memq (first (node-parameters b)) boxes) )
3200		     (set! fastinits (add1 fastinits))
3201		     '##core#updatebox_i]
3202		    [else class] )
3203	      '()
3204	      subs) ) )
3205
3206	  ((##core#provide)
3207	   ;; Allocate enough space for the ##core#provided property.
3208	   (let ((id (literal (first params))))
3209	     (set! allocated (+ allocated 8))
3210	     (make-node class (list id) '())))
3211
3212	  ((##core#lambda ##core#direct_lambda)
3213	   (let ((temps temporaries)
3214                 (ftemps float-temporaries)
3215		 (sigs signatures)
3216		 (lping looping)
3217		 (alc allocated)
3218		 (direct (eq? class '##core#direct_lambda)) )
3219	     (set! temporaries 0)
3220             (set! float-temporaries '())
3221	     (set! allocated 0)
3222	     (set! signatures '())
3223	     (set! looping 0)
3224	     (##sys#decompose-lambda-list
3225	      (third params)
3226	      (lambda (vars argc rest)
3227		(let* ((id (first params))
3228		       (rest-mode
3229			(and rest
3230			     (let ((rrefs (db-get db rest 'references)))
3231			       (cond ((db-get db rest 'assigned) 'list)
3232				     ((and (not (db-get db rest 'boxed-rest))
3233					   (or (not rrefs) (null? rrefs))) 'none)
3234				     (else (db-get db rest 'rest-parameter)) ) ) ) )
3235		       (body (walk
3236			      (car subs)
3237			      (##sys#fast-reverse (if (eq? 'none rest-mode)
3238						      (butlast vars)
3239						      vars))
3240			      (if (eq? 'none rest-mode)
3241				  (fx- (length vars) 1)
3242				  (length vars))
3243			      id
3244			      '()) ) )
3245		  (when (eq? rest-mode 'none)
3246		    (debugging 'o "unused rest argument" rest id))
3247		  (when (and direct rest)
3248		    (bomb "bad direct lambda" id allocated rest) )
3249		  (hash-table-set!
3250		   lambda-table
3251		   id
3252		   (make-lambda-literal
3253		    id
3254		    (second params)
3255		    vars
3256		    argc
3257		    rest
3258		    (add1 temporaries)
3259                    float-temporaries
3260		    signatures
3261		    allocated
3262		    (or direct (memq id direct-call-ids))
3263		    (or (db-get db id 'closure-size) 0)
3264		    (and (not rest)
3265			 (> looping 0)
3266			 (begin
3267			   (debugging 'o "identified direct recursive calls" id looping)
3268			   #t) )
3269		    (or direct (db-get db id 'customizable))
3270		    rest-mode
3271		    body
3272		    direct) )
3273		  (set! looping lping)
3274		  (set! temporaries temps)
3275                  (set! float-temporaries ftemps)
3276		  (set! allocated alc)
3277		  (set! signatures (lset-adjoin/eq? sigs argc))
3278		  (make-node '##core#proc (list (first params)) '()) ) ) ) ) )
3279
3280	  ((let)
3281	   (let* ([var (first params)]
3282		  [val (first subs)]
3283		  [boxvars (if (eq? '##core#box (node-class val)) (list var) '())] )
3284	     (set! temporaries (add1 temporaries))
3285	     (make-node
3286	      '##core#bind (list 1)	; is actually never used with more than 1 variable
3287	      (list (walk val e e-count here boxes)
3288		    (walk (second subs)
3289			  (append (##sys#fast-reverse params) e) (fx+ e-count 1)
3290			  here (append boxvars boxes)) ) ) ) )
3291
3292	  ((##core#let_float)
3293	   (let ((i (first params))
3294	         (val (first subs)))
3295             (set! float-temporaries (cons i float-temporaries))
3296	     (make-node
3297	      '##core#let_float params
3298	      (list (walk val e e-count here boxes)
3299		    (walk (second subs) e e-count here boxes) ) ) ) )
3300
3301	  ((set!)
3302	   (let ((var (first params))
3303		 (val (first subs)) )
3304	     (cond ((posq var e)
3305		    => (lambda (i)
3306			 (make-node '##core#setlocal
3307				    (list (fx- e-count (fx+ i 1)))
3308				    (list (walk val e e-count here boxes)) ) ) )
3309		   (else
3310		    (let* ((cval (node-class val))
3311			   (blockvar (not (variable-visible?
3312					   var block-compilation)))
3313			   (immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val))))
3314				     (and (pair? (cdr params)) (second params))
3315				     (eq? '##core#undefined cval) ) ) )
3316		      (when blockvar (set! fastsets (add1 fastsets)))
3317		      (make-node
3318		       (if immf '##core#setglobal_i '##core#setglobal)
3319		       (list (if blockvar
3320				 (blockvar-literal var)
3321				 (literal var) )
3322			     blockvar
3323			     var)
3324		       (list (walk (car subs) e e-count here boxes)) ) ) ) ) ) )
3325
3326	  ((##core#call)
3327	   (let* ((len (length (cdr subs)))
3328		  (p2 (pair? (cdr params)))
3329		  (source-info (and p2 (second params))))
3330	     (set! signatures (lset-adjoin/eq? signatures len))
3331	     (when (and (>= (length params) 3) (eq? here (third params)))
3332	       (set! looping (add1 looping)) )
3333               (if (and emit-debug-info source-info)
3334                 (let ((info (list dbg-index 'C_DEBUG_CALL
3335				   (source-info->line source-info)
3336				   (source-info->name source-info))))
3337                   (set! params (cons dbg-index params))
3338                   (set! debug-info (cons info debug-info))
3339                   (set! dbg-index (add1 dbg-index)))
3340                 (set! params (cons #f params)))
3341	     (make-node class params (mapwalk subs e e-count here boxes))))
3342
3343	  ((##core#recurse)
3344	   (when (first params) (set! looping (add1 looping)))
3345	   (make-node class params (mapwalk subs e e-count here boxes)) )
3346
3347	  ((quote)
3348	   (let ((c (first params)))
3349	     (cond ((and (fixnum? c) (not (big-fixnum? c)))
3350		    (immediate-literal c) )
3351		   ((number? c)
3352		    (cond ((eq? 'fixnum number-type)
3353			   (cond ((and (integer? c) (not (big-fixnum? c)))
3354				  (warning
3355				   (sprintf
3356				       "coerced inexact literal number `~S' to fixnum ~S"
3357				     c (inexact->exact c)))
3358				  (immediate-literal (inexact->exact c)) )
3359				 (else (quit-compiling "cannot coerce inexact literal `~S' to fixnum" c)) ) )
3360			  (else (make-node '##core#literal (list (literal c)) '())) ) )
3361		   ((immediate? c) (immediate-literal c))
3362		   (else (make-node '##core#literal (list (literal c)) '())) ) ) )
3363
3364	  ((if ##core#cond)
3365	   (let* ((test (walk (first subs) e e-count here boxes))
3366		  (t0 temporaries)
3367		  (a0 allocated)
3368		  (x1 (walk (second subs) e e-count here boxes))
3369		  (t1 temporaries)
3370		  (a1 allocated)
3371		  (x2 (walk (third subs) e e-count here boxes)))
3372	     (set! allocated (+ a0 (max (- allocated a1) (- a1 a0))))
3373	     (set! temporaries (+ t0 (max (- temporaries t1) (- t1 t0))))
3374	     (make-node class params (list test x1 x2))))
3375
3376	  ((##core#switch)
3377	   (let* ((exp (walk (first subs) e e-count here boxes))
3378		  (a0 allocated))
3379	     (make-node
3380	      class
3381	      params
3382	      (cons
3383	       exp
3384	       (let loop ((j (first params)) (subs (cdr subs)) (ma 0))
3385		 (set! allocated a0)
3386		 (if (zero? j)
3387		     (let ((def (walk (car subs) e e-count here boxes)))
3388		       (set! allocated (+ a0 (max ma (- allocated a0))))
3389		       (list def))
3390		     (let* ((const (walk (car subs) e e-count here boxes))
3391			    (body (walk (cadr subs) e e-count here boxes)))
3392		       (cons*
3393			const body
3394			(loop (sub1 j) (cddr subs) (max (- allocated a0) ma))))))))))
3395
3396	  ((##core#debug-event)
3397	   (let* ((i dbg-index)
3398		  (params (cons i params)))
3399	     (set! debug-info (cons params debug-info))
3400	     (set! dbg-index (add1 dbg-index))
3401	     (make-node class params '())))
3402
3403	  (else (make-node class params (mapwalk subs e e-count here boxes)) ) ) ) )
3404
3405    (define (mapwalk xs e e-count here boxes)
3406      (map (lambda (x) (walk x e e-count here boxes)) xs) )
3407
3408    (define (literal x)
3409      (cond [(immediate? x) (immediate-literal x)]
3410	    ;; Fixnums that don't fit in 32 bits are treated as non-immediates,
3411	    ;; that's why we do the (apparently redundant) C_blockp check here.
3412	    ((and (##core#inline "C_blockp" x) (##core#inline "C_lambdainfop" x))
3413	     (let ((i lambda-info-literal-count))
3414	       (set! lambda-info-literals (cons x lambda-info-literals))
3415	       (set! lambda-info-literal-count (add1 lambda-info-literal-count))
3416	       (vector i) ) )
3417	    [(posv x literals) => (lambda (p) (fx- literal-count (fx+ p 1)))]
3418	    [else (new-literal x)] ) )
3419
3420    (define (new-literal x)
3421      (let ([i literal-count])
3422	(set! literals (cons x literals))
3423	(set! literal-count (add1 literal-count))
3424	i) )
3425
3426    (define (blockvar-literal var)
3427      (cond
3428       ((list-index (lambda (lit)
3429		      (and (block-variable-literal? lit)
3430			   (eq? var (block-variable-literal-name lit)) ) )
3431		    literals)
3432	=> (lambda (p) (fx- literal-count (fx+ p 1))))
3433       (else (new-literal (make-block-variable-literal var))) ) )
3434
3435    (define (immediate-literal x)
3436      (if (eq? (void) x)
3437	  (make-node '##core#undefined '() '())
3438	  (make-node '##core#immediate
3439		     (cond ((fixnum? x) `(fix ,x))
3440			   ((boolean? x) `(bool ,x))
3441			   ((char? x) `(char ,x))
3442			   ((null? x) '(nil))
3443			   ((eof-object? x) '(eof))
3444			   ((bwp-object? x) '(bwp))
3445			   (else (bomb "bad immediate (prepare)")) )
3446		     '() ) ) )
3447
3448    (debugging 'p "preparation phase...")
3449    (let ((node2 (walk node '() 0 #f '())))
3450      (when (positive? fastinits)
3451	(debugging 'o "fast box initializations" fastinits))
3452      (when (positive? fastrefs)
3453	(debugging 'o "fast global references" fastrefs))
3454      (when (positive? fastsets)
3455	(debugging 'o "fast global assignments" fastsets))
3456      (values node2
3457	      (##sys#fast-reverse literals)
3458	      (##sys#fast-reverse lambda-info-literals)
3459	      lambda-table
3460	      (reverse debug-info) ) ) ))
3461)