[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp 23c0826 1/2: Add comp-cstr.el and comp-cstr-tests.el
|
From: |
Andrea Corallo |
|
Subject: |
feature/native-comp 23c0826 1/2: Add comp-cstr.el and comp-cstr-tests.el |
|
Date: |
Thu, 26 Nov 2020 16:06:28 -0500 (EST) |
branch: feature/native-comp
commit 23c082638e77219b51e14797a0edae27ae59a9d6
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>
Add comp-cstr.el and comp-cstr-tests.el
As the constraint logic of the compiler is not trivial and largely
independent from the rest of the code move it into comp-cstr.el to
ease separation and maintainability.
This commit improve the conversion type
specifier -> constraint for generality.
Lastly this should help with bootstrap time as comp.el compilation
unit is slimmed down.
* lisp/emacs-lisp/comp-cstr.el: New file.
(comp--typeof-types, comp--all-builtin-types): Move from comp.el.
(comp-cstr, comp-cstr-f): Same + rename.
(comp-cstr-ctxt): New struct.
(comp-supertypes, comp-common-supertype-2)
(comp-common-supertype, comp-subtype-p, comp-union-typesets)
(comp-range-1+, comp-range-1-, comp-range-<, comp-range-union)
(comp-range-intersection): Move from comp.el.
(comp-cstr-union-no-range, comp-cstr-union): Move from comp.el and
rename.
(comp-cstr-union-make): New function.
(comp-type-spec-to-cstr, comp-cstr-to-type-spec): Move from
comp.el, rename it and rework it.
* lisp/emacs-lisp/comp.el (comp-known-func-cstr-h): Rework.
(comp-ctxt): Remove two fields and include `comp-cstr-ctxt'.
(comp-mvar, comp-fwprop-call): Update for `comp-cstr' being
renamed.
(comp-fwprop-insn): Use `comp-cstr-union-no-range' or
`comp-cstr-union'.
(comp-ret-type-spec): Use `comp-cstr-union' and rework.
* test/lisp/emacs-lisp/comp-cstr-tests.el: New file.
(comp-cstr-test-ts, comp-cstr-typespec-test): New functions.
(comp-cstr-typespec-tests-alist): New defconst to generate tests
on.
(comp-cstr-generate-tests): New macro.
* test/src/comp-tests.el (comp-tests-type-spec-tests): Update.
(ret-type-spec): Initialize constraint context.
---
lisp/Makefile.in | 1 +
lisp/emacs-lisp/comp-cstr.el | 363 ++++++++++++++++++++++++++++++++
lisp/emacs-lisp/comp.el | 349 +++---------------------------
test/lisp/emacs-lisp/comp-cstr-tests.el | 68 ++++++
test/src/comp-tests.el | 7 +-
5 files changed, 470 insertions(+), 318 deletions(-)
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index d6bb4cf..5fec921 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -114,6 +114,7 @@ COMPILE_FIRST = \
$(lisp)/emacs-lisp/bytecomp.elc
ifeq ($(HAVE_NATIVE_COMP),yes)
COMPILE_FIRST += $(lisp)/emacs-lisp/comp.elc
+COMPILE_FIRST += $(lisp)/emacs-lisp/comp-cstr.elc
endif
COMPILE_FIRST += $(lisp)/emacs-lisp/autoload.elc
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
new file mode 100644
index 0000000..fcbb32f
--- /dev/null
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -0,0 +1,363 @@
+;;; comp-cstr.el --- native compiler constraint library -*- lexical-binding: t
-*-
+
+;; Author: Andrea Corallo <akrl@sdf.com>
+
+;; Copyright (C) 2020 Free Software Foundation, Inc.
+
+;; Keywords: lisp
+;; Package: emacs
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Constraint library in use by the native compiler.
+
+;; In LIMPLE each non immediate value is represented by a `comp-mvar'.
+;; The part concerning the set of all values the `comp-mvar' can
+;; assume is described into its constraint `comp-cstr'. Each
+;; constraint consists in a triplet: type-set, value-set, range-set.
+;; This file provide set operations between constraints (union
+;; intersection and negation) plus routines to convert from and to a
+;; CL like type specifier.
+
+;;; Code:
+
+(require 'cl-lib)
+
+(defconst comp--typeof-types (mapcar (lambda (x)
+ (append x '(t)))
+ cl--typeof-types)
+ ;; TODO can we just add t in `cl--typeof-types'?
+ "Like `cl--typeof-types' but with t as common supertype.")
+
+(defconst comp--all-builtin-types
+ (append cl--all-builtin-types '(t))
+ "Likewise like `cl--all-builtin-types' but with t as common supertype.")
+
+(cl-defstruct (comp-cstr (:constructor comp-type-to-cstr
+ (type &aux (typeset (list type))))
+ (:constructor comp-value-to-cstr
+ (value &aux
+ (valset (list value))
+ (typeset ())))
+ (:constructor comp-irange-to-cstr
+ (irange &aux
+ (range (list irange))
+ (typeset ()))))
+ "Internal representation of a type/value constraint."
+ (typeset '(t) :type list
+ :documentation "List of possible types the mvar can assume.
+Each element cannot be a subtype of any other element of this slot.")
+ (valset () :type list
+ :documentation "List of possible values the mvar can assume.
+Integer values are handled in the `range' slot.")
+ (range () :type list
+ :documentation "Integer interval."))
+
+(cl-defstruct comp-cstr-f
+ "Internal constraint representation for a function."
+ (args () :type list
+ :documentation "List of `comp-cstr' for its arguments.")
+ (ret nil :type (or comp-cstr comp-cstr-f)
+ :documentation "Returned value."))
+
+(cl-defstruct comp-cstr-ctxt
+ (union-typesets-mem (make-hash-table :test #'equal) :type hash-table
+ :documentation "Serve memoization for
+`comp-union-typesets'.")
+ ;; 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'."))
+
+
+;;; Type handling.
+
+(defun comp-supertypes (type)
+ "Return a list of pairs (supertype . hierarchy-level) for TYPE."
+ (cl-loop
+ named outer
+ with found = nil
+ for l in comp--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."
+ (when-let ((types (cl-intersection
+ (comp-supertypes type1)
+ (comp-supertypes type2)
+ :key #'car)))
+ (car (cl-reduce (lambda (x y)
+ (if (> (cdr x) (cdr y)) x y))
+ types))))
+
+(defun comp-common-supertype (&rest types)
+ "Return the first common supertype of TYPES."
+ (or (gethash types (comp-cstr-ctxt-common-supertype-mem comp-ctxt))
+ (puthash types
+ (cl-reduce #'comp-common-supertype-2 types)
+ (comp-cstr-ctxt-common-supertype-mem comp-ctxt))))
+
+(defsubst comp-subtype-p (type1 type2)
+ "Return t if TYPE1 is a subtype of TYPE2 or nil otherwise."
+ (eq (comp-common-supertype-2 type1 type2) type2))
+
+(defun comp-union-typesets (&rest typesets)
+ "Union types present into TYPESETS."
+ (or (gethash typesets (comp-cstr-ctxt-union-typesets-mem comp-ctxt))
+ (puthash typesets
+ (cl-loop
+ with types = (apply #'append typesets)
+ with res = '()
+ for lane in comp--typeof-types
+ do (cl-loop
+ with last = nil
+ for x in lane
+ when (memq x types)
+ do (setf last x)
+ finally (when last
+ (push last res)))
+ ;; TODO sort.
+ finally (cl-return (cl-remove-duplicates res)))
+ (comp-cstr-ctxt-union-typesets-mem comp-ctxt))))
+
+
+;;; Integer range handling
+
+(defsubst comp-range-1+ (x)
+ (if (symbolp x)
+ x
+ (1+ x)))
+
+(defsubst comp-range-1- (x)
+ (if (symbolp x)
+ x
+ (1- x)))
+
+(defsubst comp-range-< (x y)
+ (cond
+ ((eq x '+) nil)
+ ((eq x '-) t)
+ ((eq y '+) t)
+ ((eq y '-) nil)
+ (t (< x y))))
+
+(defun comp-range-union (&rest ranges)
+ "Combine integer intervals RANGES by union set operation."
+ (cl-loop
+ with all-ranges = (apply #'append ranges)
+ with lows = (mapcar (lambda (x)
+ (cons (comp-range-1- (car x)) 'l))
+ all-ranges)
+ with highs = (mapcar (lambda (x)
+ (cons (cdr x) 'h))
+ all-ranges)
+ with nest = 0
+ with low = nil
+ with res = ()
+ for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car)
+ if (eq x 'l)
+ do
+ (when (zerop nest)
+ (setf low i))
+ (cl-incf nest)
+ else
+ do
+ (when (= nest 1)
+ (push `(,(comp-range-1+ low) . ,i) res))
+ (cl-decf nest)
+ finally (cl-return (reverse res))))
+
+(defun comp-range-intersection (&rest ranges)
+ "Combine integer intervals RANGES by intersecting."
+ (cl-loop
+ with all-ranges = (apply #'append ranges)
+ with n-ranges = (length ranges)
+ with lows = (mapcar (lambda (x)
+ (cons (car x) 'l))
+ all-ranges)
+ with highs = (mapcar (lambda (x)
+ (cons (cdr x) 'h))
+ all-ranges)
+ with nest = 0
+ with low = nil
+ with res = ()
+ initially (when (cl-some #'null ranges)
+ ;; Intersecting with a null range always results in a
+ ;; null range.
+ (cl-return '()))
+ for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car)
+ if (eq x 'l)
+ do
+ (cl-incf nest)
+ (when (= nest n-ranges)
+ (setf low i))
+ else
+ do
+ (when (= nest n-ranges)
+ (push `(,low . ,i)
+ res))
+ (cl-decf nest)
+ finally (cl-return (reverse res))))
+
+
+;;; Entry points.
+
+(defun comp-cstr-union-no-range (dst &rest srcs)
+ "As `comp-cstr-union' but escluding the irange component."
+ (let ((values (mapcar #'comp-cstr-valset srcs)))
+
+ ;; Type propagation.
+ (setf (comp-cstr-typeset dst)
+ (apply #'comp-union-typesets (mapcar #'comp-cstr-typeset srcs)))
+
+ ;; Value propagation.
+ (setf (comp-cstr-valset dst)
+ (cl-loop
+ ;; TODO sort.
+ for v in (cl-remove-duplicates (apply #'append values)
+ :test #'equal)
+ ;; We propagate only values those types are not already
+ ;; into typeset.
+ when (cl-notany (lambda (x)
+ (comp-subtype-p (type-of v) x))
+ (comp-cstr-typeset dst))
+ collect v))
+
+ dst))
+
+(defun comp-cstr-union (dst &rest srcs)
+ "Combine SRCS by union set operation setting the result in DST.
+DST is returned."
+ (apply #'comp-cstr-union-no-range dst srcs)
+ ;; Range propagation
+ (setf (comp-cstr-range dst)
+ (when (cl-notany (lambda (x)
+ (comp-subtype-p 'integer x))
+ (comp-cstr-typeset dst))
+ ;; TODO memoize?
+ (apply #'comp-range-union
+ (mapcar #'comp-cstr-range srcs))))
+ dst)
+
+(defun comp-cstr-union-make (&rest srcs)
+ "Combine SRCS by union set operation and return a new constraint."
+ (apply #'comp-cstr-union (make-comp-cstr) srcs))
+
+(defun comp-type-spec-to-cstr (type-spec &optional fn)
+ "Convert a type specifier TYPE-SPEC into a `comp-cstr'.
+FN non-nil indicates we are parsing a function lambda list."
+ (cl-flet ((star-or-num (x)
+ (or (numberp x) (eq '* x))))
+ (pcase type-spec
+ ((and (or '&optional '&rest) x)
+ (if fn
+ x
+ (error "Invalid `%s` in type specifier" x)))
+ ('fixnum
+ (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum)))
+ ('boolean
+ (comp-type-spec-to-cstr '(member t nil)))
+ ('null (comp-value-to-cstr nil))
+ ((pred atom)
+ (comp-type-to-cstr type-spec))
+ (`(or . ,rest)
+ (apply #'comp-cstr-union-make
+ (mapcar #'comp-type-spec-to-cstr rest)))
+ (`(and . ,rest)
+ (cl-assert nil)
+ ;; TODO
+ ;; (apply #'comp-cstr-intersect-make
+ ;; (mapcar #'comp-type-spec-to-cstr rest))
+ )
+ (`(not ,cstr)
+ (cl-assert nil)
+ ;; TODO
+ ;; (comp-cstr-negate-make (comp-type-spec-to-cstr cstr))
+ )
+ (`(integer ,(and (pred integerp) l) ,(and (pred integerp) h))
+ (comp-irange-to-cstr `(,l . ,h)))
+ (`(integer * ,(and (pred integerp) h))
+ (comp-irange-to-cstr `(- . ,h)))
+ (`(integer ,(and (pred integerp) l) *)
+ (comp-irange-to-cstr `(,l . +)))
+ (`(float ,(pred star-or-num) ,(pred star-or-num))
+ ;; No float range support :/
+ (comp-type-to-cstr 'float))
+ (`(member . ,rest)
+ (apply #'comp-cstr-union-make (mapcar #'comp-value-to-cstr rest)))
+ (`(function ,args ,ret)
+ (make-comp-cstr-f
+ :args (mapcar (lambda (x)
+ (comp-type-spec-to-cstr x t))
+ args)
+ :ret (comp-type-spec-to-cstr ret)))
+ (_ (error "Invalid type specifier")))))
+
+(defun comp-cstr-to-type-spec (cstr)
+ "Given CSTR return its type specifier."
+ (let ((valset (comp-cstr-valset cstr))
+ (typeset (comp-cstr-typeset cstr))
+ (range (comp-cstr-range cstr)))
+
+ (when valset
+ (when (memq nil valset)
+ (if (memq t valset)
+ (progn
+ ;; t and nil are values, convert into `boolean'.
+ (push 'boolean typeset)
+ (setf valset (remove t (remove nil valset))))
+ ;; Only nil is a value, convert it into a `null' type specifier.
+ (setf valset (remove nil valset))
+ (push 'null typeset))))
+
+ ;; Form proper integer type specifiers.
+ (setf range (cl-loop for (l . h) in range
+ for low = (if (integerp l) l '*)
+ for high = (if (integerp h) h '*)
+ collect `(integer ,low , high))
+ valset (cl-remove-duplicates valset))
+
+ ;; Form the final type specifier.
+ (let* ((types-ints (append typeset range))
+ (res (cond
+ ((and types-ints valset)
+ `((member ,@valset) ,@types-ints))
+ (types-ints types-ints)
+ (valset `(member ,@valset))
+ (t
+ ;; Empty type specifier
+ nil))))
+ (pcase res
+ (`(,(or 'integer 'member) . ,_rest) res)
+ ((pred atom) res)
+ (`(,_first . ,rest)
+ (if rest
+ `(or ,@res)
+ (car res)))))))
+
+(provide 'comp-cstr)
+
+;;; comp-cstr.el ends here
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 5313bfb..498aae1 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -38,6 +38,7 @@
(require 'rx)
(require 'subr-x)
(require 'warnings)
+(require 'comp-cstr)
(defgroup comp nil
"Emacs Lisp native compiler."
@@ -267,6 +268,16 @@ Useful to hook into pass checkers.")
(comp-hint-cons (function (t) cons)))
"Alist used for type propagation.")
+(defconst comp-known-func-cstr-h
+ (cl-loop
+ with comp-ctxt = (make-comp-cstr-ctxt)
+ with h = (make-hash-table :test #'eq)
+ for (f type-spec) in comp-known-type-specifiers
+ for cstr = (comp-type-spec-to-cstr type-spec)
+ do (puthash f cstr h)
+ finally (cl-return h))
+ "Hash table function -> `comp-constraint'")
+
(defconst comp-symbol-values-optimizable '(most-positive-fixnum
most-negative-fixnum)
"Symbol values we can resolve in the compile-time.")
@@ -326,7 +337,7 @@ Useful to hook into pass checkers.")
(idx (make-hash-table :test #'equal) :type hash-table
:documentation "Obj -> position into the previous field."))
-(cl-defstruct comp-ctxt
+(cl-defstruct (comp-ctxt (:include comp-cstr-ctxt))
"Lisp side of the compiler context."
(output nil :type string
:documentation "Target output file-name for the compilation.")
@@ -356,13 +367,7 @@ This is typically 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.")
- (union-typesets-mem (make-hash-table :test #'equal) :type hash-table
- :documentation "Serve memoization for
-`comp-union-typesets'.")
- (common-supertype-mem (make-hash-table :test #'equal) :type hash-table
- :documentation "Serve memoization for
-`comp-common-supertype'."))
+ :documentation "When non-nil support late load."))
(cl-defstruct comp-args-base
(min nil :type number
@@ -489,26 +494,8 @@ CFG is mutated by a pass.")
(lambda-list nil :type list
:documentation "Original lambda-list."))
-(cl-defstruct comp-constraint
- "Internal representation of a type/value constraint."
- (typeset '(t) :type list
- :documentation "List of possible types the mvar can assume.
-Each element cannot be a subtype of any other element of this slot.")
- (valset '() :type list
- :documentation "List of possible values the mvar can assume.
-Integer values are handled in the `range' slot.")
- (range '() :type list
- :documentation "Integer interval."))
-
-(cl-defstruct comp-constraint-f
- "Internal constraint representation for a function."
- (args nil :type (or null list)
- :documentation "List of `comp-constraint' for its arguments.")
- (ret nil :type (or comp-constraint comp-constraint-f)
- :documentation "Returned value `comp-constraint'."))
-
(cl-defstruct (comp-mvar (:constructor make--comp-mvar)
- (:include comp-constraint))
+ (:include comp-cstr))
"A meta-variable being a slot in the meta-stack."
(id nil :type (or null number)
:documentation "Unique id when in SSA form.")
@@ -592,108 +579,6 @@ To be used by all entry points."
((null (native-comp-available-p))
(error "Cannot find libgccjit"))))
-(cl-defun comp-type-spec-to-constraint (type-specifier)
- "Destructure TYPE-SPECIFIER.
-Return the corresponding `comp-constraint' or `comp-constraint-f'."
- (let (typeset valset range)
- (cl-labels ((star-or-num (x)
- (or (numberp x) (eq '* x)))
- (destructure-push (x)
- (pcase x
- ('&optional
- (cl-return-from comp-type-spec-to-constraint '&optional))
- ('&rest
- (cl-return-from comp-type-spec-to-constraint '&rest))
- ('null
- (push nil valset))
- ('boolean
- (push t valset)
- (push nil valset))
- ('fixnum
- (push `(,most-negative-fixnum . ,most-positive-fixnum)
- range))
- ('bignum
- (push `(- . ,(1- most-negative-fixnum))
- range)
- (push `(,(1+ most-positive-fixnum) . +)
- range))
- ((pred symbolp)
- (push x typeset))
- (`(member . ,rest)
- (setf valset (append rest valset)))
- ('(integer * *)
- (push '(- . +) range))
- (`(integer ,(and low (pred integerp)) *)
- (push `(,low . +) range))
- (`(integer * ,(and high (pred integerp)))
- (push `(- . ,high) range))
- (`(integer ,(and low (pred integerp))
- ,(and high (pred integerp)))
- (push `(,low . ,high) range))
- (`(float ,(pred star-or-num) ,(pred star-or-num))
- ;; No float range support :/
- (push 'float typeset))
- (`(function ,args ,ret-type-spec)
- (cl-return-from
- comp-type-spec-to-constraint
- (make-comp-constraint-f
- :args (mapcar #'comp-type-spec-to-constraint args)
- :ret (comp-type-spec-to-constraint ret-type-spec))))
- (_ (error "Unsopported type specifier")))))
- (if (or (atom type-specifier)
- (memq (car type-specifier) '(member integer float function)))
- (destructure-push type-specifier)
- (if (eq (car type-specifier) 'or)
- (mapc #'destructure-push (cdr type-specifier))
- (error "Unsopported type specifier")))
- (make-comp-constraint :typeset typeset
- :valset valset
- :range range))))
-
-(defconst comp-known-constraints-h
- (let ((h (make-hash-table :test #'eq)))
- (cl-loop
- for (f type-spec) in comp-known-type-specifiers
- for constr = (comp-type-spec-to-constraint type-spec)
- do (puthash f constr h))
- h)
- "Hash table function -> `comp-constraint'")
-
-(defun comp-constraint-to-type-spec (mvar)
- "Given MVAR return its type specifier."
- (let ((valset (comp-mvar-valset mvar))
- (typeset (comp-mvar-typeset mvar))
- (range (comp-mvar-range mvar)))
-
- (when valset
- (when (memq nil valset)
- (if (memq t valset)
- (progn
- ;; t and nil are values, convert into `boolean'.
- (push 'boolean typeset)
- (setf valset (remove t (remove nil valset))))
- ;; Only nil is a value, convert it into a `null' type specifier.
- (setf valset (remove nil valset))
- (push 'null typeset))))
-
- ;; Form proper integer type specifiers.
- (setf range (cl-loop for (l . h) in range
- for low = (if (integerp l) l '*)
- for high = (if (integerp h) h '*)
- collect `(integer ,low , high))
- valset (cl-remove-duplicates valset))
-
- ;; Form the final type specifier.
- (let ((res (append typeset
- (when valset
- `((member ,@valset)))
- range)))
- (if (> (length res) 1)
- `(or ,@res)
- (if (memq (car-safe res) '(member integer))
- res
- (car res))))))
-
(defun comp-set-op-p (op)
"Assignment predicate for OP."
(when (memq op comp-limple-sets) t))
@@ -2392,143 +2277,6 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or
post-order if non-nil."
;; This is also responsible for removing function calls to pure functions if
;; possible.
-(defconst comp--typeof-types (mapcar (lambda (x)
- (append x '(t)))
- cl--typeof-types)
- ;; TODO can we just add t in `cl--typeof-types'?
- "Like `cl--typeof-types' but with t as common supertype.")
-
-(defun comp-supertypes (type)
- "Return a list of pairs (supertype . hierarchy-level) for TYPE."
- (cl-loop
- named outer
- with found = nil
- for l in comp--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."
- (when-let ((types (cl-intersection
- (comp-supertypes type1)
- (comp-supertypes type2)
- :key #'car)))
- (car (cl-reduce (lambda (x y)
- (if (> (cdr x) (cdr y)) x y))
- types))))
-
-(defun comp-common-supertype (&rest types)
- "Return the first common supertype of TYPES."
- (or (gethash types (comp-ctxt-common-supertype-mem comp-ctxt))
- (puthash types
- (cl-reduce #'comp-common-supertype-2 types)
- (comp-ctxt-common-supertype-mem comp-ctxt))))
-
-(defsubst comp-subtype-p (type1 type2)
- "Return t if TYPE1 is a subtype of TYPE1 or nil otherwise."
- (eq (comp-common-supertype-2 type1 type2) type2))
-
-(defun comp-union-typesets (&rest typesets)
- "Union types present into TYPESETS."
- (or (gethash typesets (comp-ctxt-union-typesets-mem comp-ctxt))
- (puthash typesets
- (cl-loop
- with types = (apply #'append typesets)
- with res = '()
- for lane in comp--typeof-types
- do (cl-loop
- with last = nil
- for x in lane
- when (memq x types)
- do (setf last x)
- finally (when last
- (push last res)))
- finally (cl-return (cl-remove-duplicates res)))
- (comp-ctxt-union-typesets-mem comp-ctxt))))
-
-(defsubst comp-range-1+ (x)
- (if (symbolp x)
- x
- (1+ x)))
-
-(defsubst comp-range-1- (x)
- (if (symbolp x)
- x
- (1- x)))
-
-(defsubst comp-range-< (x y)
- (cond
- ((eq x '+) nil)
- ((eq x '-) t)
- ((eq y '+) t)
- ((eq y '-) nil)
- (t (< x y))))
-
-(defun comp-range-union (&rest ranges)
- "Combine integer intervals RANGES by union operation."
- (cl-loop
- with all-ranges = (apply #'append ranges)
- with lows = (mapcar (lambda (x)
- (cons (comp-range-1- (car x)) 'l))
- all-ranges)
- with highs = (mapcar (lambda (x)
- (cons (cdr x) 'h))
- all-ranges)
- with nest = 0
- with low = nil
- with res = ()
- for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car)
- if (eq x 'l)
- do
- (when (zerop nest)
- (setf low i))
- (cl-incf nest)
- else
- do
- (when (= nest 1)
- (push `(,(comp-range-1+ low) . ,i) res))
- (cl-decf nest)
- finally (cl-return (reverse res))))
-
-(defun comp-range-intersection (&rest ranges)
- "Combine integer intervals RANGES by intersecting."
- (cl-loop
- with all-ranges = (apply #'append ranges)
- with n-ranges = (length ranges)
- with lows = (mapcar (lambda (x)
- (cons (car x) 'l))
- all-ranges)
- with highs = (mapcar (lambda (x)
- (cons (cdr x) 'h))
- all-ranges)
- with nest = 0
- with low = nil
- with res = ()
- initially (when (cl-some #'null ranges)
- ;; Intersecting with a null range always results in a
- ;; null range.
- (cl-return '()))
- for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car)
- if (eq x 'l)
- do
- (cl-incf nest)
- (when (= nest n-ranges)
- (setf low i))
- else
- do
- (when (= nest n-ranges)
- (push `(,low . ,i)
- res))
- (cl-decf nest)
- finally (cl-return (reverse res))))
-
(defun comp-copy-insn (insn)
"Deep copy INSN."
;; Adapted from `copy-tree'.
@@ -2615,55 +2363,16 @@ Return non-nil if the function is folded successfully."
(value (comp-apply-in-env f (mapcar #'comp-mvar-value args))))
(rewrite-insn-as-setimm insn value)))))))
-(defun comp-phi (lval &rest rvals)
- "Phi function propagating RVALS into LVAL.
-Return LVAL."
- (let* ((rhs-mvars (mapcar #'car rvals))
- (values (mapcar #'comp-mvar-valset rhs-mvars))
- (from-latch (cl-some
- (lambda (x)
- (comp-latch-p
- (gethash (cdr x)
- (comp-func-blocks comp-func))))
- rvals)))
-
- ;; Type propagation.
- (setf (comp-mvar-typeset lval)
- (apply #'comp-union-typesets (mapcar #'comp-mvar-typeset rhs-mvars)))
-
- ;; Value propagation.
- (setf (comp-mvar-valset lval)
- (cl-loop
- for v in (cl-remove-duplicates (apply #'append values)
- :test #'equal)
- ;; We propagate only values those types are not already
- ;; into typeset.
- when (cl-notany (lambda (x)
- (comp-subtype-p (type-of v) x))
- (comp-mvar-typeset lval))
- collect v))
-
- ;; Range propagation
- (setf (comp-mvar-range lval)
- (when (and (not from-latch)
- (cl-notany (lambda (x)
- (comp-subtype-p 'integer x))
- (comp-mvar-typeset lval)))
- ;; TODO memoize?
- (apply #'comp-range-union
- (mapcar #'comp-mvar-range rhs-mvars))))
- lval))
-
(defun comp-fwprop-call (insn lval f args)
"Propagate on a call INSN into LVAL.
F is the function being called with arguments ARGS.
Fold the call in case."
(unless (comp-function-call-maybe-fold insn f args)
- (when-let ((constr (gethash f comp-known-constraints-h)))
- (let ((constr (comp-constraint-f-ret constr)))
- (setf (comp-mvar-range lval) (comp-constraint-range constr)
- (comp-mvar-valset lval) (comp-constraint-valset constr)
- (comp-mvar-typeset lval) (comp-constraint-typeset constr))))))
+ (when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
+ (let ((cstr (comp-cstr-f-ret cstr-f)))
+ (setf (comp-mvar-range lval) (comp-cstr-range cstr)
+ (comp-mvar-valset lval) (comp-cstr-valset cstr)
+ (comp-mvar-typeset lval) (comp-cstr-typeset cstr))))))
(defun comp-fwprop-insn (insn)
"Propagate within INSN."
@@ -2695,7 +2404,17 @@ Fold the call in case."
(`(setimm ,lval ,v)
(setf (comp-mvar-value lval) v))
(`(phi ,lval . ,rest)
- (apply #'comp-phi lval rest))))
+ (let* ((from-latch (cl-some
+ (lambda (x)
+ (comp-latch-p
+ (gethash (cdr x)
+ (comp-func-blocks comp-func))))
+ rest))
+ (prop-fn (if from-latch
+ #'comp-cstr-union-no-range
+ #'comp-cstr-union))
+ (rvals (mapcar #'car rest)))
+ (apply prop-fn lval rvals)))))
(defun comp-fwprop* ()
"Propagate for set* and phi operands.
@@ -2966,8 +2685,8 @@ These are substituted with a normal 'set' op."
"Compute type specifier for `comp-func' FUNC.
Set it into the `ret-type-specifier' slot."
(let* ((comp-func (make-comp-func))
- (res-mvar (apply #'comp-phi
- (make-comp-mvar)
+ (res-mvar (apply #'comp-cstr-union
+ (make-comp-cstr)
(cl-loop
with res = nil
for bb being the hash-value in (comp-func-blocks
@@ -2978,10 +2697,10 @@ Set it into the `ret-type-specifier' slot."
;; mvars and union results.
do (pcase insn
(`(return ,mvar)
- (push `(,mvar . nil) res))))
+ (push mvar res))))
finally (cl-return res)))))
(setf (comp-func-ret-type-specifier func)
- (comp-constraint-to-type-spec res-mvar))))
+ (comp-cstr-to-type-spec res-mvar))))
(defun comp-finalize-container (cont)
"Finalize data container CONT."
diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el
b/test/lisp/emacs-lisp/comp-cstr-tests.el
new file mode 100644
index 0000000..74419ff
--- /dev/null
+++ b/test/lisp/emacs-lisp/comp-cstr-tests.el
@@ -0,0 +1,68 @@
+;;; comp-cstr-tests.el --- unit tests for src/comp.c -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2020 Free Software Foundation, Inc.
+
+;; Author: Andrea Corallo <akrl@sdf.org>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Unit tests for lisp/emacs-lisp/comp-cstr.el
+
+;;; Code:
+
+(require 'ert)
+(require 'cl-lib)
+(require 'comp-cstr)
+
+(defun comp-cstr-test-ts (type-spec)
+ "Create a constraint from TYPE-SPEC and convert it back to type specifier."
+ (let ((comp-ctxt (make-comp-cstr-ctxt)))
+ (comp-cstr-to-type-spec (comp-type-spec-to-cstr type-spec))))
+
+(defun comp-cstr-typespec-test (number type-spec expected-type-spec)
+ `(ert-deftest ,(intern (concat "comp-cstr-test-" (int-to-string number))) ()
+ (should (equal (comp-cstr-test-ts ',type-spec)
+ ',expected-type-spec))))
+
+(defconst comp-cstr-typespec-tests-alist
+ `((symbol . symbol)
+ ((or string array) . array)
+ ;; ((and string array) . string)
+ ((or symbol number) . (or symbol number))
+ ((or cons atom) . (or cons atom)) ;; SBCL return T
+ ;; ((and cons atom) . (or cons atom))
+ ((member foo) . (member foo))
+ ((member foo bar) . (member foo bar))
+ ((or (member foo) (member bar)) . (member foo bar))
+ ;; ((and (member foo) (member bar)) . symbol)
+ ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO))
+ ;; ((and (member foo) symbol) . (member foo))
+ ((or (member foo) number) . (or (member foo) number)))
+ "Alist type specifier -> expected type specifier.")
+
+(defmacro comp-cstr-synthesize-tests ()
+ "Generate all tests from `comp-cstr-typespec-tests-alist'."
+ `(progn
+ ,@(cl-loop
+ for i from 0
+ for (ts . exp-ts) in comp-cstr-typespec-tests-alist
+ append (list (comp-cstr-typespec-test i ts exp-ts)))))
+
+(comp-cstr-synthesize-tests)
+
+;;; comp-cstr-tests.el ends here
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index fffc720..dd642b6 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -855,10 +855,10 @@ Return a list of results."
(if (= x y)
x
'foo))
- (or number (member foo)))
+ (or (member foo) number))
((defun comp-tests-ret-type-spec-9-1-f (x)
- (comp-hint-fixnum y))
+ (comp-hint-fixnum x))
(integer ,most-negative-fixnum ,most-positive-fixnum))
((defun comp-tests-ret-type-spec-f (x)
@@ -892,7 +892,8 @@ Return a list of results."
(comp-deftest ret-type-spec ()
"Some derived return type specifier tests."
- (cl-loop for (func-form type-spec) in comp-tests-type-spec-tests
+ (cl-loop with comp-ctxt = (make-comp-cstr-ctxt)
+ for (func-form type-spec) in comp-tests-type-spec-tests
do (comp-tests-check-ret-type-spec func-form type-spec)))
(defun comp-tests-pure-checker-1 (_)