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

Last change on this file since 12937 was 12937, checked in by felix winkelmann, 12 years ago

updateed copyright

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