X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=0bfdae7b1dfd6addc15d9fd0b3d584140671c4a1;hb=d2241e6301bf56acf89ffd0d78922b90a58dafb1;hp=4de3a6fdc2134465f44b1e1de9fa6e32870ea732;hpb=bb404f27c6cbadbba51794a0dcc9125d873e70e2;p=ghc-hetmet.git

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 4de3a6f..0bfdae7 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -399,7 +399,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
 	       , let out = localOccs $ freeNamesDeclABI abi
                ]
 
-       name_module n = ASSERT( isExternalName n ) nameModule n
+       name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
        localOccs = map (getUnique . getParent . getOccName) 
                         . filter ((== this_mod) . name_module)
                         . nameSetToList
@@ -497,7 +497,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
    let sorted_deps = sortDependencies (mi_deps iface0)
 
    -- the export hash of a module depends on the orphan hashes of the
-   -- orphan modules below us in the dependeny tree.  This is the way
+   -- orphan modules below us in the dependency tree.  This is the way
    -- that changes in orphans get propagated all the way up the
    -- dependency tree.  We only care about orphan modules in the current
    -- package, because changes to orphans outside this package will be
@@ -1390,12 +1390,12 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
     is_local name = nameIsLocalOrFrom mod name
 
 	-- Compute orphanhood.  See Note [Orphans] in IfaceSyn
-    (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
+    (_, cls, tys) = tcSplitDFunTy (idType dfun_id)
 		-- Slightly awkward: we need the Class to get the fundeps
     (tvs, fds) = classTvsFds cls
     arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
     orph | is_local cls_name = Just (nameOccName cls_name)
-	 | all isJust mb_ns  = head mb_ns
+	 | all isJust mb_ns  = ASSERT( not (null mb_ns) ) head mb_ns
 	 | otherwise	     = Nothing
     
     mb_ns :: [Maybe OccName]	-- One for each fundep; a locally-defined name
@@ -1442,7 +1442,7 @@ toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
 --------------------------
 toIfaceIdDetails :: IdDetails -> IfaceIdDetails
 toIfaceIdDetails VanillaId 		        = IfVanillaId
-toIfaceIdDetails DFunId    		        = IfVanillaId	            
+toIfaceIdDetails (DFunId {})   		        = IfDFunId
 toIfaceIdDetails (RecSelId { sel_naughty = n
 		 	   , sel_tycon = tc })  = IfRecSelId (toIfaceTyCon tc) n
 toIfaceIdDetails other	     		        = pprTrace "toIfaceIdDetails" (ppr other) 
@@ -1451,7 +1451,7 @@ toIfaceIdDetails other	     		        = pprTrace "toIfaceIdDetails" (ppr other)
 toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
 toIfaceIdInfo id_info
   = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, 
-	       inline_hsinfo, wrkr_hsinfo,  unfold_hsinfo] 
+	       inline_hsinfo,  unfold_hsinfo] 
   where
     ------------  Arity  --------------
     arity_info = arityInfo id_info
@@ -1470,35 +1470,30 @@ toIfaceIdInfo id_info
 			Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
 			_other			      -> Nothing
 
-    ------------  Worker  --------------
-    work_info   = workerInfo id_info
-    has_worker  = workerExists work_info
-    wrkr_hsinfo = case work_info of
-		    HasWorker work_id wrap_arity -> 
-			Just (HsWorker ((idName work_id)) wrap_arity)
-		    NoWorker -> Nothing
-
     ------------  Unfolding  --------------
-    -- The unfolding is redundant if there is a worker
-    unfold_info  = unfoldingInfo id_info
-    rhs		 = unfoldingTemplate unfold_info
-    no_unfolding = neverUnfold unfold_info
-		  	-- The CoreTidy phase retains unfolding info iff
-			-- we want to expose the unfolding, taking into account
-			-- unconditional NOINLINE, etc.  See TidyPgm.addExternal
-    unfold_hsinfo | no_unfolding = Nothing			
-		  | has_worker   = Nothing	-- Unfolding is implicit
-		  | otherwise	 = Just (HsUnfold (toIfaceExpr rhs))
+    unfold_hsinfo = toIfUnfolding (unfoldingInfo id_info)
 					
     ------------  Inline prag  --------------
     inline_prag = inlinePragInfo id_info
     inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
-		  | no_unfolding && not has_worker 
-                      && isFunLike (inlinePragmaRuleMatchInfo inline_prag)
-                                                      = Nothing
-			-- If the iface file give no unfolding info, we 
-			-- don't need to say when inlining is OK!
-		  | otherwise			      = Just (HsInline inline_prag)
+                  | otherwise = Just (HsInline inline_prag)
+
+--------------------------
+toIfUnfolding :: Unfolding -> Maybe IfaceInfoItem
+toIfUnfolding (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance })
+  = case guidance of
+	InlineRule { ir_info = InlWrapper w } -> Just (HsUnfold (IfWrapper arity (idName w)))
+	InlineRule { ir_sat = InlSat }        -> Just (HsUnfold (IfInlineRule arity True  (toIfaceExpr rhs)))
+	InlineRule { ir_sat = InlUnSat }      -> Just (HsUnfold (IfInlineRule arity False (toIfaceExpr rhs)))
+	UnfoldNever         -> Nothing
+	UnfoldIfGoodArgs {} -> Just (HsUnfold (IfCoreUnfold (toIfaceExpr rhs)))
+
+toIfUnfolding (DFunUnfolding _con ops)
+  = Just (HsUnfold (IfDFunUnfold (map toIfaceExpr ops)))
+      -- No need to serialise the data constructor; 
+      -- we can recover it from the type of the dfun
+toIfUnfolding _
+  = Nothing
 
 --------------------------
 coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
@@ -1555,7 +1550,6 @@ toIfaceExpr (Note n e)    = IfaceNote (toIfaceNote n) (toIfaceExpr e)
 ---------------------
 toIfaceNote :: Note -> IfaceNote
 toIfaceNote (SCC cc)      = IfaceSCC cc
-toIfaceNote InlineMe      = IfaceInlineMe
 toIfaceNote (CoreNote s)  = IfaceCoreNote s
 
 ---------------------