f232da4 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Do DCE while generating JS.

f232da4Evan Czaplicki10 years ago

src/AST/Effects.hs+7−3

compare with master

unifiedsplit

@@ -1,7 +1,8 @@

1{-# OPTIONS_GHC -Wall #-}

2module AST.Effects

3 ( Effects(..), Raw, Canonical

4+ , Info(..)

4− , Info(..), ManagerType(..)

5+ , RawManagerType(..), ManagerType(..)

5 , PortRaw(..), PortCanonical(..), Kind(..)

6 , PortRaw(..), PortCanonical(..), Kind(..)

6 )

7 )

7 where

8 where

@@ -42,16 +43,19 @@ data Info =

42 , _init :: R.Region

43 , _init :: R.Region

43 , _onEffects :: R.Region

44 , _onEffects :: R.Region

44 , _onSelfMsg :: R.Region

45 , _onSelfMsg :: R.Region

45− , _managerType :: ManagerType

46+ , _managerType :: RawManagerType

46 }

47 }

49−data ManagerType

50+data RawManagerType

50 = CmdManager (A.Located Text)

51 = CmdManager (A.Located Text)

51 | SubManager (A.Located Text)

52 | SubManager (A.Located Text)

52 | FxManager (A.Located Text) (A.Located Text)

53 | FxManager (A.Located Text) (A.Located Text)

56+data ManagerType = Cmds | Subs | Both

57+

58+

56-- FOREIGN EFFECTS

60-- FOREIGN EFFECTS

src/AST/Expression/Canonical.hs+2−2

@@ -49,8 +49,8 @@ data Expr'

49 | Update Expr [(Text, Expr)]

50 | Record [(Text, Expr)]

51 -- for type checking and code gen only

52− | Cmd ModuleName.Canonical

52+ | Cmd ModuleName.Canonical Effects.ManagerType

53− | Sub ModuleName.Canonical

53+ | Sub ModuleName.Canonical Effects.ManagerType

54 | OutgoingPort Text Type.Canonical

55 | IncomingPort Text Type.Canonical

56 | Program Main Expr

src/AST/Expression/Optimized.hs+27−17

@@ -1,12 +1,17 @@

