X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=d8bd414edde3c6a2cb6f3c0e708e7b042cf36cb9;hb=786932468faac49aafe20b65eabc8bdf465fbc9d;hp=cecfc0b742fa50f3f743161bdaabbb6cbc302f07;hpb=2662dbc5b2c30fc11ccb99e7f9b2dba794d680ba;p=ghc-hetmet.git

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index cecfc0b..d8bd414 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -46,8 +46,9 @@ import VarEnv
 import Name
 import NameEnv
 import OccurAnal	( occurAnalyseExpr )
+import Demand		( isBottomingSig )
 import Module
-import LazyUniqFM
+import UniqFM
 import UniqSupply
 import Outputable	
 import ErrUtils
@@ -1003,20 +1004,30 @@ tcIdInfo ignore_prags name ty info
 
 \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)
@@ -1032,8 +1043,8 @@ 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 ....
+    	-- 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)