(defun flush-dead-code (block)
(declare (type cblock block))
(setf (block-flush-p block) nil)
- (do-nodes-backwards (node lvar block)
+ (do-nodes-backwards (node lvar block :restart-p t)
(unless lvar
(typecase node
(ref
(declaim (ftype (function (combination) (values)) ir1-optimize-combination))
(defun ir1-optimize-combination (node)
(when (lvar-reoptimize (basic-combination-fun node))
- (propagate-fun-change node))
+ (propagate-fun-change node)
+ (maybe-terminate-block node nil))
(let ((args (basic-combination-args node))
(kind (basic-combination-kind node)))
(case kind
;;; - CAST chains;
(defun ir1-optimize-cast (cast &optional do-not-optimize)
(declare (type cast cast))
- (let* ((value (cast-value cast))
- (value-type (lvar-derived-type value))
- (atype (cast-asserted-type cast))
- (int (values-type-intersection value-type atype)))
- (derive-node-type cast int)
- (when (eq int *empty-type*)
- (unless (eq value-type *empty-type*)
-
- ;; FIXME: Do it in one step.
- (filter-lvar
- value
- `(multiple-value-call #'list 'dummy))
- (filter-lvar
- (cast-value cast)
- ;; FIXME: Derived type.
- `(%compile-time-type-error 'dummy
- ',(type-specifier atype)
- ',(type-specifier value-type)))
- ;; KLUDGE: FILTER-LVAR does not work for non-returning
- ;; functions, so we declare the return type of
- ;; %COMPILE-TIME-TYPE-ERROR to be * and derive the real type
- ;; here.
- (setq value (cast-value cast))
- (derive-node-type (lvar-uses value) *empty-type*)
- (maybe-terminate-block (lvar-uses value) nil)
- ;; FIXME: Is it necessary?
- (aver (null (block-pred (node-block cast))))
- (setf (block-delete-p (node-block cast)) t)
- (return-from ir1-optimize-cast)))
- (when (eq (node-derived-type cast) *empty-type*)
- (maybe-terminate-block cast nil))
-
+ (let ((value (cast-value cast))
+ (atype (cast-asserted-type cast)))
(when (not do-not-optimize)
(let ((lvar (node-lvar cast)))
- (when (values-subtypep value-type (cast-asserted-type cast))
+ (when (values-subtypep (lvar-derived-type value)
+ (cast-asserted-type cast))
(delete-filter cast lvar value)
(when lvar
(reoptimize-lvar lvar)
(dolist (use (merges))
(merge-tail-sets use)))))))
- (when (and (cast-%type-check cast)
- (values-subtypep value-type
- (cast-type-to-check cast)))
- (setf (cast-%type-check cast) nil)))
+ (let* ((value-type (lvar-derived-type value))
+ (int (values-type-intersection value-type atype)))
+ (derive-node-type cast int)
+ (when (eq int *empty-type*)
+ (unless (eq value-type *empty-type*)
+
+ ;; FIXME: Do it in one step.
+ (filter-lvar
+ value
+ `(multiple-value-call #'list 'dummy))
+ (filter-lvar
+ (cast-value cast)
+ ;; FIXME: Derived type.
+ `(%compile-time-type-error 'dummy
+ ',(type-specifier atype)
+ ',(type-specifier value-type)))
+ ;; KLUDGE: FILTER-LVAR does not work for non-returning
+ ;; functions, so we declare the return type of
+ ;; %COMPILE-TIME-TYPE-ERROR to be * and derive the real type
+ ;; here.
+ (setq value (cast-value cast))
+ (derive-node-type (lvar-uses value) *empty-type*)
+ (maybe-terminate-block (lvar-uses value) nil)
+ ;; FIXME: Is it necessary?
+ (aver (null (block-pred (node-block cast))))
+ (setf (block-delete-p (node-block cast)) t)
+ (return-from ir1-optimize-cast)))
+ (when (eq (node-derived-type cast) *empty-type*)
+ (maybe-terminate-block cast nil))
+
+ (when (and (cast-%type-check cast)
+ (values-subtypep value-type
+ (cast-type-to-check cast)))
+ (setf (cast-%type-check cast) nil))))
(unless do-not-optimize
(setf (node-reoptimize cast) nil)))
start next result
(with-unique-names (bind unbind)
(once-only ((n-save-bs '(%primitive current-binding-pointer)))
- `(unwind-protect
- (progn
- (labels ((,unbind (vars)
- (declare (optimize (speed 2) (debug 0)))
- (dolist (var vars)
- (%primitive bind nil var)
- (makunbound var)))
- (,bind (vars vals)
- (declare (optimize (speed 2) (debug 0)))
- (cond ((null vars))
- ((null vals) (,unbind vars))
- (t (%primitive bind
- (car vals)
- (car vars))
- (,bind (cdr vars) (cdr vals))))))
- (,bind ,vars ,vals))
- nil
- ,@body)
- (%primitive unbind-to-here ,n-save-bs))))))
+ `(unwind-protect
+ (progn
+ (labels ((,unbind (vars)
+ (declare (optimize (speed 2) (debug 0)))
+ (dolist (var vars)
+ (%primitive bind nil var)
+ (makunbound var)))
+ (,bind (vars vals)
+ (declare (optimize (speed 2) (debug 0)))
+ (cond ((null vars))
+ ((null vals) (,unbind vars))
+ (t (%primitive bind
+ (car vals)
+ (car vars))
+ (,bind (cdr vars) (cdr vals))))))
+ (,bind ,vars ,vals))
+ nil
+ ,@body)
+ (%primitive unbind-to-here ,n-save-bs))))))
\f
;;;; non-local exit
;;; Like DO-NODES, only iterating in reverse order. Should be careful
;;; with block being split under us.
-(defmacro do-nodes-backwards ((node-var lvar block) &body body)
+(defmacro do-nodes-backwards ((node-var lvar block &key restart-p) &body body)
(let ((n-block (gensym))
(n-prev (gensym)))
`(loop with ,n-block = ,block
- for ,node-var = (block-last ,n-block) then (ctran-use ,n-prev)
+ for ,node-var = (block-last ,n-block) then
+ ,(if restart-p
+ `(if (eq ,n-block (ctran-block ,n-prev))
+ (ctran-use ,n-prev)
+ (block-last ,n-block))
+ `(ctran-use ,n-prev))
for ,n-prev = (when ,node-var (node-prev ,node-var))
and ,lvar = (when (and ,node-var (valued-node-p ,node-var))
(node-lvar ,node-var))
(if (logbitp 1 a) b (setq a -1522022182249))))))))
-1802767029877 -12374959963)
-80))
+
+;;; various MISC.*, related to NODEs/LVARs with derived type NIL
+(assert (eql (funcall (compile nil '(lambda (c)
+ (declare (type (integer -3924 1001809828) c))
+ (declare (optimize (speed 3)))
+ (min 47 (if (ldb-test (byte 2 14) c)
+ -570344431
+ (ignore-errors -732893970)))))
+ 705347625)
+ -570344431))
+(assert (eql (funcall
+ (compile nil '(lambda (b)
+ (declare (type (integer -1598566306 2941) b))
+ (declare (optimize (speed 3)))
+ (max -148949 (ignore-errors b))))
+ 0)
+ 0))
+(assert (eql (funcall
+ (compile nil '(lambda (b c)
+ (declare (type (integer -4 -3) c))
+ (block b7
+ (flet ((%f1 (f1-1 f1-2 f1-3)
+ (if (logbitp 0 (return-from b7
+ (- -815145138 f1-2)))
+ (return-from b7 -2611670)
+ 99345)))
+ (let ((v2 (%f1 -2464 (%f1 -1146 c c) -2)))
+ b)))))
+ 2950453607 -4)
+ -815145134))
+(assert (eql (funcall
+ (compile nil
+ '(lambda (b c)
+ (declare (type (integer -29742055786 23602182204) b))
+ (declare (type (integer -7409 -2075) c))
+ (declare (optimize (speed 3)))
+ (floor
+ (labels ((%f2 ()
+ (block b6
+ (ignore-errors (return-from b6
+ (if (= c 8) b 82674))))))
+ (%f2)))))
+ 22992834060 -5833)
+ 82674))
+(assert (equal (multiple-value-list
+ (funcall
+ (compile nil '(lambda (a)
+ (declare (type (integer -944 -472) a))
+ (declare (optimize (speed 3)))
+ (round
+ (block b3
+ (return-from b3
+ (if (= 55957 a) -117 (ignore-errors
+ (return-from b3 a))))))))
+ -589))
+ '(-589 0)))
projects / sbcl.git / commitdiff