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

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

Type errors for 2d float arrays.

  • 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  simple-array-double-float-2d
107  simple-array-single-float-2d
108  )
109
110
111
112
113
114(defun builtin-function-name-offset (name)
115  (and name (position name ccl::%builtin-functions% :test #'eq)))
116
117(ccl::defenum ()
118  storage-class-lisp                    ; General lisp objects
119  storage-class-imm                     ; Fixnums, chars, NIL: not relocatable
120  storage-class-wordptr                 ; "Raw" (fixnum-tagged) pointers to stack,etc
121  storage-class-u8                      ; Unsigned, untagged, 8-bit objects
122  storage-class-s8                      ; Signed, untagged, 8-bit objects
123  storage-class-u16                     ; Unsigned, untagged, 16-bit objects
124  storage-class-s16                     ; Signed, untagged, 16-bit objects
125  storage-class-u32                     ; Unsigned, untagged, 8-bit objects
126  storage-class-s32                     ; Signed, untagged, 8-bit objects
127  storage-class-address                 ; "raw" (untagged) 32-bit addresses.
128  storage-class-single-float            ; 32-bit single-float objects
129  storage-class-double-float            ; 64-bit double-float objects
130  storage-class-pc                      ; pointer to/into code vector
131  storage-class-locative                ; pointer to/into node-misc object
132  storage-class-crf                     ; condition register field
133  storage-class-crbit                   ; condition register bit: 0-31
134  storage-class-crfbit                  ; bit within condition register field : 0-3
135  storage-class-u64                     ; (unsigned-byte 64)
136  storage-class-s64                     ; (signed-byte 64)
137)
138
139
140(defvar *known-target-archs* ())
141
142(defstruct (target-arch (:conc-name target-)
143                        (:constructor %make-target-arch))
144  (name nil)
145  (lisp-node-size 0)
146  (nil-value 0)
147  (fixnum-shift 0)
148  (most-positive-fixnum 0)
149  (most-negative-fixnum 0)
150  (misc-data-offset 0)
151  (misc-dfloat-offset 0)
152  (nbits-in-word 0)
153  (ntagbits 0)
154  (nlisptagbits 0)
155  (uvector-subtags 0)
156  (max-64-bit-constant-index 0)
157  (max-32-bit-constant-index 0)
158  (max-16-bit-constant-index 0)
159  (max-8-bit-constant-index 0)
160  (max-1-bit-constant-index 0)
161  (word-shift 0)
162  (code-vector-prefix ())
163  (gvector-types ())
164  (1-bit-ivector-types ())
165  (8-bit-ivector-types ())
166  (16-bit-ivector-types ())
167  (32-bit-ivector-types ())
168  (64-bit-ivector-types ())
169  (array-type-name-from-ctype-function ())
170  (package-name ())
171  (t-offset ())
172  (array-data-size-function ())
173  (numeric-type-name-to-typecode-function ())
174  (subprims-base ())
175  (subprims-shift ())
176  (subprims-table ())
177  (primitive->subprims ())
178  (unbound-marker-value ())
179  (slot-unbound-marker-value ())
180  (fixnum-tag 0)
181  (single-float-tag nil)
182  (single-float-tag-is-subtag nil)
183  (double-float-tag nil)
184  (cons-tag nil)
185  (null-tag nil)
186  (symbol-tag nil)
187  (symbol-tag-is-subtag nil)
188  (function-tag nil)
189  (function-tag-is-subtag nil)
190  (big-endian t)
191  (target-macros (make-hash-table :test #'eq))
192  (misc-subtag-offset 0)
193  (car-offset 0)
194  (cdr-offset 0)
195  (subtag-char 0)
196  (charcode-shift 0)
197  (fulltagmask 0)
198  (fulltag-misc 0))
199 
200
201 
202 
203 
204(defun make-target-arch (&rest keys)
205  (declare (dynamic-extent keys))
206  (let* ((arch (apply #'%make-target-arch keys))
207         (tail (member (target-name arch) *known-target-archs*
208                       :key #'target-name
209                       :test #'eq)))
210    (if tail
211      (rplaca tail arch)
212      (push arch *known-target-archs*))
213    arch))
214
215(defun find-target-arch (name)
216  (car (member name *known-target-archs*
217               :key #'target-name
218               :test #'eq)))
219
220(defun target-arch-macros (arch-name)
221  (let* ((arch (or (find-target-arch arch-name)
222                   (error "unknown arch: ~s" arch-name))))
223    (target-target-macros arch)))
224
225(defmacro defarchmacro (arch-name name arglist &body body &environment env)
226  (let* ((lambda-form (ccl::parse-macro-1 name arglist body env)))
227    `(progn
228      (setf (gethash ',name (target-arch-macros ',arch-name))
229       (ccl::nfunction ,name ,lambda-form))
230      ',name)))
231
232(defun arch-macro-function (arch-name name)
233  (gethash name (target-arch-macros arch-name)))
234   
235
236
237;;; GC related operations
238(defconstant gc-trap-function-immediate-gc -1)
239(defconstant gc-trap-function-gc 0)
240(defconstant gc-trap-function-purify 1)
241(defconstant gc-trap-function-impurify 2)
242(defconstant gc-trap-function-save-application 8)
243(defconstant gc-trap-function-get-lisp-heap-threshold 16)
244(defconstant gc-trap-function-set-lisp-heap-threshold 17)
245(defconstant gc-trap-function-use-lisp-heap-threshold 18)
246(defconstant gc-trap-function-egc-control 32)
247(defconstant gc-trap-function-configure-egc 64)
248(defconstant gc-trap-function-set-hons-area-size 128)
249
250
251(provide "ARCH")
Note: See TracBrowser for help on using the repository browser.