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, 18 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