diff options
author | Andy Wingo <wingo@pobox.com> | 2015-11-12 21:44:24 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-12-01 11:30:54 +0100 |
commit | dfbe869e2421e6db03fd14c6fbfc0838e5e1988b (patch) | |
tree | eb2344376bd382cbcd296c980c8c7b11d86dc1ea | |
parent | 58153e3a08c89fd9cc84dbf65e1df27119986cca (diff) | |
download | guile-dfbe869e2421e6db03fd14c6fbfc0838e5e1988b.tar.gz |
Add low-level support for unboxed 64-bit unsigned ints
* libguile/frames.c (enum stack_item_representation)
* libguile/frames.c (scm_to_stack_item_representation):
(scm_frame_local_ref, scm_frame_local_set_x): Support 'u64 slots.
* libguile/frames.h (union scm_vm_stack_element): Add as_u64 member.
* libguile/vm-engine.c (SP_REF_U64, SP_SET_U64): New helpers.
(scm->u64, u64->scm): New instructions.
* module/language/cps/cse.scm (compute-equivalent-subexpressions):
Scalar replacement for u64->scm and scm->u64.
* module/language/cps/effects-analysis.scm (scm->u64, u64->scm): Add
cases.
* module/language/cps/slot-allocation.scm (compute-var-representations):
(allocate-slots): Represent the result of scm->u64 as a "u64" slot.
* module/language/cps/types.scm (&u64): New type.
(scm->u64, u64->scm): Add support for these ops.
* module/system/vm/assembler.scm (write-arities):
* module/system/vm/debug.scm (arity-definitions): Support u64
representations.
-rw-r--r-- | libguile/frames.c | 10 | ||||
-rw-r--r-- | libguile/frames.h | 1 | ||||
-rw-r--r-- | libguile/vm-engine.c | 31 | ||||
-rw-r--r-- | module/language/cps/cse.scm | 8 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 6 | ||||
-rw-r--r-- | module/language/cps/slot-allocation.scm | 8 | ||||
-rw-r--r-- | module/language/cps/types.scm | 17 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 1 | ||||
-rw-r--r-- | module/system/vm/debug.scm | 1 |
9 files changed, 73 insertions, 10 deletions
diff --git a/libguile/frames.c b/libguile/frames.c index 2eae45fcd..e70b25212 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -241,7 +241,8 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0, enum stack_item_representation { STACK_ITEM_SCM = 0, - STACK_ITEM_F64 = 1 + STACK_ITEM_F64 = 1, + STACK_ITEM_U64 = 2 }; static enum stack_item_representation @@ -251,6 +252,8 @@ scm_to_stack_item_representation (SCM x, const char *subr, int pos) return STACK_ITEM_SCM; if (scm_is_eq (x, scm_from_latin1_symbol ("f64"))) return STACK_ITEM_F64; + if (scm_is_eq (x, scm_from_latin1_symbol ("u64"))) + return STACK_ITEM_U64; scm_wrong_type_arg (subr, pos, x); return 0; /* Not reached. */ @@ -281,6 +284,8 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 3, 0, 0, return item->as_scm; case STACK_ITEM_F64: return scm_from_double (item->as_f64); + case STACK_ITEM_U64: + return scm_from_uint64 (item->as_u64); default: abort(); } @@ -318,6 +323,9 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 4, 0, 0, case STACK_ITEM_F64: item->as_f64 = scm_to_double (val); break; + case STACK_ITEM_U64: + item->as_u64 = scm_to_uint64 (val); + break; default: abort(); } diff --git a/libguile/frames.h b/libguile/frames.h index bf3844527..2ece0c893 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -92,6 +92,7 @@ union scm_vm_stack_element scm_t_uint32 *as_ip; SCM as_scm; double as_f64; + scm_t_uint64 as_u64; /* For GC purposes. */ void *as_ptr; diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 885ef72ef..44bd2569b 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -254,6 +254,9 @@ #define SP_REF_F64(i) (sp[i].as_f64) #define SP_SET_F64(i,o) (sp[i].as_f64 = o) +#define SP_REF_U64(i) (sp[i].as_u64) +#define SP_SET_U64(i,o) (sp[i].as_u64 = o) + #define VARIABLE_REF(v) SCM_VARIABLE_REF (v) #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED)) @@ -3312,8 +3315,32 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (0); } - VM_DEFINE_OP (143, unused_143, NULL, NOP) - VM_DEFINE_OP (144, unused_144, NULL, NOP) + /* scm->u64 dst:12 src:12 + * + * Unpack an unsigned 64-bit integer from SRC and place it in DST. + */ + VM_DEFINE_OP (143, scm_to_u64, "scm->u64", OP1 (X8_S12_S12) | OP_DST) + { + scm_t_uint16 dst, src; + UNPACK_12_12 (op, dst, src); + SYNC_IP (); + SP_SET_U64 (dst, scm_to_uint64 (SP_REF (src))); + NEXT (1); + } + + /* u64->scm dst:12 src:12 + * + * Pack an unsigned 64-bit integer into a SCM value. + */ + VM_DEFINE_OP (144, u64_to_scm, "u64->scm", OP1 (X8_S12_S12) | OP_DST) + { + scm_t_uint16 dst, src; + UNPACK_12_12 (op, dst, src); + SYNC_IP (); + SP_SET (dst, scm_from_uint64 (SP_REF_U64 (src))); + NEXT (1); + } + VM_DEFINE_OP (145, unused_145, NULL, NOP) VM_DEFINE_OP (146, unused_146, NULL, NOP) VM_DEFINE_OP (147, unused_147, NULL, NOP) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 2e47f379c..ad554faa0 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -307,6 +307,14 @@ false. It could be that both true and false proofs are available." (match defs ((scm) (add-def! `(primcall scm->f64 ,scm) f64)))) + (('primcall 'scm->u64 scm) + (match defs + ((u64) + (add-def! `(primcall u64->scm ,u64) scm)))) + (('primcall 'u64->scm u64) + (match defs + ((scm) + (add-def! `(primcall scm->u64 ,scm) u64)))) (_ #t)))) (define (visit-label label equiv-labels var-substs) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index ae7a1a614..9c9334671 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -351,10 +351,12 @@ is or might be a read or a write to the same location as A." ((string->number _) (&read-object &string) &type-check) ((string-length s) &type-check)) -;; Unboxed floats. +;; Unboxed floats and integers. (define-primitive-effects ((scm->f64 _) &type-check) - ((f64->scm _))) + ((f64->scm _)) + ((scm->u64 _) &type-check) + ((u64->scm _))) ;; Bytevectors. (define-primitive-effects diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 8d865d739..ca8e32123 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -53,8 +53,8 @@ ;; (slots allocation-slots) - ;; A map of VAR to representation. A representation is either 'scm or - ;; 'f64. + ;; A map of VAR to representation. A representation is 'scm, 'f64, or + ;; 'u64. ;; (representations allocation-representations) @@ -793,6 +793,8 @@ are comparable with eqv?. A tmp slot may be used." (($ $primcall (or 'scm->f64 'bv-f32-ref 'bv-f64-ref 'fadd 'fsub 'fmul 'fdiv)) (intmap-add representations var 'f64)) + (($ $primcall (or 'scm->u64)) + (intmap-add representations var 'u64)) (_ (intmap-add representations var 'scm)))) (vars @@ -874,7 +876,7 @@ are comparable with eqv?. A tmp slot may be used." (#f slot-map) (slot (let ((desc (match (intmap-ref representations var) - ('f64 slot-desc-live-raw) + ((or 'u64 'f64) slot-desc-live-raw) ('scm slot-desc-live-scm)))) (logior slot-map (ash desc (* 2 slot))))))) live-vars 0)) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 08e8ec8de..8482b9836 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -119,6 +119,7 @@ ;; Untagged types. &f64 + &u64 infer-types lookup-pre-type @@ -169,7 +170,8 @@ &array &hash-table - &f64) + &f64 + &u64) (define-syntax &no-type (identifier-syntax 0)) @@ -678,7 +680,7 @@ minimum, and maximum." ;;; -;;; Unboxed double-precision floating-point numbers. +;;; Unboxed numbers. ;;; (define-type-checker (scm->f64 scm) @@ -692,6 +694,17 @@ minimum, and maximum." (define-type-inferrer (f64->scm f64 result) (define! result &flonum (&min f64) (&max f64))) +(define-type-checker (scm->u64 scm) + (check-type scm &exact-integer 0 +inf.0)) +(define-type-inferrer (scm->u64 scm result) + (restrict! scm &exact-integer 0 +inf.0) + (define! result &u64 (&min scm) (&max scm))) + +(define-type-checker (u64->scm u64) + #t) +(define-type-inferrer (u64->scm u64 result) + (define! result &exact-integer (&min u64) (&max u64))) + diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index babe4796f..21f4353c8 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1895,6 +1895,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If (let ((tag (case representation ((scm) 0) ((f64) 1) + ((u64) 2) (else (error "what!" representation))))) (put-uleb128 names-port (logior (ash slot 2) tag))) (lp definitions)))))) diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index 4d9a047fe..78bf13a50 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -386,6 +386,7 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}." (representation (case (logand slot+representation #x3) ((0) 'scm) ((1) 'f64) + ((2) 'u64) (else 'unknown)))) (cons (vector name def-offset slot representation) (lp pos names))))))))))) |