Commit d49b2bb2 authored by takano-akio's avatar takano-akio Committed by Ben Gamari

Allow top-level string literals in Core (#8472)

This commits relaxes the invariants of the Core syntax so that a
top-level variable can be bound to a primitive string literal of type
Addr#.

This commit:

* Relaxes the invatiants of the Core, and allows top-level bindings whose
  type is Addr# as long as their RHS is either a primitive string literal or
  another variable.

* Allows the simplifier and the full-laziness transformer to float out
  primitive string literals to the top leve.

* Introduces the new StgGenTopBinding type to accomodate top-level Addr#
  bindings.

* Introduces a new type of labels in the object code, with the suffix "_bytes",
  for exported top-level Addr# bindings.

* Makes some built-in rules more robust. This was necessary to keep them
  functional after the above changes.

This is a continuation of D2554.

Rebasing notes:
This had two slightly suspicious performance regressions:

* T12425: bytes allocated regressed by roughly 5%
* T4029: bytes allocated regressed by a bit over 1%
* T13035: bytes allocated regressed by a bit over 5%

These deserve additional investigation.

Rebased by: bgamari.

Test Plan: ./validate --slow

Reviewers: goldfire, trofi, simonmar, simonpj, austin, hvr, bgamari

Reviewed By: trofi, simonpj, bgamari

Subscribers: trofi, simonpj, gridaphobe, thomie

Differential Revision: https://phabricator.haskell.org/D2605

GHC Trac Issues: #8472
parent a2a67b77
......@@ -26,6 +26,7 @@ module CLabel (
mkApEntryLabel,
mkApInfoTableLabel,
mkClosureTableLabel,
mkBytesLabel,
mkLocalClosureLabel,
mkLocalInfoTableLabel,
......@@ -389,6 +390,9 @@ data IdLabelInfo
| ClosureTable -- ^ Table of closures for Enum tycons
| Bytes -- ^ Content of a string literal. See
-- Note [Bytes label].
deriving (Eq, Ord)
......@@ -474,6 +478,7 @@ mkClosureTableLabel :: Name -> CafInfo -> CLabel
mkLocalConInfoTableLabel :: CafInfo -> Name -> CLabel
mkLocalConEntryLabel :: CafInfo -> Name -> CLabel
mkConInfoTableLabel :: Name -> CafInfo -> CLabel
mkBytesLabel :: Name -> CLabel
mkClosureLabel name c = IdLabel name c Closure
mkInfoTableLabel name c = IdLabel name c InfoTable
mkEntryLabel name c = IdLabel name c Entry
......@@ -481,6 +486,7 @@ mkClosureTableLabel name c = IdLabel name c ClosureTable
mkLocalConInfoTableLabel c con = IdLabel con c ConInfoTable
mkLocalConEntryLabel c con = IdLabel con c ConEntry
mkConInfoTableLabel name c = IdLabel name c ConInfoTable
mkBytesLabel name = IdLabel name NoCafRefs Bytes
mkConEntryLabel :: Name -> CafInfo -> CLabel
mkConEntryLabel name c = IdLabel name c ConEntry
......@@ -935,6 +941,7 @@ idInfoLabelType info =
ConInfoTable -> DataLabel
ClosureTable -> DataLabel
RednCounts -> DataLabel
Bytes -> DataLabel
_ -> CodeLabel
......@@ -1056,6 +1063,11 @@ export this because in other modules we either have
* A saturated call 'Just x'; allocate using Just_con_info
Not exporting these Just_info labels reduces the number of symbols
somewhat.
Note [Bytes label]
~~~~~~~~~~~~~~~~~~
For a top-level string literal 'foo', we have just one symbol 'foo_bytes', which
points to a static data block containing the content of the literal.
-}
instance Outputable CLabel where
......@@ -1234,6 +1246,7 @@ ppIdFlavor x = pp_cSEP <>
ConEntry -> text "con_entry"
ConInfoTable -> text "con_info"
ClosureTable -> text "closure_tbl"
Bytes -> text "bytes"
)
......
......@@ -400,7 +400,7 @@ mkProfLits _ (ProfilingInfo td cd)
newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
newStringLit bytes
= do { uniq <- getUniqueM
; return (mkByteStringCLit uniq bytes) }
; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }
-- Misc utils
......
......@@ -72,7 +72,6 @@ import Cmm
import BlockId
import CLabel
import Outputable
import Unique
import DynFlags
import Util
import CodeGen.Platform
......@@ -169,13 +168,13 @@ zeroExpr dflags = CmmLit (zeroCLit dflags)
mkWordCLit :: DynFlags -> Integer -> CmmLit
mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)
mkByteStringCLit :: Unique -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
mkByteStringCLit
:: CLabel -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
-- We have to make a top-level decl for the string,
-- and return a literal pointing to it
mkByteStringCLit uniq bytes
= (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes])
mkByteStringCLit lbl bytes
= (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes])
where
lbl = mkStringLitLabel uniq
-- This can not happen for String literals (as there \NUL is replaced by
-- C0 80). However, it can happen with Addr# literals.
sec = if 0 `elem` bytes then ReadOnlyData else CString
......
......@@ -24,6 +24,7 @@ import StgCmmHpc
import StgCmmTicky
import Cmm
import CmmUtils
import CLabel
import StgSyn
......@@ -45,6 +46,7 @@ import BasicTypes
import OrdList
import MkGraph
import qualified Data.ByteString as BS
import Data.IORef
import Control.Monad (when,void)
import Util
......@@ -53,7 +55,7 @@ codeGen :: DynFlags
-> Module
-> [TyCon]
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [StgBinding] -- Bindings to convert
-> [StgTopBinding] -- Bindings to convert
-> HpcInfo
-> Stream IO CmmGroup () -- Output as a stream, so codegen can
-- be interleaved with output
......@@ -113,8 +115,8 @@ This is so that we can write the top level processing in a compositional
style, with the increasing static environment being plumbed as a state
variable. -}
cgTopBinding :: DynFlags -> StgBinding -> FCode ()
cgTopBinding dflags (StgNonRec id rhs)
cgTopBinding :: DynFlags -> StgTopBinding -> FCode ()
cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))
= do { id' <- maybeExternaliseId dflags id
; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs
; fcode
......@@ -122,7 +124,7 @@ cgTopBinding dflags (StgNonRec id rhs)
-- so we find it when we look up occurrences
}
cgTopBinding dflags (StgRec pairs)
cgTopBinding dflags (StgTopLifted (StgRec pairs))
= do { let (bndrs, rhss) = unzip pairs
; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs
; let pairs' = zip bndrs' rhss
......@@ -132,6 +134,13 @@ cgTopBinding dflags (StgRec pairs)
; sequence_ fcodes
}
cgTopBinding dflags (StgTopStringLit id str)
= do { id' <- maybeExternaliseId dflags id
; let label = mkBytesLabel (idName id')
; let (lit, decl) = mkByteStringCLit label (BS.unpack str)
; emitDecl decl
; addBindC (litIdInfo dflags id' mkLFStringLit lit)
}
cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ())
-- The Id is passed along for setting up a binding...
......
......@@ -26,6 +26,7 @@ module StgCmmClosure (
StandardFormInfo, -- ...ditto...
mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
mkLFStringLit,
lfDynTag,
maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable,
......@@ -332,6 +333,10 @@ mkLFImported id
where
arity = idFunRepArity id
-------------
mkLFStringLit :: LambdaFormInfo
mkLFStringLit = LFUnlifted
-----------------------------------------------------
-- Dynamic pointer tagging
-----------------------------------------------------
......
......@@ -40,7 +40,10 @@ import MkGraph
import Name
import Outputable
import StgSyn
import Type
import TysPrim
import UniqFM
import Util
import VarEnv
-------------------------------------
......@@ -125,8 +128,15 @@ getCgIdInfo id
-- Should be imported; make up a CgIdInfo for it
let name = idName id
; if isExternalName name then
let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
in return (litIdInfo dflags id (mkLFImported id) ext_lbl)
let ext_lbl
| isUnliftedType (idType id) =
-- An unlifted external Id must refer to a top-level
-- string literal. See Note [Bytes label] in CLabel.
ASSERT( idType id `eqType` addrPrimTy )
mkBytesLabel name
| otherwise = mkClosureLabel name $ idCafInfo id
in return $
litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl)
else
cgLookupPanic id -- Bug
}}}
......
......@@ -322,7 +322,7 @@ newStringCLit str = newByteStringCLit (map (fromIntegral . ord) str)
newByteStringCLit :: [Word8] -> FCode CmmLit
newByteStringCLit bytes
= do { uniq <- newUnique
; let (lit, decl) = mkByteStringCLit uniq bytes
; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes
; emitDecl decl
; return lit }
......
......@@ -30,6 +30,7 @@ import Bag
import Literal
import DataCon
import TysWiredIn
import TysPrim
import TcType ( isFloatingTy )
import Var
import VarEnv
......@@ -480,14 +481,25 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
-- Check the let/app invariant
-- See Note [CoreSyn let/app invariant] in CoreSyn
; checkL (not (isUnliftedType binder_ty)
|| (isNonRec rec_flag && exprOkForSpeculation rhs))
|| (isNonRec rec_flag && exprOkForSpeculation rhs)
|| exprIsLiteralString rhs)
(mkRhsPrimMsg binder rhs)
-- Check that if the binder is top-level or recursive, it's not demanded
-- Check that if the binder is top-level or recursive, it's not
-- demanded. Primitive string literals are exempt as there is no
-- computation to perform, see Note [CoreSyn top-level string literals].
; checkL (not (isStrictId binder)
|| (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
|| (isNonRec rec_flag && not (isTopLevel top_lvl_flag))
|| exprIsLiteralString 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)
(mkTopNonLitStrMsg binder)
; flags <- getLintFlags
; when (lf_check_inline_loop_breakers flags
&& isStrongLoopBreaker (idOccInfo binder)
......@@ -2033,6 +2045,10 @@ mkNonTopExternalNameMsg :: Id -> MsgDoc
mkNonTopExternalNameMsg binder
= hsep [text "Non-top-level binder has an external name:", ppr binder]
mkTopNonLitStrMsg :: Id -> MsgDoc
mkTopNonLitStrMsg binder
= hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder]
mkKindErrMsg :: TyVar -> Type -> MsgDoc
mkKindErrMsg tyvar arg_ty
= vcat [text "Kinds don't match in type application:",
......
......@@ -1168,7 +1168,9 @@ deFloatTop (Floats _ floats)
= foldrOL get [] floats
where
get (FloatLet b) bs = occurAnalyseRHSs b : bs
get b _ = pprPanic "corePrepPgm" (ppr b)
get (FloatCase var body _) bs =
occurAnalyseRHSs (NonRec var body) : bs
get b _ = pprPanic "corePrepPgm" (ppr b)
-- See Note [Dead code in CorePrep]
occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e)
......
......@@ -1339,7 +1339,7 @@ than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
-- Same deal as exprIsConApp_maybe, but much simpler
-- Nevertheless we do need to look through unfoldings for
-- Integer literals, which are vigorously hoisted to top level
-- Integer and string literals, which are vigorously hoisted to top level
-- and not subsequently inlined
exprIsLiteral_maybe env@(_, id_unf) e
= case e of
......
......@@ -191,7 +191,9 @@ These data types are the heart of the compiler
--
-- The right hand sides of all top-level and recursive @let@s
-- /must/ be of lifted type (see "Type#type_classification" for
-- the meaning of /lifted/ vs. /unlifted/).
-- the meaning of /lifted/ vs. /unlifted/). There is one exception
-- to this rule, top-level @let@s are allowed to bind primitive
-- string literals, see Note [CoreSyn top-level string literals].
--
-- See Note [CoreSyn let/app invariant]
-- See Note [Levity polymorphism invariants]
......@@ -361,6 +363,46 @@ Note [CoreSyn letrec invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See #letrec_invariant#
Note [CoreSyn top-level string literals]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As an exception to the usual rule that top-level binders must be lifted,
we allow binding primitive string literals (of type Addr#) of type Addr# at the
top level. This allows us to share string literals earlier in the pipeline and
crucially allows other optimizations in the Core2Core pipeline to fire.
Consider,
f n = let a::Addr# = "foo"#
in \x -> blah
In order to be able to inline `f`, we would like to float `a` to the top.
Another option would be to inline `a`, but that would lead to duplicating string
literals, which we want to avoid. See Trac #8472.
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.
Also see Note [Compilation plan for top-level string literals].
Note [Compilation plan for top-level string literals]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.
* 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
new top-level string literals.
* In STG, top-level string literals are explicitly represented in the syntax
tree.
* A top-level string literal may end up exported from a module. In this case,
in the object file, the content of the exported literal is given a label with
the _bytes suffix.
Note [CoreSyn let/app invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The let/app invariant
......
......@@ -29,6 +29,7 @@ module CoreUtils (
exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
exprIsBig, exprIsConLike,
rhsIsStatic, isCheapApp, isExpandableApp,
exprIsLiteralString, exprIsTopLevelBindable,
-- * Equality
cheapEqExpr, cheapEqExpr', eqExpr,
......@@ -1581,6 +1582,17 @@ tick is there to tell us that the expression was evaluated, so we
don't want to discard a seq on it.
-}
-- | Can we bind this 'CoreExpr' at the top level?
exprIsTopLevelBindable :: CoreExpr -> Bool
-- See Note [CoreSyn top-level string literals]
exprIsTopLevelBindable expr
= exprIsLiteralString expr
|| not (isUnliftedType (exprType expr))
exprIsLiteralString :: CoreExpr -> Bool
exprIsLiteralString (Lit (MachStr _)) = True
exprIsLiteralString _ = False
{-
************************************************************************
* *
......
......@@ -89,9 +89,10 @@ bcoFreeNames bco
-- Top level assembler fn.
assembleBCOs
:: HscEnv -> [ProtoBCO Name] -> [TyCon] -> Maybe ModBreaks
:: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()]
-> Maybe ModBreaks
-> IO CompiledByteCode
assembleBCOs hsc_env proto_bcos tycons modbreaks = do
assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do
itblenv <- mkITbls hsc_env tycons
bcos <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos
(bcos',ptrs) <- mallocStrings hsc_env bcos
......@@ -99,7 +100,7 @@ assembleBCOs hsc_env proto_bcos tycons modbreaks = do
{ bc_bcos = bcos'
, bc_itbls = itblenv
, bc_ffis = concat (map protoBCOFFIs proto_bcos)
, bc_strs = ptrs
, bc_strs = top_strs ++ ptrs
, bc_breaks = modbreaks
}
......
{-# LANGUAGE CPP, MagicHash, RecordWildCards #-}
{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}
{-# OPTIONS_GHC -fprof-auto-top #-}
--
-- (c) The University of Glasgow 2002-2006
......@@ -48,6 +48,7 @@ import SMRep
import Bitmap
import OrdList
import Maybes
import VarEnv
import Data.List
import Foreign
......@@ -60,6 +61,7 @@ import Control.Arrow ( second )
import Control.Exception
import Data.Array
import Data.ByteString (ByteString)
import Data.Map (Map)
import Data.IntMap (IntMap)
import qualified Data.Map as Map
......@@ -85,12 +87,18 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
= withTiming (pure dflags)
(text "ByteCodeGen"<+>brackets (ppr this_mod))
(const ()) $ do
let flatBinds = [ (bndr, simpleFreeVars rhs)
| (bndr, rhs) <- flattenBinds binds]
-- Split top-level binds into strings and others.
-- 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)
_ -> Right (bndr, simpleFreeVars rhs)
stringPtrs <- allocateTopStrings hsc_env strings
us <- mkSplitUniqSupply 'y'
(BcM_State{..}, proto_bcos) <-
runBc hsc_env us this_mod mb_modBreaks $
runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $
mapM schemeTopBind flatBinds
when (notNull ffis)
......@@ -99,7 +107,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
dumpIfSet_dyn dflags Opt_D_dump_BCOs
"Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
cbc <- assembleBCOs hsc_env proto_bcos tycs
cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs)
(case modBreaks of
Nothing -> Nothing
Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
......@@ -116,6 +124,29 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
where dflags = hsc_dflags hsc_env
allocateTopStrings
:: HscEnv
-> [(Id, ByteString)]
-> IO [(Var, RemotePtr ())]
allocateTopStrings hsc_env topStrings = do
let !(bndrs, strings) = unzip topStrings
ptrs <- iservCmd hsc_env $ MallocStrings strings
return $ zip bndrs ptrs
{-
Note [generating code for top-level string literal bindings]
Here is a summary on how the byte code generator deals with top-level string
literals:
1. Top-level string literal bindings are spearted from the rest of the module.
2. The strings are allocated via iservCmd, in allocateTopStrings
3. The mapping from binders to allocated strings (topStrings) are maintained in
BcM and used when generating code for variable references.
-}
-- -----------------------------------------------------------------------------
-- Generating byte code for an expression
......@@ -136,8 +167,8 @@ coreExprToBCOs hsc_env this_mod expr
-- the uniques are needed to generate fresh variables when we introduce new
-- let bindings for ticked expressions
us <- mkSplitUniqSupply 'y'
(BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ , proto_bco)
<- runBc hsc_env us this_mod Nothing $
(BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco)
<- runBc hsc_env us this_mod Nothing emptyVarEnv $
schemeTopBind (invented_id, simpleFreeVars expr)
when (notNull mallocd)
......@@ -1356,11 +1387,16 @@ pushAtom d p (AnnVar v)
-- slots on to the top of the stack.
| otherwise -- v must be a global variable
= do dflags <- getDynFlags
let sz :: Word16
sz = fromIntegral (idSizeW dflags v)
MASSERT(sz == 1)
return (unitOL (PUSH_G (getName v)), sz)
= do topStrings <- getTopStrings
case lookupVarEnv topStrings v of
Just ptr -> pushAtom d p $ AnnLit $ MachWord $ fromIntegral $
ptrToWordPtr $ fromRemotePtr ptr
Nothing -> do
dflags <- getDynFlags
let sz :: Word16
sz = fromIntegral (idSizeW dflags v)
MASSERT(sz == 1)
return (unitOL (PUSH_G (getName v)), sz)
pushAtom _ _ (AnnLit lit) = do
......@@ -1659,6 +1695,8 @@ data BcM_State
-- Should be free()d when it is GCd
, modBreaks :: Maybe ModBreaks -- info about breakpoints
, breakInfo :: IntMap CgBreakInfo
, topStrings :: IdEnv (RemotePtr ()) -- top-level string literals
-- See Note [generating code for top-level string literal bindings].
}
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
......@@ -1668,10 +1706,12 @@ ioToBc io = BcM $ \st -> do
x <- io
return (st, x)
runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks -> BcM r
runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks
-> IdEnv (RemotePtr ())
-> BcM r
-> IO (BcM_State, r)
runBc hsc_env us this_mod modBreaks (BcM m)
= m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty)
runBc hsc_env us this_mod modBreaks topStrings (BcM m)
= m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings)
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM expr) cont = BcM $ \st0 -> do
......@@ -1746,6 +1786,9 @@ newUnique = BcM $
getCurrentModule :: BcM Module
getCurrentModule = BcM $ \st -> return (st, thisModule st)
getTopStrings :: BcM (IdEnv (RemotePtr ()))
getTopStrings = BcM $ \st -> return (st, topStrings st)
newId :: Type -> BcM Id
newId ty = do
uniq <- newUnique
......
......@@ -1363,7 +1363,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
doCodeGen :: HscEnv -> Module -> [TyCon]
-> CollectedCCs
-> [StgBinding]
-> [StgTopBinding]
-> HpcInfo
-> IO (Stream IO CmmGroup ())
-- Note we produce a 'Stream' of CmmGroups, so that the
......@@ -1429,7 +1429,7 @@ doCodeGen hsc_env this_mod data_tycons
myCoreToStg :: DynFlags -> Module -> CoreProgram
-> IO ( [StgBinding] -- output program
-> IO ( [StgTopBinding] -- output program
, CollectedCCs) -- cost centre info (declared and used)
myCoreToStg dflags this_mod prepd_binds = do
let stg_binds
......
......@@ -987,9 +987,9 @@ builtinRules :: [CoreRule]
builtinRules
= [BuiltinRule { ru_name = fsLit "AppendLitString",
ru_fn = unpackCStringFoldrName,
ru_nargs = 4, ru_try = \_ _ _ -> match_append_lit },
ru_nargs = 4, ru_try = match_append_lit },
BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
ru_nargs = 2, ru_try = \dflags _ _ -> match_eq_string dflags },
ru_nargs = 2, ru_try = match_eq_string },
BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,
......@@ -1133,37 +1133,42 @@ builtinIntegerRules =
-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
-- = unpackFoldrCString# "foobaz" c n
match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_append_lit [Type ty1,
Lit (MachStr s1),
c1,
Var unpk `App` Type ty2
`App` Lit (MachStr s2)
`App` c2
`App` n
]
match_append_lit :: RuleFun
match_append_lit _ id_unf _
[ Type ty1
, lit1
, c1
, Var unpk `App` Type ty2
`App` lit2
`App` c2
`App` n
]
| unpk `hasKey` unpackCStringFoldrIdKey &&
c1 `cheapEqExpr` c2
, Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1
, Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2
= ASSERT( ty1 `eqType` ty2 )
Just (Var unpk `App` Type ty1
`App` Lit (MachStr (s1 `BS.append` s2))
`App` c1
`App` n)
match_append_lit _ = Nothing
match_append_lit _ _ _ _ = Nothing
---------------------------------------------------
-- The rule is this:
-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
match_eq_string :: DynFlags -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
Var unpk2 `App` Lit (MachStr s2)]
| unpk1 `hasKey` unpackCStringIdKey,
unpk2 `hasKey` unpackCStringIdKey
match_eq_string :: RuleFun
match_eq_string _ id_unf _
[Var unpk1 `App` lit1, Var unpk2 `App` lit2]
| unpk1 `hasKey` unpackCStringIdKey
, unpk2 `hasKey` unpackCStringIdKey
, Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1
, Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2
= Just (if s1 == s2 then trueValBool else falseValBool)
match_eq_string _ _ = Nothing
match_eq_string _ _ _ _ = Nothing
---------------------------------------------------
......