Rework the way immediate encodings are calculated.

* module/system/base/types/internal.scm (scm->immediate-bits):
  (immediate-bits->scm, sign-extend, truncate-bits): New public
  routines.
* module/system/vm/assembler.scm (immediate-bits): Reimplement in terms
  of scm->immediate-bits and similar.
  (X8_S8_I16, X8_S8_ZI16): Rework operand encodings.
  (load-constant): Use truncate-bits to determine which cases apply.

module/system/base/types/internal.scm

@@ -1,5 +1,5 @@
 ;;; Details on internal value representation.
-;;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015, 2017, 2018, 2020 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Lesser General Public License as published by
@@ -61,7 +61,12 @@
             %tc16-flonum
             %tc16-complex
             %tc16-fraction
-            visit-heap-tags))
+            visit-heap-tags
+
+            scm->immediate-bits
+            immediate-bits->scm
+            truncate-bits
+            sign-extend))
 
 ;;; Commentary:
 ;;;
@@ -182,6 +187,50 @@
 (visit-immediate-tags define-tag)
 (visit-heap-tags define-tag)
 
+(define (scm->immediate-bits x)
+  "If @var{x} is of a type that could be encoded as an immediate, return
+that bit pattern, or @code{#f} otherwise..  Note that the immediate bits
+may not fit into a word on the target platform."
+  (cond
+   ((exact-integer? x) (logior %tc2-fixnum (ash x 2)))
+   ((char? x)          (logior %tc8-char (ash (char->integer x) 8)))
+   ((eq? x #f)         %tc16-false)
+   ((eq? x #nil)       %tc16-nil)
+   ((eq? x '())        %tc16-null)
+   ((eq? x #t)         %tc16-true)
+   ((unspecified? x)   %tc16-unspecified)
+   ;; FIXME: %tc16-undefined.
+   ((eof-object? x)  %tc16-eof)
+   (else #f)))
+
+(define (immediate-bits->scm imm)
+  "Return the SCM object corresponding to the immediate encoding
+@code{imm}.  Note that this value should be sign-extended already."
+  (define-syntax-rule (define-predicate name pred mask tag)
+    (define (pred) (eqv? (logand imm mask) tag)))
+  (visit-immediate-tags define-predicate)
+  (cond
+   ((fixnum?)      (ash imm -2))
+   ((char?)        (integer->char (ash imm -8)))
+   ((eq-false?)    #f)
+   ((eq-nil?)      #nil)
+   ((eq-null?)     '())
+   ((eq-true?)     #t)
+   ((unspecified?) (if #f #f))
+   ((eof-object?)  the-eof-object)
+   (else (error "invalid immediate" imm))) )
+
+(define (sign-extend x bits)
+  (case (ash x (- 1 bits))
+    ((0) x)
+    ((1) (- x (ash 1 bits)))
+    (else (error "value does not fit in bits" x bits))))
+
+(define (truncate-bits x bits signed?)
+  (let ((x' (logand x (1- (ash 1 bits)))))
+    (and (eq? x (if signed? (sign-extend x' bits) x'))
+         x')))
+
 ;; See discussion in tags.h and boolean.h.
 (eval-when (expand)
   (let ()

module/system/vm/assembler.scm

@@ -640,6 +640,10 @@ later by the linker."
          (reloc (make-reloc 's32 label start (- pos start))))
     (set-asm-relocs! asm (cons reloc (asm-relocs asm)))))
 
+(define (immediate-bits asm x)
+  (let ((bits (scm->immediate-bits x)))
+    (and bits (truncate-bits bits (* 8 (asm-word-size asm)) #t))))
+
 
 
 
@@ -682,11 +686,11 @@ later by the linker."
             (record-label-reference asm label)
             (emit asm opcode))
            ((X8_S8_I16 a imm)
-            (emit asm (pack-u8-u8-u16 opcode a (immediate-bits asm imm))))
+            (let ((bits (truncate-bits (scm->immediate-bits imm) 16 #f)))
+              (emit asm (pack-u8-u8-u16 opcode a bits))))
            ((X8_S8_ZI16 a imm)
-            (emit asm (pack-u8-u8-u16 opcode a
+            (let ((bits (truncate-bits (scm->immediate-bits imm) 16 #t)))
-                                      (signed-bits asm (immediate-bits asm imm)
+              (emit asm (pack-u8-u8-u16 opcode a bits))))
-                                                   16))))
            ((X8_S12_S12 a b)
             (emit asm (pack-u8-u12-u12 opcode a b)))
            ((X8_S12_C12 a b)
@@ -1207,48 +1211,6 @@ lists.  This procedure can be called many times before calling
 ;;; to the table.
 ;;;
 
-(define (immediate-bits asm x)
-  "Return the bit pattern to write into the buffer if @var{x} is
-immediate, and @code{#f} otherwise."
-  (define tc2-int 2)
-  (if (exact-integer? x)
-      ;; Object is an immediate if it is a fixnum on the target.
-      (call-with-values (lambda ()
-                          (case (asm-word-size asm)
-                            ((4) (values    (- #x20000000)
-                                            #x1fffffff))
-                            ((8) (values    (- #x2000000000000000)
-                                            #x1fffffffFFFFFFFF))
-                            (else (error "unexpected word size"))))
-        (lambda (fixnum-min fixnum-max)
-          (and (<= fixnum-min x fixnum-max)
-               (let ((fixnum-bits (if (negative? x)
-                                      (+ fixnum-max 1 (logand x fixnum-max))
-                                      x)))
-                 (logior (ash fixnum-bits 2) tc2-int)))))
-      ;; Otherwise, the object will be immediate on the target if and
-      ;; only if it is immediate on the host.  Except for integers,
-      ;; which we handle specially above, any immediate value is an
-      ;; immediate on both 32-bit and 64-bit targets.
-      (let ((bits (object-address x)))
-        (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?
@@ -1405,17 +1367,20 @@ returned instead."
 
 (define-macro-assembler (load-constant asm dst obj)
   (cond
-   ((immediate-bits asm obj)
+   ((scm->immediate-bits obj)
     => (lambda (bits)
          (cond
-          ((and (< dst 256) (signed-bits asm bits 16))
+          ((and (< dst 256) (truncate-bits bits 16 #t))
            (emit-make-immediate asm dst obj))
-          ((and (< dst 256) (zero? (ash bits -16)))
+          ((and (< dst 256) (truncate-bits bits 16 #f))
            (emit-make-short-immediate asm dst obj))
-          ((zero? (ash bits -32))
+          ((truncate-bits bits 32 (eqv? (asm-word-size asm) 4))
            (emit-make-long-immediate asm dst obj))
+          ((and (eqv? (asm-word-size asm) 8)
+                (truncate-bits bits 64 #t))
+           (emit-make-long-long-immediate asm dst obj))
           (else
-           (emit-make-long-long-immediate asm dst obj)))))
+           (emit-static-ref asm dst (intern-non-immediate asm obj))))))
    ((statically-allocatable? obj)
     (emit-make-non-immediate asm dst (intern-non-immediate asm obj)))
    (else