1.0.27.31: repeatable fasl header and debug-source
[sbcl.git] / src / compiler / generic / vm-macs.lisp
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 \f
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 \f
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 options))
37              (:make-load-form-fun just-dump-it-normally)
38              (:conc-name slot-))
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))
44
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)
51   (size 0 :type fixnum)
52   (variable-length-p nil :type (member t nil)))
53
54 (defvar *primitive-objects* nil)
55
56 (defun %define-primitive-object (primobj)
57   (let ((name (primitive-object-name primobj)))
58     (setf *primitive-objects*
59           (cons primobj
60                 (remove name *primitive-objects*
61                         :key #'primitive-object-name :test #'eq)))
62     name))
63
64 (defmacro define-primitive-object
65           ((name &key lowtag widetag alloc-trans (type t))
66            &rest slot-specs)
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."))
73         (destructuring-bind
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
79                        cas-trans
80                        &allow-other-keys)
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))))
89             (exports offset-sym))
90           (when ref-trans
91             (when ref-known-p
92               (forms `(defknown ,ref-trans (,type) ,slot-type ,ref-known)))
93             (forms `(def-reffer ,ref-trans ,offset ,lowtag)))
94           (when set-trans
95             (when set-known-p
96               (forms `(defknown ,set-trans
97                                 ,(if (listp set-trans)
98                                      (list slot-type type)
99                                      (list type slot-type))
100                                 ,slot-type
101                         ,set-known)))
102             (forms `(def-setter ,set-trans ,offset ,lowtag)))
103           (when cas-trans
104             (when rest-p
105               (error ":REST-P and :CAS-TRANS incompatible."))
106             (forms
107              `(progn
108                 (defknown ,cas-trans (,type ,slot-type ,slot-type)
109                     ,slot-type (unsafe))
110                 #!+compare-and-swap-vops
111                 (def-casser ,cas-trans ,offset ,lowtag))))
112           (when init
113             (inits (cons init offset)))
114           (when rest-p
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))
120           (exports size)))
121       (when alloc-trans
122         (forms `(def-alloc ,alloc-trans ,offset
123                   ,(if variable-length-p :var-alloc :fixed-alloc)
124                   ,widetag
125                   ,lowtag ',(inits))))
126       `(progn
127          (eval-when (:compile-toplevel :load-toplevel :execute)
128            (%define-primitive-object
129             ',(make-primitive-object :name name
130                                      :widetag widetag
131                                      :lowtag lowtag
132                                      :slots (slots)
133                                      :size offset
134                                      :variable-length-p variable-length-p))
135            ,@(constants))
136          ,@(forms)))))
137 \f
138 ;;;; stuff for defining reffers and setters
139
140 (in-package "SB!C")
141
142 (defmacro def-reffer (name offset lowtag)
143   `(%def-reffer ',name ,offset ,lowtag))
144 (defmacro def-setter (name offset lowtag)
145   `(%def-setter ',name ,offset ,lowtag))
146 (defmacro def-alloc (name words alloc-style header lowtag inits)
147   `(%def-alloc ',name ,words ,alloc-style ,header ,lowtag ,inits))
148 #!+compare-and-swap-vops
149 (defmacro def-casser (name offset lowtag)
150   `(%def-casser ',name ,offset ,lowtag))
151 ;;; KLUDGE: The %DEF-FOO functions used to implement the macros here
152 ;;; are defined later in another file, since they use structure slot
153 ;;; setters defined later, and we can't have physical forward
154 ;;; references to structure slot setters because ANSI in its wisdom
155 ;;; allows the xc host CL to implement structure slot setters as SETF
156 ;;; expanders instead of SETF functions. -- WHN 2002-02-09
157 \f
158 ;;;; some general constant definitions
159
160 ;;; FIXME: SC-NUMBER-LIMIT should probably be exported from SB!C
161 ;;; or SB!VM so that we don't need to do this extra IN-PACKAGE.
162 (in-package "SB!C")
163
164 ;;; the maximum number of SCs in any implementation
165 (def!constant sc-number-limit 32)
166 \f
167 ;;; Modular functions
168
169 ;;; For a documentation, see CUT-TO-WIDTH.
170
171 (defstruct modular-class
172   ;; hash: name -> { :GOOD | optimizer | ({modular-fun-info}*)}
173   (funs (make-hash-table :test 'eq))
174   ;; hash: modular-variant -> (prototype width)
175   ;;
176   ;; FIXME: Reimplement with generic function names of kind
177   ;; (MODULAR-VERSION prototype width)
178   (versions (make-hash-table :test 'eq))
179   ;; list of increasing widths + signedps
180   (widths nil))
181 (defvar *untagged-unsigned-modular-class* (make-modular-class))
182 (defvar *untagged-signed-modular-class* (make-modular-class))
183 (defvar *tagged-modular-class* (make-modular-class))
184 (defun find-modular-class (kind signedp)
185   (ecase kind
186     (:untagged
187      (ecase signedp
188        ((nil) *untagged-unsigned-modular-class*)
189        ((t) *untagged-signed-modular-class*)))
190     (:tagged
191      (aver signedp)
192      *tagged-modular-class*)))
193
194 (defstruct modular-fun-info
195   (name (missing-arg) :type symbol)
196   (width (missing-arg) :type (integer 0))
197   (signedp (missing-arg) :type boolean)
198   (lambda-list (missing-arg) :type list)
199   (prototype (missing-arg) :type symbol))
200
201 (defun find-modular-version (fun-name kind signedp width)
202   (let ((infos (gethash fun-name (modular-class-funs (find-modular-class kind signedp)))))
203     (if (listp infos)
204         (find-if (lambda (mfi)
205                    (aver (eq (modular-fun-info-signedp mfi) signedp))
206                    (>= (modular-fun-info-width mfi) width))
207                  infos)
208         infos)))
209
210 ;;; Return (VALUES prototype-name width)
211 (defun modular-version-info (name kind signedp)
212   (values-list (gethash name (modular-class-versions (find-modular-class kind signedp)))))
213
214 (defun %define-modular-fun (name lambda-list prototype kind signedp width)
215   (let* ((class (find-modular-class kind signedp))
216          (funs (modular-class-funs class))
217          (versions (modular-class-versions class))
218          (infos (the list (gethash prototype funs)))
219          (info (find-if (lambda (mfi)
220                           (and (eq (modular-fun-info-signedp mfi) signedp)
221                                (= (modular-fun-info-width mfi) width)))
222                         infos)))
223     (if info
224         (unless (and (eq name (modular-fun-info-name info))
225                      (= (length lambda-list)
226                         (length (modular-fun-info-lambda-list info))))
227           (setf (modular-fun-info-name info) name)
228           (style-warn "Redefining modular version ~S of ~S for ~
229                        ~:[un~;~]signed width ~S."
230                       name prototype signedp width))
231         (setf (gethash prototype funs)
232               (merge 'list
233                      (list (make-modular-fun-info :name name
234                                                   :width width
235                                                   :signedp signedp
236                                                   :lambda-list lambda-list
237                                                   :prototype prototype))
238                      infos
239                      #'< :key #'modular-fun-info-width)
240               (gethash name versions)
241               (list prototype width)))
242     (setf (modular-class-widths class)
243           (merge 'list (list (cons width signedp)) (modular-class-widths class)
244                  #'< :key #'car))))
245
246 (defmacro define-modular-fun (name lambda-list prototype kind signedp width)
247   (check-type name symbol)
248   (check-type prototype symbol)
249   (check-type kind (member :untagged :tagged))
250   (check-type width unsigned-byte)
251   (dolist (arg lambda-list)
252     (when (member arg sb!xc:lambda-list-keywords)
253       (error "Lambda list keyword ~S is not supported for ~
254               modular function lambda lists." arg)))
255   `(progn
256      (%define-modular-fun ',name ',lambda-list ',prototype ',kind ',signedp ,width)
257      (defknown ,name ,(mapcar (constantly 'integer) lambda-list)
258                (,(ecase signedp
259                    ((nil) 'unsigned-byte)
260                    ((t) 'signed-byte))
261                  ,width)
262                (foldable flushable movable)
263                :derive-type (make-modular-fun-type-deriver
264                              ',prototype ',kind ,width ',signedp))))
265
266 (defun %define-good-modular-fun (name kind signedp)
267   (setf (gethash name (modular-class-funs (find-modular-class kind signedp))) :good)
268   name)
269
270 (defmacro define-good-modular-fun (name kind signedp)
271   (check-type name symbol)
272   (check-type kind (member :untagged :tagged))
273   `(%define-good-modular-fun ',name ',kind ',signedp))
274
275 (defmacro define-modular-fun-optimizer
276     (name ((&rest lambda-list) kind signedp &key (width (gensym "WIDTH")))
277      &body body)
278   (check-type name symbol)
279   (check-type kind (member :untagged :tagged))
280   (dolist (arg lambda-list)
281     (when (member arg sb!xc:lambda-list-keywords)
282       (error "Lambda list keyword ~S is not supported for ~
283               modular function lambda lists." arg)))
284   (with-unique-names (call args)
285     `(setf (gethash ',name (modular-class-funs (find-modular-class ',kind ',signedp)))
286            (lambda (,call ,width)
287              (declare (type basic-combination ,call)
288                       (type (integer 0) ,width))
289              (let ((,args (basic-combination-args ,call)))
290                (when (= (length ,args) ,(length lambda-list))
291                  (destructuring-bind ,lambda-list ,args
292                    (declare (type lvar ,@lambda-list))
293                    ,@body)))))))