implementation module Sapl.Target.JS.Lifting import StdEnv import Sapl.SaplStruct from Data.Map import :: Map import qualified Data.Map as DM inline :: !SaplTerm -> Bool inline (SLet _ _) = False inline (SUpdate _ _ _) = False inline (SCase cond [(PLit (LBool True), case1),(PLit (LBool False), case2)]) = inline cond && inline case1 && inline case2 inline (SCase cond [(PLit (LBool False), case1),(PLit (LBool True), case2)]) = inline cond && inline case1 && inline case2 inline (SCase _ _) = False inline _ = True prepareFun :: (String Int Int -> Bool) !FuncType (Map String FuncType) -> (FuncType, Map String FuncType) prepareFun sf (FTFunc name body args) genfuns # (body, genfuns) = prepareExpr sf body genfuns = (FTFunc name body args,genfuns) prepareFun sf (FTCAF name body) genfuns # (body, genfuns) = prepareExpr sf body genfuns = (FTCAF name body, genfuns) prepareFun _ ftype genfuns = (ftype, genfuns) :: LiftingState = {varidx :: Int, genfuns :: Map String FuncType} genUpdateFun :: SaplTerm -> FuncType genUpdateFun (SUpdate _ ty updates) = FTFunc (TypedVar (NormalVar funName 0) NoType) (SUpdate (SVar (NormalVar "e" 0)) ty [(idx, SVar (NormalVar ("a" +++ toString i) 0)) \\ i <- [1..length updates] & idx <- map fst updates]) [TypedVar (NormalVar "e" 0) NoType:[TypedVar (NormalVar ("a" +++ toString i) 0) NoType \\ i <- [1..length updates]]] where funName = case ty of NoType = "update$" +++ toString (mask updates 0) (Type tn) = "update$" +++ tn +++ "_" +++ toString (mask updates 0) mask [] bits = bits mask [(idx,_):us] bits = mask us ((1 << idx) bitor bits) prepareExpr :: (String Int Int -> Bool) !SaplTerm (Map String FuncType) -> (SaplTerm, Map String FuncType) prepareExpr sf t genfuns # (t, st, defs) = walkTerm t False True {varidx = 1, genfuns = genfuns} = case defs of [] = (t, st.genfuns) defs = (SLet t defs, st.genfuns) where walkTerm :: !SaplTerm !Bool !Bool !LiftingState -> (!SaplTerm, !LiftingState, ![SaplLetDef]) walkTerm (SCase cond patterns) _ _ st | not (inline cond) # (cond, st, cdefs) = walkTerm cond True True st # (letvar, st) = genVar st # casevar = SVar (removeTypeInfo letvar) # (patterns, st) = walkPatterns patterns st # defs = [SaplLetDef letvar cond:cdefs] = case defs of [] = (SCase casevar patterns, st, []) defs = (SLet (SCase casevar patterns) defs, st, []) where genVar st=:{varidx} = (TypedVar (StrictVar ("$g"+++toString varidx) 0) (Type "B"), {st & varidx = varidx + 1}) walkTerm c=:(SCase cond patterns) doNotLift _ st # (cond, st, cdefs) = walkTerm cond False True st # (patterns, st) = walkPatterns patterns st # defs = cdefs = case defs of [] = (SCase cond patterns, st, []) // TODO: move to pattern? defs = (SLet (SCase cond patterns) defs, st, []) walkTerm (SLet expr bindings) doNotLift _ st # (expr, st, edefs) = walkTerm expr False True st # (bindings, st, bdefs) = walkBindings bindings st # defs = edefs ++ bdefs = case defs of [] = (SLet expr (bindings ++ defs), st, []) defs = (SLet expr (bindings ++ defs), st, []) walkTerm (SSelect expr ty idx) doNotLift strictPosition st # (expr, st, defs) = walkTerm expr False strictPosition st = (SSelect expr ty idx, st, defs) walkTerm (SUpdate expr ty updates) False True st # (letvar, st) = genVar st # updvar = SVar (removeTypeInfo letvar) # (updates, st, udefs) = walkUpdates updates st # (expr, st, edefs) = walkTerm expr False True st = (updvar, st, [SaplLetDef letvar (SUpdate expr ty updates):edefs++udefs]) where genVar st=:{varidx} = (TypedVar (StrictVar ("$g"+++toString varidx) 0) NoType, {st & varidx = varidx + 1}) walkTerm (SUpdate expr ty updates) doNotLift False st # (expr, st, edefs) = walkTerm expr doNotLift False st # (updates, st, udefs) = walkUpdates updates st // Generate new fun and lift it in the same time # (genfun, _) = prepareFun sf (genUpdateFun (SUpdate expr ty updates)) 'DM'.newMap # funname = extractName genfun = (SApplication (SVar funname) [expr:map snd updates], {st & genfuns = 'DM'.put (unpackVar funname) genfun st.genfuns}, edefs ++ udefs) where extractName (FTFunc (TypedVar name _) _ _) = name // TODO: is it a real option? walkTerm (SUpdate expr ty updates) True True st # (expr, st, edefs) = walkTerm expr False True st # (updates, st, udefs) = walkUpdates updates st = (SUpdate expr ty updates, st, edefs ++ udefs) walkTerm (SApplication v=:(SVar name) args) doNotLift strictPosition st # (args, st, defs) = walkArgs [sf (unpackVar name) (length args) i \\ i <- [0..]] args st = (SApplication v args, st, defs) walkTerm (SApplication name args) doNotLift strictPosition st # (args, st, defs) = walkArgs (repeat False) args st = (SApplication name args, st, defs) walkTerm t _ _ st = (t, st, []) walkArgs _ [] st = ([], st, []) walkArgs [isStrict:si] [t:ts] st # (t, st, def) = walkTerm t False isStrict st # (ts, st, defs) = walkArgs si ts st = ([t:ts], st, def ++ defs) walkPatterns [] st = ([], st) walkPatterns [(p, t):ps] st # (t, st, defs) = walkTerm t False True st # t = case defs of [] = t defs = SLet t defs # (ps, st) = walkPatterns ps st = ([(p,t):ps], st) walkBindings [] st = ([], st, []) walkBindings [SaplLetDef var expr:bs] st # (expr, st, def) = walkTerm expr True (isStrictVar var) st # (bs, st, defs) = walkBindings bs st = ([SaplLetDef var expr:bs], st, def ++ defs) walkUpdates [] st = ([], st, []) walkUpdates [(idx,expr):us] st # (expr, st, def) = walkTerm expr True False st # (us, st, defs) = walkUpdates us st = ([(idx, expr):us], st, def ++ defs)