~ chicken-core (master) /support.scm

   1;;;; support.scm - Miscellaneous support code for the CHICKEN compiler
   2;
   3; Copyright (c) 2008-2022, The CHICKEN Team
   4; Copyright (c) 2000-2007, Felix L. Winkelmann
   5; All rights reserved.
   6;
   7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
   8; conditions are met:
   9;
  10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
  11;     disclaimer.
  12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
  13;     disclaimer in the documentation and/or other materials provided with the distribution.
  14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
  15;     products derived from this software without specific prior written permission.
  16;
  17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
  18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
  20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  25; POSSIBILITY OF SUCH DAMAGE.
  26
  27
  28(declare (unit support)
  29	 (not inline ##sys#user-read-hook) ; XXX: Is this needed?
  30	 (uses data-structures extras file internal pathname port))
  31
  32(module chicken.compiler.support
  33    (compiler-cleanup-hook bomb collected-debugging-output debugging
  34     debugging-chicken with-debugging-output quit-compiling
  35     emit-syntax-trace-info check-signature build-lambda-list
  36     valid-c-identifier? read-expressions
  37     bytes->words words->bytes replace-rest-op-with-list-ops
  38     check-and-open-input-file close-checked-input-file fold-inner
  39     constant? collapsable-literal? immediate? basic-literal?
  40     canonicalize-begin-body string->expr llist-length llist-match?
  41     expand-profile-lambda reset-profile-info-vector-name!
  42     profiling-prelude-exps db-get db-get-all db-put! collect! db-get-list
  43     make-node node? node-class node-class-set! node-parameters node-parameters-set!
  44     node-subexpressions node-subexpressions-set! varnode qnode
  45     build-node-graph build-expression-tree fold-boolean inline-lambda-bindings
  46     tree-copy copy-node! copy-node emit-global-inline-file load-inline-file
  47     match-node expression-has-side-effects? simple-lambda-node?
  48     dump-undefined-globals dump-defined-globals dump-global-refs
  49     make-foreign-callback-stub foreign-callback-stub?
  50     foreign-callback-stub-id foreign-callback-stub-name
  51     foreign-callback-stub-qualifiers foreign-callback-stub-return-type
  52     foreign-callback-stub-argument-types register-foreign-callback-stub!
  53     foreign-callback-stubs 		; should not be exported
  54     foreign-type-check foreign-type-convert-result
  55     foreign-type-convert-argument final-foreign-type
  56     register-foreign-type! lookup-foreign-type clear-foreign-type-table!
  57     estimate-foreign-result-size estimate-foreign-result-location-size
  58     finish-foreign-result foreign-type->scrutiny-type scan-used-variables
  59     scan-free-variables
  60     make-block-variable-literal block-variable-literal?
  61     block-variable-literal-name make-random-name
  62     clear-real-name-table! get-real-name set-real-name!
  63     real-name real-name2 display-real-name-table
  64     source-info->string source-info->line source-info->name
  65     call-info constant-form-eval maybe-constant-fold-call
  66     dump-nodes big-fixnum? small-bignum?
  67     hide-variable export-variable variable-hidden? variable-visible?
  68     mark-variable variable-mark intrinsic? predicate? foldable?
  69     load-identifier-database
  70     print-version print-usage print-debug-options
  71
  72     ;; XXX: These are evil globals that were too hairy to get rid of.
  73     ;; These values are set! by compiler and batch-driver, and read
  74     ;; in a lot of other places.
  75     number-type unsafe)
  76
  77(import scheme
  78	chicken.base
  79	chicken.bitwise
  80	chicken.bytevector
  81	chicken.condition
  82	chicken.file
  83	chicken.fixnum
  84	chicken.foreign
  85	chicken.format
  86	chicken.internal
  87	chicken.io
  88	chicken.keyword
  89	chicken.pathname
  90	chicken.platform
  91	chicken.plist
  92	chicken.port
  93	chicken.pretty-print
  94	chicken.sort
  95	chicken.string
  96	chicken.syntax
  97	chicken.time)
  98(import (only (scheme base) open-output-string get-output-string))
  99
 100(include "tweaks")
 101(include "mini-srfi-1.scm")
 102(include "banner")
 103
 104;; Evil globals
 105(define number-type 'generic)
 106(define unsafe #f)
 107
 108;;; Debugging and error-handling stuff:
 109
 110(define (compiler-cleanup-hook) #f)
 111
 112(define debugging-chicken '())
 113
 114(define (bomb . msg-and-args)
 115  (if (pair? msg-and-args)
 116      (apply error (string-append "[internal compiler error] " (car msg-and-args)) (cdr msg-and-args))
 117      (error "[internal compiler error]") ) )
 118
 119(define collected-debugging-output
 120  (open-output-string))
 121
 122(define +logged-debugging-modes+ '(o x S))
 123
 124(define (test-debugging-mode mode enabled)
 125  (if (symbol? mode)
 126      (memq mode enabled)
 127      (any (lambda (m) (memq m enabled)) mode)))
 128
 129(define (debugging mode msg . args)
 130  (define (text)
 131    (with-output-to-string
 132      (lambda ()
 133	(display msg)
 134	(when (pair? args)
 135	  (display ": ")
 136	  (for-each
 137	   (lambda (x) (printf "~s " (force x)))
 138	   args) )
 139	(newline))))
 140  (define (dump txt)
 141    (fprintf collected-debugging-output "~a|~a" mode txt))
 142  (cond ((test-debugging-mode mode debugging-chicken)
 143	 (let ((txt (text)))
 144	   (display txt)
 145	   (flush-output)
 146	   (when (test-debugging-mode mode +logged-debugging-modes+)
 147	     (dump txt))
 148	   #t))
 149	(else
 150	 (when (test-debugging-mode mode +logged-debugging-modes+)
 151	   (dump (text)))
 152	 #f)))
 153
 154(define (with-debugging-output mode thunk)
 155  (define (collect text)
 156    (for-each
 157     (lambda (ln)
 158       (fprintf collected-debugging-output "~a|~a~%"
 159	 (if (pair? mode) (car mode) mode)
 160	 ln))
 161     (string-split text "\n")))
 162  (cond ((test-debugging-mode mode debugging-chicken)
 163	 (let ((txt (with-output-to-string thunk)))
 164	   (display txt)
 165	   (flush-output)
 166	   (when (test-debugging-mode mode +logged-debugging-modes+)
 167	     (collect txt))))
 168	((test-debugging-mode mode +logged-debugging-modes+)
 169	 (collect (with-output-to-string thunk)))))
 170
 171(define (quit-compiling msg . args)
 172  (let ([out (current-error-port)])
 173    (apply fprintf out (string-append "\nError: " msg) args)
 174    (newline out)
 175    (exit 1) ) )
 176
 177(set! ##sys#syntax-error-hook
 178  (lambda (msg . args)
 179    (let ((out (current-error-port))
 180	  (loc (and (symbol? msg)
 181		    (let ((loc msg))
 182		      (set! msg (car args))
 183		      (set! args (cdr args))
 184		      loc))))
 185      (if loc
 186	  (fprintf out "\nSyntax error (~a): ~a~%~%" loc msg)
 187	  (fprintf out "\nSyntax error: ~a~%~%" msg) )
 188      (for-each (cut fprintf out "\t~s~%" <>) args)
 189      (print-call-chain out 0 ##sys#current-thread "\n\tExpansion history:\n")
 190      (exit 70) ) ) )
 191
 192(define (emit-syntax-trace-info info cntr)
 193  (define (thread-id t) (##sys#slot t 14))
 194  (##core#inline "C_emit_syntax_trace_info" info cntr
 195                 (thread-id ##sys#current-thread)))
 196
 197(define (map-llist proc llist)
 198  (let loop ([llist llist])
 199    (cond [(null? llist) '()]
 200	  [(symbol? llist) (proc llist)]
 201	  [else (cons (proc (car llist)) (loop (cdr llist)))] ) ) )
 202
 203(define (check-signature var args llist)
 204  (let loop ((as args) (ll llist))
 205    (cond ((null? ll) (null? as))
 206          ((symbol? ll))
 207          ((null? as) #f)
 208          (else (loop (cdr as) (cdr ll))) ) ) )
 209
 210
 211;;; Generic utility routines:
 212
 213(define (build-lambda-list vars argc rest)
 214  (let loop ((vars vars) (n argc))
 215    (cond ((or (zero? n) (null? vars)) (or rest '()))
 216          (else (cons (car vars) (loop (cdr vars) (sub1 n)))) ) ) )
 217
 218;; XXX: This too, but it's used only in core.scm, WTF?
 219(define (valid-c-identifier? name)
 220  (let ([str (string->list (->string name))])
 221    (and (pair? str)
 222	 (let ([c0 (car str)])
 223	   (and (or (char-alphabetic? c0) (char=? #\_ c0))
 224		(every (lambda (c) (or (char-alphabetic? c) (char-numeric? c) (char=? #\_ c)))
 225		       (cdr str)))))))
 226
 227(define (struct/union-wrapper-type-name x)
 228  (cond ((list? (cadr x)) (string->symbol (->string (caadr x))))
 229        (else (string->symbol (string-append (symbol->string (car x)) " "
 230                                             (->string (cadr x)))))))
 231
 232;; TODO: Move these to (chicken memory)?
 233(define bytes->words (foreign-lambda int "C_bytestowords" int))
 234(define words->bytes (foreign-lambda int "C_wordstobytes" int))
 235
 236;; Used only in batch-driver; move it there?
 237(define (check-and-open-input-file fname . line)
 238  (cond ((string=? fname "-") (current-input-port))
 239	((file-exists? fname) (open-input-file fname))
 240	((or (null? line) (not (car line)))
 241	 (quit-compiling "Can not open file ~s" fname))
 242	(else (quit-compiling "(~a) can not open file ~s" (car line) fname)) ) )
 243
 244(define (close-checked-input-file port fname)
 245  (unless (string=? fname "-") (close-input-port port)) )
 246
 247(define (fold-inner proc lst)
 248  (if (null? (cdr lst))
 249      lst
 250      (let fold ((xs (reverse lst)))
 251	(apply
 252	 proc
 253	 (if (null? (cddr xs))
 254	     (list (cadr xs) (car xs))
 255	     (list (fold (cdr xs)) (car xs)) ) ) ) ) )
 256
 257(define (follow-without-loop seed proc abort)
 258  (let loop ([x seed] [done '()])
 259    (if (member x done)
 260	(abort)
 261	(proc x (lambda (x2) (loop x2 (cons x done)))) ) ) )
 262
 263(define (sort-symbols lst)
 264  (sort lst (lambda (s1 s2) (string<? (symbol->string s1) (symbol->string s2)))))
 265
 266(define (read-expressions #!optional (port (current-input-port)))
 267  (do ((x (read port) (read port))
 268       (i 0 (add1 i))
 269       (xs '() (cons x xs)))
 270      ((eof-object? x) (reverse xs))))
 271
 272
 273;;; Predicates on expressions and literals:
 274
 275(define (constant? x)
 276  (or (number? x)
 277      (char? x)
 278      (string? x)
 279      (boolean? x)
 280      (eof-object? x)
 281      (bytevector? x)
 282      (bwp-object? x)
 283      (vector? x)
 284      (##sys#srfi-4-vector? x)
 285      (and (pair? x) (eq? 'quote (car x))) ) )
 286
 287(define (collapsable-literal? x)
 288  (or (boolean? x)
 289      (char? x)
 290      (eof-object? x)
 291      (bwp-object? x)
 292      (number? x)
 293      (symbol? x) ) )
 294
 295(define (immediate? x)
 296  (or (and (fixnum? x) (not (big-fixnum? x))) ; 64-bit fixnums would result in platform-dependent .c files
 297      (eq? (##core#undefined) x)
 298      (null? x)
 299      (eof-object? x)
 300      (bwp-object? x)
 301      (char? x)
 302      (boolean? x) ) )
 303
 304(define (basic-literal? x)
 305  (or (null? x)
 306      (symbol? x)
 307      (constant? x)
 308      (and (vector? x) (every basic-literal? (vector->list x)))
 309      (and (pair? x)
 310	   (basic-literal? (car x))
 311	   (basic-literal? (cdr x)) ) ) )
 312
 313
 314;;; Expression manipulation:
 315
 316(define (canonicalize-begin-body body)
 317  (let loop ((xs body))
 318    (cond ((null? xs) '(##core#undefined))
 319	  ((null? (cdr xs)) (car xs))
 320	  ((let ([h (car xs)])
 321	     (or (equal? h '(##core#undefined))
 322		 (constant? h)
 323		 (equal? h '(##sys#void)) ) )
 324	   (loop (cdr xs)) )
 325	  (else `(let ((,(gensym 't) ,(car xs)))
 326		   ,(loop (cdr xs))) ) ) ) )
 327
 328;; Only used in batch-driver: move it there?
 329(define string->expr
 330  (let ([exn? (condition-predicate 'exn)]
 331	[exn-msg (condition-property-accessor 'exn 'message)] )
 332    (lambda (str)
 333      (handle-exceptions ex
 334	  (quit-compiling "cannot parse expression: ~s [~a]~%"
 335			  str
 336			  (if (exn? ex)
 337			      (exn-msg ex)
 338			      (->string ex) ) )
 339	(let ((xs (with-input-from-string
 340		      str
 341		    (lambda ()
 342		      (let loop ((lst '()))
 343			(let ((x (read)))
 344			  (if (eof-object? x)
 345			      (reverse lst)
 346			      (loop (cons x lst)))))))))
 347	  (cond [(null? xs) '(##core#undefined)]
 348		[(null? (cdr xs)) (car xs)]
 349		[else `(begin ,@xs)] ) ) ) ) ) )
 350
 351;; Only used in optimizer; move it there?  But it's a C function call, so
 352;; it may be better in c-platform
 353(define (llist-length llist)
 354  (##core#inline "C_u_i_length" llist))	; stops at non-pair node
 355
 356(define (llist-match? llist args)	; assumes #!optional/#!rest/#!key have been expanded
 357  (let loop ((llist llist) (args args))
 358    (cond ((null? llist) (null? args))
 359	  ((symbol? llist))
 360	  ((null? args) (atom? llist))
 361	  (else (loop (cdr llist) (cdr args))))))
 362
 363
 364;;; Profiling instrumentation:
 365(define profile-info-vector-name #f)
 366(define (reset-profile-info-vector-name!)
 367  (set! profile-info-vector-name (make-random-name 'profile-info)))
 368
 369(define profile-lambda-list '())
 370(define profile-lambda-index 0)
 371
 372(define (expand-profile-lambda name llist body)
 373  (let ([index profile-lambda-index]
 374	[args (gensym)] )
 375    (set! profile-lambda-list (alist-cons index name profile-lambda-list))
 376    (set! profile-lambda-index (add1 index))
 377    `(##core#lambda ,args
 378       (##sys#dynamic-wind
 379	(##core#lambda () (##sys#profile-entry ',index ,profile-info-vector-name))
 380	(##core#lambda () (##sys#apply (##core#lambda ,llist ,body) ,args))
 381	(##core#lambda () (##sys#profile-exit ',index ,profile-info-vector-name)) ) ) ) )
 382
 383;; Get expressions which initialize and populate the profiling vector
 384(define (profiling-prelude-exps profile-name)
 385  `((set! ,profile-info-vector-name
 386      (##sys#register-profile-info
 387       ',(length profile-lambda-list)
 388       ',profile-name))
 389    ,@(map (lambda (pl)
 390	     `(##sys#set-profile-info-vector!
 391	       ,profile-info-vector-name
 392	       ',(car pl)
 393	       ',(cdr pl) ) )
 394	   profile-lambda-list)))
 395
 396;;; Database operations:
 397
 398(define (db-get db key prop)
 399  (let ((plist (hash-table-ref db key)))
 400    (and plist
 401	 (let ([a (assq prop plist)])
 402	   (and a (##sys#slot a 1)) ) ) ) )
 403
 404(define (db-get-all db key . props)
 405  (let ((plist (hash-table-ref db key)))
 406    (if plist
 407	(filter-map (lambda (prop) (assq prop plist)) props)
 408	'() ) ) )
 409
 410(define (db-put! db key prop val)
 411  (let ((plist (hash-table-ref db key)))
 412    (if plist
 413	(let ([a (assq prop plist)])
 414	  (cond [a (##sys#setslot a 1 val)]
 415		[val (##sys#setslot plist 1 (alist-cons prop val (##sys#slot plist 1)))] ) )
 416	(when val (hash-table-set! db key (list (cons prop val)))))))
 417
 418(define (collect! db key prop val)
 419  (let ((plist (hash-table-ref db key)))
 420    (if plist
 421	(let ([a (assq prop plist)])
 422	  (cond [a (##sys#setslot a 1 (cons val (##sys#slot a 1)))]
 423		[else (##sys#setslot plist 1 (alist-cons prop (list val) (##sys#slot plist 1)))] ) )
 424	(hash-table-set! db key (list (list prop val))))))
 425
 426(define (db-get-list db key prop)		; returns '() if not set
 427  (let ((x (db-get db key prop)))
 428    (or x '())))
 429
 430
 431;;; Node creation and -manipulation:
 432
 433;; Note: much of this stuff will be overridden by the inline-definitions in "tweaks.scm".
 434
 435(define-record node
 436  class 	; symbol
 437  parameters ; (value...)
 438  subexpressions ) ; (node...)
 439
 440(set-record-printer! node
 441  (lambda (n out)
 442    (fprintf out "#<node ~a ~a>" (node-class n) (node-parameters n))))
 443
 444(define (make-node c p s)
 445  (##sys#make-structure 'chicken.compiler.support#node c p s))
 446
 447(define (varnode var) (make-node '##core#variable (list var) '()))
 448(define (qnode const) (make-node 'quote (list const) '()))
 449
 450(define (build-node-graph exp)
 451  (let ((count 0))
 452    (define (walk x)
 453      (cond ((symbol? x) (varnode x))
 454	    ((node? x) x)
 455	    ((not (pair? x)) (bomb "bad expression" x))
 456	    ((symbol? (car x))
 457	     (case (car x)
 458	       ((if ##core#undefined) (make-node (car x) '() (map walk (cdr x))))
 459	       ((quote)
 460		(let ((c (cadr x)))
 461		  (qnode (if (and (number? c)
 462				  (eq? 'fixnum number-type)
 463				  (not (integer? c)) )
 464			     (begin
 465			       (warning
 466				"literal is out of range - will be truncated to integer" c)
 467			       (inexact->exact (truncate c)) )
 468			     c) ) ) )
 469	       ((let)
 470		(let ([bs (cadr x)]
 471		      [body (caddr x)] )
 472		  (if (null? bs)
 473		      (walk body)
 474		      (make-node
 475		       'let (unzip1 bs)
 476		       (append (map (lambda (b) (walk (cadr b))) (cadr x))
 477			       (list (walk body)) ) ) ) ) )
 478	       ((lambda ##core#lambda)
 479		(make-node 'lambda (list (cadr x)) (list (walk (caddr x)))))
 480	       ((##core#the)
 481		(make-node '##core#the
 482			   (list (second x) (third x))
 483			   (list (walk (fourth x)))))
 484	       ((##core#typecase)
 485		;; clause-head is already stripped
 486		(let loop ((cls (cdddr x)) (types '()) (exps (list (walk (caddr x)))))
 487		  (cond ((null? cls) 	; no "else" clause given
 488			 (make-node
 489			  '##core#typecase
 490			  (cons (cadr x) (reverse types))
 491			  (reverse
 492			   (cons (make-node '##core#undefined '() '()) exps))))
 493			((eq? 'else (caar cls))
 494			 (make-node
 495			  '##core#typecase
 496			  (cons (cadr x) (reverse (cons '* types)))
 497			  (reverse (cons (walk (cadar cls)) exps))))
 498			(else (loop (cdr cls)
 499				    (cons (caar cls) types)
 500				    (cons (walk (cadar cls)) exps))))))
 501	       ((##core#primitive)
 502		(let ((arg (cadr x)))
 503		  (make-node
 504		   (car x)
 505		   (list (if (and (pair? arg) (eq? 'quote (car arg))) (cadr arg) arg))
 506		   (map walk (cddr x)) ) ) )
 507	       ((##core#inline ##core#provide ##core#callunit)
 508		(make-node (car x) (list (cadr x)) (map walk (cddr x))) )
 509	       ((##core#debug-event) ; 2nd argument is provided by canonicalization phase
 510		(make-node (car x) (cdr x) '()))
 511	       ((##core#proc)
 512		(make-node '##core#proc (list (cadr x) #t) '()) )
 513	       ((set! ##core#set!)
 514		(make-node
 515		 'set! (list (cadr x))
 516		 (map walk (cddr x))))
 517	       ((##core#foreign-callback-wrapper)
 518		(let ([name (cadr (second x))])
 519		  (make-node
 520		   '##core#foreign-callback-wrapper
 521		   (list name (cadr (third x)) (cadr (fourth x)) (cadr (fifth x)))
 522		   (list (walk (list-ref x 5))) ) ) )
 523	       ((##core#inline_allocate ##core#inline_ref ##core#inline_update
 524					##core#inline_loc_ref ##core#inline_loc_update)
 525		(make-node (first x) (second x) (map walk (cddr x))) )
 526	       ((##core#app)
 527		(make-node '##core#call (list #t) (map walk (cdr x))) )
 528	       (else
 529		(receive (name ln) (##sys#get-line-2 x)
 530		  (make-node
 531		   '##core#call
 532		   (list (cond [(variable-mark name '##compiler#always-bound-to-procedure)
 533				(set! count (add1 count))
 534				#t]
 535			       [else #f] )
 536			 (if ln
 537			     (let ([rn (real-name name)])
 538			       (list ln
 539				     (or rn (##sys#symbol->string name))) )
 540			     (##sys#symbol->string name) ) )
 541		   (map walk x) ) ) ) ) )
 542	    (else (make-node '##core#call (list #f) (map walk x))) ) )
 543    (let ([exp2 (walk exp)])
 544      (when (positive? count)
 545	(debugging 'o "eliminated procedure checks" count)) ;XXX perhaps throw this out
 546      exp2) ) )
 547
 548(define (build-expression-tree node)
 549  (let walk ((n node))
 550    (let ((subs (node-subexpressions n))
 551	  (params (node-parameters n))
 552	  (class (node-class n)) )
 553      (case class
 554	((if ##core#box ##core#cond) (cons class (map walk subs)))
 555	((##core#closure)
 556	 `(##core#closure ,params ,@(map walk subs)) )
 557	((##core#variable) (car params))
 558	((quote)
 559	 (let ((c (car params)))
 560	   (if (or (boolean? c) (string? c) (number? c) (char? c))
 561	       c
 562	       `(quote ,(car params)))))
 563	((let)
 564	 `(let ,(map list params (map walk (butlast subs)))
 565	    ,(walk (last subs)) ) )
 566	((##core#lambda)
 567	 (list (if (second params)
 568		   'lambda
 569		   '##core#lambda)
 570	       (third params)
 571	       (walk (car subs)) ) )
 572	((##core#the)
 573	 `(the ,(first params) ,(walk (first subs))))
 574	((##core#the/result)
 575	 (walk (first subs)))
 576	((##core#typecase)
 577	 `(compiler-typecase
 578	   ,(walk (first subs))
 579	   ,@(let loop ((types (cdr params)) (bodies (cdr subs)))
 580	       (if (null? types)
 581		   (if (null? bodies)
 582		       '()
 583		       `((else ,(walk (car bodies)))))
 584		   (cons (list (car types) (walk (car bodies)))
 585			 (loop (cdr types) (cdr bodies)))))))
 586	((##core#call)
 587	 (map walk subs))
 588	((##core#callunit) (cons* '##core#callunit (car params) (map walk subs)))
 589	((##core#undefined) (list class))
 590	((##core#bind)
 591	 (let loop ((n (car params)) (vals subs) (bindings '()))
 592	   (if (zero? n)
 593	       `(##core#bind ,(reverse bindings) ,(walk (car vals)))
 594	       (loop (- n 1) (cdr vals) (cons (walk (car vals)) bindings)) ) ) )
 595	((##core#unbox ##core#ref ##core#update ##core#update_i)
 596	 (cons* class (walk (car subs)) params (map walk (cdr subs))) )
 597	((##core#inline_allocate)
 598	 (cons* class params (map walk subs)))
 599	(else (cons class (append params (map walk subs)))) ) ) ) )
 600
 601(define (fold-boolean proc lst)
 602  (let fold ([vars lst])
 603    (if (null? (cddr vars))
 604	(apply proc vars)
 605	(make-node
 606	 '##core#inline '("C_and")
 607	 (list (proc (first vars) (second vars))
 608	       (fold (cdr vars)) ) ) ) ) )
 609
 610;; Move to optimizer.scm?
 611(define (inline-lambda-bindings llist args body copy? db cfk)
 612  (##sys#decompose-lambda-list
 613   llist
 614   (lambda (vars argc rest)
 615     (receive (largs rargs) (split-at args argc)
 616       (let* ((rlist (if copy? (map gensym vars) vars))
 617	      (body (if copy?
 618			(copy-node-tree-and-rename body vars rlist db cfk)
 619			body) )
 620	      (rarg-aliases (map (lambda (r) (gensym 'rarg)) rargs)) )
 621	 (replace-rest-ops-in-known-call! db body rest (last rlist) rarg-aliases)
 622
 623	 ;; Make sure rest ops aren't replaced after inlining (#1658)
 624	 ;; argvector does not belong to the same procedure anymore.
 625	 (when rest
 626	   (for-each (lambda (v)
 627		       (db-put! db v 'rest-cdr #f)
 628		       (db-put! db v 'rest-null? #f) )
 629		     (db-get-list db rest 'derived-rest-vars) )
 630	   (db-put! db rest 'rest-cdr #f)
 631	   (db-put! db rest 'derived-rest-vars '()) )
 632
 633	 (let loop ((vars (take rlist argc))
 634		    (vals largs))
 635	   (if (null? vars)
 636	       (if rest
 637		   ;; NOTE: If contraction happens before rest-op
 638		   ;; detection, we might needlessly build a list.
 639		   (let loop2 ((rarg-values rargs)
 640			       (rarg-aliases rarg-aliases))
 641		     (if (null? rarg-aliases)
 642			 (if (null? (db-get-list db rest 'references))
 643			     body
 644			     (make-node
 645			      'let (list (last rlist))
 646			      (list (if (null? rargs)
 647					(qnode '())
 648					(make-node
 649					 '##core#inline_allocate
 650					 (list "C_a_i_list" (* 3 (length rargs)))
 651					 rargs) )
 652				    body) ))
 653			 (make-node 'let (list (car rarg-aliases))
 654				    (list (car rarg-values)
 655					  (loop2 (cdr rarg-values) (cdr rarg-aliases))))))
 656		   body)
 657	       (make-node 'let (list (car vars))
 658			  (list (car vals)
 659				(loop (cdr vars) (cdr vals)))))))))))
 660
 661;; Copy along with the above
 662(define (copy-node-tree-and-rename node vars aliases db cfk)
 663  (let ((rlist (map cons vars aliases)))
 664    (define (rename v rl) (alist-ref v rl eq? v))
 665    (define (walk n rl)
 666      (let ((subs (node-subexpressions n))
 667	    (params (node-parameters n))
 668	    (class (node-class n)) )
 669	(case class
 670	  ((quote)
 671	   (make-node class params '()))
 672	  ((##core#variable)
 673	   (let ((var (first params)))
 674	     (when (db-get db var 'contractable)
 675	       (cfk var))
 676	     (varnode (rename var rl))) )
 677	  ((set!)
 678	   (make-node
 679	    'set! (list (rename (first params) rl))
 680	    (list (walk (first subs) rl)) ) )
 681	  ((let)
 682	   (let* ((v (first params))
 683		  (val1 (walk (first subs) rl))
 684		  (a (gensym v))
 685		  (rl2 (alist-cons v a rl)) )
 686	     (db-put! db a 'inline-transient #t)
 687	     (make-node
 688	      'let (list a)
 689	      (list val1 (walk (second subs) rl2)))) )
 690	  ((##core#lambda)
 691	   (##sys#decompose-lambda-list
 692	    (third params)
 693	    (lambda (vars argc rest)
 694	      (let* ((as (map (lambda (v)
 695				(let ((a (gensym v)))
 696				  (db-put! db v 'inline-transient #t)
 697				  a))
 698			      vars) )
 699		     (rl2 (append (map cons vars as) rl)) )
 700		(make-node
 701		 '##core#lambda
 702		 (list (gensym 'f) (second params) ; new function-id
 703		       (build-lambda-list as argc (and rest (rename rest rl2)))
 704		       (fourth params) )
 705		 (map (cut walk <> rl2) subs) ) ) ) ) )
 706	  (else (make-node class (tree-copy params)
 707			   (map (cut walk <> rl) subs))) ) ) )
 708    (walk node rlist) ) )
 709
 710;; Replace rest-{car,cdr,null?} with equivalent code which accesses
 711;; the rest argument directly.
 712(define (replace-rest-ops-in-known-call! db node rest-var rest-alias rest-args)
 713  (define (walk n)
 714    (let ((subs (node-subexpressions n))
 715	  (params (node-parameters n))
 716	  (class (node-class n)) )
 717      (case class
 718	((##core#rest-null?)
 719	 (if (eq? rest-var (first params))
 720	     (copy-node! (qnode (<= (length rest-args) (second params))) n)
 721	     n))
 722	((##core#rest-car)
 723	 (if (eq? rest-var (first params))
 724	     (let ((depth (second params))
 725		   (len (length rest-args)))
 726	       (if (> len depth)
 727		   (copy-node! (varnode (list-ref rest-args depth)) n)
 728		   (copy-node! (make-node '##core#inline
 729					  (list "C_rest_arg_out_of_bounds_error_value")
 730					  (list (qnode len) (qnode depth) (qnode 0)))
 731			       n)))
 732	     n))
 733	((##core#rest-cdr)
 734	 (cond ((eq? rest-var (first params))
 735		(collect! db rest-var 'references n) ; Restore this reference
 736		(let lp ((i (add1 (second params)))
 737			 (new-node (varnode rest-alias)))
 738		  (if (zero? i)
 739		      (copy-node! new-node n)
 740		      (lp (sub1 i)
 741			  (make-node '##core#inline (list "C_i_cdr") (list new-node))))))
 742	       (else n)))
 743	(else (for-each walk subs)) ) ) )
 744
 745  (walk node)  )
 746
 747(define (replace-rest-op-with-list-ops class rest-var-node params)
 748  (case class
 749    ((##core#rest-car)
 750     (make-node '##core#inline
 751		(list "C_i_list_ref")
 752		(list rest-var-node (qnode (second params)))))
 753    ((##core#rest-cdr)
 754     (let lp ((cdr-calls (add1 (second params)))
 755	      (var rest-var-node))
 756       (if (zero? cdr-calls)
 757	   var
 758	   (lp (sub1 cdr-calls)
 759	       (make-node '##core#inline (list "C_i_cdr") (list var))))))
 760    ((##core#rest-null?)
 761     (make-node '##core#inline
 762		(list "C_i_greater_or_equalp")
 763		(list (qnode (second params))
 764		      (make-node '##core#inline (list "C_i_length") (list rest-var-node)))))
 765    ((##core#rest-length)
 766     (make-node '##core#inline
 767		(list "C_i_length")
 768		(list rest-var-node (qnode (second params)))))
 769    (else (bomb "Unknown rest op node class while undoing rest op for explicitly consed rest arg. This shouldn't happen!" class))))
 770
 771;; Maybe move to scrutinizer.  It's generic enough to keep it here though
 772(define (tree-copy t)
 773  (let rec ([t t])
 774    (if (pair? t)
 775	(cons (rec (car t)) (rec (cdr t)))
 776	t) ) )
 777
 778(define (copy-node n)
 779  (make-node (node-class n)
 780             (node-parameters n)
 781             (node-subexpressions n)))
 782
 783(define (copy-node! from to)
 784  (node-class-set! to (node-class from))
 785  (node-parameters-set! to (node-parameters from))
 786  (node-subexpressions-set! to (node-subexpressions from))
 787  to)
 788
 789(define (node->sexpr n)
 790  (let walk ((n n))
 791    `(,(node-class n)
 792      ,(node-parameters n)
 793      ,@(map walk (node-subexpressions n)))))
 794
 795(define (sexpr->node x)
 796  (let walk ((x x))
 797    (make-node (car x) (cadr x) (map walk (cddr x)))))
 798
 799;; Only used in batch-driver.scm
 800(define (emit-global-inline-file source-file inline-file db
 801				 block-compilation inline-limit
 802				 foreign-stubs)
 803  (define (uses-foreign-stubs? node)
 804    (let walk ((n node))
 805      (case (node-class n)
 806	((##core#inline)
 807	 (memq (car (node-parameters n)) foreign-stubs))
 808	(else
 809	 (any walk (node-subexpressions n))))))
 810  (let ((lst '())
 811	(out '()))
 812    (hash-table-for-each
 813     (lambda (sym plist)
 814       (when (variable-visible? sym block-compilation)
 815	 (and-let* ((val (assq 'local-value plist))
 816		    ((not (node? (variable-mark sym '##compiler#inline-global))))
 817		    ((let ((val (assq 'value plist)))
 818		       (or (not val)
 819			   (not (eq? 'unknown (cdr val))))))
 820		    ((assq 'inlinable plist))
 821		    (lparams (node-parameters (cdr val)))
 822		    ((not (db-get db sym 'hidden-refs)))
 823		    ((case (variable-mark sym '##compiler#inline)
 824		       ((yes) #t)
 825		       ((no) #f)
 826		       (else
 827			(< (fourth lparams) inline-limit))))
 828		    ;; See #1440
 829		    ((not (uses-foreign-stubs? (cdr val)))))
 830	   (set! lst (cons sym lst))
 831	   (set! out (cons (list sym (node->sexpr (cdr val))) out)))))
 832     db)
 833    (with-output-to-file inline-file
 834      (lambda ()
 835	(print "; GENERATED BY CHICKEN " (chicken-version) " FROM "
 836	       source-file "\n")
 837	(for-each
 838	 (lambda (x)
 839	   (pp x)
 840	   (newline))
 841	 (reverse out))
 842	(print "; END OF FILE")))
 843    (when (and (pair? lst)
 844	       (debugging 'i "the following procedures can be globally inlined:"))
 845      (for-each (cut print "  " <>) (sort-symbols lst)))))
 846
 847;; Used only in batch-driver.scm
 848(define (load-inline-file fname)
 849  (with-input-from-file fname
 850    (lambda ()
 851      (let loop ()
 852	(let ((x (read)))
 853	  (unless (eof-object? x)
 854	    (mark-variable
 855	     (car x)
 856	     '##compiler#inline-global
 857	     (sexpr->node (cadr x)))
 858	    (loop)))))))
 859
 860
 861;;; Match node-structure with pattern:
 862
 863(define (match-node node pat vars)	; Only used in optimizer.scm
 864  (let ((env '()))
 865
 866    (define (resolve v x)
 867      (cond ((assq v env) => (lambda (a) (equal? x (cdr a))))
 868	    ((memq v vars)
 869	     (set! env (alist-cons v x env))
 870	     #t)
 871	    (else (eq? v x)) ) )
 872
 873    (define (match1 x p)
 874      (cond ((not (pair? p)) (resolve p x))
 875	    ((not (pair? x)) #f)
 876	    ((match1 (car x) (car p)) (match1 (cdr x) (cdr p)))
 877	    (else #f) ) )
 878
 879    (define (matchn n p)
 880      (if (not (pair? p))
 881	  (resolve p n)
 882	  (and (eq? (node-class n) (first p))
 883	       (match1 (node-parameters n) (second p))
 884	       (let loop ((ns (node-subexpressions n))
 885			  (ps (cddr p)) )
 886		 (cond ((null? ps) (null? ns))
 887		       ((not (pair? ps)) (resolve ps ns))
 888		       ((null? ns) #f)
 889		       (else (and (matchn (car ns) (car ps))
 890				  (loop (cdr ns) (cdr ps)) ) ) ) ) ) ) )
 891
 892    (let ((r (matchn node pat)))
 893      (and r
 894	   (begin
 895	     (debugging 'a "matched" (node-class node) (node-parameters node) pat)
 896	     env) ) ) ) )
 897
 898
 899;;; Test nodes for certain properties:
 900
 901(define (expression-has-side-effects? node db)
 902  (let walk ([n node])
 903    (let ([subs (node-subexpressions n)])
 904      (case (node-class n)
 905	[(##core#variable quote ##core#undefined ##core#proc) #f]
 906	[(##core#lambda)
 907	 (let ([id (first (node-parameters n))])
 908	   (find (lambda (fs)
 909		   (eq? id (foreign-callback-stub-id fs)))
 910		 foreign-callback-stubs) ) ]
 911	[(if let) (any walk subs)]
 912	[else #t] ) ) ) )
 913
 914(define (simple-lambda-node? node)	; Used only in compiler.scm
 915  (let* ([params (node-parameters node)]
 916	 [llist (third params)]
 917	 [k (and (pair? llist) (first llist))] ) ; leaf-routine has no continuation argument
 918    (and k
 919	 (second params)
 920	 (let rec ([n node])
 921	   (case (node-class n)
 922	     [(##core#call)
 923	      (let* ([subs (node-subexpressions n)]
 924		     [f (first subs)] )
 925		(and (eq? '##core#variable (node-class f))
 926		     (eq? k (first (node-parameters f)))
 927		     (every rec (cdr subs)) ) ) ]
 928	     [(##core#callunit) #f]
 929	     [else (every rec (node-subexpressions n))] ) ) ) ) )
 930
 931
 932;;; Some safety checks and database dumping:
 933
 934(define (dump-undefined-globals db)	; Used only in batch-driver.scm
 935  (hash-table-for-each
 936   (lambda (sym plist)
 937     (when (and (not (keyword? sym))
 938		(assq 'global plist)
 939		(not (assq 'assigned plist)) )
 940       (write sym)
 941       (newline) ) )
 942   db) )
 943
 944(define (dump-defined-globals db)	; Used only in batch-driver.scm
 945  (hash-table-for-each
 946   (lambda (sym plist)
 947     (when (and (not (keyword? sym))
 948		(assq 'global plist)
 949		(assq 'assigned plist))
 950       (write sym)
 951       (newline) ) )
 952   db) )
 953
 954(define (dump-global-refs db)		; Used only in batch-driver.scm
 955  (hash-table-for-each
 956   (lambda (sym plist)
 957     (when (and (not (keyword? sym)) (assq 'global plist))
 958       (let ((a (assq 'references plist)))
 959	 (write (list sym (if a (length (cdr a)) 0)))
 960	 (newline) ) ) )
 961   db) )
 962
 963
 964;;; change hook function to hide non-exported module bindings
 965
 966(set! ##sys#toplevel-definition-hook
 967  (lambda (sym renamed exported?)
 968    (cond ((namespaced-symbol? sym)
 969	   (unhide-variable sym))
 970	  ((not exported?)
 971	   (debugging 'o "hiding unexported module binding" renamed)
 972	   (hide-variable renamed)))))
 973
 974
 975;;; Foreign callback stub and type tables:
 976
 977(define foreign-callback-stubs '())
 978
 979(define-record foreign-callback-stub
 980  id 		; symbol
 981  name 	; string
 982  qualifiers ; string
 983  return-type ; type-specifier
 984  argument-types ) ; (type-specifier ...)
 985
 986(define (register-foreign-callback-stub! id params)
 987  (set! foreign-callback-stubs
 988    (cons (apply make-foreign-callback-stub id params) foreign-callback-stubs) )
 989  ;; mark to avoid leaf-routine optimization
 990  (mark-variable id '##compiler#callback-lambda))
 991
 992(define-constant foreign-type-table-size 301)
 993
 994(define foreign-type-table #f)
 995
 996(define (clear-foreign-type-table!)
 997  (if foreign-type-table
 998      (vector-fill! foreign-type-table '())
 999      (set! foreign-type-table (make-vector foreign-type-table-size '())) ))
 1000
1001;; Register a foreign type under the given alias.  type is the foreign
1002;; type's name, arg and ret are the *names* of conversion procedures
1003;; when this type is used as argument or return value, respectively.
1004;; The latter two must either both be supplied, or neither.
1005;; TODO: Maybe create a separate record type for foreign types?
1006(define (register-foreign-type! alias type #!optional arg ret)
1007  (hash-table-set! foreign-type-table alias
1008		   (vector type (and ret arg) (and arg ret))))
1009
1010;; Returns either #f (if t does not exist) or a vector with the type,
1011;; the *name* of the argument conversion procedure and the *name* of
1012;; the return value conversion procedure.  If no conversion procedures
1013;; have been supplied, the corresponding slots will be #f.
1014(define (lookup-foreign-type t)
1015  (hash-table-ref foreign-type-table t))
1016
1017;;; Create foreign type checking expression:
1018
1019(define foreign-type-check		; Used only in compiler.scm
1020  (let ((tmap '((nonnull-u8vector . u8vector) (nonnull-u16vector . u16vector)
1021		(nonnull-s8vector . s8vector) (nonnull-s16vector . s16vector)
1022		(nonnull-u32vector . u32vector) (nonnull-s32vector . s32vector)
1023		(nonnull-u64vector . u64vector) (nonnull-s64vector . s64vector)
1024		(nonnull-f32vector . f32vector) (nonnull-f64vector . f64vector)))
1025	(ftmap '((integer . "int") (unsigned-integer . "unsigned int")
1026		 (integer32 . "C_s32") (unsigned-integer32 . "C_u32")
1027		 (integer64 . "C_s64") (unsigned-integer64 . "C_u64")
1028		 (short . "short") (unsigned-short . "unsigned short")
1029		 (long . "long") (unsigned-long . "unsigned long")
1030		 (ssize_t . "ssize_t") (size_t . "size_t"))))
1031    (lambda (param type)
1032      (follow-without-loop
1033       type
1034       (lambda (t next)
1035	 (let repeat ((t t))
1036	   (case t
1037	     ((char unsigned-char) (if unsafe param `(##sys#foreign-char-argument ,param)))
1038	     ;; TODO: Should "[unsigned-]byte" be range checked?
1039	     ((int unsigned-int byte unsigned-byte int32 unsigned-int32)
1040	      (if unsafe param `(##sys#foreign-fixnum-argument ,param)))
1041	     ((float double number)
1042	      (if unsafe param `(##sys#foreign-flonum-argument ,param)))
1043	     ((u8vector bytevector scheme-pointer
1044                 blob) ; DEPRECATED
1045	      (let ((tmp (gensym)))
1046		`(##core#let ((,tmp ,param))
1047		   (##core#if ,tmp
1048			      ,(if unsafe
1049				   tmp
1050				   `(##sys#foreign-block-argument ,tmp) )
1051		       (##core#quote #f)) ) ) )
1052	     ((nonnull-scheme-pointer nonnull-bytevector nonnull-u8vector
1053                               nonnull-blob) ; DEPRECATED
1054	      (if unsafe
1055		  param
1056		  `(##sys#foreign-block-argument ,param) ) )
1057	     ((pointer-vector)
1058	      (let ((tmp (gensym)))
1059		`(##core#let ((,tmp ,param))
1060		   (##core#if ,tmp
1061			      ,(if unsafe
1062				   tmp
1063				   `(##sys#foreign-struct-wrapper-argument (##core#quote pointer-vector) ,tmp) )
1064		       (##core#quote #f)) ) ) )
1065	     ((nonnull-pointer-vector)
1066	      (if unsafe
1067		  param
1068		  `(##sys#foreign-struct-wrapper-argument (##core#quote pointer-vector) ,param) ) )
1069	     ((u16vector s8vector s16vector u32vector s32vector
1070			u64vector s64vector f32vector f64vector)
1071	      (let ((tmp (gensym)))
1072		`(##core#let ((,tmp ,param))
1073		   (##core#if ,tmp
1074			      ,(if unsafe
1075				   tmp
1076				   `(##sys#foreign-struct-wrapper-argument (##core#quote ,t) ,tmp) )
1077		       (##core#quote #f)) ) ) )
1078	     ((nonnull-u16vector
1079				nonnull-s8vector nonnull-s16vector
1080				nonnull-u32vector nonnull-s32vector
1081				nonnull-u64vector nonnull-s64vector
1082				nonnull-f32vector nonnull-f64vector)
1083	      (if unsafe
1084		  param
1085		  `(##sys#foreign-struct-wrapper-argument
1086		    (##core#quote ,(##sys#slot (assq t tmap) 1))
1087		    ,param) ) )
1088             ((complex cplxnum)
1089               ;; always converts to inexact
1090               `(##sys#foreign-cplxnum-argument ,param))
1091	     ((integer32 integer64 integer short long ssize_t)
1092	      (let* ((foreign-type (##sys#slot (assq t ftmap) 1))
1093		     (size-expr (sprintf "sizeof(~A) * CHAR_BIT" foreign-type)))
1094		(if unsafe
1095		    param
1096		    `(##sys#foreign-ranged-integer-argument
1097		      ,param (foreign-value ,size-expr int)))))
1098	     ((unsigned-short unsigned-long unsigned-integer size_t
1099			      unsigned-integer32 unsigned-integer64)
1100	      (let* ((foreign-type (##sys#slot (assq t ftmap) 1))
1101		     (size-expr (sprintf "sizeof(~A) * CHAR_BIT" foreign-type)))
1102		(if unsafe
1103		    param
1104		    `(##sys#foreign-unsigned-ranged-integer-argument
1105		      ,param (foreign-value ,size-expr int)))))
1106	     ((c-pointer c-string-list c-string-list*)
1107	      (let ((tmp (gensym)))
1108		`(##core#let ((,tmp ,param))
1109		   (##core#if ,tmp
1110			      (##sys#foreign-pointer-argument ,tmp)
1111			      (##core#quote #f)) ) ) )
1112	     ((nonnull-c-pointer)
1113	      `(##sys#foreign-pointer-argument ,param) )
1114	     ((c-string c-string* unsigned-c-string unsigned-c-string*)
1115	      (let ((tmp (gensym)))
1116		`(##core#let ((,tmp ,param))
1117		   (##core#if ,tmp
1118			      ,(if unsafe
1119				   `(##sys#slot ,tmp 0)
1120				   `(##sys#make-c-string (##sys#foreign-string-argument ,tmp)) )
1121		       (##core#quote #f)) ) ) )
1122	     ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*)
1123	      (if unsafe
1124		  `(##sys#slot ,param 0)
1125		  `(##sys#make-c-string (##sys#foreign-string-argument ,param)) ) )
1126	     ((symbol)
1127	      (if unsafe
1128		  `(##sys#slot ,param 1)
1129		  `(##sys#slot (##sys#foreign-symbol-argument ,param) 1)) )
1130             ((bool void scheme-object) param)
1131	     (else
1132	      (cond ((and (symbol? t) (lookup-foreign-type t))
1133		     => (lambda (t) (next (vector-ref t 0)) ) )
1134		    ((pair? t)
1135		     (case (car t)
1136		       ((ref pointer function c-pointer)
1137			(let ((tmp (gensym)))
1138			  `(##core#let ((,tmp ,param))
1139			     (##core#if ,tmp
1140					(##sys#foreign-pointer-argument ,tmp)
1141					(##core#quote #f)) ) )  )
1142		       ((instance instance-ref)
1143			(let ((tmp (gensym)))
1144			  `(##core#let ((,tmp ,param))
1145			     (##core#if ,tmp
1146					(slot-ref ,param (##core#quote this))
1147					(##core#quote #f)) ) ) )
1148                       ((struct union)
1149                        `(##sys#slot (##sys#foreign-struct-wrapper-argument (##core#quote ,(struct/union-wrapper-type-name t))
1150                                                                ,param) 1))
1151		       ((scheme-pointer)
1152			(let ((tmp (gensym)))
1153			  `(##core#let ((,tmp ,param))
1154			     (##core#if ,tmp
1155					,(if unsafe
1156					     tmp
1157					     `(##sys#foreign-block-argument ,tmp) )
1158					(##core#quote #f)) ) ) )
1159		       ((nonnull-scheme-pointer)
1160			(if unsafe
1161			    param
1162			    `(##sys#foreign-block-argument ,param) ) )
1163		       ((nonnull-instance)
1164			`(slot-ref ,param (##core#quote this)) )
1165		       ((const) (repeat (cadr t)))
1166		       ((enum)
1167			(if unsafe
1168			    param
1169			    `(##sys#foreign-ranged-integer-argument
1170			      ;; enums are integer size, according to the C standard.
1171			      ,param (foreign-value "sizeof(int) * CHAR_BIT" int))))
1172		       ((nonnull-pointer nonnull-c-pointer)
1173			`(##sys#foreign-pointer-argument ,param) )
1174		       (else param) ) )
1175		    (else (quit-compiling "unknown foreign type `~S'" type)) ) ) ) ) )
1176       (lambda ()
1177	 (quit-compiling "foreign type `~S' refers to itself" type)) ) ) ) )
1178
1179
1180;;; Compute foreign-type conversions:
1181
1182(define (foreign-type-result-converter t)
1183  (and-let* (((symbol? t))
1184	     (ft (lookup-foreign-type t))
1185	     (retconv (vector-ref ft 2)) )
1186    retconv))
1187
1188(define (foreign-type-argument-converter t)
1189  (and-let* (((symbol? t))
1190	     (ft (lookup-foreign-type t))
1191	     (argconv (vector-ref ft 1)) )
1192    argconv))
1193
1194(define (foreign-type-convert-result r t) ; Used only in compiler.scm
1195  (or (and-let* ((retconv (foreign-type-result-converter t)))
1196	(list retconv r) )
1197      r) )
1198
1199(define (foreign-type-convert-argument a t) ; Used only in compiler.scm
1200  (or (and-let* ((argconv (foreign-type-argument-converter t)) )
1201	(list argconv a) )
1202      a) )
1203
1204(define (final-foreign-type t0)		; Used here and in compiler.scm
1205  (follow-without-loop
1206   t0
1207   (lambda (t next)
1208     (cond ((and (symbol? t) (lookup-foreign-type t))
1209	    => (lambda (t2) (next (vector-ref t2 0)) ) )
1210	   (else t) ) )
1211   (lambda () (quit-compiling "foreign type `~S' refers to itself" t0)) ) )
1212
1213
1214;;; Compute foreign result size:
1215
1216(define (estimate-foreign-result-size type)
1217  (define (err t)
1218    (quit-compiling "cannot compute size for unknown foreign type `~S' result" type))
1219  (follow-without-loop
1220   type
1221   (lambda (t next)
1222     (case t
1223       ((char int short bool void unsigned-short scheme-object unsigned-char unsigned-int byte unsigned-byte
1224	      int32 unsigned-int32)
1225	0)
1226       ((c-string nonnull-c-string c-pointer nonnull-c-pointer symbol c-string* nonnull-c-string*
1227                  unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
1228		  c-string-list c-string-list*)
1229	(words->bytes 3) )
1230       ((unsigned-integer long integer unsigned-long integer32 unsigned-integer32)
1231	(words->bytes 6) )    ; 1 bignum digit on 32-bit (overallocs on 64-bit)
1232       ((float double number)
1233	(words->bytes 4) )		; possibly 8-byte aligned 64-bit double
1234       ((complex cplxnum)
1235	(words->bytes 8))     ; 2 double numbers, possibly 8-byte aligned (overallocs on 64-bit)
1236       ((integer64 unsigned-integer64 size_t ssize_t)
1237	(words->bytes 7))     ; 2 bignum digits on 32-bit (overallocs on 64-bit)
1238       (else
1239	(cond ((and (symbol? t) (lookup-foreign-type t))
1240	       => (lambda (t2) (next (vector-ref t2 0)) ) )
1241	      ((pair? t)
1242	       (case (car t)
1243		 ((ref nonnull-pointer pointer c-pointer nonnull-c-pointer function instance instance-ref nonnull-instance)
1244		  (words->bytes 3) )
1245		 ((const) (next (cadr t)))
1246                 ((struct union) (words->bytes 3)) ;; struct wrapper
1247		 ((enum) (words->bytes 6)) ; 1 bignum digit on 32-bit (overallocs on 64-bit)
1248		 (else (err t))))
1249	      (else (err t))))))
1250   (lambda () (quit-compiling "foreign type `~S' refers to itself" type)) ) )
1251
1252(define (estimate-foreign-result-location-size type) ; Used only in compiler.scm
1253  (define (err t)
1254    (quit-compiling "cannot compute size of location for foreign type `~S'" t) )
1255  (follow-without-loop
1256   type
1257   (lambda (t next)
1258     (case t
1259       ((char int short bool unsigned-short unsigned-char unsigned-int long unsigned-long byte
1260	      unsigned-byte c-pointer nonnull-c-pointer unsigned-integer integer float c-string symbol
1261	      scheme-pointer nonnull-scheme-pointer int32 unsigned-int32 integer32 unsigned-integer32
1262              unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
1263	      nonnull-c-string c-string* nonnull-c-string* c-string-list c-string-list*)
1264	(words->bytes 1) )
1265       ((double integer64 unsigned-integer64 size_t ssize_t)
1266	(words->bytes 2) )
1267       ((complex cplxnum)
1268        (words->bytes 4))
1269       (else
1270	(cond ((and (symbol? t) (lookup-foreign-type t))
1271	       => (lambda (t2) (next (vector-ref t2 0)) ) )
1272	      ((pair? t)
1273	       (case (car t)
1274		 ((ref nonnull-pointer pointer c-pointer nonnull-c-pointer function
1275		       scheme-pointer nonnull-scheme-pointer enum)
1276		  (words->bytes 1))
1277                 ((struct union) (words->bytes 3)) ;; struct wrapper
1278		 ((const) (next (cadr t)))
1279		 (else (err t)) ) )
1280	      (else (err t)) ) ) ) )
1281   (lambda () (quit-compiling "foreign type `~S' refers to itself" type)) ) )
1282
1283
1284;;; Convert result value, if a string:
1285
1286(define (finish-foreign-result type body) ; Used only in compiler.scm
1287  (let ((type (strip-syntax type)))
1288    (case type
1289      ((c-string unsigned-c-string) `(##sys#peek-c-string ,body (##core#quote 0)))
1290      ((nonnull-c-string) `(##sys#peek-nonnull-c-string ,body (##core#quote 0)))
1291      ((c-string* unsigned-c-string*) `(##sys#peek-and-free-c-string ,body (##core#quote 0)))
1292      ((nonnull-c-string* nonnull-unsigned-c-string*) `(##sys#peek-and-free-nonnull-c-string ,body (##core#quote 0)))
1293      ((symbol) `(##sys#string->symbol (##sys#peek-c-string ,body (##core#quote 0))))
1294      ((c-string-list) `(##sys#peek-c-string-list ,body (##core#quote #f)))
1295      ((c-string-list*) `(##sys#peek-and-free-c-string-list ,body (##core#quote #f)))
1296      (else
1297       (cond ((not (list? type)) body)
1298             ((and (memq (car type) '(struct union))
1299                   (= 2 (length type)))
1300              `(##sys#wrap-struct (##core#quote ,(struct/union-wrapper-type-name type)) ,body))
1301             ((and (eq? (car type) 'const)
1302                   (= 2 (length type))
1303                   (memq (cadr type) '(c-string c-string* unsigned-c-string
1304                                                unsigned-c-string* nonnull-c-string
1305                                                nonnull-c-string*
1306                                                nonnull-unsigned-string*)))
1307              (finish-foreign-result (cadr type) body))
1308             ((= 3 (length type))
1309              (case (car type)
1310                ((instance instance-ref)
1311                 (let ((tmp (gensym)))
1312                   `(let ((,tmp ,body))
1313                      (and ,tmp
1314                           (not (##sys#null-pointer? ,tmp))
1315                           (make ,(caddr type)
1316                                 (##core#quote this) ,tmp) ) ) ) )
1317                ((nonnull-instance)
1318                 `(make ,(caddr type) (##core#quote this) ,body) )
1319                (else body)))
1320             (else body))))))
1321
1322
1323;;; Translate foreign-type into scrutinizer type:
1324
1325;; Used in chicken-ffi-syntax.scm and scrutinizer.scm
1326(define (foreign-type->scrutiny-type t mode) ; MODE = 'arg | 'result
1327  ;; If the foreign type has a converter, it can return a different
1328  ;; type from the native type matching the foreign type (see #1649)
1329  (if (or (and (eq? mode 'arg) (foreign-type-argument-converter t))
1330	  (and (eq? mode 'result) (foreign-type-result-converter t)))
1331      ;; Here we just punt on the type, but it would be better to
1332      ;; find out the result type of the converter procedure.
1333      '*
1334      (let ((ft (final-foreign-type t)))
1335	(case ft
1336	  ((void) 'undefined)
1337	  ((char unsigned-char) 'char)
1338	  ((int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32)
1339	   'fixnum)
1340	  ((float double)
1341	   (case mode
1342	     ((arg) 'number)
1343	     (else 'float)))
1344	  ((complex cplxnum) 'complex)
1345	  ((scheme-pointer nonnull-scheme-pointer) '*)
1346	  ((bytevector u8vector
1347                blob) ; DEPRECATED
1348	   (case mode
1349	     ((arg) '(or false bytevector))
1350	     (else 'bytevector)))
1351	  ((nonnull-bytevector) 'bytevector)
1352	  ((nonnull-blob) 'bytevector) ; DEPRECATED
1353	  ((pointer-vector)
1354	   (case mode
1355	     ((arg) '(or false pointer-vector))
1356	     (else 'pointer-vector)))
1357	  ((nonnull-pointer-vector) 'pointer-vector)
1358	  ((u16vector s8vector s16vector u32vector s32vector u64vector s64vector f32vector f64vector)
1359	   (case mode
1360	     ((arg) `(or false (struct ,ft)))
1361	     (else `(struct ,ft))))
1362	  ((nonnull-u8vector) 'bytevector)
1363	  ((nonnull-s8vector) '(struct s8vector))
1364	  ((nonnull-u16vector) '(struct u16vector))
1365	  ((nonnull-s16vector) '(struct s16vector))
1366	  ((nonnull-u32vector) '(struct u32vector))
1367	  ((nonnull-s32vector) '(struct s32vector))
1368	  ((nonnull-u64vector) '(struct u64vector))
1369	  ((nonnull-s64vector) '(struct s64vector))
1370	  ((nonnull-f32vector) '(struct f32vector))
1371	  ((nonnull-f64vector) '(struct f64vector))
1372	  ((integer long size_t ssize_t integer32 unsigned-integer32 integer64 unsigned-integer64
1373		    unsigned-long)
1374	   'integer)
1375	  ((c-pointer)
1376	   (if (eq? 'arg mode)
1377	       '(or false pointer locative)
1378	       '(or false pointer)))
1379	  ((nonnull-c-pointer)
1380	   (if (eq? 'arg mode)
1381	       '(or pointer locative)
1382	       'pointer))
1383	  ((c-string c-string* unsigned-c-string unsigned-c-string*)
1384	   '(or false string))
1385	  ((c-string-list c-string-list*)
1386	   '(list-of string))
1387	  ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*) 'string)
1388	  ((symbol) 'symbol)
1389	  (else
1390	   (cond ((pair? t)
1391		  (case (car t)
1392		    ((ref pointer function c-pointer)
1393		     (if (eq? 'arg mode)
1394			 '(or false pointer locative)
1395			 '(or false pointer)))
1396		    ((const) (foreign-type->scrutiny-type (cadr t) mode))
1397                    ((struct union)
1398                     `(struct ,(struct/union-wrapper-type-name t)))
1399		    ((enum) 'integer)
1400		    ((nonnull-pointer nonnull-c-pointer)
1401		     (if (eq? 'arg mode)
1402			 '(or pointer locative)
1403			 'pointer))
1404		    (else '*)))
1405		 (else '*)))))))
1406
1407
1408;;; Scan expression-node for variable usage:
1409
1410(define (scan-used-variables node vars)
1411  (let ([used '()])
1412    (let walk ([n node])
1413      (let ([subs (node-subexpressions n)])
1414	(case (node-class n)
1415	  [(##core#variable set!)
1416	   (let ([var (first (node-parameters n))])
1417	     (when (and (memq var vars) (not (memq var used)))
1418	       (set! used (cons var used)) )
1419	     (for-each walk subs) ) ]
1420	  [(quote ##core#undefined ##core#primitive) #f]
1421	  [else (for-each walk subs)] ) ) )
1422    used) )
1423
1424
1425;;; Scan expression-node for free variables (that are not in env):
1426
1427(define (scan-free-variables node block-compilation)
1428  (let ((vars '())
1429	(hvars '()))
1430
1431    (define (walk n e)
1432      (let ([subs (node-subexpressions n)]
1433	    [params (node-parameters n)] )
1434	(case (node-class n)
1435	  ((quote ##core#undefined ##core#primitive ##core#proc ##core#inline_ref) #f)
1436	  ((##core#variable)
1437	   (let ((var (first params)))
1438	     (unless (memq var e)
1439	       (set! vars (lset-adjoin/eq? vars var))
1440	       (unless (variable-visible? var block-compilation)
1441		 (set! hvars (lset-adjoin/eq? hvars var))))))
1442	  ((set!)
1443	   (let ((var (first params)))
1444	     (unless (memq var e) (set! vars (lset-adjoin/eq? vars var)))
1445	     (walk (car subs) e) ) )
1446	  ((let)
1447	   (walk (first subs) e)
1448	   (walk (second subs) (append params e)) )
1449	  ((##core#lambda)
1450	   (##sys#decompose-lambda-list
1451	    (third params)
1452	    (lambda (vars argc rest)
1453	      (walk (first subs) (append vars e)) ) ) )
1454	  (else (walkeach subs e)) ) ) )
1455
1456    (define (walkeach ns e)
1457      (for-each (lambda (n) (walk n e)) ns) )
1458
1459    (walk node '())
1460    (values vars hvars) ) )		; => freevars hiddenvars
1461
1462
1463;;; Special block-variable literal type:
1464
1465(define-record block-variable-literal
1466  name)	; symbol
1467
1468
1469;;; Generation of random names:
1470
1471;; This one looks iffy.  It's also used only in compiler.scm
1472(define (make-random-name . prefix)
1473  (string->symbol
1474   (sprintf "~A-~A~A"
1475	    (optional prefix (gensym))
1476	    (current-seconds)
1477	    (##core#inline "C_random_fixnum" 1000))))
1478
1479
1480;;; Register/lookup real names:
1481;
1482; - The real-name-table contains the following mappings:
1483;
1484;     <variable-alias> -> <variable>
1485;     <lambda-id> -> <variable> or <variable-alias>
1486
1487(define-constant real-name-table-size 997)
1488
1489(define real-name-table #f)
1490
1491(define (clear-real-name-table!)
1492  (set! real-name-table (make-vector real-name-table-size '())))
1493
1494(define (set-real-name! name rname)	; Used only in compiler.scm
1495  (hash-table-set! real-name-table name rname))
1496
1497;; TODO: Find out why there are so many lookup functions for this and
1498;; reduce them to the minimum.
1499(define (get-real-name name)
1500  (hash-table-ref real-name-table name))
1501
1502;; Arbitrary limit to prevent runoff into exponential behavior
1503(define real-name-max-depth 20)
1504
1505(define (real-name var . db)
1506  (define (resolve n)
1507    (let ((n2 (hash-table-ref real-name-table n)))
1508      (if n2
1509	  (or (hash-table-ref real-name-table n2)
1510	      n2)
1511	  n) ) )
1512  (let ((rn (resolve var)))
1513    (cond ((not rn) (##sys#symbol->string var))
1514	  ((pair? db)
1515	   (let ((db (car db)))
1516	     (let loop ((nesting (list (##sys#symbol->string rn)))
1517			(depth 0)
1518			(container (db-get db var 'contained-in)) )
1519	       (cond
1520		((> depth real-name-max-depth)
1521		 (string-intersperse (reverse (cons "..." nesting)) " in "))
1522		(container
1523		 (let ((rc (resolve container)))
1524		   (if (eq? rc container)
1525		       (string-intersperse (reverse nesting) " in ")
1526		       (loop (cons (symbol->string rc) nesting)
1527			     (fx+ depth 1)
1528			     (db-get db container 'contained-in) ) ) ))
1529		(else (string-intersperse (reverse nesting) " in "))) ) ) )
1530	  (else (##sys#symbol->string rn)) ) ) )
1531
1532(define (real-name2 var db)		; Used only in c-backend.scm
1533  (and-let* ((rn (hash-table-ref real-name-table var)))
1534    (real-name rn db) ) )
1535
1536(define (display-real-name-table)
1537  (hash-table-for-each
1538   (lambda (key val)
1539     (printf "~S\t~S~%" key val) )
1540   real-name-table) )
1541
1542(define (source-info->string info)	; Used only in c-backend.scm
1543  (if (list? info)
1544      (let ((ln (car info))
1545	    (name (cadr info)))
1546	(conc ln ":" (make-string (max 0 (- 4 (string-length ln))) #\space) " " name) )
1547      (->string info)))
1548
1549(define (source-info->name info)
1550  (if (list? info) (cadr info) (->string info)))
1551
1552(define (source-info->line info)
1553  (and (list? info) (car info)))
1554
1555(define (call-info params var)		; Used only in optimizer.scm
1556  (or (and-let* ((info (and (pair? (cdr params)) (second params))))
1557	(and (list? info)
1558	     (let ((ln (car info))
1559		   (name (cadr info)))
1560	       (conc "(" ln ") " var))))
1561      var))
1562
1563
1564;;; constant folding support:
1565
1566(define (constant-form-eval op argnodes k)  ; Used only in optimizer.scm
1567  (let* ((args (map (lambda (n) (first (node-parameters n))) argnodes))
1568	 (form (cons op (map (lambda (arg) `(quote ,arg)) args))))
1569    ;; op must have toplevel binding, result must be single-valued
1570    (let ((proc (##sys#slot op 0)))
1571      (if (procedure? proc)
1572	  (let ((results (handle-exceptions ex ex (receive (apply proc args)))))
1573	    (cond ((condition? results) (k #f #f))
1574		  ((and (= 1 (length results))
1575			(encodeable-literal? (car results)))
1576		   (debugging 'o "folded constant expression" form)
1577		   (k #t (car results)))
1578		  ((= 1 (length results)) ; not encodeable; don't fold
1579		   (k #f #f))
1580		  (else
1581		   (bomb "attempt to constant-fold call to procedure that has multiple results" form))))
1582	  (bomb "attempt to constant-fold call to non-procedure" form)))))
1583
1584(define (maybe-constant-fold-call n subs k)
1585  (define (constant-node? n2) (eq? 'quote (node-class n2)))
1586  (if (eq? '##core#variable (node-class (car subs)))
1587      (let ((var (first (node-parameters (car subs)))))
1588	(if (and (intrinsic? var)
1589		 (or (foldable? var)
1590		     (predicate? var))
1591		 (every constant-node? (cdr subs)) )
1592	    (constant-form-eval var (cdr subs) (lambda (ok res) (k ok res #t)))
1593	    (k #f #f #f)))
1594      (k #f #f #f)))
1595
1596;; Is the literal small enough to be encoded?  Otherwise, it should
1597;; not be constant-folded.
1598(define (encodeable-literal? lit)
1599  (define getsize
1600    (foreign-lambda* int ((scheme-object lit))
1601      "return(C_header_size(lit));"))
1602  (define (fits? n)
1603    (fx<= (integer-length n) 24))
1604  (cond ((immediate? lit))
1605	((##core#inline "C_i_exact_integerp" lit)
1606	 ;; Could use integer-length, but that's trickier (minus
1607	 ;; symbol etc).  If the string is too large to allocate,
1608	 ;; we'll also get an exception!
1609	 (let ((str (handle-exceptions ex #f (number->string lit 16))))
1610	   (and str (fits? (string-length str)))))
1611	((flonum? lit))
1612	((symbol? lit)
1613	 (let ((str (##sys#symbol->string/shared lit)))
1614	   (fits? (string-length str))))
1615        ((string? lit)
1616         (fits? (getsize (##sys#slot lit 0))))
1617	((##core#inline "C_byteblockp" lit)
1618	 (fits? (getsize lit)))
1619	(else
1620	 (let ((len (getsize lit)))
1621	   (and (fits? len)
1622		(every
1623		 encodeable-literal?
1624		 (list-tabulate len (lambda (i)
1625				      (##sys#slot lit i)))))))))
1626
1627
1628;;; Dump node structure:
1629
1630(define (dump-nodes n)			; Used only in batch-driver.scm
1631  (let loop ([i 0] [n n])
1632    (let ([class (node-class n)]
1633	  [params (node-parameters n)]
1634	  [subs (node-subexpressions n)]
1635	  [ind (make-string i #\space)]
1636	  [i2 (+ i 2)] )
1637      (printf "~%~A<~A ~S" ind class params)
1638      (for-each (cut loop i2 <>) subs)
1639      (let ([len (##sys#size n)])
1640	(when (fx> len 4)
1641	  (printf "[~S" (##sys#slot n 4))
1642	  (do ([i 5 (fx+ i 1)])
1643	      ((fx>= i len))
1644	    (printf " ~S" (##sys#slot n i)) )
1645	  (write-char #\]) ) )
1646      (write-char #\>) ) )
1647  (newline) )
1648 
1649
1650;;; "#> ... <#" syntax:
1651
1652(set! ##sys#user-read-hook
1653  (let ([old-hook ##sys#user-read-hook])
1654    (lambda (char port)
1655      (if (char=? #\> char)
1656	  (let* ((_ (read-char port))		; swallow #\>
1657		 (text (scan-sharp-greater-string port)))
1658	    `(declare (foreign-declare ,text)) )
1659	  (old-hook char port) ) ) ) )
1660
1661(define (scan-sharp-greater-string port)
1662  (let ([out (open-output-string)])
1663    (let loop ()
1664      (let ((c (read-char port)))
1665	(cond ((eof-object? c)
1666	       (quit-compiling "unexpected end of `#> ... <#' sequence"))
1667	      ((char=? c #\newline)
1668	       (newline out)
1669	       (loop) )
1670	      ((char=? c #\<)
1671	       (let ([c (read-char port)])
1672		 (if (eqv? #\# c)
1673		     (get-output-string out)
1674		     (begin
1675		       (write-char #\< out)
1676		       (write-char c out)
1677		       (loop) ) ) ) )
1678	      (else
1679	       (write-char c out)
1680	       (loop) ) ) ) ) ) )
1681
1682
1683;;; 64-bit fixnum?
1684
1685(define (big-fixnum? x)	;; XXX: This should probably be in c-platform
1686  (and (fixnum? x)
1687       (feature? #:64bit)
1688       (or (fx> x 1073741823)
1689	   (fx< x -1073741824) ) ) )
1690
1691(define (small-bignum? x) ;; XXX: This should probably be in c-platform
1692  (and (bignum? x)
1693       (not (feature? #:64bit))
1694       (fx<= (integer-length x) 62) ) )
1695
1696
1697;;; symbol visibility and other global variable properties
1698
1699(define (hide-variable sym)		; Used in compiler.scm and here
1700  (mark-variable sym '##compiler#visibility 'hidden))
1701
1702(define (export-variable sym)		; Used only in compiler.scm
1703  (mark-variable sym '##compiler#visibility 'exported))
1704
1705(define (variable-hidden? sym)
1706  (eq? (##sys#get sym '##compiler#visibility) 'hidden))
1707
1708(define (unhide-variable sym)
1709  (when (variable-hidden? sym) (remprop! sym '##compiler#visibility)))
1710
1711(define (variable-visible? sym block-compilation)
1712  (let ((p (##sys#get sym '##compiler#visibility)))
1713    (case p
1714      ((hidden) #f)
1715      ((exported) #t)
1716      (else (not block-compilation)))))
1717
1718;; These two have somewhat confusing names.  Maybe mark-variable could
1719;; be renamed to "variable-mark-set!"?  Also, in some other situations,
1720;; put!/get are used directly.
1721(define (mark-variable var mark #!optional (val #t))
1722  (##sys#put! var mark val) )
1723
1724(define (variable-mark var mark)
1725  (##sys#get var mark) )
1726
1727(define intrinsic? (cut variable-mark <> '##compiler#intrinsic))
1728;; Used only in optimizer.scm
1729(define foldable? (cut variable-mark <> '##compiler#foldable))
1730(define predicate? (cut variable-mark <> '##compiler#predicate))
1731
1732
1733;;; Load support files
1734
1735(define (load-identifier-database name)	; Used only in batch-driver.scm
1736  (and-let* ((dbfile (chicken.load#find-file name (repository-path))))
1737    (debugging 'p (sprintf "loading identifier database ~a ...~%" dbfile))
1738    (for-each
1739     (lambda (e)
1740       (let ((id (car e)))
1741	 (##sys#put!
1742	  id '##core#db
1743	  (append (or (##sys#get id '##core#db) '()) (list (cdr e))) )))
1744     (call-with-input-file dbfile read-expressions))))
1745
1746
1747;;; Print version/usage information:
1748
1749(define (print-version #!optional b)	; Used only in batch-driver.scm
1750  (when b (print-banner)))
1751
1752(define (print-banner)  ; duplicate of one in csi.scm
1753  (let ((v (string-split (chicken-version #t) "\n")))
1754    (print (string-translate* +banner+ 
1755             `(("XXX" ,@(cadr v)) 
1756               ("YYY" ,@(string-translate* (substring (car v) 9) '(("." . " . ")))))))))
1757
1758;; Used only in batch-driver.scm, but it seems to me this should be moved
1759;; to chicken.scm, as that's the only place this belongs.
1760(define (print-usage)
1761  (print-version)
1762  (newline)
1763  (display #<<EOF
1764Usage: chicken FILENAME [OPTION ...]
1765
1766  `chicken' is the CHICKEN compiler.
1767
1768  FILENAME should be a complete source file name with extension, or "-" for
1769  standard input. OPTION may be one of the following:
1770
1771  General options:
1772
1773    -help                        display this text and exit
1774    -version                     display compiler version and exit
1775    -release                     print release number and exit
1776    -verbose                     display information on compilation progress
1777
1778  File and pathname options:
1779
1780    -output-file FILENAME        specifies output-filename, default is 'out.c'
1781    -include-path PATHNAME       specifies alternative path for included files
1782    -to-stdout                   write compiled file to stdout instead of file
1783
1784  Language options:
1785
1786    -feature SYMBOL              register feature identifier
1787    -no-feature SYMBOL           disable built-in feature identifier
1788
1789  Syntax related options:
1790
1791    -case-insensitive            don't preserve case of read symbols
1792    -keyword-style STYLE         allow alternative keyword syntax
1793                                  (prefix, suffix or none)
1794    -no-parentheses-synonyms     disables list delimiter synonyms
1795    -r7rs-syntax                 disables the CHICKEN extensions to
1796                                  R7RS syntax
1797    -compile-syntax              macros are made available at run-time
1798    -emit-import-library MODULE  write compile-time module information into
1799                                  separate file
1800    -emit-all-import-libraries   emit import-libraries for all defined modules
1801    -no-compiler-syntax          disable expansion of compiler-macros
1802    -module NAME                 wrap compiled code in a module
1803    -module-registration         always generate module registration code
1804    -no-module-registration      never generate module registration code
1805                                  (overrides `-module-registration')
1806
1807  Translation options:
1808
1809    -explicit-use                do not use units 'library' and 'eval' by
1810                                  default
1811    -check-syntax                stop compilation after macro-expansion
1812    -analyze-only                stop compilation after first analysis pass
1813
1814  Debugging options:
1815
1816    -no-warnings                 disable warnings
1817    -debug-level NUMBER          set level of available debugging information
1818    -no-trace                    disable tracing information
1819    -debug-info                  enable debug-information in compiled code for use
1820                                  with an external debugger
1821    -profile                     executable emits profiling information
1822    -profile-name FILENAME       name of the generated profile information file
1823    -accumulate-profile          executable emits profiling information in
1824                                  append mode
1825    -no-lambda-info              omit additional procedure-information
1826    -emit-types-file FILENAME    write type-declaration information into file
1827    -consult-types-file FILENAME load additional type database
1828
1829  Optimization options:
1830
1831    -optimize-level NUMBER       enable certain sets of optimization options
1832    -optimize-leaf-routines      enable leaf routine optimization
1833    -no-usual-integrations       standard procedures may be redefined
1834    -unsafe                      disable all safety checks
1835    -local                       assume globals are only modified in current
1836                                  file
1837    -block                       enable block-compilation
1838    -disable-interrupts          disable interrupts in compiled code
1839    -fixnum-arithmetic           assume all numbers are fixnums
1840    -disable-stack-overflow-checks  disables detection of stack-overflows
1841    -inline                      enable inlining
1842    -inline-limit LIMIT          set inlining threshold
1843    -inline-global               enable cross-module inlining
1844    -specialize                  perform type-based specialization of primitive calls
1845    -emit-inline-file FILENAME   generate file with globally inlinable
1846                                  procedures (implies -inline -local)
1847    -consult-inline-file FILENAME  explicitly load inline file
1848    -no-argc-checks              disable argument count checks
1849    -no-bound-checks             disable bound variable checks
1850    -no-procedure-checks         disable procedure call checks
1851    -no-procedure-checks-for-usual-bindings
1852                                   disable procedure call checks only for usual
1853                                   bindings
1854    -no-procedure-checks-for-toplevel-bindings
1855                                   disable procedure call checks for toplevel
1856                                   bindings
1857    -strict-types                assume variable do not change their type
1858    -lfa2                        perform additional lightweight flow-analysis pass
1859    -unroll-limit LIMIT          specifies inlining limit for self-recursive calls
1860    -merge-resuable-closures     enables closure reuse
1861    -merge-shareable-closures    enables closure sharing
1862
1863  Configuration options:
1864
1865    -unit NAME                   compile file as a library unit
1866    -uses NAME                   declare library unit as used.
1867    -heap-size NUMBER            specifies heap-size of compiled executable
1868    -nursery NUMBER  -stack-size NUMBER
1869                                 specifies nursery size of compiled executable
1870    -extend FILENAME             load file before compilation commences
1871    -prelude EXPRESSION          add expression to front of source file
1872    -postlude EXPRESSION         add expression to end of source file
1873    -prologue FILENAME           include file before main source file
1874    -epilogue FILENAME           include file after main source file
1875    -dynamic                     compile as dynamically loadable code
1876    -require-extension NAME      require and import extension NAME
1877
1878  Obscure options:
1879
1880    -debug MODES                 display debugging output for the given modes
1881    -raw                         do not generate implicit init- and exit code
1882    -emit-external-prototypes-first
1883                                 emit prototypes for callbacks before foreign
1884                                  declarations
1885    -regenerate-import-libraries emit import libraries even when unchanged
1886    -ignore-repository           do not refer to repository for extensions
1887    -setup-mode                  prefer the current directory when locating extensions
1888
1889EOF
1890) )
1891
1892;; Same as above
1893(define (print-debug-options)
1894  (display #<<EOF
1895
1896Available debugging options:
1897
1898     a          show node-matching during simplification
1899     b          show breakdown of time needed for each compiler pass
1900     c          print every expression before macro-expansion
1901     d          lists all assigned global variables
1902     e          show information about specializations
1903     h          you already figured that out
1904     i          show information about inlining
1905     m          show GC statistics during compilation
1906     n          print the line-number database
1907     o          show performed optimizations
1908     p          display information about what the compiler is currently doing
1909     r          show invocation parameters
1910     s          show program-size information and other statistics
1911     t          show time needed for compilation
1912     u          lists all unassigned global variable references
1913     x          display information about experimental features
1914     D          when printing nodes, use node-tree output
1915     I          show inferred type information for unexported globals
1916     N          show the real-name mapping table
1917     P          show expressions after specialization
1918     S          show applications of compiler syntax
1919     T          show expressions after converting to node tree
1920     1          show source expressions
1921     2          show canonicalized expressions
1922     3          show expressions converted into CPS
1923     4          show database after each analysis pass
1924     5          show expressions after each optimization pass
1925     6          show expressions after each inlining pass
1926     7          show expressions after complete optimization
1927     8          show database after final analysis
1928     9          show expressions after closure conversion
1929
1930
1931EOF
1932))
1933)
1934