1;;;; some macros and constants that are object-format-specific or are
2;;;; used for defining the object format
3
4;;;; This software is part of the SBCL system. See the README file for
5;;;; more information.
6;;;;
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.
12
13(in-package "SB!VM")
14
15;;;; other miscellaneous stuff
16
17;;; This returns a form that returns a dual-word aligned number of bytes when
18;;; given a number of words.
19;;;
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))
24
25;;;; primitive object definition stuff
26
27(defun remove-keywords (options keywords)
28  (cond ((null options) nil)
29        ((member (car options) keywords)
30         (remove-keywords (cddr options) keywords))
31        (t
32         (list* (car options) (cadr options)
33                (remove-keywords (cddr options) keywords)))))
34
35(def!struct (prim-object-slot
36             (:constructor make-slot (name docs rest-p offset special options))
37             (:conc-name slot-))
38  (name nil :type symbol :read-only t)
39  (docs nil :type (or null simple-string) :read-only t)
40  (rest-p nil :type (member t nil) :read-only t)
41  (offset 0 :type fixnum :read-only t)
42  (options nil :type list :read-only t)
43  ;; On some targets (e.g. x86-64) slots of the thread structure are
44  ;; referenced as special variables, this slot holds the name of that variable.
45  (special nil :type symbol :read-only t))
46
47(def!struct (primitive-object)
48  (name nil :type symbol :read-only t)
49  (widetag nil :type symbol :read-only t)
50  (lowtag nil :type symbol :read-only t)
51  (options nil :type list :read-only t)
52  (slots nil :type list :read-only t)
53  (size 0 :type fixnum :read-only t)
54  (variable-length-p nil :type (member t nil) :read-only t))
55
56(declaim (freeze-type prim-object-slot primitive-object))
57(!set-load-form-method prim-object-slot (:host :xc))
58(!set-load-form-method primitive-object (:host :xc))
59
60(defvar *primitive-objects* nil)
61
62(defun !%define-primitive-object (primobj)
63  (let ((name (primitive-object-name primobj)))
64    (setf *primitive-objects*
65          (cons primobj
66                (remove name *primitive-objects*
67                        :key #'primitive-object-name :test #'eq)))
68    name))
69
70(defvar *!late-primitive-object-forms* nil)
71
72(defmacro !define-primitive-object
73          ((name &key lowtag widetag alloc-trans (type t))
74           &rest slot-specs)
75  (collect ((slots) (specials) (constants) (forms) (inits))
76    (let ((offset (if widetag 1 0))
77          (variable-length-p nil))
78      (dolist (spec slot-specs)
79        (when variable-length-p
80          (error "No more slots can follow a :rest-p slot."))
81        (destructuring-bind
82            (slot-name &rest options
83                       &key docs rest-p (length (if rest-p 0 1))
84                       ((:type slot-type) t) init
85                       (ref-known nil ref-known-p) ref-trans
86                       (set-known nil set-known-p) set-trans
87                       cas-trans
88                       special
89                       pointer
90                       &allow-other-keys)
91            (if (atom spec) (list spec) spec)
92          #!-alpha
93          (declare (ignorable pointer))
94          #!+alpha
95          (when pointer
96            ;; Pointer values on ALPHA are 64 bits wide, and
97            ;; double-word aligned.  We may also wish to have such a
98            ;; mode for other 64-bit hardware outside of any defined
99            ;; 32-on-64 ABI (which would presumably have 32-bit
100            ;; pointers in the first place, obviating the alignment
101            ;; and size requirements).
102            (unless rest-p
103              (setf length 2))
104            (when (oddp offset)
105              (incf offset)))
106          (slots (make-slot slot-name docs rest-p offset special
107                            (remove-keywords options
108                                             '(:docs :rest-p :length))))
109          (let ((offset-sym (symbolicate name "-" slot-name
110                                         (if rest-p "-OFFSET" "-SLOT"))))
111            (constants `(def!constant ,offset-sym ,offset
112                          ,@(when docs (list docs))))
113            (when special
114              (specials `(defvar ,special))))
115          (when ref-trans
116            (when ref-known-p
117              (forms `(defknown ,ref-trans (,type) ,slot-type ,ref-known)))
118            (forms `(def-reffer ,ref-trans ,offset ,lowtag)))
119          (when set-trans
120            (when set-known-p
121              (forms `(defknown ,set-trans
122                                ,(if (listp set-trans)
123                                     (list slot-type type)
124                                     (list type slot-type))
125                                ,slot-type
126                        ,set-known)))
127            (forms `(def-setter ,set-trans ,offset ,lowtag)))
128          (when cas-trans
129            (when rest-p
130              (error ":REST-P and :CAS-TRANS incompatible."))
131            (forms
132             `(progn
133                (defknown ,cas-trans (,type ,slot-type ,slot-type)
134                    ,slot-type ())
135                #!+compare-and-swap-vops
136                (def-casser ,cas-trans ,offset ,lowtag))))
137          (when init
138            (inits (cons init offset)))
139          (when rest-p
140            (setf variable-length-p t))
141          (incf offset length)))
142      (unless variable-length-p
143        (constants `(def!constant ,(symbolicate name "-SIZE") ,offset)))
144      (when alloc-trans
145        (forms `(def-alloc ,alloc-trans ,offset
146                  ,(if variable-length-p :var-alloc :fixed-alloc)
147                  ,widetag
148                  ,lowtag ',(inits))))
149      `(progn
150         (eval-when (:compile-toplevel :load-toplevel :execute)
151           (setf (info :type :source-location ',name) (source-location))
152           (!%define-primitive-object
153            ',(make-primitive-object :name name
154                                     :widetag widetag
155                                     :lowtag lowtag
156                                     :slots (slots)
157                                     :size offset
158                                     :variable-length-p variable-length-p))
159           ,@(constants)
160           ,@(specials))
161         (setf *!late-primitive-object-forms*
162               (append *!late-primitive-object-forms*
163                       ',(forms)))))))
164
165;;; We want small SC-NUMBERs for SCs whose numbers are frequently
166;;; embedded into machine code. We therefore fix the numbers for the
167;;; four (i.e two bits) most frequently embedded SCs (empirically
168;;; determined) and assign the rest sequentially.
169(defmacro !define-storage-classes (&rest classes)
170  (let* ((fixed-numbers '((descriptor-reg . 0)
171                          (any-reg        . 1)
172                          (signed-reg     . 2)
173                          (constant       . 3)))
174         (index (length fixed-numbers)))
175    (flet ((process-class (class-spec)
176             (destructuring-bind (sc-name sb-name &rest args) class-spec
177               (let* ((sc-number (or (cdr (assoc sc-name fixed-numbers))
178                                     (1- (incf index))))
179                      (constant-name (symbolicate sc-name "-SC-NUMBER")))
180                 `((define-storage-class ,sc-name ,sc-number
181                     ,sb-name ,@args)
182                   (def!constant ,constant-name ,sc-number))))))
183      `(progn ,@(mapcan #'process-class classes)))))
184
185;;;; stuff for defining reffers and setters
186
187(in-package "SB!C")
188
189(defmacro def-reffer (name offset lowtag)
190  `(%def-reffer ',name ,offset ,lowtag))
191(defmacro def-setter (name offset lowtag)
192  `(%def-setter ',name ,offset ,lowtag))
193(defmacro def-alloc (name words alloc-style header lowtag inits)
194  `(%def-alloc ',name ,words ,alloc-style ,header ,lowtag ,inits))
195#!+compare-and-swap-vops
196(defmacro def-casser (name offset lowtag)
197  `(%def-casser ',name ,offset ,lowtag))
198;;; KLUDGE: The %DEF-FOO functions used to implement the macros here
199;;; are defined later in another file, since they use structure slot
200;;; setters defined later, and we can't have physical forward
201;;; references to structure slot setters because ANSI in its wisdom
202;;; allows the xc host CL to implement structure slot setters as SETF
203;;; expanders instead of SETF functions. -- WHN 2002-02-09
204
205;;;; some general constant definitions
206
207;;; FIXME: SC-NUMBER-LIMIT should probably be exported from SB!C
208;;; or SB!VM so that we don't need to do this extra IN-PACKAGE.
209(in-package "SB!C")
210
211;;; the maximum number of SCs in any implementation
212(def!constant sc-number-limit 62)
213
214;;; Modular functions
215
216;;; For a documentation, see CUT-TO-WIDTH.
217
218(defstruct modular-class
219  ;; hash: name -> { :GOOD | optimizer | ({modular-fun-info}*)}
220  (funs (make-hash-table :test 'eq))
221  ;; hash: modular-variant -> (prototype width)
222  ;;
223  ;; FIXME: Reimplement with generic function names of kind
224  ;; (MODULAR-VERSION prototype width)
225  (versions (make-hash-table :test 'eq))
226  ;; list of increasing widths + signedps
227  (widths nil))
228(defvar *untagged-unsigned-modular-class* (make-modular-class))
229(defvar *untagged-signed-modular-class* (make-modular-class))
230(defvar *tagged-modular-class* (make-modular-class))
231(defun find-modular-class (kind signedp)
232  (ecase kind
233    (:untagged
234     (ecase signedp
235       ((nil) *untagged-unsigned-modular-class*)
236       ((t) *untagged-signed-modular-class*)))
237    (:tagged
238     (aver signedp)
239     *tagged-modular-class*)))
240
241(defstruct modular-fun-info
242  (name (missing-arg) :type symbol)
243  (width (missing-arg) :type (integer 0))
244  (signedp (missing-arg) :type boolean)
245  (lambda-list (missing-arg) :type list)
246  (prototype (missing-arg) :type symbol))
247
248(defun find-modular-version (fun-name kind signedp width)
249  (let ((infos (gethash fun-name (modular-class-funs (find-modular-class kind signedp)))))
250    (if (listp infos)
251        (find-if (lambda (mfi)
252                   (aver (eq (modular-fun-info-signedp mfi) signedp))
253                   (>= (modular-fun-info-width mfi) width))
254                 infos)
255        infos)))
256
257;;; Return (VALUES prototype-name width)
258(defun modular-version-info (name kind signedp)
259  (values-list (gethash name (modular-class-versions (find-modular-class kind signedp)))))
260
261(defun %define-modular-fun (name lambda-list prototype kind signedp width)
262  (let* ((class (find-modular-class kind signedp))
263         (funs (modular-class-funs class))
264         (versions (modular-class-versions class))
265         (infos (the list (gethash prototype funs)))
266         (info (find-if (lambda (mfi)
267                          (and (eq (modular-fun-info-signedp mfi) signedp)
268                               (= (modular-fun-info-width mfi) width)))
269                        infos)))
270    (if info
271        (unless (and (eq name (modular-fun-info-name info))
272                     (= (length lambda-list)
273                        (length (modular-fun-info-lambda-list info))))
274          (setf (modular-fun-info-name info) name)
275          (style-warn "Redefining modular version ~S of ~S for ~
276                       ~:[un~;~]signed width ~S."
277                      name prototype signedp width))
278        (setf (gethash prototype funs)
279              (merge 'list
280                     (list (make-modular-fun-info :name name
281                                                  :width width
282                                                  :signedp signedp
283                                                  :lambda-list lambda-list
284                                                  :prototype prototype))
285                     infos
286                     #'< :key #'modular-fun-info-width)
287              (gethash name versions)
288              (list prototype width)))
289    (setf (modular-class-widths class)
290          (merge 'list (list (cons width signedp)) (modular-class-widths class)
291                 #'< :key #'car))))
292
293(defun %check-modular-fun-macro-arguments
294    (name kind &optional (lambda-list nil lambda-list-p))
295  (check-type name symbol)
296  (check-type kind (member :untagged :tagged))
297  (when lambda-list-p
298    (dolist (arg lambda-list)
299      (when (member arg sb!xc:lambda-list-keywords)
300        (error "Lambda list keyword ~S is not supported for modular ~
301                function lambda lists." arg)))))
302
303(defmacro define-modular-fun (name lambda-list prototype kind signedp width)
304  (%check-modular-fun-macro-arguments name kind lambda-list)
305  (check-type prototype symbol)
306  (check-type width unsigned-byte)
307  `(progn
308     (%define-modular-fun ',name ',lambda-list ',prototype ',kind ',signedp ,width)
309     (defknown ,name ,(mapcar (constantly 'integer) lambda-list)
310               (,(ecase signedp
311                   ((nil) 'unsigned-byte)
312                   ((t) 'signed-byte))
313                 ,width)
314               (foldable flushable movable)
315               :derive-type (make-modular-fun-type-deriver
316                             ',prototype ',kind ,width ',signedp))))
317
318(defun %define-good-modular-fun (name kind signedp)
319  (setf (gethash name (modular-class-funs (find-modular-class kind signedp))) :good)
320  name)
321
322(defmacro define-good-modular-fun (name kind signedp)
323  (%check-modular-fun-macro-arguments name kind)
324  `(%define-good-modular-fun ',name ',kind ',signedp))
325
326(defmacro define-modular-fun-optimizer
327    (name ((&rest lambda-list) kind signedp &key (width (gensym "WIDTH")))
328     &body body)
329  (%check-modular-fun-macro-arguments name kind lambda-list)
330  (with-unique-names (call args)
331    `(setf (gethash ',name (modular-class-funs (find-modular-class ',kind ',signedp)))
332           (lambda (,call ,width)
333             (declare (type basic-combination ,call)
334                      (type (integer 0) ,width))
335             (let ((,args (basic-combination-args ,call)))
336               (when (= (length ,args) ,(length lambda-list))
337                 (destructuring-bind ,lambda-list ,args
338                   (declare (type lvar ,@lambda-list))
339                   ,@body)))))))
340