diff options
author | Nicolas Frisby <nicolas.frisby@gmail.com> | 2013-07-17 10:39:25 -0500 |
---|---|---|
committer | Nicolas Frisby <nicolas.frisby@gmail.com> | 2013-09-08 01:34:28 -0500 |
commit | c73d372bfebb5acee45e196d4e8694b656c7fd82 (patch) | |
tree | fe1b5664a29944a5344204627cc7b3ace3d68b8b | |
parent | 275725892cc14fea32091b80d17b14c8cbf50e84 (diff) | |
download | haskell-c73d372bfebb5acee45e196d4e8694b656c7fd82.tar.gz |
resurrected -fdicts-strict, off by default
also added -fdmd-tx-dict-sel, on by default
-rw-r--r-- | compiler/basicTypes/DataCon.lhs | 42 | ||||
-rw-r--r-- | compiler/basicTypes/Demand.lhs | 58 | ||||
-rw-r--r-- | compiler/basicTypes/Id.lhs | 4 | ||||
-rw-r--r-- | compiler/deSugar/DsCCall.lhs | 41 | ||||
-rw-r--r-- | compiler/main/DynFlags.hs | 8 | ||||
-rw-r--r-- | compiler/main/StaticFlags.hs | 8 | ||||
-rw-r--r-- | compiler/stranal/DmdAnal.lhs | 49 | ||||
-rw-r--r-- | compiler/types/Type.lhs | 20 |
8 files changed, 147 insertions, 83 deletions
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index eba5c8b67d..51a096b10f 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -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} diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index 3e8096a272..ee4527e8fb 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -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} - diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index ccd490f0fb..c2e0c2199d 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -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@. diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index c0f5019457..6df9b674a6 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -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} - - diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 6e895d3a34..88668cb2a9 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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 diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 09d5772637..1eb01ca599 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -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") diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 0aff8ffd93..98c4083ddf 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -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 diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 5753aba0c1..9db0aaa3ee 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -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} |