Rollback INLINE patches

[ghc-hetmet.git] / compiler / iface / TcIface.lhs

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 48ca729..7f74cf2 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -53,6 +53,7 @@ import SrcLoc
 import DynFlags
 import Util
 import FastString
 import DynFlags
 import Util
 import FastString

+import BasicTypes (Arity)

 
 import Control.Monad
 import Data.List
 
 import Control.Monad
 import Data.List

@@ -847,6 +848,7 @@ tcIfaceExpr (IfaceCast expr co) = do
 tcIfaceExpr (IfaceNote note expr) = do
     expr' <- tcIfaceExpr expr
     case note of
 tcIfaceExpr (IfaceNote note expr) = do
     expr' <- tcIfaceExpr expr
     case note of

+        IfaceInlineMe     -> return (Note InlineMe   expr')

         IfaceSCC cc       -> return (Note (SCC cc)   expr')
         IfaceCoreNote n   -> return (Note (CoreNote n) expr')
 
         IfaceSCC cc       -> return (Note (SCC cc)   expr')
         IfaceCoreNote n   -> return (Note (CoreNote n) expr')
 

@@ -940,39 +942,43 @@ tcIdInfo ignore_prags name ty info
     tcPrag info HsNoCafRefs         = return (info `setCafInfo`   NoCafRefs)
     tcPrag info (HsArity arity)     = return (info `setArityInfo` arity)
     tcPrag info (HsStrictness str)  = return (info `setAllStrictnessInfo` Just str)
     tcPrag info HsNoCafRefs         = return (info `setCafInfo`   NoCafRefs)
     tcPrag info (HsArity arity)     = return (info `setArityInfo` arity)
     tcPrag info (HsStrictness str)  = return (info `setAllStrictnessInfo` Just str)

-    tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)

 
        -- The next two are lazy, so they don't transitively suck stuff in
 
        -- The next two are lazy, so they don't transitively suck stuff in

-    tcPrag info (HsUnfold if_unf)  = do { unf <- tcUnfolding name ty info if_unf
-                                       ; return (info `setUnfoldingInfoLazily` unf) }
+    tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity
+    tcPrag info (HsInline inline_prag) = return (info `setInlinePragInfo` inline_prag)
+    tcPrag info (HsUnfold expr) = do
+          maybe_expr' <- tcPragExpr name expr
+         let
+               -- maybe_expr' doesn't get looked at if the unfolding
+               -- is never inspected; so the typecheck doesn't even happen
+               unfold_info = case maybe_expr' of
+                               Nothing    -> noUnfolding
+                               Just expr' -> mkTopUnfolding expr' 
+          return (info `setUnfoldingInfoLazily` unfold_info)

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
-tcUnfolding name _ _ (IfCoreUnfold if_expr)
-  = do         { mb_expr <- tcPragExpr name if_expr
-       ; return (case mb_expr of
-                   Nothing -> NoUnfolding
-                   Just expr -> mkTopUnfolding expr) }
-
-tcUnfolding name _ _ (IfInlineRule arity if_expr)
-  = do         { mb_expr <- tcPragExpr name if_expr
-       ; return (case mb_expr of
-                   Nothing -> NoUnfolding
-                   Just expr -> mkInlineRule expr arity) }
-
-tcUnfolding name ty info (IfWrapper arity wkr)
+tcWorkerInfo :: Type -> IdInfo -> Name -> Arity -> IfL IdInfo
+tcWorkerInfo ty info wkr arity

   = do         { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
   = do         { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)

+
+       -- We return without testing maybe_wkr_id, but as soon as info is
+       -- looked at we will test it.  That's ok, because its outside the
+       -- knot; and there seems no big reason to further defer the
+       -- tcIfaceId lookup.  (Contrast with tcPragExpr, where postponing walking
+       -- over the unfolding until it's actually used does seem worth while.)

        ; us <- newUniqueSupply
        ; us <- newUniqueSupply

+

        ; return (case mb_wkr_id of
        ; return (case mb_wkr_id of

-                    Nothing     -> noUnfolding
-                    Just wkr_id -> make_inline_rule wkr_id us) }
+                    Nothing     -> info
+                    Just wkr_id -> add_wkr_info us wkr_id info) }

   where
   where

-    doc = text "Worker for" <+> ppr name
+    doc = text "Worker for" <+> ppr wkr
+    add_wkr_info us wkr_id info
+       = info `setUnfoldingInfoLazily`  mk_unfolding us wkr_id
+              `setWorkerInfo`           HasWorker wkr_id arity

 
 

-    make_inline_rule wkr_id us 
-       = mkWwInlineRule (initUs_ us (mkWrapper ty strict_sig) wkr_id) 
-                        arity wkr_id
+    mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id)

 
        -- We are relying here on strictness info always appearing 
        -- before worker info,  fingers crossed ....
 
        -- We are relying here on strictness info always appearing 
        -- before worker info,  fingers crossed ....