Improve the desugaring of -XStrict

Trac #14035 showed that -XStrict was generating some TERRIBLE
desugarings, espcially for bindings with INLINE pragmas. Reason: with
-XStrict, all AbsBinds (even for non-recursive functions) went via the
general-case deguaring for AbsBinds, namely "generate a tuple and
select from it", even though in this case there was only one variable
in the tuple.  And that in turn interacts terribly badly with INLINE
pragmas.

This patch cleans things up:

* I killed off AbsBindsSig completely, in favour of a boolean flag
  abs_sig in AbsBinds.  See Note [The abs_sig field of AbsBinds]

  This allowed me to delete lots of code; and instance-method
  declarations can enjoy the benefits too.  (They could have
  before, but no one had changed them to use AbsBindsSig.)

* I refactored all the AbsBinds handling in DsBinds into a new
  function DsBinds.dsAbsBinds.  This allowed me to handle the
  strict case uniformly

11 files changed, 248 insertions, 321 deletions

diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 16537bd7a5..d44c203b6f 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -281,31 +281,6 @@ addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,
                       | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
                       , isInlinePragma (idInlinePragma pid) ] }
 
-addTickLHsBind (L pos bind@(AbsBindsSig { abs_sig_bind   = val_bind
-                                        , abs_sig_export = poly_id }))
-  | L _ FunBind { fun_id = L _ mono_id } <- val_bind
-  = do withEnv (add_export  mono_id) $ do
-       withEnv (add_inlines mono_id) $ do
-       val_bind' <- addTickLHsBind val_bind
-       return $ L pos $ bind { abs_sig_bind = val_bind' }
-
-  | otherwise
-  = pprPanic "addTickLHsBind" (ppr bind)
- where
-  -- see AbsBinds comments
-  add_export mono_id env
-    | idName poly_id `elemNameSet` exports env
-    = env { exports = exports env `extendNameSet` idName mono_id }
-    | otherwise
-    = env
-
-  -- See Note [inline sccs]
-  add_inlines mono_id env
-    | isInlinePragma (idInlinePragma poly_id)
-    = env { inlines = inlines env `extendVarSet` mono_id }
-    | otherwise
-    = env
-
 addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
   let name = getOccString id
   decl_path <- getPathEntry
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 5d9a33d660..ae23a765c4 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -52,6 +52,7 @@ import Name
 import VarSet
 import Rules
 import VarEnv
+import Var( EvVar )
 import Outputable
 import Module
 import SrcLoc
@@ -105,8 +106,7 @@ dsTopLHsBinds binds
 -- later be forced in the binding group body, see Note [Desugar Strict binds]
 dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
 dsLHsBinds binds
-  = do { MASSERT( allBag (not . isUnliftedHsBind . unLoc) binds )
-       ; ds_bs <- mapBagM dsLHsBind binds
+  = do { ds_bs <- mapBagM dsLHsBind binds
        ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))
                          id ([], []) ds_bs) }
 
@@ -124,10 +124,9 @@ dsHsBind :: DynFlags
          -- binding group see Note [Desugar Strict binds] and all
          -- bindings and their desugared right hand sides.
 
-dsHsBind dflags
-         (VarBind { var_id = var
-                  , var_rhs = expr
-                  , var_inline = inline_regardless })
+dsHsBind dflags (VarBind { var_id = var
+                         , var_rhs = expr
+                         , var_inline = inline_regardless })
   = do  { core_expr <- dsLExpr expr
                 -- Dictionary bindings are always VarBinds,
                 -- so we only need do this here
@@ -139,9 +138,8 @@ dsHsBind dflags
                           else []
         ; return (force_var, [core_bind]) }
 
