From a467fa5c499c5808c6886d0d71640c1352498db8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 12 Nov 2020 17:27:31 +0100 Subject: [PATCH] Characterize functions in terms of type specifiers * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): New const in place of `comp-known-ret-types' and `comp-known-ret-ranges'. (comp-constraint): New struct to separate the constraint side of an mvar. (comp-constraint-f): Analogous for functions. (comp-mvar): Rework and include `comp-constraint'. (comp-type-spec-to-constraint): New function. (comp-known-constraints-h): New const. (comp-func-ret-typeset, comp-func-ret-range): Rework. (comp-fwprop-insn): Fix. * test/src/comp-tests.el (destructure-type-spec): New testcase. --- lisp/emacs-lisp/comp.el | 143 +++++++++++++++++++++++++++++----------- test/src/comp-tests.el | 35 ++++++++++ 2 files changed, 140 insertions(+), 38 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 217eec1b568..96b2b29043a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -191,31 +191,17 @@ For internal use only by the testsuite.") Each function in FUNCTIONS is run after PASS. Useful to hook into pass checkers.") -(defconst comp-known-ret-types '((cons . (cons)) - (1+ . (number)) - (1- . (number)) - (+ . (number)) - (- . (number)) - (* . (number)) - (/ . (number)) - (% . (number)) - ;; Type hints - (comp-hint-cons . (cons))) +(defconst comp-known-type-specifiers + `((cons (function (t t) cons)) + (1+ (function ((or number marker)) number)) + (1- (function ((or number marker)) number)) + (+ (function (&rest (or number marker)) number)) + (- (function (&rest (or number marker)) number)) + (* (function (&rest (or number marker)) number)) + (/ (function ((or number marker) &rest (or number marker)) number)) + (% (function ((or number marker) (or number marker)) number))) "Alist used for type propagation.") -(defconst comp-known-ret-ranges - `((comp-hint-fixnum . (,most-negative-fixnum . ,most-positive-fixnum))) - "Known returned ranges.") - -;; TODO fill it. -(defconst comp-type-predicates '((cons . consp) - (float . floatp) - (integer . integerp) - (number . numberp) - (string . stringp) - (symbol . symbolp)) - "Alist type -> predicate.") - (defconst comp-symbol-values-optimizable '(most-positive-fixnum most-negative-fixnum) "Symbol values we can resolve in the compile-time.") @@ -438,22 +424,33 @@ CFG is mutated by a pass.") (lambda-list nil :type list :documentation "Original lambda-list.")) -(cl-defstruct (comp-mvar (:constructor make--comp-mvar)) - "A meta-variable being a slot in the meta-stack." - (id nil :type (or null number) - :documentation "Unique id when in SSA form.") - (slot nil :type (or fixnum symbol) - :documentation "Slot number in the array if a number or - 'scratch' for scratch slot.") +(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. -Interg values are handled in the `range' slot.") +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)) + "A meta-variable being a slot in the meta-stack." + (id nil :type (or null number) + :documentation "Unique id when in SSA form.") + (slot nil :type (or fixnum symbol) + :documentation "Slot number in the array if a number or + 'scratch' for scratch slot.")) + (defun comp-mvar-value-vld-p (mvar) "Return t if one single value can be extracted by the MVAR constrains." (when (null (comp-mvar-typeset mvar)) @@ -529,6 +526,73 @@ 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-set-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-sets) t)) @@ -550,12 +614,15 @@ To be used by all entry points." (when (memq func comp-type-hints) t)) (defun comp-func-ret-typeset (func) - "Return the typeset returned by function FUNC. " - (or (alist-get func comp-known-ret-types) '(t))) + "Return the typeset returned by function FUNC." + (if-let ((spec (gethash func comp-known-constraints-h))) + (comp-constraint-typeset (comp-constraint-f-ret spec)) + '(t))) -(defsubst comp-func-ret-range (func) - "Return the range returned by function FUNC. " - (alist-get func comp-known-ret-ranges)) +(defun comp-func-ret-range (func) + "Return the range returned by function FUNC." + (when-let ((spec (gethash func comp-known-constraints-h))) + (comp-constraint-range (comp-constraint-f-ret spec)))) (defun comp-func-unique-in-cu-p (func) "Return t if FUNC is known to be unique in the current compilation unit." @@ -2495,7 +2562,7 @@ Return LVAL." (pcase rval (`(,(or 'call 'callref) ,f . ,args) (if-let ((range (comp-func-ret-range f))) - (setf (comp-mvar-range lval) (list range) + (setf (comp-mvar-range lval) range (comp-mvar-typeset lval) nil) (setf (comp-mvar-typeset lval) (comp-func-ret-typeset f))) @@ -2503,7 +2570,7 @@ Return LVAL." (`(,(or 'direct-call 'direct-callref) ,f . ,args) (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) (if-let ((range (comp-func-ret-range f))) - (setf (comp-mvar-range lval) (list range) + (setf (comp-mvar-range lval) range (comp-mvar-typeset lval) nil) (setf (comp-mvar-typeset lval) (comp-func-ret-typeset f))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index b2f83998838..a293a490d95 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1000,4 +1000,39 @@ Return a list of results." (should (equal (comp-union-typesets '(integer symbol) '()) '(symbol integer))))) +(comp-deftest destructure-type-spec () + (should (equal (comp-type-spec-to-constraint 'symbol) + (make-comp-constraint :typeset '(symbol)))) + (should (equal (comp-type-spec-to-constraint '(or symbol number)) + (make-comp-constraint :typeset '(number symbol)))) + (should-error (comp-type-spec-to-constraint '(symbol number))) + (should (equal (comp-type-spec-to-constraint '(member foo bar)) + (make-comp-constraint :typeset nil :valset '(foo bar)))) + (should (equal (comp-type-spec-to-constraint '(integer 1 2)) + (make-comp-constraint :typeset nil :range '((1 . 2))))) + (should (equal (comp-type-spec-to-constraint '(or (integer 1 2) (integer 4 5))) + (make-comp-constraint :typeset nil :range '((4 . 5) (1 . 2))))) + (should (equal (comp-type-spec-to-constraint '(integer * 2)) + (make-comp-constraint :typeset nil :range '((- . 2))))) + (should (equal (comp-type-spec-to-constraint '(integer 1 *)) + (make-comp-constraint :typeset nil :range '((1 . +))))) + (should (equal (comp-type-spec-to-constraint '(integer * *)) + (make-comp-constraint :typeset nil :range '((- . +))))) + (should (equal (comp-type-spec-to-constraint '(or (integer 1 2) + (member foo bar))) + (make-comp-constraint :typeset nil + :valset '(foo bar) + :range '((1 . 2))))) + (should (equal (comp-type-spec-to-constraint + '(function (t t) cons)) + (make-comp-constraint-f + :args `(,(make-comp-constraint :typeset '(t)) + ,(make-comp-constraint :typeset '(t))) + :ret (make-comp-constraint :typeset '(cons))))) + (should (equal (comp-type-spec-to-constraint + '(function ((or integer symbol)) float)) + (make-comp-constraint-f + :args `(,(make-comp-constraint :typeset '(symbol integer))) + :ret (make-comp-constraint :typeset '(float)))))) + ;;; comp-tests.el ends here -- 2.39.5