Serialise nested unfoldings across module boundaries

As Roman reported in #4428, nested let-bindings weren't
being recorded with their unfoldings.  Needless to say,
fixing this had more knock-on effects than I expected.

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 4db4c53..8b0499c 100644 (file)
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -278,7 +278,7 @@ cpeBind top_lvl env (Rec pairs)
        ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
 
        ; let (floats_s, bndrs2, rhss2) = unzip3 stuff
        ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
 
        ; let (floats_s, bndrs2, rhss2) = unzip3 stuff

-             all_pairs = foldrOL add_float (bndrs1 `zip` rhss2)
+             all_pairs = foldrOL add_float (bndrs2 `zip` rhss2)

                                           (concatFloats floats_s)
        ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
                         unitFloat (FloatLet (Rec all_pairs))) }
                                           (concatFloats floats_s)
        ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
                         unitFloat (FloatLet (Rec all_pairs))) }

@@ -310,9 +310,13 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
                        ; let float = mkFloat False False v rhs2
                        ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
 
                        ; let float = mkFloat False False v rhs2
                        ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
 

-               -- Record if the binder is evaluated
+       -- Record if the binder is evaluated
+       -- and otherwise trim off the unfolding altogether
+       -- It's not used by the code generator; getting rid of it reduces
+       -- heap usage and, since we may be changing uniques, we'd have
+       -- to substitute to keep it right

        ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
        ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding

-                          | otherwise      = bndr
+                          | otherwise      = bndr `setIdUnfolding` noUnfolding

 
        ; return (floats3, bndr', rhs') }
   where
 
        ; return (floats3, bndr', rhs') }
   where

diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs
index c928be4..e3bc72a 100644 (file)
--- a/compiler/coreSyn/CoreTidy.lhs
+++ b/compiler/coreSyn/CoreTidy.lhs
@@ -8,7 +8,7 @@ The code for *top-level* bindings is in TidyPgm.
 
 \begin{code}
 module CoreTidy (
 
 \begin{code}
 module CoreTidy (

-       tidyExpr, tidyVarOcc, tidyRule, tidyRules 
+       tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding

     ) where
 
 #include "HsVersions.h"
     ) where
 
 #include "HsVersions.h"

@@ -24,8 +24,8 @@ import UniqFM
 import Name hiding (tidyNameOcc)
 import SrcLoc
 import Maybes
 import Name hiding (tidyNameOcc)
 import SrcLoc
 import Maybes

-

 import Data.List
 import Data.List

+import Outputable

 \end{code}
 
 
 \end{code}
 
 

@@ -41,11 +41,13 @@ tidyBind :: TidyEnv
         ->  (TidyEnv, CoreBind)
 
 tidyBind env (NonRec bndr rhs)
         ->  (TidyEnv, CoreBind)
 
 tidyBind env (NonRec bndr rhs)

