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