1 ;;; open-coding primitive procedures
3 ;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
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.
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.
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
21 (define-module (language tree-il primitives)
22 #:use-module (system base pmatch)
23 #:use-module (rnrs bytevector)
24 #:use-module (system base syntax)
25 #:use-module (language tree-il)
26 #:use-module (srfi srfi-4)
27 #:use-module (srfi srfi-16)
28 #:export (resolve-primitives! add-interesting-primitive!
29 expand-primitives! effect-free-primitive?))
31 (define *interesting-primitive-names*
33 call-with-values @call-with-values
34 call-with-current-continuation @call-with-current-continuation
40 + * - / 1- 1+ quotient remainder modulo
41 ash logand logior logxor
43 pair? null? list? acons cons cons*
52 caaar caadr cadar caddr cdaar cdadr cddar cdddr
54 caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
55 cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
57 vector-ref vector-set!
58 variable-ref variable-set!
59 ;; args of variable-set are switched; it needs special help
61 struct? struct-vtable make-struct struct-ref struct-set!
63 bytevector-u8-ref bytevector-u8-set!
64 bytevector-s8-ref bytevector-s8-set!
65 u8vector-ref u8vector-set! s8vector-ref s8vector-set!
67 bytevector-u16-ref bytevector-u16-set!
68 bytevector-u16-native-ref bytevector-u16-native-set!
69 bytevector-s16-ref bytevector-s16-set!
70 bytevector-s16-native-ref bytevector-s16-native-set!
71 u16vector-ref u16vector-set! s16vector-ref s16vector-set!
73 bytevector-u32-ref bytevector-u32-set!
74 bytevector-u32-native-ref bytevector-u32-native-set!
75 bytevector-s32-ref bytevector-s32-set!
76 bytevector-s32-native-ref bytevector-s32-native-set!
77 u32vector-ref u32vector-set! s32vector-ref s32vector-set!
79 bytevector-u64-ref bytevector-u64-set!
80 bytevector-u64-native-ref bytevector-u64-native-set!
81 bytevector-s64-ref bytevector-s64-set!
82 bytevector-s64-native-ref bytevector-s64-native-set!
83 u64vector-ref u64vector-set! s64vector-ref s64vector-set!
85 bytevector-ieee-single-ref bytevector-ieee-single-set!
86 bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
87 bytevector-ieee-double-ref bytevector-ieee-double-set!
88 bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
89 f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
91 (define (add-interesting-primitive! name)
92 (hashq-set! *interesting-primitive-vars*
93 (or (module-variable (current-module) name)
94 (error "unbound interesting primitive" name))
97 (define *interesting-primitive-vars* (make-hash-table))
99 (for-each add-interesting-primitive! *interesting-primitive-names*)
101 (define *effect-free-primitives*
105 + * - / 1- 1+ quotient remainder modulo
107 pair? null? list? acons cons cons*
111 caaar caadr cadar caddr cdaar cdadr cddar cdddr
112 caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
113 cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
115 struct? struct-vtable make-struct struct-ref
116 bytevector-u8-ref bytevector-s8-ref
117 bytevector-u16-ref bytevector-u16-native-ref
118 bytevector-s16-ref bytevector-s16-native-ref
119 bytevector-u32-ref bytevector-u32-native-ref
120 bytevector-s32-ref bytevector-s32-native-ref
121 bytevector-u64-ref bytevector-u64-native-ref
122 bytevector-s64-ref bytevector-s64-native-ref
123 bytevector-ieee-single-ref bytevector-ieee-single-native-ref
124 bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
127 (define *effect-free-primitive-table* (make-hash-table))
129 (for-each (lambda (x) (hashq-set! *effect-free-primitive-table* x #t))
130 *effect-free-primitives*)
132 (define (effect-free-primitive? prim)
133 (hashq-ref *effect-free-primitive-table* prim))
135 (define (resolve-primitives! x mod)
139 ((<toplevel-ref> src name)
140 (and=> (hashq-ref *interesting-primitive-vars*
141 (module-variable mod name))
142 (lambda (name) (make-primitive-ref src name))))
143 ((<module-ref> src mod name public?)
144 ;; for the moment, we're disabling primitive resolution for
145 ;; public refs because resolve-interface can raise errors.
146 (let ((m (and (not public?) (resolve-module mod))))
148 (and=> (hashq-ref *interesting-primitive-vars*
149 (module-variable m name))
150 (lambda (name) (make-primitive-ref src name))))))
156 (define *primitive-expand-table* (make-hash-table))
158 (define (expand-primitives! x)
162 ((<application> src proc args)
163 (and (primitive-ref? proc)
164 (let ((expand (hashq-ref *primitive-expand-table*
165 (primitive-ref-name proc))))
166 (and expand (apply expand src args)))))
170 ;;; I actually did spend about 10 minutes trying to redo this with
171 ;;; syntax-rules. Patches appreciated.
173 (define-macro (define-primitive-expander sym . clauses)
174 (define (inline-args args)
175 (let lp ((in args) (out '()))
176 (cond ((null? in) `(list ,@(reverse out)))
177 ((symbol? in) `(cons* ,@(reverse out) ,in))
180 (cons `(make-application src (make-primitive-ref src ',(caar in))
181 ,(inline-args (cdar in)))
184 ;; assume it's locally bound
185 (lp (cdr in) (cons (car in) out)))
187 (lp (cdr in) (cons `(make-const src ,(car in)) out)))
189 (error "what what" (car in))))))
190 (define (consequent exp)
194 ((if ,test ,then ,else)
199 `(make-application src (make-primitive-ref src ',(car exp))
200 ,(inline-args (cdr exp))))))
202 ;; assume locally bound
205 `(make-const src ,exp))
206 (else (error "bad consequent yall" exp))))
207 `(hashq-set! *primitive-expand-table*
210 ,@(let lp ((in clauses) (out '()))
212 (reverse (cons '(else #f) out))
214 (cons `((src . ,(car in))
215 ,(consequent (cadr in))) out)))))))
217 (define-primitive-expander zero? (x)
220 (define-primitive-expander +
223 (x y) (if (and (const? y)
224 (let ((y (const-exp y)))
225 (and (number? y) (exact? y) (= y 1))))
228 (let ((y (const-exp y)))
229 (and (number? y) (exact? y) (= y -1))))
232 (let ((x (const-exp x)))
233 (and (number? x) (exact? x) (= x 1))))
236 (x y z . rest) (+ x (+ y z . rest)))
238 (define-primitive-expander *
241 (x y z . rest) (* x (* y z . rest)))
243 (define-primitive-expander -
245 (x y) (if (and (const? y)
246 (let ((y (const-exp y)))
247 (and (number? y) (exact? y) (= y 1))))
250 (x y z . rest) (- x (+ y z . rest)))
252 (define-primitive-expander /
254 (x y z . rest) (/ x (* y z . rest)))
256 (define-primitive-expander caar (x) (car (car x)))
257 (define-primitive-expander cadr (x) (car (cdr x)))
258 (define-primitive-expander cdar (x) (cdr (car x)))
259 (define-primitive-expander cddr (x) (cdr (cdr x)))
260 (define-primitive-expander caaar (x) (car (car (car x))))
261 (define-primitive-expander caadr (x) (car (car (cdr x))))
262 (define-primitive-expander cadar (x) (car (cdr (car x))))
263 (define-primitive-expander caddr (x) (car (cdr (cdr x))))
264 (define-primitive-expander cdaar (x) (cdr (car (car x))))
265 (define-primitive-expander cdadr (x) (cdr (car (cdr x))))
266 (define-primitive-expander cddar (x) (cdr (cdr (car x))))
267 (define-primitive-expander cdddr (x) (cdr (cdr (cdr x))))
268 (define-primitive-expander caaaar (x) (car (car (car (car x)))))
269 (define-primitive-expander caaadr (x) (car (car (car (cdr x)))))
270 (define-primitive-expander caadar (x) (car (car (cdr (car x)))))
271 (define-primitive-expander caaddr (x) (car (car (cdr (cdr x)))))
272 (define-primitive-expander cadaar (x) (car (cdr (car (car x)))))
273 (define-primitive-expander cadadr (x) (car (cdr (car (cdr x)))))
274 (define-primitive-expander caddar (x) (car (cdr (cdr (car x)))))
275 (define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x)))))
276 (define-primitive-expander cdaaar (x) (cdr (car (car (car x)))))
277 (define-primitive-expander cdaadr (x) (cdr (car (car (cdr x)))))
278 (define-primitive-expander cdadar (x) (cdr (car (cdr (car x)))))
279 (define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x)))))
280 (define-primitive-expander cddaar (x) (cdr (cdr (car (car x)))))
281 (define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x)))))
282 (define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x)))))
283 (define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
285 (define-primitive-expander cons*
288 (x y . rest) (cons x (cons* y . rest)))
290 (define-primitive-expander acons (x y z)
293 (define-primitive-expander apply (f a0 . args)
294 (@apply f a0 . args))
296 (define-primitive-expander call-with-values (producer consumer)
297 (@call-with-values producer consumer))
299 (define-primitive-expander call-with-current-continuation (proc)
300 (@call-with-current-continuation proc))
302 (define-primitive-expander call/cc (proc)
303 (@call-with-current-continuation proc))
305 (define-primitive-expander values (x) x)
308 (define-primitive-expander variable-set! (var val)
309 (variable-set val var))
311 (define-primitive-expander u8vector-ref (vec i)
312 (bytevector-u8-ref vec i))
313 (define-primitive-expander u8vector-set! (vec i x)
314 (bytevector-u8-set! vec i x))
315 (define-primitive-expander s8vector-ref (vec i)
316 (bytevector-s8-ref vec i))
317 (define-primitive-expander s8vector-set! (vec i x)
318 (bytevector-s8-set! vec i x))
320 (define-primitive-expander u16vector-ref (vec i)
321 (bytevector-u16-native-ref vec (* i 2)))
322 (define-primitive-expander u16vector-set! (vec i x)
323 (bytevector-u16-native-set! vec (* i 2) x))
324 (define-primitive-expander s16vector-ref (vec i)
325 (bytevector-s16-native-ref vec (* i 2)))
326 (define-primitive-expander s16vector-set! (vec i x)
327 (bytevector-s16-native-set! vec (* i 2) x))
329 (define-primitive-expander u32vector-ref (vec i)
330 (bytevector-u32-native-ref vec (* i 4)))
331 (define-primitive-expander u32vector-set! (vec i x)
332 (bytevector-u32-native-set! vec (* i 4) x))
333 (define-primitive-expander s32vector-ref (vec i)
334 (bytevector-s32-native-ref vec (* i 4)))
335 (define-primitive-expander s32vector-set! (vec i x)
336 (bytevector-s32-native-set! vec (* i 4) x))
338 (define-primitive-expander u64vector-ref (vec i)
339 (bytevector-u64-native-ref vec (* i 8)))
340 (define-primitive-expander u64vector-set! (vec i x)
341 (bytevector-u64-native-set! vec (* i 8) x))
342 (define-primitive-expander s64vector-ref (vec i)
343 (bytevector-s64-native-ref vec (* i 8)))
344 (define-primitive-expander s64vector-set! (vec i x)
345 (bytevector-s64-native-set! vec (* i 8) x))
347 (define-primitive-expander f32vector-ref (vec i)
348 (bytevector-ieee-single-native-ref vec (* i 4)))
349 (define-primitive-expander f32vector-set! (vec i x)
350 (bytevector-ieee-single-native-set! vec (* i 4) x))
351 (define-primitive-expander f32vector-ref (vec i)
352 (bytevector-ieee-single-native-ref vec (* i 4)))
353 (define-primitive-expander f32vector-set! (vec i x)
354 (bytevector-ieee-single-native-set! vec (* i 4) x))
356 (define-primitive-expander f64vector-ref (vec i)
357 (bytevector-ieee-double-native-ref vec (* i 8)))
358 (define-primitive-expander f64vector-set! (vec i x)
359 (bytevector-ieee-double-native-set! vec (* i 8) x))
360 (define-primitive-expander f64vector-ref (vec i)
361 (bytevector-ieee-double-native-ref vec (* i 8)))
362 (define-primitive-expander f64vector-set! (vec i x)
363 (bytevector-ieee-double-native-set! vec (* i 8) x))