-  = tidyLetBndr env (bndr,rhs) =: \ (env', bndr') ->
+  = tidyLetBndr env env (bndr,rhs) =: \ (env', bndr') ->

     (env', NonRec bndr' (tidyExpr env' rhs))
 
 tidyBind env (Rec prs)
     (env', NonRec bndr' (tidyExpr env' rhs))
 
 tidyBind env (Rec prs)

-  = mapAccumL tidyLetBndr  env prs     =: \ (env', bndrs') ->
+  = let 
+       (env', bndrs') = mapAccumL (tidyLetBndr env') env prs
+    in

     map (tidyExpr env') (map snd prs)  =: \ rhss' ->
     (env', Rec (zip bndrs' rhss'))
 
     map (tidyExpr env') (map snd prs)  =: \ rhss' ->
     (env', Rec (zip bndrs' rhss'))
 

@@ -129,12 +131,17 @@ tidyBndr env var
 tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
 tidyBndrs env vars = mapAccumL tidyBndr env vars
 
 tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
 tidyBndrs env vars = mapAccumL tidyBndr env vars
 

-tidyLetBndr :: TidyEnv -> (Id, CoreExpr) -> (TidyEnv, Var)
+tidyLetBndr :: TidyEnv        -- Knot-tied version for unfoldings
+            -> TidyEnv                -- The one to extend
+            -> (Id, CoreExpr) -> (TidyEnv, Var)

 -- Used for local (non-top-level) let(rec)s
 -- Used for local (non-top-level) let(rec)s

-tidyLetBndr env (id,rhs) 
-  = ((tidy_env,new_var_env), final_id)
+tidyLetBndr rec_tidy_env env (id,rhs) 
+  = ((tidy_occ_env,new_var_env), final_id)

   where
   where

-    ((tidy_env,var_env), new_id) = tidyIdBndr env id
+    ((tidy_occ_env,var_env), new_id) = tidyIdBndr env id
+    new_var_env = extendVarEnv var_env id final_id
+       -- Override the env we get back from tidyId with the 
+       -- new IdInfo so it gets propagated to the usage sites.

 
        -- We need to keep around any interesting strictness and
        -- demand info because later on we may need to use it when
 
        -- We need to keep around any interesting strictness and
        -- demand info because later on we may need to use it when

@@ -156,12 +163,13 @@ tidyLetBndr env (id,rhs)
     new_info = idInfo new_id
                `setArityInfo`          exprArity rhs
                `setStrictnessInfo`     strictnessInfo idinfo
     new_info = idInfo new_id
                `setArityInfo`          exprArity rhs
                `setStrictnessInfo`     strictnessInfo idinfo

-               `setDemandInfo` demandInfo idinfo
+               `setDemandInfo`         demandInfo idinfo

                `setInlinePragInfo`     inlinePragInfo idinfo
                `setInlinePragInfo`     inlinePragInfo idinfo

+               `setUnfoldingInfo`      new_unf

 
 

-    -- Override the env we get back from tidyId with the new IdInfo
-    -- so it gets propagated to the usage sites.
-    new_var_env = extendVarEnv var_env id final_id
+    new_unf | isStableUnfolding unf = tidyUnfolding rec_tidy_env unf (panic "tidy_unf")
+            | otherwise                    = noUnfolding
+    unf = unfoldingInfo idinfo

 
 -- Non-top-level variables
 tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
 
 -- Non-top-level variables
 tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)

@@ -185,6 +193,24 @@ tidyIdBndr env@(tidy_env, var_env) id
     in
     ((tidy_env', var_env'), id')
    }
     in
     ((tidy_env', var_env'), id')
    }

+
+------------ Unfolding  --------------
+tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding
+tidyUnfolding tidy_env (DFunUnfolding ar con ids) _
+  = DFunUnfolding ar con (map (tidyExpr tidy_env) ids)
+tidyUnfolding tidy_env 
+              unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
+              unf_from_rhs
+  | isStableSource src
+  = unf { uf_tmpl = tidyExpr tidy_env unf_rhs,            -- Preserves OccInfo
+         uf_src  = tidySrc tidy_env src }
+  | otherwise
+  = unf_from_rhs
+tidyUnfolding _ unf _ = unf    -- NoUnfolding or OtherCon
+
+tidySrc :: TidyEnv -> UnfoldingSource -> UnfoldingSource
+tidySrc tidy_env (InlineWrapper w) = InlineWrapper (tidyVarOcc tidy_env w)
+tidySrc _        inl_info          = inl_info

 \end{code}
 
 Note [Tidy IdInfo]
 \end{code}
 
 Note [Tidy IdInfo]

diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index f7a9aa2..7c84778 100644 (file)
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -1209,15 +1209,19 @@ instance Binary IfaceUnfolding where
        put_ bh b
        put_ bh c
        put_ bh d
        put_ bh b
        put_ bh c
        put_ bh d

-    put_ bh (IfWrapper a n) = do
+    put_ bh (IfLclWrapper a n) = do

        putByte bh 2
        put_ bh a
        put_ bh n
        putByte bh 2
        put_ bh a
        put_ bh n

-    put_ bh (IfDFunUnfold as) = do
+    put_ bh (IfExtWrapper a n) = do

        putByte bh 3
        putByte bh 3

+       put_ bh a
+       put_ bh n
+    put_ bh (IfDFunUnfold as) = do
+       putByte bh 4

        put_ bh as
     put_ bh (IfCompulsory e) = do
        put_ bh as
     put_ bh (IfCompulsory e) = do

-       putByte bh 4
+       putByte bh 5

        put_ bh e
     get bh = do
        h <- getByte bh
        put_ bh e
     get bh = do
        h <- getByte bh

@@ -1232,8 +1236,11 @@ instance Binary IfaceUnfolding where
                  return (IfInlineRule a b c d)
          2 -> do a <- get bh
                  n <- get bh
                  return (IfInlineRule a b c d)
          2 -> do a <- get bh
                  n <- get bh

-                 return (IfWrapper a n)
-         3 -> do as <- get bh
+                 return (IfLclWrapper a n)
+         3 -> do a <- get bh
+                 n <- get bh
+                 return (IfExtWrapper a n)
+         4 -> do as <- get bh

                  return (IfDFunUnfold as)
          _ -> do e <- get bh
                  return (IfCompulsory e)
                  return (IfDFunUnfold as)
          _ -> do e <- get bh
                  return (IfCompulsory e)

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 3d40b38..f86f4b9 100644 (file)
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -137,9 +137,9 @@ data IfaceConDecl
                                                -- or 1-1 corresp with arg tys
 
 data IfaceInst 
                                                -- or 1-1 corresp with arg tys
 
 data IfaceInst 

-  = IfaceInst { ifInstCls  :: Name,                    -- See comments with
+  = IfaceInst { ifInstCls  :: IfExtName,               -- See comments with

                ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of Instance
                ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of Instance

-               ifDFun     :: Name,                     -- The dfun
+               ifDFun     :: IfExtName,                -- The dfun

                ifOFlag    :: OverlapFlag,              -- Overlap flag
                ifInstOrph :: Maybe OccName }           -- See Note [Orphans]
        -- There's always a separate IfaceDecl for the DFun, which gives 
                ifOFlag    :: OverlapFlag,              -- Overlap flag
                ifInstOrph :: Maybe OccName }           -- See Note [Orphans]
        -- There's always a separate IfaceDecl for the DFun, which gives 

@@ -150,7 +150,7 @@ data IfaceInst
        -- and if the head does not change it won't be used if it wasn't before
 
 data IfaceFamInst
        -- and if the head does not change it won't be used if it wasn't before
 
 data IfaceFamInst

-  = IfaceFamInst { ifFamInstFam   :: Name                -- Family tycon
+  = IfaceFamInst { ifFamInstFam   :: IfExtName                -- Family tycon

                 , ifFamInstTys   :: [Maybe IfaceTyCon]  -- Rough match types
                 , ifFamInstTyCon :: IfaceTyCon          -- Instance decl
                 }
                 , ifFamInstTys   :: [Maybe IfaceTyCon]  -- Rough match types
                 , ifFamInstTyCon :: IfaceTyCon          -- Instance decl
                 }

@@ -160,7 +160,7 @@ data IfaceRule
        ifRuleName   :: RuleName,
        ifActivation :: Activation,
        ifRuleBndrs  :: [IfaceBndr],    -- Tyvars and term vars
        ifRuleName   :: RuleName,
        ifActivation :: Activation,
        ifRuleBndrs  :: [IfaceBndr],    -- Tyvars and term vars

-       ifRuleHead   :: Name,           -- Head of lhs
+       ifRuleHead   :: IfExtName,      -- Head of lhs

        ifRuleArgs   :: [IfaceExpr],    -- Args of LHS
        ifRuleRhs    :: IfaceExpr,
        ifRuleAuto   :: Bool,
        ifRuleArgs   :: [IfaceExpr],    -- Args of LHS
        ifRuleRhs    :: IfaceExpr,
        ifRuleAuto   :: Bool,

@@ -222,20 +222,21 @@ data IfaceUnfolding
                 Bool           -- OK to inline even if context is boring
                  IfaceExpr 
 
                 Bool           -- OK to inline even if context is boring
                  IfaceExpr 
 

-  | IfWrapper    Arity Name      -- NB: we need a Name (not just OccName) because the worker
-                                 --     can simplify to a function in another module.
+  | IfExtWrapper Arity IfExtName  -- NB: sometimes we need a IfExtName (not just IfLclName) 
+  | IfLclWrapper Arity IfLclName  --     because the worker can simplify to a function in 
+                                 --     another module.

 
   | IfDFunUnfold [IfaceExpr]
 
 --------------------------------
 data IfaceExpr
 
   | IfDFunUnfold [IfaceExpr]
 
 --------------------------------
 data IfaceExpr

-  = IfaceLcl   FastString
-  | IfaceExt    Name
+  = IfaceLcl   IfLclName
+  | IfaceExt    IfExtName

   | IfaceType   IfaceType
   | IfaceTuple         Boxity [IfaceExpr]              -- Saturated; type arguments omitted
   | IfaceLam   IfaceBndr IfaceExpr
   | IfaceApp   IfaceExpr IfaceExpr
   | IfaceType   IfaceType
   | IfaceTuple         Boxity [IfaceExpr]              -- Saturated; type arguments omitted
   | IfaceLam   IfaceBndr IfaceExpr
   | IfaceApp   IfaceExpr IfaceExpr

-  | IfaceCase  IfaceExpr FastString IfaceType [IfaceAlt]
+  | IfaceCase  IfaceExpr IfLclName IfaceType [IfaceAlt]

   | IfaceLet   IfaceBinding  IfaceExpr
   | IfaceNote  IfaceNote IfaceExpr
   | IfaceCast   IfaceExpr IfaceCoercion
   | IfaceLet   IfaceBinding  IfaceExpr
   | IfaceNote  IfaceNote IfaceExpr
   | IfaceCast   IfaceExpr IfaceCoercion

@@ -246,13 +247,13 @@ data IfaceExpr
 data IfaceNote = IfaceSCC CostCentre
                | IfaceCoreNote String
 
 data IfaceNote = IfaceSCC CostCentre
                | IfaceCoreNote String
 

-type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
-       -- Note: FastString, not IfaceBndr (and same with the case binder)
+type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr)
+       -- Note: IfLclName, not IfaceBndr (and same with the case binder)

        -- We reconstruct the kind/type of the thing from the context
        -- thus saving bulk in interface files
 
 data IfaceConAlt = IfaceDefault
        -- We reconstruct the kind/type of the thing from the context
        -- thus saving bulk in interface files
 
 data IfaceConAlt = IfaceDefault

-                | IfaceDataAlt Name
+                | IfaceDataAlt IfExtName

                 | IfaceTupleAlt Boxity
                 | IfaceLitAlt Literal
 
                 | IfaceTupleAlt Boxity
                 | IfaceLitAlt Literal
 

@@ -263,7 +264,7 @@ data IfaceBinding
 -- 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]
 -- 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
+data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo

 \end{code}
 
 Note [Expose recursive functions]
 \end{code}
 
 Note [Expose recursive functions]

@@ -280,10 +281,8 @@ 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.
 
 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.
-
+In general we retain all info that is left by CoreTidy.tidyLetBndr, since
+that is what is seen by importing module with --make

 
 Note [Orphans]: the ifInstOrph and ifRuleOrph fields
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 Note [Orphans]: the ifInstOrph and ifRuleOrph fields
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -640,11 +639,11 @@ pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
 
 pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprParendIfaceExpr body)
 
 
 pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprParendIfaceExpr body)
 

-ppr_alt :: (IfaceConAlt, [FastString], IfaceExpr) -> SDoc
+ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc

 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, 
                              arrow <+> pprIfaceExpr noParens rhs]
 
 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, 
                              arrow <+> pprIfaceExpr noParens rhs]
 

-ppr_con_bs :: IfaceConAlt -> [FastString] -> SDoc
+ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc

 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)
   

@@ -695,7 +694,9 @@ instance Outputable IfaceUnfolding where
   ppr (IfCoreUnfold s e)   = (if s then ptext (sLit "<stable>") else empty) <+> parens (ppr e)
   ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok),
                                        pprParendIfaceExpr e]
   ppr (IfCoreUnfold s e)   = (if s then ptext (sLit "<stable>") else empty) <+> parens (ppr e)
   ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok),
                                        pprParendIfaceExpr e]

