Re: User-defined integers: Asking for feedback

From cb3eae318ca02d780125245cde6f876ae2ec98ee Mon Sep 17 00:00:00 2001
From: Philipp Marek <[email protected]>
Date: Thu, 3 Oct 2024 14:34:29 +0200
Subject: [PATCH 1/3] User-defined integer types: SBCL basics.

---
 src/code/class.lisp                    |  5 ++
 src/code/pred.lisp                     | 16 +++++--
 src/code/target-udef-inttype.lisp      | 64 ++++++++++++++++++++++++++
 src/code/typep.lisp                    |  4 ++
 src/cold/build-order.lisp-expr         |  6 ++-
 src/cold/exports.lisp                  |  8 ++++
 src/compiler/fndb.lisp                 |  2 +-
 src/compiler/generic/early-objdef.lisp |  2 +-
 src/compiler/generic/late-objdef.lisp  |  4 ++
 src/compiler/generic/objdef.lisp       |  3 ++
 src/compiler/generic/primtype.lisp     |  4 ++
 src/compiler/typetran.lisp             |  1 +
 src/compiler/x86-64/type-vops.lisp     |  1 +
 src/pcl/precom2.lisp                   |  1 +
 src/runtime/lispobj.h                  |  1 +
 15 files changed, 116 insertions(+), 6 deletions(-)
 create mode 100644 src/code/target-udef-inttype.lisp

diff --git a/src/code/class.lisp b/src/code/class.lisp
index e8cdf5624..a11c2cd69 100644
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -1136,6 +1136,11 @@ between the ~A definition and the ~A definition"
       :inherits (integer rational real number)
       :codes ,sb-vm::fixnum-lowtags
       :prototype-form 42)
