1 | ;;;; compiler.scm - The CHICKEN Scheme compiler |
---|
2 | ; |
---|
3 | ; |
---|
4 | ; "This is insane. What we clearly want to do is not exactly clear, and is rooted in NCOMPLR." |
---|
5 | ; |
---|
6 | ; |
---|
7 | ;----------------------------------------------------------------------------------------------------------- |
---|
8 | ; Copyright (c) 2000-2007, Felix L. Winkelmann |
---|
9 | ; Copyright (c) 2008, The Chicken Team |
---|
10 | ; All rights reserved. |
---|
11 | ; |
---|
12 | ; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following |
---|
13 | ; conditions are met: |
---|
14 | ; |
---|
15 | ; Redistributions of source code must retain the above copyright notice, this list of conditions and the following |
---|
16 | ; disclaimer. |
---|
17 | ; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following |
---|
18 | ; disclaimer in the documentation and/or other materials provided with the distribution. |
---|
19 | ; Neither the name of the author nor the names of its contributors may be used to endorse or promote |
---|
20 | ; products derived from this software without specific prior written permission. |
---|
21 | ; |
---|
22 | ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS |
---|
23 | ; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY |
---|
24 | ; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR |
---|
25 | ; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR |
---|
26 | ; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
---|
27 | ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY |
---|
28 | ; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR |
---|
29 | ; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE |
---|
30 | ; POSSIBILITY OF SUCH DAMAGE. |
---|
31 | ; |
---|
32 | ; |
---|
33 | ; Supported syntax: |
---|
34 | ; |
---|
35 | ; - Declaration specifiers: |
---|
36 | ; |
---|
37 | ; (unit <unitname>) |
---|
38 | ; (uses {<unitname>}) |
---|
39 | ; ([not] standard-bindings {<name>}) |
---|
40 | ; ([not] usual-integrations {<name>}) |
---|
41 | ; ([not] extended-bindings (<name>}) |
---|
42 | ; ([number-type] <type>) |
---|
43 | ; (fixnum-arithmetic) |
---|
44 | ; (unsafe) |
---|
45 | ; ([not] safe) |
---|
46 | ; ([not] interrupts-enabled) |
---|
47 | ; (no-bound-checks) |
---|
48 | ; (no-argc-checks) |
---|
49 | ; (no-procedure-checks) |
---|
50 | ; (no-procedure-checks-for-usual-bindings) |
---|
51 | ; (block-global {<name>}) |
---|
52 | ; (lambda-lift) |
---|
53 | ; (hide {<name>}) |
---|
54 | ; (disable-interrupts) |
---|
55 | ; (disable-warning <class> ...) |
---|
56 | ; (always-bound {<name>}) |
---|
57 | ; (foreign-declare {<string>}) |
---|
58 | ; (block) |
---|
59 | ; (separate) |
---|
60 | ; (compile-syntax) |
---|
61 | ; (run-time-macros) DEPRECATED |
---|
62 | ; (export {<name>}) |
---|
63 | ; (safe-globals) |
---|
64 | ; (custom-declare (<tag> <name> <filename> <arg> ...) <string> ...) |
---|
65 | ; (data <tag1> <exp1> ...) |
---|
66 | ; (post-process <string> ...) |
---|
67 | ; (keep-shadowed-macros) |
---|
68 | ; (import <symbol-or-string> ...) |
---|
69 | ; (unused <symbol> ...) |
---|
70 | ; |
---|
71 | ; <type> = fixnum | generic |
---|
72 | ; |
---|
73 | ; - Source language: |
---|
74 | ; |
---|
75 | ; <variable> |
---|
76 | ; <constant> |
---|
77 | ; (##core#declare {<spec>}) |
---|
78 | ; (##core#immutable <exp>) |
---|
79 | ; (##core#global-ref <variable>) |
---|
80 | ; (quote <exp>) |
---|
81 | ; (if <exp> <exp> [<exp>]) |
---|
82 | ; (let ({(<variable> <exp>)}) <body>) |
---|
83 | ; (##core#let-location <symbol> <type> [<init>] <exp>) |
---|
84 | ; (lambda <variable> <body>) |
---|
85 | ; (lambda ({<variable>}+ [. <variable>]) <body>) |
---|
86 | ; (set! <variable> <exp>) |
---|
87 | ; (##core#set! <variable> <exp>) |
---|
88 | ; (##core#named-lambda <name> <llist> <body>) |
---|
89 | ; (##core#loop-lambda <llist> <body>) |
---|
90 | ; (##core#undefined) |
---|
91 | ; (##core#primitive <name>) |
---|
92 | ; (##core#inline <op> {<exp>}) |
---|
93 | ; (##core#inline_allocate (<op> <words>) {<exp>}) |
---|
94 | ; (##core#inline_ref (<name> <type>)) |
---|
95 | ; (##core#inline_update (<name> <type>) <exp>) |
---|
96 | ; (##core#inline_loc_ref (<type>) <exp>) |
---|
97 | ; (##core#inline_loc_update (<type>) <exp> <exp>) |
---|
98 | ; (##core#compiletimetoo <exp>) |
---|
99 | ; (##core#compiletimeonly <exp>) |
---|
100 | ; (##core#elaborationtimetoo <exp>) |
---|
101 | ; (##core#elaborationtimeonly <exp>) |
---|
102 | ; (define-foreign-variable <symbol> <type> [<string>]) |
---|
103 | ; (define-foreign-type <symbol> <type> [<proc1> [<proc2>]]) |
---|
104 | ; (foreign-lambda <type> <string> {<type>}) |
---|
105 | ; (foreign-lambda* <type> ({(<type> <var>)})) {<string>}) |
---|
106 | ; (foreign-safe-lambda <type> <string> {<type>}) |
---|
107 | ; (foreign-safe-lambda* <type> ({(<type> <var>)})) {<string>}) |
---|
108 | ; (foreign-primitive <type> ({(<type> <var>)}) {<string>}) |
---|
109 | ; (##core#define-inline <name> <exp>) |
---|
110 | ; (define-constant <name> <exp>) |
---|
111 | ; (##core#foreign-callback-wrapper '<name> <qualifiers> '<type> '({<type>}) <exp>) |
---|
112 | ; (##core#define-external-variable (quote <name>) (quote <type>) (quote <bool>)) |
---|
113 | ; (##core#check <exp>) |
---|
114 | ; (##core#require-for-syntax <exp> ...) |
---|
115 | ; (##core#require-extension <id> ...) |
---|
116 | ; (##core#app <exp> {<exp>}) |
---|
117 | ; (##coresyntax <exp>) |
---|
118 | ; (<exp> {<exp>}) |
---|
119 | ; (define-syntax <symbol> <expr>) |
---|
120 | ; (define-compiled-syntax <symbol> <expr>) |
---|
121 | ; (##core#module <symbol> (<name> | (<name> ...) ...) <body>) |
---|
122 | ; |
---|
123 | ; - Core language: |
---|
124 | ; |
---|
125 | ; [##core#variable {<variable>}] |
---|
126 | ; [if {} <exp> <exp> <exp>)] |
---|
127 | ; [quote {<exp>}] |
---|
128 | ; [let {<variable>} <exp-v> <exp>] |
---|
129 | ; [##core#lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>] |
---|
130 | ; [set! {<variable>} <exp>] |
---|
131 | ; [##core#undefined {}] |
---|
132 | ; [##core#global-ref {<variable>}] |
---|
133 | ; [##core#primitive {<name>}] |
---|
134 | ; [##core#inline {<op>} <exp>...] |
---|
135 | ; [##core#inline_allocate {<op> <words>} <exp>...] |
---|
136 | ; [##core#inline_ref {<name> <type>}] |
---|
137 | ; [##core#inline_update {<name> <type>} <exp>] |
---|
138 | ; [##core#inline_loc_ref {<type>} <exp>] |
---|
139 | ; [##core#inline_loc_update {<type>} <exp> <exp>] |
---|
140 | ; [##core#call {<safe-flag> [<debug-info>]} <exp-f> <exp>...] |
---|
141 | ; [##core#callunit {<unitname>} <exp>...] |
---|
142 | ; [##core#switch {<count>} <exp> <const1> <body1> ... <defaultbody>] |
---|
143 | ; [##core#cond <exp> <exp> <exp>] |
---|
144 | ; [##core#recurse {<tail-flag>} <exp1> ...] |
---|
145 | ; [##core#return <exp>] |
---|
146 | ; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...] |
---|
147 | ; [##core#direct_lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>] |
---|
148 | ; |
---|
149 | ; - Closure converted/prepared language: |
---|
150 | ; |
---|
151 | ; [if {} <exp> <exp> <exp>] |
---|
152 | ; [quote {<exp>}] |
---|
153 | ; [##core#bind {<count>} <exp-v>... <exp>] |
---|
154 | ; [##core#undefined {}] |
---|
155 | ; [##core#inline {<op>} <exp>...] |
---|
156 | ; [##core#inline_allocate {<op <words>} <exp>...] |
---|
157 | ; [##core#inline_ref {<name> <type>}] |
---|
158 | ; [##core#inline_update {<name> <type>} <exp>] |
---|
159 | ; [##core#inline_loc_ref {<type>} <exp>] |
---|
160 | ; [##core#inline_loc_update {<type>} <exp> <exp>] |
---|
161 | ; [##core#closure {<count>} <exp>...] |
---|
162 | ; [##core#box {} <exp>] |
---|
163 | ; [##core#unbox {} <exp>] |
---|
164 | ; [##core#ref {<index>} <exp>] |
---|
165 | ; [##core#update {<index>} <exp> <exp>] |
---|
166 | ; [##core#updatebox {} <exp> <exp>] |
---|
167 | ; [##core#update_i {<index>} <exp> <exp>] |
---|
168 | ; [##core#updatebox_i {} <exp> <exp>] |
---|
169 | ; [##core#call {<safe-flag> [<debug-info> [<call-id> <customizable-flag>]]} <exp-f> <exp>...] |
---|
170 | ; [##core#callunit {<unitname>} <exp>...] |
---|
171 | ; [##core#local {<index>}] |
---|
172 | ; [##core#setlocal {<index>} <exp>] |
---|
173 | ; [##core#global {<literal> <safe-flag> <block-mode> [<name>]}] |
---|
174 | ; [##core#setglobal {<literal> <block-mode> <name>} <exp>] |
---|
175 | ; [##core#setglobal_i {<literal> <block-mode> <name>} <exp>] |
---|
176 | ; [##core#literal {<literal>}] |
---|
177 | ; [##core#immediate {<type> [<immediate>]}] - type: bool/fix/nil/char |
---|
178 | ; [##core#proc {<name> [<non-internal>]}] |
---|
179 | ; [##core#recurse {<tail-flag> <call-id>} <exp1> ...] |
---|
180 | ; [##core#return <exp>] |
---|
181 | ; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...] |
---|
182 | ; |
---|
183 | ; |
---|
184 | ; Analysis database entries: |
---|
185 | ; |
---|
186 | ; <variable>: |
---|
187 | ; |
---|
188 | ; captured -> <boolean> If true: variable is used outside it's home-scope |
---|
189 | ; global -> <boolean> If true: variable does not occur in any lambda-list |
---|
190 | ; call-sites -> ((<lambda-id> <node>) ...) Known call-nodes of a named procedure |
---|
191 | ; home -> <lambda-id> Procedure which introduces this variable |
---|
192 | ; unknown -> <boolean> If true: variable can not have a known value |
---|
193 | ; assigned -> <boolean> If true: variable is assigned somewhere |
---|
194 | ; assigned-locally -> <boolean> If true: variable has been assigned inside user lambda |
---|
195 | ; undefined -> <boolean> If true: variable is unknown yet but can be known later |
---|
196 | ; value -> <node> Variable has a known value |
---|
197 | ; potential-value -> <node> Global variable was assigned this value |
---|
198 | ; references -> (<node> ...) Nodes that are accesses of this variable (##core#variable nodes) |
---|
199 | ; side-effecting -> <boolean> If true: variable names side-effecting standard-binding |
---|
200 | ; foldable -> <boolean> If true: variable names foldable standard-binding |
---|
201 | ; boxed -> <boolean> If true: variable has to be boxed after closure-conversion |
---|
202 | ; contractable -> <boolean> If true: variable names contractable procedure |
---|
203 | ; inlinable -> <boolean> If true: variable names potentially inlinable procedure |
---|
204 | ; collapsable -> <boolean> If true: variable refers to collapsable constant |
---|
205 | ; removable -> <boolean> If true: variable is not used |
---|
206 | ; replacable -> <variable> Variable can be replaced by another variable |
---|
207 | ; replacing -> <boolean> If true: variable can replace another variable (don't remove) |
---|
208 | ; standard-binding -> <boolean> If true: variable names a standard binding |
---|
209 | ; extended-binding -> <boolean> If true: variable names an extended binding |
---|
210 | ; unused -> <boolean> If true: variable is a formal parameter that is never used |
---|
211 | ; rest-parameter -> #f | 'vector | 'list If true: variable holds rest-argument list mode |
---|
212 | ; o-r/access-count -> <n> Contains number of references as arguments of optimizable rest operators |
---|
213 | ; constant -> <boolean> If true: variable has fixed value |
---|
214 | ; |
---|
215 | ; <lambda-id>: |
---|
216 | ; |
---|
217 | ; contains -> (<lambda-id> ...) Procedures contained in this lambda |
---|
218 | ; contained-in -> <lambda-id> Procedure containing this lambda |
---|
219 | ; has-unused-parameters -> <boolean> If true: procedure has unused formal parameters |
---|
220 | ; use-expr -> (<lambda-id> ...) Marks non-direct use-sites of common subexpression |
---|
221 | ; closure-size -> <integer> Number of free variables stored in a closure |
---|
222 | ; customizable -> <boolean> If true: all call sites are known, procedure does not escape |
---|
223 | ; simple -> <boolean> If true: procedure only calls its continuation |
---|
224 | ; explicit-rest -> <boolean> If true: procedure is called with consed rest list |
---|
225 | ; captured-variables -> (<var> ...) List of closed over variables |
---|
226 | |
---|
227 | |
---|
228 | (declare |
---|
229 | (unit compiler) |
---|
230 | (disable-warning var) ) |
---|
231 | |
---|
232 | #> |
---|
233 | #ifndef C_INSTALL_SHARE_HOME |
---|
234 | # define C_INSTALL_SHARE_HOME NULL |
---|
235 | #endif |
---|
236 | |
---|
237 | #ifndef C_DEFAULT_TARGET_STACK_SIZE |
---|
238 | # define C_DEFAULT_TARGET_STACK_SIZE 0 |
---|
239 | #endif |
---|
240 | |
---|
241 | #ifndef C_DEFAULT_TARGET_HEAP_SIZE |
---|
242 | # define C_DEFAULT_TARGET_HEAP_SIZE 0 |
---|
243 | #endif |
---|
244 | <# |
---|
245 | |
---|
246 | |
---|
247 | (private compiler |
---|
248 | compiler-arguments process-command-line explicit-use-flag inline-list not-inline-list |
---|
249 | default-standard-bindings default-extended-bindings side-effecting-standard-bindings |
---|
250 | non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings |
---|
251 | standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false |
---|
252 | installation-home decompose-lambda-list external-to-pointer defconstant-bindings constant-declarations |
---|
253 | copy-node! error-is-extended-binding toplevel-scope toplevel-lambda-id |
---|
254 | unit-name insert-timer-checks used-units external-variables require-imports-flag custom-declare-alist |
---|
255 | profile-info-vector-name finish-foreign-result pending-canonicalizations |
---|
256 | foreign-declarations emit-trace-info block-compilation line-number-database-size |
---|
257 | always-bound-to-procedure block-globals make-block-variable-literal block-variable-literal? block-variable-literal-name |
---|
258 | target-heap-size target-stack-size valid-c-identifier? |
---|
259 | target-initial-heap-size internal-bindings source-filename dump-nodes source-info->string |
---|
260 | default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size |
---|
261 | current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables |
---|
262 | rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants |
---|
263 | broken-constant-nodes inline-substitutions-enabled loop-lambda-names expand-profile-lambda |
---|
264 | profile-lambda-list profile-lambda-index emit-profile expand-profile-lambda |
---|
265 | direct-call-ids foreign-type-table first-analysis callback-names disabled-warnings |
---|
266 | initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database! scan-toplevel-assignments |
---|
267 | compiler-warning compiler-macro-table compiler-macros-enabled |
---|
268 | perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization! |
---|
269 | reorganize-recursive-bindings substitution-table simplify-named-call inline-max-size |
---|
270 | perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub |
---|
271 | expand-foreign-lambda* data-declarations emit-control-file-item expand-foreign-primitive |
---|
272 | process-declaration external-protos-first basic-literal? |
---|
273 | transform-direct-lambdas! expand-foreign-callback-lambda* debugging emit-unsafe-marker |
---|
274 | debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list |
---|
275 | string->c-identifier c-ify-string words check-and-open-input-file close-checked-input-file fold-inner constant? |
---|
276 | collapsable-literal? immediate? canonicalize-begin-body extract-mutable-constants string->expr get get-all |
---|
277 | put! collect! count! get-line get-line-2 find-lambda-container display-analysis-database varnode qnode |
---|
278 | build-node-graph build-expression-tree fold-boolean inline-lambda-bindings match-node expression-has-side-effects? |
---|
279 | simple-lambda-node? compute-database-statistics print-program-statistics output gen gen-list |
---|
280 | pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables |
---|
281 | topological-sort print-version print-usage initialize-analysis-database export-list csc-control-file |
---|
282 | estimate-foreign-result-location-size unused-variables |
---|
283 | expand-foreign-callback-lambda default-optimization-passes default-optimization-passes-when-trying-harder |
---|
284 | units-used-by-default words-per-flonum disable-stack-overflow-checking |
---|
285 | parameter-limit eq-inline-operator optimizable-rest-argument-operators postponed-initforms |
---|
286 | membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument |
---|
287 | make-random-name final-foreign-type real-name-table real-name set-real-name! safe-globals-flag |
---|
288 | location-pointer-map literal-rewrite-hook |
---|
289 | undefine-shadowed-macros process-lambda-documentation emit-syntax-trace-info |
---|
290 | generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration |
---|
291 | process-custom-declaration do-lambda-lifting file-requirements emit-closure-info |
---|
292 | foreign-argument-conversion foreign-result-conversion foreign-type-convert-argument foreign-type-convert-result |
---|
293 | big-fixnum? import-libraries) |
---|
294 | |
---|
295 | |
---|
296 | (include "tweaks") |
---|
297 | |
---|
298 | |
---|
299 | (define-inline (gensym-f-id) (gensym 'f_)) |
---|
300 | |
---|
301 | (eval-when (eval) |
---|
302 | (define installation-home #f) |
---|
303 | (define default-target-heap-size #f) |
---|
304 | (define default-target-stack-size #f) ) |
---|
305 | |
---|
306 | (eval-when (load) |
---|
307 | (define-foreign-variable installation-home c-string "C_INSTALL_SHARE_HOME") |
---|
308 | (define-foreign-variable default-target-heap-size int "C_DEFAULT_TARGET_HEAP_SIZE") |
---|
309 | (define-foreign-variable default-target-stack-size int "C_DEFAULT_TARGET_STACK_SIZE") ) |
---|
310 | |
---|
311 | (define user-options-pass (make-parameter #f)) |
---|
312 | (define user-read-pass (make-parameter #f)) |
---|
313 | (define user-preprocessor-pass (make-parameter #f)) |
---|
314 | (define user-pass (make-parameter #f)) |
---|
315 | (define user-pass-2 (make-parameter #f)) |
---|
316 | (define user-post-analysis-pass (make-parameter #f)) |
---|
317 | |
---|
318 | (define-constant foreign-type-table-size 301) |
---|
319 | (define-constant analysis-database-size 3001) |
---|
320 | (define-constant default-line-number-database-size 997) |
---|
321 | (define-constant inline-table-size 301) |
---|
322 | (define-constant constant-table-size 301) |
---|
323 | (define-constant file-requirements-size 301) |
---|
324 | (define-constant real-name-table-size 997) |
---|
325 | (define-constant default-inline-max-size 10) |
---|
326 | |
---|
327 | |
---|
328 | ;;; Global variables containing compilation parameters: |
---|
329 | |
---|
330 | (define unit-name #f) |
---|
331 | (define number-type 'generic) |
---|
332 | (define standard-bindings '()) |
---|
333 | (define extended-bindings '()) |
---|
334 | (define insert-timer-checks #t) |
---|
335 | (define used-units '()) |
---|
336 | (define unsafe #f) |
---|
337 | (define always-bound '()) |
---|
338 | (define always-bound-to-procedure '()) |
---|
339 | (define foreign-declarations '()) |
---|
340 | (define emit-trace-info #f) |
---|
341 | (define block-compilation #f) |
---|
342 | (define line-number-database-size default-line-number-database-size) |
---|
343 | (define target-heap-size #f) |
---|
344 | (define target-initial-heap-size #f) |
---|
345 | (define target-stack-size #f) |
---|
346 | (define optimize-leaf-routines #f) |
---|
347 | (define emit-profile #f) |
---|
348 | (define no-bound-checks #f) |
---|
349 | (define no-argc-checks #f) |
---|
350 | (define no-procedure-checks #f) |
---|
351 | (define block-globals '()) |
---|
352 | (define source-filename #f) |
---|
353 | (define export-list #f) |
---|
354 | (define safe-globals-flag #f) |
---|
355 | (define explicit-use-flag #f) |
---|
356 | (define disable-stack-overflow-checking #f) |
---|
357 | (define require-imports-flag #f) |
---|
358 | (define emit-unsafe-marker #f) |
---|
359 | (define external-protos-first #f) |
---|
360 | (define do-lambda-lifting #f) |
---|
361 | (define inline-max-size -1) |
---|
362 | (define emit-closure-info #t) |
---|
363 | (define undefine-shadowed-macros #t) |
---|
364 | (define constant-declarations '()) |
---|
365 | (define import-libraries '()) |
---|
366 | |
---|
367 | |
---|
368 | ;;; These are here so that the backend can access them: |
---|
369 | |
---|
370 | (define default-default-target-heap-size default-target-heap-size) |
---|
371 | (define default-default-target-stack-size default-target-stack-size) |
---|
372 | |
---|
373 | |
---|
374 | ;;; Other global variables: |
---|
375 | |
---|
376 | (define verbose-mode #f) |
---|
377 | (define original-program-size #f) |
---|
378 | (define current-program-size 0) |
---|
379 | (define line-number-database-2 #f) |
---|
380 | (define immutable-constants '()) |
---|
381 | (define rest-parameters-promoted-to-vector '()) |
---|
382 | (define inline-table #f) |
---|
383 | (define inline-table-used #f) |
---|
384 | (define constant-table #f) |
---|
385 | (define constants-used #f) |
---|
386 | (define mutable-constants '()) |
---|
387 | (define broken-constant-nodes '()) |
---|
388 | (define inline-substitutions-enabled #f) |
---|
389 | (define direct-call-ids '()) |
---|
390 | (define first-analysis #t) |
---|
391 | (define foreign-type-table #f) |
---|
392 | (define foreign-variables '()) |
---|
393 | (define foreign-lambda-stubs '()) |
---|
394 | (define foreign-callback-stubs '()) |
---|
395 | (define external-variables '()) |
---|
396 | (define loop-lambda-names '()) |
---|
397 | (define profile-lambda-list '()) |
---|
398 | (define profile-lambda-index 0) |
---|
399 | (define profile-info-vector-name #f) |
---|
400 | (define external-to-pointer '()) |
---|
401 | (define error-is-extended-binding #f) |
---|
402 | (define real-name-table #f) |
---|
403 | (define location-pointer-map '()) |
---|
404 | (define pending-canonicalizations '()) |
---|
405 | (define defconstant-bindings '()) |
---|
406 | (define callback-names '()) |
---|
407 | (define toplevel-scope #t) |
---|
408 | (define toplevel-lambda-id #f) |
---|
409 | (define custom-declare-alist '()) |
---|
410 | (define csc-control-file #f) |
---|
411 | (define data-declarations '()) |
---|
412 | (define inline-list '()) |
---|
413 | (define not-inline-list '()) |
---|
414 | (define file-requirements #f) |
---|
415 | (define postponed-initforms '()) |
---|
416 | (define unused-variables '()) |
---|
417 | (define compiler-macro-table #f) |
---|
418 | (define compiler-macros-enabled #t) |
---|
419 | (define literal-rewrite-hook #f) |
---|
420 | |
---|
421 | |
---|
422 | ;;; Initialize globals: |
---|
423 | |
---|
424 | (define (initialize-compiler) |
---|
425 | (if line-number-database-2 |
---|
426 | (vector-fill! line-number-database-2 '()) |
---|
427 | (set! line-number-database-2 (make-vector line-number-database-size '())) ) |
---|
428 | (if inline-table |
---|
429 | (vector-fill! inline-table '()) |
---|
430 | (set! inline-table (make-vector inline-table-size '())) ) |
---|
431 | (if constant-table |
---|
432 | (vector-fill! constant-table '()) |
---|
433 | (set! constant-table (make-vector constant-table-size '())) ) |
---|
434 | (set! profile-info-vector-name (make-random-name 'profile-info)) |
---|
435 | (set! real-name-table (make-vector real-name-table-size '())) |
---|
436 | (if file-requirements |
---|
437 | (vector-fill! file-requirements '()) |
---|
438 | (set! file-requirements (make-vector file-requirements-size '())) ) |
---|
439 | (if foreign-type-table |
---|
440 | (vector-fill! foreign-type-table '()) |
---|
441 | (set! foreign-type-table (make-vector foreign-type-table-size '())) ) ) |
---|
442 | |
---|
443 | |
---|
444 | ;;; Expand macros and canonicalize expressions: |
---|
445 | |
---|
446 | (define (canonicalize-expression exp) |
---|
447 | |
---|
448 | (define (find-id id se) ; ignores macro bindings |
---|
449 | (cond ((null? se) #f) |
---|
450 | ((and (eq? id (caar se)) (symbol? (cdar se))) (cdar se)) |
---|
451 | (else (find-id id (cdr se))))) |
---|
452 | |
---|
453 | (define (lookup id se) |
---|
454 | (cond ((find-id id se)) |
---|
455 | ((##sys#get id '##sys#macro-alias)) |
---|
456 | (else id))) |
---|
457 | |
---|
458 | (define (macro-alias var se) |
---|
459 | (let ((alias (gensym var))) |
---|
460 | (##sys#put! alias '##sys#macro-alias (lookup var se)) |
---|
461 | alias) ) |
---|
462 | |
---|
463 | (define (set-real-names! as ns) |
---|
464 | (for-each (lambda (a n) (set-real-name! a n)) as ns) ) |
---|
465 | |
---|
466 | (define (write-to-string x) |
---|
467 | (let ([out (open-output-string)]) |
---|
468 | (write x out) |
---|
469 | (get-output-string out) ) ) |
---|
470 | |
---|
471 | (define (unquotify x se) |
---|
472 | (if (and (list? x) |
---|
473 | (= 2 (length x)) |
---|
474 | (symbol? (car x)) |
---|
475 | (eq? 'quote (lookup (car x) se))) |
---|
476 | (cadr x) |
---|
477 | x) ) |
---|
478 | |
---|
479 | (define (resolve-variable x0 se dest) |
---|
480 | (let ((x (lookup x0 se))) |
---|
481 | (cond ((not (symbol? x)) x0) ; syntax? |
---|
482 | [(and constants-used (##sys#hash-table-ref constant-table x)) |
---|
483 | => (lambda (val) (walk (car val) se dest)) ] |
---|
484 | [(and inline-table-used (##sys#hash-table-ref inline-table x)) |
---|
485 | => (lambda (val) (walk val se dest)) ] |
---|
486 | [(assq x foreign-variables) |
---|
487 | => (lambda (fv) |
---|
488 | (let* ([t (second fv)] |
---|
489 | [ft (final-foreign-type t)] |
---|
490 | [body `(##core#inline_ref (,(third fv) ,t))] ) |
---|
491 | (foreign-type-convert-result |
---|
492 | (finish-foreign-result ft body) |
---|
493 | t) ) ) ] |
---|
494 | [(assq x location-pointer-map) |
---|
495 | => (lambda (a) |
---|
496 | (let* ([t (third a)] |
---|
497 | [ft (final-foreign-type t)] |
---|
498 | [body `(##core#inline_loc_ref (,t) ,(second a))] ) |
---|
499 | (foreign-type-convert-result |
---|
500 | (finish-foreign-result ft body) |
---|
501 | t) ) ) ] |
---|
502 | ((not (assq x0 se)) (##sys#alias-global-hook x)) ; only globals |
---|
503 | (else x)))) |
---|
504 | |
---|
505 | (define (eval/meta form) |
---|
506 | (parameterize ((##sys#current-module #f) |
---|
507 | (##sys#macro-environment (##sys#meta-macro-environment))) |
---|
508 | ((##sys#compile-to-closure |
---|
509 | form |
---|
510 | '() |
---|
511 | (##sys#current-meta-environment)) |
---|
512 | '() ) )) |
---|
513 | |
---|
514 | (define (walk x se dest) |
---|
515 | (cond ((symbol? x) |
---|
516 | (resolve-variable x se dest)) |
---|
517 | ((not-pair? x) |
---|
518 | (if (constant? x) |
---|
519 | `(quote ,x) |
---|
520 | (syntax-error "illegal atomic form" x))) |
---|
521 | ((symbol? (car x)) |
---|
522 | (let ([ln (get-line x)]) |
---|
523 | (emit-syntax-trace-info x #f) |
---|
524 | (unless (proper-list? x) |
---|
525 | (if ln |
---|
526 | (syntax-error (sprintf "(in line ~s) - malformed expression" ln) x) |
---|
527 | (syntax-error "malformed expression" x))) |
---|
528 | (set! ##sys#syntax-error-culprit x) |
---|
529 | (let ((name (lookup (car x) se)) |
---|
530 | (xexpanded (##sys#expand x se))) |
---|
531 | (cond ((not (eq? x xexpanded)) |
---|
532 | (walk xexpanded se dest)) |
---|
533 | |
---|
534 | [(and inline-table-used (##sys#hash-table-ref inline-table name)) |
---|
535 | => (lambda (val) |
---|
536 | (walk (cons val (cdr x)) se dest)) ] |
---|
537 | |
---|
538 | [else |
---|
539 | (when ln (update-line-number-database! xexpanded ln)) |
---|
540 | (case name |
---|
541 | |
---|
542 | ((if) |
---|
543 | (##sys#check-syntax 'if x '(if _ _ . #(_)) #f se) |
---|
544 | `(if |
---|
545 | ,(walk (cadr x) se #f) |
---|
546 | ,(walk (caddr x) se #f) |
---|
547 | ,(if (null? (cdddr x)) |
---|
548 | '(##core#undefined) |
---|
549 | (walk (cadddr x) se #f) ) ) ) |
---|
550 | |
---|
551 | ((quote ##core#syntax) |
---|
552 | (##sys#check-syntax 'quote x '(_ _) #f se) |
---|
553 | `(quote ,(##sys#strip-syntax (cadr x)))) |
---|
554 | |
---|
555 | ((##core#check) |
---|
556 | (if unsafe |
---|
557 | ''#t |
---|
558 | (walk (cadr x) se dest) ) ) |
---|
559 | |
---|
560 | ((##core#immutable) |
---|
561 | (let ((c (cadadr x))) |
---|
562 | (cond [(assoc c immutable-constants) => cdr] |
---|
563 | [else |
---|
564 | (let ([var (gensym 'c)]) |
---|
565 | (set! immutable-constants (alist-cons c var immutable-constants)) |
---|
566 | (set! always-bound (cons var always-bound)) |
---|
567 | (set! block-globals (cons var block-globals)) |
---|
568 | var) ] ) ) ) |
---|
569 | |
---|
570 | ((##core#undefined ##core#callunit ##core#primitive ##core#inline_ref |
---|
571 | ##core#inline_loc_ref) x) |
---|
572 | |
---|
573 | ((##core#require-for-syntax) |
---|
574 | (let ([ids (map eval (cdr x))]) |
---|
575 | (apply ##sys#require ids) |
---|
576 | (##sys#hash-table-update! |
---|
577 | file-requirements 'syntax-requirements (cut lset-union eq? <> ids) |
---|
578 | (lambda () ids) ) |
---|
579 | '(##core#undefined) ) ) |
---|
580 | |
---|
581 | ((##core#require-extension) |
---|
582 | (walk |
---|
583 | (let loop ([ids (cdr x)]) |
---|
584 | (if (null? ids) |
---|
585 | '(##core#undefined) |
---|
586 | (let ([id (car ids)]) |
---|
587 | (let-values ([(exp f) (##sys#do-the-right-thing id #t)]) |
---|
588 | (if (not (or f |
---|
589 | (and (symbol? id) |
---|
590 | (or (feature? id) |
---|
591 | (##sys#find-extension |
---|
592 | (##sys#canonicalize-extension-path |
---|
593 | id 'require-extension) #f)) ) ) ) |
---|
594 | (compiler-warning |
---|
595 | 'ext "extension `~A' is currently not installed" id)) |
---|
596 | `(begin ,exp ,(loop (cdr ids))) ) ) ) ) |
---|
597 | se dest) ) |
---|
598 | |
---|
599 | ((let) |
---|
600 | (##sys#check-syntax 'let x '(let #((variable _) 0) . #(_ 1)) #f se) |
---|
601 | (let* ((bindings (cadr x)) |
---|
602 | (vars (unzip1 bindings)) |
---|
603 | (aliases (map gensym vars)) |
---|
604 | (se2 (append (map cons vars aliases) se)) ) |
---|
605 | (set-real-names! aliases vars) |
---|
606 | `(let |
---|
607 | ,(map (lambda (alias b) |
---|
608 | (list alias (walk (cadr b) se (car b))) ) |
---|
609 | aliases bindings) |
---|
610 | ,(walk (##sys#canonicalize-body (cddr x) se2) |
---|
611 | se2 dest) ) ) ) |
---|
612 | |
---|
613 | ((lambda ##core#internal-lambda) |
---|
614 | (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se) |
---|
615 | (let ((llist (cadr x)) |
---|
616 | (obody (cddr x)) ) |
---|
617 | (when (##sys#extended-lambda-list? llist) |
---|
618 | (set!-values |
---|
619 | (llist obody) |
---|
620 | (##sys#expand-extended-lambda-list |
---|
621 | llist obody ##sys#error se) ) ) |
---|
622 | (decompose-lambda-list |
---|
623 | llist |
---|
624 | (lambda (vars argc rest) |
---|
625 | (let* ((aliases (map gensym vars)) |
---|
626 | (se2 (append (map cons vars aliases) se)) |
---|
627 | (body0 (##sys#canonicalize-body obody se2)) |
---|
628 | (body (walk body0 se2 #f)) |
---|
629 | (llist2 |
---|
630 | (build-lambda-list |
---|
631 | aliases argc |
---|
632 | (and rest (list-ref aliases (posq rest vars))) ) ) |
---|
633 | (l `(lambda ,llist2 ,body)) ) |
---|
634 | (set-real-names! aliases vars) |
---|
635 | (cond ((or (not dest) |
---|
636 | (not (assq dest se))) ; global? |
---|
637 | l) |
---|
638 | ((and emit-profile (eq? 'lambda name)) |
---|
639 | (expand-profile-lambda dest llist2 body) ) |
---|
640 | (else |
---|
641 | (if (and (> (length body0) 1) |
---|
642 | (symbol? (car body0)) |
---|
643 | (eq? 'begin (lookup (car body0) se)) |
---|
644 | (let ((x1 (cadr body0))) |
---|
645 | (or (string? x1) |
---|
646 | (and (list? x1) |
---|
647 | (= (length x1) 2) |
---|
648 | (symbol? (car x1)) |
---|
649 | (eq? 'quote (lookup (car x1) se)))))) |
---|
650 | (process-lambda-documentation |
---|
651 | dest (cadr body) l) |
---|
652 | l)))))))) |
---|
653 | |
---|
654 | ((let-syntax) |
---|
655 | (##sys#check-syntax 'let-syntax x '(let-syntax #((variable _) 0) . #(_ 1)) #f se) |
---|
656 | (let ((se2 (append |
---|
657 | (map (lambda (b) |
---|
658 | (list |
---|
659 | (car b) |
---|
660 | se |
---|
661 | (##sys#er-transformer |
---|
662 | (eval/meta (cadr b))))) |
---|
663 | (cadr x) ) |
---|
664 | se) ) ) |
---|
665 | (walk |
---|
666 | (##sys#canonicalize-body (cddr x) se2) |
---|
667 | se2 |
---|
668 | dest) ) ) |
---|
669 | |
---|
670 | ((letrec-syntax) |
---|
671 | (##sys#check-syntax 'letrec-syntax x '(letrec-syntax #((variable _) 0) . #(_ 1)) #f se) |
---|
672 | (let* ((ms (map (lambda (b) |
---|
673 | (list |
---|
674 | (car b) |
---|
675 | #f |
---|
676 | (##sys#er-transformer |
---|
677 | (eval/meta (cadr b))))) |
---|
678 | (cadr x) ) ) |
---|
679 | (se2 (append ms se)) ) |
---|
680 | (for-each |
---|
681 | (lambda (sb) |
---|
682 | (set-car! (cdr sb) se2) ) |
---|
683 | ms) |
---|
684 | (walk |
---|
685 | (##sys#canonicalize-body (cddr x) se2) |
---|
686 | se2 dest))) |
---|
687 | |
---|
688 | ((define-syntax) |
---|
689 | (##sys#check-syntax 'define-syntax x '(define-syntax variable _) #f se) |
---|
690 | (let ((name (lookup (cadr x) se)) |
---|
691 | (tx (caddr x))) |
---|
692 | (##sys#extend-macro-environment |
---|
693 | name |
---|
694 | (##sys#current-environment) |
---|
695 | (##sys#er-transformer (eval/meta tx))) |
---|
696 | (##sys#register-export name (##sys#current-module) tx) |
---|
697 | (walk |
---|
698 | (if ##sys#enable-runtime-macros |
---|
699 | `(##sys#extend-macro-environment |
---|
700 | ',(cadr x) |
---|
701 | (##sys#current-environment) |
---|
702 | (##sys#er-transformer |
---|
703 | ,tx)) ;*** possibly wrong se? |
---|
704 | '(##core#undefined) ) |
---|
705 | se dest)) ) |
---|
706 | |
---|
707 | ((define-compiled-syntax) |
---|
708 | (##sys#check-syntax 'define-compiled-syntax x '(_ variable _) #f se) |
---|
709 | (let ((name (lookup (cadr x) se)) |
---|
710 | (tx (caddr x))) |
---|
711 | (##sys#extend-macro-environment |
---|
712 | name |
---|
713 | (##sys#current-environment) |
---|
714 | (##sys#er-transformer (eval/meta tx))) |
---|
715 | (##sys#register-export name (##sys#current-module) tx) |
---|
716 | (walk |
---|
717 | `(##sys#extend-macro-environment |
---|
718 | ',(cadr x) |
---|
719 | (##sys#current-environment) |
---|
720 | (##sys#er-transformer |
---|
721 | ,tx)) ;*** possibly wrong se? |
---|
722 | se dest))) |
---|
723 | |
---|
724 | ((##core#module) |
---|
725 | (let* ((name (lookup (cadr x) se)) |
---|
726 | (exports |
---|
727 | (map (lambda (exp) |
---|
728 | (cond ((symbol? exp) (lookup exp se)) |
---|
729 | ((and (pair? exp) |
---|
730 | (let loop ((exp exp)) |
---|
731 | (or (null? exp) |
---|
732 | (and (symbol? (car exp)) |
---|
733 | (loop (cdr exp)))))) |
---|
734 | (map (cut lookup <> se) exp) ) |
---|
735 | (else |
---|
736 | (##sys#syntax-error-hook |
---|
737 | 'module |
---|
738 | "invalid export syntax" exp name)))) |
---|
739 | (caddr x))) |
---|
740 | (me0 (##sys#macro-environment))) |
---|
741 | (when (##sys#current-module) |
---|
742 | (##sys#syntax-error-hook 'module "modules may not be nested" name)) |
---|
743 | (when (pair? se) |
---|
744 | (##sys#syntax-error-hook 'module "module definition not in toplevel scope" |
---|
745 | name)) |
---|
746 | (let-values (((body mreg) |
---|
747 | (parameterize ((##sys#current-module |
---|
748 | (##sys#register-module name exports) ) |
---|
749 | (##sys#import-environment '()) |
---|
750 | (##sys#macro-environment ##sys#initial-macro-environment)) |
---|
751 | (let loop ((body (cdddr x)) (xs '())) |
---|
752 | (cond |
---|
753 | ((null? body) |
---|
754 | (##sys#finalize-module (##sys#current-module) me0) |
---|
755 | (cond ((assq name import-libraries) => |
---|
756 | (lambda (il) |
---|
757 | (with-output-to-file (cdr il) |
---|
758 | (lambda () |
---|
759 | (pretty-print |
---|
760 | (##sys#compiled-module-registration |
---|
761 | (##sys#current-module))))) |
---|
762 | (values |
---|
763 | (reverse xs) |
---|
764 | '(##core#undefined)))) |
---|
765 | (else |
---|
766 | (values |
---|
767 | (reverse xs) |
---|
768 | (##sys#compiled-module-registration (##sys#current-module)))))) |
---|
769 | (else |
---|
770 | (loop |
---|
771 | (cdr body) |
---|
772 | (cons (walk (car body) se #f) xs)))))))) |
---|
773 | (canonicalize-begin-body |
---|
774 | (append |
---|
775 | (list |
---|
776 | (parameterize ((##sys#current-module #f) |
---|
777 | (##sys#macro-environment (##sys#meta-macro-environment))) |
---|
778 | (walk mreg (##sys#current-meta-environment) #f)) ) |
---|
779 | body))))) |
---|
780 | |
---|
781 | ((##core#named-lambda) |
---|
782 | (walk `(,(macro-alias 'lambda se) ,@(cddr x)) se (cadr x)) ) |
---|
783 | |
---|
784 | ((##core#loop-lambda) |
---|
785 | (let* ([vars (cadr x)] |
---|
786 | [obody (cddr x)] |
---|
787 | [aliases (map gensym vars)] |
---|
788 | (se2 (append (map cons vars aliases) se)) |
---|
789 | [body |
---|
790 | (walk |
---|
791 | (##sys#canonicalize-body obody se2) |
---|
792 | se2 #f) ] ) |
---|
793 | (set-real-names! aliases vars) |
---|
794 | `(lambda ,aliases ,body) ) ) |
---|
795 | |
---|
796 | ((set! ##core#set!) |
---|
797 | (##sys#check-syntax 'set! x '(_ variable _) #f se) |
---|
798 | (let* ([var0 (cadr x)] |
---|
799 | [var (lookup var0 se)] |
---|
800 | [ln (get-line x)] |
---|
801 | [val (walk (caddr x) se var0)] ) |
---|
802 | (when (eq? var var0) ; global? |
---|
803 | (set! var (##sys#alias-global-hook var)) |
---|
804 | (when safe-globals-flag |
---|
805 | (set! always-bound-to-procedure |
---|
806 | (lset-adjoin eq? always-bound-to-procedure var)) |
---|
807 | (set! always-bound (lset-adjoin eq? always-bound var)) ) |
---|
808 | (when (macro? var) |
---|
809 | (compiler-warning |
---|
810 | 'var "assigned global variable `~S' is a macro ~A" |
---|
811 | var |
---|
812 | (if ln (sprintf "in line ~S" ln) "") ) |
---|
813 | (when undefine-shadowed-macros (undefine-macro! var) ) ) ) |
---|
814 | (when (keyword? var) |
---|
815 | (compiler-warning 'syntax "assignment to keyword `~S'" var) ) |
---|
816 | (when (pair? var) ; macro |
---|
817 | (syntax-error |
---|
818 | 'set! "assignment to syntactic identifier" var)) |
---|
819 | (cond ((assq var foreign-variables) |
---|
820 | => (lambda (fv) |
---|
821 | (let ([type (second fv)] |
---|
822 | [tmp (gensym)] ) |
---|
823 | `(let ([,tmp ,(foreign-type-convert-argument val type)]) |
---|
824 | (##core#inline_update |
---|
825 | (,(third fv) ,type) |
---|
826 | ,(foreign-type-check tmp type) ) ) ) ) ) |
---|
827 | ((assq var location-pointer-map) |
---|
828 | => (lambda (a) |
---|
829 | (let* ([type (third a)] |
---|
830 | [tmp (gensym)] ) |
---|
831 | `(let ([,tmp ,(foreign-type-convert-argument val type)]) |
---|
832 | (##core#inline_loc_update |
---|
833 | (,type) |
---|
834 | ,(second a) |
---|
835 | ,(foreign-type-check tmp type) ) ) ) ) ) |
---|
836 | (else `(set! ,var ,val))))) |
---|
837 | |
---|
838 | ((##core#inline) |
---|
839 | `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) se))) |
---|
840 | |
---|
841 | ((##core#inline_allocate) |
---|
842 | `(##core#inline_allocate |
---|
843 | ,(map (cut unquotify <> se) (second x)) |
---|
844 | ,@(mapwalk (cddr x) se))) |
---|
845 | |
---|
846 | ((##core#inline_update) |
---|
847 | `(##core#inline_update ,(cadr x) ,(walk (caddr x) se #f)) ) |
---|
848 | |
---|
849 | ((##core#inline_loc_update) |
---|
850 | `(##core#inline_loc_update |
---|
851 | ,(cadr x) |
---|
852 | ,(walk (caddr x) se #f) |
---|
853 | ,(walk (cadddr x) se #f)) ) |
---|
854 | |
---|
855 | ((##core#compiletimetoo ##core#elaborationtimetoo) |
---|
856 | (let ((exp (cadr x))) |
---|
857 | (eval exp) |
---|
858 | (walk exp se dest) ) ) |
---|
859 | |
---|
860 | ((##core#compiletimeonly ##core#elaborationtimeonly) |
---|
861 | (eval (cadr x)) |
---|
862 | '(##core#undefined) ) |
---|
863 | |
---|
864 | ((begin) |
---|
865 | (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se) |
---|
866 | (if (pair? (cdr x)) |
---|
867 | (canonicalize-begin-body |
---|
868 | (let fold ([xs (cdr x)]) |
---|
869 | (let ([x (car xs)] |
---|
870 | [r (cdr xs)] ) |
---|
871 | (if (null? r) |
---|
872 | (list (walk x se dest)) |
---|
873 | (cons (walk x se #f) (fold r)) ) ) ) ) |
---|
874 | '(##core#undefined) ) ) |
---|
875 | |
---|
876 | ((foreign-lambda) |
---|
877 | (walk (expand-foreign-lambda x) se dest) ) |
---|
878 | |
---|
879 | ((foreign-safe-lambda) |
---|
880 | (walk (expand-foreign-callback-lambda x) se dest) ) |
---|
881 | |
---|
882 | ((foreign-lambda*) |
---|
883 | (walk (expand-foreign-lambda* x) se dest) ) |
---|
884 | |
---|
885 | ((foreign-safe-lambda*) |
---|
886 | (walk (expand-foreign-callback-lambda* x) se dest) ) |
---|
887 | |
---|
888 | ((foreign-primitive) |
---|
889 | (walk (expand-foreign-primitive x) se dest) ) |
---|
890 | |
---|
891 | ((define-foreign-variable) |
---|
892 | (let* ([var (second x)] |
---|
893 | [type (third x)] |
---|
894 | [name (if (pair? (cdddr x)) |
---|
895 | (fourth x) |
---|
896 | (symbol->string var) ) ] ) |
---|
897 | (set! foreign-variables |
---|
898 | (cons (list var type (if (string? name) name (symbol->string name))) |
---|
899 | foreign-variables)) |
---|
900 | '(##core#undefined) ) ) |
---|
901 | |
---|
902 | ((define-foreign-type) |
---|
903 | (let ([name (second x)] |
---|
904 | [type (third x)] |
---|
905 | [conv (cdddr x)] ) |
---|
906 | (cond [(pair? conv) |
---|
907 | (let ([arg (gensym)] |
---|
908 | [ret (gensym)] ) |
---|
909 | (##sys#hash-table-set! foreign-type-table name (vector type arg ret)) |
---|
910 | (set! always-bound (cons* arg ret always-bound)) |
---|
911 | (set! block-globals (cons* arg ret block-globals)) |
---|
912 | (walk |
---|
913 | `(,(macro-alias 'begin se) |
---|
914 | (##core#set! ,arg ,(first conv)) |
---|
915 | (##core#set! |
---|
916 | ,ret |
---|
917 | ,(if (pair? (cdr conv)) (second conv) '##sys#values)) ) |
---|
918 | se dest) ) ] |
---|
919 | [else |
---|
920 | (##sys#hash-table-set! foreign-type-table name type) |
---|
921 | '(##core#undefined) ] ) ) ) |
---|
922 | |
---|
923 | ((define-external-variable) |
---|
924 | (let* ([sym (second x)] |
---|
925 | [name (symbol->string sym)] |
---|
926 | [type (third x)] |
---|
927 | [exported (fourth x)] |
---|
928 | [rname (make-random-name)] ) |
---|
929 | (unless exported (set! name (symbol->string (fifth x)))) |
---|
930 | (set! external-variables (cons (vector name type exported) external-variables)) |
---|
931 | (set! foreign-variables |
---|
932 | (cons (list rname 'c-pointer (string-append "&" name)) |
---|
933 | foreign-variables) ) |
---|
934 | (set! external-to-pointer (alist-cons sym rname external-to-pointer)) |
---|
935 | '(##core#undefined) ) ) |
---|
936 | |
---|
937 | ((##core#let-location) |
---|
938 | (let* ([var (second x)] |
---|
939 | [type (third x)] |
---|
940 | [alias (gensym)] |
---|
941 | [store (gensym)] |
---|
942 | [init (and (pair? (cddddr x)) (fourth x))] ) |
---|
943 | (set-real-name! alias var) |
---|
944 | (set! location-pointer-map |
---|
945 | (cons (list alias store type) location-pointer-map) ) |
---|
946 | `(let (,(let ([size (words (estimate-foreign-result-location-size type))]) |
---|
947 | ;; Add 2 words: 1 for the header, 1 for double-alignment: |
---|
948 | ;; Note: C_a_i_bytevector takes number of words, not bytes |
---|
949 | (list |
---|
950 | store |
---|
951 | `(##core#inline_allocate |
---|
952 | ("C_a_i_bytevector" ,(+ 2 size)) |
---|
953 | ',size)) ) ) |
---|
954 | ,(walk |
---|
955 | `(,(macro-alias 'begin se) |
---|
956 | ,@(if init |
---|
957 | `((##core#set! ,alias ,init)) |
---|
958 | '() ) |
---|
959 | ,(if init (fifth x) (fourth x)) ) |
---|
960 | (alist-cons var alias se) |
---|
961 | dest) ) ) ) |
---|
962 | |
---|
963 | ((##core#define-inline) |
---|
964 | (let* ([name (second x)] |
---|
965 | [val (third x)] ) |
---|
966 | (receive (val2 mlist) |
---|
967 | (extract-mutable-constants |
---|
968 | (walk (cons '##core#internal-lambda (cdr val)) se name) ) |
---|
969 | (##sys#hash-table-set! inline-table name val2) |
---|
970 | (set! always-bound (append (unzip1 mlist) always-bound)) |
---|
971 | (set! inline-table-used #t) |
---|
972 | (walk |
---|
973 | `(,(macro-alias 'begin se) |
---|
974 | ,@(map (lambda (m) |
---|
975 | `(##core#set! ,(car m) ',(cdr m))) mlist)) |
---|
976 | se #f) ) ) ) |
---|
977 | |
---|
978 | ((define-constant) |
---|
979 | (let* ([name (second x)] |
---|
980 | [valexp (third x)] |
---|
981 | [val (handle-exceptions ex |
---|
982 | ;; could show line number here |
---|
983 | (quit "error in constant evaluation of ~S for named constant ~S" |
---|
984 | valexp name) |
---|
985 | (if (collapsable-literal? valexp) |
---|
986 | valexp |
---|
987 | (eval |
---|
988 | `(,(macro-alias 'let se) |
---|
989 | ,defconstant-bindings ,valexp)) ) ) ] ) |
---|
990 | (set! constants-used #t) |
---|
991 | (set! defconstant-bindings (cons (list name `',val) defconstant-bindings)) |
---|
992 | (cond [(collapsable-literal? val) |
---|
993 | (##sys#hash-table-set! constant-table name (list val)) |
---|
994 | '(##core#undefined) ] |
---|
995 | [else |
---|
996 | (let ([var (gensym "constant")]) |
---|
997 | (##sys#hash-table-set! constant-table name (list var)) |
---|
998 | (set! mutable-constants (alist-cons var val mutable-constants)) |
---|
999 | (set! block-globals (cons var block-globals)) |
---|
1000 | (set! always-bound (cons var always-bound)) |
---|
1001 | (walk `(##core#set! ,var ',val) se #f) ) ] ) ) ) |
---|
1002 | |
---|
1003 | ((##core#declare) |
---|
1004 | (walk |
---|
1005 | `(,(macro-alias 'begin se) |
---|
1006 | ,@(map (lambda (d) |
---|
1007 | (process-declaration |
---|
1008 | (##sys#strip-syntax d) |
---|
1009 | se)) |
---|
1010 | (cdr x) ) ) |
---|
1011 | '() #f) ) |
---|
1012 | |
---|
1013 | ((##core#foreign-callback-wrapper) |
---|
1014 | (let-values ([(args lam) (split-at (cdr x) 4)]) |
---|
1015 | (let* ([lam (car lam)] |
---|
1016 | [name (cadr (first args))] |
---|
1017 | [rtype (cadr (third args))] |
---|
1018 | [atypes (cadr (fourth args))] |
---|
1019 | [vars (second lam)] ) |
---|
1020 | (if (valid-c-identifier? name) |
---|
1021 | (set! callback-names (cons name callback-names)) |
---|
1022 | (quit "name `~S' of external definition is not a valid C identifier" |
---|
1023 | name) ) |
---|
1024 | (when (or (not (proper-list? vars)) |
---|
1025 | (not (proper-list? atypes)) |
---|
1026 | (not (= (length vars) (length atypes))) ) |
---|
1027 | (syntax-error |
---|
1028 | "non-matching or invalid argument list to foreign callback-wrapper" |
---|
1029 | vars atypes) ) |
---|
1030 | `(##core#foreign-callback-wrapper |
---|
1031 | ,@(mapwalk args se) |
---|
1032 | ,(walk `(##core#internal-lambda |
---|
1033 | ,vars |
---|
1034 | (,(macro-alias 'let se) |
---|
1035 | ,(let loop ([vars vars] [types atypes]) |
---|
1036 | (if (null? vars) |
---|
1037 | '() |
---|
1038 | (let ([var (car vars)] |
---|
1039 | [type (car types)] ) |
---|
1040 | (cons |
---|
1041 | (list |
---|
1042 | var |
---|
1043 | (foreign-type-convert-result |
---|
1044 | (finish-foreign-result (final-foreign-type type) var) |
---|
1045 | type) ) |
---|
1046 | (loop (cdr vars) (cdr types)) ) ) ) ) |
---|
1047 | ,(foreign-type-convert-argument |
---|
1048 | `(,(macro-alias 'let se) |
---|
1049 | () |
---|
1050 | ,@(cond |
---|
1051 | ((member |
---|
1052 | rtype |
---|
1053 | '((const nonnull-c-string) |
---|
1054 | (const nonnull-unsigned-c-string) |
---|
1055 | nonnull-unsigned-c-string |
---|
1056 | nonnull-c-string)) |
---|
1057 | `((##sys#make-c-string |
---|
1058 | (,(macro-alias 'let se) |
---|
1059 | () ,@(cddr lam))))) |
---|
1060 | ((member |
---|
1061 | rtype |
---|
1062 | '((const c-string*) |
---|
1063 | (const unsigned-c-string*) |
---|
1064 | unsigned-c-string* |
---|
1065 | c-string* |
---|
1066 | c-string-list |
---|
1067 | c-string-list*)) |
---|
1068 | (syntax-error |
---|
1069 | "not a valid result type for callback procedures" |
---|
1070 | rtype |
---|
1071 | name) ) |
---|
1072 | ((member |
---|
1073 | rtype |
---|
1074 | '(c-string |
---|
1075 | (const unsigned-c-string) |
---|
1076 | unsigned-c-string |
---|
1077 | (const c-string)) ) |
---|
1078 | `((,(macro-alias 'let se) |
---|
1079 | ((r (,(macro-alias 'let se) |
---|
1080 | () ,@(cddr lam)))) |
---|
1081 | (,(macro-alias 'and se) |
---|
1082 | r |
---|
1083 | (##sys#make-c-string r)) ) ) ) |
---|
1084 | (else (cddr lam)) ) ) |
---|
1085 | rtype) ) ) |
---|
1086 | se #f) ) ) ) ) |
---|
1087 | |
---|
1088 | (else |
---|
1089 | (let ([handle-call |
---|
1090 | (lambda () |
---|
1091 | (let* ([x2 (mapwalk x se)] |
---|
1092 | [head2 (car x2)] |
---|
1093 | [old (##sys#hash-table-ref line-number-database-2 head2)] ) |
---|
1094 | (when ln |
---|
1095 | (##sys#hash-table-set! |
---|
1096 | line-number-database-2 |
---|
1097 | head2 |
---|
1098 | (cons name (alist-cons x2 ln (if old (cdr old) '()))) ) ) |
---|
1099 | x2) ) ] ) |
---|
1100 | |
---|
1101 | (cond [(eq? 'location name) |
---|
1102 | (##sys#check-syntax 'location x '(location _) #f se) |
---|
1103 | (let ([sym (cadr x)]) |
---|
1104 | (if (symbol? sym) |
---|
1105 | (cond [(assq (lookup sym se) location-pointer-map) |
---|
1106 | => (lambda (a) |
---|
1107 | (walk |
---|
1108 | `(##sys#make-locative ,(second a) 0 #f 'location) |
---|
1109 | se #f) ) ] |
---|
1110 | [(assq sym external-to-pointer) |
---|
1111 | => (lambda (a) (walk (cdr a) se #f)) ] |
---|
1112 | [(memq sym callback-names) |
---|
1113 | `(##core#inline_ref (,(symbol->string sym) c-pointer)) ] |
---|
1114 | [else |
---|
1115 | (walk `(##sys#make-locative ,sym 0 #f 'location) se #f) ] ) |
---|
1116 | (walk `(##sys#make-locative ,sym 0 #f 'location) se #f) ) ) ] |
---|
1117 | |
---|
1118 | ((and compiler-macros-enabled |
---|
1119 | compiler-macro-table |
---|
1120 | (##sys#hash-table-ref compiler-macro-table name)) => |
---|
1121 | (lambda (cm) |
---|
1122 | (let ((cx (cm x))) |
---|
1123 | (if (equal? cx x) |
---|
1124 | (handle-call) |
---|
1125 | (walk cx se dest))))) |
---|
1126 | |
---|
1127 | [else (handle-call)] ) ) ) ) ] ) ) ) ) |
---|
1128 | |
---|
1129 | ((not (proper-list? x)) |
---|
1130 | (syntax-error "malformed expression" x) ) |
---|
1131 | |
---|
1132 | ((constant? (car x)) |
---|
1133 | (emit-syntax-trace-info x #f) |
---|
1134 | (compiler-warning 'syntax "literal in operator position: ~S" x) |
---|
1135 | (mapwalk x se) ) |
---|
1136 | |
---|
1137 | ((and (pair? (car x)) (eq? 'lambda (caar x))) |
---|
1138 | (let ([lexp (car x)] |
---|
1139 | [args (cdr x)] ) |
---|
1140 | (emit-syntax-trace-info x #f) |
---|
1141 | (##sys#check-syntax 'lambda lexp '(lambda lambda-list . #(_ 1)) #f se) |
---|
1142 | (let ([llist (cadr lexp)]) |
---|
1143 | (if (and (proper-list? llist) (= (length llist) (length args))) |
---|
1144 | (walk `(,(macro-alias 'let se) |
---|
1145 | ,(map list llist args) ,@(cddr lexp)) se dest) |
---|
1146 | (let ((var (gensym 't))) |
---|
1147 | (walk |
---|
1148 | `(,(macro-alias 'let se) |
---|
1149 | ((,var ,(car x))) |
---|
1150 | (,var ,@(cdr x)) ) |
---|
1151 | se dest) ) ) ) ) ) |
---|
1152 | |
---|
1153 | (else |
---|
1154 | (emit-syntax-trace-info x #f) |
---|
1155 | (mapwalk x se)) ) ) |
---|
1156 | |
---|
1157 | (define (mapwalk xs se) |
---|
1158 | (map (lambda (x) (walk x se #f)) xs) ) |
---|
1159 | |
---|
1160 | (when (memq 'c debugging-chicken) (newline) (pretty-print exp)) |
---|
1161 | (##sys#clear-trace-buffer) |
---|
1162 | ;; Process visited definitions and main expression: |
---|
1163 | (walk |
---|
1164 | `(,(macro-alias 'begin '()) |
---|
1165 | ,@(let ([p (reverse pending-canonicalizations)]) |
---|
1166 | (set! pending-canonicalizations '()) |
---|
1167 | p) |
---|
1168 | ,(begin |
---|
1169 | (set! extended-bindings (append internal-bindings extended-bindings)) |
---|
1170 | exp) ) |
---|
1171 | '() #f) ) |
---|
1172 | |
---|
1173 | |
---|
1174 | (define (process-declaration spec se) ; se unused in the moment |
---|
1175 | (define (check-decl spec minlen . maxlen) |
---|
1176 | (let ([n (length (cdr spec))]) |
---|
1177 | (if (or (< n minlen) (> n (optional maxlen 99999))) |
---|
1178 | (syntax-error "invalid declaration" spec) ) ) ) |
---|
1179 | (call-with-current-continuation |
---|
1180 | (lambda (return) |
---|
1181 | (unless (pair? spec) |
---|
1182 | (syntax-error "invalid declaration specification" spec) ) |
---|
1183 | (case (car spec) |
---|
1184 | ((uses) |
---|
1185 | (let ((us (cdr spec))) |
---|
1186 | (apply register-feature! us) |
---|
1187 | (when (pair? us) |
---|
1188 | (##sys#hash-table-update! file-requirements 'uses (cut lset-union eq? us <>) (lambda () us)) |
---|
1189 | (let ((units (map (lambda (u) (string->c-identifier (stringify u))) us))) |
---|
1190 | (set! used-units (append used-units units)) ) ) ) ) |
---|
1191 | ((unit) |
---|
1192 | (check-decl spec 1 1) |
---|
1193 | (let* ([u (cadr spec)] |
---|
1194 | [un (string->c-identifier (stringify u))] ) |
---|
1195 | (##sys#hash-table-set! file-requirements 'unit u) |
---|
1196 | (when (and unit-name (not (string=? unit-name un))) |
---|
1197 | (compiler-warning 'usage "unit was already given a name (new name is ignored)") ) |
---|
1198 | (set! unit-name un) ) ) |
---|
1199 | ((standard-bindings) |
---|
1200 | (if (null? (cdr spec)) |
---|
1201 | (set! standard-bindings default-standard-bindings) |
---|
1202 | (set! standard-bindings (append (cdr spec) standard-bindings)) ) ) |
---|
1203 | ((extended-bindings) |
---|
1204 | (if (null? (cdr spec)) |
---|
1205 | (set! extended-bindings default-extended-bindings) |
---|
1206 | (set! extended-bindings (append (cdr spec) extended-bindings)) ) ) |
---|
1207 | ((usual-integrations) |
---|
1208 | (cond [(null? (cdr spec)) |
---|
1209 | (set! standard-bindings default-standard-bindings) |
---|
1210 | (set! extended-bindings default-extended-bindings) ] |
---|
1211 | [else |
---|
1212 | (let ([syms (cdr spec)]) |
---|
1213 | (set! standard-bindings (lset-intersection eq? syms default-standard-bindings)) |
---|
1214 | (set! extended-bindings (lset-intersection eq? syms default-extended-bindings)) ) ] ) ) |
---|
1215 | ((number-type) |
---|
1216 | (check-decl spec 1 1) |
---|
1217 | (set! number-type (cadr spec))) |
---|
1218 | ((fixnum fixnum-arithmetic) (set! number-type 'fixnum)) |
---|
1219 | ((generic) (set! number-type 'generic)) |
---|
1220 | ((unsafe) |
---|
1221 | (set! unsafe #t)) |
---|
1222 | ((safe) (set! unsafe #f)) |
---|
1223 | ((no-bound-checks) (set! no-bound-checks #t)) |
---|
1224 | ((no-argc-checks) (set! no-argc-checks #t)) |
---|
1225 | ((no-procedure-checks) (set! no-procedure-checks #t)) |
---|
1226 | ((interrupts-enabled) (set! insert-timer-checks #t)) |
---|
1227 | ((disable-interrupts) (set! insert-timer-checks #f)) |
---|
1228 | ((disable-warning) |
---|
1229 | (set! disabled-warnings |
---|
1230 | (append (cdr spec) disabled-warnings))) |
---|
1231 | ((always-bound) |
---|
1232 | (set! always-bound (append (cdr spec) always-bound))) |
---|
1233 | ((safe-globals) (set! safe-globals-flag #t)) |
---|
1234 | ((no-procedure-checks-for-usual-bindings) |
---|
1235 | (set! always-bound-to-procedure |
---|
1236 | (append default-standard-bindings default-extended-bindings always-bound-to-procedure)) |
---|
1237 | (set! always-bound |
---|
1238 | (append default-standard-bindings default-extended-bindings always-bound)) ) |
---|
1239 | ((bound-to-procedure) |
---|
1240 | (let ((vars (cdr spec))) |
---|
1241 | (set! always-bound-to-procedure (append vars always-bound-to-procedure)) |
---|
1242 | (set! always-bound (append vars always-bound)) ) ) |
---|
1243 | ((foreign-declare) |
---|
1244 | (let ([fds (cdr spec)]) |
---|
1245 | (if (every string? fds) |
---|
1246 | (set! foreign-declarations (append foreign-declarations fds)) |
---|
1247 | (syntax-error "invalid declaration" spec) ) ) ) |
---|
1248 | ((custom-declare) |
---|
1249 | (if (or (not (list? spec)) (not (list? (cadr spec))) (< (length (cadr spec)) 3)) |
---|
1250 | (syntax-error "invalid declaration" spec) |
---|
1251 | (process-custom-declaration (cadr spec) (cddr spec)) ) ) |
---|
1252 | ((c-options) |
---|
1253 | (emit-control-file-item `(c-options ,@(cdr spec))) ) |
---|
1254 | ((link-options) |
---|
1255 | (emit-control-file-item `(link-options ,@(cdr spec))) ) |
---|
1256 | ((post-process) |
---|
1257 | (emit-control-file-item |
---|
1258 | (let ([file (pathname-strip-extension source-filename)]) |
---|
1259 | `(post-process ,@(map (cut string-substitute "\\$@" file <>) (cdr spec))) ) ) ) |
---|
1260 | ((block) (set! block-compilation #t)) |
---|
1261 | ((separate) (set! block-compilation #f)) |
---|
1262 | ((keep-shadowed-macros) (set! undefine-shadowed-macros #f)) |
---|
1263 | ((unused) |
---|
1264 | (set! unused-variables (append (cdr spec) unused-variables))) |
---|
1265 | ((not) |
---|
1266 | (check-decl spec 1) |
---|
1267 | (case (second spec) |
---|
1268 | [(standard-bindings) |
---|
1269 | (if (null? (cddr spec)) |
---|
1270 | (set! standard-bindings '()) |
---|
1271 | (set! standard-bindings |
---|
1272 | (lset-difference eq? default-standard-bindings |
---|
1273 | (cddr spec)))) ] |
---|
1274 | [(extended-bindings) |
---|
1275 | (if (null? (cddr spec)) |
---|
1276 | (set! extended-bindings '()) |
---|
1277 | (set! extended-bindings |
---|
1278 | (lset-difference eq? default-extended-bindings |
---|
1279 | (cddr spec)) )) ] |
---|
1280 | [(inline) |
---|
1281 | (if (null? (cddr spec)) |
---|
1282 | (set! inline-max-size -1) |
---|
1283 | (set! not-inline-list (lset-union eq? not-inline-list |
---|
1284 | (cddr spec))) ) ] |
---|
1285 | [(usual-integrations) |
---|
1286 | (cond [(null? (cddr spec)) |
---|
1287 | (set! standard-bindings '()) |
---|
1288 | (set! extended-bindings '()) ] |
---|
1289 | [else |
---|
1290 | (let ([syms (cddr spec)]) |
---|
1291 | (set! standard-bindings (lset-difference eq? default-standard-bindings syms)) |
---|
1292 | (set! extended-bindings (lset-difference eq? default-extended-bindings syms)) ) ] ) ] |
---|
1293 | [else |
---|
1294 | (check-decl spec 1 1) |
---|
1295 | (let ((id (cadr spec))) |
---|
1296 | (case id |
---|
1297 | [(interrupts-enabled) (set! insert-timer-checks #f)] |
---|
1298 | [(safe) |
---|
1299 | (set! unsafe #t)] |
---|
1300 | [else (compiler-warning 'syntax "illegal declaration specifier `~s'" id)]))])) |
---|
1301 | ((run-time-macros compile-syntax) ;*** run-time-macros is DEPRECATED |
---|
1302 | (set! ##sys#enable-runtime-macros #t)) |
---|
1303 | ((block-global hide) |
---|
1304 | (let ([syms (cdr spec)]) |
---|
1305 | (when export-list |
---|
1306 | (set! export-list (lset-difference eq? export-list syms)) ) |
---|
1307 | (set! block-globals (lset-union eq? syms block-globals)) ) ) |
---|
1308 | ((export) |
---|
1309 | (let ((syms (cdr spec))) |
---|
1310 | (set! block-globals (lset-difference eq? block-globals syms)) |
---|
1311 | (set! export-list (lset-union eq? syms (or export-list '()))))) |
---|
1312 | ((emit-external-prototypes-first) |
---|
1313 | (set! external-protos-first #t) ) |
---|
1314 | ((lambda-lift) (set! do-lambda-lifting #t)) |
---|
1315 | ((inline) |
---|
1316 | (if (null? (cdr spec)) |
---|
1317 | (unless (> inline-max-size -1) |
---|
1318 | (set! inline-max-size default-inline-max-size) ) |
---|
1319 | (set! inline-list (lset-union eq? inline-list (cdr spec)))) ) |
---|
1320 | ((inline-limit) |
---|
1321 | (check-decl spec 1 1) |
---|
1322 | (let ([n (cadr spec)]) |
---|
1323 | (if (number? n) |
---|
1324 | (set! inline-max-size n) |
---|
1325 | (compiler-warning |
---|
1326 | 'syntax |
---|
1327 | "invalid argument to `inline-limit' declaration: ~s" spec) ) ) ) |
---|
1328 | ((constant) |
---|
1329 | (let ((syms (cdr spec))) |
---|
1330 | (if (every symbol? syms) |
---|
1331 | (set! constant-declarations (append syms constant-declarations)) |
---|
1332 | (quit "invalid arguments to `constant' declaration: ~S" spec)) ) ) |
---|
1333 | ((emit-import-library) |
---|
1334 | (set! import-libraries |
---|
1335 | (append |
---|
1336 | import-libraries |
---|
1337 | (map (lambda (il) |
---|
1338 | (cond ((symbol? il) |
---|
1339 | (cons il (string-append (symbol->string il) ".import.scm")) ) |
---|
1340 | ((and (list? il) (= 2 (length il)) |
---|
1341 | (symbol? (car il)) (string (cadr il))) |
---|
1342 | (cons (car il) (cadr il))) |
---|
1343 | (else |
---|
1344 | (compiler-warning |
---|
1345 | 'syntax |
---|
1346 | "invalid import-library specification: ~s" il)))) |
---|
1347 | (cdr spec))))) |
---|
1348 | (else (compiler-warning 'syntax "illegal declaration specifier `~s'" spec)) ) |
---|
1349 | '(##core#undefined) ) ) ) |
---|
1350 | |
---|
1351 | |
---|
1352 | ;;; Expand "foreign-lambda"/"foreign-callback-lambda" forms and add item to stub-list: |
---|
1353 | |
---|
1354 | (define-record-type foreign-stub |
---|
1355 | (make-foreign-stub id return-type name argument-types argument-names body cps callback) |
---|
1356 | foreign-stub? |
---|
1357 | (id foreign-stub-id) ; symbol |
---|
1358 | (return-type foreign-stub-return-type) ; type-specifier |
---|
1359 | (name foreign-stub-name) ; string or #f |
---|
1360 | (argument-types foreign-stub-argument-types) ; (type-specifier...) |
---|
1361 | (argument-names foreign-stub-argument-names) ; #f or (symbol ...) |
---|
1362 | (body foreign-stub-body) ; #f or string |
---|
1363 | (cps foreign-stub-cps) ; boolean |
---|
1364 | (callback foreign-stub-callback)) ; boolean |
---|
1365 | |
---|
1366 | (define (create-foreign-stub rtype sname argtypes argnames body callback cps) |
---|
1367 | (let* ([params (list-tabulate (length argtypes) (lambda (x) (gensym 'a)))] |
---|
1368 | [f-id (gensym 'stub)] |
---|
1369 | [bufvar (gensym)] |
---|
1370 | [rsize (estimate-foreign-result-size rtype)] ) |
---|
1371 | (set-real-name! f-id #t) |
---|
1372 | (set! foreign-lambda-stubs |
---|
1373 | (cons (make-foreign-stub f-id rtype sname argtypes argnames body cps callback) |
---|
1374 | foreign-lambda-stubs) ) |
---|
1375 | (let ([rsize (if callback (+ rsize 24) rsize)] ; 24 -> has to hold cons on 64-bit platforms! |
---|
1376 | [head (if cps |
---|
1377 | `((##core#primitive ,f-id)) |
---|
1378 | `(##core#inline ,f-id) ) ] |
---|
1379 | [rest (map (lambda (p t) (foreign-type-check (foreign-type-convert-argument p t) t)) params argtypes)] ) |
---|
1380 | `(lambda ,params |
---|
1381 | ;; Do minor GC (if callback) to make room on stack: |
---|
1382 | ,@(if callback '((##sys#gc #f)) '()) |
---|
1383 | ,(if (zero? rsize) |
---|
1384 | (foreign-type-convert-result (append head (cons '(##core#undefined) rest)) rtype) |
---|
1385 | (let ([ft (final-foreign-type rtype)] |
---|
1386 | [ws (words rsize)] ) |
---|
1387 | `(let ([,bufvar (##core#inline_allocate ("C_a_i_bytevector" ,(+ 2 ws)) ',ws)]) |
---|
1388 | ,(foreign-type-convert-result |
---|
1389 | (finish-foreign-result ft (append head (cons bufvar rest))) |
---|
1390 | rtype) ) ) ) ) ) ) ) |
---|
1391 | |
---|
1392 | (define (expand-foreign-lambda exp) |
---|
1393 | (let* ([name (third exp)] |
---|
1394 | [sname (cond ((symbol? name) (symbol->string name)) |
---|
1395 | ((string? name) name) |
---|
1396 | (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ] |
---|
1397 | [rtype (second exp)] |
---|
1398 | [argtypes (cdddr exp)] ) |
---|
1399 | (create-foreign-stub rtype sname argtypes #f #f #f #f) ) ) |
---|
1400 | |
---|
1401 | (define (expand-foreign-callback-lambda exp) |
---|
1402 | (let* ([name (third exp)] |
---|
1403 | [sname (cond ((symbol? name) (symbol->string name)) |
---|
1404 | ((string? name) name) |
---|
1405 | (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ] |
---|
1406 | [rtype (second exp)] |
---|
1407 | [argtypes (cdddr exp)] ) |
---|
1408 | (create-foreign-stub rtype sname argtypes #f #f #t #t) ) ) |
---|
1409 | |
---|
1410 | (define (expand-foreign-lambda* exp) |
---|
1411 | (let* ([rtype (second exp)] |
---|
1412 | [args (third exp)] |
---|
1413 | [body (apply string-append (cdddr exp))] |
---|
1414 | [argtypes (map car args)] |
---|
1415 | [argnames (map cadr args)] ) |
---|
1416 | (create-foreign-stub rtype #f argtypes argnames body #f #f) ) ) |
---|
1417 | |
---|
1418 | (define (expand-foreign-callback-lambda* exp) |
---|
1419 | (let* ([rtype (second exp)] |
---|
1420 | [args (third exp)] |
---|
1421 | [body (apply string-append (cdddr exp))] |
---|
1422 | [argtypes (map car args)] |
---|
1423 | [argnames (map cadr args)] ) |
---|
1424 | (create-foreign-stub rtype #f argtypes argnames body #t #t) ) ) |
---|
1425 | |
---|
1426 | (define (expand-foreign-primitive exp) |
---|
1427 | (let* ([hasrtype (and (pair? (cddr exp)) (not (string? (caddr exp))))] |
---|
1428 | [rtype (if hasrtype (second exp) 'void)] |
---|
1429 | [args (if hasrtype (third exp) (second exp))] |
---|
1430 | [body (apply string-append (if hasrtype (cdddr exp) (cddr exp)))] |
---|
1431 | [argtypes (map car args)] |
---|
1432 | [argnames (map cadr args)] ) |
---|
1433 | (create-foreign-stub rtype #f argtypes argnames body #f #t) ) ) |
---|
1434 | |
---|
1435 | |
---|
1436 | ;;; Traverse expression and update line-number db with all contained calls: |
---|
1437 | |
---|
1438 | (define (update-line-number-database! exp ln) |
---|
1439 | (define (mapupdate xs) |
---|
1440 | (let loop ((xs xs)) |
---|
1441 | (if (pair? xs) |
---|
1442 | (begin |
---|
1443 | (walk (car xs)) |
---|
1444 | (loop (cdr xs)) ) ) ) ) |
---|
1445 | (define (walk x) |
---|
1446 | (cond ((not-pair? x)) |
---|
1447 | ((symbol? (car x)) |
---|
1448 | (let* ((name (car x)) |
---|
1449 | (old (or (##sys#hash-table-ref ##sys#line-number-database name) '())) ) |
---|
1450 | (if (not (assq x old)) |
---|
1451 | (##sys#hash-table-set! ##sys#line-number-database name (alist-cons x ln old)) ) |
---|
1452 | (mapupdate (cdr x)) ) ) |
---|
1453 | (else (mapupdate x)) ) ) |
---|
1454 | (walk exp) ) |
---|
1455 | |
---|
1456 | |
---|
1457 | ;;; Convert canonicalized node-graph into continuation-passing-style: |
---|
1458 | |
---|
1459 | (define (perform-cps-conversion node) |
---|
1460 | |
---|
1461 | (define (cps-lambda id llist subs k) |
---|
1462 | (let ([t1 (gensym 'k)]) |
---|
1463 | (k (make-node |
---|
1464 | '##core#lambda (list id #t (cons t1 llist) 0) |
---|
1465 | (list (walk (car subs) |
---|
1466 | (lambda (r) |
---|
1467 | (make-node '##core#call '(#t) (list (varnode t1) r)) ) ) ) ) ) ) ) |
---|
1468 | |
---|
1469 | (define (walk n k) |
---|
1470 | (let ((subs (node-subexpressions n)) |
---|
1471 | (params (node-parameters n)) |
---|
1472 | (class (node-class n)) ) |
---|
1473 | (case (node-class n) |
---|
1474 | ((##core#variable quote ##core#undefined ##core#primitive ##core#global-ref) (k n)) |
---|
1475 | ((if) (let* ((t1 (gensym 'k)) |
---|
1476 | (t2 (gensym 'r)) |
---|
1477 | (k1 (lambda (r) (make-node '##core#call '(#t) (list (varnode t1) r)))) ) |
---|
1478 | (make-node 'let |
---|
1479 | (list t1) |
---|
1480 | (list (make-node '##core#lambda (list (gensym-f-id) #f (list t2) 0) |
---|
1481 | (list (k (varnode t2))) ) |
---|
1482 | (walk (car subs) |
---|
1483 | (lambda (v) |
---|
1484 | (make-node 'if '() |
---|
1485 | (list v |
---|
1486 | (walk (cadr subs) k1) |
---|
1487 | (walk (caddr subs) k1) ) ) ) ) ) ) ) ) |
---|
1488 | ((let) (let loop ((vars params) (vals subs)) |
---|
1489 | (if (null? vars) |
---|
1490 | (walk (car vals) k) |
---|
1491 | (walk (car vals) |
---|
1492 | (lambda (r) |
---|
1493 | (make-node 'let |
---|
1494 | (list (car vars)) |
---|
1495 | (list r (loop (cdr vars) (cdr vals))) ) ) ) ) ) ) |
---|
1496 | ((lambda) (cps-lambda (gensym-f-id) (first params) subs k)) |
---|
1497 | ((set!) (let ((t1 (gensym 't))) |
---|
1498 | (walk (car subs) |
---|
1499 | (lambda (r) |
---|
1500 | (make-node 'let (list t1) |
---|
1501 | (list (make-node 'set! (list (first params)) (list r)) |
---|
1502 | (k (varnode t1)) ) ) ) ) ) ) |
---|
1503 | ((##core#foreign-callback-wrapper) |
---|
1504 | (let ([id (gensym-f-id)] |
---|
1505 | [lam (first subs)] ) |
---|
1506 | (set! foreign-callback-stubs |
---|
1507 | (cons (apply make-foreign-callback-stub id params) foreign-callback-stubs) ) |
---|
1508 | (cps-lambda id (first (node-parameters lam)) (node-subexpressions lam) k) ) ) |
---|
1509 | ((##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update ##core#inline_loc_ref |
---|
1510 | ##core#inline_loc_update) |
---|
1511 | (walk-inline-call class params subs k) ) |
---|
1512 | ((##core#call) (walk-call (car subs) (cdr subs) params k)) |
---|
1513 | ((##core#callunit) (walk-call-unit (first params) k)) |
---|
1514 | (else (bomb "bad node (cps)")) ) ) ) |
---|
1515 | |
---|
1516 | (define (walk-call fn args params k) |
---|
1517 | (let ((t0 (gensym 'k)) |
---|
1518 | (t3 (gensym 'r)) ) |
---|
1519 | (make-node |
---|
1520 | 'let (list t0) |
---|
1521 | (list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0) |
---|
1522 | (list (k (varnode t3))) ) |
---|
1523 | (walk-arguments |
---|
1524 | args |
---|
1525 | (lambda (vars) |
---|
1526 | (walk fn |
---|
1527 | (lambda (r) |
---|
1528 | (make-node '##core#call params (cons* r (varnode t0) vars) ) ) ) ) ) ) ) ) ) |
---|
1529 | |
---|
1530 | (define (walk-call-unit unitname k) |
---|
1531 | (let ((t0 (gensym 'k)) |
---|
1532 | (t3 (gensym 'r)) ) |
---|
1533 | (make-node |
---|
1534 | 'let (list t0) |
---|
1535 | (list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0) |
---|
1536 | (list (k (varnode t3))) ) |
---|
1537 | (make-node '##core#callunit (list unitname) |
---|
1538 | (list (varnode t0)) ) ) ) ) ) |
---|
1539 | |
---|
1540 | (define (walk-inline-call class op args k) |
---|
1541 | (walk-arguments |
---|
1542 | args |
---|
1543 | (lambda (vars) |
---|
1544 | (k (make-node class op vars)) ) ) ) |
---|
1545 | |
---|
1546 | (define (walk-arguments args wk) |
---|
1547 | (let loop ((args args) (vars '())) |
---|
1548 | (cond ((null? args) (wk (reverse vars))) |
---|
1549 | ((atomic? (car args)) |
---|
1550 | (loop (cdr args) (cons (car args) vars)) ) |
---|
1551 | (else |
---|
1552 | (let ((t1 (gensym 'a))) |
---|
1553 | (walk (car args) |
---|
1554 | (lambda (r) |
---|
1555 | (make-node 'let (list t1) |
---|
1556 | (list r |
---|
1557 | (loop (cdr args) |
---|
1558 | (cons (varnode t1) vars) ) ) ) ) ) ) ) ) ) ) |
---|
1559 | |
---|
1560 | (define (atomic? n) |
---|
1561 | (let ((class (node-class n))) |
---|
1562 | (or (memq class '(quote ##core#variable ##core#undefined ##core#global-ref)) |
---|
1563 | (and (memq class '(##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update |
---|
1564 | ##core#inline_loc_ref ##core#inline_loc_update)) |
---|
1565 | (every atomic? (node-subexpressions n)) ) ) ) ) |
---|
1566 | |
---|
1567 | (walk node values) ) |
---|
1568 | |
---|
1569 | |
---|
1570 | ;;; Foreign callback stub type: |
---|
1571 | |
---|
1572 | (define-record-type foreign-callback-stub |
---|
1573 | (make-foreign-callback-stub id name qualifiers return-type argument-types) |
---|
1574 | foreign-callback-stub? |
---|
1575 | (id foreign-callback-stub-id) ; symbol |
---|
1576 | (name foreign-callback-stub-name) ; string |
---|
1577 | (qualifiers foreign-callback-stub-qualifiers) ; string |
---|
1578 | (return-type foreign-callback-stub-return-type) ; type-specifier |
---|
1579 | (argument-types foreign-callback-stub-argument-types)) ; (type-specifier ...) |
---|
1580 | |
---|
1581 | |
---|
1582 | ;;; Perform source-code analysis: |
---|
1583 | |
---|
1584 | (define (analyze-expression node) |
---|
1585 | (let ([db (make-vector analysis-database-size '())] |
---|
1586 | [explicitly-consed '()] ) |
---|
1587 | |
---|
1588 | (define (grow n) |
---|
1589 | (set! current-program-size (+ current-program-size n)) ) |
---|
1590 | |
---|
1591 | (define (walk n env localenv here call) |
---|
1592 | (let ((subs (node-subexpressions n)) |
---|
1593 | (params (node-parameters n)) |
---|
1594 | (class (node-class n)) ) |
---|
1595 | (grow 1) |
---|
1596 | (case class |
---|
1597 | ((quote ##core#undefined ##core#proc) #f) |
---|
1598 | |
---|
1599 | ((##core#variable) |
---|
1600 | (let ((var (first params))) |
---|
1601 | (ref var n) |
---|
1602 | (unless (memq var localenv) |
---|
1603 | (grow 1) |
---|
1604 | (cond ((memq var env) (put! db var 'captured #t)) |
---|
1605 | ((not (get db var 'global)) (put! db var 'global #t) ) ) ) ) ) |
---|
1606 | |
---|
1607 | ((##core#global-ref) |
---|
1608 | (let ((var (first params))) |
---|
1609 | (ref var n) |
---|
1610 | (grow 1) |
---|
1611 | (put! db var 'global #t) ) ) |
---|
1612 | |
---|
1613 | ((##core#callunit ##core#recurse) |
---|
1614 | (grow 1) |
---|
1615 | (walkeach subs env localenv here #f) ) |
---|
1616 | |
---|
1617 | ((##core#call) |
---|
1618 | (grow 1) |
---|
1619 | (let ([fun (car subs)]) |
---|
1620 | (if (eq? '##core#variable (node-class fun)) |
---|
1621 | (let ([name (first (node-parameters fun))]) |
---|
1622 | (collect! db name 'call-sites (cons here n)) |
---|
1623 | ;; If call to standard-binding & optimizable rest-arg operator: decrease access count: |
---|
1624 | (if (and (get db name 'standard-binding) |
---|
1625 | (memq name optimizable-rest-argument-operators) ) |
---|
1626 | (for-each |
---|
1627 | (lambda (arg) |
---|
1628 | (and-let* ([(eq? '##core#variable (node-class arg))] |
---|
1629 | [var (first (node-parameters arg))] ) |
---|
1630 | (when (get db var 'rest-parameter) (count! db var 'o-r/access-count)) ) ) |
---|
1631 | (cdr subs) ) ) ) ) |
---|
1632 | (walk (first subs) env localenv here #t) |
---|
1633 | (walkeach (cdr subs) env localenv here #f) ) ) |
---|
1634 | |
---|
1635 | ((let) |
---|
1636 | (let ([env2 (append params localenv env)]) |
---|
1637 | (let loop ([vars params] [vals subs]) |
---|
1638 | (if (null? vars) |
---|
1639 | (walk (car vals) env (append params localenv) here #f) |
---|
1640 | (let ([var (car vars)] |
---|
1641 | [val (car vals)] ) |
---|
1642 | (put! db var 'home here) |
---|
1643 | (assign var val env2 here) |
---|
1644 | (walk val env localenv here #f) |
---|
1645 | (loop (cdr vars) (cdr vals)) ) ) ) ) ) |
---|
1646 | |
---|
1647 | ((lambda) ; will this actually be ever used? aren't all lambdas now ##core#lambdas? |
---|
1648 | (grow 1) |
---|
1649 | (decompose-lambda-list |
---|
1650 | (first params) |
---|
1651 | (lambda (vars argc rest) |
---|
1652 | (for-each |
---|
1653 | (lambda (var) (put! db var 'unknown #t)) |
---|
1654 | vars) |
---|
1655 | (let ([tl toplevel-scope]) |
---|
1656 | (set! toplevel-scope #f) |
---|
1657 | (walk (car subs) (append localenv env) vars #f #f) |
---|
1658 | (set! toplevel-scope tl) ) ) ) ) |
---|
1659 | |
---|
1660 | ((##core#lambda ##core#direct_lambda) |
---|
1661 | (grow 1) |
---|
1662 | (decompose-lambda-list |
---|
1663 | (third params) |
---|
1664 | (lambda (vars argc rest) |
---|
1665 | (let ([id (first params)] |
---|
1666 | [size0 current-program-size] ) |
---|
1667 | (when here |
---|
1668 | (collect! db here 'contains id) |
---|
1669 | (put! db id 'contained-in here) ) |
---|
1670 | (for-each |
---|
1671 | (lambda (var) |
---|
1672 | (put! db var 'home here) |
---|
1673 | (put! db var 'unknown #t) ) |
---|
1674 | vars) |
---|
1675 | (when rest |
---|
1676 | (put! db rest 'rest-parameter |
---|
1677 | (if (memq rest rest-parameters-promoted-to-vector) |
---|
1678 | 'vector |
---|
1679 | 'list) ) ) |
---|
1680 | (when (simple-lambda-node? n) (put! db id 'simple #t)) |
---|
1681 | (let ([tl toplevel-scope]) |
---|
1682 | (unless toplevel-lambda-id (set! toplevel-lambda-id id)) |
---|
1683 | (when (and (second params) (not (eq? toplevel-lambda-id id))) |
---|
1684 | (set! toplevel-scope #f)) ; only if non-CPS lambda |
---|
1685 | (walk (car subs) (append localenv env) vars id #f) |
---|
1686 | (set! toplevel-scope tl) |
---|
1687 | (set-car! (cdddr (node-parameters n)) (- current-program-size size0)) ) ) ) ) ) |
---|
1688 | |
---|
1689 | ((set!) |
---|
1690 | (let* ([var (first params)] |
---|
1691 | [val (car subs)] ) |
---|
1692 | (when first-analysis |
---|
1693 | (cond [(get db var 'standard-binding) |
---|
1694 | (compiler-warning 'redef "redefinition of standard binding `~S'" var) ] |
---|
1695 | [(get db var 'extended-binding) |
---|
1696 | (compiler-warning 'redef "redefinition of extended binding `~S'" var) ] ) |
---|
1697 | (put! db var 'potential-value val) ) |
---|
1698 | (when (and (not (memq var localenv)) |
---|
1699 | (not (memq var env)) ) |
---|
1700 | (grow 1) |
---|
1701 | (when first-analysis |
---|
1702 | (when (or block-compilation (and export-list (not (memq var export-list)))) |
---|
1703 | (set! block-globals (lset-adjoin eq? block-globals var)) ) ) |
---|
1704 | (put! db var 'global #t) ) |
---|
1705 | (assign var val (append localenv env) here) |
---|
1706 | (unless toplevel-scope (put! db var 'assigned-locally #t)) |
---|
1707 | (put! db var 'assigned #t) |
---|
1708 | (walk (car subs) env localenv here #f) ) ) |
---|
1709 | |
---|
1710 | ((##core#primitive ##core#inline) |
---|
1711 | (let ([id (first params)]) |
---|
1712 | (when (and first-analysis here (symbol? id) (##sys#hash-table-ref real-name-table id)) |
---|
1713 | (set-real-name! id here) ) |
---|
1714 | (walkeach subs env localenv here #f) ) ) |
---|
1715 | |
---|
1716 | (else (walkeach subs env localenv here #f)) ) ) ) |
---|
1717 | |
---|
1718 | (define (walkeach xs env lenv here call) |
---|
1719 | (for-each (lambda (x) (walk x env lenv here call)) xs) ) |
---|
1720 | |
---|
1721 | (define (assign var val env here) |
---|
1722 | (cond ((eq? '##core#undefined (node-class val)) |
---|
1723 | (put! db var 'undefined #t) ) |
---|
1724 | ((and (eq? '##core#variable (node-class val)) |
---|
1725 | (eq? var (first (node-parameters val))) ) ) |
---|
1726 | ((or block-compilation |
---|
1727 | (memq var env) |
---|
1728 | (get db var 'constant) |
---|
1729 | ;;(memq var inline-list) - would be nice, but might be customized... |
---|
1730 | (memq var block-globals) ) |
---|
1731 | (let ((props (get-all db var 'unknown 'value)) |
---|
1732 | (home (get db var 'home)) ) |
---|
1733 | (unless (assq 'unknown props) |
---|
1734 | (if (assq 'value props) |
---|
1735 | (put! db var 'unknown #t) |
---|
1736 | (if (or (not home) (eq? here home)) |
---|
1737 | (put! db var 'value val) |
---|
1738 | (put! db var 'unknown #t) ) ) ) ) ) |
---|
1739 | (else (put! db var 'unknown #t)) ) ) |
---|
1740 | |
---|
1741 | (define (ref var node) |
---|
1742 | (collect! db var 'references node) ) |
---|
1743 | |
---|
1744 | (define (quick-put! plist prop val) |
---|
1745 | (set-cdr! plist (alist-cons prop val (cdr plist))) ) |
---|
1746 | |
---|
1747 | ;; Return true if <id> directly or indirectly contains any of <other-ids>: |
---|
1748 | (define (contains? id other-ids) |
---|
1749 | (or (memq id other-ids) |
---|
1750 | (let ((clist (get db id 'contains))) |
---|
1751 | (and clist |
---|
1752 | (any (lambda (id2) (contains? id2 other-ids)) clist) ) ) ) ) |
---|
1753 | |
---|
1754 | ;; Initialize database: |
---|
1755 | (initialize-analysis-database db) |
---|
1756 | |
---|
1757 | ;; Walk toplevel expression-node: |
---|
1758 | (debugging 'p "analysis traversal phase...") |
---|
1759 | (set! current-program-size 0) |
---|
1760 | (walk node '() '() #f #f) |
---|
1761 | |
---|
1762 | ;; Complete gathered database information: |
---|
1763 | (debugging 'p "analysis gathering phase...") |
---|
1764 | (##sys#hash-table-for-each |
---|
1765 | (lambda (sym plist) |
---|
1766 | (let ([unknown #f] |
---|
1767 | [value #f] |
---|
1768 | [pvalue #f] |
---|
1769 | [references '()] |
---|
1770 | [captured #f] |
---|
1771 | [call-sites '()] |
---|
1772 | [assigned #f] |
---|
1773 | [assigned-locally #f] |
---|
1774 | [undefined #f] |
---|
1775 | [global #f] |
---|
1776 | [o-r/access-count 0] |
---|
1777 | [rest-parameter #f] |
---|
1778 | [nreferences 0] |
---|
1779 | [ncall-sites 0] ) |
---|
1780 | |
---|
1781 | (for-each |
---|
1782 | (lambda (prop) |
---|
1783 | (case (car prop) |
---|
1784 | [(unknown) (set! unknown #t)] |
---|
1785 | [(references) |
---|
1786 | (set! references (cdr prop)) |
---|
1787 | (set! nreferences (length references)) ] |
---|
1788 | [(captured) (set! captured #t)] |
---|
1789 | [(potential-value) (set! pvalue (cdr prop))] |
---|
1790 | [(call-sites) |
---|
1791 | (set! call-sites (cdr prop)) |
---|
1792 | (set! ncall-sites (length call-sites)) ] |
---|
1793 | [(assigned) (set! assigned #t)] |
---|
1794 | [(assigned-locally) (set! assigned-locally #t)] |
---|
1795 | [(undefined) (set! undefined #t)] |
---|
1796 | [(global) (set! global #t)] |
---|
1797 | [(value) (set! value (cdr prop))] |
---|
1798 | [(o-r/access-count) (set! o-r/access-count (cdr prop))] |
---|
1799 | [(rest-parameter) (set! rest-parameter #t)] ) ) |
---|
1800 | plist) |
---|
1801 | |
---|
1802 | (set! value (and (not unknown) value)) |
---|
1803 | |
---|
1804 | ;; If this is the first analysis, register known local or potentially known global lambda-value id's |
---|
1805 | ;; along with their names: |
---|
1806 | (when (and first-analysis |
---|
1807 | (eq? '##core#lambda |
---|
1808 | (and-let* ([val (or value (and global pvalue))]) |
---|
1809 | (node-class val) ) ) ) |
---|
1810 | (set-real-name! (first (node-parameters (or value pvalue))) sym) ) |
---|
1811 | |
---|
1812 | ;; If this is the first analysis and the variable is global and has no references and we are |
---|
1813 | ;; in block mode, then issue warning: |
---|
1814 | (when (and first-analysis |
---|
1815 | global |
---|
1816 | (null? references) |
---|
1817 | (not (memq sym unused-variables))) |
---|
1818 | (when assigned-locally |
---|
1819 | (compiler-warning 'var "local assignment to unused variable `~S' may be unintended" sym) ) |
---|
1820 | (when (and (or block-compilation |
---|
1821 | (and export-list (not (memq sym export-list))) ) |
---|
1822 | (not (assq sym mutable-constants)) ) |
---|
1823 | (compiler-warning 'var "global variable `~S' is never used" sym) ) ) |
---|
1824 | |
---|
1825 | ;; Make 'boxed, if 'assigned & 'captured: |
---|
1826 | (when (and assigned captured) |
---|
1827 | (quick-put! plist 'boxed #t) ) |
---|
1828 | |
---|
1829 | ;; Make 'contractable, if it has a procedure as known value, has only one use and one call-site and |
---|
1830 | ;; if the lambda has no free non-global variables or is an internal lambda. Make 'inlinable if |
---|
1831 | ;; use/call count is not 1: |
---|
1832 | (when value |
---|
1833 | (let ((valparams (node-parameters value))) |
---|
1834 | (when (and (eq? '##core#lambda (node-class value)) |
---|
1835 | (or (not (second valparams)) |
---|
1836 | (every (lambda (v) (get db v 'global)) (scan-free-variables value)) ) ) |
---|
1837 | (if (and (= 1 nreferences) (= 1 ncall-sites)) |
---|
1838 | (quick-put! plist 'contractable #t) |
---|
1839 | (quick-put! plist 'inlinable #t) ) ) ) ) |
---|
1840 | |
---|
1841 | ;; Make 'collapsable, if it has a known constant value which is either collapsable or is only |
---|
1842 | ;; referenced once and if no assignments are made: |
---|
1843 | (when (and value |
---|
1844 | ;; (not (assq 'assigned plist)) - If it has a known value, it's assigned just once! |
---|
1845 | (eq? 'quote (node-class value)) ) |
---|
1846 | (let ((val (first (node-parameters value)))) |
---|
1847 | (when (or (collapsable-literal? val) |
---|
1848 | (= 1 nreferences) ) |
---|
1849 | (quick-put! plist 'collapsable #t) ) ) ) |
---|
1850 | |
---|
1851 | ;; If it has a known value that is a procedure, and if the number of call-sites is equal to the |
---|
1852 | ;; number of references (does not escape), then make all formal parameters 'unused which are |
---|
1853 | ;; never referenced or assigned (if no rest parameter exist): |
---|
1854 | ;; - also marks the procedure as 'has-unused-parameters (if not in `callback-names') |
---|
1855 | ;; - if the procedure is internal (a continuation) do NOT mark unused parameters. |
---|
1856 | ;; - also: if procedure has rest-parameter and no unused params, mark f-id as 'explicit-rest. |
---|
1857 | (when value |
---|
1858 | (let ([has #f]) |
---|
1859 | (when (and (eq? '##core#lambda (node-class value)) |
---|
1860 | (= nreferences ncall-sites) ) |
---|
1861 | (let ([lparams (node-parameters value)]) |
---|
1862 | (when (second lparams) |
---|
1863 | (decompose-lambda-list |
---|
1864 | (third lparams) |
---|
1865 | (lambda (vars argc rest) |
---|
1866 | (unless rest |
---|
1867 | (for-each |
---|
1868 | (lambda (var) |
---|
1869 | (cond [(and (not (get db var 'references)) |
---|
1870 | (not (get db var 'assigned)) ) |
---|
1871 | (put! db var 'unused #t) |
---|
1872 | (set! has #t) |
---|
1873 | #t] |
---|
1874 | [else #f] ) ) |
---|
1875 | vars) ) |
---|
1876 | (cond [(and has (not (memq sym callback-names))) |
---|
1877 | (put! db (first lparams) 'has-unused-parameters #t) ] |
---|
1878 | [rest |
---|
1879 | (set! explicitly-consed (cons rest explicitly-consed)) |
---|
1880 | (put! db (first lparams) 'explicit-rest #t) ] ) ) ) ) ) ) ) ) |
---|
1881 | |
---|
1882 | ;; Make 'removable, if it has no references and is not assigned to, and if it has either a value that |
---|
1883 | ;; does not cause any side-effects or if it is 'undefined: |
---|
1884 | (when (and (not assigned) |
---|
1885 | (null? references) |
---|
1886 | (or (and value |
---|
1887 | (or (not (eq? '##core#variable (node-class value))) |
---|
1888 | (not (get db (first (node-parameters value)) 'global)) ) |
---|
1889 | (not (expression-has-side-effects? value db)) ) |
---|
1890 | undefined) ) |
---|
1891 | (quick-put! plist 'removable #t) ) |
---|
1892 | |
---|
1893 | ;; Make 'replacable, if it has a variable as known value and if either that variable has |
---|
1894 | ;; a known value itself, or if it is not captured and referenced only once, the target and |
---|
1895 | ;; the source are never assigned and the source is non-global or we are in block-mode: |
---|
1896 | ;; - The target-variable is not allowed to be global. |
---|
1897 | ;; - The variable that can be substituted for the current one is marked as 'replacing. |
---|
1898 | ;; This is done to prohibit beta-contraction of the replacing variable (It wouldn't be there, if |
---|
1899 | ;; it was contracted). |
---|
1900 | (when (and value (not global)) |
---|
1901 | (when (eq? '##core#variable (node-class value)) |
---|
1902 | (let* ([name (first (node-parameters value))] |
---|
1903 | [nrefs (get db name 'references)] ) |
---|
1904 | (when (or (and (not (get db name 'unknown)) (get db name 'value)) |
---|
1905 | (and (not (get db name 'captured)) |
---|
1906 | nrefs |
---|
1907 | (= 1 (length nrefs)) |
---|
1908 | (not assigned) |
---|
1909 | (not (get db name 'assigned)) |
---|
1910 | (or block-compilation (not (get db name 'global))) ) ) |
---|
1911 | (quick-put! plist 'replacable name) |
---|
1912 | (put! db name 'replacing #t) ) ) ) ) |
---|
1913 | |
---|
1914 | ;; Make 'replacable, if it has a known value of the form: '(lambda (<xvar>) (<kvar> <xvar>))' and |
---|
1915 | ;; is an internally created procedure: (See above for 'replacing) |
---|
1916 | (when (and value (eq? '##core#lambda (node-class value))) |
---|
1917 | (let ([params (node-parameters value)]) |
---|
1918 | (when (not (second params)) |
---|
1919 | (let ([llist (third params)] |
---|
1920 | [body (first (node-subexpressions value))] ) |
---|
1921 | (when (and (pair? llist) |
---|
1922 | (null? (cdr llist)) |
---|
1923 | (eq? '##core#call (node-class body)) ) |
---|
1924 | (let ([subs (node-subexpressions body)]) |
---|
1925 | (when (= 2 (length subs)) |
---|
1926 | (let ([v1 (first subs)] |
---|
1927 | [v2 (second subs)] ) |
---|
1928 | (when (and (eq? '##core#variable (node-class v1)) |
---|
1929 | (eq? '##core#variable (node-class v2)) |
---|
1930 | (eq? (first llist) (first (node-parameters v2))) ) |
---|
1931 | (let ([kvar (first (node-parameters v1))]) |
---|
1932 | (quick-put! plist 'replacable kvar) |
---|
1933 | (put! db kvar 'replacing #t) ) ) ) ) ) ) ) ) ) ) |
---|
1934 | |
---|
1935 | ;; If a rest-argument, convert 'rest-parameter property to 'vector, if the variable is never |
---|
1936 | ;; assigned, and the number of references is identical to the number of accesses in optimizable |
---|
1937 | ;; rest-argument operators: |
---|
1938 | ;; - Add variable to "rest-parameters-promoted-to-vector", because subsequent optimization will |
---|
1939 | ;; change variables context (operators applied to it). |
---|
1940 | (when (and rest-parameter |
---|
1941 | (not assigned) |
---|
1942 | (= nreferences o-r/access-count) ) |
---|
1943 | (set! rest-parameters-promoted-to-vector (lset-adjoin eq? rest-parameters-promoted-to-vector sym)) |
---|
1944 | (put! db sym 'rest-parameter 'vector) ) ) ) |
---|
1945 | |
---|
1946 | db) |
---|
1947 | |
---|
1948 | ;; Remove explicitly consed rest parameters from promoted ones: |
---|
1949 | (set! rest-parameters-promoted-to-vector |
---|
1950 | (lset-difference eq? rest-parameters-promoted-to-vector explicitly-consed) ) |
---|
1951 | |
---|
1952 | ;; Set original program-size, if this is the first analysis-pass: |
---|
1953 | (unless original-program-size |
---|
1954 | (set! original-program-size current-program-size) ) |
---|
1955 | db) ) |
---|
1956 | |
---|
1957 | |
---|
1958 | ;;; Convert closures to explicit data structures (effectively flattens function-binding structure): |
---|
1959 | |
---|
1960 | (define (perform-closure-conversion node db) |
---|
1961 | (let ([direct-calls 0] |
---|
1962 | [customizable '()] ) |
---|
1963 | |
---|
1964 | (define (test sym item) (get db sym item)) |
---|
1965 | |
---|
1966 | (define (register-customizable! var id) |
---|
1967 | (set! customizable (lset-adjoin eq? customizable var)) |
---|
1968 | (put! db id 'customizable #t) ) |
---|
1969 | |
---|
1970 | (define (register-direct-call! id) |
---|
1971 | (set! direct-calls (add1 direct-calls)) |
---|
1972 | (set! direct-call-ids (lset-adjoin eq? direct-call-ids id)) ) |
---|
1973 | |
---|
1974 | ;; Gather free-variable information: |
---|
1975 | ;; (and: - register direct calls |
---|
1976 | ;; - update (by mutation) call information in "##core#call" nodes) |
---|
1977 | (define (gather n here env) |
---|
1978 | (let ((subs (node-subexpressions n)) |
---|
1979 | (params (node-parameters n)) ) |
---|
1980 | (case (node-class n) |
---|
1981 | |
---|
1982 | ((quote ##core#variable ##core#undefined ##core#proc ##core#primitive ##core#global-ref) #f) |
---|
1983 | |
---|
1984 | ((let) |
---|
1985 | (receive (vals body) (split-at subs (length params)) |
---|
1986 | (for-each (lambda (n) (gather n here env)) vals) |
---|
1987 | (gather (first body) here (append params env)) ) ) |
---|
1988 | |
---|
1989 | ((##core#call) |
---|
1990 | (let* ([fn (first subs)] |
---|
1991 | [mode (first params)] |
---|
1992 | [name (and (pair? (cdr params)) (second params))] |
---|
1993 | [varfn (eq? '##core#variable (node-class fn))] ) |
---|
1994 | (node-parameters-set! |
---|
1995 | n |
---|
1996 | (cons mode |
---|
1997 | (if (or name varfn) |
---|
1998 | (cons name |
---|
1999 | (if varfn |
---|
2000 | (let* ([varname (first (node-parameters fn))] |
---|
2001 | [val (and (not (test varname 'unknown)) (test varname 'value))] ) |
---|
2002 | (if (and val (eq? '##core#lambda (node-class val))) |
---|
2003 | (let* ([params (node-parameters val)] |
---|
2004 | [llist (third params)] |
---|
2005 | [id (first params)] |
---|
2006 | [refs (test varname 'references)] |
---|
2007 | [sites (test varname 'call-sites)] |
---|
2008 | [custom |
---|
2009 | (and refs sites |
---|
2010 | (= (length refs) (length sites)) |
---|
2011 | (proper-list? llist) ) ] ) |
---|
2012 | (when (and name custom (not (= (length llist) (length (cdr subs))))) |
---|
2013 | (quit |
---|
2014 | "known procedure called with wrong number of arguments: ~A" |
---|
2015 | (source-info->string name) ) ) |
---|
2016 | (register-direct-call! id) |
---|
2017 | (when custom (register-customizable! varname id)) |
---|
2018 | (list id custom) ) |
---|
2019 | '() ) ) |
---|
2020 | '() ) ) |
---|
2021 | '() ) ) ) |
---|
2022 | (for-each (lambda (n) (gather n here env)) subs) ) ) |
---|
2023 | |
---|
2024 | ((##core#lambda ##core#direct_lambda) |
---|
2025 | (decompose-lambda-list |
---|
2026 | (third params) |
---|
2027 | (lambda (vars argc rest) |
---|
2028 | (let* ([id (if here (first params) 'toplevel)] |
---|
2029 | [capturedvars (captured-variables (car subs) env)] |
---|
2030 | [csize (length capturedvars)] ) |
---|
2031 | (put! db id 'closure-size csize) |
---|
2032 | (put! db id 'captured-variables capturedvars) |
---|
2033 | (gather (car subs) id (append vars env)) ) ) ) ) |
---|
2034 | |
---|
2035 | (else (for-each (lambda (n) (gather n here env)) subs)) ) ) ) |
---|
2036 | |
---|
2037 | ;; Create explicit closures: |
---|
2038 | (define (transform n here closure) |
---|
2039 | (let ((subs (node-subexpressions n)) |
---|
2040 | (params (node-parameters n)) |
---|
2041 | (class (node-class n)) ) |
---|
2042 | (case class |
---|
2043 | |
---|
2044 | ((quote ##core#undefined ##core#proc ##core#global-ref) n) |
---|
2045 | |
---|
2046 | ((##core#variable) |
---|
2047 | (let* ((var (first params)) |
---|
2048 | (val (ref-var n here closure)) ) |
---|
2049 | (if (test var 'boxed) |
---|
2050 | (make-node '##core#unbox '() (list val)) |
---|
2051 | val) ) ) |
---|
2052 | |
---|
2053 | ((if ##core#call ##core#inline ##core#inline_allocate ##core#callunit ##core#inline_ref ##core#inline_update |
---|
2054 | ##core#switch ##core#cond ##core#direct_call ##core#recurse ##core#return ##core#inline_loc_ref |
---|
2055 | ##core#inline_loc_update) |
---|
2056 | (make-node (node-class n) params (maptransform subs here closure)) ) |
---|
2057 | |
---|
2058 | ((let) |
---|
2059 | (let* ([var (first params)] |
---|
2060 | [boxedvar (test var 'boxed)] |
---|
2061 | [boxedalias (gensym var)] ) |
---|
2062 | (if boxedvar |
---|
2063 | (make-node |
---|
2064 | 'let (list boxedalias) |
---|
2065 | (list (transform (first subs) here closure) |
---|
2066 | (make-node |
---|
2067 | 'let (list var) |
---|
2068 | (list (make-node '##core#box '() (list (varnode boxedalias))) |
---|
2069 | (transform (second subs) here closure) ) ) ) ) |
---|
2070 | (make-node |
---|
2071 | 'let params |
---|
2072 | (maptransform subs here closure) ) ) ) ) |
---|
2073 | |
---|
2074 | ((##core#lambda ##core#direct_lambda) |
---|
2075 | (let ([llist (third params)]) |
---|
2076 | (decompose-lambda-list |
---|
2077 | llist |
---|
2078 | (lambda (vars argc rest) |
---|
2079 | (let* ([boxedvars (filter (lambda (v) (test v 'boxed)) vars)] |
---|
2080 | [boxedaliases (map cons boxedvars (map gensym boxedvars))] |
---|
2081 | [cvar (gensym 'c)] |
---|
2082 | [id (if here (first params) 'toplevel)] |
---|
2083 | [capturedvars (or (test id 'captured-variables) '())] |
---|
2084 | [csize (or (test id 'closure-size) 0)] |
---|
2085 | [info (and emit-closure-info (second params) (pair? llist))] ) |
---|
2086 | ;; If rest-parameter is boxed: mark it as 'boxed-rest |
---|
2087 | ;; (if we don't do this than preparation will think the (boxed) alias |
---|
2088 | ;; of the rest-parameter is never used) |
---|
2089 | (and-let* ([rest] |
---|
2090 | [(test rest 'boxed)] |
---|
2091 | [rp (test rest 'rest-parameter)] ) |
---|
2092 | (put! db (cdr (assq rest boxedaliases)) 'boxed-rest #t) ) |
---|
2093 | (make-node |
---|
2094 | '##core#closure (list (+ csize (if info 2 1))) |
---|
2095 | (cons |
---|
2096 | (make-node |
---|
2097 | class |
---|
2098 | (list id |
---|
2099 | (second params) |
---|
2100 | (cons |
---|
2101 | cvar |
---|
2102 | (build-lambda-list |
---|
2103 | (map (lambda (v) |
---|
2104 | (cond ((assq v boxedaliases) => cdr) |
---|
2105 | (else v) ) ) |
---|
2106 | vars) |
---|
2107 | argc |
---|
2108 | (cond ((and rest (assq rest boxedaliases)) => cdr) |
---|
2109 | (else rest) ) ) ) |
---|
2110 | (fourth params) ) |
---|
2111 | (list (let ((body (transform (car subs) cvar capturedvars))) |
---|
2112 | (if (pair? boxedvars) |
---|
2113 | (fold-right |
---|
2114 | (lambda (alias val body) (make-node 'let (list alias) (list val body))) |
---|
2115 | body |
---|
2116 | (unzip1 boxedaliases) |
---|
2117 | (map (lambda (a) (make-node '##core#box '() (list (varnode (cdr a))))) |
---|
2118 | boxedaliases) ) |
---|
2119 | body) ) ) ) |
---|
2120 | (let ((cvars (map (lambda (v) (ref-var (varnode v) here closure)) |
---|
2121 | capturedvars) ) ) |
---|
2122 | (if info |
---|
2123 | (append |
---|
2124 | cvars |
---|
2125 | (list |
---|
2126 | (qnode |
---|
2127 | (##sys#make-lambda-info |
---|
2128 | (->string (cons (or (real-name id) '?) |
---|
2129 | (cdr llist) )))))) ; this is not always correct, due to optimizations |
---|
2130 | cvars) ) ) ) ) ) ) ) ) |
---|
2131 | |
---|
2132 | ((set!) |
---|
2133 | (let* ([var (first params)] |
---|
2134 | [val (first subs)] |
---|
2135 | [cval (node-class val)] |
---|
2136 | [immf (or (and (eq? 'quote cval) (immediate? (first (node-parameters val)))) |
---|
2137 | (eq? '##core#undefined cval) ) ] ) |
---|
2138 | (cond ((posq var closure) |
---|
2139 | => (lambda (i) |
---|
2140 | (if (test var 'boxed) |
---|
2141 | (make-node |
---|
2142 | (if immf '##core#updatebox_i '##core#updatebox) |
---|
2143 | '() |
---|
2144 | (list (make-node '##core#ref (list (add1 i)) (list (varnode here))) |
---|
2145 | (transform val here closure) ) ) |
---|
2146 | ;; Is the following actually used??? |
---|
2147 | (make-node |
---|
2148 | (if immf '##core#update_i '##core#update) |
---|
2149 | (list (add1 i)) |
---|
2150 | (list (varnode here) |
---|
2151 | (transform val here closure) ) ) ) ) ) |
---|
2152 | ((test var 'boxed) |
---|
2153 | (make-node |
---|
2154 | (if immf '##core#updatebox_i '##core#updatebox) |
---|
2155 | '() |
---|
2156 | (list (varnode var) |
---|
2157 | (transform val here closure) ) ) ) |
---|
2158 | (else (make-node |
---|
2159 | 'set! (list var) |
---|
2160 | (list (transform val here closure) ) ) ) ) ) ) |
---|
2161 | |
---|
2162 | ((##core#primitive) |
---|
2163 | (make-node |
---|
2164 | '##core#closure (list (if emit-closure-info 2 1)) |
---|
2165 | (cons (make-node '##core#proc (list (car params) #t) '()) |
---|
2166 | (if emit-closure-info |
---|
2167 | (list (qnode (##sys#make-lambda-info (car params)))) |
---|
2168 | '() ) ) ) ) |
---|
2169 | |
---|
2170 | (else (bomb "bad node (closure2)")) ) ) ) |
---|
2171 | |
---|
2172 | (define (maptransform xs here closure) |
---|
2173 | (map (lambda (x) (transform x here closure)) xs) ) |
---|
2174 | |
---|
2175 | (define (ref-var n here closure) |
---|
2176 | (let ((var (first (node-parameters n)))) |
---|
2177 | (cond ((posq var closure) |
---|
2178 | => (lambda (i) |
---|
2179 | (make-node '##core#ref (list (+ i 1)) |
---|
2180 | (list (varnode here)) ) ) ) |
---|
2181 | (else n) ) ) ) |
---|
2182 | |
---|
2183 | (define (captured-variables node env) |
---|
2184 | (let ([vars '()]) |
---|
2185 | (let walk ([n node]) |
---|
2186 | (let ((subs (node-subexpressions n)) |
---|
2187 | (params (node-parameters n)) ) |
---|
2188 | (case (node-class n) |
---|
2189 | ((##core#variable) |
---|
2190 | (let ([var (first params)]) |
---|
2191 | (when (memq var env) |
---|
2192 | (set! vars (lset-adjoin eq? vars var)) ) ) ) |
---|
2193 | ((quote ##core#undefined ##core#primitive ##core#proc ##core#inline_ref ##core#global-ref) #f) |
---|
2194 | ((set!) |
---|
2195 | (let ([var (first params)]) |
---|
2196 | (when (memq var env) (set! vars (lset-adjoin eq? vars var))) |
---|
2197 | (walk (car subs)) ) ) |
---|
2198 | (else (for-each walk subs)) ) ) ) |
---|
2199 | vars) ) |
---|
2200 | |
---|
2201 | (debugging 'p "closure conversion gathering phase...") |
---|
2202 | (gather node #f '()) |
---|
2203 | (debugging 'o "customizable procedures" customizable) |
---|
2204 | (debugging 'p "closure conversion transformation phase...") |
---|
2205 | (let ((node2 (transform node #f #f))) |
---|
2206 | (unless (zero? direct-calls) |
---|
2207 | (debugging 'o "calls to known targets" direct-calls (delay (length direct-call-ids))) ) |
---|
2208 | node2) ) ) |
---|
2209 | |
---|
2210 | |
---|
2211 | ;;; Do some preparations before code-generation can commence: |
---|
2212 | |
---|
2213 | (define-record-type lambda-literal |
---|
2214 | (make-lambda-literal id external arguments argument-count rest-argument temporaries |
---|
2215 | callee-signatures allocated directly-called closure-size |
---|
2216 | looping customizable rest-argument-mode body direct) |
---|
2217 | lambda-literal? |
---|
2218 | (id lambda-literal-id) ; symbol |
---|
2219 | (external lambda-literal-external) ; boolean |
---|
2220 | (arguments lambda-literal-arguments) ; (symbol...) |
---|
2221 | (argument-count lambda-literal-argument-count) ; integer |
---|
2222 | (rest-argument lambda-literal-rest-argument) ; symbol | #f |
---|
2223 | (temporaries lambda-literal-temporaries) ; integer |
---|
2224 | (callee-signatures lambda-literal-callee-signatures) ; (integer...) |
---|
2225 | (allocated lambda-literal-allocated) ; integer |
---|
2226 | (directly-called lambda-literal-directly-called) ; boolean |
---|
2227 | (closure-size lambda-literal-closure-size) ; integer |
---|
2228 | (looping lambda-literal-looping) ; boolean |
---|
2229 | (customizable lambda-literal-customizable) ; boolean |
---|
2230 | (rest-argument-mode lambda-literal-rest-argument-mode) ; #f | LIST | VECTOR | UNUSED |
---|
2231 | (body lambda-literal-body) ; expression |
---|
2232 | (direct lambda-literal-direct)) ; boolean |
---|
2233 | |
---|
2234 | (define (prepare-for-code-generation node db) |
---|
2235 | (let ([literals '()] |
---|
2236 | [lambda-info-literals '()] |
---|
2237 | [lambdas '()] |
---|
2238 | [temporaries 0] |
---|
2239 | [allocated 0] |
---|
2240 | [looping 0] |
---|
2241 | [signatures '()] |
---|
2242 | [fastinits 0] |
---|
2243 | [fastrefs 0] |
---|
2244 | [fastsets 0] ) |
---|
2245 | |
---|
2246 | (define (walk-var var e sf) |
---|
2247 | (cond [(posq var e) => (lambda (i) (make-node '##core#local (list i) '()))] |
---|
2248 | [(keyword? var) (make-node '##core#literal (list (literal var)) '())] |
---|
2249 | [else (walk-global var sf)] ) ) |
---|
2250 | |
---|
2251 | (define (walk-global var sf) |
---|
2252 | (let* ([safe (or sf |
---|
2253 | no-bound-checks |
---|
2254 | unsafe |
---|
2255 | (memq var always-bound) |
---|
2256 | (get db var 'standard-binding) |
---|
2257 | (get db var 'extended-binding) ) ] |
---|
2258 | [blockvar (memq var block-globals)] ) |
---|
2259 | (when blockvar (set! fastrefs (add1 fastrefs))) |
---|
2260 | (make-node |
---|
2261 | '##core#global |
---|
2262 | (list (if blockvar |
---|
2263 | (blockvar-literal var) |
---|
2264 | (literal var) ) |
---|
2265 | safe |
---|
2266 | blockvar |
---|
2267 | var) |
---|
2268 | '() ) ) ) |
---|
2269 | |
---|
2270 | (define (walk n e here boxes) |
---|
2271 | (let ((subs (node-subexpressions n)) |
---|
2272 | (params (node-parameters n)) |
---|
2273 | (class (node-class n)) ) |
---|
2274 | (case class |
---|
2275 | |
---|
2276 | ((##core#undefined ##core#proc) n) |
---|
2277 | |
---|
2278 | ((##core#variable) |
---|
2279 | (walk-var (first params) e #f) ) |
---|
2280 | |
---|
2281 | ((##core#global-ref) |
---|
2282 | (walk-global (first params) #t) ) |
---|
2283 | |
---|
2284 | ((##core#direct_call) |
---|
2285 | (set! allocated (+ allocated (fourth params))) |
---|
2286 | (make-node class params (mapwalk subs e here boxes)) ) |
---|
2287 | |
---|
2288 | ((##core#inline_allocate) |
---|
2289 | (set! allocated (+ allocated (second params))) |
---|
2290 | (make-node class params (mapwalk subs e here boxes)) ) |
---|
2291 | |
---|
2292 | ((##core#inline_ref) |
---|
2293 | (set! allocated (+ allocated (words (estimate-foreign-result-size (second params))))) |
---|
2294 | (make-node class params '()) ) |
---|
2295 | |
---|
2296 | ((##core#inline_loc_ref) |
---|
2297 | (set! allocated (+ allocated (words (estimate-foreign-result-size (first params))))) |
---|
2298 | (make-node class params (mapwalk subs e here boxes)) ) |
---|
2299 | |
---|
2300 | ((##core#closure) |
---|
2301 | (set! allocated (+ allocated (first params) 1)) |
---|
2302 | (make-node '##core#closure params (mapwalk subs e here boxes)) ) |
---|
2303 | |
---|
2304 | ((##core#box) |
---|
2305 | (set! allocated (+ allocated 2)) |
---|
2306 | (make-node '##core#box params (list (walk (first subs) e here boxes))) ) |
---|
2307 | |
---|
2308 | ((##core#updatebox) |
---|
2309 | (let* ([b (first subs)] |
---|
2310 | [subs (mapwalk subs e here boxes)] ) |
---|
2311 | (make-node |
---|
2312 | (cond [(and (eq? '##core#variable (node-class b)) |
---|
2313 | (memq (first (node-parameters b)) boxes) ) |
---|
2314 | (set! fastinits (add1 fastinits)) |
---|
2315 | '##core#updatebox_i] |
---|
2316 | [else class] ) |
---|
2317 | '() |
---|
2318 | subs) ) ) |
---|
2319 | |
---|
2320 | ((##core#lambda ##core#direct_lambda) |
---|
2321 | (let ([temps temporaries] |
---|
2322 | [sigs signatures] |
---|
2323 | [lping looping] |
---|
2324 | [alc allocated] |
---|
2325 | [direct (eq? class '##core#direct_lambda)] ) |
---|
2326 | (set! temporaries 0) |
---|
2327 | (set! allocated 0) |
---|
2328 | (set! signatures '()) |
---|
2329 | (set! looping 0) |
---|
2330 | (decompose-lambda-list |
---|
2331 | (third params) |
---|
2332 | (lambda (vars argc rest) |
---|
2333 | (let* ([id (first params)] |
---|
2334 | [rest-mode |
---|
2335 | (and rest |
---|
2336 | (let ([rrefs (get db rest 'references)]) |
---|
2337 | (cond [(get db rest 'assigned) 'list] |
---|
2338 | [(and (not (get db rest 'boxed-rest)) (or (not rrefs) (null? rrefs))) 'none] |
---|
2339 | [else (get db rest 'rest-parameter)] ) ) ) ] |
---|
2340 | [body (walk |
---|
2341 | (car subs) |
---|
2342 | (if (eq? 'none rest-mode) |
---|
2343 | (butlast vars) |
---|
2344 | vars) |
---|
2345 | id |
---|
2346 | '()) ] ) |
---|
2347 | (case rest-mode |
---|
2348 | [(none) (debugging 'o "unused rest argument" rest id)] |
---|
2349 | [(vector) (debugging 'o "rest argument accessed as vector" rest id)] ) |
---|
2350 | (when (and direct rest) |
---|
2351 | (bomb "bad direct lambda" id allocated rest) ) |
---|
2352 | (set! lambdas |
---|
2353 | (cons (make-lambda-literal |
---|
2354 | id |
---|
2355 | (second params) |
---|
2356 | vars |
---|
2357 | argc |
---|
2358 | rest |
---|
2359 | (add1 temporaries) |
---|
2360 | signatures |
---|
2361 | allocated |
---|
2362 | (or direct (memq id direct-call-ids)) |
---|
2363 | (or (get db id 'closure-size) 0) |
---|
2364 | (and (not rest) |
---|
2365 | (> looping 0) |
---|
2366 | (begin |
---|
2367 | (debugging 'o "identified direct recursive calls" id looping) |
---|
2368 | #t) ) |
---|
2369 | (or direct (get db id 'customizable)) |
---|
2370 | rest-mode |
---|
2371 | body |
---|
2372 | direct) |
---|
2373 | lambdas) ) |
---|
2374 | (set! looping lping) |
---|
2375 | (set! temporaries temps) |
---|
2376 | (set! allocated alc) |
---|
2377 | (set! signatures sigs) |
---|
2378 | (make-node '##core#proc (list (first params)) '()) ) ) ) ) ) |
---|
2379 | |
---|
2380 | ((let) |
---|
2381 | (let* ([var (first params)] |
---|
2382 | [val (first subs)] |
---|
2383 | [boxvars (if (eq? '##core#box (node-class val)) (list var) '())] ) |
---|
2384 | (set! temporaries (add1 temporaries)) |
---|
2385 | (make-node |
---|
2386 | '##core#bind (list 1) |
---|
2387 | (list (walk val e here boxes) |
---|
2388 | (walk (second subs) (append e params) here (append boxvars boxes)) ) ) ) ) |
---|
2389 | |
---|
2390 | ((set!) |
---|
2391 | (let ([var (first params)] |
---|
2392 | [val (first subs)] ) |
---|
2393 | (cond ((posq var e) |
---|
2394 | => (lambda (i) |
---|
2395 | (make-node '##core#setlocal (list i) (list (walk val e here boxes)) ) ) ) |
---|
2396 | (else |
---|
2397 | (let* ([cval (node-class val)] |
---|
2398 | [safe (not (or no-bound-checks |
---|
2399 | unsafe |
---|
2400 | (memq var always-bound) |
---|
2401 | (get db var 'standard-binding) |
---|
2402 | (get db var 'extended-binding) ) ) ] |
---|
2403 | [blockvar (memq var block-globals)] |
---|
2404 | [immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val)))) |
---|
2405 | (eq? '##core#undefined cval) ) ] ) |
---|
2406 | (when blockvar (set! fastsets (add1 fastsets))) |
---|
2407 | (make-node |
---|
2408 | (if immf '##core#setglobal_i '##core#setglobal) |
---|
2409 | (list (if blockvar |
---|
2410 | (blockvar-literal var) |
---|
2411 | (literal var) ) |
---|
2412 | blockvar |
---|
2413 | var) |
---|
2414 | (list (walk (car subs) e here boxes)) ) ) ) ) ) ) |
---|
2415 | |
---|
2416 | ((##core#call) |
---|
2417 | (let ([len (length (cdr subs))]) |
---|
2418 | (set! signatures (lset-adjoin = signatures len)) |
---|
2419 | (when (and (>= (length params) 3) (eq? here (third params))) |
---|
2420 | (set! looping (add1 looping)) ) |
---|
2421 | (make-node class params (mapwalk subs e here boxes)) ) ) |
---|
2422 | |
---|
2423 | ((##core#recurse) |
---|
2424 | (when (first params) (set! looping (add1 looping))) |
---|
2425 | (make-node class params (mapwalk subs e here boxes)) ) |
---|
2426 | |
---|
2427 | ((quote) |
---|
2428 | (let ((c (first params))) |
---|
2429 | (cond ((and (fixnum? c) (not (big-fixnum? c))) |
---|
2430 | (immediate-literal c) ) |
---|
2431 | ((number? c) |
---|
2432 | (cond ((eq? 'fixnum number-type) |
---|
2433 | (cond ((and (integer? c) (not (big-fixnum? c))) |
---|
2434 | (compiler-warning |
---|
2435 | 'type |
---|
2436 | "coerced inexact literal number `~S' to fixnum ~S" c (inexact->exact c)) |
---|
2437 | (immediate-literal (inexact->exact c)) ) |
---|
2438 | (else (quit "can not coerce inexact literal `~S' to fixnum" c)) ) ) |
---|
2439 | (else (make-node '##core#literal (list (literal c)) '())) ) ) |
---|
2440 | ((immediate? c) (immediate-literal c)) |
---|
2441 | (else (make-node '##core#literal (list (literal c)) '())) ) ) ) |
---|
2442 | |
---|
2443 | (else (make-node class params (mapwalk subs e here boxes)) ) ) ) ) |
---|
2444 | |
---|
2445 | (define (mapwalk xs e here boxes) |
---|
2446 | (map (lambda (x) (walk x e here boxes)) xs) ) |
---|
2447 | |
---|
2448 | (define (literal x) |
---|
2449 | (cond [(immediate? x) (immediate-literal x)] |
---|
2450 | [(number? x) |
---|
2451 | (or (and (inexact? x) |
---|
2452 | (list-index (lambda (y) (and (number? y) (inexact? y) (= x y))) |
---|
2453 | literals) ) |
---|
2454 | (new-literal x)) ] |
---|
2455 | ((##core#inline "C_lambdainfop" x) |
---|
2456 | (let ((i (length lambda-info-literals))) |
---|
2457 | (set! lambda-info-literals |
---|
2458 | (append lambda-info-literals (list x))) ;*** see below |
---|
2459 | (vector i) ) ) |
---|
2460 | [(posq x literals) => identity] |
---|
2461 | [else (new-literal x)] ) ) |
---|
2462 | |
---|
2463 | (define (new-literal x) |
---|
2464 | (let ([i (length literals)]) |
---|
2465 | (set! literals (append literals (list x))) ;*** could (should) be optimized |
---|
2466 | i) ) |
---|
2467 | |
---|
2468 | (define (blockvar-literal var) |
---|
2469 | (or (list-index |
---|
2470 | (lambda (lit) |
---|
2471 | (and (block-variable-literal? lit) |
---|
2472 | (eq? var (block-variable-literal-name lit)) ) ) |
---|
2473 | literals) |
---|
2474 | (new-literal (make-block-variable-literal var)) ) ) |
---|
2475 | |
---|
2476 | (define (immediate-literal x) |
---|
2477 | (if (eq? (void) x) |
---|
2478 | (make-node '##core#undefined '() '()) |
---|
2479 | (make-node '##core#immediate |
---|
2480 | (cond ((fixnum? x) `(fix ,x)) |
---|
2481 | ((boolean? x) `(bool ,x)) |
---|
2482 | ((char? x) `(char ,x)) |
---|
2483 | ((null? x) '(nil)) |
---|
2484 | ((eof-object? x) '(eof)) |
---|
2485 | (else (bomb "bad immediate (prepare)")) ) |
---|
2486 | '() ) ) ) |
---|
2487 | |
---|
2488 | (debugging 'p "preparation phase...") |
---|
2489 | (let ((node2 (walk node '() #f '()))) |
---|
2490 | (debugging 'o "fast box initializations" fastinits) |
---|
2491 | (debugging 'o "fast global references" fastrefs) |
---|
2492 | (debugging 'o "fast global assignments" fastsets) |
---|
2493 | (values node2 literals lambda-info-literals lambdas) ) ) ) |
---|