-dsHsBind dflags
-         b@(FunBind { fun_id = L _ fun, fun_matches = matches
-                    , fun_co_fn = co_fn, fun_tick = tick })
+dsHsBind dflags b@(FunBind { fun_id = L _ fun, fun_matches = matches
+                           , fun_co_fn = co_fn, fun_tick = tick })
  = do   { (args, body) <- matchWrapper
                            (mkPrefixFunRhs (noLoc $ idName fun))
                            Nothing matches
@@ -158,12 +156,14 @@ dsHsBind dflags
                 = [id]
                 | otherwise
                 = []
-        ; --pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun) $$ ppr (mg_alts matches) $$ ppr args $$ ppr core_binds) $
-           return (force_var, [core_binds]) }
-
-dsHsBind dflags
-         (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty
-                  , pat_ticks = (rhs_tick, var_ticks) })
+        ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun)
+          --                          , ppr (mg_alts matches)
+          --                          , ppr args, ppr core_binds]) $
+          return (force_var, [core_binds]) }
+
+dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
+                         , pat_rhs_ty = ty
+                         , pat_ticks = (rhs_tick, var_ticks) })
   = do  { body_expr <- dsGuarded grhss ty
         ; let body' = mkOptTickBox rhs_tick body_expr
               pat'  = decideBangHood dflags pat
@@ -175,47 +175,73 @@ dsHsBind dflags
                            else []
         ; return (force_var', sel_binds) }
 
-        -- A common case: one exported variable, only non-strict binds
-        -- Non-recursive bindings come through this way
-        -- So do self-recursive bindings
-        -- Bindings with complete signatures are AbsBindsSigs, below
-dsHsBind dflags
-         (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
-                   , abs_exports = [export]
-                   , abs_ev_binds = ev_binds, abs_binds = binds })
-  | ABE { abe_wrap = wrap, abe_poly = global
-        , abe_mono = local, abe_prags = prags } <- export
-  , not (xopt LangExt.Strict dflags)             -- Handle strict binds
-  , not (anyBag (isBangedBind . unLoc) binds)    --        in the next case
-  = -- See Note [AbsBinds wrappers] in HsBinds
-    addDictsDs (toTcTypeBag (listToBag dicts)) $
-         -- addDictsDs: push type constraints deeper for pattern match check
-    do { (force_vars, bind_prs) <- dsLHsBinds binds
-       ; ds_binds <- dsTcEvBinds_s ev_binds
-       ; core_wrap <- dsHsWrapper wrap -- Usually the identity
+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 <- addDictsDs (toTcTypeBag (listToBag dicts)) $
+                     dsLHsBinds binds
+                                   -- addDictsDs: push type constraints deeper
+                                   --             for inner pattern match check
+
+       ; ds_ev_binds <- dsTcEvBinds_s ev_binds
+
+       -- dsAbsBinds does the hard work
+       ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
+
+dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
+
+
+-----------------------
+dsAbsBinds :: DynFlags
+           -> [TyVar] -> [EvVar] -> [ABExport GhcTc]
+           -> [CoreBind]                -- Desugared evidence bidings
+           -> ([Id], [(Id,CoreExpr)])   -- Desugared value bindings
+           -> Bool                      -- Single binding with signature
+           -> DsM ([Id], [(Id,CoreExpr)])
+
+dsAbsBinds dflags tyvars dicts exports
+           ds_ev_binds (force_vars, bind_prs) has_sig
+
+    -- A very important common case: one exported variable
+    -- Non-recursive bindings come through this way
+    -- So do self-recursive bindings
+  | [export] <- exports
+  , ABE { abe_poly = global_id, abe_mono = local_id
+        , abe_wrap = wrap, abe_prags = prags } <- export
+  , Just force_vars' <- case force_vars of
+                           []                  -> Just []
+                           [v] | v == local_id -> Just [global_id]
+                           _                   -> Nothing
+       -- If there is a variable to force, it's just the
+       -- single variable we are binding here
+  = do { core_wrap <- dsHsWrapper wrap -- Usually the identity
 
        ; let rhs = core_wrap $
                    mkLams tyvars $ mkLams dicts $
-                   mkCoreLets ds_binds $
-                   mkLetRec bind_prs $
-                   Var local
+                   mkCoreLets ds_ev_binds $
+                   body
+
+             body | has_sig
+                  , [(_, lrhs)] <- bind_prs
+                  = lrhs
+                  | otherwise
+                  = mkLetRec bind_prs (Var local_id)
+
        ; (spec_binds, rules) <- dsSpecs rhs prags
 
-       ; let   global'  = addIdSpecialisations global rules
-               main_bind = makeCorePair dflags global' (isDefaultMethod prags)
-                                        (dictArity dicts) rhs
+       ; let global_id' = addIdSpecialisations global_id rules
+             main_bind  = makeCorePair dflags global_id'
+                                       (isDefaultMethod prags)
+                                       (dictArity dicts) rhs
 
-       ; ASSERT(null force_vars)
-         return ([], main_bind : fromOL spec_binds) }
+       ; return (force_vars', main_bind : fromOL spec_binds) }
 
-        -- Another common case: no tyvars, no dicts
-        -- In this case we can have a much simpler desugaring
-dsHsBind dflags
-         (AbsBinds { abs_tvs = [], abs_ev_vars = []
-                   , abs_exports = exports
-                   , abs_ev_binds = ev_binds, abs_binds = binds })
-  = do { (force_vars, bind_prs) <- dsLHsBinds binds
-       ; let mk_bind (ABE { abe_wrap = wrap
+    -- Another common case: no tyvars, no dicts
+    -- In this case we can have a much simpler desugaring
+  | null tyvars, null dicts
+
+  = do { let mk_bind (ABE { abe_wrap = wrap
                           , abe_poly = global
                           , abe_mono = local
                           , abe_prags = prags })
@@ -225,42 +251,35 @@ dsHsBind dflags
                                           0 (core_wrap (Var local))) }
        ; main_binds <- mapM mk_bind exports
 
-       ; ds_binds <- dsTcEvBinds_s ev_binds
-       ; return (force_vars, flattenBinds ds_binds ++ bind_prs ++ main_binds) }
-
-dsHsBind dflags
-         (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
-                   , abs_exports = exports, abs_ev_binds = ev_binds
-                   , abs_binds = binds })
-         -- See Note [Desugaring AbsBinds]
-  = addDictsDs (toTcTypeBag (listToBag dicts)) $
-         -- addDictsDs: push type constraints deeper for pattern match check
-     do { (local_force_vars, bind_prs) <- dsLHsBinds binds
-        ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
+       ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }
+
+    -- The general case
+    -- See Note [Desugaring AbsBinds]
+  | otherwise
+  = do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
                               | (lcl_id, rhs) <- bind_prs ]
                 -- Monomorphic recursion possible, hence Rec
-              new_force_vars = get_new_force_vars local_force_vars
-              locals       = map abe_mono exports
-              all_locals   = locals ++ new_force_vars
-              tup_expr     = mkBigCoreVarTup all_locals
-              tup_ty       = exprType tup_expr
-        ; ds_binds <- dsTcEvBinds_s ev_binds
-        ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
-                             mkCoreLets ds_binds $
-                             mkLet core_bind $
-                             tup_expr
-
-        ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
+             new_force_vars = get_new_force_vars force_vars
+             locals       = map abe_mono exports
+             all_locals   = locals ++ new_force_vars
+             tup_expr     = mkBigCoreVarTup all_locals
+             tup_ty       = exprType tup_expr
+       ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
+                            mkCoreLets ds_ev_binds $
+                            mkLet core_bind $
+                            tup_expr
+
+       ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
 
         -- Find corresponding global or make up a new one: sometimes
         -- we need to make new export to desugar strict binds, see
         -- Note [Desugar Strict binds]
-        ; (exported_force_vars, extra_exports) <- get_exports local_force_vars
+       ; (exported_force_vars, extra_exports) <- get_exports force_vars
 
-        ; let mk_bind (ABE { abe_wrap = wrap
-                           , abe_poly = global
-                           , abe_mono = local, abe_prags = spec_prags })
-                         -- See Note [AbsBinds wrappers] in HsBinds
+       ; let mk_bind (ABE { abe_wrap = wrap
+                          , abe_poly = global
+                          , abe_mono = local, abe_prags = spec_prags })
+                          -- See Note [AbsBinds wrappers] in HsBinds
                 = do { tup_id  <- newSysLocalDs tup_ty
                      ; core_wrap <- dsHsWrapper wrap
                      ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $
@@ -275,10 +294,10 @@ dsHsBind dflags
                            -- Id is just the selector.  Hmm.
                      ; return ((global', rhs) : fromOL spec_binds) }
 
-        ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
+       ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
 
-        ; return (exported_force_vars
-                 ,(poly_tup_id, poly_tup_rhs) :
+       ; return ( exported_force_vars
+                , (poly_tup_id, poly_tup_rhs) :
                    concat export_binds_s) }
   where
     inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
@@ -321,57 +340,10 @@ dsHsBind dflags
     mk_export local =
       do global <- newSysLocalDs
                      (exprType (mkLams tyvars (mkLams dicts (Var local))))
-         return (ABE {abe_poly = global
-                     ,abe_mono = local
-                     ,abe_wrap = WpHole
-                     ,abe_prags = SpecPrags []})
-
--- AbsBindsSig is a combination of AbsBinds and FunBind
-dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts
-                             , abs_sig_export  = global
-                             , abs_sig_prags   = prags
-                             , abs_sig_ev_bind = ev_bind
-                             , abs_sig_bind    = bind })
-  | L bind_loc FunBind { fun_matches = matches
-                       , fun_co_fn   = co_fn
-                       , fun_tick    = tick } <- bind
-  = putSrcSpanDs bind_loc $
-    addDictsDs (toTcTypeBag (listToBag dicts)) $
-             -- addDictsDs: push type constraints deeper for pattern match check
-    do { (args, body) <- matchWrapper
-                           (mkPrefixFunRhs (noLoc $ idName global))
-                           Nothing matches
-       ; core_wrap <- dsHsWrapper co_fn
-       ; let body'   = mkOptTickBox tick body
-             fun_rhs = core_wrap (mkLams args body')
-             force_vars
-               | xopt LangExt.Strict dflags
-               , matchGroupArity matches == 0 -- no need to force lambdas
-               = [global]
-               | isBangedBind (unLoc bind)
-               = [global]
-               | otherwise
-               = []
-
-       ; ds_binds <- dsTcEvBinds ev_bind
-       ; let rhs = mkLams tyvars $
-                   mkLams dicts $
-                   mkCoreLets ds_binds $
-                   fun_rhs
-
-       ; (spec_binds, rules) <- dsSpecs rhs prags
-       ; let global' = addIdSpecialisations global rules
-             main_bind = makeCorePair dflags global' (isDefaultMethod prags)
-                                      (dictArity dicts) rhs
-
-       ; return (force_vars, main_bind : fromOL spec_binds) }
-
-  | otherwise
-  = pprPanic "dsHsBind: AbsBindsSig" (ppr bind)
-
-dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
-
-
+         return (ABE { abe_poly  = global
+                     , abe_mono  = local
+                     , abe_wrap  = WpHole
+                     , abe_prags = SpecPrags [] })
 
 -- | This is where we apply INLINE and INLINABLE pragmas. All we need to
 -- do is to attach the unfolding information to the Id.
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index c3d9489476..048d558825 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -130,8 +130,6 @@ ds_val_bind (NonRecursive, hsbinds) body
   where
     is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })
                      = not (null tvs && null evs)
-    is_polymorphic (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs })
-                     = not (null tvs && null evs)
     is_polymorphic _ = False
 
     unlifted_must_be_bang bind
@@ -186,15 +184,6 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
        ; ds_binds <- dsTcEvBinds_s ev_binds
        ; return (mkCoreLets ds_binds body2) }
 
