summary |
shortlog |
log |
commit | commitdiff |
tree
raw |
patch |
inline | side by side (from parent 1:
7739158)
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.
-- CorePrep to turn the let into a case.
--
-- Similarly arity info for eta expansion in CorePrep
-- 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
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.
-- Override the env we get back from tidyId with the new IdInfo
-- so it gets propagated to the usage sites.
_ -> do ab <- get bh
return (IfaceTvBndr ab)
_ -> 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
instance Binary IfaceType where
put_ bh (IfaceForAllTy aa ab) = do
putByte bh 0
module IfaceType, -- Re-export all this
IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
module IfaceType, -- Re-export all this
IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
- IfaceExpr(..), IfaceAlt, IfaceNote(..),
+ IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
| IfaceLitAlt Literal
data IfaceBinding
| 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
+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
Note [Orphans]: the ifInstOrph and ifRuleOrph fields
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If a module contains any "orphans", then its interface file is read
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_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)
------------------
pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
------------------
instance Outputable IfaceIdInfo 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)
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
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_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_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
where
(bs1,rs1) = unzip as1
(bs2,rs2) = unzip as2
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_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_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_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_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)
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)
type IfaceTvBndr = (FastString, IfaceKind)
-------------------------------
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
type IfaceCoercion = IfaceType
data IfaceType
\begin{code}
---------------------------------
instance Outputable IfaceType where
\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
pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc
pprIfaceType = ppr_ty tOP_PREC
do_rough (Just n) = Just (toIfaceTyCon_name n)
--------------------------
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,
toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
toIfaceIdInfo id_info
= catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
toIfaceNote (CoreNote s) = IfaceCoreNote s
---------------------
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)
---------------------
toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
import ErrUtils
import Maybes
import SrcLoc
import ErrUtils
import Maybes
import SrcLoc
import DynFlags
import Control.Monad
import DynFlags
import Control.Monad
returnM (Case scrut' case_bndr' ty' alts')
tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
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)
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
where
(bndrs, rhss) = unzip pairs
\begin{code}
bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
\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
bindIfaceBndr (IfaceTvBndr bndr) thing_inside
= bindIfaceTyVar bndr thing_inside
thing_inside (b':bs')
-----------------------
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)
- ; 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)) }
- (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
= do { mod <- getIfModule
; name <- newGlobalBinder mod (mkVarOccFS var) noSrcLoc
; ty' <- tcIfaceType ty
| vdef { let (b,r) = $1
in IfaceNonRec b r }
| vdef { let (b,r) = $1
in IfaceNonRec b r }
-vdefs1 :: { [(IfaceIdBndr, IfaceExpr)] }
+vdefs1 :: { [(IfaceLetBndr, IfaceExpr)] }
: vdef { [$1] }
| vdef ';' vdefs1 { $1:$3 }
: 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
| '%local' vdef { $2 }
-- NB: qd_occ includes data constructors, because