[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp 27f666e 2/3: * Unify common fallback exit point in `
|
From: |
Andrea Corallo |
|
Subject: |
feature/native-comp 27f666e 2/3: * Unify common fallback exit point in `comp-cstr-union-1-no-mem'. |
|
Date: |
Sun, 6 Dec 2020 12:36:22 -0500 (EST) |
branch: feature/native-comp
commit 27f666e111a34d64de81a214024e1e30928b416e
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>
* Unify common fallback exit point in `comp-cstr-union-1-no-mem'.
* lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem): Define
a local function `give-up' as a common fall-back exit point.
---
lisp/emacs-lisp/comp-cstr.el | 218 +++++++++++++++++++++----------------------
1 file changed, 106 insertions(+), 112 deletions(-)
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index d4e47cf..892a8d3 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -333,121 +333,115 @@ Do range propagation when RANGE is non-nil.
Non memoized version of `comp-cstr-union-1'.
DST is returned."
(with-comp-cstr-accessors
- ;; Check first if we are in the simple case of all input non-negate
- ;; or negated so we don't have to cons.
- (cl-loop
- for cstr in srcs
- unless (neg cstr)
- count t into n-pos
- else
- count t into n-neg
- finally
- (when (or (zerop n-pos) (zerop n-neg))
- (apply #'comp-cstr-union-homogeneous dst srcs)
- (when (zerop n-pos)
- (setf (neg dst) t))
- (cl-return-from comp-cstr-union-1-no-mem dst)))
-
- ;; Some are negated and some are not
- (cl-loop
- for cstr in srcs
- if (neg cstr)
- collect cstr into negatives
- else
- collect cstr into positives
- finally
- (let* ((pos (apply #'comp-cstr-union-homogeneous
- (make-comp-cstr) positives))
- ;; We use neg as result as *most* of times this will be
- ;; negated.
- (neg (apply #'comp-cstr-union-homogeneous
- (make-comp-cstr :neg t) negatives)))
-
- ;; Type propagation.
- (when (and (typeset pos)
- ;; When every pos type is not a subtype of some neg ones.
- (cl-every (lambda (x)
- (cl-some (lambda (y)
- (not (and (not (eq x y))
- (comp-subtype-p x y))))
- (typeset neg)))
- (typeset pos)))
- ;; This is a conservative choice, ATM we can't represent such
- ;; a disjoint set of types unless we decide to add a new slot
- ;; into `comp-cstr' or adopt something like
- ;; `intersection-type' `union-type' in SBCL. Keep it
- ;; "simple" for now.
- (setf (typeset dst) '(t)
- (valset dst) ()
- (range dst) ()
- (neg dst) nil)
- (cl-return-from comp-cstr-union-1-no-mem dst))
-
- ;; Verify disjoint condition between positive types and
- ;; negative types coming from values, in case give-up.
- (let ((neg-value-types (nconc (mapcar #'type-of (valset neg))
- (when (range neg)
- '(integer)))))
- (when (cl-some (lambda (x)
- (cl-some (lambda (y)
- (and (not (eq y x))
- (comp-subtype-p y x)))
- neg-value-types))
- (typeset pos))
- (setf (typeset dst) '(t)
- (valset dst) ()
- (range dst) ()
- (neg dst) nil)
- (cl-return-from comp-cstr-union-1-no-mem dst)))
-
- ;; Value propagation.
- (cond
- ((and (valset pos) (valset neg)
- (equal (cl-union (valset pos) (valset neg)) (valset pos)))
- ;; Pos is a superset of neg.
- (setf (typeset dst) '(t)
- (valset dst) ()
- (range dst) ()
- (neg dst) nil)
- (cl-return-from comp-cstr-union-1-no-mem dst))
- (t
- ;; pos is a subset or eq to neg
- (setf (valset neg)
- (cl-nset-difference (valset neg) (valset pos)))))
-
- ;; Range propagation
- (if (and range
- (or (range pos)
- (range neg)))
- (if (or (valset neg) (typeset neg))
- (setf (range neg)
- (if (memq 'integer (typeset neg))
- (comp-range-negation (range pos))
- (comp-range-negation
- (comp-range-union (range pos)
- (comp-range-negation (range neg))))))
- ;; When possibile do not return a negated cstr.
+ (cl-flet ((give-up ()
+ (setf (typeset dst) '(t)
+ (valset dst) ()
+ (range dst) ()
+ (neg dst) nil)
+ (cl-return-from comp-cstr-union-1-no-mem dst)))
+
+ ;; Check first if we are in the simple case of all input non-negate
+ ;; or negated so we don't have to cons.
+ (cl-loop
+ for cstr in srcs
+ unless (neg cstr)
+ count t into n-pos
+ else
+ count t into n-neg
+ finally
+ (when (or (zerop n-pos) (zerop n-neg))
+ (apply #'comp-cstr-union-homogeneous dst srcs)
+ (when (zerop n-pos)
+ (setf (neg dst) t))
+ (cl-return-from comp-cstr-union-1-no-mem dst)))
+
+ ;; Some are negated and some are not
+ (cl-loop
+ for cstr in srcs
+ if (neg cstr)
+ collect cstr into negatives
+ else
+ collect cstr into positives
+ finally
+ (let* ((pos (apply #'comp-cstr-union-homogeneous
+ (make-comp-cstr) positives))
+ ;; We use neg as result as *most* of times this will be
+ ;; negated.
+ (neg (apply #'comp-cstr-union-homogeneous
+ (make-comp-cstr :neg t) negatives)))
+ ;; Type propagation.
+ (when (and (typeset pos)
+ ;; When every pos type is not a subtype of some neg ones.
+ (cl-every (lambda (x)
+ (cl-some (lambda (y)
+ (not (and (not (eq x y))
+ (comp-subtype-p x y))))
+ (typeset neg)))
+ (typeset pos)))
+ ;; This is a conservative choice, ATM we can't represent such
+ ;; a disjoint set of types unless we decide to add a new slot
+ ;; into `comp-cstr' or adopt something like
+ ;; `intersection-type' `union-type' in SBCL. Keep it
+ ;; "simple" for now.
+ (give-up))
+
+ ;; Verify disjoint condition between positive types and
+ ;; negative types coming from values, in case give-up.
+ (let ((neg-value-types (nconc (mapcar #'type-of (valset neg))
+ (when (range neg)
+ '(integer)))))
+ (when (cl-some (lambda (x)
+ (cl-some (lambda (y)
+ (and (not (eq y x))
+ (comp-subtype-p y x)))
+ neg-value-types))
+ (typeset pos))
+ (give-up)))
+
+ ;; Value propagation.
+ (cond
+ ((and (valset pos) (valset neg)
+ (equal (cl-union (valset pos) (valset neg)) (valset pos)))
+ ;; Pos is a superset of neg.
+ (give-up))
+ (t
+ ;; pos is a subset or eq to neg
+ (setf (valset neg)
+ (cl-nset-difference (valset neg) (valset pos)))))
+
+ ;; Range propagation
+ (if (and range
+ (or (range pos)
+ (range neg)))
+ (if (or (valset neg) (typeset neg))
+ (setf (range neg)
+ (if (memq 'integer (typeset neg))
+ (comp-range-negation (range pos))
+ (comp-range-negation
+ (comp-range-union (range pos)
+ (comp-range-negation (range
neg))))))
+ ;; When possibile do not return a negated cstr.
+ (setf (typeset dst) (typeset pos)
+ (valset dst) (valset pos)
+ (range dst) (unless (memq 'integer (typeset dst))
+ (comp-range-union
+ (comp-range-negation (range neg))
+ (range pos)))
+ (neg dst) nil)
+ (cl-return-from comp-cstr-union-1-no-mem dst))
+ (setf (range neg) ()))
+
+ (if (and (null (typeset neg))
+ (null (valset neg))
+ (null (range neg)))
(setf (typeset dst) (typeset pos)
(valset dst) (valset pos)
- (range dst) (unless (memq 'integer (typeset dst))
- (comp-range-union
- (comp-range-negation (range neg))
- (range pos)))
+ (range dst) (range pos)
(neg dst) nil)
- (cl-return-from comp-cstr-union-1-no-mem dst))
- (setf (range neg) ()))
-
- (if (and (null (typeset neg))
- (null (valset neg))
- (null (range neg)))
- (setf (typeset dst) (typeset pos)
- (valset dst) (valset pos)
- (range dst) (range pos)
- (neg dst) nil)
- (setf (typeset dst) (typeset neg)
- (valset dst) (valset neg)
- (range dst) (range neg)
- (neg dst) (neg neg)))))
+ (setf (typeset dst) (typeset neg)
+ (valset dst) (valset neg)
+ (range dst) (range neg)
+ (neg dst) (neg neg))))))
dst))
(defun comp-cstr-union-1 (range dst &rest srcs)