source: project/chicken/branches/scrutiny/support.scm @ 14529

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

more types; scrutiny bugfixes; integrated scrutiny of core libs into build; -types option

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