source: branches/working-0711/ccl/compiler/nxenv.lisp @ 11164

Last change on this file since 11164 was 11164, checked in by gz, 11 years ago

Another batch of changes from the trunk, some bug fixes, optimizations, as well as formatting unification

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