-- 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.
_ -> 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
module IfaceType, -- Re-export all this
IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
- IfaceExpr(..), IfaceAlt, IfaceNote(..),
+ IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
| 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
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)
------------------
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}
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
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)
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
\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
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,
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)
import ErrUtils
import Maybes
import SrcLoc
-import Util
import DynFlags
import Control.Monad
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
\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
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
| 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