Replace mkTopDmdType by mkClosedStrictSig
authorJoachim Breitner <mail@joachim-breitner.de>
Mon, 9 Dec 2013 16:09:03 +0000 (16:09 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Mon, 9 Dec 2013 16:09:03 +0000 (16:09 +0000)
because it is not a top deman (see previous commit), and it is only used
in an argument to mkStrictSig.

compiler/basicTypes/Demand.lhs
compiler/basicTypes/MkId.lhs
compiler/coreSyn/CoreArity.lhs
compiler/coreSyn/MkCore.lhs
compiler/prelude/primops.txt.pp
compiler/specialise/SpecConstr.lhs
compiler/stranal/WorkWrap.lhs

index 6f88efd..c47b83a 100644 (file)
@@ -19,7 +19,7 @@ module Demand (
         peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd,
 
         DmdType(..), dmdTypeDepth, lubDmdType, bothDmdEnv, bothDmdType,
-        nopDmdType, botDmdType, mkDmdType, mkTopDmdType,
+        nopDmdType, botDmdType, mkDmdType,
 
         DmdEnv, emptyDmdEnv,
 
@@ -28,7 +28,7 @@ module Demand (
         topRes, botRes, cprProdRes, cprSumRes,
         appIsBottom, isBottomingSig, pprIfaceStrictSig, 
         returnsCPR, returnsCPRProd, returnsCPR_maybe,
-        StrictSig(..), mkStrictSig, nopSig, botSig, cprProdSig,
+        StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig,
         isNopSig, splitStrictSig, increaseStrictSigArity,
        
         seqDemand, seqDemandList, seqDmdType, seqStrictSig, 
@@ -1049,9 +1049,6 @@ isNopDmdType _                        = False
 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
 mkDmdType fv ds res = DmdType fv ds res
 
-mkTopDmdType :: [Demand] -> DmdResult -> DmdType
-mkTopDmdType ds res = DmdType emptyDmdEnv ds res
-
 dmdTypeDepth :: DmdType -> Arity
 dmdTypeDepth (DmdType _ ds _) = length ds
 
@@ -1236,6 +1233,9 @@ instance Outputable StrictSig where
 mkStrictSig :: DmdType -> StrictSig
 mkStrictSig dmd_ty = StrictSig dmd_ty
 
+mkClosedStrictSig :: [Demand] -> DmdResult -> StrictSig
+mkClosedStrictSig ds res = mkStrictSig (DmdType emptyDmdEnv ds res)
+
 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
 
index 2bc0d12..2b31dc7 100644 (file)
@@ -323,7 +323,7 @@ mkDictSelId dflags no_unf name clas
         -- It's worth giving one, so that absence info etc is generated
         -- even if the selector isn't inlined
 
-    strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] topRes)
+    strict_sig = mkClosedStrictSig [arg_dmd] topRes
     arg_dmd | new_tycon = evalDmd
             | otherwise = mkManyUsedDmd $
                           mkProdDmd [ if the_arg_id == id then evalDmd else absDmd
@@ -393,7 +393,7 @@ mkDataConWorkId wkr_name data_con
                 `setUnfoldingInfo`   evaldUnfolding  -- Record that it's evaluated,
                                                      -- even if arity = 0
 
-    wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) (dataConCPR data_con))
+    wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
         --      Note [Data-con worker strictness]
         -- Notice that we do *not* say the worker is strict
         -- even if the data constructor is declared strict
@@ -497,7 +497,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
                             -- does not tidy the IdInfo of implicit bindings (like the wrapper)
                             -- so it not make sure that the CAF info is sane
 
-            wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds (dataConCPR data_con))
+            wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
             wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs)
             mk_dmd str | isBanged str = evalDmd
                        | otherwise    = topDmd
@@ -946,7 +946,7 @@ mkFCallId dflags uniq fcall ty
     (_, tau)        = tcSplitForAllTys ty
     (arg_tys, _)    = tcSplitFunTys tau
     arity           = length arg_tys
-    strict_sig      = mkStrictSig (mkTopDmdType (replicate arity evalDmd) topRes)
+    strict_sig      = mkClosedStrictSig (replicate arity evalDmd) topRes
 \end{code}
 
 
index ff39cfc..45b8acc 100644 (file)
@@ -145,7 +145,7 @@ exprBotStrictness_maybe e
        Just ar -> Just (ar, sig ar)
   where
     env    = AE { ae_bndrs = [], ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False }
-    sig ar = mkStrictSig (mkTopDmdType (replicate ar topDmd) botRes)
+    sig ar = mkClosedStrictSig (replicate ar topDmd) botRes
                   -- For this purpose we can be very simple
 \end{code}
 
index aa027b0..f71b4b4 100644 (file)
@@ -774,7 +774,7 @@ pc_bottoming_Id1 name ty
         -- any pc_bottoming_Id will itself have CafRefs, which bloats
         -- SRTs.
 
