Commit | Line | Data |
---|---|---|
ac4d09b1 | 1 | ;;; open-coding primitive procedures |
cb28c085 | 2 | |
b88fef55 | 3 | ;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. |
cb28c085 | 4 | |
53befeb7 NJ |
5 | ;;;; This library is free software; you can redistribute it and/or |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
cb28c085 AW |
18 | |
19 | ;;; Code: | |
20 | ||
55ae815b | 21 | (define-module (language tree-il primitives) |
7382f23e | 22 | #:use-module (system base pmatch) |
07d22c02 | 23 | #:use-module (rnrs bytevectors) |
cb28c085 AW |
24 | #:use-module (system base syntax) |
25 | #:use-module (language tree-il) | |
6c498233 | 26 | #:use-module (srfi srfi-4) |
cb28c085 | 27 | #:use-module (srfi srfi-16) |
55ae815b | 28 | #:export (resolve-primitives! add-interesting-primitive! |
4ee781a6 | 29 | expand-primitives! |
11671bba | 30 | effect-free-primitive? effect+exception-free-primitive? |
03026d0f | 31 | constructor-primitive? singly-valued-primitive?)) |
55ae815b AW |
32 | |
33 | (define *interesting-primitive-names* | |
34 | '(apply @apply | |
35 | call-with-values @call-with-values | |
36 | call-with-current-continuation @call-with-current-continuation | |
37 | call/cc | |
1bf78495 | 38 | dynamic-wind |
d69531e2 | 39 | @dynamic-wind |
55ae815b AW |
40 | values |
41 | eq? eqv? equal? | |
349d5c44 | 42 | memq memv |
55ae815b AW |
43 | = < > <= >= zero? |
44 | + * - / 1- 1+ quotient remainder modulo | |
b10d9330 | 45 | ash logand logior logxor |
55ae815b | 46 | not |
cf45ff03 | 47 | pair? null? list? symbol? vector? acons cons cons* |
55ae815b AW |
48 | |
49 | list vector | |
50 | ||
51 | car cdr | |
52 | set-car! set-cdr! | |
53 | ||
54 | caar cadr cdar cddr | |
55 | ||
56 | caaar caadr cadar caddr cdaar cdadr cddar cdddr | |
57 | ||
58 | caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr | |
d6f1ce3d AW |
59 | cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr |
60 | ||
39141c87 | 61 | vector-ref vector-set! |
1d30393f | 62 | variable-ref variable-set! |
d27a7811 | 63 | variable-bound? |
39141c87 | 64 | |
f5b1f76a AW |
65 | fluid-ref fluid-set! |
66 | ||
8fc43b12 | 67 | @prompt call-with-prompt @abort abort-to-prompt |
38030bdf | 68 | make-prompt-tag |
747022e4 | 69 | |
a752c0dc | 70 | struct? struct-vtable make-struct struct-ref struct-set! |
bd91ecce | 71 | |
39141c87 AW |
72 | bytevector-u8-ref bytevector-u8-set! |
73 | bytevector-s8-ref bytevector-s8-set! | |
6c498233 AW |
74 | u8vector-ref u8vector-set! s8vector-ref s8vector-set! |
75 | ||
39141c87 AW |
76 | bytevector-u16-ref bytevector-u16-set! |
77 | bytevector-u16-native-ref bytevector-u16-native-set! | |
78 | bytevector-s16-ref bytevector-s16-set! | |
79 | bytevector-s16-native-ref bytevector-s16-native-set! | |
6c498233 | 80 | u16vector-ref u16vector-set! s16vector-ref s16vector-set! |
39141c87 AW |
81 | |
82 | bytevector-u32-ref bytevector-u32-set! | |
83 | bytevector-u32-native-ref bytevector-u32-native-set! | |
84 | bytevector-s32-ref bytevector-s32-set! | |
85 | bytevector-s32-native-ref bytevector-s32-native-set! | |
6c498233 | 86 | u32vector-ref u32vector-set! s32vector-ref s32vector-set! |
39141c87 AW |
87 | |
88 | bytevector-u64-ref bytevector-u64-set! | |
89 | bytevector-u64-native-ref bytevector-u64-native-set! | |
90 | bytevector-s64-ref bytevector-s64-set! | |
91 | bytevector-s64-native-ref bytevector-s64-native-set! | |
6c498233 | 92 | u64vector-ref u64vector-set! s64vector-ref s64vector-set! |
39141c87 AW |
93 | |
94 | bytevector-ieee-single-ref bytevector-ieee-single-set! | |
95 | bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! | |
96 | bytevector-ieee-double-ref bytevector-ieee-double-set! | |
6c498233 AW |
97 | bytevector-ieee-double-native-ref bytevector-ieee-double-native-set! |
98 | f32vector-ref f32vector-set! f64vector-ref f64vector-set!)) | |
55ae815b AW |
99 | |
100 | (define (add-interesting-primitive! name) | |
101 | (hashq-set! *interesting-primitive-vars* | |
83c76550 AW |
102 | (or (module-variable (current-module) name) |
103 | (error "unbound interesting primitive" name)) | |
39141c87 | 104 | name)) |
55ae815b AW |
105 | |
106 | (define *interesting-primitive-vars* (make-hash-table)) | |
107 | ||
108 | (for-each add-interesting-primitive! *interesting-primitive-names*) | |
109 | ||
11671bba LC |
110 | (define *primitive-constructors* |
111 | ;; Primitives that return a fresh object. | |
112 | '(acons cons cons* list vector make-struct make-struct/no-tail)) | |
113 | ||
80af1168 | 114 | (define *effect-free-primitives* |
11671bba | 115 | `(values |
80af1168 AW |
116 | eq? eqv? equal? |
117 | = < > <= >= zero? | |
118 | + * - / 1- 1+ quotient remainder modulo | |
119 | not | |
11671bba | 120 | pair? null? list? symbol? vector? |
80af1168 AW |
121 | car cdr |
122 | caar cadr cdar cddr | |
123 | caaar caadr cadar caddr cdaar cdadr cddar cdddr | |
124 | caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr | |
125 | cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr | |
126 | vector-ref | |
11671bba | 127 | struct? struct-vtable struct-ref |
80af1168 AW |
128 | bytevector-u8-ref bytevector-s8-ref |
129 | bytevector-u16-ref bytevector-u16-native-ref | |
130 | bytevector-s16-ref bytevector-s16-native-ref | |
131 | bytevector-u32-ref bytevector-u32-native-ref | |
132 | bytevector-s32-ref bytevector-s32-native-ref | |
133 | bytevector-u64-ref bytevector-u64-native-ref | |
134 | bytevector-s64-ref bytevector-s64-native-ref | |
135 | bytevector-ieee-single-ref bytevector-ieee-single-native-ref | |
11671bba LC |
136 | bytevector-ieee-double-ref bytevector-ieee-double-native-ref |
137 | ,@*primitive-constructors*)) | |
80af1168 | 138 | |
4ee781a6 AW |
139 | ;; Like *effect-free-primitives* above, but further restricted in that they |
140 | ;; cannot raise exceptions. | |
141 | (define *effect+exception-free-primitives* | |
142 | '(values | |
143 | eq? eqv? equal? | |
144 | not | |
cf45ff03 | 145 | pair? null? list? symbol? vector? acons cons cons* |
4ee781a6 | 146 | list vector |
9b3cc659 | 147 | struct?)) |
80af1168 | 148 | |
03026d0f AW |
149 | ;; Primitives that only return one value. |
150 | (define *singly-valued-primitives* | |
151 | '(eq? eqv? equal? | |
152 | memq memv | |
153 | = < > <= >= zero? | |
154 | + * - / 1- 1+ quotient remainder modulo | |
155 | ash logand logior logxor | |
156 | not | |
157 | pair? null? list? symbol? vector? acons cons cons* | |
158 | list vector | |
159 | car cdr | |
160 | set-car! set-cdr! | |
161 | caar cadr cdar cddr | |
162 | caaar caadr cadar caddr cdaar cdadr cddar cdddr | |
163 | caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr | |
164 | cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr | |
165 | vector-ref vector-set! | |
166 | variable-ref variable-set! | |
167 | variable-bound? | |
168 | fluid-ref fluid-set! | |
169 | make-prompt-tag | |
170 | struct? struct-vtable make-struct struct-ref struct-set! | |
171 | bytevector-u8-ref bytevector-u8-set! | |
172 | bytevector-s8-ref bytevector-s8-set! | |
173 | u8vector-ref u8vector-set! s8vector-ref s8vector-set! | |
174 | bytevector-u16-ref bytevector-u16-set! | |
175 | bytevector-u16-native-ref bytevector-u16-native-set! | |
176 | bytevector-s16-ref bytevector-s16-set! | |
177 | bytevector-s16-native-ref bytevector-s16-native-set! | |
178 | u16vector-ref u16vector-set! s16vector-ref s16vector-set! | |
179 | bytevector-u32-ref bytevector-u32-set! | |
180 | bytevector-u32-native-ref bytevector-u32-native-set! | |
181 | bytevector-s32-ref bytevector-s32-set! | |
182 | bytevector-s32-native-ref bytevector-s32-native-set! | |
183 | u32vector-ref u32vector-set! s32vector-ref s32vector-set! | |
184 | bytevector-u64-ref bytevector-u64-set! | |
185 | bytevector-u64-native-ref bytevector-u64-native-set! | |
186 | bytevector-s64-ref bytevector-s64-set! | |
187 | bytevector-s64-native-ref bytevector-s64-native-set! | |
188 | u64vector-ref u64vector-set! s64vector-ref s64vector-set! | |
189 | bytevector-ieee-single-ref bytevector-ieee-single-set! | |
190 | bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! | |
191 | bytevector-ieee-double-ref bytevector-ieee-double-set! | |
192 | bytevector-ieee-double-native-ref bytevector-ieee-double-native-set! | |
193 | f32vector-ref f32vector-set! f64vector-ref f64vector-set!)) | |
194 | ||
80af1168 | 195 | (define *effect-free-primitive-table* (make-hash-table)) |
4ee781a6 | 196 | (define *effect+exceptions-free-primitive-table* (make-hash-table)) |
03026d0f | 197 | (define *singly-valued-primitive-table* (make-hash-table)) |
80af1168 | 198 | |
4ee781a6 AW |
199 | (for-each (lambda (x) |
200 | (hashq-set! *effect-free-primitive-table* x #t)) | |
80af1168 | 201 | *effect-free-primitives*) |
4ee781a6 AW |
202 | (for-each (lambda (x) |
203 | (hashq-set! *effect+exceptions-free-primitive-table* x #t)) | |
204 | *effect+exception-free-primitives*) | |
03026d0f AW |
205 | (for-each (lambda (x) |
206 | (hashq-set! *singly-valued-primitive-table* x #t)) | |
207 | *singly-valued-primitives*) | |
80af1168 | 208 | |
11671bba LC |
209 | (define (constructor-primitive? prim) |
210 | (memq prim *primitive-constructors*)) | |
80af1168 AW |
211 | (define (effect-free-primitive? prim) |
212 | (hashq-ref *effect-free-primitive-table* prim)) | |
4ee781a6 AW |
213 | (define (effect+exception-free-primitive? prim) |
214 | (hashq-ref *effect+exceptions-free-primitive-table* prim)) | |
03026d0f AW |
215 | (define (singly-valued-primitive? prim) |
216 | (hashq-ref *singly-valued-primitive-table* prim)) | |
80af1168 | 217 | |
55ae815b AW |
218 | (define (resolve-primitives! x mod) |
219 | (post-order! | |
220 | (lambda (x) | |
221 | (record-case x | |
222 | ((<toplevel-ref> src name) | |
c0ee3245 AW |
223 | (and=> (hashq-ref *interesting-primitive-vars* |
224 | (module-variable mod name)) | |
225 | (lambda (name) (make-primitive-ref src name)))) | |
55ae815b AW |
226 | ((<module-ref> src mod name public?) |
227 | ;; for the moment, we're disabling primitive resolution for | |
228 | ;; public refs because resolve-interface can raise errors. | |
229 | (let ((m (and (not public?) (resolve-module mod)))) | |
c0ee3245 AW |
230 | (and m |
231 | (and=> (hashq-ref *interesting-primitive-vars* | |
232 | (module-variable m name)) | |
233 | (lambda (name) (make-primitive-ref src name)))))) | |
55ae815b AW |
234 | (else #f))) |
235 | x)) | |
236 | ||
237 | \f | |
cb28c085 AW |
238 | |
239 | (define *primitive-expand-table* (make-hash-table)) | |
240 | ||
241 | (define (expand-primitives! x) | |
242 | (pre-order! | |
243 | (lambda (x) | |
244 | (record-case x | |
245 | ((<application> src proc args) | |
246 | (and (primitive-ref? proc) | |
247 | (let ((expand (hashq-ref *primitive-expand-table* | |
248 | (primitive-ref-name proc)))) | |
249 | (and expand (apply expand src args))))) | |
250 | (else #f))) | |
251 | x)) | |
252 | ||
253 | ;;; I actually did spend about 10 minutes trying to redo this with | |
254 | ;;; syntax-rules. Patches appreciated. | |
255 | ;;; | |
256 | (define-macro (define-primitive-expander sym . clauses) | |
257 | (define (inline-args args) | |
258 | (let lp ((in args) (out '())) | |
259 | (cond ((null? in) `(list ,@(reverse out))) | |
260 | ((symbol? in) `(cons* ,@(reverse out) ,in)) | |
261 | ((pair? (car in)) | |
262 | (lp (cdr in) | |
9b2a2a39 AW |
263 | (cons (if (eq? (caar in) 'quote) |
264 | `(make-const src ,@(cdar in)) | |
265 | `(make-application src (make-primitive-ref src ',(caar in)) | |
266 | ,(inline-args (cdar in)))) | |
cb28c085 AW |
267 | out))) |
268 | ((symbol? (car in)) | |
269 | ;; assume it's locally bound | |
270 | (lp (cdr in) (cons (car in) out))) | |
9b2a2a39 | 271 | ((self-evaluating? (car in)) |
cb28c085 AW |
272 | (lp (cdr in) (cons `(make-const src ,(car in)) out))) |
273 | (else | |
274 | (error "what what" (car in)))))) | |
275 | (define (consequent exp) | |
276 | (cond | |
277 | ((pair? exp) | |
7382f23e AW |
278 | (pmatch exp |
279 | ((if ,test ,then ,else) | |
280 | `(if ,test | |
281 | ,(consequent then) | |
282 | ,(consequent else))) | |
283 | (else | |
284 | `(make-application src (make-primitive-ref src ',(car exp)) | |
285 | ,(inline-args (cdr exp)))))) | |
cb28c085 AW |
286 | ((symbol? exp) |
287 | ;; assume locally bound | |
288 | exp) | |
289 | ((number? exp) | |
290 | `(make-const src ,exp)) | |
9a974fd3 AW |
291 | ((not exp) |
292 | ;; failed match | |
293 | #f) | |
cb28c085 AW |
294 | (else (error "bad consequent yall" exp)))) |
295 | `(hashq-set! *primitive-expand-table* | |
296 | ',sym | |
297 | (case-lambda | |
298 | ,@(let lp ((in clauses) (out '())) | |
299 | (if (null? in) | |
300 | (reverse (cons '(else #f) out)) | |
301 | (lp (cddr in) | |
302 | (cons `((src . ,(car in)) | |
303 | ,(consequent (cadr in))) out))))))) | |
304 | ||
9b29d607 AW |
305 | (define-primitive-expander zero? (x) |
306 | (= x 0)) | |
307 | ||
11671bba LC |
308 | ;; FIXME: All the code that uses `const?' is redundant with `peval'. |
309 | ||
cb28c085 AW |
310 | (define-primitive-expander + |
311 | () 0 | |
b88fef55 | 312 | (x) (values x) |
7382f23e AW |
313 | (x y) (if (and (const? y) |
314 | (let ((y (const-exp y))) | |
eebff6d7 | 315 | (and (number? y) (exact? y) (= y 1)))) |
7382f23e | 316 | (1+ x) |
8753fd53 | 317 | (if (and (const? y) |
dd902692 LC |
318 | (let ((y (const-exp y))) |
319 | (and (number? y) (exact? y) (= y -1)))) | |
8753fd53 AW |
320 | (1- x) |
321 | (if (and (const? x) | |
322 | (let ((x (const-exp x))) | |
dd902692 | 323 | (and (number? x) (exact? x) (= x 1)))) |
8753fd53 AW |
324 | (1+ y) |
325 | (+ x y)))) | |
cb28c085 AW |
326 | (x y z . rest) (+ x (+ y z . rest))) |
327 | ||
328 | (define-primitive-expander * | |
329 | () 1 | |
b88fef55 | 330 | (x) (values x) |
cb28c085 AW |
331 | (x y z . rest) (* x (* y z . rest))) |
332 | ||
333 | (define-primitive-expander - | |
334 | (x) (- 0 x) | |
7382f23e AW |
335 | (x y) (if (and (const? y) |
336 | (let ((y (const-exp y))) | |
eebff6d7 | 337 | (and (number? y) (exact? y) (= y 1)))) |
7382f23e AW |
338 | (1- x) |
339 | (- x y)) | |
cb28c085 AW |
340 | (x y z . rest) (- x (+ y z . rest))) |
341 | ||
cb28c085 AW |
342 | (define-primitive-expander / |
343 | (x) (/ 1 x) | |
81fd3152 | 344 | (x y z . rest) (/ x (* y z . rest))) |
cb28c085 AW |
345 | |
346 | (define-primitive-expander caar (x) (car (car x))) | |
347 | (define-primitive-expander cadr (x) (car (cdr x))) | |
348 | (define-primitive-expander cdar (x) (cdr (car x))) | |
349 | (define-primitive-expander cddr (x) (cdr (cdr x))) | |
350 | (define-primitive-expander caaar (x) (car (car (car x)))) | |
351 | (define-primitive-expander caadr (x) (car (car (cdr x)))) | |
352 | (define-primitive-expander cadar (x) (car (cdr (car x)))) | |
353 | (define-primitive-expander caddr (x) (car (cdr (cdr x)))) | |
354 | (define-primitive-expander cdaar (x) (cdr (car (car x)))) | |
355 | (define-primitive-expander cdadr (x) (cdr (car (cdr x)))) | |
356 | (define-primitive-expander cddar (x) (cdr (cdr (car x)))) | |
357 | (define-primitive-expander cdddr (x) (cdr (cdr (cdr x)))) | |
358 | (define-primitive-expander caaaar (x) (car (car (car (car x))))) | |
359 | (define-primitive-expander caaadr (x) (car (car (car (cdr x))))) | |
360 | (define-primitive-expander caadar (x) (car (car (cdr (car x))))) | |
361 | (define-primitive-expander caaddr (x) (car (car (cdr (cdr x))))) | |
362 | (define-primitive-expander cadaar (x) (car (cdr (car (car x))))) | |
363 | (define-primitive-expander cadadr (x) (car (cdr (car (cdr x))))) | |
364 | (define-primitive-expander caddar (x) (car (cdr (cdr (car x))))) | |
365 | (define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x))))) | |
366 | (define-primitive-expander cdaaar (x) (cdr (car (car (car x))))) | |
367 | (define-primitive-expander cdaadr (x) (cdr (car (car (cdr x))))) | |
368 | (define-primitive-expander cdadar (x) (cdr (car (cdr (car x))))) | |
369 | (define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x))))) | |
370 | (define-primitive-expander cddaar (x) (cdr (cdr (car (car x))))) | |
371 | (define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x))))) | |
372 | (define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x))))) | |
373 | (define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x))))) | |
374 | ||
375 | (define-primitive-expander cons* | |
b88fef55 | 376 | (x) (values x) |
cb28c085 AW |
377 | (x y) (cons x y) |
378 | (x y . rest) (cons x (cons* y . rest))) | |
379 | ||
dce042f1 AW |
380 | (define-primitive-expander acons (x y z) |
381 | (cons (cons x y) z)) | |
382 | ||
0e249fd3 AW |
383 | (define-primitive-expander apply (f a0 . args) |
384 | (@apply f a0 . args)) | |
dce042f1 AW |
385 | |
386 | (define-primitive-expander call-with-values (producer consumer) | |
387 | (@call-with-values producer consumer)) | |
388 | ||
389 | (define-primitive-expander call-with-current-continuation (proc) | |
390 | (@call-with-current-continuation proc)) | |
391 | ||
0f423f20 AW |
392 | (define-primitive-expander call/cc (proc) |
393 | (@call-with-current-continuation proc)) | |
394 | ||
9a974fd3 AW |
395 | (define-primitive-expander make-struct (vtable tail-size . args) |
396 | (if (and (const? tail-size) | |
397 | (let ((n (const-exp tail-size))) | |
398 | (and (number? n) (exact? n) (zero? n)))) | |
399 | (make-struct/no-tail vtable . args) | |
400 | #f)) | |
401 | ||
6c498233 AW |
402 | (define-primitive-expander u8vector-ref (vec i) |
403 | (bytevector-u8-ref vec i)) | |
404 | (define-primitive-expander u8vector-set! (vec i x) | |
405 | (bytevector-u8-set! vec i x)) | |
406 | (define-primitive-expander s8vector-ref (vec i) | |
407 | (bytevector-s8-ref vec i)) | |
408 | (define-primitive-expander s8vector-set! (vec i x) | |
409 | (bytevector-s8-set! vec i x)) | |
410 | ||
411 | (define-primitive-expander u16vector-ref (vec i) | |
412 | (bytevector-u16-native-ref vec (* i 2))) | |
413 | (define-primitive-expander u16vector-set! (vec i x) | |
414 | (bytevector-u16-native-set! vec (* i 2) x)) | |
415 | (define-primitive-expander s16vector-ref (vec i) | |
416 | (bytevector-s16-native-ref vec (* i 2))) | |
417 | (define-primitive-expander s16vector-set! (vec i x) | |
418 | (bytevector-s16-native-set! vec (* i 2) x)) | |
419 | ||
420 | (define-primitive-expander u32vector-ref (vec i) | |
421 | (bytevector-u32-native-ref vec (* i 4))) | |
422 | (define-primitive-expander u32vector-set! (vec i x) | |
423 | (bytevector-u32-native-set! vec (* i 4) x)) | |
424 | (define-primitive-expander s32vector-ref (vec i) | |
425 | (bytevector-s32-native-ref vec (* i 4))) | |
426 | (define-primitive-expander s32vector-set! (vec i x) | |
427 | (bytevector-s32-native-set! vec (* i 4) x)) | |
428 | ||
429 | (define-primitive-expander u64vector-ref (vec i) | |
430 | (bytevector-u64-native-ref vec (* i 8))) | |
431 | (define-primitive-expander u64vector-set! (vec i x) | |
432 | (bytevector-u64-native-set! vec (* i 8) x)) | |
433 | (define-primitive-expander s64vector-ref (vec i) | |
434 | (bytevector-s64-native-ref vec (* i 8))) | |
435 | (define-primitive-expander s64vector-set! (vec i x) | |
436 | (bytevector-s64-native-set! vec (* i 8) x)) | |
437 | ||
438 | (define-primitive-expander f32vector-ref (vec i) | |
439 | (bytevector-ieee-single-native-ref vec (* i 4))) | |
440 | (define-primitive-expander f32vector-set! (vec i x) | |
441 | (bytevector-ieee-single-native-set! vec (* i 4) x)) | |
442 | (define-primitive-expander f32vector-ref (vec i) | |
443 | (bytevector-ieee-single-native-ref vec (* i 4))) | |
444 | (define-primitive-expander f32vector-set! (vec i x) | |
445 | (bytevector-ieee-single-native-set! vec (* i 4) x)) | |
446 | ||
447 | (define-primitive-expander f64vector-ref (vec i) | |
448 | (bytevector-ieee-double-native-ref vec (* i 8))) | |
449 | (define-primitive-expander f64vector-set! (vec i x) | |
450 | (bytevector-ieee-double-native-set! vec (* i 8) x)) | |
451 | (define-primitive-expander f64vector-ref (vec i) | |
452 | (bytevector-ieee-double-native-ref vec (* i 8))) | |
453 | (define-primitive-expander f64vector-set! (vec i x) | |
454 | (bytevector-ieee-double-native-set! vec (* i 8) x)) | |
1bf78495 AW |
455 | |
456 | (hashq-set! *primitive-expand-table* | |
457 | 'dynamic-wind | |
458 | (case-lambda | |
459 | ((src pre thunk post) | |
460 | ;; Here we will make concessions to the fact that our inliner is | |
461 | ;; lame, and add a hack. | |
462 | (cond | |
463 | ((lambda? thunk) | |
464 | (let ((PRE (gensym " pre")) | |
465 | (POST (gensym " post"))) | |
466 | (make-let | |
467 | src | |
468 | '(pre post) | |
469 | (list PRE POST) | |
470 | (list pre post) | |
8da6ab34 | 471 | (make-dynwind |
1bf78495 AW |
472 | src |
473 | (make-lexical-ref #f 'pre PRE) | |
474 | (make-application #f thunk '()) | |
475 | (make-lexical-ref #f 'post POST))))) | |
476 | (else | |
477 | (let ((PRE (gensym " pre")) | |
478 | (THUNK (gensym " thunk")) | |
479 | (POST (gensym " post"))) | |
480 | (make-let | |
481 | src | |
482 | '(pre thunk post) | |
483 | (list PRE THUNK POST) | |
484 | (list pre thunk post) | |
8da6ab34 | 485 | (make-dynwind |
1bf78495 AW |
486 | src |
487 | (make-lexical-ref #f 'pre PRE) | |
488 | (make-application #f (make-lexical-ref #f 'thunk THUNK) '()) | |
489 | (make-lexical-ref #f 'post POST))))))) | |
490 | (else #f))) | |
9b2a2a39 | 491 | |
d69531e2 AW |
492 | (hashq-set! *primitive-expand-table* |
493 | '@dynamic-wind | |
494 | (case-lambda | |
495 | ((src pre expr post) | |
496 | (let ((PRE (gensym " pre")) | |
497 | (POST (gensym " post"))) | |
498 | (make-let | |
499 | src | |
500 | '(pre post) | |
501 | (list PRE POST) | |
502 | (list pre post) | |
8da6ab34 | 503 | (make-dynwind |
d69531e2 AW |
504 | src |
505 | (make-lexical-ref #f 'pre PRE) | |
506 | expr | |
507 | (make-lexical-ref #f 'post POST))))))) | |
508 | ||
f5b1f76a AW |
509 | (hashq-set! *primitive-expand-table* |
510 | 'fluid-ref | |
511 | (case-lambda | |
512 | ((src fluid) (make-dynref src fluid)) | |
513 | (else #f))) | |
514 | ||
515 | (hashq-set! *primitive-expand-table* | |
516 | 'fluid-set! | |
517 | (case-lambda | |
518 | ((src fluid exp) (make-dynset src fluid exp)) | |
519 | (else #f))) | |
520 | ||
9b2a2a39 AW |
521 | (hashq-set! *primitive-expand-table* |
522 | '@prompt | |
523 | (case-lambda | |
ea6b18e8 AW |
524 | ((src tag exp handler) |
525 | (let ((args-sym (gensym))) | |
526 | (make-prompt | |
527 | src tag exp | |
528 | ;; If handler itself is a lambda, the inliner can do some | |
529 | ;; trickery here. | |
530 | (make-lambda-case | |
531 | (tree-il-src handler) '() #f 'args #f '() (list args-sym) | |
532 | (make-application #f (make-primitive-ref #f 'apply) | |
533 | (list handler | |
534 | (make-lexical-ref #f 'args args-sym))) | |
535 | #f)))) | |
9b2a2a39 AW |
536 | (else #f))) |
537 | ||
538 | (hashq-set! *primitive-expand-table* | |
8fc43b12 | 539 | 'call-with-prompt |
9b2a2a39 | 540 | (case-lambda |
f828ab4f AW |
541 | ((src tag thunk handler) |
542 | ;; Sigh. Until the inliner does its job, manually inline | |
543 | ;; (let ((h (lambda ...))) (prompt k x h)) | |
544 | (cond | |
545 | ((lambda? handler) | |
546 | (let ((args-sym (gensym))) | |
547 | (make-prompt | |
548 | src tag (make-application #f thunk '()) | |
549 | ;; If handler itself is a lambda, the inliner can do some | |
550 | ;; trickery here. | |
551 | (make-lambda-case | |
552 | (tree-il-src handler) '() #f 'args #f '() (list args-sym) | |
553 | (make-application #f (make-primitive-ref #f 'apply) | |
554 | (list handler | |
555 | (make-lexical-ref #f 'args args-sym))) | |
556 | #f)))) | |
557 | (else #f))) | |
9b2a2a39 | 558 | (else #f))) |
f828ab4f | 559 | |
2d026f04 AW |
560 | (hashq-set! *primitive-expand-table* |
561 | '@abort | |
562 | (case-lambda | |
563 | ((src tag tail-args) | |
564 | (make-abort src tag '() tail-args)) | |
565 | (else #f))) | |
9b2a2a39 | 566 | (hashq-set! *primitive-expand-table* |
8fc43b12 | 567 | 'abort-to-prompt |
9b2a2a39 | 568 | (case-lambda |
6e84cb95 | 569 | ((src tag . args) |
2d026f04 | 570 | (make-abort src tag args (make-const #f '()))) |
9b2a2a39 | 571 | (else #f))) |