1{-# OPTIONS_GHC -Wall #-}

2module AST.Expression.Optimized

3− ( Def(..), Facts(..), dummyFacts

3+ ( Decl(..)

4+ , Def(..)

4− , Expr(..)

5+ , Expr(..)

5− , Decider(..), Choice(..)

6+ , Decider(..), Choice(..)

7+ )

6− ) where

8+ where

10+

11+import qualified Data.Set as Set

8import Data.Text (Text)

12import Data.Text (Text)

14+import qualified AST.Effects as Effects

10import qualified AST.Expression.Canonical as Can

15import qualified AST.Expression.Canonical as Can

11import qualified AST.Literal as Literal

16import qualified AST.Literal as Literal

12import qualified AST.Module.Name as ModuleName

17import qualified AST.Module.Name as ModuleName

@@ -17,25 +22,30 @@ import qualified Reporting.Region as R

20−-- DEFINITIONS

25+-- TOP LEVEL DECLARATIONS

21−

22−data Def

23− = Def Facts Text Expr

24− | TailDef Facts Text [Text] Expr

27−data Facts = Facts

28+data Decl =

28− { home :: Maybe ModuleName.Canonical

29+ Decl

30+ { _deps :: Set.Set Var.Global

31+ , _effects :: Maybe Effects.ManagerType

32+ , _body :: !Def

29 }

33 }

32−dummyFacts :: Facts

36+

33−dummyFacts =

37+-- DEFINITIONS

34− Facts Nothing

38+

39+

40+data Def

41+ = Def Expr

42+ | TailDef [Text] Expr

43+

37-- EXPRESSIONS

46-- EXPRESSIONS

48+

39data Expr

49data Expr

40 = Literal Literal.Literal

50 = Literal Literal.Literal

41 | Var Var.Canonical

51 | Var Var.Canonical

@@ -45,15 +55,15 @@ data Expr

45 | Call Expr [Expr]

55 | Call Expr [Expr]

46 | TailCall Text [Text] [Expr]

56 | TailCall Text [Text] [Expr]

47 | If [(Expr, Expr)] Expr

57 | If [(Expr, Expr)] Expr

48− | Let [Def] Expr

58+ | Let [(Text, Def)] Expr

49 | Case Text (Decider Choice) [(Int, Expr)]

59 | Case Text (Decider Choice) [(Int, Expr)]

50 | Ctor Text [Expr]

60 | Ctor Text [Expr]

51 | CtorAccess Expr Int

61 | CtorAccess Expr Int

52 | Access Expr Text

62 | Access Expr Text

53 | Update Expr [(Text, Expr)]

63 | Update Expr [(Text, Expr)]

54 | Record [(Text, Expr)]

64 | Record [(Text, Expr)]

55− | Cmd ModuleName.Canonical

65+ | Cmd ModuleName.Canonical Effects.ManagerType

56− | Sub ModuleName.Canonical

66+ | Sub ModuleName.Canonical Effects.ManagerType

57 | OutgoingPort Text Type.Canonical

67 | OutgoingPort Text Type.Canonical

58 | IncomingPort Text Type.Canonical

68 | IncomingPort Text Type.Canonical

59 | Program Can.Main Expr

69 | Program Can.Main Expr

src/AST/Module.hs+10−14

@@ -126,7 +126,7 @@ type Canonical =

126

127

128type Optimized =

129− Module (Info [Optimized.Def])

129+ Module (Info [(Text, Optimized.Decl)])

130

131

132

@@ -205,19 +205,15 @@ data Interface =

205

206

207toInterface :: Optimized -> Interface

208−toInterface modul =

208+toInterface (Module _ myInfo) =

209− let

210− myInfo =

211− info modul

212− in

213− Interface

209+ Interface

214− { iExports = exports myInfo

210+ { iExports = exports myInfo

215− , iImports = imports myInfo

211+ , iImports = imports myInfo

216− , iTypes = types myInfo

212+ , iTypes = types myInfo

217− , iUnions = unions myInfo

213+ , iUnions = unions myInfo

218− , iAliases = aliases myInfo

214+ , iAliases = aliases myInfo

219− , iFixities = fixities myInfo

215+ , iFixities = fixities myInfo

220− }

216+ }

221

217

222

218

223privatize :: Interface -> Maybe Interface

219privatize :: Interface -> Maybe Interface

src/AST/Variable.hs+11−1

@@ -1,7 +1,9 @@

1{-# OPTIONS_GHC -Wall #-}

2{-# LANGUAGE OverloadedStrings #-}

3module AST.Variable

4+ ( Raw(..)

4− ( Raw(..), Canonical(..), Home(..)

5+ , Canonical(..), Home(..)

6+ , Global(..)

5 , local, topLevel, builtin, fromModule

7 , local, topLevel, builtin, fromModule

6 , inCore, inHtml, cmd, sub

8 , inCore, inHtml, cmd, sub

7 , isLocalHome, isCons

9 , isLocalHome, isCons

@@ -49,6 +51,14 @@ data Canonical =

54+-- GLOBAL NAMES

55+

56+

57+data Global = Global !ModuleName.Canonical !Text

58+ deriving (Eq, Ord)

59+

60+

61+

52-- HELPERS

62-- HELPERS

src/Canonicalize/Body.hs+8−8

@@ -137,32 +137,32 @@ effectsToDefs moduleName effects =

137

138 Effects.Manager _ info ->

139 let

140− cmdToDef (A.A region name) =

140+ cmdToDef (A.A region name) managerType =

141 definition

142 "command"

143− (A.A region (C.Cmd moduleName))

143+ (A.A region (C.Cmd moduleName managerType))

144 region

145 (Type.cmd moduleName name)

146

147− subToDef (A.A region name) =

147+ subToDef (A.A region name) managerType =

148 definition

149 "subscription"

150− (A.A region (C.Sub moduleName))

150+ (A.A region (C.Sub moduleName managerType))

151 region

152 (Type.sub moduleName name)

153 in

154 case Effects._managerType info of

155 Effects.CmdManager cmd ->

156− [ cmdToDef cmd

156+ [ cmdToDef cmd Effects.Cmds

157 ]

158

159 Effects.SubManager sub ->

160− [ subToDef sub

160+ [ subToDef sub Effects.Subs

161 ]

162

163 Effects.FxManager cmd sub ->

164− [ cmdToDef cmd

164+ [ cmdToDef cmd Effects.Both

165− , subToDef sub

165+ , subToDef sub Effects.Both

166 ]

167

168

src/Canonicalize/Sort.hs+2−2

@@ -139,10 +139,10 @@ reorder (A.A region expression) =

139 C.Record

140 <$> traverse (traverse reorder) fields

141

142− C.Cmd _ ->

142+ C.Cmd _ _ ->

143 return expression

144

145− C.Sub _ ->

145+ C.Sub _ _ ->

146 return expression

147

148 C.OutgoingPort _ _ ->

src/Elm/Compiler.hs+21−8

@@ -3,6 +3,7 @@ module Elm.Compiler

3 ( version

4 , parseDependencies, Tag(..)

5 , compile, Context(..), Result(..)

6+ , generate

6 , Localizer, dummyLocalizer

7 , Localizer, dummyLocalizer

7 , Error, errorToDoc, errorToJson

8 , Error, errorToDoc, errorToJson

8 , Warning, warningToDoc, warningToJson

9 , Warning, warningToDoc, warningToJson

@@ -11,10 +12,12 @@ module Elm.Compiler

12import qualified Data.Aeson as Json

13import qualified Data.Aeson as Json

13import qualified Data.Map as Map

14import qualified Data.Map as Map

15+import qualified Data.Set as Set

14import Data.Text (Text)

16import Data.Text (Text)

15import qualified Data.ByteString.Builder as BS

17import qualified Data.ByteString.Builder as BS

16import Text.PrettyPrint.ANSI.Leijen (Doc)

18import Text.PrettyPrint.ANSI.Leijen (Doc)

20+import qualified AST.Expression.Optimized as Opt

18import qualified AST.Module as Module

21import qualified AST.Module as Module

19import qualified AST.Module.Name as ModuleName

22import qualified AST.Module.Name as ModuleName

20import qualified Compile

23import qualified Compile

@@ -49,10 +52,7 @@ version =

49-- DEPENDENCIES

52-- DEPENDENCIES

52−data Tag

55+data Tag = Normal | Effect | Port

53− = Normal

54− | Effect

55− | Port

58parseDependencies :: Package.Name -> Text -> Either Error (Tag, Maybe M.Raw, [M.Raw])

@@ -103,10 +103,10 @@ compile context source =

103 do modul <- Compile.compile packageName importDict interfaces source

104 docs <- Result.format id (docsGen exposed modul)

105

106− let interface = Module.toInterface modul

106+ let iface = Module.toInterface modul

107− let javascript = {-# SCC elm_compiler_generate #-} JS.generate modul

107+ let objs = Module.program (Module.info modul)

108

109− return (Result docs interface javascript)

109+ return (Result docs iface objs)

110 in

111 ( Result.oneToValue dummyLocalizer Localizer oneLocalizer

112 , Bag.toList Warning warnings

@@ -127,10 +127,14 @@ data Result =

127 Result

128 { _docs :: Maybe Docs.Documentation

129 , _iface :: M.Interface

130− , _js :: BS.Builder

130+ , _objs :: [(Text, Opt.Decl)]

131 }

132

133

134+

135+-- DOCUMENTATION

136+

137+

134docsGen :: Bool -> Module.Optimized -> Result.Result () w Error.Error (Maybe Docs.Documentation)

138docsGen :: Bool -> Module.Optimized -> Result.Result () w Error.Error (Maybe Docs.Documentation)

135docsGen isExposed (Module.Module name info) =

139docsGen isExposed (Module.Module name info) =

136 if not isExposed then

140 if not isExposed then

@@ -145,6 +149,15 @@ docsGen isExposed (Module.Module name info) =

145

149

146

150

147

151

152+-- CODE GENERATION

153+

154+

155+generate :: Map.Map M.Global Opt.Decl -> [M.Global] -> (Set.Set M.Canonical, BS.Builder)

156+generate =

157+ JS.generate

158+

159+

160+

148-- DEALIASER

161-- DEALIASER

149

162

150

163

src/Elm/Compiler/Module.hs+25−9

@@ -1,15 +1,30 @@

1{-# OPTIONS_GHC -Wall #-}

2{-# LANGUAGE OverloadedStrings #-}

3module Elm.Compiler.Module

4+ -- interfaces

5+ ( Module.Interface

4− ( Module.Interface, Module.Interfaces, Module.privatize

6+ , Module.Interfaces

7+ , Module.privatize

8+ , interfaceAliasedTypes

9+ , programTypes

10+

11+ -- module names

5− , ModuleName.Raw

12+ , ModuleName.Raw

6− , nameToPath

13+ , nameToPath

7− , nameToString, nameFromText

14+ , nameToString

15+ , nameFromText

16+ , hyphenate

8− , hyphenate, dehyphenate

17+ , dehyphenate

9− , RawForJson(RawForJson), fromJson

18+ , RawForJson(..)

10− , interfaceAliasedTypes, programTypes

19+ , fromJson

20+

21+ -- canonical names

11− , ModuleName.Canonical(..), qualifiedVar

22+ , ModuleName.Canonical(..)

23+ , qualifiedVar

24+

25+ -- variables

26+ , Var.Global(..)

12− )

27+ )

13 where

28 where

15import qualified Data.Aeson as Json

30import qualified Data.Aeson as Json

@@ -22,6 +37,7 @@ import System.FilePath ((</>))

23import qualified AST.Module as Module

38import qualified AST.Module as Module

24import qualified AST.Module.Name as ModuleName

39import qualified AST.Module.Name as ModuleName

40+import qualified AST.Variable as Var

25import qualified Elm.Compiler.Type as PublicType

41import qualified Elm.Compiler.Type as PublicType

26import qualified Elm.Compiler.Type.Extract as Extract

42import qualified Elm.Compiler.Type.Extract as Extract

27import qualified Generate.JavaScript.Variable as Gen

43import qualified Generate.JavaScript.Variable as Gen

src/Generate/JavaScript.hs+119−49

@@ -3,87 +3,157 @@

3module Generate.JavaScript (generate) where

5import qualified Control.Monad.State as State

6+import Data.Monoid ((<>))

7+import qualified Data.List as List

8+import qualified Data.Map as Map

9+import qualified Data.Set as Set

6import Data.Text (Text)

10import Data.Text (Text)

7import qualified Data.ByteString.Builder as BS

11import qualified Data.ByteString.Builder as BS

9import qualified AST.Effects as Effects

13import qualified AST.Effects as Effects

10−import qualified AST.Module as Module

14+import qualified AST.Expression.Optimized as Opt

11import qualified AST.Module.Name as ModuleName

15import qualified AST.Module.Name as ModuleName

16+import qualified AST.Variable as Var

12import qualified Elm.Package as Pkg

17import qualified Elm.Package as Pkg

13import qualified Generate.JavaScript.Builder as JS

18import qualified Generate.JavaScript.Builder as JS

14import qualified Generate.JavaScript.Expression as JS

19import qualified Generate.JavaScript.Expression as JS

15import qualified Generate.JavaScript.Helpers as JS

20import qualified Generate.JavaScript.Helpers as JS

16−import qualified Generate.JavaScript.Variable as Var

21+import qualified Generate.JavaScript.Variable as JS

20-- GENERATE JAVASCRIPT

25-- GENERATE JAVASCRIPT

23−generate :: Module.Optimized -> BS.Builder

28+type Graph =

24−generate (Module.Module moduleName info) =

29+ Map.Map Var.Global Opt.Decl

30+

31+

32+generate :: Graph -> [Var.Global] -> (Set.Set ModuleName.Canonical, BS.Builder)

33+generate graph roots =

25 let

34 let

26− genBody =

35+ (State builders _ natives effects) =

27− do defsList <- mapM JS.generateDef (Module.program info)

36+ List.foldl' (crawl graph) empty roots

28− let managerStmts = generateEffectManager moduleName (Module.effects info)

29− return (concat (defsList ++ [managerStmts]))

31− body =

38+ managers =

32− State.evalState genBody 0

39+ Map.foldrWithKey addManager "" effects

40+

41+ javascript =

42+ List.foldl' (\rest js -> js <> rest) managers builders

33 in

43 in

34− JS.encodeUtf8 body

44+ (natives, javascript)

45+

46+

47+

48+-- DEAD CODE ELIMINATION

49+

50+

51+data State =

52+ State

53+ { _js :: [BS.Builder]

54+ , _seen :: Set.Set Var.Global

55+ , _natives :: Set.Set ModuleName.Canonical

56+ , _effects :: Map.Map ModuleName.Canonical Effects.ManagerType

57+ }

58+

59+

60+empty :: State

61+empty =

62+ State [] Set.empty Set.empty Map.empty

63+

66+-- DEAD CODE ELIMINATION

38−-- GENERATE EFFECT MANAGER

69+crawl :: Graph -> State -> Var.Global -> State

70+crawl graph state@(State js seen natives effects) name@(Var.Global home _) =

71+ if Set.member name seen then

72+ state

41−generateEffectManager :: ModuleName.Canonical -> Effects.Canonical -> [JS.Stmt]

74+ else

42−generateEffectManager moduleName effects =

75+ case Map.lookup name graph of

43− case effects of

76+ Just decl ->

44− Effects.None ->

77+ crawlDecl graph name decl state

45− []

47− Effects.Port _ ->

79+ Nothing ->

48− []

80+ if ModuleName.canonicalIsNative home then

81+ State js seen (Set.insert home natives) effects

82+ else

83+ error "TODO something went wrong"

50− Effects.Manager pkgName (Effects.Info _ _ _ _ managerType) ->

51− let

52− managers =

53− Var.coreNative "Platform" "effectManagers"

55− managerName =

86+crawlDecl :: Graph -> Var.Global -> Opt.Decl -> State -> State

56− JS.String (ModuleName.canonicalToText moduleName)

87+crawlDecl graph name@(Var.Global home _) (Opt.Decl deps mfx body) state =

88+ let

89+ newState =

90+ state { _seen = Set.insert name (_seen state) }

91+

92+ (State js seen natives effects) =

93+ Set.foldl' (crawl graph) newState deps

94+

95+ newEffects =

96+ case mfx of

97+ Nothing -> effects

98+ Just fx -> Map.insert home fx effects

99+ in

100+ State

101+ { _js = generateDecl name body : js

102+ , _seen = seen

103+ , _natives = natives

104+ , _effects = newEffects

105+ }

106+

107+

108+generateDecl :: Var.Global -> Opt.Def -> BS.Builder

109+generateDecl (Var.Global home name) def =

110+ let

111+ genBody =

112+ JS.generateDef (Just home) name def

113+ in

114+ JS.encodeUtf8 (State.evalState genBody 0)

115

58− entry name =

59− ( JS.IdProp (JS.Id name)

60− , JS.ref (Var.qualified moduleName name)

61− )

116

63− managerEntries =

64− [ "pkg" ==> Pkg.toText pkgName

65− , entry "init"

66− , entry "onEffects"

67− , entry "onSelfMsg"

68− ]

117

70− otherEntries =

118+-- ADD EFFECT MANAGER

71− case managerType of

72− Effects.CmdManager _ ->

73− [ "tag" ==> "cmd", entry "cmdMap" ]

119

75− Effects.SubManager _ ->

76− [ "tag" ==> "sub", entry "subMap" ]

120

78− Effects.FxManager _ _ ->

121+addManager :: ModuleName.Canonical -> Effects.ManagerType -> BS.Builder -> BS.Builder

79− [ "tag" ==> "fx", entry "cmdMap", entry "subMap" ]

122+addManager name manager builder =

123+ JS.encodeUtf8 [genManager name manager] <> builder

124

81− addManager =

125+

126+genManager :: ModuleName.Canonical -> Effects.ManagerType -> JS.Stmt

127+genManager moduleName@(ModuleName.Canonical pkg _) manager =

128+ let

129+ managers =

130+ JS.coreNative "Platform" "effectManagers"

131+

132+ managerName =

133+ JS.String (ModuleName.canonicalToText moduleName)

134+

135+ entry name =

136+ ( JS.IdProp (JS.Id name)

137+ , JS.ref (JS.qualified moduleName name)

138+ )

139+

140+ managerEntries =

141+ [ "pkg" ==> Pkg.toText pkg

142+ , entry "init"

143+ , entry "onEffects"

144+ , entry "onSelfMsg"

145+ ]

146+

147+ otherEntries =

148+ case manager of

149+ Effects.Cmds -> [ "tag" ==> "cmd", entry "cmdMap" ]

150+ Effects.Subs -> [ "tag" ==> "sub", entry "subMap" ]

151+ Effects.Both -> [ "tag" ==> "fx", entry "cmdMap", entry "subMap" ]

152+ in

153+ JS.ExprStmt $

82− JS.Assign

154+ JS.Assign

83− (JS.LBracket managers managerName)

155+ (JS.LBracket managers managerName)

84− (JS.Object (managerEntries ++ otherEntries))

156+ (JS.Object (managerEntries ++ otherEntries))

85− in

86− [ JS.ExprStmt addManager ]

157

158

89(==>) :: Text -> Text -> ( JS.Prop, JS.Expr )

159(==>) :: Text -> Text -> ( JS.Prop, JS.Expr )

src/Generate/JavaScript/Expression.hs+12−11

@@ -86,15 +86,15 @@ toExpr code =

86-- DEFINITIONS

89−generateDef :: Opt.Def -> State Int [JS.Stmt]

89+generateDef :: Maybe ModuleName.Canonical -> Text -> Opt.Def -> State Int [JS.Stmt]

90−generateDef def =

90+generateDef home name def =

91− do (home, name, jsBody) <-

91+ do jsBody <-

92− case def of

92+ case def of

93− Opt.TailDef (Opt.Facts home) name argNames body ->

93+ Opt.TailDef argNames body ->

94− (,,) home name <$> generateTailFunction name argNames body

94+ generateTailFunction name argNames body

96− Opt.Def (Opt.Facts home) name body ->

96+ Opt.Def body ->

97− (,,) home name <$> generateJsExpr body

97+ generateJsExpr body

99 return (Var.define home name jsBody)

100

@@ -163,7 +163,8 @@ generateCode expr =

163 ++ [JS.Continue (Just (JS.Id (Var.safe name)))]

164

165 Let defs body ->

166+ do let genDef (name, def) = generateDef Nothing name def

166− do stmts <- mapM generateDef defs

167+ stmts <- mapM genDef defs

167 code <- generateCode body

168 code <- generateCode body

168 jsBlock (concat stmts ++ toStatementList code)

169 jsBlock (concat stmts ++ toStatementList code)

169

170

@@ -192,10 +193,10 @@ generateCode expr =

192 do jsDataExpr <- generateJsExpr dataExpr

193 do jsDataExpr <- generateJsExpr dataExpr

193 jsExpr $ JS.DotRef jsDataExpr (JS.Id ("_" <> Text.pack (show index)))

194 jsExpr $ JS.DotRef jsDataExpr (JS.Id ("_" <> Text.pack (show index)))

194

195

195− Cmd moduleName ->

196+ Cmd moduleName _ ->

196 jsExpr $ BuiltIn.effect moduleName

197 jsExpr $ BuiltIn.effect moduleName

197

198

198− Sub moduleName ->

199+ Sub moduleName _ ->

199 jsExpr $ BuiltIn.effect moduleName

200 jsExpr $ BuiltIn.effect moduleName

200

201

201 OutgoingPort name tipe ->

202 OutgoingPort name tipe ->

src/Nitpick/PatternMatches.hs+2−2

@@ -114,10 +114,10 @@ checkExpression arityDict (A.A region expression) =

114 C.Record fields ->

115 F.traverse_ (go . snd) fields

116

117− C.Cmd _ ->

117+ C.Cmd _ _ ->

118 Result.ok ()

119

120− C.Sub _ ->

120+ C.Sub _ _ ->

121 Result.ok ()

122

123 C.OutgoingPort _ _ ->

src/Optimize.hs+98−93

@@ -2,9 +2,12 @@

2{-# LANGUAGE OverloadedStrings #-}

3module Optimize (optimize) where

5+import Control.Arrow (second)

5import qualified Control.Monad as M

6import qualified Control.Monad as M

7+import Data.Monoid ((<>))

6import qualified Data.Map as Map

8import qualified Data.Map as Map

7−import qualified Data.Traversable as T

9+import qualified Data.Set as Set

10+import qualified Data.Text as Text

8import Data.Text (Text)

11import Data.Text (Text)

10import qualified AST.Expression.Canonical as Can

13import qualified AST.Expression.Canonical as Can

@@ -24,77 +27,95 @@ import qualified Reporting.Region as R

24-- OPTIMIZE

27-- OPTIMIZE

27−optimize :: DT.VariantDict -> ModuleName.Canonical -> [Can.Def] -> [Opt.Def]

30+optimize :: DT.VariantDict -> ModuleName.Canonical -> [Can.Def] -> [(Text, Opt.Decl)]

28optimize variantDict home defs =

31optimize variantDict home defs =

29− Env.run variantDict home (concat <$> mapM (optimizeDef True) defs)

32+ concat $ zipWith (optimizeDecl variantDict home) [1 .. length defs] defs

33−-- CONVERT DEFINITIONS

36+-- OPTIMIZE DECLS

36−optimizeDef :: Bool -> Can.Def -> Env.Optimizer [Opt.Def]

39+optimizeDecl :: DT.VariantDict -> ModuleName.Canonical -> Int -> Can.Def -> [(Text, Opt.Decl)]

37−optimizeDef isRoot (Can.Def _ pattern expression _) =

40+optimizeDecl variantDict home index (Can.Def _ pattern@(A.A _ ptrn) expression _) =

38 let

41 let

39− (args, canBody) =

42+ (rawArgs, rawBody) =

40 Can.collectLambdas expression

43 Can.collectLambdas expression

44+ in

45+ case (ptrn, rawArgs) of

46+ (P.Var name, _) ->

47+ (:[]) $ Env.run variantDict home $

48+ optimizeNamedDef name rawArgs rawBody

42− maybeGetHome =

50+ (_, []) ->

43− if isRoot then

51+ let

44− Just <$> Env.getHome

52+ name = "_" <> Text.pack (show index)

53+ deps = Set.singleton (Var.Global home name)

54+ decl =

55+ Env.run variantDict home $

56+ ((,) name . Opt.Def) <$> optimizeExpr Nothing rawBody

57+ destructors =

58+ destruct (Var.topLevel home name) pattern

59+ in

60+ decl : map (second (Opt.Decl deps Nothing)) destructors

46− else

62+ _ ->

47− return Nothing

63+ error "bug manifesting in Optimize.optimizeDecl, please report"

48− in

49− do home <- maybeGetHome

50− optimizeDefHelp home pattern args canBody

53−optimizeDefHelp

66+

54− :: Maybe ModuleName.Canonical

67+-- OPTIMIZE DEFS

55− -> P.Canonical

68+

56− -> [P.Canonical]

69+

57− -> Can.Expr

58− -> Env.Optimizer [Opt.Def]

70+optimizeLetDef :: Can.Def -> Env.Optimizer [(Text, Opt.Def)]

59−optimizeDefHelp home pattern@(A.A _ ptrn) rawArgs rawBody =

71+optimizeLetDef (Can.Def _ pattern@(A.A _ ptrn) expression _) =

60 let

72 let

61− facts =

73+ (rawArgs, rawBody) =

62− Opt.Facts home

74+ Can.collectLambdas expression

63 in

75 in

64− case (ptrn, rawArgs) of

76+ case (ptrn, rawArgs) of

65− (P.Var name, _ : _) ->

77+ (P.Var name, _) ->

78+ do def <- optimizeNamedDef name rawArgs rawBody

79+ return [def]

67− do htc <- Env.getTailCall

81+ (_, []) ->

68− Env.setTailCall False

82+ do name <- Env.freshName

83+ body <- optimizeExpr Nothing rawBody

84+ return $ (name, Opt.Def body) : destruct (Var.local name) pattern

70− (args, body) <- optimizeFunction (Just name) rawArgs rawBody

86+ _ ->

87+ error "bug manifesting in Optimize.optimizeLetDef, please report"

72− isTailCall <- Env.getTailCall

73− Env.setTailCall htc

90+optimizeNamedDef :: Text -> [P.Canonical] -> Can.Expr -> Env.Optimizer (Text, Opt.Def)

91+optimizeNamedDef name rawArgs rawBody =

92+ case rawArgs of

93+ [] ->

94+ do hasTailCall <- Env.getTailCall

95+ body <- optimizeExpr Nothing rawBody

96+ Env.setTailCall hasTailCall

75− return $

97+ return (name, Opt.Def body)

76− if isTailCall then

77− [ Opt.TailDef facts name args body ]

79− else

99+ _ : _ ->

80− [ Opt.Def facts name (Opt.Function args body) ]

100+ do htc <- Env.getTailCall

101+ Env.setTailCall False

102

82− (P.Var name, []) ->

103+ (args, body) <- optimizeFunction (Just name) rawArgs rawBody

104

84− do hasTailCall <- Env.getTailCall

105+ isTailCall <- Env.getTailCall

85− body <- optimizeExpr Nothing rawBody

86− Env.setTailCall hasTailCall

106+ Env.setTailCall htc

87− return [ Opt.Def facts name body ]

107

89− (_, []) ->

108+ return $ (,) name $

109+ if isTailCall then

110+ Opt.TailDef args body

111+ else

112+ Opt.Def (Opt.Function args body)

113

91− do name <- Env.freshName

92− optBody <- optimizeExpr Nothing rawBody

93− let optDef = Opt.Def facts name optBody

94− return (optDef : patternToDefs home name pattern)

114

96− _ ->

115+destruct :: Var.Canonical -> P.Canonical -> [(Text, Opt.Def)]

97− error "there should never be a function where the name is not a P.Var"

116+destruct var pattern =

117+ map (second Opt.Def) $

118+ patternToSubstitutions (Opt.Var var) pattern

119

120

100

121

@@ -114,30 +135,13 @@ optimizeFunction maybeName patterns givenBody =

114

135

115makeContext :: [Text] -> Text -> Context

136makeContext :: [Text] -> Text -> Context

116makeContext argNames name =

137makeContext argNames name =

117− Just (name, length argNames, argNames)

138+ Just (name, length argNames, argNames)

118

139

119

140

120depatternArgs :: ([Text], Can.Expr) -> P.Canonical -> Env.Optimizer ([Text], Can.Expr)

141depatternArgs :: ([Text], Can.Expr) -> P.Canonical -> Env.Optimizer ([Text], Can.Expr)

121depatternArgs (names, rawExpr) ptrn =

142depatternArgs (names, rawExpr) ptrn =

122− do (name, expr) <- depattern ptrn rawExpr

143+ do (name, expr) <- depattern ptrn rawExpr

123− return (name : names, expr)

144+ return (name : names, expr)

124−

125−

126−patternToDefs :: Maybe ModuleName.Canonical -> Text -> P.Canonical -> [Opt.Def]

127−patternToDefs home rootName pattern =

128− let

129− rootExpr =

130− case home of

131− Nothing ->

132− Opt.Var (Var.local rootName)

133−

134− Just moduleName ->

135− Opt.Var (Var.topLevel moduleName rootName)

136−

137− toDef (name, accessExpr) =

138− Opt.Def (Opt.Facts home) name accessExpr

139− in

140− map toDef (patternToSubstitutions rootExpr pattern)

141

145

142

146

143

147

@@ -196,16 +200,17 @@ optimizeExpr context annExpr@(A.A region expression) =

196 pure (Opt.Literal lit)

200 pure (Opt.Literal lit)

197

201

198 Can.Var name ->

202 Can.Var name ->

199− if name == Var.inCore "Debug" "crash" then

203+ do Env.register name

204+ if name == debugCrash

205+ then

200− do home <- Env.getHome

206+ do home <- Env.getHome

201− pure (Opt.Crash home region Nothing)

207+ pure (Opt.Crash home region Nothing)

202−

203− else

208+ else

204− pure (Opt.Var name)

209+ pure (Opt.Var name)

205

210

206 Can.List elements ->

211 Can.List elements ->

207 Opt.List

212 Opt.List

208− <$> T.traverse justConvert elements

213+ <$> traverse justConvert elements

209

214

210 Can.Binop op leftExpr rightExpr ->

215 Can.Binop op leftExpr rightExpr ->

211 optimizeBinop context region op leftExpr rightExpr

216 optimizeBinop context region op leftExpr rightExpr

@@ -224,14 +229,14 @@ optimizeExpr context annExpr@(A.A region expression) =

224 in

229 in

225 case getTailCallInfo context func (length args) of

230 case getTailCallInfo context func (length args) of

226 Just (name, argNames) ->

231 Just (name, argNames) ->

227− do optArgs <- T.traverse justConvert args

232+ do optArgs <- traverse justConvert args

228 Env.setTailCall True

233 Env.setTailCall True

229 return (Opt.TailCall name argNames optArgs)

234 return (Opt.TailCall name argNames optArgs)

230

235

231 Nothing ->

236 Nothing ->

232 do hasTailCall <- Env.getTailCall

237 do hasTailCall <- Env.getTailCall

233 optFunc <- justConvert func

238 optFunc <- justConvert func

234− optArgs <- T.traverse justConvert args

239+ optArgs <- traverse justConvert args

235 Env.setTailCall hasTailCall

240 Env.setTailCall hasTailCall

236 return (Opt.Call optFunc optArgs)

241 return (Opt.Call optFunc optArgs)

237

242

@@ -241,11 +246,11 @@ optimizeExpr context annExpr@(A.A region expression) =

241 (,) <$> justConvert cond <*> keepLooking branch

246 (,) <$> justConvert cond <*> keepLooking branch

242 in

247 in

243 Opt.If

248 Opt.If

244− <$> T.traverse crawlBranch branches

249+ <$> traverse crawlBranch branches

245 <*> keepLooking finally

250 <*> keepLooking finally

246

251

247 Can.Let defs body ->

252 Can.Let defs body ->

248− do optDefs <- concat <$> T.traverse (optimizeDef False) defs

253+ do optDefs <- concat <$> traverse optimizeLetDef defs

249 Opt.Let optDefs <$> keepLooking body

254 Opt.Let optDefs <$> keepLooking body

250

255

251 Can.Case expr branches ->

256 Can.Case expr branches ->

@@ -253,12 +258,12 @@ optimizeExpr context annExpr@(A.A region expression) =

253 variantDict <- Env.getVariantDict

258 variantDict <- Env.getVariantDict

254

259

255 name <- Env.freshName

260 name <- Env.freshName

256− optBranches <- T.traverse (optimizeBranch context region name) branches

261+ optBranches <- traverse (optimizeBranch context region name) branches

257 let optCase = Case.optimize variantDict name optBranches

262 let optCase = Case.optimize variantDict name optBranches

258− return $ Opt.Let [ Opt.Def Opt.dummyFacts name optExpr ] optCase

263+ return $ Opt.Let [ (name, Opt.Def optExpr) ] optCase

259

264

260 Can.Ctor (Var.Canonical _ name) exprs ->

265 Can.Ctor (Var.Canonical _ name) exprs ->

261− Opt.Ctor name <$> T.traverse justConvert exprs

266+ Opt.Ctor name <$> traverse justConvert exprs

262

267

263 Can.Access record field ->

268 Can.Access record field ->

264 Opt.Access

269 Opt.Access

@@ -268,17 +273,17 @@ optimizeExpr context annExpr@(A.A region expression) =

268 Can.Update record fields ->

273 Can.Update record fields ->

269 Opt.Update

274 Opt.Update

270 <$> justConvert record

275 <$> justConvert record

271− <*> T.traverse (mapSnd justConvert) fields

276+ <*> traverse (traverse justConvert) fields

272

277

273 Can.Record fields ->

278 Can.Record fields ->

274 Opt.Record

279 Opt.Record

275− <$> T.traverse (mapSnd justConvert) fields

280+ <$> traverse (traverse justConvert) fields

276

281

277− Can.Cmd moduleName ->

282+ Can.Cmd moduleName manager ->

278− pure (Opt.Cmd moduleName)

283+ Opt.Cmd moduleName <$> Env.registerEffects manager

279

284

280− Can.Sub moduleName ->

285+ Can.Sub moduleName manager ->

281− pure (Opt.Sub moduleName)

286+ Opt.Sub moduleName <$> Env.registerEffects manager

282

287

283 Can.OutgoingPort name tipe ->

288 Can.OutgoingPort name tipe ->

284 pure (Opt.OutgoingPort name tipe)

289 pure (Opt.OutgoingPort name tipe)

@@ -296,11 +301,6 @@ optimizeExpr context annExpr@(A.A region expression) =

296 pure (Opt.GLShader uid src gltipe)

301 pure (Opt.GLShader uid src gltipe)

297

302

298

303

299−mapSnd :: M.Functor box => (a -> box b) -> (x, a) -> box (x, b)

300−mapSnd func (x, a) =

301− (,) x <$> func a

302−

303−

304

305-- OPTIMIZE CASE BRANCHES

306

@@ -487,6 +487,11 @@ cons =

487 Var.Canonical Var.BuiltIn "::"

488

489

490+debugCrash :: Var.Canonical

491+debugCrash =

492+ Var.inCore "Debug" "crash"

493+

494+

490type Assoc =

495type Assoc =

491 Can.Expr -> Can.Expr -> (Can.Expr, Can.Expr)

496 Can.Expr -> Can.Expr -> (Can.Expr, Can.Expr)

492

497

src/Optimize/Environment.hs+78−14

@@ -7,15 +7,21 @@ module Optimize.Environment

7 , getHome

8 , getTailCall, setTailCall

9 , freshName

10+ , register

11+ , registerEffects

10 )

12 )

11 where

13 where

13import qualified Control.Monad.State as State

15import qualified Control.Monad.State as State

14import Data.Monoid ((<>))

16import Data.Monoid ((<>))

15−import Data.Text (Text)

17+import qualified Data.Set as Set

16import qualified Data.Text as Text

18import qualified Data.Text as Text

19+import Data.Text (Text)

21+import qualified AST.Effects as Effects

22+import qualified AST.Expression.Optimized as Opt

18import qualified AST.Module.Name as ModuleName

23import qualified AST.Module.Name as ModuleName

24+import qualified AST.Variable as Var

19import qualified Optimize.DecisionTree as DT

25import qualified Optimize.DecisionTree as DT

@@ -25,10 +31,12 @@ import qualified Optimize.DecisionTree as DT

26data Env =

32data Env =

27 Env

33 Env

28− { _hasTailCall :: Bool

29− , _uid :: Int

30− , _variantDict :: DT.VariantDict

34+ { _read_only_variants :: !DT.VariantDict

31− , _home :: ModuleName.Canonical

35+ , _read_only_home :: !ModuleName.Canonical

36+ , _uid :: !Int

37+ , _deps :: Set.Set Var.Global

38+ , _effects :: Maybe Effects.ManagerType

39+ , _has_tail_call :: !Bool

32 }

40 }

@@ -40,39 +48,95 @@ type Optimizer a =

40 State.State Env a

48 State.State Env a

51+run

52+ :: DT.VariantDict

43−run :: DT.VariantDict -> ModuleName.Canonical -> Optimizer a -> a

53+ -> ModuleName.Canonical

54+ -> Optimizer (Text, Opt.Def)

55+ -> (Text, Opt.Decl)

44run variantDict home optimizer =

56run variantDict home optimizer =

57+ let

58+ ((name, def), Env _ _ _ deps fx _) =

59+ State.runState optimizer $

45− State.evalState optimizer (Env False 0 variantDict home)

60+ Env variantDict home 0 Set.empty Nothing False

61+ in

62+ ( name, Opt.Decl deps fx def )

49−-- HELPERS

66+-- READ ONLY

52getVariantDict :: Optimizer DT.VariantDict

69getVariantDict :: Optimizer DT.VariantDict

53getVariantDict =

70getVariantDict =

54− State.gets _variantDict

71+ State.gets _read_only_variants

57getHome :: Optimizer ModuleName.Canonical

74getHome :: Optimizer ModuleName.Canonical

58getHome =

75getHome =

59− State.gets _home

76+ State.gets _read_only_home

77+

78+

79+

80+-- TAIL CALLS

62getTailCall :: Optimizer Bool

83getTailCall :: Optimizer Bool

63getTailCall =

84getTailCall =

64− State.gets _hasTailCall

85+ State.gets _has_tail_call

67setTailCall :: Bool -> Optimizer ()

88setTailCall :: Bool -> Optimizer ()

68setTailCall bool =

89setTailCall bool =

69 do env <- State.get

90 do env <- State.get

70− State.put (env { _hasTailCall = bool })

91+ State.put (env { _has_tail_call = bool })

92+

93+

94+

95+-- FRESH VARIABLES

73freshName :: Optimizer Text

98freshName :: Optimizer Text

74freshName =

99freshName =

75− do (Env htc uid vd home) <- State.get

100+ do (Env vs home uid deps fx htc) <- State.get

76− State.put (Env htc (uid + 1) vd home)

101+ State.put (Env vs home (uid + 1) deps fx htc)

77 return ("_p" <> Text.pack (show uid))

102 return ("_p" <> Text.pack (show uid))

103

104+

105+

106+-- REGISTER DEPENDENCIES

107+

108+

109+register :: Var.Canonical -> Optimizer ()

110+register (Var.Canonical home name) =

111+ case home of

112+ Var.BuiltIn ->

113+ return ()

114+

115+ Var.Module realHome ->

116+ State.modify (registerHelp (Var.Global realHome name))

117+

118+ Var.TopLevel realHome ->

119+ State.modify (registerHelp (Var.Global realHome name))

120+

121+ Var.Local ->

122+ return ()

123+

124+

125+registerHelp :: Var.Global -> Env -> Env

126+registerHelp dep (Env vs home uid deps fx htc) =

127+ Env vs home uid (Set.insert dep deps) fx htc

128+

129+

130+

131+-- REGISTER EFFECTS

132+

133+

134+registerEffects :: Effects.ManagerType -> Optimizer Effects.ManagerType

135+registerEffects manager =

136+ do State.modify (registerEffectsHelp manager)

137+ return manager

138+

139+

140+registerEffectsHelp :: Effects.ManagerType -> Env -> Env

141+registerEffectsHelp manager (Env vs home uid deps _ htc) =

142+ Env vs home uid deps (Just manager) htc

src/Optimize/Inline.hs+19−28

@@ -31,10 +31,11 @@ inline rawSubs expression =

31 inlinedExpr

33 else

34− Let (map (\(name, expr) -> Opt.Def Opt.dummyFacts name expr) defs) inlinedExpr

34+ Let (map (second Opt.Def) defs) inlinedExpr

37−data Subs = Subs

37+data Subs =

38+ Subs

38 { _substitutions :: Map.Map Text Opt.Expr

39 { _substitutions :: Map.Map Text Opt.Expr

39 , _definitions :: [(Text, Opt.Expr)]

40 , _definitions :: [(Text, Opt.Expr)]

40 }

41 }

@@ -61,16 +62,6 @@ deleteBatch names dict =

61 List.foldl' (flip Map.delete) dict names

62 List.foldl' (flip Map.delete) dict names

64−getDefName :: Opt.Def -> Text

65−getDefName def =

66− case def of

67− Opt.Def _ name _ ->

68− name

69−

70− Opt.TailDef _ name _ _ ->

71− name

72−

73−

75-- COUNT VARIABLE APPEARANCES

66-- COUNT VARIABLE APPEARANCES

@@ -122,16 +113,16 @@ count expression =

122

113

123 Let defs expr ->

114 Let defs expr ->

124 let

115 let

125− countDef def =

116+ countDef (name, def) =

126 case def of

117 case def of

127− Opt.Def _ name body ->

118+ Opt.Def body ->

128 Map.delete name (count body)

119 Map.delete name (count body)

129

120

130− Opt.TailDef _ name argNames body ->

121+ Opt.TailDef argNames body ->

131 deleteBatch (name:argNames) (count body)

122 deleteBatch (name:argNames) (count body)

132

123

133 exprCount =

124 exprCount =

134− deleteBatch (map getDefName defs) (count expr)

125+ deleteBatch (map fst defs) (count expr)

135 in

126 in

136 Map.unionsWith (+) (exprCount : map countDef defs)

127 Map.unionsWith (+) (exprCount : map countDef defs)

137

128

@@ -168,10 +159,10 @@ count expression =

168 Record fields ->

159 Record fields ->

169 countMany (map snd fields)

160 countMany (map snd fields)

170

161

171− Cmd _ ->

162+ Cmd _ _ ->

172 Map.empty

163 Map.empty

173

164

174− Sub _ ->

165+ Sub _ _ ->

175 Map.empty

166 Map.empty

176

167

177 OutgoingPort _ _ ->

168 OutgoingPort _ _ ->

@@ -229,18 +220,18 @@ replace substitutions expression =

229

220

230 Let defs expr ->

221 Let defs expr ->

231 let

222 let

232− replaceDef def =

223+ replaceDef (name, def) =

233 case def of

224 case def of

234− Opt.Def facts name body ->

225+ Opt.Def body ->

235− Opt.Def facts name

226+ (,) name $ Opt.Def $

236− (replace (Map.delete name substitutions) body)

227+ replace (Map.delete name substitutions) body

237

228

238− Opt.TailDef facts name argNames body ->

229+ Opt.TailDef argNames body ->

239− Opt.TailDef facts name argNames

230+ (,) name $ Opt.TailDef argNames $

240− (replace (deleteBatch (name:argNames) substitutions) body)

231+ replace (deleteBatch (name:argNames) substitutions) body

241

232

242 boundNames =

233 boundNames =

243− map getDefName defs

234+ map fst defs

244 in

235 in

245 Let

236 Let

246 (map replaceDef defs)

237 (map replaceDef defs)

@@ -279,10 +270,10 @@ replace substitutions expression =

279 Record fields ->

270 Record fields ->

280 Record (map (second go) fields)

271 Record (map (second go) fields)

281

272

282− Cmd _ ->

273+ Cmd _ _ ->

283 expression

274 expression

284

275

285− Sub _ ->

276+ Sub _ _ ->

286 expression

277 expression

287

278

288 OutgoingPort _ _ ->

279 OutgoingPort _ _ ->

src/Type/Constrain/Effects.hs+1−1

@@ -87,7 +87,7 @@ constrainHelp env moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =

87addEffectArgs

88 :: Env.Env

89 -> ModuleName.Canonical

90− -> Effects.ManagerType

90+ -> Effects.RawManagerType

91 -> Variable

92 -> Type

93 -> Type

src/Type/Constrain/Expression.hs+2−2

@@ -30,10 +30,10 @@ constrain env annotatedExpr@(A.A region expression) tipe =

30 C.Literal lit ->

31 Literal.constrain env region lit tipe

33− C.Cmd _ ->

33+ C.Cmd _ _ ->

34 return CTrue

36− C.Sub _ ->

36+ C.Sub _ _ ->

37 return CTrue

39 C.OutgoingPort _ _ ->

src/Validate.hs+3−3

@@ -132,7 +132,7 @@ noPorts ports =

132toManagerType

133 :: R.Region

134 -> Map.Map Text [(R.Region, A.Located Text)]

135− -> Result wrn Effects.ManagerType

135+ -> Result wrn Effects.RawManagerType

136toManagerType tagRegion settingsDict =

137 let

138 toErrors name entries =

@@ -191,7 +191,7 @@ extractOne name settingsDict =

191

192checkManager

193 :: R.Region

194− -> Effects.ManagerType

194+ -> Effects.RawManagerType

195 -> [A.Commented Src.ValidDef]

196 -> Result wrn (R.Region, R.Region, R.Region)

197checkManager tagRegion managerType validDefs =

@@ -219,7 +219,7 @@ getSimpleDefRegion decl =

219requireMaps

220 :: R.Region

221 -> Map.Map Text R.Region

222− -> Effects.ManagerType

222+ -> Effects.RawManagerType

223 -> Result wrn ()

224requireMaps tagRegion regionDict managerType =

225 let