From: Andrea Corallo Date: Sun, 13 Oct 2019 15:41:26 +0000 (+0200) Subject: fix label to addr computation X-Git-Tag: emacs-28.0.90~2727^2~1084 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=cae7d6cd58868916bcec34d9572736e7541b9710;p=emacs.git fix label to addr computation --- diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 491a0bfc25f..06bbc40012b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -102,15 +102,6 @@ Can be used by code that wants to expand differently in this case.") direct-callref) "Limple operators use to call subrs.") -(defconst comp-mostly-pure-funcs - '(% * + - / /= 1+ 1- < <= = > >= cons list % concat logand logcount logior - lognot logxor regexp-opt regexp-quote string-to-char string-to-syntax - symbol-name) - "Functions on witch we do constant propagation." - ;; Is it acceptable to move into the compile time functions that are - ;; allocating memory? (these are technically not side effect free) -) - (eval-when-compile (defconst comp-op-stack-info (cl-loop with h = (make-hash-table) @@ -123,7 +114,7 @@ Can be used by code that wants to expand differently in this case.") (cl-defstruct comp-ctxt "Lisp side of the compiler context." - (output nil :type 'string + (output nil :type string :documentation "Target output filename for the compilation.") (top-level-defvars nil :type list :documentation "List of top level form to be exp.") @@ -456,12 +447,16 @@ If INPUT is a string this is the file path to be compiled." :documentation "Current stack pointer while walking LAP.") (pc 0 :type number :documentation "Current program counter while walking LAP.") + (label-to-addr nil :type hash-table + :documentation "LAP hash table -> address.") (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) + byte-goto-if-not-nil-else-pop byte-return byte-pushcatch + byte-pophandler ; ?? + ) "LAP end of basic blocks op codes.") (defsubst comp-lap-eob-p (inst) @@ -498,13 +493,6 @@ Restore the original value afterwards." "Slot into the meta-stack pointed by sp + 1." (comp-slot-n (1+ (comp-sp)))) -(cl-defun comp-block-maybe-add (&rest args &key name sp &allow-other-keys) - (let ((blocks (comp-func-blocks comp-func))) - (if-let ((bb (gethash name blocks))) - ;; Sanity check sp. - (cl-assert (or (null sp) (= sp (comp-block-sp bb)))) - (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)))) @@ -590,7 +578,7 @@ The block is returned." (let ((target (comp-lap-to-limple-bb lap-label))) (comp-block-maybe-mark-pending :name target :sp (comp-sp) - :addr lap-label) + :addr (comp-label-to-addr lap-label)) (comp-emit `(jump ,target)))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) @@ -605,7 +593,7 @@ If NEGATED non nil negate the tested condition." :addr (1+ (comp-limplify-pc comp-pass))) (comp-block-maybe-mark-pending :name target :sp (+ target-offset (comp-sp)) - :addr lap-label) + :addr (comp-label-to-addr lap-label)) (comp-emit (if negated (list 'cond-jump a b target bb) (list 'cond-jump a b bb target))))) @@ -640,18 +628,36 @@ If NEGATED non nil negate the tested condition." (puthash n name hash) name)))) +(defun comp-fill-label-h () + "Fill label-to-addr hash table for the current function." + (setf (comp-limplify-label-to-addr comp-pass) (make-hash-table :test 'eql)) + (cl-loop for insn in (comp-func-lap comp-func) + for addr from 0 + do (pcase insn + (`(TAG ,label) + (puthash label addr (comp-limplify-label-to-addr comp-pass)))))) + +(defsubst comp-label-to-addr (label) + "Find the address of LABEL." + (and (gethash label (comp-limplify-label-to-addr comp-pass)) + (error "Can't find label %d" label))) + (defun comp-emit-handler (guarded-label handler-type) - "Emit a non local exit handler for GUARDED-LABEL of type HANDLER-TYPE." - (let ((guarded-bb (comp-new-block-sym))) - (comp-block-maybe-add :name guarded-bb :sp (comp-sp)) - (let ((handler-bb (comp-lap-to-limple-bb guarded-label))) - (comp-emit (list 'push-handler - (comp-slot+1) - (comp-slot+1) - handler-type - handler-bb - guarded-bb)) - (comp-block-maybe-add :name handler-bb :sp (1+ (comp-sp)))))) + "Emit a non local exit handler to GUARDED-LABEL of type HANDLER-TYPE." + (let ((guarded-bb (comp-new-block-sym)) + (handler-bb (comp-lap-to-limple-bb guarded-label))) + (comp-block-maybe-mark-pending :name guarded-bb + :sp (comp-sp) + :addr (1+ (comp-limplify-pc comp-pass))) + (comp-block-maybe-mark-pending :name handler-bb + :sp (1+ (comp-sp)) + :addr (comp-label-to-addr guarded-label)) + (comp-emit (list 'push-handler + (comp-slot+1) + (comp-slot+1) + handler-type + handler-bb + guarded-bb)))) (defun comp-emit-switch (var last-insn) "Emit a limple for a lap jump table given VAR and LAST-INSN." @@ -1009,6 +1015,7 @@ This will be called at load-time." :frame (comp-new-frame frame-size))) (args (comp-func-args func)) (args-min (comp-args-base-min args))) + (comp-fill-label-h) ;; Prologue (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation (concat "Lisp function: "