DEF-COLUMN-STRUCT with one or two allocation levels.

Quite a few things still missing, see TODOs.

.gitignore

@@ -1,3 +1,4 @@
+*
 *.d
 *.dSYM
 *.o

contrib/Makefile

@@ -3,7 +3,8 @@ vpath %.fasl ../obj/sbcl-home/contrib/
 contribs = sb-posix sb-bsd-sockets sb-introspect sb-cltl2 sb-aclrepl \
      sb-sprof sb-capstone sb-md5 sb-capstone sb-executable sb-gmp sb-mpfr \
      sb-queue sb-rotate-byte sb-rt sb-simple-streams sb-concurrency sb-cover \
-     sb-simd sb-grovel sb-perf asdf
+     sb-simd sb-grovel sb-perf asdf sb-udef-inttype sb-udef-inttype
+
 
 active_contribs = $(filter-out $(SBCL_CONTRIB_BLOCKLIST),$(contribs))
 

contrib/sb-udef-inttype/example.lisp

@@ -1,6 +1,83 @@
-(defpackage :new-uint-type
-  (:use :cl))
+(defpackage :udef-inttype-example
+  (:use :cl :sb-int)
+  (:import-from :sb-impl #:def-udef-inttype)
+  )
+(in-package :udef-inttype-example)
+
+
+(def-udef-inttype my-idx-51
+  :constructor make-my-idx
+   :max-bits 15)
+
+(def-udef-inttype my-2bit
+  :constructor make-my-2bit
+   :max-bits 2)
+
+
+
+(defmethod print-object ((obj my-idx-51) s)
+  (print-unreadable-object (obj s :type t :identity t)
+    (format s "0x~x" (get-my-idx-51-value obj))))
+
+;; doesn't trigger,
+;; how to match arguments?
+(sb-mop:compute-applicable-methods
+  #'print-object (list (make-my-idx #x1222) *standard-output*))
+
+
+(sb-impl::udef-inttype-type-of
+  (make-my-idx #xfe))
+
+sb-impl::*udef-types*
+(sb-int:udef-inttype-p
+  (make-my-idx #xfe))
+
+(sb-int:udef-inttype-p
+  (make-my-idx #xfe))
+
+(type-of
+  (make-my-idx #xfe))
+
+#+(or)
+(make-instance 'my-idx-51)
+
+(disassemble #'make-my-idx)
+
+;; extend src/code/class.lisp to get subtypes recognized?
+#+(or)
+(my-idx-51-p
+  (make-my-idx #xfe))
 
+(my-idx-51-p (make-my-bit 1))
+(my-2bit-p (make-my-2bit 1))
+(my-2bit-p (make-my-2bit 0))
+(my-2bit-p (make-my-2bit 2))
+(my-idx-51-p (make-my-2bit 3))
+
+(format nil "~x"
+  (sb-kernel:get-lisp-obj-address (make-my-idx #xfe)))
+
+(defun to-be-traced (x)
+    (type-of x))
+
+(to-be-traced (make-my-idx #x151))
+(to-be-traced (make-my-2bit #x1))
+(sb-c::layout-of (make-my-idx #x151))
+(sb-c::%instancep (make-my-idx #x151))
+
+
+(defparameter *vec* (make-array 5 :element-type '(unsigned-byte 16)
+                                :initial-element 0))
+
+(defparameter *my-v* (make-my-idx x15))
+
+(setf (aref *vec* 3) *vec*)
+
+*vec*
+
+  :with-batch-macro with-my-idx
+
+#|
 (defclass udef-meta-class ()
   (
    #+(or)(sb-mop:class-default-initargs :initform ())
@@ -25,3 +102,21 @@
   (eval `(defmethod make-instance ((class character) &key)
            nil))
   (untrace "SB-PCL"))
+
+
+
+(defvar *pointers* (make-array 200
+                               :element-type ()))
+
+
+(defmacro def-udef-inttype (name (&keys id))
+  (let ((make-fn (intern (format nil "~a-~a" :MAKE name)
+                     (symbol-package name))))
+  `(progn
+     (deftype ,name ())
+     (declaim (inline ,make-fn)
+              (ftype (function ((unsigned-byte 48)) ,name)))
+     (defun ,make-fn (i)
+       (sb-int:make-udef-inttype (logior ,id (ash i 8)))))))
+|#
+

contrib/sb-udef-inttype/s-l-a-d-comparison.lisp

@@ -0,0 +1,95 @@
+
+
+(require :sb-perf)
+
+(require :sb-udef-inttype)
+
+#. (let ((what (second sb-ext:*posix-argv*)))
+     (defparameter *def* (if (string= what "1")
+                             'defstruct
+                             'sb-column-struct:def-column-struct))
+     (defparameter *name* (cond
+                            ((string= what "1")
+                             'my-integers)
+                             ;; Sized up a few times, reaches *max* more or less exactly.
+                            ((string= what "2")
+                             '(my-integers (:initial-size 16500)
+                                           (:data-var var)))
+                            ((string= what "3")
+                              '(my-integers (:initial-size 2030000)
+                                            (:data-var var)))
+                            ((string= what "4")
+                              '(my-integers (:initial-size 3000000)
+                                            (:batched 1000001)
+                                            (:data-var var))))))
+
+#+(or)
+(setf *name* '(my-integers (:initial-size 30)
+                           (:batched 10)
+                           (:data-var var)))
+
+(#. *def*  #. *name*
+  (prev nil :type t)
+  (v1 0 :type fixnum)
+  (v2 0 :type fixnum))
+
+;; Only now, to have the accessors available
+(sb-perf:write-perfmap)
+
+#+(or)
+(unless (eq *def* 'defstruct)
+  (format t "Start size: ~d of ~d~%"
+          (sb-column-struct:column-struct-last-index 'my-integers)
+          (sb-column-struct:column-struct-size 'my-integers)))
+
+
+(defparameter *max* 8000000)
+
+
+(defparameter *data* (loop for i from 0 to *max*
+                           for instance = (make-my-integers :prev instance
+                                                            :v1 i)
+                           do (setf (my-integers-v2 instance)
+                                    (mod i 37))
+                           finally (return instance)))
+
+;; TODO: broken
+#+(or)
+(unless (eq *def* 'defstruct)
+  (describe *data*))
+
+;; check content
+(defun check ()
+  (loop with instance = *data*
+        for i from *max* downto 0
+        unless (eq *def* 'defstruct)
+        do (multiple-value-bind (type raw)
+               (sb-impl::udef-inttype-type-of instance)
+             (assert (eq type 'my-integers))
+             (assert (= raw i)))
+        ;;
+        do (assert (= (my-integers-v1 instance)
+                      i))
+        do (assert (= (my-integers-v2 instance)
+                      (mod i 37)))
+        do (setf instance (my-integers-prev instance))
+        ;if (zerop (mod i 100000))
+        ;do (format t "   okay for ~d~%" i)
+        finally (assert (null instance))))
+
+
+(defun sizes ()
+  (if (eq *def* 'defstruct)
+    (format t "   Created:    ~d~%" (my-integers-v1 *data*))
+    (format t "   Used items: ~d of ~d~%"
+            (sb-column-struct:column-struct-last-index 'my-integers)
+            (sb-column-struct:column-struct-size 'my-integers))))
+
+(check)
+
+(let ((file (third sb-ext:*posix-argv*)))
+  (unless (member file '(nil "" "-") :test #'equal)
+    (save-lisp-and-die file
+                       :executable t
+                       :toplevel #'sizes)))
+

contrib/sb-udef-inttype/sb-udef-inttype.asd

@@ -0,0 +1,13 @@
+;;;; SB-Perf
+
+(error "Can't build contribs with ASDF")
+
+(defsystem "sb-udef-inttype"
+  :components ((:file "column-structure")
+               ;example-column-structure.lisp
+               ;example.lisp
+               ;simple.lisp
+               ;test.lisp
+               ))
+
+

make-target-2-load.lisp

@@ -483,6 +483,9 @@ Please check that all strings which were not recognizable to the compiler
            ;; Retain some internals to keep CLSQL working.
            (member symbol '(sb-loop::*loop-epilogue*
                             sb-loop::add-loop-path))))
+      (#.(find-package "SB-UDEF-INTTYPE")
+       t #+(or)
+       (eq accessibility :external))
       (#.(find-package "SB-LOCKLESS")
        (or (eq accessibility :external)
            (member symbol '(sb-lockless::+hash-nbits+)))) ; for a test
@@ -514,7 +517,7 @@ Please check that all strings which were not recognizable to the compiler
            (or (sb-kernel:symbol-%info symbol)
                (sb-kernel:%symbol-function symbol)
                (and (boundp symbol) (not (keywordp symbol))))))))
-   :verbose nil :print nil)
+   :verbose nil :print t)
   (unintern 'sb-impl::shake-packages 'sb-impl)
   (let ((sum-delta-ext 0)
         (sum-delta-int 0))