git.iko.soy/elk
on master help sign in
Provide Debug.crash with module names
c64aa8eEvan Czaplicki
src/AST/Expression/Optimized.hs+1−1
compare with master
unifiedsplit
@@ -54,7 +54,7 @@ data Expr
54 | Record [(String, Expr)]
54 | Record [(String, Expr)]
55 | Port (General.PortImpl Expr Type.Canonical)
55 | Port (General.PortImpl Expr Type.Canonical)
56 | GLShader String String Literal.GLShaderTipe
56 | GLShader String String Literal.GLShaderTipe
57− | Crash R.Region (Maybe String)
57+ | Crash ModuleName.Canonical R.Region (Maybe String)
58
58
59
59
60data Decider a
60data Decider a
src/Generate/JavaScript/BuiltIn.hs+20−4
@@ -3,17 +3,21 @@ module Generate.JavaScript.BuiltIn where
3import Control.Arrow (first)
3import Control.Arrow (first)
4import qualified Language.ECMAScript3.Syntax as JS
4import qualified Language.ECMAScript3.Syntax as JS
5
5
6+import qualified AST.Module.Name as ModuleName
6import Generate.JavaScript.Helpers
7import Generate.JavaScript.Helpers
7import qualified Reporting.Region as R
8import qualified Reporting.Region as R
8
9
9
10
11+
10utils :: String -> [JS.Expression ()] -> JS.Expression ()
12utils :: String -> [JS.Expression ()] -> JS.Expression ()
11utils func args =
13utils func args =
12 obj ["_U", func] `call` args
14 obj ["_U", func] `call` args
13
15
14
16
17+
15-- LITERALS
18-- LITERALS
16
19
20+
17character :: Char -> JS.Expression ()
21character :: Char -> JS.Expression ()
18character char =
22character char =
19 utils "chr" [ JS.StringLit () [char] ]
23 utils "chr" [ JS.StringLit () [char] ]
@@ -24,8 +28,10 @@ string str =
24 JS.StringLit () str
28 JS.StringLit () str
25
29
26
30
31+
27-- LISTS
32-- LISTS
28
33
34+
29list :: [JS.Expression ()] -> JS.Expression ()
35list :: [JS.Expression ()] -> JS.Expression ()
30list elements =
36list elements =
31 utils "list" [ JS.ArrayLit () elements ]
37 utils "list" [ JS.ArrayLit () elements ]
@@ -36,8 +42,10 @@ range low high =
36 utils "range" [ low, high ]
42 utils "range" [ low, high ]
37
43
38
44
45+
39-- RECORDS
46-- RECORDS
40
47
48+
41recordUpdate :: JS.Expression () -> [(String, JS.Expression ())] -> JS.Expression ()
49recordUpdate :: JS.Expression () -> [(String, JS.Expression ())] -> JS.Expression ()
42recordUpdate record fields =
50recordUpdate record fields =
43 utils "update"
51 utils "update"
@@ -46,8 +54,10 @@ recordUpdate record fields =
46 ]
54 ]
47
55
48
56
57+
49-- COMPARISIONS
58-- COMPARISIONS
50
59
60+
51eq :: JS.Expression () -> JS.Expression () -> JS.Expression ()
61eq :: JS.Expression () -> JS.Expression () -> JS.Expression ()
52eq left right =
62eq left right =
53 utils "eq" [ left, right ]
63 utils "eq" [ left, right ]
@@ -58,16 +68,22 @@ cmp left right =
58 utils "cmp" [ left, right ]
68 utils "cmp" [ left, right ]
59
69
60
70
71+
61-- CRASH
72-- CRASH
62
73
74+
63−crash :: R.Region -> Maybe String -> JS.Expression ()
75+crash :: ModuleName.Canonical -> R.Region -> Maybe String -> JS.Expression ()
64−crash region maybeCaseCrashValue =
76+crash home region maybeCaseCrashValue =
77+ let
78+ homeString =
79+ JS.StringLit () (ModuleName.canonicalToString home)
80+ in
65 case maybeCaseCrashValue of
81 case maybeCaseCrashValue of
66 Nothing ->
82 Nothing ->
67− utils "crash" [ regionToJs region ]
83+ utils "crash" [ homeString, regionToJs region ]
68
84
69 Just crashValue ->
85 Just crashValue ->
70− utils "caseCrash" [ regionToJs region, ref crashValue ]
86+ utils "caseCrash" [ homeString, regionToJs region, ref crashValue ]
71
87
72
88
73regionToJs :: R.Region -> JS.Expression ()
89regionToJs :: R.Region -> JS.Expression ()
src/Generate/JavaScript/Expression.hs+2−2
@@ -209,8 +209,8 @@ generateCode expr =
209 do expr' <- generateJsExpr expr
209 do expr' <- generateJsExpr expr
210 jsExpr (Port.task name expr' portType)
210 jsExpr (Port.task name expr' portType)
211
211
212− Crash region maybeCaseCrashValue ->
212+ Crash home region maybeCaseCrashValue ->
213− jsExpr $ BuiltIn.crash region maybeCaseCrashValue
213+ jsExpr $ BuiltIn.crash home region maybeCaseCrashValue
214
214
215
215
216-- FUNCTIONS
216-- FUNCTIONS
src/Optimize.hs+54−30
@@ -19,8 +19,10 @@ import qualified Reporting.Annotation as A
19import qualified Reporting.Region as R
19import qualified Reporting.Region as R
20
20
21
21
22+
22-- OPTIMIZE
23-- OPTIMIZE
23
24
25+
24optimize :: DT.VariantDict -> Module.CanonicalModule -> Module.Optimized
26optimize :: DT.VariantDict -> Module.CanonicalModule -> Module.Optimized
25optimize variantDict module_@(Module.Module home _ _ _ _ body) =
27optimize variantDict module_@(Module.Module home _ _ _ _ body) =
26 let
28 let
@@ -28,7 +30,7 @@ optimize variantDict module_@(Module.Module home _ _ _ _ body) =
28 flattenLets [] (Module.program body)
30 flattenLets [] (Module.program body)
29
31
30 optDefs =
32 optDefs =
31− Env.run variantDict (concat <$> mapM (optimizeDef (Just home)) defs)
33+ Env.run variantDict home (concat <$> mapM (optimizeDef True) defs)
32 in
34 in
33 module_ { Module.body = body { Module.program = optDefs } }
35 module_ { Module.body = body { Module.program = optDefs } }
34
36
@@ -43,56 +45,77 @@ flattenLets defs annExpr@(A.A _ expr) =
43 (defs, annExpr)
45 (defs, annExpr)
44
46
45
47
48+
46-- CONVERT DEFINITIONS
49-- CONVERT DEFINITIONS
47
50
51+
48−optimizeDef :: Maybe ModuleName.Canonical -> Can.Def -> Env.Optimizer [Opt.Def]
52+optimizeDef :: Bool -> Can.Def -> Env.Optimizer [Opt.Def]
49−optimizeDef home (Can.Definition (Can.Facts deps) pattern@(A.A _ ptrn) expression _) =
53+optimizeDef isRoot (Can.Definition (Can.Facts deps) pattern expression _) =
50 let
54 let
51− (args, rawBody) =
55+ (args, canBody) =
52 Expr.collectLambdas expression
56 Expr.collectLambdas expression
53 in
57 in
54− case (ptrn, args) of
58+ do home <-
55− (P.Var name, _ : _) ->
59+ if isRoot then
60+ Just <$> Env.getHome
61+ else
62+ return Nothing
56
63
57− do htc <- Env.getTailCall
64+ optimizeDefHelp home deps pattern args canBody
58− Env.setTailCall False
59
65
60− (args, body) <- optimizeFunction (Just name) args rawBody
61
66
62− isTailCall <- Env.getTailCall
67+optimizeDefHelp
63− Env.setTailCall htc
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, _ : _) ->
64
81
65− let facts = Opt.Facts home deps
82+ do htc <- Env.getTailCall
83+ Env.setTailCall False
66
84
67− return $
85+ (args, body) <- optimizeFunction (Just name) args rawBody
68− if isTailCall then
69
86
70− [ Opt.TailDef facts name args body ]
87+ isTailCall <- Env.getTailCall
88+ Env.setTailCall htc
71
89
72− else
90+ return $
91+ if isTailCall then
92+ [ Opt.TailDef facts name args body ]
73
93
94+ else
74 [ Opt.Def facts name (Opt.Function args body) ]
95 [ Opt.Def facts name (Opt.Function args body) ]
75
96
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 ]
77
103
78− do hasTailCall <- Env.getTailCall
104+ (_, []) ->
79− body <- optimizeExpr Nothing rawBody
80− Env.setTailCall hasTailCall
81− return [ Opt.Def (Opt.Facts home deps) name body ]
82
105
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)
84
110
85− do name <- Env.freshName
111+ _ ->
86− optBody <- optimizeExpr Nothing rawBody
112+ error "there should never be a function where the name is not a P.Var"
87− let optDef = Opt.Def (Opt.Facts home deps) name optBody
88− return (optDef : patternToDefs home name pattern)
89
113
90− _ ->
91− error "there should never be a function where the name is not a P.Var"
92
114
93
115
94-- OPTIMIZE FUNCTION
116-- OPTIMIZE FUNCTION
95
117
118+
96optimizeFunction
119optimizeFunction
97 :: Maybe String
120 :: Maybe String
98 -> [P.CanonicalPattern]
121 -> [P.CanonicalPattern]
@@ -196,7 +219,8 @@ optimizeExpr context annExpr@(A.A region expression) =
196
219
197 Expr.Var name ->
220 Expr.Var name ->
198 if name == Var.inCore ["Debug"] "crash" then
221 if name == Var.inCore ["Debug"] "crash" then
222+ do home <- Env.getHome
199− pure (Opt.Crash region Nothing)
223+ pure (Opt.Crash home region Nothing)
200
224
201 else
225 else
202 pure (Opt.Var name)
226 pure (Opt.Var name)
@@ -248,7 +272,7 @@ optimizeExpr context annExpr@(A.A region expression) =
248 <*> keepLooking finally
272 <*> keepLooking finally
249
273
250 Expr.Let defs body ->
274 Expr.Let defs body ->
251− do optDefs <- concat <$> T.traverse (optimizeDef Nothing) defs
275+ do optDefs <- concat <$> T.traverse (optimizeDef False) defs
252 Opt.Let optDefs <$> keepLooking body
276 Opt.Let optDefs <$> keepLooking body
253
277
254 Expr.Case expr branches ->
278 Expr.Case expr branches ->
src/Optimize/Case.hs+2−2
@@ -43,11 +43,11 @@ tagCrashBranches
43 -> Env.Optimizer (P.CanonicalPattern, Opt.Expr)
43 -> Env.Optimizer (P.CanonicalPattern, Opt.Expr)
44tagCrashBranches region branch@(pattern@(A.A pr _), expr) =
44tagCrashBranches region branch@(pattern@(A.A pr _), expr) =
45 case expr of
45 case expr of
46− Opt.Call (Opt.Crash _ _) [arg] ->
46+ Opt.Call (Opt.Crash home _ _) [arg] ->
47 do name <- Env.freshName
47 do name <- Env.freshName
48 return
48 return
49 ( A.A pr (P.Alias name pattern)
49 ( A.A pr (P.Alias name pattern)
50− , Opt.Call (Opt.Crash region (Just name)) [arg]
50+ , Opt.Call (Opt.Crash home region (Just name)) [arg]
51 )
51 )
52
52
53 _ ->
53 _ ->
src/Optimize/Environment.hs+15−6
@@ -2,12 +2,14 @@ module Optimize.Environment
2 ( Optimizer, run
2 ( Optimizer, run
3 , Env
3 , Env
4 , getVariantDict
4 , getVariantDict
5+ , getHome
5 , getTailCall, setTailCall
6 , getTailCall, setTailCall
6 , freshName
7 , freshName
7 ) where
8 ) where
8
9
9import qualified Control.Monad.State as State
10import qualified Control.Monad.State as State
10
11
12+import qualified AST.Module.Name as ModuleName
11import qualified Optimize.DecisionTree as DT
13import qualified Optimize.DecisionTree as DT
12
14
13
15
@@ -15,15 +17,16 @@ type Optimizer a =
15 State.State Env a
17 State.State Env a
16
18
17
19
18−run :: DT.VariantDict -> Optimizer a -> a
20+run :: DT.VariantDict -> ModuleName.Canonical -> Optimizer a -> a
19−run variantDict optimizer =
21+run variantDict home optimizer =
20− State.evalState optimizer (Env False 0 variantDict)
22+ State.evalState optimizer (Env False 0 variantDict home)
21
23
22
24
23data Env = Env
25data Env = Env
24 { _hasTailCall :: Bool
26 { _hasTailCall :: Bool
25 , _uid :: Int
27 , _uid :: Int
26 , _variantDict :: DT.VariantDict
28 , _variantDict :: DT.VariantDict
29+ , _home :: ModuleName.Canonical
27 }
30 }
28
31
29
32
@@ -32,6 +35,11 @@ getVariantDict =
32 State.gets _variantDict
35 State.gets _variantDict
33
36
34
37
38+getHome :: Optimizer ModuleName.Canonical
39+getHome =
40+ State.gets _home
41+
42+
35getTailCall :: Optimizer Bool
43getTailCall :: Optimizer Bool
36getTailCall =
44getTailCall =
37 State.gets _hasTailCall
45 State.gets _hasTailCall
@@ -45,6 +53,7 @@ setTailCall bool =
45
53
46freshName :: Optimizer String
54freshName :: Optimizer String
47freshName =
55freshName =
48− do (Env htc uid vd) <- State.get
56+ do (Env htc uid vd home) <- State.get
49− State.put (Env htc (uid + 1) vd)
57+ State.put (Env htc (uid + 1) vd home)
50− return ("_p" ++ show uid)
58+ return ("_p" ++ show uid)
59+
src/Optimize/Inline.hs+2−2
@@ -178,7 +178,7 @@ count expression =
178 GLShader _ _ _ ->
178 GLShader _ _ _ ->
179 Map.empty
179 Map.empty
180
180
181− Crash _ _ ->
181+ Crash _ _ _ ->
182 Map.empty
182 Map.empty
183
183
184
184
@@ -287,5 +287,5 @@ replace substitutions expression =
287 GLShader _ _ _ ->
287 GLShader _ _ _ ->
288 expression
288 expression
289
289
290− Crash _ _ ->
290+ Crash _ _ _ ->
291 expression
291 expression