diff options
Diffstat (limited to 'compiler/iface')
-rw-r--r-- | compiler/iface/BinIface.hs | 23 | ||||
-rw-r--r-- | compiler/iface/IfaceSyn.lhs | 21 | ||||
-rw-r--r-- | compiler/iface/MkIface.lhs | 21 | ||||
-rw-r--r-- | compiler/iface/TcIface.lhs | 12 |
4 files changed, 51 insertions, 26 deletions
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index beb39c00f1..2931ffa70a 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -600,16 +600,18 @@ instance Binary RuleMatchInfo where else return FunLike instance Binary InlinePragma where - put_ bh (InlinePragma a b c) = do + put_ bh (InlinePragma a b c d) = do put_ bh a put_ bh b put_ bh c + put_ bh d get bh = do a <- get bh b <- get bh c <- get bh - return (InlinePragma a b c) + d <- get bh + return (InlinePragma a b c d) instance Binary StrictnessMark where put_ bh MarkedStrict = putByte bh 0 @@ -1188,11 +1190,12 @@ instance Binary IfaceUnfolding where put_ bh (IfCoreUnfold e) = do putByte bh 0 put_ bh e - put_ bh (IfInlineRule a b e) = do + put_ bh (IfInlineRule a b c d) = do putByte bh 1 put_ bh a put_ bh b - put_ bh e + put_ bh c + put_ bh d put_ bh (IfWrapper a n) = do putByte bh 2 put_ bh a @@ -1200,6 +1203,9 @@ instance Binary IfaceUnfolding where put_ bh (IfDFunUnfold as) = do putByte bh 3 put_ bh as + put_ bh (IfCompulsory e) = do + putByte bh 4 + put_ bh e get bh = do h <- getByte bh case h of @@ -1207,13 +1213,16 @@ instance Binary IfaceUnfolding where return (IfCoreUnfold e) 1 -> do a <- get bh b <- get bh - e <- get bh - return (IfInlineRule a b e) + c <- get bh + d <- get bh + return (IfInlineRule a b c d) 2 -> do a <- get bh n <- get bh return (IfWrapper a n) - _ -> do as <- get bh + 3 -> do as <- get bh return (IfDFunUnfold as) + _ -> do e <- get bh + return (IfCompulsory e) instance Binary IfaceNote where put_ bh (IfaceSCC aa) = do diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 9485dc9453..1db78220b7 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -211,11 +211,16 @@ data IfaceInfoItem data IfaceUnfolding = IfCoreUnfold IfaceExpr + | IfCompulsory IfaceExpr -- Only used for default methods, in fact + | IfInlineRule Arity Bool -- OK to inline even if *un*-saturated + Bool -- OK to inline even if context is boring IfaceExpr + | IfWrapper Arity Name -- NB: we need a Name (not just OccName) because the worker -- can simplify to a function in another module. + | IfDFunUnfold [IfaceExpr] -------------------------------- @@ -676,10 +681,11 @@ instance Outputable IfaceInfoItem where ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs") instance Outputable IfaceUnfolding where + ppr (IfCompulsory e) = ptext (sLit "<compulsory>") <+> parens (ppr e) ppr (IfCoreUnfold e) = parens (ppr e) - ppr (IfInlineRule a b e) = ptext (sLit "InlineRule:") - <+> parens (ptext (sLit "arity") <+> int a <+> ppr b) - <+> parens (ppr e) + ppr (IfInlineRule a uok bok e) = ptext (sLit "InlineRule") + <+> ppr (a,uok,bok) + <+> parens (ppr e) ppr (IfWrapper a wkr) = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a) ppr (IfDFunUnfold ns) = ptext (sLit "DFun:") <+> brackets (pprWithCommas (pprIfaceExpr parens) ns) @@ -799,10 +805,11 @@ freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u freeNamesItem _ = emptyNameSet freeNamesIfUnfold :: IfaceUnfolding -> NameSet -freeNamesIfUnfold (IfCoreUnfold e) = freeNamesIfExpr e -freeNamesIfUnfold (IfInlineRule _ _ e) = freeNamesIfExpr e -freeNamesIfUnfold (IfWrapper _ v) = unitNameSet v -freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs +freeNamesIfUnfold (IfCoreUnfold e) = freeNamesIfExpr e +freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e +freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e +freeNamesIfUnfold (IfWrapper _ v) = unitNameSet v +freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs freeNamesIfExpr :: IfaceExpr -> NameSet freeNamesIfExpr (IfaceExt v) = unitNameSet v diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 1c34edca3c..702a744d34 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1503,20 +1503,21 @@ toIfaceIdInfo id_info -------------------------- toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem -toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity - , uf_src = src, uf_guidance = guidance }) - = case src of - InlineWrapper w -> Just (HsUnfold lb (IfWrapper arity (idName w))) - InlineRule {} -> Just (HsUnfold lb (IfInlineRule arity sat (toIfaceExpr rhs))) - _other -> Just (HsUnfold lb (IfCoreUnfold (toIfaceExpr rhs))) +toIfUnfolding lb unf@(CoreUnfolding { uf_tmpl = rhs, uf_arity = arity + , uf_src = src, uf_guidance = guidance }) + = Just $ HsUnfold lb $ + case src of + InlineRule {} + -> case guidance of + UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok (toIfaceExpr rhs) + _other -> pprPanic "toIfUnfolding" (ppr unf) + InlineWrapper w -> IfWrapper arity (idName w) + InlineCompulsory -> IfCompulsory (toIfaceExpr rhs) + InlineRhs -> IfCoreUnfold (toIfaceExpr rhs) -- Yes, even if guidance is UnfNever, expose the unfolding -- If we didn't want to expose the unfolding, TidyPgm would -- have stuck in NoUnfolding. For supercompilation we want -- to see that unfolding! - where - sat = case guidance of - UnfWhen unsat_ok _ -> unsat_ok - _other -> needSaturated toIfUnfolding lb (DFunUnfolding _con ops) = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops))) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index c9c33dbde6..7d0d02ee12 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -1015,11 +1015,19 @@ tcUnfolding name _ info (IfCoreUnfold if_expr) Just sig -> isBottomingSig sig Nothing -> False -tcUnfolding name _ _ (IfInlineRule arity unsat_ok if_expr) +tcUnfolding name _ _ (IfCompulsory if_expr) = do { mb_expr <- tcPragExpr name if_expr ; return (case mb_expr of Nothing -> NoUnfolding - Just expr -> mkInlineRule unsat_ok expr arity) } + Just expr -> mkCompulsoryUnfolding expr) } + +tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) + = do { mb_expr <- tcPragExpr name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkCoreUnfolding True InlineRule expr arity + (UnfWhen unsat_ok boring_ok)) + } tcUnfolding name ty info (IfWrapper arity wkr) = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr) |