[Guile-commits] 31/41: New instructions load-f64, load-u64

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit f34688ad25c8e4cb1ebc97734f255d36518d763f
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 20 16:14:32 2015 +0100

    New instructions load-f64, load-u64
    
    * libguile/instructions.c (FOR_EACH_INSTRUCTION_WORD_TYPE): Add word
      types for immediate f64 and u64 values.
      (TYPE_WIDTH): Bump up by a bit, now that we have 32 word types.
      (NOP, parse_instruction): Use 64-bit meta type.
    
    * libguile/vm-engine.c (load-f64, load-u64): New instructions.
    
    * module/language/bytecode.scm (compute-instruction-arity): Add parser
      for new instruction word types.
    
    * module/language/cps/compile-bytecode.scm (compile-function): Add
      special-cased assemblers for new instructions, and also for scm->u64
      and u64->scm which I missed before.
    
    * module/language/cps/effects-analysis.scm (load-f64, load-u64): New
      instructions.
    
    * module/language/cps/slot-allocation.scm (compute-needs-slot): load-f64
      and load-u64 don't need slots.
      (compute-var-representations): Update for new instructions.
    
    * module/language/cps/specialize-primcalls.scm (specialize-primcalls):
      Specialize scm->f64 and scm->u64 to make-f64 and make-u64.
    
    * module/language/cps/types.scm (load-f64, load-u64): Wire up to type
      inference, though currently type inference only runs before
      specialization.
    
    * module/language/cps/utils.scm (compute-defining-expressions): For some
      reason I don't understand, it's possible to see two definitions that
      are equal but not equal? here.  Allow for now.
      (compute-constant-values): Punch through type conversions to get
      constant u64/f64 values.
    
    * module/system/vm/assembler.scm (assembler): Support for new word
      types.  Export the new assemblers.
---
 libguile/instructions.c                      |   14 +++++---
 libguile/vm-engine.c                         |   37 ++++++++++++++++++++-
 module/language/bytecode.scm                 |    4 +-
 module/language/cps/compile-bytecode.scm     |    8 ++++
 module/language/cps/effects-analysis.scm     |    2 +
 module/language/cps/slot-allocation.scm      |    7 +++-
 module/language/cps/specialize-primcalls.scm |    8 ++++
 module/language/cps/types.scm                |    2 +
 module/language/cps/utils.scm                |   45 +++++++++++++++++++------
 module/system/vm/assembler.scm               |   13 +++++++
 module/system/vm/disassembler.scm            |    2 +-
 11 files changed, 119 insertions(+), 23 deletions(-)

diff --git a/libguile/instructions.c b/libguile/instructions.c
index 003fd54..49b07d1 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -50,6 +50,10 @@ SCM_SYMBOL (sym_bang, "!");
     M(I32) /* Immediate. */                     \
     M(A32) /* Immediate, high bits. */          \
     M(B32) /* Immediate, low bits. */           \
+    M(AF32) /* Immediate double, high bits. */  \
+    M(BF32) /* Immediate double, low bits. */   \
+    M(AU32) /* Immediate uint64, high bits. */  \
+    M(BU32) /* Immediate uint64, low bits. */   \
     M(N32) /* Non-immediate. */                 \
     M(R32) /* Scheme value (indirected). */     \
     M(L32) /* Label. */                         \
@@ -61,7 +65,7 @@ SCM_SYMBOL (sym_bang, "!");
     M(B1_X7_F24)                                \
     M(B1_X31)
 
