diff options
Diffstat (limited to 'module/language/tree-il/primitives.scm')
-rw-r--r-- | module/language/tree-il/primitives.scm | 202 |
1 files changed, 194 insertions, 8 deletions
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 83eab6f55..b6953cabe 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -1,6 +1,6 @@ ;;; 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 @@ -23,6 +23,7 @@ #: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! effect-free-primitive?)) @@ -32,6 +33,8 @@ 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 @@ -55,32 +58,42 @@ vector-ref vector-set! variable-ref variable-set! + variable-bound? ;; args of variable-set are switched; it needs special help - struct? struct-vtable make-struct + 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* @@ -106,7 +119,7 @@ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr vector-ref - struct? struct-vtable make-struct + 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 @@ -171,13 +184,15 @@ ((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)))))) @@ -301,3 +316,174 @@ ;; swap args (define-primitive-expander variable-set! (var val) (variable-set val var)) + +(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))) |