3
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
5
;; This file is part of GNU Common Lisp, herein referred to as GCL
7
;; GCL is free software; you can redistribute it and/or modify it under
8
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
9
;; the Free Software Foundation; either version 2, or (at your option)
12
;; GCL is distributed in the hope that it will be useful, but WITHOUT
13
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
15
;; License for more details.
17
;; You should have received a copy of the GNU Library General Public License
18
;; along with GCL; see the file COPYING. If not, write to the Free Software
19
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
22
(in-package 'compiler)
24
(si:putprop 'var 'c2var 'c2)
25
(si:putprop 'location 'c2location 'c2)
26
(si:putprop 'setq 'c1setq 'c1special)
27
(si:putprop 'setq 'c2setq 'c2)
28
(si:putprop 'progv 'c1progv 'c1special)
29
(si:putprop 'progv 'c2progv 'c2)
30
(si:putprop 'psetq 'c1psetq 'c1)
31
(si:putprop 'psetq 'c2psetq 'c2)
33
(si:putprop 'var 'set-var 'set-loc)
34
(si:putprop 'var 'wt-var 'wt-loc)
37
name ;;; Variable name.
38
kind ;;; One of LEXICAL, SPECIAL, GLOBAL, REPLACED, FIXNUM,
39
;;; CHARACTER, LONG-FLOAT, SHORT-FLOAT, and OBJECT.
40
ref ;;; Referenced or not.
41
;;; During Pass1, T, NIL, or IGNORE.
42
;;; During Pass2, the vs-address for the variable.
43
ref-ccb ;;; Cross closure reference.
44
;;; During Pass1, T or NIL.
45
;;; During Pass2, the ccb-vs for the variable, or NIL.
46
loc ;;; For SPECIAL and GLOBAL, the vv-index for variable name.
47
;;; For others, this field is used to indicate whether
48
;;; to be allocated on the value-stack: OBJECT means
49
;;; the variable is declared as OBJECT, and CLB means
50
;;; the variable is referenced across Level Boundary and thus
51
;;; cannot be allocated on the C stack. Note that OBJECT is
52
;;; set during variable binding and CLB is set when the
53
;;; variable is used later, and therefore CLB may supersede
55
;;; For REPLACED, the actual location of the variable.
56
;;; For FIXNUM, CHARACTER, LONG-FLOAT, SHORT-FLOAT, and
57
;;; OBJECT, the cvar for the C variable that holds the value.
58
;;; Not used for LEXICAL.
59
(type t) ;;; Type of the variable.
60
(register 0) ;;; If greater than specified am't this goes into register.
63
;;; A special binding creates a var object with the kind field SPECIAL,
64
;;; whereas a special declaration without binding creates a var object with
65
;;; the kind field GLOBAL. Thus a reference to GLOBAL may need to make sure
66
;;; that the variable has a value.
69
(defvar *register-min* 4) ;criteria for putting in register.
70
(defvar *undefined-vars* nil)
71
(defvar *special-binding* nil)
73
;;; During Pass 1, *vars* holds a list of var objects and the symbols 'CB'
74
;;; (Closure Boundary) and 'LB' (Level Boundary). 'CB' will be pushed on
75
;;; *vars* when the compiler begins to process a closure. 'LB' will be pushed
76
;;; on *vars* when *level* is incremented.
77
;;; *GLOBALS* holds a list of var objects for those variables that are
78
;;; not defined. This list is used only to suppress duplicated warnings when
79
;;; undefined variables are detected.
81
(defun c1make-var (name specials ignores types &aux x)
82
(let ((var (make-var :name name)))
83
(cmpck (not (symbolp name)) "The variable ~s is not a symbol." name)
84
(cmpck (constantp name) "The constant ~s is being bound." name)
86
(cond ((or (member name specials) (si:specialp name))
87
(setf (var-kind var) 'SPECIAL)
88
(setf (var-loc var) (add-symbol name))
89
(cond ((setq x (assoc name types))
90
(setf (var-type var) (cdr x)))
91
((setq x (get name 'cmp-type))
92
(setf (var-type var) x)))
93
(setq *special-binding* t))
96
(cond ((eq (car v) name)
98
(object (setf (var-loc var) 'object))
100
(setf (var-register var)
101
(+ (var-register var) 100)))
102
(t (setf (var-type var) (cdr v)))))))
103
(and (boundp '*c-gc*) *c-gc*
104
(or (null (var-type var))
105
(eq t (var-type var)))
106
(setf (var-loc var) 'object))
107
(setf (var-kind var) 'LEXICAL)))
108
(let ((ign (member name ignores)))
110
(setf (var-ref var) (if (eq (cadr ign) 'ignorable) 'IGNORABLE 'IGNORE))))
114
(defun check-vref (var)
115
(when (and (eq (var-kind var) 'LEXICAL)
116
(not (var-ref var)) ;;; This field may be IGNORE.
117
(not (var-ref-ccb var)))
118
(cmpwarn "The variable ~s is not used." (var-name var))))
121
(let ((info (make-info))
122
(vref (c1vref name)))
123
(push-referred (car vref) info)
124
(setf (info-type info) (var-type (car vref)))
125
(list 'var info vref))
128
;;; A variable reference (vref for short) is a pair
129
;;; ( var-object ccb-reference )
131
(defun c1vref (name &aux (ccb nil) (clb nil))
132
(declare (object ccb clb))
134
(let ((var (sch-global name)))
136
(unless (si:specialp name) (undefined-variable name))
137
(setq var (make-var :name name
139
:loc (add-symbol name)
140
:type (or (get name 'cmp-type) t)
142
(push var *undefined-vars*))
144
(cond ((eq var 'cb) (setq ccb t))
145
((eq var 'lb) (setq clb t))
146
((eq (var-name var) name)
147
(when (eq (var-ref var) 'IGNORE)
148
(cmpwarn "The ignored variable ~s is used." name)
149
(setf (var-ref var) t))
150
(cond (ccb (setf (var-ref-ccb var) t))
151
(clb (when (eq (var-kind var) 'lexical)
152
(setf (var-loc var) 'clb))
153
(setf (var-ref var) t))
154
(t (setf (var-ref var) t)
155
(setf (var-register var)
156
(the fixnum (+ 1 (the fixnum (var-register var)))))
158
(return-from c1vref (list var ccb)))))
161
(defun c2var-kind (var)
162
(if (and (eq (var-kind var) 'LEXICAL)
163
(not (var-ref-ccb var))
164
(not (eq (var-loc var) 'clb)))
165
(if (eq (var-loc var) 'OBJECT)
167
(let ((type (var-type var)))
168
(declare (object type))
169
(cond ((type>= 'fixnum type) 'FIXNUM)
170
((type>= 'integer type) 'INTEGER)
171
((type>= 'CHARACTER type) 'CHARACTER)
172
((type>= 'long-float type) 'LONG-FLOAT)
173
((type>= 'short-float type) 'SHORT-FLOAT)
174
((and (boundp '*c-gc*) *c-gc* 'OBJECT))
179
(defun c2var (vref) (unwind-exit (cons 'var vref) nil 'single-value))
181
(defun c2location (loc) (unwind-exit loc nil 'single-value))
184
(defun check-downward (info &aux no-down )
185
(dolist (v *local-functions*)
186
(cond ((eq (car v) 'function)
188
(dolist (w *local-functions*)
189
(cond ((eq (car w) 'downward-function)
190
(setf (car w) 'function))))
192
(setq *local-functions* nil)
194
(do-referred (var info)
195
(if (eq (var-kind var) 'down)
196
(setf (var-kind var) 'lexical))))))
199
(defun assign-down-vars (info cfun inside &aux (ind 0) )
200
(do-referred (var info)
201
(cond ((eq (var-kind var) 'down)
202
;;don't do twice since this list may have duplicates.
203
(cond ((integerp (var-loc var) )
204
;(or (integerp (var-ref var)) (print var))
205
(setq ind (max ind (1+ (var-loc var))))
206
(setf (var-ref var) (var-loc var)) ;delete later
208
;((integerp (var-loc var)) (break "bil"))
209
(t (setf (var-ref var) ind) ;delete later
210
(setf (var-loc var) ind)
211
(setf ind (+ ind 1)))))))
213
;;(wt-nl "object Dbase[" ind "];")
214
(cond ((eq inside 't3defun)
215
(wt-nl "object base0[" ind "];")))
216
;DCnames gets defined at end whe
217
(push 'dcnames *downward-closures*)
218
(wt-nl "DCnames"cfun "")))
221
(si::putprop 'down 'wt-down 'wt-loc)
224
(or (si::fixnump n) (wfs-error))
227
(defun wt-var (var ccb)
229
(LEXICAL (cond (ccb (wt-ccb-vs (var-ref-ccb var)))
230
((var-ref-ccb var) (wt-vs* (var-ref var)))
231
((and (eq t (var-ref var))
232
(si:fixnump (var-loc var))
234
(eq t (var-type var)))
235
(setf (var-kind var) 'object)
237
(t (wt-vs (var-ref var)))))
238
(SPECIAL (wt "(VV[" (var-loc var) "]->s.s_dbind)"))
239
(REPLACED (wt (var-loc var)))
240
(DOWN (wt-down (var-loc var)))
241
(GLOBAL (if *safe-compile*
242
(wt "symbol_value(VV[" (var-loc var) "])")
243
(wt "(VV[" (var-loc var) "]->s.s_dbind)")))
244
(t (case (var-kind var)
245
(FIXNUM (when (zerop *space*) (wt "CMP"))
247
(INTEGER (wt "make_integer"))
248
(CHARACTER (wt "code_char"))
249
(LONG-FLOAT (wt "make_longfloat"))
250
(SHORT-FLOAT (wt "make_shortfloat"))
253
(wt "(V" (var-loc var) ")"))
256
;; When setting bignums across setjmps, cannot use alloca as longjmp
257
;; restores the C stack. FIXME -- only need malloc when reading variable
258
;; outside frame. CM 20031201
259
(defmacro bignum-expansion-storage ()
260
`(if (and (boundp '*unwind-exit*) (member 'frame *unwind-exit*))
264
(defun set-var (loc var ccb)
265
(unless (and (consp loc)
268
(eq (caddr loc) ccb))
271
(cond (ccb (wt-ccb-vs (var-ref-ccb var)))
272
((var-ref-ccb var) (wt-vs* (var-ref var)))
273
(t (wt-vs (var-ref var))))
275
(SPECIAL (wt-nl "(VV[" (var-loc var) "]->s.s_dbind)= " loc ";"))
278
(wt-nl "setq(VV[" (var-loc var) "]," loc ");")
279
(wt-nl "(VV[" (var-loc var) "]->s.s_dbind)= " loc ";")))
281
(wt-nl "") (wt-down (var-loc var))
284
(let ((first (and (consp loc) (car loc)))
288
(wt-nl "ISETQ_FIX(V"n",V"n"alloc,")
289
(wt-inline-loc (caddr loc) (cadddr loc)))
290
(fixnum-value (wt-nl "ISETQ_FIX(V"n",V"n"alloc,"(caddr loc)))
293
(case (var-kind (cadr loc))
294
(integer (wt "SETQ_II(V"n",V"n"alloc,V" (var-loc (cadr loc)) ","
295
(bignum-expansion-storage)))
296
(fixnum (wt "ISETQ_FIX(V"n",V"n"alloc,V" (var-loc (cadr loc))))
297
(otherwise (wt "SETQ_IO(V"n",V"n"alloc,"loc ","
298
(bignum-expansion-storage)))))
299
(vs (wt "SETQ_IO(V"n",V"n"alloc,"loc ","
300
(bignum-expansion-storage)))
302
(let ((*inline-blocks* 0) (*restore-avma* *restore-avma*))
303
(save-avma '(nil integer))
304
(wt-nl "SETQ_II(V"n",V" n"alloc,")
305
(wt-integer-loc loc (cons 'set-var var))
306
(wt "," (bignum-expansion-storage) ");")
307
(close-inline-blocks))
308
(return-from set-var nil))
312
(wt-nl "V" (var-loc var) "= ")
314
(FIXNUM (wt-fixnum-loc loc))
315
(CHARACTER (wt-character-loc loc))
316
(LONG-FLOAT (wt-long-float-loc loc))
317
(SHORT-FLOAT (wt-short-float-loc loc))
318
(OBJECT (wt-loc loc))
323
(defun sch-global (name)
324
(dolist* (var *undefined-vars* nil)
325
(when (eq (var-name var) name) (return-from sch-global var))))
327
(defun c1add-globals (globals)
328
(dolist** (name globals)
329
(push (make-var :name name
331
:loc (add-symbol name)
332
:type (let ((x (get name 'cmp-type))) (if x x t))
338
(cond ((endp args) (c1nil))
339
((endp (cdr args)) (too-few-args 'setq 2 1))
340
((endp (cddr args)) (c1setq1 (car args) (cadr args)))
342
(do ((pairs args (cddr pairs))
344
((endp pairs) (c1expr (cons 'progn (reverse forms))))
345
(declare (object pairs))
346
(cmpck (endp (cdr pairs))
347
"No form was given for the value of ~s." (car pairs))
348
(push (list 'setq (car pairs) (cadr pairs)) forms)
352
(defun c1setq1 (name form &aux (info (make-info)) type form1 name1)
353
(cmpck (not (symbolp name)) "The variable ~s is not a symbol." name)
354
(cmpck (constantp name) "The constant ~s is being assigned a value." name)
355
(setq name1 (c1vref name))
356
(push-changed (car name1) info)
357
(setq form1 (c1expr form))
358
(add-info info (cadr form1))
359
(setq type (type-and (var-type (car name1)) (info-type (cadr form1))))
361
(cmpwarn "Type mismatches between ~s and ~s." name form))
362
(unless (eq type (info-type (cadr form1)))
363
(let ((info1 (copy-info (cadr form1))))
364
(setf (info-type info1) type)
365
(setq form1 (list* (car form1) info1 (cddr form1)))))
366
(setf (info-type info) type)
367
(list 'setq info name1 form1)
370
(defun c2setq (vref form)
371
(let ((*value-to-go* (cons 'var vref))) (c2expr* form))
373
(LOCATION (c2location (caddr form)))
374
(otherwise (unwind-exit (cons 'var vref))))
377
(defun c1progv (args &aux symbols values (info (make-info)))
378
(when (or (endp args) (endp (cdr args)))
379
(too-few-args 'progv 2 (length args)))
380
(setq symbols (c1expr* (car args) info))
381
(setq values (c1expr* (cadr args) info))
382
(list 'progv info symbols values (c1progn* (cddr args) info))
385
(defun c2progv (symbols values body
386
&aux (cvar (next-cvar))
387
(*unwind-exit* *unwind-exit*))
389
(wt-nl "{object symbols,values;")
390
(wt-nl "bds_ptr V" cvar "=bds_top;")
391
(push cvar *unwind-exit*)
394
(let ((*value-to-go* (list 'vs (vs-push))))
396
(wt-nl "symbols= " *value-to-go* ";"))
398
(let ((*value-to-go* (list 'vs (vs-push))))
400
(wt-nl "values= " *value-to-go* ";"))
402
(wt-nl "while(!endp(symbols)){")
404
(wt-nl "if(type_of(MMcar(symbols))!=t_symbol)")
406
"FEinvalid_variable(\"~s is not a symbol.\",MMcar(symbols));"))
407
(wt-nl "if(endp(values))bds_bind(MMcar(symbols),OBJNULL);")
408
(wt-nl "else{bds_bind(MMcar(symbols),MMcar(values));")
409
(wt-nl "values=MMcdr(values);}")
410
(wt-nl "symbols=MMcdr(symbols);}")
416
(defun c1psetq (args &aux (vrefs nil) (forms nil)
417
(info (make-info :type '(member nil))))
418
(do ((l args (cddr l)))
421
(cmpck (not (symbolp (car l)))
422
"The variable ~s is not a symbol." (car l))
423
(cmpck (constantp (car l))
424
"The constant ~s is being assigned a value." (car l))
425
(cmpck (endp (cdr l))
426
"No form was given for the value of ~s." (car l))
427
(let* ((vref (c1vref (car l)))
428
(form (c1expr (cadr l)))
429
(type (type-and (var-type (car vref))
430
(info-type (cadr form)))))
431
(unless (equal type (info-type (cadr form)))
432
(let ((info1 (copy-info (cadr form))))
433
(setf (info-type info1) type)
434
(setq form (list* (car form) info1 (cddr form)))))
437
(push-changed (car vref) info)
438
(add-info info (cadar forms)))
440
(list 'psetq info (reverse vrefs) (reverse forms))
443
(defun c2psetq (vrefs forms &aux (*vs* *vs*) (saves nil) (blocks 0))
444
(dolist** (vref vrefs)
445
(if (or (args-info-changed-vars (car vref) (cdr forms))
446
(args-info-referred-vars (car vref) (cdr forms)))
448
(LOCATION (push (cons vref (caddar forms)) saves))
450
(if (member (var-kind (car vref))
451
'(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT))
452
(let* ((kind (var-kind (car vref)))
454
(temp (list 'var (make-var :kind kind :loc cvar) nil)))
455
(wt-nl "{" *volatile* (rep-type kind) "V" cvar ";")
457
(let ((*value-to-go* temp)) (c2expr* (car forms)))
458
(push (cons vref temp) saves))
459
(let ((*value-to-go* (list 'vs (vs-push))))
460
(c2expr* (car forms))
461
(push (cons vref *value-to-go*) saves)))))
462
(let ((*value-to-go* (cons 'var vref))) (c2expr* (car forms))))
464
(dolist** (save saves) (set-var (cdr save) (caar save) (cadar save)))
465
(dotimes (i blocks) (wt "}"))
468
(defun wt-var-decl (var)
470
(let ((n (var-loc var)))
471
(cond ((eq (var-kind var) 'integer)(wt "IDECL(")))
472
(wt *volatile* (register var) (rep-type (var-kind var))
474
(if (eql (var-kind var) 'integer) (wt ",V"n"space,V"n"alloc)"))
added
removed
cmpnew/gcl_cmpvar.lsp