-  ppr (IfWrapper a wkr)    = ptext (sLit "Worker:") <+> ppr wkr
+  ppr (IfLclWrapper a wkr) = ptext (sLit "Worker(lcl):") <+> ppr wkr
+                             <+> parens (ptext (sLit "arity") <+> int a)
+  ppr (IfExtWrapper a wkr) = ptext (sLit "Worker(ext0:") <+> ppr wkr

                              <+> parens (ptext (sLit "arity") <+> int a)
   ppr (IfDFunUnfold ns)    = ptext (sLit "DFun:")
                              <+> brackets (pprWithCommas pprParendIfaceExpr ns)
                              <+> parens (ptext (sLit "arity") <+> int a)
   ppr (IfDFunUnfold ns)    = ptext (sLit "DFun:")
                              <+> brackets (pprWithCommas pprParendIfaceExpr ns)

@@ -819,7 +820,8 @@ freeNamesIfUnfold :: IfaceUnfolding -> NameSet
 freeNamesIfUnfold (IfCoreUnfold _ e)     = freeNamesIfExpr e
 freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e
 freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
 freeNamesIfUnfold (IfCoreUnfold _ e)     = freeNamesIfExpr e
 freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e
 freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e

-freeNamesIfUnfold (IfWrapper _ v)        = unitNameSet v
+freeNamesIfUnfold (IfExtWrapper _ v)     = unitNameSet v
+freeNamesIfUnfold (IfLclWrapper {})      = emptyNameSet

 freeNamesIfUnfold (IfDFunUnfold vs)      = fnList freeNamesIfExpr vs
 
 freeNamesIfExpr :: IfaceExpr -> NameSet
 freeNamesIfUnfold (IfDFunUnfold vs)      = fnList freeNamesIfExpr vs
 
 freeNamesIfExpr :: IfaceExpr -> NameSet

diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs
index 47772d7..c97e16e 100644 (file)
--- a/compiler/iface/IfaceType.lhs
+++ b/compiler/iface/IfaceType.lhs
@@ -7,7 +7,9 @@ This module defines interface types and binders
 
 \begin{code}
 module IfaceType (
 
 \begin{code}
 module IfaceType (

-       IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..),
+       IfExtName, IfLclName,
+
+        IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..),

        IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion,
        ifaceTyConName,
 
        IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion,
        ifaceTyConName,
 

@@ -41,19 +43,24 @@ import FastString
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

+type IfLclName = FastString    -- A local name in iface syntax
+
+type IfExtName = Name  -- An External or WiredIn Name can appear in IfaceSyn
+                       -- (However Internal or System Names never should)
+

 data IfaceBndr                 -- Local (non-top-level) binders
   = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr
   | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr
 
 data IfaceBndr                 -- Local (non-top-level) binders
   = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr
   | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr
 

-type IfaceIdBndr  = (FastString, IfaceType)
-type IfaceTvBndr  = (FastString, IfaceKind)
+type IfaceIdBndr  = (IfLclName, IfaceType)
+type IfaceTvBndr  = (IfLclName, IfaceKind)

 
 -------------------------------
 type IfaceKind     = IfaceType
 type IfaceCoercion = IfaceType
 
 data IfaceType
 
 -------------------------------
 type IfaceKind     = IfaceType
 type IfaceCoercion = IfaceType
 
 data IfaceType

-  = IfaceTyVar    FastString                   -- Type variable only, not tycon
+  = IfaceTyVar    IfLclName                    -- Type variable only, not tycon

   | IfaceAppTy    IfaceType IfaceType
   | IfaceForAllTy IfaceTvBndr IfaceType
   | IfacePredTy   IfacePredType
   | IfaceAppTy    IfaceType IfaceType
   | IfaceForAllTy IfaceTvBndr IfaceType
   | IfacePredTy   IfacePredType

@@ -62,14 +69,14 @@ data IfaceType
   | IfaceFunTy  IfaceType IfaceType
 
 data IfacePredType     -- NewTypes are handled as ordinary TyConApps
   | IfaceFunTy  IfaceType IfaceType
 
 data IfacePredType     -- NewTypes are handled as ordinary TyConApps

-  = IfaceClassP Name [IfaceType]
+  = IfaceClassP IfExtName [IfaceType]

   | IfaceIParam (IPName OccName) IfaceType
   | IfaceEqPred IfaceType IfaceType
 
 type IfaceContext = [IfacePredType]
 
 data IfaceTyCon        -- Abbreviations for common tycons with known names
   | IfaceIParam (IPName OccName) IfaceType
   | IfaceEqPred IfaceType IfaceType
 
 type IfaceContext = [IfacePredType]
 
 data IfaceTyCon        -- Abbreviations for common tycons with known names

-  = IfaceTc Name       -- The common case
+  = IfaceTc IfExtName  -- The common case

   | IfaceIntTc | IfaceBoolTc | IfaceCharTc
   | IfaceListTc | IfacePArrTc
   | IfaceTupTc Boxity Arity 
   | IfaceIntTc | IfaceBoolTc | IfaceCharTc
   | IfaceListTc | IfacePArrTc
   | IfaceTupTc Boxity Arity 

@@ -78,7 +85,7 @@ data IfaceTyCon       -- Abbreviations for common tycons with known names
   | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc
   | IfaceUbxTupleKindTc | IfaceArgTypeKindTc 
 
   | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc
   | IfaceUbxTupleKindTc | IfaceArgTypeKindTc 
 

-ifaceTyConName :: IfaceTyCon -> Name
+ifaceTyConName :: IfaceTyCon -> IfExtName

 ifaceTyConName IfaceIntTc             = intTyConName
 ifaceTyConName IfaceBoolTc            = boolTyConName
 ifaceTyConName IfaceCharTc            = charTyConName
 ifaceTyConName IfaceIntTc             = intTyConName
 ifaceTyConName IfaceBoolTc            = boolTyConName
 ifaceTyConName IfaceCharTc            = charTyConName

@@ -173,7 +180,7 @@ instance Outputable IfaceBndr where
 pprIfaceBndrs :: [IfaceBndr] -> SDoc
 pprIfaceBndrs bs = sep (map ppr bs)
 
 pprIfaceBndrs :: [IfaceBndr] -> SDoc
 pprIfaceBndrs bs = sep (map ppr bs)
 

-pprIfaceIdBndr :: (FastString, IfaceType) -> SDoc
+pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc

 pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty]
 
 pprIfaceTvBndr :: IfaceTvBndr -> SDoc
 pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty]
 
 pprIfaceTvBndr :: IfaceTvBndr -> SDoc