-dsUnliftedBind (AbsBindsSig { abs_tvs         = []
-                            , abs_ev_vars     = []
-                            , abs_sig_export  = poly
-                            , abs_sig_ev_bind = ev_bind
-                            , abs_sig_bind    = L _ bind }) body
-  = do { ds_binds <- dsTcEvBinds ev_bind
-       ; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body
-       ; return (mkCoreLets ds_binds body') }
-
 dsUnliftedBind (FunBind { fun_id = L l fun
                         , fun_matches = matches
                         , fun_co_fn = co_fn
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index e732ce56b0..cc2ff133ae 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1475,7 +1475,6 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
         ; return (srcLocSpan (getSrcLoc v), ans) }
 
 rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"
-rep_bind (L _ (AbsBindsSig {})) = panic "rep_bind: AbsBindsSig"
 rep_bind (L loc (PatSynBind (PSB { psb_id   = syn
                                  , psb_fvs  = _fvs
                                  , psb_args = args
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index d766ab2c13..a8efa7206f 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -269,22 +269,9 @@ data HsBindLR idL idR
         abs_ev_binds :: [TcEvBinds],
 
         -- | Typechecked user bindings
-        abs_binds    :: LHsBinds idL
-    }
-
-  -- | Abstraction Bindings Signature
-  | AbsBindsSig {  -- Simpler form of AbsBinds, used with a type sig
-                   -- in tcPolyCheck. Produces simpler desugaring and
-                   -- is necessary to avoid #11405, comment:3.
-        abs_tvs     :: [TyVar],
-        abs_ev_vars :: [EvVar],
-
-        abs_sig_export :: IdP idL,  -- like abe_poly
-        abs_sig_prags  :: TcSpecPrags,
+        abs_binds    :: LHsBinds idL,
 
-        abs_sig_ev_bind :: TcEvBinds,  -- no list needed here
-        abs_sig_bind    :: LHsBind idL -- always only one, and it's always a
-                                       -- FunBind
+        abs_sig :: Bool  -- See Note [The abs_sig field of AbsBinds]
     }
 
   -- | Patterns Synonym Binding
@@ -312,7 +299,7 @@ deriving instance (DataId idL, DataId idR) => Data (HsBindLR idL idR)
 
 -- | Abtraction Bindings Export
 data ABExport p
-  = ABE { abe_poly      :: IdP p -- ^ Any INLINE pragmas is attached to this Id
+  = ABE { abe_poly      :: IdP p -- ^ Any INLINE pragma is attached to this Id
         , abe_mono      :: IdP p
         , abe_wrap      :: HsWrapper    -- ^ See Note [ABExport wrapper]
              -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
@@ -481,6 +468,53 @@ bindings only when
    lacks a user type signature
  * The group forms a strongly connected component
 
+
+Note [The abs_sig field of AbsBinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The abs_sig field supports a couple of special cases for bindings.
+Consider
+
+  x :: Num a => (# a, a #)
+  x = (# 3, 4 #)
+
+The general desugaring for AbsBinds would give
+
+  x = /\a. \ ($dNum :: Num a) ->
+      letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in
+      xm
+
+But that has an illegal let-binding for an unboxed tuple.  In this
+case we'd prefer to generate the (more direct)
+
+  x = /\ a. \ ($dNum :: Num a) ->
+     (# fromInteger $dNum 3, fromInteger $dNum 4 #)
+
+A similar thing happens with representation-polymorphic defns
+(Trac #11405):
+
+  undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a
+  undef = error "undef"
+
+Again, the vanilla desugaring gives a local let-binding for a
+representation-polymorphic (undefm :: a), which is illegal.  But
+again we can desugar without a let:
+
+  undef = /\ a. \ (d:HasCallStack) -> error a d "undef"
+
+The abs_sig field supports this direct desugaring, with no local
+let-bining.  When abs_sig = True
+
+ * the abs_binds is single FunBind
+
+ * the abs_exports is a singleton
+
+ * we have a complete type sig for binder
+   and hence the abs_binds is non-recursive
+   (it binds the mono_id but refers to the poly_id
+
+These properties are exploited in DsBinds.dsAbsBinds to
+generate code without a let-binding.
+
 Note [ABExport wrapper]
 ~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -662,21 +696,6 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
       , text "Evidence:" <+> ppr ev_binds ]
     else
       pprLHsBinds val_binds
-ppr_monobind (AbsBindsSig { abs_tvs         = tyvars
-                          , abs_ev_vars     = dictvars
-                          , abs_sig_export  = poly_id
-                          , abs_sig_ev_bind = ev_bind
-                          , abs_sig_bind    = bind })
-  = sdocWithDynFlags $ \ dflags ->
-    if gopt Opt_PrintTypecheckerElaboration dflags then
-      hang (text "AbsBindsSig" <+> brackets (interpp'SP tyvars)
-                               <+> brackets (interpp'SP dictvars))
-         2 $ braces $ vcat
-      [ text "Exported type:" <+> pprBndr LetBind poly_id
-      , text "Bind:"     <+> ppr bind
-      , text "Evidence:" <+> ppr ev_bind ]
-    else
-      ppr bind
 
 instance (OutputableBndrId p) => Outputable (ABExport p) where
   ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index f7d18768df..edf2e1b349 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -577,8 +577,6 @@ looksLazyPatBind (PatBind { pat_lhs = p })
   = looksLazyLPat p
 looksLazyPatBind (AbsBinds { abs_binds = binds })
   = anyBag (looksLazyPatBind . unLoc) binds
-looksLazyPatBind (AbsBindsSig { abs_sig_bind = L _ bind })
-  = looksLazyPatBind bind
 looksLazyPatBind _
   = False
 
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index e953697ce2..5be757fb72 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -796,49 +796,31 @@ to return a [Name] or [Id].  Before renaming the record punning
 and wild-card mechanism makes it hard to know what is bound.
 So these functions should not be applied to (HsSyn RdrName)
 
-Note [Unlifted id check in isHsUnliftedBind]
+Note [Unlifted id check in isUnliftedHsBind]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose there is a binding with the type (Num a => (# a, a #)). Is this a
-strict binding that should be disallowed at the top level? At first glance,
-no, because it's a function. But consider how this is desugared via
-AbsBinds:
+The function isUnliftedHsBind is used to complain if we make a top-level
+binding for a variable of unlifted type.
 
-  -- x :: Num a => (# a, a #)
-  x = (# 3, 4 #)
+Such a binding is illegal if the top-level binding would be unlifted;
+but also if the local letrec generated by desugaring AbsBinds would be.
+E.g.
+      f :: Num a => (# a, a #)
+      g :: Num a => a -> a
+      f = ...g...
+      g = ...g...
 
-becomes
+The top-level bindings for f,g are not unlifted (because of the Num a =>),
+but the local, recursive, monomorphic bindings are:
 
-  x = \ $dictNum ->
-      let x_mono = (# fromInteger $dictNum 3, fromInteger $dictNum 4 #) in
-      x_mono
+      t = /\a \(d:Num a).
+         letrec fm :: (# a, a #) = ...g...
+                gm :: a -> a = ...f...
+         in (fm, gm)
 
-Note that the inner let is strict. And thus if we have a bunch of mutually
-recursive bindings of this form, we could end up in trouble. This was shown
-up in #9140.
-
-But if there is a type signature on x, everything changes because of the
-desugaring used by AbsBindsSig:
-
-  x :: Num a => (# a, a #)
-  x = (# 3, 4 #)
-
-becomes
-
-  x = \ $dictNum -> (# fromInteger $dictNum 3, fromInteger $dictNum 4 #)
-
-No strictness anymore! The bottom line here is that, for inferred types, we
-care about the strictness of the type after the =>. For checked types
-(AbsBindsSig), we care about the overall strictness.
-
-This matters. If we don't separate out the AbsBindsSig case, then GHC runs into
-a problem when compiling
-
-  undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a
-
-Looking only after the =>, we cannot tell if this is strict or not. (GHC panics
-if you try.) Looking at the whole type, on the other hand, tells you that this
-is a lifted function type, with no trouble at all.
+Here the binding for 'fm' is illegal.  So generally we check the abe_mono types.
 
+BUT we have a special case when abs_sig is true;
+  see HsBinds Note [The abs_sig field of AbsBinds]
 -}
 
 ----------------- Bindings --------------------------
@@ -848,18 +830,19 @@ is a lifted function type, with no trouble at all.
 -- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage
 -- information, see Note [Strict binds check] is DsBinds.
 isUnliftedHsBind :: HsBind GhcTc -> Bool  -- works only over typechecked binds
-isUnliftedHsBind (AbsBindsSig { abs_sig_export = id })
-  = isUnliftedType (idType id)
 isUnliftedHsBind bind
+  | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind
+  = if has_sig
+    then any (is_unlifted_id . abe_poly) exports
+    else any (is_unlifted_id . abe_mono) exports
+    -- If has_sig is True we wil never generate a binding for abe_mono,
+    -- so we don't need to worry about it being unlifted. The abe_poly
+    -- binding might not be: e.g. forall a. Num a => (# a, a #)
+
+  | otherwise
   = any is_unlifted_id (collectHsBindBinders bind)
   where
-    is_unlifted_id id
-      = case tcSplitSigmaTy (idType id) of
-          (_, _, tau) -> isUnliftedType tau
-          -- For the is_unlifted check, we need to look inside polymorphism
-          -- and overloading.  E.g.  x = (# 1, True #)
-          -- would get type forall a. Num a => (# a, Bool #)
-          -- and we want to reject that.  See Trac #9140
+    is_unlifted_id id = isUnliftedType (idType id)
 
 -- | Is a binding a strict variable bind (e.g. @!x = ...@)?
 isBangedBind :: HsBind GhcTc -> Bool
@@ -911,7 +894,6 @@ collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++
         -- I don't think we want the binders from the abe_binds
         -- The only time we collect binders from a typechecked
         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
-collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc
 collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc
   | omitPatSyn                  = acc
   | otherwise                   = ps : acc
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 2327b6ffef..0995f6bae8 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -38,7 +38,7 @@ import FamInstEnv( normaliseType )
 import FamInst( tcGetFamInstEnvs )
 import TyCon
 import TcType
-import Type( mkStrLitTy, tidyOpenType, mkTyVarBinder, splitTyConApp_maybe)
+import Type( mkStrLitTy, tidyOpenType, splitTyConApp_maybe)
 import TysPrim
 import TysWiredIn( cTupleTyConName )
 import Id
@@ -717,13 +717,18 @@ tcPolyCheck prag_fn
                              , bind_fvs    = placeHolderNamesTc
                              , fun_tick    = funBindTicks nm_loc mono_id mod prag_sigs }
 
-             abs_bind = L loc $ AbsBindsSig
-                        { abs_sig_export  = poly_id
-                        , abs_tvs         = skol_tvs
-                        , abs_ev_vars     = ev_vars
-                        , abs_sig_prags   = SpecPrags spec_prags
-                        , abs_sig_ev_bind = ev_binds
-                        , abs_sig_bind    = L loc bind' }
+             export = ABE { abe_wrap = idHsWrapper
+                          , abe_poly  = poly_id
+                          , abe_mono  = mono_id
+                          , abe_prags = SpecPrags spec_prags }
+
+             abs_bind = L loc $
+                        AbsBinds { abs_tvs      = skol_tvs
+                                 , abs_ev_vars  = ev_vars
+                                 , abs_ev_binds = [ev_binds]
+                                 , abs_exports  = [export]
+                                 , abs_binds    = unitBag (L loc bind')
+                                 , abs_sig      = True }
 
        ; return (unitBag abs_bind, [poly_id]) }
 
@@ -799,7 +804,8 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
              abs_bind = L loc $
                         AbsBinds { abs_tvs = qtvs
                                  , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
-                                 , abs_exports = exports, abs_binds = binds' }
+                                 , abs_exports = exports, abs_binds = binds'
+                                 , abs_sig = False }
 
        ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
        ; return (unitBag abs_bind, poly_ids) }
@@ -858,9 +864,9 @@ mkExport prag_fn insoluble qtvs theta
 
         ; return (ABE { abe_wrap = wrap
                         -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
-                      , abe_poly = poly_id
-                      , abe_mono = mono_id
-                      , abe_prags = SpecPrags spec_prags}) }
+                      , abe_poly  = poly_id
+                      , abe_mono  = mono_id
+                      , abe_prags = SpecPrags spec_prags }) }
   where
     prag_sigs = lookupPragEnv prag_fn poly_name
     sig_ctxt  = InfSigCtxt poly_name
@@ -1611,7 +1617,7 @@ data GeneralisationPlan
 
   | CheckGen (LHsBind GhcRn) TcIdSigInfo
                         -- One FunBind with a signature
-                        -- Explicit generalisation; there is an AbsBindsSig
+                        -- Explicit generalisation
 
 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
index a3e9549a1c..5519cc8bca 100644
--- a/compiler/typecheck/TcClassDcl.hs
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -278,14 +278,15 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
                               (L bind_loc lm_bind)
 
        ; let export = ABE { abe_poly   = global_dm_id
-                           , abe_mono  = local_dm_id
-                           , abe_wrap  = idHsWrapper
-                           , abe_prags = IsDefaultMethod }
+                          , abe_mono  = local_dm_id
+                          , abe_wrap  = idHsWrapper
+                          , abe_prags = IsDefaultMethod }
              full_bind = AbsBinds { abs_tvs      = tyvars
                                   , abs_ev_vars  = [this_dict]
                                   , abs_exports  = [export]
                                   , abs_ev_binds = [ev_binds]
-                                  , abs_binds    = tc_bind }
+                                  , abs_binds    = tc_bind
+                                  , abs_sig      = True }
 
        ; return (unitBag (L bind_loc full_bind)) }
 
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 86ade903ec..c5de0dce01 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -455,24 +455,44 @@ zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
 zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                         , abs_ev_binds = ev_binds
                         , abs_exports = exports
-                        , abs_binds = val_binds })
+                        , abs_binds = val_binds
+                        , abs_sig = has_sig })
   = ASSERT( all isImmutableTyVar tyvars )
     do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
        ; (env1, new_evs) <- zonkEvBndrsX env0 evs
        ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
        ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
-         do { let env3 = extendIdZonkEnvRec env2
-                           (collectHsBindsBinders new_val_binds)
-            ; new_val_binds <- zonkMonoBinds env3 val_binds
-            ; new_exports   <- mapM (zonkExport env3) exports
+         do { let env3 = extendIdZonkEnvRec env2 $
+                         collectHsBindsBinders new_val_binds
+            ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds
+            ; new_exports   <- mapM (zonk_export env3) exports
             ; return (new_val_binds, new_exports) }
        ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
                           , abs_ev_binds = new_ev_binds
-                          , abs_exports = new_exports, abs_binds = new_val_bind }) }
+                          , abs_exports = new_exports, abs_binds = new_val_bind
+                          , abs_sig = has_sig }) }
   where
-    zonkExport env (ABE{ abe_wrap = wrap
-                       , abe_poly = poly_id
-                       , abe_mono = mono_id, abe_prags = prags })
+    zonk_val_bind env lbind
+      | has_sig
+      , L loc bind@(FunBind { fun_id      = L mloc mono_id
+                            , fun_matches = ms
+                            , fun_co_fn   = co_fn }) <- lbind
+      = do { new_mono_id <- updateVarTypeM (zonkTcTypeToType env) mono_id
+                            -- Specifically /not/ zonkIdBndr; we do not
+                            -- want to complain about a levity-polymorphic binder
+           ; (env', new_co_fn) <- zonkCoFn env co_fn
+           ; new_ms            <- zonkMatchGroup env' zonkLExpr ms
+           ; return $ L loc $
+             bind { fun_id      = L mloc new_mono_id
+                  , fun_matches = new_ms
+                  , fun_co_fn   = new_co_fn } }
+      | otherwise
+      = zonk_lbind env lbind   -- The normal case
+
+    zonk_export env (ABE{ abe_wrap = wrap
+                        , abe_poly = poly_id
+                        , abe_mono = mono_id
+                        , abe_prags = prags })
         = do new_poly_id <- zonkIdBndr env poly_id
              (_, new_wrap) <- zonkCoFn env wrap
              new_prags <- zonkSpecPrags env prags
@@ -481,44 +501,6 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                         , abe_mono = zonkIdOcc env mono_id
                         , abe_prags = new_prags })
 
-zonk_bind env outer_bind@(AbsBindsSig { abs_tvs         = tyvars
-                                      , abs_ev_vars     = evs
-                                      , abs_sig_export  = poly
-                                      , abs_sig_prags   = prags
-                                      , abs_sig_ev_bind = ev_bind
-                                      , abs_sig_bind    = lbind })
-  | L bind_loc bind@(FunBind { fun_id      = L loc local
-                             , fun_matches = ms
-                             , fun_co_fn   = co_fn }) <- lbind
-  = ASSERT( all isImmutableTyVar tyvars )
-    do { (env0, new_tyvars)  <- zonkTyBndrsX env  tyvars
-       ; (env1, new_evs)     <- zonkEvBndrsX env0 evs
-       ; (env2, new_ev_bind) <- zonkTcEvBinds env1 ev_bind
-           -- Inline zonk_bind (FunBind ...) because we wish to skip
-           -- the check for representation-polymorphic binders. The
-           -- local binder in the FunBind in an AbsBindsSig is never actually
-           -- bound in Core -- indeed, that's the whole point of AbsBindsSig.
-           -- just calling zonk_bind causes #11405.
-       ; new_local           <- updateVarTypeM (zonkTcTypeToType env2) local
-       ; (env3, new_co_fn)   <- zonkCoFn env2 co_fn
-       ; new_ms              <- zonkMatchGroup env3 zonkLExpr ms
-           -- If there is a representation polymorphism problem, it will
-           -- be caught here:
-       ; new_poly_id         <- zonkIdBndr env2 poly
-       ; new_prags           <- zonkSpecPrags env2 prags
-       ; let new_val_bind = L bind_loc (bind { fun_id      = L loc new_local
-                                             , fun_matches = new_ms
-                                             , fun_co_fn   = new_co_fn })
-       ; return (AbsBindsSig { abs_tvs         = new_tyvars
-                             , abs_ev_vars     = new_evs
-                             , abs_sig_export  = new_poly_id
-                             , abs_sig_prags   = new_prags
-                             , abs_sig_ev_bind = new_ev_bind
-                             , abs_sig_bind    = new_val_bind  }) }
-
-  | otherwise
-  = pprPanic "zonk_bind" (ppr outer_bind)
-
 zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id
                                     , psb_args = details
                                     , psb_def = lpat
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index dc8eb0ce9d..fe513f4f59 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -889,7 +889,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                                   , abs_ev_vars = dfun_ev_vars
                                   , abs_exports = [export]
                                   , abs_ev_binds = []
-                                  , abs_binds = unitBag dict_bind }
+                                  , abs_binds = unitBag dict_bind
+                                  , abs_sig = True }
 
        ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds)
        }
@@ -1037,7 +1038,8 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta
                                  , abs_ev_vars  = dfun_evs
                                  , abs_exports  = [export]
                                  , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
-                                 , abs_binds    = emptyBag }
+                                 , abs_binds    = emptyBag
+                                 , abs_sig      = False }
            ; return (sc_top_id, L loc bind, sc_implic) }
 
 -------------------
@@ -1374,17 +1376,18 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
        ; spec_prags     <- tcSpecPrags global_meth_id prags
 
         ; let specs  = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
-              export = ABE { abe_poly      = global_meth_id
-                           , abe_mono      = local_meth_id
-                           , abe_wrap      = idHsWrapper
-                           , abe_prags     = specs }
+              export = ABE { abe_poly  = global_meth_id
+                           , abe_mono  = local_meth_id
+                           , abe_wrap  = idHsWrapper
+                           , abe_prags = specs }
 
               local_ev_binds = TcEvBinds ev_binds_var
               full_bind = AbsBinds { abs_tvs      = tyvars
                                    , abs_ev_vars  = dfun_ev_vars
                                    , abs_exports  = [export]
                                    , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
-                                   , abs_binds    = tc_bind }
+                                   , abs_binds    = tc_bind
+                                   , abs_sig      = True }
 
         ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }
   where
@@ -1429,7 +1432,8 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
        ; return (unitBag $ L (getLoc meth_bind) $
                  AbsBinds { abs_tvs = [], abs_ev_vars = []
                           , abs_exports = [export]
-                          , abs_binds = tc_bind, abs_ev_binds = [] }) }
+                          , abs_binds = tc_bind, abs_ev_binds = []
+                          , abs_sig = True }) }
 
   | otherwise  -- No instance signature
   = do { let ctxt = FunSigCtxt sel_name False