projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
This BIG PATCH contains most of the work for the New Coercion Representation
[ghc-hetmet.git] / compiler / iface / IfaceSyn.lhs
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index c753375..48bef49 100644 (file)
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -27,7 +27,8 @@ module IfaceSyn (
 #include "HsVersions.h"
 
 import IfaceType
 #include "HsVersions.h"
 
 import IfaceType
-
+import CoreSyn( DFunArg, dfunArgExprs )
+import PprCore()            -- Printing DFunArgs
 import Demand
 import Annotations
 import Class
 import Demand
 import Annotations
 import Class
@@ -137,9 +138,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 +151,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 +161,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,
@@ -183,7 +184,7 @@ type IfaceAnnTarget = AnnTarget OccName
 data IfaceIdDetails
   = IfVanillaId
   | IfRecSelId IfaceTyCon Bool
 data IfaceIdDetails
   = IfVanillaId
   | IfRecSelId IfaceTyCon Bool
-  | IfDFunId
+  | IfDFunId Int          -- Number of silent args
 
 data IfaceIdInfo
   = NoInfo                     -- When writing interface file without -O
 
 data IfaceIdInfo
   = NoInfo                     -- When writing interface file without -O
@@ -212,28 +213,32 @@ data IfaceInfoItem
 
 data IfaceUnfolding 
   = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding
 
 data IfaceUnfolding 
   = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding
+                                -- Possibly could eliminate the Bool here, the information
+                                -- is also in the InlinePragma.
 
   | IfCompulsory IfaceExpr     -- Only used for default methods, in fact
 
 
   | IfCompulsory IfaceExpr     -- Only used for default methods, in fact
 
-  | IfInlineRule Arity 
+  | IfInlineRule Arity          -- INLINE pragmas
                  Bool          -- OK to inline even if *un*-saturated
                 Bool           -- OK to inline even if context is boring
                  IfaceExpr 
 
                  Bool          -- OK to inline even if *un*-saturated
                 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]
+  | IfDFunUnfold [DFunArg IfaceExpr]
 
 --------------------------------
 data IfaceExpr
 
 --------------------------------
 data IfaceExpr
-  = IfaceLcl   FastString
-  | IfaceExt    Name
+  = IfaceLcl   IfLclName
+  | IfaceExt    IfExtName
   | IfaceType   IfaceType
   | IfaceType   IfaceType
-  | IfaceTuple         Boxity [IfaceExpr]              -- Saturated; type arguments omitted
+  | IfaceCo     IfaceType              -- We re-use IfaceType for coercions
+  | IfaceTuple         Boxity [IfaceExpr]      -- Saturated; type arguments omitted
   | IfaceLam   IfaceBndr IfaceExpr
   | IfaceApp   IfaceExpr IfaceExpr
   | IfaceLam   IfaceBndr IfaceExpr
   | IfaceApp   IfaceExpr IfaceExpr
-  | IfaceCase  IfaceExpr FastString IfaceType [IfaceAlt]
+  | IfaceCase  IfaceExpr IfLclName [IfaceAlt]
   | IfaceLet   IfaceBinding  IfaceExpr
   | IfaceNote  IfaceNote IfaceExpr
   | IfaceCast   IfaceExpr IfaceCoercion
   | IfaceLet   IfaceBinding  IfaceExpr
   | IfaceNote  IfaceNote IfaceExpr
   | IfaceCast   IfaceExpr IfaceCoercion
@@ -244,13 +249,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
 
