f232da4 · elk · git.iko.soy

src/AST/Effects.hs+7−3

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

11{-# OPTIONS_GHC -Wall #-}

22module AST.Effects

33 ( Effects(..), Raw, Canonical

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

4+ , Info(..)

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

56 , PortRaw(..), PortCanonical(..), Kind(..)

67 )

78 where

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

4243 , _init :: R.Region

4344 , _onEffects :: R.Region

4445 , _onSelfMsg :: R.Region

45− , _managerType :: ManagerType

46+ , _managerType :: RawManagerType

4647 }

4748

4849

49−data ManagerType

50+data RawManagerType

5051 = CmdManager (A.Located Text)

5152 | SubManager (A.Located Text)

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

5354

5455

56+data ManagerType = Cmds | Subs | Both

57+

58+

5559

5660-- FOREIGN EFFECTS

5761

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

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

4949 | Update Expr [(Text, Expr)]

5050 | Record [(Text, Expr)]

5151 -- for type checking and code gen only

52− | Cmd ModuleName.Canonical

53− | Sub ModuleName.Canonical

52+ | Cmd ModuleName.Canonical Effects.ManagerType

53+ | Sub ModuleName.Canonical Effects.ManagerType

5454 | OutgoingPort Text Type.Canonical

5555 | IncomingPort Text Type.Canonical

5656 | Program Main Expr

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

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

11{-# OPTIONS_GHC -Wall #-}

22module AST.Expression.Optimized

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

4− , Expr(..)

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

6− ) where

3+ ( Decl(..)

4+ , Def(..)

5+ , Expr(..)

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

7+ )

8+ where

79

10+

11+import qualified Data.Set as Set

812import Data.Text (Text)

913

14+import qualified AST.Effects as Effects

1015import qualified AST.Expression.Canonical as Can

1116import qualified AST.Literal as Literal

1217import qualified AST.Module.Name as ModuleName

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

1722

1823

1924

20−-- DEFINITIONS

21−

22−data Def

23− = Def Facts Text Expr

24− | TailDef Facts Text [Text] Expr

25+-- TOP LEVEL DECLARATIONS

2526

2627

27−data Facts = Facts

28− { home :: Maybe ModuleName.Canonical

28+data Decl =

29+ Decl

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

31+ , _effects :: Maybe Effects.ManagerType

32+ , _body :: !Def

2933 }

3034

3135

32−dummyFacts :: Facts

33−dummyFacts =

34− Facts Nothing

36+

37+-- DEFINITIONS

38+

39+

40+data Def

41+ = Def Expr

42+ | TailDef [Text] Expr

43+

3544

3645

3746-- EXPRESSIONS

3847

48+

3949data Expr

4050 = Literal Literal.Literal

4151 | Var Var.Canonical

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

4555 | Call Expr [Expr]

4656 | TailCall Text [Text] [Expr]

4757 | If [(Expr, Expr)] Expr

48− | Let [Def] Expr

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

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

5060 | Ctor Text [Expr]

5161 | CtorAccess Expr Int

5262 | Access Expr Text

5363 | Update Expr [(Text, Expr)]

5464 | Record [(Text, Expr)]

55− | Cmd ModuleName.Canonical

56− | Sub ModuleName.Canonical

65+ | Cmd ModuleName.Canonical Effects.ManagerType

66+ | Sub ModuleName.Canonical Effects.ManagerType

5767 | OutgoingPort Text Type.Canonical

5868 | IncomingPort Text Type.Canonical

5969 | Program Can.Main Expr

src/AST/Module.hs+10−14

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

126126

127127

128128type Optimized =

129− Module (Info [Optimized.Def])

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

130130

131131

132132

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

205205

206206

207207toInterface :: Optimized -> Interface

208−toInterface modul =

209− let

210− myInfo =

211− info modul

212− in

213− Interface

214− { iExports = exports myInfo

215− , iImports = imports myInfo

216− , iTypes = types myInfo

217− , iUnions = unions myInfo

218− , iAliases = aliases myInfo

219− , iFixities = fixities myInfo

220− }

208+toInterface (Module _ myInfo) =

209+ Interface

