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

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

Added 'symbol-escape' support. Renamed 'parenthesis-synonyms' -> 'parentheses-synonyms'. Changed command-line option for 'parentheses-synonyms' to 'no-parentheses-synonyms' since binary only. Added minor comments to 'regex', used common identifier name for regular-expression argument. Re-flowed command usage so under 80 columns. Updated manual with new features.

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