1 ;;;; some macros and constants that are object-format-specific or are
2 ;;;; used for defining the object format
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
15 ;;;; other miscellaneous stuff
17 ;;; This returns a form that returns a dual-word aligned number of bytes when
18 ;;; given a number of words.
20 ;;; FIXME: should be a function
21 ;;; FIXME: should be called PAD-DATA-BLOCK-SIZE
22 (defmacro pad-data-block
(words)
23 `(logandc2 (+ (ash ,words word-shift
) lowtag-mask
) lowtag-mask
))
25 ;;;; primitive object definition stuff
27 (defun remove-keywords (options keywords
)
28 (cond ((null options
) nil
)
29 ((member (car options
) keywords
)
30 (remove-keywords (cddr options
) keywords
))
32 (list* (car options
) (cadr options
)
33 (remove-keywords (cddr options
) keywords
)))))
35 (def!struct
(prim-object-slot
36 (:constructor make-slot
(name docs rest-p offset options
))
37 (:make-load-form-fun just-dump-it-normally
)
39 (name nil
:type symbol
)
40 (docs nil
:type
(or null simple-string
))
41 (rest-p nil
:type
(member t nil
))
42 (offset 0 :type fixnum
)
43 (options nil
:type list
))
45 (def!struct
(primitive-object (:make-load-form-fun just-dump-it-normally
))
46 (name nil
:type symbol
)
47 (widetag nil
:type symbol
)
48 (lowtag nil
:type symbol
)
49 (options nil
:type list
)
50 (slots nil
:type list
)
52 (variable-length-p nil
:type
(member t nil
)))
54 (defvar *primitive-objects
* nil
)
56 (defun %define-primitive-object
(primobj)
57 (let ((name (primitive-object-name primobj
)))
58 (setf *primitive-objects
*
60 (remove name
*primitive-objects
*
61 :key
#'primitive-object-name
:test
#'eq
)))
64 (defmacro define-primitive-object
65 ((name &key lowtag widetag alloc-trans
(type t
))
67 (collect ((slots) (exports) (constants) (forms) (inits))
68 (let ((offset (if widetag
1 0))
69 (variable-length-p nil
))
70 (dolist (spec slot-specs
)
71 (when variable-length-p
72 (error "No more slots can follow a :rest-p slot."))
74 (slot-name &rest options
75 &key docs rest-p
(length (if rest-p
0 1))
76 ((:type slot-type
) t
) init
77 (ref-known nil ref-known-p
) ref-trans
78 (set-known nil set-known-p
) set-trans
81 (if (atom spec
) (list spec
) spec
)
82 (slots (make-slot slot-name docs rest-p offset
83 (remove-keywords options
84 '(:docs
:rest-p
:length
))))
85 (let ((offset-sym (symbolicate name
"-" slot-name
86 (if rest-p
"-OFFSET" "-SLOT"))))
87 (constants `(def!constant
,offset-sym
,offset
88 ,@(when docs
(list docs
))))
92 (forms `(defknown ,ref-trans
(,type
) ,slot-type
,ref-known
)))
93 (forms `(def-reffer ,ref-trans
,offset
,lowtag
)))
96 (forms `(defknown ,set-trans
97 ,(if (listp set-trans
)
99 (list type slot-type
))
102 (forms `(def-setter ,set-trans
,offset
,lowtag
)))
105 (error ":REST-P and :CAS-TRANS incompatible."))
108 (defknown ,cas-trans
(,type
,slot-type
,slot-type
)
110 #!+compare-and-swap-vops
111 (def-casser ,cas-trans
,offset
,lowtag
))))
113 (inits (cons init offset
)))
115 (setf variable-length-p t
))
116 (incf offset length
)))
117 (unless variable-length-p
118 (let ((size (symbolicate name
"-SIZE")))
119 (constants `(def!constant
,size
,offset
))
122 (forms `(def-alloc ,alloc-trans
,offset
,variable-length-p
,widetag
125 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
126 (%define-primitive-object
127 ',(make-primitive-object :name name
132 :variable-length-p variable-length-p
))
136 ;;;; stuff for defining reffers and setters
140 (defmacro def-reffer
(name offset lowtag
)
141 `(%def-reffer
',name
,offset
,lowtag
))
142 (defmacro def-setter
(name offset lowtag
)
143 `(%def-setter
',name
,offset
,lowtag
))
144 (defmacro def-alloc
(name words variable-length-p header lowtag inits
)
145 `(%def-alloc
',name
,words
,variable-length-p
,header
,lowtag
,inits
))
146 #!+compare-and-swap-vops
147 (defmacro def-casser
(name offset lowtag
)
148 `(%def-casser
',name
,offset
,lowtag
))
149 ;;; KLUDGE: The %DEF-FOO functions used to implement the macros here
150 ;;; are defined later in another file, since they use structure slot
151 ;;; setters defined later, and we can't have physical forward
152 ;;; references to structure slot setters because ANSI in its wisdom
153 ;;; allows the xc host CL to implement structure slot setters as SETF
154 ;;; expanders instead of SETF functions. -- WHN 2002-02-09
156 ;;;; some general constant definitions
158 ;;; FIXME: SC-NUMBER-LIMIT should probably be exported from SB!C
159 ;;; or SB!VM so that we don't need to do this extra IN-PACKAGE.
162 ;;; the maximum number of SCs in any implementation
163 (def!constant sc-number-limit
32)
165 ;;; Modular functions
167 ;;; For a documentation, see CUT-TO-WIDTH.
169 (defstruct modular-class
170 ;; hash: name -> { :GOOD | optimizer | ({modular-fun-info}*)}
171 (funs (make-hash-table :test
'eq
))
172 ;; hash: modular-variant -> (prototype width)
174 ;; FIXME: Reimplement with generic function names of kind
175 ;; (MODULAR-VERSION prototype width)
176 (versions (make-hash-table :test
'eq
))
177 ;; list of increasing widths
179 (defvar *unsigned-modular-class
* (make-modular-class))
180 (defvar *signed-modular-class
* (make-modular-class))
181 (defun find-modular-class (kind)
183 (:unsigned
*unsigned-modular-class
*)
184 (:signed
*signed-modular-class
*)))
186 (defstruct modular-fun-info
187 (name (missing-arg) :type symbol
)
188 (width (missing-arg) :type
(integer 0))
189 (lambda-list (missing-arg) :type list
)
190 (prototype (missing-arg) :type symbol
))
192 (defun find-modular-version (fun-name class width
)
193 (let ((infos (gethash fun-name
(modular-class-funs (find-modular-class class
)))))
195 (find-if (lambda (item-width) (>= item-width width
))
197 :key
#'modular-fun-info-width
)
200 ;;; Return (VALUES prototype-name width)
201 (defun modular-version-info (name class
)
202 (values-list (gethash name
(modular-class-versions (find-modular-class class
)))))
204 (defun %define-modular-fun
(name lambda-list prototype class width
)
205 (let* ((class (find-modular-class class
))
206 (funs (modular-class-funs class
))
207 (versions (modular-class-versions class
))
208 (infos (the list
(gethash prototype funs
)))
209 (info (find-if (lambda (item-width) (= item-width width
))
211 :key
#'modular-fun-info-width
)))
213 (unless (and (eq name
(modular-fun-info-name info
))
214 (= (length lambda-list
)
215 (length (modular-fun-info-lambda-list info
))))
216 (setf (modular-fun-info-name info
) name
)
217 (style-warn "Redefining modular version ~S of ~S for width ~S."
218 name prototype width
))
219 (setf (gethash prototype funs
)
221 (list (make-modular-fun-info :name name
223 :lambda-list lambda-list
224 :prototype prototype
))
226 #'< :key
#'modular-fun-info-width
)
227 (gethash name versions
)
228 (list prototype width
)))
229 (setf (modular-class-widths class
)
230 (merge 'list
(list width
) (modular-class-widths class
) #'<))))
232 (defmacro define-modular-fun
(name lambda-list prototype class width
)
233 (check-type name symbol
)
234 (check-type prototype symbol
)
235 (check-type class
(member :unsigned
:signed
))
236 (check-type width unsigned-byte
)
237 (dolist (arg lambda-list
)
238 (when (member arg lambda-list-keywords
)
239 (error "Lambda list keyword ~S is not supported for ~
240 modular function lambda lists." arg
)))
242 (%define-modular-fun
',name
',lambda-list
',prototype
',class
,width
)
243 (defknown ,name
,(mapcar (constantly 'integer
) lambda-list
)
245 (:unsigned
'unsigned-byte
)
246 (:signed
'signed-byte
))
248 (foldable flushable movable
)
249 :derive-type
(make-modular-fun-type-deriver
250 ',prototype
',class
,width
))))
252 (defun %define-good-modular-fun
(name class
)
253 (setf (gethash name
(modular-class-funs (find-modular-class class
))) :good
)
256 (defmacro define-good-modular-fun
(name class
)
257 (check-type name symbol
)
258 (check-type class
(member :unsigned
:signed
))
259 `(%define-good-modular-fun
',name
',class
))
261 (defmacro define-modular-fun-optimizer
262 (name ((&rest lambda-list
) class
&key
(width (gensym "WIDTH")))
264 (check-type name symbol
)
265 (check-type class
(member :unsigned
:signed
))
266 (dolist (arg lambda-list
)
267 (when (member arg lambda-list-keywords
)
268 (error "Lambda list keyword ~S is not supported for ~
269 modular function lambda lists." arg
)))
270 (with-unique-names (call args
)
271 `(setf (gethash ',name
(modular-class-funs (find-modular-class ',class
)))
272 (lambda (,call
,width
)
273 (declare (type basic-combination
,call
)
274 (type (integer 0) width
))
275 (let ((,args
(basic-combination-args ,call
)))
276 (when (= (length ,args
) ,(length lambda-list
))
277 (destructuring-bind ,lambda-list
,args
278 (declare (type lvar
,@lambda-list
))