source: trunk/source/compiler/nxenv.lisp @ 11384

Last change on this file since 11384 was 11384, checked in by gb, 11 years ago

When incrementing/propagating a variable's assignment/reference
counts, increment the VAR-REFS slot as well. (Separate instances of
inherited lexical variables are represented as separate per-function
VARs in which the child references the parent via the VAR-BITS slot
and information about "the variable as a whole, in all functions that
reference/set it" is maintained in the parent's VAR-BITS. Keeping
reference-count info per function (and not sharing structure so much)
should give us a clearer idea of which inherited variables are good
candidates for register allocation. (Until now, we've tended to
overestimate the number of times a variable's referenced in the
parent, since the shared ref info includes references from inner
functions, and have avoided NVR allocation in the child (because
that has updated shared info and confused things in the parent.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 33.9 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 operator-side-effect-free-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 . #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask))
307     (%double-float--2 .  #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask))
308     (%double-float*-2 .  #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask))
309     (%double-float/-2 .  #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask))
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 .  #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask))
319     (%short-float--2 .  #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask))
320     (%short-float*-2 .  #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask))
321     (%short-float/-2 .  #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask))
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     (i386-ff-call . 0)
371     (i386-syscall . 0))))
372
373(defmacro %nx1-operator (sym)
374  (let ((op (assq sym *next-nx-operators*)))
375    (if op (logior (%cdr op) (length (%cdr (memq op *next-nx-operators*))))
376        (error "Bug - operator not found for ~S" sym))))
377
378(declaim (special *nx1-alphatizers* *nx1-operators*))
379
380(defmacro %nx1-default-operator ()
381 #-bccl
382 `(nx1-default-operator)
383 #+bccl
384 `(gethash *nx-sfname* *nx1-operators*))
385
386(defmacro defnx1 (name sym arglist &body forms)
387  (let ((fn `(nfunction ,name ,(parse-macro name arglist forms)))
388        (theprogn ())
389        (ysym (gensym)))
390    `(let ((,ysym ,fn))
391       ,(if (symbolp sym)
392          `(progn
393             (setf (gethash ',sym *nx1-alphatizers*) ,ysym)
394             ;(proclaim '(inline ,sym))
395             (pushnew ',sym *nx1-compiler-special-forms*))
396          (dolist (x sym `(progn ,@(nreverse theprogn)))
397            (if (consp x)
398              (setq x (%car x))
399              (push `(pushnew ',x *nx1-compiler-special-forms*) theprogn))
400            ;(push `(proclaim '(inline ,x)) theprogn)
401            (push `(setf (gethash ',x *nx1-alphatizers*) ,ysym) theprogn)))
402       (record-source-file ',name 'function)
403       ,ysym)))
404
405(defmacro next-nx-num-ops ()
406  (length *next-nx-operators*))
407
408(defmacro next-nx-defops (&aux (ops (gensym)) 
409                                (num (gensym)) 
410                                (flags (gensym)) 
411                                (op (gensym)))
412  `(let ((,num ,(length *next-nx-operators*)) 
413         (,ops ',*next-nx-operators*) 
414         (,flags nil)
415         (,op nil))
416     (while ,ops
417       (setq ,op (%car ,ops)  ,flags (cdr ,op))
418       (setf (gethash (car ,op) *nx1-operators*) 
419             (logior ,flags (setq ,num (%i- ,num 1))))
420       (setq ,ops (cdr ,ops)))))
421
422(defconstant $fbitnextmethargsp 0)
423(defconstant $fbitmethodp 1)
424(defconstant $fbitnextmethp 2)
425(defconstant $fbitnoregs 3)
426(defconstant $fbitdownward 4)
427(defconstant $fbitresident 5)
428(defconstant $fbitbounddownward 6)
429(defconstant $fbitembeddedlap 7)
430(defconstant $fbitruntimedef 8)
431(defconstant $fbitnonnullenv 9)
432(defconstant $fbitccoverage 10)
433
434(defconstant $eaclosedbit 24)
435
436#+what?
437(progn
438;;; condition codes :
439;;; These are 68K condition code values, but the frontend uses them and
440;;; both backends need to understand them.
441;;; They're really backend-specific; it wouldn't hurt to have the frontend
442;;; use a more "neutral" representation.
443(defconstant $ccT 0)
444(defconstant $ccEQ 7)
445(defconstant $ccNE 6)
446(defconstant $ccVC 8)
447(defconstant $ccMI 11)
448(defconstant $ccPL 10)
449(defconstant $ccGE 12)
450(defconstant $ccLT 13)
451(defconstant $ccGT 14)
452(defconstant $ccLE 15)
453)
454
455
456(defmacro %temp-push (value place &environment env)
457  (if (not (consp place))
458    `(setq ,place (%temp-cons ,value ,place))
459    (multiple-value-bind (dummies vals store-var setter getter)
460                         (get-setf-expansion place env)
461      (let ((valvar (gensym)))
462        `(let* ((,valvar ,value)
463                ,@(mapcar #'list dummies vals)
464                (,(car store-var) (%temp-cons ,valvar ,getter)))
465           ,@dummies
466           ,(car store-var)
467           ,setter)))))
468
469; undo tokens :
470
471(defconstant $undocatch 0)  ; do some nthrowing
472(defconstant $undovalues 1) ; flush pending multiple values
473(defconstant $undostkblk 2) ; discard "variable stack block"
474(defconstant $undospecial 3) ; restore dynamic binding
475(defconstant $undointerruptlevel 4) ; restore dynamic binding of *interrupt-level*
476(defconstant $undomvexpect 5) ; stop expecting values
477(defconstant $undoregs 6)   ; allocated regs when dynamic extent var bound.
478
479; Stuff having to do with lisp:
480
481(defmacro make-acode (operator &rest args)
482  `(%temp-list ,operator ,@args))
483
484(defmacro make-acode* (operator &rest args)
485  `(%temp-cons ,operator (mapcar #'nx1-form ,@args)))
486
487; More Bootstrapping Shit.
488(defmacro acode-operator (form)
489  ; Gak.
490  `(%car ,form))
491
492(defmacro acode-operand (n form)
493  ; Gak. Gak.
494  `(nth ,n (the list ,form)))
495
496(defmacro acode-p (x)
497  " A big help this is ..."
498  `(consp ,x))
499
500
501(defmacro defnxdecl (sym lambda-list &body forms)
502  (multiple-value-bind (body decls) (parse-body forms nil t)
503    `(setf (getf *nx-standard-declaration-handlers* ',sym )
504           (function (lambda ,lambda-list
505                       ,@decls
506                       ,@body)))))
507
508(defmacro with-declarations ((pending new-env-var &optional old-env) &body body)
509  `(let* ((,pending (make-pending-declarations))
510          (,new-env-var (new-lexical-environment ,old-env)))
511     ,@body))
512
513(defmacro with-nx-declarations ((pending) &body body)
514  `(let* ((*nx-new-p2decls* nil)
515          (*nx-inlined-self* *nx-inlined-self*))
516    (with-declarations (,pending *nx-lexical-environment* *nx-lexical-environment*)
517      ,@body)))
518
519
520(eval-when (:compile-toplevel :load-toplevel :execute)
521
522(declaim (inline 
523          nx-decl-set-fbit
524          nx-adjust-setq-count
525          nx-init-var
526          nx1-sysnode
527          ))
528
529(defun nx-init-var (state node)
530  (let* ((sym (var-name node))
531         (env *nx-lexical-environment*)
532         (bits (%i+
533                (if (nx-proclaimed-special-p sym)
534                 (if (nx-proclaimed-parameter-p sym)
535                   (%ilogior (ash -1 $vbitspecial) (%ilsl $vbitparameter 1))
536                   (ash -1 $vbitspecial))
537                 0)
538                (if (proclaimed-ignore-p sym) (%ilsl $vbitignore 1) 0))))
539    (push node (lexenv.variables env))
540    (%temp-push node *nx-all-vars*)
541    (setf (var-binding-info node) *nx-bound-vars*)
542    (%temp-push node *nx-bound-vars*)
543    (dolist (decl (nx-effect-vdecls state sym env) (setf (var-bits node) bits))
544      (case (car decl)
545        (special (setq bits (%ilogior bits (ash -1 $vbitspecial) (%ilsl $vbitparameter 1))))
546        (ignore (setq bits (%ilogior bits (%ilsl $vbitignore 1))))
547        (ignore-if-unused (setq bits (%ilogior bits (%ilsl $vbitignoreunused 1))))
548        (dynamic-extent (setq bits (%ilogior bits (%ilsl $vbitdynamicextent 1))))))
549    node))
550
551(defun nx-decl-set-fbit (bit)
552  (when *nx-parsing-lambda-decls*
553    (let* ((afunc *nx-current-function*))
554      (setf (afunc-bits afunc)
555            (%ilogior (%ilsl bit 1)
556                      (afunc-bits afunc))))))
557
558(defun nx-adjust-setq-count (var &optional (by 1) catchp)
559  (let* ((bits (nx-var-bits var))
560         (scaled-by (if (%ilogbitp $vbittemporary bits)
561                      by
562                      (expt 4 *nx-loop-nesting-level*)))
563         (new (%i+ (%ilsr 8 (%ilogand2 $vsetqmask bits)) scaled-by)))
564    (if (%i> new 255) (setq new 255))
565    (setq bits (nx-set-var-bits var (%ilogior (%ilogand (%ilognot $vsetqmask) bits) (%ilsl 8 new))))
566    ;; If a variable is setq'ed from a catch nested within the construct that
567    ;; bound it, it can't be allocated to a register. *
568    ;; * unless it can be proved that the variable isn't referenced
569    ;;   after that catch construct has been exited. **
570    ;; ** or unless the saved value of the register in the catch frame
571    ;;    is also updated.
572    (when catchp
573      (nx-set-var-bits var (%ilogior2 bits (%ilsl $vbitnoreg 1))))
574    (setf (var-refs var) (+ (the fixnum (var-refs var)) by))
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.