module CorePrep (
corePrepPgm, corePrepExpr, cvtLitInteger,
lookupMkIntegerName, lookupIntegerSDataConName
) where
#include "HsVersions.h"
import OccurAnal
import HscTypes
import PrelNames
import CoreUtils
import CoreArity
import CoreFVs
import CoreMonad ( CoreToDo(..) )
import CoreLint ( endPassIO )
import CoreSyn
import CoreSubst
import MkCore hiding( FloatBind(..) )
import Type
import Literal
import Coercion
import TcEnv
import TcRnMonad
import TyCon
import Demand
import Var
import VarSet
import VarEnv
import Id
import IdInfo
import TysWiredIn
import DataCon
import PrimOp
import BasicTypes
import Module
import UniqSupply
import Maybes
import OrdList
import ErrUtils
import DynFlags
import Util
import Pair
import Outputable
import Platform
import FastString
import Config
import Name ( NamedThing(..), nameSrcSpan )
import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
import Data.Bits
import Data.List ( mapAccumL )
import Control.Monad
type CpeTriv = CoreExpr
type CpeApp = CoreExpr
type CpeBody = CoreExpr
type CpeRhs = CoreExpr
corePrepPgm :: HscEnv -> ModLocation -> CoreProgram -> [TyCon] -> IO CoreProgram
corePrepPgm hsc_env mod_loc binds data_tycons = do
let dflags = hsc_dflags hsc_env
showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
let implicit_binds = mkDataConWorkers dflags mod_loc data_tycons
binds_out = initUs_ us $ do
floats1 <- corePrepTopBinds initialCorePrepEnv binds
floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
return (deFloatTop (floats1 `appendFloats` floats2))
endPassIO hsc_env alwaysQualify CorePrep binds_out []
return binds_out
corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr dflags hsc_env expr = do
showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)
dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
return new_expr
corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats
corePrepTopBinds initialCorePrepEnv binds
= go initialCorePrepEnv binds
where
go _ [] = return emptyFloats
go env (bind : binds) = do (env', bind') <- cpeBind TopLevel env bind
binds' <- go env' binds
return (bind' `appendFloats` binds')
mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]
mkDataConWorkers dflags mod_loc data_tycons
= [ NonRec id (tick_it (getName data_con) (Var id))
| tycon <- data_tycons,
data_con <- tyConDataCons tycon,
let id = dataConWorkId data_con
]
where
tick_it name
| not (gopt Opt_Debug dflags) = id
| RealSrcSpan span <- nameSrcSpan name = tick span
| Just file <- ml_hs_file mod_loc = tick (span1 file)
| otherwise = tick (span1 "???")
where tick span = Tick (SourceNote span $ showSDoc dflags (ppr name))
span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1
cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
-> UniqSM (CorePrepEnv, Floats)
cpeBind top_lvl env (NonRec bndr rhs)
= do { (_, bndr1) <- cpCloneBndr env bndr
; let dmd = idDemandInfo bndr
is_unlifted = isUnLiftedType (idType bndr)
; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive
dmd
is_unlifted
env bndr1 rhs
; let new_float = mkFloat dmd is_unlifted bndr2 rhs2
; return (extendCorePrepEnv env bndr bndr2,
addFloat floats new_float) }
cpeBind top_lvl env (Rec pairs)
= do { let (bndrs,rhss) = unzip pairs
; (env', bndrs1) <- cpCloneBndrs env (map fst pairs)
; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') bndrs1 rhss
; let (floats_s, bndrs2, rhss2) = unzip3 stuff
all_pairs = foldrOL add_float (bndrs2 `zip` rhss2)
(concatFloats floats_s)
; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
unitFloat (FloatLet (Rec all_pairs))) }
where
add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
add_float b _ = pprPanic "cpeBind" (ppr b)
cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool
-> CorePrepEnv -> Id -> CoreExpr
-> UniqSM (Floats, Id, CpeRhs)
cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
= do { (floats1, rhs1) <- cpeRhsE env rhs
; (floats2, rhs2) <- float_from_rhs floats1 rhs1
; (floats3, rhs3)
<- if manifestArity rhs1 <= arity
then return (floats2, cpeEtaExpand arity rhs2)
else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
(do { v <- newVar (idType bndr)
; let float = mkFloat topDmd False v rhs2
; return ( addFloat floats2 float
, cpeEtaExpand arity (Var v)) })
; let (floats4, rhs4) = wrapTicks floats3 rhs3
; let bndr' | exprIsHNF rhs3 = bndr `setIdUnfolding` evaldUnfolding
| otherwise = bndr `setIdUnfolding` noUnfolding
; return (floats4, bndr', rhs4) }
where
is_strict_or_unlifted = (isStrictDmd dmd) || is_unlifted
platform = targetPlatform (cpe_dynFlags env)
arity = idArity bndr
float_from_rhs floats rhs
| isEmptyFloats floats = return (emptyFloats, rhs)
| isTopLevel top_lvl = float_top floats rhs
| otherwise = float_nested floats rhs
float_nested floats rhs
| wantFloatNested is_rec is_strict_or_unlifted floats rhs
= return (floats, rhs)
| otherwise = dont_float floats rhs
float_top floats rhs
| mayHaveCafRefs (idCafInfo bndr)
, allLazyTop floats
= return (floats, rhs)
| Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs
= return (floats', rhs')
| otherwise
= dont_float floats rhs
dont_float floats rhs
= do { body <- rhsToBodyNF rhs
; return (emptyFloats, wrapBinds floats body) }
cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr)
cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
cpeRhsE env (Lit (LitInteger i _))
= cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)
(cpe_integerSDataCon env) i)
cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
cpeRhsE env expr@(Var {}) = cpeApp env expr
cpeRhsE env (Var f `App` _ `App` arg)
| f `hasKey` lazyIdKey
= cpeRhsE env arg
cpeRhsE env expr@(App {}) = cpeApp env expr
cpeRhsE env (Let bind expr)
= do { (env', new_binds) <- cpeBind NotTopLevel env bind
; (floats, body) <- cpeRhsE env' expr
; return (new_binds `appendFloats` floats, body) }
cpeRhsE env (Tick tickish expr)
| tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope
= do { (floats, body) <- cpeRhsE env expr
; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }
| otherwise
= do { body <- cpeBodyNF env expr
; return (emptyFloats, mkTick tickish' body) }
where
tickish' | Breakpoint n fvs <- tickish
= Breakpoint n (map (lookupCorePrepEnv env) fvs)
| otherwise
= tickish
cpeRhsE env (Cast expr co)
= do { (floats, expr') <- cpeRhsE env expr
; return (floats, Cast expr' co) }
cpeRhsE env expr@(Lam {})
= do { let (bndrs,body) = collectBinders expr
; (env', bndrs') <- cpCloneBndrs env bndrs
; body' <- cpeBodyNF env' body
; return (emptyFloats, mkLams bndrs' body') }
cpeRhsE env (Case scrut bndr ty alts)
= do { (floats, scrut') <- cpeBody env scrut
; let bndr1 = bndr `setIdUnfolding` evaldUnfolding
; (env', bndr2) <- cpCloneBndr env bndr1
; alts' <- mapM (sat_alt env') alts
; return (floats, Case scrut' bndr2 ty alts') }
where
sat_alt env (con, bs, rhs)
= do { (env2, bs') <- cpCloneBndrs env bs
; rhs' <- cpeBodyNF env2 rhs
; return (con, bs', rhs') }
cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr
cvtLitInteger dflags _ (Just sdatacon) i
| inIntRange dflags i
= mkConApp sdatacon [Lit (mkMachInt dflags i)]
cvtLitInteger dflags mk_integer _ i
= mkApps (Var mk_integer) [isNonNegative, ints]
where isNonNegative = if i < 0 then mkConApp falseDataCon []
else mkConApp trueDataCon []
ints = mkListExpr intTy (f (abs i))
f 0 = []
f x = let low = x .&. mask
high = x `shiftR` bits
in mkConApp intDataCon [Lit (mkMachInt dflags low)] : f high
bits = 31
mask = 2 ^ bits 1
cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
cpeBodyNF env expr
= do { (floats, body) <- cpeBody env expr
; return (wrapBinds floats body) }
cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
cpeBody env expr
= do { (floats1, rhs) <- cpeRhsE env expr
; (floats2, body) <- rhsToBody rhs
; return (floats1 `appendFloats` floats2, body) }
rhsToBodyNF :: CpeRhs -> UniqSM CpeBody
rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs
; return (wrapBinds floats body) }
rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
rhsToBody (Tick t expr)
| tickishScoped t == NoScope
= do { (floats, expr') <- rhsToBody expr
; return (floats, mkTick t expr') }
rhsToBody (Cast e co)
= do { (floats, e') <- rhsToBody e
; return (floats, Cast e' co) }
rhsToBody expr@(Lam {})
| Just no_lam_result <- tryEtaReducePrep bndrs body
= return (emptyFloats, no_lam_result)
| all isTyVar bndrs
= return (emptyFloats, expr)
| otherwise
= do { fn <- newVar (exprType expr)
; let rhs = cpeEtaExpand (exprArity expr) expr
float = FloatLet (NonRec fn rhs)
; return (unitFloat float, Var fn) }
where
(bndrs,body) = collectBinders expr
rhsToBody expr = return (emptyFloats, expr)
cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
cpeApp env expr
= do { (app, (head,depth), _, floats, ss) <- collect_args expr 0
; MASSERT(null ss)
; case head of
Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth
; return (floats, sat_app) }
_other -> return (floats, app) }
where
collect_args
:: CoreExpr
-> Int
-> UniqSM (CpeApp,
(CoreExpr,Int),
Type,
Floats,
[Demand])
collect_args (App fun arg@(Type arg_ty)) depth
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
collect_args (App fun arg@(Coercion arg_co)) depth
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) }
collect_args (App fun arg) depth
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
; let
(ss1, ss_rest) = case ss of
(ss1:ss_rest) -> (ss1, ss_rest)
[] -> (topDmd, [])
(arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
splitFunTy_maybe fun_ty
; (fs, arg') <- cpeArg env ss1 arg arg_ty
; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) }
collect_args (Var v) depth
= do { v1 <- fiddleCCall v
; let v2 = lookupCorePrepEnv env v1
; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
where
stricts = case idStrictness v of
StrictSig (DmdType _ demands _)
| listLengthCmp demands depth /= GT -> demands
| otherwise -> []
collect_args (Cast fun co) depth
= do { let Pair _ty1 ty2 = coercionKind co
; (fun', hd, _, floats, ss) <- collect_args fun depth
; return (Cast fun' co, hd, ty2, floats, ss) }
collect_args (Tick tickish fun) depth
| tickishPlace tickish == PlaceNonLam
&& tickish `tickishScopesLike` SoftScope
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
; return (fun',hd,fun_ty,addFloat floats (FloatTick tickish),ss) }
collect_args fun depth
= do { (fun_floats, fun') <- cpeArg env evalDmd fun ty
; return (fun', (fun', depth), ty, fun_floats, []) }
where
ty = exprType fun
cpeArg :: CorePrepEnv -> Demand
-> CoreArg -> Type -> UniqSM (Floats, CpeTriv)
cpeArg env dmd arg arg_ty
= do { (floats1, arg1) <- cpeRhsE env arg
; (floats2, arg2) <- if want_float floats1 arg1
then return (floats1, arg1)
else do { body1 <- rhsToBodyNF arg1
; return (emptyFloats, wrapBinds floats1 body1) }
; if cpe_ExprIsTrivial arg2
then return (floats2, arg2)
else do
{ v <- newVar arg_ty
; let arg3 = cpeEtaExpand (exprArity arg2) arg2
arg_float = mkFloat dmd is_unlifted v arg3
; return (addFloat floats2 arg_float, varToCoreExpr v) } }
where
is_unlifted = isUnLiftedType arg_ty
is_strict = isStrictDmd dmd
want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
maybeSaturate fn expr n_args
| Just DataToTagOp <- isPrimOpId_maybe fn
= saturateDataToTag sat_expr
| hasNoBinding fn
= return sat_expr
| otherwise
= return expr
where
fn_arity = idArity fn
excess_arity = fn_arity n_args
sat_expr = cpeEtaExpand excess_arity expr
saturateDataToTag :: CpeApp -> UniqSM CpeApp
saturateDataToTag sat_expr
= do { let (eta_bndrs, eta_body) = collectBinders sat_expr
; eta_body' <- eval_data2tag_arg eta_body
; return (mkLams eta_bndrs eta_body') }
where
eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
eval_data2tag_arg app@(fun `App` arg)
| exprIsHNF arg
= return app
| otherwise
= do { arg_id <- newVar (exprType arg)
; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
; return (Case arg arg_id1 (exprType app)
[(DEFAULT, [], fun `App` Var arg_id1)]) }
eval_data2tag_arg (Tick t app)
= do { app' <- eval_data2tag_arg app
; return (Tick t app') }
eval_data2tag_arg other
= pprPanic "eval_data2tag" (ppr other)
cpe_ExprIsTrivial :: CoreExpr -> Bool
cpe_ExprIsTrivial (Var _) = True
cpe_ExprIsTrivial (Type _) = True
cpe_ExprIsTrivial (Coercion _) = True
cpe_ExprIsTrivial (Lit _) = True
cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e
cpe_ExprIsTrivial (Tick t e) = not (tickishIsCode t) && cpe_ExprIsTrivial e
cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e
cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
cpe_ExprIsTrivial _ = False
cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
cpeEtaExpand arity expr
| arity == 0 = expr
| otherwise = etaExpand arity expr
tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
tryEtaReducePrep bndrs expr@(App _ _)
| ok_to_eta_reduce f
, n_remaining >= 0
, and (zipWith ok bndrs last_args)
, not (any (`elemVarSet` fvs_remaining) bndrs)
, exprIsHNF remaining_expr
= Just remaining_expr
where
(f, args) = collectArgs expr
remaining_expr = mkApps f remaining_args
fvs_remaining = exprFreeVars remaining_expr
(remaining_args, last_args) = splitAt n_remaining args
n_remaining = length args length bndrs
ok bndr (Var arg) = bndr == arg
ok _ _ = False
ok_to_eta_reduce (Var f) = not (hasNoBinding f)
ok_to_eta_reduce _ = False
tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
| not (any (`elemVarSet` fvs) bndrs)
= case tryEtaReducePrep bndrs body of
Just e -> Just (Let bind e)
Nothing -> Nothing
where
fvs = exprFreeVars r
tryEtaReducePrep bndrs (Tick tickish e)
= fmap (mkTick tickish) $ tryEtaReducePrep bndrs e
tryEtaReducePrep _ _ = Nothing
data FloatingBind
= FloatLet CoreBind
| FloatCase
Id CpeBody
Bool
| FloatTick (Tickish Id)
data Floats = Floats OkToSpec (OrdList FloatingBind)
instance Outputable FloatingBind where
ppr (FloatLet b) = ppr b
ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r
ppr (FloatTick t) = ppr t
instance Outputable Floats where
ppr (Floats flag fs) = ptext (sLit "Floats") <> brackets (ppr flag) <+>
braces (vcat (map ppr (fromOL fs)))
instance Outputable OkToSpec where
ppr OkToSpec = ptext (sLit "OkToSpec")
ppr IfUnboxedOk = ptext (sLit "IfUnboxedOk")
ppr NotOkToSpec = ptext (sLit "NotOkToSpec")
data OkToSpec
= OkToSpec
| IfUnboxedOk
| NotOkToSpec
mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind
mkFloat dmd is_unlifted bndr rhs
| use_case = FloatCase bndr rhs (exprOkForSpeculation rhs)
| is_hnf = FloatLet (NonRec bndr rhs)
| otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)
where
is_hnf = exprIsHNF rhs
is_strict = isStrictDmd dmd
use_case = is_unlifted || is_strict && not is_hnf
emptyFloats :: Floats
emptyFloats = Floats OkToSpec nilOL
isEmptyFloats :: Floats -> Bool
isEmptyFloats (Floats _ bs) = isNilOL bs
wrapBinds :: Floats -> CpeBody -> CpeBody
wrapBinds (Floats _ binds) body
= foldrOL mk_bind body binds
where
mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
mk_bind (FloatLet bind) body = Let bind body
mk_bind (FloatTick tickish) body = mkTick tickish body
addFloat :: Floats -> FloatingBind -> Floats
addFloat (Floats ok_to_spec floats) new_float
= Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
where
check (FloatLet _) = OkToSpec
check (FloatCase _ _ ok_for_spec)
| ok_for_spec = IfUnboxedOk
| otherwise = NotOkToSpec
check FloatTick{} = OkToSpec
unitFloat :: FloatingBind -> Floats
unitFloat = addFloat emptyFloats
appendFloats :: Floats -> Floats -> Floats
appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
= Floats (combine spec1 spec2) (floats1 `appOL` floats2)
concatFloats :: [Floats] -> OrdList FloatingBind
concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
combine :: OkToSpec -> OkToSpec -> OkToSpec
combine NotOkToSpec _ = NotOkToSpec
combine _ NotOkToSpec = NotOkToSpec
combine IfUnboxedOk _ = IfUnboxedOk
combine _ IfUnboxedOk = IfUnboxedOk
combine _ _ = OkToSpec
deFloatTop :: Floats -> [CoreBind]
deFloatTop (Floats _ floats)
= foldrOL get [] floats
where
get (FloatLet b) bs = occurAnalyseRHSs b : bs
get b _ = pprPanic "corePrepPgm" (ppr b)
occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e)
occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes]
canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
| OkToSpec <- ok_to_spec
, Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
= Just (Floats OkToSpec fs', subst_expr subst rhs)
| otherwise
= Nothing
where
subst_expr = substExpr (text "CorePrep")
go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
-> Maybe (Subst, OrdList FloatingBind)
go (subst, fbs_out) [] = Just (subst, fbs_out)
go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)
| rhs_ok r
= go (subst', fbs_out `snocOL` new_fb) fbs_in
where
(subst', b') = set_nocaf_bndr subst b
new_fb = FloatLet (NonRec b' (subst_expr subst r))
go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)
| all rhs_ok rs
= go (subst', fbs_out `snocOL` new_fb) fbs_in
where
(bs,rs) = unzip prs
(subst', bs') = mapAccumL set_nocaf_bndr subst bs
rs' = map (subst_expr subst') rs
new_fb = FloatLet (Rec (bs' `zip` rs'))
go (subst, fbs_out) (ft@FloatTick{} : fbs_in)
= go (subst, fbs_out `snocOL` ft) fbs_in
go _ _ = Nothing
set_nocaf_bndr subst bndr
= (extendIdSubst subst bndr (Var bndr'), bndr')
where
bndr' = bndr `setIdCafInfo` NoCafRefs
rhs_ok :: CoreExpr -> Bool
rhs_ok = rhsIsStatic platform (\_ -> False)
(\i -> pprPanic "rhsIsStatic" (integer i))
wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
wantFloatNested is_rec strict_or_unlifted floats rhs
= isEmptyFloats floats
|| strict_or_unlifted
|| (allLazyNested is_rec floats && exprIsHNF rhs)
allLazyTop :: Floats -> Bool
allLazyTop (Floats OkToSpec _) = True
allLazyTop _ = False
allLazyNested :: RecFlag -> Floats -> Bool
allLazyNested _ (Floats OkToSpec _) = True
allLazyNested _ (Floats NotOkToSpec _) = False
allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
data CorePrepEnv = CPE {
cpe_dynFlags :: DynFlags,
cpe_env :: (IdEnv Id),
cpe_mkIntegerId :: Id,
cpe_integerSDataCon :: Maybe DataCon
}
lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id
lookupMkIntegerName dflags hsc_env
= guardIntegerUse dflags $ liftM tyThingId $
initTcForLookup hsc_env (tcLookupGlobal mkIntegerName)
lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of
IntegerGMP -> guardIntegerUse dflags $ liftM Just $
initTcForLookup hsc_env (tcLookupDataCon integerSDataConName)
IntegerGMP2-> guardIntegerUse dflags $ liftM Just $
initTcForLookup hsc_env (tcLookupDataCon integerSDataConName)
IntegerSimple -> return Nothing
guardIntegerUse :: DynFlags -> IO a -> IO a
guardIntegerUse dflags act
| thisPackage dflags == primPackageKey
= return $ panic "Can't use Integer in ghc-prim"
| thisPackage dflags == integerPackageKey
= return $ panic "Can't use Integer in integer-*"
| otherwise = act
mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv dflags hsc_env
= do mkIntegerId <- lookupMkIntegerName dflags hsc_env
integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
return $ CPE {
cpe_dynFlags = dflags,
cpe_env = emptyVarEnv,
cpe_mkIntegerId = mkIntegerId,
cpe_integerSDataCon = integerSDataCon
}
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv cpe id id'
= cpe { cpe_env = extendVarEnv (cpe_env cpe) id id' }
extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
extendCorePrepEnvList cpe prs
= cpe { cpe_env = extendVarEnvList (cpe_env cpe) prs }
lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
lookupCorePrepEnv cpe id
= case lookupVarEnv (cpe_env cpe) id of
Nothing -> id
Just id' -> id'
getMkIntegerId :: CorePrepEnv -> Id
getMkIntegerId = cpe_mkIntegerId
cpCloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs
cpCloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
cpCloneBndr env bndr
| isLocalId bndr, not (isCoVar bndr)
= do bndr' <- setVarUnique bndr <$> getUniqueM
let bndr'' = bndr' `setIdUnfolding` noUnfolding
`setIdSpecialisation` emptySpecInfo
return (extendCorePrepEnv env bndr bndr'', bndr'')
| otherwise
= return (env, bndr)
fiddleCCall :: Id -> UniqSM Id
fiddleCCall id
| isFCallId id = (id `setVarUnique`) <$> getUniqueM
| otherwise = return id
newVar :: Type -> UniqSM Id
newVar ty
= seqType ty `seq` do
uniq <- getUniqueM
return (mkSysLocal (fsLit "sat") uniq ty)
wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
wrapTicks (Floats flag floats0) expr = (Floats flag floats1, expr')
where (floats1, expr') = foldrOL go (nilOL, expr) floats0
go (FloatTick t) (fs, e) = ASSERT(tickishPlace t == PlaceNonLam)
(mapOL (wrap t) fs, mkTick t e)
go other (fs, e) = (other `consOL` fs, e)
wrap t (FloatLet bind) = FloatLet (wrapBind t bind)
wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok
wrap _ other = pprPanic "wrapTicks: unexpected float!"
(ppr other)
wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)
wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs)