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/typecheck/TcPatSyn.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/typecheck/TcPatSyn.hs')
-rw-r--r-- | compiler/typecheck/TcPatSyn.hs | 15 |
1 files changed, 9 insertions, 6 deletions
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index a4d796692f..a759716d71 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -119,6 +119,7 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, , mkTyVarTys ex_tvs, prov_theta, map evId filtered_prov_dicts) (map nlHsVar args, map idType args) pat_ty rec_fields } +tcInferPatSynDecl (XPatSynBind _) = panic "tcInferPatSynDecl" badUnivTvErr :: [TyVar] -> TyVar -> TcM () -- See Note [Type variables whose kind is captured] @@ -332,6 +333,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details -- Why do we need tcSubType here? -- See Note [Pattern synonyms and higher rank types] ; return (mkLHsWrap wrap $ nlHsVar arg_id) } +tcCheckPatSynDecl (XPatSynBind _) _ = panic "tcCheckPatSynDecl" {- [Pattern synonyms and higher rank types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -687,7 +689,7 @@ tcPatSynMatcher (L loc name) lpat match = mkMatch (mkPrefixFunRhs (L loc name)) [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') - (noLoc EmptyLocalBinds) + (noLoc (EmptyLocalBinds noExt)) mg :: MatchGroup GhcTc (LHsExpr GhcTc) mg = MG{ mg_alts = L (getLoc match) [match] , mg_arg_tys = [] @@ -695,10 +697,10 @@ tcPatSynMatcher (L loc name) lpat , mg_origin = Generated } - ; let bind = FunBind{ fun_id = L loc matcher_id + ; let bind = FunBind{ fun_ext = emptyNameSet + , fun_id = L loc matcher_id , fun_matches = mg , fun_co_fn = idHsWrapper - , bind_fvs = emptyNameSet , fun_tick = [] } matcher_bind = unitBag (noLoc bind) @@ -780,10 +782,10 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat match_group' | need_dummy_arg = add_dummy_arg match_group | otherwise = match_group - bind = FunBind { fun_id = L loc (idName builder_id) + bind = FunBind { fun_ext = placeHolderNamesTc + , fun_id = L loc (idName builder_id) , fun_matches = match_group' , fun_co_fn = idHsWrapper - , bind_fvs = placeHolderNamesTc , fun_tick = [] } sig = completeSigFromId (PatSynCtxt name) builder_id @@ -808,7 +810,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat builder_args = [L loc (VarPat noExt (L loc n)) | L loc n <- args] builder_match = mkMatch (mkPrefixFunRhs (L loc name)) builder_args body - (noLoc EmptyLocalBinds) + (noLoc (EmptyLocalBinds noExt)) args = case details of PrefixCon args -> args @@ -821,6 +823,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] } add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ pprMatches other_mg +tcPatSynBuilderBind (XPatSynBind _) = panic "tcPatSynBuilderBind" tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType) -- monadic only for failure |