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