From d33c0b24a0306cc57161b7ed7ff2510d0b017b11 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 25 Apr 2007 07:49:24 +0000 Subject: [PATCH] Retain inline-pragma information on unfoldings in interface files WARNING: this patch changes interface-file formats slightly you will need to recompile your libraries Duncan Coutts wanted to export a function that has a NOINLNE pragma in a local let-defintion. This works fine within a module, but was not surviving across the interface-file serialisation. http://www.haskell.org/pipermail/glasgow-haskell-users/2007-March/012171.html Regardless of whether or not he's doing something sensible, it seems reasonable to try to retain local-binder IdInfo across interface files. This initial patch just retains inline-pragma info, on the grounds that other IdInfo can be re-inferred at the inline site. Interface files get a tiny bit bigger, but it seesm slight. --- compiler/coreSyn/CoreTidy.lhs | 5 +++- compiler/iface/BinIface.hs | 10 ++++++++ compiler/iface/IfaceSyn.lhs | 56 ++++++++++++++++++++++++++++------------- compiler/iface/IfaceType.lhs | 12 ++------- compiler/iface/MkIface.lhs | 20 +++++++++++++-- compiler/iface/TcIface.lhs | 55 ++++++++++++++++++++-------------------- compiler/parser/ParserCore.y | 6 ++--- 7 files changed, 104 insertions(+), 60 deletions(-) diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs index c4e7ed9..6699ace 100644 --- a/compiler/coreSyn/CoreTidy.lhs +++ b/compiler/coreSyn/CoreTidy.lhs @@ -146,13 +146,16 @@ tidyLetBndr env (id,rhs) -- CorePrep to turn the let into a case. -- -- Similarly arity info for eta expansion in CorePrep - -- + -- + -- Set inline-prag info so that we preseve it across + -- separate compilation boundaries final_id = new_id `setIdInfo` new_info idinfo = idInfo id new_info = vanillaIdInfo `setArityInfo` exprArity rhs `setAllStrictnessInfo` newStrictnessInfo idinfo `setNewDemandInfo` newDemandInfo idinfo + `setInlinePragInfo` inlinePragInfo idinfo -- Override the env we get back from tidyId with the new IdInfo -- so it gets propagated to the usage sites. diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index f32049e..9bdb7b6 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -690,6 +690,16 @@ instance Binary IfaceBndr where _ -> do ab <- get bh return (IfaceTvBndr ab) +instance Binary IfaceLetBndr where + put_ bh (IfLetBndr a b c) = do + put_ bh a + put_ bh b + put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (IfLetBndr a b c) + instance Binary IfaceType where put_ bh (IfaceForAllTy aa ab) = do putByte bh 0 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 267a8cc..ad4c913 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -8,7 +8,7 @@ module IfaceSyn ( module IfaceType, -- Re-export all this IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), - IfaceExpr(..), IfaceAlt, IfaceNote(..), + IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..), @@ -219,10 +219,27 @@ data IfaceConAlt = IfaceDefault | IfaceLitAlt Literal data IfaceBinding - = IfaceNonRec IfaceIdBndr IfaceExpr - | IfaceRec [(IfaceIdBndr, IfaceExpr)] + = IfaceNonRec IfaceLetBndr IfaceExpr + | IfaceRec [(IfaceLetBndr, IfaceExpr)] + +-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too +-- It's used for *non-top-level* let/rec binders +-- See Note [IdInfo on nested let-bindings] +data IfaceLetBndr = IfLetBndr FastString IfaceType IfaceIdInfo \end{code} +Note [IdInfo on nested let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Occasionally we want to preserve IdInfo on nested let bindings The one +that came up was a NOINLINE pragma on a let-binding inside an INLINE +function. The user (Duncan Coutts) really wanted the NOINLINE control +to cross the separate compilation boundary. + +So a IfaceLetBndr keeps a trimmed-down list of IfaceIdInfo stuff. +Currently we only actually retain InlinePragInfo, but in principle we could +add strictness etc. + + Note [Orphans]: the ifInstOrph and ifRuleOrph fields ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If a module contains any "orphans", then its interface file is read @@ -549,8 +566,9 @@ ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs) ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) -ppr_bind ((b,ty),rhs) = sep [ppr b <+> dcolon <+> ppr ty, - equals <+> pprIfaceExpr noParens rhs] +ppr_bind (IfLetBndr b ty info, rhs) + = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info), + equals <+> pprIfaceExpr noParens rhs] ------------------ pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args) @@ -572,16 +590,17 @@ instance Outputable IfaceConAlt where ------------------ instance Outputable IfaceIdInfo where - ppr NoInfo = empty - ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}") + ppr NoInfo = empty + ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr is) <+> ptext SLIT("-}") -ppr_hs_info (HsUnfold unf) = ptext SLIT("Unfolding:") <+> +instance Outputable IfaceInfoItem where + ppr (HsUnfold unf) = ptext SLIT("Unfolding:") <+> parens (pprIfaceExpr noParens unf) -ppr_hs_info (HsInline act) = ptext SLIT("Inline:") <+> ppr act -ppr_hs_info (HsArity arity) = ptext SLIT("Arity:") <+> int arity -ppr_hs_info (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str -ppr_hs_info HsNoCafRefs = ptext SLIT("HasNoCafRefs") -ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a + ppr (HsInline act) = ptext SLIT("Inline:") <+> ppr act + ppr (HsArity arity) = ptext SLIT("Arity:") <+> int arity + ppr (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str + ppr HsNoCafRefs = ptext SLIT("HasNoCafRefs") + ppr (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a \end{code} @@ -805,10 +824,10 @@ eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2) eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2) eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2) - = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2) + = eq_ifaceExpr env r1 r2 &&& eq_ifLetBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2) eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2) - = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2) + = eq_ifLetBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2) where (bs1,rs1) = unzip as1 (bs2,rs2) = unzip as2 @@ -909,14 +928,17 @@ eq_ifBndr _ _ _ _ = NotEqual eq_ifTvBndr env (v1, k1) (v2, k2) k = eq_ifType env k1 k2 &&& k (extendEqEnv env v1 v2) eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2) +eq_ifLetBndr env (IfLetBndr v1 t1 i1) (IfLetBndr v2 t2 i2) k + = eq_ifType env t1 t2 &&& eqIfIdInfo i1 i2 &&& k (extendEqEnv env v1 v2) + eq_ifBndrs :: ExtEnv [IfaceBndr] -eq_ifIdBndrs :: ExtEnv [IfaceIdBndr] +eq_ifLetBndrs :: ExtEnv [IfaceLetBndr] eq_ifTvBndrs :: ExtEnv [IfaceTvBndr] eq_ifNakedBndrs :: ExtEnv [FastString] eq_ifBndrs = eq_bndrs_with eq_ifBndr -eq_ifIdBndrs = eq_bndrs_with eq_ifIdBndr eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr +eq_ifLetBndrs = eq_bndrs_with eq_ifLetBndr eq_bndrs_with eq env [] [] k = k env eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k) diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index 45fe37d..84c71ff 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -50,8 +50,7 @@ type IfaceIdBndr = (FastString, IfaceType) type IfaceTvBndr = (FastString, IfaceKind) ------------------------------- -type IfaceKind = IfaceType -- Re-use the Kind type, but no KindVars in it - +type IfaceKind = IfaceType type IfaceCoercion = IfaceType data IfaceType @@ -177,14 +176,7 @@ pprIfaceTvBndrs tyvars = hsep (map pprIfaceTvBndr tyvars) \begin{code} --------------------------------- instance Outputable IfaceType where - ppr ty = pprIfaceTypeForUser ty - -pprIfaceTypeForUser ::IfaceType -> SDoc --- Drop top-level for-alls; if that's not what you want, use pprIfaceType dire -pprIfaceTypeForUser ty - = pprIfaceForAllPart [] theta (pprIfaceType tau) - where - (_tvs, theta, tau) = splitIfaceSigmaTy ty + ppr ty = pprIfaceType ty pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc pprIfaceType = ppr_ty tOP_PREC diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index b74c233..6f3e336 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1174,6 +1174,22 @@ famInstToIfaceFamInst fi@(FamInst { fi_tycon = tycon, do_rough (Just n) = Just (toIfaceTyCon_name n) -------------------------- +toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) + (toIfaceType (idType id)) + prag_info + where + -- Stripped-down version of tcIfaceIdInfo + -- Change this if you want to export more IdInfo for + -- non-top-level Ids. Don't forget to change + -- CoreTidy.tidyLetBndr too! + -- + -- See Note [IdInfo on nested let-bindings] in IfaceSyn + id_info = idInfo id + inline_prag = inlinePragInfo id_info + prag_info | isAlwaysActive inline_prag = NoInfo + | otherwise = HasInfo [HsInline inline_prag] + +-------------------------- toIfaceIdInfo :: IdInfo -> [IfaceInfoItem] toIfaceIdInfo id_info = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, @@ -1282,8 +1298,8 @@ toIfaceNote InlineMe = IfaceInlineMe toIfaceNote (CoreNote s) = IfaceCoreNote s --------------------- -toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceIdBndr b) (toIfaceExpr r) -toIfaceBind (Rec prs) = IfaceRec [(toIfaceIdBndr b, toIfaceExpr r) | (b,r) <- prs] +toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) +toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] --------------------- toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index b82685b..8bbb79a 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -48,7 +48,6 @@ import Outputable import ErrUtils import Maybes import SrcLoc -import Util import DynFlags import Control.Monad @@ -667,16 +666,17 @@ tcIfaceExpr (IfaceCase scrut case_bndr ty alts) returnM (Case scrut' case_bndr' ty' alts') tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) - = tcIfaceExpr rhs `thenM` \ rhs' -> - bindIfaceId bndr $ \ bndr' -> - tcIfaceExpr body `thenM` \ body' -> - returnM (Let (NonRec bndr' rhs') body') + = do { rhs' <- tcIfaceExpr rhs + ; id <- tcIfaceLetBndr bndr + ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) + ; return (Let (NonRec id rhs') body') } tcIfaceExpr (IfaceLet (IfaceRec pairs) body) - = bindIfaceIds bndrs $ \ bndrs' -> - mappM tcIfaceExpr rhss `thenM` \ rhss' -> - tcIfaceExpr body `thenM` \ body' -> - returnM (Let (Rec (bndrs' `zip` rhss')) body') + = do { ids <- mapM tcIfaceLetBndr bndrs + ; extendIfaceIdEnv ids $ do + { rhss' <- mapM tcIfaceExpr rhss + ; body' <- tcIfaceExpr body + ; return (Let (Rec (ids `zip` rhss')) body') } } where (bndrs, rhss) = unzip pairs @@ -961,8 +961,11 @@ tcIfaceExtId name = do { thing <- tcIfaceGlobal name \begin{code} bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a -bindIfaceBndr (IfaceIdBndr bndr) thing_inside - = bindIfaceId bndr thing_inside +bindIfaceBndr (IfaceIdBndr (fs, ty)) thing_inside + = do { name <- newIfaceName (mkVarOccFS fs) + ; ty' <- tcIfaceType ty + ; let id = mkLocalId name ty' + ; extendIfaceIdEnv [id] (thing_inside id) } bindIfaceBndr (IfaceTvBndr bndr) thing_inside = bindIfaceTyVar bndr thing_inside @@ -974,26 +977,24 @@ bindIfaceBndrs (b:bs) thing_inside thing_inside (b':bs') ----------------------- -bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a -bindIfaceId (occ, ty) thing_inside - = do { name <- newIfaceName (mkVarOccFS occ) +tcIfaceLetBndr (IfLetBndr fs ty info) + = do { name <- newIfaceName (mkVarOccFS fs) ; ty' <- tcIfaceType ty - ; let { id = mkLocalId name ty' } - ; extendIfaceIdEnv [id] (thing_inside id) } - -bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a -bindIfaceIds bndrs thing_inside - = do { names <- newIfaceNames (map mkVarOccFS occs) - ; tys' <- mappM tcIfaceType tys - ; let { ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' } - ; extendIfaceIdEnv ids (thing_inside ids) } + ; case info of + NoInfo -> return (mkLocalId name ty') + HasInfo i -> return (mkLocalIdWithInfo name ty' (tc_info i)) } where - (occs,tys) = unzip bndrs - + -- Similar to tcIdInfo, but much simpler + tc_info [] = vanillaIdInfo + tc_info (HsInline p : i) = tc_info i `setInlinePragInfo` p + tc_info (HsArity a : i) = tc_info i `setArityInfo` a + tc_info (HsStrictness s : i) = tc_info i `setAllStrictnessInfo` Just s + tc_info (other : i) = pprTrace "tcIfaceLetBndr: discarding unexpected IdInfo" + (ppr other) (tc_info i) ----------------------- -newExtCoreBndr :: IfaceIdBndr -> IfL Id -newExtCoreBndr (var, ty) +newExtCoreBndr :: IfaceLetBndr -> IfL Id +newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now = do { mod <- getIfModule ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcLoc ; ty' <- tcIfaceType ty diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 225c164..1925dac 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -200,12 +200,12 @@ let_bind :: { IfaceBinding } | vdef { let (b,r) = $1 in IfaceNonRec b r } -vdefs1 :: { [(IfaceIdBndr, IfaceExpr)] } +vdefs1 :: { [(IfaceLetBndr, IfaceExpr)] } : vdef { [$1] } | vdef ';' vdefs1 { $1:$3 } -vdef :: { (IfaceIdBndr, IfaceExpr) } - : fs_var_occ '::' ty '=' exp { (($1, $3), $5) } +vdef :: { (IfaceLetBndr, IfaceExpr) } + : fs_var_occ '::' ty '=' exp { (IfLetBndr $1 $3 NoInfo, $5) } | '%local' vdef { $2 } -- NB: qd_occ includes data constructors, because -- 1.7.10.4