Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
GHC
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
0
Merge Requests
0
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Packages & Registries
Packages & Registries
Package Registry
Container Registry
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Alex D
GHC
Commits
2bb19fad
Commit
2bb19fad
authored
Jan 17, 2014
by
Joachim Breitner
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Make worker-wrapper unbox data families
by passing the FamInstEnvs all the way down. This closes #7619.
parent
fe3740bd
Changes
7
Hide whitespace changes
Inline
Side-by-side
Showing
7 changed files
with
118 additions
and
74 deletions
+118
-74
compiler/main/HscTypes.lhs
compiler/main/HscTypes.lhs
+1
-1
compiler/simplCore/CoreMonad.lhs
compiler/simplCore/CoreMonad.lhs
+7
-1
compiler/simplCore/SimplCore.lhs
compiler/simplCore/SimplCore.lhs
+21
-6
compiler/stranal/DmdAnal.lhs
compiler/stranal/DmdAnal.lhs
+15
-8
compiler/stranal/WorkWrap.lhs
compiler/stranal/WorkWrap.lhs
+39
-36
compiler/stranal/WwLib.lhs
compiler/stranal/WwLib.lhs
+29
-22
compiler/types/Coercion.lhs
compiler/types/Coercion.lhs
+6
-0
No files found.
compiler/main/HscTypes.lhs
View file @
2bb19fad
...
...
@@ -39,7 +39,7 @@ module HscTypes (
PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
lookupIfaceByModule, emptyModIface,
PackageInstEnv, PackageRuleBase,
PackageInstEnv, Package
FamInstEnv, Package
RuleBase,
mkSOName, mkHsSOName, soExt,
...
...
compiler/simplCore/CoreMonad.lhs
View file @
2bb19fad
...
...
@@ -34,7 +34,7 @@ module CoreMonad (
-- ** Reading from the monad
getHscEnv, getRuleBase, getModule,
getDynFlags, getOrigNameCache,
getDynFlags, getOrigNameCache,
getPackageFamInstEnv,
-- ** Writing to the monad
addSimplCount,
...
...
@@ -953,6 +953,12 @@ getOrigNameCache :: CoreM OrigNameCache
getOrigNameCache = do
nameCacheRef <- fmap hsc_NC getHscEnv
liftIO $ fmap nsNames $ readIORef nameCacheRef
getPackageFamInstEnv :: CoreM PackageFamInstEnv
getPackageFamInstEnv = do
hsc_env <- getHscEnv
eps <- liftIO $ hscEPS hsc_env
return $ eps_fam_inst_env eps
\end{code}
%************************************************************************
...
...
compiler/simplCore/SimplCore.lhs
View file @
2bb19fad
...
...
@@ -36,7 +36,7 @@ import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
import Specialise ( specProgram)
import SpecConstr ( specConstrProgram)
import DmdAnal ( dmdAnalProgram )
import DmdAnal
( dmdAnalProgram )
import WorkWrap ( wwTopBinds )
import Vectorise ( vectorise )
import FastString
...
...
@@ -387,8 +387,8 @@ doCorePass _ CoreCSE = {-# SCC "CommonSubExpr" #-}
doCorePass _ CoreLiberateCase = {-# SCC "LiberateCase" #-}
doPassD liberateCase
doCorePass
dflags
CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
doPass
(floatInwards dflags)
doCorePass
_
CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
doPass
D floatInwards
doCorePass _ (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
doPassDUM (floatOutwards f)
...
...
@@ -397,10 +397,10 @@ doCorePass _ CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
doPassU doStaticArgs
doCorePass _ CoreDoStrictness = {-# SCC "NewStranal" #-}
doPassDM dmdAnalProgram
doPassD
F
M dmdAnalProgram
doCorePass
dflags
CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
doPass
U (wwTopBinds dflags)
doCorePass
_
CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
doPass
DFU wwTopBinds
doCorePass dflags CoreDoSpecialising = {-# SCC "Specialise" #-}
specProgram dflags
...
...
@@ -462,6 +462,21 @@ doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
doPassU do_pass = doPassDU (const do_pass)
doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
doPassDFM do_pass guts = do
dflags <- getDynFlags
p_fam_env <- getPackageFamInstEnv
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
doPassM (liftIO . do_pass dflags fam_envs) guts
doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
doPassDFU do_pass guts = do
dflags <- getDynFlags
us <- getUniqueSupplyM
p_fam_env <- getPackageFamInstEnv
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
doPass (do_pass dflags fam_envs us) guts
-- Most passes return no stats and don't change rules: these combinators
-- let us lift them to the full blown ModGuts+CoreM world
doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
...
...
compiler/stranal/DmdAnal.lhs
View file @
2bb19fad
...
...
@@ -31,6 +31,7 @@ import TyCon
import Type ( eqType )
-- import Pair
-- import Coercion ( coercionKind )
import FamInstEnv
import Util
import Maybes ( isJust )
import TysWiredIn ( unboxedPairDataCon )
...
...
@@ -47,8 +48,8 @@ import Data.Function ( on )
%************************************************************************
\begin{code}
dmdAnalProgram :: DynFlags -> CoreProgram -> IO CoreProgram
dmdAnalProgram dflags binds
dmdAnalProgram :: DynFlags ->
FamInstEnvs ->
CoreProgram -> IO CoreProgram
dmdAnalProgram dflags
fam_envs
binds
= do {
let { binds_plus_dmds = do_prog binds } ;
dumpIfSet_dyn dflags Opt_D_dump_strsigs "Strictness signatures" $
...
...
@@ -57,7 +58,7 @@ dmdAnalProgram dflags binds
}
where
do_prog :: CoreProgram -> CoreProgram
do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags) binds
do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags
fam_envs
) binds
-- Analyse a (group of) top-level binding(s)
dmdAnalTopBind :: AnalEnv
...
...
@@ -611,7 +612,7 @@ dmdAnalRhs top_lvl rec_flag env id rhs
-- See Note [NOINLINE and strictness]
-- See Note [Product demands for function body]
body_dmd = case deepSplitProductType_maybe (exprType body) of
body_dmd = case deepSplitProductType_maybe (
ae_fam_envs env) (
exprType body) of
Nothing -> cleanEvalDmd
Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc)
...
...
@@ -1006,6 +1007,7 @@ data AnalEnv
, ae_virgin :: Bool -- True on first iteration only
-- See Note [Initialising strictness]
, ae_rec_tc :: RecTcChecker
, ae_fam_envs :: FamInstEnvs
}
-- We use the se_env to tell us whether to
...
...
@@ -1023,9 +1025,14 @@ instance Outputable AnalEnv where
[ ptext (sLit "ae_virgin =") <+> ppr virgin
, ptext (sLit "ae_sigs =") <+> ppr env ])
emptyAnalEnv :: DynFlags -> AnalEnv
emptyAnalEnv dflags = AE { ae_dflags = dflags, ae_sigs = emptySigEnv
, ae_virgin = True, ae_rec_tc = initRecTc }
emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv
emptyAnalEnv dflags fam_envs
= AE { ae_dflags = dflags
, ae_sigs = emptySigEnv
, ae_virgin = True
, ae_rec_tc = initRecTc
, ae_fam_envs = fam_envs
}
emptySigEnv :: SigEnv
emptySigEnv = emptyVarEnv
...
...
@@ -1071,7 +1078,7 @@ extendSigsWithLam env id
, isStrictDmd (idDemandInfo id) || ae_virgin env
-- See Note [Optimistic CPR in the "virgin" case]
-- See Note [Initial CPR for strict binders]
, Just (dc,_,_,_) <- deepSplitProductType_maybe $ idType id
, Just (dc,_,_,_) <- deepSplitProductType_maybe
(ae_fam_envs env)
$ idType id
= extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc))
| otherwise
...
...
compiler/stranal/WorkWrap.lhs
View file @
2bb19fad
...
...
@@ -28,6 +28,7 @@ import Demand
import WwLib
import Util
import Outputable
import FamInstEnv
import MonadUtils
#include "HsVersions.h"
...
...
@@ -60,11 +61,11 @@ info for exported values).
\end{enumerate}
\begin{code}
wwTopBinds :: DynFlags -> UniqSupply -> CoreProgram -> CoreProgram
wwTopBinds :: DynFlags ->
FamInstEnvs ->
UniqSupply -> CoreProgram -> CoreProgram
wwTopBinds dflags us top_binds
wwTopBinds dflags
fam_envs
us top_binds
= initUs_ us $ do
top_binds' <- mapM (wwBind dflags) top_binds
top_binds' <- mapM (wwBind dflags
fam_envs
) top_binds
return (concat top_binds')
\end{code}
...
...
@@ -79,23 +80,24 @@ turn. Non-recursive case first, then recursive...
\begin{code}
wwBind :: DynFlags
-> FamInstEnvs
-> CoreBind
-> UniqSM [CoreBind] -- returns a WwBinding intermediate form;
-- the caller will convert to Expr/Binding,
-- as appropriate.
wwBind dflags (NonRec binder rhs) = do
new_rhs <- wwExpr dflags rhs
new_pairs <- tryWW dflags NonRecursive binder new_rhs
wwBind dflags
fam_envs
(NonRec binder rhs) = do
new_rhs <- wwExpr dflags
fam_envs
rhs
new_pairs <- tryWW dflags
fam_envs
NonRecursive binder new_rhs
return [NonRec b e | (b,e) <- new_pairs]
-- Generated bindings must be non-recursive
-- because the original binding was.
wwBind dflags (Rec pairs)
wwBind dflags
fam_envs
(Rec pairs)
= return . Rec <$> concatMapM do_one pairs
where
do_one (binder, rhs) = do new_rhs <- wwExpr dflags rhs
tryWW dflags Recursive binder new_rhs
do_one (binder, rhs) = do new_rhs <- wwExpr dflags
fam_envs
rhs
tryWW dflags
fam_envs
Recursive binder new_rhs
\end{code}
@wwExpr@ basically just walks the tree, looking for appropriate
...
...
@@ -104,36 +106,36 @@ matching by looking for strict arguments of the correct type.
@wwExpr@ is a version that just returns the ``Plain'' Tree.
\begin{code}
wwExpr :: DynFlags -> CoreExpr -> UniqSM CoreExpr
wwExpr :: DynFlags ->
FamInstEnvs ->
CoreExpr -> UniqSM CoreExpr
wwExpr _ e@(Type {}) = return e
wwExpr _ e@(Coercion {}) = return e
wwExpr _ e@(Lit {}) = return e
wwExpr _ e@(Var {}) = return e
wwExpr _
_
e@(Type {}) = return e
wwExpr _
_
e@(Coercion {}) = return e
wwExpr _
_
e@(Lit {}) = return e
wwExpr _
_
e@(Var {}) = return e
wwExpr dflags (Lam binder expr)
= Lam binder <$> wwExpr dflags expr
wwExpr dflags
fam_envs
(Lam binder expr)
= Lam binder <$> wwExpr dflags
fam_envs
expr
wwExpr dflags (App f a)
= App <$> wwExpr dflags f
<*> wwExpr dflag
s a
wwExpr dflags
fam_envs
(App f a)
= App <$> wwExpr dflags f
am_envs f <*> wwExpr dflags fam_env
s a
wwExpr dflags (Tick note expr)
= Tick note <$> wwExpr dflags expr
wwExpr dflags
fam_envs
(Tick note expr)
= Tick note <$> wwExpr dflags
fam_envs
expr
wwExpr dflags (Cast expr co) = do
new_expr <- wwExpr dflags expr
wwExpr dflags
fam_envs
(Cast expr co) = do
new_expr <- wwExpr dflags
fam_envs
expr
return (Cast new_expr co)
wwExpr dflags (Let bind expr)
= mkLets <$> wwBind dflags
bind <*> wwExpr dflag
s expr
wwExpr dflags
fam_envs
(Let bind expr)
= mkLets <$> wwBind dflags
fam_envs bind <*> wwExpr dflags fam_env
s expr
wwExpr dflags (Case expr binder ty alts) = do
new_expr <- wwExpr dflags expr
wwExpr dflags
fam_envs
(Case expr binder ty alts) = do
new_expr <- wwExpr dflags
fam_envs
expr
new_alts <- mapM ww_alt alts
return (Case new_expr binder ty new_alts)
where
ww_alt (con, binders, rhs) = do
new_rhs <- wwExpr dflags rhs
new_rhs <- wwExpr dflags
fam_envs
rhs
return (con, binders, new_rhs)
\end{code}
...
...
@@ -238,6 +240,7 @@ it appears in the first place in the defining module.
\begin{code}
tryWW :: DynFlags
-> FamInstEnvs
-> RecFlag
-> Id -- The fn binder
-> CoreExpr -- The bound rhs; its innards
...
...
@@ -247,7 +250,7 @@ tryWW :: DynFlags
-- the orig "wrapper" lives on);
-- if two, then a worker and a
-- wrapper.
tryWW dflags is_rec fn_id rhs
tryWW dflags
fam_envs
is_rec fn_id rhs
| isNeverActive inline_act
-- No point in worker/wrappering if the thing is never inlined!
-- Because the no-inline prag will prevent the wrapper ever
...
...
@@ -258,8 +261,8 @@ tryWW dflags is_rec fn_id rhs
| otherwise
= do
let doSplit | is_fun = splitFun dflags new_fn_id fn_info wrap_dmds res_info rhs
| is_thunk = splitThunk dflags is_rec new_fn_id rhs
let doSplit | is_fun = splitFun dflags
fam_envs
new_fn_id fn_info wrap_dmds res_info rhs
| is_thunk = splitThunk dflags
fam_envs
is_rec new_fn_id rhs
-- See Note [Thunk splitting]
| otherwise = return Nothing
try <- doSplit
...
...
@@ -309,12 +312,12 @@ checkSize dflags fn_id rhs thing_inside
inline_rule = mkInlineUnfolding Nothing rhs
---------------------
splitFun :: DynFlags -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr
splitFun :: DynFlags ->
FamInstEnvs ->
Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr
-> UniqSM (Maybe [(Id, CoreExpr)])
splitFun dflags fn_id fn_info wrap_dmds res_info rhs
splitFun dflags f
am_envs f
n_id fn_info wrap_dmds res_info rhs
= WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) do
-- The arity should match the signature
stuff <- mkWwBodies dflags fun_ty wrap_dmds res_info one_shots
stuff <- mkWwBodies dflags f
am_envs f
un_ty wrap_dmds res_info one_shots
case stuff of
Just (work_demands, wrap_fn, work_fn) -> do
work_uniq <- getUniqueM
...
...
@@ -449,9 +452,9 @@ then the splitting will go deeper too.
-- --> x = let x = e in
-- case x of (a,b) -> let x = (a,b) in x
splitThunk :: DynFlags -> RecFlag -> Var -> Expr Var -> UniqSM (Maybe [(Var, Expr Var)])
splitThunk dflags is_rec fn_id rhs = do
(useful,_, wrap_fn, work_fn) <- mkWWstr dflags [fn_id]
splitThunk :: DynFlags ->
FamInstEnvs ->
RecFlag -> Var -> Expr Var -> UniqSM (Maybe [(Var, Expr Var)])
splitThunk dflags
fam_envs
is_rec fn_id rhs = do
(useful,_, wrap_fn, work_fn) <- mkWWstr dflags
fam_envs
[fn_id]
let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive
return (Just res)
...
...
compiler/stranal/WwLib.lhs
View file @
2bb19fad
...
...
@@ -23,6 +23,7 @@ import TysPrim ( voidPrimTy )
import TysWiredIn ( tupleCon )
import Type
import Coercion hiding ( substTy, substTyVarBndr )
import FamInstEnv
import BasicTypes ( TupleSort(..), OneShotInfo(..), worstOneShot )
import Literal ( absentLiteralOf )
import TyCon
...
...
@@ -105,6 +106,7 @@ the unusable strictness-info into the interfaces.
\begin{code}
mkWwBodies :: DynFlags
-> FamInstEnvs
-> Type -- Type of original function
-> [Demand] -- Strictness of original function
-> DmdResult -- Info about function result
...
...
@@ -124,14 +126,14 @@ mkWwBodies :: DynFlags
-- let x = (a,b) in
-- E
mkWwBodies dflags fun_ty demands res_info one_shots
mkWwBodies dflags f
am_envs f
un_ty demands res_info one_shots
= do { let arg_info = demands `zip` (one_shots ++ repeat NoOneShotInfo)
all_one_shots = foldr (worstOneShot . snd) OneShotLam arg_info
; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs emptyTvSubst fun_ty arg_info
; (useful1, work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags wrap_args
; (useful1, work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags
fam_envs
wrap_args
-- Do CPR w/w. See Note [Always do CPR w/w]
; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) <- mkWWcpr res_ty res_info
; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) <- mkWWcpr
fam_envs
res_ty res_info
; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args all_one_shots cpr_res_ty
worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]
...
...
@@ -371,6 +373,7 @@ That's why we carry the TvSubst through mkWWargs
\begin{code}
mkWWstr :: DynFlags
-> FamInstEnvs
-> [Var] -- Wrapper args; have their demand info on them
-- *Includes type variables*
-> UniqSM (Bool, -- Is this useful
...
...
@@ -382,12 +385,12 @@ mkWWstr :: DynFlags
CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function,
-- and lacking its lambdas.
-- This fn does the reboxing
mkWWstr _ []
mkWWstr _
_
[]
= return (False, [], nop_fn, nop_fn)
mkWWstr dflags (arg : args) = do
(useful1, args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags arg
(useful2, args2, wrap_fn2, work_fn2) <- mkWWstr dflags args
mkWWstr dflags
fam_envs
(arg : args) = do
(useful1, args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags
fam_envs
arg
(useful2, args2, wrap_fn2, work_fn2) <- mkWWstr dflags
fam_envs
args
return (useful1 || useful2, args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
\end{code}
...
...
@@ -426,8 +429,9 @@ as-yet-un-filled-in pkgState files.
-- brings into scope work_args (via cases)
-- * work_fn assumes work_args are in scope, a
-- brings into scope wrap_arg (via lets)
mkWWstr_one :: DynFlags -> Var -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one dflags arg
mkWWstr_one :: DynFlags -> FamInstEnvs -> Var
-> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one dflags fam_envs arg
| isTyVar arg
= return (False, [arg], nop_fn, nop_fn)
...
...
@@ -463,7 +467,7 @@ mkWWstr_one dflags arg
, Just cs <- splitProdDmd_maybe dmd
-- See Note [Unpacking arguments with product and polymorphic demands]
, Just (data_con, inst_tys, inst_con_arg_tys, co)
<- deepSplitProductType_maybe (idType arg)
<- deepSplitProductType_maybe
fam_envs
(idType arg)
, cs `equalLength` inst_con_arg_tys
-- See Note [mkWWstr and unsafeCoerce]
= do { (uniq1:uniqs) <- getUniquesM
...
...
@@ -473,7 +477,7 @@ mkWWstr_one dflags arg
data_con unpk_args
rebox_fn = Let (NonRec arg con_app)
con_app = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags unpk_args_w_ds
; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags
fam_envs
unpk_args_w_ds
; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
-- Don't pass the arg, rebox instead
...
...
@@ -503,29 +507,31 @@ If so, the worker/wrapper split doesn't work right and we get a Core Lint
bug. The fix here is simply to decline to do w/w if that happens.
\begin{code}
deepSplitProductType_maybe :: Type -> Maybe (DataCon, [Type], [Type], Coercion)
deepSplitProductType_maybe ::
FamInstEnvs ->
Type -> Maybe (DataCon, [Type], [Type], Coercion)
-- If deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)
-- then dc @ tys (args::arg_tys) :: rep_ty
-- co :: ty ~ rep_ty
deepSplitProductType_maybe ty
| let (co, ty1) = topNormaliseNewType_maybe ty `orElse` (mkReflCo Representational ty, ty)
deepSplitProductType_maybe fam_envs ty
| let (co, ty1) = topNormaliseType_maybe fam_envs ty
`orElse` (mkReflCo Representational ty, ty)
, Just (tc, tc_args) <- splitTyConApp_maybe ty1
, Just con <- isDataProductTyCon_maybe tc
= Just (con, tc_args, dataConInstArgTys con tc_args, co)
deepSplitProductType_maybe _ = Nothing
deepSplitProductType_maybe _
_
= Nothing
deepSplitCprType_maybe :: ConTag -> Type -> Maybe (DataCon, [Type], [Type], Coercion)
deepSplitCprType_maybe ::
FamInstEnvs ->
ConTag -> Type -> Maybe (DataCon, [Type], [Type], Coercion)
-- If deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co)
-- then dc @ tys (args::arg_tys) :: rep_ty
-- co :: ty ~ rep_ty
deepSplitCprType_maybe con_tag ty
| let (co, ty1) = topNormaliseNewType_maybe ty `orElse` (mkReflCo Representational ty, ty)
deepSplitCprType_maybe fam_envs con_tag ty
| let (co, ty1) = topNormaliseType_maybe fam_envs ty
`orElse` (mkReflCo Representational ty, ty)
, Just (tc, tc_args) <- splitTyConApp_maybe ty1
, isDataTyCon tc
, let cons = tyConDataCons tc
con = ASSERT( cons `lengthAtLeast` con_tag ) cons !! (con_tag - fIRST_TAG)
= Just (con, tc_args, dataConInstArgTys con tc_args, co)
deepSplitCprType_maybe _ _ = Nothing
deepSplitCprType_maybe _ _
_
= Nothing
\end{code}
...
...
@@ -546,17 +552,18 @@ left-to-right traversal of the result structure.
\begin{code}
mkWWcpr :: Type -- function body type
mkWWcpr :: FamInstEnvs
-> Type -- function body type
-> DmdResult -- CPR analysis results
-> UniqSM (Bool, -- Is w/w'ing useful?
CoreExpr -> CoreExpr, -- New wrapper
CoreExpr -> CoreExpr, -- New worker
Type) -- Type of worker's body
mkWWcpr body_ty res
mkWWcpr
fam_envs
body_ty res
= case returnsCPR_maybe res of
Nothing -> return (False, id, id, body_ty) -- No CPR info
Just con_tag | Just stuff <- deepSplitCprType_maybe con_tag body_ty
Just con_tag | Just stuff <- deepSplitCprType_maybe
fam_envs
con_tag body_ty
-> mkWWcpr_help stuff
| otherwise
-- See Note [non-algebraic or open body type warning]
...
...
compiler/types/Coercion.lhs
View file @
2bb19fad
...
...
@@ -1185,6 +1185,12 @@ topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)
--
-- The function returns @Nothing@ for non-@newtypes@,
-- or unsaturated applications
--
-- This function does *not* look through type families, because it has no access to
-- the type family environment. If you do have that at hand, consider to use
-- topNormaliseType_maybe, which should be a drop-in replacement for
-- topNormaliseNewType_maybe
--
topNormaliseNewType_maybe ty
= go initRecTc Nothing ty
where
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment