source: branches/arm/compiler/nxenv.lisp @ 13741

Last change on this file since 13741 was 13067, checked in by rme, 10 years ago

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 34.3 KB
Line 
1;;; -*- Mode: Lisp; Package: CCL -*-
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
19;;; Compile-time environment for the compiler.
20
21
22(in-package "CCL")
23
24(eval-when (:execute :compile-toplevel)
25  (require'backquote)
26  (require 'lispequ)
27)
28
29#-bootstrapped
30(eval-when (:compile-toplevel :load-toplevel :execute)
31  (when (and (macro-function 'var-decls)
32             (not (macro-function 'var-ref-forms)))
33    (setf (macro-function 'var-ref-forms)
34          (macro-function 'var-decls))))
35
36#+ppc-target (require "PPCENV")
37#+x8632-target (require "X8632ENV")
38#+x8664-target (require "X8664ENV")
39
40(defconstant $vbittemporary 16)    ; a compiler temporary
41(defconstant $vbitreg 17)          ; really wants to live in a register.
42(defconstant $vbitnoreg 18)        ; something inhibits register allocation
43(defconstant $vbitdynamicextent 19)
44(defconstant $vbitparameter 20)    ; iff special
45(defconstant $vbitpunted 20)       ; iff lexical
46(defconstant $vbitignoreunused 21)
47(defconstant $vbitignorable 21)
48(defconstant $vbitcloseddownward 22) 
49(defconstant $vbitsetq 23)
50(defconstant $vbitpuntable 24)
51(defconstant $vbitclosed 25)
52(defconstant $vbitignore 26)
53(defconstant $vbitreffed 27)
54(defconstant $vbitspecial 28)
55(defconstant $vsetqmask #xff00)
56(defconstant $vrefmask #xff)
57
58(defconstant $decl_optimize (%ilsl 16 0))  ; today's chuckle
59(defconstant $decl_tailcalls (ash 1 16))
60(defconstant $decl_opencodeinline (ash 4 16))
61(defconstant $decl_eventchk (ash 8 16))
62(defconstant $decl_unsafe (ash 16 16))
63(defconstant $decl_trustdecls (ash 32 16))
64(defconstant $decl_full_safety (ash 64 16))
65
66(defconstant $regnote-ea 1)
67
68(defmacro nx-null (x)
69 `(eq ,x *nx-nil*))
70
71(defmacro nx-t (x)
72 `(eq ,x *nx-t*))
73
74(eval-when (:compile-toplevel :load-toplevel :execute)
75
76  (defconstant operator-id-mask (1- (%ilsl 10 1)))
77  (defconstant operator-acode-subforms-bit 10)
78  (defconstant operator-acode-subforms-mask (%ilsl operator-acode-subforms-bit 1))
79  (defconstant operator-acode-list-bit 11)
80  (defconstant operator-acode-list-mask (%ilsl operator-acode-list-bit 1))
81  (defconstant operator-side-effect-free-bit 12) ; operator is side-effect free; subforms may not be ...
82  (defconstant operator-side-effect-free-mask 
83    (%ilsl operator-side-effect-free-bit 1))
84  (defconstant operator-single-valued-bit 13)
85  (defconstant operator-single-valued-mask
86    (%ilsl operator-single-valued-bit 1))
87  (defconstant operator-assignment-free-bit 14)
88  (defconstant operator-assignment-free-mask
89    (%ilsl operator-assignment-free-bit 1))
90  (defconstant operator-cc-invertable-bit 15)
91  (defconstant operator-cc-invertable-mask (ash 1 operator-cc-invertable-bit))
92  (defconstant operator-boolean-bit 16)
93  (defconstant operator-boolean-mask (ash 1 operator-boolean-bit))
94  (defconstant operator-returns-address-bit 17)
95  (defconstant operator-returns-address-mask (ash 1 operator-returns-address-bit))
96
97  )
98
99(defparameter *next-nx-operators*
100  (reverse
101   '((%primitive . 0)
102     (progn . #.(logior operator-acode-list-mask operator-assignment-free-mask operator-side-effect-free-mask))
103     (not . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask))
104     (%i+ . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask))
105     (%i- . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask))
106     (cxxr . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask))
107     (%dfp-combine . 0)
108     (%ilsl . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask))
109     (%ilogand2 . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask))
110     (%ilogior2 . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask))
111     (%ilogbitp . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask))
112     (eq . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask))
113     (neq . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask))
114     (list . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-list-mask operator-side-effect-free-mask))
115     (values . #.(logior operator-acode-list-mask operator-assignment-free-mask operator-side-effect-free-mask))
116     (if . #.(logior operator-acode-subforms-mask operator-side-effect-free-mask))
117     (or . 0)
118     (without-interrupts . 0)
119     (%fixnum-ref . #.operator-single-valued-mask)
120     (%fixnum-ref-natural . #.operator-single-valued-mask)
121     (%current-tcr . #.operator-single-valued-mask)
122     (%stack-trap . #.operator-single-valued-mask)
123     (multiple-value-prog1 . 0)
124     (multiple-value-bind . 0)
125     (multiple-value-call . 0)
126     (put-xxx . #.operator-single-valued-mask)
127     (get-xxx . #.operator-single-valued-mask)
128     (typed-form . 0)
129     (let . 0)
130     (let* . 0)
131     (tag-label . 0)
132     (local-tagbody . #.operator-single-valued-mask)
133     (%fixnum-set-natural . #.operator-single-valued-mask)
134     (type-asserted-form . 0)
135     (spushp . #.operator-single-valued-mask)
136     (simple-function . #.operator-single-valued-mask)
137     (closed-function . #.operator-single-valued-mask)
138     (setq-lexical . #.operator-single-valued-mask)
139     (lexical-reference . #.(logior operator-assignment-free-mask operator-single-valued-mask))
140     (free-reference . #.(logior operator-assignment-free-mask operator-single-valued-mask))
141     (immediate . #.(logior operator-assignment-free-mask operator-single-valued-mask))
142     (fixnum . #.(logior operator-assignment-free-mask operator-single-valued-mask ))
143     (call . 0)
144     (local-go . 0)
145     (local-block . 0)
146     (local-return-from . 0)
147     (%car . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
148     (%cdr . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
149     (%rplaca . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
150     (%rplacd . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
151     (cons . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask))
152     (simple-typed-aref2 . #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask))
153     (setq-free . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
154     (prog1 . 0)
155     (catch . 0)
156     (throw . 0)
157     (unwind-protect . 0)
158     (characterp . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask))
159     (multiple-value-list . 0)
160     (%izerop . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask))
161     (%immediate-ptr-to-int . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
162     (%immediate-int-to-ptr . #.(logior operator-returns-address-mask operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
163     (immediate-get-xxx . 0)
164     (immediate-put-xxx . 0)
165     (setq-special . 0)
166     (special-ref . 0)
167     (1+ . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
168     (1- . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
169     (add2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
170     (sub2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
171     (numeric-comparison . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-cc-invertable-mask))
172     (numcmp . #.(logior operator-assignment-free-mask operator-acode-subforms-mask operator-single-valued-mask operator-cc-invertable-mask))
173     (struct-ref . 0)
174     (struct-set . 0)
175     (%aref1 . #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask operator-side-effect-free-mask))
176     (embedded-nlexit . 0)
177     (embedded-conditional . 0) 
178     (%word-to-int . #.(logior operator-assignment-free-mask operator-single-valued-mask))
179     (%svref . #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask))
180     (%svset . #.(logior operator-acode-subforms-mask operator-single-valued-mask))
181     (%consmacptr% . 0)
182     (%macptrptr% . 0)
183     (%ptr-eql . #.operator-cc-invertable-mask)
184     (%setf-macptr . 0)
185     (bound-special-ref . 0)
186     (%char-code . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
187     (%code-char . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
188     (lap . 0)
189     (lap-inline . 0)
190     (%function . #.operator-single-valued-mask)
191     (%valid-code-char . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
192     (%ttag . #.operator-single-valued-mask) 
193     (uvsize . #.operator-single-valued-mask)
194     (endp . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask))
195     (sequence-type . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask))
196     (fixnum-overflow . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
197     (vector . #.(logior operator-assignment-free-mask operator-single-valued-mask))
198     (%immediate-inc-ptr . #.(logior operator-returns-address-mask operator-single-valued-mask))
199     (general-aref3 . #.(logior operator-acode-subforms-mask operator-single-valued-mask))
200     (general-aset2 . #.(logior operator-acode-subforms-mask operator-single-valued-mask))
201     (%new-ptr . 0)
202     (%schar . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
203     (%set-schar . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) ;??
204     (debind . 0)
205     (lambda-bind . 0)
206     (general-aset3 . #.(logior operator-acode-subforms-mask operator-single-valued-mask))
207     (simple-typed-aref3 . #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask))
208     (simple-typed-aset3 . #.(logior operator-acode-subforms-mask  operator-single-valued-mask))
209     (nth-value . 0)
210     (progv . 0)
211     (svref . #.(logior operator-assignment-free-mask operator-single-valued-mask))
212     (svset . #.operator-single-valued-mask)
213     (make-list . #.(logior operator-assignment-free-mask operator-single-valued-mask)) ; exists only so we can stack-cons
214     (%badarg1 . 0)
215     (%badarg2 . 0)
216     (newblocktag . 0)
217     (newgotag . 0)
218     (flet . 0)                         ; may not be necessary - for dynamic-extent, mostly
219                                        ; for dynamic-extent, forward refs, etc.
220     (labels . 0)                       ; removes 75% of LABELS bogosity
221     (lexical-function-call . 0)        ; most of other 25%
222     (with-downward-closures . 0)
223     (self-call . 0)
224     (inherited-arg . #.operator-single-valued-mask)
225     (ff-call . 0)
226     (commutative-subprim-binop . 0)
227     (%immediate-set-xxx . #.(logior operator-acode-subforms-mask))
228     (symbol-name . #.(logior operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask))
229     (memq . #.(logior operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask))
230     (assq . #.(logior operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask))
231     (simple-typed-aset2 . #.(logior operator-acode-subforms-mask operator-single-valued-mask))
232     (consp . #.(logior operator-cc-invertable-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-boolean-mask))
233     (aset1 . #.(logior operator-acode-subforms-mask))
234     (syscall . 0)
235     (car . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
236     (cdr . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
237     (length . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
238     (list-length . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
239     (ensure-simple-string . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
240     (%ilsr . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
241     (set . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
242     (eql . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-boolean-mask))
243     (%iasr . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
244     (logand2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
245     (logior2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
246     (logxor2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
247     (%i<> . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask))
248     (set-car . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
249     (set-cdr . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
250     (rplaca . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
251     (rplacd . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
252     (with-variable-c-frame . #.(logior operator-acode-list-mask operator-assignment-free-mask))
253     (uvref . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
254     (uvset . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
255     (%temp-cons . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
256     (%temp-List . #.(logior operator-single-valued-mask operator-side-effect-free-mask))
257     (%make-uvector . #.(logior operator-assignment-free-mask operator-single-valued-mask  operator-side-effect-free-mask))
258     (%decls-body . 0)
259     (%old-gvector . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
260     (%typed-uvref . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
261     (%typed-uvset . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
262     (schar . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
263     (set-schar . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
264     (code-char . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
265     (char-code . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
266     (list* . #.(logior operator-assignment-free-mask operator-single-valued-mask  operator-side-effect-free-mask))
267     (append . #.(logior operator-assignment-free-mask operator-single-valued-mask  operator-side-effect-free-mask))
268     (symbolp . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-boolean-mask))
269     (integer-point-h . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
270     (integer-point-v . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
271     (int>0-p . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask))
272     (immediate-constant .  #.(logior operator-assignment-free-mask operator-single-valued-mask ))
273     (with-stack-double-floats . 0)
274     (short-float . #.operator-single-valued-mask)
275     (istruct-typep . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask))
276     (%ilogxor2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
277     (%err-disp . 0)
278     (%quo2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
279     (minus1 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
280     (%ineg . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
281     (%i* . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
282     (logbitp . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-boolean-mask))
283     (%sbchar . 0)
284     (%sechar . 0)
285     (%set-sbchar . 0)
286     (%scharcode . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
287     (%set-scharcode . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
288     (lambda-list . 0)
289     (ppc-lap-function . 0)
290     (lisptag . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
291     (fulltag . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
292     (typecode . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
293     (require-simple-vector . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
294     (require-simple-string . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
295     (require-integer . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
296     (require-fixnum . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
297     (require-real . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
298     (require-list . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
299     (require-character . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
300     (require-number . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
301     (require-symbol . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
302     (base-char-p . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask))
303     (%vect-subtype . #.operator-single-valued-mask)
304     (%unbound-marker . #.operator-single-valued-mask)
305     (%slot-unbound-marker . #.operator-single-valued-mask)
306     (%gvector . #.(logior operator-assignment-free-mask operator-single-valued-mask))
307     (immediate-get-ptr . #.operator-returns-address-mask)
308     (%lisp-word-ref . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
309     (%lisp-lowbyte-ref . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
310     (poweropen-ff-call . 0)
311     (double-float-compare . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask))
312     (builtin-call . 0)
313     (%setf-double-float . 0)
314     (%double-float+-2 . #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask))
315     (%double-float--2 .  #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask))
316     (%double-float*-2 .  #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask))
317     (%double-float/-2 .  #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask))
318     (%double-float+-2! . 0)
319     (%double-float--2! . 0)
320     (%double-float*-2! . 0)
321     (%double-float/-2! . 0)
322     (poweropen-syscall . 0)
323     (%debug-trap . 0)
324     (%%ineg . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
325     (%setf-short-float . 0)
326     (%short-float+-2 .  #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask))
327     (%short-float--2 .  #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask))
328     (%short-float*-2 .  #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask))
329     (%short-float/-2 .  #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask))
330     (short-float-compare . 0)
331     (eabi-ff-call . 0)
332     (%reference-external-entry-point . 0)
333     (eabi-syscall . 0)
334     (%get-bit . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
335     (%set-bit   . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
336     (%natural+ . 0)
337     (%natural- . 0)
338     (%natural-logand . 0)
339     (%natural-logior . 0)
340     (%natural-logxor . 0)
341     (%natural<> . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask))
342     (%get-double-float . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
343     (%get-single-float . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
344     (%set-double-float . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
345      (%set-single-float . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
346     (natural-shift-right  . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
347     (natural-shift-left  . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
348     (global-ref . 0)
349     (global-setq . 0)
350     (disable-interrupts . #.(logior operator-assignment-free-mask operator-single-valued-mask))
351
352     (%interrupt-poll  . #.(logior operator-assignment-free-mask operator-single-valued-mask))
353     (with-c-frame . #.(logior operator-acode-list-mask operator-assignment-free-mask operator-side-effect-free-mask))   
354     (%current-frame-ptr . 0)
355     (%slot-ref . 0)
356     (%illegal-marker . #.operator-single-valued-mask)
357     (%symbol->symptr . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
358     (%single-to-double  . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
359     (%double-to-single . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
360     (%symptr->symvector  . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
361     (%symvector->symptr  . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
362     (%foreign-stack-pointer . 0)
363     (mul2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
364     (div2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
365     (%fixnum-to-single  . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
366     (%fixnum-to-double .  #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
367     (require-s8 . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
368     (require-u8 . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
369     (require-s16 . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
370     (require-u16 . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
371     (require-s32 . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
372     (require-u32 . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
373     (require-s64 . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
374     (require-u64 . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
375     (general-aref2 .  #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask))
376     (%single-float .  #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask))
377     (%double-float . #. #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask))
378     (i386-ff-call . 0)
379     (i386-syscall . 0))))
380
381(defmacro %nx1-operator (sym)
382  (let ((op (assq sym *next-nx-operators*)))
383    (if op (logior (%cdr op) (length (%cdr (memq op *next-nx-operators*))))
384        (error "Bug - operator not found for ~S" sym))))
385
386(declaim (special *nx1-alphatizers* *nx1-operators*))
387
388(defmacro %nx1-default-operator ()
389 #-bccl
390 `(nx1-default-operator)
391 #+bccl
392 `(gethash *nx-sfname* *nx1-operators*))
393
394(defmacro defnx1 (name sym arglist &body forms)
395  (let ((fn `(nfunction ,name ,(parse-macro name arglist forms)))
396        (theprogn ())
397        (ysym (gensym)))
398    `(let ((,ysym ,fn))
399       ,(if (symbolp sym)
400          `(progn
401             (setf (gethash ',sym *nx1-alphatizers*) ,ysym)
402             ;(proclaim '(inline ,sym))
403             (pushnew ',sym *nx1-compiler-special-forms*))
404          (dolist (x sym `(progn ,@(nreverse theprogn)))
405            (if (consp x)
406              (setq x (%car x))
407              (push `(pushnew ',x *nx1-compiler-special-forms*) theprogn))
408            ;(push `(proclaim '(inline ,x)) theprogn)
409            (push `(setf (gethash ',x *nx1-alphatizers*) ,ysym) theprogn)))
410       (record-source-file ',name 'function)
411       ,ysym)))
412
413(defmacro next-nx-num-ops ()
414  (length *next-nx-operators*))
415
416(defmacro next-nx-defops (&aux (ops (gensym)) 
417                                (num (gensym)) 
418                                (flags (gensym)) 
419                                (op (gensym)))
420  `(let ((,num ,(length *next-nx-operators*)) 
421         (,ops ',*next-nx-operators*) 
422         (,flags nil)
423         (,op nil))
424     (while ,ops
425       (setq ,op (%car ,ops)  ,flags (cdr ,op))
426       (setf (gethash (car ,op) *nx1-operators*) 
427             (logior ,flags (setq ,num (%i- ,num 1))))
428       (setq ,ops (cdr ,ops)))))
429
430(defconstant $fbitnextmethargsp 0)
431(defconstant $fbitmethodp 1)
432(defconstant $fbitnextmethp 2)
433(defconstant $fbitnoregs 3)
434(defconstant $fbitdownward 4)
435(defconstant $fbitresident 5)
436(defconstant $fbitbounddownward 6)
437(defconstant $fbitembeddedlap 7)
438(defconstant $fbitruntimedef 8)
439(defconstant $fbitnonnullenv 9)
440(defconstant $fbitccoverage 10)
441
442(defconstant $eaclosedbit 24)
443
444#+what?
445(progn
446;;; condition codes :
447;;; These are 68K condition code values, but the frontend uses them and
448;;; both backends need to understand them.
449;;; They're really backend-specific; it wouldn't hurt to have the frontend
450;;; use a more "neutral" representation.
451(defconstant $ccT 0)
452(defconstant $ccEQ 7)
453(defconstant $ccNE 6)
454(defconstant $ccVC 8)
455(defconstant $ccMI 11)
456(defconstant $ccPL 10)
457(defconstant $ccGE 12)
458(defconstant $ccLT 13)
459(defconstant $ccGT 14)
460(defconstant $ccLE 15)
461)
462
463
464(defmacro %temp-push (value place &environment env)
465  (if (not (consp place))
466    `(setq ,place (%temp-cons ,value ,place))
467    (multiple-value-bind (dummies vals store-var setter getter)
468                         (get-setf-expansion place env)
469      (let ((valvar (gensym)))
470        `(let* ((,valvar ,value)
471                ,@(mapcar #'list dummies vals)
472                (,(car store-var) (%temp-cons ,valvar ,getter)))
473           ,@dummies
474           ,(car store-var)
475           ,setter)))))
476
477; undo tokens :
478
479(defconstant $undocatch 0)  ; do some nthrowing
480(defconstant $undovalues 1) ; flush pending multiple values
481(defconstant $undostkblk 2) ; discard "variable stack block"
482(defconstant $undospecial 3) ; restore dynamic binding
483(defconstant $undointerruptlevel 4) ; restore dynamic binding of *interrupt-level*
484(defconstant $undomvexpect 5) ; stop expecting values
485(defconstant $undoregs 6)   ; allocated regs when dynamic extent var bound.
486
487; Stuff having to do with lisp:
488
489(defmacro make-acode (operator &rest args)
490  `(%temp-list ,operator ,@args))
491
492(defmacro make-acode* (operator &rest args)
493  `(%temp-cons ,operator (mapcar #'nx1-form ,@args)))
494
495; More Bootstrapping Shit.
496(defmacro acode-operator (form)
497  ;; Gak.
498  `(%car ,form))
499
500(defmacro acode-operand (n form)
501  ;; Gak. Gak.
502  `(nth ,n (the list ,form)))
503
504(defmacro acode-operands (form)
505  ;; Gak. Gak. Gak.
506  `(%cdr ,form))
507
508(defmacro acode-p (x)
509  " A big help this is ..."
510  `(consp ,x))
511
512
513(defmacro defnxdecl (sym lambda-list &body forms)
514  (multiple-value-bind (body decls) (parse-body forms nil t)
515    `(setf (getf *nx-standard-declaration-handlers* ',sym )
516           (function (lambda ,lambda-list
517                       ,@decls
518                       ,@body)))))
519
520(defmacro with-declarations ((pending new-env-var &optional old-env) &body body)
521  `(let* ((,pending (make-pending-declarations))
522          (,new-env-var (new-lexical-environment ,old-env)))
523     ,@body))
524
525(defmacro with-nx-declarations ((pending) &body body)
526  `(let* ((*nx-new-p2decls* nil)
527          (*nx-inlined-self* *nx-inlined-self*))
528    (with-declarations (,pending *nx-lexical-environment* *nx-lexical-environment*)
529      ,@body)))
530
531
532(eval-when (:compile-toplevel :load-toplevel :execute)
533
534(declaim (inline 
535          nx-decl-set-fbit
536          nx-adjust-setq-count
537          nx-init-var
538          nx1-sysnode
539          ))
540
541(defun nx-init-var (state node)
542  (let* ((sym (var-name node))
543         (env *nx-lexical-environment*)
544         (bits (%i+
545                (if (nx-proclaimed-special-p sym)
546                 (if (nx-proclaimed-parameter-p sym)
547                   (%ilogior (ash -1 $vbitspecial) (%ilsl $vbitparameter 1))
548                   (ash -1 $vbitspecial))
549                 0)
550                (if (proclaimed-ignore-p sym) (%ilsl $vbitignore 1) 0))))
551    (push node (lexenv.variables env))
552    (%temp-push node *nx-all-vars*)
553    (setf (var-binding-info node) *nx-bound-vars*)
554    (%temp-push node *nx-bound-vars*)
555    (dolist (decl (nx-effect-vdecls state sym env) (setf (var-bits node) bits))
556      (case (car decl)
557        (special (setq bits (%ilogior bits (ash -1 $vbitspecial) (%ilsl $vbitparameter 1))))
558        (ignore (setq bits (%ilogior bits (%ilsl $vbitignore 1))))
559        ((ignorable ignore-if-unused) (setq bits (%ilogior bits (%ilsl $vbitignoreunused 1))))
560        (dynamic-extent (setq bits (%ilogior bits (%ilsl $vbitdynamicextent 1))))))
561    node))
562
563(defun nx-decl-set-fbit (bit)
564  (when *nx-parsing-lambda-decls*
565    (let* ((afunc *nx-current-function*))
566      (setf (afunc-bits afunc)
567            (%ilogior (%ilsl bit 1)
568                      (afunc-bits afunc))))))
569
570(defun nx-adjust-setq-count (var &optional (by 1) catchp)
571  (let* ((bits (nx-var-bits var))
572         (scaled-by (if (%ilogbitp $vbittemporary bits)
573                      by
574                      (expt 4 *nx-loop-nesting-level*)))
575         (new (%i+ (%ilsr 8 (%ilogand2 $vsetqmask bits)) scaled-by)))
576    (if (%i> new 255) (setq new 255))
577    (setq bits (nx-set-var-bits var (%ilogior (%ilogand (%ilognot $vsetqmask) bits) (%ilsl 8 new))))
578    ;; If a variable is setq'ed from a catch nested within the construct that
579    ;; bound it, it can't be allocated to a register. *
580    ;; * unless it can be proved that the variable isn't referenced
581    ;;   after that catch construct has been exited. **
582    ;; ** or unless the saved value of the register in the catch frame
583    ;;    is also updated.
584    (when catchp
585      (nx-set-var-bits var (%ilogior2 bits (%ilsl $vbitnoreg 1))))
586    (setf (var-refs var) (+ (the fixnum (var-refs var)) by))
587    new))
588
589
590(defun nx1-sysnode (form)
591  (if form
592    (if (eq form t)
593      *nx-t*)
594    *nx-nil*))
595)
596
597(defmacro make-mask (&rest weights)
598  `(logior ,@(mapcar #'(lambda (w) `(ash 1 ,w)) weights)))
599
600(provide "NXENV")
601
Note: See TracBrowser for help on using the repository browser.