Commit 81cb1361 authored by László Domoszlai's avatar László Domoszlai

- handle oversaturated inlineable applications

- fix bug in let binding ordering
- fix pattern matching when embedded case expressions are involved

git-svn-id: https://svn.cs.ru.nl/repos/clean-sapl/branches/hierarchical@408 cb785ff4-4565-4a15-8565-04c4fcf96d79
parent c6fd054a
......@@ -12,7 +12,7 @@ from Data.Map import :: Map
}
:: ConstructorDef = { index :: !Int
, singleton :: !Bool
, nr_cons :: !Int
, nr_args :: !Int // for efficiency
, args :: [SaplVar]
}
......
......@@ -26,15 +26,11 @@ defaultState = {ps_level = 0, ps_constructors = newMap, ps_functions = newMap, p
addConstructor name def :== \s -> Ok (name, {s & ps_constructors = put (unpackVar name) def s.ps_constructors})
addConstructors conses=:[SaplConstructor name idx as]
= \s -> Ok (conses, {s & ps_constructors = put (unpackVar name) def s.ps_constructors})
where
def = {index = idx, singleton = True, nr_args = length as, args = as}
addConstructors conses = \s -> Ok (conses, {s & ps_constructors = foldl adddef s.ps_constructors conses})
where
nr_cons = length conses
adddef m (SaplConstructor name idx as)
= put (unpackVar name) {index = idx, singleton = False, nr_args = length as, args = as} m
= put (unpackVar name) {index = idx, nr_cons = nr_cons, nr_args = length as, args = as} m
factor [TIdentifier name:ts] = getLevel >>= \level = returnS (Just (SVar (NormalVar name level)), ts)
factor [TLit lit:ts] = returnS (Just (SLit lit), ts)
......@@ -194,7 +190,7 @@ constr [TTypeDef, TIdentifier name, TAssignmentOp, TOpenBracket: ts] =
getLevel
>>= \level = args_record ts
>>= \(as, ts) = case hd ts of
TCloseBracket = addConstructor (NormalVar name level) {index = 0, singleton = True, nr_args = length as, args = as} >>= \tname = returnS (FTRecord tname as, tl ts)
TCloseBracket = addConstructor (NormalVar name level) {index = 0, nr_cons = 1, nr_args = length as, args = as} >>= \tname = returnS (FTRecord tname as, tl ts)
= returnE (ts, "Missing close parenthesis3")
// ADT
......@@ -270,4 +266,3 @@ where
mergeMaps m1 m2 = putList (toList m2) m1
mergeParserStates pst1 Nothing = pst1
......@@ -49,5 +49,6 @@ unpackVar :: !SaplVar -> String
unpackBindVar :: !SaplLetDef -> SaplVar
unpackConsName :: !SaplPattern -> Maybe String
isConsPattern :: !SaplPattern -> Bool
isConsPattern :: !SaplPattern -> Bool
isDefaultPattern :: !SaplPattern -> Bool
......@@ -56,3 +56,6 @@ isConsPattern :: !SaplPattern -> Bool
isConsPattern (PCons _ _) = True
isConsPattern _ = False
isDefaultPattern :: !SaplPattern -> Bool
isDefaultPattern PDefault = True
isDefaultPattern _ = False
......@@ -13,19 +13,20 @@ import Text.Unicode.Encodings.JS
import Sapl.SaplTokenizer, Sapl.SaplParser, Sapl.Target.Flavour
import Sapl.Transform.Let
from Data.List import elem_by
:: CoderState = { cs_inbody :: Maybe SaplVar // The body of the function which is being generated (not signature)
, cs_intrfunc :: Maybe SaplVar // The name of the currently generated function if it is tail recursive
, cs_inletdef :: Maybe [SaplVar] // used for generating cross referencing (e.g. recursive) lets. Normal only!!
, cs_current_vars :: [SaplVar] // Strict, Normal
, cs_constructors :: Map String ConstructorDef
, cs_functions :: Map String [SaplVar]
, cs_CAFs :: Map String Void
, cs_builtins :: Map String (String, Int)
, cs_inlinefuncs :: Map String InlineFunDef
, cs_trampoline :: Bool
, cs_prefix :: String
from Data.List import elem_by, partition
:: CoderState = { cs_inbody :: !Maybe SaplVar // The body of the function which is being generated (not signature)
, cs_intrfunc :: !Maybe SaplVar // The name of the currently generated function if it is tail recursive
, cs_inletdef :: !Maybe SaplVar // for finding out about let-rec
, cs_incaseexpr :: !Bool
, cs_current_vars :: ![SaplVar] // Strict, Normal
, cs_constructors :: !Map String ConstructorDef
, cs_functions :: !Map String [SaplVar]
, cs_CAFs :: !Map String Void
, cs_builtins :: !Map String (String, Int)
, cs_inlinefuncs :: !Map String InlineFunDef
, cs_trampoline :: !Bool
, cs_prefix :: !String
}
newState :: !Flavour !Bool !ParserState -> CoderState
......@@ -33,6 +34,7 @@ newState f tramp p =
{ cs_inbody = Nothing
, cs_intrfunc = Nothing
, cs_inletdef = Nothing
, cs_incaseexpr = False
, cs_current_vars = []
, cs_constructors = p.ps_constructors
, cs_functions = p.ps_functions
......@@ -76,6 +78,7 @@ where
urlEncodeChar '_' = ['_']
urlEncodeChar '.' = ['_']
urlEncodeChar ' ' = ['+']
urlEncodeChar '$' = ['$']
urlEncodeChar x = ['$', c1 ,c2]
(c1,c2) = charToHex x
......@@ -290,10 +293,34 @@ get_cons_or_die s cons = maybe (abort ("Data constructor "+++cons+++" cannot be
id
(get cons s.cs_constructors)
splitDefaultPattern :: ![(SaplPattern, SaplTerm)] -> (![(SaplPattern, SaplTerm)], !Maybe SaplTerm)
splitDefaultPattern patterns
= case partition (isDefaultPattern o fst) patterns of
([],ps) = (ps, Nothing)
([(_,d)],ps) = (ps, Just d)
= abort "Error: more than one default branches in a select expression"
containsUnsafeSelect :: !CoderState !SaplTerm -> Bool
containsUnsafeSelect s (SApplication _ ts) = any (containsUnsafeSelect s) ts
containsUnsafeSelect s (SIf _ tb fb) = containsUnsafeSelect s tb || containsUnsafeSelect s fb
containsUnsafeSelect s (SSelect _ ps) = isUnsafeSelect s ps || any (containsUnsafeSelect s) (map snd ps)
containsUnsafeSelect s (SLet b _) = containsUnsafeSelect s b
containsUnsafeSelect s _ = False
isUnsafeSelect :: !CoderState ![(SaplPattern, SaplTerm)] -> Bool
isUnsafeSelect s patterns
= case ps of
[(PCons name _, _):_] = isNothing d && (get_cons_or_die s name).nr_cons <> length ps
[(PLit (LBool True), _),(PLit (LBool False), _):_] = False
[(PLit (LBool False), _),(PLit (LBool True), _):_] = False
_ = isNothing d
where
(ps, d) = splitDefaultPattern patterns
instance TermCoder (SaplPattern, SaplTerm, Bool)
where
termCoder (PDefault, body, _) s a
= a <++ "default: " <++ callWrapper body s
= callWrapper body s a
termCoder (PLit lit, body, _) s a
= a <++ "case " <++ termCoder lit s <++ ": " <++ callWrapper body s
......@@ -379,13 +406,13 @@ where
| isJust s.cs_inbody && not isLocalVar && isStrictFunction
= a <++ escapeName s.cs_prefix name <++ "$eval"
// else
| isJust s.cs_inletdef && elem_by eqVarByName t (fromJust s.cs_inletdef) // isMember t (fromJust s.cs_inletdef)
// else (TODO: probably bogus in tail-recursion...)
| isJust s.cs_inletdef && eqVarByNameLevel t (fromJust s.cs_inletdef)
= a <++ "[function(){return " <++ force var_name <++ ";},[]]"
// else: use the defined name if its a built-in function, otherwise its a variable...
// no prefix for built-in functions
= a <++ (maybe var_name (escapeName "" o fst) (get name s.cs_builtins))
// else: use the defined name if its a built-in function, otherwise its a variable...
// no prefix for built-in functions
= a <++ (maybe var_name (escapeName "" o fst) (get name s.cs_builtins))
where
mbInlineFun = get name s.cs_inlinefuncs
inlineFun = fromJust mbInlineFun
......@@ -422,18 +449,16 @@ where
letDefCoder :: ![SaplLetDef] !CoderState !StringAppender -> StringAppender
letDefCoder [t] s a = termCoder t {s & cs_intrfunc = Nothing} a
letDefCoder [t:ts] s a
= a <++ termCoder t {s & cs_intrfunc = Nothing} <++ "," <++ letDefCoder ts {s & cs_inletdef = Just rs,
cs_current_vars=[getVar t: s.cs_current_vars]}
where
rs = tl (fromJust s.cs_inletdef) // remaining definitions
getVar (SaplLetDef var _) = var
= a <++ termCoder t {s & cs_intrfunc = Nothing} <++ "," <++ letDefCoder ts {s & cs_current_vars=[unpackBindVar t: s.cs_current_vars]}
letDefCoder [] _ a = a
instance TermCoder SaplLetDef
where
termCoder (SaplLetDef name body) s a
= a <++ termCoder name {s & cs_inletdef = Nothing} <++ "=" <++ (if (isStrictVar name) forceTermCoder termCoder) body s
= a <++ termCoder name {s & cs_inletdef = Nothing} <++ "="
<++ (if (isStrictVar name) forceTermCoder termCoder) body {s & cs_inletdef = Just name}
forceTermCoder t s a = termCoder t s a
trampolineCoder t s a = termCoder t s a
......@@ -470,6 +495,13 @@ where
(\t a = termCoder t {s & cs_intrfunc = Nothing} a)
(\t a = forceTermCoder t {s & cs_intrfunc = Nothing} a) args <++ ")"
// more arguments than needed: split it
| isJust mbInlineFun && inlineFun.arity < length args
= forceApp (\a -> a <++ inlineFun.fun
(\t a = termCoder t {s & cs_intrfunc = Nothing} a)
(\t a = forceTermCoder t {s & cs_intrfunc = Nothing} a) (take inlineFun.arity args) <++ ",["
<++ termArrayCoder (drop inlineFun.arity args) "," {s & cs_intrfunc = Nothing} <++ "]") a
// BINs return no thunk, there is no need for feval even in trampolining
// no prefix for built-in functions
| isJust builtin && (snd (fromJust builtin)) == length args
......@@ -538,22 +570,51 @@ where
termCoder :: !SaplTerm !CoderState !StringAppender -> StringAppender
termCoder t=:(SVar var) s a = termCoder var s a
termCoder (SSelect expr patterns) s a | any (isConsPattern o fst) patterns
termCoder t=:(SSelect expr patterns) s a | any (isConsPattern o fst) patterns
# a = a <++ "var ys=" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ ";"
= case patterns of
[(p,body)] = if (isSingleton (fromJust (unpackConsName p)))
(termCoder (p, body, True) s a)
(addSwitch (termCoder (p, body, False) s) a)
= addSwitch (termArrayCoder (map (\(p,b)=(p,b,False)) patterns) "" s) a
= if (containsUnsafeSelect s t) (unsafe a) (safe a)
where
isSingleton cons = (get_cons_or_die s cons).singleton
addSwitch e a = a <++ "switch(ys[0]){" <++ e <++ "}"
isSingleton cons = (get_cons_or_die s cons).nr_cons == 1
addSwitch e a = a <++ "switch(ys[0]){" <++ e <++ "};"
(ps, d) = splitDefaultPattern patterns
// Something is very wrong with type inference here
termCoder (SSelect expr patterns) s a
= a <++ "switch(" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ "){"
<++ termArrayCoder (map (\(p,b)=(p,b,False)) patterns) "" s <++ "}"
ups :: [(SaplPattern, SaplTerm, Bool)]
ups = map (\(p,b)=(p,b,False)) ps
defp :: SaplTerm Bool -> (SaplPattern, SaplTerm, Bool)
defp d b = (PDefault,d,b)
cp :: SaplPattern SaplTerm Bool -> (SaplPattern, SaplTerm, Bool)
cp p d b = (p,d,b)
unsafe a
# a = addSwitch (termArrayCoder ups "" {s & cs_incaseexpr = True}) a
= case d of
(Just d) = a <++ termCoder (defp d False) s <++ ";"
= a <++ (if s.cs_incaseexpr "break;" "throw \"nomatch\";")
safe a
# a = case patterns of
[(p,body)] = if (isSingleton (fromJust (unpackConsName p)))
(termCoder (cp p body True) s a)
(addSwitch (termCoder (cp p body False) s) a)
= addSwitch (termArrayCoder ups "" s) a
= case d of
(Just d) = a <++ termCoder (defp d False) s <++ ";"
= a
termCoder t=:(SSelect expr patterns) s a
# a = a <++ "switch(" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ "){"
<++ termArrayCoder (map (\(p,b)=(p,b,False)) ps) "" s <++ "};"
= case d of
(Just d) = a <++ termCoder (PDefault,d,False) s <++ ";"
= a <++ (if s.cs_incaseexpr "break;" "throw \"nomatch\";")
where
(ps, d) = splitDefaultPattern patterns
termCoder (SIf pred lhs rhs) s a
// in the predicate of an 'if' there can't be tail recursive call
= a <++ "if(" <++ forceTermCoder pred {s & cs_intrfunc = Nothing} <++ "){"
......@@ -594,14 +655,13 @@ where
*/
termCoder (SLet body defs) s a
# s = pushArgs s defnames
= a <++ "var " <++ letDefCoder newdefs {s & cs_inletdef = Just normalnames} <++ ";\n "
= a <++ "var " <++ letDefCoder newdefs s <++ ";\n "
<++ callWrapper body {s & cs_current_vars = defnames ++ s.cs_current_vars} <++ ";"
where
newdefs = case sortBindings defs of
Just ds = ds
Nothing = abort "Cycle in let definitions is detected" // This is not supported currently
Nothing = abort ("Cycle in let definitions is detected in function "+++toString (fromJust s.cs_inbody)+++"\n") // This is not supported currently
normalnames = map (toNormalVar o unpackBindVar) defs
defnames = map unpackBindVar newdefs
generateJS :: !Flavour !Bool !String -> MaybeErrorString (StringAppender, ParserState)
......@@ -611,9 +671,7 @@ generateJS f tramp saplsrc
Ok (funcs, s) # state = newState f tramp s
# a = newAppender <++ "/*Trampoline: "
# a = if tramp (a <++ "ON") (a <++ "OFF")
// Use per function StringAppender besides the global one.
// This makes the function less recursive, so it works in JS as well.
# a = foldl (\a curr = a <++ toString (funcCoder curr state newAppender)) (a <++ "*/") funcs
# a = foldl (\a curr = a <++ funcCoder curr state) (a <++ "*/") funcs
= Ok (a, s)
Error msg = Error msg
......@@ -624,4 +682,4 @@ exprGenerateJS f tramp saplsrc mbPst
Ok (body, s) # state = newState f tramp (mergeParserStates s mbPst)
# a = termCoder body {state & cs_inbody=Just (NormalVar "__dummy" 0)} newAppender
= Ok a
Error msg = Error msg
Error msg = Error msg
\ No newline at end of file
implementation module Sapl.Transform.Let
import StdList, StdFunc, StdTuple
import StdList, StdFunc, StdTuple, StdBool
import Sapl.SaplStruct
from Data.Set import qualified newSet, fromList, toList, member, difference, insert, filter, delete, null
......@@ -21,7 +21,7 @@ genGraph binds defs = foldl (\s (SaplLetDef bv body) -> gen binds bv s body) ('D
where
gen vs bv s (SApplication f as) = foldl (gen vs bv) s [SVar f:as]
gen vs bv (es,is) (SVar v)
| 'Data.Set'.member v vs = ('Data.Set'.insert (bv, v) es, 'Data.Set'.delete v is)
| 'Data.Set'.member v vs && v <> bv = ('Data.Set'.insert (bv, v) es, 'Data.Set'.delete v is)
gen _ _ s _ = s
// Kahn, Arthur B. (1962), "Topological sorting of large networks"
......
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