X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=1f846d37fbfc2a66faad66120df9644f37d727ba;hb=e3d0f33551f53f8f78739faf168a6bb94f676c0d;hp=689dd4b1e87eef7b4dc2d503dba61ff32c909302;hpb=72462499b891d5779c19f3bda03f96e24f9554ae;p=ghc-hetmet.git

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 689dd4b..1f846d3 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -40,13 +40,15 @@ import DataCon
 import TysWiredIn
 import TysPrim		( anyTyConOfKind )
 import Var              ( TyVar )
+import BasicTypes	( nonRuleLoopBreaker )
 import qualified Var
 import VarEnv
 import Name
 import NameEnv
 import OccurAnal	( occurAnalyseExpr )
+import Demand		( isBottomingSig )
 import Module
-import LazyUniqFM
+import UniqFM
 import UniqSupply
 import Outputable	
 import ErrUtils
@@ -989,30 +991,43 @@ tcIdInfo ignore_prags name ty info
     tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
     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 (HsStrictness str) = return (info `setStrictnessInfo` Just str)
     tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)
 
 	-- 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 (HsUnfold lb if_unf) 
+      = do { unf <- tcUnfolding name ty info if_unf
+    	   ; let info1 | lb        = info `setOccInfo` nonRuleLoopBreaker
+	     	       | otherwise = info
+	   ; return (info1 `setUnfoldingInfoLazily` unf) }
 \end{code}
 
 \begin{code}
 tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
-tcUnfolding name _ _ (IfCoreUnfold if_expr)
+tcUnfolding name _ info (IfCoreUnfold if_expr)
   = do 	{ mb_expr <- tcPragExpr name if_expr
 	; return (case mb_expr of
 		    Nothing -> NoUnfolding
-		    Just expr -> mkTopUnfolding expr) }
+		    Just expr -> mkTopUnfolding is_bottoming expr) }
+  where
+     -- Strictness should occur before unfolding!
+    is_bottoming = case strictnessInfo info of
+    		     Just sig -> isBottomingSig sig
+ 		     Nothing  -> False
 
-tcUnfolding name _ _ (IfInlineRule arity sat if_expr)
+tcUnfolding name _ _ (IfCompulsory if_expr)
   = do 	{ mb_expr <- tcPragExpr name if_expr
 	; return (case mb_expr of
 		    Nothing   -> NoUnfolding
-		    Just expr -> mkInlineRule inl_info expr arity) }
-  where
-    inl_info | sat       = InlSat
-    	     | otherwise = InlUnSat
+		    Just expr -> mkCompulsoryUnfolding expr) }
+
+tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
+  = do 	{ mb_expr <- tcPragExpr name if_expr
+	; return (case mb_expr of
+		    Nothing   -> NoUnfolding
+		    Just expr -> mkCoreUnfolding True InlineRule expr arity 
+                                                 (UnfWhen unsat_ok boring_ok))
+    }
 
 tcUnfolding name ty info (IfWrapper arity wkr)
   = do 	{ mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
@@ -1028,9 +1043,9 @@ tcUnfolding name ty info (IfWrapper arity wkr)
 	  		 (initUs_ us (mkWrapper ty strict_sig) wkr_id) 
 		         arity
 
-    	-- We are relying here on strictness info always appearing 
-	-- before worker info,  fingers crossed ....
-    strict_sig = case newStrictnessInfo info of
+    	-- Again we rely here on strictness info always appearing 
+	-- before unfolding
+    strict_sig = case strictnessInfo info of
 		   Just sig -> sig
 		   Nothing  -> pprPanic "Worker info but no strictness for" (ppr wkr)
 
@@ -1038,11 +1053,9 @@ tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
   = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
        ; return (case mb_ops1 of
        	 	    Nothing   -> noUnfolding
-                    Just ops1 -> DFunUnfolding data_con ops1) }
+                    Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
   where
     doc = text "Class ops for dfun" <+> ppr name
-    (_, cls, _) = tcSplitDFunTy dfun_ty
-    data_con = classDataCon cls
 \end{code}
 
 For unfoldings we try to do the job lazily, so that we never type check
@@ -1215,7 +1228,7 @@ tcIfaceLetBndr (IfLetBndr fs ty info)
     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 (HsStrictness s : i) = tc_info i `setStrictnessInfo` Just s 
     tc_info (other          : i) = pprTrace "tcIfaceLetBndr: discarding unexpected IdInfo" 
 					    (ppr other) (tc_info i)