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.

1 files changed, 363 insertions, 0 deletions

diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
new file mode 100644
index 00000000000..fcbb32fab2e
--- /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