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