Coverage report: /home/ellis/comp/core/lib/obj/meta/typed.lisp

KindCoveredAll%
expression8125 6.4
branch128 3.6
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; obj/meta/typed.lisp --- Typed meta-objects
2
 
3
 ;; - typed-slot-class
4
 
5
 ;; inspired by:
6
 ;; https://allegrograph.com/fixed-indices-speed-up-slot-access-in-allegro-cl/
7
 
8
 ;; may implement fixed.lisp separately.. we'll see.
9
 
10
 ;;; Commentary:
11
 
12
 ;; I still need to investigate what the actual behavior is in
13
 ;; SBCL.
14
 
15
 ;; - What sort of type checking is performed on slot-access, when that
16
 ;;   slot has type information? Does this vary at different compile levels?
17
 
18
 ;; - What is the performance impact of injecting additional
19
 ;;   slot-accessor type information? For example, declare as
20
 ;;   function-type with a typed result.
21
 
22
 ;;; Code:
23
 (in-package :obj/meta/typed)
24
 
25
 (declaim (type hash-table array-type-to-byte byte-to-array-type))
26
 (defvar array-type-to-byte (make-hash-table :test 'equalp))
27
 (defvar byte-to-array-type (make-hash-table :test 'equalp))
28
 
29
 (setf (gethash 't array-type-to-byte) #x00)
30
 (setf (gethash 'base-char array-type-to-byte) #x01)
31
 (setf (gethash 'character array-type-to-byte) #x02)
32
 (setf (gethash 'single-float array-type-to-byte) #x03)
33
 (setf (gethash 'double-float array-type-to-byte) #x04)
34
 (setf (gethash '(complex single-float) array-type-to-byte) #x05)
35
 (setf (gethash '(complex double-float) array-type-to-byte) #x06)
36
 (setf (gethash 'fixnum array-type-to-byte) #x07)
37
 (setf (gethash 'bit array-type-to-byte) #x08)
38
 
39
 (defun type-num (obj)
40
   "Define a type order; no guarantee that backend and front-end match
41
    so we can't iterate over types, just all members of a give type class
42
    (i.e. numbers, etc)"
43
   (cond ((numberp obj) 1)
44
         ((characterp obj) 1)
45
         ((symbolp obj) 13)
46
         ((stringp obj) 2)
47
         ((subtypep (type-of obj) 'stored) 15)
48
         ((consp obj) 16)
49
         ((subtypep (type-of obj) 'standard-object) 18)
50
         ((pathnamep obj) 12)
51
         ((hash-table-p obj) 17)
52
         ((subtypep (type-of obj) 'structure-object) 20)
53
         ((complexp obj) 22)))
54
 
55
 (defun type<= (obj1 obj2)
56
   (<= (type-num obj1) (type-num obj2)))
57
 
58
 (defun type< (obj1 obj2)
59
   (< (type-num obj1) (type-num obj2)))
60
 
61
 (defun type= (obj1 obj2)
62
   (= (type-num obj1) (type-num obj2)))
63
 
64
 (defun array-type= (t1 t2)
65
   (and (subtypep t1 t2) (subtypep t2 t1)))
66
 
67
 (let ((counter 8))
68
   (loop for i from 2 to 65
69
         for spec = (list 'unsigned-byte i)
70
         for uspec = (upgraded-array-element-type spec)
71
         when (array-type= spec uspec)
72
         do
73
         (setf (gethash spec array-type-to-byte) (incf counter)))
74
   (loop for i from 2 to 65
75
         for spec = (list 'signed-byte i)
76
         for uspec = (upgraded-array-element-type spec)
77
         when (array-type= spec uspec)
78
         do
79
         (setf (gethash spec array-type-to-byte) (incf counter))))
80
 
81
 (loop for key being the hash-key of array-type-to-byte 
82
       using (hash-value value)
83
       do
84
       (setf (gethash value byte-to-array-type) key))
85
 
86
 (defun array-type-from-byte (b)
87
   (gethash b byte-to-array-type))
88
 
89
 (defun byte-from-array-type (ty)
90
   (the (unsigned-byte 8) (gethash ty array-type-to-byte)))
91
 
92
 (defun int-byte-spec (position)
93
   "Shared byte-spec peformance hack; not thread safe so removed
94
    from use for serializer2"
95
   (declare (type (unsigned-byte 24) position))
96
   (byte 32 (* 32 position)))