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

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

including topological-sort in the prerelease branch

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