0.pre7.20:
[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 length 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   (length 1 :type fixnum)
44   (options nil :type list))
45
46 (def!struct (primitive-object (:make-load-form-fun just-dump-it-normally))
47   (name nil :type symbol)
48   (header nil :type symbol)
49   (lowtag nil :type symbol)
50   (options nil :type list)
51   (slots nil :type list)
52   (size 0 :type fixnum)
53   (variable-length nil :type (member t nil)))
54
55 (defvar *primitive-objects* nil)
56
57 (defun %define-primitive-object (primobj)
58   (let ((name (primitive-object-name primobj)))
59     (setf *primitive-objects*
60           (cons primobj
61                 (remove name *primitive-objects*
62                         :key #'primitive-object-name :test #'eq)))
63     name))
64
65 (defmacro define-primitive-object
66           ((name &key header lowtag alloc-trans (type t))
67            &rest slot-specs)
68   (collect ((slots) (exports) (constants) (forms) (inits))
69     (let ((offset (if header 1 0))
70           (variable-length nil))
71       (dolist (spec slot-specs)
72         (when variable-length
73           (error "No more slots can follow a :rest-p slot."))
74         (destructuring-bind
75             (slot-name &rest options
76                        &key docs rest-p (length (if rest-p 0 1))
77                        ((:type slot-type) t) init
78                        (ref-known nil ref-known-p) ref-trans
79                        (set-known nil set-known-p) set-trans
80                        &allow-other-keys)
81             (if (atom spec) (list spec) spec)
82           (slots (make-slot slot-name docs rest-p offset length
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 `(defconstant ,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 init
104             (inits (cons init offset)))
105           (when rest-p
106             (setf variable-length t))
107           (incf offset length)))
108       (unless variable-length
109         (let ((size (symbolicate name "-SIZE")))
110           (constants `(defconstant ,size ,offset
111                         ,(format nil
112                                  "Number of slots used by each ~S~
113                                   ~@[~* including the header~]."
114                                  name header)))
115           (exports size)))
116       (when alloc-trans
117         (forms `(def-alloc ,alloc-trans ,offset ,variable-length ,header
118                            ,lowtag ',(inits))))
119       `(progn
120          (eval-when (:compile-toplevel :load-toplevel :execute)
121            (%define-primitive-object
122             ',(make-primitive-object :name name
123                                      :header header
124                                      :lowtag lowtag
125                                      :slots (slots)
126                                      :size offset
127                                      :variable-length variable-length))
128            ,@(constants))
129          ,@(forms)))))
130 \f
131 ;;;; stuff for defining reffers and setters
132
133 (in-package "SB!C")
134
135 (defun %def-reffer (name offset lowtag)
136   (let ((info (function-info-or-lose name)))
137     (setf (function-info-ir2-convert info)
138           #'(lambda (node block)
139               (ir2-convert-reffer node block name offset lowtag))))
140   name)
141
142 (defmacro def-reffer (name offset lowtag)
143   `(%def-reffer ',name ,offset ,lowtag))
144
145 (defun %def-setter (name offset lowtag)
146   (let ((info (function-info-or-lose name)))
147     (setf (function-info-ir2-convert info)
148           (if (listp name)
149               #'(lambda (node block)
150                   (ir2-convert-setfer node block name offset lowtag))
151               #'(lambda (node block)
152                   (ir2-convert-setter node block name offset lowtag)))))
153   name)
154
155 (defmacro def-setter (name offset lowtag)
156   `(%def-setter ',name ,offset ,lowtag))
157
158 (defun %def-alloc (name words variable-length header lowtag inits)
159   (let ((info (function-info-or-lose name)))
160     (setf (function-info-ir2-convert info)
161           (if variable-length
162               #'(lambda (node block)
163                   (ir2-convert-variable-allocation node block name words header
164                                                    lowtag inits))
165               #'(lambda (node block)
166                   (ir2-convert-fixed-allocation node block name words header
167                                                 lowtag inits)))))
168   name)
169
170 (defmacro def-alloc (name words variable-length header lowtag inits)
171   `(%def-alloc ',name ,words ,variable-length ,header ,lowtag ,inits))
172 \f
173 ;;;; some general constant definitions
174
175 ;;; FIXME: SC-NUMBER-LIMIT should probably be exported from SB!C
176 ;;; or SB!VM so that we don't need to do this extra IN-PACKAGE.
177 (in-package "SB!C")
178
179 ;;; the maximum number of SCs in any implementation
180 (defconstant sc-number-limit 32)