mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-02-05 15:11:30 -08:00
Add initial nativecomp typeset and range propagation support
This commit add an initial support for a better type propagation and integer range propagation. Each mvar can be now characterized by a set of types, a set of values and an integral range. * lisp/emacs-lisp/comp.el (comp-known-ret-types): Store into typeset and remove fixnum. (comp-known-ret-ranges, comp-type-predicates): New variables. (comp-ctxt): Remove supertype-memoize slot and add union-typesets-mem. (comp-mvar): Remove const-vld, constant, type slots. Add typeset, valset, range slots. (comp-mvar-value-vld-p, comp-mvar-value, comp-mvar-fixnum-p) (comp-mvar-symbol-p, comp-mvar-cons-p) (comp-mvar-type-hint-match-p, comp-func-ret-typeset) (comp-func-ret-range): New functions. (make-comp-mvar, make-comp-ssa-mvar): Update logic. (comp--typeof-types): New variable. (comp-supertypes, comp-common-supertype): Logic update. (comp-subtype-p, comp-union-typesets, comp-range-1+) (comp-range-1-, comp-range-<, comp-range-union) (comp-range-intersection): New functions. (comp-fwprop-prologue, comp-mvar-propagate) (comp-function-foldable-p, comp-function-call-maybe-fold) (comp-fwprop-insn, comp-call-optim-func, comp-finalize-relocs): Logic update. * src/comp.c (emit_mvar_rval, emit_call_with_type_hint) (emit_call2_with_type_hint): Logic update. * lisp/emacs-lisp/cl-preloaded.el (cl--typeof-types): Undo the add of fixnum and bignum as unnecessary. * test/src/comp-tests.el (comp-tests-mentioned-p-1, comp-tests-cond-rw-checker-val) (comp-tests-cond-rw-checker-type, cond-rw-1, cond-rw-2) (cond-rw-3, cond-rw-4, cond-rw-5): Update for new type interface. (range-simple-union, range-simple-intersection): New integer range tests. (union-types): New union type test.
This commit is contained in:
Andrea Corallo
parent
c3d0e2a09f
commit
e96cd4e82c
4 changed files with 347 additions and 112 deletions
|
|
@ -52,8 +52,7 @@
|
|||
|
||||
(defconst cl--typeof-types
|
||||
;; Hand made from the source code of `type-of'.
|
||||
'((fixnum integer number number-or-marker atom)
|
||||
(bignum integer number number-or-marker atom)
|
||||
'((integer number number-or-marker atom)
|
||||
(symbol atom) (string array sequence atom)
|
||||
(cons list sequence)
|
||||
;; Markers aren't `numberp', yet they are accepted wherever integers are
|
||||
|
|
|
|||
|
|
@ -191,19 +191,31 @@ 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)
|
||||
(defconst comp-known-ret-types '((cons . (cons))
|
||||
(1+ . (number))
|
||||
(1- . (number))
|
||||
(+ . (number))
|
||||
(- . (number))
|
||||
(* . (number))
|
||||
(/ . (number))
|
||||
(% . (number))
|
||||
;; Type hints
|
||||
(comp-hint-fixnum . fixnum)
|
||||
(comp-hint-cons . cons))
|
||||
(comp-hint-cons . (cons)))
|
||||
"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.")
|
||||
|
|
@ -285,9 +297,9 @@ This is tipically for top-level forms other than defun.")
|
|||
:documentation "Relocated data not necessary after load.")
|
||||
(with-late-load nil :type boolean
|
||||
:documentation "When non-nil support late load.")
|
||||
(supertype-memoize (make-hash-table :test #'equal) :type hash-table
|
||||
:documentation "Serve memoization for
|
||||
`comp-common-supertype'."))
|
||||
(union-typesets-mem (make-hash-table :test #'equal) :type hash-table
|
||||
:documentation "Serve memoization for
|
||||
`comp-union-typesets'."))
|
||||
|
||||
(cl-defstruct comp-args-base
|
||||
(min nil :type number
|
||||
|
|
@ -419,14 +431,68 @@ CFG is mutated by a pass.")
|
|||
(slot nil :type (or fixnum symbol)
|
||||
:documentation "Slot number in the array if a number or
|
||||
'scratch' for scratch slot.")
|
||||
(const-vld nil :type boolean
|
||||
:documentation "Valid signal for the following slot.")
|
||||
(constant nil
|
||||
:documentation "When const-vld non-nil this is used for holding
|
||||
a value known at compile time.")
|
||||
(type nil :type symbol
|
||||
:documentation "When non-nil indicates the type when known at compile
|
||||
time."))
|
||||
(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.")
|
||||
(range '() :type list
|
||||
:documentation "Integer interval."))
|
||||
|
||||
(defsubst comp-mvar-value-vld-p (mvar)
|
||||
"Return t if one single value can be extracted by the MVAR constrains."
|
||||
(or (= (length (comp-mvar-valset mvar)) 1)
|
||||
(let ((r (comp-mvar-range mvar)))
|
||||
(and (= (length r) 1)
|
||||
(let ((low (caar r))
|
||||
(high (cdar r)))
|
||||
(and
|
||||
(integerp low)
|
||||
(integerp high)
|
||||
(= low high)))))))
|
||||
|
||||
(defsubst comp-mvar-value (mvar)
|
||||
"Return the constant value of MVAR.
|
||||
`comp-mvar-value-vld-p' *must* be satisfied before calling
|
||||
`comp-mvar-const'."
|
||||
(declare (gv-setter
|
||||
(lambda (val)
|
||||
`(if (integerp ,val)
|
||||
(setf (comp-mvar-typeset ,mvar) nil
|
||||
(comp-mvar-range ,mvar) (list (cons ,val ,val)))
|
||||
(setf (comp-mvar-typeset ,mvar) nil
|
||||
(comp-mvar-valset ,mvar) (list ,val))))))
|
||||
(let ((v (comp-mvar-valset mvar)))
|
||||
(if (= (length v) 1)
|
||||
(car v)
|
||||
(caar (comp-mvar-range mvar)))))
|
||||
|
||||
(defsubst comp-mvar-fixnum-p (mvar)
|
||||
"Return t if MVAR is certainly a fixnum."
|
||||
(when-let (range (comp-mvar-range mvar))
|
||||
(let* ((low (caar range))
|
||||
(high (cdar (last range))))
|
||||
(unless (or (eq low '-)
|
||||
(< low most-negative-fixnum)
|
||||
(eq high '+)
|
||||
(> high most-positive-fixnum))
|
||||
t))))
|
||||
|
||||
(defsubst comp-mvar-symbol-p (mvar)
|
||||
"Return t if MVAR is certainly a symbol."
|
||||
(equal (comp-mvar-typeset mvar) '(symbol)))
|
||||
|
||||
(defsubst comp-mvar-cons-p (mvar)
|
||||
"Return t if MVAR is certainly a cons."
|
||||
(equal (comp-mvar-typeset mvar) '(cons)))
|
||||
|
||||
(defun comp-mvar-type-hint-match-p (mvar type-hint)
|
||||
"Match MVAR against TYPE-HINT.
|
||||
In use by the backend."
|
||||
(cl-ecase type-hint
|
||||
(cons (comp-mvar-cons-p mvar))
|
||||
(fixnum (comp-mvar-fixnum-p mvar))))
|
||||
|
||||
;; Special vars used by some passes
|
||||
(defvar comp-func)
|
||||
|
|
@ -463,6 +529,14 @@ To be used by all entry points."
|
|||
"Type-hint predicate for function name FUNC."
|
||||
(when (memq func comp-type-hints) t))
|
||||
|
||||
(defsubst comp-func-ret-typeset (func)
|
||||
"Return the typeset returned by function FUNC. "
|
||||
(or (alist-get func comp-known-ret-types) '(t)))
|
||||
|
||||
(defsubst comp-func-ret-range (func)
|
||||
"Return the range returned by function FUNC. "
|
||||
(alist-get func comp-known-ret-ranges))
|
||||
|
||||
(defun comp-func-unique-in-cu-p (func)
|
||||
"Return t if FUNC is known to be unique in the current compilation unit."
|
||||
(if (symbolp func)
|
||||
|
|
@ -943,10 +1017,14 @@ STACK-OFF is the index of the first slot frame involved."
|
|||
collect (comp-slot-n sp))))
|
||||
|
||||
(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type)
|
||||
(when const-vld
|
||||
(comp-add-const-to-relocs constant))
|
||||
(make--comp-mvar :slot slot :const-vld const-vld :constant constant
|
||||
:type type))
|
||||
"`comp-mvar' intitializer."
|
||||
(let ((mvar (make--comp-mvar :slot slot)))
|
||||
(when const-vld
|
||||
(comp-add-const-to-relocs constant)
|
||||
(setf (comp-mvar-value mvar) constant))
|
||||
(when type
|
||||
(setf (comp-mvar-typeset mvar) (list type)))
|
||||
mvar))
|
||||
|
||||
(defun comp-new-frame (size &optional ssa)
|
||||
"Return a clean frame of meta variables of size SIZE.
|
||||
|
|
@ -1823,11 +1901,9 @@ blocks."
|
|||
;; this form is called 'minimal SSA form'.
|
||||
;; This pass should be run every time basic blocks or m-var are shuffled.
|
||||
|
||||
(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type)
|
||||
(let ((mvar (make--comp-mvar :slot slot
|
||||
:const-vld const-vld
|
||||
:constant constant
|
||||
:type type)))
|
||||
(cl-defun make-comp-ssa-mvar (&rest rest &key _slot _constant _type)
|
||||
"Same as `make-comp-mvar' but set the `id' slot."
|
||||
(let ((mvar (apply #'make-comp-mvar rest)))
|
||||
(setf (comp-mvar-id mvar) (sxhash-eq mvar))
|
||||
mvar))
|
||||
|
||||
|
|
@ -2130,19 +2206,18 @@ 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.
|
||||
|
||||
(defsubst comp-strict-type-of (obj)
|
||||
"Given OBJ return its type understanding fixnums."
|
||||
;; Should be certainly smarter but now we take advantages just from fixnums.
|
||||
(if (fixnump obj)
|
||||
'fixnum
|
||||
(type-of obj)))
|
||||
(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 cl--typeof-types
|
||||
for l in comp--typeof-types
|
||||
do (cl-loop
|
||||
for x in l
|
||||
for i from (length l) downto 0
|
||||
|
|
@ -2165,10 +2240,105 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
|
|||
|
||||
(defun comp-common-supertype (&rest types)
|
||||
"Return the first common supertype of TYPES."
|
||||
(or (gethash types (comp-ctxt-supertype-memoize comp-ctxt))
|
||||
(puthash types
|
||||
(cl-reduce #'comp-common-supertype-2 types)
|
||||
(comp-ctxt-supertype-memoize comp-ctxt))))
|
||||
(cl-reduce #'comp-common-supertype-2 types))
|
||||
|
||||
(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."
|
||||
|
|
@ -2213,20 +2383,18 @@ Forward propagate immediate involed in assignments."
|
|||
for insn in (comp-block-insns b)
|
||||
do (pcase insn
|
||||
(`(setimm ,lval ,v)
|
||||
(setf (comp-mvar-const-vld lval) t
|
||||
(comp-mvar-constant lval) v
|
||||
(comp-mvar-type lval) (comp-strict-type-of v)))))))
|
||||
(setf (comp-mvar-value lval) v))))))
|
||||
|
||||
(defsubst comp-mvar-propagate (lval rval)
|
||||
"Propagate into LVAL properties of RVAL."
|
||||
(setf (comp-mvar-const-vld lval) (comp-mvar-const-vld rval)
|
||||
(comp-mvar-constant lval) (comp-mvar-constant rval)
|
||||
(comp-mvar-type lval) (comp-mvar-type rval)))
|
||||
(setf (comp-mvar-typeset lval) (comp-mvar-typeset rval)
|
||||
(comp-mvar-valset lval) (comp-mvar-valset rval)
|
||||
(comp-mvar-range lval) (comp-mvar-range rval)))
|
||||
|
||||
(defsubst comp-function-foldable-p (f args)
|
||||
"Given function F called with ARGS return non-nil when optimizable."
|
||||
(and (cl-every #'comp-mvar-const-vld args)
|
||||
(comp-function-pure-p f)))
|
||||
(and (comp-function-pure-p f)
|
||||
(cl-every #'comp-mvar-value-vld-p args)))
|
||||
|
||||
(defsubst comp-function-call-maybe-fold (insn f args)
|
||||
"Given INSN when F is pure if all ARGS are known remove the function call."
|
||||
|
|
@ -2238,10 +2406,10 @@ Forward propagate immediate involed in assignments."
|
|||
(cond
|
||||
((eq f 'symbol-value)
|
||||
(when-let* ((arg0 (car args))
|
||||
(const (comp-mvar-const-vld arg0))
|
||||
(ok-to-optim (member (comp-mvar-constant arg0)
|
||||
(const (comp-mvar-value-vld-p arg0))
|
||||
(ok-to-optim (member (comp-mvar-value arg0)
|
||||
comp-symbol-values-optimizable)))
|
||||
(rewrite-insn-as-setimm insn (symbol-value (comp-mvar-constant
|
||||
(rewrite-insn-as-setimm insn (symbol-value (comp-mvar-value
|
||||
(car args))))))
|
||||
((comp-function-foldable-p f args)
|
||||
(ignore-errors
|
||||
|
|
@ -2254,7 +2422,7 @@ Forward propagate immediate involed in assignments."
|
|||
;; and know to be pure.
|
||||
(comp-func-byte-func f-in-ctxt)
|
||||
f))
|
||||
(value (comp-apply-in-env f (mapcar #'comp-mvar-constant args))))
|
||||
(value (comp-apply-in-env f (mapcar #'comp-mvar-value args))))
|
||||
(rewrite-insn-as-setimm insn value)))))))
|
||||
|
||||
(defun comp-fwprop-insn (insn)
|
||||
|
|
@ -2263,13 +2431,19 @@ Forward propagate immediate involed in assignments."
|
|||
(`(set ,lval ,rval)
|
||||
(pcase rval
|
||||
(`(,(or 'call 'callref) ,f . ,args)
|
||||
(setf (comp-mvar-type lval)
|
||||
(alist-get f comp-known-ret-types))
|
||||
(if-let ((range (comp-func-ret-range f)))
|
||||
(setf (comp-mvar-range lval) (list range)
|
||||
(comp-mvar-typeset lval) nil)
|
||||
(setf (comp-mvar-typeset lval)
|
||||
(comp-func-ret-typeset f)))
|
||||
(comp-function-call-maybe-fold insn f args))
|
||||
(`(,(or 'direct-call 'direct-callref) ,f . ,args)
|
||||
(let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt)))))
|
||||
(setf (comp-mvar-type lval)
|
||||
(alist-get f comp-known-ret-types))
|
||||
(if-let ((range (comp-func-ret-range f)))
|
||||
(setf (comp-mvar-range lval) (list range)
|
||||
(comp-mvar-typeset lval) nil)
|
||||
(setf (comp-mvar-typeset lval)
|
||||
(comp-func-ret-typeset f)))
|
||||
(comp-function-call-maybe-fold insn f args)))
|
||||
(_
|
||||
(comp-mvar-propagate lval rval))))
|
||||
|
|
@ -2278,31 +2452,46 @@ Forward propagate immediate involed in assignments."
|
|||
('eq
|
||||
(comp-mvar-propagate lval rval))
|
||||
((or 'eql 'equal)
|
||||
(if (memq (comp-mvar-type rval) '(symbol fixnum))
|
||||
(if (or (comp-mvar-symbol-p rval)
|
||||
(comp-mvar-fixnum-p rval))
|
||||
(comp-mvar-propagate lval rval)
|
||||
(setf (comp-mvar-type lval) (comp-mvar-type rval))))
|
||||
(setf (comp-mvar-typeset lval) (comp-mvar-typeset rval))))
|
||||
('=
|
||||
(if (eq (comp-mvar-type rval) 'fixnum)
|
||||
(if (comp-mvar-fixnum-p rval)
|
||||
(comp-mvar-propagate lval rval)
|
||||
(setf (comp-mvar-type lval) 'number)))))
|
||||
(setf (comp-mvar-typeset lval)
|
||||
(unless (comp-mvar-range rval)
|
||||
'(number)))))))
|
||||
(`(setimm ,lval ,v)
|
||||
(setf (comp-mvar-const-vld lval) t
|
||||
(comp-mvar-constant lval) v
|
||||
(comp-mvar-type lval) (comp-strict-type-of v)))
|
||||
(setf (comp-mvar-value lval) v))
|
||||
(`(phi ,lval . ,rest)
|
||||
(let ((rvals (mapcar #'car rest)))
|
||||
;; Forward const prop here.
|
||||
(when-let* ((vld (cl-every #'comp-mvar-const-vld rvals))
|
||||
(consts (mapcar #'comp-mvar-constant rvals))
|
||||
(x (car consts))
|
||||
(equals (cl-every (lambda (y) (equal x y)) consts)))
|
||||
(setf (comp-mvar-const-vld lval) t
|
||||
(comp-mvar-constant lval) x))
|
||||
;; Forward type propagation.
|
||||
(when-let* ((types (mapcar #'comp-mvar-type rvals))
|
||||
(non-empty (cl-notany #'null types))
|
||||
(x (comp-common-supertype types)))
|
||||
(setf (comp-mvar-type lval) x))))))
|
||||
(let* ((rvals (mapcar #'car rest))
|
||||
(values (mapcar #'comp-mvar-valset rvals))
|
||||
(from-latch (cl-some
|
||||
(lambda (x)
|
||||
(comp-latch-p
|
||||
(gethash (cdr x)
|
||||
(comp-func-blocks comp-func))))
|
||||
rest)))
|
||||
|
||||
;; Type propagation.
|
||||
(setf (comp-mvar-typeset lval)
|
||||
(apply #'comp-union-typesets (mapcar #'comp-mvar-typeset rvals)))
|
||||
;; Value propagation.
|
||||
(setf (comp-mvar-valset lval)
|
||||
(when (cl-every #'consp values)
|
||||
;; TODO memoize?
|
||||
(cl-remove-duplicates (apply #'append values)
|
||||
:test #'equal)))
|
||||
;; 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 rvals))))))))
|
||||
|
||||
(defun comp-fwprop* ()
|
||||
"Propagate for set* and phi operands.
|
||||
|
|
@ -2416,11 +2605,11 @@ FUNCTION can be a function-name or byte compiled function."
|
|||
(pcase insn
|
||||
(`(set ,lval (callref funcall ,f . ,rest))
|
||||
(when-let ((new-form (comp-call-optim-form-call
|
||||
(comp-mvar-constant f) rest)))
|
||||
(comp-mvar-value f) rest)))
|
||||
(setf insn `(set ,lval ,new-form))))
|
||||
(`(callref funcall ,f . ,rest)
|
||||
(when-let ((new-form (comp-call-optim-form-call
|
||||
(comp-mvar-constant f) rest)))
|
||||
(comp-mvar-value f) rest)))
|
||||
(setf insn new-form)))))))
|
||||
|
||||
(defun comp-call-optim (_)
|
||||
|
|
@ -2639,7 +2828,8 @@ Update all insn accordingly."
|
|||
do
|
||||
(cl-assert (null (gethash idx reverse-h)))
|
||||
(cl-assert (fixnump idx))
|
||||
(setf (comp-mvar-constant mvar) idx)
|
||||
(setf (comp-mvar-valset mvar) ()
|
||||
(comp-mvar-range mvar) (list (cons idx idx)))
|
||||
(puthash idx t reverse-h))))
|
||||
|
||||
(defun comp-compile-ctxt-to-file (name)
|
||||
|
|
|
|||
24
src/comp.c
24
src/comp.c
|
|
@ -1845,32 +1845,32 @@ emit_PURE_P (gcc_jit_rvalue *ptr)
|
|||
static gcc_jit_rvalue *
|
||||
emit_mvar_rval (Lisp_Object mvar)
|
||||
{
|
||||
Lisp_Object const_vld = CALL1I (comp-mvar-const-vld, mvar);
|
||||
Lisp_Object constant = CALL1I (comp-mvar-constant, mvar);
|
||||
Lisp_Object const_vld = CALL1I (comp-mvar-value-vld-p, mvar);
|
||||
|
||||
if (!NILP (const_vld))
|
||||
{
|
||||
Lisp_Object value = CALL1I (comp-mvar-value, mvar);
|
||||
if (comp.debug > 1)
|
||||
{
|
||||
Lisp_Object func =
|
||||
Fgethash (constant,
|
||||
Fgethash (value,
|
||||
CALL1I (comp-ctxt-byte-func-to-func-h, Vcomp_ctxt),
|
||||
Qnil);
|
||||
|
||||
emit_comment (
|
||||
SSDATA (
|
||||
Fprin1_to_string (
|
||||
NILP (func) ? constant : CALL1I (comp-func-c-name, func),
|
||||
NILP (func) ? value : CALL1I (comp-func-c-name, func),
|
||||
Qnil)));
|
||||
}
|
||||
if (FIXNUMP (constant))
|
||||
if (FIXNUMP (value))
|
||||
{
|
||||
/* We can still emit directly objects that are self-contained in a
|
||||
word (read fixnums). */
|
||||
return emit_rvalue_from_lisp_obj (constant);
|
||||
return emit_rvalue_from_lisp_obj (value);
|
||||
}
|
||||
/* Other const objects are fetched from the reloc array. */
|
||||
return emit_lisp_obj_rval (constant);
|
||||
return emit_lisp_obj_rval (value);
|
||||
}
|
||||
|
||||
return gcc_jit_lvalue_as_rvalue (emit_mvar_lval (mvar));
|
||||
|
|
@ -2371,12 +2371,13 @@ static gcc_jit_rvalue *
|
|||
emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn,
|
||||
Lisp_Object type)
|
||||
{
|
||||
bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type);
|
||||
bool hint_match =
|
||||
!NILP (CALL2I (comp-mvar-type-hint-match-p, SECOND (insn), type));
|
||||
gcc_jit_rvalue *args[] =
|
||||
{ emit_mvar_rval (SECOND (insn)),
|
||||
gcc_jit_context_new_rvalue_from_int (comp.ctxt,
|
||||
comp.bool_type,
|
||||
type_hint) };
|
||||
hint_match) };
|
||||
|
||||
return gcc_jit_context_new_call (comp.ctxt, NULL, func, 2, args);
|
||||
}
|
||||
|
|
@ -2386,13 +2387,14 @@ static gcc_jit_rvalue *
|
|||
emit_call2_with_type_hint (gcc_jit_function *func, Lisp_Object insn,
|
||||
Lisp_Object type)
|
||||
{
|
||||
bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type);
|
||||
bool hint_match =
|
||||
!NILP (CALL2I (comp-mvar-type-hint-match-p, SECOND (insn), type));
|
||||
gcc_jit_rvalue *args[] =
|
||||
{ emit_mvar_rval (SECOND (insn)),
|
||||
emit_mvar_rval (THIRD (insn)),
|
||||
gcc_jit_context_new_rvalue_from_int (comp.ctxt,
|
||||
comp.bool_type,
|
||||
type_hint) };
|
||||
hint_match) };
|
||||
|
||||
return gcc_jit_context_new_call (comp.ctxt, NULL, func, 3, args);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@
|
|||
(defconst comp-test-dyn-src
|
||||
(concat comp-test-directory "comp-test-funcs-dyn.el"))
|
||||
|
||||
(when (boundp 'comp-ctxt)
|
||||
(when (featurep 'nativecomp)
|
||||
(message "Compiling tests...")
|
||||
(load (native-compile comp-test-src))
|
||||
(load (native-compile comp-test-dyn-src)))
|
||||
|
|
@ -676,8 +676,8 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html."
|
|||
(cl-loop for y in insn
|
||||
when (cond
|
||||
((consp y) (comp-tests-mentioned-p x y))
|
||||
((and (comp-mvar-p y) (comp-mvar-const-vld y))
|
||||
(equal (comp-mvar-constant y) x))
|
||||
((and (comp-mvar-p y) (comp-mvar-value-vld-p y))
|
||||
(equal (comp-mvar-value y) x))
|
||||
(t (equal x y)))
|
||||
return t))
|
||||
|
||||
|
|
@ -804,8 +804,8 @@ Return a list of results."
|
|||
(lambda (insn)
|
||||
(pcase insn
|
||||
(`(return ,mvar)
|
||||
(and (comp-mvar-const-vld mvar)
|
||||
(= (comp-mvar-constant mvar) 123)))))))))
|
||||
(and (comp-mvar-value-vld-p mvar)
|
||||
(eql (comp-mvar-value mvar) 123)))))))))
|
||||
|
||||
(defvar comp-tests-cond-rw-expected-type nil
|
||||
"Type to expect in `comp-tests-cond-rw-checker-type'.")
|
||||
|
|
@ -819,7 +819,8 @@ Return a list of results."
|
|||
(lambda (insn)
|
||||
(pcase insn
|
||||
(`(return ,mvar)
|
||||
(eq (comp-mvar-type mvar) comp-tests-cond-rw-expected-type))))))))
|
||||
(equal (comp-mvar-typeset mvar)
|
||||
comp-tests-cond-rw-expected-type))))))))
|
||||
|
||||
(defvar comp-tests-cond-rw-0-var)
|
||||
(comp-deftest cond-rw-0 ()
|
||||
|
|
@ -839,40 +840,39 @@ Return a list of results."
|
|||
(comp-deftest cond-rw-1 ()
|
||||
"Test cond-rw pass allow us to propagate type+val under `eq' tests."
|
||||
(let ((lexical-binding t)
|
||||
(comp-tests-cond-rw-expected-type 'fixnum)
|
||||
(comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)
|
||||
(comp-final comp-tests-cond-rw-checker-val))))
|
||||
(comp-tests-cond-rw-expected-type '(integer))
|
||||
(comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type
|
||||
comp-tests-cond-rw-checker-val))))
|
||||
(subr-native-elisp-p (native-compile '(lambda (x) (if (eq x 123) x t))))
|
||||
(subr-native-elisp-p (native-compile '(lambda (x) (if (eq 123 x) x t))))))
|
||||
|
||||
(comp-deftest cond-rw-2 ()
|
||||
"Test cond-rw pass allow us to propagate type+val under `=' tests."
|
||||
(let ((lexical-binding t)
|
||||
(comp-tests-cond-rw-expected-type 'fixnum)
|
||||
(comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)
|
||||
(comp-final comp-tests-cond-rw-checker-val))))
|
||||
(comp-tests-cond-rw-expected-type '(integer))
|
||||
(comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type
|
||||
comp-tests-cond-rw-checker-val))))
|
||||
(subr-native-elisp-p (native-compile '(lambda (x) (if (= x 123) x t))))))
|
||||
|
||||
(comp-deftest cond-rw-3 ()
|
||||
"Test cond-rw pass allow us to propagate type+val under `eql' tests."
|
||||
(let ((lexical-binding t)
|
||||
(comp-tests-cond-rw-expected-type 'fixnum)
|
||||
(comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)
|
||||
(comp-final comp-tests-cond-rw-checker-val))))
|
||||
(comp-tests-cond-rw-expected-type '(integer))
|
||||
(comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type
|
||||
comp-tests-cond-rw-checker-val))))
|
||||
(subr-native-elisp-p (native-compile '(lambda (x) (if (eql 123 x) x t))))))
|
||||
|
||||
(comp-deftest cond-rw-4 ()
|
||||
"Test cond-rw pass allow us to propagate type under `=' tests."
|
||||
(let ((lexical-binding t)
|
||||
(comp-tests-cond-rw-expected-type 'number)
|
||||
(comp-tests-cond-rw-expected-type '(number))
|
||||
(comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type))))
|
||||
(subr-native-elisp-p (native-compile '(lambda (x y) (if (= x y) x t))))))
|
||||
|
||||
(comp-deftest cond-rw-5 ()
|
||||
"Test cond-rw pass allow us to propagate type under `=' tests."
|
||||
(let ((lexical-binding t)
|
||||
(comp-tests-cond-rw-checked-function #'comp-tests-cond-rw-4-f)
|
||||
(comp-tests-cond-rw-expected-type 'fixnum)
|
||||
(let ((comp-tests-cond-rw-checked-function #'comp-tests-cond-rw-4-f)
|
||||
(comp-tests-cond-rw-expected-type '(integer))
|
||||
(comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type))))
|
||||
(eval '(defun comp-tests-cond-rw-4-f (x y)
|
||||
(declare (speed 3))
|
||||
|
|
@ -883,4 +883,48 @@ Return a list of results."
|
|||
(native-compile #'comp-tests-cond-rw-4-f)
|
||||
(should (subr-native-elisp-p (symbol-function #'comp-tests-cond-rw-4-f)))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Range propagation tests. ;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(comp-deftest range-simple-union ()
|
||||
(should (equal (comp-range-union '((-1 . 0)) '((3 . 4)))
|
||||
'((-1 . 0) (3 . 4))))
|
||||
(should (equal (comp-range-union '((-1 . 2)) '((3 . 4)))
|
||||
'((-1 . 4))))
|
||||
(should (equal (comp-range-union '((-1 . 3)) '((3 . 4)))
|
||||
'((-1 . 4))))
|
||||
(should (equal (comp-range-union '((-1 . 4)) '((3 . 4)))
|
||||
'((-1 . 4))))
|
||||
(should (equal (comp-range-union '((-1 . 5)) '((3 . 4)))
|
||||
'((-1 . 5))))
|
||||
(should (equal (comp-range-union '((-1 . 0)) '())
|
||||
'((-1 . 0)))))
|
||||
|
||||
(comp-deftest range-simple-intersection ()
|
||||
(should (equal (comp-range-intersection '((-1 . 0)) '((3 . 4)))
|
||||
'()))
|
||||
(should (equal (comp-range-intersection '((-1 . 2)) '((3 . 4)))
|
||||
'()))
|
||||
(should (equal (comp-range-intersection '((-1 . 3)) '((3 . 4)))
|
||||
'((3 . 3))))
|
||||
(should (equal (comp-range-intersection '((-1 . 4)) '((3 . 4)))
|
||||
'((3 . 4))))
|
||||
(should (equal (comp-range-intersection '((-1 . 5)) '((3 . 4)))
|
||||
'((3 . 4))))
|
||||
(should (equal (comp-range-intersection '((-1 . 0)) '())
|
||||
'())))
|
||||
|
||||
(comp-deftest union-types ()
|
||||
(let ((comp-ctxt (make-comp-ctxt)))
|
||||
(should (equal (comp-union-typesets '(integer) '(number))
|
||||
'(number)))
|
||||
(should (equal (comp-union-typesets '(integer symbol) '(number))
|
||||
'(symbol number)))
|
||||
(should (equal (comp-union-typesets '(integer symbol) '(number list))
|
||||
'(list symbol number)))
|
||||
(should (equal (comp-union-typesets '(integer symbol) '())
|
||||
'(symbol integer)))))
|
||||
|
||||
;;; comp-tests.el ends here
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue