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

Last change on this file since 13138 was 13138, checked in by Kon Lovett, 11 years ago

Chgd "can not" to "cannot" - saves bytes you know ;-)

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