source: trunk/source/compiler/arch.lisp @ 16085

Last change on this file since 16085 was 16085, checked in by gb, 5 years ago

First attempt to merge acode-rewrite branch into trunk.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.1 KB
Line 
1;;;-*- Mode: Lisp; Package: (ARCH :use CL) -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(defpackage "ARCH"
19  (:use "CL"))
20
21(in-package "ARCH")
22
23
24
25(eval-when (:compile-toplevel :load-toplevel :execute)
26
27
28
29(defconstant tcr-flag-bit-foreign 0)
30(defconstant tcr-flag-bit-awaiting-preset 1)
31(defconstant tcr-flag-bit-alt-suspend 2)
32(defconstant tcr-flag-bit-propagate-exception 3)
33(defconstant tcr-flag-bit-suspend-ack-pending 4)
34(defconstant tcr-flag-bit-pending-exception 5)
35(defconstant tcr-flag-bit-foreign-exception 6)
36(defconstant tcr-flag-bit-pending-suspend 7)       
37
38
39
40)
41
42(defmacro make-vheader (element-count subtag)
43  `(logior ,subtag (ash ,element-count 8)))
44
45
46
47;;; Error numbers, as used in UU0s and such.
48;;; These match constants defined in the kernel sources.
49(defconstant error-reg-regnum 0)        ; "real" error number is in RB field of UU0.
50                                        ; Currently only used for :errchk in emulated traps
51                                        ; The errchk macro should expand into a check-trap-error vinsn, too.
52(defconstant error-udf 1)               ; Undefined function (reported by symbol-function)
53(defconstant error-udf-call 2)          ; Attempt to call undefined function
54(defconstant error-throw-tag-missing 3)
55(defconstant error-alloc-failed 4)      ; can't allocate (largish) vector
56(defconstant error-stack-overflow 5)    ; some stack overflowed.
57(defconstant error-excised-function-call 6)     ; excised function was called.
58(defconstant error-too-many-values 7)   ; too many values returned
59(defconstant error-cant-take-car 8)
60(defconstant error-cant-take-cdr 9)
61(defconstant error-propagate-suspend 10)
62(defconstant error-interrupt 11)
63(defconstant error-suspend 12)
64(defconstant error-suspend-all 13)
65(defconstant error-resume 14)
66(defconstant error-resume-all 15)
67(defconstant error-kill 16)
68(defconstant error-cant-call 17)        ; Attempt to funcall something that is not a symbol or function.
69(defconstant error-allocate-list 18)
70(defconstant error-allocation-disabled 19)
71
72(eval-when (:compile-toplevel :load-toplevel :execute)
73  (defconstant error-type-error 128)
74)
75
76
77(defconstant error-fpu-exception-double 1024)   ; FPU exception, binary double-float op
78(defconstant error-fpu-exception-single 1025)
79
80(defconstant error-memory-full 2048)
81
82;; These are now supposed to match (mod ERROR-TYPE-ERROR) the %type-error-typespecs%
83;; array that %err-disp looks at.
84(ccl::defenum (:start  error-type-error :prefix "ERROR-OBJECT-NOT-")
85  array
86  bignum
87  fixnum
88  character
89  integer
90  list
91  number
92  sequence
93  simple-string
94  simple-vector
95  string
96  symbol
97  macptr
98  real
99  cons
100  unsigned-byte
101  radix
102  float 
103  rational
104  ratio
105  short-float
106  double-float
107  complex
108  vector
109  simple-base-string
110  function
111  unsigned-byte-16
112  unsigned-byte-8
113  unsigned-byte-32
114  signed-byte-32
115  signed-byte-16
116  signed-byte-8
117  base-char
118  bit
119  unsigned-byte-24
120  unsigned-byte-64
121  signed-byte-64
122  unsigned-byte-56
123  simple-array-double-float-2d
124  simple-array-single-float-2d
125  mod-char-code-limit
126  array-2d
127  array-3d
128  array-t
129  array-bit
130  array-s8
131  array-u8
132  array-s16
133  array-u16
134  array-s32
135  array-u32
136  array-s64
137  array-u64
138  array-fixnum
139  array-single-float
140  array-double-float
141  array-char
142  array-t-2d
143  array-bit-2d
144  array-s8-2d
145  array-u8-2d
146  array-s16-2d
147  array-u16-2d
148  array-s32-2d
149  array-u32-2d
150  array-s64-2d
151  array-u64-2d
152  array-fixnum-2d
153  array-single-float-2d
154  array-double-float-2d
155  array-char-2d
156  simple-array-t-2d
157  simple-array-bit-2d
158  simple-array-s8-2d
159  simple-array-u8-2d
160  simple-array-s16-2d
161  simple-array-u16-2d
162  simple-array-s32-2d
163  simple-array-u32-2d
164  simple-array-s64-2d
165  simple-array-u64-2d
166  simple-array-fixnum-2d
167  simple-array-char-2d
168  array-t-3d
169  array-bit-3d
170  array-s8-3d
171  array-u8-3d
172  array-s16-3d
173  array-u16-3d
174  array-s32-3d
175  array-u32-3d
176  array-s64-3d
177  array-u64-3d
178  array-fixnum-3d
179  array-single-float-3d
180  array-double-float-3d
181  array-char-3d
182  simple-array-t-3d
183  simple-array-bit-3d
184  simple-array-s8-3d
185  simple-array-u8-3d
186  simple-array-s16-3d
187  simple-array-u16-3d
188  simple-array-s32-3d
189  simple-array-u32-3d
190  simple-array-s64-3d
191  simple-array-u64-3d
192  simple-array-fixnum-3d
193  simple-array-single-float-3d
194  simple-array-double-float-3d
195  simple-array-char-3d
196
197  ;;
198  vector-t
199  bit-vector
200  vector-s8
201  vector-u8
202  vector-s16
203  vector-u16
204  vector-s32
205  vector-u32
206  vector-s64
207  vector-u64
208  vector-fixnum
209  vector-single-float
210  vector-double-float
211 
212  ;; Sentinel
213  unused-max-type-error
214  )
215
216(assert (<= error-object-not-unused-max-type-error (* 2 error-type-error)))
217
218
219
220
221
222(defun builtin-function-name-offset (name)
223  (and name (position name ccl::%builtin-functions% :test #'eq)))
224
225(ccl::defenum ()
226  storage-class-lisp                    ; General lisp objects
227  storage-class-imm                     ; Fixnums, chars, NIL: not relocatable
228  storage-class-wordptr                 ; "Raw" (fixnum-tagged) pointers to stack,etc
229  storage-class-u8                      ; Unsigned, untagged, 8-bit objects
230  storage-class-s8                      ; Signed, untagged, 8-bit objects
231  storage-class-u16                     ; Unsigned, untagged, 16-bit objects
232  storage-class-s16                     ; Signed, untagged, 16-bit objects
233  storage-class-u32                     ; Unsigned, untagged, 8-bit objects
234  storage-class-s32                     ; Signed, untagged, 8-bit objects
235  storage-class-address                 ; "raw" (untagged) 32-bit addresses.
236  storage-class-single-float            ; 32-bit single-float objects
237  storage-class-double-float            ; 64-bit double-float objects
238  storage-class-pc                      ; pointer to/into code vector
239  storage-class-locative                ; pointer to/into node-misc object
240  storage-class-crf                     ; condition register field
241  storage-class-crbit                   ; condition register bit: 0-31
242  storage-class-crfbit                  ; bit within condition register field : 0-3
243  storage-class-u64                     ; (unsigned-byte 64)
244  storage-class-s64                     ; (signed-byte 64)
245  storage-class-complex-double-float
246  storage-class-complex-single-float
247)
248
249
250(defvar *known-target-archs* ())
251
252(defstruct (target-arch (:conc-name target-)
253                        (:constructor %make-target-arch))
254  (name nil)
255  (lisp-node-size 0)
256  (nil-value 0)
257  (fixnum-shift 0)
258  (most-positive-fixnum 0)
259  (most-negative-fixnum 0)
260  (misc-data-offset 0)
261  (misc-dfloat-offset 0)
262  (nbits-in-word 0)
263  (ntagbits 0)
264  (nlisptagbits 0)
265  (uvector-subtags 0)
266  (max-64-bit-constant-index 0)
267  (max-32-bit-constant-index 0)
268  (max-16-bit-constant-index 0)
269  (max-8-bit-constant-index 0)
270  (max-1-bit-constant-index 0)
271  (word-shift 0)
272  (code-vector-prefix ())
273  (gvector-types ())
274  (1-bit-ivector-types ())
275  (8-bit-ivector-types ())
276  (16-bit-ivector-types ())
277  (32-bit-ivector-types ())
278  (64-bit-ivector-types ())
279  (array-type-name-from-ctype-function ())
280  (package-name ())
281  (t-offset ())
282  (array-data-size-function ())
283  fpr-mask-function
284  (subprims-base ())
285  (subprims-shift ())
286  (subprims-table ())
287  (primitive->subprims ())
288  (unbound-marker-value ())
289  (slot-unbound-marker-value ())
290  (fixnum-tag 0)
291  (single-float-tag nil)
292  (single-float-tag-is-subtag nil)
293  (double-float-tag nil)
294  (cons-tag nil)
295  (null-tag nil)
296  (symbol-tag nil)
297  (symbol-tag-is-subtag nil)
298  (function-tag nil)
299  (function-tag-is-subtag nil)
300  (big-endian t)
301  (target-macros (make-hash-table :test #'eq))
302  (misc-subtag-offset 0)
303  (car-offset 0)
304  (cdr-offset 0)
305  (subtag-char 0)
306  (charcode-shift 0)
307  (fulltagmask 0)
308  (fulltag-misc 0)
309  (char-code-limit nil))
310 
311
312 
313 
314 
315(defun make-target-arch (&rest keys)
316  (declare (dynamic-extent keys))
317  (let* ((arch (apply #'%make-target-arch keys))
318         (tail (member (target-name arch) *known-target-archs*
319                       :key #'target-name
320                       :test #'eq)))
321    (if tail
322      (rplaca tail arch)
323      (push arch *known-target-archs*))
324    arch))
325
326(defun find-target-arch (name)
327  (car (member name *known-target-archs*
328               :key #'target-name
329               :test #'eq)))
330
331(defun target-arch-macros (arch-name)
332  (let* ((arch (or (find-target-arch arch-name)
333                   (error "unknown arch: ~s" arch-name))))
334    (target-target-macros arch)))
335
336(defmacro defarchmacro (arch-name name arglist &body body &environment env)
337  (let* ((lambda-form (ccl::parse-macro-1 name arglist body env)))
338    `(progn
339      (setf (gethash ',name (target-arch-macros ',arch-name))
340       (ccl::nfunction ,name ,lambda-form))
341      ',name)))
342
343(defun arch-macro-function (arch-name name)
344  (gethash name (target-arch-macros arch-name)))
345   
346
347
348;;; GC related operations
349(defconstant gc-trap-function-immediate-gc -1)
350(defconstant gc-trap-function-gc 0)
351(defconstant gc-trap-function-purify 1)
352(defconstant gc-trap-function-impurify 2)
353(defconstant gc-trap-function-flash-freeze 4)
354(defconstant gc-trap-function-save-application 8)
355(defconstant gc-trap-function-get-lisp-heap-threshold 16)
356(defconstant gc-trap-function-set-lisp-heap-threshold 17)
357(defconstant gc-trap-function-use-lisp-heap-threshold 18)
358(defconstant gc-trap-function-ensure-static-conses 19)
359(defconstant gc-trap-function-get-gc-notification-threshold 20)
360(defconstant gc-trap-function-set-gc-notification-threshold 21)
361(defconstant gc-trap-function-allocation-control 22)
362(defconstant gc-trap-function-egc-control 32)
363(defconstant gc-trap-function-configure-egc 64)
364(defconstant gc-trap-function-freeze 129)
365(defconstant gc-trap-function-thaw 130)
366
367(defconstant watch-trap-function-watch 0)
368(defconstant watch-trap-function-unwatch 1)
369
370(provide "ARCH")
Note: See TracBrowser for help on using the repository browser.