Add sign-extending make-immediate instruction

* doc/ref/vm.texi (Instruction Set, Constant Instructions): Document new
  instruction.
* libguile/instructions.c (FOR_EACH_INSTRUCTION_WORD_TYPE): New first
  word kind with zi16 operand.
* libguile/jit.c (compile_make_immediate, compile_make_immediate_slow):
  New compilers.
  (COMPILE_X8_S8_ZI16): New operand kind.
* libguile/vm-engine.c (make-immediate): New instruction.
* module/language/bytecode.scm:
* module/system/vm/assembler.scm (encode-X8_S8_ZI16<-/shuffle):
  (signed-bits, load-constant): Support the new instruction kind.
* module/system/vm/disassembler.scm (disassemblers)
  (sign-extended-immediate, code-annotation): Support for zi16
  operands.

doc/ref/vm.texi

@@ -579,10 +579,12 @@ An unsigned @var{n}-bit integer, indicating a constant value.
 @item l24
 An offset from the current @code{ip}, in 32-bit units, as a signed
 24-bit value.  Indicates a bytecode address, for a relative jump.
-@item i16
+@item zi16
+@itemx i16
 @itemx i32
 An immediate Scheme value (@pxref{Immediate Objects}), encoded directly
-in 16 or 32 bits.
+in 16 or 32 bits.  @code{zi16} is sign-extended; the others are
+zero-extended.
 @item a32
 @itemx b32
 An immediate Scheme value, encoded as a pair of 32-bit words.
@@ -1358,6 +1360,10 @@ two kinds.
 The first set of instructions loads immediate values.  These
 instructions encode the immediate directly into the instruction stream.
 
+@deftypefn Instruction {} make-immediate s8:@var{dst} zi16:@var{low-bits}
+Make an immediate whose low bits are @var{low-bits}, sign-extended.
+@end deftypefn
+
 @deftypefn Instruction {} make-short-immediate s8:@var{dst} i16:@var{low-bits}
 Make an immediate whose low bits are @var{low-bits}, and whose top bits are
 0.

libguile/instructions.c

@@ -44,6 +44,7 @@ SCM_SYMBOL (sym_bang, "!");
     M(X8_L24)                                   \
     M(X8_C24)                                   \
     M(X8_S8_I16)                                \
+    M(X8_S8_ZI16)                               \
     M(X8_S12_S12)                               \
     M(X8_S12_C12)                               \
     M(X8_S12_Z12)                               \

libguile/jit.c

@@ -2816,6 +2816,17 @@ compile_call_u64_from_scm_slow (scm_jit_state *j, uint16_t dst, uint16_t a, uint
 {
 }
 
+static void
+compile_make_immediate (scm_jit_state *j, uint8_t dst, SCM a)
+{
+  emit_movi (j, T0, SCM_UNPACK (a));
+  emit_sp_set_scm (j, dst, T0);
+}
+static void
+compile_make_immediate_slow (scm_jit_state *j, uint8_t dst, SCM a)
+{
+}
+
 static void
 compile_make_short_immediate (scm_jit_state *j, uint8_t dst, SCM a)
 {
@@ -5274,6 +5285,14 @@ compile_s64_to_f64_slow (scm_jit_state *j, uint16_t dst, uint16_t src)
     comp (j, a, SCM_PACK (b));                                          \
   }
 
+#define COMPILE_X8_S8_ZI16(j, comp)                                     \
+  {                                                                     \
+    uint8_t a;                                                          \
+    int16_t b;                                                          \
+    UNPACK_8_16 (j->ip[0], a, b);                                       \
+    comp (j, a, SCM_PACK ((scm_t_signed_bits) b));                      \
+  }
+
 #define COMPILE_X32__C32(j, comp)                                       \
   {                                                                     \
     comp (j, j->ip[1]);                                                 \

libguile/vm-engine.c

@@ -1,4 +1,4 @@
-/* Copyright 2001,2009-2015,2017-2019
+/* Copyright 2001,2009-2015,2017-2020
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -3401,7 +3401,21 @@ VM_NAME (scm_thread *thread)
       NEXT (offset);
     }
 
-  VM_DEFINE_OP (164, unused_164, NULL, NOP)
+  /* make-immediate dst:8 low-bits:16
+   *
+   * Make an immediate whose low bits are LOW-BITS, and whose top bits
+   * are sign-extended.
+   */
+  VM_DEFINE_OP (164, make_immediate, "make-immediate", DOP1 (X8_S8_ZI16))
+    {
+      uint8_t dst;
+      int16_t val;
+
+      UNPACK_8_16 (op, dst, val);
+      SP_SET (dst, SCM_PACK ((scm_t_signed_bits) val));
+      NEXT (1);
+    }
+
   VM_DEFINE_OP (165, unused_165, NULL, NOP)
   VM_DEFINE_OP (166, unused_166, NULL, NOP)
   VM_DEFINE_OP (167, unused_167, NULL, NOP)

module/language/bytecode.scm

@@ -44,6 +44,7 @@
        ((X8_C24) 1)
        ((X8_L24) 1)
        ((X8_S8_I16) 2)
+       ((X8_S8_ZI16) 2)
        ((X8_S12_S12) 2)
        ((X8_S12_C12) 2)
        ((X8_S12_Z12) 2)

module/system/vm/assembler.scm

@@ -682,6 +682,10 @@ later by the linker."
             (emit asm opcode))
            ((X8_S8_I16 a imm)
             (emit asm (pack-u8-u8-u16 opcode a (immediate-bits asm imm))))
+           ((X8_S8_ZI16 a imm)
+            (emit asm (pack-u8-u8-u16 opcode a
+                                      (signed-bits asm (immediate-bits asm imm)
+                                                   16))))
            ((X8_S12_S12 a b)
             (emit asm (pack-u8-u12-u12 opcode a b)))
            ((X8_S12_C12 a b)
@@ -906,6 +910,15 @@ later by the linker."
     (emit-push asm dst)
     (encode-X8_S8_I16 asm 0 imm opcode)
     (emit-pop asm dst))))
