From 23c082638e77219b51e14797a0edae27ae59a9d6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Nov 2020 23:51:17 +0100 Subject: 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/emacs-lisp/comp-cstr.el | 363 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 363 insertions(+) create mode 100644 lisp/emacs-lisp/comp-cstr.el (limited to 'lisp/emacs-lisp/comp-cstr.el') 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 -- cgit v1.2.3