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

Last change on this file since 6057 was 6057, checked in by felix winkelmann, 13 years ago

makefile cleanups; version is 2.709

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