From 004b10b1ce8716def7a40b08317113939d907fe4 Mon Sep 17 00:00:00 2001 From: Philipp Marek Date: Fri, 2 Aug 2024 13:53:39 +0200 Subject: [PATCH] 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 | 27 ++++++++++++++++++ contrib/sb-udef-inttype/simple.lisp | 38 ++++++++++++++++++++++++++ src/code/class.lisp | 5 ++++ src/code/cross-type.lisp | 2 ++ src/code/pred.lisp | 1 + src/code/primordial-type.lisp | 2 ++ src/code/print.lisp | 4 +++ src/code/target-misc.lisp | 9 ++++++ src/code/typep.lisp | 1 + src/cold/exports.lisp | 2 ++ src/compiler/fndb.lisp | 2 +- src/compiler/generic/early-objdef.lisp | 2 +- src/compiler/generic/late-objdef.lisp | 4 +++ src/compiler/generic/primtype.lisp | 4 +++ src/compiler/generic/type-vops.lisp | 9 ++++++ src/compiler/typetran.lisp | 1 + src/compiler/x86-64/type-vops.lisp | 1 + 17 files changed, 112 insertions(+), 2 deletions(-) create mode 100644 contrib/sb-udef-inttype/example.lisp create mode 100644 contrib/sb-udef-inttype/simple.lisp diff --git a/contrib/sb-udef-inttype/example.lisp b/contrib/sb-udef-inttype/example.lisp new file mode 100644 index 0000000000..0613ec2572 --- /dev/null +++ b/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")) diff --git a/contrib/sb-udef-inttype/simple.lisp b/contrib/sb-udef-inttype/simple.lisp new file mode 100644 index 0000000000..690c1d7557 --- /dev/null +++ b/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)))) + + diff --git a/src/code/class.lisp b/src/code/class.lisp index 7ca88f4078..dca19c994b 100644 --- a/src/code/class.lisp +++ b/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) diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index 626b508121..6ba8d5d4e0 100644 --- a/src/code/cross-type.lisp +++ b/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) diff --git a/src/code/pred.lisp b/src/code/pred.lisp index ba7b7abd65..a48963fa9f 100644 --- a/src/code/pred.lisp +++ b/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, diff --git a/src/code/primordial-type.lisp b/src/code/primordial-type.lisp index 307f7c3d26..d103e706df 100644 --- a/src/code/primordial-type.lisp +++ b/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.) diff --git a/src/code/print.lisp b/src/code/print.lisp index bcf5576a46..f6f1aa0fe3 100644 --- a/src/code/print.lisp +++ b/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 diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp index 319fc6ddb7..cd9824987f 100644 --- a/src/code/target-misc.lisp +++ b/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))) diff --git a/src/code/typep.lisp b/src/code/typep.lisp index 91af3d3e14..33ac5b1d43 100644 --- a/src/code/typep.lisp +++ b/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))) diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp index d90bd34091..f2e0f6b836 100644 --- a/src/cold/exports.lisp +++ b/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" diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 155ae4f9b6..5374e8e868 100644 --- a/src/compiler/fndb.lisp +++ b/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 diff --git a/src/compiler/generic/early-objdef.lisp b/src/compiler/generic/early-objdef.lisp index a75664e23e..db8309fd47 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 584bc37d00..278a297138 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/primtype.lisp b/src/compiler/generic/primtype.lisp index 0b6fde5788..efef3c6c0d 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 (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") diff --git a/src/compiler/generic/type-vops.lisp b/src/compiler/generic/type-vops.lisp index e21d659361..66bb31fc05 100644 --- a/src/compiler/generic/type-vops.lisp +++ b/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)) diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index f3231ed01b..88d4415ed0 100644 --- a/src/compiler/typetran.lisp +++ b/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) diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp index d0ef4c0a76..879e4d8bbe 100644 --- a/src/compiler/x86-64/type-vops.lisp +++ b/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