source: trunk/ccl/compiler/arch.lisp @ 5445

Last change on this file since 5445 was 5445, checked in by gb, 13 years ago

type-errors (as encoded in UUOs) are now in the range 128-255, rather than 64-127;
more are defined.

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