1 | ;;;; c-platform.scm - Platform specific parameters and definitions |
---|
2 | ; |
---|
3 | ; Copyright (c) 2000-2007, Felix L. Winkelmann |
---|
4 | ; Copyright (c) 2008, The Chicken Team |
---|
5 | ; All rights reserved. |
---|
6 | ; |
---|
7 | ; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following |
---|
8 | ; conditions are met: |
---|
9 | ; |
---|
10 | ; Redistributions of source code must retain the above copyright notice, this list of conditions and the following |
---|
11 | ; disclaimer. |
---|
12 | ; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following |
---|
13 | ; disclaimer in the documentation and/or other materials provided with the distribution. |
---|
14 | ; Neither the name of the author nor the names of its contributors may be used to endorse or promote |
---|
15 | ; products derived from this software without specific prior written permission. |
---|
16 | ; |
---|
17 | ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS |
---|
18 | ; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY |
---|
19 | ; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR |
---|
20 | ; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR |
---|
21 | ; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
---|
22 | ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY |
---|
23 | ; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR |
---|
24 | ; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE |
---|
25 | ; POSSIBILITY OF SUCH DAMAGE. |
---|
26 | |
---|
27 | |
---|
28 | (declare (unit platform)) |
---|
29 | |
---|
30 | |
---|
31 | (private compiler |
---|
32 | compiler-arguments process-command-line |
---|
33 | default-standard-bindings default-extended-bindings side-effecting-standard-bindings |
---|
34 | non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings |
---|
35 | standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false |
---|
36 | installation-home debugging |
---|
37 | dump-nodes |
---|
38 | unit-name insert-timer-checks used-units inlining |
---|
39 | foreign-declarations block-compilation line-number-database-size |
---|
40 | target-heap-size target-stack-size |
---|
41 | default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size |
---|
42 | current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables |
---|
43 | rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants |
---|
44 | broken-constant-nodes inline-substitutions-enabled |
---|
45 | direct-call-ids foreign-type-table first-analysis |
---|
46 | initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database scan-toplevel-assignments |
---|
47 | perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization! |
---|
48 | reorganize-recursive-bindings substitution-table simplify-named-call find-inlining-candidates perform-inlining! |
---|
49 | perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub expand-foreign-lambda* |
---|
50 | transform-direct-lambdas! decompose-lambda-list rewrite |
---|
51 | debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list |
---|
52 | string->c-identifier c-ify-string words check-and-open-input-file close-checked-input-file fold-inner constant? |
---|
53 | collapsable-literal? immediate? canonicalize-begin-body extract-mutable-constants string->expr get get-all |
---|
54 | put! collect! count! get-line get-line-2 find-lambda-container display-analysis-database varnode qnode |
---|
55 | build-node-graph build-expression-tree fold-boolean inline-lambda-bindings match-node expression-has-side-effects? |
---|
56 | simple-lambda-node? compute-database-statistics print-program-statistics output gen gen-list |
---|
57 | pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables |
---|
58 | topological-sort print-version print-usage initialize-analysis-database |
---|
59 | default-declarations default-debugging-declarations units-used-by-default words-per-flonum |
---|
60 | parameter-limit eq-inline-operator optimizable-rest-argument-operators |
---|
61 | membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument |
---|
62 | target-include-file default-profiling-declarations |
---|
63 | default-optimization-passes internal-bindings big-fixnum? |
---|
64 | generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration |
---|
65 | foreign-argument-conversion foreign-result-conversion) |
---|
66 | |
---|
67 | |
---|
68 | (include "tweaks") |
---|
69 | |
---|
70 | |
---|
71 | ;;; Parameters: |
---|
72 | |
---|
73 | (define default-optimization-passes 3) |
---|
74 | |
---|
75 | (define default-declarations |
---|
76 | '((always-bound |
---|
77 | ##sys#standard-input ##sys#standard-output ##sys#standard-error) |
---|
78 | (bound-to-procedure |
---|
79 | ##sys#for-each ##sys#map ##sys#print ##sys#setter |
---|
80 | ##sys#setslot ##sys#dynamic-wind ##sys#call-with-values |
---|
81 | ##sys#start-timer ##sys#stop-timer ##sys#gcd ##sys#lcm ##sys#make-promise ##sys#structure? ##sys#slot |
---|
82 | ##sys#allocate-vector ##sys#list->vector ##sys#block-ref ##sys#block-set! |
---|
83 | ##sys#list ##sys#cons ##sys#append ##sys#vector ##sys#foreign-char-argument ##sys#foreign-fixnum-argument |
---|
84 | ##sys#foreign-flonum-argument ##sys#error ##sys#peek-c-string ##sys#peek-nonnull-c-string |
---|
85 | ##sys#peek-and-free-c-string ##sys#peek-and-free-nonnull-c-string |
---|
86 | ##sys#foreign-block-argument ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#foreign-integer-argument |
---|
87 | ##sys#call-with-current-continuation) ) ) |
---|
88 | |
---|
89 | (define default-debugging-declarations |
---|
90 | '((##core#declare |
---|
91 | '(uses debugger) |
---|
92 | '(bound-to-procedure |
---|
93 | ##sys#push-debug-frame ##sys#pop-debug-frame ##sys#check-debug-entry ##sys#check-debug-assignment |
---|
94 | ##sys#register-debug-lambdas ##sys#register-debug-variables ##sys#debug-call) ) ) ) |
---|
95 | |
---|
96 | (define default-profiling-declarations |
---|
97 | '((##core#declare |
---|
98 | '(uses profiler) |
---|
99 | '(bound-to-procedure |
---|
100 | ##sys#profile-entry ##sys#profile-exit) ) ) ) |
---|
101 | |
---|
102 | (define units-used-by-default '(library eval data-structures extras srfi-69)) |
---|
103 | (define words-per-flonum 4) |
---|
104 | (define parameter-limit 1024) |
---|
105 | (define small-parameter-limit 128) |
---|
106 | |
---|
107 | (define eq-inline-operator "C_eqp") |
---|
108 | (define optimizable-rest-argument-operators '(car cadr caddr cadddr length pair? null? list-ref)) |
---|
109 | (define membership-test-operators |
---|
110 | '(("C_i_memq" . "C_eqp") ("C_u_i_memq" . "C_eqp") ("C_i_member" . "C_i_equalp") |
---|
111 | ("C_i_memv" . "C_i_eqvp") ) ) |
---|
112 | (define membership-unfold-limit 20) |
---|
113 | (define target-include-file "chicken.h") |
---|
114 | |
---|
115 | (define valid-compiler-options |
---|
116 | '(-help h help version verbose explicit-use quiet no-trace no-warnings unsafe block |
---|
117 | check-syntax to-stdout no-usual-integrations case-insensitive no-lambda-info |
---|
118 | profile inline keep-shadowed-macros |
---|
119 | fixnum-arithmetic disable-interrupts optimize-leaf-routines check-imports |
---|
120 | lambda-lift compile-syntax tag-pointers accumulate-profile |
---|
121 | disable-stack-overflow-checks disable-c-syntax-checks unsafe-libraries raw |
---|
122 | emit-external-prototypes-first release disable-compiler-macros |
---|
123 | analyze-only dynamic extension) ) |
---|
124 | |
---|
125 | (define valid-compiler-options-with-argument |
---|
126 | '(debug output-file include-path heap-size stack-size unit uses keyword-style require-extension |
---|
127 | inline-limit profile-name disable-warning emit-exports import |
---|
128 | prelude postlude prologue epilogue nursery extend feature |
---|
129 | compress-literals ; DEPRECATED |
---|
130 | emit-import-library |
---|
131 | heap-growth heap-shrinkage heap-initial-size ffi-define ffi-include-path) ) |
---|
132 | |
---|
133 | |
---|
134 | ;;; Standard and extended bindings: |
---|
135 | |
---|
136 | (define default-standard-bindings |
---|
137 | '(not boolean? apply call-with-current-continuation eq? eqv? equal? pair? cons car cdr caar cadr |
---|
138 | cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar |
---|
139 | cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr! |
---|
140 | null? list list? length zero? * - + / - > < >= <= = current-output-port current-input-port |
---|
141 | write-char newline write display append symbol->string for-each map char? char->integer |
---|
142 | integer->char eof-object? vector-length string-length string-ref string-set! vector-ref |
---|
143 | vector-set! char=? char<? char>? char>=? char<=? gcd lcm reverse symbol? string->symbol |
---|
144 | number? complex? real? integer? rational? odd? even? positive? negative? exact? inexact? |
---|
145 | max min quotient remainder modulo floor ceiling truncate round exact->inexact inexact->exact |
---|
146 | exp log sin expt sqrt cos tan asin acos atan number->string string->number char-ci=? |
---|
147 | char-ci<? char-ci>? char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric? |
---|
148 | char-lower-case? char-upper-case? char-upcase char-downcase string? string=? string>? string<? |
---|
149 | string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=? |
---|
150 | string-append string->list list->string vector? vector->list list->vector string read |
---|
151 | read-char substring string-fill! vector-fill! make-string make-vector open-input-file |
---|
152 | open-output-file call-with-input-file call-with-output-file close-input-port close-output-port |
---|
153 | values call-with-values vector procedure? memq memv member assq assv assoc list-tail |
---|
154 | list-ref abs char-ready? peek-char list->string string->list) ) |
---|
155 | |
---|
156 | (define default-extended-bindings |
---|
157 | '(bitwise-and bitwise-ior bitwise-xor bitwise-not add1 sub1 fx+ fx- fx* fx/ fxmod |
---|
158 | fx= fx> fx< fx>= fx<= fixnum? fxneg fxmax fxmin identity fp+ fp- fp* fp/ fpmin fpmax fpneg |
---|
159 | fp> fp< fp= fp>= fp<= fxand fxnot fxior fxxor fxshr fxshl bit-set? |
---|
160 | arithmetic-shift void flush-output thread-specific thread-specific-set! |
---|
161 | not-pair? atom? null-list? print print* error cpu-time proper-list? call/cc |
---|
162 | u8vector->byte-vector s8vector->byte-vector u16vector->byte-vector s16vector->byte-vector ; DEPRECATED |
---|
163 | u32vector->byte-vector s32vector->byte-vector byte-vector-length ; DEPRECATED |
---|
164 | f32vector->byte-vector f64vector->byte-vector byte-vector-ref byte-vector-set! ; DEPRECATED |
---|
165 | blob-size u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared |
---|
166 | s16vector->blob/shared u32vector->blob/shared s32vector->blob/shared |
---|
167 | f32vector->blob/shared f64vector->blob/shared |
---|
168 | blob->u8vector/shared blob->s8vector/shared blob->u16vector/shared |
---|
169 | blob->s16vector/shared blob->u32vector/shared blob->s32vector/shared |
---|
170 | blob->f32vector/shared blob->f64vector/shared |
---|
171 | block-ref block-set! number-of-slots substring-index substring-index-ci |
---|
172 | hash-table-ref any? read-string substring=? substring-ci=? |
---|
173 | first second third fourth make-record-instance |
---|
174 | u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length |
---|
175 | f32vector-length f64vector-length setter |
---|
176 | u8vector-ref s8vector-ref u16vector-ref s16vector-ref u32vector-ref s32vector-ref |
---|
177 | f32vector-ref f64vector-ref |
---|
178 | u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set! |
---|
179 | locative-ref locative-set! locative->object locative? global-ref |
---|
180 | null-pointer? pointer->object flonum? finite?) ) |
---|
181 | |
---|
182 | (define internal-bindings |
---|
183 | '(##sys#slot ##sys#setslot ##sys#block-ref ##sys#block-set! |
---|
184 | ##sys#call-with-current-continuation ##sys#size ##sys#byte ##sys#setbyte |
---|
185 | ##sys#pointer? ##sys#generic-structure? ##sys#structure? ##sys#check-structure |
---|
186 | ##sys#check-exact ##sys#check-number ##sys#check-list ##sys#check-pair ##sys#check-string ##sys#check-symbol |
---|
187 | ##sys#check-char ##sys#check-vector ##sys#check-byte-vector ##sys#list ##sys#cons |
---|
188 | ##sys#call-with-values ##sys#fits-in-int? ##sys#fits-in-unsigned-int? ##sys#flonum-in-fixnum-range? |
---|
189 | ##sys#fudge ##sys#immediate? ##sys#direct-return ##sys#context-switch |
---|
190 | ##sys#make-structure ##sys#apply ##sys#apply-values ##sys#continuation-graft |
---|
191 | ##sys#bytevector? ##sys#make-vector ##sys#setter |
---|
192 | ##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument |
---|
193 | ##sys#foreign-block-argument ##sys#foreign-number-vector-argument |
---|
194 | ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#void |
---|
195 | ##sys#foreign-integer-argument ##sys#foreign-unsigned-integer-argument ##sys#double->number |
---|
196 | ##sys#peek-fixnum ##sys#setislot ##sys#poke-integer ##sys#permanent? ##sys#values ##sys#poke-double |
---|
197 | ##sys#intern-symbol ##sys#make-symbol ##sys#null-pointer? ##sys#peek-byte) ) |
---|
198 | |
---|
199 | (define side-effecting-standard-bindings |
---|
200 | '(apply call-with-current-continuation set-car! set-cdr! write-char newline write display |
---|
201 | peek-char char-ready? |
---|
202 | read read-char for-each map string-set! vector-set! string-fill! vector-fill! open-input-file |
---|
203 | open-output-file close-input-port close-output-port call-with-input-port call-with-output-port |
---|
204 | call-with-values eval) ) |
---|
205 | |
---|
206 | (define non-foldable-standard-bindings |
---|
207 | '(vector cons list string make-vector make-string string->symbol values current-input-port current-output-port |
---|
208 | read-char write-char) ) |
---|
209 | |
---|
210 | (define foldable-standard-bindings |
---|
211 | (lset-difference |
---|
212 | eq? default-standard-bindings |
---|
213 | side-effecting-standard-bindings non-foldable-standard-bindings) ) |
---|
214 | |
---|
215 | (define non-foldable-extended-bindings |
---|
216 | '(##sys#slot ##sys#setslot ##sys#call-with-current-continuation ##sys#fudge flush-output print void |
---|
217 | u8vector->byte-vector s8vector->byte-vector u16vector->byte-vector s16vector->byte-vector u32vector->byte-vector ; DEPRECATED |
---|
218 | f32vector->byte-vector f64vector->byte-vector s32vector->byte-vector ;DEPRECATED |
---|
219 | u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared s16vector->blob/shared u32vector->blob/shared |
---|
220 | f32vector->blob/shared f64vector->blob/shared |
---|
221 | s32vector->blob/shared read-string read-string! |
---|
222 | ##sys#make-structure print* ##sys#make-vector ##sys#apply ##sys#setislot ##sys#block-ref |
---|
223 | ##sys#byte ##sys#setbyte |
---|
224 | byte-vector-ref byte-vector-set! ; DEPRECATED |
---|
225 | u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length |
---|
226 | f32vector-length f64vector-length ##sys#apply-values ##sys#setter setter |
---|
227 | u8vector-ref s8vector-ref u16vector-ref s16vector-ref u32vector-ref s32vector-ref |
---|
228 | u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set! |
---|
229 | ##sys#intern-symbol ##sys#make-symbol make-record-instance error cpu-time ##sys#block-set!) ) |
---|
230 | |
---|
231 | (define foldable-extended-bindings |
---|
232 | (lset-difference |
---|
233 | eq? default-extended-bindings non-foldable-extended-bindings) ) |
---|
234 | |
---|
235 | (define standard-bindings-that-never-return-false |
---|
236 | '(cons list length * - + / current-output-port current-input-port append symbol->string char->integer |
---|
237 | integer->char vector-length string-length string-ref gcd lcm reverse string->symbol max min |
---|
238 | quotient remainder modulo floor ceiling truncate round exact->inexact inexact->exact exp log sin |
---|
239 | cons tan atan expt sqrt asin acos number->string char-upcase char-downcase string-append string |
---|
240 | string->list list->string vector->list list->vector read-char substring make-string make-vector |
---|
241 | open-input-file open-output-file vector write-char) ) |
---|
242 | |
---|
243 | (define side-effect-free-standard-bindings-that-never-return-false |
---|
244 | (lset-difference |
---|
245 | eq? standard-bindings-that-never-return-false |
---|
246 | side-effecting-standard-bindings) ) |
---|
247 | |
---|
248 | |
---|
249 | ;;; Rewriting-definitions for this platform: |
---|
250 | |
---|
251 | (rewrite '+ 19 0 "C_fixnum_plus" "C_u_fixnum_plus" #f) |
---|
252 | |
---|
253 | (rewrite |
---|
254 | '* 8 |
---|
255 | (lambda (db classargs cont callargs) |
---|
256 | ;; (*) -> 1 |
---|
257 | ;; (* <x>) -> <x> |
---|
258 | ;; (* <x1> ...) -> (##core#inline "C_fixnum_times" <x1> (##core#inline "C_fixnum_times" ...)) [fixnum-mode] |
---|
259 | ;; - Remove "1" from arguments. |
---|
260 | ;; - Replace multiplications with 2 by shift left. [fixnum-mode] |
---|
261 | (let ([callargs |
---|
262 | (remove |
---|
263 | (lambda (x) |
---|
264 | (and (eq? 'quote (node-class x)) |
---|
265 | (= 1 (first (node-parameters x))) ) ) |
---|
266 | callargs) ] ) |
---|
267 | (cond [(null? callargs) (make-node '##core#call '(#t) (list cont (qnode 0)))] |
---|
268 | [(null? (cdr callargs)) |
---|
269 | (make-node '##core#call '(#t) (list cont (first callargs))) ] |
---|
270 | [(eq? number-type 'fixnum) |
---|
271 | (make-node |
---|
272 | '##core#call '(#t) |
---|
273 | (list |
---|
274 | cont |
---|
275 | (fold-inner |
---|
276 | (lambda (x y) |
---|
277 | (if (and (eq? 'quote (node-class y)) (= 2 (first (node-parameters y)))) |
---|
278 | (make-node '##core#inline '("C_fixnum_shift_left") (list x (qnode 1))) |
---|
279 | (make-node '##core#inline '("C_fixnum_times") (list x y)) ) ) |
---|
280 | callargs) ) ) ] |
---|
281 | [else #f] ) ) ) ) |
---|
282 | |
---|
283 | (rewrite |
---|
284 | '- 8 |
---|
285 | (lambda (db classargs cont callargs) |
---|
286 | ;; (- <x>) -> (##core#inline "C_fixnum_negate" <x>) [fixnum-mode] |
---|
287 | ;; (- <x>) -> (##core#inline "C_u_fixnum_negate" <x>) [fixnum-mode + unsafe] |
---|
288 | ;; (- <x1> ...) -> (##core#inline "C_fixnum_difference" <x1> (##core#inline "C_fixnum_difference" ...)) [fixnum-mode] |
---|
289 | ;; (- <x1> ...) -> (##core#inline "C_u_fixnum_difference" <x1> (##core#inline "C_u_fixnum_difference" ...)) |
---|
290 | ;; [fixnum-mode + unsafe] |
---|
291 | ;; - Remove "0" from arguments, if more than 1. |
---|
292 | (cond [(null? callargs) #f] |
---|
293 | [(and (null? (cdr callargs)) (eq? number-type 'fixnum)) |
---|
294 | (make-node |
---|
295 | '##core#call '(#t) |
---|
296 | (list cont |
---|
297 | (make-node '##core#inline |
---|
298 | (if unsafe '("C_u_fixnum_negate") '("C_fixnum_negate")) |
---|
299 | callargs)) ) ] |
---|
300 | [else |
---|
301 | (let ([callargs |
---|
302 | (cons (car callargs) |
---|
303 | (remove |
---|
304 | (lambda (x) |
---|
305 | (and (eq? 'quote (node-class x)) |
---|
306 | (zero? (first (node-parameters x))) ) ) |
---|
307 | (cdr callargs) ) ) ] ) |
---|
308 | (and (eq? number-type 'fixnum) |
---|
309 | (>= (length callargs) 2) |
---|
310 | (make-node |
---|
311 | '##core#call '(#t) |
---|
312 | (list |
---|
313 | cont |
---|
314 | (fold-inner |
---|
315 | (lambda (x y) |
---|
316 | (make-node '##core#inline |
---|
317 | (if unsafe '("C_u_fixnum_difference") '("C_fixnum_difference")) |
---|
318 | (list x y) ) ) |
---|
319 | callargs) ) ) ) ) ] ) ) ) |
---|
320 | |
---|
321 | (rewrite |
---|
322 | '/ 8 |
---|
323 | (lambda (db classargs cont callargs) |
---|
324 | ;; (/ <x1> ...) -> (##core#inline "C_fixnum_divide" <x1> (##core#inline "C_fixnum_divide" ...)) [fixnum-mode] |
---|
325 | ;; - Remove "1" from arguments, if more than 1. |
---|
326 | ;; - Replace divisions by 2 with shift right. [fixnum-mode] |
---|
327 | (and (>= (length callargs) 2) |
---|
328 | (let ([callargs |
---|
329 | (cons (car callargs) |
---|
330 | (remove |
---|
331 | (lambda (x) |
---|
332 | (and (eq? 'quote (node-class x)) |
---|
333 | (= 1 (first (node-parameters x))) ) ) |
---|
334 | (cdr callargs) ) ) ] ) |
---|
335 | (and (eq? number-type 'fixnum) |
---|
336 | (>= (length callargs) 2) |
---|
337 | (make-node |
---|
338 | '##core#call '(#t) |
---|
339 | (list |
---|
340 | cont |
---|
341 | (fold-inner |
---|
342 | (lambda (x y) |
---|
343 | (if (and (eq? 'quote (node-class y)) (= 2 (first (node-parameters y)))) |
---|
344 | (make-node '##core#inline '("C_fixnum_shift_right") (list x (qnode 1))) |
---|
345 | (make-node '##core#inline '("C_fixnum_divide") (list x y)) ) ) |
---|
346 | callargs) ) ) ) ) ) ) ) |
---|
347 | |
---|
348 | (rewrite |
---|
349 | 'quotient 8 |
---|
350 | (lambda (db classargs cont callargs) |
---|
351 | ;; (quotient <x> 2) -> (##core#inline "C_fixnum_shift_right" <x> 1) [fixnum-mode] |
---|
352 | ;; (quotient <x> <y>) -> (##core#inline "C_fixnum_divide" <x> <y>) [fixnum-mode] |
---|
353 | ;; (quotient <x> <y>) -> ((##core#proc "C_quotient") <x> <y>) |
---|
354 | (and (= (length callargs) 2) |
---|
355 | (if (eq? 'fixnum number-type) |
---|
356 | (make-node |
---|
357 | '##core#call '(#t) |
---|
358 | (let ([arg2 (second callargs)]) |
---|
359 | (list cont |
---|
360 | (if (and (eq? 'quote (node-class arg2)) |
---|
361 | (= 2 (first (node-parameters arg2))) ) |
---|
362 | (make-node |
---|
363 | '##core#inline '("C_fixnum_shift_right") |
---|
364 | (list (first callargs) (qnode 1)) ) |
---|
365 | (make-node '##core#inline '("C_fixnum_divide") callargs) ) ) ) ) |
---|
366 | (make-node |
---|
367 | '##core#call '(#t) |
---|
368 | (cons* (make-node '##core#proc '("C_quotient" #t) '()) cont callargs) ) ) ) ) ) |
---|
369 | |
---|
370 | (rewrite |
---|
371 | 'eqv? 8 |
---|
372 | (lambda (db classargs cont callargs) |
---|
373 | ;; (eqv? <var> <var>) -> (quote #t) |
---|
374 | ;; (eqv? ...) -> (##core#inline "C_eqp" ...) [one argument is a constant and not a flonum] |
---|
375 | (and (= (length callargs) 2) |
---|
376 | (let ([arg1 (first callargs)] |
---|
377 | [arg2 (second callargs)] ) |
---|
378 | (or (and (eq? '##core#variable (node-class arg1)) |
---|
379 | (eq? '##core#variable (node-class arg2)) |
---|
380 | (equal? (node-parameters arg1) (node-parameters arg2)) |
---|
381 | (make-node '##core#call '(#t) (list cont (qnode #t))) ) |
---|
382 | (and (or (and (eq? 'quote (node-class arg1)) |
---|
383 | (not (flonum? (first (node-parameters arg1)))) ) |
---|
384 | (and (eq? 'quote (node-class arg2)) |
---|
385 | (not (flonum? (first (node-parameters arg2)))) ) ) |
---|
386 | (make-node |
---|
387 | '##core#call '(#t) |
---|
388 | (list cont (make-node '##core#inline '("C_eqp") callargs)) ) ) ) ) ) ) ) |
---|
389 | |
---|
390 | (rewrite |
---|
391 | 'equal? 8 |
---|
392 | (lambda (db classargs cont callargs) |
---|
393 | ;; (equal? <var> <var>) -> (quote #t) |
---|
394 | ;; (equal? ...) -> (##core#inline "C_eqp" ...) [one argument is a constant and immediate or a symbol] |
---|
395 | ;; (equal? ...) -> (##core#inline "C_i_equalp" ...) |
---|
396 | (and (= (length callargs) 2) |
---|
397 | (let ([arg1 (first callargs)] |
---|
398 | [arg2 (second callargs)] ) |
---|
399 | (or (and (eq? '##core#variable (node-class arg1)) |
---|
400 | (eq? '##core#variable (node-class arg2)) |
---|
401 | (equal? (node-parameters arg1) (node-parameters arg2)) |
---|
402 | (make-node '##core#call '(#t) (list cont (qnode #t))) ) |
---|
403 | (and (or (and (eq? 'quote (node-class arg1)) |
---|
404 | (let ([f (first (node-parameters arg1))]) |
---|
405 | (or (immediate? f) (symbol? f)) ) ) |
---|
406 | (and (eq? 'quote (node-class arg2)) |
---|
407 | (let ([f (first (node-parameters arg2))]) |
---|
408 | (or (immediate? f) (symbol? f)) ) ) ) |
---|
409 | (make-node |
---|
410 | '##core#call '(#t) |
---|
411 | (list cont (make-node '##core#inline '("C_eqp") callargs)) ) ) |
---|
412 | (make-node |
---|
413 | '##core#call '(#t) |
---|
414 | (list cont (make-node '##core#inline '("C_i_equalp") callargs)) ) ) ) ) ) ) |
---|
415 | |
---|
416 | (let () |
---|
417 | (define (rewrite-apply db classargs cont callargs) |
---|
418 | ;; (apply <fn> <x1> ... '(<y1> ...)) -> (<fn> <x1> ... '<y1> ...) |
---|
419 | ;; (apply ...) -> ((##core#proc "C_apply") ...) |
---|
420 | ;; (apply values <lst>) -> ((##core#proc "C_apply_values") lst) |
---|
421 | ;; (apply ##sys#values <lst>) -> ((##core#proc "C_apply_values") lst) |
---|
422 | (and (pair? callargs) |
---|
423 | (let ([lastarg (last callargs)] |
---|
424 | [proc (car callargs)] ) |
---|
425 | (if (eq? 'quote (node-class lastarg)) |
---|
426 | (make-node |
---|
427 | '##core#call '(#f) |
---|
428 | (cons* (first callargs) |
---|
429 | cont |
---|
430 | (append (cdr (butlast callargs)) (map qnode (first (node-parameters lastarg)))) ) ) |
---|
431 | (or (and (eq? '##core#variable (node-class proc)) |
---|
432 | (= 2 (length callargs)) |
---|
433 | (let ([name (car (node-parameters proc))]) |
---|
434 | (and (memq name '(values ##sys#values)) |
---|
435 | (or (get db name 'standard-binding) |
---|
436 | (get db name 'extended-binding) ) |
---|
437 | (make-node |
---|
438 | '##core#call '(#t) |
---|
439 | (list (make-node '##core#proc '("C_apply_values" #t) '()) |
---|
440 | cont |
---|
441 | (cadr callargs) ) ) ) ) ) |
---|
442 | (make-node |
---|
443 | '##core#call '(#t) |
---|
444 | (cons* (make-node '##core#proc '("C_apply" #t) '()) |
---|
445 | cont callargs) ) ) ) ) ) ) |
---|
446 | (rewrite 'apply 8 rewrite-apply) |
---|
447 | (rewrite '##sys#apply 8 rewrite-apply) ) |
---|
448 | |
---|
449 | (let () |
---|
450 | (define (rewrite-c..r op iop1 iop2 index) |
---|
451 | (rewrite |
---|
452 | op 8 |
---|
453 | (lambda (db classargs cont callargs) |
---|
454 | ;; (<op> <rest-vector>) -> (##core#inline "C_i_vector_ref"/"C_slot" <rest-vector> (quote <index>)) |
---|
455 | ;; (<op> <x>) -> (##core#inline <iop1> <x>) [safe] |
---|
456 | ;; (<op> <x>) -> (##core#inline <iop2> <x>) [unsafe] |
---|
457 | (and (= (length callargs) 1) |
---|
458 | (call-with-current-continuation |
---|
459 | (lambda (return) |
---|
460 | (let ([arg (first callargs)]) |
---|
461 | (make-node |
---|
462 | '##core#call '(#t) |
---|
463 | (list |
---|
464 | cont |
---|
465 | (cond [(and (eq? '##core#variable (node-class arg)) |
---|
466 | (eq? 'vector (get db (first (node-parameters arg)) 'rest-parameter)) ) |
---|
467 | (make-node |
---|
468 | '##core#inline |
---|
469 | (if unsafe |
---|
470 | '("C_slot") |
---|
471 | '("C_i_vector_ref") ) |
---|
472 | (list arg (qnode index)) ) ] |
---|
473 | [(and unsafe iop2) (make-node '##core#inline (list iop2) callargs)] |
---|
474 | [iop1 (make-node '##core#inline (list iop1) callargs)] |
---|
475 | [else (return #f)] ) ) ) ) ) ) ) ) ) ) |
---|
476 | |
---|
477 | (rewrite-c..r 'car "C_i_car" "C_u_i_car" 0) |
---|
478 | (rewrite-c..r 'cadr "C_i_cadr" "C_u_i_cadr" 1) |
---|
479 | (rewrite-c..r 'caddr "C_i_caddr" "C_u_i_caddr" 2) |
---|
480 | (rewrite-c..r 'cadddr "C_i_cadddr" "C_u_i_cadddr" 3) |
---|
481 | (rewrite-c..r 'first "C_i_car" "C_u_i_car" 0) |
---|
482 | (rewrite-c..r 'second "C_i_cadr" "C_u_i_cadr" 1) |
---|
483 | (rewrite-c..r 'third "C_i_caddr" "C_u_i_caddr" 2) |
---|
484 | (rewrite-c..r 'fourth "C_i_cadddr" "C_u_i_cadddr" 3) ) |
---|
485 | |
---|
486 | (let ([rvalues |
---|
487 | (lambda (db classargs cont callargs) |
---|
488 | ;; (values <x>) -> <x> |
---|
489 | (and (= (length callargs) 1) |
---|
490 | (make-node '##core#call '(#t) (cons cont callargs) ) ) ) ] ) |
---|
491 | (rewrite 'values 8 rvalues) |
---|
492 | (rewrite '##sys#values 8 rvalues) ) |
---|
493 | |
---|
494 | (let () |
---|
495 | (define (rewrite-c-w-v db classargs cont callargs) |
---|
496 | ;; (call-with-values <var1> <var2>) -> (let ((k (lambda (r) (<var2> <k0> r)))) (<var1> k)) |
---|
497 | ;; - if <var2> is a known lambda of a single argument |
---|
498 | (and (= 2 (length callargs)) |
---|
499 | (let ((arg1 (car callargs)) |
---|
500 | (arg2 (cadr callargs)) ) |
---|
501 | (and (eq? '##core#variable (node-class arg1)) ; probably not needed |
---|
502 | (eq? '##core#variable (node-class arg2)) |
---|
503 | (and-let* ((sym (car (node-parameters arg2))) |
---|
504 | (val (get db sym 'value)) ) |
---|
505 | (and (eq? '##core#lambda (node-class val)) |
---|
506 | (let ((llist (third (node-parameters val)))) |
---|
507 | (and (proper-list? llist) |
---|
508 | (= 2 (length (third (node-parameters val)))) |
---|
509 | (let ((tmp (gensym)) |
---|
510 | (tmpk (gensym 'r)) ) |
---|
511 | (debugging 'o "removing single-valued `call-with-values'" (node-parameters val)) |
---|
512 | (make-node |
---|
513 | 'let (list tmp) |
---|
514 | (list (make-node |
---|
515 | '##core#lambda |
---|
516 | (list (gensym 'f_) #f (list tmpk) 0) |
---|
517 | (list (make-node |
---|
518 | '##core#call '(#t) |
---|
519 | (list arg2 cont (varnode tmpk)) ) ) ) |
---|
520 | (make-node |
---|
521 | '##core#call '(#t) |
---|
522 | (list arg1 (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) ) |
---|
523 | (rewrite 'call-with-values 8 rewrite-c-w-v) |
---|
524 | (rewrite '##sys#call-with-values 8 rewrite-c-w-v) ) |
---|
525 | |
---|
526 | (rewrite 'values 13 "C_values" #t) |
---|
527 | (rewrite '##sys#values 13 "C_values" #t) |
---|
528 | (rewrite 'call-with-values 13 "C_u_call_with_values" #f) |
---|
529 | (rewrite 'call-with-values 13 "C_call_with_values" #t) |
---|
530 | (rewrite '##sys#call-with-values 13 "C_u_call_with_values" #f) |
---|
531 | (rewrite '##sys#call-with-values 13 "C_call_with_values" #t) |
---|
532 | (rewrite 'cpu-time 13 "C_cpu_time" #t) |
---|
533 | (rewrite 'locative-ref 13 "C_locative_ref" #t) |
---|
534 | (rewrite '##sys#continuation-graft 13 "C_continuation_graft" #t) |
---|
535 | |
---|
536 | (rewrite 'caar 2 1 "C_u_i_caar" #f #f) |
---|
537 | (rewrite 'cdar 2 1 "C_u_i_cdar" #f #f) |
---|
538 | (rewrite 'cddr 2 1 "C_u_i_cddr" #f #f) |
---|
539 | (rewrite 'caaar 2 1 "C_u_i_caaar" #f #f) |
---|
540 | (rewrite 'cadar 2 1 "C_u_i_cadar" #f #f) |
---|
541 | (rewrite 'caddr 2 1 "C_u_i_caddr" #f #f) |
---|
542 | (rewrite 'cdaar 2 1 "C_u_i_cdaar" #f #f) |
---|
543 | (rewrite 'cdadr 2 1 "C_u_i_cdadr" #f #f) |
---|
544 | (rewrite 'cddar 2 1 "C_u_i_cddar" #f #f) |
---|
545 | (rewrite 'cdddr 2 1 "C_u_i_cdddr" #f #f) |
---|
546 | (rewrite 'caaaar 2 1 "C_u_i_caaaar" #f #f) |
---|
547 | (rewrite 'caadar 2 1 "C_u_i_caadar" #f #f) |
---|
548 | (rewrite 'caaddr 2 1 "C_u_i_caaddr" #f #f) |
---|
549 | (rewrite 'cadaar 2 1 "C_u_i_cadaar" #f #f) |
---|
550 | (rewrite 'cadadr 2 1 "C_u_i_cadadr" #f #f) |
---|
551 | (rewrite 'caddar 2 1 "C_u_i_caddar" #f #f) |
---|
552 | (rewrite 'cadddr 2 1 "C_u_i_cadddr" #f #f) |
---|
553 | (rewrite 'cdaaar 2 1 "C_u_i_cdaaar" #f #f) |
---|
554 | (rewrite 'cdaadr 2 1 "C_u_i_cdaadr" #f #f) |
---|
555 | (rewrite 'cdadar 2 1 "C_u_i_cdadar" #f #f) |
---|
556 | (rewrite 'cdaddr 2 1 "C_u_i_cdaddr" #f #f) |
---|
557 | (rewrite 'cddaar 2 1 "C_u_i_cddaar" #f #f) |
---|
558 | (rewrite 'cddadr 2 1 "C_u_i_cddadr" #f #f) |
---|
559 | (rewrite 'cdddar 2 1 "C_u_i_cdddar" #f #f) |
---|
560 | (rewrite 'cddddr 2 1 "C_u_i_cddddr" #f #f) |
---|
561 | |
---|
562 | (rewrite 'cddr 2 1 "C_i_cddr" #t #f) |
---|
563 | (rewrite 'cdddr 2 1 "C_i_cdddr" #t #f) |
---|
564 | (rewrite 'cddddr 2 1 "C_i_cddddr" #t #f) |
---|
565 | |
---|
566 | (rewrite 'cdr 7 1 "C_slot" 1 #f) |
---|
567 | (rewrite 'cdr 2 1 "C_i_cdr" #t #f) |
---|
568 | |
---|
569 | (rewrite 'eq? 1 2 "C_eqp") |
---|
570 | (rewrite 'eqv? 1 2 "C_i_eqvp") |
---|
571 | |
---|
572 | (rewrite 'list-ref 2 2 "C_u_i_list_ref" #f "C_slot") |
---|
573 | (rewrite 'list-ref 2 2 "C_i_list_ref" #t "C_i_vector_ref") |
---|
574 | (rewrite 'null? 2 1 "C_i_nullp" #t "C_vemptyp") |
---|
575 | (rewrite 'length 2 1 "C_i_length" #t "C_block_size") |
---|
576 | (rewrite 'not 2 1 "C_i_not" #t #f) |
---|
577 | (rewrite 'char? 2 1 "C_charp" #t #f) |
---|
578 | (rewrite 'string? 2 1 "C_i_stringp" #t #f) |
---|
579 | (rewrite 'locative? 2 1 "C_i_locativep" #t #f) |
---|
580 | (rewrite 'symbol? 2 1 "C_i_symbolp" #t #f) |
---|
581 | (rewrite 'vector? 2 1 "C_i_vectorp" #t #f) |
---|
582 | (rewrite 'pair? 2 1 "C_i_pairp" #t "C_notvemptyp") |
---|
583 | (rewrite 'procedure? 2 1 "C_i_closurep" #t #f) |
---|
584 | (rewrite 'port? 2 1 "C_i_portp" #t #f) |
---|
585 | (rewrite 'boolean? 2 1 "C_booleanp" #t #f) |
---|
586 | (rewrite 'number? 2 1 "C_i_numberp" #t #f) |
---|
587 | (rewrite 'complex? 2 1 "C_i_numberp" #t #f) |
---|
588 | (rewrite 'rational? 2 1 "C_i_numberp" #t #f) |
---|
589 | (rewrite 'real? 2 1 "C_i_numberp" #t #f) |
---|
590 | (rewrite 'integer? 2 1 "C_i_integerp" #t #f) |
---|
591 | (rewrite 'flonum? 2 1 "C_i_flonump" #t #f) |
---|
592 | (rewrite 'fixnum? 2 1 "C_fixnump" #t #f) |
---|
593 | (rewrite 'finite? 2 1 "C_i_finitep" #f #f) |
---|
594 | (rewrite '##sys#pointer? 2 1 "C_pointerp" #t #f) |
---|
595 | (rewrite '##sys#generic-structure? 2 1 "C_structurep" #t #f) |
---|
596 | (rewrite 'exact? 2 1 "C_fixnump" #f #f) |
---|
597 | (rewrite 'exact? 2 1 "C_i_exactp" #t #f) |
---|
598 | (rewrite 'exact? 2 1 "C_u_i_exactp" #f #f) |
---|
599 | (rewrite 'inexact? 2 1 "C_nfixnump" #f #f) |
---|
600 | (rewrite 'inexact? 2 1 "C_i_inexactp" #t #f) |
---|
601 | (rewrite 'inexact? 2 1 "C_u_i_inexactp" #f #f) |
---|
602 | (rewrite 'list? 2 1 "C_i_listp" #t #f) |
---|
603 | (rewrite 'proper-list? 2 1 "C_i_listp" #t #f) |
---|
604 | (rewrite 'eof-object? 2 1 "C_eofp" #t #f) |
---|
605 | (rewrite 'string-ref 2 2 "C_subchar" #f #f) |
---|
606 | (rewrite 'string-ref 2 2 "C_i_string_ref" #t #f) |
---|
607 | (rewrite 'string-set! 2 3 "C_setsubchar" #f #f) |
---|
608 | (rewrite 'string-set! 2 3 "C_i_string_set" #t #f) |
---|
609 | (rewrite 'vector-ref 2 2 "C_slot" #f #f) |
---|
610 | (rewrite 'vector-ref 2 2 "C_i_vector_ref" #t #f) |
---|
611 | (rewrite 'char=? 2 2 "C_eqp" #t #f) |
---|
612 | (rewrite 'char>? 2 2 "C_fixnum_greaterp" #t #f) |
---|
613 | (rewrite 'char<? 2 2 "C_fixnum_lessp" #t #f) |
---|
614 | (rewrite 'char>=? 2 2 "C_fixnum_greater_or_equal_p" #t #f) |
---|
615 | (rewrite 'char<=? 2 2 "C_fixnum_less_or_equal_p" #t #f) |
---|
616 | (rewrite '##sys#slot 2 2 "C_slot" #t #f) ; consider as safe, the primitive is unsafe anyway. |
---|
617 | (rewrite '##sys#block-ref 2 2 "C_i_block_ref" #t #f) ;*** must be safe for pattern matcher (anymore?) |
---|
618 | (rewrite '##sys#size 2 1 "C_block_size" #t #f) |
---|
619 | (rewrite 'fxnot 2 1 "C_fixnum_not" #t #f) |
---|
620 | (rewrite 'fx* 2 2 "C_fixnum_times" #t #f) |
---|
621 | (rewrite 'fx/ 2 2 "C_fixnum_divide" #f #f) |
---|
622 | (rewrite 'fxmod 2 2 "C_fixnum_modulo" #f #f) |
---|
623 | (rewrite 'fx= 2 2 "C_eqp" #t #f) |
---|
624 | (rewrite 'fx> 2 2 "C_fixnum_greaterp" #t #f) |
---|
625 | (rewrite 'fx< 2 2 "C_fixnum_lessp" #t #f) |
---|
626 | (rewrite 'fx>= 2 2 "C_fixnum_greater_or_equal_p" #t #f) |
---|
627 | (rewrite 'fx<= 2 2 "C_fixnum_less_or_equal_p" #t #f) |
---|
628 | (rewrite 'fp= 2 2 "C_flonum_equalp" #t #f) |
---|
629 | (rewrite 'fp> 2 2 "C_flonum_greaterp" #t #f) |
---|
630 | (rewrite 'fp< 2 2 "C_flonum_lessp" #t #f) |
---|
631 | (rewrite 'fp>= 2 2 "C_flonum_greater_or_equal_p" #t #f) |
---|
632 | (rewrite 'fp<= 2 2 "C_flonum_less_or_equal_p" #t #f) |
---|
633 | (rewrite 'fxmax 2 2 "C_i_fixnum_max" #t #f) |
---|
634 | (rewrite 'fxmin 2 2 "C_i_fixnum_min" #t #f) |
---|
635 | (rewrite 'fpmax 2 2 "C_i_flonum_max" #t #f) |
---|
636 | (rewrite 'fpmin 2 2 "C_i_flonum_min" #t #f) |
---|
637 | (rewrite 'char-numeric? 2 1 "C_u_i_char_numericp" #t #f) |
---|
638 | (rewrite 'char-alphabetic? 2 1 "C_u_i_char_alphabeticp" #t #f) |
---|
639 | (rewrite 'char-whitespace? 2 1 "C_u_i_char_whitespacep" #t #f) |
---|
640 | (rewrite 'char-upper-case? 2 1 "C_u_i_char_upper_casep" #t #f) |
---|
641 | (rewrite 'char-lower-case? 2 1 "C_u_i_char_lower_casep" #t #f) |
---|
642 | (rewrite 'char-upcase 2 1 "C_u_i_char_upcase" #t #f) |
---|
643 | (rewrite 'char-downcase 2 1 "C_u_i_char_downcase" #t #f) |
---|
644 | (rewrite 'list-tail 2 2 "C_i_list_tail" #t #f) |
---|
645 | (rewrite '##sys#structure? 2 2 "C_i_structurep" #t #f) |
---|
646 | (rewrite '##sys#bytevector? 2 2 "C_bytevectorp" #t #f) |
---|
647 | (rewrite 'block-ref 2 2 "C_slot" #f #f) ; ok to be unsafe, lolevel is anyway |
---|
648 | (rewrite 'number-of-slots 2 1 "C_block_size" #f #f) |
---|
649 | |
---|
650 | (rewrite 'assv 14 'fixnum 2 "C_i_assq" "C_u_i_assq") |
---|
651 | (rewrite 'assv 2 2 "C_i_assv" #t #f) |
---|
652 | (rewrite 'memv 14 'fixnum 2 "C_i_memq" "C_u_i_memq") |
---|
653 | (rewrite 'memv 2 2 "C_i_memv" #t #f) |
---|
654 | (rewrite 'assq 17 2 "C_i_assq" "C_u_i_assq") |
---|
655 | (rewrite 'memq 17 2 "C_i_memq" "C_u_i_memq") |
---|
656 | (rewrite 'assoc 2 2 "C_i_assoc" #t #f) |
---|
657 | (rewrite 'member 2 2 "C_i_member" #t #f) |
---|
658 | |
---|
659 | (rewrite 'set-car! 4 '##sys#setslot 0) |
---|
660 | (rewrite 'set-cdr! 4 '##sys#setslot 1) |
---|
661 | (rewrite 'set-car! 17 2 "C_i_set_car" "C_u_i_set_car") |
---|
662 | (rewrite 'set-cdr! 17 2 "C_i_set_cdr" "C_u_i_set_cdr") |
---|
663 | |
---|
664 | (rewrite 'abs 14 'fixnum 1 "C_fixnum_abs" "C_fixnum_abs") |
---|
665 | (rewrite 'abs 16 1 "C_a_i_abs" #t words-per-flonum) |
---|
666 | |
---|
667 | (rewrite 'bitwise-xor 21 0 "C_fixnum_xor" "C_fixnum_xor" "C_a_i_bitwise_xor" words-per-flonum) |
---|
668 | (rewrite 'bitwise-and 21 -1 "C_fixnum_and" "C_u_fixnum_and" "C_a_i_bitwise_and" words-per-flonum) |
---|
669 | (rewrite 'bitwise-ior 21 0 "C_fixnum_or" "C_u_fixnum_or" "C_a_i_bitwise_ior" words-per-flonum) |
---|
670 | |
---|
671 | (rewrite 'bitwise-not 22 1 "C_a_i_bitwise_not" #t words-per-flonum "C_fixnum_not") |
---|
672 | |
---|
673 | (rewrite 'fp+ 16 2 "C_a_i_flonum_plus" #t words-per-flonum) |
---|
674 | (rewrite 'fp- 16 2 "C_a_i_flonum_difference" #t words-per-flonum) |
---|
675 | (rewrite 'fp* 16 2 "C_a_i_flonum_times" #t words-per-flonum) |
---|
676 | (rewrite 'fp/ 16 2 "C_a_i_flonum_quotient" #t words-per-flonum) |
---|
677 | (rewrite 'fpneg 16 1 "C_a_i_flonum_negate" #t words-per-flonum) |
---|
678 | |
---|
679 | (rewrite 'exp 16 1 "C_a_i_exp" #t words-per-flonum) |
---|
680 | (rewrite 'sin 16 1 "C_a_i_sin" #t words-per-flonum) |
---|
681 | (rewrite 'cos 16 1 "C_a_i_cos" #t words-per-flonum) |
---|
682 | (rewrite 'tan 16 1 "C_a_i_tan" #t words-per-flonum) |
---|
683 | (rewrite 'log 16 1 "C_a_i_log" #t words-per-flonum) |
---|
684 | (rewrite 'asin 16 1 "C_a_i_asin" #t words-per-flonum) |
---|
685 | (rewrite 'acos 16 1 "C_a_i_acos" #t words-per-flonum) |
---|
686 | (rewrite 'atan 16 1 "C_a_i_atan" #t words-per-flonum) |
---|
687 | (rewrite 'sqrt 16 1 "C_a_i_sqrt" #t words-per-flonum) |
---|
688 | (rewrite 'atan 16 2 "C_a_i_atan2" #t words-per-flonum) |
---|
689 | |
---|
690 | (rewrite 'zero? 5 "C_eqp" 0 'fixnum) |
---|
691 | (rewrite 'zero? 2 1 "C_i_zerop" #t #f) |
---|
692 | (rewrite 'zero? 2 1 "C_u_i_zerop" #f #f) |
---|
693 | (rewrite 'positive? 5 "C_fixnum_greaterp" 0 'fixnum) |
---|
694 | (rewrite 'positive? 5 "C_flonum_greaterp" 0 'flonum) |
---|
695 | (rewrite 'positive? 2 1 "C_i_positivep" #t #f) |
---|
696 | (rewrite 'positive? 2 1 "C_u_i_positivep" #f #f) |
---|
697 | (rewrite 'negative? 5 "C_fixnum_lessp" 0 'fixnum) |
---|
698 | (rewrite 'negative? 5 "C_flonum_lessp" 0 'flonum) |
---|
699 | (rewrite 'negative? 2 1 "C_i_negativep" #t #f) |
---|
700 | (rewrite 'negative? 2 1 "C_u_i_negativep" #f #f) |
---|
701 | |
---|
702 | (rewrite 'vector-length 6 "C_fix" "C_header_size" #f) |
---|
703 | (rewrite 'string-length 6 "C_fix" "C_header_size" #f) |
---|
704 | (rewrite 'char->integer 6 "C_fix" "C_character_code" #t) |
---|
705 | (rewrite 'integer->char 6 "C_make_character" "C_unfix" #t) |
---|
706 | |
---|
707 | (rewrite 'vector-length 2 1 "C_i_vector_length" #t #f) |
---|
708 | (rewrite 'string-length 2 1 "C_i_string_length" #t #f) |
---|
709 | (rewrite 'inexact->exact 2 1 "C_i_inexact_to_exact" #t #f) |
---|
710 | |
---|
711 | (rewrite '##sys#check-exact 2 1 "C_i_check_exact" #t #f) |
---|
712 | (rewrite '##sys#check-number 2 1 "C_i_check_number" #t #f) |
---|
713 | (rewrite '##sys#check-list 2 1 "C_i_check_list" #t #f) |
---|
714 | (rewrite '##sys#check-pair 2 1 "C_i_check_pair" #t #f) |
---|
715 | (rewrite '##sys#check-symbol 2 1 "C_i_check_symbol" #t #f) |
---|
716 | (rewrite '##sys#check-string 2 1 "C_i_check_string" #t #f) |
---|
717 | (rewrite '##sys#check-byte-vector 2 1 "C_i_check_bytevector" #t #f) |
---|
718 | (rewrite '##sys#check-vector 2 1 "C_i_check_vector" #t #f) |
---|
719 | (rewrite '##sys#check-structure 2 2 "C_i_check_structure" #t #f) |
---|
720 | (rewrite '##sys#check-char 2 1 "C_i_check_char" #t #f) |
---|
721 | (rewrite '##sys#check-exact 2 2 "C_i_check_exact_2" #t #f) |
---|
722 | (rewrite '##sys#check-number 2 2 "C_i_check_number_2" #t #f) |
---|
723 | (rewrite '##sys#check-list 2 2 "C_i_check_list_2" #t #f) |
---|
724 | (rewrite '##sys#check-pair 2 2 "C_i_check_pair_2" #t #f) |
---|
725 | (rewrite '##sys#check-symbol 2 2 "C_i_check_symbol_2" #t #f) |
---|
726 | (rewrite '##sys#check-string 2 2 "C_i_check_string_2" #t #f) |
---|
727 | (rewrite '##sys#check-byte-vector 2 2 "C_i_check_bytevector_2" #t #f) |
---|
728 | (rewrite '##sys#check-vector 2 2 "C_i_check_vector_2" #t #f) |
---|
729 | (rewrite '##sys#check-structure 2 3 "C_i_check_structure_2" #t #f) |
---|
730 | (rewrite '##sys#check-char 2 2 "C_i_check_char_2" #t #f) |
---|
731 | |
---|
732 | (rewrite '= 9 "C_eqp" "C_i_equalp" #t #t) |
---|
733 | (rewrite '> 9 "C_fixnum_greaterp" "C_flonum_greaterp" #t #f) |
---|
734 | (rewrite '< 9 "C_fixnum_lessp" "C_flonum_lessp" #t #f) |
---|
735 | (rewrite '>= 9 "C_fixnum_greater_or_equal_p" "C_flonum_greater_or_equal_p" #t #f) |
---|
736 | (rewrite '<= 9 "C_fixnum_less_or_equal_p" "C_flonum_less_or_equal_p" #t #f) |
---|
737 | |
---|
738 | (rewrite 'setter 11 1 '##sys#setter #t) |
---|
739 | (rewrite 'for-each 11 2 '##sys#for-each #t) |
---|
740 | (rewrite 'map 11 2 '##sys#map #t) |
---|
741 | (rewrite 'block-set! 11 3 '##sys#setslot #t) |
---|
742 | (rewrite '##sys#block-set! 11 3 '##sys#setslot #f) |
---|
743 | (rewrite 'make-record-instance 11 #f '##sys#make-structure #f) |
---|
744 | (rewrite 'substring 11 3 '##sys#substring #f) |
---|
745 | (rewrite 'string-append 11 2 '##sys#string-append #f) |
---|
746 | (rewrite 'string->list 11 1 '##sys#string->list #t) |
---|
747 | (rewrite 'list->string 11 1 '##sys#list->string #t) |
---|
748 | |
---|
749 | (rewrite 'vector-set! 11 3 '##sys#setslot #f) |
---|
750 | (rewrite 'vector-set! 2 3 "C_i_vector_set" #t #f) |
---|
751 | |
---|
752 | (rewrite 'gcd 12 '##sys#gcd #t 2) |
---|
753 | (rewrite 'lcm 12 '##sys#lcm #t 2) |
---|
754 | (rewrite 'identity 12 #f #t 1) |
---|
755 | |
---|
756 | (rewrite 'gcd 18 0) |
---|
757 | (rewrite 'lcm 18 1) |
---|
758 | (rewrite 'list 18 '()) |
---|
759 | |
---|
760 | (rewrite 'argv 13 "C_get_argv" #t) |
---|
761 | |
---|
762 | (rewrite '* 16 2 "C_a_i_times" #t 4) ; words-per-flonum |
---|
763 | (rewrite '+ 16 2 "C_a_i_plus" #t 4) ; words-per-flonum |
---|
764 | (rewrite '- 16 2 "C_a_i_minus" #t 4) ; words-per-flonum |
---|
765 | (rewrite '/ 16 2 "C_a_i_divide" #t 4) ; words-per-flonum |
---|
766 | (rewrite '= 17 2 "C_i_nequalp") |
---|
767 | (rewrite '> 17 2 "C_i_greaterp") |
---|
768 | (rewrite '< 17 2 "C_i_lessp") |
---|
769 | (rewrite '>= 17 2 "C_i_greater_or_equalp") |
---|
770 | (rewrite '<= 17 2 "C_i_less_or_equalp") |
---|
771 | |
---|
772 | (rewrite '* 13 "C_times" #t) |
---|
773 | (rewrite '- 13 "C_minus" #t) |
---|
774 | (rewrite '+ 13 "C_plus" #t) |
---|
775 | (rewrite '/ 13 "C_divide" #t) |
---|
776 | (rewrite '= 13 "C_nequalp" #t) |
---|
777 | (rewrite '> 13 "C_greaterp" #t) |
---|
778 | (rewrite '< 13 "C_lessp" #t) |
---|
779 | (rewrite '>= 13 "C_greater_or_equal_p" #t) |
---|
780 | (rewrite '<= 13 "C_less_or_equal_p" #t) |
---|
781 | |
---|
782 | (rewrite 'exact->inexact 13 "C_exact_to_inexact" #t) |
---|
783 | (rewrite 'string->number 13 "C_string_to_number" #t) |
---|
784 | (rewrite 'number->string 13 "C_number_to_string" #t) |
---|
785 | (rewrite '##sys#call-with-current-continuation 13 "C_call_cc" #t) |
---|
786 | (rewrite '##sys#floor 13 "C_flonum_floor" #t) |
---|
787 | (rewrite '##sys#ceiling 13 "C_flonum_ceiling" #t) |
---|
788 | (rewrite '##sys#truncate 13 "C_flonum_truncate" #t) |
---|
789 | (rewrite '##sys#round 13 "C_flonum_round" #t) |
---|
790 | (rewrite '##sys#allocate-vector 13 "C_allocate_vector" #t) |
---|
791 | (rewrite '##sys#ensure-heap-reserve 13 "C_ensure_heap_reserve" #t) |
---|
792 | (rewrite 'return-to-host 13 "C_return_to_host" #t) |
---|
793 | (rewrite '##sys#context-switch 13 "C_context_switch" #t) |
---|
794 | (rewrite '##sys#intern-symbol 13 "C_string_to_symbol" #t) |
---|
795 | (rewrite '##sys#make-symbol 13 "C_make_symbol" #t) |
---|
796 | |
---|
797 | (rewrite 'even? 14 'fixnum 1 "C_i_fixnumevenp" "C_i_fixnumevenp") |
---|
798 | (rewrite 'odd? 14 'fixnum 1 "C_i_fixnumoddp" "C_i_fixnumoddp") |
---|
799 | (rewrite 'add1 14 'fixnum 1 "C_fixnum_increase" "C_u_fixnum_increase") |
---|
800 | (rewrite 'sub1 14 'fixnum 1 "C_fixnum_decrease" "C_u_fixnum_decrease") |
---|
801 | (rewrite 'remainder 14 'fixnum 2 "C_fixnum_modulo" "C_fixnum_modulo") |
---|
802 | |
---|
803 | (rewrite 'even? 2 1 "C_i_evenp" #t #f) |
---|
804 | (rewrite 'even? 2 1 "C_u_i_evenp" #f #f) |
---|
805 | (rewrite 'odd? 2 1 "C_i_oddp" #t #f) |
---|
806 | (rewrite 'odd? 2 1 "C_u_i_oddp" #f #f) |
---|
807 | |
---|
808 | (rewrite 'floor 15 'flonum 'fixnum '##sys#floor #f) |
---|
809 | (rewrite 'ceiling 15 'flonum 'fixnum '##sys#ceiling #f) |
---|
810 | (rewrite 'truncate 15 'flonum 'fixnum '##sys#truncate #f) |
---|
811 | (rewrite 'round 15 'flonum 'fixnum '##sys#round #f) |
---|
812 | |
---|
813 | (rewrite 'cons 16 2 "C_a_i_cons" #t 3) |
---|
814 | (rewrite '##sys#cons 16 2 "C_a_i_cons" #t 3) |
---|
815 | (rewrite 'list 16 #f "C_a_i_list" #t '(3)) |
---|
816 | (rewrite '##sys#list 16 #f "C_a_i_list" #t '(3)) |
---|
817 | (rewrite 'vector 16 #f "C_a_i_vector" #t #t) |
---|
818 | (rewrite '##sys#vector 16 #f "C_a_i_vector" #t #t) |
---|
819 | (rewrite '##sys#make-structure 16 #f "C_a_i_record" #t #t) |
---|
820 | (rewrite 'string 16 #f "C_a_i_string" #t #t) ; the last #t is actually too much, but we don't care |
---|
821 | |
---|
822 | (rewrite |
---|
823 | '##sys#setslot 8 |
---|
824 | (lambda (db classargs cont callargs) |
---|
825 | ;; (##sys#setslot <x> <y> <immediate>) -> (##core#inline "C_i_set_i_slot" <x> <y> <i>) |
---|
826 | ;; (##sys#setslot <x> <y> <z>) -> (##core#inline "C_i_setslot" <x> <y> <z>) |
---|
827 | (and (= (length callargs) 3) |
---|
828 | (make-node |
---|
829 | '##core#call '(#t) |
---|
830 | (list cont |
---|
831 | (make-node |
---|
832 | '##core#inline |
---|
833 | (let ([val (third callargs)]) |
---|
834 | (if (and (eq? 'quote (node-class val)) |
---|
835 | (immediate? (first (node-parameters val))) ) |
---|
836 | '("C_i_set_i_slot") |
---|
837 | '("C_i_setslot") ) ) |
---|
838 | callargs) ) ) ) ) ) |
---|
839 | |
---|
840 | (rewrite 'fx+ 17 2 "C_fixnum_plus" "C_u_fixnum_plus") |
---|
841 | (rewrite 'fx- 17 2 "C_fixnum_difference" "C_u_fixnum_difference") |
---|
842 | (rewrite 'fxshl 17 2 "C_fixnum_shift_left") |
---|
843 | (rewrite 'fxshr 17 2 "C_fixnum_shift_right") |
---|
844 | (rewrite 'fxneg 17 1 "C_fixnum_negate" "C_u_fixnum_negate") |
---|
845 | (rewrite 'fxxor 17 2 "C_fixnum_xor" "C_fixnum_xor") |
---|
846 | (rewrite 'fxand 17 2 "C_fixnum_and" "C_u_fixnum_and") |
---|
847 | (rewrite 'fxior 17 2 "C_fixnum_or" "C_u_fixnum_or") |
---|
848 | |
---|
849 | (rewrite |
---|
850 | 'arithmetic-shift 8 |
---|
851 | (lambda (db classargs cont callargs) |
---|
852 | ;; (arithmetic-shift <x> <-int>) -> (##core#inline "C_fixnum_shift_right" <x> -<int>) |
---|
853 | ;; (arithmetic-shift <x> <+int>) -> (##core#inline "C_fixnum_shift_left" <x> <int>) |
---|
854 | ;; _ -> (##core#inline "C_a_i_arithmetic_shift" <x> <y>) |
---|
855 | ;; not in fixnum-mode: _ -> (##core#inline_allocate ("C_a_i_arithmetic_shift" words-per-flonum) <x> <y>) |
---|
856 | (and (= 2 (length callargs)) |
---|
857 | (let ([val (second callargs)]) |
---|
858 | (make-node |
---|
859 | '##core#call '(#t) |
---|
860 | (list cont |
---|
861 | (or (and-let* ([(eq? 'quote (node-class val))] |
---|
862 | [(eq? number-type 'fixnum)] |
---|
863 | [n (first (node-parameters val))] |
---|
864 | [(and (fixnum? n) (not (big-fixnum? n)))] ) |
---|
865 | (if (negative? n) |
---|
866 | (make-node |
---|
867 | '##core#inline '("C_fixnum_shift_right") |
---|
868 | (list (first callargs) (qnode (- n))) ) |
---|
869 | (make-node |
---|
870 | '##core#inline '("C_fixnum_shift_left") |
---|
871 | (list (first callargs) val) ) ) ) |
---|
872 | (if (eq? number-type 'fixnum) |
---|
873 | (make-node '##core#inline '("C_i_fixnum_arithmetic_shift") callargs) |
---|
874 | (make-node '##core#inline_allocate (list "C_a_i_arithmetic_shift" words-per-flonum) |
---|
875 | callargs) ) ) ) ) ) ) ) ) |
---|
876 | |
---|
877 | (rewrite '##sys#byte 17 2 "C_subbyte") |
---|
878 | (rewrite '##sys#setbyte 17 3 "C_setbyte") |
---|
879 | (rewrite '##sys#peek-fixnum 17 2 "C_peek_fixnum") |
---|
880 | (rewrite '##sys#peek-byte 17 2 "C_peek_byte") |
---|
881 | (rewrite 'pointer->object 17 2 "C_pointer_to_object") |
---|
882 | (rewrite '##sys#setislot 17 3 "C_i_set_i_slot") |
---|
883 | (rewrite '##sys#poke-integer 17 3 "C_poke_integer") |
---|
884 | (rewrite '##sys#poke-double 17 3 "C_poke_double") |
---|
885 | (rewrite '##sys#double->number 17 1 "C_double_to_number") |
---|
886 | (rewrite 'string=? 17 2 "C_i_string_equal_p" "C_u_i_string_equal_p") |
---|
887 | (rewrite 'string-ci=? 17 2 "C_i_string_ci_equal_p") |
---|
888 | (rewrite '##sys#fudge 17 1 "C_fudge") |
---|
889 | (rewrite '##sys#fits-in-int? 17 1 "C_fits_in_int_p") |
---|
890 | (rewrite '##sys#fits-in-unsigned-int? 17 1 "C_fits_in_unsigned_int_p") |
---|
891 | (rewrite '##sys#flonum-in-fixnum-range? 17 1 "C_flonum_in_fixnum_range_p") |
---|
892 | (rewrite '##sys#permanent? 17 1 "C_permanentp") |
---|
893 | (rewrite '##sys#null-pointer? 17 1 "C_null_pointerp" "C_null_pointerp") |
---|
894 | (rewrite 'null-pointer? 17 1 "C_i_null_pointerp" "C_null_pointerp") |
---|
895 | (rewrite '##sys#immediate? 17 1 "C_immp") |
---|
896 | (rewrite 'locative->object 17 1 "C_i_locative_to_object") |
---|
897 | (rewrite 'locative-set! 17 2 "C_i_locative_set") |
---|
898 | (rewrite '##sys#foreign-fixnum-argument 17 1 "C_i_foreign_fixnum_argumentp") |
---|
899 | (rewrite '##sys#foreign-char-argument 17 1 "C_i_foreign_char_argumentp") |
---|
900 | (rewrite '##sys#foreign-flonum-argument 17 1 "C_i_foreign_flonum_argumentp") |
---|
901 | (rewrite '##sys#foreign-block-argument 17 1 "C_i_foreign_block_argumentp") |
---|
902 | (rewrite '##sys#foreign-number-vector-argument 17 2 "C_i_foreign_number_vector_argumentp") |
---|
903 | (rewrite '##sys#foreign-string-argument 17 1 "C_i_foreign_string_argumentp") |
---|
904 | (rewrite '##sys#foreign-pointer-argument 17 1 "C_i_foreign_pointer_argumentp") |
---|
905 | (rewrite '##sys#foreign-integer-argument 17 1 "C_i_foreign_integer_argumentp") |
---|
906 | (rewrite '##sys#foreign-unsigned-integer-argument 17 1 "C_i_foreign_unsigned_integer_argumentp") |
---|
907 | (rewrite '##sys#direct-return 17 2 "C_direct_return") |
---|
908 | |
---|
909 | (rewrite 'byte-vector-ref 2 2 "C_subbyte" #f #f) ; DEPRECATED |
---|
910 | (rewrite 'byte-vector-set! 2 3 "C_setbyte" #f #f) ; DEPRECATED |
---|
911 | (rewrite 'byte-vector-length 2 1 "C_block_size" #f #f) ; DEPRECATED |
---|
912 | (rewrite 'blob-size 2 1 "C_block_size" #f #f) ; DEPRECATED |
---|
913 | |
---|
914 | (rewrite 'u8vector-ref 2 2 "C_u_i_u8vector_ref" #f #f) |
---|
915 | (rewrite 's8vector-ref 2 2 "C_u_i_s8vector_ref" #f #f) |
---|
916 | (rewrite 'u16vector-ref 2 2 "C_u_i_u16vector_ref" #f #f) |
---|
917 | (rewrite 's16vector-ref 2 2 "C_u_i_s16vector_ref" #f #f) |
---|
918 | |
---|
919 | (rewrite 'u32vector-ref 22 2 "C_a_i_u32vector_ref" #f words-per-flonum "C_u_i_u32vector_ref") |
---|
920 | (rewrite 's32vector-ref 22 2 "C_a_i_s32vector_ref" #f words-per-flonum "C_u_i_s32vector_ref") |
---|
921 | |
---|
922 | (rewrite 'u8vector-set! 2 3 "C_u_i_u8vector_set" #f #f) |
---|
923 | (rewrite 's8vector-set! 2 3 "C_u_i_s8vector_set" #f #f) |
---|
924 | (rewrite 'u16vector-set! 2 3 "C_u_i_u16vector_set" #f #f) |
---|
925 | (rewrite 's16vector-set! 2 3 "C_u_i_s16vector_set" #f #f) |
---|
926 | (rewrite 'u32vector-set! 2 3 "C_u_i_u32vector_set" #f #f) |
---|
927 | (rewrite 's32vector-set! 2 3 "C_u_i_s32vector_set" #f #f) |
---|
928 | |
---|
929 | (rewrite 'u8vector-length 2 1 "C_u_i_8vector_length" #f #f) |
---|
930 | (rewrite 's8vector-length 2 1 "C_u_i_8vector_length" #f #f) |
---|
931 | (rewrite 'u16vector-length 2 1 "C_u_i_16vector_length" #f #f) |
---|
932 | (rewrite 's16vector-length 2 1 "C_u_i_16vector_length" #f #f) |
---|
933 | (rewrite 'u32vector-length 2 1 "C_u_i_32vector_length" #f #f) |
---|
934 | (rewrite 's32vector-length 2 1 "C_u_i_32vector_length" #f #f) |
---|
935 | (rewrite 'f32vector-length 2 1 "C_u_i_32vector_length" #f #f) |
---|
936 | (rewrite 'f64vector-length 2 1 "C_u_i_64vector_length" #f #f) |
---|
937 | |
---|
938 | (rewrite 'not-pair? 17 1 "C_i_not_pair_p") |
---|
939 | (rewrite 'atom? 17 1 "C_i_not_pair_p") |
---|
940 | (rewrite 'null-list? 17 1 "C_i_null_list_p" "C_i_nullp") |
---|
941 | |
---|
942 | (rewrite 'u8vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED |
---|
943 | (rewrite 's8vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED |
---|
944 | (rewrite 'u16vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED |
---|
945 | (rewrite 's16vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED |
---|
946 | (rewrite 'u32vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED |
---|
947 | (rewrite 's32vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED |
---|
948 | (rewrite 'f32vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED |
---|
949 | (rewrite 'f64vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED |
---|
950 | |
---|
951 | (rewrite 'u8vector->blob/shared 7 1 "C_slot" 1 #f) |
---|
952 | (rewrite 's8vector->blob/shared 7 1 "C_slot" 1 #f) |
---|
953 | (rewrite 'u16vector->blob/shared 7 1 "C_slot" 1 #f) |
---|
954 | (rewrite 's16vector->blob/shared 7 1 "C_slot" 1 #f) |
---|
955 | (rewrite 'u32vector->blob/shared 7 1 "C_slot" 1 #f) |
---|
956 | (rewrite 's32vector->blob/shared 7 1 "C_slot" 1 #f) |
---|
957 | (rewrite 'f32vector->blob/shared 7 1 "C_slot" 1 #f) |
---|
958 | (rewrite 'f64vector->blob/shared 7 1 "C_slot" 1 #f) |
---|
959 | |
---|
960 | (let () |
---|
961 | (define (rewrite-make-vector db classargs cont callargs) |
---|
962 | ;; (make-vector '<n> [<x>]) -> (let ((<tmp> <x>)) (##core#inline_allocate ("C_a_i_vector" <n>+1) '<n> <tmp>)) |
---|
963 | ;; - <n> should be less or equal to 32. |
---|
964 | (let ([argc (length callargs)]) |
---|
965 | (and (pair? callargs) |
---|
966 | (let ([n (first callargs)]) |
---|
967 | (and (eq? 'quote (node-class n)) |
---|
968 | (let ([tmp (gensym)] |
---|
969 | [c (first (node-parameters n))] ) |
---|
970 | (and (fixnum? c) |
---|
971 | (<= c 32) |
---|
972 | (let ([val (if (pair? (cdr callargs)) |
---|
973 | (second callargs) |
---|
974 | (make-node '##core#undefined '() '()) ) ] ) |
---|
975 | (make-node |
---|
976 | 'let |
---|
977 | (list tmp) |
---|
978 | (list val |
---|
979 | (make-node |
---|
980 | '##core#call '(#t) |
---|
981 | (list cont |
---|
982 | (make-node |
---|
983 | '##core#inline_allocate |
---|
984 | (list "C_a_i_vector" (add1 c)) |
---|
985 | (list-tabulate c (lambda (i) (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) ) ) ) |
---|
986 | (rewrite 'make-vector 8 rewrite-make-vector) |
---|
987 | (rewrite '##sys#make-vector 8 rewrite-make-vector) ) |
---|
988 | |
---|
989 | (rewrite 'thread-specific 7 1 "C_slot" 10 #f) |
---|
990 | (rewrite 'thread-specific-set! 20 2 "C_i_setslot" 10 #f) |
---|
991 | |
---|
992 | (let () |
---|
993 | (define (rewrite-call/cc db classargs cont callargs) |
---|
994 | ;; (call/cc <var>), <var> = (lambda (kont k) ... k is never used ...) -> (<var> #f) |
---|
995 | (and (= 1 (length callargs)) |
---|
996 | (let ([val (first callargs)]) |
---|
997 | (and (eq? '##core#variable (node-class val)) |
---|
998 | (and-let* ([proc (get db (first (node-parameters val)) 'value)] |
---|
999 | [(eq? '##core#lambda (node-class proc))] ) |
---|
1000 | (let ([llist (third (node-parameters proc))]) |
---|
1001 | (decompose-lambda-list |
---|
1002 | llist |
---|
1003 | (lambda (vars argc rest) |
---|
1004 | (and (= argc 2) |
---|
1005 | (let ([var (or rest (second llist))]) |
---|
1006 | (and (not (get db var 'references)) |
---|
1007 | (not (get db var 'assigned)) |
---|
1008 | (make-node |
---|
1009 | '##core#call '(#t) |
---|
1010 | (list val cont (qnode #f)) ) ) ) ) ) ) ) ) ) ) ) ) |
---|
1011 | (rewrite 'call-with-current-continuation 8 rewrite-call/cc) |
---|
1012 | (rewrite 'call/cc 8 rewrite-call/cc) ) |
---|
1013 | |
---|
1014 | (declare (hide setter-map)) |
---|
1015 | |
---|
1016 | (define setter-map |
---|
1017 | '((car . set-car!) |
---|
1018 | (cdr . set-cdr!) |
---|
1019 | (hash-table-ref . hash-table-set!) |
---|
1020 | (block-ref . block-set!) |
---|
1021 | (byte-vector-ref . byte-vector-set!) ; DEPRECATED |
---|
1022 | (locative-ref . locative-set!) |
---|
1023 | (u8vector-ref . u8vector-set!) |
---|
1024 | (s8vector-ref . s8vector-set!) |
---|
1025 | (u16vector-ref . u16vector-set!) |
---|
1026 | (s16vector-ref . s16vector-set!) |
---|
1027 | (u32vector-ref . u32vector-set!) |
---|
1028 | (s32vector-ref . s32vector-set!) |
---|
1029 | (f32vector-ref . f32vector-set!) |
---|
1030 | (f64vector-ref . f64vector-set!) |
---|
1031 | (pointer-u8-ref . pointer-u8-set!) |
---|
1032 | (pointer-s8-ref . pointer-s8-set!) |
---|
1033 | (pointer-u16-ref . pointer-u16-set!) |
---|
1034 | (pointer-s16-ref . pointer-s16-set!) |
---|
1035 | (pointer-u32-ref . pointer-u32-set!) |
---|
1036 | (pointer-s32-ref . pointer-s32-set!) |
---|
1037 | (pointer-f32-ref . pointer-f32-set!) |
---|
1038 | (pointer-f64-ref . pointer-f64-set!) |
---|
1039 | (string-ref . string-set!) |
---|
1040 | (global-ref . global-set!) |
---|
1041 | (vector-ref . vector-set!) ) ) |
---|
1042 | |
---|
1043 | (rewrite |
---|
1044 | '##sys#setter 8 |
---|
1045 | (lambda (db classargs cont callargs) |
---|
1046 | ;; (setter <known-getter>) -> <known-setter> |
---|
1047 | (and (= 1 (length callargs)) |
---|
1048 | (let ((arg (car callargs))) |
---|
1049 | (and (eq? '##core#variable (node-class arg)) |
---|
1050 | (let ((sym (car (node-parameters arg)))) |
---|
1051 | (and (or (get db sym 'standard-binding) |
---|
1052 | (get db sym 'extended-binding)) |
---|
1053 | (and-let* ((a (assq sym setter-map))) |
---|
1054 | (make-node |
---|
1055 | '##core#call '(#t) |
---|
1056 | (list cont (varnode (cdr a))) ) ) ) ) ) ) ) ) ) |
---|
1057 | |
---|
1058 | (rewrite 'void 3 '##sys#undefined-value) |
---|
1059 | (rewrite '##sys#void 3 '##sys#undefined-value) |
---|
1060 | |
---|
1061 | (rewrite |
---|
1062 | 'any? 8 |
---|
1063 | (lambda (db classargs cont callargs) |
---|
1064 | (and (= 1 (length callargs)) |
---|
1065 | (let ((arg (car callargs))) |
---|
1066 | (make-node |
---|
1067 | '##core#call '(#t) |
---|
1068 | (list cont |
---|
1069 | (if (and (eq? '##core#variable (node-class arg)) |
---|
1070 | (not (get db (car (node-parameters arg)) 'global)) ) |
---|
1071 | (qnode #t) |
---|
1072 | (make-node |
---|
1073 | '##core#inline '("C_anyp") |
---|
1074 | (list arg)) ) ) ) ) ) ) ) |
---|
1075 | |
---|
1076 | (rewrite |
---|
1077 | 'bit-set? 8 |
---|
1078 | (lambda (db classargs cont callargs) |
---|
1079 | (and (= 2 (length callargs)) |
---|
1080 | (make-node |
---|
1081 | '##core#call '(#t) |
---|
1082 | (list cont |
---|
1083 | (make-node |
---|
1084 | '##core#inline |
---|
1085 | (list (if (eq? number-type 'fixnum) "C_u_i_bit_setp" "C_i_bit_setp")) |
---|
1086 | callargs) ) ) ) ) ) |
---|
1087 | |
---|
1088 | (rewrite 'read-char 23 0 '##sys#read-char/port '##sys#standard-input) |
---|
1089 | (rewrite 'write-char 23 1 '##sys#write-char/port '##sys#standard-output) |
---|
1090 | (rewrite 'read-string 23 1 '##sys#read-string/port '##sys#standard-input) |
---|
1091 | (rewrite 'substring=? 23 2 '##sys#substring=? 0 0 #f) |
---|
1092 | (rewrite 'substring-ci=? 23 2 '##sys#substring-ci=? 0 0 #f) |
---|
1093 | (rewrite 'substring-index 23 2 '##sys#substring-index 0) |
---|
1094 | (rewrite 'substring-index-ci 23 2 '##sys#substring-index-ci 0) |
---|