Implement auto-specialisation of imported Ids

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

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 68c6cf1..a8ea826 100644 (file)
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -280,9 +280,11 @@ mkIface_ hsc_env maybe_old_fingerprint
                                          intermediate_iface decls
 
                -- Warn about orphans
-       ; let orph_warnings   --- Laziness means no work done unless -fwarn-orphans
-               | dopt Opt_WarnOrphans dflags = rule_warns `unionBags` inst_warns
-               | otherwise                   = emptyBag
+       ; let warn_orphs      = dopt Opt_WarnOrphans dflags
+              warn_auto_orphs = dopt Opt_WarnAutoOrphans dflags
+              orph_warnings   --- Laziness means no work done unless -fwarn-orphans
+               | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
+               | otherwise                     = emptyBag
              errs_and_warns = (orph_warnings, emptyBag)
              unqual = mkPrintUnqualified dflags rdr_env
              inst_warns = listToBag [ instOrphWarn unqual d 
@@ -290,7 +292,9 @@ mkIface_ hsc_env maybe_old_fingerprint
                                     , isNothing (ifInstOrph i) ]
              rule_warns = listToBag [ ruleOrphWarn unqual this_mod r 
                                     | r <- iface_rules
-                                    , isNothing (ifRuleOrph r) ]
+                                    , isNothing (ifRuleOrph r)
+                                     , if ifRuleAuto r then warn_auto_orphs
+                                                       else warn_orphs ]
 
        ; if errorsFound dflags errs_and_warns
             then return ( errs_and_warns, Nothing )
@@ -1535,21 +1539,23 @@ toIfaceIdInfo id_info
 
 --------------------------
 toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
-toIfUnfolding lb unf@(CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
-                                    , uf_src = src, uf_guidance = guidance })
+toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
+                                , uf_src = src, uf_guidance = guidance })
   = Just $ HsUnfold lb $
     case src of
-       InlineRule {}
+       InlineStable
           -> case guidance of
-               UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok (toIfaceExpr rhs)
-               _other                     -> pprPanic "toIfUnfolding" (ppr unf)
+               UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs
+               _other                     -> IfCoreUnfold True if_rhs
        InlineWrapper w  -> IfWrapper arity (idName w)
-        InlineCompulsory -> IfCompulsory (toIfaceExpr rhs)
-        InlineRhs        -> IfCoreUnfold (toIfaceExpr rhs)
+        InlineCompulsory -> IfCompulsory if_rhs
+        InlineRhs        -> IfCoreUnfold False if_rhs
        -- Yes, even if guidance is UnfNever, expose the unfolding
        -- If we didn't want to expose the unfolding, TidyPgm would
        -- have stuck in NoUnfolding.  For supercompilation we want 
        -- to see that unfolding!
+  where
+    if_rhs = toIfaceExpr rhs
 
 toIfUnfolding lb (DFunUnfolding _ar _con ops)
   = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
@@ -1567,12 +1573,14 @@ coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn})
 
 coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn, 
                                 ru_act = act, ru_bndrs = bndrs,
-                               ru_args = args, ru_rhs = rhs })
+                               ru_args = args, ru_rhs = rhs, 
+                                ru_auto = auto })
   = IfaceRule { ifRuleName  = name, ifActivation = act, 
                ifRuleBndrs = map toIfaceBndr bndrs,
                ifRuleHead  = fn, 
                ifRuleArgs  = map do_arg args,
                ifRuleRhs   = toIfaceExpr rhs,
+                ifRuleAuto  = auto,
                ifRuleOrph  = orph }
   where
        -- For type args we must remove synonyms from the outermost
@@ -1597,7 +1605,7 @@ bogusIfaceRule :: Name -> IfaceRule
 bogusIfaceRule id_name
   = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,  
        ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], 
-       ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
+       ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing, ifRuleAuto = True }
 
 ---------------------
 toIfaceExpr :: CoreExpr -> IfaceExpr