mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-18 10:10:23 +02:00
Code Activity

Better aliased primcall compilation

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2013-10-31 12:06:06 +01:00
parent becce37b58
commit 6165d8120d
4 changed files with 29 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

4
libguile/vm-engine.c
View file

@ -2232,12 +2232,12 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (2); 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 * Look up a binding for SYM in the current module, creating it if
* necessary. Set its value to VAL. * 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_t_uint16 sym, val;
SCM_UNPACK_RTL_12_12 (op, sym, val); SCM_UNPACK_RTL_12_12 (op, sym, val);

6
module/language/cps/arities.scm
View file

@ -138,7 +138,11 @@
,(match (prim-arity name) ,(match (prim-arity name)
((out . in) ((out . in)
(if (= in (length args)) (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*) (let-gensyms (k* p*)
(build-cps-term (build-cps-term
($letk ((k* #f ($kargs ('prim) (p*) ($letk ((k* #f ($kargs ('prim) (p*)

2
module/language/cps/compile-rtl.scm
View file

@ -280,7 +280,7 @@
(($ $primcall 'set-cdr! (pair value)) (($ $primcall 'set-cdr! (pair value))
(emit-set-cdr! asm (slot pair) (slot value))) (emit-set-cdr! asm (slot pair) (slot value)))
(($ $primcall 'define! (sym value)) (($ $primcall 'define! (sym value))
(emit-define asm (slot sym) (slot value))) (emit-define! asm (slot sym) (slot value)))
(($ $primcall 'push-fluid (fluid val)) (($ $primcall 'push-fluid (fluid val))
(emit-push-fluid asm (slot fluid) (slot val))) (emit-push-fluid asm (slot fluid) (slot val)))
(($ $primcall 'pop-fluid ()) (($ $primcall 'pop-fluid ())

23
module/language/cps/primitives.scm
View file

@ -38,9 +38,28 @@
(* . mul) (/ . div) (* . mul) (/ . div)
(quotient . quo) (remainder . rem) (quotient . quo) (remainder . rem)
(modulo . mod) (modulo . mod)
(define! . define)
(variable-ref . box-ref) (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* (define *macro-instruction-arities*
'((cache-current-module! . (0 . 2)) '((cache-current-module! . (0 . 2))