210+ { iExports = exports myInfo

211+ , iImports = imports myInfo

212+ , iTypes = types myInfo

213+ , iUnions = unions myInfo

214+ , iAliases = aliases myInfo

215+ , iFixities = fixities myInfo

216+ }

221217

222218

223219privatize :: Interface -> Maybe Interface

src/AST/Variable.hs+11−1

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

11{-# OPTIONS_GHC -Wall #-}

22{-# LANGUAGE OverloadedStrings #-}

33module AST.Variable

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

4+ ( Raw(..)

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

6+ , Global(..)

57 , local, topLevel, builtin, fromModule

68 , inCore, inHtml, cmd, sub

79 , isLocalHome, isCons

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

4951

5052

5153

54+-- GLOBAL NAMES

55+

56+

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

58+ deriving (Eq, Ord)

59+

60+

61+

5262-- HELPERS

5363

5464

src/Canonicalize/Body.hs+8−8

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

137137

138138 Effects.Manager _ info ->

139139 let

140− cmdToDef (A.A region name) =

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

141141 definition

142142 "command"

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

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

144144 region

145145 (Type.cmd moduleName name)

146146

147− subToDef (A.A region name) =

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

148148 definition

149149 "subscription"

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

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

151151 region

152152 (Type.sub moduleName name)

153153 in

154154 case Effects._managerType info of

155155 Effects.CmdManager cmd ->

156− [ cmdToDef cmd

156+ [ cmdToDef cmd Effects.Cmds

157157 ]

158158

159159 Effects.SubManager sub ->

160− [ subToDef sub

160+ [ subToDef sub Effects.Subs

161161 ]

162162

163163 Effects.FxManager cmd sub ->

164− [ cmdToDef cmd

165− , subToDef sub

164+ [ cmdToDef cmd Effects.Both

165+ , subToDef sub Effects.Both

166166 ]

167167

168168

src/Canonicalize/Sort.hs+2−2

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

139139 C.Record

140140 <$> traverse (traverse reorder) fields

141141

142− C.Cmd _ ->

142+ C.Cmd _ _ ->

143143 return expression

144144

145− C.Sub _ ->

145+ C.Sub _ _ ->

146146 return expression

147147

148148 C.OutgoingPort _ _ ->

src/Elm/Compiler.hs+21−8

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

33 ( version

44 , parseDependencies, Tag(..)

55 , compile, Context(..), Result(..)

6+ , generate

67 , Localizer, dummyLocalizer

78 , Error, errorToDoc, errorToJson

89 , Warning, warningToDoc, warningToJson

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

1112

1213import qualified Data.Aeson as Json

1314import qualified Data.Map as Map

15+import qualified Data.Set as Set

1416import Data.Text (Text)

1517import qualified Data.ByteString.Builder as BS

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

1719

20+import qualified AST.Expression.Optimized as Opt

1821import qualified AST.Module as Module

1922import qualified AST.Module.Name as ModuleName

2023import qualified Compile

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

4952-- DEPENDENCIES

5053

5154

52−data Tag

53− = Normal

54− | Effect

55− | Port

55+data Tag = Normal | Effect | Port

5656

5757

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

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

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

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

105105

106− let interface = Module.toInterface modul

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

106+ let iface = Module.toInterface modul

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

108108

109− return (Result docs interface javascript)

109+ return (Result docs iface objs)

110110 in

111111 ( Result.oneToValue dummyLocalizer Localizer oneLocalizer

112112 , Bag.toList Warning warnings

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

127127 Result

128128 { _docs :: Maybe Docs.Documentation

129129 , _iface :: M.Interface

130− , _js :: BS.Builder

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

131131 }

132132

133133

134+

135+-- DOCUMENTATION

136+

137+

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

135139docsGen isExposed (Module.Module name info) =

136140 if not isExposed then

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

145149

146150

147151

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+

148161-- DEALIASER

149162

150163

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

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

11{-# OPTIONS_GHC -Wall #-}

22{-# LANGUAGE OverloadedStrings #-}

33module Elm.Compiler.Module

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

5− , ModuleName.Raw

6− , nameToPath

7− , nameToString, nameFromText

8− , hyphenate, dehyphenate

9− , RawForJson(RawForJson), fromJson

10− , interfaceAliasedTypes, programTypes

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

12− )

4+ -- interfaces

5+ ( Module.Interface

6+ , Module.Interfaces

7+ , Module.privatize

8+ , interfaceAliasedTypes

9+ , programTypes

10+

11+ -- module names

12+ , ModuleName.Raw

13+ , nameToPath

14+ , nameToString

15+ , nameFromText

16+ , hyphenate

17+ , dehyphenate

18+ , RawForJson(..)

19+ , fromJson

20+

21+ -- canonical names

22+ , ModuleName.Canonical(..)

23+ , qualifiedVar

24+

25+ -- variables

26+ , Var.Global(..)

27+ )

1328 where

1429

1530import qualified Data.Aeson as Json

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

2237

2338import qualified AST.Module as Module

2439import qualified AST.Module.Name as ModuleName

40+import qualified AST.Variable as Var

2541import qualified Elm.Compiler.Type as PublicType

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

2743import qualified Generate.JavaScript.Variable as Gen

src/Generate/JavaScript.hs+119−49

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

33module Generate.JavaScript (generate) where

44

55import 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

610import Data.Text (Text)

711import qualified Data.ByteString.Builder as BS

812

913import qualified AST.Effects as Effects

10−import qualified AST.Module as Module

14+import qualified AST.Expression.Optimized as Opt

1115import qualified AST.Module.Name as ModuleName

16+import qualified AST.Variable as Var

1217import qualified Elm.Package as Pkg

1318import qualified Generate.JavaScript.Builder as JS

1419import qualified Generate.JavaScript.Expression as JS

1520import qualified Generate.JavaScript.Helpers as JS

16−import qualified Generate.JavaScript.Variable as Var

21+import qualified Generate.JavaScript.Variable as JS

1722

1823

1924

2025-- GENERATE JAVASCRIPT

2126

2227

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

24−generate (Module.Module moduleName info) =

28+type Graph =

29+ Map.Map Var.Global Opt.Decl

30+

31+

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

33+generate graph roots =

2534 let

26− genBody =

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

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

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

35+ (State builders _ natives effects) =

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

3037

31− body =

32− State.evalState genBody 0

38+ managers =

39+ Map.foldrWithKey addManager "" effects

40+

41+ javascript =

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

3343 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+

3564

3665

66+-- DEAD CODE ELIMINATION

3767

38−-- GENERATE EFFECT MANAGER

3968

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

4073

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

42−generateEffectManager moduleName effects =

43− case effects of

44− Effects.None ->

45− []

74+ else

75+ case Map.lookup name graph of

76+ Just decl ->

77+ crawlDecl graph name decl state

4678

47− Effects.Port _ ->

48− []

79+ Nothing ->

80+ if ModuleName.canonicalIsNative home then

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

82+ else

83+ error "TODO something went wrong"

4984

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

51− let

52− managers =

53− Var.coreNative "Platform" "effectManagers"

5485

55− managerName =

56− JS.String (ModuleName.canonicalToText moduleName)

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

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)

57115

58− entry name =

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

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

61− )

62116

63− managerEntries =

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

65− , entry "init"

66− , entry "onEffects"

67− , entry "onSelfMsg"

68− ]

69117

70− otherEntries =

71− case managerType of

72− Effects.CmdManager _ ->

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

118+-- ADD EFFECT MANAGER

74119

75− Effects.SubManager _ ->

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

77120

78− Effects.FxManager _ _ ->

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

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

122+addManager name manager builder =

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

80124

81− addManager =

82− JS.Assign

83− (JS.LBracket managers managerName)

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

85− in

86− [ JS.ExprStmt 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 $

154+ JS.Assign

155+ (JS.LBracket managers managerName)

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

87157

88158

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

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

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

8686-- DEFINITIONS

8787

8888

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

90−generateDef def =

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

92− case def of

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

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

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

90+generateDef home name def =

91+ do jsBody <-

92+ case def of

93+ Opt.TailDef argNames body ->

94+ generateTailFunction name argNames body

9595

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

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

96+ Opt.Def body ->

97+ generateJsExpr body

9898

9999 return (Var.define home name jsBody)

100100

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

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

164164

165165 Let defs body ->

166− do stmts <- mapM generateDef defs

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

167+ stmts <- mapM genDef defs

167168 code <- generateCode body

168169 jsBlock (concat stmts ++ toStatementList code)

169170

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

192193 do jsDataExpr <- generateJsExpr dataExpr

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

194195

195− Cmd moduleName ->

196+ Cmd moduleName _ ->

196197 jsExpr $ BuiltIn.effect moduleName

197198

198− Sub moduleName ->

199+ Sub moduleName _ ->

199200 jsExpr $ BuiltIn.effect moduleName

200201

201202 OutgoingPort name tipe ->

src/Nitpick/PatternMatches.hs+2−2

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

114114 C.Record fields ->

115115 F.traverse_ (go . snd) fields

116116

117− C.Cmd _ ->

117+ C.Cmd _ _ ->

118118 Result.ok ()

119119

120− C.Sub _ ->

120+ C.Sub _ _ ->

121121 Result.ok ()

122122

123123 C.OutgoingPort _ _ ->

src/Optimize.hs+98−93

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

22{-# LANGUAGE OverloadedStrings #-}

33module Optimize (optimize) where

44

5+import Control.Arrow (second)

56import qualified Control.Monad as M

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

68import 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

811import Data.Text (Text)

912

1013import qualified AST.Expression.Canonical as Can

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

2427-- OPTIMIZE

2528

2629

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

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

2831optimize variantDict home defs =

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

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

3033

3134

3235

33−-- CONVERT DEFINITIONS

36+-- OPTIMIZE DECLS

3437

3538

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

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

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

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

3841 let

39− (args, canBody) =

42+ (rawArgs, rawBody) =

4043 Can.collectLambdas expression

44+ in

45+ case (ptrn, rawArgs) of

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

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

48+ optimizeNamedDef name rawArgs rawBody

4149

42− maybeGetHome =

43− if isRoot then

44− Just <$> Env.getHome

50+ (_, []) ->

51+ let

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

4561

46− else

47− return Nothing

48− in

49− do home <- maybeGetHome

50− optimizeDefHelp home pattern args canBody

62+ _ ->

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

5164

5265

53−optimizeDefHelp

54− :: Maybe ModuleName.Canonical

55− -> P.Canonical

56− -> [P.Canonical]

57− -> Can.Expr

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

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

66+

67+-- OPTIMIZE DEFS

68+

69+

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

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

6072 let

61− facts =

62− Opt.Facts home

73+ (rawArgs, rawBody) =

74+ Can.collectLambdas expression

6375 in

64− case (ptrn, rawArgs) of

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

76+ case (ptrn, rawArgs) of

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

78+ do def <- optimizeNamedDef name rawArgs rawBody

79+ return [def]

6680

67− do htc <- Env.getTailCall

68− Env.setTailCall False

81+ (_, []) ->

82+ do name <- Env.freshName

83+ body <- optimizeExpr Nothing rawBody

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

6985

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

86+ _ ->

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

7188

72− isTailCall <- Env.getTailCall

73− Env.setTailCall htc

7489

75− return $

76− if isTailCall then

77− [ Opt.TailDef facts name args body ]

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

97+ return (name, Opt.Def body)

7898

79− else

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

99+ _ : _ ->

100+ do htc <- Env.getTailCall

101+ Env.setTailCall False

81102

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

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

83104

84− do hasTailCall <- Env.getTailCall

85− body <- optimizeExpr Nothing rawBody

86− Env.setTailCall hasTailCall

87− return [ Opt.Def facts name body ]

105+ isTailCall <- Env.getTailCall

106+ Env.setTailCall htc

88107

89− (_, []) ->

108+ return $ (,) name $

109+ if isTailCall then

110+ Opt.TailDef args body

111+ else

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

90113

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)

95114

96− _ ->

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

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

116+destruct var pattern =

117+ map (second Opt.Def) $

118+ patternToSubstitutions (Opt.Var var) pattern

98119

99120

100121

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

114135

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

116137makeContext argNames name =

117− Just (name, length argNames, argNames)

138+ Just (name, length argNames, argNames)

118139

119140

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

121142depatternArgs (names, rawExpr) ptrn =

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

123− 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)

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

144+ return (name : names, expr)

141145

142146

143147

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

196200 pure (Opt.Literal lit)

197201

198202 Can.Var name ->

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

200− do home <- Env.getHome

201− pure (Opt.Crash home region Nothing)

202−

203− else

204− pure (Opt.Var name)

203+ do Env.register name

204+ if name == debugCrash

205+ then

206+ do home <- Env.getHome

207+ pure (Opt.Crash home region Nothing)

208+ else

209+ pure (Opt.Var name)

205210

206211 Can.List elements ->

207212 Opt.List

208− <$> T.traverse justConvert elements

213+ <$> traverse justConvert elements

209214

210215 Can.Binop op leftExpr rightExpr ->

211216 optimizeBinop context region op leftExpr rightExpr

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

224229 in

225230 case getTailCallInfo context func (length args) of

226231 Just (name, argNames) ->

227− do optArgs <- T.traverse justConvert args

232+ do optArgs <- traverse justConvert args

228233 Env.setTailCall True

229234 return (Opt.TailCall name argNames optArgs)

230235

231236 Nothing ->

232237 do hasTailCall <- Env.getTailCall

233238 optFunc <- justConvert func

234− optArgs <- T.traverse justConvert args

239+ optArgs <- traverse justConvert args

235240 Env.setTailCall hasTailCall

236241 return (Opt.Call optFunc optArgs)

237242

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

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

242247 in

243248 Opt.If

244− <$> T.traverse crawlBranch branches

249+ <$> traverse crawlBranch branches

245250 <*> keepLooking finally

246251

247252 Can.Let defs body ->

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

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

249254 Opt.Let optDefs <$> keepLooking body

250255

251256 Can.Case expr branches ->

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

253258 variantDict <- Env.getVariantDict

254259

255260 name <- Env.freshName

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

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

257262 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

259264

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

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

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

262267

263268 Can.Access record field ->

264269 Opt.Access

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

268273 Can.Update record fields ->

269274 Opt.Update

270275 <$> justConvert record

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

276+ <*> traverse (traverse justConvert) fields

272277

273278 Can.Record fields ->

274279 Opt.Record

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

280+ <$> traverse (traverse justConvert) fields

276281

277− Can.Cmd moduleName ->

278− pure (Opt.Cmd moduleName)

282+ Can.Cmd moduleName manager ->

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

279284

280− Can.Sub moduleName ->

281− pure (Opt.Sub moduleName)

285+ Can.Sub moduleName manager ->

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

282287

283288 Can.OutgoingPort name tipe ->

284289 pure (Opt.OutgoingPort name tipe)

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

296301 pure (Opt.GLShader uid src gltipe)

297302

298303

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

300−mapSnd func (x, a) =

301− (,) x <$> func a

302−

303−

304304

305305-- OPTIMIZE CASE BRANCHES

306306

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

487487 Var.Canonical Var.BuiltIn "::"

488488

489489

490+debugCrash :: Var.Canonical

491+debugCrash =

492+ Var.inCore "Debug" "crash"

493+

494+

490495type Assoc =

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

492497

src/Optimize/Environment.hs+78−14

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

77 , getHome

88 , getTailCall, setTailCall

99 , freshName

10+ , register

11+ , registerEffects

1012 )

1113 where

1214

1315import qualified Control.Monad.State as State

1416import Data.Monoid ((<>))

15−import Data.Text (Text)

17+import qualified Data.Set as Set

1618import qualified Data.Text as Text

19+import Data.Text (Text)

1720

21+import qualified AST.Effects as Effects

22+import qualified AST.Expression.Optimized as Opt

1823import qualified AST.Module.Name as ModuleName

24+import qualified AST.Variable as Var

1925import qualified Optimize.DecisionTree as DT

2026

2127

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

2531

2632data Env =

2733 Env

28− { _hasTailCall :: Bool

29− , _uid :: Int

30− , _variantDict :: DT.VariantDict

31− , _home :: ModuleName.Canonical

34+ { _read_only_variants :: !DT.VariantDict

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

3240 }

3341

3442

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

4048 State.State Env a

4149

4250

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

51+run

52+ :: DT.VariantDict

53+ -> ModuleName.Canonical

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

55+ -> (Text, Opt.Decl)

4456run variantDict home optimizer =

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

57+ let

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

59+ State.runState optimizer $

60+ Env variantDict home 0 Set.empty Nothing False

61+ in

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

4663

4764

4865

49−-- HELPERS

66+-- READ ONLY

5067

5168

5269getVariantDict :: Optimizer DT.VariantDict

5370getVariantDict =

54− State.gets _variantDict

71+ State.gets _read_only_variants

5572

5673

5774getHome :: Optimizer ModuleName.Canonical

5875getHome =

59− State.gets _home

76+ State.gets _read_only_home

77+

78+

79+

80+-- TAIL CALLS

6081

6182

6283getTailCall :: Optimizer Bool

6384getTailCall =

64− State.gets _hasTailCall

85+ State.gets _has_tail_call

6586

6687

6788setTailCall :: Bool -> Optimizer ()

6889setTailCall bool =

6990 do env <- State.get

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

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

92+

93+

94+

95+-- FRESH VARIABLES

7196

7297

7398freshName :: Optimizer Text

7499freshName =

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

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

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

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

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

78103

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 =

3131 inlinedExpr

3232

3333 else

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

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

3535

3636

37−data Subs = Subs

37+data Subs =

38+ Subs

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

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

4041 }

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

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

6263

6364

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−

7465

7566-- COUNT VARIABLE APPEARANCES

7667

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

122113

123114 Let defs expr ->

124115 let

125− countDef def =

116+ countDef (name, def) =

126117 case def of

127− Opt.Def _ name body ->

118+ Opt.Def body ->

128119 Map.delete name (count body)

129120

130− Opt.TailDef _ name argNames body ->

121+ Opt.TailDef argNames body ->

131122 deleteBatch (name:argNames) (count body)

132123

133124 exprCount =

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

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

135126 in

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

137128

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

168159 Record fields ->

169160 countMany (map snd fields)

170161

171− Cmd _ ->

162+ Cmd _ _ ->

172163 Map.empty

173164

174− Sub _ ->

165+ Sub _ _ ->

175166 Map.empty

176167

177168 OutgoingPort _ _ ->

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

229220

230221 Let defs expr ->

231222 let

232− replaceDef def =

223+ replaceDef (name, def) =

233224 case def of

234− Opt.Def facts name body ->

235− Opt.Def facts name

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

225+ Opt.Def body ->

226+ (,) name $ Opt.Def $

227+ replace (Map.delete name substitutions) body

237228

238− Opt.TailDef facts name argNames body ->

239− Opt.TailDef facts name argNames

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

229+ Opt.TailDef argNames body ->

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

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

241232

242233 boundNames =

243− map getDefName defs

234+ map fst defs

244235 in

245236 Let

246237 (map replaceDef defs)

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

279270 Record fields ->

280271 Record (map (second go) fields)

281272

282− Cmd _ ->

273+ Cmd _ _ ->

283274 expression

284275

285− Sub _ ->

276+ Sub _ _ ->

286277 expression

287278

288279 OutgoingPort _ _ ->

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

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

8787addEffectArgs

8888 :: Env.Env

8989 -> ModuleName.Canonical

90− -> Effects.ManagerType

90+ -> Effects.RawManagerType

9191 -> Variable

9292 -> Type

9393 -> Type

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

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

3030 C.Literal lit ->

3131 Literal.constrain env region lit tipe

3232

33− C.Cmd _ ->

33+ C.Cmd _ _ ->

3434 return CTrue

3535

36− C.Sub _ ->

36+ C.Sub _ _ ->

3737 return CTrue

3838

3939 C.OutgoingPort _ _ ->

src/Validate.hs+3−3

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

132132toManagerType

133133 :: R.Region

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

135− -> Result wrn Effects.ManagerType

135+ -> Result wrn Effects.RawManagerType

136136toManagerType tagRegion settingsDict =

137137 let

138138 toErrors name entries =

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

191191

192192checkManager

193193 :: R.Region

194− -> Effects.ManagerType

194+ -> Effects.RawManagerType

195195 -> [A.Commented Src.ValidDef]

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

197197checkManager tagRegion managerType validDefs =

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

219219requireMaps

220220 :: R.Region

221221 -> Map.Map Text R.Region

222− -> Effects.ManagerType

222+ -> Effects.RawManagerType

223223 -> Result wrn ()

224224requireMaps tagRegion regionDict managerType =

225225 let