6ec2d6b · elk · git.iko.soy

14import qualified AST.Pattern as P

15import qualified AST.Variable as V

16

17+

17ctors :: P.CanonicalPattern -> [String]

18ctors :: P.CanonicalPattern -> [String]

18ctors pattern =

19ctors pattern =

19 case pattern of

20 case pattern of

30 where

31 where

31 rest = concatMap ctors ps

32 rest = concatMap ctors ps

32

33

34+

33free :: String -> State (Set.Set String) ()

35free :: String -> State (Set.Set String) ()

36+free x =

34−free x = modify (Set.insert x)

37+ modify (Set.insert x)

38+

35

39

36freeIfLocal :: V.Canonical -> State (Set.Set String) ()

40freeIfLocal :: V.Canonical -> State (Set.Set String) ()

37freeIfLocal (V.Canonical home name) =

41freeIfLocal (V.Canonical home name) =

38− do case home of

42+ case home of

39− V.Local -> free name

43+ V.Local -> free name

40− V.BuiltIn -> return ()

44+ V.BuiltIn -> return ()

41− V.Module _ -> return ()

45+ V.Module _ -> return ()

46+

42

47

43bound :: Set.Set String -> State (Set.Set String) ()

48bound :: Set.Set String -> State (Set.Set String) ()

49+bound boundVars =

44−bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

50+ modify (\freeVars -> Set.difference freeVars boundVars)

51+

45

52

46sortDefs :: Canonical.Expr -> Canonical.Expr

53sortDefs :: Canonical.Expr -> Canonical.Expr

54+sortDefs expr =

47−sortDefs expr = evalState (reorder expr) Set.empty

55+ evalState (reorder expr) Set.empty

56+

48

57

49reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr

58reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr

50reorder (A ann expr) =

59reorder (A ann expr) =

51 A ann <$>

60 A ann <$>

52 case expr of

61 case expr of

53 -- Be careful adding and restricting freeVars

62 -- Be careful adding and restricting freeVars

63+ Var var ->

54− Var var -> freeIfLocal var >> return expr

64+ freeIfLocal var >> return expr

55

65

56 Lambda p e ->

66 Lambda p e ->

57 uncurry Lambda <$> bindingReorder (p,e)

67 uncurry Lambda <$> bindingReorder (p,e)

58

68

59 Binop op e1 e2 ->

69 Binop op e1 e2 ->

60− do freeIfLocal op

70+ do freeIfLocal op

61− Binop op <$> reorder e1 <*> reorder e2

71+ Binop op <$> reorder e1 <*> reorder e2

62

72

63 Case e cases ->

73 Case e cases ->

64 Case <$> reorder e <*> mapM bindingReorder cases

74 Case <$> reorder e <*> mapM bindingReorder cases

65

75

66 Data name es ->

76 Data name es ->

67− do free name

77+ do free name

68− Data name <$> mapM reorder es

78+ Data name <$> mapM reorder es

69

79

70 -- Just pipe the reorder though

80 -- Just pipe the reorder though

81+ Literal _ ->

71− Literal _ -> return expr

82+ return expr

72

83

73 Range e1 e2 ->

84 Range e1 e2 ->

74 Range <$> reorder e1 <*> reorder e2

85 Range <$> reorder e1 <*> reorder e2

97 Record fields ->

108 Record fields ->

98 Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields

109 Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields

99

110

100− GLShader _ _ _ -> return expr

111+ GLShader _ _ _ ->

112+ return expr

101

113

114+ PortOut name st signal ->

102− PortOut name st signal -> PortOut name st <$> reorder signal

115+ PortOut name st <$> reorder signal

103

116

117+ PortIn name st ->

104− PortIn name st -> return $ PortIn name st

118+ return $ PortIn name st

105

119

106 -- Actually do some reordering

120 -- Actually do some reordering

107 Let defs body ->

121 Let defs body ->

108− do body' <- reorder body

122+ do body' <- reorder body

109−

123+

110− -- Sort defs into strongly connected components.This

124+ -- Sort defs into strongly connected components.This

111− -- allows the programmer to write definitions in whatever

125+ -- allows the programmer to write definitions in whatever

112− -- order they please, we can still define things in order

126+ -- order they please, we can still define things in order

113− -- and generalize polymorphic functions when appropriate.

