NestedCPR/AdvancedConverges: 0001-Try-to-make-S-t-meaningful.patch

File 0001-Try-to-make-S-t-meaningful.patch, 14.0 KB (added by nomeata, 20 months ago)

I hate deleting stuff, but don’t want to store this on any branch. So I bury it here.

  • compiler/basicTypes/Demand.lhs

    From 54d9697947a82a8630c6fcde54c6bc25bc4a6af7 Mon Sep 17 00:00:00 2001
    From: Joachim Breitner <[email protected]>
    Date: Thu, 9 Jan 2014 10:37:29 +0000
    Subject: [PATCH] Try to make "<S>t" meaningful
    MIME-Version: 1.0
    Content-Type: text/plain; charset=UTF-8
    Content-Transfer-Encoding: 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 ( 
    1111        countOnce, countMany,   -- cardinality
    1212
    1313        Demand, CleanDemand,
    14         mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd,
     14        mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, strictifyDmd,
    1515        getUsage, toCleanDmd,
    1616        absDmd, topDmd, botDmd, seqDmd,
    1717        lubDmd, bothDmd, apply1Dmd, apply2Dmd,
    1818        isTopDmd, isBotDmd, isAbsDmd, isSeqDmd,
    1919        peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd,
    2020
    21         DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,
    22         nopDmdType, botDmdType, mkDmdType,
     21        DmdType(..), dmdTypeDepth, lubDmdType, lubDmdTypes, bothDmdType,
     22        nopDmdType, litDmdType, botDmdType, mkDmdType,
    2323        addDemand,
    2424        BothDmdArg, mkBothDmdArg, toBothDmdArg,
    2525
    module Demand ( 
    2727        peelFV,
    2828
    2929        DmdResult, CPRResult,
    30         isBotRes, isTopRes, resTypeArgDmd, 
    31         topRes, botRes, cprProdRes, vanillaCprProdRes, cprSumRes,
     30        isBotRes, isTopRes, resTypeArgDmd,
     31        topRes, convRes, botRes, cprProdRes, vanillaCprProdRes, cprSumRes,
    3232        appIsBottom, isBottomingSig, isConvSig, pprIfaceStrictSig,
    3333        trimCPRInfo, returnsCPR, returnsCPR_maybe,
    34         StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig,
     34        StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig, convergeSig,
    3535        isNopSig, splitStrictSig, increaseStrictSigArity,
    3636        sigMayDiverge,
    3737
    module Demand ( 
    3939
    4040        evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd,
    4141        splitDmdTy, splitFVs,
    42         deferAfterIO,
     42        deferAfterIO, deferDmd,
    4343        postProcessUnsat, postProcessDmdTypeM,
    4444
    4545        splitProdDmd, splitProdDmd_maybe, peelCallDmd, mkCallDmd,
    import UniqFM 
    6565import Util
    6666import BasicTypes
    6767import Binary
    68 import Maybes           ( isJust, orElse )
     68import Maybes           ( isJust, orElse, fromMaybe )
    6969
    7070import Type            ( Type )
    7171import TyCon           ( isNewTyCon, isClassTyCon )
    bothStr (SProd s1) (SProd s2) 
    186186    | otherwise                = HyperStr  -- Weird
    187187bothStr (SProd _) (SCall _)    = HyperStr
    188188
     189strictifyDmd :: Demand -> Demand
     190strictifyDmd (JD Lazy u) = (JD (Str HeadStr) u)
     191strictifyDmd (JD s u) = (JD s u)
     192
    189193-- utility functions to deal with memory leaks
    190194seqStrDmd :: StrDmd -> ()
    191195seqStrDmd (SProd ds)   = seqStrDmdList ds
    lubCPR _ _ = NoCPR 
    731735
    732736lubDmdResult :: DmdResult -> DmdResult -> DmdResult
    733737lubDmdResult Diverges       r              = r
    734 lubDmdResult (Converges c1) Diverges       = Converges c1
     738lubDmdResult (Converges c1) Diverges       = Dunno c1
    735739lubDmdResult (Converges c1) (Converges c2) = Converges (c1 `lubCPR` c2)
    736740lubDmdResult (Converges c1) (Dunno c2)     = Dunno (c1 `lubCPR` c2)
    737741lubDmdResult (Dunno c1)     Diverges       = Dunno c1
    instance Eq DmdType where 
    10341038       (DmdType fv2 ds2 res2) =  ufmToList fv1 == ufmToList fv2
    10351039                              && ds1 == ds2 && res1 == res2
    10361040
     1041lubDmdTypes :: [DmdType] -> DmdType
     1042lubDmdTypes [] = botDmdType
     1043lubDmdTypes tys = foldr1 lubDmdType tys
     1044
    10371045lubDmdType :: DmdType -> DmdType -> DmdType
    10381046lubDmdType (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'
    10401048  where
    10411049    lub_fv  = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2)
    10421050
     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
    10431060      -- Extend the shorter argument list to match the longer
    10441061    lub_ds (d1:ds1) (d2:ds2) = lubDmd d1 d2 : lub_ds ds1 ds2
    10451062    lub_ds []     []       = []
    10461063    lub_ds ds1    []       = map (`lubDmd` resTypeArgDmd r2) ds1
    10471064    lub_ds []     ds2      = map (resTypeArgDmd r1 `lubDmd`) ds2
    10481065
     1066foldVarEnv2_D  :: (a -> b -> c -> c) -> c ->
     1067                  VarEnv a -> a ->
     1068                  VarEnv b -> b ->
     1069                  c
     1070foldVarEnv2_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
    10491077
    10501078type BothDmdArg = (DmdEnv, Termination ())
    10511079
    emptyDmdEnv = emptyVarEnv 
    10841112-- (lazy, absent, no CPR information, no termination information).
    10851113-- Note that it is ''not'' the top of the lattice (which would be "may use everything"),
    10861114-- so it is (no longer) called topDmd
    1087 nopDmdType, botDmdType :: DmdType
     1115nopDmdType, litDmdType, botDmdType :: DmdType
    10881116nopDmdType = DmdType emptyDmdEnv [] topRes
    10891117botDmdType = DmdType emptyDmdEnv [] botRes
     1118litDmdType = DmdType emptyDmdEnv [] convRes
    10901119
    10911120cprProdDmdType :: Arity -> DmdType
    10921121cprProdDmdType _arity
    1093   = DmdType emptyDmdEnv [] (Converges RetProd)
     1122  = DmdType emptyDmdEnv [] topRes
    10941123
    10951124isNopDmdType :: DmdType -> Bool
    10961125isNopDmdType (DmdType env [] res)
    cprProdSig arity = StrictSig (cprProdDmdType arity) 
    14271456sigMayDiverge :: StrictSig -> StrictSig
    14281457sigMayDiverge (StrictSig (DmdType env ds res)) = (StrictSig (DmdType env ds (divergeDmdResult res)))
    14291458
     1459convergeSig :: StrictSig -> StrictSig
     1460convergeSig (StrictSig (DmdType fv args r)) = StrictSig (DmdType fv args (convergeResult r))
     1461
     1462convergeResult :: DmdResult -> DmdResult
     1463convergeResult Diverges      = Converges NoCPR
     1464convergeResult (Dunno c)     = Converges c
     1465convergeResult (Converges c) = Converges c
     1466
    14301467argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]]
    14311468argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args
    14321469  = go arg_ds
  • compiler/prelude/PrimOp.lhs

    diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs
    index 12f71c2..2ee7da4 100644
    a b primOpOcc op = case primOpInfo op of 
    516516
    517517primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictSig)
    518518primOpSig op
    519   = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity)
     519  = (tyvars, arg_tys, res_ty, arity, strict_sig)
    520520  where
     521    strict_sig | primOpOkForSpeculation op = convergeSig $ primOpStrictness op arity
     522               | otherwise                 =               primOpStrictness op arity
    521523    arity = length arg_tys
    522524    (tyvars, arg_tys, res_ty)
    523525      = case (primOpInfo op) of
  • compiler/prelude/primops.txt.pp

    diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
    index b3cf2f4..5fc7f95 100644
    a b defaults 
    6161   can_fail         = False   -- See Note Note [PrimOp can_fail and has_side_effects] in PrimOp
    6262   commutable       = False
    6363   code_size        = { primOpCodeSizeDefault }
     64   -- Strictness is turned to terminating in PrimOp.primOpSig, if allowed
    6465   strictness       = { \ arity -> mkClosedStrictSig (replicate arity topDmd) topRes }
    6566   fixity           = Nothing
    6667   llvm_only        = False
  • compiler/stranal/DmdAnal.lhs

    diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
    index 795ffa5..24c627c 100644
    a b import Id 
    2828import CoreUtils        ( exprIsHNF, exprType, exprIsTrivial )
    2929-- import PprCore       
    3030import TyCon
    31 import Type             ( eqType )
     31import Type             ( eqType, isUnLiftedType )
    3232-- import Pair
    3333-- import Coercion         ( coercionKind )
    3434import Util
    dmdAnal :: AnalEnv 
    129129-- The CleanDemand is always strict and not absent
    130130--    See Note [Ensure demand is strict]
    131131
    132 dmdAnal _ _ (Lit lit)     = (nopDmdType, Lit lit)
     132dmdAnal _ _ (Lit lit)     = (litDmdType, Lit lit)
    133133dmdAnal _ _ (Type ty)     = (nopDmdType, Type ty)       -- Doesn't happen, in fact
    134134dmdAnal _ _ (Coercion co) = (nopDmdType, Coercion co)
    135135
    dmdAnal env dmd (App fun arg) -- Non-type arguments 
    176176        call_dmd          = mkCallDmd dmd
    177177        (fun_ty, fun')    = dmdAnal env call_dmd fun
    178178        (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
    180183    in
    181184--    pprTrace "dmdAnal:app" (vcat
    182185--         [ text "dmd =" <+> ppr dmd
    dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) 
    219222        (alt_ty, alt')        = dmdAnalAlt env_alt dmd alt
    220223        (alt_ty1, case_bndr') = annotateBndr env alt_ty case_bndr
    221224        (_, bndrs', _)        = alt'
    222         case_bndr_sig         = cprProdSig (dataConRepArity dc)
     225        case_bndr_sig         = convergeSig (cprProdSig (dataConRepArity dc))
    223226                -- Inside the alternative, the case binder has the CPR property.
    224227                -- Meaning that a case on it will successfully cancel.
    225228                -- Example:
    dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) 
    268271
    269272dmdAnal env dmd (Case scrut case_bndr ty alts)
    270273  = 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
    272277        (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
    274279        res_ty               = alt_ty `bothDmdType` toBothDmdArg scrut_ty
    275280    in
    276281--    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
    a product type. 
    688693
    689694\begin{code}
    690695unitVarDmd :: Var -> Demand -> DmdType
    691 unitVarDmd var dmd
    692   = DmdType (unitVarEnv var dmd) [] topRes
     696unitVarDmd 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
    693707
    694708addVarDmd :: DmdType -> Var -> Demand -> DmdType
    695709addVarDmd (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
    697715
    698716addLazyFVs :: DmdType -> DmdEnv -> DmdType
    699717addLazyFVs dmd_ty lazy_fvs
    extendSigsWithLam env id 
    10751093       -- See Note [Optimistic CPR in the "virgin" case]
    10761094       -- See Note [Initial CPR for strict binders]
    10771095  , Just (dc,_,_,_) <- deepSplitProductType_maybe $ idType id
    1078   = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc))
     1096  = extendAnalEnv NotTopLevel env id (convergeSig (cprProdSig (dataConRepArity dc)))
    10791097
    10801098  | otherwise
    10811099  = env