-    strict_sig = mkStrictSig (mkTopDmdType [evalDmd] botRes)
+    strict_sig = mkClosedStrictSig [evalDmd] botRes
     -- These "bottom" out, no matter what their arguments
 
 pc_bottoming_Id0 :: Name -> Type -> Id
@@ -783,6 +783,6 @@ pc_bottoming_Id0 name ty
  = mkVanillaGlobalWithInfo name ty bottoming_info
  where
     bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
-    strict_sig = mkStrictSig (mkTopDmdType [] botRes)
+    strict_sig = mkClosedStrictSig [] botRes
 \end{code}
 
index 41a6785..7457583 100644 (file)
@@ -61,7 +61,7 @@ defaults
    can_fail         = False   -- See Note Note [PrimOp can_fail and has_side_effects] in PrimOp
    commutable       = False
    code_size        = { primOpCodeSizeDefault }
-   strictness       = { \ arity -> mkStrictSig (mkTopDmdType (replicate arity topDmd) topRes) }
+   strictness       = { \ arity -> mkClosedStrictSig (replicate arity topDmd) topRes }
    fixity           = Nothing
    llvm_only        = False
    vector           = []
@@ -1626,7 +1626,7 @@ primop  CatchOp "catch#" GenPrimOp
 primop  RaiseOp "raise#" GenPrimOp
    a -> b
    with
-   strictness  = { \ _arity -> mkStrictSig (mkTopDmdType [topDmd] botRes) }
+   strictness  = { \ _arity -> mkClosedStrictSig [topDmd] botRes }
       -- NB: result is bottom
    out_of_line = True
 
@@ -1643,7 +1643,7 @@ primop  RaiseOp "raise#" GenPrimOp
 primop  RaiseIOOp "raiseIO#" GenPrimOp
    a -> State# RealWorld -> (# State# RealWorld, b #)
    with
-   strictness  = { \ _arity -> mkStrictSig (mkTopDmdType [topDmd, topDmd] botRes) }
+   strictness  = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] botRes }
    out_of_line = True
    has_side_effects = True
 
@@ -1700,7 +1700,7 @@ primop    AtomicallyOp "atomically#" GenPrimOp
 primop  RetryOp "retry#" GenPrimOp
    State# RealWorld -> (# State# RealWorld, a #)
    with
-   strictness  = { \ _arity -> mkStrictSig (mkTopDmdType [topDmd] botRes) }
+   strictness  = { \ _arity -> mkClosedStrictSig [topDmd] botRes }
    out_of_line = True
    has_side_effects = True
 
@@ -2159,7 +2159,7 @@ section "Tag to enum stuff"
 primop  DataToTagOp "dataToTag#" GenPrimOp
    a -> Int#
    with
-   strictness  = { \ _arity -> mkStrictSig (mkTopDmdType [evalDmd] topRes) }
+   strictness  = { \ _arity -> mkClosedStrictSig [evalDmd] topRes }
 
        -- dataToTag# must have an evaluated argument
 
index 44dc6f0..4b71054 100644 (file)
@@ -1567,7 +1567,7 @@ calcSpecStrictness :: Id                     -- The original function
                    -> StrictSig              -- Strictness of specialised thing
 -- See Note [Transfer strictness]
 calcSpecStrictness fn qvars pats
-  = StrictSig (mkTopDmdType spec_dmds topRes)
+  = mkClosedStrictSig spec_dmds topRes
   where
     spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]
     StrictSig (DmdType _ dmds _) = idStrictness fn
index 6a448ca..4e04d45 100644 (file)
@@ -285,8 +285,8 @@ tryWW dflags is_rec fn_id rhs
        --      (c) it becomes incorrect as things are cloned, because
        --          we don't push the substitution into it
     new_fn_id | isEmptyVarEnv env = fn_id
-             | otherwise         = fn_id `setIdStrictness` 
-                                    StrictSig (mkTopDmdType wrap_dmds res_info)
+              | otherwise         = fn_id `setIdStrictness`
+                                     mkClosedStrictSig wrap_dmds res_info
 
     is_fun    = notNull wrap_dmds
     is_thunk  = not is_fun && not (exprIsHNF rhs)
@@ -339,7 +339,7 @@ splitFun dflags fn_id fn_info wrap_dmds res_info rhs
                                -- not w/wd). However, the RuleMatchInfo is not transferred since
                                 -- it does not make sense for workers to be constructorlike.
 
-                       `setIdStrictness` StrictSig (mkTopDmdType work_demands work_res_info)
+                       `setIdStrictness` mkClosedStrictSig work_demands work_res_info
                                -- Even though we may not be at top level, 
                                -- it's ok to give it an empty DmdEnv