@@ -261,7 +266,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]
@@ -278,10 +283,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
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -595,6 +598,7 @@ pprIfaceExpr _       (IfaceLit l)       = ppr l
 pprIfaceExpr _       (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
 pprIfaceExpr _       (IfaceTick m ix)   = braces (text "tick" <+> ppr m <+> ppr ix)
 pprIfaceExpr _       (IfaceType ty)     = char '@' <+> pprParendIfaceType ty
 pprIfaceExpr _       (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
 pprIfaceExpr _       (IfaceTick m ix)   = braces (text "tick" <+> ppr m <+> ppr ix)
 pprIfaceExpr _       (IfaceType ty)     = char '@' <+> pprParendIfaceType ty
+pprIfaceExpr _       (IfaceCo co)       = text "@~" <+> pprParendIfaceType co
 
 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
 pprIfaceExpr _       (IfaceTuple c as)  = tupleParens c (interpp'SP as)
 
 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
 pprIfaceExpr _       (IfaceTuple c as)  = tupleParens c (interpp'SP as)
@@ -607,14 +611,14 @@ pprIfaceExpr add_par e@(IfaceLam _ _)
     collect bs (IfaceLam b e) = collect (b:bs) e
     collect bs e              = (reverse bs, e)
 
     collect bs (IfaceLam b e) = collect (b:bs) e
     collect bs e              = (reverse bs, e)
 
-pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
-  = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
+pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
+  = add_par (sep [ptext (sLit "case") 
                        <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") 
                        <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
                  pprIfaceExpr noParens rhs <+> char '}'])
 
                        <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") 
                        <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
                  pprIfaceExpr noParens rhs <+> char '}'])
 
-pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
-  = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
+pprIfaceExpr add_par (IfaceCase scrut bndr alts)
+  = add_par (sep [ptext (sLit "case") 
                        <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") 
                        <+> ppr bndr <+> char '{',
                  nest 2 (sep (map ppr_alt alts)) <+> char '}'])
                        <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") 
                        <+> ppr bndr <+> char '{',
                  nest 2 (sep (map ppr_alt alts)) <+> char '}'])
@@ -638,11 +642,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)
   
@@ -674,7 +678,7 @@ instance Outputable IfaceIdDetails where
   ppr IfVanillaId    = empty
   ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc
                          <+> if b then ptext (sLit "<naughty>") else empty
   ppr IfVanillaId    = empty
   ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc
                          <+> if b then ptext (sLit "<naughty>") else empty
-  ppr IfDFunId       = ptext (sLit "DFunId")
+  ppr (IfDFunId ns)     = ptext (sLit "DFunId") <> brackets (int ns)
 
 instance Outputable IfaceIdInfo where
   ppr NoInfo       = empty
 
 instance Outputable IfaceIdInfo where
   ppr NoInfo       = empty
@@ -693,11 +697,12 @@ 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:")
                              <+> parens (ptext (sLit "arity") <+> int a)
   ppr (IfDFunUnfold ns)    = ptext (sLit "DFun:")
-                             <+> brackets (pprWithCommas pprParendIfaceExpr ns)
-
+                             <+> brackets (pprWithCommas ppr ns)
 
 -- -----------------------------------------------------------------------------
 -- Finding the Names in IfaceSyn
 
 -- -----------------------------------------------------------------------------
 -- Finding the Names in IfaceSyn
@@ -785,6 +790,8 @@ freeNamesIfType (IfaceTyConApp tc ts) =
 freeNamesIfType (IfaceForAllTy tv t)  =
    freeNamesIfTvBndr tv &&& freeNamesIfType t
 freeNamesIfType (IfaceFunTy s t)      = freeNamesIfType s &&& freeNamesIfType t
 freeNamesIfType (IfaceForAllTy tv t)  =
    freeNamesIfTvBndr tv &&& freeNamesIfType t
 freeNamesIfType (IfaceFunTy s t)      = freeNamesIfType s &&& freeNamesIfType t
+freeNamesIfType (IfaceCoConApp tc ts) = 
+   freeNamesIfCo tc &&& fnList freeNamesIfType ts
 
 freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet
 freeNamesIfTvBndrs = fnList freeNamesIfTvBndr
 
 freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet
 freeNamesIfTvBndrs = fnList freeNamesIfTvBndr
@@ -795,8 +802,10 @@ freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b
 
 freeNamesIfLetBndr :: IfaceLetBndr -> NameSet
 -- Remember IfaceLetBndr is used only for *nested* bindings
 
 freeNamesIfLetBndr :: IfaceLetBndr -> NameSet
 -- Remember IfaceLetBndr is used only for *nested* bindings