-#define TYPE_WIDTH 5
+#define TYPE_WIDTH 6
 
 enum word_type
   {
@@ -82,14 +86,14 @@ static SCM word_type_symbols[] =
 /* The VM_DEFINE_OP macro uses a CPP-based DSL to describe what kinds of
    arguments each instruction takes.  This piece of code is the only
    bit that actually interprets that language.  These macro definitions
-   encode the operand types into bits in a 32-bit integer.
+   encode the operand types into bits in a 64-bit integer.
 
    (instruction-list) parses those encoded values into lists of symbols,
-   one for each 32-bit word that the operator takes.  This list is used
+   one for each 64-bit word that the operator takes.  This list is used
    by Scheme to generate assemblers and disassemblers for the
    instructions.  */
 
-#define NOP SCM_T_UINT32_MAX
+#define NOP SCM_T_UINT64_MAX
 #define OP1(type0) \
   (OP (0, type0))
 #define OP2(type0, type1) \
@@ -113,7 +117,7 @@ static SCM word_type_symbols[] =
 /* Scheme interface */
 
 static SCM
-parse_instruction (scm_t_uint8 opcode, const char *name, scm_t_uint32 meta)
+parse_instruction (scm_t_uint8 opcode, const char *name, scm_t_uint64 meta)
 {
   SCM tail = SCM_EOL;
   int len;
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 2f3b3fd..d15fe32 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3495,8 +3495,41 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (1);
     }
 
-  VM_DEFINE_OP (155, unused_155, NULL, NOP)
-  VM_DEFINE_OP (156, unused_156, NULL, NOP)
+  /* load-f64 dst:24 high-bits:32 low-bits:32
+   *
+   * Make a double-precision floating-point value with HIGH-BITS and
+   * LOW-BITS.
+   */
+  VM_DEFINE_OP (155, load_f64, "load-f64", OP3 (X8_S24, AF32, BF32) | OP_DST)
+    {
+      scm_t_uint32 dst;
+      scm_t_uint64 val;
+
+      UNPACK_24 (op, dst);
+      val = ip[1];
+      val <<= 32;
+      val |= ip[2];
+      SP_SET_U64 (dst, val);
+      NEXT (3);
+    }
+
+  /* load-u64 dst:24 high-bits:32 low-bits:32
+   *
+   * Make an unsigned 64-bit integer with HIGH-BITS and LOW-BITS.
+   */
+  VM_DEFINE_OP (156, load_u64, "load-u64", OP3 (X8_S24, AU32, BU32) | OP_DST)
+    {
+      scm_t_uint32 dst;
+      scm_t_uint64 val;
+
+      UNPACK_24 (op, dst);
+      val = ip[1];
+      val <<= 32;
+      val |= ip[2];
+      SP_SET_U64 (dst, val);
+      NEXT (3);
+    }
+
   VM_DEFINE_OP (157, unused_157, NULL, NOP)
   VM_DEFINE_OP (158, unused_158, NULL, NOP)
   VM_DEFINE_OP (159, unused_159, NULL, NOP)
diff --git a/module/language/bytecode.scm b/module/language/bytecode.scm
index 089bf9e..fb7ef73 100644
--- a/module/language/bytecode.scm
+++ b/module/language/bytecode.scm
@@ -51,8 +51,8 @@
     (case word
       ((C32) 1)
       ((I32) 1)
-      ((A32) 1)
-      ((B32) 0)
+      ((A32 AU32 AF32) 1)
+      ((B32 BF32 BU32) 0)
       ((N32) 1)
       ((R32) 1)
       ((L32) 1)
diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index 9dfee57..615ae86 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -196,8 +196,16 @@
          (emit-builtin-ref asm (from-sp dst) (constant name)))
         (($ $primcall 'scm->f64 (src))
          (emit-scm->f64 asm (from-sp dst) (from-sp (slot src))))
+        (($ $primcall 'load-f64 (src))
+         (emit-load-f64 asm (from-sp dst) (constant src)))
         (($ $primcall 'f64->scm (src))
          (emit-f64->scm asm (from-sp dst) (from-sp (slot src))))
+        (($ $primcall 'scm->u64 (src))
+         (emit-scm->u64 asm (from-sp dst) (from-sp (slot src))))
+        (($ $primcall 'load-u64 (src))
+         (emit-load-u64 asm (from-sp dst) (constant src)))
+        (($ $primcall 'u64->scm (src))
+         (emit-u64->scm asm (from-sp dst) (from-sp (slot src))))
         (($ $primcall 'bv-length (bv))
          (emit-bv-length asm (from-sp dst) (from-sp (slot bv))))
         (($ $primcall 'bv-u8-ref (bv idx))
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 43ec1b0..a53800c 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -354,8 +354,10 @@ is or might be a read or a write to the same location as 
A."
 ;; Unboxed floats and integers.
 (define-primitive-effects
   ((scm->f64 _)                                                &type-check)
+  ((load-f64 _))
   ((f64->scm _))
   ((scm->u64 _)                                                &type-check)
+  ((load-u64 _))
   ((u64->scm _)))
 
 ;; Bytevectors.
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index d41013f..1edf703 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -323,6 +323,8 @@ the definitions that are live before and after LABEL, as 
intsets."
            (match exp
              (($ $const)
               empty-intset)
+             (($ $primcall (or 'load-f64 'load-u64) (val))
+              empty-intset)
              (($ $primcall 'free-ref (closure slot))
               (defs+ closure))
              (($ $primcall 'free-set! (closure slot value))
@@ -794,10 +796,11 @@ are comparable with eqv?.  A tmp slot may be used."
              (($ $values (arg))
               (intmap-add representations var
                           (intmap-ref representations arg)))
-             (($ $primcall (or 'scm->f64 'bv-f32-ref 'bv-f64-ref
+             (($ $primcall (or 'scm->f64 'load-f64
+                               'bv-f32-ref 'bv-f64-ref
                                'fadd 'fsub 'fmul 'fdiv))
               (intmap-add representations var 'f64))
-             (($ $primcall (or 'scm->u64 'bv-length
+             (($ $primcall (or 'scm->u64 'load-u64 'bv-length
                                'uadd 'usub 'umul
                                'uadd/immediate 'usub/immediate 
'umul/immediate))
               (intmap-add representations var 'u64))
diff --git a/module/language/cps/specialize-primcalls.scm 
b/module/language/cps/specialize-primcalls.scm
index 0c234ee..1df0b8e 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -36,6 +36,12 @@
     (define (u8? var)
       (let ((val (intmap-ref constants var (lambda (_) #f))))
         (and (exact-integer? val) (<= 0 val 255))))
+    (define (u64? var)
+      (let ((val (intmap-ref constants var (lambda (_) #f))))
+        (and (exact-integer? val) (<= 0 val #xffffFFFFffffFFFF))))
+    (define (f64? var)
+      (let ((val (intmap-ref constants var (lambda (_) #f))))
+        (and (number? val) (inexact? val) (real? val))))
     (define (specialize-primcall name args)
       (define (rename name)
         (build-exp ($primcall name args)))
@@ -54,6 +60,8 @@
         (('usub x (? u8? y)) (build-exp ($primcall 'usub/immediate (x y))))
         (('umul x (? u8? y)) (build-exp ($primcall 'umul/immediate (x y))))
         (('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate (y x))))
+        (('scm->f64 (? f64?)) (rename 'load-f64))
+        (('scm->u64 (? u64?)) (rename 'load-u64))
         (_ #f)))
     (intmap-map
      (lambda (label cont)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 6928589..f542365 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -706,6 +706,7 @@ minimum, and maximum."
 (define-type-inferrer (scm->f64 scm result)
   (restrict! scm &real -inf.0 +inf.0)
   (define! result &f64 (&min scm) (&max scm)))
+(define-type-aliases scm->f64 load-f64)
 
 (define-type-checker (f64->scm f64)
   #t)
@@ -717,6 +718,7 @@ minimum, and maximum."
 (define-type-inferrer (scm->u64 scm result)
   (restrict! scm &exact-integer 0 #xffffffffffffffff)
   (define! result &u64 (max (&min scm) 0) (min (&max scm) #xffffffffffffffff)))
+(define-type-aliases scm->u64 load-u64)
 
 (define-type-checker (u64->scm u64)
   #t)
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index fcbda9e..902860c 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -182,9 +182,11 @@ disjoint, an error will be signalled."
 
 (define (compute-defining-expressions conts)
   (define (meet-defining-expressions old new)
-    ;; If there are multiple definitions, punt and
-    ;; record #f.
-    #f)
+    ;; If there are multiple definitions and they are different, punt
+    ;; and record #f.
+    (if (equal? old new)
+        old
+        #f))
   (persistent-intmap
    (intmap-fold (lambda (label cont defs)
                   (match cont
@@ -198,14 +200,35 @@ disjoint, an error will be signalled."
                 empty-intmap)))
 
 (define (compute-constant-values conts)
-  (persistent-intmap
-   (intmap-fold (lambda (var exp out)
-                  (match exp
-                    (($ $const val)
-                     (intmap-add! out var val))
-                    (_ out)))
-                (compute-defining-expressions conts)
-                empty-intmap)))
+  (let ((defs (compute-defining-expressions conts)))
+    (persistent-intmap
+     (intmap-fold
+      (lambda (var exp out)
+        (match exp
+          (($ $primcall (or 'load-f64 'load-u64) (val))
+           (intmap-add! out var (intmap-ref out val)))
+          ;; Punch through type conversions to allow uadd to specialize
+          ;; to uadd/immediate.
+          (($ $primcall 'scm->f64 (val))
+           (let ((f64 (intmap-ref out val (lambda (_) #f))))
+             (if (and f64 (number? f64) (inexact? f64) (real? f64))
+                 (intmap-add! out var f64)
+                 out)))
+          (($ $primcall 'scm->u64 (val))
+           (let ((u64 (intmap-ref out val (lambda (_) #f))))
+             (if (and u64 (number? u64) (exact-integer? u64)
+                      (<= 0 u64 #xffffFFFFffffFFFF))
+                 (intmap-add! out var u64)
+                 out)))
+          (_ out)))
+      defs
+      (intmap-fold (lambda (var exp out)
+                     (match exp
+                       (($ $const val)
+                        (intmap-add! out var val))
+                       (_ out)))
+                   defs
+                   empty-intmap)))))
 
 (define (compute-function-body conts kfun)
   (persistent-intset
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 0733311..bbd4e5d 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -168,7 +168,11 @@
             (emit-class-of* . emit-class-of)
             emit-make-array
             (emit-scm->f64* . emit-scm->f64)
+            emit-load-f64
             (emit-f64->scm* . emit-f64->scm)
+            (emit-scm->u64* . emit-scm->u64)
+            emit-load-u64
+            (emit-u64->scm* . emit-u64->scm)
             (emit-bv-length* . emit-bv-length)
             (emit-bv-u8-ref* . emit-bv-u8-ref)
             (emit-bv-s8-ref* . emit-bv-s8-ref)
@@ -568,7 +572,16 @@ later by the linker."
             (error "make-long-immediate unavailable for this target"))
           (emit asm (ash (object-address imm) -32))
           (emit asm (logand (object-address imm) (1- (ash 1 32)))))
+         ((AF32 f64)
+          (let ((u64 (u64vector-ref (f64vector f64) 0)))
+            (emit asm (ash u64 -32))
+            (emit asm (logand u64 (1- (ash 1 32))))))
+         ((AU32 u64)
+          (emit asm (ash u64 -32))
+          (emit asm (logand u64 (1- (ash 1 32)))))
          ((B32))
+         ((BU32))
+         ((BF32))
          ((N32 label)
           (record-far-label-reference asm label)
           (emit asm 0))
diff --git a/module/system/vm/disassembler.scm 
b/module/system/vm/disassembler.scm
index b071254..794caa7 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -108,7 +108,7 @@
     (define (parse-tail-word word type)
       (with-syntax ((word word))
         (case type
-          ((C32 I32 A32 B32)
+          ((C32 I32 A32 B32 AU32 BU32 AF32 BF32)
            #'(word))
           ((N32 R32 L32 LO32)
            #'((unpack-s32 word)))