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

reworking limplify

Browse source
This commit is contained in:
Andrea Corallo 2019-10-13 10:36:22 +02:00
parent 01334409d6
commit 6bbbf3fd82
1 changed files with 105 additions and 80 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -160,11 +160,11 @@ To be used when ncall-conv is nil."))
"A basic block." "A basic block."
(name nil :type symbol) (name nil :type symbol)
;; These two slots are used during limplification. ;; These two slots are used during limplification.
(sp nil (sp nil :type number
:documentation "When non nil indicates the sp value while entering :documentation "When non nil indicates the sp value while entering
into it.") into it.")
(closed nil :type boolean (addr nil :type number
:documentation "If the block was already closed.") :documentation "Start block LAP address.")
(insns () :type list (insns () :type list
:documentation "List of instructions.") :documentation "List of instructions.")
;; All the followings are for SSA and CGF analysis. ;; All the followings are for SSA and CGF analysis.
@ -228,7 +228,6 @@ structure.")
(defun comp-func-reset-generators (func) (defun comp-func-reset-generators (func)
"Reset unique id generators for FUNC." "Reset unique id generators for FUNC."
;; (setf (block-cnt-gen func) (comp-gen-counter))
(setf (comp-func-edge-cnt-gen func) (comp-gen-counter)) (setf (comp-func-edge-cnt-gen func) (comp-gen-counter))
(setf (comp-func-ssa-cnt-gen func) (comp-gen-counter))) (setf (comp-func-ssa-cnt-gen func) (comp-gen-counter)))
@ -251,7 +250,6 @@ structure.")
(defvar comp-ctxt) ;; FIXME (to be removed) (defvar comp-ctxt) ;; FIXME (to be removed)
;; Special vars used by some passes ;; Special vars used by some passes
(defvar comp-block) ; Can probably be removed
(defvar comp-func) (defvar comp-func)
@ -450,12 +448,26 @@ If INPUT is a string this is the file path to be compiled."
(cl-defstruct (comp-limplify (:copier nil)) (cl-defstruct (comp-limplify (:copier nil))
"Support structure used during function limplification." "Support structure used during function limplification."
(sp 0 :type fixnum
:documentation "Current stack pointer while walking LAP.")
(frame nil :type vector (frame nil :type vector
:documentation "Meta-stack used to flat LAP.") :documentation "Meta-stack used to flat LAP.")
(block-name nil :type symbol (curr-block nil :type comp-block
:documentation "Current basic block name.")) :documentation "Current block baing limplified.")
(sp 0 :type number
:documentation "Current stack pointer while walking LAP.")
(pc 0 :type number
:documentation "Current program counter while walking LAP.")
(pending-blocks () :type list
:documentation "List of blocks waiting for limplification."))
(defconst comp-lap-eob-ops
'(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop
byte-goto-if-not-nil-else-pop byte-return)
"LAP end of basic blocks op codes.")
(defsubst comp-lap-eob-p (inst)
"Return t if INST closes the current basic blocks, nil otherwise."
(when (member (car inst) comp-lap-eob-ops)
t))
(defsubst comp-sp () (defsubst comp-sp ()
"Current stack pointer." "Current stack pointer."
@ -489,13 +501,23 @@ Restore the original value afterwards."
(cl-defun comp-block-maybe-add (&rest args &key name sp &allow-other-keys) (cl-defun comp-block-maybe-add (&rest args &key name sp &allow-other-keys)
(let ((blocks (comp-func-blocks comp-func))) (let ((blocks (comp-func-blocks comp-func)))
(if-let ((bb (gethash name blocks))) (if-let ((bb (gethash name blocks)))
(if-let ((bb-sp (comp-block-sp bb))) ;; Sanity check sp.
;; If was a sp was already registered sanity check it. (cl-assert (or (null sp) (= sp (comp-block-sp bb))))
(cl-assert (or (null sp) (= sp bb-sp)))
;; Otherwise set it.
(setf (comp-block-sp bb) sp))
(puthash name (apply #'make--comp-block args) blocks)))) (puthash name (apply #'make--comp-block args) blocks))))
(cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys)
"Create a basic block and mark it as pending."
(if-let ((bb (gethash name (comp-func-blocks comp-func))))
;; If was already limplified sanity check sp.
(cl-assert (or (null sp) (= sp (comp-block-sp bb)))
(sp (comp-block-sp bb)) "sp %d %d differs")
;; Mark it pending in case is not already.
(unless (cl-find-if (lambda (bb)
(eq (comp-block-name bb) name))
(comp-limplify-pending-blocks comp-pass))
(push (apply #'make--comp-block args)
(comp-limplify-pending-blocks comp-pass)))))
(defun comp-call (func &rest args) (defun comp-call (func &rest args)
"Emit a call for function FUNC with ARGS." "Emit a call for function FUNC with ARGS."
(comp-add-subr-to-relocs func) (comp-add-subr-to-relocs func)
@ -524,10 +546,9 @@ Restore the original value afterwards."
do (aset v i mvar) do (aset v i mvar)
finally (return v))) finally (return v)))
(defun comp-emit (insn) (defsubst comp-emit (insn)
"Emit INSN into current basic block." "Emit INSN into current basic block."
(cl-assert (not (comp-block-closed comp-block))) (push insn (comp-block-insns (comp-limplify-curr-block comp-pass))))
(push insn (comp-block-insns comp-block)))
(defun comp-emit-set-call (call) (defun comp-emit-set-call (call)
"Emit CALL assigning the result the the current slot frame. "Emit CALL assigning the result the the current slot frame.
@ -553,53 +574,41 @@ If DST-N is specified use it otherwise assume it to be the current slot."
(cl-assert (numberp rel-idx)) (cl-assert (numberp rel-idx))
(comp-emit `(setimm ,(comp-slot) ,rel-idx ,val)))) (comp-emit `(setimm ,(comp-slot) ,rel-idx ,val))))
(defun comp-mark-block-closed () (defun comp-make-curr-block (block-name entry-sp)
"Mark current basic block as closed." "Create a basic block with BLOCK-NAME and set it as current block.
(setf (comp-block-closed (gethash (comp-limplify-block-name comp-pass) ENTRY-SP is the sp value when entering.
(comp-func-blocks comp-func))) The block is added to the current function.
t)) The block is returned."
(let ((bb (make--comp-block :name block-name :sp entry-sp)))
(setf (comp-limplify-curr-block comp-pass) bb)
(setf (comp-limplify-sp comp-pass) (comp-block-sp bb))
(puthash (comp-block-name bb) bb (comp-func-blocks comp-func))
bb))
(defun comp-emit-jump (target) (defun comp-emit-uncond-jump (lap-label)
"Emit an unconditional branch to block TARGET." "Emit an unconditional branch to LAP-LABEL."
(comp-emit (list 'jump target)) (let ((target (comp-lap-to-limple-bb lap-label)))
(comp-mark-block-closed)) (comp-block-maybe-mark-pending :name target
:sp (comp-sp)
(defun comp-emit-block (block-name &optional entry-sp) :addr lap-label)
"Emit basic block BLOCK-NAME. (comp-emit `(jump ,target))))
ENTRY-SP is the sp value when entering."
(let ((blocks (comp-func-blocks comp-func)))
;; In case does not exist register it into comp-func-blocks.
(comp-block-maybe-add :name block-name
:sp entry-sp)
;; If we are abandoning an non closed basic block close it with a fall
;; through.
(when (and (not (eq block-name 'entry))
(not (comp-block-closed
(gethash (comp-limplify-block-name comp-pass)
blocks))))
(comp-emit-jump block-name))
;; Set this a currently compiled block.
(setf comp-block (gethash block-name blocks))
;; If we are landing here from a previously recorded branch with known sp
;; adjust accordingly.
(when-let ((new-sp (comp-block-sp (gethash block-name blocks))))
(setf (comp-sp) new-sp))
(setf (comp-limplify-block-name comp-pass) block-name)))
(defun comp-emit-cond-jump (a b target-offset lap-label negated) (defun comp-emit-cond-jump (a b target-offset lap-label negated)
"Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ.
TARGET-OFFSET is the positive offset on the SP when branching to the target TARGET-OFFSET is the positive offset on the SP when branching to the target
block. block.
If NEGATED non nil negate the tested condition." If NEGATED non nil negate the tested condition."
(let ((bb (comp-new-block-sym))) ;; Fall through block (let ((bb (comp-new-block-sym)) ; Fall through block.
(comp-block-maybe-add :name bb :sp (comp-sp)) (target (comp-lap-to-limple-bb lap-label)))
(let ((target (comp-lap-to-limple-bb lap-label))) (comp-block-maybe-mark-pending :name bb
:sp (comp-sp)
:addr (1+ (comp-limplify-pc comp-pass)))
(comp-block-maybe-mark-pending :name target
:sp (+ target-offset (comp-sp))
:addr lap-label)
(comp-emit (if negated (comp-emit (if negated
(list 'cond-jump a b target bb) (list 'cond-jump a b target bb)
(list 'cond-jump a b bb target))) (list 'cond-jump a b bb target)))))
(comp-block-maybe-add :name target :sp (+ target-offset (comp-sp)))
(comp-mark-block-closed))
(comp-emit-block bb (comp-sp))))
(defun comp-stack-adjust (n) (defun comp-stack-adjust (n)
"Move sp by N." "Move sp by N."
@ -642,9 +651,7 @@ If NEGATED non nil negate the tested condition."
handler-type handler-type
handler-bb handler-bb
guarded-bb)) guarded-bb))
(comp-block-maybe-add :name handler-bb :sp (1+ (comp-sp))) (comp-block-maybe-add :name handler-bb :sp (1+ (comp-sp))))))
(comp-mark-block-closed)
(comp-emit-block guarded-bb (comp-sp)))))
(defun comp-emit-switch (var last-insn) (defun comp-emit-switch (var last-insn)
"Emit a limple for a lap jump table given VAR and LAST-INSN." "Emit a limple for a lap jump table given VAR and LAST-INSN."
@ -734,7 +741,7 @@ the annotation emission."
(cdr insn)))) (cdr insn))))
(comp-op-case (comp-op-case
(TAG (TAG
(comp-emit-block (comp-lap-to-limple-bb arg))) (comp-lap-to-limple-bb arg))
(byte-stack-ref (byte-stack-ref
(comp-copy-slot (- (comp-sp) arg 1))) (comp-copy-slot (- (comp-sp) arg 1)))
(byte-varref (byte-varref
@ -847,9 +854,10 @@ the annotation emission."
(byte-widen (byte-widen
(comp-emit-set-call (comp-call 'widen))) (comp-emit-set-call (comp-call 'widen)))
(byte-end-of-line auto) (byte-end-of-line auto)
(byte-constant2) ;; TODO (byte-constant2) ; TODO
;; Branches.
(byte-goto (byte-goto
(comp-emit-jump (comp-lap-to-limple-bb (cl-third insn)))) (comp-emit-uncond-jump (cl-third insn)))
(byte-goto-if-nil (byte-goto-if-nil
(comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0
(cl-third insn) nil)) (cl-third insn) nil))
@ -863,8 +871,7 @@ the annotation emission."
(comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1
(cl-third insn) t)) (cl-third insn) t))
(byte-return (byte-return
(comp-emit `(return ,(comp-slot+1))) (comp-emit `(return ,(comp-slot+1))))
(comp-mark-block-closed))
(byte-discard 'pass) (byte-discard 'pass)
(byte-dup (byte-dup
(comp-copy-slot (1- (comp-sp)))) (comp-copy-slot (1- (comp-sp))))
@ -920,7 +927,9 @@ the annotation emission."
(byte-switch (byte-switch
;; Assume to follow the emission of a setimm. ;; Assume to follow the emission of a setimm.
;; This is checked into comp-emit-switch. ;; This is checked into comp-emit-switch.
(comp-emit-switch (comp-slot+1) (cl-second (comp-block-insns comp-block)))) (comp-emit-switch (comp-slot+1)
(cl-second (comp-block-insns
(comp-limplify-curr-block comp-pass)))))
(byte-constant (byte-constant
(comp-emit-set-const arg)) (comp-emit-set-const arg))
(byte-discardN-preserve-tos (byte-discardN-preserve-tos
@ -938,17 +947,16 @@ the annotation emission."
for fallback = (intern (format "entry_fallback_%s" i)) for fallback = (intern (format "entry_fallback_%s" i))
do (progn do (progn
(comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback)) (comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback))
(comp-mark-block-closed) (comp-make-curr-block bb (comp-sp))
(comp-emit-block bb (comp-sp))
(comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit `(set-args-to-local ,(comp-slot-n i)))
(comp-emit '(inc-args))) (comp-emit '(inc-args)))
finally (comp-emit-jump 'entry_rest_args)) finally (comp-emit '(jump entry_rest_args)))
(cl-loop for i from minarg below nonrest (cl-loop for i from minarg below nonrest
do (comp-with-sp i do (comp-with-sp i
(comp-emit-block (intern (format "entry_fallback_%s" i)) (comp-make-curr-block (intern (format "entry_fallback_%s" i))
(comp-sp)) (comp-sp))
(comp-emit-set-const nil))) (comp-emit-set-const nil)))
(comp-emit-block 'entry_rest_args (comp-sp)) (comp-make-curr-block 'entry_rest_args (comp-sp))
(comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))) (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest))))
(defun comp-limplify-finalize-function (func) (defun comp-limplify-finalize-function (func)
@ -969,16 +977,29 @@ This will be called at load-time."
:frame-size 0)) :frame-size 0))
(comp-func func) (comp-func func)
(comp-pass (make-comp-limplify (comp-pass (make-comp-limplify
:curr-block (make--comp-block)
:sp -1 :sp -1
:frame (comp-new-frame 0))) :frame (comp-new-frame 0))))
(comp-block ())) (comp-make-curr-block 'entry (comp-sp))
(comp-emit-block 'entry (comp-sp))
(comp-emit-annotation "Top level") (comp-emit-annotation "Top level")
(cl-loop for args in (comp-ctxt-top-level-defvars comp-ctxt) (cl-loop for args in (comp-ctxt-top-level-defvars comp-ctxt)
do (comp-emit (comp-call 'defvar (make-comp-mvar :constant args)))) do (comp-emit (comp-call 'defvar (make-comp-mvar :constant args))))
(comp-emit `(return ,(make-comp-mvar :constant nil))) (comp-emit `(return ,(make-comp-mvar :constant nil)))
(comp-limplify-finalize-function func))) (comp-limplify-finalize-function func)))
(defun comp-limplify-block (bb)
"Limplify basic-block BB and add it to the current function."
(setf (comp-limplify-curr-block comp-pass) bb)
(setf (comp-limplify-sp comp-pass) (comp-block-sp bb))
(setf (comp-limplify-pc comp-pass) (comp-block-addr bb))
(cl-loop for inst in (nthcdr (comp-limplify-pc comp-pass)
(comp-func-lap comp-func))
do (progn
(comp-limplify-lap-inst inst)
(cl-incf (comp-limplify-pc comp-pass)))
until (comp-lap-eob-p inst))
(puthash (comp-block-name bb) bb (comp-func-blocks comp-func)))
(defun comp-limplify-function (func) (defun comp-limplify-function (func)
"Limplify a single function FUNC." "Limplify a single function FUNC."
(let* ((frame-size (comp-func-frame-size func)) (let* ((frame-size (comp-func-frame-size func))
@ -987,10 +1008,9 @@ This will be called at load-time."
:sp -1 :sp -1
:frame (comp-new-frame frame-size))) :frame (comp-new-frame frame-size)))
(args (comp-func-args func)) (args (comp-func-args func))
(args-min (comp-args-base-min args)) (args-min (comp-args-base-min args)))
(comp-block ()))
;; Prologue ;; Prologue
(comp-emit-block 'entry (comp-sp)) (comp-make-curr-block 'entry (comp-sp))
(comp-emit-annotation (concat "Lisp function: " (comp-emit-annotation (concat "Lisp function: "
(symbol-name (comp-func-symbol-name func)))) (symbol-name (comp-func-symbol-name func))))
(if (comp-args-p args) (if (comp-args-p args)
@ -1000,9 +1020,14 @@ This will be called at load-time."
(let ((nonrest (comp-nargs-nonrest args))) (let ((nonrest (comp-nargs-nonrest args)))
(comp-emit-narg-prologue args-min nonrest) (comp-emit-narg-prologue args-min nonrest)
(cl-incf (comp-sp) (1+ nonrest)))) (cl-incf (comp-sp) (1+ nonrest))))
(comp-emit '(jump bb_0))
;; Body ;; Body
(comp-emit-block (comp-new-block-sym) (comp-sp)) (comp-block-maybe-mark-pending :name (comp-new-block-sym)
(mapc #'comp-limplify-lap-inst (comp-func-lap func)) :sp (comp-sp)
:addr 0)
(cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass))
while next-bb
do (comp-limplify-block next-bb))
(comp-limplify-finalize-function func))) (comp-limplify-finalize-function func)))
(defun comp-add-func-to-ctxt (func) (defun comp-add-func-to-ctxt (func)