@@ -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, []) ->
98+
99+ do hasTailCall <- Env.getTailCall
100+ body <- optimizeExpr Nothing rawBody
101+ Env.setTailCall hasTailCall
102+ return [ Opt.Def facts name body ]
77103
78− do hasTailCall <- Env.getTailCall
79− body <- optimizeExpr Nothing rawBody
80− Env.setTailCall hasTailCall
81− return [ Opt.Def (Opt.Facts home deps) name body ]
104+ (_, []) ->
82105
83− (_, []) ->
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)
84110
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)
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 ->