30261e2 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Distinguish between local and global variables in optimized AST

30261e2Evan Czaplicki10 years ago

src/AST/Expression/Optimized.hs+3−2

compare with master

unifiedsplit

@@ -48,9 +48,10 @@ data Def

49data Expr

50 = Literal Literal.Literal

51− | Var Var.Canonical

51+ | VarLocal Text

52+ | VarGlobal ModuleName.Canonical Text

52 | List [Expr]

53 | List [Expr]

53− | Binop Var.Canonical Expr Expr

54+ | Binop ModuleName.Canonical Text Expr Expr

54 | Function [Text] Expr

55 | Function [Text] Expr

55 | Call Expr [Expr]

56 | Call Expr [Expr]

56 | TailCall Text [Text] [Expr]

57 | TailCall Text [Text] [Expr]

src/Generate/JavaScript.hs+1−1

@@ -109,7 +109,7 @@ generateDecl :: Var.Global -> Opt.Def -> BS.Builder

109generateDecl (Var.Global home name) def =

110 let

111 genBody =

112− JS.generateDef (Just home) name def

112+ JS.generateDecl home name def

113 in

114 JS.encodeUtf8 (State.evalState genBody 0)

115

src/Generate/JavaScript/Expression.hs+107−127

@@ -1,5 +1,8 @@

