source: project/chicken/trunk/support.scm @ 15920

Last change on this file since 15920 was 15773, checked in by felix, 10 years ago

units used by default have been reduced to library and eval (expand); added -setup-mode option to compiler and interpreter

File size: 48.0 KB
Line 
1;;;; support.scm - Miscellaneous support code for the CHICKEN compiler
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
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
29  (unit support))
30
31
32(include "compiler-namespace")
33(include "tweaks")
34(include "banner")
35
36(declare
37  (not inline compiler-cleanup-hook ##sys#user-read-hook) )
38
39
40;;; Debugging and error-handling stuff:
41
42(define (compiler-cleanup-hook) #f)
43
44(define debugging-chicken '())
45(define disabled-warnings '())          ; usage type load var const syntax redef use call ffi
46
47(define (bomb . msg-and-args)
48  (if (pair? msg-and-args)
49      (apply error (string-append "[internal compiler error] " (car msg-and-args)) (cdr msg-and-args))
50      (error "[internal compiler error]") ) )
51
52(define (debugging mode msg . args)
53  (and (memq mode debugging-chicken)
54       (begin
55         (printf "~a" msg)
56         (if (pair? args)
57             (begin
58               (display ": ")
59               (for-each (lambda (x) (printf "~s " (force x))) args) ) )
60         (newline)
61         (flush-output)
62         #t) ) )
63
64(define (compiler-warning class msg . args)           
65  (when (and ##sys#warnings-enabled (not (memq class disabled-warnings)))
66    (let ((out (current-error-port)))
67      (apply fprintf out (string-append "\nWarning: " msg) args)
68      (newline out) ) ) )
69
70(define (quit msg . args)
71  (let ([out (current-error-port)])
72    (apply fprintf out (string-append "\nError: " msg) args)
73    (newline out)
74    (exit 1) ) )
75
76(set! ##sys#syntax-error-hook
77  (lambda (msg . args)
78    (let ((out (current-error-port))
79          (loc (and (symbol? msg) 
80                    (let ((loc msg))
81                      (set! msg (car args))
82                      (set! args (cdr args))
83                      loc))))
84      (if loc
85          (fprintf out "Syntax error (~a): ~a~%~%" loc msg) 
86          (fprintf out "Syntax error: ~a~%~%" msg) )
87      (for-each (cut fprintf out "\t~s~%" <>) args)
88      (print-call-chain out 0 ##sys#current-thread "\n\tExpansion history:\n")
89      (exit 70) ) ) )
90
91(set! syntax-error ##sys#syntax-error-hook)
92
93(define (emit-syntax-trace-info info cntr) 
94  (##core#inline "C_emit_syntax_trace_info" info cntr ##sys#current-thread) )
95
96(define (map-llist proc llist)
97  (let loop ([llist llist])
98    (cond [(null? llist) '()]
99          [(symbol? llist) (proc llist)]
100          [else (cons (proc (car llist)) (loop (cdr llist)))] ) ) )
101
102(define (check-signature var args llist)
103  (define (err)
104    (quit "Arguments to inlined call of `~A' do not match parameter-list ~A" 
105          (real-name var)
106          (map-llist real-name (cdr llist)) ) )
107  (let loop ([as args] [ll llist])
108    (cond [(null? ll) (unless (null? as) (err))]
109          [(symbol? ll)]
110          [(null? as) (err)]
111          [else (loop (cdr as) (cdr ll))] ) ) )
112
113
114;;; Generic utility routines:
115
116(define (posq x lst)
117  (let loop ([lst lst] [i 0])
118    (cond [(null? lst) #f]
119          [(eq? x (car lst)) i]
120          [else (loop (cdr lst) (add1 i))] ) ) )
121
122(define (stringify x)
123  (cond ((string? x) x)
124        ((symbol? x) (symbol->string x))
125        (else (sprintf "~a" x)) ) )
126
127(define (symbolify x)
128  (cond ((symbol? x) x)
129        ((string? x) (string->symbol x))
130        (else (string->symbol (sprintf "~a" x))) ) )
131
132(define (build-lambda-list vars argc rest)
133  (let loop ((vars vars) (n argc))
134    (cond ((or (zero? n) (null? vars)) (or rest '()))
135          (else (cons (car vars) (loop (cdr vars) (sub1 n)))) ) ) )
136
137(define string->c-identifier ##sys#string->c-identifier)
138
139(define (c-ify-string str)
140  (list->string
141   (cons
142    #\"
143    (let loop ((chars (string->list str)))
144      (if (null? chars)
145          '(#\")
146          (let* ((c (car chars))
147                 (code (char->integer c)) )
148            (if (or (< code 32) (>= code 127) (memq c '(#\" #\' #\\ #\?)))
149                (append '(#\\)
150                        (cond ((< code 8) '(#\0 #\0))
151                              ((< code 64) '(#\0))
152                              (else '()) )
153                        (string->list (number->string code 8))
154                        (loop (cdr chars)) )
155                (cons c (loop (cdr chars))) ) ) ) ) ) ) )
156
157(define (valid-c-identifier? name)
158  (let ([str (string->list (->string name))])
159    (and (pair? str)
160         (let ([c0 (car str)])
161           (and (or (char-alphabetic? c0) (char=? #\_ c0))
162                (any (lambda (c) (or (char-alphabetic? c) (char-numeric? c) (char=? #\_ c)))
163                     (cdr str) ) ) ) ) ) )
164
165(eval-when (load)
166  (define words (foreign-lambda int "C_bytestowords" int)) 
167  (define words->bytes (foreign-lambda int "C_wordstobytes" int)) )
168
169(eval-when (eval)
170  (define (words n)
171    (let ([wordsize (##sys#fudge 7)])
172      (+ (quotient n wordsize) (if (zero? (modulo n wordsize)) 0 1)) ) )
173  (define (words->bytes n)
174    (* n (##sys#fudge 7)) ) )
175
176(define (check-and-open-input-file fname . line)
177  (cond [(string=? fname "-") (current-input-port)]
178        [(file-exists? fname) (open-input-file fname)]
179        [(or (null? line) (not (car line))) (quit "Can not open file ~s" fname)]
180        [else (quit "Can not open file ~s in line ~s" fname (car line))] ) )
181
182(define (close-checked-input-file port fname)
183  (unless (string=? fname "-") (close-input-port port)) )
184
185(define (fold-inner proc lst)
186  (if (null? (cdr lst)) 
187      lst
188      (let fold ((xs (reverse lst)))
189        (apply
190         proc 
191         (if (null? (cddr xs))
192             (list (cadr xs) (car xs))
193             (list (fold (cdr xs)) (car xs)) ) ) ) ) )
194
195(define (follow-without-loop seed proc abort)
196  (let loop ([x seed] [done '()])
197    (if (member x done)
198        (abort)
199        (proc x (lambda (x2) (loop x2 (cons x done)))) ) ) )
200
201(define (sort-symbols lst)
202  (sort lst (lambda (s1 s2) (string<? (symbol->string s1) (symbol->string s2)))))
203
204
205;;; Predicates on expressions and literals:
206
207(define (constant? x)
208  (or (number? x)
209      (char? x)
210      (string? x)
211      (boolean? x)
212      (eof-object? x)
213      (and (pair? x) (eq? 'quote (car x))) ) )
214
215(define (collapsable-literal? x)
216  (or (boolean? x)
217      (char? x)
218      (eof-object? x)
219      (number? x)
220      (symbol? x) ) )
221
222(define (immediate? x)
223  (or (and (fixnum? x) (not (big-fixnum? x))) ; 64-bit fixnums would result in platform-dependent .c files
224      (eq? (##core#undefined) x)
225      (null? x)
226      (eof-object? x)
227      (char? x)
228      (boolean? x) ) )
229
230(define (basic-literal? x)
231  (or (null? x)
232      (symbol? x)
233      (constant? x)
234      (and (vector? x) (every basic-literal? (vector->list x)))
235      (and (pair? x) 
236           (basic-literal? (car x))
237           (basic-literal? (cdr x)) ) ) )
238
239
240;;; Expression manipulation:
241
242(define (canonicalize-begin-body body)
243  (let loop ((xs body))
244    (cond ((null? xs) '(##core#undefined))
245          ((null? (cdr xs)) (car xs))
246          ((let ([h (car xs)])
247             (or (equal? h '(##core#undefined))
248                 (constant? h) 
249                 (equal? h '(##sys#void)) ) )
250           (loop (cdr xs)) )
251          (else `(let ((,(gensym 't) ,(car xs)))
252                   ,(loop (cdr xs))) ) ) ) )
253
254(define string->expr
255  (let ([exn? (condition-predicate 'exn)]
256        [exn-msg (condition-property-accessor 'exn 'message)] )
257    (lambda (str)
258      (handle-exceptions ex
259          (quit "cannot parse expression: ~s [~a]~%" 
260                str
261                (if (exn? ex) 
262                    (exn-msg ex)
263                    (->string ex) ) ) 
264        (let ([xs (with-input-from-string str (lambda () (unfold eof-object? values (lambda (x) (read)) (read))))])
265          (cond [(null? xs) '(##core#undefined)]
266                [(null? (cdr xs)) (car xs)]
267                [else `(begin ,@xs)] ) ) ) ) ) )
268
269(define decompose-lambda-list ##sys#decompose-lambda-list)
270
271(define (process-lambda-documentation id doc proc)
272  proc)                                 ; Hook this
273
274(define (llist-length llist)
275  (##core#inline "C_u_i_length" llist))
276
277
278;;; Profiling instrumentation:
279
280(define (expand-profile-lambda name llist body)
281  (let ([index profile-lambda-index] 
282        [args (gensym)] )
283    (set! profile-lambda-list (alist-cons index name profile-lambda-list))
284    (set! profile-lambda-index (add1 index))
285    `(lambda ,args
286       (##sys#dynamic-wind
287        (lambda () (##sys#profile-entry ',index ,profile-info-vector-name))
288        (lambda () (apply (lambda ,llist ,body) ,args))
289        (lambda () (##sys#profile-exit ',index ,profile-info-vector-name)) ) ) ) )
290
291
292;;; Database operations:
293;
294; - 'get' and 'put' shadow the routines in the extras-unit, we use low-level
295;   symbol-keyed hash-tables here.
296; - does currently nothing after the first invocation, but we leave it
297;   this way to have the option to add default entries for each new db.
298
299(define initialize-analysis-database
300  (let ((initial #t))
301    (lambda ()
302      (when initial
303        (for-each
304         (lambda (s)
305           (mark-variable s '##compiler#intrinsic 'standard)
306           (when (memq s foldable-bindings)
307             (mark-variable s '##compiler#foldable #t)))
308         standard-bindings)
309        (for-each
310         (lambda (s)
311           (mark-variable s '##compiler#intrinsic 'extended)
312           (when (memq s foldable-bindings)
313             (mark-variable s '##compiler#foldable #t)))
314         extended-bindings)
315        (for-each
316         (lambda (s)
317           (mark-variable s '##compiler#intrinsic 'internal))
318         internal-bindings))
319      (set! initial #f))))
320
321(define (get db key prop)
322  (let ((plist (##sys#hash-table-ref db key)))
323    (and plist
324         (let ([a (assq prop plist)])
325           (and a (##sys#slot a 1)) ) ) ) )
326
327(define (get-all db key . props)
328  (let ((plist (##sys#hash-table-ref db key)))
329    (if plist
330        (filter-map (lambda (prop) (assq prop plist)) props)
331        '() ) ) )
332
333(define (put! db key prop val)
334  (let ([plist (##sys#hash-table-ref db key)])
335    (if plist
336        (let ([a (assq prop plist)])
337          (cond [a (##sys#setslot a 1 val)]
338                [val (##sys#setslot plist 1 (alist-cons prop val (##sys#slot plist 1)))] ) )
339        (when val (##sys#hash-table-set! db key (list (cons prop val)))) ) ) )
340
341(define (collect! db key prop val)
342  (let ((plist (##sys#hash-table-ref db key)))
343    (if plist
344        (let ([a (assq prop plist)])
345          (cond [a (##sys#setslot a 1 (cons val (##sys#slot a 1)))]
346                [else (##sys#setslot plist 1 (alist-cons prop (list val) (##sys#slot plist 1)))] ) )
347        (##sys#hash-table-set! db key (list (list prop val)))) ) )
348
349(define (count! db key prop . val)
350  (let ([plist (##sys#hash-table-ref db key)]
351        [n (if (pair? val) (car val) 1)] )
352    (if plist
353        (let ([a (assq prop plist)])
354          (cond [a (##sys#setslot a 1 (+ (##sys#slot a 1) n))]
355                [else (##sys#setslot plist 1 (alist-cons prop n (##sys#slot plist 1)))] ) )
356        (##sys#hash-table-set! db key (list (cons prop val)))) ) )
357
358(define (get-list db key prop)          ; returns '() if not set
359  (let ((x (get db key prop)))
360    (or x '())))
361
362
363;;; Line-number database management:
364
365(define (get-line exp)
366  (get ##sys#line-number-database (car exp) exp) )
367
368(define (get-line-2 exp)
369  (let* ((name (car exp))
370         (lst (##sys#hash-table-ref ##sys#line-number-database name)) )
371    (cond ((and lst (assq exp (cdr lst)))
372           => (lambda (a) (values (car lst) (cdr a))) )
373          (else (values name #f)) ) ) )
374
375(define (find-lambda-container id cid db)
376  (let loop ([id id])
377    (or (eq? id cid)
378        (let ([c (get db id 'contained-in)])
379          (and c (loop c)) ) ) ) )
380
381(define (display-line-number-database)
382  (##sys#hash-table-for-each
383   (lambda (key val)
384     (when val (printf "~S ~S~%" key (map cdr val))) )
385   ##sys#line-number-database) )
386
387
388;;; Display analysis database:
389
390(define display-analysis-database
391  (let ((names '((captured . cpt) (assigned . set) (boxed . box) (global . glo) (assigned-locally . stl)
392                 (contractable . con) (standard-binding . stb) (simple . sim) (inlinable . inl)
393                 (collapsable . col) (removable . rem) (constant . con)
394                 (inline-target . ilt) (inline-transient . itr)
395                 (undefined . und) (replacing . rpg) (unused . uud) (extended-binding . xtb) (inline-export . ilx)
396                 (customizable . cst) (has-unused-parameters . hup) (boxed-rest . bxr) ) ) 
397        (omit #f))
398    (lambda (db)
399      (unless omit
400        (set! omit 
401          (append default-standard-bindings
402                  default-extended-bindings
403                  internal-bindings) ) )
404      (##sys#hash-table-for-each
405       (lambda (sym plist)
406         (let ([val #f]
407               (lval #f)
408               [pval #f]
409               [csites '()]
410               [refs '()] )
411           (unless (memq sym omit)
412             (write sym)
413             (let loop ((es plist))
414               (if (pair? es)
415                   (begin
416                     (case (caar es)
417                       ((captured assigned boxed global contractable standard-binding assigned-locally
418                                  collapsable removable undefined replacing unused simple inlinable inline-export
419                                  has-unused-parameters extended-binding customizable constant boxed-rest hidden-refs)
420                        (printf "\t~a" (cdr (assq (caar es) names))) )
421                       ((unknown)
422                        (set! val 'unknown) )
423                       ((value)
424                        (unless (eq? val 'unknown) (set! val (cdar es))) )
425                       ((local-value)
426                        (unless (eq? val 'unknown) (set! lval (cdar es))) )
427                       ((potential-value)
428                        (set! pval (cdar es)) )
429                       ((replacable home contains contained-in use-expr closure-size rest-parameter
430                                    o-r/access-count captured-variables explicit-rest)
431                        (printf "\t~a=~s" (caar es) (cdar es)) )
432                       ((references)
433                        (set! refs (cdar es)) )
434                       ((call-sites)
435                        (set! csites (cdar es)) )
436                       (else (bomb "Illegal property" (car es))) )
437                     (loop (cdr es)) ) ) )
438             (cond [(and val (not (eq? val 'unknown)))
439                    (printf "\tval=~s" (cons (node-class val) (node-parameters val))) ]
440                   [(and lval (not (eq? val 'unknown)))
441                    (printf "\tlval=~s" (cons (node-class lval) (node-parameters lval))) ]
442                   [(and pval (not (eq? val 'unknown)))
443                    (printf "\tpval=~s" (cons (node-class pval) (node-parameters pval)))] )
444             (when (pair? refs) (printf "\trefs=~s" (length refs)))
445             (when (pair? csites) (printf "\tcss=~s" (length csites)))
446             (newline) ) ) )
447       db) ) ) )       
448
449
450;;; Node creation and -manipulation:
451
452;; Note: much of this stuff will be overridden by the inline-definitions in "tweaks.scm".
453
454(define-record-type node
455  (make-node class parameters subexpressions)
456  node?
457  (class node-class node-class-set!)    ; symbol
458  (parameters node-parameters node-parameters-set!) ; (value...)
459  (subexpressions node-subexpressions node-subexpressions-set!)) ; (node...)
460
461(define (make-node c p s)
462  (##sys#make-structure 'node c p s) ) ; this kludge is for allowing the inlined `make-node'
463
464(define (varnode var) (make-node '##core#variable (list var) '()))
465(define (qnode const) (make-node 'quote (list const) '()))
466
467(define (build-node-graph exp)
468  (let ([count 0])
469    (define (walk x)
470      (cond ((symbol? x) (varnode x))
471            ((not-pair? x) (bomb "bad expression" x))
472            ((symbol? (car x))
473             (case (car x)
474               ((##core#global-ref) (make-node '##core#global-ref (list (cadr x)) '()))
475               ((if ##core#undefined) (make-node (car x) '() (map walk (cdr x))))
476               ((quote)
477                (let ((c (cadr x)))
478                  (qnode (if (and (number? c)
479                                  (eq? 'fixnum number-type)
480                                  (not (integer? c)) )
481                             (begin
482                               (compiler-warning
483                                'type
484                                "literal '~s' is out of range - will be truncated to integer" c)
485                               (inexact->exact (truncate c)) )
486                             c) ) ) )
487               ((let)
488                (let ([bs (cadr x)]
489                      [body (caddr x)] )
490                  (if (null? bs)
491                      (walk body)
492                      (make-node 'let (unzip1 bs)
493                                 (append (map (lambda (b) (walk (cadr b))) (cadr x))
494                                         (list (walk body)) ) ) ) ) )
495               ((lambda ##core#lambda) 
496                (make-node 'lambda (list (cadr x)) (list (walk (caddr x)))))
497               ((##core#primitive)
498                (let ([arg (cadr x)])
499                  (make-node
500                   (car x)
501                   (list (if (and (pair? arg) (eq? 'quote (car arg))) (cadr arg) arg))
502                   (map walk (cddr x)) ) ) )
503               ((##core#inline ##core#callunit) 
504                (make-node (car x) (list (cadr x)) (map walk (cddr x))) )
505               ((##core#proc)
506                (make-node '##core#proc (list (cadr x) #t) '()) )
507               ((set! ##core#set!)
508                (make-node
509                 'set! (list (cadr x))
510                 (map walk (cddr x))))
511               ((##core#foreign-callback-wrapper)
512                (let ([name (cadr (second x))])
513                  (make-node
514                   '##core#foreign-callback-wrapper
515                   (list name (cadr (third x)) (cadr (fourth x)) (cadr (fifth x)))
516                   (list (walk (sixth x))) ) ) )
517               ((##core#inline_allocate ##core#inline_ref ##core#inline_update
518                                        ##core#inline_loc_ref ##core#inline_loc_update)
519                (make-node (first x) (second x) (map walk (cddr x))) )
520               ((##core#app)
521                (make-node '##core#call '(#t) (map walk (cdr x))) )
522               (else
523                (receive (name ln) (get-line-2 x)
524                  (make-node
525                   '##core#call
526                   (list (cond [(variable-mark name '##compiler#always-bound-to-procedure)
527                                (set! count (add1 count))
528                                #t]
529                               [else #f] )
530                         (if ln
531                             (let ([rn (real-name name)])
532                               (list source-filename ln (or rn (##sys#symbol->qualified-string name))) )
533                             (##sys#symbol->qualified-string name) ) )
534                   (map walk x) ) ) ) ) )
535            (else (make-node '##core#call '(#f) (map walk x))) ) )
536    (let ([exp2 (walk exp)])
537      (debugging 'o "eliminated procedure checks" count)
538      exp2) ) )
539
540(define (build-expression-tree node)
541  (let walk ((n node))
542    (let ((subs (node-subexpressions n))
543          (params (node-parameters n)) 
544          (class (node-class n)) )
545      (case class
546        ((if ##core#box ##core#cond) (cons class (map walk subs)))
547        ((##core#closure)
548         `(##core#closure ,params ,@(map walk subs)) )
549        ((##core#variable ##core#global-ref) (car params))
550        ((quote) `(quote ,(car params)))
551        ((let)
552         `(let ,(map list params (map walk (butlast subs)))
553            ,(walk (last subs)) ) )
554        ((##core#lambda) 
555         (list (if (second params)
556                   'lambda
557                   '##core#lambda)
558               (third params)
559               (walk (car subs)) ) )
560        ((##core#call) (map walk subs))
561        ((##core#callunit) (cons* '##core#callunit (car params) (map walk subs)))
562        ((##core#undefined) (list class))
563        ((##core#bind) 
564         (let loop ((n (car params)) (vals subs) (bindings '()))
565           (if (zero? n)
566               `(##core#bind ,(reverse bindings) ,(walk (car vals)))
567               (loop (- n 1) (cdr vals) (cons (walk (car vals)) bindings)) ) ) )
568        ((##core#unbox ##core#ref ##core#update ##core#update_i)
569         (cons* class (walk (car subs)) params (map walk (cdr subs))) ) 
570        (else (cons class (append params (map walk subs)))) ) ) ) )
571
572(define (fold-boolean proc lst)
573  (let fold ([vars lst])
574    (if (null? (cddr vars))
575        (apply proc vars)
576        (make-node 
577         '##core#inline '("C_and") 
578         (list (proc (first vars) (second vars))
579               (fold (cdr vars)) ) ) ) ) )
580
581(define (inline-lambda-bindings llist args body copy? db)
582  (decompose-lambda-list
583   llist
584   (lambda (vars argc rest)
585     (receive (largs rargs) (split-at args argc)
586       (let* ([rlist (if copy? (map gensym vars) vars)]
587              [body (if copy? 
588                        (copy-node-tree-and-rename body vars rlist db)
589                        body) ] )
590         (fold-right
591          (lambda (var val body) (make-node 'let (list var) (list val body)) )
592          (if rest
593              (make-node
594               'let (list (last rlist))
595               (list (if (null? rargs)
596                         (qnode '())
597                         (make-node '##core#inline_allocate (list "C_a_i_list" (* 3 (length rargs))) rargs) )
598                     body) )
599              body)
600          (take rlist argc)
601          largs) ) ) ) ) )
602
603(define (copy-node-tree-and-rename node vars aliases db)
604  (let ([rlist (map cons vars aliases)])
605    (define (rename v rl) (alist-ref v rl eq? v))
606    (define (walk n rl)
607      (let ([subs (node-subexpressions n)]
608            [params (node-parameters n)]
609            [class (node-class n)] )
610        (case class
611          [(##core#variable) (varnode (rename (first params) rl))]
612          [(set!) 
613           (make-node
614            'set! (list (rename (first params) rl))
615            (list (walk (first subs) rl)) ) ]
616          [(let) 
617           (let* ((v (first params))
618                  (val1 (walk (first subs) rl))
619                  (a (gensym v))
620                  (rl2 (alist-cons v a rl)) )
621             (make-node 
622              'let (list a)
623              (list val1 (walk (second subs) rl2)))) ]
624          [(##core#lambda)
625           (decompose-lambda-list
626            (third params)
627            (lambda (vars argc rest)
628              (let* ((as (map (lambda (v)
629                                (let ((a (gensym v)))
630                                  (put! db v 'inline-transient #t)
631                                  a))
632                              vars) )
633                     (rl2 (append (map cons vars as) rl)) )
634                (make-node 
635                 '##core#lambda
636                 (list (gensym 'f) (second params) ; new function-id
637                       (build-lambda-list as argc (and rest (rename rest rl2)))
638                       (fourth params) )
639                 (map (cut walk <> rl2) subs) ) ) ) ) ]
640          [else (make-node class (tree-copy params) (map (cut walk <> rl) subs))] ) ) )
641    (walk node rlist) ) )
642
643(define (tree-copy t)
644  (let rec ([t t])
645    (if (pair? t)
646        (cons (rec (car t)) (rec (cdr t)))
647        t) ) )
648
649(define (copy-node! from to)
650  (node-class-set! to (node-class from))
651  (node-parameters-set! to (node-parameters from))
652  (node-subexpressions-set! to (node-subexpressions from)) 
653  to)
654
655(define (node->sexpr n)
656  (let walk ((n n))
657    `(,(node-class n)
658      ,(node-parameters n)
659      ,@(map walk (node-subexpressions n)))))
660
661(define (sexpr->node x)
662  (let walk ((x x))
663    (make-node (car x) (cadr x) (map walk (cddr x)))))
664
665(define (emit-global-inline-file filename db)
666  (let ((lst '()))
667    (with-output-to-file filename
668      (lambda ()
669        (print "; GENERATED BY CHICKEN " (chicken-version) " FROM "
670               source-filename "\n")
671        (##sys#hash-table-for-each
672         (lambda (sym plist)
673           (when (variable-visible? sym)
674             (and-let* ((val (assq 'local-value plist))
675                        ((not (node? (variable-mark sym '##compiler#inline-global))))
676                        ((let ((val (assq 'value plist)))
677                           (or (not val)
678                               (not (eq? 'unknown (cdr val))))))
679                        ((assq 'inlinable plist))
680                        (lparams (node-parameters (cdr val)))
681                        ;;((get db (first lparams) 'simple))
682                        ((not (get db sym 'hidden-refs)))
683                        ((case (variable-mark sym '##compiler#inline)
684                           ((yes) #t)
685                           ((no) #f)
686                           (else
687                            (< (fourth lparams) inline-max-size) ) ) ) )
688               (set! lst (cons sym lst))
689               (pp (list sym (node->sexpr (cdr val))))
690               (newline))))
691         db)
692        (print "; END OF FILE")))
693    (when (and (pair? lst)
694               (debugging 'i "the following procedures can be globally inlined:"))
695      (for-each (cut print "  " <>) (sort-symbols lst)))))
696
697(define (load-inline-file fname)
698  (with-input-from-file fname
699    (lambda ()
700      (let loop ()
701        (let ((x (read)))
702          (unless (eof-object? x)
703            (mark-variable 
704             (car x)
705             '##compiler#inline-global 
706             (sexpr->node (cadr x)))
707            (loop)))))))
708
709
710;;; Match node-structure with pattern:
711
712(define (match-node node pat vars)
713  (let ((env '()))
714
715    (define (resolve v x)
716      (cond ((assq v env) => (lambda (a) (equal? x (cdr a))))
717            ((memq v vars)
718             (set! env (alist-cons v x env))
719             #t)
720            (else (eq? v x)) ) )
721
722    (define (match1 x p)
723      (cond ((not-pair? p) (resolve p x))
724            ((not-pair? x) #f)
725            ((match1 (car x) (car p)) (match1 (cdr x) (cdr p)))
726            (else #f) ) )
727   
728    (define (matchn n p)
729      (if (not-pair? p)
730          (resolve p n)
731          (and (eq? (node-class n) (first p))
732               (match1 (node-parameters n) (second p))
733               (let loop ((ns (node-subexpressions n))
734                          (ps (cddr p)) )
735                 (cond ((null? ps) (null? ns))
736                       ((not-pair? ps) (resolve ps ns))
737                       ((null? ns) #f)
738                       (else (and (matchn (car ns) (car ps))
739                                  (loop (cdr ns) (cdr ps)) ) ) ) ) ) ) )
740
741    (let ((r (matchn node pat)))
742      (and r
743           (begin
744             (debugging 'a "matched" (node-class node) (node-parameters node) pat)
745             env) ) ) ) )
746
747
748;;; Test nodes for certain properties:
749
750(define (expression-has-side-effects? node db)
751  (let walk ([n node])
752    (let ([subs (node-subexpressions n)])
753      (case (node-class n)
754        [(##core#variable quote ##core#undefined ##core#proc ##core#global-ref) #f]
755        [(##core#lambda) 
756         (let ([id (first (node-parameters n))])
757           (find (lambda (fs) (eq? id (foreign-callback-stub-id fs))) foreign-callback-stubs) ) ]
758        [(if let) (any walk subs)]
759        [else #t] ) ) ) )
760
761(define (simple-lambda-node? node)
762  (let* ([params (node-parameters node)]
763         [llist (third params)]
764         [k (and (pair? llist) (first llist))] ) ; leaf-routine has no continuation argument
765    (and k 
766         (second params)
767         (let rec ([n node])
768           (case (node-class n)
769             [(##core#call)
770              (let* ([subs (node-subexpressions n)]
771                     [f (first subs)] )
772                (and (eq? '##core#variable (node-class f)) 
773                     (eq? k (first (node-parameters f)))
774                     (every rec (cdr subs)) ) ) ]
775             [(##core#callunit) #f]
776             [else (every rec (node-subexpressions n))] ) ) ) ) )
777
778
779;;; Some safety checks and database dumping:
780
781(define (dump-undefined-globals db)
782  (##sys#hash-table-for-each
783   (lambda (sym plist)
784     (when (and (not (keyword? sym))
785                (assq 'global plist)
786                (not (assq 'assigned plist)) )
787       (write sym)
788       (newline) ) )
789   db) )
790
791(define (dump-defined-globals db)
792  (##sys#hash-table-for-each
793   (lambda (sym plist)
794     (when (and (not (keyword? sym))
795                (assq 'global plist)
796                (assq 'assigned plist))
797       (write sym)
798       (newline) ) )
799   db) )
800
801(define (dump-global-refs db)
802  (##sys#hash-table-for-each
803   (lambda (sym plist)
804     (when (and (not (keyword? sym)) (assq 'global plist))
805       (let ((a (assq 'references plist)))
806         (write (list sym (if a (length (cdr a)) 0)))
807         (newline) ) ) )
808   db) )
809
810
811;;; change hook function to hide non-exported module bindings
812
813(set! ##sys#toplevel-definition-hook
814  (lambda (sym mod exp val)
815    (when (and (not val) (not exp))
816      (debugging 'o "hiding nonexported module bindings" sym)
817      (hide-variable sym))))
818
819
820;;; Compute general statistics from analysis database:
821;
822; - Returns:
823;
824;   current-program-size
825;   original-program-size
826;   number of known variables
827;   number of known procedures
828;   number of global variables
829;   number of known call-sites
830;   number of database entries
831;   average bucket load
832
833(define (compute-database-statistics db)
834  (let ((nprocs 0)
835        (nvars 0)
836        (nglobs 0)
837        (entries 0)
838        (nsites 0) )
839    (##sys#hash-table-for-each
840     (lambda (sym plist)
841       (for-each
842        (lambda (prop)
843          (set! entries (+ entries 1))
844          (case (car prop)
845            ((global) (set! nglobs (+ nglobs 1)))
846            ((value)
847             (set! nvars (+ nvars 1))
848             (if (eq? '##core#lambda (node-class (cdr prop)))
849                 (set! nprocs (+ nprocs 1)) ) )
850            ((call-sites) (set! nsites (+ nsites (length (cdr prop))))) ) )
851        plist) )
852     db)
853    (values current-program-size
854            original-program-size
855            nvars
856            nprocs
857            nglobs
858            nsites
859            entries) ) )
860
861(define (print-program-statistics db)
862  (receive
863   (size osize kvars kprocs globs sites entries) (compute-database-statistics db)
864   (when (debugging 's "program statistics:")
865     (printf ";   program size: \t~s \toriginal program size: \t~s\n" size osize)
866     (printf ";   variables with known values: \t~s\n" kvars)
867     (printf ";   known procedures: \t~s\n" kprocs)
868     (printf ";   global variables: \t~s\n" globs)
869     (printf ";   known call sites: \t~s\n" sites) 
870     (printf ";   database entries: \t~s\n" entries) ) ) )
871
872
873;;; Pretty-print expressions:
874
875(define (pprint-expressions-to-file exps filename)
876  (let ([port (if filename (open-output-file filename) (current-output-port))])
877    (with-output-to-port port
878      (lambda ()
879        (for-each
880         (lambda (x)
881           (pretty-print x)
882           (newline) ) 
883         exps) ) )
884    (when filename (close-output-port port)) ) )
885
886
887;;; Create foreign type checking expression:
888
889(define foreign-type-check
890  (let ([tmap '((nonnull-u8vector . u8vector) (nonnull-u16vector . u16vector)
891                (nonnull-s8vector . s8vector) (nonnull-s16vector . s16vector)
892                (nonnull-u32vector . u32vector) (nonnull-s32vector . s32vector)
893                (nonnull-f32vector . f32vector) (nonnull-f64vector . f64vector) ) ] )
894    (lambda (param type)
895      (follow-without-loop
896       type
897       (lambda (t next)
898         (let repeat ([t t])
899           (case t
900             [(char unsigned-char) (if unsafe param `(##sys#foreign-char-argument ,param))]
901             [(int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32)
902              (if unsafe param `(##sys#foreign-fixnum-argument ,param))]
903             [(float double number) (if unsafe param `(##sys#foreign-flonum-argument ,param))]
904             [(pointer byte-vector blob scheme-pointer) ; pointer and byte-vector are DEPRECATED
905              (let ([tmp (gensym)])
906                `(let ([,tmp ,param])
907                   (if ,tmp
908                       ,(if unsafe
909                            tmp
910                            `(##sys#foreign-block-argument ,tmp) )
911                       '#f) ) ) ]
912             [(nonnull-pointer nonnull-scheme-pointer nonnull-blob nonnull-byte-vector) ; nonnull-pointer and nonnull-byte-vector are DEPRECATED
913              (if unsafe
914                  param
915                  `(##sys#foreign-block-argument ,param) ) ]
916             [(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector)
917              (let ([tmp (gensym)])
918                `(let ([,tmp ,param])
919                   (if ,tmp
920                       ,(if unsafe
921                            tmp
922                            `(##sys#foreign-number-vector-argument ',t ,tmp) )
923                       '#f) ) ) ]
924             [(nonnull-u8vector nonnull-u16vector nonnull-s8vector nonnull-s16vector nonnull-u32vector nonnull-s32vector 
925                                nonnull-f32vector nonnull-f64vector)
926              (if unsafe
927                  param
928                  `(##sys#foreign-number-vector-argument 
929                    ',(##sys#slot (assq t tmap) 1)
930                    ,param) ) ]
931             [(integer long integer32) (if unsafe param `(##sys#foreign-integer-argument ,param))]
932             [(unsigned-integer unsigned-integer32 unsigned-long)
933              (if unsafe
934                  param
935                  `(##sys#foreign-unsigned-integer-argument ,param) ) ]
936             [(c-pointer c-string-list c-string-list*)
937              (let ([tmp (gensym)])
938                `(let ([,tmp ,param])
939                   (if ,tmp
940                       (##sys#foreign-pointer-argument ,tmp)
941                       '#f) ) ) ]
942             [(nonnull-c-pointer)
943              `(##sys#foreign-pointer-argument ,param) ]
944             [(c-string c-string* unsigned-c-string unsigned-c-string*)
945              (let ([tmp (gensym)])
946                `(let ([,tmp ,param])
947                   (if ,tmp
948                       ,(if unsafe 
949                            `(##sys#make-c-string ,tmp)
950                            `(##sys#make-c-string (##sys#foreign-string-argument ,tmp)) )
951                       '#f) ) ) ]
952             [(nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*)
953              (if unsafe 
954                  `(##sys#make-c-string ,param)
955                  `(##sys#make-c-string (##sys#foreign-string-argument ,param)) ) ]
956             [(symbol)
957              (if unsafe 
958                  `(##sys#make-c-string (##sys#symbol->string ,param))
959                  `(##sys#make-c-string (##sys#foreign-string-argument (##sys#symbol->string ,param))) ) ]
960             [else
961              (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
962                     => (lambda (t)
963                          (next (if (vector? t) (vector-ref t 0) t)) ) ]
964                    [(pair? t)
965                     (case (car t)
966                       [(ref pointer function c-pointer)
967                        (let ([tmp (gensym)])
968                          `(let ([,tmp ,param])
969                             (if ,tmp
970                                 (##sys#foreign-pointer-argument ,tmp)
971                                 '#f) ) )  ]
972                       [(instance instance-ref)
973                        (let ([tmp (gensym)])
974                          `(let ([,tmp ,param])
975                             (if ,tmp
976                                 (slot-ref ,param 'this)
977                                 '#f) ) ) ]
978                       [(nonnull-instance)
979                        `(slot-ref ,param 'this) ]
980                       [(const) (repeat (cadr t))]
981                       [(enum)
982                        (if unsafe param `(##sys#foreign-integer-argument ,param))]
983                       [(nonnull-pointer nonnull-c-pointer)
984                        `(##sys#foreign-pointer-argument ,param) ]
985                       [else param] ) ]
986                    [else param] ) ] ) ) )
987       (lambda () (quit "foreign type `~S' refers to itself" type)) ) ) ) )
988
989
990;;; Compute foreign-type conversions:
991
992(define (foreign-type-convert-result r t)
993  (or (and-let* ([(symbol? t)]
994                 [ft (##sys#hash-table-ref foreign-type-table t)] 
995                 [(vector? ft)] )
996        (list (vector-ref ft 2) r) )
997      r) )
998
999(define (foreign-type-convert-argument a t)
1000  (or (and-let* ([(symbol? t)]
1001                 [ft (##sys#hash-table-ref foreign-type-table t)] 
1002                 [(vector? ft)] )
1003        (list (vector-ref ft 1) a) )
1004      a) )
1005
1006(define (final-foreign-type t0)
1007  (follow-without-loop
1008   t0
1009   (lambda (t next)
1010     (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
1011            => (lambda (t2)
1012                 (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
1013           [else t] ) )
1014   (lambda () (quit "foreign type `~S' refers to itself" t0)) ) )
1015
1016
1017;;; Compute foreign result size:
1018
1019(define (estimate-foreign-result-size type)
1020  (follow-without-loop
1021   type
1022   (lambda (t next)
1023     (case t
1024       ((char int short bool void unsigned-short scheme-object unsigned-char unsigned-int byte unsigned-byte
1025              int32 unsigned-int32) 
1026        0)
1027       ((c-string nonnull-c-string c-pointer nonnull-c-pointer symbol c-string* nonnull-c-string*
1028                  unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
1029                  c-string-list c-string-list*)
1030        (words->bytes 3) )
1031       ((unsigned-integer long integer unsigned-long integer32 unsigned-integer32)
1032        (words->bytes 4) )
1033       ((float double number integer64) 
1034        (words->bytes 4) )              ; possibly 8-byte aligned 64-bit double
1035       (else
1036        (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
1037               => (lambda (t2)
1038                    (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
1039              [(pair? t)
1040               (case (car t)
1041                 [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function instance instance-ref nonnull-instance) 
1042                  (words->bytes 3) ]
1043                 [else 0] ) ]
1044              [else 0] ) ) ) )
1045   (lambda () (quit "foreign type `~S' refers to itself" type)) ) )
1046
1047(define (estimate-foreign-result-location-size type)
1048  (define (err t) 
1049    (quit "cannot compute size of location for foreign type `~S'" t) )
1050  (follow-without-loop
1051   type
1052   (lambda (t next)
1053     (case t
1054       ((char int short bool unsigned-short unsigned-char unsigned-int long unsigned-long byte unsigned-byte
1055              c-pointer pointer nonnull-c-pointer unsigned-integer integer float c-string symbol
1056              scheme-pointer nonnull-scheme-pointer int32 unsigned-int32 integer32 unsigned-integer32
1057              unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
1058              nonnull-c-string c-string* nonnull-c-string* c-string-list c-string-list*) ; pointer and nonnull-pointer are DEPRECATED
1059        (words->bytes 1) )
1060       ((double number)
1061        (words->bytes 2) )
1062       (else
1063        (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
1064               => (lambda (t2)
1065                    (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
1066              [(pair? t)
1067               (case (car t)
1068                 [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function) (words->bytes 1)]
1069                 [else (err t)] ) ]
1070              [else (err t)] ) ) ) )
1071   (lambda () (quit "foreign type `~S' refers to itself" type)) ) )
1072
1073
1074;;; Convert result value, if a string:
1075
1076(define (finish-foreign-result type body)
1077  (case type
1078    [(c-string unsigned-c-string) `(##sys#peek-c-string ,body '0)]
1079    [(nonnull-c-string) `(##sys#peek-nonnull-c-string ,body '0)]
1080    [(c-string* unsigned-c-string*) `(##sys#peek-and-free-c-string ,body '0)]
1081    [(nonnull-c-string* nonnull-unsigned-c-string*) `(##sys#peek-and-free-nonnull-c-string ,body '0)]
1082    [(symbol) `(##sys#intern-symbol (##sys#peek-c-string ,body '0))]
1083    [(c-string-list) `(##sys#peek-c-string-list ,body '#f)]
1084    [(c-string-list*) `(##sys#peek-and-free-c-string-list ,body '#f)]
1085    [else
1086     (cond
1087       [(and (list? type) (= 3 (length type)) 
1088             (memq (car type) '(instance instance-ref)))
1089        `(##tinyclos#make-instance-from-pointer ,body ,(caddr type)) ] ;XXX eggified, needs better treatment...
1090       [(and (list? type) (= 3 (length type)) (eq? 'nonnull-instance (car type)))
1091        `(make ,(caddr type) 'this ,body) ]
1092       [else body] ) ] ) )
1093
1094
1095;;; Scan expression-node for variable usage:
1096
1097(define (scan-used-variables node vars)
1098  (let ([used '()])
1099    (let walk ([n node])
1100      (let ([subs (node-subexpressions n)])
1101        (case (node-class n)
1102          [(##core#variable set!) 
1103           (let ([var (first (node-parameters n))])
1104             (when (and (memq var vars) (not (memq var used)))
1105               (set! used (cons var used)) ) 
1106             (for-each walk subs) ) ]
1107          [(quote ##core#undefined ##core#primitive) #f]
1108          [else (for-each walk subs)] ) ) )
1109    used) )
1110
1111
1112;;; Scan expression-node for free variables (that are not in env):
1113
1114(define (scan-free-variables node)
1115  (let ((vars '())
1116        (hvars '()))
1117
1118    (define (walk n e)
1119      (let ([subs (node-subexpressions n)]
1120            [params (node-parameters n)] )
1121        (case (node-class n)
1122          ((quote ##core#undefined ##core#primitive ##core#proc ##core#inline_ref) #f)
1123          ((##core#variable) 
1124           (let ((var (first params)))
1125             (unless (memq var e)
1126               (set! vars (lset-adjoin eq? vars var))
1127               (unless (variable-visible? var) 
1128                 (set! hvars (lset-adjoin eq? hvars var))))))
1129          ((set!)
1130           (let ((var (first params)))
1131             (unless (memq var e) (set! vars (lset-adjoin eq? vars var)))
1132             (walk (car subs) e) ) )
1133          ((let) 
1134           (walk (first subs) e)
1135           (walk (second subs) (append params e)) )
1136          ((##core#lambda)
1137           (decompose-lambda-list
1138            (third params)
1139            (lambda (vars argc rest)
1140              (walk (first subs) (append vars e)) ) ) )
1141          (else (walkeach subs e)) ) ) )
1142
1143    (define (walkeach ns e)
1144      (for-each (lambda (n) (walk n e)) ns) )
1145
1146    (walk node '())
1147    (values vars hvars) ) )
1148
1149
1150;;; Some pathname operations:
1151
1152(define (chop-separator str)
1153  (let ([len (sub1 (string-length str))])
1154    (if (and (> len 0) 
1155             (memq (string-ref str len) '(#\\ #\/)))
1156        (substring str 0 len)
1157        str) ) )
1158
1159(define (chop-extension str)
1160  (let ([len (sub1 (string-length str))])
1161    (let loop ([i len])
1162      (cond [(zero? i) str]
1163            [(char=? #\. (string-ref str i)) (substring str 0 i)]
1164            [else (loop (sub1 i))] ) ) ) )
1165
1166
1167;;; Print version/usage information:
1168
1169(define (print-version #!optional b)
1170  (when b (print* +banner+))
1171  (print (chicken-version #t)) )
1172
1173(define (print-usage)
1174  (print-version)
1175  (newline)
1176  (display #<<EOF
1177Usage: chicken FILENAME OPTION ...
1178
1179  `chicken' is the CHICKEN compiler.
1180 
1181  FILENAME should be a complete source file name with extension, or "-" for
1182  standard input. OPTION may be one of the following:
1183
1184  General options:
1185
1186    -help                        display this text and exit
1187    -version                     display compiler version and exit
1188    -release                     print release number and exit
1189    -verbose                     display information on compilation progress
1190
1191  File and pathname options:
1192
1193    -output-file FILENAME        specifies output-filename, default is 'out.c'
1194    -include-path PATHNAME       specifies alternative path for included files
1195    -to-stdout                   write compiled file to stdout instead of file
1196
1197  Language options:
1198
1199    -feature SYMBOL              register feature identifier
1200
1201  Syntax related options:
1202
1203    -case-insensitive            don't preserve case of read symbols
1204    -keyword-style STYLE         allow alternative keyword syntax
1205                                  (prefix, suffix or none)
1206    -no-parentheses-synonyms     disables list delimiter synonyms
1207    -no-symbol-escape            disables support for escaped symbols
1208    -r5rs-syntax                 disables the Chicken extensions to
1209                                  R5RS syntax
1210    -compile-syntax              macros are made available at run-time
1211    -emit-import-library MODULE  write compile-time module information into
1212                                  separate file
1213    -emit-all-import-libraries   emit import-libraries for all defined modules
1214    -no-compiler-syntax          disable expansion of compiler-macros
1215
1216  Translation options:
1217
1218    -explicit-use                do not use units 'library' and 'eval' by
1219                                  default
1220    -check-syntax                stop compilation after macro-expansion
1221    -analyze-only                stop compilation after first analysis pass
1222
1223  Debugging options:
1224
1225    -no-warnings                 disable warnings
1226    -disable-warning CLASS       disable specific class of warnings
1227    -debug-level NUMBER          set level of available debugging information
1228    -no-trace                    disable tracing information
1229    -profile                     executable emits profiling information 
1230    -profile-name FILENAME       name of the generated profile information file
1231    -accumulate-profile          executable emits profiling information in
1232                                  append mode
1233    -no-lambda-info              omit additional procedure-information
1234    -scrutinize                  perform local flow analysis
1235    -types FILENAME              load additional type database
1236
1237  Optimization options:
1238
1239    -optimize-level NUMBER       enable certain sets of optimization options
1240    -optimize-leaf-routines      enable leaf routine optimization
1241    -lambda-lift                 enable lambda-lifting
1242    -no-usual-integrations       standard procedures may be redefined
1243    -unsafe                      disable all safety checks
1244    -local                       assume globals are only modified in current
1245                                  file
1246    -block                       enable block-compilation
1247    -disable-interrupts          disable interrupts in compiled code
1248    -fixnum-arithmetic           assume all numbers are fixnums
1249    -benchmark-mode              equivalent to 'block -optimize-level 4
1250                                  -debug-level 0 -fixnum-arithmetic -lambda-lift
1251                                  -inline -disable-interrupts'
1252    -disable-stack-overflow-checks  disables detection of stack-overflows
1253    -inline                      enable inlining
1254    -inline-limit                set inlining threshold
1255    -inline-global               enable cross-module inlining
1256    -emit-inline-file FILENAME   generate file with globally inlinable
1257                                  procedures (implies -inline -local)
1258    -consult-inline-file FILENAME  explicitly load inline file
1259    -no-argc-checks              disable argument count checks
1260    -no-bound-checks             disable bound variable checks
1261    -no-procedure-checks         disable procedure call checks
1262    -no-procedure-checks-for-usual-bindings
1263                                 disable procedure call checks only for usual
1264                                  bindings
1265
1266  Configuration options:
1267
1268    -unit NAME                   compile file as a library unit
1269    -uses NAME                   declare library unit as used.
1270    -heap-size NUMBER            specifies heap-size of compiled executable
1271    -heap-initial-size NUMBER    specifies heap-size at startup time
1272    -heap-growth PERCENTAGE      specifies growth-rate of expanding heap
1273    -heap-shrinkage PERCENTAGE   specifies shrink-rate of contracting heap
1274    -nursery NUMBER  -stack-size NUMBER
1275                                 specifies nursery size of compiled executable
1276    -extend FILENAME             load file before compilation commences
1277    -prelude EXPRESSION          add expression to front of source file
1278    -postlude EXPRESSION         add expression to end of source file
1279    -prologue FILENAME           include file before main source file
1280    -epilogue FILENAME           include file after main source file
1281    -dynamic                     compile as dynamically loadable code
1282    -require-extension NAME      require and import extension NAME
1283    -static-extension NAME       import extension NAME but link statically
1284                                  (if available)
1285
1286  Obscure options:
1287
1288    -debug MODES                 display debugging output for the given modes
1289    -unsafe-libraries            marks the generated file as being linked with
1290                                  the unsafe runtime system
1291    -raw                         do not generate implicit init- and exit code                           
1292    -emit-external-prototypes-first
1293                                 emit prototypes for callbacks before foreign
1294                                  declarations
1295    -ignore-repository           do not refer to repository for extensions
1296    -setup-mode                  prefer the current directory when locating extensions
1297
1298EOF
1299) )
1300
1301
1302;;; Special block-variable literal type:
1303
1304(define-record-type block-variable-literal 
1305  (make-block-variable-literal name)
1306  block-variable-literal?
1307  (name block-variable-literal-name))   ; symbol
1308
1309
1310;;; Generation of random names:
1311
1312(define (make-random-name . prefix)
1313  (string->symbol
1314   (sprintf "~A-~A~A"
1315            (optional prefix (gensym))
1316            (current-seconds)
1317            (random 1000) ) ) )
1318
1319
1320;;; Register/lookup real names:
1321;
1322; - The real-name-table contains the following mappings:
1323;
1324;     <variable-alias> -> <variable>
1325;     <lambda-id> -> <variable> or <variable-alias>
1326
1327(define (set-real-name! name rname)
1328  (##sys#hash-table-set! real-name-table name rname) )
1329
1330(define (real-name var . db)
1331  (define (resolve n)
1332    (let ([n2 (##sys#hash-table-ref real-name-table n)])
1333      (if n2
1334          (or (##sys#hash-table-ref real-name-table n2)
1335              n2) 
1336          n) ) )
1337  (let ([rn (resolve var)])
1338    (cond [(not rn) (##sys#symbol->qualified-string var)]
1339          [(pair? db)
1340           (let ([db (car db)])
1341             (let loop ([prev (##sys#symbol->qualified-string rn)] 
1342                        [container (get db var 'contained-in)] )
1343               (if container
1344                   (let ([rc (resolve container)])
1345                     (if (eq? rc container)
1346                         prev
1347                         (loop (sprintf "~A in ~A" prev rc)
1348                               (get db container 'contained-in) ) ) )
1349                   prev) ) ) ]
1350          [else (##sys#symbol->qualified-string rn)] ) ) )
1351
1352(define (real-name2 var db)
1353  (and-let* ([rn (##sys#hash-table-ref real-name-table var)])
1354    (real-name rn db) ) )
1355
1356(define (display-real-name-table)
1357  (##sys#hash-table-for-each
1358   (lambda (key val)
1359     (printf "~S\t~S~%" key val) )
1360   real-name-table) )
1361
1362(define (source-info->string info)
1363  (if (list? info)
1364      (let ((file (car info))
1365            (ln (cadr info))
1366            (name (caddr info)))
1367        (let ((lns (->string ln)))
1368          (conc file ": " lns (make-string (max 0 (- 4 (string-length lns))) #\space) " " name) ) )
1369      (and info (->string info))) )
1370
1371(define (source-info->line info)
1372  (if (list? info)
1373      (cadr info)
1374      (and info (->string info))) )
1375
1376
1377;;; We need this for constant folding:
1378
1379(define (string-null? x) 
1380  (##core#inline "C_i_string_null_p" s))
1381
1382
1383;;; Dump node structure:
1384
1385(define (dump-nodes n)
1386  (let loop ([i 0] [n n])
1387    (let ([class (node-class n)]
1388          [params (node-parameters n)]
1389          [subs (node-subexpressions n)] 
1390          [ind (make-string i #\space)] 
1391          [i2 (+ i 2)] )
1392      (printf "~%~A<~A ~S" ind class params)
1393      (for-each (cut loop i2 <>) subs)
1394      (let ([len (##sys#size n)])
1395        (when (fx> len 4)
1396          (printf "[~S" (##sys#slot n 4))
1397          (do ([i 5 (fx+ i 1)])
1398              ((fx>= i len))
1399            (printf " ~S" (##sys#slot n i)) )
1400          (write-char #\]) ) )
1401      (write-char #\>) ) )
1402  (newline) )
1403
1404
1405;;; "#> ... <#" syntax:
1406
1407(set! ##sys#user-read-hook
1408  (let ([old-hook ##sys#user-read-hook])
1409    (lambda (char port)
1410      (if (char=? #\> char)           
1411          (let* ((_ (read-char port))           ; swallow #\>
1412                 (text (scan-sharp-greater-string port)))
1413            `(declare (foreign-declare ,text)) )
1414          (old-hook char port) ) ) ) )
1415
1416(define (scan-sharp-greater-string port)
1417  (let ([out (open-output-string)])
1418    (let loop ()
1419      (let ([c (read-char port)])
1420        (cond [(eof-object? c) (quit "unexpected end of `#> ... <#' sequence")]
1421              [(char=? c #\newline)
1422               (newline out)
1423               (loop) ]
1424              [(char=? c #\<)
1425               (let ([c (read-char port)])
1426                 (if (eqv? #\# c)
1427                     (get-output-string out)
1428                     (begin
1429                       (write-char #\< out)
1430                       (write-char c out) 
1431                       (loop) ) ) ) ]
1432              [else
1433               (write-char c out)
1434               (loop) ] ) ) ) ) )
1435
1436
1437;;; 64-bit fixnum?
1438
1439(define (big-fixnum? x)
1440  (and (fixnum? x)
1441       (##sys#fudge 3)                  ; 64 bit?
1442       (or (fx> x 1073741823)
1443           (fx< x -1073741824) ) ) )
1444
1445
1446;;; symbol visibility and other global variable properties
1447
1448(define (hide-variable sym)
1449  (mark-variable sym '##compiler#visibility 'hidden))
1450
1451(define (export-variable sym)
1452  (mark-variable sym '##compiler#visibility 'exported))
1453
1454(define (variable-visible? sym)
1455  (let ((p (##sys#get sym '##compiler#visibility)))
1456    (case p
1457      ((hidden) #f)
1458      ((exported) #t)
1459      (else (not block-compilation)))))
1460
1461(define (mark-variable var mark #!optional (val #t))
1462  (##sys#put! var mark val) )
1463
1464(define (variable-mark var mark)
1465  (##sys#get var mark) )
1466
1467(define intrinsic? (cut variable-mark <> '##compiler#intrinsic))
1468(define foldable? (cut variable-mark <> '##compiler#foldable))
1469
1470
1471;;; Load support files
1472
1473(define (load-identifier-database name)
1474  (and-let* ((rp (repository-path))
1475             (dbfile (file-exists? (make-pathname rp name))))
1476    (when verbose-mode
1477      (printf "loading identifier database ~a ...~%" dbfile))
1478    (for-each
1479     (lambda (e)
1480       (##sys#put! 
1481        (car e) '##core#db
1482        (append (or (##sys#get (car e) '##core#db) '()) (list (cdr e))) ))
1483     (read-file dbfile))))
Note: See TracBrowser for help on using the repository browser.