Commit c73d372b authored by nfrisby's avatar nfrisby

resurrected -fdicts-strict, off by default

also added -fdmd-tx-dict-sel, on by default
parent 27572589
......@@ -36,7 +36,9 @@ module DataCon (
dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
dataConRepStrictness, dataConRepBangs, dataConBoxer,
splitDataProductType_maybe,
-- ** Predicates on DataCons
isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
isVanillaDataCon, classDataCon, dataConCannotMatch,
......@@ -1086,3 +1088,41 @@ promoteKind (TyConApp tc [])
promoteKind (FunTy arg res) = FunTy (promoteKind arg) (promoteKind res)
promoteKind k = pprPanic "promoteKind" (ppr k)
\end{code}
%************************************************************************
%* *
\subsection{Splitting products}
%* *
%************************************************************************
\begin{code}
-- | Extract the type constructor, type argument, data constructor and it's
-- /representation/ argument types from a type if it is a product type.
--
-- Precisely, we return @Just@ for any type that is all of:
--
-- * Concrete (i.e. constructors visible)
--
-- * Single-constructor
--
-- * Not existentially quantified
--
-- Whether the type is a @data@ type or a @newtype@
splitDataProductType_maybe
:: Type -- ^ A product type, perhaps
-> Maybe (TyCon, -- The type constructor
[Type], -- Type args of the tycon
DataCon, -- The data constructor
[Type]) -- Its /representation/ arg types
-- Rejecing existentials is conservative. Maybe some things
-- could be made to work with them, but I'm not going to sweat
-- it through till someone finds it's important.
splitDataProductType_maybe ty
| Just (tycon, ty_args) <- splitTyConApp_maybe ty
, Just con <- isDataProductTyCon_maybe tycon
= Just (tycon, ty_args, con, dataConInstArgTys con ty_args)
| otherwise
= Nothing
\end{code}
......@@ -38,11 +38,14 @@ module Demand (
deferDmd, deferType, deferAndUse, deferEnv, modifyEnv,
splitProdDmd, splitProdDmd_maybe, peelCallDmd, mkCallDmd,
dmdTransformSig, dmdTransformDataConSig, argOneShots, argsOneShots,
dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig,
argOneShots, argsOneShots,
isSingleUsed, useType, useEnv, zapDemand, zapStrictSig,
worthSplittingFun, worthSplittingThunk
worthSplittingFun, worthSplittingThunk,
strictifyDictDmd
) where
......@@ -57,6 +60,10 @@ import Util
import BasicTypes
import Binary
import Maybes ( isJust, expectJust )
import Type ( Type )
import TyCon ( isNewTyCon, isClassTyCon )
import DataCon ( splitDataProductType_maybe )
\end{code}
%************************************************************************
......@@ -1303,6 +1310,21 @@ dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res))
go_abs 0 dmd = Just (splitUseProdDmd arity dmd)
go_abs n (UCall One u') = go_abs (n-1) u'
go_abs _ _ = Nothing
dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType
-- Like dmdTransformDataConSig, we have a special demand transformer
-- for dictionary selectors. If the selector is saturated (ie has one
-- argument: the dictionary), we feed the demand on the result into
-- the indicated dictionary component.
dmdTransformDictSelSig (StrictSig (DmdType _ [dictJd] _)) cd
= case peelCallDmd cd of
(cd',False,_) -> case splitProdDmd_maybe dictJd of
Just jds -> DmdType emptyDmdEnv [mkManyUsedDmd $ mkProdDmd $ map enhance jds] topRes
where enhance old | isAbsDmd old = old
| otherwise = mkManyUsedDmd cd'
Nothing -> panic "dmdTransformDictSelSig: split failed"
_ -> topDmdType
dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args"
\end{code}
Note [Non-full application]
......@@ -1373,6 +1395,37 @@ zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us)
zap_usg _ u = u
\end{code}
\begin{code}
-- If the argument is a used non-newtype dictionary, give it strict
-- demand. Also split the product type & demand and recur in order to
-- similarly strictify the argument's contained used non-newtype
-- superclass dictionaries. We use the demand as our recursive measure
-- to guarantee termination.
strictifyDictDmd :: Type -> Demand -> Demand
strictifyDictDmd ty dmd = case absd dmd of
Use n _ |
Just (tycon, _arg_tys, _data_con, inst_con_arg_tys)
<- splitDataProductType_maybe ty,
not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary
-> seqDmd `bothDmd` -- main idea: ensure it's strict
case splitProdDmd_maybe dmd of
-- superclass cycles should not be a problem, since the demand we are
-- consuming would also have to be infinite in order for us to diverge
Nothing -> dmd -- no components have interesting demand, so stop
-- looking for superclass dicts
Just dmds
| all (not . isAbsDmd) dmds -> evalDmd
-- abstract to strict w/ arbitrary component use, since this
-- smells like reboxing; results in CBV boxed
--
-- TODO revisit this if we ever do boxity analysis
| otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of
CD {sd = s,ud = a} -> JD (Str s) (Use n a)
-- TODO could optimize with an aborting variant of zipWith since
-- the superclass dicts are always a prefix
_ -> dmd -- unused or not a dictionary
\end{code}
%************************************************************************
%* *
......@@ -1500,4 +1553,3 @@ instance Binary CPRResult where
2 -> return NoCPR
_ -> return BotCPR
\end{code}
......@@ -479,8 +479,8 @@ zapIdStrictness :: Id -> Id
zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` topSig) id
-- | This predicate says whether the 'Id' has a strict demand placed on it or
-- has a type such that it can always be evaluated strictly (e.g., an
-- unlifted type, but see the comment for 'isStrictType'). We need to
-- has a type such that it can always be evaluated strictly (i.e an
-- unlifted type, as of GHC 7.6). We need to
-- check separately whether the 'Id' has a so-called \"strict type\" because if
-- the demand for the given @id@ hasn't been computed yet but @id@ has a strict
-- type, we still want @isStrictId id@ to be @True@.
......
......@@ -19,7 +19,6 @@ module DsCCall
, unboxArg
, boxResult
, resultWrapper
, splitDataProductType_maybe
) where
#include "HsVersions.h"
......@@ -392,43 +391,3 @@ maybeNarrow dflags tycon
&& wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
| otherwise = id
\end{code}
%************************************************************************
%* *
\subsection{Splitting products}
%* *
%************************************************************************
\begin{code}
-- | Extract the type constructor, type argument, data constructor and it's
-- /representation/ argument types from a type if it is a product type.
--
-- Precisely, we return @Just@ for any type that is all of:
--
-- * Concrete (i.e. constructors visible)
--
-- * Single-constructor
--
-- * Not existentially quantified
--
-- Whether the type is a @data@ type or a @newtype@
splitDataProductType_maybe
:: Type -- ^ A product type, perhaps
-> Maybe (TyCon, -- The type constructor
[Type], -- Type args of the tycon
DataCon, -- The data constructor
[Type]) -- Its /representation/ arg types
-- Rejecing existentials is conservative. Maybe some things
-- could be made to work with them, but I'm not going to sweat
-- it through till someone finds it's important.
splitDataProductType_maybe ty
| Just (tycon, ty_args) <- splitTyConApp_maybe ty
, Just con <- isDataProductTyCon_maybe tycon
= Just (tycon, ty_args, con, dataConInstArgTys con ty_args)
| otherwise
= Nothing
\end{code}
......@@ -308,6 +308,8 @@ data GeneralFlag
| Opt_OmitYields
| Opt_SimpleListLiterals
| Opt_FunToThunk -- allow WwLib.mkWorkerArgs to remove all value lambdas
| Opt_DictsStrict -- be strict in argument dictionaries
| Opt_DmdTxDictSel -- use a special demand transformer for dictionary selectors
-- Interface files
| Opt_IgnoreInterfacePragmas
......@@ -2590,7 +2592,9 @@ fFlags = [
( "flat-cache", Opt_FlatCache, nop ),
( "use-rpaths", Opt_RPath, nop ),
( "kill-absence", Opt_KillAbsence, nop),
( "kill-one-shot", Opt_KillOneShot, nop)
( "kill-one-shot", Opt_KillOneShot, nop),
( "dicts-strict", Opt_DictsStrict, nop ),
( "dmd-tx-dict-sel", Opt_DmdTxDictSel, nop )
]
-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
......@@ -2874,6 +2878,8 @@ optLevelFlags
, ([1,2], Opt_CmmSink)
, ([1,2], Opt_CmmElimCommonBlocks)
, ([0,1,2], Opt_DmdTxDictSel)
-- , ([2], Opt_StaticArgumentTransformation)
-- Max writes: I think it's probably best not to enable SAT with -O2 for the
-- 6.10 release. The version of SAT in HEAD at the moment doesn't incorporate
......
......@@ -23,9 +23,6 @@ module StaticFlags (
opt_PprStyle_Debug,
opt_NoDebugOutput,
-- language opts
opt_DictsStrict,
-- optimisation opts
opt_NoStateHack,
opt_CprOff,
......@@ -149,7 +146,6 @@ isStaticFlag f = f `elem` flagsStaticNames
flagsStaticNames :: [String]
flagsStaticNames = [
"fdicts-strict",
"fno-state-hack",
"fno-opt-coercion",
"fcpr-off"
......@@ -189,10 +185,6 @@ opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug")
opt_NoDebugOutput :: Bool
opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output")
-- language opts
opt_DictsStrict :: Bool
opt_DictsStrict = lookUp (fsLit "-fdicts-strict")
opt_NoStateHack :: Bool
opt_NoStateHack = lookUp (fsLit "-fno-state-hack")
......
......@@ -180,6 +180,7 @@ dmdAnal env dmd (App fun arg) -- Non-type arguments
-- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])
(res_ty `bothDmdType` arg_ty, App fun' arg')
-- this is an anonymous lambda, since @dmdAnalRhs@ uses @collectBinders@
dmdAnal env dmd (Lam var body)
| isTyVar var
= let
......@@ -195,7 +196,7 @@ dmdAnal env dmd (Lam var body)
env' = extendSigsWithLam env var
(body_ty, body') = dmdAnal env' body_dmd body
(lam_ty, var') = annotateLamIdBndr env body_ty one_shot var
(lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty one_shot var
in
(deferAndUse defer_me one_shot lam_ty, Lam var' body')
......@@ -480,6 +481,10 @@ dmdTransform env var dmd
= dmdTransformDataConSig
(idArity var) (idStrictness var) dmd
| gopt Opt_DmdTxDictSel (ae_dflags env),
Just _ <- isClassOpId_maybe var -- Dictionary component selector
= dmdTransformDictSelSig (idStrictness var) dmd
| isGlobalId var -- Imported function
= let res = dmdTransformSig (idStrictness var) dmd in
-- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])
......@@ -589,7 +594,7 @@ dmdAnalRhs top_lvl rec_flag env id rhs
(bndrs, body) = collectBinders rhs
env_body = foldl extendSigsWithLam env bndrs
(body_dmd_ty, body') = dmdAnal env_body body_dmd body
(rhs_dmd_ty, bndrs') = annotateLamBndrs env body_dmd_ty bndrs
(rhs_dmd_ty, bndrs') = annotateLamBndrs env (isDFunId id) body_dmd_ty bndrs
id' = set_idStrictness env id sig_ty
sig_ty = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res')
-- See Note [NOINLINE and strictness]
......@@ -733,6 +738,13 @@ the safe result we also have absent demand set to Abs, which makes it
possible to safely ignore non-mentioned variables (their joint demand
is <L,A>).
Note [do not strictify the argument dictionaries of a dfun]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The typechecker can tie recursive knots involving dfuns, so we do the
conservative thing and refrain from strictifying a dfun's argument
dictionaries.
\begin{code}
annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)
-- The returned env has the var deleted
......@@ -741,33 +753,41 @@ annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)
-- No effect on the argument demands
annotateBndr env dmd_ty@(DmdType fv ds res) var
| isTyVar var = (dmd_ty, var)
| otherwise = (DmdType fv' ds res, set_idDemandInfo env var dmd)
| otherwise = (DmdType fv' ds res, set_idDemandInfo env var dmd')
where
(fv', dmd) = peelFV fv var res
dmd' | gopt Opt_DictsStrict (ae_dflags env)
-- We never want to strictify a recursive let. At the moment
-- annotateBndr is only call for non-recursive lets; if that
-- changes, we need a RecFlag parameter and another guard here.
= strictifyDictDmd (idType var) dmd
| otherwise = dmd
annotateBndrs :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Var])
annotateBndrs env = mapAccumR (annotateBndr env)
annotateLamBndrs :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Var])
annotateLamBndrs env ty bndrs = mapAccumR annotate ty bndrs
annotateLamBndrs :: AnalEnv -> DFunFlag -> DmdType -> [Var] -> (DmdType, [Var])
annotateLamBndrs env args_of_dfun ty bndrs = mapAccumR annotate ty bndrs
where
annotate dmd_ty bndr
| isId bndr = annotateLamIdBndr env dmd_ty Many bndr
| isId bndr = annotateLamIdBndr env args_of_dfun dmd_ty Many bndr
| otherwise = (dmd_ty, bndr)
annotateLamIdBndr :: AnalEnv
-> DFunFlag -- is this lambda at the top of the RHS of a dfun?
-> DmdType -- Demand type of body
-> Count -- One-shot-ness of the lambda
-> Id -- Lambda binder
-> (DmdType, -- Demand type of lambda
Id) -- and binder annotated with demand
annotateLamIdBndr env _dmd_ty@(DmdType fv ds res) one_shot id
annotateLamIdBndr env arg_of_dfun _dmd_ty@(DmdType fv ds res) one_shot id
-- For lambdas we add the demand to the argument demands
-- Only called for Ids
= ASSERT( isId id )
-- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $
(final_ty, setOneShotness one_shot (set_idDemandInfo env id dmd))
(final_ty, setOneShotness one_shot (set_idDemandInfo env id dmd'))
where
-- Watch out! See note [Lambda-bound unfoldings]
final_ty = case maybeUnfoldingTemplate (idUnfolding id) of
......@@ -780,6 +800,12 @@ annotateLamIdBndr env _dmd_ty@(DmdType fv ds res) one_shot id
(fv', dmd) = peelFV fv id res
dmd' | gopt Opt_DictsStrict (ae_dflags env),
-- see Note [do not strictify the argument dictionaries of a dfun]
not arg_of_dfun
= strictifyDictDmd (idType id) dmd
| otherwise = dmd
deleteFVs :: DmdType -> [Var] -> DmdType
deleteFVs (DmdType fvs dmds res) bndrs
= DmdType (delVarEnvList fvs bndrs) dmds res
......@@ -985,13 +1011,18 @@ forget that fact, otherwise we might make 'x' absent when it isn't.
%************************************************************************
\begin{code}
type DFunFlag = Bool -- indicates if the lambda being considered is in the
-- sequence of lambdas at the top of the RHS of a dfun
notArgOfDfun :: DFunFlag
notArgOfDfun = False
data AnalEnv
= AE { ae_dflags :: DynFlags
, ae_sigs :: SigEnv
, ae_virgin :: Bool -- True on first iteration only
-- See Note [Initialising strictness]
, ae_rec_tc :: RecTcChecker
}
}
-- We use the se_env to tell us whether to
-- record info about a variable in the DmdEnv
......
......@@ -166,7 +166,6 @@ import CoAxiom
-- others
import Unique ( Unique, hasKey )
import BasicTypes ( Arity, RepArity )
import StaticFlags
import Util
import Outputable
import FastString
......@@ -1093,25 +1092,10 @@ isClosedAlgType ty
\begin{code}
-- | Computes whether an argument (or let right hand side) should
-- be computed strictly or lazily, based only on its type.
-- Works just like 'isUnLiftedType', except that it has a special case
-- for dictionaries (i.e. does not work purely on representation types)
-- Currently, it's just 'isUnLiftedType'.
-- Since it takes account of class 'PredType's, you might think
-- this function should be in 'TcType', but 'isStrictType' is used by 'DataCon',
-- which is below 'TcType' in the hierarchy, so it's convenient to put it here.
--
-- We may be strict in dictionary types, but only if it
-- has more than one component.
--
-- (Being strict in a single-component dictionary risks
-- poking the dictionary component, which is wrong.)
isStrictType :: Type -> Bool
isStrictType ty | Just ty' <- coreView ty = isStrictType ty'
isStrictType (ForAllTy _ ty) = isStrictType ty
isStrictType (TyConApp tc _)
| isUnLiftedTyCon tc = True
| isClassTyCon tc, opt_DictsStrict = True
isStrictType _ = False
isStrictType = isUnLiftedType
\end{code}
\begin{code}
......
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