1{-# LANGUAGE OverloadedStrings #-}

2−module Generate.JavaScript.Expression (generateDef) where

2+module Generate.JavaScript.Expression

3+ ( generateDecl

4+ )

5+ where

4import Control.Arrow (second)

7import Control.Arrow (second)

5import Control.Monad.State (State, foldM)

8import Control.Monad.State (State, foldM)

@@ -13,7 +16,7 @@ import qualified AST.Expression.Canonical as Can

13import AST.Expression.Optimized as Opt

16import AST.Expression.Optimized as Opt

14import qualified AST.Literal as L

17import qualified AST.Literal as L

15import qualified AST.Module.Name as ModuleName

18import qualified AST.Module.Name as ModuleName

16−import qualified AST.Variable as Var

19+import qualified AST.Variable as V

17import Generate.JavaScript.Helpers as Help

20import Generate.JavaScript.Helpers as Help

18import qualified Generate.JavaScript.Builder as JS

21import qualified Generate.JavaScript.Builder as JS

19import qualified Generate.JavaScript.BuiltIn as BuiltIn

22import qualified Generate.JavaScript.BuiltIn as BuiltIn

@@ -24,6 +27,15 @@ import qualified Optimize.DecisionTree as DT

30+-- GENERATE DECLARATION

31+

32+

33+generateDecl :: ModuleName.Canonical -> Text -> Opt.Def -> State Int [JS.Stmt]

34+generateDecl home name def =

35+ Var.defineGlobal home name <$> generateDef name def

36+

37+

38+

27-- CODE CHUNKS

39-- CODE CHUNKS

@@ -83,23 +95,6 @@ toExpr code =

86−-- DEFINITIONS

87−

88−

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

95−

96− Opt.Def body ->

97− generateJsExpr body

98−

99− return (Var.define home name jsBody)

100−

101−

102−

103-- EXPRESSIONS

98-- EXPRESSIONS

104

105

100

@@ -111,8 +106,11 @@ generateJsExpr optExpr =

111generateCode :: Opt.Expr -> State Int Code

106generateCode :: Opt.Expr -> State Int Code

112generateCode expr =

107generateCode expr =

113 case expr of

108 case expr of

114− Var var ->

109+ VarLocal name ->

110+ jsExpr $ Var.local name

111+

112+ VarGlobal home name ->

115− jsExpr $ Var.canonical var

113+ jsExpr $ Var.global home name

116

114

117 Literal lit ->

115 Literal lit ->

118 jsExpr (Literal.literal lit)

116 jsExpr (Literal.literal lit)

@@ -140,8 +138,8 @@ generateCode expr =

140 do jsFields <- mapM toField fields

138 do jsFields <- mapM toField fields

141 jsExpr $ JS.Object jsFields

139 jsExpr $ JS.Object jsFields

142

140

143− Binop op leftExpr rightExpr ->

141+ Binop home op leftExpr rightExpr ->

144− binop op leftExpr rightExpr

142+ generateBinop home op leftExpr rightExpr

145

143

146 Function args body ->

144 Function args body ->

147 generateFunction args body

145 generateFunction args body

@@ -163,10 +161,9 @@ generateCode expr =

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

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

164

162

165 Let defs body ->

163 Let defs body ->

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

167− stmts <- mapM genDef defs

164+ do stmts <- mapM generateLetDef defs

168 code <- generateCode body

165 code <- generateCode body

169− jsBlock (concat stmts ++ toStatementList code)

166+ jsBlock (stmts ++ toStatementList code)

170

167

171 If branches finally ->

168 If branches finally ->

172 generateIf branches finally

169 generateIf branches finally

@@ -239,13 +236,23 @@ generateProgram kind body =

239

236

240

237

241

238

242−-- FUNCTIONS

239+-- DEFINITIONS

243

240

244

241

245−generateFunction :: [Text] -> Opt.Expr -> State Int Code

242+generateLetDef :: (Text, Opt.Def) -> State Int JS.Stmt

246−generateFunction args body =

243+generateLetDef (name, def) =

247− do code <- generateCode body

244+ do jsBody <- generateDef name def

248− jsExpr (generateFunctionWithArity args code)

245+ return $ JS.VarDeclStmt [ Help.varDecl name jsBody ]

246+

247+

248+generateDef :: Text -> Opt.Def -> State Int JS.Expr

249+generateDef name def =

250+ case def of

251+ Opt.TailDef argNames body ->

252+ generateTailFunction name argNames body

253+

254+ Opt.Def body ->

255+ generateJsExpr body

249

256

250

257

251generateTailFunction :: Text -> [Text] -> Opt.Expr -> State Int JS.Expr

258generateTailFunction :: Text -> [Text] -> Opt.Expr -> State Int JS.Expr

@@ -257,6 +264,16 @@ generateTailFunction name args body =

257 (JS.While (JS.Bool True) (toStatement code))

264 (JS.While (JS.Bool True) (toStatement code))

258

265

259

266

267+

268+-- FUNCTIONS

269+

270+

271+generateFunction :: [Text] -> Opt.Expr -> State Int Code

272+generateFunction args body =

273+ do code <- generateCode body

274+ jsExpr (generateFunctionWithArity args code)

275+

276+

260generateFunctionWithArity :: [Text] -> Code -> JS.Expr

277generateFunctionWithArity :: [Text] -> Code -> JS.Expr

261generateFunctionWithArity rawArgs code =

278generateFunctionWithArity rawArgs code =

262 let

279 let

@@ -283,27 +300,47 @@ generateFunctionWithArity rawArgs code =

283generateCall :: Opt.Expr -> [Opt.Expr] -> State Int Code

300generateCall :: Opt.Expr -> [Opt.Expr] -> State Int Code

284generateCall func args =

301generateCall func args =

285 case (func, args) of

302 case (func, args) of

286− (Opt.Var var, [arg]) ->

303+ (Opt.VarGlobal home name, [arg]) ->

287− case getUnaryOp var of

304+ case name of

288− Just op ->

305+ "complement" | home == bitwise -> genPrefix JS.PrefixBNot arg

289− do jsArg <- generateJsExpr arg

306+ "not" | home == basics -> genPrefix JS.PrefixLNot arg

290− jsExpr $ JS.Prefix op jsArg

307+ _ -> generateCallHelp func args

308+

309+ (Opt.VarGlobal home name, [ left, right ]) | home == bitwise ->

310+ case name of

311+ "and" -> genInfix JS.OpBAnd left right

312+ "or" -> genInfix JS.OpBOr left right

313+ "xor" -> genInfix JS.OpBXor left right

314+ "shiftLeftBy" -> genInfix JS.OpLShift right left

315+ "shiftRightBy" -> genInfix JS.OpSpRShift right left

316+ "shiftRightZfBy" -> genInfix JS.OpZfRShift right left

317+ _ -> generateCallHelp func args

291

318

292− Nothing ->

319+ _ ->

293− generateCallHelp func args

320+ generateCallHelp func args

294

321

295− (Opt.Var var, [ arg1, arg2 ]) ->

296− case getBinaryOp var arg1 arg2 of

297− Just (op, left, right) ->

298− do jsLeft <- generateJsExpr left

299− jsRight <- generateJsExpr right

300− jsExpr $ JS.Infix op jsLeft jsRight

301

322

302− Nothing ->

323+genPrefix :: JS.PrefixOp -> Opt.Expr -> State Int Code

303− generateCallHelp func args

324+genPrefix op arg =

325+ do jsArg <- generateJsExpr arg

326+ jsExpr (JS.Prefix op jsArg)

304

327

305− _ ->

328+

306− generateCallHelp func args

329+genInfix :: JS.InfixOp -> Opt.Expr -> Opt.Expr -> State Int Code

330+genInfix op left right =

331+ do jsLeft <- generateJsExpr left

332+ jsRight <- generateJsExpr right

333+ jsExpr $ JS.Infix op jsLeft jsRight

334+

335+

336+basics :: ModuleName.Canonical

337+basics =

338+ ModuleName.inCore "Basics"

339+

340+

341+bitwise :: ModuleName.Canonical

342+bitwise =

343+ ModuleName.inCore "Bitwise"

307

344

308

345

309generateCallHelp :: Opt.Expr -> [Opt.Expr] -> State Int Code

346generateCallHelp :: Opt.Expr -> [Opt.Expr] -> State Int Code

@@ -321,49 +358,6 @@ generateCallHelp func args =

321 foldl1 (<|) (jsFunc:jsArgs)

358 foldl1 (<|) (jsFunc:jsArgs)

322

359

323

360

324−getUnaryOp :: Var.Canonical -> Maybe JS.PrefixOp

325−getUnaryOp var =

326− if var == bitwiseComplement then

327− Just JS.PrefixBNot

328−

329− else if var == basicsNot then

330− Just JS.PrefixLNot

331−

332− else

333− Nothing

334−

335−

336−getBinaryOp :: Var.Canonical -> Opt.Expr -> Opt.Expr -> Maybe (JS.InfixOp, Opt.Expr, Opt.Expr)

337−getBinaryOp (Var.Canonical home name) left right =

338− if home /= bitwise then

339− Nothing

340−

341− else

342− case name of

343− "and" -> Just ( JS.OpBAnd, left, right )

344− "or" -> Just ( JS.OpBOr, left, right )

345− "xor" -> Just ( JS.OpBXor, left, right )

346− "shiftLeftBy" -> Just ( JS.OpLShift, right, left )

347− "shiftRightBy" -> Just ( JS.OpSpRShift, right, left )

348− "shiftRightZfBy" -> Just ( JS.OpZfRShift, right, left )

349− _ -> Nothing

350−

351−

352−bitwiseComplement :: Var.Canonical

353−bitwiseComplement =

354− Var.inCore "Bitwise" "complement"

355−

356−

357−basicsNot :: Var.Canonical

358−basicsNot =

359− Var.inCore "Basics" "not"

360−

361−

362−bitwise :: Var.Home

363−bitwise =

364− Var.Module (ModuleName.inCore "Bitwise")

365−

366−

367

361

368-- GENERATE IFS

362-- GENERATE IFS

369

363

@@ -495,7 +489,7 @@ edgeToCase exprName labelRoot (test, subTree) =

495testToExpr :: DT.Test -> JS.Expr

489testToExpr :: DT.Test -> JS.Expr

496testToExpr test =

490testToExpr test =

497 case test of

491 case test of

498− DT.Constructor (Var.Canonical _ tag) ->

492+ DT.Constructor (V.Canonical _ tag) ->

499 JS.String tag

493 JS.String tag

500

494

501 DT.Literal (L.Chr char) ->

495 DT.Literal (L.Chr char) ->

@@ -525,7 +519,7 @@ pathToTestableExpr root path exampleTest =

525

519

526pathToExpr :: Text -> DT.Path -> Opt.Expr

520pathToExpr :: Text -> DT.Path -> Opt.Expr

527pathToExpr root fullPath =

521pathToExpr root fullPath =

528− go (Opt.Var (Var.local root)) fullPath

522+ go (Opt.VarLocal root) fullPath

529 where

523 where

530 go expr path =

524 go expr path =

531 case path of

525 case path of

@@ -546,50 +540,36 @@ pathToExpr root fullPath =

546-- BINARY OPERATORS

540-- BINARY OPERATORS

547

541

548

542

549−binop

543+generateBinop :: ModuleName.Canonical -> Text -> Opt.Expr -> Opt.Expr -> State Int Code

550− :: Var.Canonical

544+generateBinop home op left right =

551− -> Opt.Expr

552− -> Opt.Expr

553− -> State Int Code

554−binop func left right =

555− do jsLeft <- generateJsExpr left

545+ do jsLeft <- generateJsExpr left

556− jsRight <- generateJsExpr right

546+ jsRight <- generateJsExpr right

557− jsExpr (binopHelp func jsLeft jsRight)

547+ jsExpr (generateBinopHelp home op jsLeft jsRight)

558

548

559

549

560

550

561-- BINARY OPERATOR HELPERS

551-- BINARY OPERATOR HELPERS

562

552

563

553

564−binopHelp :: Var.Canonical -> JS.Expr -> JS.Expr -> JS.Expr

554+generateBinopHelp :: ModuleName.Canonical -> Text -> JS.Expr -> JS.Expr -> JS.Expr

565−binopHelp qualifiedOp@(Var.Canonical home op) leftExpr rightExpr =

555+generateBinopHelp home op leftExpr rightExpr =

566− let

556+ let

567− simpleMake left right =

557+ simpleMake left right =

568− JS.Call (ref "A2") [ Var.canonical qualifiedOp, left, right ]

558+ JS.Call (ref "A2") [ Var.global home op, left, right ]

569− in

559+ in

570− if home == basicsModule then

560+ if home == basics then

571− (Map.findWithDefault simpleMake op basicOps) leftExpr rightExpr

561+ (Map.findWithDefault simpleMake op basicOps) leftExpr rightExpr

572−

573− else if op == "::" && (home == listModule || home == listModuleInternals) then

574− BuiltIn.cons leftExpr rightExpr

575−

576− else

577− simpleMake leftExpr rightExpr

578−

579−

580−listModule :: Var.Home

581−listModule =

582− Var.Module (ModuleName.inCore "List")

583

562

563+ else if op == "::" && home == list then

564+ BuiltIn.cons leftExpr rightExpr

584

565

585−listModuleInternals :: Var.Home

566+ else

586−listModuleInternals =

567+ simpleMake leftExpr rightExpr

587− Var.TopLevel (ModuleName.inCore "List")

588

568

589

569

590−basicsModule :: Var.Home

570+list :: ModuleName.Canonical

591−basicsModule =

571+list =

592− Var.Module (ModuleName.inCore "Basics")

572+ ModuleName.inCore "List"

593

573

594

574

595basicOps :: Map.Map Text (JS.Expr -> JS.Expr -> JS.Expr)

575basicOps :: Map.Map Text (JS.Expr -> JS.Expr -> JS.Expr)

src/Generate/JavaScript/Foreign.hs+10−9

@@ -9,6 +9,7 @@ import Data.Text (Text)

10import qualified AST.Expression.Optimized as Opt

11import qualified AST.Literal as Literal

12+import qualified AST.Module.Name as ModuleName

12import qualified AST.Type as T

13import qualified AST.Type as T

13import qualified AST.Variable as Var

14import qualified AST.Variable as Var

14import qualified Generate.JavaScript.Builder as JS

15import qualified Generate.JavaScript.Builder as JS

@@ -152,14 +153,14 @@ decode tipe =

152-- DECODE HELPERS

153-- DECODE HELPERS

153

154

155

155−inJsonDecode :: Text -> Var.Canonical

156−inJsonDecode name =

157− Var.inCore "Json.Decode" name

158−

159−

160to :: Text -> Opt.Expr

156to :: Text -> Opt.Expr

161to name =

157to name =

162− Opt.Var (inJsonDecode name)

158+ Opt.VarGlobal jsonDecode name

159+

160+

161+jsonDecode :: ModuleName.Canonical

162+jsonDecode =

163+ ModuleName.inCore "Json.Decode"

163

164

165

165field :: Text -> Opt.Expr -> Opt.Expr

166field :: Text -> Opt.Expr -> Opt.Expr

@@ -185,7 +186,7 @@ toMaybe :: T.Canonical -> Opt.Expr

185toMaybe tipe =

186toMaybe tipe =

186 let

187 let

187 maybe tag =

188 maybe tag =

188− Opt.Var (Var.inCore "Maybe" tag)

189+ Opt.VarGlobal (ModuleName.inCore "Maybe") tag

189 in

190 in

190 to "oneOf" <==

191 to "oneOf" <==

191 [ Opt.List

192 [ Opt.List

@@ -216,7 +217,7 @@ toTuple types =

216 to "succeed" <==

217 to "succeed" <==

217 [ Opt.Ctor

218 [ Opt.Ctor

218 (Text.pack ("_Tuple" ++ show size))

219 (Text.pack ("_Tuple" ++ show size))

219− (map (Opt.Var . Var.local . toVar . fst) pairs)

220+ (map (Opt.VarLocal . toVar . fst) pairs)

220 ]

221 ]

221

222

222 andThen (i, tipe) decoder =

223 andThen (i, tipe) decoder =

@@ -229,7 +230,7 @@ toRecord :: [(Text, T.Canonical)] -> Opt.Expr

229toRecord fields =

230toRecord fields =

230 let

231 let

231 toFieldExpr (key, _) =

232 toFieldExpr (key, _) =

232− (key, Opt.Var (Var.local key))

233+ (key, Opt.VarLocal key)

233

234

234 finalDecoder =

235 finalDecoder =

235 to "succeed" <== [ Opt.Record (map toFieldExpr fields) ]

236 to "succeed" <== [ Opt.Record (map toFieldExpr fields) ]

src/Generate/JavaScript/Variable.hs+47−72

@@ -2,12 +2,13 @@

2{-# LANGUAGE OverloadedStrings #-}

3module Generate.JavaScript.Variable

4 ( fresh

5− , canonical

5+ , local

6+ , global

6 , qualified

7 , qualified

7 , native

8 , native

8 , coreNative

9 , coreNative

9 , staticProgram

10 , staticProgram

10− , define

11+ , defineGlobal

11 , safe

12 , safe

12 )

13 )

13 where

14 where

@@ -20,7 +21,6 @@ import Data.Text (Text)

21import qualified AST.Helpers as Help

22import qualified AST.Helpers as Help

22import qualified AST.Module.Name as ModuleName

23import qualified AST.Module.Name as ModuleName

23−import qualified AST.Variable as Var

24import qualified Elm.Package as Pkg

25import qualified Generate.JavaScript.Builder as JS

26import qualified Generate.JavaScript.Helpers as JS

@@ -38,72 +38,24 @@ fresh =

41−-- DEF NAMES

41+-- VARIABLES

44−define :: Maybe ModuleName.Canonical -> Text -> JS.Expr -> [JS.Stmt]

44+local :: Text -> JS.Expr

45−define maybeHome name body =

45+local name =

46− if not (Help.isOp name) then

46+ JS.ref (safe name)

47− let

48− jsName =

49− maybe unqualified qualified maybeHome name

50− in

51− [ JS.VarDeclStmt [ JS.varDecl jsName body ] ]

52−

53− else

54− case maybeHome of

55− Nothing ->

56− error "can only define infix operators at the top level"

57−

58− Just home ->

59− let

60− opsDictName =

61− getOpsDictName (Var.TopLevel home)

62−

63− lvalue =

64− JS.LBracket (JS.ref opsDictName) (JS.String name)

65− in

66− [ JS.VarDeclStmt [ JS.varDecl opsDictName (JS.refOrObject opsDictName) ]

67− , JS.ExprStmt (JS.Assign lvalue body)

68− ]

69−

70−

71−

72−-- INSTANTIATE VARIABLES

75−canonical :: Var.Canonical -> JS.Expr

49+global :: ModuleName.Canonical -> Text -> JS.Expr

76−canonical (Var.Canonical home name) =

50+global home name =

77 if Help.isOp name then

51 if Help.isOp name then

78− JS.BracketRef (JS.ref (getOpsDictName home)) (JS.String name)

52+ JS.BracketRef (JS.ref (opsDict home)) (JS.String name)

79−

80 else

53 else

81− case home of

82− Var.Local ->

83− JS.ref (unqualified name)

84−

85− Var.BuiltIn ->

86− JS.ref (unqualified name)

87−

88− Var.Module moduleName@(ModuleName.Canonical _ rawName) ->

89− if ModuleName.isNative rawName then

90− native moduleName name

91−

92− else

93− JS.ref (qualified moduleName name)

54+ JS.ref (qualified home name)

95− Var.TopLevel moduleName ->

96− JS.ref (qualified moduleName name)

99−unqualified :: Text -> Text

58+-- MISC

100−unqualified =

101− safe

102−

103−

104−qualified :: ModuleName.Canonical -> Text -> Text

105−qualified moduleName name =

106− moduleToText moduleName <> "$" <> name

107

108

109native :: ModuleName.Canonical -> Text -> JS.Expr

61native :: ModuleName.Canonical -> Text -> JS.Expr

@@ -121,17 +73,39 @@ staticProgram =

121 native (ModuleName.inVirtualDom "Native.VirtualDom") "staticProgram"

73 native (ModuleName.inVirtualDom "Native.VirtualDom") "staticProgram"

122

123

124−getOpsDictName :: Var.Home -> Text

76+

125−getOpsDictName home =

77+-- DEFINE GLOBALS

126− let

78+

127− moduleName =

79+

80+defineGlobal :: ModuleName.Canonical -> Text -> JS.Expr -> [JS.Stmt]

81+defineGlobal home name body =

128− case home of

82+ case Help.isOp name of

129− Var.Local -> error "infix operators should only be defined in top-level declarations"

83+ False ->

130− Var.BuiltIn -> error "there should be no built-in infix operators"

84+ [ JS.VarDeclStmt [ JS.varDecl (qualified home name) body ]

131− Var.Module name -> name

85+ ]

132− Var.TopLevel name -> name

86+

133− in

87+ True ->

88+ let

89+ dict = opsDict home

90+ lvalue = JS.LBracket (JS.ref dict) (JS.String name)

91+ in

92+ [ JS.VarDeclStmt [ JS.varDecl dict (JS.refOrObject dict) ]

93+ , JS.ExprStmt (JS.Assign lvalue body)

94+ ]

95+

96+

97+

98+-- GLOBAL NAMES

99+

100+

101+qualified :: ModuleName.Canonical -> Text -> Text

102+qualified home name =

103+ moduleToText home <> "$" <> name

104+

105+

106+opsDict :: ModuleName.Canonical -> Text

107+opsDict home =

134− moduleToText moduleName <> "_ops"

108+ moduleToText home <> "_ops"

135

109

136

110

137moduleToText :: ModuleName.Canonical -> Text

111moduleToText :: ModuleName.Canonical -> Text

@@ -155,7 +129,7 @@ moduleToText (ModuleName.Canonical (Pkg.Name user project) moduleName) =

155

129

156safe :: Text -> Text

130safe :: Text -> Text

157safe name =

131safe name =

158− if Set.member name jsReserveds then "$" <> name else name

132+ if Set.member name jsReserveds then "_" <> name else name

159

133

160

134

161jsReserveds :: Set.Set Text

135jsReserveds :: Set.Set Text

@@ -175,4 +149,5 @@ jsReserveds =

175 -- reserved by the Elm runtime system

149 -- reserved by the Elm runtime system

176 , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"

150 , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"

177 , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9"

151 , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9"

152+ , "ctor"

178 ]

153 ]

src/Optimize.hs+57−29

@@ -55,7 +55,7 @@ optimizeDecl variantDict home index (Can.Def _ pattern@(A.A _ ptrn) expression _

55 Env.run variantDict home $

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

57 destructors =

58− destruct (Var.topLevel home name) pattern

58+ destruct (Opt.VarGlobal home name) pattern

59 in

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

@@ -81,7 +81,7 @@ optimizeLetDef (Can.Def _ pattern@(A.A _ ptrn) expression _) =

81 (_, []) ->

82 do name <- Env.freshName

83 body <- optimizeExpr Nothing rawBody

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

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

86 _ ->

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

@@ -112,10 +112,10 @@ optimizeNamedDef name rawArgs rawBody =

112 Opt.Def (Opt.Function args body)

113

114

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

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

116−destruct var pattern =

116+destruct root pattern =

117 map (second Opt.Def) $

118− patternToSubstitutions (Opt.Var var) pattern

118+ patternToSubstitutions root pattern

119

120

121

@@ -199,14 +199,8 @@ optimizeExpr context annExpr@(A.A region expression) =

199 Can.Literal lit ->

200 pure (Opt.Literal lit)

201

202− Can.Var name ->

202+ Can.Var var ->

203− do Env.register name

203+ optimizeVariable region var

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)

210

204

211 Can.List elements ->

205 Can.List elements ->

212 Opt.List

206 Opt.List

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

302

296

303

297

304

298

299+-- OPTIMIZE VARIABLE

300+

301+

302+optimizeVariable :: R.Region -> Var.Canonical -> Env.Optimizer Opt.Expr

303+optimizeVariable region (Var.Canonical home name) =

304+ case home of

305+ Var.BuiltIn ->

306+ pure (Opt.VarLocal name)

307+

308+ Var.Local ->

309+ pure (Opt.VarLocal name)

310+

311+ Var.TopLevel modul ->

312+ do Env.register (Var.Global modul name)

313+ pure (Opt.VarGlobal modul name)

314+

315+ Var.Module modul ->

316+ do Env.register (Var.Global modul name)

317+ if name == "crash" && modul == ModuleName.inCore "Debug"

318+ then

319+ do here <- Env.getHome

320+ pure (Opt.Crash here region Nothing)

321+ else

322+ pure (Opt.VarGlobal modul name)

323+

324+

325+

305-- OPTIMIZE CASE BRANCHES

326-- OPTIMIZE CASE BRANCHES

306

327

307

328

@@ -312,17 +333,13 @@ optimizeBranch

312 -> (P.Canonical, Can.Expr)

333 -> (P.Canonical, Can.Expr)

313 -> Env.Optimizer (P.Canonical, Opt.Expr)

334 -> Env.Optimizer (P.Canonical, Opt.Expr)

314optimizeBranch context region exprName (rawPattern, canBranch) =

335optimizeBranch context region exprName (rawPattern, canBranch) =

315− let

316− root =

317− Opt.Var (Var.Canonical Var.Local exprName)

318− in

319− do optBranch <- optimizeExpr context canBranch

336+ do optBranch <- optimizeExpr context canBranch

320− (pattern, branch) <- tagCrashBranch region rawPattern optBranch

337+ (pattern, branch) <- tagCrashBranch region rawPattern optBranch

321

338

322− let substitutions =

339+ let substitutions = Map.fromList $

323− Map.fromList (patternToSubstitutions root pattern)

340+ patternToSubstitutions (Opt.VarLocal exprName) pattern

324

341

325− (,) pattern <$> Inline.inline substitutions branch

342+ (,) pattern <$> Inline.inline substitutions branch

326

343

327

344

328tagCrashBranch

345tagCrashBranch

@@ -336,7 +353,7 @@ tagCrashBranch region pattern@(A.A pr _) expr =

336 do name <- Env.freshName

353 do name <- Env.freshName

337 return

354 return

338 ( A.A pr (P.Alias name pattern)

355 ( A.A pr (P.Alias name pattern)

339− , Opt.Call (Opt.Crash home region (Just (Opt.Var (Var.local name)))) [arg]

356+ , Opt.Call (Opt.Crash home region (Just (Opt.VarLocal name))) [arg]

340 )

357 )

341

358

342 _ ->

359 _ ->

@@ -453,7 +470,7 @@ optimizeBinop context region op leftExpr rightExpr =

453

470

454 else

471 else

455

472

456− Opt.Binop op

473+ makeOptBinop op

457 <$> optimizeExpr Nothing leftExpr

474 <$> optimizeExpr Nothing leftExpr

458 <*> optimizeExpr Nothing rightExpr

475 <*> optimizeExpr Nothing rightExpr

459

476

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

487 Var.Canonical Var.BuiltIn "::"

504 Var.Canonical Var.BuiltIn "::"

488

505

489

506

490−debugCrash :: Var.Canonical

491−debugCrash =

492− Var.inCore "Debug" "crash"

493−

494−

495type Assoc =

507type Assoc =

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

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

497

509

@@ -517,3 +529,19 @@ collect makeRoot assoc desiredOp annExpr@(A.A ann expr) =

517

529

518 _ ->

530 _ ->

519 makeRoot annExpr

531 makeRoot annExpr

532+

533+

534+makeOptBinop :: Var.Canonical -> Opt.Expr -> Opt.Expr -> Opt.Expr

535+makeOptBinop (Var.Canonical home op) leftExpr rightExpr =

536+ case home of

537+ Var.Local ->

538+ error "bug manifesting in Optimize.makeOptBinop"

539+

540+ Var.BuiltIn ->

541+ error "bug manifesting in Optimize.makeOptBinop"

542+

543+ Var.Module name ->

544+ Opt.Binop name op leftExpr rightExpr

545+

546+ Var.TopLevel name ->

547+ Opt.Binop name op leftExpr rightExpr

src/Optimize/Environment.hs+3−14

@@ -106,20 +106,9 @@ freshName =

106-- REGISTER DEPENDENCIES

107

108

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

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

110−register (Var.Canonical home name) =

110+register global =

111− case home of

112− Var.BuiltIn ->

113− return ()

114−

115− Var.Module realHome ->

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

111+ State.modify (registerHelp global)

117−

118− Var.TopLevel realHome ->

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

120−

121− Var.Local ->

122− return ()

123

112

124

113

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

114registerHelp :: Var.Global -> Env -> Env

src/Optimize/Inline.hs+10−19

@@ -10,7 +10,6 @@ import Data.Text (Text)

11import AST.Expression.Optimized (Expr(..), Decider(..), Choice(..))

12import qualified AST.Expression.Optimized as Opt

13−import qualified AST.Variable as Var

14import qualified Optimize.Environment as Env

13import qualified Optimize.Environment as Env

@@ -49,7 +48,7 @@ processSubs (Subs subs defs) (name, (n, expr)) =

49 else

48 else

50 do uniqueName <- Env.freshName

49 do uniqueName <- Env.freshName

51 return $ Subs

50 return $ Subs

52− (Map.insert name (Opt.Var (Var.local uniqueName)) subs)

51+ (Map.insert name (Opt.VarLocal uniqueName) subs)

53 ((uniqueName, expr) : defs)

52 ((uniqueName, expr) : defs)

@@ -79,24 +78,16 @@ count expression =

79 Literal _ ->

78 Literal _ ->

80 Map.empty

79 Map.empty

82− Var (Var.Canonical home name) ->

81+ VarLocal name ->

83− case home of

84− Var.Local ->

85− Map.singleton name 1

82+ Map.singleton name 1

87− Var.BuiltIn ->

84+ VarGlobal _ _ ->

88− Map.empty

89−

90− Var.Module _ ->

91− Map.empty

92−

93− Var.TopLevel _ ->

94− Map.empty

85+ Map.empty

96 List exprs ->

87 List exprs ->

97 countMany exprs

88 countMany exprs

99− Binop _op left right ->

90+ Binop _ _ left right ->

100 count2 left right

91 count2 left right

101

102 Function args body ->

93 Function args body ->

@@ -194,17 +185,17 @@ replace substitutions expression =

194 Literal _ ->

185 Literal _ ->

195 expression

186 expression

196

187

197− Var (Var.Canonical Var.Local name) ->

188+ VarLocal name ->

198 maybe expression id (Map.lookup name substitutions)

189 maybe expression id (Map.lookup name substitutions)

199

190

200− Var _ ->

191+ VarGlobal _ _ ->

201 expression

192 expression

202

193

203 List exprs ->

194 List exprs ->

204 List (map go exprs)

195 List (map go exprs)

205

196

206− Binop op left right ->

197+ Binop home op left right ->

207− Binop op (go left) (go right)

198+ Binop home op (go left) (go right)

208

199

209 Function args body ->

200 Function args body ->

210 Function args (replace (deleteBatch args substitutions) body)

201 Function args (replace (deleteBatch args substitutions) body)