vm-macs.lisp 8.02 KB
Newer Older
ram's avatar
ram committed
1
2
3
;;; -*- Package: VM -*-
;;;
;;; **********************************************************************
ram's avatar
ram committed
4
5
6
7
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
8
  "$Header: src/compiler/generic/vm-macs.lisp $")
ram's avatar
ram committed
9
;;;
ram's avatar
ram committed
10
11
12
13
14
15
16
17
;;; **********************************************************************
;;;
;;;    This file contains some macros and constants that are object-format
;;; specific or are used for defining the object format.
;;;
;;; Written by William Lott and Christopher Hoover.
;;; 
(in-package "VM")
18
(intl:textdomain "cmucl")
ram's avatar
ram committed
19

chiles's avatar
   
chiles committed
20
21
22
23
24
25
26
27
28


;;;; Other random stuff.

;;; PAD-DATA-BLOCK -- Internal Interface.
;;;
;;; This returns a form that returns a dual-word aligned number of bytes when
;;; given a number of words.
;;;
ram's avatar
ram committed
29
(defmacro pad-data-block (words)
cwang's avatar
cwang committed
30
31
  `(logandc2 (+ (ash ,words word-shift) #+amd64 15 #-amd64 lowtag-mask)
    #+amd64 15 #-amd64 lowtag-mask))
ram's avatar
ram committed
32

chiles's avatar
   
chiles committed
33
34
;;; DEFENUM -- Internal Interface.
;;;
ram's avatar
ram committed
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1))
		   &rest identifiers)
  (let ((results nil)
	(index 0)
	(start (eval start))
	(step (eval step)))
    (dolist (id identifiers)
      (when id
	(multiple-value-bind
	    (root docs)
	    (if (consp id)
		(values (car id) (cdr id))
		(values id nil))
	  (push `(defconstant ,(intern (concatenate 'simple-string
						    (string prefix)
						    (string root)
						    (string suffix)))
		   ,(+ start (* step index))
		   ,@docs)
		results)))
      (incf index))
    `(eval-when (compile load eval)
       ,@(nreverse results))))

59
60
61

;;;; Primitive object definition stuff.

62
63
64
65
66
(export '(primitive-object primitive-object-p
	  primitive-object-name primitive-object-header
	  primitive-object-lowtag primitive-object-options
	  primitive-object-slots primitive-object-size
	  primitive-object-variable-length slot-name slot-docs slot-rest-p
toy's avatar
toy committed
67
	  slot-offset slot-length slot-options *primitive-objects*))
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

(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)))))

(defstruct (prim-object-slot
	    (:conc-name slot-)
	    (:constructor make-slot (name docs rest-p offset length options))
	    (:make-load-form-fun :just-dump-it-normally))
  (name nil :type symbol)
  (docs nil :type (or null simple-string))
  (rest-p nil :type (member t nil))
  (offset 0 :type fixnum)
  (length 1 :type fixnum)
  (options nil :type list))

(defstruct (primitive-object
	    (:make-load-form-fun :just-dump-it-normally))
  (name nil :type symbol)
  (header nil :type symbol)
  (lowtag nil :type symbol)
  (options nil :type list)
  (slots nil :type list)
  (size 0 :type fixnum)
  (variable-length nil :type (member t nil)))


(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))


(defmacro define-primitive-object
	  ((name &key header lowtag alloc-trans (type t))
	   &rest slot-specs)
  (collect ((slots) (exports) (constants) (forms) (inits))
    (let ((offset (if header 1 0))
	  (variable-length nil))
      (dolist (spec slot-specs)
	(when variable-length
119
	  (error (intl:gettext "No more slots can follow a :rest-p slot.")))
120
121
	(destructuring-bind
	    (slot-name &rest options
122
		       &key docs rest-p (length (if rest-p 0 1))
123
		       ((:type slot-type) t) init
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
		       (ref-known nil ref-known-p) ref-trans
		       (set-known nil set-known-p) set-trans
		       &allow-other-keys)
	    (if (atom spec) (list spec) spec)
	  (slots (make-slot slot-name docs rest-p offset length
			    (remove-keywords options
					     '(:docs :rest-p :length))))
	  (let ((offset-sym (symbolicate name "-" slot-name
					 (if rest-p "-OFFSET" "-SLOT"))))
	    (constants `(defconstant ,offset-sym ,offset
			  ,@(when docs (list docs))))
	    (exports offset-sym))
	  (when ref-trans
	    (when ref-known-p
	      (forms `(defknown ,ref-trans (,type) ,slot-type ,ref-known)))
	    (forms `(def-reffer ,ref-trans ,offset ,lowtag)))
	  (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)))
	  (when init
	    (inits (cons init offset)))
	  (when rest-p
	    (setf variable-length t))
	  (incf offset length)))
      (unless variable-length
	(let ((size (symbolicate name "-SIZE")))
	  (constants `(defconstant ,size ,offset
			,(format nil
158
159
				 (intl:gettext "Number of slots used by each ~S~
				  ~@[~* including the header~].")
160
161
162
163
164
165
166
				 name header)))
	  (exports size)))
      (when alloc-trans
	(forms `(def-alloc ,alloc-trans ,offset ,variable-length ,header
			   ,lowtag ',(inits))))
      `(progn
	 (eval-when (compile load eval)
Raymond Toy's avatar
Raymond Toy committed
167
	   (export ',(exports))
168
169
170
171
172
173
174
175
176
177
	   (%define-primitive-object
	    ',(make-primitive-object :name name
				     :header header
				     :lowtag lowtag
				     :slots (slots)
				     :size offset
				     :variable-length variable-length))
	   ,@(constants))
	 ,@(forms)))))

chiles's avatar
   
chiles committed
178

ram's avatar
ram committed
179

180
;;;; reffer and setter definition stuff.
ram's avatar
ram committed
181

182
183
184
185
186
(in-package :c)

(export '(def-reffer def-setter def-alloc))

(defun %def-reffer (name offset lowtag)
187
188
189
  (let ((info (function-info-or-lose name)))
    (setf (function-info-ir2-convert info)
	  #'(lambda (node block)
ram's avatar
ram committed
190
	      (ir2-convert-reffer node block name offset lowtag))))
191
192
193
194
195
196
  name)

(defmacro def-reffer (name offset lowtag)
  `(%def-reffer ',name ,offset ,lowtag))

(defun %def-setter (name offset lowtag)
197
198
199
200
201
202
  (let ((info (function-info-or-lose name)))
    (setf (function-info-ir2-convert info)
	  (if (listp name)
	      #'(lambda (node block)
		  (ir2-convert-setfer node block name offset lowtag))
	      #'(lambda (node block)
ram's avatar
ram committed
203
		  (ir2-convert-setter node block name offset lowtag)))))
204
205
206
207
208
209
  name)

(defmacro def-setter (name offset lowtag)
  `(%def-setter ',name ,offset ,lowtag))

(defun %def-alloc (name words variable-length header lowtag inits)
210
211
212
213
214
215
216
217
  (let ((info (function-info-or-lose name)))
    (setf (function-info-ir2-convert info)
	  (if variable-length
	      #'(lambda (node block)
		  (ir2-convert-variable-allocation node block name words header
						   lowtag inits))
	      #'(lambda (node block)
		  (ir2-convert-fixed-allocation node block name words header
ram's avatar
ram committed
218
						lowtag inits)))))
219
220
221
222
223
224
225
  name)

(defmacro def-alloc (name words variable-length header lowtag inits)
  `(%def-alloc ',name ,words ,variable-length ,header ,lowtag ,inits))


;;;; Some general constant definitions:
ram's avatar
ram committed
226
227
228
229
230
231

(in-package "C")

(export '(fasl-file-implementations
	  pmax-fasl-file-implementation
	  sparc-fasl-file-implementation
ram's avatar
ram committed
232
	  rt-fasl-file-implementation
233
	  rt-afpa-fasl-file-implementation
wlott's avatar
wlott committed
234
	  x86-fasl-file-implementation
235
236
	  hppa-fasl-file-implementation
	  big-endian-fasl-file-implementation
hallgren's avatar
hallgren committed
237
	  little-endian-fasl-file-implementation
hallgren's avatar
hallgren committed
238
	  alpha-fasl-file-implementation
239
	  sgi-fasl-file-implementation
cwang's avatar
cwang committed
240
241
	  ppc-fasl-file-implementation
	  amd64-fasl-file-implementation))
ram's avatar
ram committed
242
243
244
245

;;; Constants for the different implementations.  These are all defined in
;;; one place to make sure they are all unique.

246
(defparameter fasl-file-implementations
ram's avatar
ram committed
247
  '(nil "Pmax" "Sparc" "RT" "RT/AFPA" "x86" "HPPA"
cwang's avatar
cwang committed
248
	"Big-endian byte-code" "Little-endian byte-code" "Alpha" "SGI" "PPC" "AMD64"))
ram's avatar
ram committed
249
250
251
(defconstant pmax-fasl-file-implementation 1)
(defconstant sparc-fasl-file-implementation 2)
(defconstant rt-fasl-file-implementation 3)
ram's avatar
ram committed
252
(defconstant rt-afpa-fasl-file-implementation 4)
253
(defconstant x86-fasl-file-implementation 5)
wlott's avatar
wlott committed
254
(defconstant hppa-fasl-file-implementation 6)
255
256
(defconstant big-endian-fasl-file-implementation 7)
(defconstant little-endian-fasl-file-implementation 8)
hallgren's avatar
hallgren committed
257
(defconstant alpha-fasl-file-implementation 9)
hallgren's avatar
hallgren committed
258
(defconstant sgi-fasl-file-implementation 10)
259
(defconstant ppc-fasl-file-implementation 11)
cwang's avatar
cwang committed
260
(defconstant amd64-fasl-file-implementation 12)
ram's avatar
ram committed
261
262
263

;;; The maximum number of SCs in any implementation.
(defconstant sc-number-limit 32)