/[gcl]/gcl/cmpnew/gcl_cmplet.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmplet.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.10 by camm, Tue Dec 28 22:24:18 2004 UTC revision 1.11 by camm, Fri Jan 7 17:58:33 2005 UTC
# Line 28  Line 28 
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)
# Line 46  Line 44 
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)
# Line 71  Line 70 
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))
# Line 101  Line 100 
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    
# Line 236  Line 201 
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))
# Line 248  Line 212 
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)))
# Line 306  Line 275 
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)))
# Line 323  Line 292 
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)
# Line 361  Line 330 
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))
# Line 374  Line 343 
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))
# Line 414  Line 392 
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))

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.11

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26