From 724d9572783b8c3ecfa8bec2dc4dc19a50255e06 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Thu, 1 Dec 2011 09:35:52 +0000 Subject: * interp/compiler.boot (compSeq1): Generate %labelled forms. (coerceExit): Likewise. (compRepeatOrCollect): Likewise. (replaceExitEtc): Tidy. (canReturn): Likewise. (compIterate): Generate %lave form. (nullifyTargetingLeaves): Move out of massageLoop. (massageLoop): Adjust. * interp/define.boot (compDefineCapsuleFunction): Generate %labelled form for the body. * interp/g-opt.boot: Now handle %labelled and %leave forms. (optLabelled): Rename from optCatch. --- src/ChangeLog | 15 +++++++++ src/interp/compiler.boot | 57 ++++++++++++++++++-------------- src/interp/define.boot | 2 +- src/interp/g-opt.boot | 85 ++++++++++++++++++++++++------------------------ 4 files changed, 90 insertions(+), 69 deletions(-) (limited to 'src') diff --git a/src/ChangeLog b/src/ChangeLog index 914ca6ee..7316184e 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,18 @@ +2011-12-01 Gabriel Dos Reis + + * interp/compiler.boot (compSeq1): Generate %labelled forms. + (coerceExit): Likewise. + (compRepeatOrCollect): Likewise. + (replaceExitEtc): Tidy. + (canReturn): Likewise. + (compIterate): Generate %lave form. + (nullifyTargetingLeaves): Move out of massageLoop. + (massageLoop): Adjust. + * interp/define.boot (compDefineCapsuleFunction): Generate + %labelled form for the body. + * interp/g-opt.boot: Now handle %labelled and %leave forms. + (optLabelled): Rename from optCatch. + 2011-12-01 Gabriel Dos Reis * interp/buildom.boot (UnionEqual): Use %lambda, not %lam. diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index e99173ab..a4ee1cc7 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -1154,7 +1154,7 @@ compSeq1(l,$exitModeStack,e) == if c is "failed" then return nil catchTag := MKQ gensym() form := ["SEQ",:replaceExitEtc(c,catchTag,"TAGGEDexit",first $exitModeStack)] - [["CATCH",catchTag,form],first $exitModeStack,$finalEnv] + [['%labelled,catchTag,form],first $exitModeStack,$finalEnv] compSeqItem(x,m,e) == $insideExpressionIfTrue := false @@ -1170,10 +1170,10 @@ replaceExitEtc(x,tag,opFlag,opMode) == $finalEnv := $finalEnv ~= nil => intersectionEnvironment($finalEnv,t.env) t.env - first(x) := + x.op := opFlag is 'TAGGEDreturn => '%return second(x) := tag - "THROW" + '%leave third(x) := convertOrCroak(t,opMode).expr second(x) := n-1 x is [key,n,t] and key in '(TAGGEDreturn TAGGEDexit) => @@ -1242,7 +1242,7 @@ compIterate(x,m,e) == modifyModeStack(u.mode,index) if $loopBodyTag = nil then -- bound in compRepeatOrCollect $loopBodyTag := MKQ gensym() - [['THROW,$loopBodyTag,u.expr],u.mode,e] + [['%leave,$loopBodyTag,u.expr],u.mode,e] --% return @@ -1385,12 +1385,12 @@ canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends level=exitCount and not ValueFlag => nil op is "SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr] op is "TAGGEDreturn" => nil - op is "CATCH" => + op is '%labelled => [.,gs,data]:= expr (findThrow(gs,data,level,exitCount,ValueFlag) => true) where findThrow(gs,expr,level,exitCount,ValueFlag) == expr isnt [.,:.] => nil - expr is ["THROW", =gs,data] => true + expr is ['%leave, =gs,data] => true --this is pessimistic, but I know of no more accurate idea expr is ["SEQ",:l] => or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l] @@ -1865,7 +1865,7 @@ coerceExit: (%Triple,%Mode) -> %Maybe %Triple coerceExit([x,m,e],m') == m' := resolve(m,m') x' := replaceExitEtc(x,catchTag := MKQ gensym(),"TAGGEDexit",$exitMode) - coerce([["CATCH",catchTag,x'],m,e],m') + coerce([['%labelled,catchTag,x'],m,e],m') compAtSign: (%Form,%Mode,%Env) -> %Maybe %Triple compAtSign(["@",x,m'],m,e) == @@ -2413,29 +2413,36 @@ localReferenceIfThere(m,e) == idx := assocIndex(constructorDB currentConstructor e,m) => ['%tref,'$,idx] quote m +++ We are processing a loop with entrypoint labelled `tag'. +++ Attempt to nullify targets of all enclosed %leave forms +++ that designate `tag'. +++ NOTES: A %leave form with null target exits the innermost +++ enclosing labelled expression. +nullifyTargetingLeaves(x,tag) == + atomic? x => nil + x is ['%leave,=tag,expr] => + nullifyTargetingLeaves(expr,tag) + -- Avoid redundant %leave for return-expressions. + expr is ['TAGGEDreturn,:.] => + x.op := expr.op + x.args := expr.args + second(x) := nil + for x' in x repeat + nullifyTargetingLeaves(x',tag) + + massageLoop x == main x where main x == - x isnt ['CATCH,tag,['REPEAT,:iters,body]] => x - replaceThrowWithLeave(body,tag) + x isnt ['%labelled,tag,['REPEAT,:iters,body]] => x + nullifyTargetingLeaves(body,tag) containsNonLocalControl?(body,nil) => systemErrorHere ['massageLoop,x] - ['CATCH,tag,['%loop,:iters,body,'%nil]] - replaceThrowWithLeave(x,tag) == - atomic? x => nil - x is ['THROW,=tag,expr] => - replaceThrowWithLeave(expr,tag) - -- Avoid redudant THROW for return-expressions. - if expr is ['TAGGEDreturn,:.] then - x.op := expr.op - x.args := expr.args - else - x.op := '%leave - x.args := [nil,:rest x.args] - for x' in x repeat replaceThrowWithLeave(x',tag) + ['%labelled,tag,['%loop,:iters,body,'%nil]] containsNonLocalControl?(x,tags) == atomic? x => false - x is ['THROW,tag,x'] => + x is ['%leave,tag,x'] => + tag = nil => false -- see NOTES in nullifyTargetingLeaves. not symbolMember?(tag,tags) or containsNonLocalControl?(x',tags) - x is ['CATCH,tag,x'] => + x is ['%labelled,tag,x'] => containsNonLocalControl?(x',[tag,:tags]) or/[containsNonLocalControl?(x',tags) for x' in x] @@ -2474,7 +2481,7 @@ compRepeatOrCollect(form,m,e) == [body',m',e'] := compOrCroak(body,bodyMode,e) or return nil -- Massage the loop body if we have a structured jump. if $iterateCount > 0 then - body' := ["CATCH",$loopBodyTag,body'] + body' := ['%labelled,$loopBodyTag,body'] if $until then [untilCode,.,e']:= comp($until,$Boolean,e') itl':= substitute(["UNTIL",untilCode],'$until,itl') diff --git a/src/interp/define.boot b/src/interp/define.boot index f9a6e6e0..1102f795 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -1910,7 +1910,7 @@ compDefineCapsuleFunction(db,df is ['DEF,form,signature,body], catchTag := MKQ gensym() body' := replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode) body' := addArgumentConditions(body',$op) - finalBody := ["CATCH",catchTag,body'] + finalBody := ['%labelled,catchTag,body'] compile(db,[op',["LAM",[:argl,'_$],finalBody]],signature) $functorStats:= addStats($functorStats,$functionStats) diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot index c92e326e..5cdf2d66 100644 --- a/src/interp/g-opt.boot +++ b/src/interp/g-opt.boot @@ -105,8 +105,8 @@ changeVariableDefinitionToStore(form,vars) == jumpToToplevel? x == atomic? x => false op := x.op - op is 'SEQ => CONTAINED('THROW,x.args) -- FIXME: what about GO? - op in '(EXIT THROW %leave) => true + op is 'SEQ => CONTAINED('%leave,x.args) -- FIXME: what about GO? + op in '(EXIT %leave) => true or/[jumpToToplevel? x' for x' in x] ++ Return true if `form' is just one assignment expression. @@ -148,21 +148,21 @@ optimizeFunctionDef(def) == [name,[slamOrLam,args,body]] := def' body':= - removeTopLevelCatch body where - removeTopLevelCatch body == - body is ["CATCH",g,u] => - removeTopLevelCatch replaceThrowByReturn(u,g) + removeTopLevelLabel body where + removeTopLevelLabel body == + body is ['%labelled,g,u] => + removeTopLevelLabel replaceLeaveByReturn(u,g) body - replaceThrowByReturn(x,g) == + replaceLeaveByReturn(x,g) == fn(x,g) x fn(x,g) == - x is ["THROW", =g,:u] => + x is ['%leave,=g,:u] => x.first := "RETURN" - x.rest := replaceThrowByReturn(u,g) + x.rest := replaceLeaveByReturn(u,g) x isnt [.,:.] => nil - replaceThrowByReturn(first x,g) - replaceThrowByReturn(rest x,g) + replaceLeaveByReturn(first x,g) + replaceLeaveByReturn(rest x,g) changeVariableDefinitionToStore(body',args) [name,[slamOrLam,args,groupVariableDefinitions body']] @@ -198,54 +198,53 @@ subrname u == COMPILED_-FUNCTION_-P u or MBPIP u => BPINAME u nil -changeThrowToExit(s,g) == +changeLeaveToExit(s,g) == s isnt [.,:.] or s.op in '(QUOTE SEQ REPEAT COLLECT %collect %loop) => nil - s is ["THROW", =g,:u] => (s.first := "EXIT"; s.rest := u) - changeThrowToExit(first s,g) - changeThrowToExit(rest s,g) + s is ['%leave, =g,:u] => (s.first := "EXIT"; s.rest := u) + changeLeaveToExit(first s,g) + changeLeaveToExit(rest s,g) -hasNoThrows(a,g) == - a is ["THROW", =g,:.] => false +hasNoLeave(a,g) == + a is ['%leave, =g,:.] => false a isnt [.,:.] => true - hasNoThrows(first a,g) and hasNoThrows(rest a,g) + hasNoLeave(first a,g) and hasNoLeave(rest a,g) -changeThrowToGo(s,g) == +changeLeaveToGo(s,g) == s isnt [.,:.] or s.op is 'QUOTE => nil - s is ["THROW", =g,u] => - changeThrowToGo(u,g) + s is ['%leave, =g,u] => + changeLeaveToGo(u,g) s.first := "PROGN" s.rest := [["%LET",second g,u],["GO",second g]] - changeThrowToGo(first s,g) - changeThrowToGo(rest s,g) + changeLeaveToGo(first s,g) + changeLeaveToGo(rest s,g) -++ Change any `(THROW tag (%return expr))' in x to just +++ Change any `(%leave tag (%return expr))' in x to just ++ `(%return expr) since a %return-expression transfers control ++ out of the function body anyway. Similarly, transform -++ reudant `(THROW tag (THROW tag expr))' to `(THROW tag expr)'. -removeNeedlessThrow x == +++ reudant `('%leave tag (%leave tag expr))' to `(%leave tag expr)'. +removeNeedlessLeave x == atomic? x => x - x is ['THROW,.,y] and y is ['%return,:.] => - removeNeedlessThrow third y + x is ['%leave,.,y] and y is ['%return,:.] => + removeNeedlessLeave third y x.op := y.op x.args := y.args - x is ['THROW,g,y] and y is ['THROW,=g,z] => - removeNeedlessThrow z + x is ['%leave,g,y] and y is ['%leave,=g,z] => + removeNeedlessLeave z second(x.args) := z for x' in x repeat - removeNeedlessThrow x' + removeNeedlessLeave x' -optCatch (x is ["CATCH",g,a]) == - $InteractiveMode => x +optLabelled (x is ['%labelled,g,a]) == a isnt [.,:.] => a - removeNeedlessThrow a - if a is ["SEQ",:s,["THROW", =g,u]] then - changeThrowToExit(s,g) + removeNeedlessLeave a + if a is ["SEQ",:s,['%leave,=g,u]] then + changeLeaveToExit(s,g) a.rest := [:s,["EXIT",u]] a := simplifyVMForm a - if hasNoThrows(a,g) then + if hasNoLeave(a,g) then resetTo(x,a) else - changeThrowToGo(a,g) + changeLeaveToGo(a,g) x.first := "SEQ" x.rest := [["EXIT",a],second g,["EXIT",second g]] x @@ -389,10 +388,10 @@ optIF2COND ["IF",a,b,c] == ++ Determine whether the symbol `g' is the name of a temporary that ++ can be replaced in the form `x', if it is of linear usage and not -++ the name of a program point. The latter occurs when THROW forms -++ are changed to %LET form followed by a GO form -- see optCatch. +++ the name of a program point. The latter occurs when %leave forms +++ are changed to %LET form followed by a GO form -- see optLabelled. replaceableTemporary?(g,x) == - GENSYMP g and numOfOccurencesOf(g,x) < 2 and not jumpTarget?(g,x) where + gensym? g and numOfOccurencesOf(g,x) < 2 and not jumpTarget?(g,x) where jumpTarget?(g,x) == atomic? x => false x is ['GO,=g] => true @@ -419,7 +418,7 @@ optSEQ ["SEQ",:l] == null aft => ['%when,:transform,'(%otherwise (conderr))] optCond ['%when,:transform,['%otherwise,optSEQ ["SEQ",:aft]]] tryToRemoveSEQ l == - l is ["SEQ",[op,a]] and op in '(EXIT RETURN THROW) => a + l is ["SEQ",[op,a]] and op in '(EXIT RETURN %leave %return) => a l optSuchthat [.,:u] == ["SUCHTHAT",:u] @@ -841,7 +840,7 @@ for x in '((%call optCall) _ (%list optList)_ (SPADCALL optSPADCALL)_ (_| optSuchthat)_ - (CATCH optCatch)_ + (%labelled optLabelled)_ (%when optCond)_ (%retract optRetract)_ (%pullback optPullback)_ -- cgit v1.2.3