diff options
| -rw-r--r-- | stdlib/compiler.tl | 69 |
1 files changed, 49 insertions, 20 deletions
diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl index f3c27153..7ad727e0 100644 --- a/stdlib/compiler.tl +++ b/stdlib/compiler.tl @@ -56,6 +56,8 @@ (defstruct blockinfo nil sym + label + oreg used sys:env) @@ -103,13 +105,10 @@ (((up me.up)) up.(lookup-lisp1 sym mark-used)) (t nil))) - (:method lookup-block (me sym : mark-used) + (:method lookup-block (me sym) (condlet - (((cell (assoc sym me.bb))) - (let ((bi (cdr cell))) - (if mark-used (set bi.used t)) - bi)) - (((up me.up)) up.(lookup-block sym mark-used)) + (((cell (assoc sym me.bb))) (cdr cell)) + (((up me.up)) up.(lookup-block sym)) (t nil))) (:method get-loc (me) @@ -166,8 +165,8 @@ (let ((lev (ssucc (cadr reg)))) (< me.lev lev)))) - (:method extend-block (me sym) - (let* ((bn (new blockinfo sym sym env me))) + (:method extend-block (me sym label oreg) + (let* ((bn (new blockinfo sym sym label label oreg oreg env me))) (set me.bb (acons sym bn me.bb)))) (:method unused-check (me form nuance) @@ -231,6 +230,7 @@ closure-spies access-spies tjmp-occurs + bjmp-occurs (:method snapshot (me) (let ((snap (copy me))) @@ -835,14 +835,16 @@ (let* ((star (and name (eq op 'block*))) (nenv (unless star (new env up env lev env.lev co me))) + (lskip (gensym "l")) (binfo (unless star - (cdar nenv.(extend-block name)))) + (cdar nenv.(extend-block name lskip oreg)))) (treg (if star me.(maybe-alloc-treg oreg))) (nfrag (if star (ntp me.(compile treg env name)))) (nreg (if star nfrag.oreg me.(get-dreg name))) - (*esc-blocks* (cons name *esc-blocks*)) - (bfrag me.(comp-progn oreg (or nenv env) body)) - (lskip (gensym "l"))) + (*esc-blocks* (if star + *esc-blocks* + (cons name *esc-blocks*))) + (bfrag me.(comp-progn oreg (or nenv env) body))) (when treg me.(maybe-free-treg treg oreg)) (if (and (>= *opt-level* 2) @@ -852,7 +854,11 @@ [all bfrag.ffuns [orf system-symbol-p (op eq name)]] [all bfrag.ffuns system-symbol-p]) [none bfrag.ffuns (op member @1 %block-using-funs%)]) - bfrag + (set bfrag.code (append bfrag.code + ^(,*(maybe-mov oreg bfrag.oreg) + ,lskip)) + bfrag.oreg oreg + bfrag bfrag) (new (frag oreg ^(,*(if nfrag nfrag.code) (block ,oreg ,nreg ,lskip) @@ -871,11 +877,19 @@ nil me.(get-dreg name))) (opcode (if (eq op 'return-from) 'ret 'abscsr)) - (vfrag me.(compile oreg env value))) - env.(lookup-block name t) + (vfrag me.(compile oreg env value)) + (binfo env.(lookup-block name))) (new (frag oreg - ^(,*vfrag.code - (,opcode ,nreg ,vfrag.oreg)) + (cond + ((member name *esc-blocks*) + (set me.bjmp-occurs t) + ^(,*vfrag.code + ,*(maybe-mov binfo.oreg vfrag.oreg) + (bjmp ,binfo.label))) + (t (if binfo + (set binfo.used t)) + ^(,*vfrag.code + (,opcode ,nreg ,vfrag.oreg)))) vfrag.fvars vfrag.ffuns))))) @@ -1873,7 +1887,7 @@ @1))] insns))) -(defun convert-tjmps (insns) +(defun convert-t-b-jmps (insns) (build (while-true-match-case insns (((tjmp @top) . @rest) @@ -1891,11 +1905,26 @@ ((zerop bal) (add (pop rest))) (t (dec bal) (pop rest)))) (@nil (pop rest))))) + (((bjmp @bskip) . @rest) + (let ((bal 0)) + (while-true-match-case rest + ((@bskip . @nil) + (add ^(jmp ,bskip)) + (pop insns) + (return)) + (((@(or frame dframe block handle catch uwprot) . @nil) . @nil) + (inc bal) + (pop rest)) + (((end . @nil) . @nil) + (cond + ((zerop bal) (add (pop rest))) + (t (dec bal) (pop rest)))) + (@nil (pop rest))))) (@nil (add (pop insns)))))) (defmeth compiler optimize (me insns) - (when me.tjmp-occurs - (set insns (convert-tjmps insns))) + (when (or me.tjmp-occurs me.bjmp-occurs) + (set insns (convert-t-b-jmps insns))) (let ((olev *opt-level*)) (if (>= olev 4) (let* ((lt-dregs (mapcar .oreg me.lt-frags)) |