From: Andrea Corallo Date: Thu, 11 Jun 2020 20:53:31 +0000 (+0200) Subject: * Introduce latches X-Git-Tag: emacs-28.0.90~2727^2~565 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=34ed9d24984360dcc26fc36561f2de6a0917c58e;p=emacs.git * Introduce latches Define a new kind of basic block 'latch' to close over loops. Its purpose is for now to emit calls to `comp-maybe-gc-or-quit' but in future will be usefull for the loop optimizer to exploit unboxes. * lisp/emacs-lisp/comp.el (comp-block): New base class. (comp-block-lap): New class for LAP derived basic blocks. (comp-latch): New class. (comp-bb-maybe-add, comp-make-curr-block, comp-emit-handler) (comp-emit-switch, comp-emit-switch, comp-limplify-top-level) (comp-addr-to-bb-name, comp-limplify-block) (comp-limplify-function): Update logic for new bb objects arrangment. (comp-latch-make-fill): New function. (comp-emit-uncond-jump, comp-emit-cond-jump): Update to emit latches. (comp-new-block-sym): Add a postfix paramenter. --- diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2cde99e7280..5027d1da088 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -279,16 +279,9 @@ To be used when ncall-conv is nil.")) :documentation "t if rest argument is present.")) (cl-defstruct (comp-block (:copier nil) - (:constructor make--comp-block - (addr sp name))) ; Positional - "A basic block." + (:constructor nil)) + "A base class for basic blocks." (name nil :type symbol) - ;; These two slots are used during limplification. - (sp nil :type number - :documentation "When non nil indicates the sp value while entering -into it.") - (addr nil :type number - :documentation "Start block LAP address.") (insns () :type list :documentation "List of instructions.") (closed nil :type boolean @@ -309,6 +302,22 @@ into it.") :documentation "This is a copy of the frame when leaving the block. Is in use to help the SSA rename pass.")) +(cl-defstruct (comp-block-lap (:copier nil) + (:include comp-block) + (:constructor make--comp-block-lap + (addr sp name))) ; Positional + "A basic block created from lap." + ;; These two slots are used during limplification. + (sp nil :type number + :documentation "When non nil indicates the sp value while entering +into it.") + (addr nil :type number + :documentation "Start block LAP address.")) + +(cl-defstruct (comp-latch (:copier nil) + (:include comp-block)) + "A basic block for a latch loop.") + (cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) "An edge connecting two basic blocks." (src nil :type comp-block) @@ -751,20 +760,22 @@ Restore the original value afterwards." (defun comp-bb-maybe-add (lap-addr &optional sp) "If necessary create a pending basic block for LAP-ADDR with stack depth SP. The basic block is returned regardless it was already declared or not." - (let ((bb (or (cl-loop ; See if the block was already liplified. + (let ((bb (or (cl-loop ; See if the block was already limplified. for bb being the hash-value in (comp-func-blocks comp-func) - when (equal (comp-block-addr bb) lap-addr) + when (and (comp-block-lap-p bb) + (equal (comp-block-lap-addr bb) lap-addr)) return bb) (cl-find-if (lambda (bb) ; Look within the pendings blocks. - (= (comp-block-addr bb) lap-addr)) + (and (comp-block-lap-p bb) + (= (comp-block-lap-addr bb) lap-addr))) (comp-limplify-pending-blocks comp-pass))))) (if bb (progn - (unless (or (null sp) (= sp (comp-block-sp bb))) + (unless (or (null sp) (= sp (comp-block-lap-sp bb))) (signal 'native-ice (list "incoherent stack pointers" - sp (comp-block-sp bb)))) + sp (comp-block-lap-sp bb)))) bb) - (car (push (make--comp-block lap-addr sp (comp-new-block-sym)) + (car (push (make--comp-block-lap lap-addr sp (comp-new-block-sym)) (comp-limplify-pending-blocks comp-pass)))))) (defsubst comp-call (func &rest args) @@ -832,21 +843,44 @@ If DST-N is specified use it otherwise assume it to be the current slot." ENTRY-SP is the sp value when entering. The block is added to the current function. The block is returned." - (let ((bb (make--comp-block addr entry-sp block-name))) + (let ((bb (make--comp-block-lap addr entry-sp block-name))) (setf (comp-limplify-curr-block comp-pass) bb (comp-limplify-pc comp-pass) addr - (comp-limplify-sp comp-pass) (comp-block-sp bb)) + (comp-limplify-sp comp-pass) (when (comp-block-lap-p bb) + (comp-block-lap-sp bb))) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) bb)) +(defun comp-latch-make-fill (target) + "Create a latch pointing to TARGET and fill it. +Return the created latch" + (let ((latch (make-comp-latch :name (comp-new-block-sym "latch"))) + (curr-bb (comp-limplify-curr-block comp-pass))) + ;; See `comp-make-curr-block'. + (setf (comp-limplify-curr-block comp-pass) latch) + (when (< comp-speed 3) + ;; At speed 3 the programmer is responsible to manually + ;; place `comp-maybe-gc-or-quit'. + (comp-emit '(call comp-maybe-gc-or-quit))) + ;; See `comp-emit-uncond-jump'. + (comp-emit `(jump ,(comp-block-name target))) + (comp-mark-curr-bb-closed) + (puthash (comp-block-name latch) latch (comp-func-blocks comp-func)) + (setf (comp-limplify-curr-block comp-pass) curr-bb) + latch)) + (defun comp-emit-uncond-jump (lap-label) "Emit an unconditional branch to LAP-LABEL." (cl-destructuring-bind (label-num . stack-depth) lap-label (when stack-depth (cl-assert (= (1- stack-depth) (comp-sp)))) - (let ((target (comp-bb-maybe-add (comp-label-to-addr label-num) - (comp-sp)))) - (comp-emit `(jump ,(comp-block-name target))) + (let* ((target-addr (comp-label-to-addr label-num)) + (target (comp-bb-maybe-add target-addr + (comp-sp))) + (latch (when (< target-addr (comp-limplify-pc comp-pass)) + (comp-latch-make-fill target))) + (eff-target-name (comp-block-name (or latch target)))) + (comp-emit `(jump ,eff-target-name)) (comp-mark-curr-bb-closed)))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) @@ -859,13 +893,16 @@ Return value is the fall through block name." (let* ((bb (comp-block-name (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) (comp-sp)))) ; Fall through block. (target-sp (+ target-offset (comp-sp))) - (target (comp-block-name (comp-bb-maybe-add (comp-label-to-addr label-num) - target-sp)))) + (target-addr (comp-label-to-addr label-num)) + (target (comp-bb-maybe-add target-addr target-sp)) + (latch (when (< target-addr (comp-limplify-pc comp-pass)) + (comp-latch-make-fill target))) + (eff-target-name (comp-block-name (or latch target)))) (when label-sp (cl-assert (= (1- label-sp) (+ target-offset (comp-sp))))) (comp-emit (if negated - (list 'cond-jump a b target bb) - (list 'cond-jump a b bb target))) + (list 'cond-jump a b eff-target-name bb) + (list 'cond-jump a b bb eff-target-name))) (comp-mark-curr-bb-closed) bb))) @@ -878,7 +915,7 @@ Return value is the fall through block name." (comp-sp))) (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) (1+ (comp-sp)))) - (pop-bb (make--comp-block nil (comp-sp) (comp-new-block-sym)))) + (pop-bb (make--comp-block-lap nil (comp-sp) (comp-new-block-sym)))) (comp-emit (list 'push-handler handler-type (comp-slot+1) @@ -904,9 +941,11 @@ Return value is the fall through block name." (comp-slot) (comp-slot+1)))))) -(defun comp-new-block-sym () - "Return a unique symbol naming the next new basic block." - (intern (format "bb_%s" (funcall (comp-func-block-cnt-gen comp-func))))) +(defun comp-new-block-sym (&optional postfix) + "Return a unique symbol postfixing POSTFIX naming the next new basic block." + (intern (format (if postfix "bb_%s_%s" "bb_%s") + (funcall (comp-func-block-cnt-gen comp-func)) + postfix))) (defun comp-fill-label-h () "Fill label-to-addr hash table for the current function." @@ -948,9 +987,9 @@ Return value is the fall through block name." for ff-bb = (if last (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) (comp-sp)) - (make--comp-block nil - (comp-sp) - (comp-new-block-sym))) + (make--comp-block-lap nil + (comp-sp) + (comp-new-block-sym))) for ff-bb-name = (comp-block-name ff-bb) if (eq test-func 'eq) do (comp-emit (list 'cond-jump var m-test ff-bb-name target-name)) @@ -1375,7 +1414,7 @@ into the C code forwarding the compilation unit." :frame-size 1)) (comp-func func) (comp-pass (make-comp-limplify - :curr-block (make--comp-block -1 0 'top-level) + :curr-block (make--comp-block-lap -1 0 'top-level) :frame (comp-new-frame 1)))) (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation (if for-late-load @@ -1396,7 +1435,7 @@ into the C code forwarding the compilation unit." "Search for a block starting at ADDR into pending or limplified blocks." ;; FIXME Actually we could have another hash for this. (cl-flet ((pred (bb) - (equal (comp-block-addr bb) addr))) + (equal (comp-block-lap-addr bb) addr))) (if-let ((pending (cl-find-if #'pred (comp-limplify-pending-blocks comp-pass)))) (comp-block-name pending) @@ -1407,8 +1446,8 @@ into the C code forwarding the compilation unit." (defun comp-limplify-block (bb) "Limplify basic-block BB and add it to the current function." (setf (comp-limplify-curr-block comp-pass) bb - (comp-limplify-sp comp-pass) (comp-block-sp bb) - (comp-limplify-pc comp-pass) (comp-block-addr bb)) + (comp-limplify-sp comp-pass) (comp-block-lap-sp bb) + (comp-limplify-pc comp-pass) (comp-block-lap-addr bb)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) (cl-loop for inst-cell on (nthcdr (comp-limplify-pc comp-pass) @@ -1459,7 +1498,8 @@ into the C code forwarding the compilation unit." ;; Sanity check against block duplication. (cl-loop with addr-h = (make-hash-table) for bb being the hash-value in (comp-func-blocks func) - for addr = (comp-block-addr bb) + for addr = (when (comp-block-lap-p bb) + (comp-block-lap-addr bb)) when addr do (cl-assert (null (gethash addr addr-h))) (puthash addr t addr-h))