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

@@ -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
 

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

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.")
+                  :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'."))
 
 (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)))
+    (when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
-      (let ((constr (comp-constraint-f-ret constr)))
+      (let ((cstr (comp-cstr-f-ret cstr-f)))
-        (setf (comp-mvar-range lval) (comp-constraint-range constr)
+        (setf (comp-mvar-range lval) (comp-cstr-range cstr)
-              (comp-mvar-valset lval) (comp-constraint-valset constr)
+              (comp-mvar-valset lval) (comp-cstr-valset cstr)
-              (comp-mvar-typeset lval) (comp-constraint-typeset constr))))))
+              (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
+         (res-mvar (apply #'comp-cstr-union
-                          (make-comp-mvar)
+                          (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."

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

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 (_)