[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp 09ec39e 8/8: * Memoize `comp-cstr-union-1'
From: |
Andrea Corallo |
Subject: |
feature/native-comp 09ec39e 8/8: * Memoize `comp-cstr-union-1' |
Date: |
Sat, 5 Dec 2020 17:07:34 -0500 (EST) |
branch: feature/native-comp
commit 09ec39e35213f92ce297dfed7a42af56b5e2b693
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>
* Memoize `comp-cstr-union-1'
* lisp/emacs-lisp/comp-cstr.el (comp-cstr): Do not synthesize the
copier.
(comp-cstr-ctxt): Add `union-1-mem-no-range' `union-1-mem-range'
slots.
(comp-cstr-copy): New function.
(comp-cstr-union-1-no-mem): Rename from `comp-cstr-union-1'.
(comp-cstr-union-1): New function.
---
lisp/emacs-lisp/comp-cstr.el | 49 +++++++++++++++++++++++++++++++++++++-------
1 file changed, 42 insertions(+), 7 deletions(-)
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index c0e6a57..bb63ff3 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -57,7 +57,8 @@
(:constructor comp-irange-to-cstr
(irange &aux
(range (list irange))
- (typeset ()))))
+ (typeset ())))
+ (:copier nil))
"Internal representation of a type/value constraint."
(typeset '(t) :type list
:documentation "List of possible types the mvar can assume.
@@ -84,7 +85,13 @@ Integer values are handled in the `range' slot.")
;; TODO we should be able to just cons hash this.
(common-supertype-mem (make-hash-table :test #'equal) :type hash-table
:documentation "Serve memoization for
-`comp-common-supertype'."))
+`comp-common-supertype'.")
+ (union-1-mem-no-range (make-hash-table :test #'equal) :type hash-table
+ :documentation "Serve memoization for
+`comp-cstr-union-1'.")
+ (union-1-mem-range (make-hash-table :test #'equal) :type hash-table
+ :documentation "Serve memoization for
+`comp-cstr-union-1'."))
(defmacro with-comp-cstr-accessors (&rest body)
"Define some quick accessor to reduce code vergosity in BODY."
@@ -100,6 +107,14 @@ Integer values are handled in the `range' slot.")
`(comp-cstr-neg ,@x)))
,@body))
+(defun comp-cstr-copy (cstr)
+ "Return a deep copy of CSTR."
+ (with-comp-cstr-accessors
+ (make-comp-cstr :typeset (copy-tree (typeset cstr))
+ :valset (copy-tree (valset cstr))
+ :range (copy-tree (range cstr))
+ :neg (copy-tree (neg cstr)))))
+
;;; Type handling.
@@ -312,9 +327,10 @@ DST is returned."
(mapcar #'comp-cstr-range srcs))))
dst)
-(cl-defun comp-cstr-union-1 (range dst &rest srcs)
+(cl-defun comp-cstr-union-1-no-mem (range dst &rest srcs)
"Combine SRCS by union set operation setting the result in DST.
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
@@ -330,7 +346,7 @@ DST is returned."
(apply #'comp-cstr-union-homogeneous dst srcs)
(when (zerop n-pos)
(setf (neg dst) t))
- (cl-return-from comp-cstr-union-1 dst)))
+ (cl-return-from comp-cstr-union-1-no-mem dst)))
;; Some are negated and some are not
(cl-loop
@@ -365,7 +381,7 @@ DST is returned."
(valset dst) ()
(range dst) ()
(neg dst) nil)
- (cl-return-from comp-cstr-union-1 dst))
+ (cl-return-from comp-cstr-union-1-no-mem dst))
;; Value propagation.
(cond
@@ -376,7 +392,7 @@ DST is returned."
(valset dst) ()
(range dst) ()
(neg dst) nil)
- (cl-return-from comp-cstr-union-1 dst))
+ (cl-return-from comp-cstr-union-1-no-mem dst))
(t
;; pos is a subset or eq to neg
(setf (valset neg)
@@ -404,7 +420,7 @@ DST is returned."
(comp-range-negation (range neg))
(range pos))
(neg dst) nil)
- (cl-return-from comp-cstr-union-1 dst))
+ (cl-return-from comp-cstr-union-1-no-mem dst))
(setf (range neg) ()))
(if (and (null (typeset neg))
@@ -420,6 +436,25 @@ DST is returned."
(neg dst) (neg neg)))))
dst))
+(defun comp-cstr-union-1 (range dst &rest srcs)
+ "Combine SRCS by union set operation setting the result in DST.
+Do range propagation when RANGE is non-nil.
+DST is returned."
+ (let ((mem-h (if range
+ (comp-cstr-ctxt-union-1-mem-range comp-ctxt)
+ (comp-cstr-ctxt-union-1-mem-no-range comp-ctxt))))
+ (with-comp-cstr-accessors
+ (if-let ((mem-res (gethash srcs mem-h)))
+ (progn
+ (setf (typeset dst) (typeset mem-res)
+ (valset dst) (valset mem-res)
+ (range dst) (range mem-res)
+ (neg dst) (neg mem-res))
+ mem-res)
+ (let ((res (apply #'comp-cstr-union-1-no-mem range dst srcs)))
+ (puthash srcs (comp-cstr-copy res) mem-h)
+ res)))))
+
;;; Entry points.
- feature/native-comp updated (eb8d155 -> 09ec39e), Andrea Corallo, 2020/12/05
- feature/native-comp 9b85ae6 1/8: Initial constraint negation support, Andrea Corallo, 2020/12/05
- feature/native-comp 7c1d90a 3/8: Initial support for union of negated constraints, Andrea Corallo, 2020/12/05
- feature/native-comp 726e40f 5/8: Fix union of homogeneously negated input constraints, Andrea Corallo, 2020/12/05
- feature/native-comp f923de6 6/8: * Fix `comp-cstr-to-type-spec', Andrea Corallo, 2020/12/05
- feature/native-comp 09ec39e 8/8: * Memoize `comp-cstr-union-1',
Andrea Corallo <=
- feature/native-comp 1fb249f 2/8: * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-no-range): Cosmetic., Andrea Corallo, 2020/12/05
- feature/native-comp cbbdb4e 4/8: * Add `with-comp-cstr-accessors' macro., Andrea Corallo, 2020/12/05
- feature/native-comp 2eb41ec 7/8: More improvements to `comp-cstr-union-1' for mixed positive/negative cases, Andrea Corallo, 2020/12/05