digital-asset/daml
1
1
Fork 0
mirror of https://github.com/digital-asset/daml.git synced 2024-09-20 01:07:18 +03:00
Code Issues Projects Releases Wiki Activity

Strip ELocation nodes in simplifier rules. (#6930)

Browse Source 
* Strip ELocation nodes in simplifier rules.

Uses stripLoc in the patterns used by the simplifier. This change
reduces the size of the generated code by 1.5% for a very large project,
meaning we had rules (like `let x = e in x`) that weren't trigerring
because of the `ELocation` nodes that weren't being properly ignored.

changelog_begin
changelog_end

* More stripLoc
This commit is contained in:
Sofia Faro 2020-07-30 15:37:35 +01:00 committed by GitHub
parent 91b174da91
commit 3b08440fe7
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
1 changed files with 17 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
compiler/daml-lf-tools/src/DA/Daml/LF/Simplifier.hs
View File

@ -353,6 +353,12 @@ liftClosedExpr e = do
Left _ ->
pure e
-- | Remove top-level location information.
stripLoc :: Expr -> Expr
stripLoc = \case
ELocation _ e -> stripLoc e
e -> e
simplifyExpr :: Expr -> Simplifier Expr
simplifyExpr = fmap fst . cata go'
where
@ -404,35 +410,36 @@ simplifyExpr = fmap fst . cata go'
-> cata (go world) e'
-- <...; f = e; ...>.f ==> e
EStructProjF f (EStructCon fes, s)
EStructProjF f (stripLoc -> EStructCon fes, s)
-- NOTE(MH): We're deliberately overapproximating the potential of
-- bottoms and the set of free variables below to avoid recomputing
-- them.
| Safe _ <- safety s, Just e <- f `lookup` fes -> (e, s)
-- let x = e in x ==> e
ELetF (BindingF (x, _) e) (EVar x', _)
| x == x' -> e
ELetF (BindingF (x1, _) e) (stripLoc -> EVar x2, _)
| x1 == x2
-> e
-- let x = x in e ==> e
ELetF (BindingF (x, _) (EVar x', _)) e
ELetF (BindingF (x, _) (stripLoc -> EVar x', _)) e
| x == x' -> e
-- let x = <...; f = e; ...> in x.f ==> e
ELetF (BindingF (x, _) (EStructCon fes, s)) (EStructProj f (EVar x'), _)
ELetF (BindingF (x, _) (stripLoc -> EStructCon fes, s)) (stripLoc -> EStructProj f (stripLoc -> EVar x'), _)
-- NOTE(MH): See NOTE above on @s@.
| x == x', Safe _ <- safety s, Just e <- f `lookup` fes -> (e, s)
-- let x = <f1 = e1; ...; fn = en> in T {f1 = x.f1; ...; fn = x.fn}
-- ==>
-- T {f1 = e1; ...; fn = en}
ELetF (BindingF (x1, _) (EStructCon fes1, s)) (ERecCon t fes2, _)
ELetF (BindingF (x1, _) (stripLoc -> EStructCon fes1, s)) (stripLoc -> ERecCon t fes2, _)
| Just bs <- Safe.zipWithExactMay matchField fes1 fes2
, and bs ->
(ERecCon t fes1, s)
where
matchField (f1, _) = \case
(f2, EStructProj f3 (EVar x3)) ->
(f2, stripLoc -> EStructProj f3 (stripLoc -> EVar x3)) ->
(f1 == f2) && (f1 == f3) && (x1 == x3)
_ -> False
@ -442,7 +449,7 @@ simplifyExpr = fmap fst . cata go'
, not (isFreeExprVar x (freeVars (snd e2))) -> e2
-- (let x = e1 in e2).f ==> let x = e1 in e2.f
EStructProjF f (ELet (Binding (x, t) e1) e2, s0) ->
EStructProjF f (stripLoc -> ELet (Binding (x, t) e1) e2, s0) ->
go world $ ELetF (BindingF (x, t) (e1, s1)) (go world $ EStructProjF f (e2, s2))
where
(s1, s2) = infoUnstepELet x s0
@ -457,13 +464,13 @@ simplifyExpr = fmap fst . cata go'
--
-- NOTE(MH): This also works when `x` is free in `e2` since let-bindings
-- are _not_ recursive.
ETmAppF (ETmLam (x, t) e1, s0) (e2, s2) ->
ETmAppF (stripLoc -> ETmLam (x, t) e1, s0) (e2, s2) ->
go world $ ELetF (BindingF (x, t) (e2, s2)) (e1, s1)
where
s1 = infoUnstepETmapp x s0
-- (let x = e1 in e2) e3 ==> let x = e1 in e2 e3, if x is not free in e3
ETmAppF (ELet (Binding (x, t) e1) e2, s0) e3
ETmAppF (stripLoc -> ELet (Binding (x, t) e1) e2, s0) e3
| not (isFreeExprVar x (freeVars (snd e3))) ->
go world $ ELetF (BindingF (x, t) (e1, s1)) (go world $ ETmAppF (e2, s2) e3)
where