~ 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 read/source-info 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	     (else
1131	      (cond ((and (symbol? t) (lookup-foreign-type t))
1132		     => (lambda (t) (next (vector-ref t 0)) ) )
1133		    ((pair? t)
1134		     (case (car t)
1135		       ((ref pointer function c-pointer)
1136			(let ((tmp (gensym)))
1137			  `(##core#let ((,tmp ,param))
1138			     (##core#if ,tmp
1139					(##sys#foreign-pointer-argument ,tmp)
1140					(##core#quote #f)) ) )  )
1141		       ((instance instance-ref)
1142			(let ((tmp (gensym)))
1143			  `(##core#let ((,tmp ,param))
1144			     (##core#if ,tmp
1145					(slot-ref ,param (##core#quote this))
1146					(##core#quote #f)) ) ) )
1147                       ((struct union)
1148                        `(##sys#slot (##sys#foreign-struct-wrapper-argument (##core#quote ,(struct/union-wrapper-type-name t))
1149                                                                ,param) 1))
1150		       ((scheme-pointer)
1151			(let ((tmp (gensym)))
1152			  `(##core#let ((,tmp ,param))
1153			     (##core#if ,tmp
1154					,(if unsafe
1155					     tmp
1156					     `(##sys#foreign-block-argument ,tmp) )
1157					(##core#quote #f)) ) ) )
1158		       ((nonnull-scheme-pointer)
1159			(if unsafe
1160			    param
1161			    `(##sys#foreign-block-argument ,param) ) )
1162		       ((nonnull-instance)
1163			`(slot-ref ,param (##core#quote this)) )
1164		       ((const) (repeat (cadr t)))
1165		       ((enum)
1166			(if unsafe
1167			    param
1168			    `(##sys#foreign-ranged-integer-argument
1169			      ;; enums are integer size, according to the C standard.
1170			      ,param (foreign-value "sizeof(int) * CHAR_BIT" int))))
1171		       ((nonnull-pointer nonnull-c-pointer)
1172			`(##sys#foreign-pointer-argument ,param) )
1173		       (else param) ) )
1174		    (else param) ) ) ) ) )
1175       (lambda ()
1176	 (quit-compiling "foreign type `~S' refers to itself" type)) ) ) ) )
1177
1178
1179;;; Compute foreign-type conversions:
1180
1181(define (foreign-type-result-converter t)
1182  (and-let* (((symbol? t))
1183	     (ft (lookup-foreign-type t))
1184	     (retconv (vector-ref ft 2)) )
1185    retconv))
1186
1187(define (foreign-type-argument-converter t)
1188  (and-let* (((symbol? t))
1189	     (ft (lookup-foreign-type t))
1190	     (argconv (vector-ref ft 1)) )
1191    argconv))
1192
1193(define (foreign-type-convert-result r t) ; Used only in compiler.scm
1194  (or (and-let* ((retconv (foreign-type-result-converter t)))
1195	(list retconv r) )
1196      r) )
1197
1198(define (foreign-type-convert-argument a t) ; Used only in compiler.scm
1199  (or (and-let* ((argconv (foreign-type-argument-converter t)) )
1200	(list argconv a) )
1201      a) )
1202
1203(define (final-foreign-type t0)		; Used here and in compiler.scm
1204  (follow-without-loop
1205   t0
1206   (lambda (t next)
1207     (cond ((and (symbol? t) (lookup-foreign-type t))
1208	    => (lambda (t2) (next (vector-ref t2 0)) ) )
1209	   (else t) ) )
1210   (lambda () (quit-compiling "foreign type `~S' refers to itself" t0)) ) )
1211
1212
1213;;; Compute foreign result size:
1214
1215(define (estimate-foreign-result-size type)
1216  (define (err t)
1217    (quit-compiling "cannot compute size for unknown foreign type `~S' result" type))
1218  (follow-without-loop
1219   type
1220   (lambda (t next)
1221     (case t
1222       ((char int short bool void unsigned-short scheme-object unsigned-char unsigned-int byte unsigned-byte
1223	      int32 unsigned-int32)
1224	0)
1225       ((c-string nonnull-c-string c-pointer nonnull-c-pointer symbol c-string* nonnull-c-string*
1226                  unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
1227		  c-string-list c-string-list*)
1228	(words->bytes 3) )
1229       ((unsigned-integer long integer unsigned-long integer32 unsigned-integer32)
1230	(words->bytes 6) )    ; 1 bignum digit on 32-bit (overallocs on 64-bit)
1231       ((float double number)
1232	(words->bytes 4) )		; possibly 8-byte aligned 64-bit double
1233       ((complex cplxnum)
1234	(words->bytes 8))     ; 2 double numbers, possibly 8-byte aligned (overallocs on 64-bit)
1235       ((integer64 unsigned-integer64 size_t ssize_t)
1236	(words->bytes 7))     ; 2 bignum digits on 32-bit (overallocs on 64-bit)
1237       (else
1238	(cond ((and (symbol? t) (lookup-foreign-type t))
1239	       => (lambda (t2) (next (vector-ref t2 0)) ) )
1240	      ((pair? t)
1241	       (case (car t)
1242		 ((ref nonnull-pointer pointer c-pointer nonnull-c-pointer function instance instance-ref nonnull-instance)
1243		  (words->bytes 3) )
1244		 ((const) (next (cadr t)))
1245                 ((struct union) (words->bytes 3)) ;; struct wrapper
1246		 ((enum) (words->bytes 6)) ; 1 bignum digit on 32-bit (overallocs on 64-bit)
1247		 (else (err t))))
1248	      (else (err t))))))
1249   (lambda () (quit-compiling "foreign type `~S' refers to itself" type)) ) )
1250
1251(define (estimate-foreign-result-location-size type) ; Used only in compiler.scm
1252  (define (err t)
1253    (quit-compiling "cannot compute size of location for foreign type `~S'" t) )
1254  (follow-without-loop
1255   type
1256   (lambda (t next)
1257     (case t
1258       ((char int short bool unsigned-short unsigned-char unsigned-int long unsigned-long byte
1259	      unsigned-byte c-pointer nonnull-c-pointer unsigned-integer integer float c-string symbol
1260	      scheme-pointer nonnull-scheme-pointer int32 unsigned-int32 integer32 unsigned-integer32
1261              unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
1262	      nonnull-c-string c-string* nonnull-c-string* c-string-list c-string-list*)
1263	(words->bytes 1) )
1264       ((double integer64 unsigned-integer64 size_t ssize_t)
1265	(words->bytes 2) )
1266       ((complex cplxnum)
1267        (words->bytes 4))
1268       (else
1269	(cond ((and (symbol? t) (lookup-foreign-type t))
1270	       => (lambda (t2) (next (vector-ref t2 0)) ) )
1271	      ((pair? t)
1272	       (case (car t)
1273		 ((ref nonnull-pointer pointer c-pointer nonnull-c-pointer function
1274		       scheme-pointer nonnull-scheme-pointer enum)
1275		  (words->bytes 1))
1276                 ((struct union) (words->bytes 3)) ;; struct wrapper
1277		 ((const) (next (cadr t)))
1278		 (else (err t)) ) )
1279	      (else (err t)) ) ) ) )
1280   (lambda () (quit-compiling "foreign type `~S' refers to itself" type)) ) )
1281
1282
1283;;; Convert result value, if a string:
1284
1285(define (finish-foreign-result type body) ; Used only in compiler.scm
1286  (let ((type (strip-syntax type)))
1287    (case type
1288      ((c-string unsigned-c-string) `(##sys#peek-c-string ,body (##core#quote 0)))
1289      ((nonnull-c-string) `(##sys#peek-nonnull-c-string ,body (##core#quote 0)))
1290      ((c-string* unsigned-c-string*) `(##sys#peek-and-free-c-string ,body (##core#quote 0)))
1291      ((nonnull-c-string* nonnull-unsigned-c-string*) `(##sys#peek-and-free-nonnull-c-string ,body (##core#quote 0)))
1292      ((symbol) `(##sys#string->symbol (##sys#peek-c-string ,body (##core#quote 0))))
1293      ((c-string-list) `(##sys#peek-c-string-list ,body (##core#quote #f)))
1294      ((c-string-list*) `(##sys#peek-and-free-c-string-list ,body (##core#quote #f)))
1295      (else
1296       (cond ((not (list? type)) body)
1297             ((and (memq (car type) '(struct union))
1298                   (= 2 (length type)))
1299              `(##sys#wrap-struct (##core#quote ,(struct/union-wrapper-type-name type)) ,body))
1300             ((and (eq? (car type) 'const)
1301                   (= 2 (length type))
1302                   (memq (cadr type) '(c-string c-string* unsigned-c-string
1303                                                unsigned-c-string* nonnull-c-string
1304                                                nonnull-c-string*
1305                                                nonnull-unsigned-string*)))
1306              (finish-foreign-result (cadr type) body))
1307             ((= 3 (length type))
1308              (case (car type)
1309                ((instance instance-ref)
1310                 (let ((tmp (gensym)))
1311                   `(let ((,tmp ,body))
1312                      (and ,tmp
1313                           (not (##sys#null-pointer? ,tmp))
1314                           (make ,(caddr type)
1315                                 (##core#quote this) ,tmp) ) ) ) )
1316                ((nonnull-instance)
1317                 `(make ,(caddr type) (##core#quote this) ,body) )
1318                (else body)))
1319             (else body))))))
1320
1321
1322;;; Translate foreign-type into scrutinizer type:
1323
1324;; Used in chicken-ffi-syntax.scm and scrutinizer.scm
1325(define (foreign-type->scrutiny-type t mode) ; MODE = 'arg | 'result
1326  ;; If the foreign type has a converter, it can return a different
1327  ;; type from the native type matching the foreign type (see #1649)
1328  (if (or (and (eq? mode 'arg) (foreign-type-argument-converter t))
1329	  (and (eq? mode 'result) (foreign-type-result-converter t)))
1330      ;; Here we just punt on the type, but it would be better to
1331      ;; find out the result type of the converter procedure.
1332      '*
1333      (let ((ft (final-foreign-type t)))
1334	(case ft
1335	  ((void) 'undefined)
1336	  ((char unsigned-char) 'char)
1337	  ((int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32)
1338	   'fixnum)
1339	  ((float double)
1340	   (case mode
1341	     ((arg) 'number)
1342	     (else 'float)))
1343	  ((complex cplxnum) 'complex)
1344	  ((scheme-pointer nonnull-scheme-pointer) '*)
1345	  ((bytevector u8vector
1346                blob) ; DEPRECATED
1347	   (case mode
1348	     ((arg) '(or false bytevector))
1349	     (else 'bytevector)))
1350	  ((nonnull-bytevector) 'bytevector)
1351	  ((nonnull-blob) 'bytevector) ; DEPRECATED
1352	  ((pointer-vector)
1353	   (case mode
1354	     ((arg) '(or false pointer-vector))
1355	     (else 'pointer-vector)))
1356	  ((nonnull-pointer-vector) 'pointer-vector)
1357	  ((u16vector s8vector s16vector u32vector s32vector u64vector s64vector f32vector f64vector)
1358	   (case mode
1359	     ((arg) `(or false (struct ,ft)))
1360	     (else `(struct ,ft))))
1361	  ((nonnull-u8vector) 'bytevector)
1362	  ((nonnull-s8vector) '(struct s8vector))
1363	  ((nonnull-u16vector) '(struct u16vector))
1364	  ((nonnull-s16vector) '(struct s16vector))
1365	  ((nonnull-u32vector) '(struct u32vector))
1366	  ((nonnull-s32vector) '(struct s32vector))
1367	  ((nonnull-u64vector) '(struct u64vector))
1368	  ((nonnull-s64vector) '(struct s64vector))
1369	  ((nonnull-f32vector) '(struct f32vector))
1370	  ((nonnull-f64vector) '(struct f64vector))
1371	  ((integer long size_t ssize_t integer32 unsigned-integer32 integer64 unsigned-integer64
1372		    unsigned-long)
1373	   'integer)
1374	  ((c-pointer)
1375	   (if (eq? 'arg mode)
1376	       '(or false pointer locative)
1377	       '(or false pointer)))
1378	  ((nonnull-c-pointer)
1379	   (if (eq? 'arg mode)
1380	       '(or pointer locative)
1381	       'pointer))
1382	  ((c-string c-string* unsigned-c-string unsigned-c-string*)
1383	   '(or false string))
1384	  ((c-string-list c-string-list*)
1385	   '(list-of string))
1386	  ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*) 'string)
1387	  ((symbol) 'symbol)
1388	  (else
1389	   (cond ((pair? t)
1390		  (case (car t)
1391		    ((ref pointer function c-pointer)
1392		     (if (eq? 'arg mode)
1393			 '(or false pointer locative)
1394			 '(or false pointer)))
1395		    ((const) (foreign-type->scrutiny-type (cadr t) mode))
1396                    ((struct union)
1397                     `(struct ,(struct/union-wrapper-type-name t)))
1398		    ((enum) 'integer)
1399		    ((nonnull-pointer nonnull-c-pointer)
1400		     (if (eq? 'arg mode)
1401			 '(or pointer locative)
1402			 'pointer))
1403		    (else '*)))
1404		 (else '*)))))))
1405
1406
1407;;; Scan expression-node for variable usage:
1408
1409(define (scan-used-variables node vars)
1410  (let ([used '()])
1411    (let walk ([n node])
1412      (let ([subs (node-subexpressions n)])
1413	(case (node-class n)
1414	  [(##core#variable set!)
1415	   (let ([var (first (node-parameters n))])
1416	     (when (and (memq var vars) (not (memq var used)))
1417	       (set! used (cons var used)) )
1418	     (for-each walk subs) ) ]
1419	  [(quote ##core#undefined ##core#primitive) #f]
1420	  [else (for-each walk subs)] ) ) )
1421    used) )
1422
1423
1424;;; Scan expression-node for free variables (that are not in env):
1425
1426(define (scan-free-variables node block-compilation)
1427  (let ((vars '())
1428	(hvars '()))
1429
1430    (define (walk n e)
1431      (let ([subs (node-subexpressions n)]
1432	    [params (node-parameters n)] )
1433	(case (node-class n)
1434	  ((quote ##core#undefined ##core#primitive ##core#proc ##core#inline_ref) #f)
1435	  ((##core#variable)
1436	   (let ((var (first params)))
1437	     (unless (memq var e)
1438	       (set! vars (lset-adjoin/eq? vars var))
1439	       (unless (variable-visible? var block-compilation)
1440		 (set! hvars (lset-adjoin/eq? hvars var))))))
1441	  ((set!)
1442	   (let ((var (first params)))
1443	     (unless (memq var e) (set! vars (lset-adjoin/eq? vars var)))
1444	     (walk (car subs) e) ) )
1445	  ((let)
1446	   (walk (first subs) e)
1447	   (walk (second subs) (append params e)) )
1448	  ((##core#lambda)
1449	   (##sys#decompose-lambda-list
1450	    (third params)
1451	    (lambda (vars argc rest)
1452	      (walk (first subs) (append vars e)) ) ) )
1453	  (else (walkeach subs e)) ) ) )
1454
1455    (define (walkeach ns e)
1456      (for-each (lambda (n) (walk n e)) ns) )
1457
1458    (walk node '())
1459    (values vars hvars) ) )		; => freevars hiddenvars
1460
1461
1462;;; Special block-variable literal type:
1463
1464(define-record block-variable-literal
1465  name)	; symbol
1466
1467
1468;;; Generation of random names:
1469
1470;; This one looks iffy.  It's also used only in compiler.scm
1471(define (make-random-name . prefix)
1472  (string->symbol
1473   (sprintf "~A-~A~A"
1474	    (optional prefix (gensym))
1475	    (current-seconds)
1476	    (##core#inline "C_random_fixnum" 1000))))
1477
1478
1479;;; Register/lookup real names:
1480;
1481; - The real-name-table contains the following mappings:
1482;
1483;     <variable-alias> -> <variable>
1484;     <lambda-id> -> <variable> or <variable-alias>
1485
1486(define-constant real-name-table-size 997)
1487
1488(define real-name-table #f)
1489
1490(define (clear-real-name-table!)
1491  (set! real-name-table (make-vector real-name-table-size '())))
1492
1493(define (set-real-name! name rname)	; Used only in compiler.scm
1494  (hash-table-set! real-name-table name rname))
1495
1496;; TODO: Find out why there are so many lookup functions for this and
1497;; reduce them to the minimum.
1498(define (get-real-name name)
1499  (hash-table-ref real-name-table name))
1500
1501;; Arbitrary limit to prevent runoff into exponential behavior
1502(define real-name-max-depth 20)
1503
1504(define (real-name var . db)
1505  (define (resolve n)
1506    (let ((n2 (hash-table-ref real-name-table n)))
1507      (if n2
1508	  (or (hash-table-ref real-name-table n2)
1509	      n2)
1510	  n) ) )
1511  (let ((rn (resolve var)))
1512    (cond ((not rn) (##sys#symbol->string var))
1513	  ((pair? db)
1514	   (let ((db (car db)))
1515	     (let loop ((nesting (list (##sys#symbol->string rn)))
1516			(depth 0)
1517			(container (db-get db var 'contained-in)) )
1518	       (cond
1519		((> depth real-name-max-depth)
1520		 (string-intersperse (reverse (cons "..." nesting)) " in "))
1521		(container
1522		 (let ((rc (resolve container)))
1523		   (if (eq? rc container)
1524		       (string-intersperse (reverse nesting) " in ")
1525		       (loop (cons (symbol->string rc) nesting)
1526			     (fx+ depth 1)
1527			     (db-get db container 'contained-in) ) ) ))
1528		(else (string-intersperse (reverse nesting) " in "))) ) ) )
1529	  (else (##sys#symbol->string rn)) ) ) )
1530
1531(define (real-name2 var db)		; Used only in c-backend.scm
1532  (and-let* ((rn (hash-table-ref real-name-table var)))
1533    (real-name rn db) ) )
1534
1535(define (display-real-name-table)
1536  (hash-table-for-each
1537   (lambda (key val)
1538     (printf "~S\t~S~%" key val) )
1539   real-name-table) )
1540
1541(define (source-info->string info)	; Used only in c-backend.scm
1542  (if (list? info)
1543      (let ((ln (car info))
1544	    (name (cadr info)))
1545	(conc ln ":" (make-string (max 0 (- 4 (string-length ln))) #\space) " " name) )
1546      (->string info)))
1547
1548(define (source-info->name info)
1549  (if (list? info) (cadr info) (->string info)))
1550
1551(define (source-info->line info)
1552  (and (list? info) (car info)))
1553
1554(define (call-info params var)		; Used only in optimizer.scm
1555  (or (and-let* ((info (and (pair? (cdr params)) (second params))))
1556	(and (list? info)
1557	     (let ((ln (car info))
1558		   (name (cadr info)))
1559	       (conc "(" ln ") " var))))
1560      var))
1561
1562
1563;;; constant folding support:
1564
1565(define (constant-form-eval op argnodes k)  ; Used only in optimizer.scm
1566  (let* ((args (map (lambda (n) (first (node-parameters n))) argnodes))
1567	 (form (cons op (map (lambda (arg) `(quote ,arg)) args))))
1568    ;; op must have toplevel binding, result must be single-valued
1569    (let ((proc (##sys#slot op 0)))
1570      (if (procedure? proc)
1571	  (let ((results (handle-exceptions ex ex (receive (apply proc args)))))
1572	    (cond ((condition? results) (k #f #f))
1573		  ((and (= 1 (length results))
1574			(encodeable-literal? (car results)))
1575		   (debugging 'o "folded constant expression" form)
1576		   (k #t (car results)))
1577		  ((= 1 (length results)) ; not encodeable; don't fold
1578		   (k #f #f))
1579		  (else
1580		   (bomb "attempt to constant-fold call to procedure that has multiple results" form))))
1581	  (bomb "attempt to constant-fold call to non-procedure" form)))))
1582
1583(define (maybe-constant-fold-call n subs k)
1584  (define (constant-node? n2) (eq? 'quote (node-class n2)))
1585  (if (eq? '##core#variable (node-class (car subs)))
1586      (let ((var (first (node-parameters (car subs)))))
1587	(if (and (intrinsic? var)
1588		 (or (foldable? var)
1589		     (predicate? var))
1590		 (every constant-node? (cdr subs)) )
1591	    (constant-form-eval var (cdr subs) (lambda (ok res) (k ok res #t)))
1592	    (k #f #f #f)))
1593      (k #f #f #f)))
1594
1595;; Is the literal small enough to be encoded?  Otherwise, it should
1596;; not be constant-folded.
1597(define (encodeable-literal? lit)
1598  (define getsize
1599    (foreign-lambda* int ((scheme-object lit))
1600      "return(C_header_size(lit));"))
1601  (define (fits? n)
1602    (fx<= (integer-length n) 24))
1603  (cond ((immediate? lit))
1604	((exact-integer? lit)
1605	 ;; Could use integer-length, but that's trickier (minus
1606	 ;; symbol etc).  If the string is too large to allocate,
1607	 ;; we'll also get an exception!
1608	 (let ((str (handle-exceptions ex #f (number->string lit 16))))
1609	   (and str (fits? (string-length str)))))
1610	((flonum? lit))
1611	((symbol? lit)
1612	 (let ((str (##sys#symbol->string/shared lit)))
1613	   (fits? (string-length str))))
1614        ((string? lit)
1615         (fits? (getsize (##sys#slot lit 0))))
1616	((##core#inline "C_byteblockp" lit)
1617	 (fits? (getsize lit)))
1618	(else
1619	 (let ((len (getsize lit)))
1620	   (and (fits? len)
1621		(every
1622		 encodeable-literal?
1623		 (list-tabulate len (lambda (i)
1624				      (##sys#slot lit i)))))))))
1625
1626
1627;;; Dump node structure:
1628
1629(define (dump-nodes n)			; Used only in batch-driver.scm
1630  (let loop ([i 0] [n n])
1631    (let ([class (node-class n)]
1632	  [params (node-parameters n)]
1633	  [subs (node-subexpressions n)]
1634	  [ind (make-string i #\space)]
1635	  [i2 (+ i 2)] )
1636      (printf "~%~A<~A ~S" ind class params)
1637      (for-each (cut loop i2 <>) subs)
1638      (let ([len (##sys#size n)])
1639	(when (fx> len 4)
1640	  (printf "[~S" (##sys#slot n 4))
1641	  (do ([i 5 (fx+ i 1)])
1642	      ((fx>= i len))
1643	    (printf " ~S" (##sys#slot n i)) )
1644	  (write-char #\]) ) )
1645      (write-char #\>) ) )
1646  (newline) )
1647
1648
1649;; DEPRECATED
1650(define (read/source-info in)
1651  (chicken.syntax#read-with-source-info in) )
1652
1653;;; "#> ... <#" syntax:
1654
1655(set! ##sys#user-read-hook
1656  (let ([old-hook ##sys#user-read-hook])
1657    (lambda (char port)
1658      (if (char=? #\> char)
1659	  (let* ((_ (read-char port))		; swallow #\>
1660		 (text (scan-sharp-greater-string port)))
1661	    `(declare (foreign-declare ,text)) )
1662	  (old-hook char port) ) ) ) )
1663
1664(define (scan-sharp-greater-string port)
1665  (let ([out (open-output-string)])
1666    (let loop ()
1667      (let ((c (read-char port)))
1668	(cond ((eof-object? c)
1669	       (quit-compiling "unexpected end of `#> ... <#' sequence"))
1670	      ((char=? c #\newline)
1671	       (newline out)
1672	       (loop) )
1673	      ((char=? c #\<)
1674	       (let ([c (read-char port)])
1675		 (if (eqv? #\# c)
1676		     (get-output-string out)
1677		     (begin
1678		       (write-char #\< out)
1679		       (write-char c out)
1680		       (loop) ) ) ) )
1681	      (else
1682	       (write-char c out)
1683	       (loop) ) ) ) ) ) )
1684
1685
1686;;; 64-bit fixnum?
1687
1688(define (big-fixnum? x)	;; XXX: This should probably be in c-platform
1689  (and (fixnum? x)
1690       (feature? #:64bit)
1691       (or (fx> x 1073741823)
1692	   (fx< x -1073741824) ) ) )
1693
1694(define (small-bignum? x) ;; XXX: This should probably be in c-platform
1695  (and (bignum? x)
1696       (not (feature? #:64bit))
1697       (fx<= (integer-length x) 62) ) )
1698
1699
1700;;; symbol visibility and other global variable properties
1701
1702(define (hide-variable sym)		; Used in compiler.scm and here
1703  (mark-variable sym '##compiler#visibility 'hidden))
1704
1705(define (export-variable sym)		; Used only in compiler.scm
1706  (mark-variable sym '##compiler#visibility 'exported))
1707
1708(define (variable-hidden? sym)
1709  (eq? (##sys#get sym '##compiler#visibility) 'hidden))
1710
1711(define (unhide-variable sym)
1712  (when (variable-hidden? sym) (remprop! sym '##compiler#visibility)))
1713
1714(define (variable-visible? sym block-compilation)
1715  (let ((p (##sys#get sym '##compiler#visibility)))
1716    (case p
1717      ((hidden) #f)
1718      ((exported) #t)
1719      (else (not block-compilation)))))
1720
1721;; These two have somewhat confusing names.  Maybe mark-variable could
1722;; be renamed to "variable-mark-set!"?  Also, in some other situations,
1723;; put!/get are used directly.
1724(define (mark-variable var mark #!optional (val #t))
1725  (##sys#put! var mark val) )
1726
1727(define (variable-mark var mark)
1728  (##sys#get var mark) )
1729
1730(define intrinsic? (cut variable-mark <> '##compiler#intrinsic))
1731;; Used only in optimizer.scm
1732(define foldable? (cut variable-mark <> '##compiler#foldable))
1733(define predicate? (cut variable-mark <> '##compiler#predicate))
1734
1735
1736;;; Load support files
1737
1738(define (load-identifier-database name)	; Used only in batch-driver.scm
1739  (and-let* ((dbfile (chicken.load#find-file name (repository-path))))
1740    (debugging 'p (sprintf "loading identifier database ~a ...~%" dbfile))
1741    (for-each
1742     (lambda (e)
1743       (let ((id (car e)))
1744	 (##sys#put!
1745	  id '##core#db
1746	  (append (or (##sys#get id '##core#db) '()) (list (cdr e))) )))
1747     (call-with-input-file dbfile read-expressions))))
1748
1749
1750;;; Print version/usage information:
1751
1752(define (print-version #!optional b)	; Used only in batch-driver.scm
1753  (when b (print* +banner+))
1754  (print (chicken-version #t)) )
1755
1756;; Used only in batch-driver.scm, but it seems to me this should be moved
1757;; to chicken.scm, as that's the only place this belongs.
1758(define (print-usage)
1759  (print-version)
1760  (newline)
1761  (display #<<EOF
1762Usage: chicken FILENAME [OPTION ...]
1763
1764  `chicken' is the CHICKEN compiler.
1765
1766  FILENAME should be a complete source file name with extension, or "-" for
1767  standard input. OPTION may be one of the following:
1768
1769  General options:
1770
1771    -help                        display this text and exit
1772    -version                     display compiler version and exit
1773    -release                     print release number and exit
1774    -verbose                     display information on compilation progress
1775
1776  File and pathname options:
1777
1778    -output-file FILENAME        specifies output-filename, default is 'out.c'
1779    -include-path PATHNAME       specifies alternative path for included files
1780    -to-stdout                   write compiled file to stdout instead of file
1781
1782  Language options:
1783
1784    -feature SYMBOL              register feature identifier
1785    -no-feature SYMBOL           disable built-in feature identifier
1786
1787  Syntax related options:
1788
1789    -case-insensitive            don't preserve case of read symbols
1790    -keyword-style STYLE         allow alternative keyword syntax
1791                                  (prefix, suffix or none)
1792    -no-parentheses-synonyms     disables list delimiter synonyms
1793    -r7rs-syntax                 disables the CHICKEN extensions to
1794                                  R7RS syntax
1795    -compile-syntax              macros are made available at run-time
1796    -emit-import-library MODULE  write compile-time module information into
1797                                  separate file
1798    -emit-all-import-libraries   emit import-libraries for all defined modules
1799    -no-compiler-syntax          disable expansion of compiler-macros
1800    -module NAME                 wrap compiled code in a module
1801    -module-registration         always generate module registration code
1802    -no-module-registration      never generate module registration code
1803                                  (overrides `-module-registration')
1804
1805  Translation options:
1806
1807    -explicit-use                do not use units 'library' and 'eval' by
1808                                  default
1809    -check-syntax                stop compilation after macro-expansion
1810    -analyze-only                stop compilation after first analysis pass
1811
1812  Debugging options:
1813
1814    -no-warnings                 disable warnings
1815    -debug-level NUMBER          set level of available debugging information
1816    -no-trace                    disable tracing information
1817    -debug-info                  enable debug-information in compiled code for use
1818                                  with an external debugger
1819    -profile                     executable emits profiling information
1820    -profile-name FILENAME       name of the generated profile information file
1821    -accumulate-profile          executable emits profiling information in
1822                                  append mode
1823    -no-lambda-info              omit additional procedure-information
1824    -emit-types-file FILENAME    write type-declaration information into file
1825    -consult-types-file FILENAME load additional type database
1826
1827  Optimization options:
1828
1829    -optimize-level NUMBER       enable certain sets of optimization options
1830    -optimize-leaf-routines      enable leaf routine optimization
1831    -no-usual-integrations       standard procedures may be redefined
1832    -unsafe                      disable all safety checks
1833    -local                       assume globals are only modified in current
1834                                  file
1835    -block                       enable block-compilation
1836    -disable-interrupts          disable interrupts in compiled code
1837    -fixnum-arithmetic           assume all numbers are fixnums
1838    -disable-stack-overflow-checks  disables detection of stack-overflows
1839    -inline                      enable inlining
1840    -inline-limit LIMIT          set inlining threshold
1841    -inline-global               enable cross-module inlining
1842    -specialize                  perform type-based specialization of primitive calls
1843    -emit-inline-file FILENAME   generate file with globally inlinable
1844                                  procedures (implies -inline -local)
1845    -consult-inline-file FILENAME  explicitly load inline file
1846    -no-argc-checks              disable argument count checks
1847    -no-bound-checks             disable bound variable checks
1848    -no-procedure-checks         disable procedure call checks
1849    -no-procedure-checks-for-usual-bindings
1850                                   disable procedure call checks only for usual
1851                                   bindings
1852    -no-procedure-checks-for-toplevel-bindings
1853                                   disable procedure call checks for toplevel
1854                                   bindings
1855    -strict-types                assume variable do not change their type
1856    -clustering                  combine groups of local procedures into dispatch
1857                                   loop
1858    -lfa2                        perform additional lightweight flow-analysis pass
1859    -unroll-limit LIMIT          specifies inlining limit for self-recursive calls
1860
1861  Configuration options:
1862
1863    -unit NAME                   compile file as a library unit
1864    -uses NAME                   declare library unit as used.
1865    -heap-size NUMBER            specifies heap-size of compiled executable
1866    -nursery NUMBER  -stack-size NUMBER
1867                                 specifies nursery size of compiled executable
1868    -extend FILENAME             load file before compilation commences
1869    -prelude EXPRESSION          add expression to front of source file
1870    -postlude EXPRESSION         add expression to end of source file
1871    -prologue FILENAME           include file before main source file
1872    -epilogue FILENAME           include file after main source file
1873    -dynamic                     compile as dynamically loadable code
1874    -require-extension NAME      require and import extension NAME
1875
1876  Obscure options:
1877
1878    -debug MODES                 display debugging output for the given modes
1879    -raw                         do not generate implicit init- and exit code
1880    -emit-external-prototypes-first
1881                                 emit prototypes for callbacks before foreign
1882                                  declarations
1883    -regenerate-import-libraries emit import libraries even when unchanged
1884    -ignore-repository           do not refer to repository for extensions
1885    -setup-mode                  prefer the current directory when locating extensions
1886
1887EOF
1888) )
1889
1890;; Same as above
1891(define (print-debug-options)
1892  (display #<<EOF
1893
1894Available debugging options:
1895
1896     a          show node-matching during simplification
1897     b          show breakdown of time needed for each compiler pass
1898     c          print every expression before macro-expansion
1899     d          lists all assigned global variables
1900     e          show information about specializations
1901     h          you already figured that out
1902     i          show information about inlining
1903     m          show GC statistics during compilation
1904     n          print the line-number database
1905     o          show performed optimizations
1906     p          display information about what the compiler is currently doing
1907     r          show invocation parameters
1908     s          show program-size information and other statistics
1909     t          show time needed for compilation
1910     u          lists all unassigned global variable references
1911     x          display information about experimental features
1912     D          when printing nodes, use node-tree output
1913     I          show inferred type information for unexported globals
1914     N          show the real-name mapping table
1915     P          show expressions after specialization
1916     S          show applications of compiler syntax
1917     T          show expressions after converting to node tree
1918     1          show source expressions
1919     2          show canonicalized expressions
1920     3          show expressions converted into CPS
1921     4          show database after each analysis pass
1922     5          show expressions after each optimization pass
1923     6          show expressions after each inlining pass
1924     7          show expressions after complete optimization
1925     8          show database after final analysis
1926     9          show expressions after closure conversion
1927
1928
1929EOF
1930))
1931)
1932