+(define (encode-X8_S8_ZI16<-/shuffle asm dst imm opcode)
+  (cond
+   ((< dst (ash 1 8))
+    (encode-X8_S8_ZI16 asm dst imm opcode))
+   (else
+    ;; Push garbage value to make space for dst.
+    (emit-push asm dst)
+    (encode-X8_S8_ZI16 asm 0 imm opcode)
+    (emit-pop asm dst))))
 (define (encode-X8_S8_S8_S8!/shuffle asm a b c opcode)
   (cond
    ((< (logior a b c) (ash 1 8))
@@ -1030,6 +1043,7 @@ later by the linker."
       (('<- 'X8_S12_C12)         #'encode-X8_S12_C12<-/shuffle)
       (('! 'X8_S12_Z12)          #'encode-X8_S12_Z12!/shuffle)
       (('<- 'X8_S8_I16)          #'encode-X8_S8_I16<-/shuffle)
+      (('<- 'X8_S8_ZI16)         #'encode-X8_S8_ZI16<-/shuffle)
       (('! 'X8_S8_S8_S8)         #'encode-X8_S8_S8_S8!/shuffle)
       (('<- 'X8_S8_S8_S8)        #'encode-X8_S8_S8_S8<-/shuffle)
       (('<- 'X8_S8_S8_C8)        #'encode-X8_S8_S8_C8<-/shuffle)
@@ -1076,6 +1090,7 @@ later by the linker."
           ('X8_C24 #'(arg))
           ('X8_L24 #'(label))
           ('X8_S8_I16 #'(a imm))
+          ('X8_S8_ZI16 #'(a imm))
           ('X8_S12_S12 #'(a b))
           ('X8_S12_C12 #'(a b))
           ('X8_S12_Z12 #'(a b))
@@ -1209,6 +1224,21 @@ immediate, and @code{#f} otherwise."
         (and (not (zero? (logand bits 6)))
              bits))))
 
+(define (signed-bits asm uimm n)
+  "Given the immediate-bits encoding @var{uimm}, return its bit pattern
+if it can be restricted to a sign-extended bitfield of @var{n} bits, or
+@code{#f} otherwise."
+  (let* ((all-bits (1- (ash 1 (* (asm-word-size asm) 8))))
+         (fixed-bits (1- (ash 1 n)))
+         (sign-bits (lognot (ash fixed-bits -1))))
+    (cond
+     ((eqv? (logand all-bits sign-bits) (logand uimm sign-bits))
+      (logand uimm fixed-bits))
+     ((zero? (logand uimm sign-bits))
+      uimm)
+     (else
+      #f))))
+
 (define-record-type <stringbuf>
   (make-stringbuf string)
   stringbuf?
@@ -1368,6 +1398,8 @@ returned instead."
    ((immediate-bits asm obj)
     => (lambda (bits)
          (cond
+          ((and (< dst 256) (signed-bits asm bits 16))
+           (emit-make-immediate asm dst obj))
           ((and (< dst 256) (zero? (ash bits -16)))
            (emit-make-short-immediate asm dst obj))
           ((zero? (ash bits -32))

module/system/vm/disassembler.scm

@@ -95,7 +95,7 @@
            #'((ash word -8)))
           ((X8_L24)
            #'((unpack-s24 (ash word -8))))
-          ((X8_S8_I16)
+          ((X8_S8_I16 X8_S8_ZI16)
            #'((logand (ash word -8) #xff)
               (ash word -16)))
           ((X8_S12_S12
@@ -205,6 +205,14 @@ address of that offset."
 
 (visit-heap-tags define-heap-tag-annotation)
 
+(define (sign-extended-immediate uimm n)
+  (unpack-scm
+   (if (>= uimm (ash 1 (- n 1)))
+       (let ((word-bits (* (sizeof '*) 8))) ; FIXME
+         (logand (1- (ash 1 word-bits))
+                 (- uimm (ash 1 n))))
+       uimm)))
+
 (define (code-annotation code len offset start labels context push-addr!)
   ;; FIXME: Print names for register loads and stores that correspond to
   ;; access to named locals.
@@ -227,6 +235,8 @@ address of that offset."
     (('prompt tag escape-only? proc-slot handler)
      ;; The H is for handler.
      (list "H -> ~A" (vector-ref labels (- (+ offset handler) start))))
+    (('make-immediate _ imm)
+     (list "~S" (sign-extended-immediate imm 16)))
     (((or 'make-short-immediate 'make-long-immediate) _ imm)
      (list "~S" (unpack-scm imm)))
     (('make-long-long-immediate _ high low)