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

Last change on this file since 15235 was 15235, checked in by felix winkelmann, 10 years ago

merged trunk rev. 15234 into prerelease branch

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