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

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

hopefully better unsigned-c-string support

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