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

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

global inlining fixes; other small things

File size: 51.8 KB
Line 
1;;;; support.scm - Miscellaneous support code for the CHICKEN compiler
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-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 (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  to)
676
677(define (node->sexpr n)
678  (let walk ((n n))
679    `(,(node-class n)
680      ,(node-parameters n)
681      ,@(map walk (node-subexpressions n)))))
682
683(define (sexpr->node x)
684  (let walk ((x x))
685    (make-node (car x) (cadr x) (map walk (cddr x)))))
686
687(define (emit-global-inline-file filename db)
688  (let ((lst '()))
689    (with-output-to-file filename
690      (lambda ()
691        (print "; GENERATED BY CHICKEN " (chicken-version) " FROM "
692               source-filename "\n")
693        (##sys#hash-table-for-each
694         (lambda (sym plist)
695           (when (variable-visible? sym)
696             (and-let* ((val (assq 'local-value plist))
697                        ((not (node? (variable-mark sym '##compiler#inline-global))))
698                        ((let ((val (assq 'value plist)))
699                           (or (not val)
700                               (not (eq? 'unknown (cdr val))))))
701                        ((assq 'inlinable plist))
702                        (lparams (node-parameters (cdr val)))
703                        ((get db (first lparams) 'simple)) 
704                        ((not (get db sym 'hidden-refs)))
705                        ((case (variable-mark sym '##compiler#inline)
706                           ((yes) #t)
707                           ((no) #f)
708                           (else
709                            (< (fourth lparams) inline-max-size) ) ) ) )
710               (set! lst (cons sym lst))
711               (pp (list sym (node->sexpr (cdr val))))
712               (newline))))
713         db)
714        (print "; END OF FILE")))
715    (when (and (pair? lst)
716               (debugging 'i "the following procedures can be globally inlined:"))
717      (for-each (cut print "  " <>) (sort-symbols lst)))))
718
719(define (load-inline-file fname)
720  (with-input-from-file fname
721    (lambda ()
722      (let loop ()
723        (let ((x (read)))
724          (unless (eof-object? x)
725            (mark-variable 
726             (car x)
727             '##compiler#inline-global 
728             (sexpr->node (cadr x)))
729            (loop)))))))
730
731
732;;; Match node-structure with pattern:
733
734(define (match-node node pat vars)
735  (let ((env '()))
736
737    (define (resolve v x)
738      (cond ((assq v env) => (lambda (a) (equal? x (cdr a))))
739            ((memq v vars)
740             (set! env (alist-cons v x env))
741             #t)
742            (else (eq? v x)) ) )
743
744    (define (match1 x p)
745      (cond ((not-pair? p) (resolve p x))
746            ((not-pair? x) #f)
747            ((match1 (car x) (car p)) (match1 (cdr x) (cdr p)))
748            (else #f) ) )
749   
750    (define (matchn n p)
751      (if (not-pair? p)
752          (resolve p n)
753          (and (eq? (node-class n) (first p))
754               (match1 (node-parameters n) (second p))
755               (let loop ((ns (node-subexpressions n))
756                          (ps (cddr p)) )
757                 (cond ((null? ps) (null? ns))
758                       ((not-pair? ps) (resolve ps ns))
759                       ((null? ns) #f)
760                       (else (and (matchn (car ns) (car ps))
761                                  (loop (cdr ns) (cdr ps)) ) ) ) ) ) ) )
762
763    (let ((r (matchn node pat)))
764      (and r
765           (begin
766             (debugging 'a "matched" (node-class node) (node-parameters node) pat)
767             env) ) ) ) )
768
769
770;;; Test nodes for certain properties:
771
772(define (expression-has-side-effects? node db)
773  (let walk ([n node])
774    (let ([subs (node-subexpressions n)])
775      (case (node-class n)
776        [(##core#variable quote ##core#undefined ##core#proc ##core#global-ref) #f]
777        [(##core#lambda) 
778         (let ([id (first (node-parameters n))])
779           (find (lambda (fs) (eq? id (foreign-callback-stub-id fs))) foreign-callback-stubs) ) ]
780        [(if let) (any walk subs)]
781        [else #t] ) ) ) )
782
783(define (simple-lambda-node? node)
784  (let* ([params (node-parameters node)]
785         [llist (third params)]
786         [k (and (pair? llist) (first llist))] ) ; leaf-routine has no continuation argument
787    (and k 
788         (second params)
789         (let rec ([n node])
790           (case (node-class n)
791             [(##core#call)
792              (let* ([subs (node-subexpressions n)]
793                     [f (first subs)] )
794                (and (eq? '##core#variable (node-class f)) 
795                     (eq? k (first (node-parameters f)))
796                     (every rec (cdr subs)) ) ) ]
797             [(##core#callunit) #f]
798             [else (every rec (node-subexpressions n))] ) ) ) ) )
799
800
801;;; Some safety checks and database dumping:
802
803(define (dump-undefined-globals db)
804  (##sys#hash-table-for-each
805   (lambda (sym plist)
806     (when (and (assq 'global plist)
807                (not (assq 'assigned plist)) )
808       (write sym)
809       (newline) ) )
810   db) )
811
812(define (dump-defined-globals db)
813  (##sys#hash-table-for-each
814   (lambda (sym plist)
815     (when (and (assq 'global plist)
816                (assq 'assigned plist))
817       (write sym)
818       (newline) ) )
819   db) )
820
821
822;;; change hook function to hide non-exported module bindings
823
824(set! ##sys#toplevel-definition-hook
825  (lambda (sym mod exp val)
826    (when (and (not val) (not exp))
827      (debugging 'o "hiding nonexported module bindings" sym)
828      (hide-variable sym))))
829
830
831;;; Compute general statistics from analysis database:
832;
833; - Returns:
834;
835;   current-program-size
836;   original-program-size
837;   number of known variables
838;   number of known procedures
839;   number of global variables
840;   number of known call-sites
841;   number of database entries
842;   average bucket load
843
844(define (compute-database-statistics db)
845  (let ((nprocs 0)
846        (nvars 0)
847        (nglobs 0)
848        (entries 0)
849        (nsites 0) )
850    (##sys#hash-table-for-each
851     (lambda (sym plist)
852       (for-each
853        (lambda (prop)
854          (set! entries (+ entries 1))
855          (case (car prop)
856            ((global) (set! nglobs (+ nglobs 1)))
857            ((value)
858             (set! nvars (+ nvars 1))
859             (if (eq? '##core#lambda (node-class (cdr prop)))
860                 (set! nprocs (+ nprocs 1)) ) )
861            ((call-sites) (set! nsites (+ nsites (length (cdr prop))))) ) )
862        plist) )
863     db)
864    (values current-program-size
865            original-program-size
866            nvars
867            nprocs
868            nglobs
869            nsites
870            entries) ) )
871
872(define (print-program-statistics db)
873  (receive
874   (size osize kvars kprocs globs sites entries) (compute-database-statistics db)
875   (when (debugging 's "program statistics:")
876     (printf ";   program size: \t~s \toriginal program size: \t~s\n" size osize)
877     (printf ";   variables with known values: \t~s\n" kvars)
878     (printf ";   known procedures: \t~s\n" kprocs)
879     (printf ";   global variables: \t~s\n" globs)
880     (printf ";   known call sites: \t~s\n" sites) 
881     (printf ";   database entries: \t~s\n" entries) ) ) )
882
883
884;;; Pretty-print expressions:
885
886(define (pprint-expressions-to-file exps filename)
887  (let ([port (if filename (open-output-file filename) (current-output-port))])
888    (with-output-to-port port
889      (lambda ()
890        (for-each
891         (lambda (x)
892           (pretty-print x)
893           (newline) ) 
894         exps) ) )
895    (when filename (close-output-port port)) ) )
896
897
898;;; Create foreign type checking expression:
899
900(define foreign-type-check
901  (let ([tmap '((nonnull-u8vector . u8vector) (nonnull-u16vector . u16vector)
902                (nonnull-s8vector . s8vector) (nonnull-s16vector . s16vector)
903                (nonnull-u32vector . u32vector) (nonnull-s32vector . s32vector)
904                (nonnull-f32vector . f32vector) (nonnull-f64vector . f64vector) ) ] )
905    (lambda (param type)
906      (follow-without-loop
907       type
908       (lambda (t next)
909         (let repeat ([t t])
910           (case t
911             [(char unsigned-char) (if unsafe param `(##sys#foreign-char-argument ,param))]
912             [(int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32)
913              (if unsafe param `(##sys#foreign-fixnum-argument ,param))]
914             [(float double number) (if unsafe param `(##sys#foreign-flonum-argument ,param))]
915             [(pointer byte-vector blob scheme-pointer) ; pointer and byte-vector are DEPRECATED
916              (let ([tmp (gensym)])
917                `(let ([,tmp ,param])
918                   (if ,tmp
919                       ,(if unsafe
920                            tmp
921                            `(##sys#foreign-block-argument ,tmp) )
922                       '#f) ) ) ]
923             [(nonnull-pointer nonnull-scheme-pointer nonnull-blob nonnull-byte-vector) ; nonnull-pointer and nonnull-byte-vector are DEPRECATED
924              (if unsafe
925                  param
926                  `(##sys#foreign-block-argument ,param) ) ]
927             [(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector)
928              (let ([tmp (gensym)])
929                `(let ([,tmp ,param])
930                   (if ,tmp
931                       ,(if unsafe
932                            tmp
933                            `(##sys#foreign-number-vector-argument ',t ,tmp) )
934                       '#f) ) ) ]
935             [(nonnull-u8vector nonnull-u16vector nonnull-s8vector nonnull-s16vector nonnull-u32vector nonnull-s32vector 
936                                nonnull-f32vector nonnull-f64vector)
937              (if unsafe
938                  param
939                  `(##sys#foreign-number-vector-argument 
940                    ',(##sys#slot (assq t tmap) 1)
941                    ,param) ) ]
942             [(integer long integer32) (if unsafe param `(##sys#foreign-integer-argument ,param))]
943             [(unsigned-integer unsigned-integer32 unsigned-long)
944              (if unsafe
945                  param
946                  `(##sys#foreign-unsigned-integer-argument ,param) ) ]
947             [(c-pointer c-string-list c-string-list*)
948              (let ([tmp (gensym)])
949                `(let ([,tmp ,param])
950                   (if ,tmp
951                       (##sys#foreign-pointer-argument ,tmp)
952                       '#f) ) ) ]
953             [(nonnull-c-pointer)
954              `(##sys#foreign-pointer-argument ,param) ]
955             [(c-string c-string* unsigned-c-string unsigned-c-string*)
956              (let ([tmp (gensym)])
957                `(let ([,tmp ,param])
958                   (if ,tmp
959                       ,(if unsafe 
960                            `(##sys#make-c-string ,tmp)
961                            `(##sys#make-c-string (##sys#foreign-string-argument ,tmp)) )
962                       '#f) ) ) ]
963             [(nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*)
964              (if unsafe 
965                  `(##sys#make-c-string ,param)
966                  `(##sys#make-c-string (##sys#foreign-string-argument ,param)) ) ]
967             [(symbol)
968              (if unsafe 
969                  `(##sys#make-c-string (##sys#symbol->string ,param))
970                  `(##sys#make-c-string (##sys#foreign-string-argument (##sys#symbol->string ,param))) ) ]
971             [else
972              (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
973                     => (lambda (t)
974                          (next (if (vector? t) (vector-ref t 0) t)) ) ]
975                    [(pair? t)
976                     (case (car t)
977                       [(ref pointer function c-pointer)
978                        (let ([tmp (gensym)])
979                          `(let ([,tmp ,param])
980                             (if ,tmp
981                                 (##sys#foreign-pointer-argument ,tmp)
982                                 '#f) ) )  ]
983                       [(instance instance-ref)
984                        (let ([tmp (gensym)])
985                          `(let ([,tmp ,param])
986                             (if ,tmp
987                                 (slot-ref ,param 'this)
988                                 '#f) ) ) ]
989                       [(nonnull-instance)
990                        `(slot-ref ,param 'this) ]
991                       [(const) (repeat (cadr t))]
992                       [(enum)
993                        (if unsafe param `(##sys#foreign-integer-argument ,param))]
994                       [(nonnull-pointer nonnull-c-pointer)
995                        `(##sys#foreign-pointer-argument ,param) ]
996                       [else param] ) ]
997                    [else param] ) ] ) ) )
998       (lambda () (quit "foreign type `~S' refers to itself" type)) ) ) ) )
999
1000
1001;;; Compute foreign-type conversions:
1002
1003(define (foreign-type-convert-result r t)
1004  (or (and-let* ([(symbol? t)]
1005                 [ft (##sys#hash-table-ref foreign-type-table t)] 
1006                 [(vector? ft)] )
1007        (list (vector-ref ft 2) r) )
1008      r) )
1009
1010(define (foreign-type-convert-argument a t)
1011  (or (and-let* ([(symbol? t)]
1012                 [ft (##sys#hash-table-ref foreign-type-table t)] 
1013                 [(vector? ft)] )
1014        (list (vector-ref ft 1) a) )
1015      a) )
1016
1017(define (final-foreign-type t0)
1018  (follow-without-loop
1019   t0
1020   (lambda (t next)
1021     (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
1022            => (lambda (t2)
1023                 (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
1024           [else t] ) )
1025   (lambda () (quit "foreign type `~S' refers to itself" t0)) ) )
1026
1027
1028;;; Compute foreign result size:
1029
1030(define (estimate-foreign-result-size type)
1031  (follow-without-loop
1032   type
1033   (lambda (t next)
1034     (case t
1035       ((char int short bool void unsigned-short scheme-object unsigned-char unsigned-int byte unsigned-byte
1036              int32 unsigned-int32) 
1037        0)
1038       ((c-string nonnull-c-string c-pointer nonnull-c-pointer symbol c-string* nonnull-c-string*
1039                  unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
1040                  c-string-list c-string-list*)
1041        (words->bytes 3) )
1042       ((unsigned-integer long integer unsigned-long integer32 unsigned-integer32)
1043        (words->bytes 4) )
1044       ((float double number integer64) 
1045        (words->bytes 4) )              ; possibly 8-byte aligned 64-bit double
1046       (else
1047        (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
1048               => (lambda (t2)
1049                    (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
1050              [(pair? t)
1051               (case (car t)
1052                 [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function instance instance-ref nonnull-instance) 
1053                  (words->bytes 3) ]
1054                 [else 0] ) ]
1055              [else 0] ) ) ) )
1056   (lambda () (quit "foreign type `~S' refers to itself" type)) ) )
1057
1058(define (estimate-foreign-result-location-size type)
1059  (define (err t) 
1060    (quit "cannot compute size of location for foreign type `~S'" t) )
1061  (follow-without-loop
1062   type
1063   (lambda (t next)
1064     (case t
1065       ((char int short bool unsigned-short unsigned-char unsigned-int long unsigned-long byte unsigned-byte
1066              c-pointer pointer nonnull-c-pointer unsigned-integer integer float c-string symbol
1067              scheme-pointer nonnull-scheme-pointer int32 unsigned-int32 integer32 unsigned-integer32
1068              unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
1069              nonnull-c-string c-string* nonnull-c-string* c-string-list c-string-list*) ; pointer and nonnull-pointer are DEPRECATED
1070        (words->bytes 1) )
1071       ((double number)
1072        (words->bytes 2) )
1073       (else
1074        (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
1075               => (lambda (t2)
1076                    (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
1077              [(pair? t)
1078               (case (car t)
1079                 [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function) (words->bytes 1)]
1080                 [else (err t)] ) ]
1081              [else (err t)] ) ) ) )
1082   (lambda () (quit "foreign type `~S' refers to itself" type)) ) )
1083
1084
1085;;; Convert result value, if a string:
1086
1087(define (finish-foreign-result type body)
1088  (case type
1089    [(c-string unsigned-c-string) `(##sys#peek-c-string ,body '0)]
1090    [(nonnull-c-string) `(##sys#peek-nonnull-c-string ,body '0)]
1091    [(c-string* unsigned-c-string*) `(##sys#peek-and-free-c-string ,body '0)]
1092    [(nonnull-c-string* nonnull-unsigned-c-string*) `(##sys#peek-and-free-nonnull-c-string ,body '0)]
1093    [(symbol) `(##sys#intern-symbol (##sys#peek-c-string ,body '0))]
1094    [(c-string-list) `(##sys#peek-c-string-list ,body '#f)]
1095    [(c-string-list*) `(##sys#peek-and-free-c-string-list ,body '#f)]
1096    [else
1097     (cond
1098       [(and (list? type) (= 3 (length type)) 
1099             (memq (car type) '(instance instance-ref)))
1100        `(##tinyclos#make-instance-from-pointer ,body ,(caddr type)) ] ;XXX eggified, needs better treatment...
1101       [(and (list? type) (= 3 (length type)) (eq? 'nonnull-instance (car type)))
1102        `(make ,(caddr type) 'this ,body) ]
1103       [else body] ) ] ) )
1104
1105
1106;;; Scan expression-node for variable usage:
1107
1108(define (scan-used-variables node vars)
1109  (let ([used '()])
1110    (let walk ([n node])
1111      (let ([subs (node-subexpressions n)])
1112        (case (node-class n)
1113          [(##core#variable set!) 
1114           (let ([var (first (node-parameters n))])
1115             (when (and (memq var vars) (not (memq var used)))
1116               (set! used (cons var used)) ) 
1117             (for-each walk subs) ) ]
1118          [(quote ##core#undefined ##core#primitive) #f]
1119          [else (for-each walk subs)] ) ) )
1120    used) )
1121
1122
1123;;; Scan expression-node for free variables (that are not in env):
1124
1125(define (scan-free-variables node)
1126  (let ((vars '())
1127        (hvars '()))
1128
1129    (define (walk n e)
1130      (let ([subs (node-subexpressions n)]
1131            [params (node-parameters n)] )
1132        (case (node-class n)
1133          ((quote ##core#undefined ##core#primitive ##core#proc ##core#inline_ref) #f)
1134          ((##core#variable) 
1135           (let ((var (first params)))
1136             (unless (memq var e)
1137               (set! vars (lset-adjoin eq? vars var))
1138               (unless (variable-visible? var) 
1139                 (set! hvars (lset-adjoin eq? hvars var))))))
1140          ((set!)
1141           (let ((var (first params)))
1142             (unless (memq var e) (set! vars (lset-adjoin eq? vars var)))
1143             (walk (car subs) e) ) )
1144          ((let) 
1145           (walk (first subs) e)
1146           (walk (second subs) (append params e)) )
1147          ((##core#lambda)
1148           (decompose-lambda-list
1149            (third params)
1150            (lambda (vars argc rest)
1151              (walk (first subs) (append vars e)) ) ) )
1152          (else (walkeach subs e)) ) ) )
1153
1154    (define (walkeach ns e)
1155      (for-each (lambda (n) (walk n e)) ns) )
1156
1157    (walk node '())
1158    (values vars hvars) ) )
1159
1160
1161;;; Simple topological sort:
1162;
1163; - Taken from SLIB (slightly adapted): Copyright (C) 1995 Mikael Djurfeldt
1164
1165(define (topological-sort dag pred)
1166  (if (null? dag)
1167      '()
1168      (let* ((adj-table '())
1169             (sorted '()))
1170
1171        (define (insert x y)
1172          (let loop ([at adj-table])
1173            (cond [(null? at) (set! adj-table (cons (cons x y) adj-table))]
1174                  [(pred x (caar at)) (set-cdr! (car at) y)]
1175                  [else (loop (cdr at))] ) ) )
1176       
1177        (define (lookup x)
1178          (let loop ([at adj-table])
1179            (cond [(null? at) #f]
1180                  [(pred x (caar at)) (cdar at)]
1181                  [else (loop (cdr at))] ) ) )
1182       
1183        (define (visit u adj-list)
1184          ;; Color vertex u
1185          (insert u 'colored)
1186          ;; Visit uncolored vertices which u connects to
1187          (for-each (lambda (v)
1188                      (let ((val (lookup v)))
1189                        (if (not (eq? val 'colored))
1190                            (visit v (or val '())))))
1191                    adj-list)
1192          ;; Since all vertices downstream u are visited
1193          ;; by now, we can safely put u on the output list
1194          (set! sorted (cons u sorted)) )
1195       
1196        ;; Hash adjacency lists
1197        (for-each (lambda (def) (insert (car def) (cdr def)))
1198                  (cdr dag))
1199        ;; Visit vertices
1200        (visit (caar dag) (cdar dag))
1201        (for-each (lambda (def)
1202                    (let ((val (lookup (car def))))
1203                      (if (not (eq? val 'colored))
1204                          (visit (car def) (cdr def)))))
1205                  (cdr dag)) 
1206        sorted) ) )
1207
1208
1209;;; Some pathname operations:
1210
1211(define (chop-separator str)
1212  (let ([len (sub1 (string-length str))])
1213    (if (and (> len 0) 
1214             (memq (string-ref str len) '(#\\ #\/)))
1215        (substring str 0 len)
1216        str) ) )
1217
1218(define (chop-extension str)
1219  (let ([len (sub1 (string-length str))])
1220    (let loop ([i len])
1221      (cond [(zero? i) str]
1222            [(char=? #\. (string-ref str i)) (substring str 0 i)]
1223            [else (loop (sub1 i))] ) ) ) )
1224
1225
1226;;; Print version/usage information:
1227
1228(define (print-version #!optional b)
1229  (when b (print* +banner+))
1230  (print (chicken-version #t)) )
1231
1232(define (print-usage)
1233  (print-version)
1234  (newline)
1235  (display #<<EOF
1236Usage: chicken FILENAME OPTION ...
1237
1238  `chicken' is the CHICKEN compiler.
1239 
1240  FILENAME should be a complete source file name with extension, or "-" for
1241  standard input. OPTION may be one of the following:
1242
1243  General options:
1244
1245    -help                        display this text and exit
1246    -version                     display compiler version and exit
1247    -release                     print release number and exit
1248    -verbose                     display information on compilation progress
1249
1250  File and pathname options:
1251
1252    -output-file FILENAME        specifies output-filename, default is 'out.c'
1253    -include-path PATHNAME       specifies alternative path for included files
1254    -to-stdout                   write compiled file to stdout instead of file
1255
1256  Language options:
1257
1258    -feature SYMBOL              register feature identifier
1259
1260  Syntax related options:
1261
1262    -case-insensitive            don't preserve case of read symbols
1263    -keyword-style STYLE         allow alternative keyword syntax
1264                                  (prefix, suffix or none)
1265    -no-parentheses-synonyms     disables list delimiter synonyms
1266    -no-symbol-escape            disables support for escaped symbols
1267    -r5rs-syntax                 disables the Chicken extensions to
1268                                  R5RS syntax
1269    -compile-syntax              macros are made available at run-time
1270    -emit-import-library MODULE  write compile-time module information into
1271                                  separate file
1272
1273  Translation options:
1274
1275    -explicit-use                do not use units 'library' and 'eval' by
1276                                  default
1277    -check-syntax                stop compilation after macro-expansion
1278    -analyze-only                stop compilation after first analysis pass
1279
1280  Debugging options:
1281
1282    -no-warnings                 disable warnings
1283    -disable-warning CLASS       disable specific class of warnings
1284    -debug-level NUMBER          set level of available debugging information
1285    -no-trace                    disable tracing information
1286    -profile                     executable emits profiling information 
1287    -profile-name FILENAME       name of the generated profile information file
1288    -accumulate-profile          executable emits profiling information in
1289                                  append mode
1290    -no-lambda-info              omit additional procedure-information
1291    -scrutinize                  perform local flow analysis
1292    -types FILENAME              load additional type database
1293
1294  Optimization options:
1295
1296    -optimize-level NUMBER       enable certain sets of optimization options
1297    -optimize-leaf-routines      enable leaf routine optimization
1298    -lambda-lift                 enable lambda-lifting
1299    -no-usual-integrations       standard procedures may be redefined
1300    -unsafe                      disable all safety checks
1301    -local                       assume globals are only modified in current
1302                                  file
1303    -block                       enable block-compilation
1304    -disable-interrupts          disable interrupts in compiled code
1305    -fixnum-arithmetic           assume all numbers are fixnums
1306    -benchmark-mode              equivalent to 'block -optimize-level 4
1307                                  -debug-level 0 -fixnum-arithmetic -lambda-lift
1308                                  -inline -disable-interrupts'
1309    -disable-stack-overflow-checks  disables detection of stack-overflows
1310    -inline                      enable inlining
1311    -inline-limit                set inlining threshold
1312    -inline-global               enable cross-module inlining
1313    -emit-inline-file FILENAME   generate file with globally inlinable
1314                                  procedures (implies -inline -local)
1315    -consult-inline-file FILENAME  explicitly load inline file
1316    -no-argc-checks              disable argument count checks
1317    -no-bound-checks             disable bound variable checks
1318    -no-procedure-checks         disable procedure call checks
1319    -no-procedure-checks-for-usual-bindings
1320                                 disable procedure call checks only for usual
1321                                  bindings
1322
1323  Configuration options:
1324
1325    -unit NAME                   compile file as a library unit
1326    -uses NAME                   declare library unit as used.
1327    -heap-size NUMBER            specifies heap-size of compiled executable
1328    -heap-initial-size NUMBER    specifies heap-size at startup time
1329    -heap-growth PERCENTAGE      specifies growth-rate of expanding heap
1330    -heap-shrinkage PERCENTAGE   specifies shrink-rate of contracting heap
1331    -nursery NUMBER  -stack-size NUMBER
1332                                 specifies nursery size of compiled executable
1333    -extend FILENAME             load file before compilation commences
1334    -prelude EXPRESSION          add expression to front of source file
1335    -postlude EXPRESSION         add expression to end of source file
1336    -prologue FILENAME           include file before main source file
1337    -epilogue FILENAME           include file after main source file
1338    -dynamic                     compile as dynamically loadable code
1339    -require-extension NAME      require and import extension NAME
1340    -static-extension NAME       import extension NAME but link statically
1341                                  (if available)
1342
1343  Obscure options:
1344
1345    -debug MODES                 display debugging output for the given modes
1346    -unsafe-libraries            marks the generated file as being linked with
1347                                  the unsafe runtime system
1348    -raw                         do not generate implicit init- and exit code                           
1349    -emit-external-prototypes-first
1350                                 emit prototypes for callbacks before foreign
1351                                  declarations
1352    -ignore-repository           do not refer to repository for extensions
1353
1354EOF
1355) )
1356
1357
1358;;; Special block-variable literal type:
1359
1360(define-record-type block-variable-literal 
1361  (make-block-variable-literal name)
1362  block-variable-literal?
1363  (name block-variable-literal-name))   ; symbol
1364
1365
1366;;; Generation of random names:
1367
1368(define (make-random-name . prefix)
1369  (string->symbol
1370   (sprintf "~A-~A~A"
1371            (optional prefix (gensym))
1372            (current-seconds)
1373            (random 1000) ) ) )
1374
1375
1376;;; Register/lookup real names:
1377;
1378; - The real-name-table contains the following mappings:
1379;
1380;     <variable-alias> -> <variable>
1381;     <lambda-id> -> <variable> or <variable-alias>
1382
1383(define (set-real-name! name rname)
1384  (##sys#hash-table-set! real-name-table name rname) )
1385
1386(define (real-name var . db)
1387  (define (resolve n)
1388    (let ([n2 (##sys#hash-table-ref real-name-table n)])
1389      (if n2
1390          (or (##sys#hash-table-ref real-name-table n2)
1391              n2) 
1392          n) ) )
1393  (let ([rn (resolve var)])
1394    (cond [(not rn) (##sys#symbol->qualified-string var)]
1395          [(pair? db)
1396           (let ([db (car db)])
1397             (let loop ([prev (##sys#symbol->qualified-string rn)] 
1398                        [container (get db var 'contained-in)] )
1399               (if container
1400                   (let ([rc (resolve container)])
1401                     (if (eq? rc container)
1402                         prev
1403                         (loop (sprintf "~A in ~A" prev rc)
1404                               (get db container 'contained-in) ) ) )
1405                   prev) ) ) ]
1406          [else (##sys#symbol->qualified-string rn)] ) ) )
1407
1408(define (real-name2 var db)
1409  (and-let* ([rn (##sys#hash-table-ref real-name-table var)])
1410    (real-name rn db) ) )
1411
1412(define (display-real-name-table)
1413  (##sys#hash-table-for-each
1414   (lambda (key val)
1415     (printf "~S\t~S~%" key val) )
1416   real-name-table) )
1417
1418(define (source-info->string info)
1419  (if (list? info)
1420      (let ((file (car info))
1421            (ln (cadr info))
1422            (name (caddr info)))
1423        (let ((lns (->string ln)))
1424          (conc file ": " lns (make-string (max 0 (- 4 (string-length lns))) #\space) " " name) ) )
1425      (and info (->string info))) )
1426
1427(define (source-info->line info)
1428  (if (list? info)
1429      (cadr info)
1430      (and info (->string info))) )
1431
1432
1433;;; We need this for constant folding:
1434
1435(define (string-null? x) (string-null? x))
1436
1437
1438;;; Dump node structure:
1439
1440(define (dump-nodes n)
1441  (let loop ([i 0] [n n])
1442    (let ([class (node-class n)]
1443          [params (node-parameters n)]
1444          [subs (node-subexpressions n)] 
1445          [ind (make-string i #\space)] 
1446          [i2 (+ i 2)] )
1447      (printf "~%~A<~A ~S" ind class params)
1448      (for-each (cut loop i2 <>) subs)
1449      (let ([len (##sys#size n)])
1450        (when (fx> len 4)
1451          (printf "[~S" (##sys#slot n 4))
1452          (do ([i 5 (fx+ i 1)])
1453              ((fx>= i len))
1454            (printf " ~S" (##sys#slot n i)) )
1455          (write-char #\]) ) )
1456      (write-char #\>) ) )
1457  (newline) )
1458
1459
1460;;; "#> ... <#" syntax:
1461
1462(set! ##sys#user-read-hook
1463  (let ([old-hook ##sys#user-read-hook])
1464    (lambda (char port)
1465      (if (char=? #\> char)           
1466          (let* ((_ (read-char port))           ; swallow #\>
1467                 (text (scan-sharp-greater-string port)))
1468            `(declare (foreign-declare ,text)) )
1469          (old-hook char port) ) ) ) )
1470
1471(define (scan-sharp-greater-string port)
1472  (let ([out (open-output-string)])
1473    (let loop ()
1474      (let ([c (read-char port)])
1475        (cond [(eof-object? c) (quit "unexpected end of `#> ... <#' sequence")]
1476              [(char=? c #\newline)
1477               (newline out)
1478               (loop) ]
1479              [(char=? c #\<)
1480               (let ([c (read-char port)])
1481                 (if (eqv? #\# c)
1482                     (get-output-string out)
1483                     (begin
1484                       (write-char #\< out)
1485                       (write-char c out) 
1486                       (loop) ) ) ) ]
1487              [else
1488               (write-char c out)
1489               (loop) ] ) ) ) ) )
1490
1491
1492;;; 64-bit fixnum?
1493
1494(define (big-fixnum? x)
1495  (and (fixnum? x)
1496       (##sys#fudge 3)                  ; 64 bit?
1497       (or (fx> x 1073741823)
1498           (fx< x -1073741824) ) ) )
1499
1500
1501;;; symbol visibility and other global variable properties
1502
1503(define (hide-variable sym)
1504  (mark-variable sym '##compiler#visibility 'hidden))
1505
1506(define (export-variable sym)
1507  (mark-variable sym '##compiler#visibility 'exported))
1508
1509(define (variable-visible? sym)
1510  (let ((p (##sys#get sym '##compiler#visibility)))
1511    (case p
1512      ((hidden) #f)
1513      ((exported) #t)
1514      (else (not block-compilation)))))
1515
1516(define (mark-variable var mark #!optional (val #t))
1517  (##sys#put! var mark val) )
1518
1519(define (variable-mark var mark)
1520  (##sys#get var mark) )
1521
1522(define intrinsic? (cut variable-mark <> '##compiler#intrinsic))
1523(define foldable? (cut variable-mark <> '##compiler#foldable))
1524
1525
1526;;; Load support files
1527
1528(define (load-identifier-database name)
1529  (and-let* ((rp (repository-path))
1530             (dbfile (file-exists? (make-pathname rp name))))
1531    (when verbose-mode
1532      (printf "loading identifier database ~a ...~%" dbfile))
1533    (for-each
1534     (lambda (e)
1535       (##sys#put! 
1536        (car e) '##core#db
1537        (append (or (##sys#get (car e) '##core#db) '()) (list (cdr e))) ))
1538     (read-file dbfile))))
Note: See TracBrowser for help on using the repository browser.