User-defined integer type, part 1.

Missing is DEFMETHOD support, the *instance-type* in
src/code/primordial-type.lisp causes a
  (declare (type instance x))
for defmethod and that breaks.

contrib/sb-udef-inttype/example.lisp

@@ -0,0 +1,27 @@
+(defpackage :new-uint-type
+  (:use :cl))
+
+(defclass udef-meta-class ()
+  (
+   #+(or)(sb-mop:class-default-initargs :initform ())
+   )
+  )
+
+
+(defmethod make-instance ((class udef-meta-class) &key)
+  nil)
+
+(defclass my-enum-1 (sb-int:udef-inttype)
+  ((id :initform (error "need ID")
+       :initargs id
+       :type (unsigned-byte 8)))
+  (:metaclass udef-meta-class))
+
+
+(progn
+  (eval `(defmethod make-instance ((class symbol) &key)
+           nil))
+  (trace "SB-PCL")
+  (eval `(defmethod make-instance ((class character) &key)
+           nil))
+  (untrace "SB-PCL"))

contrib/sb-udef-inttype/simple.lisp

@@ -0,0 +1,38 @@
+(assert (not (typep 4 'sb-kernel::udef-inttype)))
+(assert (not (sb-int:udef-inttype-p 4)))
+
+(sb-int:udef-inttype-p
+  (sb-int:make-udef-inttype 51))
+
+#+broken
+(assert
+  (sb-int:udef-inttype-p
+    (sb-int:make-udef-inttype 51)))
+
+
+
+(defvar *x* (make-array 20000 :initial-element (sb-int:make-udef-inttype 541)))
+(sb-ext:gc)
+
+(print (sb-int:udef-inttype-value (aref *x* 0)))
+(print (type-of (aref *x* 0)))
+(print (aref *x* 0))
+(print (sb-int:udef-inttype-p (aref *x* 0)))
+
+
+(defmethod my-dispatch ((y t))
+  :anything)
+(defmethod my-dispatch ((x sb-int:udef-inttype))
+    :udef)
+
+#+broken
+(my-dispatch (sb-int:make-udef-inttype 1))
+
+(assert (eq :anything
+            (my-dispatch 1)))
+
+#+broken
+(assert (eq :udef
+            (my-dispatch (sb-int:make-udef-inttype 1))))
+
+

src/code/class.lisp

@@ -1123,6 +1123,11 @@ between the ~A definition and the ~A definition"
       :inherits (integer rational real number)
       :codes ,sb-vm::fixnum-lowtags
       :prototype-form 42)
+     (udef-inttype
+      :codes (,sb-vm::udef-inttype-lowtag)
+      :predicate udef-inttype-p
+      :prototype-form #+sb-xc ,(sb-kernel:%make-lisp-obj sb-vm::udef-inttype-lowtag)
+                      #-sb-xc :udef-inttype-prototype)
      (bignum
       :translation (and integer (not fixnum))
       :inherits (integer rational real number)

src/code/cross-type.lisp

@@ -144,6 +144,8 @@
           (if (built-in-classoid-p type)
               (ecase name
                 (symbol (values (symbolp obj) t)) ; 1:1 correspondence with host
+                ;; Not used or available during cross-compilation
+                (udef-inttype (values nil t))
                 (function
                  (if (functionp obj)
                      (uncertain)

src/code/pred.lisp

@@ -98,6 +98,7 @@
   (def-type-predicate-wrapper double-float-p)
   (def-type-predicate-wrapper fdefn-p)
   (def-type-predicate-wrapper fixnump)
+  (def-type-predicate-wrapper udef-inttype-p)
   (def-type-predicate-wrapper floatp)
   (def-type-predicate-wrapper functionp)
   ;; SIMPLE-FUN-P is needed for constant folding in early warm load,

src/code/primordial-type.lisp

@@ -52,6 +52,8 @@
   ;; 2005-09-09
   (frob instance *instance-type*)
   (frob funcallable-instance *funcallable-instance-type*)
+  ;; New after sbcl-2.4.7: User-defined integers, to be used in DEFMETHOD etc.
+  (frob udef-inttype *instance-type*)
   ;; new in sbcl-1.0.3.3: necessary to act as a join point for the
   ;; extended sequence hierarchy.  (Might be removed later if we use
   ;; a dedicated FUNDAMENTAL-SEQUENCE class for this.)

src/code/print.lisp

@@ -597,6 +597,10 @@ variable: an unreadable object representing the error is printed instead.")
         (return-from output-ugly-object
           (print-unreadable-object (object stream :identity t)
             (prin1 'funcallable-instance stream))))))
+  (when (udef-inttype-p object)
+    (return-from output-ugly-object
+      (print-unreadable-object (object stream :identity nil :type t)
+        (format stream "#x~x" (udef-inttype-value object)))))
   (print-object object stream))
 
 ;;;; symbols

src/code/target-misc.lisp

@@ -250,3 +250,12 @@ version 1[.0.0...] or greater."
   (declare (type (or null string) string))
   (push (list string name doc-type) sb-pcl::*!docstrings*)
   string)
+
+
+(defun udef-inttype-value (x)
+  (ash (sb-kernel:get-lisp-obj-address x)
+       -8))
+(defun make-udef-inttype (x)
+  (declare (type (unsigned-byte 56) x))
+  (sb-kernel:%make-lisp-obj (logior (ash x 8)
+                                    sb-int:udef-inttype-lowtag)))

src/code/typep.lisp

@@ -41,6 +41,7 @@
      (ecase (named-type-name type)
        ((* t) t)
        ((instance) (%instancep object))
+       ((udef-inttype) (udef-inttype-p object))
        ((funcallable-instance) (funcallable-instance-p object))
        ((extended-sequence) (extended-sequence-p object))
        ((nil) nil)))

src/cold/exports.lisp

@@ -777,6 +777,8 @@ possibly temporarily, because it might be used internally.")
    "CONSTANT-DISPLACEMENT"
    "EXTENDED-FUNCTION-DESIGNATOR"
    "EXTENDED-FUNCTION-DESIGNATOR-P"
+   "UDEF-INTTYPE" "UDEF-INTTYPE-P" "UDEF-INTTYPE-LOWTAG"
+   "MAKE-UDEF-INTTYPE" "UDEF-INTTYPE-VALUE"
    ;; ..and type predicates
 
    "DOUBLE-FLOAT-P"

src/compiler/fndb.lisp

@@ -80,7 +80,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

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

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*)

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 (unsigned-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")

src/compiler/generic/type-vops.lisp

@@ -50,7 +50,16 @@
 
 (define-type-vop single-float-p (single-float-widetag))
 
+;; Ineffective because they're lowtags!!
 (define-type-vop fixnump #.fixnum-lowtags)
+(defun udef-inttype-p (x)
+  (declare (optimize (speed 3) (debug 1)))
+  (or (eq x :udef-inttype-prototype)
+      ;; No user-define integer types during cross-compilation
+      #+sb-xc
+      (eql sb-int:udef-inttype-lowtag
+           (logand #xff
+                   (sb-kernel:get-lisp-obj-address x)))))
 
 (define-type-vop functionp (fun-pointer-lowtag))
 

src/compiler/typetran.lisp

@@ -308,6 +308,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)

src/compiler/x86-64/type-vops.lisp

@@ -546,6 +546,7 @@
   (define functionp fun-pointer-lowtag)
   (define listp list-pointer-lowtag)
   (define %instancep instance-pointer-lowtag)
+  (define udef-inttype-p udef-inttype-lowtag)
   (define %other-pointer-p other-pointer-lowtag))
 
 ;;; Function subtypes produce a flag result