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