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

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