From 54d9697947a82a8630c6fcde54c6bc25bc4a6af7 Mon Sep 17 00:00:00 2001
From: Joachim Breitner <mail@joachimbreitner.de>
Date: Thu, 9 Jan 2014 10:37:29 +0000
Subject: [PATCH] Try to make "<S>t" meaningful
MIMEVersion: 1.0
ContentType: text/plain; charset=UTF8
ContentTransferEncoding: 8bit
by giving it the meaning: "Assuming my first argument is terminating,
then I am terminating".
In pictures: This is the lattice, which is not a simple product lattice any more:
 <L><L>
/  \ \
/  <L><L>t \
<S><L>  <S><L>
 \ \    \
 \ <S><L>t  /  <S><L>t
 \  / 
\ \  / 
\  <S><S> 
\  \ 
\  <S><S>t /
\  /
⊥/
This means that we need to be careful when lub’ing: If one branch is lazy, but
not absent in an argument or free variable, and the other branch is strict,
then even if both branches claim to terminate, we need to remove the
termination flag (as one had the termination under a stronger hypothesis as the
hole result) (Feels inelegant.)
There is no unit for lubDmdType any more. So for case, use we use botDmdType
for no alternatives, and foldr1 if there are multiple.
Unlifted variables (e.g. Int#) are tricky. Everything is strict in them, so for
an *unlifted* argument, <L>t implies <S>t and hence <S>t ⊔ <L>t = <S>t, and we
really want to make use of that stronger equation. But when lub’ing, we don’t
know any more if this is the demand for an unlifted type. So instead, the
demand type of x :: Int# itself is {x ↦ <L>} t, while x :: Int continues to
have type {x ↦ <S>} t.
It is important that functions (including primitive operations and constructors
like I#) have a strict demand on their unlifted argument. But it turned out to
be easier to enforce this in the demand analyser: So even if f claims to have a
lazy demand on a argument of unlifted type, we make this demand strict before
feeding it into the argument.

compiler/basicTypes/Demand.lhs  61 +++++++++++++++++++++++++++++++++
compiler/prelude/PrimOp.lhs  4 ++
compiler/prelude/primops.txt.pp  1 +
compiler/stranal/DmdAnal.lhs  38 ++++++++++++++++++
4 files changed, 81 insertions(+), 23 deletions()
diff git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 92f1dc1..ec9c0ea 100644
a

b

module Demand ( 
11  11  countOnce, countMany,  cardinality 
12  12  
13  13  Demand, CleanDemand, 
14   mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, 
 14  mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, strictifyDmd, 
15  15  getUsage, toCleanDmd, 
16  16  absDmd, topDmd, botDmd, seqDmd, 
17  17  lubDmd, bothDmd, apply1Dmd, apply2Dmd, 
18  18  isTopDmd, isBotDmd, isAbsDmd, isSeqDmd, 
19  19  peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd, 
20  20  
21   DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType, 
22   nopDmdType, botDmdType, mkDmdType, 
 21  DmdType(..), dmdTypeDepth, lubDmdType, lubDmdTypes, bothDmdType, 
 22  nopDmdType, litDmdType, botDmdType, mkDmdType, 
23  23  addDemand, 
24  24  BothDmdArg, mkBothDmdArg, toBothDmdArg, 
25  25  
… 
… 
module Demand ( 
27  27  peelFV, 
28  28  
29  29  DmdResult, CPRResult, 
30   isBotRes, isTopRes, resTypeArgDmd, 
31   topRes, botRes, cprProdRes, vanillaCprProdRes, cprSumRes, 
 30  isBotRes, isTopRes, resTypeArgDmd, 
 31  topRes, convRes, botRes, cprProdRes, vanillaCprProdRes, cprSumRes, 
32  32  appIsBottom, isBottomingSig, isConvSig, pprIfaceStrictSig, 
33  33  trimCPRInfo, returnsCPR, returnsCPR_maybe, 
34   StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig, 
 34  StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig, convergeSig, 
35  35  isNopSig, splitStrictSig, increaseStrictSigArity, 
36  36  sigMayDiverge, 
37  37  
… 
… 
module Demand ( 
39  39  
40  40  evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, 
41  41  splitDmdTy, splitFVs, 
42   deferAfterIO, 
 42  deferAfterIO, deferDmd, 
43  43  postProcessUnsat, postProcessDmdTypeM, 
44  44  
45  45  splitProdDmd, splitProdDmd_maybe, peelCallDmd, mkCallDmd, 
… 
… 
import UniqFM 
65  65  import Util 
66  66  import BasicTypes 
67  67  import Binary 
68   import Maybes ( isJust, orElse ) 
 68  import Maybes ( isJust, orElse, fromMaybe ) 
69  69  
70  70  import Type ( Type ) 
71  71  import TyCon ( isNewTyCon, isClassTyCon ) 
… 
… 
bothStr (SProd s1) (SProd s2) 
186  186   otherwise = HyperStr  Weird 
187  187  bothStr (SProd _) (SCall _) = HyperStr 
188  188  
 189  strictifyDmd :: Demand > Demand 
 190  strictifyDmd (JD Lazy u) = (JD (Str HeadStr) u) 
 191  strictifyDmd (JD s u) = (JD s u) 
 192  
189  193   utility functions to deal with memory leaks 
190  194  seqStrDmd :: StrDmd > () 
191  195  seqStrDmd (SProd ds) = seqStrDmdList ds 
… 
… 
lubCPR _ _ = NoCPR 
731  735  
732  736  lubDmdResult :: DmdResult > DmdResult > DmdResult 
733  737  lubDmdResult Diverges r = r 
734   lubDmdResult (Converges c1) Diverges = Converges c1 
 738  lubDmdResult (Converges c1) Diverges = Dunno c1 
735  739  lubDmdResult (Converges c1) (Converges c2) = Converges (c1 `lubCPR` c2) 
736  740  lubDmdResult (Converges c1) (Dunno c2) = Dunno (c1 `lubCPR` c2) 
737  741  lubDmdResult (Dunno c1) Diverges = Dunno c1 
… 
… 
instance Eq DmdType where 
1034  1038  (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2 
1035  1039  && ds1 == ds2 && res1 == res2 
1036  1040  
 1041  lubDmdTypes :: [DmdType] > DmdType 
 1042  lubDmdTypes [] = botDmdType 
 1043  lubDmdTypes tys = foldr1 lubDmdType tys 
 1044  
1037  1045  lubDmdType :: DmdType > DmdType > DmdType 
1038  1046  lubDmdType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2) 
1039   = DmdType lub_fv (lub_ds ds1 ds2) (r1 `lubDmdResult` r2) 
 1047  = DmdType lub_fv (lub_ds ds1 ds2) r' 
1040  1048  where 
1041  1049  lub_fv = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2) 
1042  1050  
 1051  r'  strictness_differs = (r1 `lubDmdResult` r2 `lubDmdResult` Diverges) 
 1052   otherwise = (r1 `lubDmdResult` r2) 
 1053  
 1054  strictness_differs 
 1055  = length ds1 /= length ds2  not sure, but this is the safe choice 
 1056   or (zipWith go ds1 ds2) 
 1057   foldVarEnv2_D (\d1 d2 > (go d1 d2 )) False fv1 (defaultDmd r1) fv2 (defaultDmd r2) 
 1058  go d1 d2 = isStrictDmd d1 /= isStrictDmd d2 
 1059  
1043  1060   Extend the shorter argument list to match the longer 
1044  1061  lub_ds (d1:ds1) (d2:ds2) = lubDmd d1 d2 : lub_ds ds1 ds2 
1045  1062  lub_ds [] [] = [] 
1046  1063  lub_ds ds1 [] = map (`lubDmd` resTypeArgDmd r2) ds1 
1047  1064  lub_ds [] ds2 = map (resTypeArgDmd r1 `lubDmd`) ds2 
1048  1065  
 1066  foldVarEnv2_D :: (a > b > c > c) > c > 
 1067  VarEnv a > a > 
 1068  VarEnv b > b > 
 1069  c 
 1070  foldVarEnv2_D f x e1 d1 e2 d2 = 
 1071  foldr (\k > f (l1 k) (l2 k)) x $ 
 1072  varEnvKeys e1 ++ varEnvKeys (e2 `minusVarEnv` e1) 
 1073  where l1 k = fromMaybe d1 (lookupVarEnv_Directly e1 k) 
 1074  l2 k = fromMaybe d2 (lookupVarEnv_Directly e2 k) 
 1075  
 1076  
1049  1077  
1050  1078  type BothDmdArg = (DmdEnv, Termination ()) 
1051  1079  
… 
… 
emptyDmdEnv = emptyVarEnv 
1084  1112   (lazy, absent, no CPR information, no termination information). 
1085  1113   Note that it is ''not'' the top of the lattice (which would be "may use everything"), 
1086  1114   so it is (no longer) called topDmd 
1087   nopDmdType, botDmdType :: DmdType 
 1115  nopDmdType, litDmdType, botDmdType :: DmdType 
1088  1116  nopDmdType = DmdType emptyDmdEnv [] topRes 
1089  1117  botDmdType = DmdType emptyDmdEnv [] botRes 
 1118  litDmdType = DmdType emptyDmdEnv [] convRes 
1090  1119  
1091  1120  cprProdDmdType :: Arity > DmdType 
1092  1121  cprProdDmdType _arity 
1093   = DmdType emptyDmdEnv [] (Converges RetProd) 
 1122  = DmdType emptyDmdEnv [] topRes 
1094  1123  
1095  1124  isNopDmdType :: DmdType > Bool 
1096  1125  isNopDmdType (DmdType env [] res) 
… 
… 
cprProdSig arity = StrictSig (cprProdDmdType arity) 
1427  1456  sigMayDiverge :: StrictSig > StrictSig 
1428  1457  sigMayDiverge (StrictSig (DmdType env ds res)) = (StrictSig (DmdType env ds (divergeDmdResult res))) 
1429  1458  
 1459  convergeSig :: StrictSig > StrictSig 
 1460  convergeSig (StrictSig (DmdType fv args r)) = StrictSig (DmdType fv args (convergeResult r)) 
 1461  
 1462  convergeResult :: DmdResult > DmdResult 
 1463  convergeResult Diverges = Converges NoCPR 
 1464  convergeResult (Dunno c) = Converges c 
 1465  convergeResult (Converges c) = Converges c 
 1466  
1430  1467  argsOneShots :: StrictSig > Arity > [[OneShotInfo]] 
1431  1468  argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args 
1432  1469  = go arg_ds 
diff git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs
index 12f71c2..2ee7da4 100644
a

b

primOpOcc op = case primOpInfo op of 
516  516  
517  517  primOpSig :: PrimOp > ([TyVar], [Type], Type, Arity, StrictSig) 
518  518  primOpSig op 
519   = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity) 
 519  = (tyvars, arg_tys, res_ty, arity, strict_sig) 
520  520  where 
 521  strict_sig  primOpOkForSpeculation op = convergeSig $ primOpStrictness op arity 
 522   otherwise = primOpStrictness op arity 
521  523  arity = length arg_tys 
522  524  (tyvars, arg_tys, res_ty) 
523  525  = case (primOpInfo op) of 
diff git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index b3cf2f4..5fc7f95 100644
a

b

defaults 
61  61  can_fail = False  See Note Note [PrimOp can_fail and has_side_effects] in PrimOp 
62  62  commutable = False 
63  63  code_size = { primOpCodeSizeDefault } 
 64   Strictness is turned to terminating in PrimOp.primOpSig, if allowed 
64  65  strictness = { \ arity > mkClosedStrictSig (replicate arity topDmd) topRes } 
65  66  fixity = Nothing 
66  67  llvm_only = False 
diff git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 795ffa5..24c627c 100644
a

b

import Id 
28  28  import CoreUtils ( exprIsHNF, exprType, exprIsTrivial ) 
29  29   import PprCore 
30  30  import TyCon 
31   import Type ( eqType ) 
 31  import Type ( eqType, isUnLiftedType ) 
32  32   import Pair 
33  33   import Coercion ( coercionKind ) 
34  34  import Util 
… 
… 
dmdAnal :: AnalEnv 
129  129   The CleanDemand is always strict and not absent 
130  130   See Note [Ensure demand is strict] 
131  131  
132   dmdAnal _ _ (Lit lit) = (nopDmdType, Lit lit) 
 132  dmdAnal _ _ (Lit lit) = (litDmdType, Lit lit) 
133  133  dmdAnal _ _ (Type ty) = (nopDmdType, Type ty)  Doesn't happen, in fact 
134  134  dmdAnal _ _ (Coercion co) = (nopDmdType, Coercion co) 
135  135  
… 
… 
dmdAnal env dmd (App fun arg)  Nontype arguments 
176  176  call_dmd = mkCallDmd dmd 
177  177  (fun_ty, fun') = dmdAnal env call_dmd fun 
178  178  (arg_dmd, res_ty) = splitDmdTy fun_ty 
179   (arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg 
 179   Make sure that calling something unlifted is always strict 
 180  arg_dmd'  isUnLiftedType (exprType arg) = strictifyDmd arg_dmd 
 181   otherwise = arg_dmd 
 182  (arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd') arg 
180  183  in 
181  184   pprTrace "dmdAnal:app" (vcat 
182  185   [ text "dmd =" <+> ppr dmd 
… 
… 
dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) 
219  222  (alt_ty, alt') = dmdAnalAlt env_alt dmd alt 
220  223  (alt_ty1, case_bndr') = annotateBndr env alt_ty case_bndr 
221  224  (_, bndrs', _) = alt' 
222   case_bndr_sig = cprProdSig (dataConRepArity dc) 
 225  case_bndr_sig = convergeSig (cprProdSig (dataConRepArity dc)) 
223  226   Inside the alternative, the case binder has the CPR property. 
224  227   Meaning that a case on it will successfully cancel. 
225  228   Example: 
… 
… 
dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) 
268  271  
269  272  dmdAnal env dmd (Case scrut case_bndr ty alts) 
270  273  = let  Case expression with multiple alternatives 
271   (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd) alts 
 274  case_bndr_sig = convergeSig nopSig 
 275  env_alt = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig 
 276  (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env_alt dmd) alts 
272  277  (scrut_ty, scrut') = dmdAnal env cleanEvalDmd scrut 
273   (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr 
 278  (alt_ty, case_bndr') = annotateBndr env (lubDmdTypes alt_tys) case_bndr 
274  279  res_ty = alt_ty `bothDmdType` toBothDmdArg scrut_ty 
275  280  in 
276  281   pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut 
… 
… 
a product type. 
688  693  
689  694  \begin{code} 
690  695  unitVarDmd :: Var > Demand > DmdType 
691   unitVarDmd var dmd 
692   = DmdType (unitVarEnv var dmd) [] topRes 
 696  unitVarDmd var dmd 
 697  =  pprTrace "unitVarDmd" (vcat [ppr var, ppr dmd, ppr res]) $ 
 698  DmdType (unitVarEnv var dmd') [] res 
 699  where 
 700   If this is a strict demand, then we know that entering the variable 
 701   will terminate 
 702  res  isStrictDmd dmd  isUnLiftedType (idType var) = convRes 
 703   otherwise = topRes 
 704   Never record a strict demand on a unlifted type 
 705  dmd'  isUnLiftedType (idType var) = deferDmd dmd 
 706   otherwise = dmd 
693  707  
694  708  addVarDmd :: DmdType > Var > Demand > DmdType 
695  709  addVarDmd (DmdType fv ds res) var dmd 
696   = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res 
 710  = DmdType (extendVarEnv_C bothDmd fv var dmd') ds res 
 711   Never record a strict demand on a unlifted type 
 712  where 
 713  dmd'  isUnLiftedType (idType var) = deferDmd dmd 
 714   otherwise = dmd 
697  715  
698  716  addLazyFVs :: DmdType > DmdEnv > DmdType 
699  717  addLazyFVs dmd_ty lazy_fvs 
… 
… 
extendSigsWithLam env id 
1075  1093   See Note [Optimistic CPR in the "virgin" case] 
1076  1094   See Note [Initial CPR for strict binders] 
1077  1095  , Just (dc,_,_,_) < deepSplitProductType_maybe $ idType id 
1078   = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc)) 
 1096  = extendAnalEnv NotTopLevel env id (convergeSig (cprProdSig (dataConRepArity dc))) 
1079  1097  
1080  1098   otherwise 
1081  1099  = env 