summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-10-31 12:06:06 +0100
committerAndy Wingo <wingo@pobox.com>2013-10-31 12:55:24 +0100
commit6165d8120d5973ea177514d0632247e1d38904ee (patch)
tree30e7431d69f6d0cb0c2ab0af377fdd139ad77f5f
parentbecce37b5835720857068c4865f1cd48275133d1 (diff)
downloadguile-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.c4
-rw-r--r--module/language/cps/arities.scm6
-rw-r--r--module/language/cps/compile-rtl.scm2
-rw-r--r--module/language/cps/primitives.scm23
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))