Commit 5bc195a2 authored by niteria's avatar niteria

Allow top level ticked string literals

This reverts f5b275a2
and changes the places that looked for `Lit (MachStr _))`
to use `exprIsMbTickedLitString_maybe` to unwrap ticks as
necessary.
Also updated relevant comments.

Test Plan:
I added 3 new tests that previously reproduced.
GHC HEAD now builds with -g

Reviewers: simonpj, simonmar, bgamari, hvr, goldfire

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #14779

Differential Revision: https://phabricator.haskell.org/D4470
parent ee597e9e
......@@ -531,7 +531,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
; checkL ( isJoinId binder
|| not (isUnliftedType binder_ty)
|| (isNonRec rec_flag && exprOkForSpeculation rhs)
|| exprIsLiteralString rhs)
|| exprIsTickedString rhs)
(badBndrTyMsg binder (text "unlifted"))
-- Check that if the binder is top-level or recursive, it's not
......@@ -539,14 +539,14 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
-- computation to perform, see Note [CoreSyn top-level string literals].
; checkL (not (isStrictId binder)
|| (isNonRec rec_flag && not (isTopLevel top_lvl_flag))
|| exprIsLiteralString rhs)
|| exprIsTickedString rhs)
(mkStrictMsg binder)
-- Check that if the binder is at the top level and has type Addr#,
-- that it is a string literal, see
-- Note [CoreSyn top-level string literals].
; checkL (not (isTopLevel top_lvl_flag && binder_ty `eqType` addrPrimTy)
|| exprIsLiteralString rhs)
|| exprIsTickedString rhs)
(mkTopNonLitStrMsg binder)
; flags <- getLintFlags
......
......@@ -401,10 +401,10 @@ 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.
We allow the top-level primitive string literals to be wrapped in Ticks
in the same way they can be wrapped when nested in an expression.
CoreToSTG currently discards Ticks around top-level primitive string literals.
See Trac #14779.
Also see Note [Compilation plan for top-level string literals].
......@@ -414,7 +414,7 @@ Here is a summary on how top-level string literals are handled by various
parts of the compilation pipeline.
* In the source language, there is no way to bind a primitive string literal
at the top leve.
at the top level.
* In Core, we have a special rule that permits top-level Addr# bindings. See
Note [CoreSyn top-level string literals]. Core-to-core passes may introduce
......
......@@ -29,7 +29,8 @@ module CoreUtils (
exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
exprIsBig, exprIsConLike,
rhsIsStatic, isCheapApp, isExpandableApp,
exprIsLiteralString, exprIsTopLevelBindable,
exprIsTickedString, exprIsTickedString_maybe,
exprIsTopLevelBindable,
altsAreExhaustive,
-- * Equality
......@@ -90,6 +91,7 @@ import BasicTypes ( Arity, isConLike )
import Platform
import Util
import Pair
import Data.ByteString ( ByteString )
import Data.Function ( on )
import Data.List
import Data.Ord ( comparing )
......@@ -1726,12 +1728,25 @@ exprIsTopLevelBindable :: CoreExpr -> Type -> Bool
-- Top-level literal strings can't even be wrapped in ticks
-- see Note [CoreSyn top-level string literals] in CoreSyn
exprIsTopLevelBindable expr ty
= exprIsLiteralString expr
|| not (isUnliftedType ty)
exprIsLiteralString :: CoreExpr -> Bool
exprIsLiteralString (Lit (MachStr _)) = True
exprIsLiteralString _ = False
= not (isUnliftedType ty)
|| exprIsTickedString expr
-- | Check if the expression is zero or more Ticks wrapped around a literal
-- string.
exprIsTickedString :: CoreExpr -> Bool
exprIsTickedString = isJust . exprIsTickedString_maybe
-- | Extract a literal string from an expression that is zero or more Ticks
-- wrapped around a literal string. Returns Nothing if the expression has a
-- different shape.
-- Used to "look through" Ticks in places that need to handle literal strings.
exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString
exprIsTickedString_maybe (Lit (MachStr bs)) = Just bs
exprIsTickedString_maybe (Tick t e)
-- we don't tick literals with CostCentre ticks, compare to mkTick
| tickishPlace t == PlaceCostCentre = Nothing
| otherwise = exprIsTickedString_maybe e
exprIsTickedString_maybe _ = Nothing
{-
************************************************************************
......
......@@ -93,8 +93,8 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
-- See Note [generating code for top-level string literal bindings].
let (strings, flatBinds) = splitEithers $ do
(bndr, rhs) <- flattenBinds binds
return $ case rhs of
Lit (MachStr str) -> Left (bndr, str)
return $ case exprIsTickedString_maybe rhs of
Just str -> Left (bndr, str)
_ -> Right (bndr, simpleFreeVars rhs)
stringPtrs <- allocateTopStrings hsc_env strings
......
......@@ -19,7 +19,7 @@ import Id ( Id, idType, idInlineActivation, isDeadBinder
, zapIdOccInfo, zapIdUsageInfo, idInlinePragma
, isJoinId )
import CoreUtils ( mkAltExpr, eqExpr
, exprIsLiteralString
, exprIsTickedString
, stripTicksE, stripTicksT, mkTicks )
import CoreFVs ( exprFreeVars )
import Type ( tyConAppArgs )
......@@ -349,7 +349,7 @@ cseBind toplevel env (Rec pairs)
-- which are equal to @out_rhs@.
cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr))
cse_bind toplevel env (in_id, in_rhs) out_id
| isTopLevel toplevel, exprIsLiteralString in_rhs
| isTopLevel toplevel, exprIsTickedString in_rhs
-- See Note [Take care with literal strings]
= (env', (out_id, in_rhs))
......
......@@ -23,7 +23,6 @@ import DynFlags
import ErrUtils ( dumpIfSet_dyn )
import Id ( Id, idArity, idType, isBottomingId,
isJoinId, isJoinId_maybe )
import BasicTypes ( TopLevelFlag(..), isTopLevel )
import SetLevels
import UniqSupply ( UniqSupply )
import Bag
......@@ -737,26 +736,19 @@ atJoinCeiling (fs, floats, expr')
wrapTick :: Tickish Id -> FloatBinds -> FloatBinds
wrapTick t (FB tops ceils defns)
= FB (mapBag (wrap_bind TopLevel) tops)
(wrap_defns NotTopLevel ceils)
(M.map (M.map (wrap_defns NotTopLevel)) defns)
= FB (mapBag wrap_bind tops) (wrap_defns ceils)
(M.map (M.map wrap_defns) defns)
where
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
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
-- 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
......
......@@ -496,9 +496,9 @@ unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))
flag (Rec {}) = FltLifted
flag (NonRec bndr rhs)
| not (isStrictId bndr) = FltLifted
| exprIsLiteralString rhs = FltLifted
| exprIsTickedString rhs = FltLifted
-- String literals can be floated freely.
-- See Note [CoreSyn top-level string ltierals] in CoreSyn.
-- See Note [CoreSyn top-level string literals] in CoreSyn.
| exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF)
| otherwise = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )
FltCareful
......
......@@ -440,13 +440,7 @@ prepareRhs mode top_lvl occ _ rhs0
-- we can obtain non-counting ticks.
| (not (tickishCounts t) || tickishCanSplit t)
= do { (is_exp, floats, rhs') <- go n_val_args rhs
; 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)
; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)
floats' = mapLetFloats floats tickIt
; return (is_exp, floats', Tick t rhs') }
......
......@@ -18,7 +18,8 @@ module CoreToStg ( coreToStg ) where
import GhcPrelude
import CoreSyn
import CoreUtils ( exprType, findDefault, isJoinBind )
import CoreUtils ( exprType, findDefault, isJoinBind
, exprIsTickedString_maybe )
import CoreArity ( manifestArity )
import StgSyn
......@@ -273,8 +274,10 @@ coreTopBindToStg
-> CoreBind
-> (IdEnv HowBound, FreeVarsInfo, CollectedCCs, StgTopBinding)
coreTopBindToStg _ _ env body_fvs ccs (NonRec id (Lit (MachStr str)))
coreTopBindToStg _ _ env body_fvs ccs (NonRec id e)
| Just str <- exprIsTickedString_maybe e
-- top-level string literal
-- See Note [CoreSyn top-level string literals] in CoreSyn
= let
env' = extendVarEnv env id how_bound
how_bound = LetBound TopLet 0
......
{-# OPTIONS_GHC -g -O #-}
{-# OPTIONS
-fno-strictness
-fno-case-merge
-fno-call-arity
-fno-case-folding
-fno-cse
-fno-do-eta-reduction
-fno-do-lambda-eta-expansion
-fno-float-in
-ffull-laziness
-fno-enable-rewrite-rules
#-}
-- This used to fail with:
--
-- *** Core Lint errors : in result of Simplifier ***
-- <no location info>: warning:
-- [RHS of str_sZr :: Addr#]
-- Recursive or top-level binder has strict demand info: str_sZr
-- Binder's demand info: <L,U>
module T14779a where
mkConstr :: String -> String
mkConstr str = r
where
r = idx `seq` str
idx = eqS r str `seq` [r]
conMkFixed :: String
conMkFixed = mkConstr "MkFixed"
eqS :: String -> String -> Bool
eqS [] [] = True
eqS _ _ = False
{-# OPTIONS_GHC -g -O #-}
-- This used to fail with:
--
-- *** Core Lint errors : in result of Simplifier ***
-- <no location info>: warning:
-- [RHS of str_s2UI :: Addr#]
-- The type of this binder is unlifted: str_s2UI
-- Binder's type: Addr#
module T14779b where
data DataType = DataType
{ tycon :: String
, datarep :: DataRep
}
data Constr = Constr
{ conrep :: ConstrRep
, constring :: String
, confields :: [String] -- for AlgRep only
, confixity :: Fixity -- for AlgRep only
, datatype :: DataType
}
data DataRep = AlgRep [Constr]
| IntRep
| FloatRep
| CharRep
| NoRep
data ConstrRep = AlgConstr ConIndex
| IntConstr Integer
| FloatConstr Rational
| CharConstr Char
type ConIndex = Int
-- | Fixity of constructors
data Fixity = Prefix
| Infix -- Later: add associativity and precedence
mkDataType :: String -> [Constr] -> DataType
mkDataType str cs = DataType
{ tycon = str
, datarep = AlgRep cs
}
mkConstr :: DataType -> String -> [String] -> Fixity -> Constr
mkConstr dt str fields fix =
Constr
{ conrep = AlgConstr idx
, constring = str
, confields = fields
, confixity = fix
, datatype = dt
}
where
idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..],
showConstr c == str ]
dataTypeConstrs :: DataType -> [Constr]
dataTypeConstrs dt = case datarep dt of
(AlgRep cons) -> cons
_ -> errorWithoutStackTrace $
"Data.Data.dataTypeConstrs is not supported for "
++ dataTypeName dt ++
", as it is not an algebraic data type."
dataTypeName :: DataType -> String
dataTypeName = tycon
showConstr :: Constr -> String
showConstr = constring
-- | The type parameter should be an instance of 'HasResolution'.
newtype Fixed a = MkFixed Integer -- ^ @since 4.7.0.0
deriving (Eq,Ord)
tyFixed :: DataType
tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed]
conMkFixed :: Constr
conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix
......@@ -270,6 +270,12 @@ test('T12600',
test('T13658',
[when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261))],
compile, ['-dcore-lint'])
test('T14779a',
[when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261))],
compile, ['-dcore-lint'])
test('T14779b',
[when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261))],
compile, ['-dcore-lint'])
test('T13708', normal, compile, [''])
# thunk should inline here, so check whether or not it appears in the Core
......
{-# OPTIONS -O -g #-}
main = print (4, "foo")
......@@ -79,3 +79,6 @@ test('T13429_2', normal, compile_and_run, [''])
test('T13750', normal, compile_and_run, [''])
test('T14178', normal, compile_and_run, [''])
test('T14768', reqlib('vector'), compile_and_run, [''])
test('T14868',
[when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261))],
compile_and_run, [''])
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