-data IdInfo
- = IdInfo {
- arityInfo :: ArityInfo, -- Its arity
- demandInfo :: Demand, -- Whether or not it is definitely demanded
- specInfo :: IdSpecEnv, -- Specialisations of this function which exist
- strictnessInfo :: StrictnessInfo, -- Strictness properties
- workerInfo :: WorkerInfo, -- Pointer to Worker Function
- unfoldingInfo :: Unfolding, -- Its unfolding
- updateInfo :: UpdateInfo, -- Which args should be updated
- cafInfo :: CafInfo,
- cprInfo :: CprInfo, -- Function always constructs a product result
- inlinePragInfo :: !InlinePragInfo -- Inline pragmas
- }
+-- setAllStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo
+-- Set old and new strictness info
+setAllStrictnessInfo info Nothing
+ = info { newStrictnessInfo = Nothing
+#ifdef OLD_STRICTNESS
+ , strictnessInfo = NoStrictnessInfo
+ , cprInfo = NoCPRInfo
+#endif
+ }
+
+setAllStrictnessInfo info (Just sig)
+ = info { newStrictnessInfo = Just sig
+#ifdef OLD_STRICTNESS
+ , strictnessInfo = oldStrictnessFromNew sig
+ , cprInfo = cprInfoFromNewStrictness sig
+#endif
+ }
+
+seqNewStrictnessInfo Nothing = ()
+seqNewStrictnessInfo (Just ty) = seqStrictSig ty
+
+pprNewStrictness Nothing = empty
+pprNewStrictness (Just sig) = ftext FSLIT("Str:") <+> ppr sig
+
+#ifdef OLD_STRICTNESS
+oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo
+oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info)
+ where
+ (dmds, res_info) = splitStrictSig sig
+
+cprInfoFromNewStrictness :: StrictSig -> CprInfo
+cprInfoFromNewStrictness sig = case strictSigResInfo sig of
+ RetCPR -> ReturnsCPR
+ other -> NoCPRInfo
+
+newStrictnessFromOld :: Name -> Arity -> Demand.StrictnessInfo -> CprInfo -> StrictSig
+newStrictnessFromOld name arity (Demand.StrictnessInfo ds res) cpr
+ | listLengthCmp ds arity /= GT -- length ds <= arity
+ -- Sometimes the old strictness analyser has more
+ -- demands than the arity justifies
+ = mk_strict_sig name arity $
+ mkTopDmdType (map newDemand ds) (newRes res cpr)
+
+newStrictnessFromOld name arity other cpr
+ = -- Either no strictness info, or arity is too small
+ -- In either case we can't say anything useful
+ mk_strict_sig name arity $
+ mkTopDmdType (replicate arity lazyDmd) (newRes False cpr)
+
+mk_strict_sig name arity dmd_ty
+ = WARN( arity /= dmdTypeDepth dmd_ty, ppr name <+> (ppr arity $$ ppr dmd_ty) )
+ mkStrictSig dmd_ty
+
+newRes True _ = BotRes
+newRes False ReturnsCPR = retCPR
+newRes False NoCPRInfo = TopRes
+
+newDemand :: Demand.Demand -> NewDemand.Demand
+newDemand (WwLazy True) = Abs
+newDemand (WwLazy False) = lazyDmd
+newDemand WwStrict = evalDmd
+newDemand (WwUnpack unpk ds) = Eval (Prod (map newDemand ds))
+newDemand WwPrim = lazyDmd
+newDemand WwEnum = evalDmd
+
+oldDemand :: NewDemand.Demand -> Demand.Demand
+oldDemand Abs = WwLazy True
+oldDemand Top = WwLazy False
+oldDemand Bot = WwStrict
+oldDemand (Box Bot) = WwStrict
+oldDemand (Box Abs) = WwLazy False
+oldDemand (Box (Eval _)) = WwStrict -- Pass box only
+oldDemand (Defer d) = WwLazy False
+oldDemand (Eval (Prod ds)) = WwUnpack True (map oldDemand ds)
+oldDemand (Eval (Poly _)) = WwStrict
+oldDemand (Call _) = WwStrict
+
+#endif /* OLD_STRICTNESS */