source: branches/1.2-devel/ccl/compiler/nxenv.lisp @ 15278

Last change on this file since 15278 was 6176, checked in by gb, 13 years ago

Operators of %SINGLE-FLOAT, %DOUBLE-FLOAT.

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