+     (udef-inttype
+      :predicate udef-inttype-p
+      :codes (,sb-vm::udef-inttype-lowtag)
+      ;:prototype-form 0 ; gets filled in later
+      :prototype-form sb-pcl:+slot-unbound+)
      (bignum
       :translation (and integer (not fixnum))
       :inherits (integer rational real number)
diff --git a/src/code/pred.lisp b/src/code/pred.lisp
index fc4ac7749..2423c8c50 100644
--- a/src/code/pred.lisp
+++ b/src/code/pred.lisp
@@ -222,9 +222,19 @@
            (if (functionp object) 'funcallable-instance 'instance)))
        (let* ((classoid (layout-classoid layout))
               (name (classoid-name classoid)))
-         ;; FIXME: should the first test be (not (or (%instancep) (%funcallable-instance-p)))?
-         ;; God forbid anyone makes anonymous classes of generic functions.
-         (cond ((not (%instancep object))
+         (cond ;; cold compilation already does type derivations,
+               ;; but sb-xc:*features* (from src/cold/shebang.lisp) isn't active?
+               ;#- #.(cl:find :sb-xc sb-xc:*features*)
+               ;#-sb-xc
+               ;; the predicate doesn't exist during xc
+               ((= sb-vm::udef-inttype-lowtag
+                   (ldb (byte sb-vm:n-widetag-bits 0)
+                        (sb-kernel:get-lisp-obj-address object)))
+                ;(udef-inttype-p object)
+                (sb-int:udef-inttype-type-of object))
+               ;; FIXME: should the first test be (not (or (%instancep) (%funcallable-instance-p)))?
+               ;; God forbid anyone makes anonymous classes of generic functions.
+               ((not (%instancep object))
                 name)
                ((eq name 'sb-alien-internals:alien-value)
                 `(alien ,(sb-alien-internals:unparse-alien-type
diff --git a/src/code/target-udef-inttype.lisp b/src/code/target-udef-inttype.lisp
new file mode 100644
index 000000000..250ffdd34
--- /dev/null
+++ b/src/code/target-udef-inttype.lisp
@@ -0,0 +1,64 @@
+;;;; User-defined integer types / enumerations
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-INT")
+
+;; Apart from the bits used by udef-inttype-lowtag,
+;; this here declares a further
+(defconstant +udef-tag-bits+ 8)
+;; bits to be used for a range of user-defined integer types.
+
+(defvar *udef-types* nil
+  "Vector of user-defined integer types.
+  NIL until first use.")
+
+(declaim (inline udef-inttype-p))
+
+(defun sb-int::udef-inttype-p (x)
+  (= sb-vm::udef-inttype-lowtag
+     (ldb (byte sb-vm:n-widetag-bits 0)
+          (sb-kernel:get-lisp-obj-address x))))
+
+;; This FTYPE gets me an error
+;;   0: (ALLOCATE-CONDITION NIL)
+;;   1: (MAKE-CONDITION NIL)
+;;   2: (MAKE-CONDITION NIL) [more]
+;;   3: (COERCE-TO-CONDITION NIL SIMPLE-ERROR ERROR) [more]
+;;   4: (ERROR NIL)
+;;   5: ((LABELS SB-KERNEL::RECURSE :IN CTYPEP) NIL #<BUILT-IN-CLASSOID UDEF-INTTYPE (sealed)>)
+;;   6: ((LAMBDA (ELT) :IN SB-KERNEL::MEMBER-COMPLEX-SUBTYPEP-ARG1-TYPE-METHOD) NIL)
+;;   7: (MAP-XSET #<FUNCTION (LAMBDA (ELT) :IN SB-KERNEL::MEMBER-COMPLEX-SUBTYPEP-ARG1-TYPE-METHOD) {12071F718B}> #S(XSET :DATA (NIL) :EXTRA 1))
+;;   8: (SB-KERNEL::MEMBER-COMPLEX-SUBTYPEP-ARG1-TYPE-METHOD #<MEMBER-TYPE NULL> #<BUILT-IN-CLASSOID UDEF-INTTYPE (sealed)>)
+;;   9: (CSUBTYPEP #<MEMBER-TYPE NULL> #<BUILT-IN-CLASSOID UDEF-INTTYPE (sealed)>)
+;;   10: (SB-KERNEL::%COERCE-TO-VALUES #<BUILT-IN-CLASSOID UDEF-INTTYPE (sealed)>)
+;;   11: (SB-KERNEL::SIMPLIFY-UNIONS (#<MEMBER-TYPE NULL> #<BUILT-IN-CLASSOID UDEF-INTTYPE (sealed)>))
+;;   12: (SB-KERNEL::%TYPE-UNION (#<MEMBER-TYPE NULL> #<BUILT-IN-CLASSOID UDEF-INTTYPE (sealed)>))
+;;   13: (TYPE-UNION #<MEMBER-TYPE NULL> #<BUILT-IN-CLASSOID UDEF-INTTYPE (sealed)>) [more]
+;;   14: (SB-C::IR1-TRANSFORM-TYPE-PREDICATE #<SB-C::LVAR 1 {1207284523}> #<BUILT-IN-CLASSOID UDEF-INTTYPE (sealed)> #<SB-C::COMBINATION :FUN #<SB-C::REF  :LEAF #<SB-C::GLOBAL-VAR :%SOURCE-NAME UDEF-INTTYPE-P :TYPE #1=#<FUN-TYPE (FUNCTION (T) (VALUES BOOLEAN &OPTIONAL))> :DEFINED-TYPE #1# :WHERE-FROM :DECLARED :KIND :GLOBAL-FUNCTION {12072842F3}> {12072843D3}> :ARGS (#<SB-C::REF :%SOURCE-NAME X :LEAF #<SB-C::LAMBDA-VAR :%SOURCE-NAME X {1207283803}> {1207284573}>) {1207284443}>)
+;; during cold/warm.
+(declaim #+(or)(ftype (function (udef-inttype) (unsigned-byte #. +udef-tag-bits+))
+                udef-inttype-tag)
+         (inline udef-inttype-tag))
+(defun udef-inttype-tag (x)
+  (ldb (byte +udef-tag-bits+ sb-vm:n-widetag-bits)
+       (sb-kernel:get-lisp-obj-address x)))
+
+(declaim (ftype (function (T) (values symbol)) udef-inttype-type-of))
+(defun udef-inttype-type-of (x)
+  "Returns the type symbol, or NIL."
+;  (declare (ignore x)) nil
+  ;; TODO: error out if not a udef-inttype?
+  (when (udef-inttype-p x)
+    (let ((type (and *udef-types*
+                     (aref *udef-types* (udef-inttype-tag x)))))
+      (if type
+          type
+          'udef-inttype))))
diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index d00f3213c..cb0435ab3 100644
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -40,6 +40,10 @@
     (named-type
      (ecase (named-type-name type)
        ((* t) t)
+       ;; cold compilation already does type derivations,
+       ;; but sb-xc:*features* (from src/cold/shebang.lisp) isn't active?
+       #- #.(cl:find :sb-xc sb-xc:*features*)
+       ((udef-inttype) (values (udef-inttype-p object)))
        ((instance) (%instancep object))
        ((funcallable-instance) (funcallable-instance-p object))
        ((extended-sequence) (extended-sequence-p object))
diff --git a/src/cold/build-order.lisp-expr b/src/cold/build-order.lisp-expr
index 5df1afda2..7584f34d9 100644
--- a/src/cold/build-order.lisp-expr
+++ b/src/cold/build-order.lisp-expr
@@ -729,4 +729,8 @@
   "src/code/repack-xref"
   #+cheneygc "src/code/purify"
   "src/code/module"
-  "src/code/save"))
+  "src/code/save")
+
+#-sb-xc
+  ("src/code/target-udef-inttype")
+  )
diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
index 2cea5f65d..d4d3b71e7 100644
--- a/src/cold/exports.lisp
+++ b/src/cold/exports.lisp
@@ -778,6 +778,7 @@ possibly temporarily, because it might be used internally.")
    "CONSTANT-DISPLACEMENT"
    "EXTENDED-FUNCTION-DESIGNATOR"
    "EXTENDED-FUNCTION-DESIGNATOR-P"
+
    ;; ..and type predicates
 
    "DOUBLE-FLOAT-P"
@@ -969,6 +970,12 @@ possibly temporarily, because it might be used internally.")
    "STDIO-FILE"
    "MAKE-STDIO-FILE"
 
+   ;; for SB-UDEF-INTTYPE
+
+   "UDEF-INTTYPE" "UDEF-INTTYPE-P"
+   "MAKE-UDEF-INTTYPE" "UDEF-INTTYPE-VALUE"
+   "UDEF-INTTYPE-TYPE-OF"
+
    ;; for SB-COVER
 
    "*CODE-COVERAGE-INFO*"
@@ -2988,6 +2995,7 @@ structure representations")
            "SIMPLE-FUN-NAME-SLOT"
            "SIMPLE-FUN-ENTRY-SAP"
            "FUN-POINTER-LOWTAG"
+           "UDEF-INTTYPE-LOWTAG"
            "FUNCTION-LAYOUT"
            "SIMPLE-FUN-INFO-SLOT"
            "SIMPLE-FUN-SELF-SLOT"
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 3de9dcc22..005c7e37f 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -59,7 +59,7 @@
 (defknown (null symbolp atom consp listp numberp integerp rationalp floatp
                 complexp characterp stringp bit-vector-p vectorp
                 simple-vector-p simple-string-p simple-bit-vector-p arrayp
-                packagep functionp compiled-function-p not)
+                packagep functionp compiled-function-p not udef-inttype-p)
   (t) boolean (movable foldable flushable))
 
 (defknown (eq eql) (t t) boolean
diff --git a/src/compiler/generic/early-objdef.lisp b/src/compiler/generic/early-objdef.lisp
index 8662d6f50..74bc8a8aa 100644
--- a/src/compiler/generic/early-objdef.lisp
+++ b/src/compiler/generic/early-objdef.lisp
@@ -56,7 +56,7 @@
     pad0-lowtag
     instance-pointer-lowtag
     pad1-lowtag
-    other-immediate-1-lowtag
+    udef-inttype-lowtag
     pad2-lowtag
     list-pointer-lowtag
     odd-fixnum-lowtag
diff --git a/src/compiler/generic/late-objdef.lisp b/src/compiler/generic/late-objdef.lisp
index 2d4130bae..2de947daf 100644
--- a/src/compiler/generic/late-objdef.lisp
+++ b/src/compiler/generic/late-objdef.lisp
@@ -156,6 +156,7 @@
                 (member (logand byte lowtag-mask)
                         `(,instance-pointer-lowtag
                           ,list-pointer-lowtag
+                          ,udef-inttype-lowtag
                           ,fun-pointer-lowtag
                           ,other-pointer-lowtag))
                 (member byte `(#+64-bit ,single-float-widetag
@@ -186,6 +187,8 @@
     (dotimes (i 256)
       (cond ((eql 0 (logand i fixnum-tag-mask))
              (setf (svref scavtab i) "immediate" (svref sizetab i) "immediate"))
+            ((eql udef-inttype-lowtag (logand i lowtag-mask))
+             (setf (svref scavtab i) "immediate" (svref sizetab i) "immediate"))
             (t
              (let ((pointer-kind (case (logand i lowtag-mask)
                                    (#.instance-pointer-lowtag "instance")
@@ -206,6 +209,7 @@
             (aref sizetab #xff) "consfiller")
       (setf (nth instance-pointer-lowtag ptrtab) "scav_instance_pointer"
             (nth list-pointer-lowtag ptrtab)     "scav_list_pointer"
+            (nth udef-inttype-lowtag ptrtab)     "scav_immediate"
             (nth fun-pointer-lowtag ptrtab)      "scav_fun_pointer"
             (nth other-pointer-lowtag ptrtab)    "scav_other_pointer"))
     (dolist (entry *scav/trans/size*)
diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp
index ea991e683..e0a3f7376 100644
--- a/src/compiler/generic/objdef.lisp
+++ b/src/compiler/generic/objdef.lisp
@@ -75,6 +75,9 @@
   #+sparc (filler)
   (value :c-type "long double" :length #+x86 3 #+sparc 4))
 
+(define-primitive-object (udef-inttype :lowtag udef-inttype-lowtag
+                                       :widetag udef-inttype-lowtag))
+
 ;;; FIXME: the primitive-type should probably be named COMPLEX-RATIONAL
 ;;; but that was more invasive than renaming just the widetag
 (define-primitive-object (complex :type complex
diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp
index f15e16b9b..9ada761b5 100644
--- a/src/compiler/generic/primtype.lisp
+++ b/src/compiler/generic/primtype.lisp
@@ -47,6 +47,10 @@
 (!def-primitive-type signed-byte-64 (signed-reg descriptor-reg)
   :type (signed-byte 64))
 
+#+(or 64-bit 64-bit-registers)
+(!def-primitive-type udef-inttype (any-reg descriptor-reg)
+  :type (unsigned-byte #.(- 64 n-widetag-bits)))
+
 (define-load-time-global *fixnum-primitive-type* (primitive-type-or-lose 'fixnum))
 
 (/show0 "primtype.lisp 53")
diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 3d25fd5d5..84ba797d0 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -355,6 +355,7 @@
   (define-type-predicate consp cons)
   (define-type-predicate floatp float)
   (define-type-predicate functionp function)
+  (define-type-predicate udef-inttype-p udef-inttype)
   (define-type-predicate integerp integer)
   (define-type-predicate keywordp keyword)
   (define-type-predicate listp list)
diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp
index 735d56821..e7d817182 100644
--- a/src/compiler/x86-64/type-vops.lisp
+++ b/src/compiler/x86-64/type-vops.lisp
@@ -656,6 +656,7 @@
                 (:generator 1 (inst cmp :byte value ,widetag)))))
   (define single-float-p single-float-widetag)
   (define characterp character-widetag)
+  (define udef-inttype-p udef-inttype-lowtag)
   (define unbound-marker-p unbound-marker-widetag))
 
 ;;; FUNCTIONP, LISTP, %INSTANCEP, %OTHER-POINTER-P produce a flag result
diff --git a/src/pcl/precom2.lisp b/src/pcl/precom2.lisp
index ab6a805b2..4ee025c27 100644
--- a/src/pcl/precom2.lisp
+++ b/src/pcl/precom2.lisp
@@ -32,6 +32,7 @@
                 (precompile-ctors))))
   (precompile-random-code-segments pcl))
 
+#+(or)
 (push '("SB-PCL" *built-in-classes*) *!removable-symbols*)
 
 (defun !system-class-p (x) (typep x 'sb-pcl::system-class))
diff --git a/src/runtime/lispobj.h b/src/runtime/lispobj.h
index 311755f53..10a9e12a4 100644
--- a/src/runtime/lispobj.h
+++ b/src/runtime/lispobj.h
@@ -34,6 +34,7 @@ is_lisp_immediate(lispobj obj)
 #if N_WORD_BITS == 64
             || (widetag == SINGLE_FLOAT_WIDETAG)
 #endif
+            || (widetag == UDEF_INTTYPE_LOWTAG)
             || (widetag == UNBOUND_MARKER_WIDETAG));
 }
 
-- 
2.51.0

From 3d8fc2bbd4d30b6d509b6c33f1fa4f073338e2f5 Mon Sep 17 00:00:00 2001
From: Douglas Katzman <[email protected]>
Date: Sun, 15 Dec 2024 17:52:09 +0100
Subject: [PATCH 2/3] Fix GC for UDEFs.

---
 src/runtime/lispobj.h | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/src/runtime/lispobj.h b/src/runtime/lispobj.h
index 10a9e12a4..a4019f7fb 100644
--- a/src/runtime/lispobj.h
+++ b/src/runtime/lispobj.h
@@ -31,6 +31,7 @@ is_lisp_immediate(lispobj obj)
     int widetag;
     return (fixnump(obj)
             || ((widetag = header_widetag(obj)) == CHARACTER_WIDETAG)
+            || (widetag == UDEF_INTTYPE_LOWTAG)
 #if N_WORD_BITS == 64
             || (widetag == SINGLE_FLOAT_WIDETAG)
 #endif
@@ -132,6 +133,7 @@ static inline int is_cons_half(lispobj obj)
     if (fixnump(obj) || is_lisp_pointer(obj)) return 1;
     int widetag = header_widetag(obj);
     return widetag == CHARACTER_WIDETAG ||
+           widetag == UDEF_INTTYPE_LOWTAG ||
 #if N_WORD_BITS == 64
            widetag == SINGLE_FLOAT_WIDETAG ||
 #endif
-- 
2.51.0