source: branches/working-0711/ccl/compiler/arch.lisp @ 11164

Last change on this file since 11164 was 11164, checked in by gz, 12 years ago

Another batch of changes from the trunk, some bug fixes, optimizations, as well as formatting unification

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.4 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(eval-when (:compile-toplevel :load-toplevel :execute)
69  (defconstant error-type-error 128)
70)
71
72(defconstant error-fpu-exception-double 1024)   ; FPU exception, binary double-float op
73(defconstant error-fpu-exception-single 1025)
74
75(defconstant error-memory-full 2048)
76
77;; These are now supposed to match (mod ERROR-TYPE-ERROR) the %type-error-typespecs%
78;; array that %err-disp looks at.
79(ccl::defenum (:start  error-type-error :prefix "ERROR-OBJECT-NOT-")
80  array
81  bignum
82  fixnum
83  character
84  integer
85  list
86  number
87  sequence
88  simple-string
89  simple-vector
90  string
91  symbol
92  macptr
93  real
94  cons
95  unsigned-byte
96  radix
97  float 
98  rational
99  ratio
100  short-float
101  double-float
102  complex
103  vector
104  simple-base-string
105  function
106  unsigned-byte-16
107  unsigned-byte-8
108  unsigned-byte-32
109  signed-byte-32
110  signed-byte-16
111  signed-byte-8
112  base-char
113  bit
114  unsigned-byte-24
115  unsigned-byte-64
116  signed-byte-64
117  unsigned-byte-56
118  simple-array-double-float-2d
119  simple-array-single-float-2d
120  mod-char-code-limit
121  array-2d
122  array-3d
123  array-t
124  array-bit
125  array-s8
126  array-u8
127  array-s16
128  array-u16
129  array-s32
130  array-u32
131  array-s64
132  array-u64
133  array-fixnum
134  array-single-float
135  array-double-float
136  array-char
137  array-t-2d
138  array-bit-2d
139  array-s8-2d
140  array-u8-2d
141  array-s16-2d
142  array-u16-2d
143  array-s32-2d
144  array-u32-2d
145  array-s64-2d
146  array-u64-2d
147  array-fixnum-2d
148  array-single-float-2d
149  array-double-float-2d
150  array-char-2d
151  simple-array-t-2d
152  simple-array-bit-2d
153  simple-array-s8-2d
154  simple-array-u8-2d
155  simple-array-s16-2d
156  simple-array-u16-2d
157  simple-array-s32-2d
158  simple-array-u32-2d
159  simple-array-s64-2d
160  simple-array-u64-2d
161  simple-array-fixnum-2d
162  simple-array-char-2d
163  array-t-3d
164  array-bit-3d
165  array-s8-3d
166  array-u8-3d
167  array-s16-3d
168  array-u16-3d
169  array-s32-3d
170  array-u32-3d
171  array-s64-3d
172  array-u64-3d
173  array-fixnum-3d
174  array-single-float-3d
175  array-double-float-3d
176  array-char-3d
177  simple-array-t-3d
178  simple-array-bit-3d
179  simple-array-s8-3d
180  simple-array-u8-3d
181  simple-array-s16-3d
182  simple-array-u16-3d
183  simple-array-s32-3d
184  simple-array-u32-3d
185  simple-array-s64-3d
186  simple-array-u64-3d
187  simple-array-fixnum-3d
188  simple-array-single-float-3d
189  simple-array-double-float-3d
190  simple-array-char-3d
191
192  ;; Sentinel
193  unused-max-type-error
194  )
195
196(assert (<= error-object-not-unused-max-type-error (* 2 error-type-error)))
197
198
199
200
201
202(defun builtin-function-name-offset (name)
203  (and name (position name ccl::%builtin-functions% :test #'eq)))
204
205(ccl::defenum ()
206  storage-class-lisp                    ; General lisp objects
207  storage-class-imm                     ; Fixnums, chars, NIL: not relocatable
208  storage-class-wordptr                 ; "Raw" (fixnum-tagged) pointers to stack,etc
209  storage-class-u8                      ; Unsigned, untagged, 8-bit objects
210  storage-class-s8                      ; Signed, untagged, 8-bit objects
211  storage-class-u16                     ; Unsigned, untagged, 16-bit objects
212  storage-class-s16                     ; Signed, untagged, 16-bit objects
213  storage-class-u32                     ; Unsigned, untagged, 8-bit objects
214  storage-class-s32                     ; Signed, untagged, 8-bit objects
215  storage-class-address                 ; "raw" (untagged) 32-bit addresses.
216  storage-class-single-float            ; 32-bit single-float objects
217  storage-class-double-float            ; 64-bit double-float objects
218  storage-class-pc                      ; pointer to/into code vector
219  storage-class-locative                ; pointer to/into node-misc object
220  storage-class-crf                     ; condition register field
221  storage-class-crbit                   ; condition register bit: 0-31
222  storage-class-crfbit                  ; bit within condition register field : 0-3
223  storage-class-u64                     ; (unsigned-byte 64)
224  storage-class-s64                     ; (signed-byte 64)
225)
226
227
228(defvar *known-target-archs* ())
229
230(defstruct (target-arch (:conc-name target-)
231                        (:constructor %make-target-arch))
232  (name nil)
233  (lisp-node-size 0)
234  (nil-value 0)
235  (fixnum-shift 0)
236  (most-positive-fixnum 0)
237  (most-negative-fixnum 0)
238  (misc-data-offset 0)
239  (misc-dfloat-offset 0)
240  (nbits-in-word 0)
241  (ntagbits 0)
242  (nlisptagbits 0)
243  (uvector-subtags 0)
244  (max-64-bit-constant-index 0)
245  (max-32-bit-constant-index 0)
246  (max-16-bit-constant-index 0)
247  (max-8-bit-constant-index 0)
248  (max-1-bit-constant-index 0)
249  (word-shift 0)
250  (code-vector-prefix ())
251  (gvector-types ())
252  (1-bit-ivector-types ())
253  (8-bit-ivector-types ())
254  (16-bit-ivector-types ())
255  (32-bit-ivector-types ())
256  (64-bit-ivector-types ())
257  (array-type-name-from-ctype-function ())
258  (package-name ())
259  (t-offset ())
260  (array-data-size-function ())
261  (numeric-type-name-to-typecode-function ())
262  (subprims-base ())
263  (subprims-shift ())
264  (subprims-table ())
265  (primitive->subprims ())
266  (unbound-marker-value ())
267  (slot-unbound-marker-value ())
268  (fixnum-tag 0)
269  (single-float-tag nil)
270  (single-float-tag-is-subtag nil)
271  (double-float-tag nil)
272  (cons-tag nil)
273  (null-tag nil)
274  (symbol-tag nil)
275  (symbol-tag-is-subtag nil)
276  (function-tag nil)
277  (function-tag-is-subtag nil)
278  (big-endian t)
279  (target-macros (make-hash-table :test #'eq))
280  (misc-subtag-offset 0)
281  (car-offset 0)
282  (cdr-offset 0)
283  (subtag-char 0)
284  (charcode-shift 0)
285  (fulltagmask 0)
286  (fulltag-misc 0)
287  (char-code-limit nil))
288 
289
290 
291 
292 
293(defun make-target-arch (&rest keys)
294  (declare (dynamic-extent keys))
295  (let* ((arch (apply #'%make-target-arch keys))
296         (tail (member (target-name arch) *known-target-archs*
297                       :key #'target-name
298                       :test #'eq)))
299    (if tail
300      (rplaca tail arch)
301      (push arch *known-target-archs*))
302    arch))
303
304(defun find-target-arch (name)
305  (car (member name *known-target-archs*
306               :key #'target-name
307               :test #'eq)))
308
309(defun target-arch-macros (arch-name)
310  (let* ((arch (or (find-target-arch arch-name)
311                   (error "unknown arch: ~s" arch-name))))
312    (target-target-macros arch)))
313
314(defmacro defarchmacro (arch-name name arglist &body body &environment env)
315  (let* ((lambda-form (ccl::parse-macro-1 name arglist body env)))
316    `(progn
317      (setf (gethash ',name (target-arch-macros ',arch-name))
318       (ccl::nfunction ,name ,lambda-form))
319      ',name)))
320
321(defun arch-macro-function (arch-name name)
322  (gethash name (target-arch-macros arch-name)))
323   
324
325
326;;; GC related operations
327(defconstant gc-trap-function-immediate-gc -1)
328(defconstant gc-trap-function-gc 0)
329(defconstant gc-trap-function-purify 1)
330(defconstant gc-trap-function-impurify 2)
331(defconstant gc-trap-function-save-application 8)
332(defconstant gc-trap-function-get-lisp-heap-threshold 16)
333(defconstant gc-trap-function-set-lisp-heap-threshold 17)
334(defconstant gc-trap-function-use-lisp-heap-threshold 18)
335(defconstant gc-trap-function-egc-control 32)
336(defconstant gc-trap-function-configure-egc 64)
337(defconstant gc-trap-function-set-hons-area-size 128)
338(defconstant gc-trap-function-freeze 129)
339(defconstant gc-trap-function-thaw 130)
340
341
342
343(provide "ARCH")
Note: See TracBrowser for help on using the repository browser.