source: project/chicken/branches/release/support.scm @ 7276

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

merged trunk

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