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