diff options
-rw-r--r-- | libguile/vm-engine.c | 12 | ||||
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 2 | ||||
-rw-r--r-- | module/language/cps/cse.scm | 5 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 3 | ||||
-rw-r--r-- | module/language/cps/types.scm | 6 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 1 |
6 files changed, 27 insertions, 2 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 4c4d9eb7b..c2b0156b6 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -4057,7 +4057,17 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - VM_DEFINE_OP (215, unused_215, NULL, NOP) + VM_DEFINE_OP (215, tag_fixnum, "tag-fixnum", OP1 (X8_S12_S12) | OP_DST) + { + scm_t_uint16 dst, src; + + UNPACK_12_12 (op, dst, src); + + SP_SET (dst, SCM_I_MAKINUM (SP_REF_S64 (src))); + + NEXT (1); + } + VM_DEFINE_OP (216, unused_216, NULL, NOP) VM_DEFINE_OP (217, unused_217, NULL, NOP) VM_DEFINE_OP (218, unused_218, NULL, NOP) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index ed2514864..2e3697bdf 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -271,6 +271,8 @@ (from-sp (slot expected)) (from-sp (slot desired)))) (($ $primcall 'untag-fixnum #f (src)) (emit-untag-fixnum asm (from-sp dst) (from-sp (slot src)))) + (($ $primcall 'tag-fixnum #f (src)) + (emit-tag-fixnum asm (from-sp dst) (from-sp (slot src)))) (($ $primcall name #f args) ;; FIXME: Inline all the cases. (let ((inst (prim-instruction name))) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index a074c7b9c..b4b23ed1b 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -329,6 +329,11 @@ false. It could be that both true and false proofs are available." (match defs ((scm) (add-def! `(primcall scm->s64 #f ,scm) s64)))) + (('primcall 'untag-fixnum #f scm) + (match defs + ((s64) + (add-def! `(primcall s64->scm #f ,s64) scm) + (add-def! `(primcall tag-fixnum #f ,s64) scm)))) (_ #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 9a7f70dca..3131366d6 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -374,7 +374,8 @@ is or might be a read or a write to the same location as A." ((load-s64)) ((s64->scm _)) ((s64->scm/unlikely _)) - ((untag-fixnum _))) + ((untag-fixnum _)) + ((tag-fixnum _))) ;; Bytevectors. (define-primitive-effects diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 267e9efb2..c40a8071b 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -398,6 +398,8 @@ minimum, and maximum." (define-syntax-rule (&max/u64 x) (min (&max x) &u64-max)) (define-syntax-rule (&min/s64 x) (max (&min x) &s64-min)) (define-syntax-rule (&max/s64 x) (min (&max x) &s64-max)) +(define-syntax-rule (&min/fixnum x) (max (&min x) most-negative-fixnum)) +(define-syntax-rule (&max/fixnum x) (min (&max x) most-positive-fixnum)) (define-syntax-rule (&max/size x) (min (&max x) (target-max-size-t))) (define-syntax-rule (&max/scm-size x) (min (&max x) (target-max-size-t/scm))) @@ -901,6 +903,10 @@ minimum, and maximum." (define-type-inferrer (untag-fixnum scm result) (define! result &s64 (&min/s64 scm) (&max/s64 scm))) +(define-simple-type-checker (tag-fixnum (logior &s64 &u64))) +(define-type-inferrer (tag-fixnum s64 result) + (define! result &fixnum (&min/fixnum s64) (&max/fixnum s64))) + diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 5fccd866d..dbbe812ed 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -98,6 +98,7 @@ emit-eof-object? emit-untag-fixnum + emit-tag-fixnum emit-throw (emit-throw/value* . emit-throw/value) |