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

Last change on this file since 12789 was 12789, checked in by felix winkelmann, 12 years ago

setup-utils removal was quite incomplete; added -ignore-repository; msvc Makefile fix (thanks to Ivan Shcheklein); lots of mindless hacking

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