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.

diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs
index c4e7ed9..6699ace 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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