Commit d33c0b24 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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.
parent 7739158f
......@@ -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.
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -1173,6 +1173,22 @@ famInstToIfaceFamInst fi@(FamInst { fi_tycon = tycon,
do_rough Nothing = Nothing
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
......@@ -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)
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment