[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp acf101c 1/2: Handle type hierarchy in native compile
From: |
Andrea Corallo |
Subject: |
feature/native-comp acf101c 1/2: Handle type hierarchy in native compiler forward propagation |
Date: |
Sat, 7 Nov 2020 06:15:56 -0500 (EST) |
branch: feature/native-comp
commit acf101c63644da5587822afbea1b186d91ff3348
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>
Handle type hierarchy in native compiler forward propagation
2020-11-07 Andrea Corallo <andrea.corallo@arm.com>
* lisp/emacs-lisp/cl-preloaded.el (cl--typeof-types): Add fixnum
and bignum.
* lisp/emacs-lisp/comp.el (comp-ctxt): Add `supertype-memoize'
slot.
(comp-supertypes, comp-common-supertype-2)
(comp-common-supertype): New functions.
(comp-fwprop-insn): Make use of `comp-common-supertype' to
identify the common supertype to be propagated.
---
lisp/emacs-lisp/cl-preloaded.el | 3 ++-
lisp/emacs-lisp/comp.el | 44 ++++++++++++++++++++++++++++++++++++-----
2 files changed, 41 insertions(+), 6 deletions(-)
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index eed43c5..b5dbcbd 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -52,7 +52,8 @@
(defconst cl--typeof-types
;; Hand made from the source code of `type-of'.
- '((integer number number-or-marker atom)
+ '((fixnum integer number number-or-marker atom)
+ (bignum integer number number-or-marker atom)
(symbol atom) (string array sequence atom)
(cons list sequence)
;; Markers aren't `numberp', yet they are accepted wherever integers are
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 51fed2f..bb32aef 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -278,7 +278,10 @@ This is tipically for top-level forms other than defun.")
(d-ephemeral (make-comp-data-container) :type comp-data-container
:documentation "Relocated data not necessary after load.")
(with-late-load nil :type boolean
- :documentation "When non-nil support late load."))
+ :documentation "When non-nil support late load.")
+ (supertype-memoize (make-hash-table :test #'equal) :type hash-table
+ :documentation "Serve memoization for
+ `comp-common-supertype'."))
(cl-defstruct comp-args-base
(min nil :type number
@@ -2124,6 +2127,40 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or
post-order if non-nil."
'fixnum
(type-of obj)))
+(defun comp-supertypes (type)
+ "Return a list of pairs (supertype . hierarchy-level) for TYPE."
+ (cl-loop
+ named outer
+ with found = nil
+ for l in cl--typeof-types
+ do (cl-loop
+ for x in l
+ for i from (length l) downto 0
+ when (eq type x)
+ do (setf found t)
+ when found
+ collect `(,x . ,i) into res
+ finally (when found
+ (cl-return-from outer res)))))
+
+(defun comp-common-supertype-2 (type1 type2)
+ "Return the first common supertype of TYPE1 TYPE2."
+ (car (cl-reduce (lambda (x y)
+ (if (> (cdr x) (cdr y))
+ x
+ y))
+ (cl-intersection
+ (comp-supertypes type1)
+ (comp-supertypes type2)
+ :key #'car))))
+
+(defun comp-common-supertype (&rest types)
+ "Return the first common supertype of TYPES."
+ (or (gethash types (comp-ctxt-supertype-memoize comp-ctxt))
+ (puthash types
+ (cl-reduce #'comp-common-supertype-2 types)
+ (comp-ctxt-supertype-memoize comp-ctxt))))
+
(defun comp-copy-insn (insn)
"Deep copy INSN."
;; Adapted from `copy-tree'.
@@ -2252,12 +2289,9 @@ Forward propagate immediate involed in assignments."
(setf (comp-mvar-const-vld lval) t
(comp-mvar-constant lval) x))
;; Forward type propagation.
- ;; FIXME: checking for type equality is not sufficient cause does not
- ;; account type hierarchy!
(when-let* ((types (mapcar #'comp-mvar-type rest))
(non-empty (cl-notany #'null types))
- (x (car types))
- (eqs (cl-every (lambda (y) (eq x y)) types)))
+ (x (comp-common-supertype types)))
(setf (comp-mvar-type lval) x)))))
(defun comp-fwprop* ()