[522d13]: src / cmp / cmpvar.lsp Maximize Restore History

Download this file

cmpvar.lsp    468 lines (415 with data), 15.6 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
;;;; CMPVAR Variables.
(in-package "COMPILER")
(defun make-var (&rest args)
(let ((var (apply #'%make-var args)))
(unless (member (var-kind var) '(SPECIAL GLOBAL))
(when *current-function*
(push var (fun-local-vars *current-function*))))
var))
(defun var-referenced-in-form-list (var form-list)
(loop for f in form-list
thereis (var-referenced-in-form var f)))
(defun var-changed-in-form-list (var form-list)
(loop for f in form-list
thereis (var-changed-in-form var f)))
;;; FIXME! VAR-REFERENCED-IN-FORM and VAR-CHANGED-IN-FORM are too
;;; pessimistic. One should check whether the functions reading/setting the
;;; variable are actually called from the given node. The problem arises when
;;; we create a closure of a function, as in
;;;
;;; (let* ((a 1) (b #'(lambda () (incf a)))) ...)
;;;
;;; To know whether A is changed or read, we would have to track where B is
;;; actually used.
(defun var-referenced-in-form (var form)
(declare (type var var))
(or (find-form-in-node-list form (var-read-nodes var))
(var-functions-reading var)))
(defun var-changed-in-form (var form)
(declare (type var var))
(or (find-form-in-node-list form (var-set-nodes var))
(let ((kind (var-kind var)))
(if (or (eq kind 'SPECIAL) (eq kind 'GLOBAL))
(c1form-sp-change form)
(var-functions-setting var)))))
(defun update-variable-type (var orig-type)
;; FIXME! Refuse to update type of variables that are modified
(when (var-set-nodes var)
(return-from update-variable-type))
(let ((type (type-and (var-type var) orig-type)))
(if (null type)
(cmpwarn "Variable assigned a value incompatible with its type declaration.~%Variable: ~A~%Expected type: ~A~%Value type: ~A"
(var-name var)
(var-type var)
orig-type)
(loop for form in (var-read-forms var)
when (and (eq (c1form-name form) 'VAR)
(eq var (c1form-arg 0 form)))
do (setf (c1form-type form) (type-and type (c1form-primary-type form)))
finally (setf (var-type var) type)))))
(defun var-read-forms (var)
(mapcar #'first (var-read-nodes var)))
(defun assert-var-ref-value (var)
(unless (let ((ref (var-ref var)))
(or (> ref (/ most-positive-fixnum 2))
(= (var-ref var) (+ (length (var-read-nodes var))
(length (var-set-nodes var))))))
(baboon :format-control "Number of references in VAR ~A unequal to references list"
:format-arguments (list var))))
(defun assert-var-not-ignored (var)
(when (let ((x (var-ignorable var))) (and x (minusp x)))
(cmpwarn "Variable ~A, declared as IGNORE, found in a lisp form."
(var-name var))
(setf (var-ignorable var) nil)))
(defun delete-from-read-nodes (var form)
(assert-var-ref-value var)
(setf (var-ref var) (1- (var-ref var))
(var-read-nodes var) (delete-form-from-node-list form (var-read-nodes var))))
(defun add-to-read-nodes (var form)
(assert-var-ref-value var)
(assert-var-not-ignored var)
(setf (var-ref var) (1+ (var-ref var))
(var-read-nodes var) (add-form-to-node-list form (var-read-nodes var)))
(when *current-function*
(unless (eq *current-function* (var-function var))
(pushnew *current-function* (var-functions-reading var))
(pushnew var (fun-referenced-vars *current-function*))))
form)
(defun add-to-set-nodes (var form)
(assert-var-ref-value var)
(assert-var-not-ignored var)
(setf (var-ref var) (1+ (var-ref var))
(var-set-nodes var) (add-form-to-node-list form (var-set-nodes var)))
;;(push form (var-read-nodes var))
(when *current-function*
(unless (eq *current-function* (var-function var))
(pushnew *current-function* (var-functions-setting var))
(pushnew var (fun-referenced-vars *current-function*))))
form)
(defun add-to-set-nodes-of-var-list (var-list form)
(dolist (v var-list)
(add-to-set-nodes v form))
form)
;;; A special binding creates a var object with the kind field SPECIAL,
;;; whereas a special declaration without binding creates a var object with
;;; the kind field GLOBAL. Thus a reference to GLOBAL may need to make sure
;;; that the variable has a value.
;;; Bootstrap problem: proclaim needs this function:
;;;
;;; Check if a variable has been declared as a special variable with a global
;;; value.
(defun check-global (name)
(member name *global-vars* :test #'eq :key #'var-name))
(defun special-variable-p (name)
"Return true if NAME is associated to a special variable in the lexical environment."
(or (si::specialp name)
(check-global name)
(let ((v (cmp-env-search-var name *cmp-env-root*)))
;; Fixme! Revise the declamation code to ensure whether
;; we also have to consider 'GLOBAL here.
(and v (eq (var-kind v) 'SPECIAL)))))
(defun local-variable-p (name &optional (env *cmp-env*))
(let ((record (cmp-env-search-var name env)))
(and record (var-p record))))
(defun symbol-macro-p (name &optional (env *cmp-env*))
(let ((record (cmp-env-search-var name env)))
(and record (not (var-p record)))))
(defun variable-type-in-env (name &optional (env *cmp-env*))
(multiple-value-bind (var ccb clb unw)
(cmp-env-search-var name)
(cond ((var-p var)
(var-type var))
((get-sysprop name 'CMP-TYPE))
(t))))
;;;
;;; Check if the symbol has a symbol macro
;;;
(defun chk-symbol-macrolet (form)
(loop
(when (not (symbolp form))
(return form))
(let ((new-form (macroexpand-1 form *cmp-env*)))
(when (eq new-form form)
(return form))
(setf form new-form))))
(defun c1make-var (name specials ignores types)
(cmpck (not (symbolp name)) "The variable ~s is not a symbol." name)
(cmpck (constantp name) "The constant ~s is being bound." name)
(let ((ignorable (cdr (assoc name ignores)))
type)
(setq type (if (setq type (assoc name types))
(cdr type)
'T))
(cond ((or (member name specials) (special-variable-p name))
(unless type
(setf type (or (get-sysprop name 'CMP-TYPE) 'T)))
(c1make-global-variable name :kind 'SPECIAL :type type))
(t
(make-var :name name :type type :loc 'OBJECT
:kind 'LEXICAL ; we rely on check-vref to fix it
:ignorable ignorable
:ref 0)))))
(defun check-vref (var)
(when (eq (var-kind var) 'LEXICAL)
(when (and (zerop (var-ref var)) ;;; This field may be -1 (IGNORE). Beppe
(not (var-ignorable var)))
(cmpwarn "The variable ~s is not used." (var-name var)))
(when (not (var-ref-clb var))
;; if the variable can be stored locally, set it var-kind to its type
(setf (var-kind var)
(if (plusp (var-ref var))
(lisp-type->rep-type (var-type var))
:OBJECT)))))
(defun c1var (name)
(let* ((var (c1vref name))
(output (make-c1form* 'VAR
:type (var-type var)
:args var)))
(add-to-read-nodes var output)
output))
(defun make-lcl-var (&key rep-type (type 'T))
(unless rep-type
(setq rep-type (if type (lisp-type->rep-type type) :object)))
(unless type
(setq type 'T))
(make-var :kind rep-type :type type :loc (next-lcl)))
(defun make-temp-var (&optional (type 'T))
(make-var :kind :object :type type :loc `(TEMP ,(next-temp))))
;;; A variable reference (vref for short) is a list: pair
;;; ( var-object ) Beppe(ccb) ccb-reference )
(defun c1vref (name)
(multiple-value-bind (var ccb clb unw)
(cmp-env-search-var name)
(cond ((null var)
(c1make-global-variable name :warn t
:type (or (get-sysprop name 'CMP-TYPE) t)))
((not (var-p var))
;; symbol-macrolet
(baboon))
(t
(assert-var-ref-value var)
(assert-var-not-ignored var)
(when (eq (var-kind var) 'LEXICAL)
(cond (ccb (setf (var-ref-clb var) nil ; replace a previous 'CLB
(var-ref-ccb var) t
(var-kind var) 'CLOSURE
(var-loc var) 'OBJECT))
(clb (setf (var-ref-clb var) t
(var-loc var) 'OBJECT))))
var))))
(defun push-vars (v)
(setf (var-index v) (length (cmp-env-variables)))
(cmp-env-register-var v))
(defun unboxed (var)
(not (eq (var-rep-type var) :object)))
(defun local (var)
(and (not (member (var-kind var) '(LEXICAL CLOSURE SPECIAL GLOBAL)))
(var-kind var)))
(defun global-var-p (var)
(let ((kind (var-kind var)))
(or (eq kind 'global)
(eq kind 'special))))
(defun c2var/location (c1form loc)
#+(or)
(unwind-exit loc)
(unwind-exit (precise-loc-type loc (c1form-primary-type c1form))))
(defun wt-var (var)
(declare (type var var))
(let ((var-loc (var-loc var)))
(case (var-kind var)
(CLOSURE (wt-env var-loc))
(LEXICAL (wt-lex var-loc))
((SPECIAL GLOBAL)
(if (safe-compile)
(wt "ecl_symbol_value(" var-loc ")")
(wt "ECL_SYM_VAL(cl_env_copy," var-loc ")")))
(t (wt var-loc))
)))
(defun var-rep-type (var)
(case (var-kind var)
((LEXICAL CLOSURE SPECIAL GLOBAL) :object)
(t (var-kind var))))
(defun set-var (loc var &aux (var-loc (var-loc var))) ; ccb
(unless (var-p var)
(baboon))
(case (var-kind var)
(CLOSURE
(wt-nl)(wt-env var-loc)(wt " = ")
(wt-coerce-loc (var-rep-type var) loc)
(wt #\;))
(LEXICAL
(wt-nl)(wt-lex var-loc)(wt " = ")
(wt-coerce-loc (var-rep-type var) loc)
(wt #\;))
((SPECIAL GLOBAL)
(if (safe-compile)
(wt-nl "cl_set(" var-loc ",")
(wt-nl "ECL_SETQ(cl_env_copy," var-loc ","))
(wt-coerce-loc (var-rep-type var) loc)
(wt ");"))
(t
(wt-nl var-loc " = ")
(wt-coerce-loc (var-rep-type var) loc)
(wt #\;))
))
(defun wt-lex (lex)
(if (consp lex)
(wt "lex" (car lex) "[" (cdr lex) "]")
(wt-lcl lex)))
;;; reference to variable of inner closure.
(defun wt-env (clv) (wt "ECL_CONS_CAR(CLV" clv ")"))
;;; ----------------------------------------------------------------------
(defun c1make-global-variable (name &key
(type (or (get-sysprop name 'CMP-TYPE) t))
(kind 'GLOBAL)
(warn nil))
(let* ((var (find name *global-var-objects* :key #'var-name))
(found var))
(unless found
(setf var (make-var :name name :kind kind :type type :loc (add-symbol name)))
(push var *global-var-objects*))
(when warn
(unless (or (constantp name) (special-variable-p name))
(undefined-variable name)
(unless found
(push var *undefined-vars*))))
var))
(defun c1declare-specials (globals)
(mapc #'cmp-env-declare-special globals))
(defun si::register-global (name)
(unless (check-global name)
(push (c1make-global-variable name :kind 'GLOBAL
:type (or (get-sysprop name 'CMP-TYPE) 'T))
*global-vars*))
(values))
(defun c1setq (args)
(let ((l (length args)))
(cmpck (oddp l) "SETQ requires an even number of arguments.")
(cond ((zerop l) (c1nil))
((= l 2) (c1setq1 (first args) (second args)))
(t
(c1progn
(loop while args
collect `(setq ,(pop args) ,(pop args))))))))
(defun c1setq1 (name form)
(cmpck (not (symbolp name)) "The variable ~s is not a symbol." name)
(cmpck (constantp name) "The constant ~s is being assigned a value." name)
(setq name (chk-symbol-macrolet name))
(if (symbolp name)
(let* ((name (c1vref name))
(type (var-type name))
(form (c1expr (if (trivial-type-p type)
form
`(checked-value ,type ,form)))))
(add-to-set-nodes name (make-c1form* 'SETQ
:type (c1form-type form)
:args name form)))
`(setf ,name ,form)))
(defun c2setq (c1form vref form)
(declare (ignore c1form))
;; First comes the assignement
(let ((*destination* vref))
(c2expr* form))
;; Then the returned value
(if (eq (c1form-name form) 'LOCATION)
(c2var/location form (c1form-arg 0 form))
(unwind-exit vref)))
(defun c1progv (args)
(check-args-number 'PROGV args 2)
(let ((symbols (c1expr (first args)))
(values (c1expr (second args)))
(forms (c1progn (cddr args))))
(make-c1form* 'PROGV :type (c1form-type forms)
:args symbols values forms)))
(defun c2progv (c1form symbols values body)
(declare (ignore c1form))
(let* ((*lcl* *lcl*)
(lcl (next-lcl))
(sym-loc (make-lcl-var))
(val-loc (make-lcl-var))
(*unwind-exit* (cons lcl *unwind-exit*)))
(wt-nl-open-brace)
(wt-nl "cl_object " sym-loc ", " val-loc "; cl_index " lcl ";")
(let ((*destination* sym-loc)) (c2expr* symbols))
(let ((*destination* val-loc)) (c2expr* values))
(wt-nl lcl " = ecl_progv(cl_env_copy, " sym-loc ", " val-loc ");")
(c2expr body)
(wt-nl-close-brace)
))
(defun c1psetq (old-args &aux (args nil) (use-psetf nil))
;; A first pass ensures that none of the assigned locations is
;; a SETF form. Otherwise we have to resort to PSETF.
(do ((l old-args))
((endp l))
(let ((var (pop l)))
(cmpck (not (symbolp var))
"The variable ~s is not a symbol." var)
(cmpck (endp l)
"No form was given for the value of ~s." var)
(setq var (chk-symbol-macrolet var))
(setq args (nconc args (list var (pop l))))
(if (symbolp var)
(cmpck (constantp var)
"The constant ~s is being assigned a value." var)
(setq use-psetf t))))
(when use-psetf
(return-from c1psetq `(psetf ,@args)))
;; In the second pass we compile the variable references and the
;; assignments. Here we may need to create checked values if the
;; variables have been proclaimed.
(do ((vrefs '())
(forms '()))
((endp args)
(add-to-set-nodes-of-var-list
vrefs (make-c1form* 'PSETQ :type '(MEMBER NIL)
:args (reverse vrefs) (nreverse forms))))
(let* ((vref (c1vref (pop args)))
(type (var-type vref))
(form (pop args)))
(push vref vrefs)
(push (c1expr (if (trivial-type-p type)
form
`(checked-value ,type ,form)))
forms))))
(defun c2psetq (c1form vrefs forms
&aux (*lcl* *lcl*) (saves nil) (braces *opened-c-braces*))
(declare (ignore c1form))
;; similar to inline-args
(do ((vrefs vrefs (cdr vrefs))
(forms forms (cdr forms))
(var) (form))
((null vrefs))
(setq var (first vrefs)
form (car forms))
(if (or (var-changed-in-form-list var (rest forms))
(var-referenced-in-form-list var (rest forms)))
(case (c1form-name form)
(LOCATION (push (cons var (c1form-arg 0 form)) saves))
(otherwise
(if (local var)
(let* ((rep-type (var-rep-type var))
(rep-type-name (rep-type-name rep-type))
(temp (make-lcl-var :rep-type rep-type)))
(wt-nl-open-brace)
(wt-nl *volatile* rep-type-name " " temp ";")
(let ((*destination* temp)) (c2expr* form))
(push (cons var temp) saves))
(let ((*destination* (make-temp-var)))
(c2expr* form)
(push (cons var *destination*) saves)))))
(let ((*destination* var)) (c2expr* form))))
(dolist (save saves) (set-var (cdr save) (car save)))
(wt-nl-close-many-braces braces)
(unwind-exit nil)
)