From 23c082638e77219b51e14797a0edae27ae59a9d6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Nov 2020 23:51:17 +0100 Subject: [PATCH] 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(-) create mode 100644 lisp/emacs-lisp/comp-cstr.el create mode 100644 test/lisp/emacs-lisp/comp-cstr-tests.el diff --git a/lisp/Makefile.in b/lisp/Makefile.in index d6bb4cf5570..5fec921b072 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 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 + +;; 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 . + +;;; 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 5313bfba996..498aae183a5 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 00000000000..74419ff01e4 --- /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 + +;; 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 . + +;;; 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 fffc72015b8..dd642b6a66e 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 (_) -- 2.39.5