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

Last change on this file since 16611 was 16611, checked in by gb, 6 years ago

handle LOAD-TIME-VALUE differently.
In the COMPILE (EVAL) case, wrap the literal (immediate) in new acode.
make ACODE-CONSTANT-P recognize the COMPILE-FILE case, and return NIl,NIL
Fixes ticket:1317 in the trunk

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