More wibbleswip/inline-compulsory

5 files changed, 29 insertions, 15 deletions

diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs
index 8853b8592b..bf082518c9 100644
--- a/compiler/coreSyn/CoreUnfold.hs
+++ b/compiler/coreSyn/CoreUnfold.hs
@@ -1120,11 +1120,12 @@ certainlyWillInline :: DynFlags -> IdInfo -> Maybe Unfolding
 -- ^ Sees if the unfolding is pretty certain to inline.
 -- If so, return a *stable* unfolding for it, that will always inline.
 certainlyWillInline dflags fn_info
-  = case unfoldingInfo fn_info of
-      CoreUnfolding { uf_tmpl = e, uf_guidance = g }
-        | loop_breaker -> Nothing      -- Won't inline, so try w/w
-        | noinline     -> Nothing      -- See Note [Worker-wrapper for NOINLINE functions]
-        | otherwise    -> do_cunf e g  -- Depends on size, so look at that
+  = case fn_unf of
+      CoreUnfolding { uf_tmpl = e, uf_guidance = g, uf_src = src }
+        | loop_breaker   -> Nothing     -- Won't inline, so try w/w
+        | noinline       -> Nothing     -- See Note [Worker-wrapper for NOINLINE functions]
+        | compulsory src -> Just fn_unf
+        | otherwise      -> do_cunf e g -- Depends on size, so look at that
 
       DFunUnfolding {} -> Just fn_unf  -- Don't w/w DFuns; it never makes sense
                                        -- to do so, and even if it is currently a
@@ -1137,6 +1138,9 @@ certainlyWillInline dflags fn_info
     noinline     = inlinePragmaSpec (inlinePragInfo fn_info) == InlSpecNoInline
     fn_unf       = unfoldingInfo fn_info
 
+    compulsory InlineCompulsory = True
+    compulsory _                = False
+
     do_cunf :: CoreExpr -> UnfoldingGuidance -> Maybe Unfolding
     do_cunf _ UnfNever     = Nothing
     do_cunf _ (UnfWhen {}) = Just (fn_unf { uf_src = InlineStable })
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 1ca5a6b438..342ad414f9 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -495,7 +495,9 @@ bindNonRec bndr rhs body
 -- | Tests whether we have to use a @case@ rather than @let@ binding for this expression
 -- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant"
 needsCaseBinding :: Type -> CoreExpr -> Bool
-needsCaseBinding ty rhs = isUnliftedType ty && not (exprOkForSpeculation rhs)
+needsCaseBinding ty rhs
+  = not (isLiftedType_maybe ty `orElse` True)
+  && not (exprOkForSpeculation rhs)
         -- Make a case expression instead of a let
         -- These can arise either from the desugarer,
         -- or from beta reductions: (\x.e) (x +# y)
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index bee958afac..93e4a988a0 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -49,7 +49,7 @@ import TcEvidence
 import TcType
 import Type
 import Coercion
-import TysWiredIn ( typeNatKind, typeSymbolKind )
+import TysWiredIn ( typeNatKind, typeSymbolKind, unitTy, unitDataConId )
 import Id
 import MkId(proxyHashId)
 import Name
@@ -187,7 +187,8 @@ dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                           , abs_exports = exports
                           , abs_ev_binds = ev_binds
                           , abs_binds = binds, abs_sig = has_sig })
-  = do { ds_binds <- applyWhen (needToRunPmCheck dflags FromSource)
+  = do { ds_binds <- switchOffLevPolyCheck has_sig exports $
+                     applyWhen (needToRunPmCheck dflags FromSource)
                                -- FromSource might not be accurate, but at worst
                                -- we do superfluous calls to the pattern match
                                -- oracle.
@@ -197,8 +198,7 @@ dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                                (addTyCsDs (listToBag dicts))
                                (dsLHsBinds binds)
 
-       ; ds_ev_binds <- switchOffLevPolyCheck has_sig exports $
-                        dsTcEvBinds_s ev_binds
+       ; ds_ev_binds <- dsTcEvBinds_s ev_binds
 
        -- dsAbsBinds does the hard work
        ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
@@ -382,7 +382,7 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs
           NoInlSpec         -> (gbl_id, rhs)
           InlSpecNoInline   -> (gbl_id, rhs)
           InlSpecInlinable  -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
-          InlSpecCompulsory -> (gbl_id `setIdUnfolding` compulsory_unf, rhs)
+          InlSpecCompulsory -> (gbl_id `setIdUnfolding` compulsory_unf, dummy_rhs)
           InlSpecInline     -> inline_pair
 
   where
@@ -402,6 +402,9 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs
        = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
          (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs)
 
+    dummy_rhs = Var unitDataConId `mkCast`
+                mkUnsafeCo Representational unitTy (idType gbl_id)
+
 dictArity :: [Var] -> Arity
 -- Don't count coercion variables in arity
 dictArity dicts = count isId dicts
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 7e09716223..c5a39c901a 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -1141,7 +1141,8 @@ checkLevPolyFun :: Var -> Type -> DsM ()
 checkLevPolyFun var ty
   | hasNoBinding var
   = do { env <- getLclEnv
-       ; when (dsl_lev_poly_check env && not (null bad_tys)) $
+       ; pprTrace "clpf" (ppr (dsl_lev_poly_check env)) $
+         when (dsl_lev_poly_check env && not (null bad_tys)) $
          levPolyPrimopErr var ty bad_tys }
   | otherwise
   = return ()
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
index 874ccfb793..27b375f868 100644
--- a/compiler/deSugar/DsMonad.hs
+++ b/compiler/deSugar/DsMonad.hs
@@ -604,10 +604,14 @@ pprRuntimeTrace str doc expr = do
 
 switchOffLevPolyCheck :: Bool -> [ABExport GhcTc] -> DsM a -> DsM a
 switchOffLevPolyCheck has_sig exports thing_inside
-  | has_sig
+  | pprTrace "switch" (ppr has_sig $$ ppr exports) $
+    has_sig
   , [ABE { abe_poly = poly_id }] <- exports
-  , InlSpecCompulsory <- inlinePragmaSpec (idInlinePragma poly_id)
-  = updLclEnv (\env -> env { dsl_lev_poly_check = False }) thing_inside
+  , InlSpecCompulsory <- pprTrace "sw2" (vcat [ ppr (idInlinePragma poly_id)
+                                              , ppr (inlinePragmaSpec (idInlinePragma poly_id)) ]) $
+                         inlinePragmaSpec (idInlinePragma poly_id)
+  = pprTrace "switch off" empty $
+    updLclEnv (\env -> env { dsl_lev_poly_check = False }) thing_inside
   | otherwise
   = thing_inside