diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2018-04-01 21:33:53 +0200 |
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2018-04-13 13:40:30 +0200 |
| commit | b1386942e63ba5fe4b2da27f5025afdf80356392 (patch) | |
| tree | c2ffbbc151e8f6f1693e375d44f85781418ca825 /compiler/deSugar/Coverage.hs | |
| parent | 5417c68977db2f2c2c1ce3b8b19ac1f540df471c (diff) | |
| download | haskell-b1386942e63ba5fe4b2da27f5025afdf80356392.tar.gz | |
TTG for HsBinds and Data instances Plan B
Summary:
- Add the balance of the TTG extensions for hsSyn/HsBinds
- Move all the (now orphan) data instances into hsSyn/HsInstances and
use TTG Data instances Plan B
https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/Instances#PLANB
Updates haddock submodule.
Illustrative numbers
Compiling HsInstances before using Plan B.
Max residency ~ 5G
<<ghc: 629,864,691,176 bytes, 5300 GCs,
321075437/1087762592 avg/max bytes residency (23 samples),
2953M in use, 0.000 INIT (0.000 elapsed),
383.511 MUT (384.986 elapsed), 37.426 GC (37.444 elapsed) :ghc>>
Using Plan B
Max residency 1.1G
<<ghc: 78,832,782,968 bytes, 2884 GCs,
222140352/386470152 avg/max bytes residency (34 samples),
1062M in use, 0.001 INIT (0.001 elapsed),
56.612 MUT (62.917 elapsed), 32.974 GC (32.923 elapsed) :ghc>>
Test Plan: ./validate
Reviewers: shayan-najd, goldfire, bgamari
Subscribers: goldfire, thomie, mpickering, carter
Differential Revision: https://phabricator.haskell.org/D4581
Diffstat (limited to 'compiler/deSugar/Coverage.hs')
| -rw-r--r-- | compiler/deSugar/Coverage.hs | 22 |
1 files changed, 13 insertions, 9 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 1f84114726..ab04ee472f 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -351,6 +351,7 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do -- Only internal stuff, not from source, uses VarBind, so we ignore it. addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind +addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind bindTick @@ -779,13 +780,14 @@ addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) = addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders" addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) -addTickHsLocalBinds (HsValBinds binds) = - liftM HsValBinds +addTickHsLocalBinds (HsValBinds x binds) = + liftM (HsValBinds x) (addTickHsValBinds binds) -addTickHsLocalBinds (HsIPBinds binds) = - liftM HsIPBinds +addTickHsLocalBinds (HsIPBinds x binds) = + liftM (HsIPBinds x) (addTickHsIPBinds binds) -addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds +addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x) +addTickHsLocalBinds (XHsLocalBindsLR x) = return (XHsLocalBindsLR x) addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a) -> TM (HsValBindsLR GhcTc (GhcPass b)) @@ -801,16 +803,18 @@ addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do addTickHsValBinds _ = panic "addTickHsValBinds" addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) -addTickHsIPBinds (IPBinds ipbinds dictbinds) = +addTickHsIPBinds (IPBinds dictbinds ipbinds) = liftM2 IPBinds - (mapM (liftL (addTickIPBind)) ipbinds) (return dictbinds) + (mapM (liftL (addTickIPBind)) ipbinds) +addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x) addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) -addTickIPBind (IPBind nm e) = - liftM2 IPBind +addTickIPBind (IPBind x nm e) = + liftM2 (IPBind x) (return nm) (addTickLHsExpr e) +addTickIPBind (XCIPBind x) = return (XCIPBind x) -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) |