/[cmucl]/src/compiler/checkgen.lisp
ViewVC logotype

Diff of /src/compiler/checkgen.lisp

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

revision 1.2 by ram, Tue Mar 27 11:39:36 1990 UTC revision 1.3 by ram, Sat May 12 20:13:16 1990 UTC
# Line 84  Line 84 
84  ;;;; Checking strategy determination:  ;;;; Checking strategy determination:
85    
86    
87    ;;; MAYBE-WEAKEN-CHECK  --  Internal
88    ;;;
89    ;;;    Return the type we should test for when we really want to check for
90    ;;; Type.   If speed, space or compilation speed is more important than safety,
91    ;;; then we return a weaker type if it is easier to check.  First we try the
92    ;;; defined type weakenings, then look for any predicate that is cheaper.
93    ;;;
94    ;;;    If the supertype is equal in cost to the type, we prefer the supertype.
95    ;;; This produces a closer approximation of the right thing in the presence of
96    ;;; poor cost info.
97    ;;;
98    (defun maybe-weaken-check (type cont)
99      (declare (type ctype type) (type continuation cont))
100      (cond ((policy (continuation-dest cont)
101                     (<= speed safety) (<= space safety) (<= cspeed safety))
102             type)
103            (t
104             (let ((min-cost (type-test-cost type))
105                   (min-type type)
106                   (found-super nil))
107               (dolist (x *type-predicates*)
108                 (let ((stype (car x)))
109                   (when (csubtypep type stype)
110                     (setq found-super t)
111                     (let ((stype-cost (type-test-cost stype)))
112                       (when (< stype-cost min-cost)
113                         (setq min-type stype  min-cost stype-cost))))))
114               (if found-super
115                   min-type
116                   *universal-type*)))))
117    
118    
119  ;;; MAYBE-NEGATE-CHECK  --  Internal  ;;; MAYBE-NEGATE-CHECK  --  Internal
120  ;;;  ;;;
121  ;;;    Cont is a continuation we are doing a type check on and Types is a list  ;;;    Cont is a continuation we are doing a type check on and Types is a list
# Line 101  Line 133 
133      (if (eq count :unknown)      (if (eq count :unknown)
134          (if (every #'type-check-template types)          (if (every #'type-check-template types)
135              (values :simple types)              (values :simple types)
136              (values :hairy (mapcar #'(lambda (x) (list nil x x)) types)))              (values :hairy
137                        (mapcar #'(lambda (x)
138                                    (list nil (maybe-weaken-check x cont) x))
139                                types)))
140          (let ((res (mapcar #'(lambda (p c)          (let ((res (mapcar #'(lambda (p c)
141                                 (let ((diff (type-difference p c)))                                 (let ((diff (type-difference p c)))
142                                   (if (and diff                                   (if (and diff
143                                            (< (type-test-cost diff)                                            (< (type-test-cost diff)
144                                               (type-test-cost c)))                                               (type-test-cost c)))
145                                       (list t diff c)                                       (list t (maybe-weaken-check diff cont) c)
146                                       (list nil c c))))                                       (list nil (maybe-weaken-check c cont) c))))
147                             ptypes types)))                             ptypes types)))
148            (if (and (not (find-if #'first res))            (if (and (not (find-if #'first res))
149                     (every #'type-check-template types))                     (every #'type-check-template types))
# Line 167  Line 202 
202  ;;; to choose to implement the continuation's DEST, we use a heuristic.  We  ;;; to choose to implement the continuation's DEST, we use a heuristic.  We
203  ;;; always return T unless:  ;;; always return T unless:
204  ;;;  -- Nobody uses the value, or  ;;;  -- Nobody uses the value, or
205  ;;;  -- Speed or space is more important that safety, or  ;;;  -- Safety is totally unimportant, or
206  ;;;  -- the continuation is an argument to an unknown function, or  ;;;  -- the continuation is an argument to an unknown function, or
207  ;;;  -- the continuation is an argument to a known function that has no  ;;;  -- the continuation is an argument to a known function that has no
208  ;;;     IR2-Convert method or :fast-safe templates that are compatible with the  ;;;     IR2-Convert method or :fast-safe templates that are compatible with the
# Line 185  Line 220 
220    (let ((dest (continuation-dest cont)))    (let ((dest (continuation-dest cont)))
221      (cond ((eq (continuation-type-check cont) :error))      (cond ((eq (continuation-type-check cont) :error))
222            ((or (not dest)            ((or (not dest)
223                 (policy dest (or (> speed safety) (> space safety))))                 (policy dest (zerop safety)))
224             nil)             nil)
225            ((basic-combination-p dest)            ((basic-combination-p dest)
226             (let ((kind (basic-combination-kind dest)))             (let ((kind (basic-combination-kind dest)))
# Line 355  Line 390 
390                    (setf (basic-combination-kind dest) :full)))                    (setf (basic-combination-kind dest) :full)))
391                (when (policy node (>= safety brevity))                (when (policy node (>= safety brevity))
392                  (let ((*compiler-error-context* node))                  (let ((*compiler-error-context* node))
393                    (compiler-warning "Result is a ~S, not a ~S."                    (if (and (ref-p node) (constant-p (ref-leaf node)))
394                                      (type-specifier dtype)                        (compiler-warning "This is not a ~S:~%  ~S"
395                                      (type-specifier atype))))))                                          (type-specifier atype)
396                                            (constant-value (ref-leaf node)))
397                          (compiler-warning "Result is a ~S, not a ~S."
398                                            (type-specifier dtype)
399                                            (type-specifier atype)))))))
400    
401            (let ((check-p (probable-type-check-p cont)))            (let ((check-p (probable-type-check-p cont)))
402              (multiple-value-bind (check types)              (multiple-value-bind (check types)

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

  ViewVC Help
Powered by ViewVC 1.1.5