source: project/chicken/branches/inlining/support.scm @ 15323

Last change on this file since 15323 was 15323, checked in by felix winkelmann, 10 years ago

more intelligent inlining; standard-extension procedure in setup-api

File size: 49.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 (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;;; Simple topological sort:
1149;
1150; - Taken from SLIB (slightly adapted): Copyright (C) 1995 Mikael Djurfeldt
1151
1152(define (topological-sort dag pred)
1153  (if (null? dag)
1154      '()
1155      (let* ((adj-table '())
1156             (sorted '()))
1157
1158        (define (insert x y)
1159          (let loop ([at adj-table])
1160            (cond [(null? at) (set! adj-table (cons (cons x y) adj-table))]
1161                  [(pred x (caar at)) (set-cdr! (car at) y)]
1162                  [else (loop (cdr at))] ) ) )
1163       
1164        (define (lookup x)
1165          (let loop ([at adj-table])
1166            (cond [(null? at) #f]
1167                  [(pred x (caar at)) (cdar at)]
1168                  [else (loop (cdr at))] ) ) )
1169       
1170        (define (visit u adj-list)
1171          ;; Color vertex u
1172          (insert u 'colored)
1173          ;; Visit uncolored vertices which u connects to
1174          (for-each (lambda (v)
1175                      (let ((val (lookup v)))
1176                        (if (not (eq? val 'colored))
1177                            (visit v (or val '())))))
1178                    adj-list)
1179          ;; Since all vertices downstream u are visited
1180          ;; by now, we can safely put u on the output list
1181          (set! sorted (cons u sorted)) )
1182       
1183        ;; Hash adjacency lists
1184        (for-each (lambda (def) (insert (car def) (cdr def)))
1185                  (cdr dag))
1186        ;; Visit vertices
1187        (visit (caar dag) (cdar dag))
1188        (for-each (lambda (def)
1189                    (let ((val (lookup (car def))))
1190                      (if (not (eq? val 'colored))
1191                          (visit (car def) (cdr def)))))
1192                  (cdr dag)) 
1193        sorted) ) )
1194
1195
1196;;; Some pathname operations:
1197
1198(define (chop-separator str)
1199  (let ([len (sub1 (string-length str))])
1200    (if (and (> len 0) 
1201             (memq (string-ref str len) '(#\\ #\/)))
1202        (substring str 0 len)
1203        str) ) )
1204
1205(define (chop-extension str)
1206  (let ([len (sub1 (string-length str))])
1207    (let loop ([i len])
1208      (cond [(zero? i) str]
1209            [(char=? #\. (string-ref str i)) (substring str 0 i)]
1210            [else (loop (sub1 i))] ) ) ) )
1211
1212
1213;;; Print version/usage information:
1214
1215(define (print-version #!optional b)
1216  (when b (print* +banner+))
1217  (print (chicken-version #t)) )
1218
1219(define (print-usage)
1220  (print-version)
1221  (newline)
1222  (display #<<EOF
1223Usage: chicken FILENAME OPTION ...
1224
1225  `chicken' is the CHICKEN compiler.
1226 
1227  FILENAME should be a complete source file name with extension, or "-" for
1228  standard input. OPTION may be one of the following:
1229
1230  General options:
1231
1232    -help                        display this text and exit
1233    -version                     display compiler version and exit
1234    -release                     print release number and exit
1235    -verbose                     display information on compilation progress
1236
1237  File and pathname options:
1238
1239    -output-file FILENAME        specifies output-filename, default is 'out.c'
1240    -include-path PATHNAME       specifies alternative path for included files
1241    -to-stdout                   write compiled file to stdout instead of file
1242
1243  Language options:
1244
1245    -feature SYMBOL              register feature identifier
1246
1247  Syntax related options:
1248
1249    -case-insensitive            don't preserve case of read symbols
1250    -keyword-style STYLE         allow alternative keyword syntax
1251                                  (prefix, suffix or none)
1252    -no-parentheses-synonyms     disables list delimiter synonyms
1253    -no-symbol-escape            disables support for escaped symbols
1254    -r5rs-syntax                 disables the Chicken extensions to
1255                                  R5RS syntax
1256    -compile-syntax              macros are made available at run-time
1257    -emit-import-library MODULE  write compile-time module information into
1258                                  separate file
1259    -no-compiler-syntax          disable expansion of compiler-macros
1260
1261  Translation options:
1262
1263    -explicit-use                do not use units 'library' and 'eval' by
1264                                  default
1265    -check-syntax                stop compilation after macro-expansion
1266    -analyze-only                stop compilation after first analysis pass
1267
1268  Debugging options:
1269
1270    -no-warnings                 disable warnings
1271    -disable-warning CLASS       disable specific class of warnings
1272    -debug-level NUMBER          set level of available debugging information
1273    -no-trace                    disable tracing information
1274    -profile                     executable emits profiling information 
1275    -profile-name FILENAME       name of the generated profile information file
1276    -accumulate-profile          executable emits profiling information in
1277                                  append mode
1278    -no-lambda-info              omit additional procedure-information
1279    -scrutinize                  perform local flow analysis
1280    -types FILENAME              load additional type database
1281
1282  Optimization options:
1283
1284    -optimize-level NUMBER       enable certain sets of optimization options
1285    -optimize-leaf-routines      enable leaf routine optimization
1286    -lambda-lift                 enable lambda-lifting
1287    -no-usual-integrations       standard procedures may be redefined
1288    -unsafe                      disable all safety checks
1289    -local                       assume globals are only modified in current
1290                                  file
1291    -block                       enable block-compilation
1292    -disable-interrupts          disable interrupts in compiled code
1293    -fixnum-arithmetic           assume all numbers are fixnums
1294    -benchmark-mode              equivalent to 'block -optimize-level 4
1295                                  -debug-level 0 -fixnum-arithmetic -lambda-lift
1296                                  -inline -disable-interrupts'
1297    -disable-stack-overflow-checks  disables detection of stack-overflows
1298    -inline                      enable inlining
1299    -inline-limit                set inlining threshold
1300    -inline-global               enable cross-module inlining
1301    -emit-inline-file FILENAME   generate file with globally inlinable
1302                                  procedures (implies -inline -local)
1303    -consult-inline-file FILENAME  explicitly load inline file
1304    -no-argc-checks              disable argument count checks
1305    -no-bound-checks             disable bound variable checks
1306    -no-procedure-checks         disable procedure call checks
1307    -no-procedure-checks-for-usual-bindings
1308                                 disable procedure call checks only for usual
1309                                  bindings
1310
1311  Configuration options:
1312
1313    -unit NAME                   compile file as a library unit
1314    -uses NAME                   declare library unit as used.
1315    -heap-size NUMBER            specifies heap-size of compiled executable
1316    -heap-initial-size NUMBER    specifies heap-size at startup time
1317    -heap-growth PERCENTAGE      specifies growth-rate of expanding heap
1318    -heap-shrinkage PERCENTAGE   specifies shrink-rate of contracting heap
1319    -nursery NUMBER  -stack-size NUMBER
1320                                 specifies nursery size of compiled executable
1321    -extend FILENAME             load file before compilation commences
1322    -prelude EXPRESSION          add expression to front of source file
1323    -postlude EXPRESSION         add expression to end of source file
1324    -prologue FILENAME           include file before main source file
1325    -epilogue FILENAME           include file after main source file
1326    -dynamic                     compile as dynamically loadable code
1327    -require-extension NAME      require and import extension NAME
1328    -static-extension NAME       import extension NAME but link statically
1329                                  (if available)
1330
1331  Obscure options:
1332
1333    -debug MODES                 display debugging output for the given modes
1334    -unsafe-libraries            marks the generated file as being linked with
1335                                  the unsafe runtime system
1336    -raw                         do not generate implicit init- and exit code                           
1337    -emit-external-prototypes-first
1338                                 emit prototypes for callbacks before foreign
1339                                  declarations
1340    -ignore-repository           do not refer to repository for extensions
1341
1342EOF
1343) )
1344
1345
1346;;; Special block-variable literal type:
1347
1348(define-record-type block-variable-literal 
1349  (make-block-variable-literal name)
1350  block-variable-literal?
1351  (name block-variable-literal-name))   ; symbol
1352
1353
1354;;; Generation of random names:
1355
1356(define (make-random-name . prefix)
1357  (string->symbol
1358   (sprintf "~A-~A~A"
1359            (optional prefix (gensym))
1360            (current-seconds)
1361            (random 1000) ) ) )
1362
1363
1364;;; Register/lookup real names:
1365;
1366; - The real-name-table contains the following mappings:
1367;
1368;     <variable-alias> -> <variable>
1369;     <lambda-id> -> <variable> or <variable-alias>
1370
1371(define (set-real-name! name rname)
1372  (##sys#hash-table-set! real-name-table name rname) )
1373
1374(define (real-name var . db)
1375  (define (resolve n)
1376    (let ([n2 (##sys#hash-table-ref real-name-table n)])
1377      (if n2
1378          (or (##sys#hash-table-ref real-name-table n2)
1379              n2) 
1380          n) ) )
1381  (let ([rn (resolve var)])
1382    (cond [(not rn) (##sys#symbol->qualified-string var)]
1383          [(pair? db)
1384           (let ([db (car db)])
1385             (let loop ([prev (##sys#symbol->qualified-string rn)] 
1386                        [container (get db var 'contained-in)] )
1387               (if container
1388                   (let ([rc (resolve container)])
1389                     (if (eq? rc container)
1390                         prev
1391                         (loop (sprintf "~A in ~A" prev rc)
1392                               (get db container 'contained-in) ) ) )
1393                   prev) ) ) ]
1394          [else (##sys#symbol->qualified-string rn)] ) ) )
1395
1396(define (real-name2 var db)
1397  (and-let* ([rn (##sys#hash-table-ref real-name-table var)])
1398    (real-name rn db) ) )
1399
1400(define (display-real-name-table)
1401  (##sys#hash-table-for-each
1402   (lambda (key val)
1403     (printf "~S\t~S~%" key val) )
1404   real-name-table) )
1405
1406(define (source-info->string info)
1407  (if (list? info)
1408      (let ((file (car info))
1409            (ln (cadr info))
1410            (name (caddr info)))
1411        (let ((lns (->string ln)))
1412          (conc file ": " lns (make-string (max 0 (- 4 (string-length lns))) #\space) " " name) ) )
1413      (and info (->string info))) )
1414
1415(define (source-info->line info)
1416  (if (list? info)
1417      (cadr info)
1418      (and info (->string info))) )
1419
1420
1421;;; We need this for constant folding:
1422
1423(define (string-null? x) (string-null? x))
1424
1425
1426;;; Dump node structure:
1427
1428(define (dump-nodes n)
1429  (let loop ([i 0] [n n])
1430    (let ([class (node-class n)]
1431          [params (node-parameters n)]
1432          [subs (node-subexpressions n)] 
1433          [ind (make-string i #\space)] 
1434          [i2 (+ i 2)] )
1435      (printf "~%~A<~A ~S" ind class params)
1436      (for-each (cut loop i2 <>) subs)
1437      (let ([len (##sys#size n)])
1438        (when (fx> len 4)
1439          (printf "[~S" (##sys#slot n 4))
1440          (do ([i 5 (fx+ i 1)])
1441              ((fx>= i len))
1442            (printf " ~S" (##sys#slot n i)) )
1443          (write-char #\]) ) )
1444      (write-char #\>) ) )
1445  (newline) )
1446
1447
1448;;; "#> ... <#" syntax:
1449
1450(set! ##sys#user-read-hook
1451  (let ([old-hook ##sys#user-read-hook])
1452    (lambda (char port)
1453      (if (char=? #\> char)           
1454          (let* ((_ (read-char port))           ; swallow #\>
1455                 (text (scan-sharp-greater-string port)))
1456            `(declare (foreign-declare ,text)) )
1457          (old-hook char port) ) ) ) )
1458
1459(define (scan-sharp-greater-string port)
1460  (let ([out (open-output-string)])
1461    (let loop ()
1462      (let ([c (read-char port)])
1463        (cond [(eof-object? c) (quit "unexpected end of `#> ... <#' sequence")]
1464              [(char=? c #\newline)
1465               (newline out)
1466               (loop) ]
1467              [(char=? c #\<)
1468               (let ([c (read-char port)])
1469                 (if (eqv? #\# c)
1470                     (get-output-string out)
1471                     (begin
1472                       (write-char #\< out)
1473                       (write-char c out) 
1474                       (loop) ) ) ) ]
1475              [else
1476               (write-char c out)
1477               (loop) ] ) ) ) ) )
1478
1479
1480;;; 64-bit fixnum?
1481
1482(define (big-fixnum? x)
1483  (and (fixnum? x)
1484       (##sys#fudge 3)                  ; 64 bit?
1485       (or (fx> x 1073741823)
1486           (fx< x -1073741824) ) ) )
1487
1488
1489;;; symbol visibility and other global variable properties
1490
1491(define (hide-variable sym)
1492  (mark-variable sym '##compiler#visibility 'hidden))
1493
1494(define (export-variable sym)
1495  (mark-variable sym '##compiler#visibility 'exported))
1496
1497(define (variable-visible? sym)
1498  (let ((p (##sys#get sym '##compiler#visibility)))
1499    (case p
1500      ((hidden) #f)
1501      ((exported) #t)
1502      (else (not block-compilation)))))
1503
1504(define (mark-variable var mark #!optional (val #t))
1505  (##sys#put! var mark val) )
1506
1507(define (variable-mark var mark)
1508  (##sys#get var mark) )
1509
1510(define intrinsic? (cut variable-mark <> '##compiler#intrinsic))
1511(define foldable? (cut variable-mark <> '##compiler#foldable))
1512
1513
1514;;; Load support files
1515
1516(define (load-identifier-database name)
1517  (and-let* ((rp (repository-path))
1518             (dbfile (file-exists? (make-pathname rp name))))
1519    (when verbose-mode
1520      (printf "loading identifier database ~a ...~%" dbfile))
1521    (for-each
1522     (lambda (e)
1523       (##sys#put! 
1524        (car e) '##core#db
1525        (append (or (##sys#get (car e) '##core#db) '()) (list (cdr e))) ))
1526     (read-file dbfile))))
Note: See TracBrowser for help on using the repository browser.