Commit f5b275a2 authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

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
parent 5cb5b7a5
......@@ -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]
......
......@@ -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
......
......@@ -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') }
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment