Cheng Shao pushed to branch wip/computed-goto at Glasgow Haskell Compiler / GHC

Commits:

25 changed files:

Changes:

  • cabal.project-reinstall
    ... ... @@ -59,6 +59,7 @@ constraints: ghc +internal-interpreter +dynamic-system-linke,
    59 59 
                  ghc-bin +internal-interpreter +threaded,
    60 60 
                  ghci +internal-interpreter,
    61 61 
                  haddock +in-ghc-tree,
    62 
    +             haddock-api +in-ghc-tree,
    62 63 
                  any.array installed,
    63 64 
                  any.base installed,
    64 65 
                  any.deepseq installed,
    ... ... @@ -68,6 +69,8 @@ constraints: ghc +internal-interpreter +dynamic-system-linke,
    68 69 
                  any.pretty installed,
    69 70 
                  any.template-haskell installed
    70 71
    72 
    +package *
    73 
    +    happy-options: --strict
    71 74
    72 75 
     benchmarks: False
    73 76 
     tests: False

  • compiler/GHC/Core/Coercion.hs
    ... ... @@ -41,7 +41,8 @@ module GHC.Core.Coercion (
    41 41 
             mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo,
    42 42 
             mkFunCo, mkFunCo2, mkFunCoNoFTF, mkFunResCo,
    43 43 
             mkNakedFunCo,
    44 
    -        mkNakedForAllCo, mkForAllCo, mkForAllVisCos, mkHomoForAllCos,
    44 
    +        mkNakedForAllCo, mkForAllCo, mkForAllVisCos,
    45 
    +        mkHomoForAllCo, mkHomoForAllCos,
    45 46 
             mkPhantomCo, mkAxiomCo,
    46 47 
             mkHoleCo, mkUnivCo, mkSubCo,
    47 48 
             mkProofIrrelCo,
    ... ... @@ -980,7 +981,7 @@ mkForAllCo v visL visR kind_co co
    980 981 
       = mkReflCo r (mkTyCoForAllTy v visL ty)
    981 982
    982 983 
       | otherwise
    983 
    -  = mkForAllCo_NoRefl v visL visR kind_co co
    984 
    +  = mk_forall_co v visL visR kind_co co
    984 985
    985 986 
     -- mkForAllVisCos [tv{vis}] constructs a cast
    986 987 
     --   forall tv. res  ~R#   forall tv{vis} res`.
    ... ... @@ -1000,14 +1001,26 @@ mkHomoForAllCos vs orig_co
    1000 1001 
       = foldr go orig_co vs
    1001 1002 
       where
    1002 1003 
         go :: ForAllTyBinder -> Coercion -> Coercion
    1003 
    -    go (Bndr var vis) = mkForAllCo_NoRefl var vis vis MRefl
    1004 
    -
    1005 
    --- | Like 'mkForAllCo', but there is no need to check that the inner coercion isn't Refl;
    1006 
    ---   the caller has done that. (For example, it is guaranteed in 'mkHomoForAllCos'.)
    1007 
    --- The kind of the tycovar should be the left-hand kind of the kind coercion.
    1008 
    -mkForAllCo_NoRefl :: TyCoVar -> ForAllTyFlag -> ForAllTyFlag
    1009 
    -                  -> KindMCoercion -> Coercion -> Coercion
    1010 
    -mkForAllCo_NoRefl tcv visL visR kind_co co
    1004 
    +    go (Bndr var vis) co = mk_forall_co var vis vis MRefl co
    1005 
    +
    1006 
    +mkHomoForAllCo :: TyVar -> Coercion -> Coercion
    1007 
    +-- Specialised for a single TyVar,
    1008 
    +--    and visibility of coreTyLamForAllTyFlag
    1009 
    +mkHomoForAllCo tv orig_co
    1010 
    +  | Just (ty, r) <- isReflCo_maybe orig_co
    1011 
    +  = mkReflCo r (mkForAllTy (Bndr tv vis) ty)
    1012 
    +  | otherwise
    1013 
    +  = mk_forall_co tv vis vis MRefl orig_co
    1014 
    +  where
    1015 
    +    vis  = coreTyLamForAllTyFlag
    1016 
    +
    1017 
    +-- | `mk_forall_co` just builds a ForAllCo.
    1018 
    +-- With debug on, it checks invariants (e.g. he kind of the tycovar should
    1019 
    +--   be the left-hand kind of the kind coercion).
    1020 
    +-- Callers should have done any isReflCo short-cutting.
    1021 
    +mk_forall_co :: TyCoVar -> ForAllTyFlag -> ForAllTyFlag
    1022 
    +             -> KindMCoercion -> Coercion -> Coercion
    1023 
    +mk_forall_co tcv visL visR kind_co co
    1011 1024 
       = assertGoodForAllCo tcv visL visR kind_co co $
    1012 1025 
         assertPpr (not (isReflCo co && isReflMCo kind_co && visL == visR)) (ppr co) $
    1013 1026 
         ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR
    ... ... @@ -1769,7 +1782,7 @@ mkPiCos r vs co = foldr (mkPiCo r) co vs
    1769 1782 
     -- | Make a forall 'Coercion', where both types related by the coercion
    1770 1783 
     -- are quantified over the same variable.
    1771 1784 
     mkPiCo  :: Role -> Var -> Coercion -> Coercion
    1772 
    -mkPiCo r v co | isTyVar v = mkHomoForAllCos [Bndr v coreTyLamForAllTyFlag] co
    1785 
    +mkPiCo r v co | isTyVar v = mkHomoForAllCo v co
    1773 1786 
                   | isCoVar v = assert (not (v `elemVarSet` tyCoVarsOfCo co)) $
    1774 1787 
                       -- We didn't call mkForAllCo here because if v does not appear
    1775 1788 
                       -- in co, the argument coercion will be nominal. But here we

  • compiler/GHC/Hs/Syn/Type.hs
    ... ... @@ -187,11 +187,13 @@ liftPRType :: (Type -> Type) -> PRType -> PRType
    187 187 
     liftPRType f pty = (f (prTypeType pty), [])
    188 188
    189 189 
     hsWrapperType :: HsWrapper -> Type -> Type
    190 
    +-- Return the type of (WrapExpr wrap e), given that e :: ty
    190 191 
     hsWrapperType wrap ty = prTypeType $ go wrap (ty,[])
    191 192 
       where
    192 193 
         go WpHole              = id
    194 
    +    go (WpSubType w)       = go w
    193 195 
         go (w1 `WpCompose` w2) = go w1 . go w2
    194 
    -    go (WpFun _ w2 (Scaled m exp_arg)) = liftPRType $ \t ->
    196 
    +    go (WpFun _ w2 (Scaled m exp_arg) _) = liftPRType $ \t ->
    195 197 
           let act_res = funResultTy t
    196 198 
               exp_res = hsWrapperType w2 act_res
    197 199 
           in mkFunctionType m exp_arg exp_res

  • compiler/GHC/HsToCore/Binds.hs
    ... ... @@ -1597,9 +1597,13 @@ dsHsWrapper hs_wrap thing_inside
    1597 1597 
     ds_hs_wrapper :: HsWrapper
    1598 1598 
                   -> ((CoreExpr -> CoreExpr) -> DsM a)
    1599 1599 
                   -> DsM a
    1600 
    -ds_hs_wrapper wrap = go wrap
    1600 
    +ds_hs_wrapper hs_wrap
    1601 
    +  = go hs_wrap
    1601 1602 
       where
    1602 1603 
         go WpHole            k = k $ \e -> e
    1604 
    +    go (WpSubType w)     k = go (optSubTypeHsWrapper w) k
    1605 
    +                             -- See (DSST3) in Note [Deep subsumption and WpSubType]
    1606 
    +                             --             in GHC.Tc.Types.Evidence
    1603 1607 
         go (WpTyApp ty)      k = k $ \e -> App e (Type ty)
    1604 1608 
         go (WpEvLam ev)      k = k $ Lam ev
    1605 1609 
         go (WpTyLam tv)      k = k $ Lam tv
    ... ... @@ -1612,13 +1616,13 @@ ds_hs_wrapper wrap = go wrap
    1612 1616 
         go (WpCompose c1 c2) k = go c1 $ \w1 ->
    1613 1617 
                                  go c2 $ \w2 ->
    1614 1618 
                                  k (w1 . w2)
    1615 
    -    go (WpFun c1 c2 st)  k = -- See Note [Desugaring WpFun]
    1616 
    -                             do { x <- newSysLocalDs st
    1617 
    -                                ; go c1 $ \w1 ->
    1618 
    -                                  go c2 $ \w2 ->
    1619 
    -                                  let app f a = mkCoreApp (text "dsHsWrapper") f a
    1620 
    -                                      arg     = w1 (Var x)
    1621 
    -                                  in k (\e -> (Lam x (w2 (app e arg)))) }
    1619 
    +    go (WpFun c1 c2 st _) k = -- See Note [Desugaring WpFun]
    1620 
    +                              do { x <- newSysLocalDs st
    1621 
    +                                 ; go c1 $ \w1 ->
    1622 
    +                                   go c2 $ \w2 ->
    1623 
    +                                   let app f a = mkCoreApp (text "dsHsWrapper") f a
    1624 
    +                                       arg     = w1 (Var x)
    1625 
    +                                   in k (\e -> (Lam x (w2 (app e arg)))) }
    1622 1626
    1623 1627 
     --------------------------------------
    1624 1628 
     dsTcEvBinds_s :: [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a

  • compiler/GHC/HsToCore/Match.hs
    ... ... @@ -1240,7 +1240,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
    1240 1240 
         --        equating different ways of writing a coercion)
    1241 1241 
         wrap WpHole WpHole = True
    1242 1242 
         wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
    1243 
    -    wrap (WpFun w1 w2 _)   (WpFun w1' w2' _)   = wrap w1 w1' && wrap w2 w2'
    1243 
    +    wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2'
    1244 1244 
         wrap (WpCast co)       (WpCast co')        = co `eqCoercion` co'
    1245 1245 
         wrap (WpEvApp et1)     (WpEvApp et2)       = et1 `ev_term` et2
    1246 1246 
         wrap (WpTyApp t)       (WpTyApp t')        = eqType t t'

  • compiler/GHC/Iface/Ext/Ast.hs
    ... ... @@ -696,7 +696,7 @@ instance ToHie (LocatedA HsWrapper) where
    696 696 
             (WpLet bs)      -> toHie $ EvBindContext (mkScope osp) (getRealSpanA osp) (L osp bs)
    697 697 
             (WpCompose a b) -> concatM $
    698 698 
               [toHie (L osp a), toHie (L osp b)]
    699 
    -        (WpFun a b _)   -> concatM $
    699 
    +        (WpFun a b _ _) -> concatM $
    700 700 
               [toHie (L osp a), toHie (L osp b)]
    701 701 
             (WpEvLam a) ->
    702 702 
               toHie $ C (EvidenceVarBind EvWrapperBind (mkScope osp) (getRealSpanA osp))

  • compiler/GHC/Tc/Errors/Hole.hs
    ... ... @@ -823,9 +823,11 @@ tcFilterHoleFits limit typed_hole ht@(hole_ty, _) candidates =
    823 823
    824 824 
         unfoldWrapper :: HsWrapper -> [Type]
    825 825 
         unfoldWrapper = reverse . unfWrp'
    826 
    -      where unfWrp' (WpTyApp ty) = [ty]
    827 
    -            unfWrp' (WpCompose w1 w2) = unfWrp' w1 ++ unfWrp' w2
    828 
    -            unfWrp' _ = []
    826 
    +      where
    827 
    +        unfWrp' (WpTyApp ty)      = [ty]
    828 
    +        unfWrp' (WpSubType w)     = unfWrp' w
    829 
    +        unfWrp' (WpCompose w1 w2) = unfWrp' w1 ++ unfWrp' w2
    830 
    +        unfWrp' _                  = []
    829 831
    830 832
    831 833 
         -- The real work happens here, where we invoke the type checker using

  • compiler/GHC/Tc/Gen/App.hs
    ... ... @@ -794,7 +794,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
    794 794 
           = do { let herald = case fun_ctxt of
    795 795 
                                  VAExpansion (OrigStmt{}) _ _ -> ExpectedFunTySyntaxOp DoOrigin tc_fun
    796 796 
                                  _ ->  ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
    797 
    -           ; (wrap, arg_ty, res_ty) <-
    797 
    +           ; (fun_co, arg_ty, res_ty) <-
    798 798 
                     -- NB: matchActualFunTy does the rep-poly check.
    799 799 
                     -- For example, suppose we have f :: forall r (a::TYPE r). a -> Int
    800 800 
                     -- In an application (f x), we need 'x' to have a fixed runtime
    ... ... @@ -805,7 +805,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
    805 805 
                       (n_val_args, fun_sigma) fun_ty
    806 806
    807 807 
                ; arg' <- quickLookArg do_ql ctxt arg arg_ty
    808 
    -           ; let acc' = arg' : addArgWrap wrap acc
    808 
    +           ; let acc' = arg' : addArgWrap (mkWpCastN fun_co) acc
    809 809 
                ; go (pos+1) acc' res_ty rest_args }
    810 810
    811 811 
         new_arg_ty :: LHsExpr GhcRn -> Int -> TcM (Scaled TcType)

  • compiler/GHC/Tc/Gen/Head.hs
    ... ... @@ -765,13 +765,13 @@ tcInferOverLit lit@(OverLit { ol_val = val
    765 765 
                thing    = NameThing from_name
    766 766 
                mb_thing = Just thing
    767 767 
                herald   = ExpectedFunTyArg thing (HsLit noExtField hs_lit)
    768 
    -       ; (wrap2, sarg_ty, res_ty) <- matchActualFunTy herald mb_thing (1, from_ty) from_ty
    768 
    +       ; (co2, sarg_ty, res_ty) <- matchActualFunTy herald mb_thing (1, from_ty) from_ty
    769 769
    770 770 
            ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty)
    771 771 
            -- See Note [Source locations for implicit function calls] in GHC.Iface.Ext.Ast
    772 772 
            ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $
    773 773 
                             HsLit noExtField hs_lit
    774 
    -             from_expr = mkHsWrap (wrap2 <.> wrap1) $
    774 
    +             from_expr = mkHsWrap (mkWpCastN co2 <.> wrap1) $
    775 775 
                              mkHsVar (L loc from_id)
    776 776 
                  witness = HsApp noExtField (L (l2l loc) from_expr) lit_expr
    777 777 
                  lit' = OverLit { ol_val = val

  • compiler/GHC/Tc/Gen/Pat.hs
    ... ... @@ -699,7 +699,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
    699 699
    700 700 
              -- Expression must be a function
    701 701 
             ; let herald = ExpectedFunTyViewPat $ unLoc expr
    702 
    -        ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma)
    702 
    +        ; (expr_co1, Scaled _mult inf_arg_ty, inf_res_sigma)
    703 703 
                 <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_rho) expr_rho
    704 704 
                    -- See Note [View patterns and polymorphism]
    705 705 
                    -- expr_wrap1 :: expr_rho "->" (inf_arg_ty -> inf_res_sigma)
    ... ... @@ -720,7 +720,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
    720 720 
                   -- NB: pat_ty comes from matchActualFunTy, so it has a
    721 721 
                   -- fixed RuntimeRep, as needed to call mkWpFun.
    722 722
    723 
    -              expr_wrap = expr_wrap2' <.> expr_wrap1
    723 
    +              expr_wrap = expr_wrap2' <.> mkWpCastN expr_co1
    724 724
    725 725 
             ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) }
    726 726

  • compiler/GHC/Tc/Types/Evidence.hs
    ... ... @@ -8,10 +8,11 @@ module GHC.Tc.Types.Evidence (
    8 8 
       -- * HsWrapper
    9 9 
       HsWrapper(..),
    10 10 
       (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpForAllCast,
    11 
    -  mkWpEvLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, mkWpEta,
    11 
    +  mkWpEvLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, mkWpEta, mkWpSubType,
    12 12 
       collectHsWrapBinders,
    13 13 
       idHsWrapper, isIdHsWrapper,
    14 14 
       pprHsWrapper, hsWrapDictBinders,
    15 
    +  optSubTypeHsWrapper,
    15 16
    16 17 
       -- * Evidence bindings
    17 18 
       TcEvBinds(..), EvBindsVar(..),
    ... ... @@ -73,7 +74,7 @@ import GHC.Types.Unique.DFM
    73 74 
     import GHC.Types.Unique.FM
    74 75 
     import GHC.Types.Name( isInternalName )
    75 76 
     import GHC.Types.Var
    76 
    -import GHC.Types.Id( idScaledType )
    77 
    +import GHC.Types.Id( idScaledType, idType )
    77 78 
     import GHC.Types.Var.Env
    78 79 
     import GHC.Types.Var.Set
    79 80 
     import GHC.Types.Basic
    ... ... @@ -134,35 +135,128 @@ maybeSymCo NotSwapped co = co
    134 135 
     ************************************************************************
    135 136 
     -}
    136 137
    137 
    --- We write    wrap :: t1 ~> t2
    138 
    --- if       wrap[ e::t1 ] :: t2
    138 
    +{- Note [Deep subsumption and WpSubType]
    139 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    140 
    +When making DeepSubsumption checks, we may end up with hard-to-spot identity wrappers.
    141 
    +For example (#26349) suppose we have
    142 
    +    (forall a. Eq a => a->a) -> Int  <=   (forall a. Eq a => a->a) -> Int
    143 
    +The two types are equal so we should certainly get an identity wrapper.  But we'll get
    144 
    +tihs wrapper from `tcSubType`:
    145 
    +    WpFun (WpTyLam a <.> WpEvLam dg <.> WpLet (dw=dg) <.> WpEvApp dw <.> WpTyApp a)
    146 
    +          WpHole
    147 
    +That elaborate wrapper is really just a no-op, but it's far from obvious.  If we just
    148 
    +desugar (HsWrap f wp) straightforwardly we'll get
    149 
    +   \(g:forall a. Eq a => a -> a).
    150 
    +       f (/\a. \(dg:Eq a). let dw=dg in g a dw)
    151 
    +
    152 
    +To recognise that as just `f`, we'd have to eta-reduce twice.  But eta-reduction
    153 
    +is not sound in general, so we'll end up retaining the lambdas.  Two bad results:
    154 
    +
    155 
    +* Adding DeepSubsumption gratuitiously makes programs less efficient.
    156 
    +
    157 
    +* When the subsumption is on the LHS of a rule, or in a SPECIALISE pragma, we
    158 
    +  may not be able to make a decent RULE at all, and will fail with "LHS of rule
    159 
    +  is too complicated to desugar" (#26255)
    160 
    +
    161 
    +It'd be ideal to solve the problem at the source, by never generating those
    162 
    +gruesome wrappers in the first place, but we can't do that because:
    163 
    +
    164 
    +* The WpTyLam and WpTyApp are introduced independently, not together, in `tcSubType`,
    165 
    +  so we can't easily cancel them out.   For example, even if we have
    166 
    +     forall a. t1  <=  forall a. t2
    167 
    +  there is no guarantee that these are the "same" a.  E.g.
    168 
    +     forall a b. a -> b -> b   <=   forall x y. y -> x -> x
    169 
    +  Similarly WpEvLam and WpEvApp
    170 
    +
    171 
    +* We have not yet done constraint solving so we don't know what evidence will
    172 
    +  end up in those WpLet bindings.
    173 
    +
    174 
    +TL;DR we must generate the wrapper and then optimise it way if it turns out
    175 
    +that it is a no-op.  Here's our solution:
    176 
    +
    177 
    +(DSST1) Tag the wrappers generated from a subtype check with WpSubType. In normal
    178 
    +  wrappers the binders of a WpTyLam or WpEvLam can scope over the "hole" of the
    179 
    +  wrapper -- that is how we introduce type-lambdas and dictionary-lambda into the
    180 
    +  terms!  But in /subtype/ wrappers, these type/dictionary lambdas only scope over
    181 
    +  the WpTyApp and WpEvApp nodes in the /same/ wrapper.  That is what justifies us
    182 
    +  eta-reducing the type/dictionary lambdas.
    183 
    +
    184 
    +  In short, (WpSubType wp) means the same as `wp`, but with the added promise that
    185 
    +  the binders in `wp` do not scope over the hole.
    186 
    +
    187 
    +(DSST2) Avoid creating a WpSubType in the common WpHole case, using `mkWpSubType`.
    188 
    +
    189 
    +(DSST3) When desugaring, try eta-reduction on the payload of a WpSubType.
    190 
    +  This is done in `GHC.HsToCore.Binds.dsHsWrapper` by the call to `optSubTypeHsWrapper`.
    191 
    +
    192 
    +  We don't attempt to optimise HsWrappers /other than/ subtype wrappers. Why not?
    193 
    +  Because there aren't any useful optimsations we can do.  (We could collapse
    194 
    +  adjacent `WpCast`s perhaps, but that'll happen later automatically via `mkCast`.)
    195 
    +
    196 
    +  TL;DR:
    197 
    +    * we /must/ optimise subtype-HsWrappers (that's the point of this Note!)
    198 
    +    * there is little point in attempting to optimise any other HsWrappers
    199 
    +
    200 
    +Note [WpFun-RR-INVARIANT]
    201 
    +~~~~~~~~~~~~~~~~~~~~~~~~~
    202 
    +Given
    203 
    +  wrap = WpFun wrap1 wrap2 sty1 ty2
    204 
    +  where:  wrap1 :: exp_arg ~~> act_arg
    205 
    +          wrap2 :: act_res ~~> exp_res
    206 
    +          wrap  :: (act_arg -> act_res) ~~> (exp_arg -> exp_res)
    207 
    +we have
    208 
    +  WpFun-RR-INVARIANT:
    209 
    +      the input (exp_arg) and output (act_arg) types of `wrap1`
    210 
    +      both have a fixed runtime-rep
    211 
    +
    212 
    +Reason: We desugar wrap[e] into
    213 
    +    \(x:exp_arg). wrap2[ e wrap1[x] ]
    214 
    +And then, because of Note [Representation polymorphism invariants], we need:
    215 
    +
    216 
    +  * `exp_arg` must have a fixed runtime rep,
    217 
    +    so that lambda obeys the the FRR rules
    218 
    +
    219 
    +  * `act_arg` must have a fixed runtime rep,
    220 
    +    so the that application (e wrap1[x]) obeys the FRR tules
    221 
    +
    222 
    +Hence WpFun-INVARIANT.
    223 
    +-}
    224 
    +
    139 225 
     data HsWrapper
    226 
    +  -- NOTATION (~~>):
    227 
    +  --    We write          wrap :: t1 ~~> t2
    228 
    +  --    if       wrap[ e::t1 ] :: t2
    140 229 
       = WpHole                      -- The identity coercion
    141 230
    231 
    +  | WpSubType HsWrapper
    232 
    +       -- (WpSubType wp) is the same as `wp`, but with extra invariants
    233 
    +       -- See Note [Deep subsumption and WpSubType] (DSST1)
    234 
    +
    142 235 
       | WpCompose HsWrapper HsWrapper
    143 236 
            -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]]
    144 237 
            --
    145 238 
            -- Hence  (\a. []) `WpCompose` (\b. []) = (\a b. [])
    146 239 
            -- But    ([] a)   `WpCompose` ([] b)   = ([] b a)
    147 240 
            --
    148 
    -       -- If wrap1 :: t2 ~> t3
    149 
    -       --    wrap2 :: t1 ~> t2
    150 
    -       --- Then (wrap1 `WpCompose` wrap2) :: t1 ~> t3
    151 
    -
    152 
    -  | WpFun HsWrapper HsWrapper (Scaled TcTypeFRR)
    153 
    -       -- (WpFun wrap1 wrap2 (w, t1))[e] = \(x:_w exp_arg). wrap2[ e wrap1[x] ]
    154 
    -       -- So note that if  e     :: act_arg -> act_res
    155 
    -       --                  wrap1 :: exp_arg ~> act_arg
    156 
    -       --                  wrap2 :: act_res ~> exp_res
    157 
    -       --           then   WpFun wrap1 wrap2 : (act_arg -> arg_res) ~> (exp_arg -> exp_res)
    241 
    +       -- If wrap1 :: t2 ~~> t3
    242 
    +       --    wrap2 :: t1 ~~> t2
    243 
    +       --- Then (wrap1 `WpCompose` wrap2) :: t1 ~~> t3
    244 
    +
    245 
    +  | WpFun HsWrapper HsWrapper (Scaled TcTypeFRR) TcType
    246 
    +       -- (WpFun wrap1 wrap2 (w, t1) t2)[e] = \(x:_w exp_arg). wrap2[ e wrap1[x] ]
    247 
    +       --
    248 
    +       -- INVARIANT: both input and output types of `wrap1` have a fixed runtime-rep
    249 
    +       --            See Note [WpFun-RR-INVARIANT]
    250 
    +       --
    251 
    +       -- Typing rules:
    252 
    +       -- If    e     :: act_arg -> act_res
    253 
    +       --       wrap1 :: exp_arg ~~> act_arg
    254 
    +       --       wrap2 :: act_res ~~> exp_res
    255 
    +       -- then   WpFun wrap1 wrap2 :: (act_arg -> act_res) ~~> (exp_arg -> exp_res)
    158 256 
            -- This isn't the same as for mkFunCo, but it has to be this way
    159 257 
            -- because we can't use 'sym' to flip around these HsWrappers
    160 
    -       -- The TcType is the "from" type of the first wrapper;
    161 
    -       --     it always a Type, not a Constraint
    162 258 
            --
    163 
    -       -- NB: a WpFun is always for a (->) function arrow
    164 
    -       --
    165 
    -       -- Use 'mkWpFun' to construct such a wrapper.
    259 
    +       -- NB: a WpFun is always for a (->) function arrow, never (=>)
    166 260
    167 261 
       | WpCast TcCoercionR        -- A cast:  [] `cast` co
    168 262 
                                   -- Guaranteed not the identity coercion
    ... ... @@ -212,50 +306,48 @@ WpCast c1 <.> WpCast c2 = WpCast (c2 `mkTransCo` c1)
    212 306 
       --
    213 307 
       -- NB: <.> behaves like function composition:
    214 308 
       --
    215 
    -  --   WpCast c1 <.> WpCast c2 :: coercionLKind c2 ~> coercionRKind c1
    309 
    +  --   WpCast c1 <.> WpCast c2 :: coercionLKind c2 ~~> coercionRKind c1
    216 310 
       --
    217 311 
       -- This is thus the same as WpCast (c2 ; c1) and not WpCast (c1 ; c2).
    218 312 
     c1        <.> c2        = c1 `WpCompose` c2
    219 313
    220 
    --- | Smart constructor to create a 'WpFun' 'HsWrapper', which avoids introducing
    221 
    --- a lambda abstraction if the two supplied wrappers are either identities or
    222 
    --- casts.
    223 
    ---
    224 
    --- PRECONDITION: either:
    225 
    ---
    226 
    ---  1. both of the 'HsWrapper's are identities or casts, or
    227 
    ---  2. both the "from" and "to" types of the first wrapper have a syntactically
    228 
    ---     fixed RuntimeRep (see Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete).
    229 314 
     mkWpFun :: HsWrapper -> HsWrapper
    230 315 
             -> Scaled TcTypeFRR -- ^ the "from" type of the first wrapper
    231 316 
             -> TcType           -- ^ Either "from" type or "to" type of the second wrapper
    232 317 
                                 --   (used only when the second wrapper is the identity)
    233 318 
             -> HsWrapper
    234 
    -mkWpFun WpHole       WpHole       _             _  = WpHole
    235 
    -mkWpFun WpHole       (WpCast co2) (Scaled w t1) _  = WpCast (mk_wp_fun_co w (mkRepReflCo t1) co2)
    236 
    -mkWpFun (WpCast co1) WpHole       (Scaled w _)  t2 = WpCast (mk_wp_fun_co w (mkSymCo co1)    (mkRepReflCo t2))
    237 
    -mkWpFun (WpCast co1) (WpCast co2) (Scaled w _)  _  = WpCast (mk_wp_fun_co w (mkSymCo co1)    co2)
    238 
    -mkWpFun w_arg        w_res        t1            _  =
    239 
    -  -- In this case, we will desugar to a lambda
    240 
    -  --
    241 
    -  --   \x. w_res[ e w_arg[x] ]
    242 
    -  --
    243 
    -  -- To satisfy Note [Representation polymorphism invariants] in GHC.Core,
    244 
    -  -- it must be the case that both the lambda bound variable x and the function
    245 
    -  -- argument w_arg[x] have a fixed runtime representation, i.e. that both the
    246 
    -  -- "from" and "to" types of the first wrapper "w_arg" have a fixed runtime representation.
    247 
    -  --
    248 
    -  -- Unfortunately, we can't check this with an assertion here, because of
    249 
    -  -- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
    250 
    -  WpFun w_arg w_res t1
    251 
    -
    252 
    -mkWpEta :: [Id] -> HsWrapper -> HsWrapper
    319 
    +-- ^ Smart constructor for `WpFun`
    320 
    +-- Just removes clutter and optimises some common cases.
    321 
    +--
    322 
    +-- PRECONDITION: same as Note [WpFun-RR-INVARIANT]
    323 
    +--
    324 
    +-- Unfortunately, we can't check PRECONDITION with an assertion here, because of
    325 
    +-- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
    326 
    +mkWpFun w1 w2 st1@(Scaled m1 t1) t2
    327 
    +  = case (w1,w2) of
    328 
    +      (WpHole,     WpHole)     -> WpHole
    329 
    +      (WpHole,     WpCast co2) -> WpCast (mk_wp_fun_co m1 (mkRepReflCo t1) co2)
    330 
    +      (WpCast co1, WpHole)     -> WpCast (mk_wp_fun_co m1 (mkSymCo co1)    (mkRepReflCo t2))
    331 
    +      (WpCast co1, WpCast co2) -> WpCast (mk_wp_fun_co m1 (mkSymCo co1)    co2)
    332 
    +      (_,          _)          -> WpFun w1 w2 st1 t2
    333 
    +
    334 
    +mkWpSubType :: HsWrapper -> HsWrapper
    335 
    +-- See (DSST2) in Note [Deep subsumption and WpSubType]
    336 
    +mkWpSubType WpHole      = WpHole
    337 
    +mkWpSubType (WpCast co) = WpCast co
    338 
    +mkWpSubType w           = WpSubType w
    339 
    +
    340 
    +mkWpEta :: Type -> [Id] -> HsWrapper -> HsWrapper
    253 341 
     -- (mkWpEta [x1, x2] wrap) [e]
    254 342 
     --   = \x1. \x2.  wrap[e x1 x2]
    255 343 
     -- Just generates a bunch of WpFuns
    256 
    -mkWpEta xs wrap = foldr eta_one wrap xs
    344 
    +-- The incoming type is the type of the entire expression
    345 
    +mkWpEta orig_fun_ty xs wrap = go orig_fun_ty xs
    257 346 
       where
    258 
    -    eta_one x wrap = WpFun idHsWrapper wrap (idScaledType x)
    347 
    +    go _      []       = wrap
    348 
    +    go fun_ty (id:ids) = WpFun idHsWrapper (go res_ty ids) (idScaledType id) res_ty
    349 
    +                       where
    350 
    +                         res_ty = funResultTy fun_ty
    259 351
    260 352 
     mk_wp_fun_co :: Mult -> TcCoercionR -> TcCoercionR -> TcCoercionR
    261 353 
     mk_wp_fun_co mult arg_co res_co
    ... ... @@ -333,8 +425,9 @@ hsWrapDictBinders wrap = go wrap
    333 425 
      where
    334 426 
        go (WpEvLam dict_id)   = unitBag dict_id
    335 427 
        go (w1 `WpCompose` w2) = go w1 `unionBags` go w2
    336 
    -   go (WpFun _ w _)       = go w
    428 
    +   go (WpFun _ w _ _)     = go w
    337 429 
        go WpHole              = emptyBag
    430 
    +   go (WpSubType {})      = emptyBag  -- See Note [Deep subsumption and WpSubType]
    338 431 
        go (WpCast  {})        = emptyBag
    339 432 
        go (WpEvApp {})        = emptyBag
    340 433 
        go (WpTyLam {})        = emptyBag
    ... ... @@ -350,6 +443,7 @@ collectHsWrapBinders wrap = go wrap []
    350 443 
         go :: HsWrapper -> [HsWrapper] -> ([Var], HsWrapper)
    351 444 
         go (WpEvLam v)       wraps = add_lam v (gos wraps)
    352 445 
         go (WpTyLam v)       wraps = add_lam v (gos wraps)
    446 
    +    go (WpSubType w)     wraps = go w wraps
    353 447 
         go (WpCompose w1 w2) wraps = go w1 (w2:wraps)
    354 448 
         go wrap              wraps = ([], foldl' (<.>) wrap wraps)
    355 449
    ... ... @@ -358,6 +452,162 @@ collectHsWrapBinders wrap = go wrap []
    358 452
    359 453 
         add_lam v (vs,w) = (v:vs, w)
    360 454
    455 
    +
    456 
    +optSubTypeHsWrapper :: HsWrapper -> HsWrapper
    457 
    +-- This optimiser is used only on the payload of WpSubType
    458 
    +-- It finds cases where the entire wrapper is a no-op
    459 
    +-- See (DSST3) in Note [Deep subsumption and WpSubType]
    460 
    +optSubTypeHsWrapper wrap
    461 
    +  = opt wrap
    462 
    +  where
    463 
    +    opt :: HsWrapper -> HsWrapper
    464 
    +    opt w = foldr (<.>) WpHole (opt1 w [])
    465 
    +
    466 
    +    opt1 :: HsWrapper -> [HsWrapper] -> [HsWrapper]
    467 
    +    -- opt1 w ws = w <.> (foldr <.> WpHole ws)
    468 
    +    -- INVARIANT: ws::[HsWrapper] is optimised
    469 
    +    opt1 WpHole                 ws = ws
    470 
    +    opt1 (WpSubType w)          ws = opt1 w ws
    471 
    +    opt1 (w1 `WpCompose` w2)    ws = opt1 w1 (opt1 w2 ws)
    472 
    +    opt1 (WpCast co)            ws = opt_co co ws
    473 
    +    opt1 (WpEvLam ev)           ws = opt_ev_lam ev ws
    474 
    +    opt1 (WpTyLam tv)           ws = opt_ty_lam tv ws
    475 
    +    opt1 (WpLet binds)          ws = pushWpLet binds ws
    476 
    +    opt1 (WpFun w1 w2 sty1 ty2) ws = opt_fun w1 w2 sty1 ty2 ws
    477 
    +    opt1 w@(WpTyApp {})         ws = w : ws
    478 
    +    opt1 w@(WpEvApp {})         ws = w : ws
    479 
    +
    480 
    +    -----------------
    481 
    +    -- (WpTyLam a <.> WpTyApp a <.> w) = w
    482 
    +    -- i.e.   /\a. <hole> a   -->  <hole>
    483 
    +    -- This is only valid if whatever fills the hole does not mention 'a'
    484 
    +    -- But that's guaranteed in subtype-wrappers;
    485 
    +    -- see (DSST1) in Note [Deep subsumption and WpSubType]
    486 
    +    opt_ty_lam tv (WpTyApp ty : ws)
    487 
    +      | Just tv' <- getTyVar_maybe ty
    488 
    +      , tv==tv'
    489 
    +      , all (tv `not_in`) ws
    490 
    +      = ws
    491 
    +
    492 
    +    -- (WpTyLam a <.> WpCastCo co <.> w)
    493 
    +    --    = WpCast (ForAllCo a co) (WpTyLam <.> w)
    494 
    +    opt_ty_lam tv (WpCast co : ws)
    495 
    +      = opt_co (mkHomoForAllCo tv co) (opt_ty_lam tv ws)
    496 
    +
    497 
    +    opt_ty_lam tv ws
    498 
    +      = WpTyLam tv : ws
    499 
    +
    500 
    +    -----------------
    501 
    +    -- (WpEvLam ev <.> WpEvAp ev <.> w) = w
    502 
    +    -- Similar notes to WpTyLam
    503 
    +    opt_ev_lam ev (WpEvApp ev_tm : ws)
    504 
    +      | EvExpr (Var ev') <- ev_tm
    505 
    +      , ev == ev'
    506 
    +      , all (ev `not_in`) ws
    507 
    +      = ws
    508 
    +
    509 
    +    -- (WpEvLam ev <.> WpCast co <.> w)
    510 
    +    --    = WpCast (FunCo ev co) (WpEvLam <.> w)
    511 
    +    opt_ev_lam ev (WpCast co : ws)
    512 
    +      = opt_co fun_co (opt_ev_lam ev ws)
    513 
    +      where
    514 
    +        fun_co = mkFunCo Representational FTF_C_T
    515 
    +                        (mkNomReflCo ManyTy)
    516 
    +                        (mkRepReflCo (idType ev))
    517 
    +                        co
    518 
    +
    519 
    +    opt_ev_lam ev ws
    520 
    +      = WpEvLam ev : ws
    521 
    +
    522 
    +    -----------------
    523 
    +    -- WpCast co <.> WpCast co' <.> ws = WpCast (co;co') ws
    524 
    +    opt_co co (WpCast co' : ws)     = opt_co (co `mkTransCo` co') ws
    525 
    +    opt_co co ws | isReflexiveCo co = ws
    526 
    +                 | otherwise        = WpCast co : ws
    527 
    +
    528 
    +    ------------------
    529 
    +    opt_fun w1 w2 sty1 ty2 ws
    530 
    +      = case mkWpFun (opt w1) (opt w2) sty1 ty2 of
    531 
    +          WpHole    -> ws
    532 
    +          WpCast co -> opt_co co ws
    533 
    +          w         -> w : ws
    534 
    +
    535 
    +    ------------------
    536 
    +    -- Tiresome check that the lambda-bound type/evidence variable that we
    537 
    +    -- want to eta-reduce isn't free in the rest of the wrapper
    538 
    +    not_in :: TyVar -> HsWrapper -> Bool
    539 
    +    not_in _  WpHole                   = True
    540 
    +    not_in v (WpCast co)               = not (anyFreeVarsOfCo (== v) co)
    541 
    +    not_in v (WpTyApp ty)              = not (anyFreeVarsOfType (== v) ty)
    542 
    +    not_in v (WpFun w1 w2 _ _)         = not_in v w1 && not_in v w2
    543 
    +    not_in v (WpSubType w)             = not_in v w
    544 
    +    not_in v (WpCompose w1 w2)         = not_in v w1 && not_in v w2
    545 
    +    not_in v (WpEvApp (EvExpr e))      = not (v `elemVarSet` exprFreeVars e)
    546 
    +    not_in _ (WpEvApp (EvTypeable {})) = False  -- Giving up; conservative
    547 
    +    not_in _ (WpEvApp (EvFun {}))      = False  -- Giving up; conservative
    548 
    +    not_in _ (WpTyLam {}) = False    -- Give  up; conservative
    549 
    +    not_in _ (WpEvLam {}) = False    -- Ditto
    550 
    +    not_in _ (WpLet {})   = False    -- Ditto
    551 
    +
    552 
    +pushWpLet :: TcEvBinds -> [HsWrapper] -> [HsWrapper]
    553 
    +-- See if we can transform
    554 
    +--    WpLet binds <.> w1 <.> .. <.> wn   -->   w1' <.> .. <.> wn'
    555 
    +-- by substitution.
    556 
    +-- We do this just for the narrow case when
    557 
    +--   - the `binds` are all just v=w, variables only
    558 
    +--   - the wi are all WpTyApp, WpEvApp, or WpCast
    559 
    +-- This is just enough to get us the eta-reductions that we seek
    560 
    +pushWpLet tc_ev_binds ws
    561 
    +  = case tc_ev_binds of
    562 
    +      TcEvBinds {} -> pprPanic "pushWpLet" (ppr tc_ev_binds)
    563 
    +      EvBinds binds
    564 
    +        | isEmptyBag binds
    565 
    +        -> ws
    566 
    +        | Just env <- ev_bind_swizzle binds
    567 
    +        -> case go env ws of
    568 
    +              Just ws' -> ws'
    569 
    +              Nothing  -> bale_out
    570 
    +        | otherwise
    571 
    +        -> bale_out
    572 
    +  where
    573 
    +    bale_out = WpLet tc_ev_binds : ws
    574 
    +
    575 
    +    go :: IdEnv Id -> [HsWrapper] -> Maybe [HsWrapper]
    576 
    +    go env (WpCast co  : ws) = do { ws' <- go env ws
    577 
    +                                  ; return (WpCast co  : ws') }
    578 
    +    go env (WpTyApp ty : ws) = do { ws' <- go env ws
    579 
    +                                  ; return (WpTyApp ty : ws') }
    580 
    +    go env (WpEvApp (EvExpr (Var v)) : ws)
    581 
    +       = do { v'  <- swizzle_id env v
    582 
    +            ; ws' <- go env ws
    583 
    +            ; return (WpEvApp (EvExpr (Var v')) : ws') }
    584 
    +
    585 
    +    go _ ws = case ws of
    586 
    +                 []    -> Just []
    587 
    +                 (_:_) -> Nothing  -- Could not fully eliminate the WpLet
    588 
    +
    589 
    +    swizzle_id :: IdEnv Id -> Id -> Maybe Id
    590 
    +    -- Nothing <=> ran out of fuel
    591 
    +    -- This is just belt and braces; we should never build bottom evidence
    592 
    +    swizzle_id env v = go 100 v
    593 
    +      where
    594 
    +        go :: Int -> EvId -> Maybe EvId
    595 
    +        go fuel v
    596 
    +          | fuel == 0                     = Nothing
    597 
    +          | Just v' <- lookupVarEnv env v = go (fuel-1) v'
    598 
    +          | otherwise                     = Just v
    599 
    +
    600 
    +    ev_bind_swizzle :: Bag EvBind -> Maybe (IdEnv Id)
    601 
    +    -- Succeeds only if the bindings are all var-to-var bindings
    602 
    +    ev_bind_swizzle evbs = foldl' do_one (Just emptyVarEnv) evbs
    603 
    +      where
    604 
    +        do_one :: Maybe (IdEnv Id) -> EvBind -> Maybe (IdEnv Id)
    605 
    +        do_one Nothing _ = Nothing
    606 
    +        do_one (Just swizzle) (EvBind {eb_lhs = bndr, eb_rhs = rhs})
    607 
    +          = case rhs of
    608 
    +               EvExpr (Var v) -> Just (extendVarEnv swizzle bndr v)
    609 
    +               _              -> Nothing
    610 
    +
    361 611 
     {-
    362 612 
     ************************************************************************
    363 613 
     *                                                                      *
    ... ... @@ -1018,8 +1268,9 @@ pprHsWrapper wrap pp_thing_inside
    1018 1268 
         -- True  <=> appears in function application position
    1019 1269 
         -- False <=> appears as body of let or lambda
    1020 1270 
         help it WpHole             = it
    1021 
    -    help it (WpCompose f1 f2)  = help (help it f2) f1
    1022 
    -    help it (WpFun f1 f2 (Scaled w t1)) = add_parens $ text "\\(x" <> dcolon <> brackets (ppr w) <> ppr t1 <> text ")." <+>
    1271 
    +    help it (WpCompose w1 w2)  = help (help it w2) w1
    1272 
    +    help it (WpSubType w)      = no_parens $ text "subtype" <> braces (help it w False)
    1273 
    +    help it (WpFun f1 f2 (Scaled w t1) _) = add_parens $ text "\\(x" <> dcolon <> brackets (ppr w) <> ppr t1 <> text ")." <+>
    1023 1274 
                                                 help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False
    1024 1275 
         help it (WpCast co)   = add_parens $ sep [it False, nest 2 (text "|>"
    1025 1276 
                                                   <+> pprParendCo co)]

  • compiler/GHC/Tc/Utils/Concrete.hs
    ... ... @@ -626,8 +626,12 @@ hasFixedRuntimeRep :: HasDebugCallStack
    626 626 
                             -- @ki@ is concrete, and @co :: ty ~# ty'@.
    627 627 
                             -- That is, @ty'@ has a syntactically fixed RuntimeRep
    628 628 
                             -- in the sense of Note [Fixed RuntimeRep].
    629 
    -hasFixedRuntimeRep frr_ctxt ty =
    630 
    -  checkFRR_with (fmap (fmap coToMCo) . unifyConcrete_kind (fsLit "cx") . ConcreteFRR) frr_ctxt ty
    629 
    +hasFixedRuntimeRep frr_ctxt ty
    630 
    +  = checkFRR_with unify_conc frr_ctxt ty
    631 
    +  where
    632 
    +    unify_conc frr_orig ki
    633 
    +      = do { co <- unifyConcrete_kind (fsLit "cx") (ConcreteFRR frr_orig) ki
    634 
    +           ; return (coToMCo co) }
    631 635
    632 636 
     -- | Like 'hasFixedRuntimeRep', but we perform an eager syntactic check.
    633 637 
     --

  • compiler/GHC/Tc/Utils/Unify.hs
    ... ... @@ -148,7 +148,7 @@ matchActualFunTy
    148 148 
           -- (Both are used only for error messages)
    149 149 
       -> TcRhoType
    150 150 
           -- ^ Type to analyse: a TcRhoType
    151 
    -  -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType)
    151 
    +  -> TcM (TcCoercion, Scaled TcSigmaTypeFRR, TcSigmaType)
    152 152 
     -- This function takes in a type to analyse (a RhoType) and returns
    153 153 
     -- an argument type and a result type (splitting apart a function arrow).
    154 154 
     -- The returned argument type is a SigmaType with a fixed RuntimeRep;
    ... ... @@ -157,7 +157,7 @@ matchActualFunTy
    157 157 
     -- See Note [matchActualFunTy error handling] for the first three arguments
    158 158
    159 159 
     -- If   (wrap, arg_ty, res_ty) = matchActualFunTy ... fun_ty
    160 
    --- then wrap :: fun_ty ~> (arg_ty -> res_ty)
    160 
    +-- then wrap :: fun_ty ~~> (arg_ty -> res_ty)
    161 161 
     -- and NB: res_ty is an (uninstantiated) SigmaType
    162 162
    163 163 
     matchActualFunTy herald mb_thing err_info fun_ty
    ... ... @@ -172,13 +172,13 @@ matchActualFunTy herald mb_thing err_info fun_ty
    172 172 
         -- hide the forall inside a meta-variable
    173 173 
         go :: TcRhoType   -- The type we're processing, perhaps after
    174 174 
                           -- expanding type synonyms
    175 
    -       -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType)
    175 
    +       -> TcM (TcCoercion, Scaled TcSigmaTypeFRR, TcSigmaType)
    176 176 
         go ty | Just ty' <- coreView ty = go ty'
    177 177
    178 178 
         go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty })
    179 179 
           = assert (isVisibleFunArg af) $
    180 180 
           do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty
    181 
    -         ; return (idHsWrapper, Scaled w arg_ty, res_ty) }
    181 
    +         ; return (mkNomReflCo fun_ty, Scaled w arg_ty, res_ty) }
    182 182
    183 183 
         go ty@(TyVarTy tv)
    184 184 
           | isMetaTyVar tv
    ... ... @@ -210,7 +210,7 @@ matchActualFunTy herald mb_thing err_info fun_ty
    210 210 
                ; res_ty <- newOpenFlexiTyVarTy
    211 211 
                ; let unif_fun_ty = mkScaledFunTys [arg_ty] res_ty
    212 212 
                ; co <- unifyType mb_thing fun_ty unif_fun_ty
    213 
    -           ; return (mkWpCastN co, arg_ty, res_ty) }
    213 
    +           ; return (co, arg_ty, res_ty) }
    214 214
    215 215 
         ------------
    216 216 
         mk_ctxt :: TcType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)
    ... ... @@ -249,8 +249,10 @@ matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpected
    249 249 
                       -> Arity
    250 250 
                       -> TcSigmaType
    251 251 
                       -> TcM (HsWrapper, [Scaled TcSigmaTypeFRR], TcRhoType)
    252 
    --- If    matchActualFunTys n ty = (wrap, [t1,..,tn], res_ty)
    253 
    --- then  wrap : ty ~> (t1 -> ... -> tn -> res_ty)
    252 
    +-- NB: Called only from `tcSynArgA`, and hence scheduled for destruction
    253 
    +--
    254 
    +-- If    matchActualFunTys n fun_ty = (wrap, [t1,..,tn], res_ty)
    255 
    +-- then  wrap : fun_ty ~~>  (t1 -> ... -> tn -> res_ty)
    254 256 
     --       and res_ty is a RhoType
    255 257 
     -- NB: the returned type is top-instantiated; it's a RhoType
    256 258 
     matchActualFunTys herald ct_orig n_val_args_wanted top_ty
    ... ... @@ -265,15 +267,13 @@ matchActualFunTys herald ct_orig n_val_args_wanted top_ty
    265 267 
         go 0 _ fun_ty = return (idHsWrapper, [], fun_ty)
    266 268
    267 269 
         go n so_far fun_ty
    268 
    -      = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTy
    269 
    -                                                 herald Nothing
    270 
    -                                                 (n_val_args_wanted, top_ty)
    271 
    -                                                 fun_ty
    272 
    -           ; (wrap_res, arg_tys, res_ty)   <- go (n-1) (arg_ty1:so_far) res_ty1
    270 
    +      = do { (co1, arg_ty1, res_ty1) <- matchActualFunTy herald Nothing
    271 
    +                                           (n_val_args_wanted, top_ty) fun_ty
    272 
    +           ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1
    273 273 
                ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty
    274 274 
                -- NB: arg_ty1 comes from matchActualFunTy, so it has
    275 
    -           -- a syntactically fixed RuntimeRep as needed to call mkWpFun.
    276 
    -           ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) }
    275 
    +           -- a syntactically fixed RuntimeRep
    276 
    +           ; return (wrap_fun2 <.> mkWpCastN co1, arg_ty1:arg_tys, res_ty) }
    277 277
    278 278 
     {-
    279 279 
     ************************************************************************
    ... ... @@ -459,7 +459,7 @@ tcSkolemiseGeneral ds_flag ctxt top_ty expected_ty thing_inside
    459 459 
     tcSkolemiseCompleteSig :: TcCompleteSig
    460 460 
                            -> ([ExpPatType] -> TcRhoType -> TcM result)
    461 461 
                            -> TcM (HsWrapper, result)
    462 
    --- ^ The wrapper has type: spec_ty ~> expected_ty
    462 
    +-- ^ The wrapper has type: spec_ty ~~> expected_ty
    463 463 
     -- See Note [Skolemisation] for the differences between
    464 464 
     -- tcSkolemiseCompleteSig and tcTopSkolemise
    465 465
    ... ... @@ -790,7 +790,7 @@ matchExpectedFunTys :: forall a.
    790 790 
                         -> ([ExpPatType] -> ExpRhoType -> TcM a)
    791 791 
                         -> TcM (HsWrapper, a)
    792 792 
     -- If    matchExpectedFunTys n ty = (wrap, _)
    793 
    --- then  wrap : (t1 -> ... -> tn -> ty_r) ~> ty,
    793 
    +-- then  wrap : (t1 -> ... -> tn -> ty_r) ~~> ty,
    794 794 
     --   where [t1, ..., tn], ty_r are passed to the thing_inside
    795 795 
     --
    796 796 
     -- Unconditionally concludes by skolemising any trailing invisible
    ... ... @@ -865,12 +865,13 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
    865 865 
                                        , ft_arg = arg_ty, ft_res = res_ty })
    866 866 
           = assert (isVisibleFunArg af) $
    867 867 
             do { let arg_pos = arity - n_req + 1   -- 1 for the first argument etc
    868 
    -           ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty
    868 
    +           ; (arg_co, arg_ty_frr) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty
    869 
    +           ; let arg_sty_frr = Scaled mult arg_ty_frr
    869 870 
                ; (wrap_res, result) <- check (n_req - 1)
    870 
    -                                         (mkCheckExpFunPatTy (Scaled mult arg_ty) : rev_pat_tys)
    871 
    +                                         (mkCheckExpFunPatTy arg_sty_frr : rev_pat_tys)
    871 872 
                                              res_ty
    872 873 
                ; let wrap_arg = mkWpCastN arg_co
    873 
    -                 fun_wrap = mkWpFun wrap_arg wrap_res (Scaled mult arg_ty) res_ty
    874 
    +                 fun_wrap = mkWpFun wrap_arg wrap_res arg_sty_frr res_ty
    874 875 
                ; return (fun_wrap, result) }
    875 876
    876 877 
         ----------------------------
    ... ... @@ -1407,7 +1408,7 @@ tcSubTypePat :: CtOrigin -> UserTypeCtxt
    1407 1408 
     -- Used in patterns; polarity is backwards compared
    1408 1409 
     --   to tcSubType
    1409 1410 
     -- If wrap = tc_sub_type_et t1 t2
    1410 
    ---    => wrap :: t1 ~> t2
    1411 
    +--    => wrap :: t1 ~~> t2
    1411 1412 
     tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected
    1412 1413 
       = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected
    1413 1414
    ... ... @@ -1427,11 +1428,12 @@ tcSubTypeDS :: HsExpr GhcRn
    1427 1428 
                                -- DeepSubsumption <=> when checking, this type
    1428 1429 
                                --                     is deeply skolemised
    1429 1430 
                 -> TcM HsWrapper
    1430 
    --- Only one call site, in GHC.Tc.Gen.App.tcApp
    1431 
    +-- Only one call site, in GHC.Tc.Gen.App.checkResultTy
    1431 1432 
     tcSubTypeDS rn_expr act_rho exp_rho
    1432 
    -  = tc_sub_type_deep Top (unifyExprType rn_expr) orig GenSigCtxt act_rho exp_rho
    1433 
    -  where
    1434 
    -    orig = exprCtOrigin rn_expr
    1433 
    +  = do { wrap <- tc_sub_type_deep Top (unifyExprType rn_expr)
    1434 
    +                                  (exprCtOrigin rn_expr)
    1435 
    +                                  GenSigCtxt act_rho exp_rho
    1436 
    +       ; return (mkWpSubType wrap) }
    1435 1437
    1436 1438 
     ---------------
    1437 1439
    ... ... @@ -1456,7 +1458,7 @@ tcSubTypeSigma :: CtOrigin -- where did the actual type arise / why are we
    1456 1458 
                    -> TcSigmaType -> TcSigmaType -> TcM HsWrapper
    1457 1459 
     -- External entry point, but no ExpTypes on either side
    1458 1460 
     -- Checks that actual <= expected
    1459 
    --- Returns HsWrapper :: actual ~ expected
    1461 
    +-- Returns HsWrapper :: actual ~~> expected
    1460 1462 
     tcSubTypeSigma orig ctxt ty_actual ty_expected
    1461 1463 
       = tc_sub_type (unifyType Nothing) orig ctxt ty_actual ty_expected
    1462 1464
    ... ... @@ -1495,7 +1497,7 @@ tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify
    1495 1497 
                 -> TcM HsWrapper
    1496 1498 
     -- Checks that actual_ty is more polymorphic than expected_ty
    1497 1499 
     -- If wrap = tc_sub_type t1 t2
    1498 
    ---    => wrap :: t1 ~> t2
    1500 
    +--    => wrap :: t1 ~~> t2
    1499 1501 
     --
    1500 1502 
     -- The "how to unify argument" is always a call to `uType TypeLevel orig`,
    1501 1503 
     -- but with different ways of constructing the CtOrigin `orig` from
    ... ... @@ -1504,7 +1506,8 @@ tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify
    1504 1506 
     ----------------------
    1505 1507 
     tc_sub_type unify inst_orig ctxt ty_actual ty_expected
    1506 1508 
       = do { ds_flag <- getDeepSubsumptionFlag
    1507 
    -       ; tc_sub_type_ds Top ds_flag unify inst_orig ctxt ty_actual ty_expected }
    1509 
    +       ; wrap <- tc_sub_type_ds Top ds_flag unify inst_orig ctxt ty_actual ty_expected
    1510 
    +       ; return (mkWpSubType wrap) }
    1508 1511
    1509 1512 
     ----------------------
    1510 1513 
     tc_sub_type_ds :: Position p -- ^ position in the type (for error messages only)
    ... ... @@ -1753,59 +1756,59 @@ we deal with function arrows. Suppose we have:
    1753 1756 
       ty_actual   = act_arg -> act_res
    1754 1757 
       ty_expected = exp_arg -> exp_res
    1755 1758
    1756 
    -To produce fun_wrap :: (act_arg -> act_res) ~> (exp_arg -> exp_res), we use
    1759 
    +To produce fun_wrap :: (act_arg -> act_res) ~~> (exp_arg -> exp_res), we use
    1757 1760 
     the fact that the function arrow is contravariant in its argument type and
    1758 1761 
     covariant in its result type. Thus we recursively perform subtype checks
    1759 1762 
     on the argument types (with actual/expected switched) and the result types,
    1760 1763 
     to get:
    1761 1764
    1762 
    -  arg_wrap :: exp_arg ~> act_arg   -- NB: expected/actual have switched sides
    1763 
    -  res_wrap :: act_res ~> exp_res
    1765 
    +  arg_wrap :: exp_arg ~~> act_arg   -- NB: expected/actual have switched sides
    1766 
    +  res_wrap :: act_res ~~> exp_res
    1764 1767
    1765 1768 
     Then fun_wrap = mkWpFun arg_wrap res_wrap.
    1766 1769
    1767 
    -Wrinkle [Representation-polymorphism checking during subtyping]
    1770 
    +Note [Representation-polymorphism checking during subtyping]
    1771 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    1772 
    +When doing deep subsumption in `tc_sub_type_deep`, looking under function arrows,
    1773 
    +we would usually build a `WpFun` HsWrapper.  When desugared, we get eta-expansion:
    1768 1774
    1769 
    -  Inserting a WpFun HsWrapper amounts to impedance matching in deep subsumption
    1770 
    -  via eta-expansion:
    1775 
    +  f  ==>  \(x :: exp_arg). res_wrap [ f (arg_wrap [x]) ]
    1771 1776
    1772 
    -    f  ==>  \ (x :: exp_arg) -> res_wrap [ f (arg_wrap [x]) ]
    1777 
    +Since we produce a lambda, we must enforce the representation polymorphism
    1778 
    +invariants described in Note [Representation polymorphism invariants] in GHC.Core.
    1779 
    +That is, we must ensure that both
    1780 
    +   - x (the lambda binder), and
    1781 
    +   - (arg_wrap [x]) (the function argument)
    1782 
    +have a fixed runtime representation.
    1773 1783
    1774 
    -  As we produce a lambda, we must enforce the representation polymorphism
    1775 
    -  invariants described in Note [Representation polymorphism invariants] in GHC.Core.
    1776 
    -  That is, we must ensure that both x (the lambda binder) and (arg_wrap [x]) (the function argument)
    1777 
    -  have a fixed runtime representation.
    1784 
    +But we don't /always/ need to produce a `WpFun`: if both argument and result wrappers
    1785 
    +are merely coercions, we can produce a `WpCast co` instead of a `WpFun`.  In that
    1786 
    +case there is no eta-expansion, and hence no need for FRR checks.
    1778 1787
    1779 
    -  Note however that desugaring mkWpFun does not always introduce a lambda: if
    1780 
    -  both the argument and result HsWrappers are casts, then a FunCo cast suffices,
    1781 
    -  in which case we should not perform representation-polymorphism checking.
    1788 
    +Here's a contrived example (there are undoubtedly more natural examples)
    1789 
    +(see testsuite/tests/rep-poly/NoEtaRequired):
    1782 1790
    1783 
    -  This means that, in the FunTy/FunTy case of tc_sub_type_deep, we can skip
    1784 
    -  the representation-polymorphism checks if the produced argument and result
    1785 
    -  wrappers are identities or casts.
    1786 
    -  It is important to do so, otherwise we reject valid programs.
    1791 
    +    type Id :: k -> k
    1792 
    +    type family Id a where
    1787 1793
    1788 
    -    Here's a contrived example (there are undoubtedly more natural examples)
    1789 
    -    (see testsuite/tests/rep-poly/NoEtaRequired):
    1794 
    +    type T :: TYPE r -> TYPE (Id r)
    1795 
    +    type family T a where
    1790 1796
    1791 
    -      type Id :: k -> k
    1792 
    -      type family Id a where
    1797 
    +    test :: forall r (a :: TYPE r). a :~~: T a -> ()
    1798 
    +    test HRefl =
    1799 
    +      let
    1800 
    +        f :: (a -> a) -> ()
    1801 
    +        f _ = ()
    1802 
    +        g :: T a -> T a
    1803 
    +        g = undefined
    1804 
    +      in f g
    1793 1805
    1794 
    -      type T :: TYPE r -> TYPE (Id r)
    1795 
    -      type family T a where
    1806 
    +We don't need to eta-expand `g` to make `f g` typecheck; a cast
    1807 
    +suffices.  Hence we should not perform representation-polymorphism
    1808 
    +checks; they would fail here.
    1796 1809
    1797 
    -      test :: forall r (a :: TYPE r). a :~~: T a -> ()
    1798 
    -      test HRefl =
    1799 
    -        let
    1800 
    -          f :: (a -> a) -> ()
    1801 
    -          f _ = ()
    1802 
    -          g :: T a -> T a
    1803 
    -          g = undefined
    1804 
    -        in f g
    1805 
    -
    1806 
    -    We don't need to eta-expand `g` to make `f g` typecheck; a cast suffices.
    1807 
    -    Hence we should not perform representation-polymorphism checks; they would
    1808 
    -    fail here.
    1810 
    +All this is done by `mkWpFun_FRR`, which checks for the cast/cast case and
    1811 
    +returns a `FunCo` if so.
    1809 1812
    1810 1813 
     Note [Setting the argument context]
    1811 1814 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -1947,7 +1950,7 @@ getDeepSubsumptionFlag = do { ds <- xoptM LangExt.DeepSubsumption
    1947 1950 
     -- | 'tc_sub_type_deep' is where the actual work happens for deep subsumption.
    1948 1951 
     --
    1949 1952 
     -- Given @ty_actual@ (a sigma-type) and @ty_expected@ (deeply skolemised, i.e.
    1953 
    +-- a deep rho type), it returns an 'HsWrapper' @wrap :: ty_actual ~~> ty_expected@.
    1950 1954 
     tc_sub_type_deep :: HasDebugCallStack
    1951 1955 
                      => Position p     -- ^ Position in the type (for error messages only)
    1952 1956 
                      -> (TcType -> TcType -> TcM TcCoercionN) -- ^ How to unify
    ... ... @@ -1958,7 +1961,7 @@ tc_sub_type_deep :: HasDebugCallStack
    1958 1961 
                      -> TcM HsWrapper
    1959 1962
    1960 1963 
     -- If wrap = tc_sub_type_deep t1 t2
    1961 
    ---    => wrap :: t1 ~> t2
    1964 
    +--    => wrap :: t1 ~~> t2
    1962 1965 
     -- Here is where the work actually happens!
    1963 1966 
     -- Precondition: ty_expected is deeply skolemised
    1964 1967
    ... ... @@ -2015,8 +2018,8 @@ tc_sub_type_deep pos unify inst_orig ctxt ty_actual ty_expected
    2015 2018 
                ; unify_wrap <- just_unify exp_funTy ty_e
    2016 2019 
                ; fun_wrap <- go_fun af1 act_mult act_arg act_res af1 exp_mult exp_arg exp_res
    2017 2020 
                ; return $ unify_wrap <.> fun_wrap
    2018 
    -             -- unify_wrap :: exp_funTy ~> ty_e
    2019 
    -             -- fun_wrap :: ty_a ~> exp_funTy
    2021 
    +             -- unify_wrap :: exp_funTy ~~> ty_e
    2022 
    +             -- fun_wrap :: ty_a ~~> exp_funTy
    2020 2023 
                }
    2021 2024 
         go1 ty_a (FunTy { ft_af = af2, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res })
    2022 2025 
           | isVisibleFunArg af2
    ... ... @@ -2028,8 +2031,8 @@ tc_sub_type_deep pos unify inst_orig ctxt ty_actual ty_expected
    2028 2031 
                ; unify_wrap <- just_unify ty_a act_funTy
    2029 2032 
                ; fun_wrap <- go_fun af2 act_mult act_arg act_res af2 exp_mult exp_arg exp_res
    2030 2033 
                ; return $ fun_wrap <.> unify_wrap
    2031 
    -             -- unify_wrap :: ty_a ~> act_funTy
    2032 
    -             -- fun_wrap :: act_funTy ~> ty_e
    2034 
    +             -- unify_wrap :: ty_a ~~> act_funTy
    2035 
    +             -- fun_wrap :: act_funTy ~~> ty_e
    2033 2036 
                }
    2034 2037
    2035 2038 
         -- Otherwise, revert to unification.
    ... ... @@ -2064,17 +2067,28 @@ mkWpFun_FRR
    2064 2067 
       -> Position p
    2065 2068 
       -> FunTyFlag -> Type -> TcType -> Type --   actual FunTy
    2066 2069 
       -> FunTyFlag -> Type -> TcType -> Type -- expected FunTy
    2067 
    -  -> HsWrapper -- ^ exp_arg ~> act_arg
    2068 
    -  -> HsWrapper -- ^ act_res ~> exp_res
    2069 
    -  -> TcM HsWrapper -- ^ act_funTy ~> exp_funTy
    2070 
    +  -> HsWrapper -- ^ exp_arg ~~> act_arg
    2071 
    +  -> HsWrapper -- ^ act_res ~~> exp_res
    2072 
    +  -> TcM HsWrapper -- ^ (act_arg->act_res) ~~> (exp_arg->exp_res)
    2070 2073 
     mkWpFun_FRR unify pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res arg_wrap res_wrap
    2071 
    -  = do { ((exp_arg_co, exp_arg_frr), (act_arg_co, _act_arg_frr)) <-
    2072 
    -            if needs_frr_checks
    2073 
    -              -- See Wrinkle [Representation-polymorphism checking during subtyping]
    2074 
    -            then do { exp_frr_wrap <- hasFixedRuntimeRep (frr_ctxt True ) exp_arg
    2075 
    -                    ; act_frr_wrap <- hasFixedRuntimeRep (frr_ctxt False) act_arg
    2076 
    -                    ; return (exp_frr_wrap, act_frr_wrap) }
    2077 
    -            else return ((mkNomReflCo exp_arg, exp_arg), (mkNomReflCo act_arg, act_arg))
    2074 
    +  | Just arg_co <- getWpCo_maybe arg_wrap act_arg   -- arg_co :: exp_arg ~R# act_arg
    2075 
    +  , Just res_co <- getWpCo_maybe res_wrap act_res   -- res_co :: act_res ~R# exp_res
    2076 
    +  = -- The argument and result wrappers are both hole or cast;
    2077 
    +    -- so we can make do with a FunCo
    2078 
    +    -- See Note [Representation-polymorphism checking during subtyping]
    2079 
    +    do { mult_co <- unify act_mult exp_mult
    2080 
    +       ; let the_co = mkFunCo2 Representational act_af exp_af mult_co (mkSymCo arg_co) res_co
    2081 
    +       ; return (mkWpCastR the_co) }
    2082 
    +
    2083 
    +  | otherwise
    2084 
    +  = -- We need a full WpFun, with the eta-expansion that it entails
    2085 
    +    -- And hence we must add fixed-runtime-rep checks so that the eta-expansion is OK
    2086 
    +    -- See Note [Representation-polymorphism checking during subtyping]
    2087 
    +    do { (exp_arg_co, exp_arg_frr)  <- hasFixedRuntimeRep (frr_ctxt True ) exp_arg
    2088 
    +       ; (act_arg_co, _act_arg_frr) <- hasFixedRuntimeRep (frr_ctxt False) act_arg
    2089 
    +       -- exp_arg_frr, act_arg_frr :: Type   have fixed runtime-reps
    2090 
    +       -- exp_arg_co :: exp_arg ~ exp_arg_frr      Usually Refl
    2091 
    +       -- act_arg_co :: act_arg ~ act_arg_frr      Usually Refl
    2078 2092
    2079 2093 
              -- Enforce equality of multiplicities (not the more natural sub-multiplicity).
    2080 2094 
              -- See Note [Multiplicity in deep subsumption]
    ... ... @@ -2083,46 +2097,36 @@ mkWpFun_FRR unify pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg ex
    2083 2097 
                -- equality to be Refl, but it might well not be (#26332).
    2084 2098
    2085 2099 
            ; let
    2086 
    -            exp_arg_fun_co =
    2100 
    +            exp_arg_fun_co =  -- (exp_arg_frr -> exp_res) ~ (exp_arg -> exp_res)
    2087 2101 
                   mkFunCo Nominal exp_af
    2088 
    -                 (mkReflCo Nominal exp_mult)
    2102 
    +                 (mkNomReflCo exp_mult)
    2089 2103 
                      (mkSymCo exp_arg_co)
    2090 
    -                 (mkReflCo Nominal exp_res)
    2091 
    -            act_arg_fun_co =
    2104 
    +                 (mkNomReflCo exp_res)
    2105 
    +            act_arg_fun_co =  -- (act_arg -> act_res) ~ (act_arg_frr -> act_res)
    2092 2106 
                   mkFunCo Nominal act_af
    2093 2107 
                      act_arg_mult_co
    2094 2108 
                      act_arg_co
    2095 
    -                 (mkReflCo Nominal act_res)
    2096 
    -            arg_wrap_frr =
    2109 
    +                 (mkNomReflCo act_res)
    2110 
    +            arg_wrap_frr =    -- exp_arg_frr ~~> act_arg_frr
    2097 2111 
                   mkWpCastN (mkSymCo exp_arg_co) <.> arg_wrap <.> mkWpCastN act_arg_co
    2098 
    -               --  exp_arg_co :: exp_arg ~> exp_arg_frr
    2099 
    -               --  act_arg_co :: act_arg ~> act_arg_frr
    2100 
    -               --  arg_wrap :: exp_arg ~> act_arg
    2101 
    -               --  arg_wrap_frr :: exp_arg_frr ~> act_arg_frr
    2102 2112
    2103 
    -       ; return $
    2104 
    -            mkWpCastN exp_arg_fun_co
    2113 
    +       ; return $   -- Whole thing :: (act_arg->act_res) ~~> (exp_arg->exp_ress)
    2114 
    +            mkWpCastN exp_arg_fun_co   -- (exp_ar_frr->exp_res) ~~> (exp_arg->exp_res)
    2105 2115 
                   <.>
    2106 2116 
                 mkWpFun arg_wrap_frr res_wrap (Scaled exp_mult exp_arg_frr) exp_res
    2107 
    -              <.>
    2108 
    -            mkWpCastN act_arg_fun_co
    2117 
    +              <.>                       -- (act_arg_frr->act_res) ~~> (exp_arg_frr->exp_res)
    2118 
    +            mkWpCastN act_arg_fun_co    -- (act_arg->act_res) ~~> (act_arg_frr->act_res)
    2109 2119 
            }
    2110 2120 
       where
    2111 
    -    needs_frr_checks :: Bool
    2112 
    -    needs_frr_checks =
    2113 
    -      not (hole_or_cast arg_wrap)
    2114 
    -        ||
    2115 
    -      not (hole_or_cast res_wrap)
    2116 
    -    hole_or_cast :: HsWrapper -> Bool
    2117 
    -    hole_or_cast WpHole = True
    2118 
    -    hole_or_cast (WpCast {}) = True
    2119 
    -    hole_or_cast _ = False
    2121 
    +    getWpCo_maybe :: HsWrapper -> Type -> Maybe CoercionR
    2122 
    +    -- See if a HsWrapper is just a coercion
    2123 
    +    getWpCo_maybe WpHole      ty = Just (mkRepReflCo ty)
    2124 
    +    getWpCo_maybe (WpCast co) _  = Just co
    2125 
    +    getWpCo_maybe _           _  = Nothing
    2126 
    +
    2120 2127 
         frr_ctxt :: Bool -> FixedRuntimeRepContext
    2121 
    -    frr_ctxt is_exp_ty =
    2122 
    -      FRRDeepSubsumption
    2123 
    -        { frrDSExpected = is_exp_ty
    2124 
    -        , frrDSPosition = pos
    2125 
    -        }
    2128 
    +    frr_ctxt is_exp_ty = FRRDeepSubsumption { frrDSExpected = is_exp_ty
    2129 
    +                                            , frrDSPosition = pos }
    2126 2130
    2127 2131 
     -----------------------
    2128 2132 
     deeplySkolemise :: SkolemInfo -> TcSigmaType
    ... ... @@ -2146,9 +2150,9 @@ deeplySkolemise skol_info ty
    2146 2150 
                ; let tvs     = binderVars bndrs
    2147 2151 
                      tvs1    = binderVars bndrs1
    2148 2152 
                      tv_prs1 = map tyVarName tvs `zip` bndrs1
    2149 
    -           ; return ( mkWpEta ids1 (mkWpTyLams tvs1
    2150 
    -                                    <.> mkWpEvLams ev_vars1
    2151 
    -                                    <.> wrap)
    2153 
    +           ; return ( mkWpEta ty ids1 (mkWpTyLams tvs1
    2154 
    +                                      <.> mkWpEvLams ev_vars1
    2155 
    +                                      <.> wrap)
    2152 2156 
                         , tv_prs1  ++ tvs_prs2
    2153 2157 
                         , ev_vars1 ++ ev_vars2
    2154 2158 
                         , mkScaledFunTys arg_tys' rho ) }
    ... ... @@ -2182,7 +2186,7 @@ deeplyInstantiate orig ty
    2182 2186 
                ; ids1  <- newSysLocalIds (fsLit "di") arg_tys'
    2183 2187 
                ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
    2184 2188 
                ; (wrap2, rho2) <- go subst' rho
    2185 
    -           ; return (mkWpEta ids1 (wrap2 <.> wrap1),
    2189 
    +           ; return (mkWpEta ty ids1 (wrap2 <.> wrap1),
    2186 2190 
                          mkScaledFunTys arg_tys' rho2) }
    2187 2191
    2188 2192 
           | otherwise

  • compiler/GHC/Tc/Zonk/Type.hs
    ... ... @@ -1233,13 +1233,16 @@ zonk_cmd_top (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
    1233 1233 
     -------------------------------------------------------------------------
    1234 1234 
     zonkCoFn :: HsWrapper -> ZonkBndrTcM HsWrapper
    1235 1235 
     zonkCoFn WpHole   = return WpHole
    1236 
    +zonkCoFn (WpSubType w)     = do { w' <- zonkCoFn w
    1237 
    +                                ; return (WpSubType w') }
    1236 1238 
     zonkCoFn (WpCompose c1 c2) = do { c1' <- zonkCoFn c1
    1237 1239 
                                     ; c2' <- zonkCoFn c2
    1238 1240 
                                     ; return (WpCompose c1' c2') }
    1239 
    -zonkCoFn (WpFun c1 c2 t1)  = do { c1' <- zonkCoFn c1
    1240 
    -                                ; c2' <- zonkCoFn c2
    1241 
    -                                ; t1' <- noBinders $ zonkScaledTcTypeToTypeX t1
    1242 
    -                                ; return (WpFun c1' c2' t1') }
    1241 
    +zonkCoFn (WpFun c1 c2 t1 t2) = do { c1' <- zonkCoFn c1
    1242 
    +                                  ; c2' <- zonkCoFn c2
    1243 
    +                                  ; t1' <- noBinders $ zonkScaledTcTypeToTypeX t1
    1244 
    +                                  ; t2' <- noBinders $ zonkTcTypeToTypeX t2
    1245 
    +                                  ; return (WpFun c1' c2' t1' t2') }
    1243 1246 
     zonkCoFn (WpCast co)   = WpCast  <$> noBinders (zonkCoToCo co)
    1244 1247 
     zonkCoFn (WpEvLam ev)  = WpEvLam <$> zonkEvBndrX ev
    1245 1248 
     zonkCoFn (WpEvApp arg) = WpEvApp <$> noBinders (zonkEvTerm arg)

  • compiler/Setup.hs
    1 1 
     {-# LANGUAGE NamedFieldPuns #-}
    2 
    +{-# LANGUAGE CPP #-}
    2 3 
     module Main where
    3 4
    4 5 
     import Distribution.Simple
    ... ... @@ -12,6 +13,8 @@ import Distribution.Simple.Program
    12 13 
     import Distribution.Simple.Utils
    13 14 
     import Distribution.Simple.Setup
    14 15 
     import Distribution.Simple.PackageIndex
    16 
    +import qualified Distribution.Simple.LocalBuildInfo as LBI
    17 
    +
    15 18
    16 19 
     import System.IO
    17 20 
     import System.Process
    ... ... @@ -59,8 +62,9 @@ primopIncls =
    59 62 
     ghcAutogen :: Verbosity -> LocalBuildInfo -> IO ()
    60 63 
     ghcAutogen verbosity lbi@LocalBuildInfo{pkgDescrFile,withPrograms,componentNameMap,installedPkgs}
    61 64 
       = do
    65 
    +  let i = LBI.interpretSymbolicPathLBI lbi
    62 66 
       -- Get compiler/ root directory from the cabal file
    63 
    -  let Just compilerRoot = takeDirectory <$> pkgDescrFile
    67 
    +  let Just compilerRoot = takeDirectory . i <$> pkgDescrFile
    64 68
    65 69 
       -- Require the necessary programs
    66 70 
       (gcc   ,withPrograms) <- requireProgram normal gccProgram withPrograms
    ... ... @@ -80,15 +84,19 @@ ghcAutogen verbosity lbi@LocalBuildInfo{pkgDescrFile,withPrograms,componentNameM
    80 84 
       -- Call genprimopcode to generate *.hs-incl
    81 85 
       forM_ primopIncls $ \(file,command) -> do
    82 86 
         contents <- readProcess "genprimopcode" [command] primopsStr
    83 
    -    rewriteFileEx verbosity (buildDir lbi </> file) contents
    87 
    +    rewriteFileEx verbosity (i (buildDir lbi) </> file) contents
    84 88
    85 89 
       -- Write GHC.Platform.Constants
    86 
    -  let platformConstantsPath = autogenPackageModulesDir lbi </> "GHC/Platform/Constants.hs"
    90 
    +  let platformConstantsPath = i (autogenPackageModulesDir lbi) </> "GHC/Platform/Constants.hs"
    87 91 
           targetOS = case lookup "target os" settings of
    88 92 
             Nothing -> error "no target os in settings"
    89 93 
             Just os -> os
    90 94 
       createDirectoryIfMissingVerbose verbosity True (takeDirectory platformConstantsPath)
    95 
    +#if MIN_VERSION_Cabal(3,14,0)
    96 
    +  withTempFile "Constants_tmp.hs" $ \tmp h -> do
    97 
    +#else
    91 98 
       withTempFile (takeDirectory platformConstantsPath) "Constants_tmp.hs" $ \tmp h -> do
    99 
    +#endif
    92 100 
         hClose h
    93 101 
         callProcess "deriveConstants" ["--gen-haskell-type","-o",tmp,"--target-os",targetOS]
    94 102 
         renameFile tmp platformConstantsPath
    ... ... @@ -103,7 +111,7 @@ ghcAutogen verbosity lbi@LocalBuildInfo{pkgDescrFile,withPrograms,componentNameM
    103 111 
             _ -> error "Couldn't find unique ghc-internal library when building ghc"
    104 112
    105 113 
       -- Write GHC.Settings.Config
    106 
    -      configHsPath = autogenPackageModulesDir lbi </> "GHC/Settings/Config.hs"
    114 
    +      configHsPath = i (autogenPackageModulesDir lbi) </> "GHC/Settings/Config.hs"
    107 115 
           configHs = generateConfigHs cProjectUnitId cGhcInternalUnitId settings
    108 116 
       createDirectoryIfMissingVerbose verbosity True (takeDirectory configHsPath)
    109 117 
       rewriteFileEx verbosity configHsPath configHs

  • compiler/ghc.cabal.in
    ... ... @@ -50,7 +50,7 @@ extra-source-files:
    50 50
    51 51
    52 52 
     custom-setup
    53 
    -    setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.14, directory, process, filepath, containers
    53 
    +    setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.16, directory, process, filepath, containers
    54 54
    55 55 
     Flag internal-interpreter
    56 56 
         Description: Build with internal interpreter support.

  • libraries/ghc-boot/Setup.hs
    ... ... @@ -10,6 +10,7 @@ import Distribution.Verbosity
    10 10 
     import Distribution.Simple.Program
    11 11 
     import Distribution.Simple.Utils
    12 12 
     import Distribution.Simple.Setup
    13 
    +import qualified Distribution.Simple.LocalBuildInfo as LBI
    13 14
    14 15 
     import System.IO
    15 16 
     import System.Directory
    ... ... @@ -32,12 +33,13 @@ main = defaultMainWithHooks ghcHooks
    32 33 
     ghcAutogen :: Verbosity -> LocalBuildInfo -> IO ()
    33 34 
     ghcAutogen verbosity lbi@LocalBuildInfo{..} = do
    34 35 
       -- Get compiler/ root directory from the cabal file
    35 
    -  let Just compilerRoot = takeDirectory <$> pkgDescrFile
    36 
    +  let Just compilerRoot = takeDirectory . i <$> pkgDescrFile
    36 37
    37 
    -  let platformHostFile = "GHC/Platform/Host.hs"
    38 
    -      platformHostPath = autogenPackageModulesDir lbi </> platformHostFile
    38 
    +      i = LBI.interpretSymbolicPathLBI lbi
    39 
    +      platformHostFile = "GHC/Platform/Host.hs"
    40 
    +      platformHostPath = i (autogenPackageModulesDir lbi) </> platformHostFile
    39 41 
           ghcVersionFile = "GHC/Version.hs"
    40 
    -      ghcVersionPath = autogenPackageModulesDir lbi </> ghcVersionFile
    42 
    +      ghcVersionPath = i (autogenPackageModulesDir lbi) </> ghcVersionFile
    41 43
    42 44 
       -- Get compiler settings
    43 45 
       settings <- lookupEnv "HADRIAN_SETTINGS" >>= \case

  • libraries/ghc-boot/ghc-boot.cabal.in
    ... ... @@ -28,7 +28,7 @@ build-type: Custom
    28 28 
     extra-source-files: changelog.md
    29 29
    30 30 
     custom-setup
    31 
    -    setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.14, directory, filepath
    31 
    +    setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.16, directory, filepath
    32 32
    33 33 
     source-repository head
    34 34 
         type:     git

  • rts/Interpreter.c
    ... ... @@ -91,6 +91,80 @@ See also Note [Width of parameters] for some more motivation.
    91 91
    92 92 
     /* #define INTERP_STATS */
    93 93
    94 
    +// Note [Instruction dispatch in the bytecode interpreter]
    95 
    +// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    96 
    +// Like all bytecode interpreters out there, instruction dispatch is
    97 
    +// the backbone of our bytecode interpreter:
    98 
    +//
    99 
    +// - Each instruction starts with a unique integer tag
    100 
    +// - Each instruction has a piece of code to handle it
    101 
    +// - Fetch next instruction's tag, interpret, repeat
    102 
    +//
    103 
    +// There are two classical approaches to organize the interpreter loop
    104 
    +// and implement instruction dispatch:
    105 
    +//
    106 
    +// 1. switch-case: fetch the instruction tag, then a switch statement
    107 
    +//    contains each instruction's handler code as a case within it.
    108 
    +//    This is the simplest and most portable approach, but the
    109 
    +//    compiler often generates suboptimal code that involves two jumps
    110 
    +//    per instruction: the first one that jumps back to the switch
    111 
    +//    statement, followed by the second one that jumps to the handler
    112 
    +//    case statement.
    113 
    +// 2. computed-goto (direct threaded code): GNU C has an extension
    114 
    +//    (https://gcc.gnu.org/onlinedocs/gcc/Labels-as-Values.html) that
    115 
    +//    allows storing a code label as a pointer and using the goto
    116 
    +//    statement to jump to such a pointer. So we can organize the
    117 
    +//    handler code as a code block under a label, have a pointer array
    118 
    +//    that maps an instruction tag to its handler's code label, then
    119 
    +//    instruction dispatch can happen with a single jump after a
    120 
    +//    memory load.
    121 
    +//
    122 
    +// A classical paper "The Structure and Performance of Efficient
    123 
    +// Interpreters" by M. Anton Ertl and David Gregg in 2003 explains it
    124 
    +// in further details with profiling data:
    125 
    +// https://jilp.org/vol5/v5paper12.pdf. There exist more subtle issues
    126 
    +// like interaction with modern CPU's branch predictors, though in
    127 
    +// practice computed-goto does outperform switch-case, and I've
    128 
    +// observed around 10%-15% wall clock time speedup in simple
    129 
    +// benchmarks, so our bytecode interpreter now defaults to using
    130 
    +// computed-goto when applicable, and falls back to switch-case in
    131 
    +// other cases.
    132 
    +//
    133 
    +// The COMPUTED_GOTO macro is defined when we use computed-goto. We
    134 
    +// don't do autoconf feature detection since it works with all
    135 
    +// versions of gcc/clang on all platforms we currently support.
    136 
    +// Exceptions include:
    137 
    +//
    138 
    +// - When DEBUG or other macros are enabled so that there's extra
    139 
    +//   logic per instruction: assertions, statistics, etc. To make
    140 
    +//   computed-goto support those would need us to duplicate the extra
    141 
    +//   code in every instruction's handler code block, not really worth
    142 
    +//   it when speed is not the primary concern.
    143 
    +// - On wasm, because wasm prohibits goto anyway and LLVM has to lower
    144 
    +//   goto in C to br_table, so there's no performance benefit of
    145 
    +//   computed-goto, only slight penalty due to an extra load from the
    146 
    +//   user-defined dispatch table in the linear memory.
    147 
    +//
    148 
    +// The source of truth for our bytecode definition is
    149 
    +// rts/include/rts/Bytecodes.h. For each bytecode `#define bci_FOO
    150 
    +// tag`, we have jumptable[tag] which stores the 32-bit offset
    151 
    +// `&&lbl_bci_FOO - &&lbl_bci_DEFAULT`, so the goto destination can
    152 
    +// always be computed by adding the jumptable[tag] offset to the base
    153 
    +// address `&&lbl_bci_DEFAULT`. Whenever you change the bytecode
    154 
    +// definitions, always remember to update `jumptable` as well!
    155 
    +
    156 
    +#if !defined(DEBUG) && !defined(ASSERTS_ENABLED) && !defined(INTERP_STATS) && !defined(wasm32_HOST_ARCH)
    157 
    +#define COMPUTED_GOTO
    158 
    +#endif
    159 
    +
    160 
    +#if defined(COMPUTED_GOTO)
    161 
    +#pragma GCC diagnostic ignored "-Wpointer-arith"
    162 
    +#define INSTRUCTION(name) lbl_##name
    163 
    +#define NEXT_INSTRUCTION goto *(&&lbl_bci_DEFAULT + jumptable[(bci = instrs[bciPtr++]) & 0xFF])
    164 
    +#else
    165 
    +#define INSTRUCTION(name) case name
    166 
    +#define NEXT_INSTRUCTION goto nextInsn
    167 
    +#endif
    94 168
    95 169 
     /* Sp points to the lowest live word on the stack. */
    96 170
    ... ... @@ -1542,7 +1616,9 @@ run_BCO:
    1542 1616 
             it_lastopc = 0; /* no opcode */
    1543 1617 
     #endif
    1544 1618
    1619 
    +#if !defined(COMPUTED_GOTO)
    1545 1620 
         nextInsn:
    1621 
    +#endif
    1546 1622 
             ASSERT(bciPtr < bcoSize);
    1547 1623 
             IF_DEBUG(interpreter,
    1548 1624 
                      //if (do_print_stack) {
    ... ... @@ -1572,15 +1648,263 @@ run_BCO:
    1572 1648 
             it_lastopc = (int)instrs[bciPtr];
    1573 1649 
     #endif
    1574 1650
    1575 
    -        bci = BCO_NEXT;
    1651 
    +#if defined(COMPUTED_GOTO)
    1652 
    +        static const int32_t jumptable[] = {
    1653 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1654 
    +            &&lbl_bci_STKCHECK - &&lbl_bci_DEFAULT,
    1655 
    +            &&lbl_bci_PUSH_L - &&lbl_bci_DEFAULT,
    1656 
    +            &&lbl_bci_PUSH_LL - &&lbl_bci_DEFAULT,
    1657 
    +            &&lbl_bci_PUSH_LLL - &&lbl_bci_DEFAULT,
    1658 
    +            &&lbl_bci_PUSH8 - &&lbl_bci_DEFAULT,
    1659 
    +            &&lbl_bci_PUSH16 - &&lbl_bci_DEFAULT,
    1660 
    +            &&lbl_bci_PUSH32 - &&lbl_bci_DEFAULT,
    1661 
    +            &&lbl_bci_PUSH8_W - &&lbl_bci_DEFAULT,
    1662 
    +            &&lbl_bci_PUSH16_W - &&lbl_bci_DEFAULT,
    1663 
    +            &&lbl_bci_PUSH32_W - &&lbl_bci_DEFAULT,
    1664 
    +            &&lbl_bci_PUSH_G - &&lbl_bci_DEFAULT,
    1665 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1666 
    +            &&lbl_bci_PUSH_ALTS_P - &&lbl_bci_DEFAULT,
    1667 
    +            &&lbl_bci_PUSH_ALTS_N - &&lbl_bci_DEFAULT,
    1668 
    +            &&lbl_bci_PUSH_ALTS_F - &&lbl_bci_DEFAULT,
    1669 
    +            &&lbl_bci_PUSH_ALTS_D - &&lbl_bci_DEFAULT,
    1670 
    +            &&lbl_bci_PUSH_ALTS_L - &&lbl_bci_DEFAULT,
    1671 
    +            &&lbl_bci_PUSH_ALTS_V - &&lbl_bci_DEFAULT,
    1672 
    +            &&lbl_bci_PUSH_PAD8 - &&lbl_bci_DEFAULT,
    1673 
    +            &&lbl_bci_PUSH_PAD16 - &&lbl_bci_DEFAULT,
    1674 
    +            &&lbl_bci_PUSH_PAD32 - &&lbl_bci_DEFAULT,
    1675 
    +            &&lbl_bci_PUSH_UBX8 - &&lbl_bci_DEFAULT,
    1676 
    +            &&lbl_bci_PUSH_UBX16 - &&lbl_bci_DEFAULT,
    1677 
    +            &&lbl_bci_PUSH_UBX32 - &&lbl_bci_DEFAULT,
    1678 
    +            &&lbl_bci_PUSH_UBX - &&lbl_bci_DEFAULT,
    1679 
    +            &&lbl_bci_PUSH_APPLY_N - &&lbl_bci_DEFAULT,
    1680 
    +            &&lbl_bci_PUSH_APPLY_F - &&lbl_bci_DEFAULT,
    1681 
    +            &&lbl_bci_PUSH_APPLY_D - &&lbl_bci_DEFAULT,
    1682 
    +            &&lbl_bci_PUSH_APPLY_L - &&lbl_bci_DEFAULT,
    1683 
    +            &&lbl_bci_PUSH_APPLY_V - &&lbl_bci_DEFAULT,
    1684 
    +            &&lbl_bci_PUSH_APPLY_P - &&lbl_bci_DEFAULT,
    1685 
    +            &&lbl_bci_PUSH_APPLY_PP - &&lbl_bci_DEFAULT,
    1686 
    +            &&lbl_bci_PUSH_APPLY_PPP - &&lbl_bci_DEFAULT,
    1687 
    +            &&lbl_bci_PUSH_APPLY_PPPP - &&lbl_bci_DEFAULT,
    1688 
    +            &&lbl_bci_PUSH_APPLY_PPPPP - &&lbl_bci_DEFAULT,
    1689 
    +            &&lbl_bci_PUSH_APPLY_PPPPPP - &&lbl_bci_DEFAULT,
    1690 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1691 
    +            &&lbl_bci_SLIDE - &&lbl_bci_DEFAULT,
    1692 
    +            &&lbl_bci_ALLOC_AP - &&lbl_bci_DEFAULT,
    1693 
    +            &&lbl_bci_ALLOC_AP_NOUPD - &&lbl_bci_DEFAULT,
    1694 
    +            &&lbl_bci_ALLOC_PAP - &&lbl_bci_DEFAULT,
    1695 
    +            &&lbl_bci_MKAP - &&lbl_bci_DEFAULT,
    1696 
    +            &&lbl_bci_MKPAP - &&lbl_bci_DEFAULT,
    1697 
    +            &&lbl_bci_UNPACK - &&lbl_bci_DEFAULT,
    1698 
    +            &&lbl_bci_PACK - &&lbl_bci_DEFAULT,
    1699 
    +            &&lbl_bci_TESTLT_I - &&lbl_bci_DEFAULT,
    1700 
    +            &&lbl_bci_TESTEQ_I - &&lbl_bci_DEFAULT,
    1701 
    +            &&lbl_bci_TESTLT_F - &&lbl_bci_DEFAULT,
    1702 
    +            &&lbl_bci_TESTEQ_F - &&lbl_bci_DEFAULT,
    1703 
    +            &&lbl_bci_TESTLT_D - &&lbl_bci_DEFAULT,
    1704 
    +            &&lbl_bci_TESTEQ_D - &&lbl_bci_DEFAULT,
    1705 
    +            &&lbl_bci_TESTLT_P - &&lbl_bci_DEFAULT,
    1706 
    +            &&lbl_bci_TESTEQ_P - &&lbl_bci_DEFAULT,
    1707 
    +            &&lbl_bci_CASEFAIL - &&lbl_bci_DEFAULT,
    1708 
    +            &&lbl_bci_JMP - &&lbl_bci_DEFAULT,
    1709 
    +            &&lbl_bci_CCALL - &&lbl_bci_DEFAULT,
    1710 
    +            &&lbl_bci_SWIZZLE - &&lbl_bci_DEFAULT,
    1711 
    +            &&lbl_bci_ENTER - &&lbl_bci_DEFAULT,
    1712 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1713 
    +            &&lbl_bci_RETURN_P - &&lbl_bci_DEFAULT,
    1714 
    +            &&lbl_bci_RETURN_N - &&lbl_bci_DEFAULT,
    1715 
    +            &&lbl_bci_RETURN_F - &&lbl_bci_DEFAULT,
    1716 
    +            &&lbl_bci_RETURN_D - &&lbl_bci_DEFAULT,
    1717 
    +            &&lbl_bci_RETURN_L - &&lbl_bci_DEFAULT,
    1718 
    +            &&lbl_bci_RETURN_V - &&lbl_bci_DEFAULT,
    1719 
    +            &&lbl_bci_BRK_FUN - &&lbl_bci_DEFAULT,
    1720 
    +            &&lbl_bci_TESTLT_W - &&lbl_bci_DEFAULT,
    1721 
    +            &&lbl_bci_TESTEQ_W - &&lbl_bci_DEFAULT,
    1722 
    +            &&lbl_bci_RETURN_T - &&lbl_bci_DEFAULT,
    1723 
    +            &&lbl_bci_PUSH_ALTS_T - &&lbl_bci_DEFAULT,
    1724 
    +            &&lbl_bci_TESTLT_I64 - &&lbl_bci_DEFAULT,
    1725 
    +            &&lbl_bci_TESTEQ_I64 - &&lbl_bci_DEFAULT,
    1726 
    +            &&lbl_bci_TESTLT_I32 - &&lbl_bci_DEFAULT,
    1727 
    +            &&lbl_bci_TESTEQ_I32 - &&lbl_bci_DEFAULT,
    1728 
    +            &&lbl_bci_TESTLT_I16 - &&lbl_bci_DEFAULT,
    1729 
    +            &&lbl_bci_TESTEQ_I16 - &&lbl_bci_DEFAULT,
    1730 
    +            &&lbl_bci_TESTLT_I8 - &&lbl_bci_DEFAULT,
    1731 
    +            &&lbl_bci_TESTEQ_I8 - &&lbl_bci_DEFAULT,
    1732 
    +            &&lbl_bci_TESTLT_W64 - &&lbl_bci_DEFAULT,
    1733 
    +            &&lbl_bci_TESTEQ_W64 - &&lbl_bci_DEFAULT,
    1734 
    +            &&lbl_bci_TESTLT_W32 - &&lbl_bci_DEFAULT,
    1735 
    +            &&lbl_bci_TESTEQ_W32 - &&lbl_bci_DEFAULT,
    1736 
    +            &&lbl_bci_TESTLT_W16 - &&lbl_bci_DEFAULT,
    1737 
    +            &&lbl_bci_TESTEQ_W16 - &&lbl_bci_DEFAULT,
    1738 
    +            &&lbl_bci_TESTLT_W8 - &&lbl_bci_DEFAULT,
    1739 
    +            &&lbl_bci_TESTEQ_W8 - &&lbl_bci_DEFAULT,
    1740 
    +            &&lbl_bci_PRIMCALL - &&lbl_bci_DEFAULT,
    1741 
    +            &&lbl_bci_BCO_NAME - &&lbl_bci_DEFAULT,
    1742 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1743 
    +            &&lbl_bci_OP_ADD_64 - &&lbl_bci_DEFAULT,
    1744 
    +            &&lbl_bci_OP_SUB_64 - &&lbl_bci_DEFAULT,
    1745 
    +            &&lbl_bci_OP_AND_64 - &&lbl_bci_DEFAULT,
    1746 
    +            &&lbl_bci_OP_XOR_64 - &&lbl_bci_DEFAULT,
    1747 
    +            &&lbl_bci_OP_NOT_64 - &&lbl_bci_DEFAULT,
    1748 
    +            &&lbl_bci_OP_NEG_64 - &&lbl_bci_DEFAULT,
    1749 
    +            &&lbl_bci_OP_MUL_64 - &&lbl_bci_DEFAULT,
    1750 
    +            &&lbl_bci_OP_SHL_64 - &&lbl_bci_DEFAULT,
    1751 
    +            &&lbl_bci_OP_ASR_64 - &&lbl_bci_DEFAULT,
    1752 
    +            &&lbl_bci_OP_LSR_64 - &&lbl_bci_DEFAULT,
    1753 
    +            &&lbl_bci_OP_OR_64 - &&lbl_bci_DEFAULT,
    1754 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1755 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1756 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1757 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1758 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1759 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1760 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1761 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1762 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1763 
    +            &&lbl_bci_OP_NEQ_64 - &&lbl_bci_DEFAULT,
    1764 
    +            &&lbl_bci_OP_EQ_64 - &&lbl_bci_DEFAULT,
    1765 
    +            &&lbl_bci_OP_U_GE_64 - &&lbl_bci_DEFAULT,
    1766 
    +            &&lbl_bci_OP_U_GT_64 - &&lbl_bci_DEFAULT,
    1767 
    +            &&lbl_bci_OP_U_LT_64 - &&lbl_bci_DEFAULT,
    1768 
    +            &&lbl_bci_OP_U_LE_64 - &&lbl_bci_DEFAULT,
    1769 
    +            &&lbl_bci_OP_S_GE_64 - &&lbl_bci_DEFAULT,
    1770 
    +            &&lbl_bci_OP_S_GT_64 - &&lbl_bci_DEFAULT,
    1771 
    +            &&lbl_bci_OP_S_LT_64 - &&lbl_bci_DEFAULT,
    1772 
    +            &&lbl_bci_OP_S_LE_64 - &&lbl_bci_DEFAULT,
    1773 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1774 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1775 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1776 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1777 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1778 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1779 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1780 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1781 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1782 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1783 
    +            &&lbl_bci_OP_ADD_32 - &&lbl_bci_DEFAULT,
    1784 
    +            &&lbl_bci_OP_SUB_32 - &&lbl_bci_DEFAULT,
    1785 
    +            &&lbl_bci_OP_AND_32 - &&lbl_bci_DEFAULT,
    1786 
    +            &&lbl_bci_OP_XOR_32 - &&lbl_bci_DEFAULT,
    1787 
    +            &&lbl_bci_OP_NOT_32 - &&lbl_bci_DEFAULT,
    1788 
    +            &&lbl_bci_OP_NEG_32 - &&lbl_bci_DEFAULT,
    1789 
    +            &&lbl_bci_OP_MUL_32 - &&lbl_bci_DEFAULT,
    1790 
    +            &&lbl_bci_OP_SHL_32 - &&lbl_bci_DEFAULT,
    1791 
    +            &&lbl_bci_OP_ASR_32 - &&lbl_bci_DEFAULT,
    1792 
    +            &&lbl_bci_OP_LSR_32 - &&lbl_bci_DEFAULT,
    1793 
    +            &&lbl_bci_OP_OR_32 - &&lbl_bci_DEFAULT,
    1794 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1795 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1796 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1797 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1798 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1799 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1800 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1801 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1802 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1803 
    +            &&lbl_bci_OP_NEQ_32 - &&lbl_bci_DEFAULT,
    1804 
    +            &&lbl_bci_OP_EQ_32 - &&lbl_bci_DEFAULT,
    1805 
    +            &&lbl_bci_OP_U_GE_32 - &&lbl_bci_DEFAULT,
    1806 
    +            &&lbl_bci_OP_U_GT_32 - &&lbl_bci_DEFAULT,
    1807 
    +            &&lbl_bci_OP_U_LT_32 - &&lbl_bci_DEFAULT,
    1808 
    +            &&lbl_bci_OP_U_LE_32 - &&lbl_bci_DEFAULT,
    1809 
    +            &&lbl_bci_OP_S_GE_32 - &&lbl_bci_DEFAULT,
    1810 
    +            &&lbl_bci_OP_S_GT_32 - &&lbl_bci_DEFAULT,
    1811 
    +            &&lbl_bci_OP_S_LT_32 - &&lbl_bci_DEFAULT,
    1812 
    +            &&lbl_bci_OP_S_LE_32 - &&lbl_bci_DEFAULT,
    1813 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1814 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1815 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1816 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1817 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1818 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1819 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1820 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1821 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1822 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1823 
    +            &&lbl_bci_OP_ADD_16 - &&lbl_bci_DEFAULT,
    1824 
    +            &&lbl_bci_OP_SUB_16 - &&lbl_bci_DEFAULT,
    1825 
    +            &&lbl_bci_OP_AND_16 - &&lbl_bci_DEFAULT,
    1826 
    +            &&lbl_bci_OP_XOR_16 - &&lbl_bci_DEFAULT,
    1827 
    +            &&lbl_bci_OP_NOT_16 - &&lbl_bci_DEFAULT,
    1828 
    +            &&lbl_bci_OP_NEG_16 - &&lbl_bci_DEFAULT,
    1829 
    +            &&lbl_bci_OP_MUL_16 - &&lbl_bci_DEFAULT,
    1830 
    +            &&lbl_bci_OP_SHL_16 - &&lbl_bci_DEFAULT,
    1831 
    +            &&lbl_bci_OP_ASR_16 - &&lbl_bci_DEFAULT,
    1832 
    +            &&lbl_bci_OP_LSR_16 - &&lbl_bci_DEFAULT,
    1833 
    +            &&lbl_bci_OP_OR_16 - &&lbl_bci_DEFAULT,
    1834 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1835 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1836 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1837 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1838 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1839 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1840 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1841 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1842 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1843 
    +            &&lbl_bci_OP_NEQ_16 - &&lbl_bci_DEFAULT,
    1844 
    +            &&lbl_bci_OP_EQ_16 - &&lbl_bci_DEFAULT,
    1845 
    +            &&lbl_bci_OP_U_GE_16 - &&lbl_bci_DEFAULT,
    1846 
    +            &&lbl_bci_OP_U_GT_16 - &&lbl_bci_DEFAULT,
    1847 
    +            &&lbl_bci_OP_U_LT_16 - &&lbl_bci_DEFAULT,
    1848 
    +            &&lbl_bci_OP_U_LE_16 - &&lbl_bci_DEFAULT,
    1849 
    +            &&lbl_bci_OP_S_GE_16 - &&lbl_bci_DEFAULT,
    1850 
    +            &&lbl_bci_OP_S_GT_16 - &&lbl_bci_DEFAULT,
    1851 
    +            &&lbl_bci_OP_S_LT_16 - &&lbl_bci_DEFAULT,
    1852 
    +            &&lbl_bci_OP_S_LE_16 - &&lbl_bci_DEFAULT,
    1853 
    +            &&lbl_bci_OP_ADD_08 - &&lbl_bci_DEFAULT,
    1854 
    +            &&lbl_bci_OP_SUB_08 - &&lbl_bci_DEFAULT,
    1855 
    +            &&lbl_bci_OP_AND_08 - &&lbl_bci_DEFAULT,
    1856 
    +            &&lbl_bci_OP_XOR_08 - &&lbl_bci_DEFAULT,
    1857 
    +            &&lbl_bci_OP_NOT_08 - &&lbl_bci_DEFAULT,
    1858 
    +            &&lbl_bci_OP_NEG_08 - &&lbl_bci_DEFAULT,
    1859 
    +            &&lbl_bci_OP_MUL_08 - &&lbl_bci_DEFAULT,
    1860 
    +            &&lbl_bci_OP_SHL_08 - &&lbl_bci_DEFAULT,
    1861 
    +            &&lbl_bci_OP_ASR_08 - &&lbl_bci_DEFAULT,
    1862 
    +            &&lbl_bci_OP_LSR_08 - &&lbl_bci_DEFAULT,
    1863 
    +            &&lbl_bci_OP_OR_08 - &&lbl_bci_DEFAULT,
    1864 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1865 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1866 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1867 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1868 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1869 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1870 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1871 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1872 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1873 
    +            &&lbl_bci_OP_NEQ_08 - &&lbl_bci_DEFAULT,
    1874 
    +            &&lbl_bci_OP_EQ_08 - &&lbl_bci_DEFAULT,
    1875 
    +            &&lbl_bci_OP_U_GE_08 - &&lbl_bci_DEFAULT,
    1876 
    +            &&lbl_bci_OP_U_GT_08 - &&lbl_bci_DEFAULT,
    1877 
    +            &&lbl_bci_OP_U_LT_08 - &&lbl_bci_DEFAULT,
    1878 
    +            &&lbl_bci_OP_U_LE_08 - &&lbl_bci_DEFAULT,
    1879 
    +            &&lbl_bci_OP_S_GE_08 - &&lbl_bci_DEFAULT,
    1880 
    +            &&lbl_bci_OP_S_GT_08 - &&lbl_bci_DEFAULT,
    1881 
    +            &&lbl_bci_OP_S_LT_08 - &&lbl_bci_DEFAULT,
    1882 
    +            &&lbl_bci_OP_S_LE_08 - &&lbl_bci_DEFAULT,
    1883 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1884 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1885 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1886 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1887 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1888 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1889 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1890 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1891 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1892 
    +            &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
    1893 
    +            &&lbl_bci_OP_INDEX_ADDR_08 - &&lbl_bci_DEFAULT,
    1894 
    +            &&lbl_bci_OP_INDEX_ADDR_16 - &&lbl_bci_DEFAULT,
    1895 
    +            &&lbl_bci_OP_INDEX_ADDR_32 - &&lbl_bci_DEFAULT,
    1896 
    +            &&lbl_bci_OP_INDEX_ADDR_64 - &&lbl_bci_DEFAULT};
    1897 
    +        NEXT_INSTRUCTION;
    1898 
    +#else
    1899 
    +    bci = BCO_NEXT;
    1576 1900 
         /* We use the high 8 bits for flags. The highest of which is
    1577 1901 
          * currently allocated to LARGE_ARGS */
    1578 1902 
         ASSERT((bci & 0xFF00) == (bci & ( bci_FLAG_LARGE_ARGS )));
    1579 
    -
    1580 1903 
         switch (bci & 0xFF) {
    1904 
    +#endif
    1581 1905
    1582 1906 
             /* check for a breakpoint on the beginning of a BCO */
    1583 
    -        case bci_BRK_FUN:
    1907 
    +        INSTRUCTION(bci_BRK_FUN):
    1584 1908 
             {
    1585 1909 
                 W_ arg1_brk_array, arg2_info_mod_name, arg3_info_mod_id, arg4_info_index;
    1586 1910 
     #if defined(PROFILING)
    ... ... @@ -1779,10 +2103,10 @@ run_BCO:
    1779 2103 
                 cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
    1780 2104
    1781 2105 
                 // continue normal execution of the byte code instructions
    1782 
    -            goto nextInsn;
    2106 
    +            NEXT_INSTRUCTION;
    1783 2107 
             }
    1784 2108
    1785 
    -        case bci_STKCHECK: {
    2109 
    +        INSTRUCTION(bci_STKCHECK): {
    1786 2110 
                 // Explicit stack check at the beginning of a function
    1787 2111 
                 // *only* (stack checks in case alternatives are
    1788 2112 
                 // propagated to the enclosing function).
    ... ... @@ -1793,27 +2117,27 @@ run_BCO:
    1793 2117 
                     SpW(0) = (W_)&stg_apply_interp_info;
    1794 2118 
                     RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
    1795 2119 
                 } else {
    1796 
    -                goto nextInsn;
    2120 
    +                NEXT_INSTRUCTION;
    1797 2121 
                 }
    1798 2122 
             }
    1799 2123
    1800 
    -        case bci_PUSH_L: {
    2124 
    +        INSTRUCTION(bci_PUSH_L): {
    1801 2125 
                 W_ o1 = BCO_GET_LARGE_ARG;
    1802 2126 
                 SpW(-1) = ReadSpW(o1);
    1803 2127 
                 Sp_subW(1);
    1804 
    -            goto nextInsn;
    2128 
    +            NEXT_INSTRUCTION;
    1805 2129 
             }
    1806 2130
    1807 
    -        case bci_PUSH_LL: {
    2131 
    +        INSTRUCTION(bci_PUSH_LL): {
    1808 2132 
                 W_ o1 = BCO_GET_LARGE_ARG;
    1809 2133 
                 W_ o2 = BCO_GET_LARGE_ARG;
    1810 2134 
                 SpW(-1) = ReadSpW(o1);
    1811 2135 
                 SpW(-2) = ReadSpW(o2);
    1812 2136 
                 Sp_subW(2);
    1813 
    -            goto nextInsn;
    2137 
    +            NEXT_INSTRUCTION;
    1814 2138 
             }
    1815 2139
    1816 
    -        case bci_PUSH_LLL: {
    2140 
    +        INSTRUCTION(bci_PUSH_LLL): {
    1817 2141 
                 W_ o1 = BCO_GET_LARGE_ARG;
    1818 2142 
                 W_ o2 = BCO_GET_LARGE_ARG;
    1819 2143 
                 W_ o3 = BCO_GET_LARGE_ARG;
    ... ... @@ -1821,52 +2145,52 @@ run_BCO:
    1821 2145 
                 SpW(-2) = ReadSpW(o2);
    1822 2146 
                 SpW(-3) = ReadSpW(o3);
    1823 2147 
                 Sp_subW(3);
    1824 
    -            goto nextInsn;
    2148 
    +            NEXT_INSTRUCTION;
    1825 2149 
             }
    1826 2150
    1827 
    -        case bci_PUSH8: {
    2151 
    +        INSTRUCTION(bci_PUSH8): {
    1828 2152 
                 W_ off = BCO_GET_LARGE_ARG;
    1829 2153 
                 Sp_subB(1);
    1830 2154 
                 *(StgWord8*)Sp = (StgWord8) (ReadSpB(off+1));
    1831 
    -            goto nextInsn;
    2155 
    +            NEXT_INSTRUCTION;
    1832 2156 
             }
    1833 2157
    1834 
    -        case bci_PUSH16: {
    2158 
    +        INSTRUCTION(bci_PUSH16): {
    1835 2159 
                 W_ off = BCO_GET_LARGE_ARG;
    1836 2160 
                 Sp_subB(2);
    1837 2161 
                 *(StgWord16*)Sp = (StgWord16) (ReadSpB(off+2));
    1838 
    -            goto nextInsn;
    2162 
    +            NEXT_INSTRUCTION;
    1839 2163 
             }
    1840 2164
    1841 
    -        case bci_PUSH32: {
    2165 
    +        INSTRUCTION(bci_PUSH32): {
    1842 2166 
                 W_ off = BCO_GET_LARGE_ARG;
    1843 2167 
                 Sp_subB(4);
    1844 2168 
                 *(StgWord32*)Sp = (StgWord32) (ReadSpB(off+4));
    1845 
    -            goto nextInsn;
    2169 
    +            NEXT_INSTRUCTION;
    1846 2170 
             }
    1847 2171
    1848 
    -        case bci_PUSH8_W: {
    2172 
    +        INSTRUCTION(bci_PUSH8_W): {
    1849 2173 
                 W_ off = BCO_GET_LARGE_ARG;
    1850 2174 
                 *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord8) (ReadSpB(off)));
    1851 2175 
                 Sp_subW(1);
    1852 
    -            goto nextInsn;
    2176 
    +            NEXT_INSTRUCTION;
    1853 2177 
             }
    1854 2178
    1855 
    -        case bci_PUSH16_W: {
    2179 
    +        INSTRUCTION(bci_PUSH16_W): {
    1856 2180 
                 W_ off = BCO_GET_LARGE_ARG;
    1857 2181 
                 *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord16) (ReadSpB(off)));
    1858 2182 
                 Sp_subW(1);
    1859 
    -            goto nextInsn;
    2183 
    +            NEXT_INSTRUCTION;
    1860 2184 
             }
    1861 2185
    1862 
    -        case bci_PUSH32_W: {
    2186 
    +        INSTRUCTION(bci_PUSH32_W): {
    1863 2187 
                 W_ off = BCO_GET_LARGE_ARG;
    1864 2188 
                 *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord32) (ReadSpB(off)));
    1865 2189 
                 Sp_subW(1);
    1866 
    -            goto nextInsn;
    2190 
    +            NEXT_INSTRUCTION;
    1867 2191 
             }
    1868 2192
    1869 
    -        case bci_PUSH_G: {
    2193 
    +        INSTRUCTION(bci_PUSH_G): {
    1870 2194 
                 W_ o1 = BCO_GET_LARGE_ARG;
    1871 2195 
                 StgClosure *tagged_obj = (StgClosure*) BCO_PTR(o1);
    1872 2196
    ... ... @@ -1905,10 +2229,10 @@ run_BCO:
    1905 2229
    1906 2230 
                 SpW(-1) = (W_) tagged_obj;
    1907 2231 
                 Sp_subW(1);
    1908 
    -            goto nextInsn;
    2232 
    +            NEXT_INSTRUCTION;
    1909 2233 
             }
    1910 2234
    1911 
    -        case bci_PUSH_ALTS_P: {
    2235 
    +        INSTRUCTION(bci_PUSH_ALTS_P): {
    1912 2236 
                 W_ o_bco  = BCO_GET_LARGE_ARG;
    1913 2237 
                 Sp_subW(2);
    1914 2238 
                 SpW(1) = BCO_PTR(o_bco);
    ... ... @@ -1918,10 +2242,10 @@ run_BCO:
    1918 2242 
                 SpW(1) = (W_)cap->r.rCCCS;
    1919 2243 
                 SpW(0) = (W_)&stg_restore_cccs_d_info;
    1920 2244 
     #endif
    1921 
    -            goto nextInsn;
    2245 
    +            NEXT_INSTRUCTION;
    1922 2246 
             }
    1923 2247
    1924 
    -        case bci_PUSH_ALTS_N: {
    2248 
    +        INSTRUCTION(bci_PUSH_ALTS_N): {
    1925 2249 
                 W_ o_bco  = BCO_GET_LARGE_ARG;
    1926 2250 
                 SpW(-2) = (W_)&stg_ctoi_R1n_info;
    1927 2251 
                 SpW(-1) = BCO_PTR(o_bco);
    ... ... @@ -1931,10 +2255,10 @@ run_BCO:
    1931 2255 
                 SpW(1) = (W_)cap->r.rCCCS;
    1932 2256 
                 SpW(0) = (W_)&stg_restore_cccs_d_info;
    1933 2257 
     #endif
    1934 
    -            goto nextInsn;
    2258 
    +            NEXT_INSTRUCTION;
    1935 2259 
             }
    1936 2260
    1937 
    -        case bci_PUSH_ALTS_F: {
    2261 
    +        INSTRUCTION(bci_PUSH_ALTS_F): {
    1938 2262 
                 W_ o_bco  = BCO_GET_LARGE_ARG;
    1939 2263 
                 SpW(-2) = (W_)&stg_ctoi_F1_info;
    1940 2264 
                 SpW(-1) = BCO_PTR(o_bco);
    ... ... @@ -1944,10 +2268,10 @@ run_BCO:
    1944 2268 
                 SpW(1) = (W_)cap->r.rCCCS;
    1945 2269 
                 SpW(0) = (W_)&stg_restore_cccs_d_info;
    1946 2270 
     #endif
    1947 
    -            goto nextInsn;
    2271 
    +            NEXT_INSTRUCTION;
    1948 2272 
             }
    1949 2273
    1950 
    -        case bci_PUSH_ALTS_D: {
    2274 
    +        INSTRUCTION(bci_PUSH_ALTS_D): {
    1951 2275 
                 W_ o_bco  = BCO_GET_LARGE_ARG;
    1952 2276 
                 SpW(-2) = (W_)&stg_ctoi_D1_info;
    1953 2277 
                 SpW(-1) = BCO_PTR(o_bco);
    ... ... @@ -1957,10 +2281,10 @@ run_BCO:
    1957 2281 
                 SpW(1) = (W_)cap->r.rCCCS;
    1958 2282 
                 SpW(0) = (W_)&stg_restore_cccs_d_info;
    1959 2283 
     #endif
    1960 
    -            goto nextInsn;
    2284 
    +            NEXT_INSTRUCTION;
    1961 2285 
             }
    1962 2286
    1963 
    -        case bci_PUSH_ALTS_L: {
    2287 
    +        INSTRUCTION(bci_PUSH_ALTS_L): {
    1964 2288 
                 W_ o_bco  = BCO_GET_LARGE_ARG;
    1965 2289 
                 SpW(-2) = (W_)&stg_ctoi_L1_info;
    1966 2290 
                 SpW(-1) = BCO_PTR(o_bco);
    ... ... @@ -1970,10 +2294,10 @@ run_BCO:
    1970 2294 
                 SpW(1) = (W_)cap->r.rCCCS;
    1971 2295 
                 SpW(0) = (W_)&stg_restore_cccs_d_info;
    1972 2296 
     #endif
    1973 
    -            goto nextInsn;
    2297 
    +            NEXT_INSTRUCTION;
    1974 2298 
             }
    1975 2299
    1976 
    -        case bci_PUSH_ALTS_V: {
    2300 
    +        INSTRUCTION(bci_PUSH_ALTS_V): {
    1977 2301 
                 W_ o_bco  = BCO_GET_LARGE_ARG;
    1978 2302 
                 SpW(-2) = (W_)&stg_ctoi_V_info;
    1979 2303 
                 SpW(-1) = BCO_PTR(o_bco);
    ... ... @@ -1983,10 +2307,10 @@ run_BCO:
    1983 2307 
                 SpW(1) = (W_)cap->r.rCCCS;
    1984 2308 
                 SpW(0) = (W_)&stg_restore_cccs_d_info;
    1985 2309 
     #endif
    1986 
    -            goto nextInsn;
    2310 
    +            NEXT_INSTRUCTION;
    1987 2311 
             }
    1988 2312
    1989 
    -        case bci_PUSH_ALTS_T: {
    2313 
    +        INSTRUCTION(bci_PUSH_ALTS_T): {
    1990 2314 
                 W_ o_bco = BCO_GET_LARGE_ARG;
    1991 2315 
                 W_ tuple_info = (W_)BCO_LIT(BCO_GET_LARGE_ARG);
    1992 2316 
                 W_ o_tuple_bco = BCO_GET_LARGE_ARG;
    ... ... @@ -2006,83 +2330,83 @@ run_BCO:
    2006 2330 
                 W_ ctoi_t_offset = (W_) ctoi_tuple_infos[tuple_stack_words];
    2007 2331 
                 SpW(-4) = ctoi_t_offset;
    2008 2332 
                 Sp_subW(4);
    2009 
    -            goto nextInsn;
    2333 
    +            NEXT_INSTRUCTION;
    2010 2334 
             }
    2011 2335
    2012 
    -        case bci_PUSH_APPLY_N:
    2336 
    +        INSTRUCTION(bci_PUSH_APPLY_N):
    2013 2337 
                 Sp_subW(1); SpW(0) = (W_)&stg_ap_n_info;
    2014 
    -            goto nextInsn;
    2015 
    -        case bci_PUSH_APPLY_V:
    2338 
    +            NEXT_INSTRUCTION;
    2339 
    +        INSTRUCTION(bci_PUSH_APPLY_V):
    2016 2340 
                 Sp_subW(1); SpW(0) = (W_)&stg_ap_v_info;
    2017 
    -            goto nextInsn;
    2018 
    -        case bci_PUSH_APPLY_F:
    2341 
    +            NEXT_INSTRUCTION;
    2342 
    +        INSTRUCTION(bci_PUSH_APPLY_F):
    2019 2343 
                 Sp_subW(1); SpW(0) = (W_)&stg_ap_f_info;
    2020 
    -            goto nextInsn;
    2021 
    -        case bci_PUSH_APPLY_D:
    2344 
    +            NEXT_INSTRUCTION;
    2345 
    +        INSTRUCTION(bci_PUSH_APPLY_D):
    2022 2346 
                 Sp_subW(1); SpW(0) = (W_)&stg_ap_d_info;
    2023 
    -            goto nextInsn;
    2024 
    -        case bci_PUSH_APPLY_L:
    2347 
    +            NEXT_INSTRUCTION;
    2348 
    +        INSTRUCTION(bci_PUSH_APPLY_L):
    2025 2349 
                 Sp_subW(1); SpW(0) = (W_)&stg_ap_l_info;
    2026 
    -            goto nextInsn;
    2027 
    -        case bci_PUSH_APPLY_P:
    2350 
    +            NEXT_INSTRUCTION;
    2351 
    +        INSTRUCTION(bci_PUSH_APPLY_P):
    2028 2352 
                 Sp_subW(1); SpW(0) = (W_)&stg_ap_p_info;
    2029 
    -            goto nextInsn;
    2030 
    -        case bci_PUSH_APPLY_PP:
    2353 
    +            NEXT_INSTRUCTION;
    2354 
    +        INSTRUCTION(bci_PUSH_APPLY_PP):
    2031 2355 
                 Sp_subW(1); SpW(0) = (W_)&stg_ap_pp_info;
    2032 
    -            goto nextInsn;
    2033 
    -        case bci_PUSH_APPLY_PPP:
    2356 
    +            NEXT_INSTRUCTION;
    2357 
    +        INSTRUCTION(bci_PUSH_APPLY_PPP):
    2034 2358 
                 Sp_subW(1); SpW(0) = (W_)&stg_ap_ppp_info;
    2035 
    -            goto nextInsn;
    2036 
    -        case bci_PUSH_APPLY_PPPP:
    2359 
    +            NEXT_INSTRUCTION;
    2360 
    +        INSTRUCTION(bci_PUSH_APPLY_PPPP):
    2037 2361 
                 Sp_subW(1); SpW(0) = (W_)&stg_ap_pppp_info;
    2038 
    -            goto nextInsn;
    2039 
    -        case bci_PUSH_APPLY_PPPPP:
    2362 
    +            NEXT_INSTRUCTION;
    2363 
    +        INSTRUCTION(bci_PUSH_APPLY_PPPPP):
    2040 2364 
                 Sp_subW(1); SpW(0) = (W_)&stg_ap_ppppp_info;
    2041 
    -            goto nextInsn;
    2042 
    -        case bci_PUSH_APPLY_PPPPPP:
    2365 
    +            NEXT_INSTRUCTION;
    2366 
    +        INSTRUCTION(bci_PUSH_APPLY_PPPPPP):
    2043 2367 
                 Sp_subW(1); SpW(0) = (W_)&stg_ap_pppppp_info;
    2044 
    -            goto nextInsn;
    2368 
    +            NEXT_INSTRUCTION;
    2045 2369
    2046 
    -        case bci_PUSH_PAD8: {
    2370 
    +        INSTRUCTION(bci_PUSH_PAD8): {
    2047 2371 
                 Sp_subB(1);
    2048 2372 
                 *(StgWord8*)Sp = 0;
    2049 
    -            goto nextInsn;
    2373 
    +            NEXT_INSTRUCTION;
    2050 2374 
             }
    2051 2375
    2052 
    -        case bci_PUSH_PAD16: {
    2376 
    +        INSTRUCTION(bci_PUSH_PAD16): {
    2053 2377 
                 Sp_subB(2);
    2054 2378 
                 *(StgWord16*)Sp = 0;
    2055 
    -            goto nextInsn;
    2379 
    +            NEXT_INSTRUCTION;
    2056 2380 
             }
    2057 2381
    2058 
    -        case bci_PUSH_PAD32: {
    2382 
    +        INSTRUCTION(bci_PUSH_PAD32): {
    2059 2383 
                 Sp_subB(4);
    2060 2384 
                 *(StgWord32*)Sp = 0;
    2061 
    -            goto nextInsn;
    2385 
    +            NEXT_INSTRUCTION;
    2062 2386 
             }
    2063 2387
    2064 
    -        case bci_PUSH_UBX8: {
    2388 
    +        INSTRUCTION(bci_PUSH_UBX8): {
    2065 2389 
                 W_ o_lit = BCO_GET_LARGE_ARG;
    2066 2390 
                 Sp_subB(1);
    2067 2391 
                 *(StgWord8*)Sp = (StgWord8) BCO_LIT(o_lit);
    2068 
    -            goto nextInsn;
    2392 
    +            NEXT_INSTRUCTION;
    2069 2393 
             }
    2070 2394
    2071 
    -        case bci_PUSH_UBX16: {
    2395 
    +        INSTRUCTION(bci_PUSH_UBX16): {
    2072 2396 
                 W_ o_lit = BCO_GET_LARGE_ARG;
    2073 2397 
                 Sp_subB(2);
    2074 2398 
                 *(StgWord16*)Sp = (StgWord16) BCO_LIT(o_lit);
    2075 
    -            goto nextInsn;
    2399 
    +            NEXT_INSTRUCTION;
    2076 2400 
             }
    2077 2401
    2078 
    -        case bci_PUSH_UBX32: {
    2402 
    +        INSTRUCTION(bci_PUSH_UBX32): {
    2079 2403 
                 W_ o_lit = BCO_GET_LARGE_ARG;
    2080 2404 
                 Sp_subB(4);
    2081 2405 
                 *(StgWord32*)Sp = (StgWord32) BCO_LIT(o_lit);
    2082 
    -            goto nextInsn;
    2406 
    +            NEXT_INSTRUCTION;
    2083 2407 
             }
    2084 2408
    2085 
    -        case bci_PUSH_UBX: {
    2409 
    +        INSTRUCTION(bci_PUSH_UBX): {
    2086 2410 
                 W_ i;
    2087 2411 
                 W_ o_lits = BCO_GET_LARGE_ARG;
    2088 2412 
                 W_ n_words = BCO_GET_LARGE_ARG;
    ... ... @@ -2090,10 +2414,10 @@ run_BCO:
    2090 2414 
                 for (i = 0; i < n_words; i++) {
    2091 2415 
                     SpW(i) = (W_)BCO_LIT(o_lits+i);
    2092 2416 
                 }
    2093 
    -            goto nextInsn;
    2417 
    +            NEXT_INSTRUCTION;
    2094 2418 
             }
    2095 2419
    2096 
    -        case bci_SLIDE: {
    2420 
    +        INSTRUCTION(bci_SLIDE): {
    2097 2421 
                 W_ n  = BCO_GET_LARGE_ARG;
    2098 2422 
                 W_ by = BCO_GET_LARGE_ARG;
    2099 2423 
                 /*
    ... ... @@ -2106,10 +2430,10 @@ run_BCO:
    2106 2430 
                 }
    2107 2431 
                 Sp_addW(by);
    2108 2432 
                 INTERP_TICK(it_slides);
    2109 
    -            goto nextInsn;
    2433 
    +            NEXT_INSTRUCTION;
    2110 2434 
             }
    2111 2435
    2112 
    -        case bci_ALLOC_AP: {
    2436 
    +        INSTRUCTION(bci_ALLOC_AP): {
    2113 2437 
                 StgHalfWord n_payload = BCO_GET_LARGE_ARG;
    2114 2438 
                 StgAP *ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
    2115 2439 
                 SpW(-1) = (W_)ap;
    ... ... @@ -2119,10 +2443,10 @@ run_BCO:
    2119 2443 
                 // visible only from our stack
    2120 2444 
                 SET_HDR(ap, &stg_AP_info, cap->r.rCCCS)
    2121 2445 
                 Sp_subW(1);
    2122 
    -            goto nextInsn;
    2446 
    +            NEXT_INSTRUCTION;
    2123 2447 
             }
    2124 2448
    2125 
    -        case bci_ALLOC_AP_NOUPD: {
    2449 
    +        INSTRUCTION(bci_ALLOC_AP_NOUPD): {
    2126 2450 
                 StgHalfWord n_payload = BCO_GET_LARGE_ARG;
    2127 2451 
                 StgAP *ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
    2128 2452 
                 SpW(-1) = (W_)ap;
    ... ... @@ -2132,10 +2456,10 @@ run_BCO:
    2132 2456 
                 // visible only from our stack
    2133 2457 
                 SET_HDR(ap, &stg_AP_NOUPD_info, cap->r.rCCCS)
    2134 2458 
                 Sp_subW(1);
    2135 
    -            goto nextInsn;
    2459 
    +            NEXT_INSTRUCTION;
    2136 2460 
             }
    2137 2461
    2138 
    -        case bci_ALLOC_PAP: {
    2462 
    +        INSTRUCTION(bci_ALLOC_PAP): {
    2139 2463 
                 StgPAP* pap;
    2140 2464 
                 StgHalfWord arity = BCO_GET_LARGE_ARG;
    2141 2465 
                 StgHalfWord n_payload = BCO_GET_LARGE_ARG;
    ... ... @@ -2147,10 +2471,10 @@ run_BCO:
    2147 2471 
                 // visible only from our stack
    2148 2472 
                 SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS)
    2149 2473 
                 Sp_subW(1);
    2150 
    -            goto nextInsn;
    2474 
    +            NEXT_INSTRUCTION;
    2151 2475 
             }
    2152 2476
    2153 
    -        case bci_MKAP: {
    2477 
    +        INSTRUCTION(bci_MKAP): {
    2154 2478 
                 StgHalfWord i;
    2155 2479 
                 W_ stkoff = BCO_GET_LARGE_ARG;
    2156 2480 
                 StgHalfWord n_payload = BCO_GET_LARGE_ARG;
    ... ... @@ -2171,10 +2495,10 @@ run_BCO:
    2171 2495 
                          debugBelch("\tBuilt ");
    2172 2496 
                          printObj((StgClosure*)ap);
    2173 2497 
                     );
    2174 
    -            goto nextInsn;
    2498 
    +            NEXT_INSTRUCTION;
    2175 2499 
             }
    2176 2500
    2177 
    -        case bci_MKPAP: {
    2501 
    +        INSTRUCTION(bci_MKPAP): {
    2178 2502 
                 StgHalfWord i;
    2179 2503 
                 W_ stkoff = BCO_GET_LARGE_ARG;
    2180 2504 
                 StgHalfWord n_payload = BCO_GET_LARGE_ARG;
    ... ... @@ -2198,10 +2522,10 @@ run_BCO:
    2198 2522 
                          debugBelch("\tBuilt ");
    2199 2523 
                          printObj((StgClosure*)pap);
    2200 2524 
                     );
    2201 
    -            goto nextInsn;
    2525 
    +            NEXT_INSTRUCTION;
    2202 2526 
             }
    2203 2527
    2204 
    -        case bci_UNPACK: {
    2528 
    +        INSTRUCTION(bci_UNPACK): {
    2205 2529 
                 /* Unpack N ptr words from t.o.s constructor */
    2206 2530 
                 W_ i;
    2207 2531 
                 W_ n_words = BCO_GET_LARGE_ARG;
    ... ... @@ -2210,10 +2534,10 @@ run_BCO:
    2210 2534 
                 for (i = 0; i < n_words; i++) {
    2211 2535 
                     SpW(i) = (W_)con->payload[i];
    2212 2536 
                 }
    2213 
    -            goto nextInsn;
    2537 
    +            NEXT_INSTRUCTION;
    2214 2538 
             }
    2215 2539
    2216 
    -        case bci_PACK: {
    2540 
    +        INSTRUCTION(bci_PACK): {
    2217 2541 
                 W_ o_itbl         = BCO_GET_LARGE_ARG;
    2218 2542 
                 W_ n_words        = BCO_GET_LARGE_ARG;
    2219 2543 
                 StgConInfoTable* itbl = CON_INFO_PTR_TO_STRUCT((StgInfoTable *)BCO_LIT(o_itbl));
    ... ... @@ -2244,220 +2568,220 @@ run_BCO:
    2244 2568 
                          debugBelch("\tBuilt ");
    2245 2569 
                          printObj((StgClosure*)tagged_con);
    2246 2570 
                     );
    2247 
    -            goto nextInsn;
    2571 
    +            NEXT_INSTRUCTION;
    2248 2572 
             }
    2249 2573
    2250 
    -        case bci_TESTLT_P: {
    2574 
    +        INSTRUCTION(bci_TESTLT_P): {
    2251 2575 
                 unsigned int discr  = BCO_NEXT;
    2252 2576 
                 int failto = BCO_GET_LARGE_ARG;
    2253 2577 
                 StgClosure* con = UNTAG_CLOSURE((StgClosure*)ReadSpW(0));
    2254 2578 
                 if (GET_TAG(con) >= discr) {
    2255 2579 
                     bciPtr = failto;
    2256 2580 
                 }
    2257 
    -            goto nextInsn;
    2581 
    +            NEXT_INSTRUCTION;
    2258 2582 
             }
    2259 2583
    2260 
    -        case bci_TESTEQ_P: {
    2584 
    +        INSTRUCTION(bci_TESTEQ_P): {
    2261 2585 
                 unsigned int discr  = BCO_NEXT;
    2262 2586 
                 int failto = BCO_GET_LARGE_ARG;
    2263 2587 
                 StgClosure* con = UNTAG_CLOSURE((StgClosure*)ReadSpW(0));
    2264 2588 
                 if (GET_TAG(con) != discr) {
    2265 2589 
                     bciPtr = failto;
    2266 2590 
                 }
    2267 
    -            goto nextInsn;
    2591 
    +            NEXT_INSTRUCTION;
    2268 2592 
             }
    2269 2593
    2270 
    -        case bci_TESTLT_I: {
    2594 
    +        INSTRUCTION(bci_TESTLT_I): {
    2271 2595 
                 int discr   = BCO_GET_LARGE_ARG;
    2272 2596 
                 int failto  = BCO_GET_LARGE_ARG;
    2273 2597 
                 I_ stackInt = (I_)ReadSpW(0);
    2274 2598 
                 if (stackInt >= (I_)BCO_LIT(discr))
    2275 2599 
                     bciPtr = failto;
    2276 
    -            goto nextInsn;
    2600 
    +            NEXT_INSTRUCTION;
    2277 2601 
             }
    2278 2602
    2279 
    -        case bci_TESTLT_I64: {
    2603 
    +        INSTRUCTION(bci_TESTLT_I64): {
    2280 2604 
                 int discr   = BCO_GET_LARGE_ARG;
    2281 2605 
                 int failto  = BCO_GET_LARGE_ARG;
    2282 2606 
                 StgInt64 stackInt = ReadSpW64(0);
    2283 2607 
                 if (stackInt >= BCO_LITI64(discr))
    2284 2608 
                     bciPtr = failto;
    2285 
    -            goto nextInsn;
    2609 
    +            NEXT_INSTRUCTION;
    2286 2610 
             }
    2287 2611
    2288 
    -        case bci_TESTLT_I32: {
    2612 
    +        INSTRUCTION(bci_TESTLT_I32): {
    2289 2613 
                 int discr   = BCO_GET_LARGE_ARG;
    2290 2614 
                 int failto  = BCO_GET_LARGE_ARG;
    2291 2615 
                 StgInt32 stackInt = (StgInt32) ReadSpW(0);
    2292 2616 
                 if (stackInt >= (StgInt32)BCO_LIT(discr))
    2293 2617 
                     bciPtr = failto;
    2294 
    -            goto nextInsn;
    2618 
    +            NEXT_INSTRUCTION;
    2295 2619 
             }
    2296 2620
    2297 
    -        case bci_TESTLT_I16: {
    2621 
    +        INSTRUCTION(bci_TESTLT_I16): {
    2298 2622 
                 int discr   = BCO_GET_LARGE_ARG;
    2299 2623 
                 int failto  = BCO_GET_LARGE_ARG;
    2300 2624 
                 StgInt16 stackInt = (StgInt16) ReadSpW(0);
    2301 2625 
                 if (stackInt >= (StgInt16)BCO_LIT(discr))
    2302 2626 
                     bciPtr = failto;
    2303 
    -            goto nextInsn;
    2627 
    +            NEXT_INSTRUCTION;
    2304 2628 
             }
    2305 2629
    2306 
    -        case bci_TESTLT_I8: {
    2630 
    +        INSTRUCTION(bci_TESTLT_I8): {
    2307 2631 
                 int discr   = BCO_GET_LARGE_ARG;
    2308 2632 
                 int failto  = BCO_GET_LARGE_ARG;
    2309 2633 
                 StgInt8 stackInt = (StgInt8) ReadSpW(0);
    2310 2634 
                 if (stackInt >= (StgInt8)BCO_LIT(discr))
    2311 2635 
                     bciPtr = failto;
    2312 
    -            goto nextInsn;
    2636 
    +            NEXT_INSTRUCTION;
    2313 2637 
             }
    2314 2638
    2315 
    -        case bci_TESTEQ_I: {
    2639 
    +        INSTRUCTION(bci_TESTEQ_I): {
    2316 2640 
                 int discr   = BCO_GET_LARGE_ARG;
    2317 2641 
                 int failto  = BCO_GET_LARGE_ARG;
    2318 2642 
                 I_ stackInt = (I_)ReadSpW(0);
    2319 2643 
                 if (stackInt != (I_)BCO_LIT(discr)) {
    2320 2644 
                     bciPtr = failto;
    2321 2645 
                 }
    2322 
    -            goto nextInsn;
    2646 
    +            NEXT_INSTRUCTION;
    2323 2647 
             }
    2324 2648
    2325 
    -        case bci_TESTEQ_I64: {
    2649 
    +        INSTRUCTION(bci_TESTEQ_I64): {
    2326 2650 
                 int discr   = BCO_GET_LARGE_ARG;
    2327 2651 
                 int failto  = BCO_GET_LARGE_ARG;
    2328 2652 
                 StgInt64 stackInt = ReadSpW64(0);
    2329 2653 
                 if (stackInt != BCO_LITI64(discr)) {
    2330 2654 
                     bciPtr = failto;
    2331 2655 
                 }
    2332 
    -            goto nextInsn;
    2656 
    +            NEXT_INSTRUCTION;
    2333 2657 
             }
    2334 2658
    2335 
    -        case bci_TESTEQ_I32: {
    2659 
    +        INSTRUCTION(bci_TESTEQ_I32): {
    2336 2660 
                 int discr   = BCO_GET_LARGE_ARG;
    2337 2661 
                 int failto  = BCO_GET_LARGE_ARG;
    2338 2662 
                 StgInt32 stackInt = (StgInt32) ReadSpW(0);
    2339 2663 
                 if (stackInt != (StgInt32)BCO_LIT(discr)) {
    2340 2664 
                     bciPtr = failto;
    2341 2665 
                 }
    2342 
    -            goto nextInsn;
    2666 
    +            NEXT_INSTRUCTION;
    2343 2667 
             }
    2344 2668
    2345 
    -        case bci_TESTEQ_I16: {
    2669 
    +        INSTRUCTION(bci_TESTEQ_I16): {
    2346 2670 
                 int discr   = BCO_GET_LARGE_ARG;
    2347 2671 
                 int failto  = BCO_GET_LARGE_ARG;
    2348 2672 
                 StgInt16 stackInt = (StgInt16) ReadSpW(0);
    2349 2673 
                 if (stackInt != (StgInt16)BCO_LIT(discr)) {
    2350 2674 
                     bciPtr = failto;
    2351 2675 
                 }
    2352 
    -            goto nextInsn;
    2676 
    +            NEXT_INSTRUCTION;
    2353 2677 
             }
    2354 2678
    2355 
    -        case bci_TESTEQ_I8: {
    2679 
    +        INSTRUCTION(bci_TESTEQ_I8): {
    2356 2680 
                 int discr   = BCO_GET_LARGE_ARG;
    2357 2681 
                 int failto  = BCO_GET_LARGE_ARG;
    2358 2682 
                 StgInt8 stackInt = (StgInt8) ReadSpW(0);
    2359 2683 
                 if (stackInt != (StgInt8)BCO_LIT(discr)) {
    2360 2684 
                     bciPtr = failto;
    2361 2685 
                 }
    2362 
    -            goto nextInsn;
    2686 
    +            NEXT_INSTRUCTION;
    2363 2687 
             }
    2364 2688
    2365 
    -        case bci_TESTLT_W: {
    2689 
    +        INSTRUCTION(bci_TESTLT_W): {
    2366 2690 
                 int discr   = BCO_GET_LARGE_ARG;
    2367 2691 
                 int failto  = BCO_GET_LARGE_ARG;
    2368 2692 
                 W_ stackWord = (W_)ReadSpW(0);
    2369 2693 
                 if (stackWord >= (W_)BCO_LIT(discr))
    2370 2694 
                     bciPtr = failto;
    2371 
    -            goto nextInsn;
    2695 
    +            NEXT_INSTRUCTION;
    2372 2696 
             }
    2373 2697
    2374 
    -        case bci_TESTLT_W64: {
    2698 
    +        INSTRUCTION(bci_TESTLT_W64): {
    2375 2699 
                 int discr   = BCO_GET_LARGE_ARG;
    2376 2700 
                 int failto  = BCO_GET_LARGE_ARG;
    2377 2701 
                 StgWord64 stackWord = ReadSpW64(0);
    2378 2702 
                 if (stackWord >= BCO_LITW64(discr))
    2379 2703 
                     bciPtr = failto;
    2380 
    -            goto nextInsn;
    2704 
    +            NEXT_INSTRUCTION;
    2381 2705 
             }
    2382 2706
    2383 
    -        case bci_TESTLT_W32: {
    2707 
    +        INSTRUCTION(bci_TESTLT_W32): {
    2384 2708 
                 int discr   = BCO_GET_LARGE_ARG;
    2385 2709 
                 int failto  = BCO_GET_LARGE_ARG;
    2386 2710 
                 StgWord32 stackWord = (StgWord32) ReadSpW(0);
    2387 2711 
                 if (stackWord >= (StgWord32)BCO_LIT(discr))
    2388 2712 
                     bciPtr = failto;
    2389 
    -            goto nextInsn;
    2713 
    +            NEXT_INSTRUCTION;
    2390 2714 
             }
    2391 2715
    2392 
    -        case bci_TESTLT_W16: {
    2716 
    +        INSTRUCTION(bci_TESTLT_W16): {
    2393 2717 
                 int discr   = BCO_GET_LARGE_ARG;
    2394 2718 
                 int failto  = BCO_GET_LARGE_ARG;
    2395 2719 
                 StgWord16 stackWord = (StgInt16) ReadSpW(0);
    2396 2720 
                 if (stackWord >= (StgWord16)BCO_LIT(discr))
    2397 2721 
                     bciPtr = failto;
    2398 
    -            goto nextInsn;
    2722 
    +            NEXT_INSTRUCTION;
    2399 2723 
             }
    2400 2724
    2401 
    -        case bci_TESTLT_W8: {
    2725 
    +        INSTRUCTION(bci_TESTLT_W8): {
    2402 2726 
                 int discr   = BCO_GET_LARGE_ARG;
    2403 2727 
                 int failto  = BCO_GET_LARGE_ARG;
    2404 2728 
                 StgWord8 stackWord = (StgInt8) ReadSpW(0);
    2405 2729 
                 if (stackWord >= (StgWord8)BCO_LIT(discr))
    2406 2730 
                     bciPtr = failto;
    2407 
    -            goto nextInsn;
    2731 
    +            NEXT_INSTRUCTION;
    2408 2732 
             }
    2409 2733
    2410 
    -        case bci_TESTEQ_W: {
    2734 
    +        INSTRUCTION(bci_TESTEQ_W): {
    2411 2735 
                 int discr   = BCO_GET_LARGE_ARG;
    2412 2736 
                 int failto  = BCO_GET_LARGE_ARG;
    2413 2737 
                 W_ stackWord = (W_)ReadSpW(0);
    2414 2738 
                 if (stackWord != (W_)BCO_LIT(discr)) {
    2415 2739 
                     bciPtr = failto;
    2416 2740 
                 }
    2417 
    -            goto nextInsn;
    2741 
    +            NEXT_INSTRUCTION;
    2418 2742 
             }
    2419 2743
    2420 
    -        case bci_TESTEQ_W64: {
    2744 
    +        INSTRUCTION(bci_TESTEQ_W64): {
    2421 2745 
                 int discr   = BCO_GET_LARGE_ARG;
    2422 2746 
                 int failto  = BCO_GET_LARGE_ARG;
    2423 2747 
                 StgWord64 stackWord = ReadSpW64(0);
    2424 2748 
                 if (stackWord != BCO_LITW64(discr)) {
    2425 2749 
                     bciPtr = failto;
    2426 2750 
                 }
    2427 
    -            goto nextInsn;
    2751 
    +            NEXT_INSTRUCTION;
    2428 2752 
             }
    2429 2753
    2430 
    -        case bci_TESTEQ_W32: {
    2754 
    +        INSTRUCTION(bci_TESTEQ_W32): {
    2431 2755 
                 int discr   = BCO_GET_LARGE_ARG;
    2432 2756 
                 int failto  = BCO_GET_LARGE_ARG;
    2433 2757 
                 StgWord32 stackWord = (StgWord32) ReadSpW(0);
    2434 2758 
                 if (stackWord != (StgWord32)BCO_LIT(discr)) {
    2435 2759 
                     bciPtr = failto;
    2436 2760 
                 }
    2437 
    -            goto nextInsn;
    2761 
    +            NEXT_INSTRUCTION;
    2438 2762 
             }
    2439 2763
    2440 
    -        case bci_TESTEQ_W16: {
    2764 
    +        INSTRUCTION(bci_TESTEQ_W16): {
    2441 2765 
                 int discr   = BCO_GET_LARGE_ARG;
    2442 2766 
                 int failto  = BCO_GET_LARGE_ARG;
    2443 2767 
                 StgWord16 stackWord = (StgWord16) ReadSpW(0);
    2444 2768 
                 if (stackWord != (StgWord16)BCO_LIT(discr)) {
    2445 2769 
                     bciPtr = failto;
    2446 2770 
                 }
    2447 
    -            goto nextInsn;
    2771 
    +            NEXT_INSTRUCTION;
    2448 2772 
             }
    2449 2773
    2450 
    -        case bci_TESTEQ_W8: {
    2774 
    +        INSTRUCTION(bci_TESTEQ_W8): {
    2451 2775 
                 int discr   = BCO_GET_LARGE_ARG;
    2452 2776 
                 int failto  = BCO_GET_LARGE_ARG;
    2453 2777 
                 StgWord8 stackWord = (StgWord8) ReadSpW(0);
    2454 2778 
                 if (stackWord != (StgWord8)BCO_LIT(discr)) {
    2455 2779 
                     bciPtr = failto;
    2456 2780 
                 }
    2457 
    -            goto nextInsn;
    2781 
    +            NEXT_INSTRUCTION;
    2458 2782 
             }
    2459 2783
    2460 
    -        case bci_TESTLT_D: {
    2784 
    +        INSTRUCTION(bci_TESTLT_D): {
    2461 2785 
                 int discr   = BCO_GET_LARGE_ARG;
    2462 2786 
                 int failto  = BCO_GET_LARGE_ARG;
    2463 2787 
                 StgDouble stackDbl, discrDbl;
    ... ... @@ -2466,10 +2790,10 @@ run_BCO:
    2466 2790 
                 if (stackDbl >= discrDbl) {
    2467 2791 
                     bciPtr = failto;
    2468 2792 
                 }
    2469 
    -            goto nextInsn;
    2793 
    +            NEXT_INSTRUCTION;
    2470 2794 
             }
    2471 2795
    2472 
    -        case bci_TESTEQ_D: {
    2796 
    +        INSTRUCTION(bci_TESTEQ_D): {
    2473 2797 
                 int discr   = BCO_GET_LARGE_ARG;
    2474 2798 
                 int failto  = BCO_GET_LARGE_ARG;
    2475 2799 
                 StgDouble stackDbl, discrDbl;
    ... ... @@ -2478,10 +2802,10 @@ run_BCO:
    2478 2802 
                 if (stackDbl != discrDbl) {
    2479 2803 
                     bciPtr = failto;
    2480 2804 
                 }
    2481 
    -            goto nextInsn;
    2805 
    +            NEXT_INSTRUCTION;
    2482 2806 
             }
    2483 2807
    2484 
    -        case bci_TESTLT_F: {
    2808 
    +        INSTRUCTION(bci_TESTLT_F): {
    2485 2809 
                 int discr   = BCO_GET_LARGE_ARG;
    2486 2810 
                 int failto  = BCO_GET_LARGE_ARG;
    2487 2811 
                 StgFloat stackFlt, discrFlt;
    ... ... @@ -2490,10 +2814,10 @@ run_BCO:
    2490 2814 
                 if (stackFlt >= discrFlt) {
    2491 2815 
                     bciPtr = failto;
    2492 2816 
                 }
    2493 
    -            goto nextInsn;
    2817 
    +            NEXT_INSTRUCTION;
    2494 2818 
             }
    2495 2819
    2496 
    -        case bci_TESTEQ_F: {
    2820 
    +        INSTRUCTION(bci_TESTEQ_F): {
    2497 2821 
                 int discr   = BCO_GET_LARGE_ARG;
    2498 2822 
                 int failto  = BCO_GET_LARGE_ARG;
    2499 2823 
                 StgFloat stackFlt, discrFlt;
    ... ... @@ -2502,11 +2826,11 @@ run_BCO:
    2502 2826 
                 if (stackFlt != discrFlt) {
    2503 2827 
                     bciPtr = failto;
    2504 2828 
                 }
    2505 
    -            goto nextInsn;
    2829 
    +            NEXT_INSTRUCTION;
    2506 2830 
             }
    2507 2831
    2508 2832 
             // Control-flow ish things
    2509 
    -        case bci_ENTER:
    2833 
    +        INSTRUCTION(bci_ENTER):
    2510 2834 
                 // Context-switch check.  We put it here to ensure that
    2511 2835 
                 // the interpreter has done at least *some* work before
    2512 2836 
                 // context switching: sometimes the scheduler can invoke
    ... ... @@ -2518,50 +2842,50 @@ run_BCO:
    2518 2842 
                 }
    2519 2843 
                 goto eval;
    2520 2844
    2521 
    -        case bci_RETURN_P:
    2845 
    +        INSTRUCTION(bci_RETURN_P):
    2522 2846 
                 tagged_obj = (StgClosure *)ReadSpW(0);
    2523 2847 
                 Sp_addW(1);
    2524 2848 
                 goto do_return_pointer;
    2525 2849
    2526 
    -        case bci_RETURN_N:
    2850 
    +        INSTRUCTION(bci_RETURN_N):
    2527 2851 
                 Sp_subW(1);
    2528 2852 
                 SpW(0) = (W_)&stg_ret_n_info;
    2529 2853 
                 goto do_return_nonpointer;
    2530 
    -        case bci_RETURN_F:
    2854 
    +        INSTRUCTION(bci_RETURN_F):
    2531 2855 
                 Sp_subW(1);
    2532 2856 
                 SpW(0) = (W_)&stg_ret_f_info;
    2533 2857 
                 goto do_return_nonpointer;
    2534 
    -        case bci_RETURN_D:
    2858 
    +        INSTRUCTION(bci_RETURN_D):
    2535 2859 
                 Sp_subW(1);
    2536 2860 
                 SpW(0) = (W_)&stg_ret_d_info;
    2537 2861 
                 goto do_return_nonpointer;
    2538 
    -        case bci_RETURN_L:
    2862 
    +        INSTRUCTION(bci_RETURN_L):
    2539 2863 
                 Sp_subW(1);
    2540 2864 
                 SpW(0) = (W_)&stg_ret_l_info;
    2541 2865 
                 goto do_return_nonpointer;
    2542 
    -        case bci_RETURN_V:
    2866 
    +        INSTRUCTION(bci_RETURN_V):
    2543 2867 
                 Sp_subW(1);
    2544 2868 
                 SpW(0) = (W_)&stg_ret_v_info;
    2545 2869 
                 goto do_return_nonpointer;
    2546 
    -        case bci_RETURN_T: {
    2870 
    +        INSTRUCTION(bci_RETURN_T): {
    2547 2871 
                 /* tuple_info and tuple_bco must already be on the stack */
    2548 2872 
                 Sp_subW(1);
    2549 2873 
                 SpW(0) = (W_)&stg_ret_t_info;
    2550 2874 
                 goto do_return_nonpointer;
    2551 2875 
             }
    2552 2876
    2553 
    -        case bci_BCO_NAME:
    2877 
    +        INSTRUCTION(bci_BCO_NAME):
    2554 2878 
                 bciPtr++;
    2555 
    -            goto nextInsn;
    2879 
    +            NEXT_INSTRUCTION;
    2556 2880
    2557 
    -        case bci_SWIZZLE: {
    2881 
    +        INSTRUCTION(bci_SWIZZLE): {
    2558 2882 
                 W_ stkoff = BCO_GET_LARGE_ARG;
    2559 2883 
                 StgInt n = BCO_GET_LARGE_ARG;
    2560 2884 
                 (*(StgInt*)(SafeSpWP(stkoff))) += n;
    2561 
    -            goto nextInsn;
    2885 
    +            NEXT_INSTRUCTION;
    2562 2886 
             }
    2563 2887
    2564 
    -        case bci_PRIMCALL: {
    2888 
    +        INSTRUCTION(bci_PRIMCALL): {
    2565 2889 
                 Sp_subW(1);
    2566 2890 
                 SpW(0) = (W_)&stg_primcall_info;
    2567 2891 
                 RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
    ... ... @@ -2577,7 +2901,7 @@ run_BCO:
    2577 2901 
                 ty r = op ((ty) ReadSpW(0));                          \
    2578 2902 
                 SpW(0) = (StgWord) r;                                   \
    2579 2903 
             }                                                           \
    2580 
    -        goto nextInsn;                                              \
    2904 
    +        NEXT_INSTRUCTION;                                              \
    2581 2905 
         }
    2582 2906
    2583 2907 
     // op :: ty -> ty -> ty
    ... ... @@ -2592,7 +2916,7 @@ run_BCO:
    2592 2916 
                     Sp_addW(1);                                                     \
    2593 2917 
                     SpW(0) = (StgWord) r;                                           \
    2594 2918 
                 };                                                                  \
    2595 
    -            goto nextInsn;                                                      \
    2919 
    +            NEXT_INSTRUCTION;                                                      \
    2596 2920 
             }
    2597 2921
    2598 2922 
     // op :: ty -> Int -> ty
    ... ... @@ -2607,7 +2931,7 @@ run_BCO:
    2607 2931 
             Sp_addW(1);                                                     \
    2608 2932 
             SpW(0) = (StgWord) r;                                           \
    2609 2933 
         };                                                                  \
    2610 
    -    goto nextInsn;                                                      \
    2934 
    +    NEXT_INSTRUCTION;                                                      \
    2611 2935 
     }
    2612 2936
    2613 2937 
     // op :: ty -> ty -> Int
    ... ... @@ -2622,113 +2946,113 @@ run_BCO:
    2622 2946 
             Sp_addW(1);                                                     \
    2623 2947 
             SpW(0) = (StgWord) r;                                           \
    2624 2948 
         };                                                                  \
    2625 
    -    goto nextInsn;                                                      \
    2949 
    +    NEXT_INSTRUCTION;                                                      \
    2626 2950 
     }
    2627 2951
    2628 
    -        case bci_OP_ADD_64: SIZED_BIN_OP(+, StgInt64)
    2629 
    -        case bci_OP_SUB_64: SIZED_BIN_OP(-, StgInt64)
    2630 
    -        case bci_OP_AND_64: SIZED_BIN_OP(&, StgInt64)
    2631 
    -        case bci_OP_XOR_64: SIZED_BIN_OP(^, StgInt64)
    2632 
    -        case bci_OP_OR_64:  SIZED_BIN_OP(|, StgInt64)
    2633 
    -        case bci_OP_MUL_64: SIZED_BIN_OP(*, StgInt64)
    2634 
    -        case bci_OP_SHL_64: SIZED_BIN_OP_TY_INT(<<, StgWord64)
    2635 
    -        case bci_OP_LSR_64: SIZED_BIN_OP_TY_INT(>>, StgWord64)
    2636 
    -        case bci_OP_ASR_64: SIZED_BIN_OP_TY_INT(>>, StgInt64)
    2637 
    -
    2638 
    -        case bci_OP_NEQ_64:  SIZED_BIN_OP_TY_TY_INT(!=, StgWord64)
    2639 
    -        case bci_OP_EQ_64:   SIZED_BIN_OP_TY_TY_INT(==, StgWord64)
    2640 
    -        case bci_OP_U_GT_64: SIZED_BIN_OP_TY_TY_INT(>, StgWord64)
    2641 
    -        case bci_OP_U_GE_64: SIZED_BIN_OP_TY_TY_INT(>=, StgWord64)
    2642 
    -        case bci_OP_U_LT_64: SIZED_BIN_OP_TY_TY_INT(<, StgWord64)
    2643 
    -        case bci_OP_U_LE_64: SIZED_BIN_OP_TY_TY_INT(<=, StgWord64)
    2644 
    -
    2645 
    -        case bci_OP_S_GT_64: SIZED_BIN_OP_TY_TY_INT(>, StgInt64)
    2646 
    -        case bci_OP_S_GE_64: SIZED_BIN_OP_TY_TY_INT(>=, StgInt64)
    2647 
    -        case bci_OP_S_LT_64: SIZED_BIN_OP_TY_TY_INT(<, StgInt64)
    2648 
    -        case bci_OP_S_LE_64: SIZED_BIN_OP_TY_TY_INT(<=, StgInt64)
    2649 
    -
    2650 
    -        case bci_OP_NOT_64: UN_SIZED_OP(~, StgWord64)
    2651 
    -        case bci_OP_NEG_64: UN_SIZED_OP(-, StgInt64)
    2652 
    -
    2653 
    -
    2654 
    -        case bci_OP_ADD_32: SIZED_BIN_OP(+, StgInt32)
    2655 
    -        case bci_OP_SUB_32: SIZED_BIN_OP(-, StgInt32)
    2656 
    -        case bci_OP_AND_32: SIZED_BIN_OP(&, StgInt32)
    2657 
    -        case bci_OP_XOR_32: SIZED_BIN_OP(^, StgInt32)
    2658 
    -        case bci_OP_OR_32:  SIZED_BIN_OP(|, StgInt32)
    2659 
    -        case bci_OP_MUL_32: SIZED_BIN_OP(*, StgInt32)
    2660 
    -        case bci_OP_SHL_32: SIZED_BIN_OP_TY_INT(<<, StgWord32)
    2661 
    -        case bci_OP_LSR_32: SIZED_BIN_OP_TY_INT(>>, StgWord32)
    2662 
    -        case bci_OP_ASR_32: SIZED_BIN_OP_TY_INT(>>, StgInt32)
    2663 
    -
    2664 
    -        case bci_OP_NEQ_32:  SIZED_BIN_OP_TY_TY_INT(!=, StgWord32)
    2665 
    -        case bci_OP_EQ_32:   SIZED_BIN_OP_TY_TY_INT(==, StgWord32)
    2666 
    -        case bci_OP_U_GT_32: SIZED_BIN_OP_TY_TY_INT(>, StgWord32)
    2667 
    -        case bci_OP_U_GE_32: SIZED_BIN_OP_TY_TY_INT(>=, StgWord32)
    2668 
    -        case bci_OP_U_LT_32: SIZED_BIN_OP_TY_TY_INT(<, StgWord32)
    2669 
    -        case bci_OP_U_LE_32: SIZED_BIN_OP_TY_TY_INT(<=, StgWord32)
    2670 
    -
    2671 
    -        case bci_OP_S_GT_32: SIZED_BIN_OP_TY_TY_INT(>, StgInt32)
    2672 
    -        case bci_OP_S_GE_32: SIZED_BIN_OP_TY_TY_INT(>=, StgInt32)
    2673 
    -        case bci_OP_S_LT_32: SIZED_BIN_OP_TY_TY_INT(<, StgInt32)
    2674 
    -        case bci_OP_S_LE_32: SIZED_BIN_OP_TY_TY_INT(<=, StgInt32)
    2675 
    -
    2676 
    -        case bci_OP_NOT_32: UN_SIZED_OP(~, StgWord32)
    2677 
    -        case bci_OP_NEG_32: UN_SIZED_OP(-, StgInt32)
    2678 
    -
    2679 
    -
    2680 
    -        case bci_OP_ADD_16: SIZED_BIN_OP(+, StgInt16)
    2681 
    -        case bci_OP_SUB_16: SIZED_BIN_OP(-, StgInt16)
    2682 
    -        case bci_OP_AND_16: SIZED_BIN_OP(&, StgInt16)
    2683 
    -        case bci_OP_XOR_16: SIZED_BIN_OP(^, StgInt16)
    2684 
    -        case bci_OP_OR_16:  SIZED_BIN_OP(|, StgInt16)
    2685 
    -        case bci_OP_MUL_16: SIZED_BIN_OP(*, StgInt16)
    2686 
    -        case bci_OP_SHL_16: SIZED_BIN_OP_TY_INT(<<, StgWord16)
    2687 
    -        case bci_OP_LSR_16: SIZED_BIN_OP_TY_INT(>>, StgWord16)
    2688 
    -        case bci_OP_ASR_16: SIZED_BIN_OP_TY_INT(>>, StgInt16)
    2689 
    -
    2690 
    -        case bci_OP_NEQ_16:  SIZED_BIN_OP_TY_TY_INT(!=, StgWord16)
    2691 
    -        case bci_OP_EQ_16:   SIZED_BIN_OP_TY_TY_INT(==, StgWord16)
    2692 
    -        case bci_OP_U_GT_16: SIZED_BIN_OP_TY_TY_INT(>, StgWord16)
    2693 
    -        case bci_OP_U_GE_16: SIZED_BIN_OP_TY_TY_INT(>=, StgWord16)
    2694 
    -        case bci_OP_U_LT_16: SIZED_BIN_OP_TY_TY_INT(<, StgWord16)
    2695 
    -        case bci_OP_U_LE_16: SIZED_BIN_OP_TY_TY_INT(<=, StgWord16)
    2696 
    -
    2697 
    -        case bci_OP_S_GT_16: SIZED_BIN_OP(>, StgInt16)
    2698 
    -        case bci_OP_S_GE_16: SIZED_BIN_OP(>=, StgInt16)
    2699 
    -        case bci_OP_S_LT_16: SIZED_BIN_OP(<, StgInt16)
    2700 
    -        case bci_OP_S_LE_16: SIZED_BIN_OP(<=, StgInt16)
    2701 
    -
    2702 
    -        case bci_OP_NOT_16: UN_SIZED_OP(~, StgWord16)
    2703 
    -        case bci_OP_NEG_16: UN_SIZED_OP(-, StgInt16)
    2704 
    -
    2705 
    -
    2706 
    -        case bci_OP_ADD_08: SIZED_BIN_OP(+, StgInt8)
    2707 
    -        case bci_OP_SUB_08: SIZED_BIN_OP(-, StgInt8)
    2708 
    -        case bci_OP_AND_08: SIZED_BIN_OP(&, StgInt8)
    2709 
    -        case bci_OP_XOR_08: SIZED_BIN_OP(^, StgInt8)
    2710 
    -        case bci_OP_OR_08:  SIZED_BIN_OP(|, StgInt8)
    2711 
    -        case bci_OP_MUL_08: SIZED_BIN_OP(*, StgInt8)
    2712 
    -        case bci_OP_SHL_08: SIZED_BIN_OP_TY_INT(<<, StgWord8)
    2713 
    -        case bci_OP_LSR_08: SIZED_BIN_OP_TY_INT(>>, StgWord8)
    2714 
    -        case bci_OP_ASR_08: SIZED_BIN_OP_TY_INT(>>, StgInt8)
    2715 
    -
    2716 
    -        case bci_OP_NEQ_08:  SIZED_BIN_OP_TY_TY_INT(!=, StgWord8)
    2717 
    -        case bci_OP_EQ_08:   SIZED_BIN_OP_TY_TY_INT(==, StgWord8)
    2718 
    -        case bci_OP_U_GT_08: SIZED_BIN_OP_TY_TY_INT(>, StgWord8)
    2719 
    -        case bci_OP_U_GE_08: SIZED_BIN_OP_TY_TY_INT(>=, StgWord8)
    2720 
    -        case bci_OP_U_LT_08: SIZED_BIN_OP_TY_TY_INT(<, StgWord8)
    2721 
    -        case bci_OP_U_LE_08: SIZED_BIN_OP_TY_TY_INT(<=, StgWord8)
    2722 
    -
    2723 
    -        case bci_OP_S_GT_08: SIZED_BIN_OP_TY_TY_INT(>, StgInt8)
    2724 
    -        case bci_OP_S_GE_08: SIZED_BIN_OP_TY_TY_INT(>=, StgInt8)
    2725 
    -        case bci_OP_S_LT_08: SIZED_BIN_OP_TY_TY_INT(<, StgInt8)
    2726 
    -        case bci_OP_S_LE_08: SIZED_BIN_OP_TY_TY_INT(<=, StgInt8)
    2727 
    -
    2728 
    -        case bci_OP_NOT_08: UN_SIZED_OP(~, StgWord8)
    2729 
    -        case bci_OP_NEG_08: UN_SIZED_OP(-, StgInt8)
    2730 
    -
    2731 
    -        case bci_OP_INDEX_ADDR_64:
    2952 
    +        INSTRUCTION(bci_OP_ADD_64): SIZED_BIN_OP(+, StgInt64)
    2953 
    +        INSTRUCTION(bci_OP_SUB_64): SIZED_BIN_OP(-, StgInt64)
    2954 
    +        INSTRUCTION(bci_OP_AND_64): SIZED_BIN_OP(&, StgInt64)
    2955 
    +        INSTRUCTION(bci_OP_XOR_64): SIZED_BIN_OP(^, StgInt64)
    2956 
    +        INSTRUCTION(bci_OP_OR_64):  SIZED_BIN_OP(|, StgInt64)
    2957 
    +        INSTRUCTION(bci_OP_MUL_64): SIZED_BIN_OP(*, StgInt64)
    2958 
    +        INSTRUCTION(bci_OP_SHL_64): SIZED_BIN_OP_TY_INT(<<, StgWord64)
    2959 
    +        INSTRUCTION(bci_OP_LSR_64): SIZED_BIN_OP_TY_INT(>>, StgWord64)
    2960 
    +        INSTRUCTION(bci_OP_ASR_64): SIZED_BIN_OP_TY_INT(>>, StgInt64)
    2961 
    +
    2962 
    +        INSTRUCTION(bci_OP_NEQ_64):  SIZED_BIN_OP_TY_TY_INT(!=, StgWord64)
    2963 
    +        INSTRUCTION(bci_OP_EQ_64):   SIZED_BIN_OP_TY_TY_INT(==, StgWord64)
    2964 
    +        INSTRUCTION(bci_OP_U_GT_64): SIZED_BIN_OP_TY_TY_INT(>, StgWord64)
    2965 
    +        INSTRUCTION(bci_OP_U_GE_64): SIZED_BIN_OP_TY_TY_INT(>=, StgWord64)
    2966 
    +        INSTRUCTION(bci_OP_U_LT_64): SIZED_BIN_OP_TY_TY_INT(<, StgWord64)
    2967 
    +        INSTRUCTION(bci_OP_U_LE_64): SIZED_BIN_OP_TY_TY_INT(<=, StgWord64)
    2968 
    +
    2969 
    +        INSTRUCTION(bci_OP_S_GT_64): SIZED_BIN_OP_TY_TY_INT(>, StgInt64)
    2970 
    +        INSTRUCTION(bci_OP_S_GE_64): SIZED_BIN_OP_TY_TY_INT(>=, StgInt64)
    2971 
    +        INSTRUCTION(bci_OP_S_LT_64): SIZED_BIN_OP_TY_TY_INT(<, StgInt64)
    2972 
    +        INSTRUCTION(bci_OP_S_LE_64): SIZED_BIN_OP_TY_TY_INT(<=, StgInt64)
    2973 
    +
    2974 
    +        INSTRUCTION(bci_OP_NOT_64): UN_SIZED_OP(~, StgWord64)
    2975 
    +        INSTRUCTION(bci_OP_NEG_64): UN_SIZED_OP(-, StgInt64)
    2976 
    +
    2977 
    +
    2978 
    +        INSTRUCTION(bci_OP_ADD_32): SIZED_BIN_OP(+, StgInt32)
    2979 
    +        INSTRUCTION(bci_OP_SUB_32): SIZED_BIN_OP(-, StgInt32)
    2980 
    +        INSTRUCTION(bci_OP_AND_32): SIZED_BIN_OP(&, StgInt32)
    2981 
    +        INSTRUCTION(bci_OP_XOR_32): SIZED_BIN_OP(^, StgInt32)
    2982 
    +        INSTRUCTION(bci_OP_OR_32):  SIZED_BIN_OP(|, StgInt32)
    2983 
    +        INSTRUCTION(bci_OP_MUL_32): SIZED_BIN_OP(*, StgInt32)
    2984 
    +        INSTRUCTION(bci_OP_SHL_32): SIZED_BIN_OP_TY_INT(<<, StgWord32)
    2985 
    +        INSTRUCTION(bci_OP_LSR_32): SIZED_BIN_OP_TY_INT(>>, StgWord32)
    2986 
    +        INSTRUCTION(bci_OP_ASR_32): SIZED_BIN_OP_TY_INT(>>, StgInt32)
    2987 
    +
    2988 
    +        INSTRUCTION(bci_OP_NEQ_32):  SIZED_BIN_OP_TY_TY_INT(!=, StgWord32)
    2989 
    +        INSTRUCTION(bci_OP_EQ_32):   SIZED_BIN_OP_TY_TY_INT(==, StgWord32)
    2990 
    +        INSTRUCTION(bci_OP_U_GT_32): SIZED_BIN_OP_TY_TY_INT(>, StgWord32)
    2991 
    +        INSTRUCTION(bci_OP_U_GE_32): SIZED_BIN_OP_TY_TY_INT(>=, StgWord32)
    2992 
    +        INSTRUCTION(bci_OP_U_LT_32): SIZED_BIN_OP_TY_TY_INT(<, StgWord32)
    2993 
    +        INSTRUCTION(bci_OP_U_LE_32): SIZED_BIN_OP_TY_TY_INT(<=, StgWord32)
    2994 
    +
    2995 
    +        INSTRUCTION(bci_OP_S_GT_32): SIZED_BIN_OP_TY_TY_INT(>, StgInt32)
    2996 
    +        INSTRUCTION(bci_OP_S_GE_32): SIZED_BIN_OP_TY_TY_INT(>=, StgInt32)
    2997 
    +        INSTRUCTION(bci_OP_S_LT_32): SIZED_BIN_OP_TY_TY_INT(<, StgInt32)
    2998 
    +        INSTRUCTION(bci_OP_S_LE_32): SIZED_BIN_OP_TY_TY_INT(<=, StgInt32)
    2999 
    +
    3000 
    +        INSTRUCTION(bci_OP_NOT_32): UN_SIZED_OP(~, StgWord32)
    3001 
    +        INSTRUCTION(bci_OP_NEG_32): UN_SIZED_OP(-, StgInt32)
    3002 
    +
    3003 
    +
    3004 
    +        INSTRUCTION(bci_OP_ADD_16): SIZED_BIN_OP(+, StgInt16)
    3005 
    +        INSTRUCTION(bci_OP_SUB_16): SIZED_BIN_OP(-, StgInt16)
    3006 
    +        INSTRUCTION(bci_OP_AND_16): SIZED_BIN_OP(&, StgInt16)
    3007 
    +        INSTRUCTION(bci_OP_XOR_16): SIZED_BIN_OP(^, StgInt16)
    3008 
    +        INSTRUCTION(bci_OP_OR_16):  SIZED_BIN_OP(|, StgInt16)
    3009 
    +        INSTRUCTION(bci_OP_MUL_16): SIZED_BIN_OP(*, StgInt16)
    3010 
    +        INSTRUCTION(bci_OP_SHL_16): SIZED_BIN_OP_TY_INT(<<, StgWord16)
    3011 
    +        INSTRUCTION(bci_OP_LSR_16): SIZED_BIN_OP_TY_INT(>>, StgWord16)
    3012 
    +        INSTRUCTION(bci_OP_ASR_16): SIZED_BIN_OP_TY_INT(>>, StgInt16)
    3013 
    +
    3014 
    +        INSTRUCTION(bci_OP_NEQ_16):  SIZED_BIN_OP_TY_TY_INT(!=, StgWord16)
    3015 
    +        INSTRUCTION(bci_OP_EQ_16):   SIZED_BIN_OP_TY_TY_INT(==, StgWord16)
    3016 
    +        INSTRUCTION(bci_OP_U_GT_16): SIZED_BIN_OP_TY_TY_INT(>, StgWord16)
    3017 
    +        INSTRUCTION(bci_OP_U_GE_16): SIZED_BIN_OP_TY_TY_INT(>=, StgWord16)
    3018 
    +        INSTRUCTION(bci_OP_U_LT_16): SIZED_BIN_OP_TY_TY_INT(<, StgWord16)
    3019 
    +        INSTRUCTION(bci_OP_U_LE_16): SIZED_BIN_OP_TY_TY_INT(<=, StgWord16)
    3020 
    +
    3021 
    +        INSTRUCTION(bci_OP_S_GT_16): SIZED_BIN_OP(>, StgInt16)
    3022 
    +        INSTRUCTION(bci_OP_S_GE_16): SIZED_BIN_OP(>=, StgInt16)
    3023 
    +        INSTRUCTION(bci_OP_S_LT_16): SIZED_BIN_OP(<, StgInt16)
    3024 
    +        INSTRUCTION(bci_OP_S_LE_16): SIZED_BIN_OP(<=, StgInt16)
    3025 
    +
    3026 
    +        INSTRUCTION(bci_OP_NOT_16): UN_SIZED_OP(~, StgWord16)
    3027 
    +        INSTRUCTION(bci_OP_NEG_16): UN_SIZED_OP(-, StgInt16)
    3028 
    +
    3029 
    +
    3030 
    +        INSTRUCTION(bci_OP_ADD_08): SIZED_BIN_OP(+, StgInt8)
    3031 
    +        INSTRUCTION(bci_OP_SUB_08): SIZED_BIN_OP(-, StgInt8)
    3032 
    +        INSTRUCTION(bci_OP_AND_08): SIZED_BIN_OP(&, StgInt8)
    3033 
    +        INSTRUCTION(bci_OP_XOR_08): SIZED_BIN_OP(^, StgInt8)
    3034 
    +        INSTRUCTION(bci_OP_OR_08):  SIZED_BIN_OP(|, StgInt8)
    3035 
    +        INSTRUCTION(bci_OP_MUL_08): SIZED_BIN_OP(*, StgInt8)
    3036 
    +        INSTRUCTION(bci_OP_SHL_08): SIZED_BIN_OP_TY_INT(<<, StgWord8)
    3037 
    +        INSTRUCTION(bci_OP_LSR_08): SIZED_BIN_OP_TY_INT(>>, StgWord8)
    3038 
    +        INSTRUCTION(bci_OP_ASR_08): SIZED_BIN_OP_TY_INT(>>, StgInt8)
    3039 
    +
    3040 
    +        INSTRUCTION(bci_OP_NEQ_08):  SIZED_BIN_OP_TY_TY_INT(!=, StgWord8)
    3041 
    +        INSTRUCTION(bci_OP_EQ_08):   SIZED_BIN_OP_TY_TY_INT(==, StgWord8)
    3042 
    +        INSTRUCTION(bci_OP_U_GT_08): SIZED_BIN_OP_TY_TY_INT(>, StgWord8)
    3043 
    +        INSTRUCTION(bci_OP_U_GE_08): SIZED_BIN_OP_TY_TY_INT(>=, StgWord8)
    3044 
    +        INSTRUCTION(bci_OP_U_LT_08): SIZED_BIN_OP_TY_TY_INT(<, StgWord8)
    3045 
    +        INSTRUCTION(bci_OP_U_LE_08): SIZED_BIN_OP_TY_TY_INT(<=, StgWord8)
    3046 
    +
    3047 
    +        INSTRUCTION(bci_OP_S_GT_08): SIZED_BIN_OP_TY_TY_INT(>, StgInt8)
    3048 
    +        INSTRUCTION(bci_OP_S_GE_08): SIZED_BIN_OP_TY_TY_INT(>=, StgInt8)
    3049 
    +        INSTRUCTION(bci_OP_S_LT_08): SIZED_BIN_OP_TY_TY_INT(<, StgInt8)
    3050 
    +        INSTRUCTION(bci_OP_S_LE_08): SIZED_BIN_OP_TY_TY_INT(<=, StgInt8)
    3051 
    +
    3052 
    +        INSTRUCTION(bci_OP_NOT_08): UN_SIZED_OP(~, StgWord8)
    3053 
    +        INSTRUCTION(bci_OP_NEG_08): UN_SIZED_OP(-, StgInt8)
    3054 
    +
    3055 
    +        INSTRUCTION(bci_OP_INDEX_ADDR_64):
    2732 3056 
             {
    2733 3057 
                 StgWord64* addr = (StgWord64*) SpW(0);
    2734 3058 
                 StgInt offset = (StgInt) SpW(1);
    ... ... @@ -2736,35 +3060,35 @@ run_BCO:
    2736 3060 
                     Sp_addW(1);
    2737 3061 
                 }
    2738 3062 
                 SpW64(0) = *(addr+offset);
    2739 
    -            goto nextInsn;
    3063 
    +            NEXT_INSTRUCTION;
    2740 3064 
             }
    2741 3065
    2742 
    -        case bci_OP_INDEX_ADDR_32:
    3066 
    +        INSTRUCTION(bci_OP_INDEX_ADDR_32):
    2743 3067 
             {
    2744 3068 
                 StgWord32* addr = (StgWord32*) SpW(0);
    2745 3069 
                 StgInt offset = (StgInt) SpW(1);
    2746 3070 
                 Sp_addW(1);
    2747 3071 
                 SpW(0) = (StgWord) *(addr+offset);
    2748 
    -            goto nextInsn;
    3072 
    +            NEXT_INSTRUCTION;
    2749 3073 
             }
    2750 
    -        case bci_OP_INDEX_ADDR_16:
    3074 
    +        INSTRUCTION(bci_OP_INDEX_ADDR_16):
    2751 3075 
             {
    2752 3076 
                 StgWord16* addr = (StgWord16*) SpW(0);
    2753 3077 
                 StgInt offset = (StgInt) SpW(1);
    2754 3078 
                 Sp_addW(1);
    2755 3079 
                 SpW(0) = (StgWord) *(addr+offset);
    2756 
    -            goto nextInsn;
    3080 
    +            NEXT_INSTRUCTION;
    2757 3081 
             }
    2758 
    -        case bci_OP_INDEX_ADDR_08:
    3082 
    +        INSTRUCTION(bci_OP_INDEX_ADDR_08):
    2759 3083 
             {
    2760 3084 
                 StgWord8* addr = (StgWord8*) SpW(0);
    2761 3085 
                 StgInt offset = (StgInt) SpW(1);
    2762 3086 
                 Sp_addW(1);
    2763 3087 
                 SpW(0) = (StgWord) *(addr+offset);
    2764 
    -            goto nextInsn;
    3088 
    +            NEXT_INSTRUCTION;
    2765 3089 
             }
    2766 3090
    2767 
    -        case bci_CCALL: {
    3091 
    +        INSTRUCTION(bci_CCALL): {
    2768 3092 
                 void *tok;
    2769 3093 
                 W_ stk_offset             = BCO_GET_LARGE_ARG;
    2770 3094 
                 int o_itbl                = BCO_GET_LARGE_ARG;
    ... ... @@ -2921,25 +3245,33 @@ run_BCO:
    2921 3245 
                 memcpy(Sp, ret, sizeof(W_) * ret_size);
    2922 3246 
     #endif
    2923 3247
    2924 
    -            goto nextInsn;
    3248 
    +            NEXT_INSTRUCTION;
    2925 3249 
             }
    2926 3250
    2927 
    -        case bci_JMP: {
    3251 
    +        INSTRUCTION(bci_JMP): {
    2928 3252 
                 /* BCO_NEXT modifies bciPtr, so be conservative. */
    2929 3253 
                 int nextpc = BCO_GET_LARGE_ARG;
    2930 3254 
                 bciPtr     = nextpc;
    2931 
    -            goto nextInsn;
    3255 
    +            NEXT_INSTRUCTION;
    2932 3256 
             }
    2933 3257
    2934 
    -        case bci_CASEFAIL:
    3258 
    +        INSTRUCTION(bci_CASEFAIL):
    2935 3259 
                 barf("interpretBCO: hit a CASEFAIL");
    2936 3260
    2937 
    -            // Errors
    3261 
    +
    3262 
    +
    3263 
    +#if defined(COMPUTED_GOTO)
    3264 
    +        INSTRUCTION(bci_DEFAULT):
    3265 
    +            barf("interpretBCO: unknown or unimplemented opcode %d",
    3266 
    +                 (int)(bci & 0xFF));
    3267 
    +#else
    3268 
    +        // Errors
    2938 3269 
             default:
    2939 3270 
                 barf("interpretBCO: unknown or unimplemented opcode %d",
    2940 3271 
                      (int)(bci & 0xFF));
    2941 
    -
    2942 3272 
             } /* switch on opcode */
    3273 
    +#endif
    3274 
    +
    2943 3275 
         }
    2944 3276 
         }
    2945 3277

  • rts/include/rts/Bytecodes.h
    ... ... @@ -23,6 +23,11 @@
    23 23 
        I hope that's clear :-)
    24 24 
     */
    25 25
    26 
    +/*
    27 
    +   Make sure to update jumptable in rts/Interpreter.c when modifying
    28 
    +   bytecodes! See Note [Instruction dispatch in the bytecode interpreter]
    29 
    +   for details.
    30 
    +*/
    26 31 
     #define bci_STKCHECK                    1
    27 32 
     #define bci_PUSH_L                      2
    28 33 
     #define bci_PUSH_LL                     3

  • testsuite/tests/simplCore/should_compile/T26349.hs
    1 
    +{-# LANGUAGE DeepSubsumption, RankNTypes #-}
    2 
    +module T26349 where
    3 
    +
    4 
    +{-# SPECIALIZE INLINE mapTCMT :: (forall b. IO b -> IO b) -> IO a -> IO a #-}
    5 
    +mapTCMT :: (forall b. m b -> n b) -> m a -> n a
    6 
    +mapTCMT f m = f m
    7 
    +
    8 
    +{-
    9 
    + We'll check
    10 
    +    tcExpr (mapTCMT) (Check ((forall b. IO b -> IO b) -> IO a_sk -> IO a_sk))
    11 
    +-}

  • testsuite/tests/simplCore/should_compile/T26349.stderr
    1 
    +==================== Tidy Core rules ====================
    2 
    +"USPEC mapTCMT @(*) @IO @IO @_"
    3 
    +    forall (@a). mapTCMT @(*) @IO @IO @a = mapTCMT_$smapTCMT @a

  • testsuite/tests/simplCore/should_compile/all.T
    ... ... @@ -559,3 +559,4 @@ test('T26051', [ grep_errmsg(r'\$wspecMe')
    559 559 
     test('T26115', [grep_errmsg(r'DFun')], compile, ['-O -ddump-simpl -dsuppress-uniques'])
    560 560 
     test('T26116', normal, compile, ['-O -ddump-rules'])
    561 561 
     test('T26117', [grep_errmsg(r'==')], compile, ['-O -ddump-simpl -dsuppress-uniques'])
    562 
    +test('T26349',  normal, compile, ['-O -ddump-rules'])

  • testsuite/tests/simplCore/should_compile/rule2.stderr
    ... ... @@ -10,18 +10,15 @@
    10 10
    11 11
    12 12 
     ==================== Grand total simplifier statistics ====================
    13 
    -Total ticks:     13
    13 
    +Total ticks:     11
    14 14
    15 
    -2 PreInlineUnconditionally
    16 
    -  1 ds
    17 
    -  1 f
    15 
    +1 PreInlineUnconditionally 1 f
    18 16 
     2 UnfoldingDone
    19 17 
       1 GHC.Internal.Base.id
    20 18 
       1 Roman.bar
    21 19 
     1 RuleFired 1 foo/bar
    22 20 
     1 LetFloatFromLet 1
    23 
    -7 BetaReduction
    24 
    -  1 ds
    21 
    +6 BetaReduction
    25 22 
       1 f
    26 23 
       1 a
    27 24 
       1 m

  • utils/genprimopcode/genprimopcode.cabal
    ... ... @@ -32,4 +32,4 @@ Executable genprimopcode
    32 32 
         Build-Depends: base       >= 4   && < 5,
    33 33 
                        array
    34 34 
         if flag(build-tool-depends)
    35 
    -      build-tool-depends: alex:alex >= 3.2.6, happy:happy >= 1.20.0
    35 
    +      build-tool-depends: alex:alex >= 3.2.6, happy:happy >= 2.1.5 || == 1.20.0 || == 1.20.1.1

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help