diff options
author | Ben Gamari <bgamari.foss@gmail.com> | 2017-02-01 22:48:32 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2017-02-01 23:37:47 -0500 |
commit | f5b275a239d2554c4da0b7621211642bf3b10650 (patch) | |
tree | ca54df9dfc804f5007aba000fe35921c1d941dda | |
parent | 5cb5b7a505d3cf87b4bdac31acae2a650221d05f (diff) | |
download | haskell-f5b275a239d2554c4da0b7621211642bf3b10650.tar.gz |
Don't tick top-level string literals
This fixes a regression due to D2605 (see #8472) wherein top-level primitive
strings would fail to be noticed by CoreToStg as they were wrapped in a
tick. This resulted in a panic in CoreToStg due to inconsistent CAF information
(or a Core Lint failure, if enabled). Here we document the invariant that
unlifted expressions can only sit at top-level if of the form `Lit (MachStr
...)` with no ticks or other embellishments. Moreover, we fix instance of
this in `Simplify.prepareRhs` and `FloatOut.wrapTick` where this
invariant was being broken.
Test Plan: Validate with `-g`. Run testsuite with `WAY=ghci`.
Reviewers: austin, simonpj
Reviewed By: simonpj
Subscribers: simonpj, akio, scpmw, thomie
Differential Revision: https://phabricator.haskell.org/D3051
-rw-r--r-- | compiler/coreSyn/CoreSyn.hs | 5 | ||||
-rw-r--r-- | compiler/simplCore/FloatOut.hs | 32 | ||||
-rw-r--r-- | compiler/simplCore/Simplify.hs | 10 |
3 files changed, 33 insertions, 14 deletions
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index f74e3e585a..f8cf6f4dca 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -383,6 +383,11 @@ The solution is simply to allow top-level unlifted binders. We can't allow arbitrary unlifted expression at the top-level though, unlifted binders cannot be thunks, so we just allow string literals. +It is important to note that top-level primitive string literals cannot be +wrapped in Ticks, as is otherwise done with lifted bindings. CoreToStg expects +to see just a plain (Lit (MachStr ...)) expression on the RHS of primitive +string bindings; anything else and things break. CoreLint checks this invariant. + Also see Note [Compilation plan for top-level string literals]. Note [Compilation plan for top-level string literals] diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs index 17ffba404c..4806862f85 100644 --- a/compiler/simplCore/FloatOut.hs +++ b/compiler/simplCore/FloatOut.hs @@ -22,6 +22,7 @@ import ErrUtils ( dumpIfSet_dyn ) import Id ( Id, idArity, idType, isBottomingId, isJoinId, isJoinId_maybe ) import Var ( Var ) +import BasicTypes ( TopLevelFlag(..), isTopLevel ) import SetLevels import UniqSupply ( UniqSupply ) import Bag @@ -735,19 +736,26 @@ atJoinCeiling (fs, floats, expr') wrapTick :: Tickish Id -> FloatBinds -> FloatBinds wrapTick t (FB tops ceils defns) - = FB (mapBag wrap_bind tops) (wrap_defns ceils) - (M.map (M.map wrap_defns) defns) + = FB (mapBag (wrap_bind TopLevel) tops) + (wrap_defns NotTopLevel ceils) + (M.map (M.map (wrap_defns NotTopLevel)) defns) where - wrap_defns = mapBag wrap_one - - wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs) - wrap_bind (Rec pairs) = Rec (mapSnd maybe_tick pairs) - - wrap_one (FloatLet bind) = FloatLet (wrap_bind bind) - wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs - - maybe_tick e | exprIsHNF e = tickHNFArgs t e - | otherwise = mkTick t e + wrap_defns toplvl = mapBag (wrap_one toplvl) + + wrap_bind toplvl (NonRec binder rhs) = NonRec binder (maybe_tick toplvl rhs) + wrap_bind toplvl (Rec pairs) = Rec (mapSnd (maybe_tick toplvl) pairs) + + wrap_one toplvl (FloatLet bind) = FloatLet (wrap_bind toplvl bind) + wrap_one toplvl (FloatCase e b c bs) = FloatCase (maybe_tick toplvl e) b c bs + + maybe_tick :: TopLevelFlag -> CoreExpr -> CoreExpr + maybe_tick toplvl e + -- We must take care not to tick top-level literal + -- strings as this violated the Core invariants. See Note [CoreSyn + -- top-level string literals]. + | isTopLevel toplvl && exprIsLiteralString e = e + | exprIsHNF e = tickHNFArgs t e + | otherwise = mkTick t e -- we don't need to wrap a tick around an HNF when we float it -- outside a tick: that is an invariant of the tick semantics -- Conversely, inlining of HNFs inside an SCC is allowed, and diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index 7c6f8757cc..7357e32338 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -566,9 +566,15 @@ prepareRhs top_lvl env0 id rhs0 -- On the other hand, for scoping ticks we need to be able to -- copy them on the floats, which in turn is only allowed if -- we can obtain non-counting ticks. - | not (tickishCounts t) || tickishCanSplit t + | (not (tickishCounts t) || tickishCanSplit t) = do { (is_exp, env', rhs') <- go n_val_args (zapFloats env) rhs - ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) + ; let tickIt (id, expr) + -- we have to take care not to tick top-level literal + -- strings. See Note [CoreSyn top-level string literals]. + | isTopLevel top_lvl && exprIsLiteralString expr + = (id, expr) + | otherwise + = (id, mkTick (mkNoCount t) expr) floats' = seFloats $ env `addFloats` mapFloats env' tickIt ; return (is_exp, env' { seFloats = floats' }, Tick t rhs') } |