Commit f5f90c61 authored by László Domoszlai's avatar László Domoszlai

topological sort on let definitions to ensure their correct order. cycle is not allowed.

git-svn-id: https://svn.cs.ru.nl/repos/clean-sapl/branches/hierarchical@393 cb785ff4-4565-4a15-8565-04c4fcf96d79
parent 4a0f9045
......@@ -32,8 +32,13 @@ import Data.Maybe
| PLit Literal
| PDefault
instance == SaplVar
instance < SaplVar
instance toString SaplVar
// I don't provide instances of (==) and (<) here because multiple good way can be imagined...
eqVarByName :: !SaplVar !SaplVar -> Bool
ltVarByName :: !SaplVar !SaplVar -> Bool
eqVarByNameLevel :: !SaplVar !SaplVar -> Bool
ltVarByNameLevel :: !SaplVar !SaplVar -> Bool
eqStrictVar :: !String !SaplVar -> Bool
isStrictVar :: !SaplVar -> Bool
......
......@@ -3,17 +3,27 @@ implementation module Sapl.SaplStruct
import StdEnv
import Data.Map, Data.Void, Data.Error
instance == SaplVar
where
(==) (NormalVar name1 _) (NormalVar name2 _) = name1 == name2
(==) (StrictVar name1 _) (StrictVar name2 _) = name1 == name2
(==) _ _ = False
ltVarByName :: !SaplVar !SaplVar -> Bool
ltVarByName a b = unpackVar a < unpackVar b
eqVarByName :: !SaplVar !SaplVar -> Bool
eqVarByName a b = unpackVar a == unpackVar b
eqVarByNameLevel :: !SaplVar !SaplVar -> Bool
eqVarByNameLevel a b = unpackVar a == unpackVar b && unpackLevel a == unpackLevel b
ltVarByNameLevel :: !SaplVar !SaplVar -> Bool
ltVarByNameLevel a b = unpackVar a < unpackVar b || (unpackVar a == unpackVar b && unpackLevel a < unpackLevel b)
unpackLevel (NormalVar _ level) = level
unpackLevel (StrictVar _ level) = level
instance < SaplVar
instance toString SaplVar
where
(<) (NormalVar name1 _) (NormalVar name2 _) = name1 < name2
(<) (StrictVar name1 _) (StrictVar name2 _) = name1 < name2
(<) _ _ = False
toString (NormalVar name 0) = name
toString (NormalVar name level) = name +++ "_" +++ toString level
toString (StrictVar name 0) = "!" +++ name
toString (StrictVar name level) = "!" +++ name +++ "_" +++ toString level
isStrictVar :: !SaplVar -> Bool
isStrictVar (StrictVar _ _) = True
......
......@@ -22,6 +22,9 @@ implementation module Sapl.Target.JS.CodeGeneratorJS
import StdEnv, Data.Maybe, Data.Void, Text.StringAppender, Data.Map, Sapl.FastString
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
......@@ -388,7 +391,7 @@ where
= a <++ escapeName s.cs_prefix name <++ "$eval"
// else
| isJust s.cs_inletdef && isMember t (fromJust s.cs_inletdef)
| isJust s.cs_inletdef && elem_by eqVarByName t (fromJust s.cs_inletdef) // isMember 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...
......@@ -405,7 +408,7 @@ where
findLocalVar [(NormalVar cn level):cs] = if (cn == name) level (findLocalVar cs)
findLocalVar [(StrictVar cn level):cs] = if (cn == name) level (findLocalVar cs)
findLocalVar [] = 0
isLocalVar = isMember t s.cs_current_vars
isLocalVar = elem_by eqVarByName t s.cs_current_vars //isMember t s.cs_current_vars
isFunction = isJust (get t s.cs_functions)
isStrictFunction = a || b
......@@ -437,28 +440,6 @@ where
getVar (SaplLetDef var _) = var
letDefCoder [] _ a = a
deStrictIfNeeded [] [] = []
deStrictIfNeeded [d=:(SaplLetDef var body):ds] [_:vs]
| isDependent vs body
= [SaplLetDef (toNormalVar var) body:deStrictIfNeeded ds vs]
= [d:deStrictIfNeeded ds vs]
/*
* Determine wheter a given term is dependent on some of the variables given in the first argument.
* Used at let definition. For example:
*
* let !a = ...b..., b = ... in ...
*
* "a" cannot be brought to head normal form in place because it depends on "b"
*
* TODO: should be extended for non-application terms?
*/
isDependent :: ![SaplVar] !SaplTerm -> Bool
isDependent vs (SApplication f as) = any (isDependent vs) [SVar f:as]
isDependent vs (SVar v) = isMember v vs
isDependent _ _ = False
instance TermCoder SaplLetDef
where
......@@ -627,7 +608,10 @@ where
= a <++ "var " <++ letDefCoder newdefs {s & cs_inletdef = Just normalnames} <++ ";\n "
<++ callWrapper body {s & cs_current_vars = defnames ++ s.cs_current_vars} <++ ";"
where
newdefs = deStrictIfNeeded defs normalnames
newdefs = case sortBindings defs of
Just ds = ds
Nothing = abort "Cycle in let definitions is detected" // This is not supported currently
normalnames = map (toNormalVar o unpackBindVar) defs
defnames = map unpackBindVar newdefs
......
definition module Sapl.Transform.Let
import Data.Maybe
from Sapl.SaplStruct import :: SaplVar, :: SaplLetDef
// Topological sort of the let definitions. Return Nothing if a cycle is detected
sortBindings :: ![SaplLetDef] -> Maybe [SaplLetDef]
implementation module Sapl.Transform.Let
import StdList, StdFunc, StdTuple
import Sapl.SaplStruct
from Data.Set import qualified newSet, fromList, toList, member, difference, insert, filter, delete, null
from Data.Set import :: Set
from Data.Map import qualified fromList, get
instance == SaplVar
where
(==) a b = eqVarByNameLevel a b
instance < SaplVar
where
(<) a b = ltVarByNameLevel a b
// Generate the graph: edges and the start nodes (independent nodes)
genGraph :: !(Set SaplVar) ![SaplLetDef] -> (!Set (SaplVar,SaplVar), !Set SaplVar)
genGraph binds defs = foldl (\s (SaplLetDef bv body) -> gen binds bv s body) ('Data.Set'.newSet,binds) defs
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)
gen _ _ s _ = s
// Kahn, Arthur B. (1962), "Topological sorting of large networks"
sortBindings :: ![SaplLetDef] -> Maybe [SaplLetDef]
sortBindings [d] = Just [d]
sortBindings defs
# (redges,rordbinds) = gen edges ('Data.Set'.toList startnodes)
| 'Data.Set'.null redges
= Just (map (\k -> fromJust ('Data.Map'.get k defmap)) (reverse rordbinds))
= Nothing // cycle is detected
where
(edges, startnodes) = genGraph binds defs
binds = 'Data.Set'.fromList (map (toNormalVar o unpackBindVar) defs)
defmap = 'Data.Map'.fromList (map (\d=:(SaplLetDef bv body) -> (bv,d)) defs)
// Returns the renaming edges (if any) and the ordered list of bind vars (reversed order)
gen edges [] = (edges, [])
gen edges [n:ns] = let (redges,rout) = gen nedges (nns++ns) in (redges,[n:rout])
where
(nedges, nns) = foldl peredge (edges,[]) outedges
outedges = filter (\e = fst e == n) ('Data.Set'.toList edges)
peredge (edges,out) e=:(n,m)
# edges = 'Data.Set'.delete e edges
| 'Data.Set'.null ('Data.Set'.filter (\e = snd e == m) edges)
= (edges, [m:out])
= (edges, out)
\ No newline at end of file
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