@@ -284,11 +291,11 @@ pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
 
 \begin{code}
 ----------------
 
 \begin{code}
 ----------------

-toIfaceTvBndr :: TyVar -> (FastString, IfaceType)
+toIfaceTvBndr :: TyVar -> (IfLclName, IfaceType)

 toIfaceTvBndr tyvar   = (occNameFS (getOccName tyvar), toIfaceKind (tyVarKind tyvar))
 toIfaceTvBndr tyvar   = (occNameFS (getOccName tyvar), toIfaceKind (tyVarKind tyvar))

-toIfaceIdBndr :: Id -> (FastString, IfaceType)
+toIfaceIdBndr :: Id -> (IfLclName, IfaceType)

 toIfaceIdBndr id      = (occNameFS (getOccName id),    toIfaceType (idType id))
 toIfaceIdBndr id      = (occNameFS (getOccName id),    toIfaceType (idType id))

-toIfaceTvBndrs :: [TyVar] -> [(FastString, IfaceType)]
+toIfaceTvBndrs :: [TyVar] -> [(IfLclName, IfaceType)]

 toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars
 
 toIfaceBndr :: Var -> IfaceBndr
 toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars
 
 toIfaceBndr :: Var -> IfaceBndr

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index a8ea826..0d59216 100644 (file)
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -439,7 +439,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
           | isWiredInName name  =  putNameLiterally bh name 
            -- wired-in names don't have fingerprints
           | otherwise
           | isWiredInName name  =  putNameLiterally bh name 
            -- wired-in names don't have fingerprints
           | otherwise

