diff options
| -rw-r--r-- | stdlib/compiler.tl | 78 |
1 files changed, 69 insertions, 9 deletions
diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl index c3043d38..6a5e189f 100644 --- a/stdlib/compiler.tl +++ b/stdlib/compiler.tl @@ -180,7 +180,7 @@ name env lambda - called) + label) (defstruct closure-spy () env @@ -230,6 +230,7 @@ top-form closure-spies access-spies + tjmp-occurs (:method snapshot (me) (let ((snap (copy me))) @@ -479,7 +480,7 @@ ((bindable sym) (caseq sym (quote me.(comp-atom oreg (cadr form))) - (sys:setq me.(comp-setq oreg env form)) + (sys:setq me.(comp-setq oreg env env form)) (sys:lisp1-setq me.(comp-lisp1-setq oreg env form)) (sys:setqf me.(comp-setqf oreg env form)) (cond me.(comp-cond oreg env form)) @@ -520,6 +521,7 @@ (sys:load-time-lit me.(comp-load-time-lit oreg env form)) ;; compiler-only special operators: (ift me.(comp-ift oreg env form)) + (setq-in-env me.(comp-setq-in-env oreg env form)) (compiler-let me.(comp-compiler-let oreg env form)) ;; error cases ((macrolet symacrolet macro-time) @@ -562,9 +564,9 @@ (new (frag oreg ^((getv ,oreg ,dreg)) (list sym))))) (t (new (frag oreg ^((getlx ,oreg ,me.(get-sidx sym))) (list sym))))))) -(defmeth compiler comp-setq (me oreg env form) +(defmeth compiler comp-setq (me oreg env venv form) (mac-param-bind form (t sym value) form - (let* ((bind env.(lookup-var sym)) + (let* ((bind venv.(lookup-var sym)) (spec (special-var-p sym)) (vloc (cond (bind bind.loc) @@ -743,6 +745,10 @@ (uni (uni le-frag.ffuns ri-frag.ffuns) (uni th-frag.ffuns el-frag.ffuns)))))))) +(defmeth compiler comp-setq-in-env (me oreg env form) + (mac-param-bind form (op sym value venv) form + me.(comp-setq oreg env venv ^(,op ,sym ,value)))) + (defmeth compiler comp-switch (me oreg env form) (mac-param-bind form (t idx-form cases-vec) form (let* ((ncases (len cases-vec)) @@ -1129,7 +1135,8 @@ (compile-warning form "~s arguments in a lambda (max is ~s)" pars.nfix %max-lambda-fixed-args%)) (when (and tfn (eq tfn.lambda form)) - (set tfn.env env + (set tfn.env nenv + tfn.label (gensym "l") tpos t)) (flet ((spec-sub (sym : (loc :)) (cond @@ -1200,6 +1207,8 @@ nenv.(lookup-var (car op)).loc) ,*(if rest-par (list nenv.(lookup-var rest-par).loc))) + ,*(when tpos + ^(,tfn.label)) ,*(if need-dframe ^((dframe ,benv.lev 0))) ,*(if specials @@ -1413,6 +1422,9 @@ (defmeth compiler comp-fun-form (me oreg env form) (let* ((olev *opt-level*) + (tfn *tail-fun*) + (tpos *tail-pos*) + (*tail-pos* nil) (sym (car form)) (nargs (len (cdr form))) (fbin env.(lookup-fun sym t)) @@ -1422,6 +1434,9 @@ (param-check form nargs pars) (push (cons form nargs) *unchecked-calls*)) + (if (and tpos (eq tfn.?name sym)) + (return-from comp-fun-form me.(comp-tail-call oreg env form))) + (when (null fbin) (when (plusp olev) (match-case form @@ -1582,6 +1597,26 @@ apply-list-arg nil))))) +(defmeth compiler comp-tail-call (me oreg env form) + (let* ((tfn *tail-fun*) + (tenv (new env up tfn.env lev (succ env.lev) co me))) + (match (lambda @params . @nil) tfn.lambda + (let* ((lamb ^(lambda ,params)) + (args (butlastn 0 (cdr form))) + (dot-arg (nthlast 0 form)) + (lat (sys:lambda-apply-transform lamb args dot-arg nil))) + (match (@(or alet let) @temps (let* @sets . @code)) lat + (let* ((xsets (mapcar (tb ((sym val)) + ^(sys:setq-in-env ,sym ,val ,tenv)) + sets)) + (sfrag me.(comp-let oreg env ^(let ,temps ,*xsets))) + (cfrag me.(compile oreg tenv (expand ^(progn ,*code))))) + (set me.tjmp-occurs t) + (new (frag cfrag.oreg + (append sfrag.code cfrag.code ^((tjmp ,tfn.label))) + (uni sfrag.fvars cfrag.fvars) + (uni sfrag.ffuns cfrag.ffuns))))))))) + (defmeth compiler comp-for (me oreg env form) (mac-param-bind form (t inits (: (test nil test-p) . rets) incs . body) form (let* ((treg me.(alloc-treg)) @@ -1590,7 +1625,7 @@ (tfrag (if test-p (ntp me.(compile treg env test)))) (rfrag me.(comp-progn oreg env rets)) (nfrag (ntp me.(comp-progn treg env incs))) - (bfrag me.(comp-progn treg env body)) + (bfrag (ntp me.(comp-progn treg env body))) (lback (gensym "l")) (lskip (gensym "l")) (frags (build @@ -1732,7 +1767,8 @@ (defmeth compiler comp-prof (me oreg env form) (mac-param-bind form (t . forms) form - (let ((bfrag me.(comp-progn oreg env forms))) + (let ((*tail-pos* nil) + (bfrag me.(comp-progn oreg env forms))) (new (frag oreg ^((prof ,oreg) ,*bfrag.code @@ -1827,7 +1863,29 @@ @1))] insns))) +(defun convert-tjmps (insns) + (build + (while-true-match-case insns + (((tjmp @top) . @rest) + (let ((bal 0)) + (while-true-match-case rest + (((jend . @nil) . @nil) + (add ^(jmp ,top)) + (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))) (let ((olev *opt-level*)) (if (>= olev 4) (let* ((lt-dregs (mapcar .oreg me.lt-frags)) @@ -2770,17 +2828,19 @@ (defun usr:compile (obj) (match-case obj (@(functionp) - (tree-bind (t args . body) (func-get-form obj) + (tree-bind (name args . body) (func-get-form obj) (let* ((form (sys:env-to-let (func-get-env obj) ^(lambda ,args ,*body))) + (*tail-fun* (new tail-fun-info name name lambda form)) (vm-desc (compile-toplevel form t))) (vm-execute-toplevel vm-desc)))) ((lambda . @nil) [(compile-toplevel obj nil)]) (@(@fun (symbol-function)) - (tree-bind (t args . body) (func-get-form fun) + (tree-bind (name args . body) (func-get-form fun) (let* ((form (sys:env-to-let (func-get-env fun) ^(lambda ,args ,*body))) + (*tail-fun* (new tail-fun-info name name lambda form)) (vm-desc (compile-toplevel form t)) (comp-fun (vm-execute-toplevel vm-desc))) (set (symbol-function obj) comp-fun)))) |