23c082638e
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.
363 lines
12 KiB
EmacsLisp
363 lines
12 KiB
EmacsLisp
;;; 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
|