diff options
author | Andy Wingo <wingo@pobox.com> | 2013-10-31 12:06:06 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-10-31 12:55:24 +0100 |
commit | 6165d8120d5973ea177514d0632247e1d38904ee (patch) | |
tree | 30e7431d69f6d0cb0c2ab0af377fdd139ad77f5f | |
parent | becce37b5835720857068c4865f1cd48275133d1 (diff) | |
download | guile-6165d8120d5973ea177514d0632247e1d38904ee.tar.gz |
Better aliased primcall compilation
* libguile/vm-engine.c (define!): Rename from define.
* module/language/cps/arities.scm (fix-clause-arities): If a prim
aliases an RTL instruction with a different name and we reify a
primcall, reify the instruction name.
* module/language/cps/compile-rtl.scm (emit-rtl-sequence): Update
emit-define! for new name.
* module/language/cps/primitives.scm (*rtl-instruction-aliases*): Add
bytevector native accessors.
-rw-r--r-- | libguile/vm-engine.c | 4 | ||||
-rw-r--r-- | module/language/cps/arities.scm | 6 | ||||
-rw-r--r-- | module/language/cps/compile-rtl.scm | 2 | ||||
-rw-r--r-- | module/language/cps/primitives.scm | 23 |
4 files changed, 29 insertions, 6 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index b6b9f8fd4..d0f63fb27 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2232,12 +2232,12 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) NEXT (2); } - /* define sym:12 val:12 + /* define! sym:12 val:12 * * Look up a binding for SYM in the current module, creating it if * necessary. Set its value to VAL. */ - VM_DEFINE_OP (58, define, "define", OP1 (U8_U12_U12)) + VM_DEFINE_OP (58, define, "define!", OP1 (U8_U12_U12)) { scm_t_uint16 sym, val; SCM_UNPACK_RTL_12_12 (op, sym, val); diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm index 877750278..51b1892a1 100644 --- a/module/language/cps/arities.scm +++ b/module/language/cps/arities.scm @@ -138,7 +138,11 @@ ,(match (prim-arity name) ((out . in) (if (= in (length args)) - (adapt-exp out k exp) + (adapt-exp out k + (let ((inst (prim-rtl-instruction name))) + (if (and inst (not (eq? inst name))) + (build-cps-exp ($primcall inst args)) + exp))) (let-gensyms (k* p*) (build-cps-term ($letk ((k* #f ($kargs ('prim) (p*) diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm index 2f0716b77..51478c125 100644 --- a/module/language/cps/compile-rtl.scm +++ b/module/language/cps/compile-rtl.scm @@ -280,7 +280,7 @@ (($ $primcall 'set-cdr! (pair value)) (emit-set-cdr! asm (slot pair) (slot value))) (($ $primcall 'define! (sym value)) - (emit-define asm (slot sym) (slot value))) + (emit-define! asm (slot sym) (slot value))) (($ $primcall 'push-fluid (fluid val)) (emit-push-fluid asm (slot fluid) (slot val))) (($ $primcall 'pop-fluid ()) diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index 570150294..ac0d336a1 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -38,9 +38,28 @@ (* . mul) (/ . div) (quotient . quo) (remainder . rem) (modulo . mod) - (define! . define) (variable-ref . box-ref) - (variable-set! . box-set!))) + (variable-set! . box-set!) + (bytevector-u8-native-ref . bv-u8-ref) + (bytevector-u16-native-ref . bv-u16-ref) + (bytevector-u32-native-ref . bv-u32-ref) + (bytevector-u64-native-ref . bv-u64-ref) + (bytevector-s8-native-ref . bv-s8-ref) + (bytevector-s16-native-ref . bv-s16-ref) + (bytevector-s32-native-ref . bv-s32-ref) + (bytevector-s64-native-ref . bv-s64-ref) + (bytevector-f32-native-ref . bv-f32-ref) + (bytevector-f64-native-ref . bv-f64-ref) + (bytevector-u8-native-set! . bv-u8-set!) + (bytevector-u16-native-set! . bv-u16-set!) + (bytevector-u32-native-set! . bv-u32-set!) + (bytevector-u64-native-set! . bv-u64-set!) + (bytevector-s8-native-set! . bv-s8-set!) + (bytevector-s16-native-set! . bv-s16-set!) + (bytevector-s32-native-set! . bv-s32-set!) + (bytevector-s64-native-set! . bv-s64-set!) + (bytevector-f32-native-set! . bv-f32-set!) + (bytevector-f64-native-set! . bv-f64-set!))) (define *macro-instruction-arities* '((cache-current-module! . (0 . 2)) |