--- The cut-down IdInfo never contains any Names, but the type may!
-freeNamesIfLetBndr (IfLetBndr _name ty _info) = freeNamesIfType ty
+-- The IdInfo can contain an unfolding (in the case of 
+-- local INLINE pragmas), so look there too
+freeNamesIfLetBndr (IfLetBndr _name ty info) = freeNamesIfType ty
+                                             &&& freeNamesIfIdInfo info
 
 freeNamesIfTvBndr :: IfaceTvBndr -> NameSet
 freeNamesIfTvBndr (_fs,k) = freeNamesIfType k
 
 freeNamesIfTvBndr :: IfaceTvBndr -> NameSet
 freeNamesIfTvBndr (_fs,k) = freeNamesIfType k
@@ -817,23 +826,24 @@ 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 (IfDFunUnfold vs)      = fnList freeNamesIfExpr vs
+freeNamesIfUnfold (IfExtWrapper _ v)     = unitNameSet v
+freeNamesIfUnfold (IfLclWrapper {})      = emptyNameSet
+freeNamesIfUnfold (IfDFunUnfold vs)      = fnList freeNamesIfExpr (dfunArgExprs vs)
 
 freeNamesIfExpr :: IfaceExpr -> NameSet
 freeNamesIfExpr (IfaceExt v)     = unitNameSet v
 freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
 freeNamesIfExpr (IfaceType ty)    = freeNamesIfType ty
 
 freeNamesIfExpr :: IfaceExpr -> NameSet
 freeNamesIfExpr (IfaceExt v)     = unitNameSet v
 freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
 freeNamesIfExpr (IfaceType ty)    = freeNamesIfType ty
+freeNamesIfExpr (IfaceCo co)      = freeNamesIfType co
 freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
 freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body
 freeNamesIfExpr (IfaceApp f a)    = freeNamesIfExpr f &&& freeNamesIfExpr a
 freeNamesIfExpr (IfaceCast e co)  = freeNamesIfExpr e &&& freeNamesIfType co
 freeNamesIfExpr (IfaceNote _n r)   = freeNamesIfExpr r
 
 freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
 freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body
 freeNamesIfExpr (IfaceApp f a)    = freeNamesIfExpr f &&& freeNamesIfExpr a
 freeNamesIfExpr (IfaceCast e co)  = freeNamesIfExpr e &&& freeNamesIfType co
 freeNamesIfExpr (IfaceNote _n r)   = freeNamesIfExpr r
 
-freeNamesIfExpr (IfaceCase s _ ty alts)
+freeNamesIfExpr (IfaceCase s _ alts)
   = freeNamesIfExpr s 
     &&& fnList fn_alt alts &&& fn_cons alts
   = freeNamesIfExpr s 
     &&& fnList fn_alt alts &&& fn_cons alts
-    &&& freeNamesIfType ty
   where
     fn_alt (_con,_bs,r) = freeNamesIfExpr r
 
   where
     fn_alt (_con,_bs,r) = freeNamesIfExpr r
 
@@ -854,12 +864,15 @@ freeNamesIfExpr (IfaceLet (IfaceRec as) x)
 
 freeNamesIfExpr _ = emptyNameSet
 
 
 freeNamesIfExpr _ = emptyNameSet
 
-
 freeNamesIfTc :: IfaceTyCon -> NameSet
 freeNamesIfTc (IfaceTc tc) = unitNameSet tc
 -- ToDo: shouldn't we include IfaceIntTc & co.?
 freeNamesIfTc _ = emptyNameSet
 
 freeNamesIfTc :: IfaceTyCon -> NameSet
 freeNamesIfTc (IfaceTc tc) = unitNameSet tc
 -- ToDo: shouldn't we include IfaceIntTc & co.?
 freeNamesIfTc _ = emptyNameSet
 
+freeNamesIfCo :: IfaceCoCon -> NameSet
+freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc
+freeNamesIfCo _ = emptyNameSet
+
 freeNamesIfRule :: IfaceRule -> NameSet
 freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
                            , ifRuleArgs = es, ifRuleRhs = rhs })
 freeNamesIfRule :: IfaceRule -> NameSet
 freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
                            , ifRuleArgs = es, ifRuleRhs = rhs })
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)