-          = ASSERT( isExternalName name )
+          = ASSERT2( isExternalName name, ppr name )

            let hash | nameModule name /= this_mod =  global_hash_fn name
                      | otherwise = 
                         snd (lookupOccEnv local_env (getOccName name)
            let hash | nameModule name /= this_mod =  global_hash_fn name
                      | otherwise = 
                         snd (lookupOccEnv local_env (getOccName name)

@@ -1322,11 +1322,7 @@ tyThingToIfaceDecl (AnId id)
   = IfaceId { ifName      = getOccName id,
              ifType      = toIfaceType (idType id),
              ifIdDetails = toIfaceIdDetails (idDetails id),
   = IfaceId { ifName      = getOccName id,
              ifType      = toIfaceType (idType id),
              ifIdDetails = toIfaceIdDetails (idDetails id),

-             ifIdInfo    = info }
-  where
-    info = case toIfaceIdInfo (idInfo id) of
-               []    -> NoInfo
-               items -> HasInfo items
+             ifIdInfo    = toIfaceIdInfo (idInfo id) }

 
 tyThingToIfaceDecl (AClass clas)
   = IfaceClass { ifCtxt          = toIfaceContext sc_theta,
 
 tyThingToIfaceDecl (AClass clas)
   = IfaceClass { ifCtxt          = toIfaceContext sc_theta,

@@ -1482,18 +1478,9 @@ famInstToIfaceFamInst (FamInst { fi_tycon = tycon,
 toIfaceLetBndr :: Id -> IfaceLetBndr
 toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
                               (toIfaceType (idType id)) 
 toIfaceLetBndr :: Id -> IfaceLetBndr
 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 | isDefaultInlinePragma inline_prag = NoInfo
-             | otherwise                         = HasInfo [HsInline inline_prag]
+                              (toIfaceIdInfo (idInfo id))
+  -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr 
+  -- has left on the Id.  See Note [IdInfo on nested let-bindings] in IfaceSyn

 
 --------------------------
 toIfaceIdDetails :: IdDetails -> IfaceIdDetails
 
 --------------------------
 toIfaceIdDetails :: IdDetails -> IfaceIdDetails

@@ -1504,11 +1491,13 @@ toIfaceIdDetails (RecSelId { sel_naughty = n
 toIfaceIdDetails other                         = pprTrace "toIfaceIdDetails" (ppr other) 
                                                   IfVanillaId   -- Unexpected
 
 toIfaceIdDetails other                         = pprTrace "toIfaceIdDetails" (ppr other) 
                                                   IfVanillaId   -- Unexpected
 

-toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
+toIfaceIdInfo :: IdInfo -> IfaceIdInfo

 toIfaceIdInfo id_info
 toIfaceIdInfo id_info

-  = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, 
-              inline_hsinfo,  unfold_hsinfo] 
-              -- NB: strictness must be before unfolding
+  = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, 
+                   inline_hsinfo,  unfold_hsinfo] of
+       []    -> NoInfo
+       infos -> HasInfo infos
+              -- NB: strictness must appear in the list before unfolding

               -- See TcIface.tcUnfolding
   where
     ------------  Arity  --------------
               -- See TcIface.tcUnfolding
   where
     ------------  Arity  --------------

@@ -1547,7 +1536,10 @@ toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
           -> case guidance of
                UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs
                _other                     -> IfCoreUnfold True if_rhs
           -> case guidance of
                UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs
                _other                     -> IfCoreUnfold True if_rhs

-       InlineWrapper w  -> IfWrapper arity (idName w)
+       InlineWrapper w | isExternalName n -> IfExtWrapper arity n
+                       | otherwise        -> IfLclWrapper arity (getFS n)
+                       where
+                          n = idName w

         InlineCompulsory -> IfCompulsory if_rhs
         InlineRhs        -> IfCoreUnfold False if_rhs
        -- Yes, even if guidance is UnfNever, expose the unfolding
         InlineCompulsory -> IfCompulsory if_rhs
         InlineRhs        -> IfCoreUnfold False if_rhs
        -- Yes, even if guidance is UnfNever, expose the unfolding

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index ba1da60..c39b713 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -39,8 +39,8 @@ import TyCon
 import DataCon
 import TysWiredIn
 import TysPrim         ( anyTyConOfKind )
 import DataCon
 import TysWiredIn
 import TysPrim         ( anyTyConOfKind )

-import Var              ( TyVar )
-import BasicTypes      ( nonRuleLoopBreaker )
+import Var              ( Var, TyVar )
+import BasicTypes      ( Arity, nonRuleLoopBreaker )

 import qualified Var
 import VarEnv
 import Name
 import qualified Var
 import VarEnv
 import Name

@@ -1038,8 +1038,23 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
                                                  (UnfWhen unsat_ok boring_ok))
     }
 
                                                  (UnfWhen unsat_ok boring_ok))
     }
 

-tcUnfolding name ty info (IfWrapper arity wkr)
-  = do         { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
+tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
+  = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
+       ; return (case mb_ops1 of
+                           Nothing   -> noUnfolding
+                    Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
+  where
+    doc = text "Class ops for dfun" <+> ppr name
+
+tcUnfolding name ty info (IfExtWrapper arity wkr)
+  = tcIfaceWrapper name ty info arity (tcIfaceExtId wkr)
+tcUnfolding name ty info (IfLclWrapper arity wkr)
+  = tcIfaceWrapper name ty info arity (tcIfaceLclId wkr)
+
+-------------
+tcIfaceWrapper :: Name -> Type -> IdInfo -> Arity -> IfL Id -> IfL Unfolding
+tcIfaceWrapper name ty info arity get_worker
+  = do         { mb_wkr_id <- forkM_maybe doc get_worker

        ; us <- newUniqueSupply
        ; return (case mb_wkr_id of
                     Nothing     -> noUnfolding
        ; us <- newUniqueSupply
        ; return (case mb_wkr_id of
                     Nothing     -> noUnfolding

@@ -1056,15 +1071,7 @@ tcUnfolding name ty info (IfWrapper arity wkr)
        -- before unfolding
     strict_sig = case strictnessInfo info of
                   Just sig -> sig
        -- before unfolding
     strict_sig = case strictnessInfo info of
                   Just sig -> sig

-                  Nothing  -> pprPanic "Worker info but no strictness for" (ppr wkr)
-
-tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
-  = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
-       ; return (case mb_ops1 of
-                           Nothing   -> noUnfolding
-                    Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
-  where
-    doc = text "Class ops for dfun" <+> ppr name
+                  Nothing  -> pprPanic "Worker info but no strictness for" (ppr name)

 \end{code}
 
 For unfoldings we try to do the job lazily, so that we never type check
 \end{code}
 
 For unfoldings we try to do the job lazily, so that we never type check

@@ -1078,22 +1085,28 @@ tcPragExpr name expr
 
                 -- Check for type consistency in the unfolding
     ifDOptM Opt_DoCoreLinting $ do
 
                 -- Check for type consistency in the unfolding
     ifDOptM Opt_DoCoreLinting $ do

-        in_scope <- get_in_scope_ids
+        in_scope <- get_in_scope

         case lintUnfolding noSrcLoc in_scope core_expr' of
           Nothing       -> return ()
         case lintUnfolding noSrcLoc in_scope core_expr' of
           Nothing       -> return ()

-          Just fail_msg -> pprPanic "Iface Lint failure" (hang doc 2 fail_msg)
-
+          Just fail_msg -> do { mod <- getIfModule 
+                              ; pprPanic "Iface Lint failure" 
+                                  (vcat [ ptext (sLit "In interface for") <+> ppr mod
+                                        , hang doc 2 fail_msg ]) }

     return core_expr'
   where
     doc = text "Unfolding of" <+> ppr name
     return core_expr'
   where
     doc = text "Unfolding of" <+> ppr name

-    get_in_scope_ids   -- Urgh; but just for linting
-       = setLclEnv () $ 
-         do    { env <- getGblEnv 
-               ; case if_rec_types env of {
-                         Nothing -> return [] ;
-                         Just (_, get_env) -> do
-               { type_env <- get_env
-               ; return (typeEnvIds type_env) }}}
+
+    get_in_scope :: IfL [Var] -- Totally disgusting; but just for linting
+    get_in_scope       
+       = do { (gbl_env, lcl_env) <- getEnvs
+             ; setLclEnv () $ do
+            { case if_rec_types gbl_env of {
+                 Nothing -> return [] ;
+                 Just (_, get_env) -> do
+            { type_env <- get_env
+             ; return (varEnvElts (if_tv_env lcl_env) ++
+                       varEnvElts (if_id_env lcl_env) ++
+                       typeEnvIds type_env) }}}}

 \end{code}
 
 
 \end{code}
 
 

@@ -1229,17 +1242,9 @@ tcIfaceLetBndr :: IfaceLetBndr -> IfL Id
 tcIfaceLetBndr (IfLetBndr fs ty info)
   = do { name <- newIfaceName (mkVarOccFS fs)
        ; ty' <- tcIfaceType ty
 tcIfaceLetBndr (IfLetBndr fs ty info)
   = do { name <- newIfaceName (mkVarOccFS fs)
        ; ty' <- tcIfaceType ty

-       ; case info of
-               NoInfo    -> return (mkLocalId name ty')
-               HasInfo i -> return (mkLocalIdWithInfo name ty' (tc_info i)) } 
-  where
-       -- 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 `setStrictnessInfo` Just s 
-    tc_info (other          : i) = pprTrace "tcIfaceLetBndr: discarding unexpected IdInfo" 
-                                           (ppr other) (tc_info i)
+        ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
+                              name ty' info
+       ; return (mkLocalIdWithInfo name ty' id_info) } 

 
 -----------------------
 newExtCoreBndr :: IfaceLetBndr -> IfL Id
 
 -----------------------
 newExtCoreBndr :: IfaceLetBndr -> IfL Id

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 8025f20..4ab553d 100644 (file)
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -1065,8 +1065,12 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info
 
     --------- Unfolding ------------
     unf_info = unfoldingInfo idinfo
 
     --------- Unfolding ------------
     unf_info = unfoldingInfo idinfo

-    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env tidy_rhs final_sig unf_info
+    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs

                | otherwise   = noUnfolding
                | otherwise   = noUnfolding

+    unf_from_rhs = mkTopUnfolding is_bot tidy_rhs
+    is_bot = case final_sig of 
+                Just sig -> isBottomingSig sig
+                Nothing  -> False

     -- NB: do *not* expose the worker if show_unfold is off,
     --     because that means this thing is a loop breaker or
     --     marked NOINLINE or something like that
     -- NB: do *not* expose the worker if show_unfold is off,
     --     because that means this thing is a loop breaker or
     --     marked NOINLINE or something like that

@@ -1089,30 +1093,6 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info
     -- it to the top level. So it seems more robust just to
     -- fix it here.
     arity = exprArity orig_rhs
     -- it to the top level. So it seems more robust just to
     -- fix it here.
     arity = exprArity orig_rhs

-
-
-
------------- Unfolding  --------------
-tidyUnfolding :: TidyEnv -> CoreExpr -> Maybe StrictSig -> Unfolding -> Unfolding
-tidyUnfolding tidy_env _ _ (DFunUnfolding ar con ids)
-  = DFunUnfolding ar con (map (tidyExpr tidy_env) ids)
-tidyUnfolding tidy_env tidy_rhs strict_sig
-              unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
-  | isStableSource src
-  = unf { uf_tmpl = tidyExpr tidy_env unf_rhs,            -- Preserves OccInfo
-         uf_src  = tidyInl tidy_env src }
-  | otherwise
-  = mkTopUnfolding is_bot tidy_rhs
-  where
-    is_bot = case strict_sig of 
-                Just sig -> isBottomingSig sig
-                Nothing  -> False
-
-tidyUnfolding _ _ _ unf = unf
-
-tidyInl :: TidyEnv -> UnfoldingSource -> UnfoldingSource
-tidyInl tidy_env (InlineWrapper w) = InlineWrapper (tidyVarOcc tidy_env w)
-tidyInl _        inl_info          = inl_info

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************