diff options
| author | Luke Maurer <maurerl@cs.uoregon.edu> | 2017-02-01 11:56:01 -0500 |
|---|---|---|
| committer | David Feuer <David.Feuer@gmail.com> | 2017-02-01 13:44:52 -0500 |
| commit | 8d5cf8bf584fd4849917c29d82dcf46ee75dd035 (patch) | |
| tree | 9d1b012562fd7ec1d1089b7d87e061884ba71f1c /compiler/specialise/Rules.hs | |
| parent | 4fa439e3ee2822f893bd364a6cbfe410a0c1e29f (diff) | |
| download | haskell-8d5cf8bf584fd4849917c29d82dcf46ee75dd035.tar.gz | |
Join points
This major patch implements Join Points, as described in
https://ghc.haskell.org/trac/ghc/wiki/SequentCore. You have
to read that page, and especially the paper it links to, to
understand what's going on; but it is very cool.
It's Luke Maurer's work, but done in close collaboration with Simon PJ.
This Phab is a squash-merge of wip/join-points branch of
http://github.com/lukemaurer/ghc. There are many, many interdependent
changes.
Reviewers: goldfire, mpickering, bgamari, simonmar, dfeuer, austin
Subscribers: simonpj, dfeuer, mpickering, Mikolaj, thomie
Differential Revision: https://phabricator.haskell.org/D2853
Diffstat (limited to 'compiler/specialise/Rules.hs')
| -rw-r--r-- | compiler/specialise/Rules.hs | 6 |
1 files changed, 4 insertions, 2 deletions
diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs index 42cb13e8df..ba44794db4 100644 --- a/compiler/specialise/Rules.hs +++ b/compiler/specialise/Rules.hs @@ -35,7 +35,8 @@ import OccurAnal ( occurAnalyseExpr ) import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList ) import CoreUtils ( exprType, eqExpr, mkTick, mkTicks, - stripTicksTopT, stripTicksTopE ) + stripTicksTopT, stripTicksTopE, + isJoinBind ) import PprCore ( pprRules ) import Type ( Type, substTy, mkTCvSubst ) import TcType ( tcSplitTyConApp_maybe ) @@ -728,7 +729,8 @@ match renv subst e1 (Var v2) -- Note [Expanding variables] match renv subst e1 (Let bind e2) | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $ - okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets] + not (isJoinBind bind) -- can't float join point out of argument position + , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets] = match (renv { rv_fltR = flt_subst' }) (subst { rs_binds = rs_binds subst . Let bind' , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs }) |