source: branches/ia32/compiler/nxenv.lisp @ 7708

Last change on this file since 7708 was 7708, checked in by rme, 13 years ago

Add nx operator i386-ff-call and x862 stub.

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