procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* Allow for adding constraints targetting blocks with multiple predecessors

Browse source 
This commit remove the limitaiton we had not being able to add
constraints derived from conditional branches to basic blocks with
multiple predecessors.  When this condition is verified we add a new
dedicated basic block to hold the constraints.

	* lisp/emacs-lisp/comp.el (comp-block, comp-edge): Better slot
	type specifiers.
	(comp-block-cstr): New struct specializing `comp-block'.
	(make-comp-edge): New function.
	(comp-func): Better test function + doc for `blocks' slot.
	(comp-limple-lock-keywords): Update possible basic block names.
	(comp-emit-assume): Recive directly the block instead of its name.
	(comp-add-new-block-beetween): New function.
	(comp-cond-cstr-target-block): Logic update and use
	`comp-add-new-block-beetween'.
	(comp-cond-cstr-func): Make use of the latter.
	(comp-compute-edges): Make use of `make-comp-edge'.
This commit is contained in:
Andrea Corallo 2020-12-12 22:20:28 +01:00
parent 258eaddef8
commit 682bd30347
1 changed files with 116 additions and 79 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

195
lisp/emacs-lisp/comp.el
View file

@ -313,6 +313,9 @@ Useful to hook into pass checkers.")
return)
"All limple operators.")
(defvar comp-func nil
"Bound to the current function by most passes.")
(define-error 'native-compiler-error-dyn-func
"can't native compile a non-lexically-scoped function"
'native-compiler-error)
@ -400,13 +403,13 @@ To be used when ncall-conv is nil."))
:documentation "List of incoming edges.")
(out-edges () :type list
:documentation "List of out-coming edges.")
(dom nil :type comp-block
(dom nil :type (or null comp-block)
:documentation "Immediate dominator.")
(df (make-hash-table) :type hash-table
(df (make-hash-table) :type (or null hash-table)
:documentation "Dominance frontier set. Block-name -> block")
(post-num nil :type number
(post-num nil :type (or null number)
:documentation "Post order number.")
(final-frame nil :type vector
(final-frame nil :type (or null vector)
:documentation "This is a copy of the frame when leaving the block.
Is in use to help the SSA rename pass."))
@ -426,14 +429,26 @@ into it.")
(:include comp-block))
"A basic block for a latch loop.")
(cl-defstruct (comp-block-cstr (:copier nil)
(:include comp-block))
"A basic block holding only constraints.")
(cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge))
"An edge connecting two basic blocks."
(src nil :type comp-block)
(dst nil :type comp-block)
(src nil :type (or null comp-block))
(dst nil :type (or null comp-block))
(number nil :type number
:documentation "The index number corresponding to this edge in the
edge hash."))
(defun make-comp-edge (&rest args)
"Create a `comp-edge' with basic blocks SRC and DST."
(let ((n (funcall (comp-func-edge-cnt-gen comp-func))))
(puthash
n
(apply #'make--comp-edge :number n args)
(comp-func-edges-h comp-func))))
(defun comp-block-preds (basic-block)
"Given BASIC-BLOCK return the list of its predecessors."
(mapcar #'comp-edge-src (comp-block-in-edges basic-block)))
@ -463,8 +478,8 @@ into it.")
Once in SSA form this *must* be set to 'dirty' every time the topology of the
CFG is mutated by a pass.")
(frame-size nil :type number)
(blocks (make-hash-table) :type hash-table
:documentation "Basic block name -> basic block.")
(blocks (make-hash-table :test #'eq) :type hash-table
:documentation "Basic block symbol -> basic block.")
(lap-block (make-hash-table :test #'equal) :type hash-table
:documentation "LAP label -> LIMPLE basic block name.")
(edges-h (make-hash-table) :type hash-table
@ -570,9 +585,6 @@ In use by the backend."
(cons (comp-mvar-cons-p mvar))
(fixnum (comp-mvar-fixnum-p mvar))))
;; Special vars used by some passes
(defvar comp-func)
(defun comp-ensure-native-compiler ()
@ -650,7 +662,7 @@ Assume allocation class 'd-default as default."
(1 font-lock-variable-name-face))
(,(rx (group-n 1 (or "entry"
(seq (or "entry_" "entry_fallback_" "bb_")
(1+ num) (? "_latch")))))
(1+ num) (? (or "_latch" "_cstrs"))))))
(1 font-lock-constant-face))
(,(rx-to-string
`(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops)))))
@ -1841,12 +1853,11 @@ into the C code forwarding the compilation unit."
;;; conditional branches rewrite pass specific code.
(defun comp-emit-assume (target-slot rhs bb-name kind)
(defun comp-emit-assume (target-slot rhs bb kind)
"Emit an assume of kind KIND for TARGET-SLOT being RHS.
The assume is emitted at the beginning of the block named
BB-NAME."
The assume is emitted at the beginning of the block BB."
(push `(assume ,(make-comp-mvar :slot target-slot) ,rhs ,kind)
(comp-block-insns (gethash bb-name (comp-func-blocks comp-func))))
(comp-block-insns bb))
(setf (comp-func-ssa-status comp-func) 'dirty))
(defun comp-cond-cstr-target-slot (slot-num exit-insn bb)
@ -1867,34 +1878,67 @@ Return the corresponding rhs slot number."
(setf res rhs)))
finally (cl-assert nil))))
(defun comp-add-new-block-beetween (bb-symbol bb-a bb-b)
"Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B."
(cl-loop
with new-bb = (make-comp-block-cstr :name bb-symbol
:insns `((jump ,(comp-block-name bb-b))))
with new-edge = (make-comp-edge :src bb-a :dst new-bb)
for ed in (comp-block-in-edges bb-b)
when (eq (comp-edge-src ed) bb-a)
do
;; Connect `ed' to `new-bb' and disconnect it from `bb-a'.
(cl-assert (memq ed (comp-block-out-edges bb-a)))
(setf (comp-edge-src ed) new-bb
(comp-block-out-edges bb-a) (delq ed (comp-block-out-edges bb-a)))
(push ed (comp-block-out-edges new-bb))
;; Connect `bb-a' `new-bb' with `new-edge'.
(push (comp-block-out-edges bb-a) new-edge)
(push (comp-block-in-edges new-bb) new-edge)
(setf (comp-func-ssa-status comp-func) 'dirty)
;; Add `new-edge' to the current function and return it.
(cl-return (puthash bb-symbol new-bb (comp-func-blocks comp-func)))
finally (cl-assert nil)))
(defun comp-cond-cstr-target-block (curr-bb target-bb-sym)
"Return the appropriate basic block to add constraint assumptions into.
CURR-BB is the current basic block.
TARGET-BB-SYM is the symbol name of the target block."
(let ((target-bb (gethash target-bb-sym
(comp-func-blocks comp-func))))
(if (= (length (comp-block-in-edges target-bb)) 1)
;; If block has only one predecessor is already suitable for
;; adding constraint assumptions.
target-bb
(comp-add-new-block-beetween (intern (concat (symbol-name target-bb-sym)
"_cstrs"))
curr-bb target-bb))))
(defun comp-cond-cstr-func ()
"`comp-cond-cstr' worker function for each selected function."
(cl-loop
for b being each hash-value of (comp-func-blocks comp-func)
do (cl-loop
named in-the-basic-block
for insns-seq on (comp-block-insns b)
do (pcase insns-seq
(`((set ,(and (pred comp-mvar-p) cond)
(,(pred comp-call-op-p)
,(and (or 'eq 'eql '= 'equal) test-fn) ,op1 ,op2))
(comment ,_comment-str)
(cond-jump ,cond ,(pred comp-mvar-p) ,bb-1 ,_bb-2))
;; FIXME We guard the target block against having more
;; then one predecessor. The right fix will be to add a
;; new dedicated basic block for the assumptions so we
;; can proceed always.
(when (= (length (comp-block-in-edges
(gethash bb-1
(comp-func-blocks comp-func))))
1)
(when-let ((target-slot1 (comp-cond-cstr-target-slot
(comp-mvar-slot op1) (car insns-seq) b)))
(comp-emit-assume target-slot1 op2 bb-1 test-fn))
(when-let ((target-slot2 (comp-cond-cstr-target-slot
(comp-mvar-slot op2) (car insns-seq) b)))
(comp-emit-assume target-slot2 op1 bb-1 test-fn)))
(cl-return-from in-the-basic-block))))))
do
(cl-loop
named in-the-basic-block
for insns-seq on (comp-block-insns b)
do
(pcase insns-seq
(`((set ,(and (pred comp-mvar-p) cond)
(,(pred comp-call-op-p)
,(and (or 'eq 'eql '= 'equal) test-fn) ,op1 ,op2))
(comment ,_comment-str)
(cond-jump ,cond ,(pred comp-mvar-p) . ,blocks))
(let* ((bb-1 (car blocks))
(bb-target (comp-cond-cstr-target-block b bb-1)))
(setf (car blocks) (comp-block-name bb-target))
(when-let ((target-slot1 (comp-cond-cstr-target-slot
(comp-mvar-slot op1) (car insns-seq) b)))
(comp-emit-assume target-slot1 op2 bb-target test-fn))
(when-let ((target-slot2 (comp-cond-cstr-target-slot
(comp-mvar-slot op2) (car insns-seq) b)))
(comp-emit-assume target-slot2 op1 bb-target test-fn)))
(cl-return-from in-the-basic-block))))))
(defun comp-cond-cstr (_)
"Rewrite conditional branches adding appropriate 'assume' insns.
@ -2002,45 +2046,38 @@ blocks."
(defun comp-compute-edges ()
"Compute the basic block edges for the current function."
(cl-flet ((edge-add (&rest args &aux (n (funcall
(comp-func-edge-cnt-gen comp-func))))
(puthash
n
(apply #'make--comp-edge :number n args)
(comp-func-edges-h comp-func))))
(cl-loop with blocks = (comp-func-blocks comp-func)
for bb being each hash-value of blocks
for last-insn = (car (last (comp-block-insns bb)))
for (op first second third forth) = last-insn
do (cl-case op
(jump
(edge-add :src bb :dst (gethash first blocks)))
(cond-jump
(edge-add :src bb :dst (gethash third blocks))
(edge-add :src bb :dst (gethash forth blocks)))
(cond-jump-narg-leq
(edge-add :src bb :dst (gethash second blocks))
(edge-add :src bb :dst (gethash third blocks)))
(push-handler
(edge-add :src bb :dst (gethash third blocks))
(edge-add :src bb :dst (gethash forth blocks)))
(return)
(otherwise
(signal 'native-ice
(list "block does not end with a branch"
bb
(comp-func-name comp-func)))))
;; Update edge refs into blocks.
finally
(cl-loop
for edge being the hash-value in (comp-func-edges-h comp-func)
do
(push edge
(comp-block-out-edges (comp-edge-src edge)))
(push edge
(comp-block-in-edges (comp-edge-dst edge))))
(comp-log-edges comp-func))))
(cl-loop with blocks = (comp-func-blocks comp-func)
for bb being each hash-value of blocks
for last-insn = (car (last (comp-block-insns bb)))
for (op first second third forth) = last-insn
do (cl-case op
(jump
(make-comp-edge :src bb :dst (gethash first blocks)))
(cond-jump
(make-comp-edge :src bb :dst (gethash third blocks))
(make-comp-edge :src bb :dst (gethash forth blocks)))
(cond-jump-narg-leq
(make-comp-edge :src bb :dst (gethash second blocks))
(make-comp-edge :src bb :dst (gethash third blocks)))
(push-handler
(make-comp-edge :src bb :dst (gethash third blocks))
(make-comp-edge :src bb :dst (gethash forth blocks)))
(return)
(otherwise
(signal 'native-ice
(list "block does not end with a branch"
bb
(comp-func-name comp-func)))))
;; Update edge refs into blocks.
finally
(cl-loop
for edge being the hash-value in (comp-func-edges-h comp-func)
do
(push edge
(comp-block-out-edges (comp-edge-src edge)))
(push edge
(comp-block-in-edges (comp-edge-dst edge))))
(comp-log-edges comp-func)))
(defun comp-collect-rev-post-order (basic-block)
"Walk BASIC-BLOCK children and return their name in reversed post-order."