diff options
Diffstat (limited to 'lisp/emacs-lisp/comp-cstr.el')
| -rw-r--r-- | lisp/emacs-lisp/comp-cstr.el | 1197 |
1 files changed, 1197 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..3c5578217aa --- /dev/null +++ b/lisp/emacs-lisp/comp-cstr.el @@ -0,0 +1,1197 @@ +;;; comp-cstr.el --- native compiler constraint library -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. + +;; Author: Andrea Corallo <akrl@sdf.com> +;; 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 + (null (eq type 'null)) + (integer (eq type 'integer)) + (typeset (if (or null integer) + nil + (list type))) + (valset (when null + '(nil))) + (range (when integer + '((- . +)))))) + (:constructor comp-value-to-cstr + (value &aux + (integer (integerp value)) + (valset (unless integer + (list value))) + (range (when integer + `((,value . ,value)))) + (typeset ()))) + (:constructor comp-irange-to-cstr + (irange &aux + (range (list irange)) + (typeset ()))) + (:copier comp-cstr-shallow-copy)) + "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.") + (neg nil :type boolean + :documentation "Non-nil if the constraint is negated")) + +(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'.") + (subtype-p-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-subtype-p-mem'.") + (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'.") + (intersection-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`intersection-mem'.")) + +(defmacro with-comp-cstr-accessors (&rest body) + "Define some quick accessor to reduce code vergosity in BODY." + (declare (debug (form body)) + (indent defun)) + `(cl-macrolet ((typeset (x) + `(comp-cstr-typeset ,x)) + (valset (x) + `(comp-cstr-valset ,x)) + (range (x) + `(comp-cstr-range ,x)) + (neg (x) + `(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-sequence (typeset cstr)) + :valset (copy-sequence (valset cstr)) + :range (copy-tree (range cstr)) + :neg (neg cstr)))) + +(defsubst comp-cstr-empty-p (cstr) + "Return t if CSTR is equivalent to the `nil' type specifier or nil otherwise." + (with-comp-cstr-accessors + (and (null (typeset cstr)) + (null (valset cstr)) + (null (range cstr)) + (null (neg cstr))))) + +(defsubst comp-cstr-null-p (cstr) + "Return t if CSTR is equivalent to the `null' type specifier, nil otherwise." + (with-comp-cstr-accessors + (and (null (typeset cstr)) + (null (range cstr)) + (null (neg cstr)) + (equal (valset cstr) '(nil))))) + +(defun comp-cstrs-homogeneous (cstrs) + "Check if constraints CSTRS are all homogeneously negated or non-negated. +Return `pos' if they are all positive, `neg' if they are all +negated or nil othewise." + (cl-loop + for cstr in cstrs + unless (comp-cstr-neg cstr) + count t into n-pos + else + count t into n-neg + finally + (cond + ((zerop n-neg) (cl-return 'pos)) + ((zerop n-pos) (cl-return 'neg))))) + +(defun comp-split-pos-neg (cstrs) + "Split constraints CSTRS into non-negated and negated. +Return them as multiple value." + (cl-loop + for cstr in cstrs + if (comp-cstr-neg cstr) + collect cstr into negatives + else + collect cstr into positives + finally return (cl-values positives negatives))) + +;; So we can load comp-cstr.el and comp.el in non native compiled +;; builds. +(defvar comp-ctxt nil) + +(defvar comp-cstr-one (comp-value-to-cstr 1) + "Represent the integer immediate one.") + +(defvar comp-cstr-t (comp-type-to-cstr t) + "Represent the superclass t.") + + +;;; Value handling. + +(defun comp-normalize-valset (valset) + "Sort and remove duplicates from VALSET then return it." + (cl-sort (cl-remove-duplicates valset :test #'eq) + (lambda (x y) + (cond + ((and (symbolp x) (symbolp y)) + (string< x y)) + ((and (symbolp x) (not (symbolp y))) + t) + ((and (not (symbolp x)) (symbolp y)) + nil) + (t + (< (sxhash-equal x) + (sxhash-equal y))))))) + +(defun comp-union-valsets (&rest valsets) + "Union values present into VALSETS." + (comp-normalize-valset (cl-reduce #'cl-union valsets))) + +(defun comp-intersection-valsets (&rest valsets) + "Union values present into VALSETS." + (comp-normalize-valset (cl-reduce #'cl-intersection valsets))) + + +;;; Type handling. + +(defun comp-normalize-typeset (typeset) + "Sort TYPESET and return it." + (cl-sort (cl-remove-duplicates typeset) + (lambda (x y) + (string-lessp (symbol-name x) + (symbol-name y))))) + +(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." + (let ((types (cons type1 type2))) + (or (gethash types (comp-cstr-ctxt-subtype-p-mem comp-ctxt)) + (puthash types + (eq (comp-common-supertype-2 type1 type2) type2) + (comp-cstr-ctxt-subtype-p-mem comp-ctxt))))) + +(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))) + finally return (comp-normalize-typeset res)) + (comp-cstr-ctxt-union-typesets-mem comp-ctxt)))) + +(defun comp-intersect-two-typesets (t1 t2) + "Intersect typesets T1 and T2." + (with-comp-cstr-accessors + (cl-loop + for types in (list t1 t2) + for other-types in (list t2 t1) + append + (cl-loop + for type in types + when (cl-some (lambda (x) + (comp-subtype-p type x)) + other-types) + collect type)))) + +(defun comp-intersect-typesets (&rest typesets) + "Intersect types present into TYPESETS." + (unless (cl-some #'null typesets) + (if (length= typesets 1) + (car typesets) + (comp-normalize-typeset + (cl-reduce #'comp-intersect-two-typesets typesets))))) + + +;;; Integer range handling + +(defsubst comp-star-or-num-p (x) + (or (numberp x) (eq '* x))) + +(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) + (pcase (cons x y) + ((or '(+ . -) '(- . +)) '??) + ((or `(- . ,_) `(,_ . -)) '-) + ((or `(+ . ,_) `(,_ . +)) '+) + (_ (+ x y)))) + +(defsubst comp-range-- (x y) + (pcase (cons x y) + ((or '(+ . +) '(- . -)) '??) + ('(+ . -) '+) + ('(- . +) '-) + ((or `(+ . ,_) `(,_ . -)) '+) + ((or `(- . ,_) `(,_ . +)) '-) + (_ (- x y)))) + +(defsubst comp-range-< (x y) + (cond + ((eq x '+) nil) + ((eq x '-) t) + ((eq y '+) t) + ((eq y '-) nil) + (t (< x y)))) + +(defsubst comp-cstr-smallest-in-range (range) + "Smallest entry in RANGE." + (caar range)) + +(defsubst comp-cstr-greatest-in-range (range) + "Greater entry in RANGE." + (cdar (last range))) + +(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 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 = () + for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) + initially (when (cl-some #'null ranges) + ;; Intersecting with a null range always results in a + ;; null range. + (cl-return '())) + 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 return (reverse res))) + +(defun comp-range-negation (range) + "Negate range RANGE." + (if (null range) + '((- . +)) + (cl-loop + with res = () + with last-h = '- + for (l . h) in range + unless (eq l '-) + do (push `(,(comp-range-1+ last-h) . ,(1- l)) res) + do (setf last-h h) + finally + (unless (eq '+ last-h) + (push `(,(1+ last-h) . +) res)) + (cl-return (reverse res))))) + +(defsubst comp-cstr-set-cmp-range (dst old-dst ext-range) + "Support range comparison functions." + (with-comp-cstr-accessors + (if ext-range + (setf (typeset dst) (when (cl-some (lambda (x) + (comp-subtype-p 'float x)) + (typeset old-dst)) + '(float)) + (valset dst) () + (range dst) (if (range old-dst) + (comp-range-intersection (range old-dst) + ext-range) + ext-range) + (neg dst) nil) + (setf (typeset dst) (typeset old-dst) + (valset dst) (valset old-dst) + (range dst) (range old-dst) + (neg dst) (neg old-dst))))) + +(defmacro comp-cstr-set-range-for-arithm (dst src1 src2 &rest range-body) + ;; Prevent some code duplication for `comp-cstr-add-2' + ;; `comp-cstr-sub-2'. + (declare (debug (range-body)) + (indent defun)) + `(with-comp-cstr-accessors + (when-let ((r1 (range ,src1)) + (r2 (range ,src2))) + (let* ((l1 (comp-cstr-smallest-in-range r1)) + (l2 (comp-cstr-smallest-in-range r2)) + (h1 (comp-cstr-greatest-in-range r1)) + (h2 (comp-cstr-greatest-in-range r2))) + (setf (typeset ,dst) (when (cl-some (lambda (x) + (comp-subtype-p 'float x)) + (append (typeset src1) + (typeset src2))) + '(float)) + (range ,dst) ,@range-body))))) + +(defun comp-cstr-add-2 (dst src1 src2) + "Sum SRC1 and SRC2 into DST." + (comp-cstr-set-range-for-arithm dst src1 src2 + `((,(comp-range-+ l1 l2) . ,(comp-range-+ h1 h2))))) + +(defun comp-cstr-sub-2 (dst src1 src2) + "Subtract SRC1 and SRC2 into DST." + (comp-cstr-set-range-for-arithm dst src1 src2 + (let ((l (comp-range-- l1 h2)) + (h (comp-range-- h1 l2))) + (if (or (eq l '??) (eq h '??)) + '((- . +)) + `((,l . ,h)))))) + + +;;; Union specific code. + +(defun comp-cstr-union-homogeneous-no-range (dst &rest srcs) + "As `comp-cstr-union' but escluding the irange component. +All SRCS constraints must be homogeneously negated or non-negated." + + ;; Type propagation. + (setf (comp-cstr-typeset dst) + (apply #'comp-union-typesets (mapcar #'comp-cstr-typeset srcs))) + + ;; Value propagation. + (setf (comp-cstr-valset dst) + (comp-normalize-valset + (cl-loop + with values = (mapcar #'comp-cstr-valset srcs) + ;; 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-homogeneous (range dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +Do range propagation when RANGE is non-nil. +All SRCS constraints must be homogeneously negated or non-negated. +DST is returned." + (apply #'comp-cstr-union-homogeneous-no-range dst srcs) + ;; Range propagation. + (setf (comp-cstr-neg dst) + (when srcs + (comp-cstr-neg (car srcs))) + + (comp-cstr-range dst) + (when (cl-notany (lambda (x) + (comp-subtype-p 'integer x)) + (comp-cstr-typeset dst)) + (if range + (apply #'comp-range-union + (mapcar #'comp-cstr-range srcs)) + '((- . +))))) + dst) + +(cl-defun comp-cstr-union-1-no-mem (range &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 + (let ((dst (make-comp-cstr))) + (cl-flet ((give-up () + (setf (typeset dst) '(t) + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-union-1-no-mem dst))) + + ;; Check first if we are in the simple case of all input non-negate + ;; or negated so we don't have to cons. + (when-let ((res (comp-cstrs-homogeneous srcs))) + (apply #'comp-cstr-union-homogeneous range dst srcs) + (cl-return-from comp-cstr-union-1-no-mem dst)) + + ;; Some are negated and some are not + (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) + (let* ((pos (apply #'comp-cstr-union-homogeneous range + (make-comp-cstr) positives)) + ;; We'll always use neg as result as this is almost + ;; always necessary for describing open intervals + ;; resulting from negated constraints. + (neg (apply #'comp-cstr-union-homogeneous range + (make-comp-cstr :neg t) negatives))) + ;; Type propagation. + (when (and (typeset pos) + ;; When every pos type is a subtype of some neg ones. + (cl-every (lambda (x) + (cl-some (lambda (y) + (comp-subtype-p x y)) + (append (typeset neg) + (when (range neg) + '(integer))))) + (typeset pos))) + ;; This is a conservative choice, ATM we can't represent such + ;; a disjoint set of types unless we decide to add a new slot + ;; into `comp-cstr' or adopt something like + ;; `intersection-type' `union-type' in SBCL. Keep it + ;; "simple" for now. + (give-up)) + + ;; When every neg type is a subtype of some pos one. + ;; In case return pos. + (when (and (typeset neg) + (cl-every (lambda (x) + (cl-some (lambda (y) + (comp-subtype-p x y)) + (append (typeset pos) + (when (range pos) + '(integer))))) + (typeset neg))) + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) + (neg dst) nil) + (cl-return-from comp-cstr-union-1-no-mem dst)) + + ;; Verify disjoint condition between positive types and + ;; negative types coming from values, in case give-up. + (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) + (when (range neg) + '(integer))))) + (when (cl-some (lambda (x) + (cl-some (lambda (y) + (and (not (eq y x)) + (comp-subtype-p y x))) + neg-value-types)) + (typeset pos)) + (give-up))) + + ;; Value propagation. + (cond + ((and (valset pos) (valset neg) + (equal (comp-union-valsets (valset pos) (valset neg)) + (valset pos))) + ;; Pos is a superset of neg. + (give-up)) + ((cl-some (lambda (x) + (cl-some (lambda (y) + (comp-subtype-p y x)) + (mapcar #'type-of (valset pos)))) + (typeset neg)) + (give-up)) + (t + ;; pos is a subset or eq to neg + (setf (valset neg) + (cl-nset-difference (valset neg) (valset pos))))) + + ;; Range propagation + (when range + ;; Handle apart (or (integer 1 1) (not (integer 1 1))) + ;; like cases. + (if (and (range pos) (range neg) + (equal (range pos) (range neg))) + (give-up) + (setf (range neg) + (comp-range-negation + (comp-range-union + (comp-range-negation (range neg)) + (range pos)))))) + + (if (comp-cstr-empty-p neg) + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) + (neg dst) nil) + (setf (typeset dst) (typeset neg) + (valset dst) (valset neg) + (range dst) (range neg) + (neg dst) (neg neg))))) + + ;; (not null) => t + (when (and (neg dst) + (null (typeset dst)) + (null (valset dst)) + (null (range dst))) + (give-up))) + + 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." + (with-comp-cstr-accessors + (let* ((mem-h (if range + (comp-cstr-ctxt-union-1-mem-range comp-ctxt) + (comp-cstr-ctxt-union-1-mem-no-range comp-ctxt))) + (res (or (gethash srcs mem-h) + (puthash + (mapcar #'comp-cstr-copy srcs) + (apply #'comp-cstr-union-1-no-mem range srcs) + mem-h)))) + (setf (typeset dst) (typeset res) + (valset dst) (valset res) + (range dst) (range res) + (neg dst) (neg res)) + res))) + +(cl-defun comp-cstr-intersection-homogeneous (dst &rest srcs) + "Combine SRCS by intersection set operation setting the result in DST. +All SRCS constraints must be homogeneously negated or non-negated. +DST is returned." + + (with-comp-cstr-accessors + (when (cl-some #'comp-cstr-empty-p srcs) + (setf (valset dst) nil + (range dst) nil + (typeset dst) nil) + (cl-return-from comp-cstr-intersection-homogeneous dst)) + + (setf (neg dst) (when srcs + (neg (car srcs)))) + + ;; Type propagation. + (setf (typeset dst) + (apply #'comp-intersect-typesets + (mapcar #'comp-cstr-typeset srcs))) + + ;; Value propagation. + (setf (valset dst) + (comp-normalize-valset + (cl-loop + for src in srcs + append + (cl-loop + for val in (valset src) + ;; If (member value) is subtypep of all other sources then + ;; is good to be colleted. + when (cl-every (lambda (s) + (or (memql val (valset s)) + (cl-some (lambda (type) + (cl-typep val type)) + (typeset s)))) + (remq src srcs)) + collect val)))) + + ;; Range propagation. + (setf (range dst) + ;; Do range propagation only if the destination typeset + ;; doesn't cover it already. + (unless (cl-some (lambda (type) + (comp-subtype-p 'integer type)) + (typeset dst)) + (apply #'comp-range-intersection + (cl-loop + for src in srcs + ;; Collect effective ranges. + collect (or (range src) + (when (cl-some (lambda (s) + (comp-subtype-p 'integer s)) + (typeset src)) + '((- . +)))))))) + + dst)) + +(cl-defun comp-cstr-intersection-no-mem (&rest srcs) + "Combine SRCS by intersection set operation. +Non memoized version of `comp-cstr-intersection-no-mem'." + (let ((dst (make-comp-cstr))) + (with-comp-cstr-accessors + (cl-flet ((return-empty () + (setf (typeset dst) () + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-intersection-no-mem dst))) + (when-let ((res (comp-cstrs-homogeneous srcs))) + (if (eq res 'neg) + (apply #'comp-cstr-union-homogeneous t dst srcs) + (apply #'comp-cstr-intersection-homogeneous dst srcs)) + (cl-return-from comp-cstr-intersection-no-mem dst)) + + ;; Some are negated and some are not + (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) + (let* ((pos (apply #'comp-cstr-intersection-homogeneous + (make-comp-cstr) positives)) + (neg (apply #'comp-cstr-intersection-homogeneous + (make-comp-cstr) negatives))) + + ;; In case pos is not relevant return directly the content + ;; of neg. + (when (equal (typeset pos) '(t)) + (setf (typeset dst) (typeset neg) + (valset dst) (valset neg) + (range dst) (range neg) + (neg dst) t) + + ;; (not t) => nil + (when (and (null (valset dst)) + (null (range dst)) + (neg dst) + (equal '(t) (typeset dst))) + (setf (typeset dst) () + (neg dst) nil)) + + (cl-return-from comp-cstr-intersection-no-mem dst)) + + (when (cl-some + (lambda (ty) + (memq ty (typeset neg))) + (typeset pos)) + (return-empty)) + + ;; Some negated types are subtypes of some non-negated one. + ;; Transform the corresponding set of types from neg to pos. + (cl-loop + for neg-type in (typeset neg) + do (cl-loop + for pos-type in (copy-sequence (typeset pos)) + when (and (not (eq neg-type pos-type)) + (comp-subtype-p neg-type pos-type)) + do (cl-loop + with found + for (type . _) in (comp-supertypes neg-type) + when found + collect type into res + when (eq type pos-type) + do (setf (typeset pos) (cl-union (typeset pos) res)) + (cl-return) + when (eq type neg-type) + do (setf found t)))) + + (setf (range pos) + (comp-range-intersection (range pos) + (comp-range-negation (range neg))) + (valset pos) + (cl-set-difference (valset pos) (valset neg))) + + ;; Return a non negated form. + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) + (neg dst) nil))) + dst)))) + + +;;; Entry points. + +(defun comp-cstr-imm-vld-p (cstr) + "Return t if one and only one immediate value can be extracted from CSTR." + (with-comp-cstr-accessors + (when (and (null (typeset cstr)) + (null (neg cstr))) + (let* ((v (valset cstr)) + (r (range cstr)) + (valset-len (length v)) + (range-len (length r))) + (if (and (= valset-len 1) + (= range-len 0)) + t + (when (and (= valset-len 0) + (= range-len 1)) + (let* ((low (caar r)) + (high (cdar r))) + (and (integerp low) + (integerp high) + (= low high))))))))) + +(defun comp-cstr-imm (cstr) + "Return the immediate value of CSTR. +`comp-cstr-imm-vld-p' *must* be satisfied before calling +`comp-cstr-imm'." + (declare (gv-setter + (lambda (val) + `(with-comp-cstr-accessors + (if (integerp ,val) + (setf (typeset ,cstr) nil + (range ,cstr) (list (cons ,val ,val))) + (setf (typeset ,cstr) nil + (valset ,cstr) (list ,val))))))) + (with-comp-cstr-accessors + (let ((v (valset cstr))) + (if (length= v 1) + (car v) + (caar (range cstr)))))) + +(defun comp-cstr-fixnum-p (cstr) + "Return t if CSTR is certainly a fixnum." + (with-comp-cstr-accessors + (when (null (neg cstr)) + (when-let (range (range cstr)) + (let* ((low (caar range)) + (high (cdar (last range)))) + (unless (or (eq low '-) + (< low most-negative-fixnum) + (eq high '+) + (> high most-positive-fixnum)) + t)))))) + +(defun comp-cstr-symbol-p (cstr) + "Return t if CSTR is certainly a symbol." + (with-comp-cstr-accessors + (and (null (range cstr)) + (null (neg cstr)) + (or (and (null (valset cstr)) + (equal (typeset cstr) '(symbol))) + (and (or (null (typeset cstr)) + (equal (typeset cstr) '(symbol))) + (cl-every #'symbolp (valset cstr))))))) + +(defsubst comp-cstr-cons-p (cstr) + "Return t if CSTR is certainly a cons." + (with-comp-cstr-accessors + (and (null (valset cstr)) + (null (range cstr)) + (null (neg cstr)) + (equal (typeset cstr) '(cons))))) + +(defun comp-cstr-= (dst op1 op2) + "Constraint OP1 being = OP2 setting the result into DST." + (with-comp-cstr-accessors + (cl-flet ((relax-cstr (cstr) + (setf cstr (comp-cstr-shallow-copy cstr)) + ;; If can be any float extend it to all integers. + (when (memq 'float (typeset cstr)) + (setf (range cstr) '((- . +)))) + ;; For each float value that can be represented + ;; precisely as an integer add the integer as well. + (cl-loop + for v in (valset cstr) + do + (when-let* ((ok (floatp v)) + (truncated (ignore-error overflow-error + (truncate v))) + (ok (= v truncated))) + (push (cons truncated truncated) (range cstr)))) + (cl-loop + with vals-to-add + for (l . h) in (range cstr) + ;; If an integer range reduces to single value add + ;; its float value too. + if (eql l h) + do (push (float l) vals-to-add) + ;; Otherwise can be any float. + else + do (cl-pushnew 'float (typeset cstr)) + (cl-return cstr) + finally (setf (valset cstr) + (append vals-to-add (valset cstr)))) + (when (memql 0.0 (valset cstr)) + (cl-pushnew -0.0 (valset cstr))) + (when (memql -0.0 (valset cstr)) + (cl-pushnew 0.0 (valset cstr))) + cstr)) + (comp-cstr-intersection dst (relax-cstr op1) (relax-cstr op2))))) + +(defun comp-cstr-> (dst old-dst src) + "Constraint DST being > than SRC. +SRC can be either a comp-cstr or an integer." + (with-comp-cstr-accessors + (let ((ext-range + (if (integerp src) + `((,(1+ src) . +)) + (when-let* ((range (range src)) + (low (comp-cstr-smallest-in-range range)) + (okay (integerp low))) + `((,(1+ low) . +)))))) + (comp-cstr-set-cmp-range dst old-dst ext-range)))) + +(defun comp-cstr->= (dst old-dst src) + "Constraint DST being >= than SRC. +SRC can be either a comp-cstr or an integer." + (with-comp-cstr-accessors + (let ((ext-range + (if (integerp src) + `((,src . +)) + (when-let* ((range (range src)) + (low (comp-cstr-smallest-in-range range)) + (okay (integerp low))) + `((,low . +)))))) + (comp-cstr-set-cmp-range dst old-dst ext-range)))) + +(defun comp-cstr-< (dst old-dst src) + "Constraint DST being < than SRC. +SRC can be either a comp-cstr or an integer." + (with-comp-cstr-accessors + (let ((ext-range + (if (integerp src) + `((- . ,(1- src))) + (when-let* ((range (range src)) + (low (comp-cstr-greatest-in-range range)) + (okay (integerp low))) + `((- . ,(1- low))))))) + (comp-cstr-set-cmp-range dst old-dst ext-range)))) + +(defun comp-cstr-<= (dst old-dst src) + "Constraint DST being > than SRC. +SRC can be either a comp-cstr or an integer." + (with-comp-cstr-accessors + (let ((ext-range + (if (integerp src) + `((- . ,src)) + (when-let* ((range (range src)) + (low (comp-cstr-greatest-in-range range)) + (okay (integerp low))) + `((- . ,low)))))) + (comp-cstr-set-cmp-range dst old-dst ext-range)))) + +(defun comp-cstr-add (dst srcs) + "Sum SRCS into DST." + (comp-cstr-add-2 dst (cl-first srcs) (cl-second srcs)) + (cl-loop + for src in (nthcdr 2 srcs) + do (comp-cstr-add-2 dst dst src))) + +(defun comp-cstr-sub (dst srcs) + "Subtract SRCS into DST." + (comp-cstr-sub-2 dst (cl-first srcs) (cl-second srcs)) + (cl-loop + for src in (nthcdr 2 srcs) + do (comp-cstr-sub-2 dst dst src))) + +(defun comp-cstr-union-no-range (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +Do not propagate the range component. +DST is returned." + (apply #'comp-cstr-union-1 nil dst srcs)) + +(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-1 t dst srcs)) + +(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-cstr-intersection (dst &rest srcs) + "Combine SRCS by intersection set operation setting the result in DST. +DST is returned." + (with-comp-cstr-accessors + (let* ((mem-h (comp-cstr-ctxt-intersection-mem comp-ctxt)) + (res (or (gethash srcs mem-h) + (puthash + (mapcar #'comp-cstr-copy srcs) + (apply #'comp-cstr-intersection-no-mem srcs) + mem-h)))) + (setf (typeset dst) (typeset res) + (valset dst) (valset res) + (range dst) (range res) + (neg dst) (neg res)) + res))) + +(defun comp-cstr-intersection-no-hashcons (dst &rest srcs) + "Combine SRCS by intersection set operation setting the result in DST. +Non hash consed values are not propagated as values but rather +promoted to their types. +DST is returned." + (with-comp-cstr-accessors + (apply #'comp-cstr-intersection dst srcs) + (if (and (neg dst) + (valset dst) + (cl-notevery #'symbolp (valset dst))) + (setf (valset dst) () + (typeset dst) '(t) + (range dst) () + (neg dst) nil) + (let (strip-values strip-types) + (cl-loop for v in (valset dst) + unless (symbolp v) + do (push v strip-values) + (push (type-of v) strip-types)) + (when strip-values + (setf (typeset dst) (comp-union-typesets (typeset dst) strip-types) + (valset dst) (cl-set-difference (valset dst) strip-values))) + (cl-loop for (l . h) in (range dst) + when (or (bignump l) (bignump h)) + do (setf (range dst) '((- . +))) + (cl-return)))) + dst)) + +(defun comp-cstr-intersection-make (&rest srcs) + "Combine SRCS by intersection set operation and return a new constraint." + (apply #'comp-cstr-intersection (make-comp-cstr) srcs)) + +(defun comp-cstr-negation (dst src) + "Negate SRC setting the result in DST. +DST is returned." + (with-comp-cstr-accessors + (cond + ((and (null (valset src)) + (null (range src)) + (null (neg src)) + (equal (typeset src) '(t))) + (setf (typeset dst) () + (valset dst) () + (range dst) nil + (neg dst) nil)) + ((and (null (valset src)) + (null (range src)) + (null (neg src)) + (null (typeset src))) + (setf (typeset dst) '(t) + (valset dst) () + (range dst) nil + (neg dst) nil)) + (t (setf (typeset dst) (typeset src) + (valset dst) (valset src) + (range dst) (range src) + (neg dst) (not (neg src))))) + dst)) + +(defun comp-cstr-value-negation (dst src) + "Negate values in SRC setting the result in DST. +DST is returned." + (with-comp-cstr-accessors + (if (or (valset src) (range src)) + (setf (typeset dst) () + (valset dst) (valset src) + (range dst) (range src) + (neg dst) (not (neg src))) + (setf (typeset dst) (typeset src) + (valset dst) () + (range dst) ())) + dst)) + +(defun comp-cstr-negation-make (src) + "Negate SRC and return a new constraint." + (comp-cstr-negation (make-comp-cstr) src)) + +(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." + (pcase type-spec + ((and (or '&optional '&rest) x) + (if fn + x + (error "Invalid `%s` in type specifier" x))) + ('nil + (make-comp-cstr :typeset ())) + ('fixnum + (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum))) + ('boolean + (comp-type-spec-to-cstr '(member t nil))) + ('integer + (comp-irange-to-cstr '(- . +))) + ('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) + (apply #'comp-cstr-intersection-make + (mapcar #'comp-type-spec-to-cstr rest))) + (`(not ,cstr) + (comp-cstr-negation-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 comp-star-or-num-p) ,(pred comp-star-or-num-p)) + ;; 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)) + (negated (comp-cstr-neg 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 '*) + if (and (eq low '*) (eq high '*)) + collect 'integer + else + 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))) + (final + (pcase res + ((or `(member . ,rest) + `(integer ,(pred comp-star-or-num-p) + ,(pred comp-star-or-num-p))) + (if rest + res + (car res))) + ((pred atom) res) + (`(,_first . ,rest) + (if rest + `(or ,@res) + (car res)))))) + (if negated + `(not ,final) + final)))) + +(provide 'comp-cstr) + +;;; comp-cstr.el ends here |