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

Last change on this file since 15543 was 15543, checked in by felix winkelmann, 11 years ago

merged inlining branch (r15318:15542) into trunk; updated bootstrap tarball; bumped version to 4.1.4

File size: 47.7 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 (assq 'global plist)
785                (not (assq 'assigned plist)) )
786       (write sym)
787       (newline) ) )
788   db) )
789
790(define (dump-defined-globals db)
791  (##sys#hash-table-for-each
792   (lambda (sym plist)
793     (when (and (assq 'global plist)
794                (assq 'assigned plist))
795       (write sym)
796       (newline) ) )
797   db) )
798
799(define (dump-global-refs db)
800  (##sys#hash-table-for-each
801   (lambda (sym plist)
802     (when (assq 'global plist)
803       (let ((a (assq 'references plist)))
804         (write (list sym (if a (length (cdr a)) 0)))
805         (newline) ) ) )
806   db) )
807
808
809;;; change hook function to hide non-exported module bindings
810
811(set! ##sys#toplevel-definition-hook
812  (lambda (sym mod exp val)
813    (when (and (not val) (not exp))
814      (debugging 'o "hiding nonexported module bindings" sym)
815      (hide-variable sym))))
816
817
818;;; Compute general statistics from analysis database:
819;
820; - Returns:
821;
822;   current-program-size
823;   original-program-size
824;   number of known variables
825;   number of known procedures
826;   number of global variables
827;   number of known call-sites
828;   number of database entries
829;   average bucket load
830
831(define (compute-database-statistics db)
832  (let ((nprocs 0)
833        (nvars 0)
834        (nglobs 0)
835        (entries 0)
836        (nsites 0) )
837    (##sys#hash-table-for-each
838     (lambda (sym plist)
839       (for-each
840        (lambda (prop)
841          (set! entries (+ entries 1))
842          (case (car prop)
843            ((global) (set! nglobs (+ nglobs 1)))
844            ((value)
845             (set! nvars (+ nvars 1))
846             (if (eq? '##core#lambda (node-class (cdr prop)))
847                 (set! nprocs (+ nprocs 1)) ) )
848            ((call-sites) (set! nsites (+ nsites (length (cdr prop))))) ) )
849        plist) )
850     db)
851    (values current-program-size
852            original-program-size
853            nvars
854            nprocs
855            nglobs
856            nsites
857            entries) ) )
858
859(define (print-program-statistics db)
860  (receive
861   (size osize kvars kprocs globs sites entries) (compute-database-statistics db)
862   (when (debugging 's "program statistics:")
863     (printf ";   program size: \t~s \toriginal program size: \t~s\n" size osize)
864     (printf ";   variables with known values: \t~s\n" kvars)
865     (printf ";   known procedures: \t~s\n" kprocs)
866     (printf ";   global variables: \t~s\n" globs)
867     (printf ";   known call sites: \t~s\n" sites) 
868     (printf ";   database entries: \t~s\n" entries) ) ) )
869
870
871;;; Pretty-print expressions:
872
873(define (pprint-expressions-to-file exps filename)
874  (let ([port (if filename (open-output-file filename) (current-output-port))])
875    (with-output-to-port port
876      (lambda ()
877        (for-each
878         (lambda (x)
879           (pretty-print x)
880           (newline) ) 
881         exps) ) )
882    (when filename (close-output-port port)) ) )
883
884
885;;; Create foreign type checking expression:
886
887(define foreign-type-check
888  (let ([tmap '((nonnull-u8vector . u8vector) (nonnull-u16vector . u16vector)
889                (nonnull-s8vector . s8vector) (nonnull-s16vector . s16vector)
890                (nonnull-u32vector . u32vector) (nonnull-s32vector . s32vector)
891                (nonnull-f32vector . f32vector) (nonnull-f64vector . f64vector) ) ] )
892    (lambda (param type)
893      (follow-without-loop
894       type
895       (lambda (t next)
896         (let repeat ([t t])
897           (case t
898             [(char unsigned-char) (if unsafe param `(##sys#foreign-char-argument ,param))]
899             [(int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32)
900              (if unsafe param `(##sys#foreign-fixnum-argument ,param))]
901             [(float double number) (if unsafe param `(##sys#foreign-flonum-argument ,param))]
902             [(pointer byte-vector blob scheme-pointer) ; pointer and byte-vector are DEPRECATED
903              (let ([tmp (gensym)])
904                `(let ([,tmp ,param])
905                   (if ,tmp
906                       ,(if unsafe
907                            tmp
908                            `(##sys#foreign-block-argument ,tmp) )
909                       '#f) ) ) ]
910             [(nonnull-pointer nonnull-scheme-pointer nonnull-blob nonnull-byte-vector) ; nonnull-pointer and nonnull-byte-vector are DEPRECATED
911              (if unsafe
912                  param
913                  `(##sys#foreign-block-argument ,param) ) ]
914             [(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector)
915              (let ([tmp (gensym)])
916                `(let ([,tmp ,param])
917                   (if ,tmp
918                       ,(if unsafe
919                            tmp
920                            `(##sys#foreign-number-vector-argument ',t ,tmp) )
921                       '#f) ) ) ]
922             [(nonnull-u8vector nonnull-u16vector nonnull-s8vector nonnull-s16vector nonnull-u32vector nonnull-s32vector 
923                                nonnull-f32vector nonnull-f64vector)
924              (if unsafe
925                  param
926                  `(##sys#foreign-number-vector-argument 
927                    ',(##sys#slot (assq t tmap) 1)
928                    ,param) ) ]
929             [(integer long integer32) (if unsafe param `(##sys#foreign-integer-argument ,param))]
930             [(unsigned-integer unsigned-integer32 unsigned-long)
931              (if unsafe
932                  param
933                  `(##sys#foreign-unsigned-integer-argument ,param) ) ]
934             [(c-pointer c-string-list c-string-list*)
935              (let ([tmp (gensym)])
936                `(let ([,tmp ,param])
937                   (if ,tmp
938                       (##sys#foreign-pointer-argument ,tmp)
939                       '#f) ) ) ]
940             [(nonnull-c-pointer)
941              `(##sys#foreign-pointer-argument ,param) ]
942             [(c-string c-string* unsigned-c-string unsigned-c-string*)
943              (let ([tmp (gensym)])
944                `(let ([,tmp ,param])
945                   (if ,tmp
946                       ,(if unsafe 
947                            `(##sys#make-c-string ,tmp)
948                            `(##sys#make-c-string (##sys#foreign-string-argument ,tmp)) )
949                       '#f) ) ) ]
950             [(nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*)
951              (if unsafe 
952                  `(##sys#make-c-string ,param)
953                  `(##sys#make-c-string (##sys#foreign-string-argument ,param)) ) ]
954             [(symbol)
955              (if unsafe 
956                  `(##sys#make-c-string (##sys#symbol->string ,param))
957                  `(##sys#make-c-string (##sys#foreign-string-argument (##sys#symbol->string ,param))) ) ]
958             [else
959              (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
960                     => (lambda (t)
961                          (next (if (vector? t) (vector-ref t 0) t)) ) ]
962                    [(pair? t)
963                     (case (car t)
964                       [(ref pointer function c-pointer)
965                        (let ([tmp (gensym)])
966                          `(let ([,tmp ,param])
967                             (if ,tmp
968                                 (##sys#foreign-pointer-argument ,tmp)
969                                 '#f) ) )  ]
970                       [(instance instance-ref)
971                        (let ([tmp (gensym)])
972                          `(let ([,tmp ,param])
973                             (if ,tmp
974                                 (slot-ref ,param 'this)
975                                 '#f) ) ) ]
976                       [(nonnull-instance)
977                        `(slot-ref ,param 'this) ]
978                       [(const) (repeat (cadr t))]
979                       [(enum)
980                        (if unsafe param `(##sys#foreign-integer-argument ,param))]
981                       [(nonnull-pointer nonnull-c-pointer)
982                        `(##sys#foreign-pointer-argument ,param) ]
983                       [else param] ) ]
984                    [else param] ) ] ) ) )
985       (lambda () (quit "foreign type `~S' refers to itself" type)) ) ) ) )
986
987
988;;; Compute foreign-type conversions:
989
990(define (foreign-type-convert-result r t)
991  (or (and-let* ([(symbol? t)]
992                 [ft (##sys#hash-table-ref foreign-type-table t)] 
993                 [(vector? ft)] )
994        (list (vector-ref ft 2) r) )
995      r) )
996
997(define (foreign-type-convert-argument a t)
998  (or (and-let* ([(symbol? t)]
999                 [ft (##sys#hash-table-ref foreign-type-table t)] 
1000                 [(vector? ft)] )
1001        (list (vector-ref ft 1) a) )
1002      a) )
1003
1004(define (final-foreign-type t0)
1005  (follow-without-loop
1006   t0
1007   (lambda (t next)
1008     (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
1009            => (lambda (t2)
1010                 (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
1011           [else t] ) )
1012   (lambda () (quit "foreign type `~S' refers to itself" t0)) ) )
1013
1014
1015;;; Compute foreign result size:
1016
1017(define (estimate-foreign-result-size type)
1018  (follow-without-loop
1019   type
1020   (lambda (t next)
1021     (case t
1022       ((char int short bool void unsigned-short scheme-object unsigned-char unsigned-int byte unsigned-byte
1023              int32 unsigned-int32) 
1024        0)
1025       ((c-string nonnull-c-string c-pointer nonnull-c-pointer symbol c-string* nonnull-c-string*
1026                  unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
1027                  c-string-list c-string-list*)
1028        (words->bytes 3) )
1029       ((unsigned-integer long integer unsigned-long integer32 unsigned-integer32)
1030        (words->bytes 4) )
1031       ((float double number integer64) 
1032        (words->bytes 4) )              ; possibly 8-byte aligned 64-bit double
1033       (else
1034        (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
1035               => (lambda (t2)
1036                    (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
1037              [(pair? t)
1038               (case (car t)
1039                 [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function instance instance-ref nonnull-instance) 
1040                  (words->bytes 3) ]
1041                 [else 0] ) ]
1042              [else 0] ) ) ) )
1043   (lambda () (quit "foreign type `~S' refers to itself" type)) ) )
1044
1045(define (estimate-foreign-result-location-size type)
1046  (define (err t) 
1047    (quit "cannot compute size of location for foreign type `~S'" t) )
1048  (follow-without-loop
1049   type
1050   (lambda (t next)
1051     (case t
1052       ((char int short bool unsigned-short unsigned-char unsigned-int long unsigned-long byte unsigned-byte
1053              c-pointer pointer nonnull-c-pointer unsigned-integer integer float c-string symbol
1054              scheme-pointer nonnull-scheme-pointer int32 unsigned-int32 integer32 unsigned-integer32
1055              unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
1056              nonnull-c-string c-string* nonnull-c-string* c-string-list c-string-list*) ; pointer and nonnull-pointer are DEPRECATED
1057        (words->bytes 1) )
1058       ((double number)
1059        (words->bytes 2) )
1060       (else
1061        (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
1062               => (lambda (t2)
1063                    (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
1064              [(pair? t)
1065               (case (car t)
1066                 [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function) (words->bytes 1)]
1067                 [else (err t)] ) ]
1068              [else (err t)] ) ) ) )
1069   (lambda () (quit "foreign type `~S' refers to itself" type)) ) )
1070
1071
1072;;; Convert result value, if a string:
1073
1074(define (finish-foreign-result type body)
1075  (case type
1076    [(c-string unsigned-c-string) `(##sys#peek-c-string ,body '0)]
1077    [(nonnull-c-string) `(##sys#peek-nonnull-c-string ,body '0)]
1078    [(c-string* unsigned-c-string*) `(##sys#peek-and-free-c-string ,body '0)]
1079    [(nonnull-c-string* nonnull-unsigned-c-string*) `(##sys#peek-and-free-nonnull-c-string ,body '0)]
1080    [(symbol) `(##sys#intern-symbol (##sys#peek-c-string ,body '0))]
1081    [(c-string-list) `(##sys#peek-c-string-list ,body '#f)]
1082    [(c-string-list*) `(##sys#peek-and-free-c-string-list ,body '#f)]
1083    [else
1084     (cond
1085       [(and (list? type) (= 3 (length type)) 
1086             (memq (car type) '(instance instance-ref)))
1087        `(##tinyclos#make-instance-from-pointer ,body ,(caddr type)) ] ;XXX eggified, needs better treatment...
1088       [(and (list? type) (= 3 (length type)) (eq? 'nonnull-instance (car type)))
1089        `(make ,(caddr type) 'this ,body) ]
1090       [else body] ) ] ) )
1091
1092
1093;;; Scan expression-node for variable usage:
1094
1095(define (scan-used-variables node vars)
1096  (let ([used '()])
1097    (let walk ([n node])
1098      (let ([subs (node-subexpressions n)])
1099        (case (node-class n)
1100          [(##core#variable set!) 
1101           (let ([var (first (node-parameters n))])
1102             (when (and (memq var vars) (not (memq var used)))
1103               (set! used (cons var used)) ) 
1104             (for-each walk subs) ) ]
1105          [(quote ##core#undefined ##core#primitive) #f]
1106          [else (for-each walk subs)] ) ) )
1107    used) )
1108
1109
1110;;; Scan expression-node for free variables (that are not in env):
1111
1112(define (scan-free-variables node)
1113  (let ((vars '())
1114        (hvars '()))
1115
1116    (define (walk n e)
1117      (let ([subs (node-subexpressions n)]
1118            [params (node-parameters n)] )
1119        (case (node-class n)
1120          ((quote ##core#undefined ##core#primitive ##core#proc ##core#inline_ref) #f)
1121          ((##core#variable) 
1122           (let ((var (first params)))
1123             (unless (memq var e)
1124               (set! vars (lset-adjoin eq? vars var))
1125               (unless (variable-visible? var) 
1126                 (set! hvars (lset-adjoin eq? hvars var))))))
1127          ((set!)
1128           (let ((var (first params)))
1129             (unless (memq var e) (set! vars (lset-adjoin eq? vars var)))
1130             (walk (car subs) e) ) )
1131          ((let) 
1132           (walk (first subs) e)
1133           (walk (second subs) (append params e)) )
1134          ((##core#lambda)
1135           (decompose-lambda-list
1136            (third params)
1137            (lambda (vars argc rest)
1138              (walk (first subs) (append vars e)) ) ) )
1139          (else (walkeach subs e)) ) ) )
1140
1141    (define (walkeach ns e)
1142      (for-each (lambda (n) (walk n e)) ns) )
1143
1144    (walk node '())
1145    (values vars hvars) ) )
1146
1147
1148;;; Some pathname operations:
1149
1150(define (chop-separator str)
1151  (let ([len (sub1 (string-length str))])
1152    (if (and (> len 0) 
1153             (memq (string-ref str len) '(#\\ #\/)))
1154        (substring str 0 len)
1155        str) ) )
1156
1157(define (chop-extension str)
1158  (let ([len (sub1 (string-length str))])
1159    (let loop ([i len])
1160      (cond [(zero? i) str]
1161            [(char=? #\. (string-ref str i)) (substring str 0 i)]
1162            [else (loop (sub1 i))] ) ) ) )
1163
1164
1165;;; Print version/usage information:
1166
1167(define (print-version #!optional b)
1168  (when b (print* +banner+))
1169  (print (chicken-version #t)) )
1170
1171(define (print-usage)
1172  (print-version)
1173  (newline)
1174  (display #<<EOF
1175Usage: chicken FILENAME OPTION ...
1176
1177  `chicken' is the CHICKEN compiler.
1178 
1179  FILENAME should be a complete source file name with extension, or "-" for
1180  standard input. OPTION may be one of the following:
1181
1182  General options:
1183
1184    -help                        display this text and exit
1185    -version                     display compiler version and exit
1186    -release                     print release number and exit
1187    -verbose                     display information on compilation progress
1188
1189  File and pathname options:
1190
1191    -output-file FILENAME        specifies output-filename, default is 'out.c'
1192    -include-path PATHNAME       specifies alternative path for included files
1193    -to-stdout                   write compiled file to stdout instead of file
1194
1195  Language options:
1196
1197    -feature SYMBOL              register feature identifier
1198
1199  Syntax related options:
1200
1201    -case-insensitive            don't preserve case of read symbols
1202    -keyword-style STYLE         allow alternative keyword syntax
1203                                  (prefix, suffix or none)
1204    -no-parentheses-synonyms     disables list delimiter synonyms
1205    -no-symbol-escape            disables support for escaped symbols
1206    -r5rs-syntax                 disables the Chicken extensions to
1207                                  R5RS syntax
1208    -compile-syntax              macros are made available at run-time
1209    -emit-import-library MODULE  write compile-time module information into
1210                                  separate file
1211    -no-compiler-syntax          disable expansion of compiler-macros
1212
1213  Translation options:
1214
1215    -explicit-use                do not use units 'library' and 'eval' by
1216                                  default
1217    -check-syntax                stop compilation after macro-expansion
1218    -analyze-only                stop compilation after first analysis pass
1219
1220  Debugging options:
1221
1222    -no-warnings                 disable warnings
1223    -disable-warning CLASS       disable specific class of warnings
1224    -debug-level NUMBER          set level of available debugging information
1225    -no-trace                    disable tracing information
1226    -profile                     executable emits profiling information 
1227    -profile-name FILENAME       name of the generated profile information file
1228    -accumulate-profile          executable emits profiling information in
1229                                  append mode
1230    -no-lambda-info              omit additional procedure-information
1231    -scrutinize                  perform local flow analysis
1232    -types FILENAME              load additional type database
1233
1234  Optimization options:
1235
1236    -optimize-level NUMBER       enable certain sets of optimization options
1237    -optimize-leaf-routines      enable leaf routine optimization
1238    -lambda-lift                 enable lambda-lifting
1239    -no-usual-integrations       standard procedures may be redefined
1240    -unsafe                      disable all safety checks
1241    -local                       assume globals are only modified in current
1242                                  file
1243    -block                       enable block-compilation
1244    -disable-interrupts          disable interrupts in compiled code
1245    -fixnum-arithmetic           assume all numbers are fixnums
1246    -benchmark-mode              equivalent to 'block -optimize-level 4
1247                                  -debug-level 0 -fixnum-arithmetic -lambda-lift
1248                                  -inline -disable-interrupts'
1249    -disable-stack-overflow-checks  disables detection of stack-overflows
1250    -inline                      enable inlining
1251    -inline-limit                set inlining threshold
1252    -inline-global               enable cross-module inlining
1253    -emit-inline-file FILENAME   generate file with globally inlinable
1254                                  procedures (implies -inline -local)
1255    -consult-inline-file FILENAME  explicitly load inline file
1256    -no-argc-checks              disable argument count checks
1257    -no-bound-checks             disable bound variable checks
1258    -no-procedure-checks         disable procedure call checks
1259    -no-procedure-checks-for-usual-bindings
1260                                 disable procedure call checks only for usual
1261                                  bindings
1262
1263  Configuration options:
1264
1265    -unit NAME                   compile file as a library unit
1266    -uses NAME                   declare library unit as used.
1267    -heap-size NUMBER            specifies heap-size of compiled executable
1268    -heap-initial-size NUMBER    specifies heap-size at startup time
1269    -heap-growth PERCENTAGE      specifies growth-rate of expanding heap
1270    -heap-shrinkage PERCENTAGE   specifies shrink-rate of contracting heap
1271    -nursery NUMBER  -stack-size NUMBER
1272                                 specifies nursery size of compiled executable
1273    -extend FILENAME             load file before compilation commences
1274    -prelude EXPRESSION          add expression to front of source file
1275    -postlude EXPRESSION         add expression to end of source file
1276    -prologue FILENAME           include file before main source file
1277    -epilogue FILENAME           include file after main source file
1278    -dynamic                     compile as dynamically loadable code
1279    -require-extension NAME      require and import extension NAME
1280    -static-extension NAME       import extension NAME but link statically
1281                                  (if available)
1282
1283  Obscure options:
1284
1285    -debug MODES                 display debugging output for the given modes
1286    -unsafe-libraries            marks the generated file as being linked with
1287                                  the unsafe runtime system
1288    -raw                         do not generate implicit init- and exit code                           
1289    -emit-external-prototypes-first
1290                                 emit prototypes for callbacks before foreign
1291                                  declarations
1292    -ignore-repository           do not refer to repository for extensions
1293
1294EOF
1295) )
1296
1297
1298;;; Special block-variable literal type:
1299
1300(define-record-type block-variable-literal 
1301  (make-block-variable-literal name)
1302  block-variable-literal?
1303  (name block-variable-literal-name))   ; symbol
1304
1305
1306;;; Generation of random names:
1307
1308(define (make-random-name . prefix)
1309  (string->symbol
1310   (sprintf "~A-~A~A"
1311            (optional prefix (gensym))
1312            (current-seconds)
1313            (random 1000) ) ) )
1314
1315
1316;;; Register/lookup real names:
1317;
1318; - The real-name-table contains the following mappings:
1319;
1320;     <variable-alias> -> <variable>
1321;     <lambda-id> -> <variable> or <variable-alias>
1322
1323(define (set-real-name! name rname)
1324  (##sys#hash-table-set! real-name-table name rname) )
1325
1326(define (real-name var . db)
1327  (define (resolve n)
1328    (let ([n2 (##sys#hash-table-ref real-name-table n)])
1329      (if n2
1330          (or (##sys#hash-table-ref real-name-table n2)
1331              n2) 
1332          n) ) )
1333  (let ([rn (resolve var)])
1334    (cond [(not rn) (##sys#symbol->qualified-string var)]
1335          [(pair? db)
1336           (let ([db (car db)])
1337             (let loop ([prev (##sys#symbol->qualified-string rn)] 
1338                        [container (get db var 'contained-in)] )
1339               (if container
1340                   (let ([rc (resolve container)])
1341                     (if (eq? rc container)
1342                         prev
1343                         (loop (sprintf "~A in ~A" prev rc)
1344                               (get db container 'contained-in) ) ) )
1345                   prev) ) ) ]
1346          [else (##sys#symbol->qualified-string rn)] ) ) )
1347
1348(define (real-name2 var db)
1349  (and-let* ([rn (##sys#hash-table-ref real-name-table var)])
1350    (real-name rn db) ) )
1351
1352(define (display-real-name-table)
1353  (##sys#hash-table-for-each
1354   (lambda (key val)
1355     (printf "~S\t~S~%" key val) )
1356   real-name-table) )
1357
1358(define (source-info->string info)
1359  (if (list? info)
1360      (let ((file (car info))
1361            (ln (cadr info))
1362            (name (caddr info)))
1363        (let ((lns (->string ln)))
1364          (conc file ": " lns (make-string (max 0 (- 4 (string-length lns))) #\space) " " name) ) )
1365      (and info (->string info))) )
1366
1367(define (source-info->line info)
1368  (if (list? info)
1369      (cadr info)
1370      (and info (->string info))) )
1371
1372
1373;;; We need this for constant folding:
1374
1375(define (string-null? x) 
1376  (##core#inline "C_i_string_null_p" s))
1377
1378
1379;;; Dump node structure:
1380
1381(define (dump-nodes n)
1382  (let loop ([i 0] [n n])
1383    (let ([class (node-class n)]
1384          [params (node-parameters n)]
1385          [subs (node-subexpressions n)] 
1386          [ind (make-string i #\space)] 
1387          [i2 (+ i 2)] )
1388      (printf "~%~A<~A ~S" ind class params)
1389      (for-each (cut loop i2 <>) subs)
1390      (let ([len (##sys#size n)])
1391        (when (fx> len 4)
1392          (printf "[~S" (##sys#slot n 4))
1393          (do ([i 5 (fx+ i 1)])
1394              ((fx>= i len))
1395            (printf " ~S" (##sys#slot n i)) )
1396          (write-char #\]) ) )
1397      (write-char #\>) ) )
1398  (newline) )
1399
1400
1401;;; "#> ... <#" syntax:
1402
1403(set! ##sys#user-read-hook
1404  (let ([old-hook ##sys#user-read-hook])
1405    (lambda (char port)
1406      (if (char=? #\> char)           
1407          (let* ((_ (read-char port))           ; swallow #\>
1408                 (text (scan-sharp-greater-string port)))
1409            `(declare (foreign-declare ,text)) )
1410          (old-hook char port) ) ) ) )
1411
1412(define (scan-sharp-greater-string port)
1413  (let ([out (open-output-string)])
1414    (let loop ()
1415      (let ([c (read-char port)])
1416        (cond [(eof-object? c) (quit "unexpected end of `#> ... <#' sequence")]
1417              [(char=? c #\newline)
1418               (newline out)
1419               (loop) ]
1420              [(char=? c #\<)
1421               (let ([c (read-char port)])
1422                 (if (eqv? #\# c)
1423                     (get-output-string out)
1424                     (begin
1425                       (write-char #\< out)
1426                       (write-char c out) 
1427                       (loop) ) ) ) ]
1428              [else
1429               (write-char c out)
1430               (loop) ] ) ) ) ) )
1431
1432
1433;;; 64-bit fixnum?
1434
1435(define (big-fixnum? x)
1436  (and (fixnum? x)
1437       (##sys#fudge 3)                  ; 64 bit?
1438       (or (fx> x 1073741823)
1439           (fx< x -1073741824) ) ) )
1440
1441
1442;;; symbol visibility and other global variable properties
1443
1444(define (hide-variable sym)
1445  (mark-variable sym '##compiler#visibility 'hidden))
1446
1447(define (export-variable sym)
1448  (mark-variable sym '##compiler#visibility 'exported))
1449
1450(define (variable-visible? sym)
1451  (let ((p (##sys#get sym '##compiler#visibility)))
1452    (case p
1453      ((hidden) #f)
1454      ((exported) #t)
1455      (else (not block-compilation)))))
1456
1457(define (mark-variable var mark #!optional (val #t))
1458  (##sys#put! var mark val) )
1459
1460(define (variable-mark var mark)
1461  (##sys#get var mark) )
1462
1463(define intrinsic? (cut variable-mark <> '##compiler#intrinsic))
1464(define foldable? (cut variable-mark <> '##compiler#foldable))
1465
1466
1467;;; Load support files
1468
1469(define (load-identifier-database name)
1470  (and-let* ((rp (repository-path))
1471             (dbfile (file-exists? (make-pathname rp name))))
1472    (when verbose-mode
1473      (printf "loading identifier database ~a ...~%" dbfile))
1474    (for-each
1475     (lambda (e)
1476       (##sys#put! 
1477        (car e) '##core#db
1478        (append (or (##sys#get (car e) '##core#db) '()) (list (cdr e))) ))
1479     (read-file dbfile))))
Note: See TracBrowser for help on using the repository browser.