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

Last change on this file since 4101 was 4101, checked in by gb, 15 years ago

OPERAND, OPCODE belong elsewhere (in RISC-LAP, for instance). That's
a different package, too.

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