@@ -19,8 +19,10 @@ import qualified Reporting.Annotation as A
1919import qualified Reporting.Region as R
2020
2121
22+
2223-- OPTIMIZE
2324
25+
2426optimize :: DT.VariantDict -> Module.CanonicalModule -> Module.Optimized
2527optimize variantDict module_@(Module.Module home _ _ _ _ body) =
2628 let
@@ -28,7 +30,7 @@ optimize variantDict module_@(Module.Module home _ _ _ _ body) =
2830 flattenLets [] (Module.program body)
2931
3032 optDefs =
31− Env.run variantDict (concat <$> mapM (optimizeDef (Just home)) defs)
33+ Env.run variantDict home (concat <$> mapM (optimizeDef True) defs)
3234 in
3335 module_ { Module.body = body { Module.program = optDefs } }
3436
@@ -43,56 +45,77 @@ flattenLets defs annExpr@(A.A _ expr) =
4345 (defs, annExpr)
4446
4547
48+
4649-- CONVERT DEFINITIONS
4750
48−optimizeDef :: Maybe ModuleName.Canonical -> Can.Def -> Env.Optimizer [Opt.Def]
49−optimizeDef home (Can.Definition (Can.Facts deps) pattern@(A.A _ ptrn) expression _) =
51+
52+optimizeDef :: Bool -> Can.Def -> Env.Optimizer [Opt.Def]
53+optimizeDef isRoot (Can.Definition (Can.Facts deps) pattern expression _) =
5054 let
51− (args, rawBody) =
55+ (args, canBody) =
5256 Expr.collectLambdas expression
5357 in
54− case (ptrn, args) of
55− (P.Var name, _ : _) ->
58+ do home <-
59+ if isRoot then
60+ Just <$> Env.getHome
61+ else
62+ return Nothing
5663
57− do htc <- Env.getTailCall
58− Env.setTailCall False
64+ optimizeDefHelp home deps pattern args canBody
5965
60− (args, body) <- optimizeFunction (Just name) args rawBody
6166
62− isTailCall <- Env.getTailCall
63− Env.setTailCall htc
67+optimizeDefHelp
68+ :: Maybe ModuleName.Canonical
69+ -> [Var.TopLevel]
70+ -> P.CanonicalPattern
71+ -> [P.CanonicalPattern]
72+ -> Can.Expr
73+ -> Env.Optimizer [Opt.Def]
74+optimizeDefHelp home deps pattern@(A.A _ ptrn) args rawBody =
75+ let
76+ facts =
77+ Opt.Facts home deps
78+ in
79+ case (ptrn, args) of
80+ (P.Var name, _ : _) ->
6481
65− let facts = Opt.Facts home deps
82+ do htc <- Env.getTailCall
83+ Env.setTailCall False
6684
67− return $
68− if isTailCall then
85+ (args, body) <- optimizeFunction (Just name) args rawBody
6986
70− [ Opt.TailDef facts name args body ]
87+ isTailCall <- Env.getTailCall
88+ Env.setTailCall htc
7189
72− else
90+ return $
91+ if isTailCall then
92+ [ Opt.TailDef facts name args body ]
7393
94+ else
7495 [ Opt.Def facts name (Opt.Function args body) ]
7596
76− (P.Var name, []) ->
97+ (P.Var name, []) ->
7798
78− do hasTailCall <- Env.getTailCall
79− body <- optimizeExpr Nothing rawBody
80− Env.setTailCall hasTailCall
81− return [ Opt.Def (Opt.Facts home deps) name body ]
99+ do hasTailCall <- Env.getTailCall
100+ body <- optimizeExpr Nothing rawBody
101+ Env.setTailCall hasTailCall
102+ return [ Opt.Def facts name body ]
82103
83− (_, []) ->
104+ (_, []) ->
84105
85− do name <- Env.freshName
86− optBody <- optimizeExpr Nothing rawBody
87− let optDef = Opt.Def (Opt.Facts home deps) name optBody
88− return (optDef : patternToDefs home name pattern)
106+ do name <- Env.freshName
107+ optBody <- optimizeExpr Nothing rawBody
108+ let optDef = Opt.Def facts name optBody
109+ return (optDef : patternToDefs home name pattern)
110+
111+ _ ->
112+ error "there should never be a function where the name is not a P.Var"
89113
90− _ ->
91− error "there should never be a function where the name is not a P.Var"
92114
93115
94116-- OPTIMIZE FUNCTION
95117
118+
96119optimizeFunction
97120 :: Maybe String
98121 -> [P.CanonicalPattern]
@@ -196,7 +219,8 @@ optimizeExpr context annExpr@(A.A region expression) =
196219
197220 Expr.Var name ->
198221 if name == Var.inCore ["Debug"] "crash" then
199− pure (Opt.Crash region Nothing)
222+ do home <- Env.getHome
223+ pure (Opt.Crash home region Nothing)
200224
201225 else
202226 pure (Opt.Var name)
@@ -248,7 +272,7 @@ optimizeExpr context annExpr@(A.A region expression) =
248272 <*> keepLooking finally
249273
250274 Expr.Let defs body ->
251− do optDefs <- concat <$> T.traverse (optimizeDef Nothing) defs
275+ do optDefs <- concat <$> T.traverse (optimizeDef False) defs
252276 Opt.Let optDefs <$> keepLooking body
253277
254278 Expr.Case expr branches ->
@@ -256,8 +280,8 @@ optimizeExpr context annExpr@(A.A region expression) =
256280 variantDict <- Env.getVariantDict
257281
258282 name <- Env.freshName
259− optBranches <- T.traverse (optimizeBranch context name) branches
260− optCase <- Case.optimize variantDict region name optBranches
283+ optBranches <- T.traverse (optimizeBranch context region name) branches
284+ let optCase = Case.optimize variantDict name optBranches
261285 return $ Opt.Let [ Opt.Def Opt.dummyFacts name optExpr ] optCase
262286
263287 Expr.Data name exprs ->
@@ -302,19 +326,40 @@ mapSnd func (x, a) =
302326
303327optimizeBranch
304328 :: Context
329+ -> R.Region
305330 -> String
306331 -> (P.CanonicalPattern, Can.Expr)
307332 -> Env.Optimizer (P.CanonicalPattern, Opt.Expr)
308−optimizeBranch context exprName (pattern, canonicalExpr) =
333+optimizeBranch context region exprName (rawPattern, canBranch) =
309334 let
310335 root =
311336 Opt.Var (Var.Canonical Var.Local exprName)
312−
313− substitutions =
314− Map.fromList (patternToSubstitutions root pattern)
315337 in
316− do optExpr <- optimizeExpr context canonicalExpr
317− (,) pattern <$> Inline.inline substitutions optExpr
338+ do optBranch <- optimizeExpr context canBranch
339+ (pattern, branch) <- tagCrashBranch region rawPattern optBranch
340+
341+ let substitutions =
342+ Map.fromList (patternToSubstitutions root pattern)
343+
344+ (,) pattern <$> Inline.inline substitutions branch
345+
346+
347+tagCrashBranch
348+ :: R.Region
349+ -> P.CanonicalPattern
350+ -> Opt.Expr
351+ -> Env.Optimizer (P.CanonicalPattern, Opt.Expr)
352+tagCrashBranch region pattern@(A.A pr _) expr =
353+ case expr of
354+ Opt.Call (Opt.Crash home _ _) [arg] ->
355+ do name <- Env.freshName
356+ return
357+ ( A.A pr (P.Alias name pattern)
358+ , Opt.Call (Opt.Crash home region (Just (Opt.Var (Var.local name)))) [arg]
359+ )
360+
361+ _ ->
362+ return (pattern, expr)
318363
319364
320365-- DETECT TAIL CALL