Commit 08110c68 authored by Laszlo Domoszlai's avatar Laszlo Domoszlai

fix lifting of embedded record updates

parent 3635602c
...@@ -2,7 +2,7 @@ definition module Sapl.Optimization.StrictnessPropagation ...@@ -2,7 +2,7 @@ definition module Sapl.Optimization.StrictnessPropagation
import Sapl.SaplParser, Sapl.Target.Flavour import Sapl.SaplParser, Sapl.Target.Flavour
:: IsStrictArgFun :== !ParserState !String !Int !Int -> Bool :: IsStrictArgFun :== ParserState String Int Int -> Bool
// strict argument checker for Flavour file // strict argument checker for Flavour file
isStrictArgFlavour :: !Flavour !ParserState !String !Int !Int -> Bool isStrictArgFlavour :: !Flavour !ParserState !String !Int !Int -> Bool
......
...@@ -676,7 +676,7 @@ where ...@@ -676,7 +676,7 @@ where
strictness = strictnessMap type s strictness = strictnessMap type s
isStrict idx = (strictness bitand (2 << idx)) > 0 isStrict idx = (strictness bitand (2 << idx)) > 0
// Should not happen, at thi spoint "update" is always at strict position // Should not happen, at this point "update" is always at strict position
termCoder t=:(SUpdate _ _ _) s a termCoder t=:(SUpdate _ _ _) s a
= a <++ "/* UPD */" = a <++ "/* UPD */"
...@@ -807,7 +807,7 @@ generateJS f tramp saplsrc mbPst ...@@ -807,7 +807,7 @@ generateJS f tramp saplsrc mbPst
= Ok (a, newpst) = Ok (a, newpst)
Error msg = Error msg Error msg = Error msg
where where
upd :: (!String !Int !Int -> Bool) ([FuncType], Map String FuncType) FuncType -> ([FuncType], Map String FuncType) upd :: (String Int Int -> Bool) ([FuncType], Map String FuncType) FuncType -> ([FuncType], Map String FuncType)
upd sf (nfs, genfuns) fun upd sf (nfs, genfuns) fun
= let (nfun, ngenfuns) = prepareFun sf fun genfuns in ([nfun:nfs], union genfuns ngenfuns) = let (nfun, ngenfuns) = prepareFun sf fun genfuns in ([nfun:nfs], union genfuns ngenfuns)
......
...@@ -8,7 +8,7 @@ inline :: !SaplTerm -> Bool ...@@ -8,7 +8,7 @@ inline :: !SaplTerm -> Bool
// First function: decide on strictness. See doStrictnessPropagation // First function: decide on strictness. See doStrictnessPropagation
// Map: generated functions // Map: generated functions
prepareFun :: (!String !Int !Int -> Bool) !FuncType (Map String FuncType) -> (FuncType, Map String FuncType) prepareFun :: (String Int Int -> Bool) !FuncType (Map String FuncType) -> (FuncType, Map String FuncType)
prepareExpr :: (!String !Int !Int -> Bool) !SaplTerm (Map String FuncType) -> (SaplTerm, Map String FuncType) prepareExpr :: (String Int Int -> Bool) !SaplTerm (Map String FuncType) -> (SaplTerm, Map String FuncType)
...@@ -7,12 +7,12 @@ import Data.Map ...@@ -7,12 +7,12 @@ import Data.Map
inline :: !SaplTerm -> Bool inline :: !SaplTerm -> Bool
inline (SLet _ _) = False inline (SLet _ _) = False
inline (SUpdate _ _ _) = 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 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 cond [(PLit (LBool False), case1),(PLit (LBool True), case2)]) = inline cond && inline case1 && inline case2
inline (SCase _ _) = False inline (SCase _ _) = False
inline _ = True inline _ = True
prepareFun :: (!String !Int !Int -> Bool) !FuncType (Map String FuncType) -> (FuncType, Map String FuncType) prepareFun :: (String Int Int -> Bool) !FuncType (Map String FuncType) -> (FuncType, Map String FuncType)
prepareFun sf (FTFunc name body args) genfuns prepareFun sf (FTFunc name body args) genfuns
# (body, genfuns) = prepareExpr sf body genfuns # (body, genfuns) = prepareExpr sf body genfuns
= (FTFunc name body args,genfuns) = (FTFunc name body args,genfuns)
...@@ -37,7 +37,7 @@ where ...@@ -37,7 +37,7 @@ where
mask [] bits = bits mask [] bits = bits
mask [(idx,_):us] bits = mask us ((1 << idx) bitor 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 :: (String Int Int -> Bool) !SaplTerm (Map String FuncType) -> (SaplTerm, Map String FuncType)
prepareExpr sf t genfuns prepareExpr sf t genfuns
# (t, st, defs) = walkTerm t False True {varidx = 1, genfuns = genfuns} # (t, st, defs) = walkTerm t False True {varidx = 1, genfuns = genfuns}
= case defs of = case defs of
...@@ -86,8 +86,8 @@ where ...@@ -86,8 +86,8 @@ where
where where
genVar st=:{varidx} = (TypedVar (StrictVar ("$g"+++toString varidx) 0) NoType, {st & varidx = varidx + 1}) genVar st=:{varidx} = (TypedVar (StrictVar ("$g"+++toString varidx) 0) NoType, {st & varidx = varidx + 1})
walkTerm (SUpdate expr ty updates) False False st walkTerm (SUpdate expr ty updates) doNotLift False st
# (expr, st, edefs) = walkTerm expr False False st # (expr, st, edefs) = walkTerm expr doNotLift False st
# (updates, st, udefs) = walkUpdates updates st # (updates, st, udefs) = walkUpdates updates st
// Generate new fun and lift it in the same time // Generate new fun and lift it in the same time
# (genfun, _) = prepareFun sf (genUpdateFun (SUpdate expr ty updates)) newMap # (genfun, _) = prepareFun sf (genUpdateFun (SUpdate expr ty updates)) newMap
...@@ -97,8 +97,9 @@ where ...@@ -97,8 +97,9 @@ where
where where
extractName (FTFunc (TypedVar name _) _ _) = name extractName (FTFunc (TypedVar name _) _ _) = name
walkTerm (SUpdate expr ty updates) _ strictPosition st // TODO: is it a real option?
# (expr, st, edefs) = walkTerm expr False strictPosition st walkTerm (SUpdate expr ty updates) True True st
# (expr, st, edefs) = walkTerm expr False True st
# (updates, st, udefs) = walkUpdates updates st # (updates, st, udefs) = walkUpdates updates st
= (SUpdate expr ty updates, st, edefs ++ udefs) = (SUpdate expr ty updates, st, edefs ++ udefs)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment