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

Last change on this file since 11522 was 11522, checked in by gb, 12 years ago

PPC support for FLASH-FREEZE, which is like FREEZE without forcing
GC.

Incidentally, ensure that GC-related functions (things called via
the gc_like_from_xp() mechanism) return signed_natural results, not
just ints. (I think that in most cases the return values are currently
ignored, but they shouldn't be truncated to 32 bits, just in case something
uses them.)

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