guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 07/12: Add tag-fixnum instruction


From: Andy Wingo
Subject: [Guile-commits] 07/12: Add tag-fixnum instruction
Date: Sat, 11 Nov 2017 16:12:25 -0500 (EST)

wingo pushed a commit to branch master
in repository guile.

commit 8b5f9648ff806157f90489b1f5eb26fb1e05a8cf
Author: Andy Wingo <address@hidden>
Date:   Thu Nov 9 14:18:01 2017 +0100

    Add tag-fixnum instruction
    
    * libguile/vm-engine.c (tag-fixnum): New instruction.
    * module/language/cps/compile-bytecode.scm (compile-function):
    * module/language/cps/cse.scm (compute-equivalent-subexpressions):
    * module/language/cps/effects-analysis.scm:
    * module/language/cps/types.scm (&min/fixnum, &max/fixnum, tag-fixnum):
    * module/system/vm/assembler.scm: Add support for the new instruction.
---
 libguile/vm-engine.c                     | 12 +++++++++++-
 module/language/cps/compile-bytecode.scm |  2 ++
 module/language/cps/cse.scm              |  5 +++++
 module/language/cps/effects-analysis.scm |  3 ++-
 module/language/cps/types.scm            |  6 ++++++
 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 4c4d9eb..c2b0156 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 ed25148..2e3697b 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 a074c7b..b4b23ed 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 9a7f70d..3131366 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 267e9ef..c40a807 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 5fccd86..dbbe812 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)



reply via email to

[Prev in Thread] Current Thread [Next in Thread]