codeGen: Optimize continuation argumentswip/T16098

This diff implements code generation for continuation arguments, as
proposed in #16098. For primops like `catch#`/`with#`/`mask`/... which
are defined in the runtime-system there is no mechanism for inlining
them. This often leads to otherwise unnecessary allocations of closures.

This patch introduces the notion of continuation arguments to code
generation, including:

 * A way to control CorePrep to not ANFize certain primops. That is,
   leaving arguments of the form `State# s -> (# State# s, a #)` in
   defined positions.
 * Teaching `CoreToStg` how to translate these to STG by extending STG
   language. Namely the `GenStgArg` type.
 * Inline primops and continuation in code generation.

This patch happily inlines `catch`#:

```
...
I64[Sp - 24] = PicBaseReg + stg_catch_frame_info;
I64[Sp - 16] = %MO_UU_Conv_W32_W64(I32[I64[BaseReg + 872] + 28]);
I64[Sp - 8] = PicBaseReg + (Test.someHandler_closure+2);
...
```

No...

 * ... call to runtime system
 * ... allocation
 * ... copying of free variables

needed

Currently this is implemented only for catch# primop. Once we agree to
merge this I will bring in the rest.

P.S. Also StgCse and Unarise are broken for continuation arguments. I
will fix that in the coming days.

[1] https://gitlab.haskell.org/ghc/ghc/blob/4898df1cc25132dc9e2599d4fa4e1bbc9423cda5/rts/Exception.cmm#L393

9 files changed, 175 insertions, 42 deletions

diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index e84278bf65..d38f31ea6d 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -41,6 +41,7 @@ module GHC.Cmm.CLabel (
 
         mkDirty_MUT_VAR_Label,
         mkNonmovingWriteBarrierEnabledLabel,
+        mkCatchInfoLabel,
         mkUpdInfoLabel,
         mkBHUpdInfoLabel,
         mkIndStaticInfoLabel,
@@ -487,6 +488,7 @@ mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable
 -- Constructing Cmm Labels
 mkDirty_MUT_VAR_Label,
     mkNonmovingWriteBarrierEnabledLabel,
+    mkCatchInfoLabel,
     mkUpdInfoLabel,
     mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,
     mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,
@@ -499,6 +501,7 @@ mkDirty_MUT_VAR_Label,
 mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
 mkNonmovingWriteBarrierEnabledLabel
                                 = CmmLabel rtsUnitId (fsLit "nonmoving_write_barrier_enabled") CmmData
+mkCatchInfoLabel                = CmmLabel rtsUnitId (fsLit "stg_catch_frame")       CmmInfo
 mkUpdInfoLabel                  = CmmLabel rtsUnitId (fsLit "stg_upd_frame")         CmmInfo
 mkBHUpdInfoLabel                = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" )     CmmInfo
 mkIndStaticInfoLabel            = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC")        CmmInfo
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index 83799f6e49..c61f378504 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -582,12 +582,21 @@ coreToStgArgs (arg : args) = do         -- Non-type argument
     (stg_args, ticks) <- coreToStgArgs args
     arg' <- coreToStgExpr arg
     let
+        arg_ty = exprType arg
         (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
         stg_arg = case arg'' of
                        StgApp v []        -> StgVarArg v
                        StgConApp con [] _ -> StgVarArg (dataConWorkId con)
                        StgLit lit         -> StgLitArg lit
-                       _                  -> pprPanic "coreToStgArgs" (ppr arg)
+                       StgLam bndrs body  ->
+                         let
+                           bndr = case toList bndrs of
+                             [x] -> x
+                             xs  ->
+                               -- TODO: more informative error message
+                               pprPanic "coreToStgArgs" (ppr arg'')
+                         in StgContArg bndr body arg_ty
+                       _  -> pprPanic "coreToStgArgs" (ppr arg'')
 
         -- WARNING: what if we have an argument like (v `cast` co)
         --          where 'co' changes the representation type?
@@ -601,7 +610,7 @@ coreToStgArgs (arg : args) = do         -- Non-type argument
 
     dflags <- getDynFlags
     let
-        arg_rep = typePrimRep (exprType arg)
+        arg_rep = typePrimRep arg_ty
         stg_arg_rep = typePrimRep (stgArgType stg_arg)
         bad_args = not (primRepsCompatible dflags arg_rep stg_arg_rep)
 
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 4dd1822a5e..186b9e96b3 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -785,6 +785,18 @@ data ArgInfo = CpeApp  CoreArg
              | CpeCast Coercion
              | CpeTick (Tickish Id)
 
+
+data ArgForm = ArgCont
+             | ArgValue
+
+-- TODO: make this configurable in primops.pp.txt
+argForms :: Id -> [ArgForm]
+argForms f
+  | Just CatchOp <- isPrimOpId_maybe f
+  = [ ArgValue, ArgValue, ArgCont, ArgValue, ArgValue]
+argForms f
+  = repeat ArgValue
+
 {- Note [runRW arg]
 ~~~~~~~~~~~~~~~~~~~
 If we got, say
@@ -856,16 +868,47 @@ cpeApp top_env expr
         = case arg of
             Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body [] 0
             _          -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1
+{-
+    cpe_app env (Var f) [ CpeApp resTy@Type{}
+                        , CpeApp excTy@Type{}
+                        , CpeApp body
+                        , CpeApp handler
+                        , CpeApp rw
+                        ] _depth
+        | Just CatchOp <- isPrimOpId_maybe f
+        =
+
+
+        case body of
+            Lam s rhs -> do
+              rhs' <- cpeBodyNF env rhs
+              return (emptyFloats, mkApps (Var f) [ resTy
+                                                  , excTy
+                                                  , Lam s rhs'
+                                                  , handler
+                                                  , rw
+                                                  ])
+            _ -> do
+              body' <- cpeBodyNF env body
+              return (emptyFloats, mkApps (Var f) [ resTy
+                                                  , excTy
+                                                  , cpeEtaExpand 1 body'
+                                                  , handler
+                                                  , rw
+                                                  ])
+-}
     cpe_app env (Var v) args depth
       = do { v1 <- fiddleCCall v
-           ; let e2 = lookupCorePrepEnv env v1
-                 hd = getIdFromTrivialExpr_maybe e2
+           ; let e2  = lookupCorePrepEnv env v1
+                 hd  = getIdFromTrivialExpr_maybe e2
+                 afs = argForms v1
+
            -- NB: depth from collect_args is right, because e2 is a trivial expression
            -- and thus its embedded Id *must* be at the same depth as any
            -- Apps it is under are type applications only (c.f.
            -- exprIsTrivial).  But note that we need the type of the
            -- expression, not the id.
-           ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts
+           ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts afs
            ; mb_saturate hd app floats depth }
         where
           stricts = case idStrictness v of
@@ -885,10 +928,10 @@ cpeApp top_env expr
 
         -- N-variable fun, better let-bind it
     cpe_app env fun args depth
-      = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty
+      = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty ArgValue
                           -- The evalDmd says that it's sure to be evaluated,
                           -- so we'll end up case-binding it
-           ; (app, floats) <- rebuild_app args fun' ty fun_floats []
+           ; (app, floats) <- rebuild_app args fun' ty fun_floats [] []
            ; mb_saturate Nothing app floats depth }
         where
           ty = exprType fun
@@ -911,33 +954,37 @@ cpeApp top_env expr
         -> Type
         -> Floats
         -> [Demand]
+        -> [ArgForm]
         -> UniqSM (CpeApp, Floats)
-    rebuild_app [] app _ floats ss = do
+    rebuild_app [] app _ floats ss _ = do
       MASSERT(null ss) -- make sure we used all the strictness info
       return (app, floats)
-    rebuild_app (a : as) fun' fun_ty floats ss = case a of
+    rebuild_app (a : as) fun' fun_ty floats ss afs = case a of
       CpeApp arg@(Type arg_ty) ->
-        rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss
+        rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss afs_rest
       CpeApp arg@(Coercion {}) ->
-        rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss
+        rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss afs_rest
       CpeApp arg -> do
         let (ss1, ss_rest)  -- See Note [lazyId magic] in MkId
                = case (ss, isLazyExpr arg) of
                    (_   : ss_rest, True)  -> (topDmd, ss_rest)
                    (ss1 : ss_rest, False) -> (ss1,    ss_rest)
                    ([],            _)     -> (topDmd, [])
-            (arg_ty, res_ty) =
-              case splitFunTy_maybe fun_ty of
-                Just as -> as
-                Nothing -> pprPanic "cpeBody" (ppr fun_ty $$ ppr expr)
-        (fs, arg') <- cpeArg top_env ss1 arg arg_ty
-        rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest
+            (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
+                               splitFunTy_maybe fun_ty
+        (fs, arg') <- cpeArg top_env ss1 arg arg_ty arg_form
+        rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest afs_rest
       CpeCast co ->
-        let ty2 = coercionRKind co
-        in rebuild_app as (Cast fun' co) ty2 floats ss
+        let Pair _ty1 ty2 = coercionKind co
+        in rebuild_app as (Cast fun' co) ty2 floats ss afs_rest
       CpeTick tickish ->
         -- See [Floating Ticks in CorePrep]
-        rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss
+        rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss afs_rest
+      where
+        (arg_form, afs_rest)
+          = case afs of
+              []     -> (ArgValue, [])
+              (a:ax) -> (a, ax)
 
 isLazyExpr :: CoreExpr -> Bool
 -- See Note [lazyId magic] in MkId
@@ -1026,8 +1073,18 @@ okCpeArg expr    = not (exprIsTrivial expr)
 
 -- This is where we arrange that a non-trivial argument is let-bound
 cpeArg :: CorePrepEnv -> Demand
-       -> CoreArg -> Type -> UniqSM (Floats, CpeArg)
-cpeArg env dmd arg arg_ty
+       -> CoreArg -> Type -> ArgForm -> UniqSM (Floats, CpeArg)
+cpeArg env dmd arg arg_ty ArgCont = do
+  arg' <- case arg of
+    Lam s body -> do
+      body' <- cpeBodyNF env body
+      return (Lam s body')
+    _ -> do
+      body' <- cpeBodyNF env arg
+      return (cpeEtaExpand 1 body')
+  pure (emptyFloats, arg')
+
+cpeArg env dmd arg arg_ty arg_form
   = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda
        ; (floats2, arg2) <- if want_float floats1 arg1
                             then return (floats1, arg1)
diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs
index 66f5004b49..714fbe5d4a 100644
--- a/compiler/GHC/Stg/CSE.hs
+++ b/compiler/GHC/Stg/CSE.hs
@@ -116,10 +116,12 @@ instance TrieMap StgArgMap where
     type Key StgArgMap = StgArg
     emptyTM  = SAM { sam_var = emptyTM
                    , sam_lit = emptyTM }
-    lookupTM (StgVarArg var) = sam_var >.> lkDFreeVar var
-    lookupTM (StgLitArg lit) = sam_lit >.> lookupTM lit
+    lookupTM (StgVarArg var)  = sam_var >.> lkDFreeVar var
+    lookupTM (StgLitArg lit)  = sam_lit >.> lookupTM lit
+    lookupTM (StgContArg _ _ _) = const Nothing
     alterTM  (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f }
     alterTM  (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f }
+    alterTM  (StgContArg _ _ _) f m = m
     foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m)
     mapTM f (SAM {sam_var = varm, sam_lit = litm}) =
         SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm }
@@ -198,8 +200,9 @@ initEnv in_scope = CseEnv
 envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId
 envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env)
   where args' = map go args -- See Note [Trivial case scrutinee]
-        go (StgVarArg v  ) = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v)
-        go (StgLitArg lit) = StgLitArg lit
+        go (StgVarArg v  )  = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v)
+        go (StgLitArg lit)  = StgLitArg lit
+        go (StgContArg bndr body ty) = StgContArg bndr body ty
 
 addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv
 -- do not bother with nullary data constructors, they are static anyways
@@ -224,8 +227,9 @@ substArgs :: CseEnv -> [InStgArg] -> [OutStgArg]
 substArgs env = map (substArg env)
 
 substArg :: CseEnv -> InStgArg -> OutStgArg
-substArg env (StgVarArg from) = StgVarArg (substVar env from)
-substArg _   (StgLitArg lit)  = StgLitArg lit
+substArg env (StgVarArg from)       = StgVarArg (substVar env from)
+substArg _   (StgLitArg lit)        = StgLitArg lit
+substArg env (StgContArg bndr body ty) = StgContArg bndr body ty
 
 substVar :: CseEnv -> InId -> OutId
 substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id
diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs
index 256be34ce8..cf74842ca6 100644
--- a/compiler/GHC/Stg/Syntax.hs
+++ b/compiler/GHC/Stg/Syntax.hs
@@ -20,7 +20,7 @@ generation.
 {-# LANGUAGE ConstraintKinds #-}
 
 module GHC.Stg.Syntax (
-        StgArg(..),
+        StgArg(..), stgIsContArg,
 
         GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
         GenStgAlt, AltType(..),
@@ -116,9 +116,14 @@ StgArg
 ************************************************************************
 -}
 
-data StgArg
+data GenStgArg pass
   = StgVarArg  Id
   | StgLitArg  Literal
+  | StgContArg (BinderP pass) (GenStgExpr pass) Type
+
+stgIsContArg :: GenStgArg bndr occ -> Bool
+stgIsContArg StgContArg{} = True
+stgIsContArg _            = False
 
 -- | Does this constructor application refer to anything in a different
 -- *Windows* DLL?
@@ -165,6 +170,7 @@ isAddrRep _           = False
 stgArgType :: StgArg -> Type
 stgArgType (StgVarArg v)   = idType v
 stgArgType (StgLitArg lit) = literalType lit
+stgArgType (StgContArg _ _ ty) = ty
 
 
 -- | Strip ticks of a given type from an STG expression.
@@ -237,11 +243,11 @@ literals.
         -- StgConApp is vital for returning unboxed tuples or sums
         -- which can't be let-bound
   | StgConApp   DataCon
-                [StgArg] -- Saturated
+                [GenStgArg pass] -- Saturated
                 [Type]   -- See Note [Types in StgConApp] in GHC.Stg.Unarise
 
   | StgOpApp    StgOp    -- Primitive op or foreign call
-                [StgArg] -- Saturated.
+                [GenStgArg pass] -- Saturated.
                 Type     -- Result type
                          -- We need to know this so that we can
                          -- assign result registers
@@ -427,7 +433,7 @@ important):
                         -- from static closure.
         DataCon         -- Constructor. Never an unboxed tuple or sum, as those
                         -- are not allocated.
-        [StgArg]        -- Args
+        [GenStgArg pass] -- Args
 
 -- | Used as a data type index for the stgSyn AST
 data StgPass
@@ -538,9 +544,11 @@ rhsHasCafRefs (StgRhsCon _ _ args)
 altHasCafRefs :: GenStgAlt pass -> Bool
 altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs
 
-stgArgHasCafRefs :: StgArg -> Bool
+stgArgHasCafRefs :: GenStgArg pass -> Bool
 stgArgHasCafRefs (StgVarArg id)
   = stgIdHasCafRefs id
+stgArgHasCafRefs (StgContArg _ e _)
+  = exprHasCafRefs e
 stgArgHasCafRefs _
   = False
 
@@ -591,6 +599,7 @@ The Plain STG parameterisation
 
 This happens to be the only one we use at the moment.
 -}
+type StgArg = GenStgArg 'Vanilla
 
 type StgTopBinding = GenStgTopBinding 'Vanilla
 type StgBinding    = GenStgBinding    'Vanilla
@@ -732,7 +741,7 @@ pprStgBinding = pprGenStgBinding
 pprStgTopBindings :: [StgTopBinding] -> SDoc
 pprStgTopBindings = pprGenStgTopBindings
 
-instance Outputable StgArg where
+instance OutputablePass pass => Outputable (GenStgArg pass) where
     ppr = pprStgArg
 
 instance OutputablePass pass => Outputable (GenStgTopBinding pass) where
@@ -747,9 +756,10 @@ instance OutputablePass pass => Outputable (GenStgExpr pass) where
 instance OutputablePass pass => Outputable (GenStgRhs pass) where
     ppr rhs = pprStgRhs rhs
 
-pprStgArg :: StgArg -> SDoc
+pprStgArg :: OutputablePass pass =>  GenStgArg pass -> SDoc
 pprStgArg (StgVarArg var) = ppr var
 pprStgArg (StgLitArg con) = ppr con
+pprStgArg (StgContArg bndr body _) = ppr body
 
 pprStgExpr :: OutputablePass pass => GenStgExpr pass -> SDoc
 -- special case
diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs
index b2c1371840..46f6320902 100644
--- a/compiler/GHC/StgToCmm/Env.hs
+++ b/compiler/GHC/StgToCmm/Env.hs
@@ -158,6 +158,7 @@ cgLookupPanic id
 getArgAmode :: NonVoid StgArg -> FCode CmmExpr
 getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var
 getArgAmode (NonVoid (StgLitArg lit)) = CmmLit <$> cgLit lit
+getArgAmode (NonVoid arg) = pprPanic "getArgAmode" (ppr arg)
 
 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
 -- NB: Filters out void args,
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index 0c2d9b8ae5..2da9e21f34 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -506,7 +506,9 @@ isSimpleOp :: StgOp -> [StgArg] -> FCode Bool
 isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)
 -- dataToTag# evaluates its argument, see Note [dataToTag#] in primops.txt.pp
 isSimpleOp (StgPrimOp DataToTagOp) _ = return False
-isSimpleOp (StgPrimOp op) stg_args                  = do
+isSimpleOp (StgPrimOp op) stg_args = do
+  | any stgIsContArg stg_args = return False
+  | otherwise = do
     arg_exprs <- getNonVoidArgAmodes stg_args
     dflags <- getDynFlags
     -- See Note [Inlining out-of-line primops and heap checks]
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 06264099df..e1fe3b3ba8 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -24,6 +24,8 @@ module GHC.StgToCmm.Prim (
 
 import GhcPrelude hiding ((<*>))
 
+import {-# SOURCE #-} StgCmmExpr ( cgExpr )
+
 import GHC.StgToCmm.Layout
 import GHC.StgToCmm.Foreign
 import GHC.StgToCmm.Env
@@ -80,6 +82,20 @@ cgOpApp (StgFCallOp fcall ty) stg_args res_ty
   = cgForeignCall fcall ty stg_args res_ty
       -- Note [Foreign call results]
 
+cgOpApp (StgPrimOp CatchOp) (StgContArg _bndr body _ : handler : _) _res_ty = do
+  args' <- getNonVoidArgAmodes [handler]
+  let
+    handler_amode =
+      case args' of
+        [amode] -> amode
+        _       -> panic "CatchOp had void arg as handler"
+  emitCatchFrame handler_amode (cgExpr body)
+  -- TODO(hsyl20):
+  -- Shouldn't we substitute the binder in body with the real-world token
+  -- applied to catch#?
+  --
+  -- Shouldn't we emitReturn code just like the other inline primops?
+
 cgOpApp (StgPrimOp primop) args res_ty = do
     dflags <- getDynFlags
     cmm_args <- getNonVoidArgAmodes args
@@ -2994,6 +3010,35 @@ emitCtzCall res x width = do
         (MO_Ctz width)
         [ x ]
 
+-----------------------------------------------------------------------------
+-- Setting up catch frames
+
+emitCatchFrame :: CmmExpr -> FCode a -> FCode a
+emitCatchFrame handler body
+  = do
+       updfr  <- getUpdFrameOff
+       dflags <- getDynFlags
+       let
+         hdr       = fixedHdrSize dflags
+         off_frame = updfr + hdr + sIZEOF_StgCatchFrame_NoHdr dflags
+         frame     = CmmStackSlot Old off_frame
+
+         off_handler     = hdr + oFFSET_StgCatchFrame_handler dflags
+         off_exc_blocked = hdr + oFFSET_StgCatchFrame_exceptions_blocked dflags
+
+         exc_blocked =
+           CmmMachOp
+             (mo_u_32ToWord dflags)
+             [CmmLoad (CmmRegOff currentTSOReg (oFFSET_StgTSO_flags dflags)) b32]
+
+       -- TODO(hsyl20): It seems like some masking is missing compared to stg_catch#: see
+       -- https://github.com/hsyl20/ghc/commit/c4aecdf75fb2b9fa809458da14b578fa5d41190f#diff-38e0a01473e008dd4172ab960702dcfaL2492
+       emitStore frame (mkLblExpr mkCatchInfoLabel)
+       emitStore (cmmOffset dflags frame off_exc_blocked) exc_blocked
+       emitStore (cmmOffset dflags frame off_handler) handler
+
+       withUpdFrameOff off_frame body
+
 ---------------------------------------------------------------------------
 -- Pushing to the update remembered set
 ---------------------------------------------------------------------------
diff --git a/utils/deriveConstants/Main.hs b/utils/deriveConstants/Main.hs
index f6f590715b..2fd9f93a00 100644
--- a/utils/deriveConstants/Main.hs
+++ b/utils/deriveConstants/Main.hs
@@ -321,6 +321,9 @@ wanteds os = concat
           ,constantWord Both "TICKY_BIN_COUNT" "TICKY_BIN_COUNT"
            -- number of bins for histograms used in ticky code
 
+          ,constantWord Both "TSO_BLOCKEX" "TSO_BLOCKEX"
+          ,constantWord Both "TSO_INTERRUPTIBLE" "TSO_INTERRUPTIBLE"
+
           ,fieldOffset Both "StgRegTable" "rR1"
           ,fieldOffset Both "StgRegTable" "rR2"
           ,fieldOffset Both "StgRegTable" "rR3"
@@ -424,7 +427,7 @@ wanteds os = concat
           ,structField  Both "StgEntCounter" "entry_count"
 
           ,closureSize Both "StgUpdateFrame"
-          ,closureSize C    "StgCatchFrame"
+          ,closureSize Both "StgCatchFrame"
           ,closureSize C    "StgStopFrame"
 
           ,closureSize  Both "StgMutArrPtrs"
@@ -448,7 +451,7 @@ wanteds os = concat
           ,closureField  C    "StgTSO"      "cap"
           ,closureField  C    "StgTSO"      "saved_errno"
           ,closureField  C    "StgTSO"      "trec"
-          ,closureField  C    "StgTSO"      "flags"
+          ,closureField  Both "StgTSO"      "flags"
           ,closureField  C    "StgTSO"      "dirty"
           ,closureField  C    "StgTSO"      "bq"
           ,closureField  Both "StgTSO"      "alloc_limit"
@@ -464,8 +467,8 @@ wanteds os = concat
 
           ,closureField Both "StgUpdateFrame" "updatee"
 
-          ,closureField C "StgCatchFrame" "handler"
-          ,closureField C "StgCatchFrame" "exceptions_blocked"
+          ,closureField Both "StgCatchFrame" "handler"
+          ,closureField Both "StgCatchFrame" "exceptions_blocked"
 
           ,closureSize       C "StgPAP"
           ,closureField      C "StgPAP" "n_args"
@@ -973,4 +976,3 @@ execute verbose prog args
       ec <- rawSystem prog args
       unless (ec == ExitSuccess) $
           die ("Executing " ++ show prog ++ " failed")
-