127+ -- and generalize polymorphic functions when appropriate.

114− sccs <- Graph.stronglyConnComp <$> buildDefDict defs

128+ sccs <- Graph.stronglyConnComp <$> buildDefDict defs

115− let defss = map Graph.flattenSCC sccs

129+ let defss = map Graph.flattenSCC sccs

116−

130+

117− -- remove let-bound variables from the context

131+ -- remove let-bound variables from the context

118− forM_ defs $ \(Canonical.Definition pattern _ _) -> do

132+ forM_ defs $ \(Canonical.Definition pattern _ _) -> do

119− bound (P.boundVars pattern)

133+ bound (P.boundVars pattern)

120− mapM free (ctors pattern)

134+ mapM free (ctors pattern)

121−

135+

136+ let A _ let' =

122− let A _ let' = foldr (\ds bod -> A ann (Let ds bod)) body' defss

137+ foldr (\ds bod -> A ann (Let ds bod)) body' defss

123−

138+

124− return let'

139+ return let'

125−

140+

141+

142+bindingReorder

126−bindingReorder :: (P.CanonicalPattern, Canonical.Expr)

143+ :: (P.CanonicalPattern, Canonical.Expr)

127− -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)

144+ -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)

128bindingReorder (pattern,expr) =

145bindingReorder (pattern,expr) =

129− do expr' <- reorder expr

146+ do expr' <- reorder expr

130− bound (P.boundVars pattern)

147+ bound (P.boundVars pattern)

131− mapM_ free (ctors pattern)

148+ mapM_ free (ctors pattern)

132− return (pattern, expr')

149+ return (pattern, expr')

133

150

134

151

152+reorderAndGetDependencies

153+ :: Canonical.Def

135−reorderAndGetDependencies :: Canonical.Def -> State (Set.Set String) (Canonical.Def, [String])

154+ -> State (Set.Set String) (Canonical.Def, [String])

136reorderAndGetDependencies (Canonical.Definition pattern expr mType) =

155reorderAndGetDependencies (Canonical.Definition pattern expr mType) =

137− do globalFrees <- get

156+ do globalFrees <- get

138− -- work in a fresh environment

157+ -- work in a fresh environment

139− put Set.empty

158+ put Set.empty

140− expr' <- reorder expr

159+ expr' <- reorder expr

141− localFrees <- get

160+ localFrees <- get

142− -- merge with global frees

161+ -- merge with global frees

143− modify (Set.union globalFrees)

162+ modify (Set.union globalFrees)

144− return (Canonical.Definition pattern expr' mType, Set.toList localFrees)

163+ return (Canonical.Definition pattern expr' mType, Set.toList localFrees)

145

164

146

165

147-- This also reorders the all of the sub-expressions in the Def list.

166-- This also reorders the all of the sub-expressions in the Def list.

167+buildDefDict

168+ :: [Canonical.Def]

148−buildDefDict :: [Canonical.Def] -> State (Set.Set String) [(Canonical.Def, Int, [Int])]

169+ -> State (Set.Set String) [(Canonical.Def, Int, [Int])]

149buildDefDict defs =

170buildDefDict defs =

150− do pdefsDeps <- mapM reorderAndGetDependencies defs

171+ do pdefsDeps <- mapM reorderAndGetDependencies defs

151− return $ realDeps (addKey pdefsDeps)

172+ return $ realDeps (addKey pdefsDeps)

152−

153 where

173 where

154 addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]

174 addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]

175+ addKey =

155− addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

176+ zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

156

177

157 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]

178 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]

158 variableToKey (Canonical.Definition pattern _ _, key, _) =

179 variableToKey (Canonical.Definition pattern _ _, key, _) =

163 Map.fromList (concatMap variableToKey pdefsDeps)

184 Map.fromList (concatMap variableToKey pdefsDeps)

164

185

165 realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]

186 realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]

187+ realDeps pdefsDeps =

166− realDeps pdefsDeps = map convert pdefsDeps

188+ map convert pdefsDeps

167− where

189+ where

168− varDict = variableToKeyMap pdefsDeps

190+ varDict = variableToKeyMap pdefsDeps

169− convert (pdef, key, deps) =

191+ convert (pdef, key, deps) =

170− (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)

192+ (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)