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.
18 ;;;; other miscellaneous stuff
20 ;;; This returns a form that returns a dual-word aligned number of bytes when
21 ;;; given a number of words.
23 ;;; FIXME: should be a function
24 ;;; FIXME: should be called PAD-DATA-BLOCK-SIZE
25 (defmacro pad-data-block (words)
26 `(logandc2 (+ (ash ,words word-shift) lowtag-mask) lowtag-mask))
28 ;;;; primitive object definition stuff
30 (defun remove-keywords (options keywords)
31 (cond ((null options) nil)
32 ((member (car options) keywords)
33 (remove-keywords (cddr options) keywords))
35 (list* (car options) (cadr options)
36 (remove-keywords (cddr options) keywords)))))
38 (def!struct (prim-object-slot
39 (:constructor make-slot (name docs rest-p offset length options))
40 (:make-load-form-fun just-dump-it-normally)
42 (name nil :type symbol)
43 (docs nil :type (or null simple-string))
44 (rest-p nil :type (member t nil))
45 (offset 0 :type fixnum)
46 (length 1 :type fixnum)
47 (options nil :type list))
49 (def!struct (primitive-object (:make-load-form-fun just-dump-it-normally))
50 (name nil :type symbol)
51 (header nil :type symbol)
52 (lowtag nil :type symbol)
53 (options nil :type list)
54 (slots nil :type list)
56 (variable-length nil :type (member t nil)))
58 (defvar *primitive-objects* nil)
60 (defun %define-primitive-object (primobj)
61 (let ((name (primitive-object-name primobj)))
62 (setf *primitive-objects*
64 (remove name *primitive-objects*
65 :key #'primitive-object-name :test #'eq)))
68 (defmacro define-primitive-object
69 ((name &key header lowtag alloc-trans (type t))
71 (collect ((slots) (exports) (constants) (forms) (inits))
72 (let ((offset (if header 1 0))
73 (variable-length nil))
74 (dolist (spec slot-specs)
76 (error "No more slots can follow a :rest-p slot."))
78 (slot-name &rest options
79 &key docs rest-p (length (if rest-p 0 1))
80 ((:type slot-type) t) init
81 (ref-known nil ref-known-p) ref-trans
82 (set-known nil set-known-p) set-trans
84 (if (atom spec) (list spec) spec)
85 (slots (make-slot slot-name docs rest-p offset length
86 (remove-keywords options
87 '(:docs :rest-p :length))))
88 (let ((offset-sym (symbolicate name "-" slot-name
89 (if rest-p "-OFFSET" "-SLOT"))))
90 (constants `(defconstant ,offset-sym ,offset
91 ,@(when docs (list docs))))
95 (forms `(defknown ,ref-trans (,type) ,slot-type ,ref-known)))
96 (forms `(def-reffer ,ref-trans ,offset ,lowtag)))
99 (forms `(defknown ,set-trans
100 ,(if (listp set-trans)
101 (list slot-type type)
102 (list type slot-type))
105 (forms `(def-setter ,set-trans ,offset ,lowtag)))
107 (inits (cons init offset)))
109 (setf variable-length t))
110 (incf offset length)))
111 (unless variable-length
112 (let ((size (symbolicate name "-SIZE")))
113 (constants `(defconstant ,size ,offset
115 "Number of slots used by each ~S~
116 ~@[~* including the header~]."
120 (forms `(def-alloc ,alloc-trans ,offset ,variable-length ,header
123 (let ((sb!int::*rogue-export* "DEFINE-PRIMITIVE-OBJECT"))
124 (export ',(exports)))
125 (eval-when (:compile-toplevel :load-toplevel :execute)
126 (%define-primitive-object
127 ',(make-primitive-object :name name
132 :variable-length variable-length))
136 ;;;; stuff for defining reffers and setters
140 (defun %def-reffer (name offset lowtag)
141 (let ((info (function-info-or-lose name)))
142 (setf (function-info-ir2-convert info)
143 #'(lambda (node block)
144 (ir2-convert-reffer node block name offset lowtag))))
147 (defmacro def-reffer (name offset lowtag)
148 `(%def-reffer ',name ,offset ,lowtag))
150 (defun %def-setter (name offset lowtag)
151 (let ((info (function-info-or-lose name)))
152 (setf (function-info-ir2-convert info)
154 #'(lambda (node block)
155 (ir2-convert-setfer node block name offset lowtag))
156 #'(lambda (node block)
157 (ir2-convert-setter node block name offset lowtag)))))
160 (defmacro def-setter (name offset lowtag)
161 `(%def-setter ',name ,offset ,lowtag))
163 (defun %def-alloc (name words variable-length header lowtag inits)
164 (let ((info (function-info-or-lose name)))
165 (setf (function-info-ir2-convert info)
167 #'(lambda (node block)
168 (ir2-convert-variable-allocation node block name words header
170 #'(lambda (node block)
171 (ir2-convert-fixed-allocation node block name words header
175 (defmacro def-alloc (name words variable-length header lowtag inits)
176 `(%def-alloc ',name ,words ,variable-length ,header ,lowtag ,inits))
178 ;;;; some general constant definitions
180 ;;; FIXME: SC-NUMBER-LIMIT should probably be exported from SB!C
181 ;;; or SB!VM so that we don't need to do this extra IN-PACKAGE.
184 ;;; the maximum number of SCs in any implementation
185 (defconstant sc-number-limit 32)