source: branches/gz-working/compiler/nxenv.lisp @ 8505

Last change on this file since 8505 was 8505, checked in by gz, 13 years ago

checkpoint work in progress, mainly some final cleanup, reorg, don't try to track atoms, keep track of source through transforms; reporting implementation in library;cover.lisp

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