resurrected -fdicts-strict, off by default

also added -fdmd-tx-dict-sel, on by default

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}

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}
-

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@.

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}
-
-

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

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")
 

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

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}