diff options
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 61 | ||||
| -rw-r--r-- | txr.1 | 91 |
2 files changed, 139 insertions, 13 deletions
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index 7defa0de..ea9b932d 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -41,9 +41,15 @@ (defstruct fbinding binding) +(defstruct blockinfo nil + sym + used + sys:env) + (defstruct sys:env nil vb fb + bb up co lev @@ -75,6 +81,12 @@ (((up me.up)) up.(lookup-lisp1 sym)) (t nil))) + (:method lookup-block (me sym) + (condlet + (((cell (assoc sym me.bb))) (cdr cell)) + (((up me.up)) up.(lookup-block sym)) + (t nil))) + (:method extend-var (me sym) (when (assoc sym me.vb) (compile-error me.co.last-form "duplicate variable: ~s" sym)) @@ -103,7 +115,11 @@ (:method out-of-scope (me reg) (if (eq (car reg) 'v) (let ((lev (ssucc (cadr reg)))) - (< me.lev lev))))) + (< me.lev lev)))) + + (:method extend-block (me sym) + (let* ((bn (new blockinfo sym sym env me))) + (set me.bb (acons sym bn me.bb))))) (compile-only (defstruct compiler nil @@ -187,6 +203,9 @@ (defvarl %test-inv% (relate %test-funs-pos% %test-funs-neg%)) +(defvarl %block-using-funs% '(sys:capture-cont return* sys:abscond* match-fun + eval load compile compile-file compile-toplevel)) + (defmeth compiler get-dreg (me atom) (condlet ((((null atom))) '(t 0)) @@ -566,22 +585,31 @@ (defmeth compiler comp-block (me oreg env form) (mac-param-bind form (op name . body) form (let* ((star (and name (eq op 'block*))) + (nenv (unless star + (new env up env lev env.lev co me))) + (binfo (unless star + (cdar nenv.(extend-block name)))) (treg (if star me.(maybe-alloc-treg oreg))) - (nfrag (if star me.(compile treg env name))) + (nfrag (if star me.(compile treg nenv name))) (nreg (if star nfrag.oreg me.(get-dreg name))) - (bfrag me.(comp-progn oreg env body)) + (bfrag me.(comp-progn oreg nenv body)) (lskip (gensym "l"))) (when treg me.(maybe-free-treg treg oreg)) - (new (frag oreg - ^(,*(if nfrag nfrag.code) - (block ,oreg ,nreg ,lskip) - ,*bfrag.code - ,*(maybe-mov oreg bfrag.oreg) - (end ,oreg) - ,lskip) - bfrag.fvars - bfrag.ffuns))))) + (if (and (not star) + (not binfo.used) + [all bfrag.ffuns system-symbol-p] + [none bfrag.ffuns (op member @1 %block-using-funs%)]) + bfrag + (new (frag oreg + ^(,*(if nfrag nfrag.code) + (block ,oreg ,nreg ,lskip) + ,*bfrag.code + ,*(maybe-mov oreg bfrag.oreg) + (end ,oreg) + ,lskip) + bfrag.fvars + bfrag.ffuns)))))) (defmeth compiler comp-return-from (me oreg env form) (mac-param-bind form (op name : value) form @@ -589,7 +617,10 @@ nil me.(get-dreg name))) (opcode (if (eq op 'return-from) 'ret 'abscsr)) - (vfrag me.(compile oreg env value))) + (vfrag me.(compile oreg env value)) + (binfo env.(lookup-block name))) + (when binfo + (set binfo.used t)) (new (frag oreg ^(,*vfrag.code (,opcode ,nreg ,vfrag.oreg)) @@ -1419,6 +1450,10 @@ (add ^(,pars.rest)))))) ,*lm-body)))) +(defun system-symbol-p (sym) + (member (symbol-package sym) + (load-time (list user-package system-package)))) + (defun usr:compile-toplevel (exp : (expanded-p nil)) (let ((co (new compiler)) (as (new assembler))) @@ -15704,6 +15704,97 @@ sense to have support a dynamically computed name. Thus blocks in \*(TL provide dynamic non-local returns, as well as returns out of lexical nesting. +It is permitted for blocks to be aggressively +.codn progn -converted +by compilation. This means that a +.code block +form which meets certain criteria is converted to a +.code progn +form which surrounds the +.metn body-form -s +and thus no longer establishes an exit point. + +A +.code block +form will be spared from +.codn progn -conversion +by the compiler if it meets the following rules. +.RS +.IP 1 +Any +.meta body-form +references the block's +.meta name +in a +.codn return , +.codn return-from , +.code sys:abscond-from +or +.code sys:capture-cont +expression. +.IP 2 +The form contains at least one direct call to a function +not in the standard \*(TL library. +.IP 3 +The form contains at least one direct call to the functions +.codn sys:capture-cont , +.codn return* , +.codn sys:abscond* , +.codn match-fun , +.codn eval , +.codn load , +.codn compile , +.code compile-file +or +.codn compile-toplevel . +.IP 4 +The form references any of the functions in rules 2 and 3 +as a function binding via the +.code dwim +operator (or the DWIM brackets notation) or via the +.code fun +operator. +.RE +.PP +Removal of blocks under the above rules means that some use of blocks which +works in interpreted code will not work in compiled programs. Programs which +adhere to the rules are not affected by such a difference. + +Additionally, the compiler may +.codn progn -convert +blocks in contravention of the above rules, but only if doing so makes no +difference to visible program behavior. + +.TP* Examples: +.cblk + (defun helper () + (return-from top 42)) + + ;; defun implicitly defines a block named top + (defun top () + (helper) ;; function returns 42 + (prinl 'notreached)) ;; never printed + + (defun top2 () + (let ((h (fun helper))) + (block top (call h)) ;; may progn-convert + (block top (call 'helper)) ;; may progn-convert + (block top (helper)))) ;; not removed +.cble +In the above examples, the block containing +.code "(call h)" +may be converted to +.code progn +because it doesn't express a +.B direct +call to the +.code helper +function. The block which calls +.code helper +using +.code "(call 'helper)" +is also not considered to be making a direct call. + .TP* "Dialect Note:" In Common Lisp, blocks are lexical. A separate mechanism consisting of catch and throw operators performs non-local transfer based on symbols. |