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

Last change on this file since 13280 was 13280, checked in by gb, 10 years ago

Lots of changes from "purify" branch, mostly involving:

  • new memory layout, to support x86 function purification, static cons
  • fasloader changes to load/save string constants faster

Fasl version, image version changed; new binaries for all platforms soon.

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