;;; open-coding primitive procedures
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
#:use-module (rnrs bytevector)
#:use-module (system base syntax)
#:use-module (language tree-il)
+ #:use-module (srfi srfi-4)
#:use-module (srfi srfi-16)
#:export (resolve-primitives! add-interesting-primitive!
- expand-primitives!))
+ expand-primitives! effect-free-primitive?))
(define *interesting-primitive-names*
'(apply @apply
call-with-values @call-with-values
call-with-current-continuation @call-with-current-continuation
call/cc
+ dynamic-wind
+ @dynamic-wind
values
eq? eqv? equal?
+ memq memv
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
+ ash logand logior logxor
not
pair? null? list? acons cons cons*
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
vector-ref vector-set!
+ variable-ref variable-set!
+ variable-bound?
+ ;; args of variable-set are switched; it needs special help
+
+ fluid-ref fluid-set!
+
+ @prompt call-with-prompt @abort abort-to-prompt
+
+ struct? struct-vtable make-struct struct-ref struct-set!
bytevector-u8-ref bytevector-u8-set!
bytevector-s8-ref bytevector-s8-set!
-
+ u8vector-ref u8vector-set! s8vector-ref s8vector-set!
+
bytevector-u16-ref bytevector-u16-set!
bytevector-u16-native-ref bytevector-u16-native-set!
bytevector-s16-ref bytevector-s16-set!
bytevector-s16-native-ref bytevector-s16-native-set!
+ u16vector-ref u16vector-set! s16vector-ref s16vector-set!
bytevector-u32-ref bytevector-u32-set!
bytevector-u32-native-ref bytevector-u32-native-set!
bytevector-s32-ref bytevector-s32-set!
bytevector-s32-native-ref bytevector-s32-native-set!
+ u32vector-ref u32vector-set! s32vector-ref s32vector-set!
bytevector-u64-ref bytevector-u64-set!
bytevector-u64-native-ref bytevector-u64-native-set!
bytevector-s64-ref bytevector-s64-set!
bytevector-s64-native-ref bytevector-s64-native-set!
+ u64vector-ref u64vector-set! s64vector-ref s64vector-set!
bytevector-ieee-single-ref bytevector-ieee-single-set!
bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
bytevector-ieee-double-ref bytevector-ieee-double-set!
- bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!))
+ bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
+ f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
(define (add-interesting-primitive! name)
(hashq-set! *interesting-primitive-vars*
- (module-variable (current-module) name)
+ (or (module-variable (current-module) name)
+ (error "unbound interesting primitive" name))
name))
(define *interesting-primitive-vars* (make-hash-table))
(for-each add-interesting-primitive! *interesting-primitive-names*)
+(define *effect-free-primitives*
+ '(values
+ eq? eqv? equal?
+ = < > <= >= zero?
+ + * - / 1- 1+ quotient remainder modulo
+ not
+ pair? null? list? acons cons cons*
+ list vector
+ car cdr
+ caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ vector-ref
+ struct? struct-vtable make-struct struct-ref
+ bytevector-u8-ref bytevector-s8-ref
+ bytevector-u16-ref bytevector-u16-native-ref
+ bytevector-s16-ref bytevector-s16-native-ref
+ bytevector-u32-ref bytevector-u32-native-ref
+ bytevector-s32-ref bytevector-s32-native-ref
+ bytevector-u64-ref bytevector-u64-native-ref
+ bytevector-s64-ref bytevector-s64-native-ref
+ bytevector-ieee-single-ref bytevector-ieee-single-native-ref
+ bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
+
+
+(define *effect-free-primitive-table* (make-hash-table))
+
+(for-each (lambda (x) (hashq-set! *effect-free-primitive-table* x #t))
+ *effect-free-primitives*)
+
+(define (effect-free-primitive? prim)
+ (hashq-ref *effect-free-primitive-table* prim))
+
(define (resolve-primitives! x mod)
(post-order!
(lambda (x)
((symbol? in) `(cons* ,@(reverse out) ,in))
((pair? (car in))
(lp (cdr in)
- (cons `(make-application src (make-primitive-ref src ',(caar in))
- ,(inline-args (cdar in)))
+ (cons (if (eq? (caar in) 'quote)
+ `(make-const src ,@(cdar in))
+ `(make-application src (make-primitive-ref src ',(caar in))
+ ,(inline-args (cdar in))))
out)))
((symbol? (car in))
;; assume it's locally bound
(lp (cdr in) (cons (car in) out)))
- ((number? (car in))
+ ((self-evaluating? (car in))
(lp (cdr in) (cons `(make-const src ,(car in)) out)))
(else
(error "what what" (car in))))))
exp)
((number? exp)
`(make-const src ,exp))
+ ((not exp)
+ ;; failed match
+ #f)
(else (error "bad consequent yall" exp))))
`(hashq-set! *primitive-expand-table*
',sym
(cons `((src . ,(car in))
,(consequent (cadr in))) out)))))))
+(define-primitive-expander zero? (x)
+ (= x 0))
+
(define-primitive-expander +
() 0
(x) x
(x y) (if (and (const? y)
(let ((y (const-exp y)))
- (and (exact? y) (= y 1))))
+ (and (number? y) (exact? y) (= y 1))))
(1+ x)
- (if (and (const? x)
- (let ((x (const-exp x)))
- (and (exact? x) (= x 1))))
- (1+ y)
- (+ x y)))
+ (if (and (const? y)
+ (let ((y (const-exp y)))
+ (and (number? y) (exact? y) (= y -1))))
+ (1- x)
+ (if (and (const? x)
+ (let ((x (const-exp x)))
+ (and (number? x) (exact? x) (= x 1))))
+ (1+ y)
+ (+ x y))))
(x y z . rest) (+ x (+ y z . rest)))
(define-primitive-expander *
(x) (- 0 x)
(x y) (if (and (const? y)
(let ((y (const-exp y)))
- (and (exact? y) (= y 1))))
+ (and (number? y) (exact? y) (= y 1))))
(1- x)
(- x y))
(x y z . rest) (- x (+ y z . rest)))
(define-primitive-expander acons (x y z)
(cons (cons x y) z))
-(define-primitive-expander apply (f . args)
- (@apply f . args))
+(define-primitive-expander apply (f a0 . args)
+ (@apply f a0 . args))
(define-primitive-expander call-with-values (producer consumer)
(@call-with-values producer consumer))
(@call-with-current-continuation proc))
(define-primitive-expander values (x) x)
+
+;; swap args
+(define-primitive-expander variable-set! (var val)
+ (variable-set val var))
+
+(define-primitive-expander make-struct (vtable tail-size . args)
+ (if (and (const? tail-size)
+ (let ((n (const-exp tail-size)))
+ (and (number? n) (exact? n) (zero? n))))
+ (make-struct/no-tail vtable . args)
+ #f))
+
+(define-primitive-expander u8vector-ref (vec i)
+ (bytevector-u8-ref vec i))
+(define-primitive-expander u8vector-set! (vec i x)
+ (bytevector-u8-set! vec i x))
+(define-primitive-expander s8vector-ref (vec i)
+ (bytevector-s8-ref vec i))
+(define-primitive-expander s8vector-set! (vec i x)
+ (bytevector-s8-set! vec i x))
+
+(define-primitive-expander u16vector-ref (vec i)
+ (bytevector-u16-native-ref vec (* i 2)))
+(define-primitive-expander u16vector-set! (vec i x)
+ (bytevector-u16-native-set! vec (* i 2) x))
+(define-primitive-expander s16vector-ref (vec i)
+ (bytevector-s16-native-ref vec (* i 2)))
+(define-primitive-expander s16vector-set! (vec i x)
+ (bytevector-s16-native-set! vec (* i 2) x))
+
+(define-primitive-expander u32vector-ref (vec i)
+ (bytevector-u32-native-ref vec (* i 4)))
+(define-primitive-expander u32vector-set! (vec i x)
+ (bytevector-u32-native-set! vec (* i 4) x))
+(define-primitive-expander s32vector-ref (vec i)
+ (bytevector-s32-native-ref vec (* i 4)))
+(define-primitive-expander s32vector-set! (vec i x)
+ (bytevector-s32-native-set! vec (* i 4) x))
+
+(define-primitive-expander u64vector-ref (vec i)
+ (bytevector-u64-native-ref vec (* i 8)))
+(define-primitive-expander u64vector-set! (vec i x)
+ (bytevector-u64-native-set! vec (* i 8) x))
+(define-primitive-expander s64vector-ref (vec i)
+ (bytevector-s64-native-ref vec (* i 8)))
+(define-primitive-expander s64vector-set! (vec i x)
+ (bytevector-s64-native-set! vec (* i 8) x))
+
+(define-primitive-expander f32vector-ref (vec i)
+ (bytevector-ieee-single-native-ref vec (* i 4)))
+(define-primitive-expander f32vector-set! (vec i x)
+ (bytevector-ieee-single-native-set! vec (* i 4) x))
+(define-primitive-expander f32vector-ref (vec i)
+ (bytevector-ieee-single-native-ref vec (* i 4)))
+(define-primitive-expander f32vector-set! (vec i x)
+ (bytevector-ieee-single-native-set! vec (* i 4) x))
+
+(define-primitive-expander f64vector-ref (vec i)
+ (bytevector-ieee-double-native-ref vec (* i 8)))
+(define-primitive-expander f64vector-set! (vec i x)
+ (bytevector-ieee-double-native-set! vec (* i 8) x))
+(define-primitive-expander f64vector-ref (vec i)
+ (bytevector-ieee-double-native-ref vec (* i 8)))
+(define-primitive-expander f64vector-set! (vec i x)
+ (bytevector-ieee-double-native-set! vec (* i 8) x))
+
+(hashq-set! *primitive-expand-table*
+ 'dynamic-wind
+ (case-lambda
+ ((src pre thunk post)
+ ;; Here we will make concessions to the fact that our inliner is
+ ;; lame, and add a hack.
+ (cond
+ ((lambda? thunk)
+ (let ((PRE (gensym " pre"))
+ (POST (gensym " post")))
+ (make-let
+ src
+ '(pre post)
+ (list PRE POST)
+ (list pre post)
+ (make-dynwind
+ src
+ (make-lexical-ref #f 'pre PRE)
+ (make-application #f thunk '())
+ (make-lexical-ref #f 'post POST)))))
+ (else
+ (let ((PRE (gensym " pre"))
+ (THUNK (gensym " thunk"))
+ (POST (gensym " post")))
+ (make-let
+ src
+ '(pre thunk post)
+ (list PRE THUNK POST)
+ (list pre thunk post)
+ (make-dynwind
+ src
+ (make-lexical-ref #f 'pre PRE)
+ (make-application #f (make-lexical-ref #f 'thunk THUNK) '())
+ (make-lexical-ref #f 'post POST)))))))
+ (else #f)))
+
+(hashq-set! *primitive-expand-table*
+ '@dynamic-wind
+ (case-lambda
+ ((src pre expr post)
+ (let ((PRE (gensym " pre"))
+ (POST (gensym " post")))
+ (make-let
+ src
+ '(pre post)
+ (list PRE POST)
+ (list pre post)
+ (make-dynwind
+ src
+ (make-lexical-ref #f 'pre PRE)
+ expr
+ (make-lexical-ref #f 'post POST)))))))
+
+(hashq-set! *primitive-expand-table*
+ 'fluid-ref
+ (case-lambda
+ ((src fluid) (make-dynref src fluid))
+ (else #f)))
+
+(hashq-set! *primitive-expand-table*
+ 'fluid-set!
+ (case-lambda
+ ((src fluid exp) (make-dynset src fluid exp))
+ (else #f)))
+
+(hashq-set! *primitive-expand-table*
+ '@prompt
+ (case-lambda
+ ((src tag exp handler)
+ (let ((args-sym (gensym)))
+ (make-prompt
+ src tag exp
+ ;; If handler itself is a lambda, the inliner can do some
+ ;; trickery here.
+ (make-lambda-case
+ (tree-il-src handler) '() #f 'args #f '() (list args-sym)
+ (make-application #f (make-primitive-ref #f 'apply)
+ (list handler
+ (make-lexical-ref #f 'args args-sym)))
+ #f))))
+ (else #f)))
+
+(hashq-set! *primitive-expand-table*
+ 'call-with-prompt
+ (case-lambda
+ ((src tag thunk handler)
+ ;; Sigh. Until the inliner does its job, manually inline
+ ;; (let ((h (lambda ...))) (prompt k x h))
+ (cond
+ ((lambda? handler)
+ (let ((args-sym (gensym)))
+ (make-prompt
+ src tag (make-application #f thunk '())
+ ;; If handler itself is a lambda, the inliner can do some
+ ;; trickery here.
+ (make-lambda-case
+ (tree-il-src handler) '() #f 'args #f '() (list args-sym)
+ (make-application #f (make-primitive-ref #f 'apply)
+ (list handler
+ (make-lexical-ref #f 'args args-sym)))
+ #f))))
+ (else #f)))
+ (else #f)))
+
+(hashq-set! *primitive-expand-table*
+ '@abort
+ (case-lambda
+ ((src tag tail-args)
+ (make-abort src tag '() tail-args))
+ (else #f)))
+(hashq-set! *primitive-expand-table*
+ 'abort-to-prompt
+ (case-lambda
+ ((src tag . args)
+ (make-abort src tag args (make-const #f '())))
+ (else #f)))
HCoop / bpt / guile.git / blobdiff