source: project/chicken/branches/prerelease/support.scm @ 15844

Last change on this file since 15844 was 15844, checked in by Ivan Raikov, 10 years ago

Merged trunk r15734 into the prerelease branch.

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