28 |
(si:putprop 'let* 'c1let* 'c1special) |
(si:putprop 'let* 'c1let* 'c1special) |
29 |
(si:putprop 'let* 'c2let* 'c2) |
(si:putprop 'let* 'c2let* 'c2) |
30 |
|
|
|
(defvar *decls* nil) |
|
|
|
|
31 |
;;FIXME centralize this |
;;FIXME centralize this |
32 |
(defun push-macrolets (form) |
(defun push-macrolets (form) |
33 |
(dolist** (def form) |
(dolist** (def form) |
44 |
form)) |
form)) |
45 |
form))) |
form))) |
46 |
|
|
47 |
(defun recursively-cmp-macroexpand (form &optional bf &aux (*funs* *funs*)) |
(defun recursively-cmp-macroexpand (form bf &aux (*funs* *funs*)) |
48 |
(if (atom form) |
(if (atom form) |
49 |
form |
form |
50 |
(let ((cf (car form))) |
(let ((cf (car form))) |
51 |
(let ((new-cdr-bf (or (and (consp bf) |
(let ((new-cdr-bf (or (and (eq bf 'quote) 'quote) |
52 |
|
(car (member cf '(let let* lambda flet labels macrolet quote function))) |
53 |
|
(and (consp bf) |
54 |
(if (atom (car bf)) bf |
(if (atom (car bf)) bf |
55 |
(and (member (caar bf) '(flet labels macrolet) :test #'eq) 'lambda))) |
(and (member (caar bf) '(flet labels macrolet) :test #'eq) 'lambda))))) |
56 |
(car (member cf '(let let* lambda flet labels macrolet quote function))))) |
(new-car-bf (and (consp cf) bf (if (eq bf 'quote) bf (list bf)))) |
|
(new-car-bf (and (consp cf) bf (list bf))) |
|
57 |
(new-cf (if (or bf (atom cf) (eq (car cf) 'lambda)) |
(new-cf (if (or bf (atom cf) (eq (car cf) 'lambda)) |
58 |
cf (cmp-macroexp-with-compiler-macros cf)))) |
cf (cmp-macroexp-with-compiler-macros cf)))) |
59 |
(cons (recursively-cmp-macroexpand new-cf new-car-bf) |
(cons (recursively-cmp-macroexpand new-cf new-car-bf) |
70 |
(t (or (if (atom (car form)) nil (var-is-changed var (car form))) |
(t (or (if (atom (car form)) nil (var-is-changed var (car form))) |
71 |
(var-is-changed var (cdr form)))))) |
(var-is-changed var (cdr form)))))) |
72 |
|
|
73 |
(defun var-type-position (var form procl) |
;(defun var-type-position (var form procl) |
74 |
(let ((pos (and (consp form) (position var form)))) |
; (let ((pos (and (consp form) (position var form)))) |
75 |
(if (not pos) t |
; (if (not pos) t |
76 |
(type-and (or (nth pos procl) t) |
; (type-and (or (nth pos procl) t) |
77 |
(let ((pos (1+ pos))) |
; (let ((pos (1+ pos))) |
78 |
(var-type-position var (nthcdr pos form) (nthcdr pos procl))))))) |
; (var-type-position var (nthcdr pos form) (nthcdr pos procl))))))) |
79 |
|
|
80 |
(defun var-is-inferred (var form) |
;(defun var-is-inferred (var form) |
81 |
(if (atom form) t |
; (if (atom form) t |
82 |
(let ((procl (and (consp (car form)) (symbolp (caar form)) (get (caar form) 'compiler::proclaimed-arg-types)))) |
; (let ((procl (and (consp (car form)) (symbolp (caar form)) (get (caar form) 'compiler::proclaimed-arg-types)))) |
83 |
(type-and (if procl (var-type-position var (cdar form) procl) t) |
; (type-and (if procl (var-type-position var (cdar form) procl) t) |
84 |
(type-and (var-is-inferred var (car form)) (var-is-inferred var (cdr form))))))) |
; (type-and (var-is-inferred var (car form)) (var-is-inferred var (cdr form))))))) |
85 |
|
|
86 |
(defun var-in-decl (var form) |
;(defun var-in-decl (var form) |
87 |
(and form (or (member var (cdar form) :test #'eq) (var-in-decl var (cdr form))))) |
; (and form (or (member var (cdar form) :test #'eq) (var-in-decl var (cdr form))))) |
88 |
|
|
89 |
(defun var-is-declared (var form) |
;(defun var-is-declared (var form) |
90 |
(cond ((atom form) nil) |
; (cond ((atom form) nil) |
91 |
((stringp (car form)) (var-is-declared var (cdr form))) |
; ((stringp (car form)) (var-is-declared var (cdr form))) |
92 |
((and (consp (car form)) (eq 'declare (caar form))) |
; ((and (consp (car form)) (eq 'declare (caar form))) |
93 |
(or (var-in-decl var (cdar form)) |
; (or (var-in-decl var (cdar form)) |
94 |
(var-is-declared var (cdr form)))) |
; (var-is-declared var (cdr form)))) |
95 |
(t nil))) |
; (t nil))) |
96 |
|
|
97 |
(defun t-to-nil (x) |
(defun t-to-nil (x) |
98 |
(if (eq x t) nil x)) |
(if (eq x t) nil x)) |
100 |
(defun nil-to-t (x) |
(defun nil-to-t (x) |
101 |
(if x x t)) |
(if x x t)) |
102 |
|
|
|
;(defun fun-ret-type (form) |
|
|
; (cond ((symbolp form) (nil-to-t (cdr (assoc form *decls*)))) |
|
|
; ((integerp form) (list 'integer form form)) |
|
|
; ((atom form) (type-of form)) |
|
|
; ((eq (car form) 'quote) (type-of (cadr form))) |
|
|
; ((and (cdr form) (atom (cdr form))) (error "Dotted list in fun-ret-type~")) |
|
|
; ((symbolp (car form)) |
|
|
; (nil-to-t (or (result-type-from-args (car form) (mapcar #'fun-ret-type (cdr form))) |
|
|
; (let ((proc (get (car form) 'proclaimed-return-type))) |
|
|
; (and (symbolp proc) proc))))) |
|
|
; (t t))) |
|
|
|
|
103 |
(defun coerce-to-one-value (type) |
(defun coerce-to-one-value (type) |
104 |
(if (and (consp type) (eq (car type) 'values)) |
(if (and (consp type) (eq (car type) 'values)) |
105 |
(cadr type) |
(cadr type) |
106 |
type)) |
type)) |
107 |
|
|
108 |
(defun binding-decls (bindings body star) |
(defun type-of-form (form) |
109 |
(cond ((atom bindings) nil) |
(t-to-nil (coerce-to-one-value (info-type (cadr (c1expr form)))))) |
110 |
((atom (car bindings)) (binding-decls (cdr bindings) body star)) |
|
111 |
|
(defun binding-decls-new (bindings star body out) |
112 |
|
(cond ((atom bindings) (nreverse out)) |
113 |
|
((atom (car bindings)) (binding-decls-new (cdr bindings) star body out)) |
114 |
(t |
(t |
115 |
(let* ((bf (car bindings)) |
(let* ((bf (car bindings)) |
116 |
(var (car bf))) |
(var (car bf)) |
117 |
(let ((outer (and (symbolp (cadr bf)) (cdr (assoc (cadr bf) *decls*)))) |
(form (cadr bf))) |
118 |
(inf (t-to-nil (var-is-inferred var body))) |
(let ((type (type-of-form form)) |
119 |
(exp (and (consp (cadr bf)) (eq (caadr bf) 'the) (cadadr bf))) |
(ch (or (var-is-changed var body) (and star (var-is-changed var (cdr bindings)))))) |
120 |
(frt (and (consp (cadr bf)) |
(let ((*vars* (if (not star) *vars* |
121 |
(symbolp (caadr bf)) |
(cons (c1make-var var nil nil (list (cons var (nil-to-t type)))) *vars*)))) |
122 |
(t-to-nil |
(when type |
123 |
(coerce-to-one-value |
(cmpnote "var ~S is type ~S from type propagation, ~a~%" var type |
124 |
(info-type |
(if ch "but is changed" "declaring"))) |
125 |
(cadr |
(binding-decls-new (cdr bindings) star body |
126 |
(c1symbol-fun (caadr bf) (cdadr bf)))))))) |
(if (and type (not ch)) (cons (list type var) out) out)))))))) |
127 |
(dec (var-is-declared var body)) |
|
128 |
(chb (var-is-changed var body)) |
|
129 |
(chc (and star (var-is-changed var (cdr bindings))))) |
;;FIXME -- We can eliminate the extra recursively-cmp-macroexpand |
130 |
(let ((type (or exp frt inf outer)) |
;;code, the logic of which as already provided in a somewhat differing |
131 |
(ublk (not (or chb chc)))) |
;;form by pass1, and extract the changed variable information from the |
132 |
(let ((*vars* (if (not star) *vars* |
;;info record. This takes too long in copilation, esp. pcl, and so |
133 |
(cons (c1make-var var nil nil (list (cons var (nil-to-t type)))) *vars*)))) |
;;this is omitted until we can determine the bottleneck. Using pass1 |
134 |
(if type |
;;also lets of flet shadow c1setq1 to catch cases where the new form |
135 |
(progn |
;;is of the same type as the initial type of the binding. CM |
136 |
(cmpnote "var ~S is type ~S from ~a, ~a~%" |
;;20050106. |
137 |
var type (cond (exp "explicit declaration") |
(defun declare-let-bindings-new (args star) |
138 |
(frt "deduced function return type") |
; (let ((info (make-info)) |
139 |
(inf "argument inference") |
; (newvars *vars*)) |
140 |
(outer "outer scope")) |
; (dolist (bind (car args)) |
141 |
(cond (dec "is already declared, but amending declaration") |
; (push (c1make-var (if (consp bind) (car bind) bind) nil nil nil) newvars)) |
142 |
(chb "but is changed in body") |
; (let ((*vars* newvars)) |
143 |
(chc "but is changed in other bindings") |
; (c1args (c1body (cdr args) nil) info) |
144 |
(t "declaring"))) |
; (when star |
145 |
(if ublk |
; (dolist (bind (car args)) |
146 |
(cons (list type var) (binding-decls (cdr bindings) body star)) |
; (when (consp bind) |
147 |
(binding-decls (cdr bindings) body star))) |
; (c1expr* (cadr bind) info))))) |
148 |
(binding-decls (cdr bindings) body star))))))))) |
(let ((body (recursively-cmp-macroexpand (cdr args) nil)) |
149 |
|
(bindings (if star (recursively-cmp-macroexpand (car args) (list 'let*)) (car args)))) |
150 |
;(type (or (and (symbolp (cadr bf)) (cdr (assoc (cadr bf) *decls*))) |
(let ((decls (binding-decls-new bindings star body nil))) |
151 |
; (t-to-nil (var-is-inferred var body)) |
(if decls |
152 |
; (and (consp (cadr bf)) |
(progn (cmpnote "Let bindings ~S declared ~S~%" (car args) decls) |
153 |
; (if (eq (caadr bf) 'the) (cadadr bf) |
(cons (car args) (cons (cons 'declare decls) (cdr args)))) |
154 |
; (and (symbolp (caadr bf)) |
args)))) |
155 |
; (t-to-nil (get (caadr bf) 'compiler::proclaimed-return-type)))))))) |
|
|
; (if (and type |
|
|
; (symbolp type) |
|
|
; (not (var-is-declared var body)) |
|
|
; (not (var-is-changed var body)) |
|
|
; (or (not star) (not (var-is-changed var (cdr bindings))))) |
|
|
; (cons (list type var) (binding-decls (cdr bindings) body star)) |
|
|
; (binding-decls (cdr bindings) body star)))))) |
|
|
|
|
|
(defun declare-let-bindings (args) |
|
|
(let ((decls (binding-decls (recursively-cmp-macroexpand (car args) (list 'let)) |
|
|
(recursively-cmp-macroexpand (cdr args)) nil))) |
|
|
(if decls |
|
|
(progn (cmpnote "Let bindings ~S declared ~S~%" (car args) decls) |
|
|
(cons (car args) (cons (cons 'declare decls) (cdr args)))) |
|
|
args))) |
|
|
|
|
|
(defun declare-let*-bindings (args) |
|
|
(let ((decls (binding-decls |
|
|
(recursively-cmp-macroexpand (car args) (list 'let*)) |
|
|
(recursively-cmp-macroexpand (cdr args)) |
|
|
t))) |
|
|
(if decls |
|
|
(progn (cmpnote "Let* bindings ~S declared ~S~%" (car args) decls) |
|
|
(cons (car args) (cons (cons 'declare decls) (cdr args)))) |
|
|
args))) |
|
156 |
|
|
157 |
(defun c1let (args &aux (info (make-info))(setjmps *setjmps*) |
(defun c1let (args &aux (info (make-info))(setjmps *setjmps*) |
158 |
(forms nil) (vars nil) (vnames nil) |
(forms nil) (vars nil) (vnames nil) |
159 |
ss is ts body other-decls |
ss is ts body other-decls |
160 |
(*vars* *vars*) (*decls* *decls*)) |
(*vars* *vars*)) |
161 |
(when (endp args) (too-few-args 'let 1 0)) |
(when (endp args) (too-few-args 'let 1 0)) |
162 |
|
|
163 |
(setq args (declare-let-bindings args)) |
(setq args (declare-let-bindings-new args nil)) |
164 |
|
|
165 |
(multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) |
(multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) |
166 |
|
|
201 |
) |
) |
202 |
|
|
203 |
(defun c2let (vars forms body |
(defun c2let (vars forms body |
204 |
&aux (block-p nil) (bindings nil) initials |
&aux (block-p nil) (bindings nil) initials used-vars |
|
|
|
205 |
(*unwind-exit* *unwind-exit*) |
(*unwind-exit* *unwind-exit*) |
206 |
(*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) |
(*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) |
207 |
(declare (object block-p)) |
(declare (object block-p)) |
212 |
(let* ((form (car fl)) (var (car vl)) |
(let* ((form (car fl)) (var (car vl)) |
213 |
(kind (c2var-kind var))) |
(kind (c2var-kind var))) |
214 |
(declare (object form var)) |
(declare (object form var)) |
215 |
(cond (kind (setf (var-kind var) kind) |
;;FIXME -- we still write unused variables. CM 20050106 |
216 |
|
(unless (and (member (car form) '(return return-from throw go) :test #'eq) |
217 |
|
(not (is-referred var (cadr body))) |
218 |
|
(not (is-changed var (cadr body)))) |
219 |
|
(push var used-vars)) |
220 |
|
(cond (kind (setf (var-kind var) kind) |
221 |
(setf (var-loc var) (next-cvar))) |
(setf (var-loc var) (next-cvar))) |
222 |
((eq (var-kind var) 'down) |
((eq (var-kind var) 'down) |
223 |
(or (si::fixnump (var-loc var)) (wfs-error))) |
(or (si::fixnump (var-loc var)) (wfs-error))) |
275 |
(when (eq (var-kind var) 'SPECIAL) (push (var-name var) prev-ss)) |
(when (eq (var-kind var) 'SPECIAL) (push (var-name var) prev-ss)) |
276 |
)) |
)) |
277 |
|
|
278 |
(setq block-p (write-block-open vars)) |
(setq block-p (write-block-open (nreverse used-vars))) |
279 |
|
|
280 |
(dolist* (binding (reverse initials)) |
(dolist* (binding (reverse initials)) |
281 |
(let ((*value-to-go* (second binding))) |
(let ((*value-to-go* (second binding))) |
292 |
(defun c1let* (args &aux (forms nil) (vars nil) (vnames nil) |
(defun c1let* (args &aux (forms nil) (vars nil) (vnames nil) |
293 |
(setjmps *setjmps*) |
(setjmps *setjmps*) |
294 |
ss is ts body other-decls |
ss is ts body other-decls |
295 |
(info (make-info)) (*vars* *vars*) (*decls* *decls*)) |
(info (make-info)) (*vars* *vars*)) |
296 |
(when (endp args) (too-few-args 'let* 1 0)) |
(when (endp args) (too-few-args 'let* 1 0)) |
297 |
|
|
298 |
(setq args (declare-let*-bindings args)) |
(setq args (declare-let-bindings-new args t)) |
299 |
|
|
300 |
(multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) |
(multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) |
301 |
(c1add-globals ss) |
(c1add-globals ss) |
330 |
) |
) |
331 |
|
|
332 |
(defun c2let* (vars forms body |
(defun c2let* (vars forms body |
333 |
&aux (block-p nil) |
&aux (block-p nil) used-vars |
334 |
(*unwind-exit* *unwind-exit*) |
(*unwind-exit* *unwind-exit*) |
335 |
(*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) |
(*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) |
336 |
(declare (object block-p)) |
(declare (object block-p)) |
343 |
(let* ((form (car fl)) (var (car vl)) |
(let* ((form (car fl)) (var (car vl)) |
344 |
(kind (c2var-kind var))) |
(kind (c2var-kind var))) |
345 |
(declare (object form var)) |
(declare (object form var)) |
346 |
(cond (kind (setf (var-kind var) kind) |
(unless (and (member (car form) '(return return-from throw go) :test #'eq) |
347 |
|
(not (is-referred var (cadr body))) |
348 |
|
(not (is-changed var (cadr body))) |
349 |
|
(not (reduce (lambda (&optional x y) |
350 |
|
(and |
351 |
|
(or (and (consp x) (is-referred var (cadr x)) (is-changed var (cadr x))) x) |
352 |
|
(or (and (consp y) (is-referred var (cadr y)) (is-changed var (cadr y))) y))) |
353 |
|
(cdr fl)))) |
354 |
|
(push var used-vars)) |
355 |
|
(cond (kind (setf (var-kind var) kind) |
356 |
(setf (var-loc var) (next-cvar)))) |
(setf (var-loc var) (next-cvar)))) |
357 |
(if (member (var-kind var) |
(if (member (var-kind var) |
358 |
'(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER)) |
'(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER)) |
392 |
))) |
))) |
393 |
)) |
)) |
394 |
|
|
395 |
(setq block-p (write-block-open vars)) |
(setq block-p (write-block-open (nreverse used-vars))) |
396 |
|
|
397 |
(do ((vl vars (cdr vl)) |
(do ((vl vars (cdr vl)) |
398 |
(fl forms (cdr fl)) |
(fl forms (cdr fl)) |