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

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