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

Last change on this file since 14807 was 14807, checked in by gb, 8 years ago

Define and export the functions ALLOW-HEAP-ALLOCATION and
HEAP-ALLOCATION-ALLOWED-P and the condition type ALLOCATION-DISABLED.

(ALLOW-HEAP-ALLOCATION arg) : when ARG is NIL, causes any subsequent
attempts to heap-allocate lisp memory to signal (as if by CERROR)
an ALLOCATION-DISABLED condition. (Allocaton is enabled globally at
the point where the error is signaled.) Continuing from the CERROR
restarts the allocation attempt.

This is intended to help verify that code that's not expected to
cons doesn't do so.

(This is only implemented on the ARM at the moment, but the intent
is that it be supported on all platforms.)

Note that calling (ALLOW-HEAP-ALLOCATION NIL) in the REPL CERRORs
immediately, since the REPL will cons to create the new value of CL:/.

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