WIP: New tagging v9wip-new-tagging-bis-broken

53 files changed, 757 insertions, 386 deletions

diff --git a/libguile/alist.c b/libguile/alist.c
index 7bc86be9f..8b423738e 100644
--- a/libguile/alist.c
+++ b/libguile/alist.c
@@ -98,7 +98,7 @@ SCM_DEFINE (scm_sloppy_assoc, "sloppy-assoc", 2, 0, 0,
 #define FUNC_NAME s_scm_sloppy_assoc
 {
   /* Immediate values can be checked using `eq?'.  */
-  if (SCM_IMP (key))
+  if (!SCM_HEAP_OBJECT_P (key))
     return scm_sloppy_assq (key, alist);
 
   for (; scm_is_pair (alist); alist = SCM_CDR (alist))
@@ -179,7 +179,7 @@ SCM_DEFINE (scm_assoc, "assoc", 2, 0, 0,
   SCM ls = alist;
 
   /* Immediate values can be checked using `eq?'.  */
-  if (SCM_IMP (key))
+  if (!SCM_HEAP_OBJECT_P (key))
     return scm_assq (key, alist);
 
   for(; scm_is_pair (ls); ls = SCM_CDR (ls)) 
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 4b69e67a1..27245ac71 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -170,7 +170,7 @@ initialize_vector_handle (scm_t_array_handle *h, size_t len,
 void
 scm_array_get_handle (SCM array, scm_t_array_handle *h)
 {
-  if (!SCM_HEAP_OBJECT_P (array))
+  if (!SCM_THOB_P (array))
     scm_wrong_type_arg_msg (NULL, 0, array, "array");
 
   h->array = array;
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 0a919515b..dbe0efd6e 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -635,7 +635,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
   int ndim, i, k;
 
   SCM_VALIDATE_REST_ARGUMENT (args);
-  SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME);
+  SCM_ASSERT (SCM_THOB_P (ra), ra, SCM_ARG1, FUNC_NAME);
 
   switch (scm_c_array_rank (ra))
     {
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 7221fdb63..d592099b6 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -66,7 +66,7 @@ SCM_API SCM scm_array_rank (SCM ra);
 #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
   (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
 
-#define SCM_I_ARRAYP(a)	    SCM_TYP16_PREDICATE (scm_tc7_array, a)
+#define SCM_I_ARRAYP(x)      (SCM_HAS_TYP7 (x, scm_tc7_array))
 #define SCM_I_ARRAY_NDIM(x)  ((size_t) (SCM_CELL_WORD_0 (x)>>17))
 #define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0 (x) & (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))
 
diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c
index 0bb4c1f59..1c932e20b 100644
--- a/libguile/bitvectors.c
+++ b/libguile/bitvectors.c
@@ -48,7 +48,7 @@
 
 #define IS_BITVECTOR(obj)         SCM_HAS_TYP7  ((obj), scm_tc7_bitvector)
 #define IS_MUTABLE_BITVECTOR(x)                                 \
-  (SCM_NIMP (x) &&                                              \
+  (SCM_THOB_P (x) &&                                            \
    ((SCM_CELL_TYPE (x) & (0x7f | SCM_F_BITVECTOR_IMMUTABLE))    \
     == scm_tc7_bitvector))
 #define BITVECTOR_LENGTH(obj)   ((size_t)SCM_CELL_WORD_1(obj))
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index 980d6e267..f0ce2325b 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -132,7 +132,7 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM);
 #define SCM_F_BYTEVECTOR_IMMUTABLE 0x200UL
 
 #define SCM_MUTABLE_BYTEVECTOR_P(x)                                     \
-  (SCM_NIMP (x) &&                                                      \
+  (SCM_THOB_P (x) &&                                                    \
    ((SCM_CELL_TYPE (x) & (0x7fUL | (SCM_F_BYTEVECTOR_IMMUTABLE << 7UL)))  \
     == scm_tc7_bytevector))
 
diff --git a/libguile/eq.c b/libguile/eq.c
index 627d6f09b..3f1239f56 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -159,7 +159,7 @@ scm_i_fraction_equalp (SCM x, SCM y)
 int
 scm_i_heap_numbers_equal_p (SCM x, SCM y)
 {
-  if (SCM_IMP (x)) abort();
+  if (!SCM_THOB_P (x)) abort();
   switch (SCM_TYP16 (x))
     {
     case scm_tc16_big:
@@ -216,9 +216,9 @@ SCM scm_eqv_p (SCM x, SCM y)
 {
   if (scm_is_eq (x, y))
     return SCM_BOOL_T;
-  if (SCM_IMP (x))
+  if (!SCM_THOB_P (x))
     return SCM_BOOL_F;
-  if (SCM_IMP (y))
+  if (!SCM_THOB_P (y))
     return SCM_BOOL_F;
 
   /* this ensures that types and scm_length are the same. */
@@ -299,18 +299,28 @@ scm_equal_p (SCM x, SCM y)
   SCM_TICK;
   if (scm_is_eq (x, y))
     return SCM_BOOL_T;
-  if (SCM_IMP (x))
-    return SCM_BOOL_F;
-  if (SCM_IMP (y))
-    return SCM_BOOL_F;
-  if (scm_is_pair (x) && scm_is_pair (y))
+
+  if (scm_is_pair (x))
     {
-      if (scm_is_false (scm_equal_p (SCM_CAR (x), SCM_CAR (y))))
-	return SCM_BOOL_F;
-      x = SCM_CDR(x);
-      y = SCM_CDR(y);
-      goto tailrecurse;
+      if (scm_is_pair (y))
+        {
+          if (scm_is_false (scm_equal_p (SCM_CAR (x), SCM_CAR (y))))
+            return SCM_BOOL_F;
+          x = SCM_CDR(x);
+          y = SCM_CDR(y);
+          goto tailrecurse;
+        }
+      else
+        return SCM_BOOL_F;
     }
+  else if (scm_is_pair (y))
+    return SCM_BOOL_F;
+
+  if (!SCM_THOB_P (x))
+    return SCM_BOOL_F;
+  if (!SCM_THOB_P (y))
+    return SCM_BOOL_F;
+
   if (SCM_TYP7 (x) == scm_tc7_smob && SCM_TYP16 (x) == SCM_TYP16 (y))
     {
       int i = SCM_SMOBNUM (x);
diff --git a/libguile/eval.h b/libguile/eval.h
index b25e76f94..6987399ab 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -33,15 +33,6 @@
 
 
 
-/* {Ilocs}
- *
- * Ilocs are relative pointers into local environment structures.
- * 
- */
-#define SCM_ILOCP(n)		(SCM_ITAG8(n)==scm_tc8_iloc)
-
-
-
 /* {Evaluator}
  */
 
diff --git a/libguile/evalext.c b/libguile/evalext.c
index 4ac434343..dd93959b8 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -64,16 +64,17 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
 	    "Return #t for objects which Guile considers self-evaluating")
 #define FUNC_NAME s_scm_self_evaluating_p
 {
-  switch (SCM_ITAG3 (obj))
+  switch (SCM_ITAG (obj))
     {
-    case scm_tc3_int_1:
-    case scm_tc3_int_2:
-      /* inum */
+    case scm_itags_fixnum:
+      /* immediate numbers */
       return SCM_BOOL_T;
-    case scm_tc3_imm24:
-	/* characters, booleans, other immediates */
+    case scm_itags_imm24:
+      /* characters, booleans, other immediates */
       return scm_from_bool (!scm_is_null_and_not_nil (obj));
-    case scm_tc3_cons:
+    case scm_itags_pair:
+      return SCM_BOOL_F;
+    case scm_itags_thob:
       switch (SCM_TYP7 (obj))
 	{
 	case scm_tc7_vector:
diff --git a/libguile/gc-inline.h b/libguile/gc-inline.h
index 62fdb9eec..3f0dec587 100644
--- a/libguile/gc-inline.h
+++ b/libguile/gc-inline.h
@@ -166,7 +166,7 @@ scm_inline_words (scm_thread *thread, scm_t_bits car, uint32_t n_words)
 static inline SCM
 scm_inline_cons (scm_thread *thread, SCM x, SCM y)
 {
-  return scm_inline_cell (thread, SCM_UNPACK (x), SCM_UNPACK (y));
+  return SCM_ADD_PAIR_TAG (scm_inline_cell (thread, SCM_UNPACK (x), SCM_UNPACK (y)));
 }
 
 
diff --git a/libguile/gc.c b/libguile/gc.c
index 5bbe1d968..5dc566123 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -478,9 +478,9 @@ scm_storage_prehistory ()
   /* We only need to register a displacement for those types for which the
      higher bits of the type tag are used to store a pointer (that is, a
      pointer to an 8-octet aligned region).  */
-  GC_REGISTER_DISPLACEMENT (scm_tc3_cons);
+  GC_REGISTER_DISPLACEMENT (scm_thob_tag);
+  GC_REGISTER_DISPLACEMENT (scm_pair_tag);
   GC_REGISTER_DISPLACEMENT (scm_tc3_struct);
-  /* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */
 
   /* Sanity check.  */
   if (!GC_is_visible (&scm_protects))
diff --git a/libguile/gc.h b/libguile/gc.h
index 387f78a7d..8c891d141 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -77,8 +77,15 @@ typedef struct scm_t_cell
 #define SCM_SET_CELL_OBJECT_3(x, v) SCM_SET_CELL_OBJECT ((x), 3, (v))
 
 #define SCM_CELL_OBJECT_LOC(x, n) (&SCM_GC_CELL_OBJECT ((x), (n)))
-#define SCM_CARLOC(x)             (SCM_CELL_OBJECT_LOC ((x), 0))
-#define SCM_CDRLOC(x)             (SCM_CELL_OBJECT_LOC ((x), 1))
+
+#define SCM_ADD_POINTER_TAG(tag, x)     (SCM_PACK (SCM_UNPACK (x) + (tag)))
+#define SCM_REMOVE_POINTER_TAG(tag, x)  (SCM_PACK (SCM_UNPACK (x) - (tag)))
+
+#define SCM_ADD_PAIR_TAG(x)       (SCM_ADD_POINTER_TAG (scm_pair_tag, (x)))
+#define SCM_REMOVE_PAIR_TAG(x)    (SCM_REMOVE_POINTER_TAG (scm_pair_tag, (x)))
+
+#define SCM_CARLOC(x)     (SCM_CELL_OBJECT_LOC (SCM_REMOVE_PAIR_TAG (x), 0))
+#define SCM_CDRLOC(x)     (SCM_CELL_OBJECT_LOC (SCM_REMOVE_PAIR_TAG (x), 1))
 
 #define SCM_CELL_TYPE(x) SCM_CELL_WORD_0 (x)
 #define SCM_SET_CELL_TYPE(x, t) SCM_SET_CELL_WORD_0 ((x), (t))
diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c
index 28ca6b3c7..d1a959edc 100644
--- a/libguile/generalized-arrays.c
+++ b/libguile/generalized-arrays.c
@@ -46,7 +46,7 @@ SCM_INTERNAL SCM scm_i_array_set_x (SCM v, SCM obj,
 int
 scm_is_array (SCM obj)
 {
-  if (!SCM_HEAP_OBJECT_P (obj))
+  if (!SCM_THOB_P (obj))
     return 0;
 
   switch (SCM_TYP7 (obj))
diff --git a/libguile/generalized-arrays.h b/libguile/generalized-arrays.h
index 130807b29..ec88d651c 100644
--- a/libguile/generalized-arrays.h
+++ b/libguile/generalized-arrays.h
@@ -34,7 +34,7 @@
 
 #define SCM_VALIDATE_ARRAY(pos, v) \
   do { \
-    SCM_ASSERT (SCM_HEAP_OBJECT_P (v) \
+    SCM_ASSERT (SCM_THOB_P (v) \
                 && scm_is_true (scm_array_p (v, SCM_UNDEFINED)), \
                 v, pos, FUNC_NAME); \
   } while (0)
diff --git a/libguile/goops.c b/libguile/goops.c
index fd312a8f1..99353b555 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -203,13 +203,12 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
 	    "Return the class of @var{x}.")
 #define FUNC_NAME s_scm_class_of
 {
-  switch (SCM_ITAG3 (x))
+  switch (SCM_ITAG (x))
     {
-    case scm_tc3_int_1:
-    case scm_tc3_int_2:
+    case scm_itags_fixnum:
       return class_integer;
 
-    case scm_tc3_imm24:
+    case scm_itags_imm24:
       if (SCM_CHARP (x))
 	return class_char;
       else if (scm_is_bool (x))
@@ -219,11 +218,12 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
       else
         return class_unknown;
 
-    case scm_tc3_cons:
+    case scm_itags_pair:
+      return class_pair;
+
+    case scm_itags_thob:
       switch (SCM_TYP7 (x))
 	{
-	case scm_tcs_cons_nimcar:
-	  return class_pair;
 	case scm_tc7_symbol:
 	  return class_symbol;
 	case scm_tc7_vector:
@@ -325,18 +325,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
               return scm_i_define_class_for_vtable (vtable);
           }
 	default:
-	  if (scm_is_pair (x))
-	    return class_pair;
-	  else
-	    return class_unknown;
+          return class_unknown;
 	}
-
-    case scm_tc3_struct:
-    case scm_tc3_tc7_1:
-    case scm_tc3_tc7_2:
-      /* case scm_tc3_unused: */
-      /* Never reached */
-      break;
     }
   return class_unknown;
 }
diff --git a/libguile/hash.c b/libguile/hash.c
index d6e93dae0..c590dc56d 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -284,62 +284,63 @@ scm_raw_ihashq (scm_t_bits key)
 static unsigned long
 scm_raw_ihash (SCM obj, size_t depth)
 {
-  if (SCM_IMP (obj))
-    return scm_raw_ihashq (SCM_UNPACK (obj));
-
-  switch (SCM_TYP7(obj))
-    {
-      /* FIXME: do better for structs, variables, ...  Also the hashes
-         are currently associative, which ain't the right thing.  */
-    case scm_tc7_smob:
-      return scm_raw_ihashq (SCM_TYP16 (obj));
-    case scm_tc7_number:
-      if (scm_is_integer (obj))
+  if (SCM_THOB_P (obj))
+    switch (SCM_TYP7(obj))
+      {
+        /* FIXME: do better for structs, variables, ...  Also the hashes
+           are currently associative, which ain't the right thing.  */
+      case scm_tc7_smob:
+        return scm_raw_ihashq (SCM_TYP16 (obj));
+      case scm_tc7_number:
+        if (scm_is_integer (obj))
+          {
+            SCM n = SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM);
+            if (scm_is_inexact (obj))
+              obj = scm_inexact_to_exact (obj);
+            return scm_raw_ihashq (scm_to_ulong (scm_modulo (obj, n)));
+          }
+        else
+          return scm_i_string_hash (scm_number_to_string (obj, scm_from_int (10)));
+      case scm_tc7_string:
+        return scm_i_string_hash (obj);
+      case scm_tc7_symbol:
+        return scm_i_symbol_hash (obj);
+      case scm_tc7_pointer:
+        return scm_raw_ihashq ((uintptr_t) SCM_POINTER_VALUE (obj));
+      case scm_tc7_wvect:
+      case scm_tc7_vector:
         {
-          SCM n = SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM);
-          if (scm_is_inexact (obj))
-            obj = scm_inexact_to_exact (obj);
-          return scm_raw_ihashq (scm_to_ulong (scm_modulo (obj, n)));
+          size_t len = SCM_SIMPLE_VECTOR_LENGTH (obj);
+          size_t i = depth / 2;
+          unsigned long h = scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
+          if (len)
+            while (i--)
+              h ^= scm_raw_ihash (scm_c_vector_ref (obj, h % len), i);
+          return h;
         }
-      else
-        return scm_i_string_hash (scm_number_to_string (obj, scm_from_int (10)));
-    case scm_tc7_string:
-      return scm_i_string_hash (obj);
-    case scm_tc7_symbol:
-      return scm_i_symbol_hash (obj);
-    case scm_tc7_pointer:
-      return scm_raw_ihashq ((uintptr_t) SCM_POINTER_VALUE (obj));
-    case scm_tc7_wvect:
-    case scm_tc7_vector:
-      {
-	size_t len = SCM_SIMPLE_VECTOR_LENGTH (obj);
-        size_t i = depth / 2;
-        unsigned long h = scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
-        if (len)
-          while (i--)
-            h ^= scm_raw_ihash (scm_c_vector_ref (obj, h % len), i);
-        return h;
-      }
-    case scm_tc7_syntax:
-      {
-        unsigned long h;
-        h = scm_raw_ihash (scm_syntax_expression (obj), depth);
-        h ^= scm_raw_ihash (scm_syntax_wrap (obj), depth);
-        h ^= scm_raw_ihash (scm_syntax_module (obj), depth);
-        return h;
+      case scm_tc7_syntax:
+        {
+          unsigned long h;
+          h = scm_raw_ihash (scm_syntax_expression (obj), depth);
+          h ^= scm_raw_ihash (scm_syntax_wrap (obj), depth);
+          h ^= scm_raw_ihash (scm_syntax_module (obj), depth);
+          return h;
+        }
+      case scm_tcs_struct:
+        return scm_i_struct_hash (obj, depth);
+      default:
+        return scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
       }
-    case scm_tcs_cons_imcar: 
-    case scm_tcs_cons_nimcar:
+  else if (scm_is_pair (obj))
+    {
       if (depth)
         return (scm_raw_ihash (SCM_CAR (obj), depth / 2)
                 ^ scm_raw_ihash (SCM_CDR (obj), depth / 2));
       else
-        return scm_raw_ihashq (scm_tc3_cons);
-    case scm_tcs_struct:
-      return scm_i_struct_hash (obj, depth);
-    default:
-      return scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
+        return scm_raw_ihashq (0);
     }
+  else /* immediate */
+    return scm_raw_ihashq (SCM_UNPACK (obj));
 }
 
 
diff --git a/libguile/instructions.c b/libguile/instructions.c
index ddd88b311..8295a5c4a 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -52,6 +52,7 @@ SCM_SYMBOL (sym_bang, "!");
     M(X8_S8_S8_S8)                              \
     M(X8_S8_C8_S8)                              \
     M(X8_S8_S8_C8)                              \
+    M(X8_S8_C8_C8)                              \
     M(C8_C24)                                   \
     M(C8_S24)                                   \
     M(C32) /* Unsigned. */                      \
diff --git a/libguile/jit.c b/libguile/jit.c
index 5350982d2..b850ca672 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -1226,9 +1226,9 @@ emit_load_fp_slot (scm_jit_state *j, jit_gpr_t dst, uint32_t slot)
 }
 
 static jit_reloc_t
-emit_branch_if_immediate (scm_jit_state *j, jit_gpr_t r)
+emit_branch_if_not_thob (scm_jit_state *j, jit_gpr_t r)
 {
-  return jit_bmsi (j->jit, r, 6);
+  return jit_bmsi (j->jit, r, 7);   /* TAGS-SENSITIVE */
 }
 
 static void
@@ -1637,7 +1637,7 @@ compile_subr_call (scm_jit_state *j, uint32_t idx)
   clear_scratch_register_state (j);
   jit_retval (j->jit, ret);
 
-  immediate = emit_branch_if_immediate (j, ret);
+  immediate = emit_branch_if_not_thob (j, ret);
   not_values = emit_branch_if_heap_object_not_tc7 (j, ret, t, scm_tc7_values);
   emit_call_2 (j, scm_vm_intrinsics.unpack_values_object, thread_operand (),
                jit_operand_gpr (JIT_OPERAND_ABI_POINTER, ret));
@@ -2042,6 +2042,20 @@ compile_allocate_words_immediate (scm_jit_state *j, uint16_t dst, uint16_t nword
 }
 
 static void
+compile_tagged_allocate_words_immediate (scm_jit_state *j, uint8_t dst, uint8_t nwords, uint8_t tag)
+{
+  jit_gpr_t t = T0;
+
+  emit_store_current_ip (j, t);
+  emit_call_2 (j, scm_vm_intrinsics.allocate_words, thread_operand (),
+               jit_operand_imm (JIT_OPERAND_ABI_WORD, nwords));
+  emit_retval (j, t);
+  emit_addi (j, t, t, tag);
+  emit_reload_sp (j);
+  emit_sp_set_scm (j, dst, t);
+}
+
+static void
 compile_scm_ref (scm_jit_state *j, uint8_t dst, uint8_t obj, uint8_t idx)
 {
   emit_sp_ref_scm (j, T0, obj);
@@ -2088,6 +2102,15 @@ compile_scm_ref_immediate (scm_jit_state *j, uint8_t dst, uint8_t obj, uint8_t i
 }
 
 static void
+compile_tagged_scm_ref_immediate (scm_jit_state *j, uint8_t dst, uint8_t obj, uint8_t byte_offset_u)
+{
+  int8_t byte_offset = byte_offset_u;
+  emit_sp_ref_scm (j, T0, obj);
+  emit_ldxi (j, T0, T0, byte_offset);
+  emit_sp_set_scm (j, dst, T0);
+}
+
+static void
 compile_scm_set_immediate (scm_jit_state *j, uint8_t obj, uint8_t idx, uint8_t val)
 {
   emit_sp_ref_scm (j, T0, obj);
@@ -2096,6 +2119,15 @@ compile_scm_set_immediate (scm_jit_state *j, uint8_t obj, uint8_t idx, uint8_t v
 }
 
 static void
+compile_tagged_scm_set_immediate (scm_jit_state *j, uint8_t obj, uint8_t byte_offset_u, uint8_t val)
+{
+  int8_t byte_offset = byte_offset_u;
+  emit_sp_ref_scm (j, T0, obj);
+  emit_sp_ref_scm (j, T1, val);
+  jit_stxi (j->jit, byte_offset, T0, T1);
+}
+
+static void
 compile_word_ref (scm_jit_state *j, uint8_t dst, uint8_t obj, uint8_t idx)
 {
   emit_sp_ref_scm (j, T0, obj);
@@ -2194,16 +2226,16 @@ compile_call_scm_from_scm_scm (scm_jit_state *j, uint8_t dst, uint8_t a, uint8_t
         emit_sp_ref_scm (j, T1, b);
         op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0);
         op_b = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T1);
-        jit_reloc_t a_not_inum = jit_bmci (j->jit, T0, scm_tc2_int);
-        jit_reloc_t b_not_inum = jit_bmci (j->jit, T1, scm_tc2_int);
-        jit_subi (j->jit, T0, T0, scm_tc2_int);
+        jit_subi (j->jit, T0, T0, scm_fixnum_tag);
+        jit_subi (j->jit, T2, T1, scm_fixnum_tag);
+        jit_orr (j->jit, T2, T2, T0);   /* TAGS-SENSITIVE */
+        jit_reloc_t not_inum = jit_bmsi (j->jit, T2, scm_fixnum_tag_mask);
         fast = jit_bxaddr (j->jit, T0, T1);
         has_fast = 1;
         /* Restore previous value before slow path.  */
         jit_subr (j->jit, T0, T0, T1);
-        jit_addi (j->jit, T0, T0, scm_tc2_int);
-        jit_patch_here (j->jit, a_not_inum);
-        jit_patch_here (j->jit, b_not_inum);
+        jit_patch_here (j->jit, not_inum);
+        jit_addi (j->jit, T0, T0, scm_fixnum_tag);
         break;
       }
     case SCM_VM_INTRINSIC_SUB:
@@ -2212,16 +2244,16 @@ compile_call_scm_from_scm_scm (scm_jit_state *j, uint8_t dst, uint8_t a, uint8_t
         emit_sp_ref_scm (j, T1, b);
         op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0);
         op_b = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T1);
-        jit_reloc_t a_not_inum = jit_bmci (j->jit, T0, scm_tc2_int);
-        jit_reloc_t b_not_inum = jit_bmci (j->jit, T1, scm_tc2_int);
-        jit_subi (j->jit, T1, T1, scm_tc2_int);
+        jit_subi (j->jit, T1, T1, scm_fixnum_tag);
+        jit_subi (j->jit, T2, T0, scm_fixnum_tag);
+        jit_orr (j->jit, T2, T2, T1);   /* TAGS-SENSITIVE */
+        jit_reloc_t not_inum = jit_bmsi (j->jit, T2, scm_fixnum_tag_mask);
         fast = jit_bxsubr (j->jit, T0, T1);
         has_fast = 1;
         /* Restore previous values before slow path.  */
         jit_addr (j->jit, T0, T0, T1);
-        jit_addi (j->jit, T1, T1, scm_tc2_int);
-        jit_patch_here (j->jit, a_not_inum);
-        jit_patch_here (j->jit, b_not_inum);
+        jit_patch_here (j->jit, not_inum);
+        jit_addi (j->jit, T1, T1, scm_fixnum_tag);
         break;
       }
     default:
@@ -2254,8 +2286,9 @@ compile_call_scm_from_scm_uimm (scm_jit_state *j, uint8_t dst, uint8_t a, uint8_
       {
         emit_sp_ref_scm (j, T0, a);
         op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0);
-        scm_t_bits addend = b << 2;
-        jit_reloc_t not_inum = jit_bmci (j->jit, T0, 2);
+        scm_t_bits addend = b << scm_fixnum_tag_size;
+        jit_comr (j->jit, T1, T0); /* TAGS-SENSITIVE */
+        jit_reloc_t not_inum = jit_bmsi (j->jit, T1, scm_fixnum_tag_mask);
         fast = jit_bxaddi (j->jit, T0, addend);
         has_fast = 1;
         /* Restore previous value before slow path.  */
@@ -2267,8 +2300,9 @@ compile_call_scm_from_scm_uimm (scm_jit_state *j, uint8_t dst, uint8_t a, uint8_
       {
         emit_sp_ref_scm (j, T0, a);
         op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0);
-        scm_t_bits subtrahend = b << 2;
-        jit_reloc_t not_inum = jit_bmci (j->jit, T0, 2);
+        scm_t_bits subtrahend = b << scm_fixnum_tag_size;
+        jit_comr (j->jit, T1, T0); /* TAGS-SENSITIVE */
+        jit_reloc_t not_inum = jit_bmsi (j->jit, T1, scm_fixnum_tag_mask);
         fast = jit_bxsubi (j->jit, T0, subtrahend);
         has_fast = 1;
         /* Restore previous value before slow path.  */
@@ -2371,6 +2405,14 @@ compile_make_non_immediate (scm_jit_state *j, uint32_t dst, const void *data)
 }
 
 static void
+compile_make_tagged_non_immediate (scm_jit_state *j, uint32_t dst, uint32_t tag, const void *data)
+{
+  emit_movi (j, T0, (uintptr_t)data);
+  emit_addi (j, T0, T0, tag);
+  emit_sp_set_scm (j, dst, T0);
+}
+
+static void
 compile_static_ref (scm_jit_state *j, uint32_t dst, void *loc)
 {
   emit_ldi (j, T0, loc);
@@ -2465,7 +2507,7 @@ compile_tag_char (scm_jit_state *j, uint16_t dst, uint16_t src)
 #else
   emit_sp_ref_u64_lower_half (j, T0, src);
 #endif
-  emit_lshi (j, T0, T0, 8);
+  emit_lshi (j, T0, T0, 8);  /* TAGS-SENSITIVE */
   emit_addi (j, T0, T0, scm_tc8_char);
   emit_sp_set_scm (j, dst, T0);
 }
@@ -2474,7 +2516,7 @@ static void
 compile_untag_char (scm_jit_state *j, uint16_t dst, uint16_t src)
 {
   emit_sp_ref_scm (j, T0, src);
-  emit_rshi (j, T0, T0, 8);
+  emit_rshi (j, T0, T0, 8);  /* TAGS-SENSITIVE */
 #if SIZEOF_UINTPTR_T >= 8
   emit_sp_set_u64 (j, dst, T0);
 #else
@@ -3298,7 +3340,8 @@ compile_less (scm_jit_state *j, uint16_t a, uint16_t b)
   emit_sp_ref_scm (j, T1, b);
 
   emit_andr (j, T2, T0, T1);
-  fast = jit_bmsi (j->jit, T2, scm_tc2_int);
+  emit_comr (j, T2, T2);
+  fast = jit_bmci (j->jit, T2, scm_fixnum_tag_mask);
 
   emit_call_2 (j, scm_vm_intrinsics.less_p,
                jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0),
@@ -3409,7 +3452,7 @@ compile_check_positional_arguments (scm_jit_state *j, uint32_t nreq, uint32_t ex
   emit_ldr (j, obj, walk);
   jit_patch_there
     (j->jit,
-     emit_branch_if_immediate (j, obj),
+     emit_branch_if_not_thob (j, obj),
      head);
   jit_patch_there
     (j->jit,
@@ -3559,11 +3602,11 @@ static void
 compile_untag_fixnum (scm_jit_state *j, uint16_t dst, uint16_t a)
 {
   emit_sp_ref_scm (j, T0, a);
-  emit_rshi (j, T0, T0, 2);
+  emit_rshi (j, T0, T0, scm_fixnum_tag_size);
 #if SIZEOF_UINTPTR_T >= 8
   emit_sp_set_s64 (j, dst, T0);
 #else
-  /* FIXME: Untested!  */
+  /* FIXME: Untested!, and also not updated for new tagging XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
   emit_rshi (j, T1, T0, 31);
   emit_sp_set_s64 (j, dst, T0, T1);
 #endif
@@ -3577,8 +3620,8 @@ compile_tag_fixnum (scm_jit_state *j, uint16_t dst, uint16_t a)
 #else
   emit_sp_ref_s32 (j, T0, a);
 #endif
-  emit_lshi (j, T0, T0, 2);
-  emit_addi (j, T0, T0, scm_tc2_int);
+  emit_lshi (j, T0, T0, scm_fixnum_tag_size);
+  emit_addi (j, T0, T0, scm_fixnum_tag);
   emit_sp_set_scm (j, dst, T0);
 }
 
@@ -4260,6 +4303,15 @@ compile_f64_set (scm_jit_state *j, uint8_t ptr, uint8_t idx, uint8_t v)
     comp (j, a, b);                                                     \
   }
 
+#define COMPILE_X8_S12_C12__N32(j, comp)                                \
+  {                                                                     \
+    uint16_t a, b;                                                      \
+    int32_t c;                                                          \
+    UNPACK_12_12 (j->ip[0], a, b);                                      \
+    c = j->ip[1];                                                       \
+    comp (j, a, b, j->ip + c);                                          \
+  }
+
 #define COMPILE_X8_S8_C8_S8(j, comp)                                    \
   {                                                                     \
     uint8_t a, b, c;                                                    \
@@ -4270,6 +4322,8 @@ compile_f64_set (scm_jit_state *j, uint8_t ptr, uint8_t idx, uint8_t v)
   COMPILE_X8_S8_C8_S8 (j, comp)
 #define COMPILE_X8_S8_S8_S8(j, comp)                                    \
   COMPILE_X8_S8_C8_S8 (j, comp)
+#define COMPILE_X8_S8_C8_C8(j, comp)                                    \
+  COMPILE_X8_S8_C8_S8 (j, comp)
 
 #define COMPILE_X8_S8_I16(j, comp)                                      \
   {                                                                     \
diff --git a/libguile/list.c b/libguile/list.c
index 82aab8a5d..70bfcb077 100644
--- a/libguile/list.c
+++ b/libguile/list.c
@@ -40,9 +40,9 @@
 
 /* creating lists */
 
-#define SCM_I_CONS(cell, x, y)                          \
-  do {                                                  \
-    cell = scm_cell (SCM_UNPACK (x), SCM_UNPACK (y));   \
+#define SCM_I_CONS(cell, x, y)                                            \
+  do {                                                                    \
+    cell = SCM_ADD_PAIR_TAG (scm_cell (SCM_UNPACK (x), SCM_UNPACK (y)));  \
   } while (0)
 
 SCM
diff --git a/libguile/modules.h b/libguile/modules.h
index 34edb328d..5b7b25c84 100644
--- a/libguile/modules.h
+++ b/libguile/modules.h
@@ -31,7 +31,7 @@ SCM_API int scm_module_system_booted_p;
 SCM_API scm_t_bits scm_module_tag;
 
 #define SCM_MODULEP(OBJ) \
-  (!SCM_IMP (OBJ) && SCM_CELL_TYPE (OBJ) == scm_module_tag)
+  (SCM_THOB_P (OBJ) && SCM_CELL_TYPE (OBJ) == scm_module_tag)
 
 #define SCM_VALIDATE_MODULE(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, MODULEP, "module")
 
diff --git a/libguile/numbers.c b/libguile/numbers.c
index d1b463358..4626ccee4 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -148,7 +148,7 @@ VARARG_MPZ_ITERATOR (mpz_clear)
   #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
   #define SCM_I_NUMTAG(x) \
     (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
-       : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
+       : (!SCM_THOB_P(x) ? SCM_I_NUMTAG_NOTNUM \
          : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
            : SCM_I_NUMTAG_NOTNUM)))
 */
diff --git a/libguile/numbers.h b/libguile/numbers.h
index b472ab8cd..14cb851f8 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -1,7 +1,7 @@
 #ifndef SCM_NUMBERS_H
 #define SCM_NUMBERS_H
 
-/* Copyright 1995-1996,1998,2000-2006,2008-2011,2013-2014,2016-2018
+/* Copyright 1995-1996,1998,2000-2006,2008-2011,2013-2014,2016-2019
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -38,7 +38,7 @@
  * In the current implementation, Inums must also fit within a long
  * because that's what GMP's mpz_*_si functions accept.  */
 typedef long scm_t_inum;
-#define SCM_I_FIXNUM_BIT         (SCM_LONG_BIT - 2)
+#define SCM_I_FIXNUM_BIT         (SCM_SIZEOF_UINTPTR_T * 8 - scm_fixnum_tag_size)
 #define SCM_MOST_NEGATIVE_FIXNUM (-1L << (SCM_I_FIXNUM_BIT - 1))
 #define SCM_MOST_POSITIVE_FIXNUM (- (SCM_MOST_NEGATIVE_FIXNUM + 1))
 
@@ -67,18 +67,18 @@ typedef long scm_t_inum;
 
    NOTE: X must not perform side effects.  */
 #ifdef __GNUC__
-# define SCM_I_INUM(x)  (SCM_SRS ((scm_t_inum) SCM_UNPACK (x), 2))
+# define SCM_I_INUM(x)  (SCM_SRS ((scm_t_inum) SCM_UNPACK (x), scm_fixnum_tag_size))
 #else
-# define SCM_I_INUM(x)                          \
-  (SCM_UNPACK (x) > SCM_T_SIGNED_BITS_MAX       \
-   ? -1 - (scm_t_inum) (~SCM_UNPACK (x) >> 2)   \
-   : (scm_t_inum) (SCM_UNPACK (x) >> 2))
+# define SCM_I_INUM(x)                                             \
+  (SCM_UNPACK (x) > SCM_T_SIGNED_BITS_MAX                          \
+   ? -1 - (scm_t_inum) (~SCM_UNPACK (x) >> scm_fixnum_tag_size)    \
+   : (scm_t_inum) (SCM_UNPACK (x) >> scm_fixnum_tag_size))
 #endif
 
-#define SCM_I_INUMP(x)	(2 & SCM_UNPACK (x))
+#define SCM_I_INUMP(x)	((SCM_UNPACK (x) & scm_fixnum_tag_mask) == scm_fixnum_tag)
 #define SCM_I_NINUMP(x) (!SCM_I_INUMP (x))
 #define SCM_I_MAKINUM(x) \
-  (SCM_PACK ((((scm_t_bits) (x)) << 2) + scm_tc2_int))
+  (SCM_PACK ((((scm_t_bits) (x)) << scm_fixnum_tag_size) + scm_fixnum_tag))
 
 /* SCM_FIXABLE is true if its long argument can be encoded in an SCM_INUM. */
 #define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM)
@@ -130,19 +130,20 @@ typedef long scm_t_inum;
  */
 
 
-/* Note that scm_tc16_real and scm_tc16_complex are given tc16-codes that only
- * differ in one bit: This way, checking if an object is an inexact number can
- * be done quickly (using the TYP16S macro).  */
+/* Note that scm_tc16_real and scm_tc16_complex are given tc16-codes that
+ * only differ in one bit: This way, checking if an object is an inexact
+ * number can be done quickly.  */
 
-/* Number subtype 1 to 3 (note the dependency on the predicates SCM_INEXACTP
- * and SCM_NUMP)  */
+/* Number subtype 1 to 4 (note the dependency on SCM_INEXACTP) */
 #define scm_tc16_big		(scm_tc7_number + 1 * 256L)
 #define scm_tc16_real           (scm_tc7_number + 2 * 256L)
 #define scm_tc16_complex        (scm_tc7_number + 3 * 256L)
 #define scm_tc16_fraction       (scm_tc7_number + 4 * 256L)
 
-#define SCM_INEXACTP(x) \
-  (!SCM_IMP (x) && (0xfeff & SCM_CELL_TYPE (x)) == scm_tc16_real)
+#define SCM_INEXACTP(x)                                            \
+  (SCM_THOB_P (x)                                                  \
+   && ((SCM_TYP16 (x) & ~(scm_tc16_real ^ scm_tc16_complex))       \
+       == (scm_tc16_real & scm_tc16_complex)))
 #define SCM_REALP(x) (SCM_HAS_TYP16 (x, scm_tc16_real))
 #define SCM_COMPLEXP(x) (SCM_HAS_TYP16 (x, scm_tc16_complex))
 
diff --git a/libguile/pairs.h b/libguile/pairs.h
index 617b4c229..02e8919b3 100644
--- a/libguile/pairs.h
+++ b/libguile/pairs.h
@@ -67,11 +67,11 @@
 /* #nil is null. */
 #define scm_is_null(x)		(scm_is_null_or_nil(x))
 
-#define SCM_CAR(x)		(SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_0 (x)))
-#define SCM_CDR(x)		(SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_1 (x)))
+#define SCM_CAR(x)		(SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_0 (SCM_REMOVE_PAIR_TAG (x))))
+#define SCM_CDR(x)		(SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_1 (SCM_REMOVE_PAIR_TAG (x))))
 
-#define SCM_SETCAR(x, v)	(SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_0 ((x), (v))))
-#define SCM_SETCDR(x, v)	(SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_1 ((x), (v))))
+#define SCM_SETCAR(x, v)	(SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_0 (SCM_REMOVE_PAIR_TAG (x), (v))))
+#define SCM_SETCDR(x, v)	(SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_1 (SCM_REMOVE_PAIR_TAG (x), (v))))
 
 #define SCM_CAAR(OBJ)		SCM_CAR (SCM_CAR (OBJ))
 #define SCM_CDAR(OBJ)		SCM_CDR (SCM_CAR (OBJ))
@@ -152,7 +152,7 @@ SCM_INLINE SCM scm_cdr (SCM x);
 SCM_INLINE_IMPLEMENTATION SCM
 scm_cons (SCM x, SCM y)
 {
-  return scm_cell (SCM_UNPACK (x), SCM_UNPACK (y));
+  return SCM_ADD_PAIR_TAG (scm_cell (SCM_UNPACK (x), SCM_UNPACK (y)));
 }
 
 SCM_INLINE_IMPLEMENTATION int
@@ -163,7 +163,7 @@ scm_is_pair (SCM x)
 
      Under the default -O2 the inlined SCM_I_CONSP test gets "optimized" so
      the fetch of the tag word from x is done before confirming it's a
-     non-immediate (SCM_NIMP).  Needless to say that bombs badly if x is a
+     tagged heap object (SCM_THOB_P).  Needless to say that bombs if x is
      immediate.  This was seen to afflict scm_srfi1_split_at and something
      deep in the bowels of ceval().  In both cases segvs resulted from
      deferencing a random immediate value.  srfi-1.test exposes the problem
@@ -219,7 +219,7 @@ scm_is_mutable_pair (SCM x)
      read-only, shareable section of the file.  Attempting to mutate a
      pair in the read-only section would cause a segmentation fault, so
      to avoid that, we really do need to enforce the restriction.  */
-  return scm_is_pair (x) && GC_is_heap_ptr (SCM2PTR (x));
+  return scm_is_pair (x) && GC_is_heap_ptr (SCM2PTR (SCM_REMOVE_PAIR_TAG (x)));
 }
 #endif /* BUILDING_LIBGUILE */
 
diff --git a/libguile/print.c b/libguile/print.c
index b10f0f8a8..f60444a82 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -591,21 +591,12 @@ print_vector_or_weak_vector (SCM v, size_t len, SCM (*ref) (SCM, size_t),
 static void
 iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 {
-  switch (SCM_ITAG3 (exp))
+  switch (SCM_ITAG (exp))
     {
-    case scm_tc3_tc7_1:
-    case scm_tc3_tc7_2:
-      /* These tc3 tags should never occur in an immediate value.  They are
-       * only used in cell types of non-immediates, i. e. the value returned
-       * by SCM_CELL_TYPE (exp) can use these tags.
-       */
-      scm_ipruk ("immediate", exp, port);
-      break;
-    case scm_tc3_int_1:
-    case scm_tc3_int_2:
+    case scm_itags_fixnum:
       scm_intprint (SCM_I_INUM (exp), 10, port);
       break;
-    case scm_tc3_imm24:
+    case scm_itags_imm24:
       if (SCM_CHARP (exp))
 	{
 	  if (SCM_WRITINGP (pstate))
@@ -624,7 +615,12 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 	  scm_ipruk ("immediate", exp, port);
 	}
       break;
-    case scm_tc3_cons:
+    case scm_itags_pair:
+      ENTER_NESTED_DATA (pstate, exp, circref);
+      scm_iprlist ("(", exp, ')', port, pstate);
+      EXIT_NESTED_DATA (pstate);
+      break;
+    case scm_itags_thob:
       switch (SCM_TYP7 (exp))
 	{
 	case scm_tcs_struct:
@@ -647,12 +643,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 	    EXIT_NESTED_DATA (pstate);
 	  }
 	  break;
-	case scm_tcs_cons_imcar:
-	case scm_tcs_cons_nimcar:
-	  ENTER_NESTED_DATA (pstate, exp, circref);
-	  scm_iprlist ("(", exp, ')', port, pstate);
-	  EXIT_NESTED_DATA (pstate);
-	  break;
 	circref:
 	  print_circref (port, pstate, exp);
 	  break;
@@ -787,7 +777,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 	  EXIT_NESTED_DATA (pstate);
 	  break;
 	default:
-          /* case scm_tcs_closures: */
+          /* fall through */
 	punk:
 	  scm_ipruk ("type", exp, port);
 	}
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 89cc6c2f7..942ce16e6 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -324,7 +324,7 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
         return src;
 
       if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)
-          && SCM_HEAP_OBJECT_P ((proc = SCM_STRUCT_PROCEDURE (proc))))
+          && SCM_THOB_P ((proc = SCM_STRUCT_PROCEDURE (proc))))
         continue;
     }
   while (0);
diff --git a/libguile/read.c b/libguile/read.c
index f146f0ef0..bc8b30100 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -764,7 +764,7 @@ scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
         str = scm_string_downcase_x (str);
       result = scm_string_to_symbol (str);
     }
-  else if (SCM_NIMP (result))
+  else if (SCM_HEAP_OBJECT_P (result))
     result = maybe_annotate_source (result, port, opts, line, column);
 
   scm_set_port_column_x (port,
@@ -1661,7 +1661,7 @@ scm_read_sharp_extension (int chr, SCM port, scm_t_read_opts *opts)
 
       got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port);
 
-      if (opts->record_positions_p && SCM_NIMP (got)
+      if (opts->record_positions_p && SCM_HEAP_OBJECT_P (got)
           && !scm_i_has_source_properties (got))
         scm_i_set_source_properties_x (got, line, column, SCM_FILENAME (port));
       
diff --git a/libguile/scm.h b/libguile/scm.h
index b4c605ec8..64984dfdf 100644
--- a/libguile/scm.h
+++ b/libguile/scm.h
@@ -420,43 +420,52 @@ typedef uintptr_t scm_t_bits;
 
 
 
-/* Checking if a SCM variable holds an immediate or a heap object.  This
-   check can either be performed by checking for tc3==000 or tc3==00x,
-   since for a SCM variable it is known that tc1==0.  */
-#define SCM_IMP(x) 		(6 & SCM_UNPACK (x))
-#define SCM_NIMP(x) 		(!SCM_IMP (x))
-#define SCM_HEAP_OBJECT_P(x)    (SCM_NIMP (x))
+/* Checking if a SCM variable holds a tagged heap object (thob).  */
 
-/* Checking if a SCM variable holds an immediate integer: See numbers.h
-   for the definition of the following macros: SCM_I_FIXNUM_BIT,
-   SCM_MOST_POSITIVE_FIXNUM, SCM_I_INUMP, SCM_I_MAKINUM, SCM_I_INUM.  */
+#define scm_thob_tag             0
+#define scm_thob_tag_mask        7
+#define scm_thob_tag_size        3
+
+#define SCM_THOB_P(x)  ((SCM_UNPACK (x) & scm_thob_tag_mask) == scm_thob_tag)
+
+#define scm_pair_tag             6
+#define scm_pair_tag_mask        15
+#define scm_pair_tag_size        4
 
 /* Checking if a SCM variable holds a pair (for historical reasons, in
-   Guile also known as a cons-cell): This is done by first checking that
-   the SCM variable holds a heap object, and second, by checking that
-   tc1==0 holds for the SCM_CELL_TYPE of the SCM variable.  */
-#define SCM_I_CONSP(x)  (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0))
+   Guile also known as a cons-cell).  */
+#define SCM_I_CONSP(x) \
+  ((SCM_UNPACK (x) & scm_pair_tag_mask) == scm_pair_tag)
+
+#define SCM_HEAP_OBJECT_P(x)    (SCM_THOB_P (x) || SCM_I_CONSP (x))
 
 
 
-/* Definitions for tc2: */
+/* Definitions for immediate tags: */
 
-#define scm_tc2_int              2
+#define scm_itag_mask            15
+#define scm_itag_mask_size       4
 
+#define SCM_ITAG(x) 		 (SCM_UNPACK (x) & scm_itag_mask)
 
-/* Definitions for tc3: */
+#define scm_itags_thob		 0: case 8
+#define scm_itags_fixnum	 15
+#define scm_itags_pair		 6
+#define scm_itags_imm24		 14
+
+#define scm_fixnum_tag           15
+#define scm_fixnum_tag_mask      15
+#define scm_fixnum_tag_size      4
 
-#define SCM_ITAG3(x) 		 (7 & SCM_UNPACK (x))
-#define SCM_TYP3(x) 		 (7 & SCM_CELL_TYPE (x))
 
-#define scm_tc3_cons	 	 0
+/* Definitions for tc3: */
+
 #define scm_tc3_struct    	 1
-#define scm_tc3_int_1		 (scm_tc2_int + 0)
-#define scm_tc3_unused		 3
-#define scm_tc3_imm24		 4
-#define scm_tc3_tc7_1		 5
-#define scm_tc3_int_2		 (scm_tc2_int + 4)
-#define scm_tc3_tc7_2		 7
+
+
+/* Definitions for tc4: */
+
+#define scm_tc4_imm24            14
 
 
 /* Definitions for tc7: */
@@ -464,15 +473,14 @@ typedef uintptr_t scm_t_bits;
 #define SCM_ITAG7(x) 		(0x7f & SCM_UNPACK (x))
 #define SCM_TYP7(x) 		(0x7f & SCM_CELL_TYPE (x))
 #define SCM_HAS_HEAP_TYPE(x, type, tag)                         \
-  (SCM_NIMP (x) && type (x) == (tag))
+  (SCM_THOB_P (x) && type (x) == (tag))
 #define SCM_HAS_TYP7(x, tag)    (SCM_HAS_HEAP_TYPE (x, SCM_TYP7, tag))
 
 /* These type codes form part of the ABI and cannot be changed in a
-   stable series.  The low bits of each must have the tc3 of a heap
-   object type code (see above).  If you do change them in a development
-   series, change them also in (system vm assembler) and (system base
-   types).  Bonus points if you change the build to define these tag
-   values in only one place!  */
+   stable series.  If you do change them in a development series,
+   change them also in (system vm assembler) and (system base types).
+   Bonus points if you change the build to define these tag values
+   in only one place!  */
 
 #define scm_tc7_symbol		0x05
 #define scm_tc7_variable        0x07
@@ -520,10 +528,10 @@ typedef uintptr_t scm_t_bits;
 
 enum scm_tc8_tags
 {
-  scm_tc8_flag = scm_tc3_imm24 + 0x00,  /* special objects ('flags') */
-  scm_tc8_char = scm_tc3_imm24 + 0x08,  /* characters */
-  scm_tc8_unused_0 = scm_tc3_imm24 + 0x10,
-  scm_tc8_unused_1 = scm_tc3_imm24 + 0x18
+  scm_tc8_flag = scm_tc4_imm24 + 0x00,  /* special objects ('flags') */
+  scm_tc8_char = scm_tc4_imm24 + 0x10,  /* characters */
+  scm_tc8_unused_0 = scm_tc4_imm24 + 0x20,
+  scm_tc8_unused_1 = scm_tc4_imm24 + 0x30
 };
 
 #define SCM_ITAG8(X)		(SCM_UNPACK (X) & 0xff)
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index b644a32a5..0667d9741 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -103,7 +103,9 @@ scm_t_bits scm_tc16_srcprops;
 static int
 supports_source_props (SCM obj)
 {
-  return SCM_NIMP (obj) && !scm_is_symbol (obj) && !scm_is_keyword (obj);
+  return (SCM_THOB_P (obj)
+          ? (!scm_is_symbol (obj) && !scm_is_keyword (obj))
+          : scm_is_pair (obj));
 }
 
 
@@ -188,7 +190,7 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
 	    "Return the source property association list of @var{obj}.")
 #define FUNC_NAME s_scm_source_properties
 {
-  if (SCM_IMP (obj))
+  if (!SCM_HEAP_OBJECT_P (obj))
     return SCM_EOL;
   else
     {
@@ -204,7 +206,7 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
 #undef FUNC_NAME
 
 #define SCM_VALIDATE_NIM(pos, scm) \
-  SCM_MAKE_VALIDATE_MSG (pos, scm, NIMP, "non-immediate")
+  SCM_MAKE_VALIDATE_MSG (pos, scm, HEAP_OBJECT_P, "non-immediate")
 
 /* Perhaps this procedure should look through an alist
    and try to make a srcprops-object...? */
@@ -226,7 +228,7 @@ int
 scm_i_has_source_properties (SCM obj)
 #define FUNC_NAME "%set-source-properties"
 {
-  if (SCM_IMP (obj))
+  if (!SCM_HEAP_OBJECT_P (obj))
     return 0;
   else
     return scm_is_true (scm_weak_table_refq (scm_source_whash, obj, SCM_BOOL_F));
@@ -257,7 +259,7 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
 {
   SCM p;
 
-  if (SCM_IMP (obj))
+  if (!SCM_HEAP_OBJECT_P (obj))
     return SCM_BOOL_F;
 
   p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL);
diff --git a/libguile/struct.c b/libguile/struct.c
index 3dbcc71d4..716d30df9 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -322,7 +322,7 @@ struct_finalizer_trampoline (void *ptr, void *unused_data)
 }
 
 /* A struct is a sequence of words preceded by a pointer to the struct's
-   vtable.  The vtable reference is tagged with the struct tc3.  */
+   vtable.  The vtable reference is tagged with the struct tag.  */
 static SCM
 scm_i_alloc_struct (scm_t_bits vtable_bits, int n_words)
 {
diff --git a/libguile/struct.h b/libguile/struct.h
index c9533518b..46dfd2baf 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -109,7 +109,7 @@
 
 typedef void (*scm_t_struct_finalize) (SCM obj);
 
-#define SCM_STRUCTP(X)  		(!SCM_IMP(X) && (SCM_TYP3(X) == scm_tc3_struct))
+#define SCM_STRUCTP(X)  		(SCM_THOB_P(X) && (SCM_CELL_TYPE (X) & 7) == scm_tc3_struct)
 #define SCM_STRUCT_SLOTS(X) 		(SCM_CELL_OBJECT_LOC(X, 1))
 #define SCM_STRUCT_SLOT_REF(X,I) 	(SCM_STRUCT_SLOTS (X)[(I)])
 #define SCM_STRUCT_SLOT_SET(X,I,V) 	SCM_STRUCT_SLOTS (X)[(I)]=(V)
diff --git a/libguile/vectors.h b/libguile/vectors.h
index 41e2c8909..b0819b1ad 100644
--- a/libguile/vectors.h
+++ b/libguile/vectors.h
@@ -79,7 +79,7 @@ SCM_API SCM *scm_vector_writable_elements (SCM vec,
    immutability.  */
 #define SCM_F_VECTOR_IMMUTABLE 0x80UL
 #define SCM_I_IS_MUTABLE_VECTOR(x)                              \
-  (SCM_NIMP (x) &&                                              \
+  (SCM_THOB_P (x) &&                                            \
    ((SCM_CELL_TYPE (x) & (0x7f | SCM_F_VECTOR_IMMUTABLE))       \
     == scm_tc7_vector))
 #define SCM_I_IS_VECTOR(x)     (SCM_HAS_TYP7 (x, scm_tc7_vector))
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index e089d4faa..e581a2003 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3234,10 +3234,96 @@ VM_NAME (scm_thread *thread)
   VM_DEFINE_OP (153, f64_set, "f64-set!", OP1 (X8_S8_S8_S8))
     PTR_SET (double, F64);
 
-  VM_DEFINE_OP (154, unused_154, NULL, NOP)
-  VM_DEFINE_OP (155, unused_155, NULL, NOP)
-  VM_DEFINE_OP (156, unused_156, NULL, NOP)
-  VM_DEFINE_OP (157, unused_157, NULL, NOP)
+  /* make-tagged-non-immediate dst:12 tag:12 offset:32
+   *
+   * Load a pointer to statically allocated memory into DST, with TAG
+   * applied.  The object's memory will be found OFFSET 32-bit words
+   * away from the current instruction pointer.  OFFSET is a signed
+   * value.  The intention here is that the compiler would produce an
+   * object file containing the words of a non-immediate object, and
+   * this instruction creates a pointer to that memory, effectively
+   * resurrecting that object.
+   *
+   * Whether the object is mutable or immutable depends on where it was
+   * allocated by the compiler, and loaded by the loader.
+   */
+  VM_DEFINE_OP (154, make_tagged_non_immediate, "make-tagged-non-immediate", DOP2 (X8_S12_C12, N32))
+    {
+      uint32_t dst, tag;
+      int32_t offset;
+      uint32_t* loc;
+      scm_t_bits unpacked;
+
+      UNPACK_12_12 (op, dst, tag);
+      offset = ip[1];
+      loc = ip + offset;
+      unpacked = (scm_t_bits) loc;
+
+      VM_ASSERT (!(unpacked & scm_pair_tag_mask), abort());   /* temporary debugging hack XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
+
+      SP_SET (dst, SCM_PACK (unpacked + tag));
+
+      NEXT (2);
+    }
+
+  /* tagged-scm-ref/immediate dst:8 obj:8 byte-offset:8
+   *
+   * Load the SCM object at BYTE-OFFSET from local OBJ, and store it to
+   * DST.  BYTE-OFFSET is a int8_t immediate.  The resulting address
+   * must be aligned on a word boundary.  This is intended to be used
+   * when OBJ is a tagged pointer, with BYTE-OFFSET equal to the true
+   * byte offset minus OBJ's pointer tag.
+   */
+  VM_DEFINE_OP (155, tagged_scm_ref_immediate, "tagged-scm-ref/immediate", DOP1 (X8_S8_S8_C8))
+    {
+      uint8_t dst, obj;
+      int8_t byte_offset;
+
+      UNPACK_8_8_8 (op, dst, obj, byte_offset);
+
+      SP_SET (dst, SCM_CELL_OBJECT_0 (SCM_PACK (byte_offset + SCM_UNPACK (SP_REF (obj)))));
+
+      NEXT (1);
+    }
+
+  /* tagged-scm-set!/immediate obj:8 byte-offset:8 val:8
+   *
+   * Store the SCM local VAL into object OBJ at BYTE-OFFSET.
+   * BYTE-OFFSET is an int8_t immediate.  The resulting address must be
+   * aligned on a word boundary.  This is intended to be used when OBJ
+   * is a tagged pointer, with BYTE-OFFSET equal to the true byte offset
+   * minus OBJ's pointer tag.
+   */
+  VM_DEFINE_OP (156, tagged_scm_set_immediate, "tagged-scm-set!/immediate", OP1 (X8_S8_C8_S8))
+    {
+      uint8_t obj, val;
+      int8_t byte_offset;
+
+      UNPACK_8_8_8 (op, obj, byte_offset, val);
+
+      SCM_SET_CELL_OBJECT_0 (SCM_PACK (byte_offset + SCM_UNPACK (SP_REF (obj))),
+                             SP_REF (val));
+
+      NEXT (1);
+    }
+
+  /* tagged-allocate-words/immediate dst:8 count:8 tag:8
+   *
+   * Allocate a fresh GC-traced object consisting of COUNT words and
+   * store it into DST with TAG applied.  COUNT and TAG are immediates.
+   */
+  VM_DEFINE_OP (157, tagged_allocate_words_immediate, "tagged-allocate-words/immediate", DOP1 (X8_S8_C8_C8))
+    {
+      uint8_t dst, size, tag;
+
+      UNPACK_8_8_8 (op, dst, size, tag);
+
+      SYNC_IP ();
+      SP_SET (dst, SCM_PACK (tag + SCM_UNPACK (CALL_INTRINSIC (allocate_words, (thread, size)))));
+
+      NEXT (1);
+    }
+
   VM_DEFINE_OP (158, unused_158, NULL, NOP)
   VM_DEFINE_OP (159, unused_159, NULL, NOP)
   VM_DEFINE_OP (160, unused_160, NULL, NOP)
diff --git a/libguile/vm.c b/libguile/vm.c
index 82cdae91a..be59ad290 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -748,8 +748,8 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
               break;
             case SLOT_DESC_UNUSED:
             case SLOT_DESC_LIVE_GC:
-              if (SCM_NIMP (sp->as_scm) &&
-                  sp->as_ptr >= lower && sp->as_ptr <= upper)
+              if (SCM_HEAP_OBJECT_P (sp->as_scm)
+                  && sp->as_ptr >= lower && sp->as_ptr <= upper)
                 mark_stack_ptr = GC_mark_and_push (sp->as_ptr,
                                                    mark_stack_ptr,
                                                    mark_stack_limit,
diff --git a/libguile/weak-set.c b/libguile/weak-set.c
index 8cf1b8286..06fec2d6b 100644
--- a/libguile/weak-set.c
+++ b/libguile/weak-set.c
@@ -419,9 +419,12 @@ resize_set (scm_t_weak_set *set)
       new_entries[new_k].hash = copy.hash;
       new_entries[new_k].key = copy.key;
 
-      if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
+      if (SCM_THOB_P (SCM_PACK (copy.key)))
         SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &new_entries[new_k].key,
                                           (void *) new_entries[new_k].key);
+      else if (scm_is_pair (SCM_PACK (copy.key)))
+        SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &new_entries[new_k].key,
+                                          (void *) (new_entries[new_k].key - scm_pair_tag));
     }
 }
 
@@ -580,9 +583,12 @@ weak_set_add_x (scm_t_weak_set *set, unsigned long hash,
   entries[k].hash = hash;
   entries[k].key = SCM_UNPACK (obj);
 
-  if (SCM_HEAP_OBJECT_P (obj))
+  if (SCM_THOB_P (obj))
     SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entries[k].key,
                                       (void *) SCM2PTR (obj));
+  else if (scm_is_pair (obj))
+    SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entries[k].key,
+                                      (void *) SCM2PTR (SCM_REMOVE_PAIR_TAG (obj)));
 
   return obj;
 }
diff --git a/libguile/weak-table.c b/libguile/weak-table.c
index 1e4d8d302..f51a4717c 100644
--- a/libguile/weak-table.c
+++ b/libguile/weak-table.c
@@ -118,13 +118,17 @@ register_disappearing_links (scm_t_weak_entry *entry,
       && (kind == SCM_WEAK_TABLE_KIND_KEY
           || kind == SCM_WEAK_TABLE_KIND_BOTH))
     SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->key,
-                                      SCM2PTR (k));
+                                      (scm_is_pair (k)
+                                       ? SCM2PTR (SCM_REMOVE_PAIR_TAG (k))
+                                       : SCM2PTR (k)));
 
   if (SCM_UNPACK (v) && SCM_HEAP_OBJECT_P (v)
       && (kind == SCM_WEAK_TABLE_KIND_VALUE
           || kind == SCM_WEAK_TABLE_KIND_BOTH))
     SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->value,
-                                      SCM2PTR (v));
+                                      (scm_is_pair (v)
+                                       ? SCM2PTR (SCM_REMOVE_PAIR_TAG (v))
+                                       : SCM2PTR (v)));
 }
 
 static void
diff --git a/libguile/weak-vector.c b/libguile/weak-vector.c
index b087891f6..02fbc77c5 100644
--- a/libguile/weak-vector.c
+++ b/libguile/weak-vector.c
@@ -245,9 +245,12 @@ scm_c_weak_vector_set_x (SCM wv, size_t k, SCM x)
   
   elts[k] = x;
 
-  if (SCM_HEAP_OBJECT_P (x))
+  if (SCM_THOB_P (x))
     SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &elts[k],
                                       SCM2PTR (x));
+  else if (scm_is_pair (x))
+    SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &elts[k],
+                                      SCM2PTR (SCM_REMOVE_PAIR_TAG (x)));
 }
 #undef FUNC_NAME
 
diff --git a/module/language/bytecode.scm b/module/language/bytecode.scm
index ec0392ba4..4e67c411d 100644
--- a/module/language/bytecode.scm
+++ b/module/language/bytecode.scm
@@ -51,7 +51,9 @@
       ((X8_F12_F12) 2)
       ((X8_S8_S8_S8) 3)
       ((X8_S8_S8_C8) 3)
-      ((X8_S8_C8_S8) 3)))
+      ((X8_S8_C8_S8) 3)
+      ((X8_S8_C8_C8) 3)
+      (else (error "unknown first word type" word))))
   (define (tail-word-arity word)
     (case word
       ((C32) 1)
@@ -74,7 +76,8 @@
       ((X8_S24) 1)
       ((X8_F24) 1)
       ((X8_C24) 1)
-      ((X8_L24) 1)))
+      ((X8_L24) 1)
+      (else (error "unknown tail word type" word))))
   (match args
     ((arg0 . args)
      (fold (lambda (arg arity)
diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm
index 77c8faef3..a0e09df52 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -555,7 +555,7 @@ term."
          (with-cps cps
            (build-term
              ($continue k src
-               ($primcall 'allocate-words/immediate `(pair . 2) ())))))
+               ($primcall 'tagged-allocate-words/immediate `(pair . 2) ())))))
         ;; Well-known callee with more than two free variables; the closure
         ;; is a vector.
         (#(#t nfree)
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index ad43eebf5..70327ce93 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -38,6 +38,7 @@
   #:use-module (language cps intmap)
   #:use-module (language cps intset)
   #:use-module (system vm assembler)
+  #:use-module (system base target)
   #:use-module (system base types internal)
   #:export (compile-bytecode))
 
@@ -161,16 +162,29 @@
          (emit-allocate-words asm (from-sp dst) (from-sp (slot nfields))))
         (($ $primcall 'allocate-words/immediate (annotation . nfields))
          (emit-allocate-words/immediate asm (from-sp dst) nfields))
+        (($ $primcall 'tagged-allocate-words/immediate (annotation . nfields))
+         (let ((tag (match annotation
+                      ('pair (target-pair-tag)))))
+           (emit-tagged-allocate-words/immediate asm (from-sp dst) nfields
+                                                 tag)))
         (($ $primcall 'scm-ref annotation (obj idx))
          (emit-scm-ref asm (from-sp dst) (from-sp (slot obj))
                        (from-sp (slot idx))))
         (($ $primcall 'scm-ref/tag annotation (obj))
          (let ((tag (match annotation
-                      ('pair %tc1-pair)
+                      ('pair 0)  ; TAGS-SENSITIVE
                       ('struct %tc3-struct))))
            (emit-scm-ref/tag asm (from-sp dst) (from-sp (slot obj)) tag)))
         (($ $primcall 'scm-ref/immediate (annotation . idx) (obj))
          (emit-scm-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx))
+        (($ $primcall 'tagged-scm-ref/immediate (annotation . idx) (obj))
+         (let* ((tag (match annotation
+                       ('pair (target-pair-tag))))
+                (byte-offset-u (modulo (- (* idx (target-word-size))
+                                          tag)
+                                       256)))
+           (emit-tagged-scm-ref/immediate asm (from-sp dst) (from-sp (slot obj))
+                                          byte-offset-u)))
         (($ $primcall 'word-ref annotation (obj idx))
          (emit-word-ref asm (from-sp dst) (from-sp (slot obj))
                        (from-sp (slot idx))))
@@ -298,13 +312,21 @@
                         (from-sp (slot val))))
         (($ $primcall 'scm-set!/tag annotation (obj val))
          (let ((tag (match annotation
-                      ('pair %tc1-pair)
+                      ('pair 0)  ; TAGS-SENSITIVE
                       ('struct %tc3-struct))))
            (emit-scm-set!/tag asm (from-sp (slot obj)) tag
                               (from-sp (slot val)))))
         (($ $primcall 'scm-set!/immediate (annotation . idx) (obj val))
          (emit-scm-set!/immediate asm (from-sp (slot obj)) idx
                                   (from-sp (slot val))))
+        (($ $primcall 'tagged-scm-set!/immediate (annotation . idx) (obj val))
+         (let* ((tag (match annotation
+                       ('pair (target-pair-tag))))
+                (byte-offset-u (modulo (- (* idx (target-word-size))
+                                          tag)
+                                       256)))
+           (emit-tagged-scm-set!/immediate asm (from-sp (slot obj)) byte-offset-u
+                                           (from-sp (slot val)))))
         (($ $primcall 'word-set! annotation (obj idx val))
          (emit-word-set! asm (from-sp (slot obj)) (from-sp (slot idx))
                         (from-sp (slot val))))
@@ -451,7 +473,8 @@
       (match (vector op param args)
         ;; Immediate type tag predicates.
         (#('fixnum? #f (a)) (unary emit-fixnum? a))
-        (#('heap-object? #f (a)) (unary emit-heap-object? a))
+        (#('thob? #f (a)) (unary emit-thob? a))
+        (#('pair? #f (a)) (unary emit-pair? a))
         (#('char? #f (a)) (unary emit-char? a))
         (#('eq-false? #f (a)) (unary emit-eq-false? a))
         (#('eq-nil? #f (a)) (unary emit-eq-nil? a))
@@ -464,7 +487,6 @@
         (#('false? #f (a)) (unary emit-false? a))
         (#('nil? #f (a)) (unary emit-nil? a))
         ;; Heap type tag predicates.
-        (#('pair? #f (a)) (unary emit-pair? a))
         (#('struct? #f (a)) (unary emit-struct? a))
         (#('symbol? #f (a)) (unary emit-symbol? a))
         (#('variable? #f (a)) (unary emit-variable? a))
diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm
index 43a58a1e6..73e69f7f3 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -32,6 +32,7 @@
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-11)
   #:use-module ((srfi srfi-1) #:select (fold))
+  #:use-module (system base target)
   #:use-module (language cps)
   #:use-module (language cps renumber)
   #:use-module (language cps utils)
@@ -387,15 +388,15 @@ function set."
            (letk ktail
                  ($kargs () ()
                    ($continue kdone src
-                     ($primcall 'scm-set!/immediate '(pair . 1) (pair tail)))))
+                     ($primcall 'tagged-scm-set!/immediate '(pair . 1) (pair tail)))))
            (letk khead
                  ($kargs ('pair) (pair)
                    ($continue ktail src
-                     ($primcall 'scm-set!/immediate '(pair . 0) (pair v)))))
+                     ($primcall 'tagged-scm-set!/immediate '(pair . 0) (pair v)))))
            (letk ktail
                  ($kargs ('tail) (tail)
                    ($continue khead src
-                     ($primcall 'allocate-words/immediate '(pair . 2) ()))))
+                     ($primcall 'tagged-allocate-words/immediate '(pair . 2) ()))))
            ($ (build-list ktail src vals))))))
     (cond
      ((and (not rest) (eqv? (length vals) nreq))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 70b3ad3e0..6cbc17f75 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -255,6 +255,7 @@ false.  It could be that both true and false proofs are available."
            ((scm-set! p s i x)               (x <- scm-ref p s i))
            ((scm-set!/tag p s x)             (x <- scm-ref/tag p s))
            ((scm-set!/immediate p s x)       (x <- scm-ref/immediate p s))
+           ((tagged-scm-set!/immediate p s x) (x <- tagged-scm-ref/immediate p s))
            ((word-set! p s i x)              (x <- word-ref p s i))
            ((word-set!/immediate p s x)      (x <- word-ref/immediate p s))
            ((pointer-set!/immediate p s x)   (x <- pointer-ref/immediate p s))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 6fc885e7f..3d0d1e972 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -191,6 +191,7 @@ sites."
                 (match exp
                   (($ $primcall
                       (or 'scm-set! 'scm-set!/tag 'scm-set!/immediate
+                          'tagged-scm-set!/immediate
                           'word-set! 'word-set!/immediate) _
                       (obj . _))
                    (or (var-live? obj live-vars)
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 250aec78a..edba3669d 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -305,7 +305,7 @@ the LABELS that are clobbered by the effects of LABEL."
   ((null? arg))
   ((false? arg))
   ((nil? arg))
-  ((heap-object? arg))
+  ((thob? arg))
   ((pair? arg))
   ((symbol? arg))
   ((variable? arg))
@@ -363,6 +363,11 @@ the LABELS that are clobbered by the effects of LABEL."
                                      ((ann . size)
                                       (&allocate
                                        (annotation->memory-kind ann)))))
+  ((tagged-allocate-words/immediate)
+                                   (match param
+                                     ((ann . size)
+                                      (&allocate
+                                       (annotation->memory-kind ann)))))
   ((scm-ref obj idx)               (&read-object
                                     (annotation->memory-kind param)))
   ((scm-ref/tag obj)               (&read-field
@@ -371,6 +376,10 @@ the LABELS that are clobbered by the effects of LABEL."
                                      ((ann . idx)
                                       (&read-field
                                        (annotation->memory-kind ann) idx))))
+  ((tagged-scm-ref/immediate obj)  (match param
+                                     ((ann . idx)
+                                      (&read-field
+                                       (annotation->memory-kind ann) idx))))
   ((scm-set! obj idx val)          (&write-object
                                     (annotation->memory-kind param)))
   ((scm-set/tag! obj val)          (&write-field
@@ -379,6 +388,11 @@ the LABELS that are clobbered by the effects of LABEL."
                                      ((ann . idx)
                                       (&write-field
                                        (annotation->memory-kind ann) idx))))
+  ((tagged-scm-set!/immediate obj val)
+                                   (match param
+                                     ((ann . idx)
+                                      (&write-field
+                                       (annotation->memory-kind ann) idx))))
   ((word-ref obj idx)              (&read-object
                                     (annotation->memory-kind param)))
   ((word-ref/immediate obj)        (match param
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index 6ec90299e..3f5eec445 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -216,7 +216,7 @@
         (with-cps cps
           (letk kres
                 ($kargs ('var) (var)
-                  ($branch kbad k src 'heap-object? #f (var))))
+                  ($branch kbad k src 'thob? #f (var))))
           (build-term
             ($continue kres src
               ($primcall 'lookup #f (mod-var name-var)))))))
@@ -262,7 +262,7 @@
          (letk kok ($kargs () () ($continue k src ($values (cached)))))
          (letk ktest
                ($kargs ('cached) (cached)
-                 ($branch kinit kok src 'heap-object? #f (cached))))
+                 ($branch kinit kok src 'thob? #f (cached))))
          (build-term
            ($continue ktest src
              ($primcall 'cache-ref cache-key ()))))))))
@@ -296,7 +296,7 @@
          (letk kok ($kargs () () ($continue k src ($values (cached)))))
          (letk ktest
                ($kargs ('cached) (cached)
-                 ($branch kinit kok src 'heap-object? #f (cached))))
+                 ($branch kinit kok src 'thob? #f (cached))))
          (build-term
            ($continue ktest src
              ($primcall 'cache-ref cache-key ()))))))))
@@ -531,6 +531,12 @@
                              (setk label ($kargs names vars
                                            ($continue kop src
                                              ($primcall 'load-u64 idx ()))))))))))
+                 ;; TODO: Consider adding cases for
+                 ;; 'tagged-allocate-words/immediate',
+                 ;; 'tagged-scm-ref/immediate' and
+                 ;; 'tagged-scm-set!/immediate', although at present
+                 ;; those primitives are only used for pairs, where the
+                 ;; byte-offset will always fit within the S8 operand.
                  (_ cps))))))))
         (param (error "unexpected param to reified primcall" name))
         (else
diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm
index 405806626..9cde7e5fa 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -94,11 +94,11 @@
        ((eqv? type type*) (values #t #t))
        (else (values #f #f))))))
 
-(define-unary-branch-folder (heap-object? type min max)
-  (define &immediate-types (logior &fixnum &char &special-immediate))
+(define-unary-branch-folder (thob? type min max)
+  (define &non-thob-types (logior &pair &fixnum &char &special-immediate))
   (cond
-   ((zero? (logand type &immediate-types)) (values #t #t))
-   ((type<=? type &immediate-types) (values #t #f))
+   ((zero? (logand type &non-thob-types)) (values #t #t))
+   ((type<=? type &non-thob-types) (values #t #f))
    (else (values #f #f))))
 
 (define-unary-branch-folder (heap-number? type min max)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 2e73705d3..425e80af8 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -615,12 +615,12 @@ minimum, and maximum."
     (when (eqv? (&type val) &special-immediate)
       (restrict! val &special-immediate (1+ &false) +inf.0)))))
 
-(define-predicate-inferrer (heap-object? val true?)
-  (define &immediate-types
-    (logior &fixnum &char &special-immediate))
-  (define &heap-object-types
-    (logand &all-types (lognot &immediate-types)))
-  (restrict! val (if true? &heap-object-types &immediate-types) -inf.0 +inf.0))
+(define-predicate-inferrer (thob? val true?)
+  (define &non-thob-types
+    (logior &pair &fixnum &char &special-immediate))
+  (define &thob-types
+    (logand &all-types (lognot &non-thob-types)))
+  (restrict! val (if true? &thob-types &non-thob-types) -inf.0 +inf.0))
 
 (define-predicate-inferrer (heap-number? val true?)
   (define &heap-number-types
@@ -742,6 +742,11 @@ minimum, and maximum."
     ((annotation . size)
      (define! result (annotation->type annotation) size size))))
 
+(define-type-inferrer/param (tagged-allocate-words/immediate param result)
+  (match param
+    ((annotation . size)
+     (define! result (annotation->type annotation) size size))))
+
 (define-type-inferrer/param (scm-ref param obj idx result)
   (restrict! obj (annotation->type param)
              (1+ (&min/0 idx)) (target-max-size-t/scm))
@@ -753,6 +758,12 @@ minimum, and maximum."
      (restrict! obj (annotation->type annotation) (1+ idx) +inf.0)
      (define! result &all-types -inf.0 +inf.0))))
 
+(define-type-inferrer/param (tagged-scm-ref/immediate param obj result)
+  (match param
+    ((annotation . idx)
+     (restrict! obj (annotation->type annotation) (1+ idx) +inf.0)
+     (define! result &all-types -inf.0 +inf.0))))
+
 (define-type-inferrer/param (scm-ref/tag param obj result)
   (restrict! obj (annotation->type param) -inf.0 +inf.0)
   (define! result &all-types -inf.0 +inf.0))
@@ -767,6 +778,11 @@ minimum, and maximum."
     ((annotation . idx)
      (restrict! obj (annotation->type annotation) (1+ idx) +inf.0))))
 
+(define-type-inferrer/param (tagged-scm-set!/immediate param obj val)
+  (match param
+    ((annotation . idx)
+     (restrict! obj (annotation->type annotation) (1+ idx) +inf.0))))
+
 (define-type-inferrer/param (word-ref param obj idx result)
   (restrict! obj (annotation->type param)
              (1+ (&min/0 idx)) (target-max-size-t/scm))
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 6c8884add..ff52a5f49 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -104,7 +104,7 @@
             ($continue kcast src
               ($primcall 'assume-u64 `(0 . ,(target-max-vector-length)) (ulen)))))
     (letk krsh
-          ($kargs ('w0) (w0)
+          ($kargs ('w0) (w0)                     ;TAGS-SENSITIVE
             ($continue kassume src ($primcall 'ursh/immediate 8 (w0)))))
     (letk kv
           ($kargs () ()
@@ -114,7 +114,7 @@
           ($kargs () ()
             ($branch knot-vector kv src pred #f (v))))
     (build-term
-      ($branch knot-vector kheap-object src 'heap-object? #f (v)))))
+      ($branch knot-vector kheap-object src 'thob? #f (v)))))
 
 (define (untag-fixnum-index-in-range cps src op idx slen have-index-in-range)
   ;; Precondition: SLEN is a non-negative S64 that is representable as a
@@ -342,7 +342,7 @@
          (letk ktag0
                ($kargs ('v) (v)
                  ($continue ktag1 src
-                   ($primcall 'ulsh/immediate 8 (usize)))))
+                   ($primcall 'ulsh/immediate 8 (usize)))))  ;TAGS-SENSITIVE
          (letk kalloc
                ($kargs ('nwords) (nwords)
                  ($continue ktag0 src
@@ -420,8 +420,7 @@
     (letk knot-pair ($kargs () () ($throw src 'throw/value+data not-pair (x))))
     (let$ body (is-pair))
     (letk k ($kargs () () ,body))
-    (letk kheap-object ($kargs () () ($branch knot-pair k src pred #f (x))))
-    (build-term ($branch knot-pair kheap-object src 'heap-object? #f (x)))))
+    (build-term ($branch knot-pair k src 'pair? #f (x)))))
 
 (define-primcall-converter cons
   (lambda (cps k src op param head tail)
@@ -433,14 +432,14 @@
       (letk ktail
             ($kargs () ()
               ($continue kdone src
-                ($primcall 'scm-set!/immediate '(pair . 1) (pair tail)))))
+                ($primcall 'tagged-scm-set!/immediate '(pair . 1) (pair tail)))))
       (letk khead
             ($kargs ('pair) (pair)
               ($continue ktail src
-                ($primcall 'scm-set!/immediate '(pair . 0) (pair head)))))
+                ($primcall 'tagged-scm-set!/immediate '(pair . 0) (pair head)))))
       (build-term
         ($continue khead src
-          ($primcall 'allocate-words/immediate '(pair . 2) ()))))))
+          ($primcall 'tagged-allocate-words/immediate '(pair . 2) ()))))))
 
 (define-primcall-converter car
   (lambda (cps k src op param pair)
@@ -450,7 +449,7 @@
        (with-cps cps
          (build-term
            ($continue k src
-             ($primcall 'scm-ref/immediate '(pair . 0) (pair)))))))))
+             ($primcall 'tagged-scm-ref/immediate '(pair . 0) (pair)))))))))
 
 (define-primcall-converter cdr
   (lambda (cps k src op param pair)
@@ -460,7 +459,7 @@
        (with-cps cps
          (build-term
            ($continue k src
-             ($primcall 'scm-ref/immediate '(pair . 1) (pair)))))))))
+             ($primcall 'tagged-scm-ref/immediate '(pair . 1) (pair)))))))))
 
 (define-primcall-converter set-car!
   (lambda (cps k src op param pair val)
@@ -471,7 +470,7 @@
        (with-cps cps
          (build-term
            ($continue k src
-             ($primcall 'scm-set!/immediate '(pair . 0) (pair val)))))))))
+             ($primcall 'tagged-scm-set!/immediate '(pair . 0) (pair val)))))))))
 
 (define-primcall-converter set-cdr!
   (lambda (cps k src op param pair val)
@@ -482,7 +481,7 @@
        (with-cps cps
          (build-term
            ($continue k src
-             ($primcall 'scm-set!/immediate '(pair . 1) (pair val)))))))))
+             ($primcall 'tagged-scm-set!/immediate '(pair . 1) (pair val)))))))))
 
 (define-primcall-converter box
   (lambda (cps k src op param val)
@@ -517,7 +516,7 @@
     (let$ body (is-box))
     (letk k ($kargs () () ,body))
     (letk kheap-object ($kargs () () ($branch knot-box k src 'variable? #f (x))))
-    (build-term ($branch knot-box kheap-object src 'heap-object? #f (x)))))
+    (build-term ($branch knot-box kheap-object src 'thob? #f (x)))))
 
 (define-primcall-converter box-ref
   (lambda (cps k src op param box)
@@ -562,7 +561,7 @@
                     ($continue k src ($primcall 'scm-ref/tag 'struct (x)))))
     (letk kheap-object
           ($kargs () () ($branch knot-struct kvtable src 'struct? #f (x))))
-    (build-term ($branch knot-struct kheap-object src 'heap-object? #f (x)))))
+    (build-term ($branch knot-struct kheap-object src 'thob? #f (x)))))
 
 (define-primcall-converter struct-vtable
   (lambda (cps k src op param struct)
@@ -859,7 +858,7 @@
   (with-cps cps
     (letk kf ($kargs () () ($throw src 'throw/value+data bad-type (x))))
     (letk kheap-object ($kargs () () ($branch kf k src pred #f (x))))
-    (build-term ($branch kf kheap-object src 'heap-object? #f (x)))))
+    (build-term ($branch kf kheap-object src 'thob? #f (x)))))
 
 (define (prepare-bytevector-access cps src op pred bv idx width
                                    have-ptr-and-uidx)
@@ -1104,7 +1103,7 @@
           ($kargs () ()
             ($branch knot-string ks src 'string? #f (x))))
     (build-term
-      ($branch knot-string kheap-object src 'heap-object? #f (x)))))
+      ($branch knot-string kheap-object src 'thob? #f (x)))))
 
 (define (ensure-char cps src op x have-char)
   (define msg "Wrong type argument (expecting char): ~S")
@@ -1133,7 +1132,7 @@
   (lambda (cps k src op param s idx)
     (define out-of-range
       #(out-of-range string-ref "Argument 2 out of range: ~S"))
-    (define stringbuf-f-wide #x400)
+    (define stringbuf-f-wide #x400)  ;TAGS-SENSITIVE
     (ensure-string
      cps src op s
      (lambda (cps ulen)
@@ -1203,7 +1202,7 @@
   (lambda (cps k src op param s idx ch)
     (define out-of-range
       #(out-of-range string-ref "Argument 2 out of range: ~S"))
-    (define stringbuf-f-wide #x400)
+    (define stringbuf-f-wide #x400)  ;TAGS-SENSITIVE
     (ensure-string
      cps src op s
      (lambda (cps ulen)
@@ -1327,7 +1326,7 @@
     (let$ body (is-atomic-box))
     (letk k ($kargs () () ,body))
     (letk kheap-object ($kargs () () ($branch kbad k src 'atomic-box? #f (x))))
-    (build-term ($branch kbad kheap-object src 'heap-object? #f (x)))))
+    (build-term ($branch kbad kheap-object src 'thob? #f (x)))))
 
 (define-primcall-converter atomic-box-ref
   (lambda (cps k src op param x)
@@ -1421,7 +1420,7 @@
                       ($ (have-var box)))))))
        (letk ktest ($kargs () () ,body))
        (letk kbox ($kargs ('box) (box)
-                    ($branch kbad ktest src 'heap-object? #f (box))))
+                    ($branch kbad ktest src 'thob? #f (box))))
        (letk kname ($kargs ('name) (name-var)
                      ($continue kbox src
                        ($primcall 'lookup #f (mod name-var)))))
@@ -2136,7 +2135,7 @@
                     (letk kt* ($kargs () ()
                                 ($branch kf kt src name #f args)))
                     (build-term
-                      ($branch kf kt* src 'heap-object? #f args)))
+                      ($branch kf kt* src 'thob? #f args)))
                   (with-cps cps
                     (build-term ($branch kf kt src name #f args)))))))
          (($ <conditional> src test consequent alternate)
@@ -2459,10 +2458,8 @@ integer."
                                 (heap-number? b)
                                 (bool (primcall heap-numbers-equal? a b))))
                ('equal?
-                ;; Partially inline.
-                (primcall-chain (heap-object? a)
-                                (heap-object? b)
-                                (primcall equal? a b))))))))
+                ;; XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+                (primcall equal? a b)))))))
 
        (($ <primcall> src 'vector args)
         ;; Expand to "allocate-vector" + "vector-init!".
diff --git a/module/language/tree-il/cps-primitives.scm b/module/language/tree-il/cps-primitives.scm
index b9f2fe95b..710e651a3 100644
--- a/module/language/tree-il/cps-primitives.scm
+++ b/module/language/tree-il/cps-primitives.scm
@@ -162,7 +162,7 @@
   (hashq-ref *branching-primitive-arities* name))
 
 (define (heap-type-predicate? name)
-  "Is @var{name} a predicate that needs guarding by @code{heap-object?}
+  "Is @var{name} a predicate that needs guarding by @code{thob?}
  before it is lowered to CPS?"
   (hashq-ref *heap-type-predicates* name))
 
diff --git a/module/system/base/target.scm b/module/system/base/target.scm
index 2088cd866..d6fb6e77c 100644
--- a/module/system/base/target.scm
+++ b/module/system/base/target.scm
@@ -1,6 +1,6 @@
 ;;; Compilation targets
 
-;; Copyright (C) 2011-2014,2017-2018 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2014,2017-2019 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
@@ -34,7 +34,15 @@
 
             target-most-negative-fixnum
             target-most-positive-fixnum
-            target-fixnum?))
+            target-fixnum?
+
+            target-fixnum-tag
+            target-fixnum-tag-mask
+            target-fixnum-tag-bits
+
+            target-pair-tag
+            target-pair-tag-mask
+            target-pair-tag-bits))
 
 
 
@@ -172,6 +180,7 @@ SCM words."
   ;; address space.
   (/ (target-max-size-t) (target-word-size)))
 
+;; TAGS-SENSITIVE
 (define (target-max-vector-length)
   "Return the maximum vector length of the target platform, in units of
 SCM words."
@@ -179,18 +188,75 @@ SCM words."
   ;; type tag.  Additionally, restrict to 48-bit address space.
   (1- (ash 1 (min (- (* (target-word-size) 8) 8) 48))))
 
+;; TAGS-SENSITIVE
 (define (target-most-negative-fixnum)
   "Return the most negative integer representable as a fixnum on the
 target platform."
-  (- (ash 1 (- (* (target-word-size) 8) 3))))
+  (case (target-word-size)
+    ((4) #x-40000000)
+    ((8) #x-800000000000000)
+    (else (error "unexpected word size"))))
 
+;; TAGS-SENSITIVE
 (define (target-most-positive-fixnum)
   "Return the most positive integer representable as a fixnum on the
 target platform."
-  (1- (ash 1 (- (* (target-word-size) 8) 3))))
+  (case (target-word-size)
+    ((4) #x3fffffff)
+    ((8) #x7ffffffFFFFFFFF)
+    (else (error "unexpected word size"))))
 
+;; TAGS-SENSITIVE
 (define (target-fixnum? n)
   (and (exact-integer? n)
        (<= (target-most-negative-fixnum)
            n
            (target-most-positive-fixnum))))
+
+;; TAGS-SENSITIVE
+(define (target-fixnum-tag)
+  "Return the fixnum tag on the target platform."
+  (case (target-word-size)
+    ((4) 1)
+    ((8) 15)
+    (else (error "unexpected word size"))))
+
+;; TAGS-SENSITIVE
+(define (target-fixnum-tag-mask)
+  "Return the fixnum tag mask on the target platform."
+  (case (target-word-size)
+    ((4) 1)
+    ((8) 15)
+    (else (error "unexpected word size"))))
+
+;; TAGS-SENSITIVE
+(define (target-fixnum-tag-bits)
+  "Return the number of bits in the fixnum tag mask on the target platform."
+  (case (target-word-size)
+    ((4) 1)
+    ((8) 4)
+    (else (error "unexpected word size"))))
+
+;; TAGS-SENSITIVE
+(define (target-pair-tag)
+  "Return the pair tag on the target platform."
+  (case (target-word-size)
+    ((4) 4)
+    ((8) 6)
+    (else (error "unexpected word size"))))
+
+;; TAGS-SENSITIVE
+(define (target-pair-tag-mask)
+  "Return the pair tag mask on the target platform."
+  (case (target-word-size)
+    ((4) 7)
+    ((8) 15)
+    (else (error "unexpected word size"))))
+
+;; TAGS-SENSITIVE
+(define (target-pair-tag-bits)
+  "Return the number of bits in the pair tag mask on the target platform."
+  (case (target-word-size)
+    ((4) 3)
+    ((8) 4)
+    (else (error "unexpected word size"))))
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
index 418c9fed4..f0151f359 100644
--- a/module/system/base/types.scm
+++ b/module/system/base/types.scm
@@ -1,5 +1,5 @@
 ;;; 'SCM' type tag decoding.
-;;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015, 2017, 2018, 2019 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
@@ -308,16 +308,24 @@ KIND/SUB-KIND."
                           (lambda (io port)
                             (match io
                               (($ <inferior-object> kind sub-kind address)
-                               (format port "#<~a ~:[~*~;~a ~]~x>"
+                               (format port "#<~a~:[~*~; ~a~]~:[~*~; ~x~]>"
                                        kind sub-kind sub-kind
-                                       address)))))
+                                       address address)))))
 
-(define (inferior-smob backend type-number address)
+(define (inferior-smob backend type-number flags word1 address)
   "Return an object representing the SMOB at ADDRESS whose type is
 TYPE-NUMBER."
-  (inferior-object 'smob
-                   (or (type-number->name backend 'smob type-number)
-                       type-number)
+  (inferior-object (let ((type-name (or (type-number->name backend 'smob
+                                                           type-number)
+                                        (string->symbol
+                                         (string-append "smob-" (number->string type-number))))))
+                     (if (zero? flags)
+                         type-name
+                         (string->symbol (string-append
+                                          (symbol->string type-name)
+                                          "/"
+                                          (number->string flags 16)))))
+                   (number->string word1 16)
                    address))
 
 (define (inferior-port-type backend address)
@@ -438,8 +446,25 @@ using BACKEND."
            (inferior-object 'dynamic-state address))
           ((((flags << 8) || %tc7-port))
            (inferior-port backend (logand flags #xff) address))
-          (((_ & #x7f = %tc7-program))
-           (inferior-object 'program address))
+          (((bits & #x7f = %tc7-program) code)
+           (let ((num-free-vars (ash bits -16))
+                 (flags (filter-map (match-lambda
+                                      ((mask . flag-name)
+                                       (and (logtest mask bits) flag-name)))
+                                    '((#x0100 . boot)
+                                      (#x0200 . prim)
+                                      (#x0400 . prim-generic)
+                                      (#x0800 . cont)
+                                      (#x1000 . partial-cont)
+                                      (#x2000 . foreign)))))
+             (inferior-object (cons* 'program flags
+                                     (unfold zero?
+                                             (lambda (n)
+                                               (number->string (get-word port) 16))
+                                             1-
+                                             num-free-vars))
+                              (number->string code 16)
+                              address)))
           (((_ & #xffff = %tc16-bignum))
            (inferior-object 'bignum address))
           (((_ & #xffff = %tc16-flonum) pad)
@@ -458,11 +483,14 @@ using BACKEND."
           (((_ & #x7f = %tc7-syntax) expression wrap module)
            (cond-expand
              (guile-2.2
-              (make-syntax (cell->object expression backend)
-                           (cell->object wrap backend)
-                           (cell->object module backend)))
+              (make-syntax (scm->object expression backend)
+                           (scm->object wrap backend)
+                           (scm->object module backend)))
              (else
-              (inferior-object 'syntax address))))
+              (vector 'syntax-object
+                      (scm->object expression backend)
+                      (scm->object wrap backend)
+                      (scm->object module backend)))))
           (((_ & #x7f = %tc7-vm-continuation))
            (inferior-object 'vm-continuation address))
           (((_ & #x7f = %tc7-weak-set))
@@ -473,31 +501,35 @@ using BACKEND."
            (inferior-object 'array address))
           (((_ & #x7f = %tc7-bitvector))
            (inferior-object 'bitvector address))
-          ((((smob-type << 8) || %tc7-smob) word1)
-           (inferior-smob backend smob-type address))))))
+          (((bits & #x7f = %tc7-smob) word1)
+           (let ((smob-type (bit-extract bits 8 16))
+                 (flags     (ash bits -16)))
+             (inferior-smob backend smob-type flags word1 address)))))))
 
 
 (define* (scm->object bits #:optional (backend %ffi-memory-backend))
   "Return the Scheme object corresponding to BITS, the bits of an 'SCM'
 object."
   (match-scm bits
-    (((integer << 2) || %tc2-fixnum)
+    (((integer << %fixnum-tag-size) || %fixnum-tag)
      integer)
-    ((address & 7 = %tc3-heap-object)
-     (let* ((type  (dereference-word backend address))
-            (pair? (= (logand type #b1) %tc1-pair)))
-       (if pair?
-           (or (and=> (vhash-assv address (%visited-cells)) cdr)
-               (let ((car    type)
-                     (cdrloc (+ address %word-size))
-                     (pair   (cons *unspecified* *unspecified*)))
-                 (visited (address -> pair)
-                   (set-car! pair (scm->object car backend))
-                   (set-cdr! pair
-                             (scm->object (dereference-word backend cdrloc)
-                                          backend))
-                   pair)))
-           (cell->object address backend))))
+    ((bits & %pair-tag-mask = %pair-tag)
+     (or (and=> (vhash-assv bits (%visited-cells)) cdr)
+         (let* ((carloc (- bits %pair-tag))
+                (cdrloc (+ carloc %word-size))
+                (pair   (cons *unspecified* *unspecified*)))
+           (visited (bits -> pair)
+             (set-car! pair
+                       (scm->object (dereference-word backend carloc)
+                                    backend))
+             (set-cdr! pair
+                       (scm->object (dereference-word backend cdrloc)
+                                    backend))
+             pair))))
+    ((address & %thob-tag-mask = %thob-tag)
+     (if (zero? address)
+         (inferior-object 'NULL #f)   ; XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+         (cell->object address backend)))
     (((char << 8) || %tc8-char)
      (integer->char char))
     ((= %tc16-false) #f)
diff --git a/module/system/base/types/internal.scm b/module/system/base/types/internal.scm
index 9e4e4cc9c..cef812e94 100644
--- a/module/system/base/types/internal.scm
+++ b/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-2019 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
@@ -16,8 +16,15 @@
 
 (define-module (system base types internal)
   #:export (;; Immediate tags.
-            %tc2-fixnum
-            %tc3-heap-object
+            %fixnum-tag
+            %fixnum-tag-mask
+            %fixnum-tag-size
+            %thob-tag
+            %thob-tag-mask
+            %thob-tag-size
+            %pair-tag
+            %pair-tag-mask
+            %pair-tag-size
             %tc8-char
             %tc16-false
             %tc16-nil
@@ -29,7 +36,6 @@
             visit-immediate-tags
 
             ;; Heap object tags (cell types).
-            %tc1-pair
             %tc3-struct
             %tc7-symbol
             %tc7-variable
@@ -71,7 +77,7 @@
 
 
 ;;;
-;;; Tags---keep in sync with libguile/tags.h!
+;;; Tags---keep in sync with libguile/scm.h!
 ;;;
 
 (define-syntax define-tags
@@ -93,29 +99,32 @@
                        tag)
                     ...)))))))))
 
+;; XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+;; For now, this file defines tags for 64-bit word size.  TODO: support
+;; tags that vary depending on the target word size.
 (define-tags immediate-tags
   ;;                                    321076543210    321076543210
-  (fixnum           fixnum?                     #b11            #b10)
-  (heap-object      heap-object?               #b111           #b000)
-  (char             char?                 #b11111111      #b00001100)
-  (false            eq-false?         #b111111111111  #b000000000100)
-  (nil              eq-nil?           #b111111111111  #b000100000100)
-  (null             eq-null?          #b111111111111  #b001100000100)
-  (true             eq-true?          #b111111111111  #b010000000100)
-  (unspecified      unspecified?      #b111111111111  #b100000000100)
-  (undefined        undefined?        #b111111111111  #b100100000100)
-  (eof              eof-object?       #b111111111111  #b101000000100)
+  (thob             thob?                      #b111           #b000)
+  (pair             pair?                     #b1111          #b0110)
+  (fixnum           fixnum?                   #b1111          #b1111)
+  (char             char?                 #b11111111      #b00011110)
+  (false            eq-false?         #b111111111111  #b000000001110)
+  (nil              eq-nil?           #b111111111111  #b000100001110)
+  (null             eq-null?          #b111111111111  #b001100001110)
+  (true             eq-true?          #b111111111111  #b010000001110)
+  (unspecified      unspecified?      #b111111111111  #b100000001110)
+  (undefined        undefined?        #b111111111111  #b100100001110)
+  (eof              eof-object?       #b111111111111  #b101000001110)
 
-  ;;(nil            eq-nil?           #b111111111111  #b000100000100)
-  ;;(eol            eq-null?          #b111111111111  #b001100000100)
-  ;;(false          eq-false?         #b111111111111  #b000000000100)
-  (null+nil         null?             #b110111111111  #b000100000100)
-  (false+nil        false?            #b111011111111  #b000000000100)
-  (null+false+nil   nil?              #b110011111111  #b000000000100))
+  ;;(false          eq-false?         #b111111111111  #b000000001110)
+  ;;(nil            eq-nil?           #b111111111111  #b000100001110)
+  ;;(null           eq-null?          #b111111111111  #b001100001110)
+  (null+nil         null?             #b110111111111  #b000100001110)
+  (false+nil        false?            #b111011111111  #b000000001110)
+  (null+false+nil   nil?              #b110011111111  #b000000001110))
 
 (define-tags heap-tags
   ;;                                    321076543210    321076543210
-  (pair             pair?                        #b1             #b0)
   (struct           struct?                    #b111           #b001)
   ;; For tc7 values, low bits 2 and 0 must be 1.
   (symbol           symbol?                #b1111111       #b0000101)
@@ -159,15 +168,25 @@
   (complex          compnum?          #b111111111111  #b001100010111)
   (fraction         fracnum?          #b111111111111  #b010000010111))
 
+(eval-when (expand)
+  (define configurable-width-tag-names
+    '(fixnum thob pair)))
+
 (define-syntax define-tag
   (lambda (x)
-    (define (id-append ctx a b)
-      (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
+    (define (id-append ctx . ids)
+      (datum->syntax ctx (apply symbol-append (map syntax->datum ids))))
     (define (def prefix name tag)
       #`(define #,(id-append name prefix name) #,tag))
+    (define (def* name mask tag)
+      #`(begin
+          (define #,(id-append name #'% name #'-tag-mask) #,mask)
+          (define #,(id-append name #'% name #'-tag-size) (logcount #,mask))
+          (define #,(id-append name #'% name #'-tag) #,tag)))
     (syntax-case x ()
-      ((_ name pred #b1 tag)             (def #'%tc1- #'name #'tag))
-      ((_ name pred #b11 tag)            (def #'%tc2- #'name #'tag))
+      ((_ name pred mask tag)
+       (member (syntax->datum #'name) configurable-width-tag-names)
+       (def* #'name #'mask #'tag))
       ((_ name pred #b111 tag)           (def #'%tc3- #'name #'tag))
       ((_ name pred #b1111111 tag)       (def #'%tc7- #'name #'tag))
       ((_ name pred #b11111111 tag)      (def #'%tc8- #'name #'tag))
@@ -175,9 +194,7 @@
       ;; tc16 values.
       ((_ name pred #b111111111111 tag)  (def #'%tc16- #'name #'tag))
       ((_ name pred mask tag)
-       #`(begin
-           (define #,(id-append #'name #'name #'-mask) mask)
-           (define #,(id-append #'name #'name #'-tag) tag))))))
+       (def* #'name #'mask #'tag)))))
 
 (visit-immediate-tags define-tag)
 (visit-heap-tags define-tag)
@@ -205,13 +222,13 @@
       (error "expected #f and '() to differ in exactly two bit positions"))
     (call-with-values (lambda () (common-bits %tc16-null %tc16-nil))
       (lambda (mask tag)
-        (unless (= mask null+nil-mask) (error "unexpected mask for null?"))
-        (unless (= tag null+nil-tag) (error "unexpected tag for null?"))))
+        (unless (= mask %null+nil-tag-mask) (error "unexpected mask for null?"))
+        (unless (= tag %null+nil-tag) (error "unexpected tag for null?"))))
     (call-with-values (lambda () (common-bits %tc16-false %tc16-nil))
       (lambda (mask tag)
-        (unless (= mask false+nil-mask) (error "unexpected mask for false?"))
-        (unless (= tag false+nil-tag) (error "unexpected tag for false?"))))
+        (unless (= mask %false+nil-tag-mask) (error "unexpected mask for false?"))
+        (unless (= tag %false+nil-tag) (error "unexpected tag for false?"))))
     (call-with-values (lambda () (common-bits %tc16-false %tc16-null))
       (lambda (mask tag)
-        (unless (= mask null+false+nil-mask) (error "unexpected mask for nil?"))
-        (unless (= tag null+false+nil-tag) (error "unexpected tag for nil?"))))))
+        (unless (= mask %null+false+nil-tag-mask) (error "unexpected mask for nil?"))
+        (unless (= tag %null+false+nil-tag) (error "unexpected tag for nil?"))))))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 241d285d3..b5adc39fb 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -91,7 +91,8 @@
             emit-jnge
 
             emit-fixnum?
-            emit-heap-object?
+            emit-thob?
+            emit-pair?
             emit-char?
             emit-eq-null?
             emit-eq-nil?
@@ -110,7 +111,6 @@
             (emit-throw/value* . emit-throw/value)
             (emit-throw/value+data* . emit-throw/value+data)
 
-            emit-pair?
             emit-struct?
             emit-symbol?
             emit-variable?
@@ -144,6 +144,7 @@
 
             emit-allocate-words
             emit-allocate-words/immediate
+            emit-tagged-allocate-words/immediate
 
             emit-scm-ref
             emit-scm-set!
@@ -152,6 +153,9 @@
             emit-scm-ref/immediate
             emit-scm-set!/immediate
 
+            emit-tagged-scm-ref/immediate
+            emit-tagged-scm-set!/immediate
+
             emit-word-ref
             emit-word-set!
             emit-word-ref/immediate
@@ -643,6 +647,8 @@ later by the linker."
            ((X8_S8_S8_C8 a b c)
             (emit asm (pack-u8-u8-u8-u8 opcode a b c)))
            ((X8_S8_C8_S8 a b c)
+            (emit asm (pack-u8-u8-u8-u8 opcode a b c)))
+           ((X8_S8_C8_C8 a b c)
             (emit asm (pack-u8-u8-u8-u8 opcode a b c))))))
 
       (define (pack-tail-word asm type)
@@ -884,6 +890,23 @@ later by the linker."
     (emit-push asm a)
     (encode-X8_S8_C8_S8 asm 0 const 0 opcode)
     (emit-pop asm dst))))
+(define (encode-X8_S8_C8_C8!/shuffle asm a const1 const2 opcode)
+  (cond
+   ((< a (ash 1 8))
+    (encode-X8_S8_C8_C8 asm a const1 const2 opcode))
+   (else
+    (emit-push asm a)
+    (encode-X8_S8_C8_C8 asm 0 const1 const2 opcode)
+    (emit-drop asm 1))))
+(define (encode-X8_S8_C8_C8<-/shuffle asm dst const1 const2 opcode)
+  (cond
+   ((< dst (ash 1 8))
+    (encode-X8_S8_C8_C8 asm dst const1 const2 opcode))
+   (else
+    ;; Push garbage value to make space for dst.
+    (emit-push asm dst)
+    (encode-X8_S8_C8_C8 asm 0 const1 const2 opcode)
+    (emit-pop asm dst))))
 (define (encode-X8_S8_S8_S8-C32<-/shuffle asm dst a b c32 opcode)
   (cond
    ((< (logior dst a b) (ash 1 8))
@@ -954,6 +977,8 @@ later by the linker."
       (('! 'X8_S12_S12 'C32)     #'encode-X8_S12_S12-C32!/shuffle)
       (('! 'X8_S8_C8_S8)         #'encode-X8_S8_C8_S8!/shuffle)
       (('<- 'X8_S8_C8_S8)        #'encode-X8_S8_C8_S8<-/shuffle)
+      (('! 'X8_S8_C8_C8)         #'encode-X8_S8_C8_C8!/shuffle)
+      (('<- 'X8_S8_C8_C8)        #'encode-X8_S8_C8_C8<-/shuffle)
       (else (encoder-name operands))))
 
   (define-syntax assembler
@@ -996,6 +1021,7 @@ later by the linker."
           ('X8_S8_S8_S8 #'(a b c))
           ('X8_S8_S8_C8 #'(a b c))
           ('X8_S8_C8_S8 #'(a b c))
+          ('X8_S8_C8_C8 #'(a b c))
           ('X32 #'())))
 
       (syntax-case x ()
@@ -1097,28 +1123,25 @@ lists.  This procedure can be called many times before calling
 (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)))))
+      (and (target-fixnum? x)
+           (let* ((fixnum-max (target-most-positive-fixnum))
+                  (fixnum-bits (if (negative? x)
+                                   (+ fixnum-max 1 (logand x fixnum-max))
+                                   x)))
+             (logior (ash fixnum-bits (target-fixnum-tag-bits))
+                     (target-fixnum-tag))))
       ;; 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)))
+        ;; TAGS-SENSITIVE
+        (and (not (= (logand bits %thob-tag-mask)
+                     %thob-tag))
+             (not (= (logand bits (target-pair-tag-mask))
+                     (target-pair-tag)))
              bits))))
 
 (define-record-type <stringbuf>
@@ -1169,10 +1192,13 @@ table, its existing label is used directly."
   (define (field dst n obj)
     (let ((src (recur obj)))
       (if src
-          (if (statically-allocatable? obj)
-              `((static-patch! 0 ,dst ,n ,src))
-              `((static-ref 1 ,src)
-                (static-set! 1 ,dst ,n)))
+          (cond ((pair? obj)
+                 `((static-patch! (target-pair-tag) ,dst ,n ,src)))
+                ((statically-allocatable? obj)
+                 `((static-patch! 0 ,dst ,n ,src)))
+                (else
+                 `((static-ref 1 ,src)
+                   (static-set! 1 ,dst ,n))))
           '())))
   (define (intern obj label)
     (cond
@@ -1286,6 +1312,9 @@ returned instead."
            (emit-make-long-immediate asm dst obj))
           (else
            (emit-make-long-long-immediate asm dst obj)))))
+   ((pair? obj)
+    (emit-make-tagged-non-immediate asm dst (target-pair-tag)
+                                    (intern-non-immediate asm obj)))
    ((statically-allocatable? obj)
     (emit-make-non-immediate asm dst (intern-non-immediate asm obj)))
    (else
@@ -1781,7 +1810,7 @@ should be .data or .rodata), and return the resulting linker object.
                                bitvector-immutable-flag)
                        (logior tc7-bytevector
                                ;; Bytevector immutable flag also shifted
-                               ;; left.
+                               ;; left.  TAGS-SENSITIVE
                                (ash (logior bytevector-immutable-flag
                                             (array-type-code obj))
                                     7)))))
@@ -1858,7 +1887,7 @@ should be .data or .rodata), and return the resulting linker object.
      ((vlist-null? data) #f)
      (else
       (let* ((byte-len (vhash-fold (lambda (k v len)
-                                     (+ (byte-length k) (align len 8)))
+                                     (+ (byte-length k) (align len 16)))   ; temporary alignment hack XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
                                    0 data))
              (buf (make-bytevector byte-len 0)))
         (let lp ((i 0) (pos 0) (relocs '()) (symbols '()))
@@ -1867,7 +1896,7 @@ should be .data or .rodata), and return the resulting linker object.
                 ((obj . obj-label)
                  (write buf pos obj)
                  (lp (1+ i)
-                     (align (+ (byte-length obj) pos) 8)
+                     (align (+ (byte-length obj) pos) 16)   ; temporary alignment hack XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
                      (add-relocs obj pos relocs)
                      (cons (make-linker-symbol obj-label pos) symbols))))
               (make-object asm name buf relocs symbols
diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index 83499333c..7519e2e0b 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -107,7 +107,8 @@
               (unpack-s12 (ash word -20))))
           ((X8_S8_S8_S8
             X8_S8_S8_C8
-            X8_S8_C8_S8)
+            X8_S8_C8_S8
+            X8_S8_C8_C8)
            #'((logand (ash word -8) #xff)
               (logand (ash word -16) #xff)
               (ash word -24)))
@@ -208,6 +209,9 @@ address of that offset."
   (define (reference-scm target)
     (unpack-scm (u32-offset->addr (+ offset target) context)))
 
+  (define (reference-tagged-scm tag target)
+    (unpack-scm (+ tag (u32-offset->addr (+ offset target) context))))
+
   (define (dereference-scm target)
     (let ((addr (u32-offset->addr (+ offset target)
                                   context)))
@@ -270,6 +274,11 @@ address of that offset."
        (when (program? val)
          (push-addr! (program-code val) val))
        (list "~@Y" val)))
+    (('make-tagged-non-immediate dst tag target)
+     (let ((val (reference-tagged-scm tag target)))
+       (when (program? val)
+         (push-addr! (program-code val) val))
+       (list "~@Y" val)))
     (((or 'throw/value 'throw/value+data) dst target)
      (list "~@Y" (reference-scm target)))
     (('builtin-ref dst idx)
@@ -408,6 +417,8 @@ address of that offset."
        `(load-label ,dst ,(u32-offset->addr (+ offset src) context)))
       (('make-non-immediate dst target)
        `(make-non-immediate ,dst ,(reference-scm target)))
+      (('make-tagged-non-immediate dst tag target)
+       `(make-tagged-non-immediate ,dst ,tag ,(reference-tagged-scm tag target)))
       (('builtin-ref dst idx)
        `(builtin-ref ,dst ,(builtin-index->name idx)))
       (((or 'static-ref 'static-set!) dst target)