06 Nov '25
Simon Peyton Jones pushed to branch wip/T24464 at Glasgow Haskell Compiler / GHC
Commits:
c8978c05 by Simon Peyton Jones at 2025-11-07T00:31:51+00:00
Yet more [skip ci]
- - - - -
10 changed files:
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Types/BasicTypes.hs
- compiler/GHC/Tc/Utils/Env.hs
Changes:
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -38,13 +38,16 @@ import Language.Haskell.Syntax.Expr( LHsExpr )
import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprLExpr, pprFunBind, pprPatBind )
import {-# SOURCE #-} GHC.Hs.Pat (pprLPat )
-import GHC.Data.BooleanFormula ( LBooleanFormula, pprBooleanFormulaNormal )
-import GHC.Types.Tickish
import GHC.Hs.Extension
-import GHC.Parser.Annotation
import GHC.Hs.Type
+
import GHC.Tc.Types.Evidence
+
import GHC.Core.Type
+
+import GHC.Parser.Annotation
+
+import GHC.Types.Tickish
import GHC.Types.Name.Set
import GHC.Types.Basic
import GHC.Types.SourceText
@@ -52,6 +55,8 @@ import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Var
import GHC.Types.Name
+import GHC.Data.BooleanFormula ( LBooleanFormula, pprBooleanFormulaNormal )
+
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
@@ -89,7 +94,18 @@ data HsValBindGroups p -- Divided into strongly connected components
type family HsValBindGroup p
type instance HsValBindGroup GhcPs = ()
type instance HsValBindGroup GhcRn = (RecFlag, LHsBinds GhcRn)
-type instance HsValBindGroup GhcTc = (RecFlag, LHsBinds GhcTc, TopLevelFlag)
+type instance HsValBindGroup GhcTc = (RecFlag, LHsBinds GhcTc, StaticFlag)
+
+data StaticFlag
+ = IsStatic | NotStatic
+ deriving( Data )
+ -- IsStatic <=> this binding consists only code; all free
+ -- vars are top level (or themselves static).
+ -- So it can be moved to top level
+
+instance Outputable StaticFlag where
+ ppr IsStatic = text "static"
+ ppr NotStatic = text "not-static"
-- ---------------------------------------------------------------------
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -95,9 +95,9 @@ dsLocalBinds (HsIPBinds _ binds) body = dsIPBinds binds body
-------------------------
-- caller sets location
dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsValBinds (XValBindsLR (NValBinds binds _)) body
+dsValBinds (XValBindsLR (HsVBG grps _)) body
= do { dflags <- getDynFlags
- ; foldrM (ds_val_bind dflags) body binds }
+ ; foldrM (ds_val_bind dflags) body grps }
dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn"
-------------------------
@@ -119,12 +119,14 @@ dsIPBinds (IPBinds ev_binds ip_binds) body
-------------------------
-- caller sets location
-ds_val_bind :: DynFlags -> (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
+ds_val_bind :: DynFlags
+ -> (RecFlag, LHsBinds GhcTc, StaticFlag) -> CoreExpr
+ -> DsM CoreExpr
-- Special case for bindings which bind unlifted variables
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
-- Silently ignore INLINE and SPECIALISE pragmas...
-ds_val_bind _ (NonRecursive, hsbinds) body
+ds_val_bind _ (NonRecursive, hsbinds, _) body
| [L loc bind] <- hsbinds
-- Non-recursive, non-overloaded bindings only come in ones
-- ToDo: in some bizarre case it's conceivable that there
@@ -158,7 +160,7 @@ ds_val_bind _ (NonRecursive, hsbinds) body
is_polymorphic _ = False
-ds_val_bind _ (is_rec, binds) _body
+ds_val_bind _ (is_rec, binds, _) _body
| any (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in GHC.HsToCore.Binds
= assert (isRec is_rec )
errDsCoreExpr $ DsRecBindsNotAllowedForUnliftedTys binds
@@ -168,7 +170,7 @@ ds_val_bind _ (is_rec, binds) _body
-- linear, but selectors as used in the general case aren't. So the general case
-- would transform a linear definition into a non-linear one. See Wrinkle 2
-- Note [Desugar Strict binds] in GHC.HsToCore.Binds.
-ds_val_bind dflags (NonRecursive, hsbinds) body
+ds_val_bind dflags (NonRecursive, hsbinds, _) body
| [L _loc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_mult = mult_ann
, pat_ext = (ty, (rhs_tick, _var_ticks))})] <- hsbinds
-- Non-recursive, non-overloaded bindings only come in ones
@@ -190,21 +192,26 @@ ds_val_bind dflags (NonRecursive, hsbinds) body
-- problem?
-- Ordinary case for bindings; none should be unlifted
-ds_val_bind _ (is_rec, binds) body
+ds_val_bind _ (is_rec, binds, static_flag) body
= do { massert (isRec is_rec || isSingleton binds)
- -- we should never produce a non-recursive list of multiple binds
+ -- We should never produce a non-recursive list of multiple binds
; (force_vars,prs) <- dsLHsBinds binds
- ; let body' = foldr seqVar body force_vars
+
; assertPpr (not (any (isUnliftedType . idType . fst) prs)) (ppr is_rec $$ ppr binds) $
-- NB: bindings have a fixed RuntimeRep, so it's OK to call isUnliftedType
case prs of
[] -> return body
- _ -> return (mkLets (mk_binds is_rec prs) body') }
+ _ -> case static_flag of
+ NotStatic -> return (mkLets (mk_binds is_rec prs) body')
+ IsStatic -> do { emitStaticBinds prs; return body' }
+ where
+ body' = foldr seqVar body force_vars
-- We can make a non-recursive let because we make sure to return
-- the bindings in dependency order in dsLHsBinds,
-- see Note [Return non-recursive bindings in dependency order] in
-- GHC.HsToCore.Binds
+ }
-- | Helper function. You can use the result of 'mk_binds' with 'mkLets' for
-- instance.
@@ -494,7 +501,7 @@ dsExpr (HsStatic (_, whole_ty) expr@(L loc _))
; static_id <- newStaticId (mkSpecForAllTys static_fvs whole_ty)
- ; emitStaticBind static_id static_rhs
+ ; emitStaticBinds [(static_id, static_rhs)]
; return (mkVarApps (Var static_id) static_fvs) }
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -34,7 +34,7 @@ module GHC.HsToCore.Monad (
DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
-- Static bindings
- emitStaticBind, getStaticBinds,
+ emitStaticBinds, getStaticBinds,
-- Getting and setting pattern match oracle states
getPmNablas, updPmNablas,
@@ -643,10 +643,10 @@ pprRuntimeTrace str doc expr = do
getCCIndexDsM :: FastString -> DsM CostCentreIndex
getCCIndexDsM = getCCIndexM ds_cc_st
-emitStaticBind :: Id -> CoreExpr -> DsM ()
-emitStaticBind static_id rhs
+emitStaticBinds :: [(Id,CoreExpr)] -> DsM ()
+emitStaticBinds static_binds
= do { env <- getGblEnv
- ; liftIO $ modifyIORef' (ds_static_binds env) (`snocOL` (static_id,rhs)) }
+ ; liftIO $ modifyIORef' (ds_static_binds env) (`appOL` toOL static_binds) }
getStaticBinds :: DsM (OrdList (Id,CoreExpr))
getStaticBinds = do { env <- getGblEnv
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -341,8 +341,8 @@ hsScopedTvBinders binds
= concatMap get_scoped_tvs sigs
where
sigs = case binds of
- ValBinds _ _ sigs -> sigs
- XValBindsLR (NValBinds _ sigs) -> sigs
+ ValBinds _ _ sigs -> sigs
+ XValBindsLR (HsVBG _ sigs) -> sigs
get_scoped_tvs :: LSig GhcRn -> [Name]
get_scoped_tvs (L _ signature)
@@ -1987,7 +1987,7 @@ rep_implicit_param_name (HsIPName name) = coreStringLit name
rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
-- Assumes: all the binders of the binding are already in the meta-env
-rep_val_binds (XValBindsLR (NValBinds binds sigs))
+rep_val_binds (XValBindsLR (HsVBG binds sigs))
= do { core1 <- rep_binds (concatMap snd binds)
; core2 <- rep_sigs sigs
; return (core1 ++ core2) }
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -260,7 +260,7 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
tcValBinds :: TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
-> TcM thing
- -> TcM ([(RecFlag, LHsBinds GhcTc, TopLevelFlag)], thing)
+ -> TcM ([(RecFlag, LHsBinds GhcTc, StaticFlag)], thing)
tcValBinds top_lvl grps sigs thing_inside
= do { -- Typecheck the signatures
@@ -285,7 +285,7 @@ tcValBinds top_lvl grps sigs thing_inside
-- See Note [Pattern synonym builders don't yield dependencies]
-- in GHC.Rename.Bind
; patsyn_builders <- mapM (tcPatSynBuilderBind prag_fn) patsyns
- ; let extra_binds = [ (NonRecursive, builder, TopLevel)
+ ; let extra_binds = [ (NonRecursive, builder, IsStatic)
| builder <- patsyn_builders ]
; return (extra_binds, thing) }
; return (binds' ++ extra_binds', thing) }}
@@ -297,7 +297,7 @@ tcValBinds top_lvl grps sigs thing_inside
tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
-> [(RecFlag, LHsBinds GhcRn)] -> TcM thing
- -> TcM ([(RecFlag, LHsBinds GhcTc, TopLevelFlag)], thing)
+ -> TcM ([(RecFlag, LHsBinds GhcTc, StaticFlag)], thing)
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
-- Here a "strongly connected component" has the straightforward
@@ -334,7 +334,7 @@ before we sub-divide it based on what type signatures it has.
tc_group :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> (RecFlag, LHsBinds GhcRn) -> TcM thing
- -> TcM ((RecFlag, LHsBinds GhcTc, TopLevelFlag), thing)
+ -> TcM ((RecFlag, LHsBinds GhcTc, StaticFlag), thing)
-- Typecheck one strongly-connected component of the original program.
tc_group top_lvl sig_fn prag_fn (rec_flag, binds) thing_inside
= case rec_flag of
@@ -345,12 +345,12 @@ tc_group top_lvl sig_fn prag_fn (rec_flag, binds) thing_inside
tc_nonrec_group :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> LHsBinds GhcRn -> TcM thing
- -> TcM ((RecFlag, LHsBinds GhcTc, TopLevelFlag), thing)
+ -> TcM ((RecFlag, LHsBinds GhcTc, StaticFlag), thing)
tc_nonrec_group top_lvl sig_fn prag_fn [lbind] thing_inside
| L loc (PatSynBind _ psb) <- lbind
= do { (aux_binds, tcg_env) <- tcPatSynDecl (L loc psb) sig_fn prag_fn
; thing <- setGblEnv tcg_env thing_inside
- ; return ((NonRecursive, aux_binds, TopLevel), thing) }
+ ; return ((NonRecursive, aux_binds, IsStatic), thing) }
| otherwise
= -- A single non-recursive binding
@@ -375,7 +375,7 @@ tc_nonrec_group _ _ _ binds _ -- Non-rec groups should always be a singleton
tc_rec_group :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> LHsBinds GhcRn -> TcM thing
- -> TcM ((RecFlag, LHsBinds GhcTc, TopLevelFlag), thing)
+ -> TcM ((RecFlag, LHsBinds GhcTc, StaticFlag), thing)
tc_rec_group top_lvl sig_fn prag_fn binds thing_inside
= -- For a recursive group, to maximise polymorphism, we do a new
-- strongly-connected-component analysis, this time omitting
@@ -1855,7 +1855,7 @@ decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds
isClosedBndrGroup :: TcTypeEnv -> [LHsBind GhcRn] -> IsGroupClosed
isClosedBndrGroup type_env binds
- = IsGroupClosed is_top fv_env type_closed
+ = IsGroupClosed is_static fv_env type_closed
where
fv_env :: NameEnv NameSet
fv_env = mkNameEnv $ [ (b,fvs) | (bs,fvs) <- bind_fvs, b <-bs ]
@@ -1875,16 +1875,20 @@ isClosedBndrGroup type_env binds
`delListFromNameSet` all_bndrs
-- all_fvs does not include the binders of this group
- is_top | nameSetAll id_is_top all_fvs = TopLevel
- | otherwise = NotTopLevel
+ is_static | not (any (is_pat_bind . unLoc) binds)
+ , nameSetAll id_is_static all_fvs = IsStatic
+ | otherwise = NotStatic
- id_is_top :: Name -> Bool
- id_is_top name
+ is_pat_bind (PatBind {}) = True
+ is_pat_bind _ = False
+
+ id_is_static :: Name -> Bool
+ id_is_static name
| Just thing <- lookupNameEnv type_env name
= case thing of
- AGlobal {} -> True
- ATcId { tct_info = LetBound { lb_top = top } } -> isTopLevel top
- _ -> False
+ AGlobal {} -> True
+ ATcId { tct_info = LetBound { lb_top = IsStatic } } -> True
+ _ -> False
| otherwise -- Imported Ids
= True
@@ -1897,10 +1901,12 @@ isClosedBndrGroup type_env binds
is_closed_type_id name
| Just thing <- lookupNameEnv type_env name
= case thing of
- AGlobal {} -> True
- ATcId { tct_info = info } -> lb_closed info
- ATyVar {} -> False
- -- In-scope type variables are not closed!
+ AGlobal {} -> True
+ ATyVar {} -> False -- In-scope type variables are not closed!
+ ATcId { tct_info = info}
+ -> case info of
+ LetBound { lb_closed = closed } -> closed
+ NotLetBound -> False
_ -> pprPanic "is_closed_id" (ppr name)
| otherwise
@@ -1911,13 +1917,13 @@ isClosedBndrGroup type_env binds
adjustClosedForUnlifted :: IsGroupClosed -> [Scaled TcId] -> IsGroupClosed
adjustClosedForUnlifted closed@(IsGroupClosed top_lvl fv_env type_closed) ids
- | TopLevel <- top_lvl
+ | IsStatic <- top_lvl
, all definitely_lifted ids = closed
- | otherwise = IsGroupClosed NotTopLevel fv_env type_closed
+ | otherwise = IsGroupClosed NotStatic fv_env type_closed
where
definitely_lifted (Scaled _ id) = definitelyLiftedType (idType id)
-sendToTopLevel :: IsGroupClosed -> TopLevelFlag
+sendToTopLevel :: IsGroupClosed -> StaticFlag
sendToTopLevel (IsGroupClosed top _ _) = top
lHsBindFreeVars :: LHsBind GhcRn -> NameSet
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -1506,7 +1506,7 @@ expandRecordUpd record_expr possible_parents rbnds res_ty
let_binds :: HsLocalBindsLR GhcRn GhcRn
let_binds = HsValBinds noAnn $ XValBindsLR
- $ NValBinds upd_ids_lhs (map mk_idSig upd_ids)
+ $ HsVBG upd_ids_lhs (map mk_idSig upd_ids)
upd_ids_lhs :: [(RecFlag, LHsBindsLR GhcRn GhcRn)]
upd_ids_lhs = [ (NonRecursive, [genSimpleFunBind (idName id) [] rhs])
| (_, (id, rhs)) <- upd_ids ]
@@ -1821,9 +1821,8 @@ checkClosedInStaticForm name = do
-- visited nodes, so we avoid repeating cycles in the traversal.
case lookupNameEnv type_env n of
Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of
- ClosedLet -> Nothing
NotLetBound -> Just NotLetBoundReason
- NonClosedLet fvs type_closed -> listToMaybe $
+ LetBound { lb_fvs = fvs, lb_closed = type_closed } -> listToMaybe $
-- Look for a non-closed variable in fvs
[ NotClosed n' reason
| n' <- nameSetElemsStable fvs
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -791,7 +791,7 @@ tcRnHsBootDecls boot_or_sig decls
, hs_defds = def_decls
, hs_ruleds = rule_decls
, hs_annds = _
- , hs_valds = XValBindsLR (NValBinds val_binds val_sigs) })
+ , hs_valds = XValBindsLR (HsVBG val_binds val_sigs) })
<- rnTopSrcDecls first_group
; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do {
@@ -1707,7 +1707,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
hs_annds = annotation_decls,
hs_ruleds = rule_decls,
hs_valds = hs_val_binds@(XValBindsLR
- (NValBinds val_binds val_sigs)) })
+ (HsVBG val_binds val_sigs)) })
= do { -- Type-check the type and class decls, and all imported decls
-- The latter come in via tycl_decls
traceTc "Tc2 (src)" empty ;
@@ -1716,7 +1716,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-- and import the supporting declarations
traceTc "Tc3" empty ;
(tcg_env, inst_infos, th_bndrs,
- XValBindsLR (NValBinds deriv_binds deriv_sigs))
+ XValBindsLR (HsVBG deriv_binds deriv_sigs))
<- tcTyClsInstDecls tycl_decls deriv_decls default_decls val_binds ;
updLclCtxt (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $
@@ -2316,7 +2316,7 @@ tcUserStmt (L loc (BodyStmt _ expr _ _))
-- [let it = expr]
let_stmt = L loc $ LetStmt noAnn $ HsValBinds noAnn
$ XValBindsLR
- (NValBinds [(NonRecursive,[the_bind])] [])
+ (HsVBG [(NonRecursive,[the_bind])] [])
-- [it <- e]
bind_stmt = L loc $ BindStmt
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -846,7 +846,7 @@ tcRecSelBinds sel_bind_prs
-- See Note [Impredicative record selectors]
setXOptM LangExt.ImpredicativeTypes $
tcValBinds TopLevel binds sigs getGblEnv
- ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) }
+ ; return (tcg_env `addTypecheckedBinds` map sndOf3 rec_sel_binds) }
where
sigs = [ L (noAnnSrcSpan loc) (XSig $ IdSig sel_id)
| (sel_id, _) <- sel_bind_prs
=====================================
compiler/GHC/Tc/Types/BasicTypes.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Hs.Extension ( GhcRn )
+import GHC.Hs.Binds ( StaticFlag )
import Language.Haskell.Syntax.Type ( LHsSigWcType )
@@ -309,7 +310,7 @@ data TcTyThing
| ATcId -- Ids defined in this module; may not be fully zonked
{ tct_id :: Id
- , tct_info :: IdBindingInfo -- See Note [Meaning of IdBindingInfo]
+ , tct_info :: IdBindingInfo
}
| ATyVar Name TcTyVar -- See Note [Type variables in the type environment]
@@ -346,16 +347,16 @@ instance Outputable TcTyThing where -- Debugging only
-- b) to figure out when a nested binding can be generalised,
-- in 'GHC.Tc.Gen.Bind.decideGeneralisationPlan'.
--
-data IdBindingInfo -- See Note [Meaning of IdBindingInfo]
+data IdBindingInfo
= NotLetBound
| LetBound
- { lb_top :: TopLevelFlag
- -- TopLevel <=> this binding may safely be moved to top level
+ { lb_top :: StaticFlag
+ -- IsStatic <=> this binding may safely be moved to top level
-- E.g f x = let ys = reverse [1,2]
-- zs = reverse ys
-- in ...
- -- Both ys and zs count as TopLevel
+ -- Both ys and zs count as IsStatic
, lb_fvs :: RhsNames
-- Free vars of the RHS that are NotLetBound, or LetBound NotTopLevel
@@ -372,7 +373,7 @@ data IdBindingInfo -- See Note [Meaning of IdBindingInfo]
-- mutually-recursive /renamed/ (but not yet typechecked) bindings
data IsGroupClosed
= IsGroupClosed
- TopLevelFlag -- TopLevel <=> all free vars are themselves TopLevel
+ StaticFlag -- IsStatic <=> all free vars of the group are top-level or static
(NameEnv RhsNames) -- Frees for the RHS of each binding in the group
-- (includes free vars of RHS bound in the same group)
ClosedTypeId -- True <=> all the free vars of the group have closed types
@@ -383,8 +384,21 @@ type RhsNames = NameSet -- Names of variables, mentioned on the RHS of
type ClosedTypeId = Bool
-- See Note [Meaning of IdBindingInfo]
-{- Note [Meaning of IdBindingInfo]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Static bindings and StaticFlag]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A (possibly-recursive) binding is /static/ iff
+ * It is syntactically top-level
+OR
+ * It is not a PatBind
+ * Its free variables are all static
+ * It has a lifted type
+
+Static bindings are important for static forms (static e):
+ * The free vars of `e` must all be static
+ * All static bindings are immediately floated to top level by the desugarer
+ * The desugarer also floats `e` to top level, and replaces (static e)
+Static bindings can all float to top level, and the de
+
* NotLetBound means that
- the Id is not let-bound (e.g. it is bound in a
lambda-abstraction or in a case pattern)
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -675,7 +675,7 @@ tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
tcExtendRecIds pairs thing_inside
= tc_extend_local_env NotTopLevel
[ (name, ATcId { tct_id = let_id
- , tct_info = LetBound { lb_top = NotTopLevel
+ , tct_info = LetBound { lb_top = NotStatic
, lb_fvs = emptyNameSet
, lb_closed = False } })
| (name, let_id) <- pairs ] $
@@ -691,7 +691,7 @@ tcExtendSigIds top_lvl sig_ids thing_inside
, tct_info = info })
| id <- sig_ids
, let closed = isTypeClosedLetBndr id
- info = LetBound { lb_top = NotTopLevel
+ info = LetBound { lb_top = NotStatic
, lb_fvs = emptyNameSet
, lb_closed = closed } ]
thing_inside
@@ -703,7 +703,7 @@ tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
-- Used for both top-level value bindings and nested let/where-bindings
-- Used for a single NonRec or a single Rec
-- Adds to the TcBinderStack too
-tcExtendLetEnv top_lvl _sig_fn (IsGroupClosed group_top fv_env _)
+tcExtendLetEnv top_lvl _sig_fn (IsGroupClosed group_static fv_env _)
ids thing_inside
= tcExtendBinderStack [TcIdBndr id top_lvl | Scaled _ id <- ids] $
tc_extend_local_env top_lvl
@@ -713,7 +713,7 @@ tcExtendLetEnv top_lvl _sig_fn (IsGroupClosed group_top fv_env _)
foldr check_usage thing_inside scaled_names
where
mk_tct_info id
- = LetBound { lb_top = group_top
+ = LetBound { lb_top = group_static
, lb_fvs = lookupNameEnv fv_env (idName id) `orElse` emptyNameSet
, lb_closed = isTypeClosedLetBndr id }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c8978c0582898f2afa2a1313841bfe0…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c8978c0582898f2afa2a1313841bfe0…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: compiler: Exclude units with no exposed modules from unused package check
by Marge Bot (＠marge-bot) 06 Nov '25
by Marge Bot (＠marge-bot) 06 Nov '25
06 Nov '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
5cdcfaed by Ben Gamari at 2025-11-06T09:01:36-05:00
compiler: Exclude units with no exposed modules from unused package check
Such packages cannot be "used" in the Haskell sense of the word yet
are nevertheless necessary as they may provide, e.g., C object code or
link flags.
Fixes #24120.
- - - - -
74b8397a by Brandon Chinn at 2025-11-06T09:02:19-05:00
Replace deprecated argparse.FileType
- - - - -
36ddf988 by Ben Gamari at 2025-11-06T09:03:01-05:00
Bump unix submodule to 2.8.8.0
Closes #26474.
- - - - -
c32b3a29 by fendor at 2025-11-06T09:03:43-05:00
Fix assertion in `postStringLen` to account for \0 byte
We fix the assertion to handle trailing \0 bytes in `postStringLen`.
Before this change, the assertion looked like this:
ASSERT(eb->begin + eb->size > eb->pos + len + 1);
Let's assume some values to see why this is actually off by one:
eb->begin = 0
eb->size = 1
eb->pos = 0
len = 1
then the assertion would trigger correctly:
0 + 1 > 0 + 1 + 1 => 1 > 2 => false
as there is not enough space for the \0 byte (which is the trailing +1).
However, if we change `eb->size = 2`, then we do have enough space for a
string of length 1, but the assertion still fails:
0 + 2 > 0 + 1 + 1 => 2 > 2 => false
Which causes the assertion to fail if there is exactly enough space for
the string with a trailing \0 byte.
Clearly, the assertion should be `>=`!
If we switch around the operand, it should become more obvious that `<=`
is the correct comparison:
ASSERT(eb->pos + len + 1 <= eb->begin + eb->size);
This is expresses more naturally that the current position plus the
length of the string (and the null byte) must be smaller or equal to the
overall size of the buffer.
This change also is in line with the implementation in
`hasRoomForEvent` and `hasRoomForVariableEvent`:
```
StgBool hasRoomForEvent(EventsBuf *eb, EventTypeNum eNum)
{
uint32_t size = ...;
if (eb->pos + size > eb->begin + eb->size)
...
```
the check `eb->pos + size > eb->begin + eb->size` is identical to
`eb->pos + size <= eb->begin + eb->size` plus a negation.
- - - - -
3034a6f2 by Ben Gamari at 2025-11-06T09:04:24-05:00
Bump os-string submodule to 2.0.8
- - - - -
39567e85 by Cheng Shao at 2025-11-06T09:05:06-05:00
rts: use computed goto for instruction dispatch in the bytecode interpreter
This patch uses computed goto for instruction dispatch in the bytecode
interpreter. Previously instruction dispatch is done by a classic
switch loop, so executing the next instruction requires two jumps: one
to the start of the switch loop and another to the case block based on
the instruction tag. By using computed goto, we can build a jump table
consisted of code addresses indexed by the instruction tags
themselves, so executing the next instruction requires only one jump,
to the destination directly fetched from the jump table.
Closes #12953.
- - - - -
1c01258b by sheaf at 2025-11-06T15:12:54-05:00
Correct hasFixedRuntimeRep in matchExpectedFunTys
This commit fixes a bug in the representation-polymormorphism check in
GHC.Tc.Utils.Unify.matchExpectedFunTys. The problem was that we put
the coercion resulting from hasFixedRuntimeRep in the wrong place,
leading to the Core Lint error reported in #26528.
The change is that we have to be careful when using 'mkWpFun': it
expects **both** the expected and actual argument types to have a
syntactically fixed RuntimeRep, as explained in Note [WpFun-FRR-INVARIANT]
in GHC.Tc.Types.Evidence.
On the way, this patch improves some of the commentary relating to
other usages of 'mkWpFun' in the compiler, in particular in the view
pattern case of 'tc_pat'. No functional changes, but some stylistic
changes to make the code more readable, and make it easier to understand
how we are upholding the WpFun-FRR-INVARIANT.
Fixes #26528
- - - - -
c9d258d3 by Simon Peyton Jones at 2025-11-06T15:12:55-05:00
Fix a horrible shadowing bug in implicit parameters
Fixes #26451. The change is in GHC.Tc.Solver.Monad.updInertDicts
where we now do /not/ delete /Wanted/ implicit-parameeter constraints.
This bug has been in GHC since 9.8! But it's quite hard to provoke;
I contructed a tests in T26451, but it was hard to do so.
- - - - -
22 changed files:
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Unify.hs
- docs/users_guide/compare-flags.py
- libraries/os-string
- libraries/unix
- rts/Interpreter.c
- rts/eventlog/EventLog.c
- rts/gen_event_types.py
- rts/include/rts/Bytecodes.h
- testsuite/driver/runtests.py
- + testsuite/tests/driver/T24120.hs
- testsuite/tests/driver/all.T
- + testsuite/tests/rep-poly/T26528.hs
- testsuite/tests/rep-poly/all.T
- + testsuite/tests/typecheck/should_compile/T26451.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -474,6 +474,10 @@ warnUnusedPackages us dflags mod_graph =
ui <- lookupUnit us u
-- Which are not explicitly used
guard (Set.notMember (unitId ui) used_args)
+ -- Exclude units with no exposed modules. This covers packages which only
+ -- provide C object code or link flags (e.g. system-cxx-std-lib).
+ -- See #24120.
+ guard (not $ null $ unitExposedModules ui)
return (unitId ui, unitPackageName ui, unitPackageVersion ui, flag)
unusedArgs = sortOn (\(u,_,_,_) -> u) $ mapMaybe resolve (explicitUnits us)
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -957,7 +957,7 @@ tcSynArgE :: CtOrigin
-> SyntaxOpType -- ^ shape it is expected to have
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments
-> TcM (a, HsWrapper)
- -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
+ -- ^ returns a wrapper :: (type of right shape) ~~> (type passed in)
tcSynArgE orig op sigma_ty syn_ty thing_inside
= do { (skol_wrap, (result, ty_wrapper))
<- tcSkolemise Shallow GenSigCtxt sigma_ty $ \rho_ty ->
@@ -978,10 +978,10 @@ tcSynArgE orig op sigma_ty syn_ty thing_inside
; return (result, mkWpCastN list_co) }
go rho_ty (SynFun arg_shape res_shape)
- = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty
+ = do { ( match_wrapper -- :: (arg_ty -> res_ty) ~~> rho_ty
, ( ( (result, arg_ty, res_ty, op_mult)
- , res_wrapper ) -- :: res_ty_out "->" res_ty
- , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out
+ , res_wrapper ) -- :: res_ty_out ~~> res_ty
+ , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty ~~> arg_ty_out
<- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $
\ [ExpFunPatTy arg_ty] res_ty ->
do { arg_tc_ty <- expTypeToType (scaledThing arg_ty)
@@ -1031,7 +1031,7 @@ tcSynArgA :: CtOrigin
tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside
= do { (match_wrapper, arg_tys, res_ty)
<- matchActualFunTys herald orig (length arg_shapes) sigma_ty
- -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
+ -- match_wrapper :: sigma_ty ~~> (arg_tys -> res_ty)
; ((result, res_wrapper), arg_wrappers)
<- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults ->
tc_syn_arg res_ty res_shape $ \ res_results ->
@@ -1061,12 +1061,12 @@ tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside
; return (result, idHsWrapper) }
tc_syn_arg res_ty SynRho thing_inside
= do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
- -- inst_wrap :: res_ty "->" rho_ty
+ -- inst_wrap :: res_ty ~~> rho_ty
; result <- thing_inside [rho_ty]
; return (result, inst_wrap) }
tc_syn_arg res_ty SynList thing_inside
= do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
- -- inst_wrap :: res_ty "->" rho_ty
+ -- inst_wrap :: res_ty ~~> rho_ty
; (list_co, elt_ty) <- matchExpectedListTy rho_ty
-- list_co :: [elt_ty] ~N rho_ty
; result <- thing_inside [elt_ty]
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -329,7 +329,7 @@ tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl
-- Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind
| Just bndr_id <- sig_fn bndr_name -- There is a signature
- = do { wrap <- tc_sub_type penv (scaledThing exp_pat_ty) (idType bndr_id)
+ = do { wrap <- tcSubTypePat_GenSigCtxt penv (scaledThing exp_pat_ty) (idType bndr_id)
-- See Note [Subsumption check at pattern variables]
; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty)
; return (wrap, bndr_id) }
@@ -376,10 +376,12 @@ newLetBndr LetLclBndr name w ty
newLetBndr (LetGblBndr prags) name w ty
= addInlinePrags (mkLocalId name w ty) (lookupPragEnv prags name)
-tc_sub_type :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
--- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt
--- Used during typechecking patterns
-tc_sub_type penv t1 t2 = tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2
+-- | A version of 'tcSubTypePat' specialised to 'GenSigCtxt'.
+--
+-- Used during typechecking of patterns.
+tcSubTypePat_GenSigCtxt :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
+tcSubTypePat_GenSigCtxt penv t1 t2 =
+ tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2
{- Note [Subsumption check at pattern variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -618,111 +620,123 @@ tc_pat :: Scaled ExpSigmaTypeFRR
-> Checker (Pat GhcRn) (Pat GhcTc)
-- ^ Translated pattern
-tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
-
- VarPat x (L l name) -> do
- { (wrap, id) <- tcPatBndr penv name pat_ty
- ; res <- tcCheckUsage name (scaledMult pat_ty) $
- tcExtendIdEnv1 name id thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
-
- ParPat x pat -> do
- { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
- ; return (ParPat x pat', res) }
-
- BangPat x pat -> do
- { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
- ; return (BangPat x pat', res) }
-
- OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1)
- { let pats_list = NE.toList pats
- ; (pats_list', (res, pat_ct)) <- tc_lpats (map (const pat_ty) pats_list) penv pats_list (captureConstraints thing_inside)
- ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness
- ; emitConstraints pat_ct
- -- captureConstraints/extendConstraints:
- -- like in Note [Hopping the LIE in lazy patterns]
- ; pat_ty <- expTypeToType (scaledThing pat_ty)
- ; return (OrPat pat_ty pats', res) }
-
- LazyPat x pat -> do
- { checkManyPattern LazyPatternReason (noLocA ps_pat) pat_ty
- ; (pat', (res, pat_ct))
- <- tc_lpat pat_ty (makeLazy penv) pat $
- captureConstraints thing_inside
- -- Ignore refined penv', revert to penv
-
- ; emitConstraints pat_ct
- -- captureConstraints/extendConstraints:
- -- see Note [Hopping the LIE in lazy patterns]
-
- -- Check that the expected pattern type is itself lifted
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind
-
- ; return ((LazyPat x pat'), res) }
-
- WildPat _ -> do
- { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
- ; res <- thing_inside
- ; pat_ty <- expTypeToType (scaledThing pat_ty)
- ; return (WildPat pat_ty, res) }
-
- AsPat x (L nm_loc name) pat -> do
- { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
- ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty)
- ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
- tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id))
- penv pat thing_inside
- -- NB: if we do inference on:
- -- \ (y@(x::forall a. a->a)) = e
- -- we'll fail. The as-pattern infers a monotype for 'y', which then
- -- fails to unify with the polymorphic type for 'x'. This could
- -- perhaps be fixed, but only with a bit more work.
- --
- -- If you fix it, don't forget the bindInstsOfPatIds!
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) }
-
- ViewPat _ expr pat -> do
- { checkManyPattern ViewPatternReason (noLocA ps_pat) pat_ty
- --
- -- It should be possible to have view patterns at linear (or otherwise
- -- non-Many) multiplicity. But it is not clear at the moment what
- -- restriction need to be put in place, if any, for linear view
- -- patterns to desugar to type-correct Core.
-
- ; (expr', expr_rho) <- tcInferExpr IIF_ShallowRho expr
- -- IIF_ShallowRho: do not perform deep instantiation, regardless of
- -- DeepSubsumption (Note [View patterns and polymorphism])
- -- But we must do top-instantiation to expose the arrow to matchActualFunTy
-
- -- Expression must be a function
- ; let herald = ExpectedFunTyViewPat $ unLoc expr
- ; (expr_co1, Scaled _mult inf_arg_ty, inf_res_sigma)
- <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_rho) expr_rho
- -- See Note [View patterns and polymorphism]
- -- expr_wrap1 :: expr_rho "->" (inf_arg_ty -> inf_res_sigma)
-
- -- Check that overall pattern is more polymorphic than arg type
- ; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty
- -- expr_wrap2 :: pat_ty "->" inf_arg_ty
-
- -- Pattern must have inf_res_sigma
- ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType inf_res_sigma) penv pat thing_inside
-
- ; let Scaled w h_pat_ty = pat_ty
- ; pat_ty <- readExpType h_pat_ty
- ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper
- (Scaled w pat_ty) inf_res_sigma
- -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"
- -- (pat_ty -> inf_res_sigma)
- -- NB: pat_ty comes from matchActualFunTy, so it has a
- -- fixed RuntimeRep, as needed to call mkWpFun.
-
- expr_wrap = expr_wrap2' <.> mkWpCastN expr_co1
-
- ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) }
+tc_pat scaled_exp_pat_ty@(Scaled w_pat exp_pat_ty) penv ps_pat thing_inside =
+
+ case ps_pat of
+
+ VarPat x (L l name) -> do
+ { (wrap, id) <- tcPatBndr penv name scaled_exp_pat_ty
+ ; res <- tcCheckUsage name w_pat $ tcExtendIdEnv1 name id thing_inside
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
+
+ ParPat x pat -> do
+ { (pat', res) <- tc_lpat scaled_exp_pat_ty penv pat thing_inside
+ ; return (ParPat x pat', res) }
+
+ BangPat x pat -> do
+ { (pat', res) <- tc_lpat scaled_exp_pat_ty penv pat thing_inside
+ ; return (BangPat x pat', res) }
+
+ OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1)
+ { let pats_list = NE.toList pats
+ pat_exp_tys = map (const scaled_exp_pat_ty) pats_list
+ ; (pats_list', (res, pat_ct)) <- tc_lpats pat_exp_tys penv pats_list (captureConstraints thing_inside)
+ ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness
+ ; emitConstraints pat_ct
+ -- captureConstraints/extendConstraints:
+ -- like in Note [Hopping the LIE in lazy patterns]
+ ; pat_ty <- expTypeToType exp_pat_ty
+ ; return (OrPat pat_ty pats', res) }
+
+ LazyPat x pat -> do
+ { checkManyPattern LazyPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ ; (pat', (res, pat_ct))
+ <- tc_lpat scaled_exp_pat_ty (makeLazy penv) pat $
+ captureConstraints thing_inside
+ -- Ignore refined penv', revert to penv
+
+ ; emitConstraints pat_ct
+ -- captureConstraints/extendConstraints:
+ -- see Note [Hopping the LIE in lazy patterns]
+
+ -- Check that the expected pattern type is itself lifted
+ ; pat_ty <- readExpType exp_pat_ty
+ ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind
+
+ ; return ((LazyPat x pat'), res) }
+
+ WildPat _ -> do
+ { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ ; res <- thing_inside
+ ; pat_ty <- expTypeToType exp_pat_ty
+ ; return (WildPat pat_ty, res) }
+
+ AsPat x (L nm_loc name) pat -> do
+ { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name scaled_exp_pat_ty)
+ ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
+ tc_lpat (Scaled w_pat (mkCheckExpType $ idType bndr_id))
+ penv pat thing_inside
+ -- NB: if we do inference on:
+ -- \ (y@(x::forall a. a->a)) = e
+ -- we'll fail. The as-pattern infers a monotype for 'y', which then
+ -- fails to unify with the polymorphic type for 'x'. This could
+ -- perhaps be fixed, but only with a bit more work.
+ --
+ -- If you fix it, don't forget the bindInstsOfPatIds!
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) }
+
+ ViewPat _ view_expr inner_pat -> do
+
+ -- The pattern is a view pattern, 'pat = (view_expr -> inner_pat)'.
+ -- First infer the type of 'view_expr'; the overall type of the pattern
+ -- is the argument type of 'view_expr', and the inner pattern type is
+ -- checked against the result type of 'view_expr'.
+
+ { checkManyPattern ViewPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ -- It should be possible to have view patterns at linear (or otherwise
+ -- non-Many) multiplicity. But it is not clear at the moment what
+ -- restrictions need to be put in place, if any, for linear view
+ -- patterns to desugar to type-correct Core.
+
+ -- Infer the type of 'view_expr'.
+ ; (view_expr', view_expr_rho) <- tcInferExpr IIF_ShallowRho view_expr
+ -- IIF_ShallowRho: do not perform deep instantiation, regardless of
+ -- DeepSubsumption (Note [View patterns and polymorphism])
+ -- But we must do top-instantiation to expose the arrow to matchActualFunTy
+
+ -- 'view_expr' must be a function; expose its argument/result types
+ -- using 'matchActualFunTy'.
+ ; let herald = ExpectedFunTyViewPat $ unLoc view_expr
+ ; (view_expr_co1, Scaled _mult view_arg_ty, view_res_ty)
+ <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc view_expr)
+ (1, view_expr_rho) view_expr_rho
+ -- See Note [View patterns and polymorphism]
+ -- view_expr_co1 :: view_expr_rho ~~> (view_arg_ty -> view_res_ty)
+
+ -- Check that the overall pattern's type is more polymorphic than
+ -- the view function argument type.
+ ; view_expr_wrap2 <- tcSubTypePat_GenSigCtxt penv exp_pat_ty view_arg_ty
+ -- view_expr_wrap2 :: pat_ty ~~> view_arg_ty
+
+ -- The inner pattern must have type 'view_res_ty'.
+ ; (inner_pat', res) <- tc_lpat (Scaled w_pat (mkCheckExpType view_res_ty)) penv inner_pat thing_inside
+
+ ; pat_ty <- readExpType exp_pat_ty
+ ; let view_expr_wrap2' =
+ mkWpFun view_expr_wrap2 idHsWrapper
+ (Scaled w_pat pat_ty) view_res_ty
+ -- view_expr_wrap2' :: (view_arg_ty -> view_res_ty)
+ -- ~~> (pat_ty -> view_res_ty)
+ -- This satisfies WpFun-FRR-INVARIANT:
+ -- 'view_arg_ty' was returned by matchActualFunTy, hence FRR
+ -- 'pat_ty' was passed in and is an 'ExpSigmaTypeFRR'
+
+ view_expr_wrap = view_expr_wrap2' <.> mkWpCastN view_expr_co1
+
+ ; return $ (ViewPat pat_ty (mkLHsWrap view_expr_wrap view_expr') inner_pat', res) }
{- Note [View patterns and polymorphism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -748,93 +762,91 @@ Another example is #26331.
-- Type signatures in patterns
-- See Note [Pattern coercions] below
- SigPat _ pat sig_ty -> do
- { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
- sig_ty (scaledThing pat_ty)
- -- Using tcExtendNameTyVarEnv is appropriate here
- -- because we're not really bringing fresh tyvars into scope.
- -- We're *naming* existing tyvars. Note that it is OK for a tyvar
- -- from an outer scope to mention one of these tyvars in its kind.
- ; (pat', res) <- tcExtendNameTyVarEnv wcs $
- tcExtendNameTyVarEnv tv_binds $
- tc_lpat (pat_ty `scaledSet` mkCheckExpType inner_ty) penv pat thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
+ SigPat _ pat sig_ty -> do
+ { (inner_ty, tv_binds, wcs, wrap) <-
+ tcPatSig (inPatBind penv) sig_ty exp_pat_ty
+ -- Using tcExtendNameTyVarEnv is appropriate here
+ -- because we're not really bringing fresh tyvars into scope.
+ -- We're *naming* existing tyvars. Note that it is OK for a tyvar
+ -- from an outer scope to mention one of these tyvars in its kind.
+ ; (pat', res) <- tcExtendNameTyVarEnv wcs $
+ tcExtendNameTyVarEnv tv_binds $
+ tc_lpat (Scaled w_pat $ mkCheckExpType inner_ty) penv pat thing_inside
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
------------------------
-- Lists, tuples, arrays
-- Necessarily a built-in list pattern, not an overloaded list pattern.
-- See Note [Desugaring overloaded list patterns].
- ListPat _ pats -> do
- { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty)
- ; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty))
- penv pats thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (mkHsWrapPat coi
- (ListPat elt_ty pats') pat_ty, res) }
-
- TuplePat _ pats boxity -> do
- { let arity = length pats
- tc = tupleTyCon boxity arity
- -- NB: tupleTyCon does not flatten 1-tuples
- -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
- ; checkTupSize arity
- ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
- penv (scaledThing pat_ty)
- -- Unboxed tuples have RuntimeRep vars, which we discard:
- -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
- ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
- Boxed -> arg_tys
- ; (pats', res) <- tc_lpats (map (scaledSet pat_ty . mkCheckExpType) con_arg_tys)
+ ListPat _ pats -> do
+ { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv exp_pat_ty
+ ; (pats', res) <- tcMultiple (tc_lpat (Scaled w_pat $ mkCheckExpType elt_ty))
penv pats thing_inside
-
- ; dflags <- getDynFlags
-
- -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
- -- so that we can experiment with lazy tuple-matching.
- -- This is a pretty odd place to make the switch, but
- -- it was easy to do.
- ; let
- unmangled_result = TuplePat con_arg_tys pats' boxity
- -- pat_ty /= pat_ty iff coi /= IdCo
- possibly_mangled_result
- | gopt Opt_IrrefutableTuples dflags &&
- isBoxed boxity = LazyPat noExtField (noLocA unmangled_result)
- | otherwise = unmangled_result
-
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced
- ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
- }
-
- SumPat _ pat alt arity -> do
- { let tc = sumTyCon arity
- ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
- penv (scaledThing pat_ty)
- ; -- Drop levity vars, we don't care about them here
- let con_arg_tys = drop arity arg_tys
- ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
- penv pat thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
- , res)
- }
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (mkHsWrapPat coi
+ (ListPat elt_ty pats') pat_ty, res) }
+
+ TuplePat _ pats boxity -> do
+ { let arity = length pats
+ tc = tupleTyCon boxity arity
+ -- NB: tupleTyCon does not flatten 1-tuples
+ -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
+ ; checkTupSize arity
+ ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv exp_pat_ty
+ -- Unboxed tuples have RuntimeRep vars, which we discard:
+ -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
+ ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
+ Boxed -> arg_tys
+ ; (pats', res) <- tc_lpats (map (Scaled w_pat . mkCheckExpType) con_arg_tys)
+ penv pats thing_inside
+
+ ; dflags <- getDynFlags
+
+ -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
+ -- so that we can experiment with lazy tuple-matching.
+ -- This is a pretty odd place to make the switch, but
+ -- it was easy to do.
+ ; let
+ unmangled_result = TuplePat con_arg_tys pats' boxity
+ -- pat_ty /= pat_ty iff coi /= IdCo
+ possibly_mangled_result
+ | gopt Opt_IrrefutableTuples dflags &&
+ isBoxed boxity = LazyPat noExtField (noLocA unmangled_result)
+ | otherwise = unmangled_result
+
+ ; pat_ty <- readExpType exp_pat_ty
+ ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced
+ ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
+ }
+
+ SumPat _ pat alt arity -> do
+ { let tc = sumTyCon arity
+ ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv exp_pat_ty
+ ; -- Drop levity vars, we don't care about them here
+ let con_arg_tys = drop arity arg_tys
+ ; (pat', res) <- tc_lpat (Scaled w_pat $ mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
+ penv pat thing_inside
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
+ , res)
+ }
------------------------
-- Data constructors
- ConPat _ con arg_pats ->
- tcConPat penv con pat_ty arg_pats thing_inside
+ ConPat _ con arg_pats ->
+ tcConPat penv con scaled_exp_pat_ty arg_pats thing_inside
------------------------
-- Literal patterns
- LitPat x simple_lit -> do
- { let lit_ty = hsLitType simple_lit
- ; wrap <- tc_sub_type penv (scaledThing pat_ty) lit_ty
- ; res <- thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
- , res) }
+ LitPat x simple_lit -> do
+ { let lit_ty = hsLitType simple_lit
+ ; wrap <- tcSubTypePat_GenSigCtxt penv exp_pat_ty lit_ty
+ ; res <- thing_inside
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
+ , res) }
------------------------
-- Overloaded patterns: n, and n+k
@@ -854,31 +866,31 @@ Another example is #26331.
-- where lit_ty is the type of the overloaded literal 5.
--
-- When there is no negation, neg_lit_ty and lit_ty are the same
- NPat _ (L l over_lit) mb_neg eq -> do
- { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
- -- It may be possible to refine linear pattern so that they work in
- -- linear environments. But it is not clear how useful this is.
- ; let orig = LiteralOrigin over_lit
- ; ((lit', mb_neg'), eq')
- <- tcSyntaxOp orig eq [SynType (scaledThing pat_ty), SynAny]
- (mkCheckExpType boolTy) $
- \ [neg_lit_ty] _ ->
- let new_over_lit lit_ty = newOverloadedLit over_lit
- (mkCheckExpType lit_ty)
- in case mb_neg of
- Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty
- Just neg -> -- Negative literal
- -- The 'negate' is re-mappable syntax
- second Just <$>
- (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
- \ [lit_ty] _ -> new_over_lit lit_ty)
- -- applied to a closed literal: linearity doesn't matter as
- -- literals are typed in an empty environment, hence have
- -- all multiplicities.
-
- ; res <- thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (NPat pat_ty (L l lit') mb_neg' eq', res) }
+ NPat _ (L l over_lit) mb_neg eq -> do
+ { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ -- It may be possible to refine linear pattern so that they work in
+ -- linear environments. But it is not clear how useful this is.
+ ; let orig = LiteralOrigin over_lit
+ ; ((lit', mb_neg'), eq')
+ <- tcSyntaxOp orig eq [SynType exp_pat_ty, SynAny]
+ (mkCheckExpType boolTy) $
+ \ [neg_lit_ty] _ ->
+ let new_over_lit lit_ty = newOverloadedLit over_lit
+ (mkCheckExpType lit_ty)
+ in case mb_neg of
+ Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty
+ Just neg -> -- Negative literal
+ -- The 'negate' is re-mappable syntax
+ second Just <$>
+ (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
+ \ [lit_ty] _ -> new_over_lit lit_ty)
+ -- applied to a closed literal: linearity doesn't matter as
+ -- literals are typed in an empty environment, hence have
+ -- all multiplicities.
+
+ ; res <- thing_inside
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (NPat pat_ty (L l lit') mb_neg' eq', res) }
{-
Note [NPlusK patterns]
@@ -904,68 +916,67 @@ AST is used for the subtraction operation.
-}
-- See Note [NPlusK patterns]
- NPlusKPat _ (L nm_loc name)
- (L loc lit) _ ge minus -> do
- { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
- ; let pat_exp_ty = scaledThing pat_ty
- orig = LiteralOrigin lit
- ; (lit1', ge')
- <- tcSyntaxOp orig ge [SynType pat_exp_ty, SynRho]
- (mkCheckExpType boolTy) $
- \ [lit1_ty] _ ->
- newOverloadedLit lit (mkCheckExpType lit1_ty)
- ; ((lit2', minus_wrap, bndr_id), minus')
- <- tcSyntaxOpGen orig minus [SynType pat_exp_ty, SynRho] SynAny $
- \ [lit2_ty, var_ty] _ ->
- do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
- ; (wrap, bndr_id) <- setSrcSpanA nm_loc $
- tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty)
- -- co :: var_ty ~ idType bndr_id
-
- -- minus_wrap is applicable to minus'
- ; return (lit2', wrap, bndr_id) }
-
- ; pat_ty <- readExpType pat_exp_ty
-
- -- The Report says that n+k patterns must be in Integral
- -- but it's silly to insist on this in the RebindableSyntax case
- ; unlessM (xoptM LangExt.RebindableSyntax) $
- do { icls <- tcLookupClass integralClassName
- ; instStupidTheta orig [mkClassPred icls [pat_ty]] }
-
- ; res <- tcExtendIdEnv1 name bndr_id thing_inside
-
- ; let minus'' = case minus' of
- NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus')
- -- this should be statically avoidable
- -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr"
- SyntaxExprTc { syn_expr = minus'_expr
- , syn_arg_wraps = minus'_arg_wraps
- , syn_res_wrap = minus'_res_wrap }
- -> SyntaxExprTc { syn_expr = minus'_expr
- , syn_arg_wraps = minus'_arg_wraps
- , syn_res_wrap = minus_wrap <.> minus'_res_wrap }
- -- Oy. This should really be a record update, but
- -- we get warnings if we try. #17783
- pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'
- ge' minus''
- ; return (pat', res) }
+ NPlusKPat _ (L nm_loc name)
+ (L loc lit) _ ge minus -> do
+ { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ ; let orig = LiteralOrigin lit
+ ; (lit1', ge')
+ <- tcSyntaxOp orig ge [SynType exp_pat_ty, SynRho]
+ (mkCheckExpType boolTy) $
+ \ [lit1_ty] _ ->
+ newOverloadedLit lit (mkCheckExpType lit1_ty)
+ ; ((lit2', minus_wrap, bndr_id), minus')
+ <- tcSyntaxOpGen orig minus [SynType exp_pat_ty, SynRho] SynAny $
+ \ [lit2_ty, var_ty] _ ->
+ do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
+ ; (wrap, bndr_id) <- setSrcSpanA nm_loc $
+ tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty)
+ -- co :: var_ty ~ idType bndr_id
+
+ -- minus_wrap is applicable to minus'
+ ; return (lit2', wrap, bndr_id) }
+
+ ; pat_ty <- readExpType exp_pat_ty
+
+ -- The Report says that n+k patterns must be in Integral
+ -- but it's silly to insist on this in the RebindableSyntax case
+ ; unlessM (xoptM LangExt.RebindableSyntax) $
+ do { icls <- tcLookupClass integralClassName
+ ; instStupidTheta orig [mkClassPred icls [pat_ty]] }
+
+ ; res <- tcExtendIdEnv1 name bndr_id thing_inside
+
+ ; let minus'' = case minus' of
+ NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus')
+ -- this should be statically avoidable
+ -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr"
+ SyntaxExprTc { syn_expr = minus'_expr
+ , syn_arg_wraps = minus'_arg_wraps
+ , syn_res_wrap = minus'_res_wrap }
+ -> SyntaxExprTc { syn_expr = minus'_expr
+ , syn_arg_wraps = minus'_arg_wraps
+ , syn_res_wrap = minus_wrap <.> minus'_res_wrap }
+ -- Oy. This should really be a record update, but
+ -- we get warnings if we try. #17783
+ pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'
+ ge' minus''
+ ; return (pat', res) }
-- Here we get rid of it and add the finalizers to the global environment.
-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
- SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do
+ SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do
{ addModFinalizersWithLclEnv mod_finalizers
- ; tc_pat pat_ty penv pat thing_inside }
+ ; tc_pat scaled_exp_pat_ty penv pat thing_inside }
- SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat"
+ SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat"
- EmbTyPat _ _ -> failWith TcRnIllegalTypePattern
+ EmbTyPat _ _ -> failWith TcRnIllegalTypePattern
- InvisPat _ _ -> panic "tc_pat: invisible pattern appears recursively in the pattern"
+ InvisPat _ _ -> panic "tc_pat: invisible pattern appears recursively in the pattern"
- XPat (HsPatExpanded lpat rpat) -> do
- { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside
- ; return (XPat $ ExpansionPat lpat rpat', res) }
+ XPat (HsPatExpanded lpat rpat) -> do
+ { (rpat', res) <- tc_pat scaled_exp_pat_ty penv rpat thing_inside
+ ; return (XPat $ ExpansionPat lpat rpat', res) }
{-
Note [Hopping the LIE in lazy patterns]
@@ -1295,7 +1306,7 @@ tcPatSynPat (L con_span con_name) pat_syn pat_ty penv arg_pats thing_inside
; (univ_ty_args, ex_ty_args, val_arg_pats) <- splitConTyArgs con_like arg_pats
- ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty'
+ ; wrap <- tcSubTypePat_GenSigCtxt penv (scaledThing pat_ty) ty'
; traceTc "tcPatSynPat" $
vcat [ text "Pat syn:" <+> ppr pat_syn
@@ -1405,8 +1416,9 @@ matchExpectedConTy :: PatEnv
-- In the case of a data family, this would
-- mention the /family/ TyCon
-> TcM (HsWrapper, [TcSigmaType])
--- See Note [Matching constructor patterns]
--- Returns a wrapper : pat_ty "->" T ty1 ... tyn
+-- ^ See Note [Matching constructor patterns]
+--
+-- Returns a wrapper : pat_ty ~~> T ty1 ... tyn
matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty
| Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc
-- Comments refer to Note [Matching constructor patterns]
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -263,7 +263,9 @@ in two places:
* In `updInertDicts`, in this module, when adding [G] (?x :: ty), remove any
existing [G] (?x :: ty'), regardless of ty'.
-* Wrinkle (SIP1): we must be careful of superclasses. Consider
+There are wrinkles:
+
+* Wrinkle (SIP1): we must be careful of superclasses (#14218). Consider
f,g :: (?x::Int, C a) => a -> a
f v = let ?x = 4 in g v
@@ -271,24 +273,31 @@ in two places:
We must /not/ solve this from the Given (?x::Int, C a), because of
the intervening binding for (?x::Int). #14218.
- We deal with this by arranging that when we add [G] (?x::ty) we delete
+ We deal with this by arranging that when we add [G] (?x::ty) we /delete/
* from the inert_cans, and
* from the inert_solved_dicts
any existing [G] (?x::ty) /and/ any [G] D tys, where (D tys) has a superclass
with (?x::ty). See Note [Local implicit parameters] in GHC.Core.Predicate.
- An important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
- But it could happen for `class xx => D xx where ...` and the constraint D
- (?x :: int). This corner (constraint-kinded variables instantiated with
- implicit parameter constraints) is not well explored.
+ An very important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
+
+ But it could also happen for `class xx => D xx where ...` and the constraint
+ D (?x :: int); again see Note [Local implicit parameters]. This corner
+ (constraint-kinded variables instantiated with implicit parameter constraints)
+ is not well explored.
- Example in #14218, and #23761
+ You might worry about whether deleting an /entire/ constraint just because
+ a distant superclass has an implicit parameter might make another Wanted for
+ that constraint un-solvable. Indeed so. But for constraint tuples it doesn't
+ matter -- their entire payload is their superclasses. And the other case is
+ the ill-explored corner above.
The code that accounts for (SIP1) is in updInertDicts; in particular the call to
GHC.Core.Predicate.mentionsIP.
* Wrinkle (SIP2): we must apply this update semantics for `inert_solved_dicts`
- as well as `inert_cans`.
+ as well as `inert_cans` (#23761).
+
You might think that wouldn't be necessary, because an element of
`inert_solved_dicts` is never an implicit parameter (see
Note [Solved dictionaries] in GHC.Tc.Solver.InertSet).
@@ -301,6 +310,19 @@ in two places:
Now (C (?x::Int)) has a superclass (?x::Int). This may look exotic, but it
happens particularly for constraint tuples, like `(% ?x::Int, Eq a %)`.
+* Wrinkle (SIP3)
+ - Note that for the inert dictionaries, `inert_cans`, we must /only/ delete
+ existing /Givens/! Deleting an existing Wanted led to #26451; we just never
+ solved it!
+
+ - In contrast, the solved dictionaries, `inert_solved_dicts`, are really like
+ Givens; they may be "inherited" from outer scopes, so we must delete any
+ solved dictionaries for this implicit parameter for /both/ Givens /and/
+ Wanteds.
+
+ Otherwise the new Given doesn't properly shadow those inherited solved
+ dictionaries. Test T23761 showed this up.
+
Example 1:
Suppose we have (typecheck/should_compile/ImplicitParamFDs)
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -377,28 +377,53 @@ in GHC.Tc.Solver.Dict.
-}
updInertDicts :: DictCt -> TcS ()
-updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
- = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys)
-
- ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys
- -> -- For [G] ?x::ty, remove any dicts mentioning ?x,
- -- from /both/ inert_cans /and/ inert_solved_dicts (#23761)
- -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters]
- updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
- inerts { inert_cans = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics
- , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved }
- | otherwise
- -> return ()
+updInertDicts dict_ct
+ = do { traceTcS "Adding inert dict" (ppr dict_ct)
+
+ -- For Given implicit parameters (only), delete any existing
+ -- Givens for the same implicit parameter.
+ -- See Note [Shadowing of implicit parameters]
+ ; deleteGivenIPs dict_ct
+
-- Add the new constraint to the inert set
; updInertCans (updDicts (addDict dict_ct)) }
+
+deleteGivenIPs :: DictCt -> TcS ()
+-- Special magic when adding a Given implicit parameter to the inert set
+-- For [G] ?x::ty, remove any existing /Givens/ mentioning ?x,
+-- from /both/ inert_cans /and/ inert_solved_dicts (#23761)
+-- See Note [Shadowing of implicit parameters]
+deleteGivenIPs (DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
+ | isGiven ev
+ , Just (str_ty, _) <- isIPPred_maybe cls tys
+ = updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
+ inerts { inert_cans = updDicts (filterDicts (keep_can str_ty)) ics
+ , inert_solved_dicts = filterDicts (keep_solved str_ty) solved }
+ | otherwise
+ = return ()
where
- -- Does this class constraint or any of its superclasses mention
- -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?
- does_not_mention_ip_for :: Type -> DictCt -> Bool
- does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
- = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys
- -- See Note [Using typesAreApart when calling mightMentionIP]
- -- in GHC.Core.Predicate
+ keep_can, keep_solved :: Type -> DictCt -> Bool
+ -- keep_can: we keep an inert dictionary UNLESS
+ -- (1) it is a Given
+ -- (2) it binds an implicit parameter (?str :: ty) for the given 'str'
+ -- regardless of 'ty', possibly via its superclasses
+ -- The test is a bit conservative, hence `mightMentionIP` and `typesAreApart`
+ -- See Note [Using typesAreApart when calling mightMentionIP]
+ -- in GHC.Core.Predicate
+ --
+ -- keep_solved: same as keep_can, but for /all/ constraints not just Givens
+ --
+ -- Why two functions? See (SIP3) in Note [Shadowing of implicit parameters]
+ keep_can str (DictCt { di_ev = ev, di_cls = cls, di_tys = tys })
+ = not (isGiven ev -- (1)
+ && mentions_ip str cls tys) -- (2)
+ keep_solved str (DictCt { di_cls = cls, di_tys = tys })
+ = not (mentions_ip str cls tys)
+
+ -- mentions_ip: the inert constraint might provide evidence
+ -- for an implicit parameter (?str :: ty) for the given 'str'
+ mentions_ip str cls tys
+ = mightMentionIP (not . typesAreApart str) (const True) cls tys
updInertIrreds :: IrredCt -> TcS ()
updInertIrreds irred
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -197,29 +197,29 @@ that it is a no-op. Here's our solution:
* we /must/ optimise subtype-HsWrappers (that's the point of this Note!)
* there is little point in attempting to optimise any other HsWrappers
-Note [WpFun-RR-INVARIANT]
-~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [WpFun-FRR-INVARIANT]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
Given
wrap = WpFun wrap1 wrap2 sty1 ty2
where: wrap1 :: exp_arg ~~> act_arg
wrap2 :: act_res ~~> exp_res
wrap :: (act_arg -> act_res) ~~> (exp_arg -> exp_res)
we have
- WpFun-RR-INVARIANT:
+ WpFun-FRR-INVARIANT:
the input (exp_arg) and output (act_arg) types of `wrap1`
both have a fixed runtime-rep
Reason: We desugar wrap[e] into
\(x:exp_arg). wrap2[ e wrap1[x] ]
-And then, because of Note [Representation polymorphism invariants], we need:
+And then, because of Note [Representation polymorphism invariants]:
* `exp_arg` must have a fixed runtime rep,
so that lambda obeys the the FRR rules
* `act_arg` must have a fixed runtime rep,
- so the that application (e wrap1[x]) obeys the FRR tules
+ so that the application (e wrap1[x]) obeys the FRR rules
-Hence WpFun-INVARIANT.
+Hence WpFun-FRR-INVARIANT.
-}
data HsWrapper
@@ -246,7 +246,7 @@ data HsWrapper
-- (WpFun wrap1 wrap2 (w, t1) t2)[e] = \(x:_w exp_arg). wrap2[ e wrap1[x] ]
--
-- INVARIANT: both input and output types of `wrap1` have a fixed runtime-rep
- -- See Note [WpFun-RR-INVARIANT]
+ -- See Note [WpFun-FRR-INVARIANT]
--
-- Typing rules:
-- If e :: act_arg -> act_res
@@ -319,7 +319,7 @@ mkWpFun :: HsWrapper -> HsWrapper
-- ^ Smart constructor for `WpFun`
-- Just removes clutter and optimises some common cases.
--
--- PRECONDITION: same as Note [WpFun-RR-INVARIANT]
+-- PRECONDITION: same as Note [WpFun-FRR-INVARIANT]
--
-- Unfortunately, we can't check PRECONDITION with an assertion here, because of
-- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -277,7 +277,7 @@ skolemiseRequired skolem_info n_req sigma
topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
-- Instantiate outer invisible binders (both Inferred and Specified)
-- If top_instantiate ty = (wrap, inner_ty)
--- then wrap :: inner_ty "->" ty
+-- then wrap :: inner_ty ~~> ty
-- NB: returns a type with no (=>),
-- and no invisible forall at the top
topInstantiate orig sigma
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -66,7 +66,6 @@ module GHC.Tc.Utils.Unify (
import GHC.Prelude
import GHC.Hs
-
import GHC.Tc.Errors.Types ( ErrCtxtMsg(..) )
import GHC.Tc.Errors.Ppr ( pprErrCtxtMsg )
import GHC.Tc.Utils.Concrete
@@ -256,24 +255,24 @@ matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpected
-- and res_ty is a RhoType
-- NB: the returned type is top-instantiated; it's a RhoType
matchActualFunTys herald ct_orig n_val_args_wanted top_ty
- = go n_val_args_wanted [] top_ty
+ = go n_val_args_wanted top_ty
where
- go n so_far fun_ty
+ go n fun_ty
| not (isRhoTy fun_ty)
= do { (wrap1, rho) <- topInstantiate ct_orig fun_ty
- ; (wrap2, arg_tys, res_ty) <- go n so_far rho
+ ; (wrap2, arg_tys, res_ty) <- go n rho
; return (wrap2 <.> wrap1, arg_tys, res_ty) }
- go 0 _ fun_ty = return (idHsWrapper, [], fun_ty)
+ go 0 fun_ty = return (idHsWrapper, [], fun_ty)
- go n so_far fun_ty
- = do { (co1, arg_ty1, res_ty1) <- matchActualFunTy herald Nothing
- (n_val_args_wanted, top_ty) fun_ty
- ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1
- ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty
- -- NB: arg_ty1 comes from matchActualFunTy, so it has
- -- a syntactically fixed RuntimeRep
- ; return (wrap_fun2 <.> mkWpCastN co1, arg_ty1:arg_tys, res_ty) }
+ go n fun_ty
+ = do { (co1, arg1_ty_frr, res_ty1) <-
+ matchActualFunTy herald Nothing (n_val_args_wanted, top_ty) fun_ty
+ ; (wrap_res, arg_tys, res_ty) <- go (n-1) res_ty1
+ ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg1_ty_frr res_ty
+ -- This call to mkWpFun satisfies WpFun-FRR-INVARIANT:
+ -- 'arg1_ty_frr' comes from matchActualFunTy, so is FRR.
+ ; return (wrap_fun2 <.> mkWpCastN co1, arg1_ty_frr:arg_tys, res_ty) }
{-
************************************************************************
@@ -866,12 +865,30 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
= assert (isVisibleFunArg af) $
do { let arg_pos = arity - n_req + 1 -- 1 for the first argument etc
; (arg_co, arg_ty_frr) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty
- ; let arg_sty_frr = Scaled mult arg_ty_frr
- ; (wrap_res, result) <- check (n_req - 1)
- (mkCheckExpFunPatTy arg_sty_frr : rev_pat_tys)
+ ; let scaled_arg_ty_frr = Scaled mult arg_ty_frr
+ ; (res_wrap, result) <- check (n_req - 1)
+ (mkCheckExpFunPatTy scaled_arg_ty_frr : rev_pat_tys)
res_ty
- ; let wrap_arg = mkWpCastN arg_co
- fun_wrap = mkWpFun wrap_arg wrap_res arg_sty_frr res_ty
+
+ -- arg_co :: arg_ty ~ arg_ty_frr
+ -- res_wrap :: act_res_ty ~~> res_ty
+ ; let fun_wrap1 -- :: (arg_ty_frr -> act_res_ty) ~~> (arg_ty_frr -> res_ty)
+ = mkWpFun idHsWrapper res_wrap scaled_arg_ty_frr res_ty
+ -- Satisfies WpFun-FRR-INVARIANT because arg_sty_frr is FRR
+
+ fun_wrap2 -- :: (arg_ty_frr -> res_ty) ~~> (arg_ty -> res_ty)
+ = mkWpCastN (mkFunCo Nominal af (mkNomReflCo mult) (mkSymCo arg_co) (mkNomReflCo res_ty))
+
+ fun_wrap -- :: (arg_ty_frr -> act_res_ty) ~~> (arg_ty -> res_ty)
+ = fun_wrap2 <.> fun_wrap1
+
+-- NB: in the common case, 'arg_ty' is already FRR (in the sense of
+-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete), hence 'arg_co' is 'Refl'.
+-- Then 'fun_wrap' will collapse down to 'fun_wrap1'. This applies recursively;
+-- as 'mkWpFun WpHole WpHole' is 'WpHole', this means that 'fun_wrap' will
+-- typically just be 'WpHole'; no clutter.
+-- This is important because 'matchExpectedFunTys' is called a lot.
+
; return (fun_wrap, result) }
----------------------------
@@ -1404,7 +1421,7 @@ tcSubTypeMono rn_expr act_ty exp_ty
------------------------
tcSubTypePat :: CtOrigin -> UserTypeCtxt
- -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
+ -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
-- Used in patterns; polarity is backwards compared
-- to tcSubType
-- If wrap = tc_sub_type_et t1 t2
=====================================
docs/users_guide/compare-flags.py
=====================================
@@ -35,7 +35,7 @@ def expected_undocumented(flag: str) -> bool:
return False
-def read_documented_flags(doc_flags) -> Set[str]:
+def read_documented_flags(doc_flags: Path) -> Set[str]:
# Map characters that mark the end of a flag
# to whitespace.
trans = str.maketrans({
@@ -44,10 +44,10 @@ def read_documented_flags(doc_flags) -> Set[str]:
'⟨': ' ',
})
return {line.translate(trans).split()[0]
- for line in doc_flags.read().split('\n')
+ for line in doc_flags.read_text(encoding="UTF-8").split('\n')
if line != ''}
-def read_ghc_flags(ghc_path: str) -> Set[str]:
+def read_ghc_flags(ghc_path: Path) -> Set[str]:
ghc_output = subprocess.check_output([ghc_path, '--show-options'])
ghci_output = subprocess.check_output([ghc_path, '--interactive', '--show-options'])
@@ -63,16 +63,16 @@ def error(s: str):
def main() -> None:
import argparse
parser = argparse.ArgumentParser()
- parser.add_argument('--ghc', type=argparse.FileType('r'),
+ parser.add_argument('--ghc', type=Path,
help='path of GHC executable',
required=True)
- parser.add_argument('--doc-flags', type=argparse.FileType(mode='r', encoding='UTF-8'),
+ parser.add_argument('--doc-flags', type=Path,
help='path of ghc-flags.txt output from Sphinx',
required=True)
args = parser.parse_args()
doc_flags = read_documented_flags(args.doc_flags)
- ghc_flags = read_ghc_flags(args.ghc.name)
+ ghc_flags = read_ghc_flags(args.ghc)
failed = False
=====================================
libraries/os-string
=====================================
@@ -1 +1 @@
-Subproject commit 2e693aad07540173a0169971b27c9acac28eeff1
+Subproject commit c08666bf7bf528e607fc1eacc20032ec59e69df3
=====================================
libraries/unix
=====================================
@@ -1 +1 @@
-Subproject commit c9b3e95b5c15b118e55522bd92963038c6a88160
+Subproject commit 60f432b76871bd7787df07dd3e2a567caba393f5
=====================================
rts/Interpreter.c
=====================================
@@ -91,6 +91,80 @@ See also Note [Width of parameters] for some more motivation.
/* #define INTERP_STATS */
+// Note [Instruction dispatch in the bytecode interpreter]
+// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+// Like all bytecode interpreters out there, instruction dispatch is
+// the backbone of our bytecode interpreter:
+//
+// - Each instruction starts with a unique integer tag
+// - Each instruction has a piece of code to handle it
+// - Fetch next instruction's tag, interpret, repeat
+//
+// There are two classical approaches to organize the interpreter loop
+// and implement instruction dispatch:
+//
+// 1. switch-case: fetch the instruction tag, then a switch statement
+// contains each instruction's handler code as a case within it.
+// This is the simplest and most portable approach, but the
+// compiler often generates suboptimal code that involves two jumps
+// per instruction: the first one that jumps back to the switch
+// statement, followed by the second one that jumps to the handler
+// case statement.
+// 2. computed-goto (direct threaded code): GNU C has an extension
+// (https://gcc.gnu.org/onlinedocs/gcc/Labels-as-Values.html) that
+// allows storing a code label as a pointer and using the goto
+// statement to jump to such a pointer. So we can organize the
+// handler code as a code block under a label, have a pointer array
+// that maps an instruction tag to its handler's code label, then
+// instruction dispatch can happen with a single jump after a
+// memory load.
+//
+// A classical paper "The Structure and Performance of Efficient
+// Interpreters" by M. Anton Ertl and David Gregg in 2003 explains it
+// in further details with profiling data:
+// https://jilp.org/vol5/v5paper12.pdf. There exist more subtle issues
+// like interaction with modern CPU's branch predictors, though in
+// practice computed-goto does outperform switch-case, and I've
+// observed around 10%-15% wall clock time speedup in simple
+// benchmarks, so our bytecode interpreter now defaults to using
+// computed-goto when applicable, and falls back to switch-case in
+// other cases.
+//
+// The COMPUTED_GOTO macro is defined when we use computed-goto. We
+// don't do autoconf feature detection since it works with all
+// versions of gcc/clang on all platforms we currently support.
+// Exceptions include:
+//
+// - When DEBUG or other macros are enabled so that there's extra
+// logic per instruction: assertions, statistics, etc. To make
+// computed-goto support those would need us to duplicate the extra
+// code in every instruction's handler code block, not really worth
+// it when speed is not the primary concern.
+// - On wasm, because wasm prohibits goto anyway and LLVM has to lower
+// goto in C to br_table, so there's no performance benefit of
+// computed-goto, only slight penalty due to an extra load from the
+// user-defined dispatch table in the linear memory.
+//
+// The source of truth for our bytecode definition is
+// rts/include/rts/Bytecodes.h. For each bytecode `#define bci_FOO
+// tag`, we have jumptable[tag] which stores the 32-bit offset
+// `&&lbl_bci_FOO - &&lbl_bci_DEFAULT`, so the goto destination can
+// always be computed by adding the jumptable[tag] offset to the base
+// address `&&lbl_bci_DEFAULT`. Whenever you change the bytecode
+// definitions, always remember to update `jumptable` as well!
+
+#if !defined(DEBUG) && !defined(ASSERTS_ENABLED) && !defined(INTERP_STATS) && !defined(wasm32_HOST_ARCH)
+#define COMPUTED_GOTO
+#endif
+
+#if defined(COMPUTED_GOTO)
+#pragma GCC diagnostic ignored "-Wpointer-arith"
+#define INSTRUCTION(name) lbl_##name
+#define NEXT_INSTRUCTION goto *(&&lbl_bci_DEFAULT + jumptable[(bci = instrs[bciPtr++]) & 0xFF])
+#else
+#define INSTRUCTION(name) case name
+#define NEXT_INSTRUCTION goto nextInsn
+#endif
/* Sp points to the lowest live word on the stack. */
@@ -1542,7 +1616,9 @@ run_BCO:
it_lastopc = 0; /* no opcode */
#endif
+#if !defined(COMPUTED_GOTO)
nextInsn:
+#endif
ASSERT(bciPtr < bcoSize);
IF_DEBUG(interpreter,
//if (do_print_stack) {
@@ -1572,15 +1648,263 @@ run_BCO:
it_lastopc = (int)instrs[bciPtr];
#endif
- bci = BCO_NEXT;
+#if defined(COMPUTED_GOTO)
+ static const int32_t jumptable[] = {
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_STKCHECK - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_L - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_LL - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_LLL - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH8_W - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH16_W - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH32_W - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_G - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_P - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_N - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_F - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_D - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_L - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_V - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_PAD8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_PAD16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_PAD32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_UBX8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_UBX16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_UBX32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_UBX - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_N - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_F - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_D - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_L - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_V - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_P - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_PP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_PPP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_PPPP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_PPPPP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_PPPPPP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_SLIDE - &&lbl_bci_DEFAULT,
+ &&lbl_bci_ALLOC_AP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_ALLOC_AP_NOUPD - &&lbl_bci_DEFAULT,
+ &&lbl_bci_ALLOC_PAP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_MKAP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_MKPAP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_UNPACK - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PACK - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_I - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_I - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_F - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_F - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_D - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_D - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_P - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_P - &&lbl_bci_DEFAULT,
+ &&lbl_bci_CASEFAIL - &&lbl_bci_DEFAULT,
+ &&lbl_bci_JMP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_CCALL - &&lbl_bci_DEFAULT,
+ &&lbl_bci_SWIZZLE - &&lbl_bci_DEFAULT,
+ &&lbl_bci_ENTER - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_P - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_N - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_F - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_D - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_L - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_V - &&lbl_bci_DEFAULT,
+ &&lbl_bci_BRK_FUN - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_W - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_W - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_T - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_T - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_I64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_I64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_I32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_I32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_I16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_I16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_I8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_I8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_W64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_W64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_W32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_W32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_W16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_W16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_W8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_W8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PRIMCALL - &&lbl_bci_DEFAULT,
+ &&lbl_bci_BCO_NAME - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ADD_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SUB_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_AND_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_XOR_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NOT_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEG_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_MUL_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SHL_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ASR_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_LSR_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_OR_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEQ_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_EQ_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GE_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GT_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LT_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LE_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GE_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GT_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LT_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LE_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ADD_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SUB_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_AND_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_XOR_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NOT_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEG_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_MUL_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SHL_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ASR_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_LSR_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_OR_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEQ_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_EQ_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GE_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GT_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LT_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LE_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GE_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GT_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LT_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LE_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ADD_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SUB_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_AND_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_XOR_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NOT_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEG_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_MUL_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SHL_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ASR_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_LSR_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_OR_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEQ_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_EQ_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GE_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GT_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LT_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LE_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GE_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GT_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LT_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LE_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ADD_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SUB_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_AND_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_XOR_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NOT_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEG_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_MUL_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SHL_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ASR_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_LSR_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_OR_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEQ_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_EQ_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GE_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GT_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LT_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LE_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GE_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GT_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LT_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LE_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_INDEX_ADDR_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_INDEX_ADDR_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_INDEX_ADDR_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_INDEX_ADDR_64 - &&lbl_bci_DEFAULT};
+ NEXT_INSTRUCTION;
+#else
+ bci = BCO_NEXT;
/* We use the high 8 bits for flags. The highest of which is
* currently allocated to LARGE_ARGS */
ASSERT((bci & 0xFF00) == (bci & ( bci_FLAG_LARGE_ARGS )));
-
switch (bci & 0xFF) {
+#endif
/* check for a breakpoint on the beginning of a BCO */
- case bci_BRK_FUN:
+ INSTRUCTION(bci_BRK_FUN):
{
W_ arg1_brk_array, arg2_info_mod_name, arg3_info_mod_id, arg4_info_index;
#if defined(PROFILING)
@@ -1779,10 +2103,10 @@ run_BCO:
cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
// continue normal execution of the byte code instructions
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_STKCHECK: {
+ INSTRUCTION(bci_STKCHECK): {
// Explicit stack check at the beginning of a function
// *only* (stack checks in case alternatives are
// propagated to the enclosing function).
@@ -1793,27 +2117,27 @@ run_BCO:
SpW(0) = (W_)&stg_apply_interp_info;
RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
} else {
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
}
- case bci_PUSH_L: {
+ INSTRUCTION(bci_PUSH_L): {
W_ o1 = BCO_GET_LARGE_ARG;
SpW(-1) = ReadSpW(o1);
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_LL: {
+ INSTRUCTION(bci_PUSH_LL): {
W_ o1 = BCO_GET_LARGE_ARG;
W_ o2 = BCO_GET_LARGE_ARG;
SpW(-1) = ReadSpW(o1);
SpW(-2) = ReadSpW(o2);
Sp_subW(2);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_LLL: {
+ INSTRUCTION(bci_PUSH_LLL): {
W_ o1 = BCO_GET_LARGE_ARG;
W_ o2 = BCO_GET_LARGE_ARG;
W_ o3 = BCO_GET_LARGE_ARG;
@@ -1821,52 +2145,52 @@ run_BCO:
SpW(-2) = ReadSpW(o2);
SpW(-3) = ReadSpW(o3);
Sp_subW(3);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH8: {
+ INSTRUCTION(bci_PUSH8): {
W_ off = BCO_GET_LARGE_ARG;
Sp_subB(1);
*(StgWord8*)Sp = (StgWord8) (ReadSpB(off+1));
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH16: {
+ INSTRUCTION(bci_PUSH16): {
W_ off = BCO_GET_LARGE_ARG;
Sp_subB(2);
*(StgWord16*)Sp = (StgWord16) (ReadSpB(off+2));
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH32: {
+ INSTRUCTION(bci_PUSH32): {
W_ off = BCO_GET_LARGE_ARG;
Sp_subB(4);
*(StgWord32*)Sp = (StgWord32) (ReadSpB(off+4));
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH8_W: {
+ INSTRUCTION(bci_PUSH8_W): {
W_ off = BCO_GET_LARGE_ARG;
*(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord8) (ReadSpB(off)));
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH16_W: {
+ INSTRUCTION(bci_PUSH16_W): {
W_ off = BCO_GET_LARGE_ARG;
*(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord16) (ReadSpB(off)));
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH32_W: {
+ INSTRUCTION(bci_PUSH32_W): {
W_ off = BCO_GET_LARGE_ARG;
*(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord32) (ReadSpB(off)));
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_G: {
+ INSTRUCTION(bci_PUSH_G): {
W_ o1 = BCO_GET_LARGE_ARG;
StgClosure *tagged_obj = (StgClosure*) BCO_PTR(o1);
@@ -1905,10 +2229,10 @@ run_BCO:
SpW(-1) = (W_) tagged_obj;
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_P: {
+ INSTRUCTION(bci_PUSH_ALTS_P): {
W_ o_bco = BCO_GET_LARGE_ARG;
Sp_subW(2);
SpW(1) = BCO_PTR(o_bco);
@@ -1918,10 +2242,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_N: {
+ INSTRUCTION(bci_PUSH_ALTS_N): {
W_ o_bco = BCO_GET_LARGE_ARG;
SpW(-2) = (W_)&stg_ctoi_R1n_info;
SpW(-1) = BCO_PTR(o_bco);
@@ -1931,10 +2255,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_F: {
+ INSTRUCTION(bci_PUSH_ALTS_F): {
W_ o_bco = BCO_GET_LARGE_ARG;
SpW(-2) = (W_)&stg_ctoi_F1_info;
SpW(-1) = BCO_PTR(o_bco);
@@ -1944,10 +2268,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_D: {
+ INSTRUCTION(bci_PUSH_ALTS_D): {
W_ o_bco = BCO_GET_LARGE_ARG;
SpW(-2) = (W_)&stg_ctoi_D1_info;
SpW(-1) = BCO_PTR(o_bco);
@@ -1957,10 +2281,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_L: {
+ INSTRUCTION(bci_PUSH_ALTS_L): {
W_ o_bco = BCO_GET_LARGE_ARG;
SpW(-2) = (W_)&stg_ctoi_L1_info;
SpW(-1) = BCO_PTR(o_bco);
@@ -1970,10 +2294,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_V: {
+ INSTRUCTION(bci_PUSH_ALTS_V): {
W_ o_bco = BCO_GET_LARGE_ARG;
SpW(-2) = (W_)&stg_ctoi_V_info;
SpW(-1) = BCO_PTR(o_bco);
@@ -1983,10 +2307,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_T: {
+ INSTRUCTION(bci_PUSH_ALTS_T): {
W_ o_bco = BCO_GET_LARGE_ARG;
W_ tuple_info = (W_)BCO_LIT(BCO_GET_LARGE_ARG);
W_ o_tuple_bco = BCO_GET_LARGE_ARG;
@@ -2006,83 +2330,83 @@ run_BCO:
W_ ctoi_t_offset = (W_) ctoi_tuple_infos[tuple_stack_words];
SpW(-4) = ctoi_t_offset;
Sp_subW(4);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_APPLY_N:
+ INSTRUCTION(bci_PUSH_APPLY_N):
Sp_subW(1); SpW(0) = (W_)&stg_ap_n_info;
- goto nextInsn;
- case bci_PUSH_APPLY_V:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_V):
Sp_subW(1); SpW(0) = (W_)&stg_ap_v_info;
- goto nextInsn;
- case bci_PUSH_APPLY_F:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_F):
Sp_subW(1); SpW(0) = (W_)&stg_ap_f_info;
- goto nextInsn;
- case bci_PUSH_APPLY_D:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_D):
Sp_subW(1); SpW(0) = (W_)&stg_ap_d_info;
- goto nextInsn;
- case bci_PUSH_APPLY_L:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_L):
Sp_subW(1); SpW(0) = (W_)&stg_ap_l_info;
- goto nextInsn;
- case bci_PUSH_APPLY_P:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_P):
Sp_subW(1); SpW(0) = (W_)&stg_ap_p_info;
- goto nextInsn;
- case bci_PUSH_APPLY_PP:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_PP):
Sp_subW(1); SpW(0) = (W_)&stg_ap_pp_info;
- goto nextInsn;
- case bci_PUSH_APPLY_PPP:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_PPP):
Sp_subW(1); SpW(0) = (W_)&stg_ap_ppp_info;
- goto nextInsn;
- case bci_PUSH_APPLY_PPPP:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_PPPP):
Sp_subW(1); SpW(0) = (W_)&stg_ap_pppp_info;
- goto nextInsn;
- case bci_PUSH_APPLY_PPPPP:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_PPPPP):
Sp_subW(1); SpW(0) = (W_)&stg_ap_ppppp_info;
- goto nextInsn;
- case bci_PUSH_APPLY_PPPPPP:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_PPPPPP):
Sp_subW(1); SpW(0) = (W_)&stg_ap_pppppp_info;
- goto nextInsn;
+ NEXT_INSTRUCTION;
- case bci_PUSH_PAD8: {
+ INSTRUCTION(bci_PUSH_PAD8): {
Sp_subB(1);
*(StgWord8*)Sp = 0;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_PAD16: {
+ INSTRUCTION(bci_PUSH_PAD16): {
Sp_subB(2);
*(StgWord16*)Sp = 0;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_PAD32: {
+ INSTRUCTION(bci_PUSH_PAD32): {
Sp_subB(4);
*(StgWord32*)Sp = 0;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_UBX8: {
+ INSTRUCTION(bci_PUSH_UBX8): {
W_ o_lit = BCO_GET_LARGE_ARG;
Sp_subB(1);
*(StgWord8*)Sp = (StgWord8) BCO_LIT(o_lit);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_UBX16: {
+ INSTRUCTION(bci_PUSH_UBX16): {
W_ o_lit = BCO_GET_LARGE_ARG;
Sp_subB(2);
*(StgWord16*)Sp = (StgWord16) BCO_LIT(o_lit);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_UBX32: {
+ INSTRUCTION(bci_PUSH_UBX32): {
W_ o_lit = BCO_GET_LARGE_ARG;
Sp_subB(4);
*(StgWord32*)Sp = (StgWord32) BCO_LIT(o_lit);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_UBX: {
+ INSTRUCTION(bci_PUSH_UBX): {
W_ i;
W_ o_lits = BCO_GET_LARGE_ARG;
W_ n_words = BCO_GET_LARGE_ARG;
@@ -2090,10 +2414,10 @@ run_BCO:
for (i = 0; i < n_words; i++) {
SpW(i) = (W_)BCO_LIT(o_lits+i);
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_SLIDE: {
+ INSTRUCTION(bci_SLIDE): {
W_ n = BCO_GET_LARGE_ARG;
W_ by = BCO_GET_LARGE_ARG;
/*
@@ -2106,10 +2430,10 @@ run_BCO:
}
Sp_addW(by);
INTERP_TICK(it_slides);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_ALLOC_AP: {
+ INSTRUCTION(bci_ALLOC_AP): {
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
StgAP *ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
SpW(-1) = (W_)ap;
@@ -2119,10 +2443,10 @@ run_BCO:
// visible only from our stack
SET_HDR(ap, &stg_AP_info, cap->r.rCCCS)
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_ALLOC_AP_NOUPD: {
+ INSTRUCTION(bci_ALLOC_AP_NOUPD): {
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
StgAP *ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
SpW(-1) = (W_)ap;
@@ -2132,10 +2456,10 @@ run_BCO:
// visible only from our stack
SET_HDR(ap, &stg_AP_NOUPD_info, cap->r.rCCCS)
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_ALLOC_PAP: {
+ INSTRUCTION(bci_ALLOC_PAP): {
StgPAP* pap;
StgHalfWord arity = BCO_GET_LARGE_ARG;
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
@@ -2147,10 +2471,10 @@ run_BCO:
// visible only from our stack
SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS)
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_MKAP: {
+ INSTRUCTION(bci_MKAP): {
StgHalfWord i;
W_ stkoff = BCO_GET_LARGE_ARG;
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
@@ -2171,10 +2495,10 @@ run_BCO:
debugBelch("\tBuilt ");
printObj((StgClosure*)ap);
);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_MKPAP: {
+ INSTRUCTION(bci_MKPAP): {
StgHalfWord i;
W_ stkoff = BCO_GET_LARGE_ARG;
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
@@ -2198,10 +2522,10 @@ run_BCO:
debugBelch("\tBuilt ");
printObj((StgClosure*)pap);
);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_UNPACK: {
+ INSTRUCTION(bci_UNPACK): {
/* Unpack N ptr words from t.o.s constructor */
W_ i;
W_ n_words = BCO_GET_LARGE_ARG;
@@ -2210,10 +2534,10 @@ run_BCO:
for (i = 0; i < n_words; i++) {
SpW(i) = (W_)con->payload[i];
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PACK: {
+ INSTRUCTION(bci_PACK): {
W_ o_itbl = BCO_GET_LARGE_ARG;
W_ n_words = BCO_GET_LARGE_ARG;
StgConInfoTable* itbl = CON_INFO_PTR_TO_STRUCT((StgInfoTable *)BCO_LIT(o_itbl));
@@ -2244,220 +2568,220 @@ run_BCO:
debugBelch("\tBuilt ");
printObj((StgClosure*)tagged_con);
);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_P: {
+ INSTRUCTION(bci_TESTLT_P): {
unsigned int discr = BCO_NEXT;
int failto = BCO_GET_LARGE_ARG;
StgClosure* con = UNTAG_CLOSURE((StgClosure*)ReadSpW(0));
if (GET_TAG(con) >= discr) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_P: {
+ INSTRUCTION(bci_TESTEQ_P): {
unsigned int discr = BCO_NEXT;
int failto = BCO_GET_LARGE_ARG;
StgClosure* con = UNTAG_CLOSURE((StgClosure*)ReadSpW(0));
if (GET_TAG(con) != discr) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_I: {
+ INSTRUCTION(bci_TESTLT_I): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
I_ stackInt = (I_)ReadSpW(0);
if (stackInt >= (I_)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_I64: {
+ INSTRUCTION(bci_TESTLT_I64): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt64 stackInt = ReadSpW64(0);
if (stackInt >= BCO_LITI64(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_I32: {
+ INSTRUCTION(bci_TESTLT_I32): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt32 stackInt = (StgInt32) ReadSpW(0);
if (stackInt >= (StgInt32)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_I16: {
+ INSTRUCTION(bci_TESTLT_I16): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt16 stackInt = (StgInt16) ReadSpW(0);
if (stackInt >= (StgInt16)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_I8: {
+ INSTRUCTION(bci_TESTLT_I8): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt8 stackInt = (StgInt8) ReadSpW(0);
if (stackInt >= (StgInt8)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_I: {
+ INSTRUCTION(bci_TESTEQ_I): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
I_ stackInt = (I_)ReadSpW(0);
if (stackInt != (I_)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_I64: {
+ INSTRUCTION(bci_TESTEQ_I64): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt64 stackInt = ReadSpW64(0);
if (stackInt != BCO_LITI64(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_I32: {
+ INSTRUCTION(bci_TESTEQ_I32): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt32 stackInt = (StgInt32) ReadSpW(0);
if (stackInt != (StgInt32)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_I16: {
+ INSTRUCTION(bci_TESTEQ_I16): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt16 stackInt = (StgInt16) ReadSpW(0);
if (stackInt != (StgInt16)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_I8: {
+ INSTRUCTION(bci_TESTEQ_I8): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt8 stackInt = (StgInt8) ReadSpW(0);
if (stackInt != (StgInt8)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_W: {
+ INSTRUCTION(bci_TESTLT_W): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
W_ stackWord = (W_)ReadSpW(0);
if (stackWord >= (W_)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_W64: {
+ INSTRUCTION(bci_TESTLT_W64): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord64 stackWord = ReadSpW64(0);
if (stackWord >= BCO_LITW64(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_W32: {
+ INSTRUCTION(bci_TESTLT_W32): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord32 stackWord = (StgWord32) ReadSpW(0);
if (stackWord >= (StgWord32)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_W16: {
+ INSTRUCTION(bci_TESTLT_W16): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord16 stackWord = (StgInt16) ReadSpW(0);
if (stackWord >= (StgWord16)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_W8: {
+ INSTRUCTION(bci_TESTLT_W8): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord8 stackWord = (StgInt8) ReadSpW(0);
if (stackWord >= (StgWord8)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_W: {
+ INSTRUCTION(bci_TESTEQ_W): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
W_ stackWord = (W_)ReadSpW(0);
if (stackWord != (W_)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_W64: {
+ INSTRUCTION(bci_TESTEQ_W64): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord64 stackWord = ReadSpW64(0);
if (stackWord != BCO_LITW64(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_W32: {
+ INSTRUCTION(bci_TESTEQ_W32): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord32 stackWord = (StgWord32) ReadSpW(0);
if (stackWord != (StgWord32)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_W16: {
+ INSTRUCTION(bci_TESTEQ_W16): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord16 stackWord = (StgWord16) ReadSpW(0);
if (stackWord != (StgWord16)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_W8: {
+ INSTRUCTION(bci_TESTEQ_W8): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord8 stackWord = (StgWord8) ReadSpW(0);
if (stackWord != (StgWord8)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_D: {
+ INSTRUCTION(bci_TESTLT_D): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgDouble stackDbl, discrDbl;
@@ -2466,10 +2790,10 @@ run_BCO:
if (stackDbl >= discrDbl) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_D: {
+ INSTRUCTION(bci_TESTEQ_D): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgDouble stackDbl, discrDbl;
@@ -2478,10 +2802,10 @@ run_BCO:
if (stackDbl != discrDbl) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_F: {
+ INSTRUCTION(bci_TESTLT_F): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgFloat stackFlt, discrFlt;
@@ -2490,10 +2814,10 @@ run_BCO:
if (stackFlt >= discrFlt) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_F: {
+ INSTRUCTION(bci_TESTEQ_F): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgFloat stackFlt, discrFlt;
@@ -2502,11 +2826,11 @@ run_BCO:
if (stackFlt != discrFlt) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
// Control-flow ish things
- case bci_ENTER:
+ INSTRUCTION(bci_ENTER):
// Context-switch check. We put it here to ensure that
// the interpreter has done at least *some* work before
// context switching: sometimes the scheduler can invoke
@@ -2518,50 +2842,50 @@ run_BCO:
}
goto eval;
- case bci_RETURN_P:
+ INSTRUCTION(bci_RETURN_P):
tagged_obj = (StgClosure *)ReadSpW(0);
Sp_addW(1);
goto do_return_pointer;
- case bci_RETURN_N:
+ INSTRUCTION(bci_RETURN_N):
Sp_subW(1);
SpW(0) = (W_)&stg_ret_n_info;
goto do_return_nonpointer;
- case bci_RETURN_F:
+ INSTRUCTION(bci_RETURN_F):
Sp_subW(1);
SpW(0) = (W_)&stg_ret_f_info;
goto do_return_nonpointer;
- case bci_RETURN_D:
+ INSTRUCTION(bci_RETURN_D):
Sp_subW(1);
SpW(0) = (W_)&stg_ret_d_info;
goto do_return_nonpointer;
- case bci_RETURN_L:
+ INSTRUCTION(bci_RETURN_L):
Sp_subW(1);
SpW(0) = (W_)&stg_ret_l_info;
goto do_return_nonpointer;
- case bci_RETURN_V:
+ INSTRUCTION(bci_RETURN_V):
Sp_subW(1);
SpW(0) = (W_)&stg_ret_v_info;
goto do_return_nonpointer;
- case bci_RETURN_T: {
+ INSTRUCTION(bci_RETURN_T): {
/* tuple_info and tuple_bco must already be on the stack */
Sp_subW(1);
SpW(0) = (W_)&stg_ret_t_info;
goto do_return_nonpointer;
}
- case bci_BCO_NAME:
+ INSTRUCTION(bci_BCO_NAME):
bciPtr++;
- goto nextInsn;
+ NEXT_INSTRUCTION;
- case bci_SWIZZLE: {
+ INSTRUCTION(bci_SWIZZLE): {
W_ stkoff = BCO_GET_LARGE_ARG;
StgInt n = BCO_GET_LARGE_ARG;
(*(StgInt*)(SafeSpWP(stkoff))) += n;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PRIMCALL: {
+ INSTRUCTION(bci_PRIMCALL): {
Sp_subW(1);
SpW(0) = (W_)&stg_primcall_info;
RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
@@ -2577,7 +2901,7 @@ run_BCO:
ty r = op ((ty) ReadSpW(0)); \
SpW(0) = (StgWord) r; \
} \
- goto nextInsn; \
+ NEXT_INSTRUCTION; \
}
// op :: ty -> ty -> ty
@@ -2592,7 +2916,7 @@ run_BCO:
Sp_addW(1); \
SpW(0) = (StgWord) r; \
}; \
- goto nextInsn; \
+ NEXT_INSTRUCTION; \
}
// op :: ty -> Int -> ty
@@ -2607,7 +2931,7 @@ run_BCO:
Sp_addW(1); \
SpW(0) = (StgWord) r; \
}; \
- goto nextInsn; \
+ NEXT_INSTRUCTION; \
}
// op :: ty -> ty -> Int
@@ -2622,113 +2946,113 @@ run_BCO:
Sp_addW(1); \
SpW(0) = (StgWord) r; \
}; \
- goto nextInsn; \
+ NEXT_INSTRUCTION; \
}
- case bci_OP_ADD_64: SIZED_BIN_OP(+, StgInt64)
- case bci_OP_SUB_64: SIZED_BIN_OP(-, StgInt64)
- case bci_OP_AND_64: SIZED_BIN_OP(&, StgInt64)
- case bci_OP_XOR_64: SIZED_BIN_OP(^, StgInt64)
- case bci_OP_OR_64: SIZED_BIN_OP(|, StgInt64)
- case bci_OP_MUL_64: SIZED_BIN_OP(*, StgInt64)
- case bci_OP_SHL_64: SIZED_BIN_OP_TY_INT(<<, StgWord64)
- case bci_OP_LSR_64: SIZED_BIN_OP_TY_INT(>>, StgWord64)
- case bci_OP_ASR_64: SIZED_BIN_OP_TY_INT(>>, StgInt64)
-
- case bci_OP_NEQ_64: SIZED_BIN_OP_TY_TY_INT(!=, StgWord64)
- case bci_OP_EQ_64: SIZED_BIN_OP_TY_TY_INT(==, StgWord64)
- case bci_OP_U_GT_64: SIZED_BIN_OP_TY_TY_INT(>, StgWord64)
- case bci_OP_U_GE_64: SIZED_BIN_OP_TY_TY_INT(>=, StgWord64)
- case bci_OP_U_LT_64: SIZED_BIN_OP_TY_TY_INT(<, StgWord64)
- case bci_OP_U_LE_64: SIZED_BIN_OP_TY_TY_INT(<=, StgWord64)
-
- case bci_OP_S_GT_64: SIZED_BIN_OP_TY_TY_INT(>, StgInt64)
- case bci_OP_S_GE_64: SIZED_BIN_OP_TY_TY_INT(>=, StgInt64)
- case bci_OP_S_LT_64: SIZED_BIN_OP_TY_TY_INT(<, StgInt64)
- case bci_OP_S_LE_64: SIZED_BIN_OP_TY_TY_INT(<=, StgInt64)
-
- case bci_OP_NOT_64: UN_SIZED_OP(~, StgWord64)
- case bci_OP_NEG_64: UN_SIZED_OP(-, StgInt64)
-
-
- case bci_OP_ADD_32: SIZED_BIN_OP(+, StgInt32)
- case bci_OP_SUB_32: SIZED_BIN_OP(-, StgInt32)
- case bci_OP_AND_32: SIZED_BIN_OP(&, StgInt32)
- case bci_OP_XOR_32: SIZED_BIN_OP(^, StgInt32)
- case bci_OP_OR_32: SIZED_BIN_OP(|, StgInt32)
- case bci_OP_MUL_32: SIZED_BIN_OP(*, StgInt32)
- case bci_OP_SHL_32: SIZED_BIN_OP_TY_INT(<<, StgWord32)
- case bci_OP_LSR_32: SIZED_BIN_OP_TY_INT(>>, StgWord32)
- case bci_OP_ASR_32: SIZED_BIN_OP_TY_INT(>>, StgInt32)
-
- case bci_OP_NEQ_32: SIZED_BIN_OP_TY_TY_INT(!=, StgWord32)
- case bci_OP_EQ_32: SIZED_BIN_OP_TY_TY_INT(==, StgWord32)
- case bci_OP_U_GT_32: SIZED_BIN_OP_TY_TY_INT(>, StgWord32)
- case bci_OP_U_GE_32: SIZED_BIN_OP_TY_TY_INT(>=, StgWord32)
- case bci_OP_U_LT_32: SIZED_BIN_OP_TY_TY_INT(<, StgWord32)
- case bci_OP_U_LE_32: SIZED_BIN_OP_TY_TY_INT(<=, StgWord32)
-
- case bci_OP_S_GT_32: SIZED_BIN_OP_TY_TY_INT(>, StgInt32)
- case bci_OP_S_GE_32: SIZED_BIN_OP_TY_TY_INT(>=, StgInt32)
- case bci_OP_S_LT_32: SIZED_BIN_OP_TY_TY_INT(<, StgInt32)
- case bci_OP_S_LE_32: SIZED_BIN_OP_TY_TY_INT(<=, StgInt32)
-
- case bci_OP_NOT_32: UN_SIZED_OP(~, StgWord32)
- case bci_OP_NEG_32: UN_SIZED_OP(-, StgInt32)
-
-
- case bci_OP_ADD_16: SIZED_BIN_OP(+, StgInt16)
- case bci_OP_SUB_16: SIZED_BIN_OP(-, StgInt16)
- case bci_OP_AND_16: SIZED_BIN_OP(&, StgInt16)
- case bci_OP_XOR_16: SIZED_BIN_OP(^, StgInt16)
- case bci_OP_OR_16: SIZED_BIN_OP(|, StgInt16)
- case bci_OP_MUL_16: SIZED_BIN_OP(*, StgInt16)
- case bci_OP_SHL_16: SIZED_BIN_OP_TY_INT(<<, StgWord16)
- case bci_OP_LSR_16: SIZED_BIN_OP_TY_INT(>>, StgWord16)
- case bci_OP_ASR_16: SIZED_BIN_OP_TY_INT(>>, StgInt16)
-
- case bci_OP_NEQ_16: SIZED_BIN_OP_TY_TY_INT(!=, StgWord16)
- case bci_OP_EQ_16: SIZED_BIN_OP_TY_TY_INT(==, StgWord16)
- case bci_OP_U_GT_16: SIZED_BIN_OP_TY_TY_INT(>, StgWord16)
- case bci_OP_U_GE_16: SIZED_BIN_OP_TY_TY_INT(>=, StgWord16)
- case bci_OP_U_LT_16: SIZED_BIN_OP_TY_TY_INT(<, StgWord16)
- case bci_OP_U_LE_16: SIZED_BIN_OP_TY_TY_INT(<=, StgWord16)
-
- case bci_OP_S_GT_16: SIZED_BIN_OP(>, StgInt16)
- case bci_OP_S_GE_16: SIZED_BIN_OP(>=, StgInt16)
- case bci_OP_S_LT_16: SIZED_BIN_OP(<, StgInt16)
- case bci_OP_S_LE_16: SIZED_BIN_OP(<=, StgInt16)
-
- case bci_OP_NOT_16: UN_SIZED_OP(~, StgWord16)
- case bci_OP_NEG_16: UN_SIZED_OP(-, StgInt16)
-
-
- case bci_OP_ADD_08: SIZED_BIN_OP(+, StgInt8)
- case bci_OP_SUB_08: SIZED_BIN_OP(-, StgInt8)
- case bci_OP_AND_08: SIZED_BIN_OP(&, StgInt8)
- case bci_OP_XOR_08: SIZED_BIN_OP(^, StgInt8)
- case bci_OP_OR_08: SIZED_BIN_OP(|, StgInt8)
- case bci_OP_MUL_08: SIZED_BIN_OP(*, StgInt8)
- case bci_OP_SHL_08: SIZED_BIN_OP_TY_INT(<<, StgWord8)
- case bci_OP_LSR_08: SIZED_BIN_OP_TY_INT(>>, StgWord8)
- case bci_OP_ASR_08: SIZED_BIN_OP_TY_INT(>>, StgInt8)
-
- case bci_OP_NEQ_08: SIZED_BIN_OP_TY_TY_INT(!=, StgWord8)
- case bci_OP_EQ_08: SIZED_BIN_OP_TY_TY_INT(==, StgWord8)
- case bci_OP_U_GT_08: SIZED_BIN_OP_TY_TY_INT(>, StgWord8)
- case bci_OP_U_GE_08: SIZED_BIN_OP_TY_TY_INT(>=, StgWord8)
- case bci_OP_U_LT_08: SIZED_BIN_OP_TY_TY_INT(<, StgWord8)
- case bci_OP_U_LE_08: SIZED_BIN_OP_TY_TY_INT(<=, StgWord8)
-
- case bci_OP_S_GT_08: SIZED_BIN_OP_TY_TY_INT(>, StgInt8)
- case bci_OP_S_GE_08: SIZED_BIN_OP_TY_TY_INT(>=, StgInt8)
- case bci_OP_S_LT_08: SIZED_BIN_OP_TY_TY_INT(<, StgInt8)
- case bci_OP_S_LE_08: SIZED_BIN_OP_TY_TY_INT(<=, StgInt8)
-
- case bci_OP_NOT_08: UN_SIZED_OP(~, StgWord8)
- case bci_OP_NEG_08: UN_SIZED_OP(-, StgInt8)
-
- case bci_OP_INDEX_ADDR_64:
+ INSTRUCTION(bci_OP_ADD_64): SIZED_BIN_OP(+, StgInt64)
+ INSTRUCTION(bci_OP_SUB_64): SIZED_BIN_OP(-, StgInt64)
+ INSTRUCTION(bci_OP_AND_64): SIZED_BIN_OP(&, StgInt64)
+ INSTRUCTION(bci_OP_XOR_64): SIZED_BIN_OP(^, StgInt64)
+ INSTRUCTION(bci_OP_OR_64): SIZED_BIN_OP(|, StgInt64)
+ INSTRUCTION(bci_OP_MUL_64): SIZED_BIN_OP(*, StgInt64)
+ INSTRUCTION(bci_OP_SHL_64): SIZED_BIN_OP_TY_INT(<<, StgWord64)
+ INSTRUCTION(bci_OP_LSR_64): SIZED_BIN_OP_TY_INT(>>, StgWord64)
+ INSTRUCTION(bci_OP_ASR_64): SIZED_BIN_OP_TY_INT(>>, StgInt64)
+
+ INSTRUCTION(bci_OP_NEQ_64): SIZED_BIN_OP_TY_TY_INT(!=, StgWord64)
+ INSTRUCTION(bci_OP_EQ_64): SIZED_BIN_OP_TY_TY_INT(==, StgWord64)
+ INSTRUCTION(bci_OP_U_GT_64): SIZED_BIN_OP_TY_TY_INT(>, StgWord64)
+ INSTRUCTION(bci_OP_U_GE_64): SIZED_BIN_OP_TY_TY_INT(>=, StgWord64)
+ INSTRUCTION(bci_OP_U_LT_64): SIZED_BIN_OP_TY_TY_INT(<, StgWord64)
+ INSTRUCTION(bci_OP_U_LE_64): SIZED_BIN_OP_TY_TY_INT(<=, StgWord64)
+
+ INSTRUCTION(bci_OP_S_GT_64): SIZED_BIN_OP_TY_TY_INT(>, StgInt64)
+ INSTRUCTION(bci_OP_S_GE_64): SIZED_BIN_OP_TY_TY_INT(>=, StgInt64)
+ INSTRUCTION(bci_OP_S_LT_64): SIZED_BIN_OP_TY_TY_INT(<, StgInt64)
+ INSTRUCTION(bci_OP_S_LE_64): SIZED_BIN_OP_TY_TY_INT(<=, StgInt64)
+
+ INSTRUCTION(bci_OP_NOT_64): UN_SIZED_OP(~, StgWord64)
+ INSTRUCTION(bci_OP_NEG_64): UN_SIZED_OP(-, StgInt64)
+
+
+ INSTRUCTION(bci_OP_ADD_32): SIZED_BIN_OP(+, StgInt32)
+ INSTRUCTION(bci_OP_SUB_32): SIZED_BIN_OP(-, StgInt32)
+ INSTRUCTION(bci_OP_AND_32): SIZED_BIN_OP(&, StgInt32)
+ INSTRUCTION(bci_OP_XOR_32): SIZED_BIN_OP(^, StgInt32)
+ INSTRUCTION(bci_OP_OR_32): SIZED_BIN_OP(|, StgInt32)
+ INSTRUCTION(bci_OP_MUL_32): SIZED_BIN_OP(*, StgInt32)
+ INSTRUCTION(bci_OP_SHL_32): SIZED_BIN_OP_TY_INT(<<, StgWord32)
+ INSTRUCTION(bci_OP_LSR_32): SIZED_BIN_OP_TY_INT(>>, StgWord32)
+ INSTRUCTION(bci_OP_ASR_32): SIZED_BIN_OP_TY_INT(>>, StgInt32)
+
+ INSTRUCTION(bci_OP_NEQ_32): SIZED_BIN_OP_TY_TY_INT(!=, StgWord32)
+ INSTRUCTION(bci_OP_EQ_32): SIZED_BIN_OP_TY_TY_INT(==, StgWord32)
+ INSTRUCTION(bci_OP_U_GT_32): SIZED_BIN_OP_TY_TY_INT(>, StgWord32)
+ INSTRUCTION(bci_OP_U_GE_32): SIZED_BIN_OP_TY_TY_INT(>=, StgWord32)
+ INSTRUCTION(bci_OP_U_LT_32): SIZED_BIN_OP_TY_TY_INT(<, StgWord32)
+ INSTRUCTION(bci_OP_U_LE_32): SIZED_BIN_OP_TY_TY_INT(<=, StgWord32)
+
+ INSTRUCTION(bci_OP_S_GT_32): SIZED_BIN_OP_TY_TY_INT(>, StgInt32)
+ INSTRUCTION(bci_OP_S_GE_32): SIZED_BIN_OP_TY_TY_INT(>=, StgInt32)
+ INSTRUCTION(bci_OP_S_LT_32): SIZED_BIN_OP_TY_TY_INT(<, StgInt32)
+ INSTRUCTION(bci_OP_S_LE_32): SIZED_BIN_OP_TY_TY_INT(<=, StgInt32)
+
+ INSTRUCTION(bci_OP_NOT_32): UN_SIZED_OP(~, StgWord32)
+ INSTRUCTION(bci_OP_NEG_32): UN_SIZED_OP(-, StgInt32)
+
+
+ INSTRUCTION(bci_OP_ADD_16): SIZED_BIN_OP(+, StgInt16)
+ INSTRUCTION(bci_OP_SUB_16): SIZED_BIN_OP(-, StgInt16)
+ INSTRUCTION(bci_OP_AND_16): SIZED_BIN_OP(&, StgInt16)
+ INSTRUCTION(bci_OP_XOR_16): SIZED_BIN_OP(^, StgInt16)
+ INSTRUCTION(bci_OP_OR_16): SIZED_BIN_OP(|, StgInt16)
+ INSTRUCTION(bci_OP_MUL_16): SIZED_BIN_OP(*, StgInt16)
+ INSTRUCTION(bci_OP_SHL_16): SIZED_BIN_OP_TY_INT(<<, StgWord16)
+ INSTRUCTION(bci_OP_LSR_16): SIZED_BIN_OP_TY_INT(>>, StgWord16)
+ INSTRUCTION(bci_OP_ASR_16): SIZED_BIN_OP_TY_INT(>>, StgInt16)
+
+ INSTRUCTION(bci_OP_NEQ_16): SIZED_BIN_OP_TY_TY_INT(!=, StgWord16)
+ INSTRUCTION(bci_OP_EQ_16): SIZED_BIN_OP_TY_TY_INT(==, StgWord16)
+ INSTRUCTION(bci_OP_U_GT_16): SIZED_BIN_OP_TY_TY_INT(>, StgWord16)
+ INSTRUCTION(bci_OP_U_GE_16): SIZED_BIN_OP_TY_TY_INT(>=, StgWord16)
+ INSTRUCTION(bci_OP_U_LT_16): SIZED_BIN_OP_TY_TY_INT(<, StgWord16)
+ INSTRUCTION(bci_OP_U_LE_16): SIZED_BIN_OP_TY_TY_INT(<=, StgWord16)
+
+ INSTRUCTION(bci_OP_S_GT_16): SIZED_BIN_OP(>, StgInt16)
+ INSTRUCTION(bci_OP_S_GE_16): SIZED_BIN_OP(>=, StgInt16)
+ INSTRUCTION(bci_OP_S_LT_16): SIZED_BIN_OP(<, StgInt16)
+ INSTRUCTION(bci_OP_S_LE_16): SIZED_BIN_OP(<=, StgInt16)
+
+ INSTRUCTION(bci_OP_NOT_16): UN_SIZED_OP(~, StgWord16)
+ INSTRUCTION(bci_OP_NEG_16): UN_SIZED_OP(-, StgInt16)
+
+
+ INSTRUCTION(bci_OP_ADD_08): SIZED_BIN_OP(+, StgInt8)
+ INSTRUCTION(bci_OP_SUB_08): SIZED_BIN_OP(-, StgInt8)
+ INSTRUCTION(bci_OP_AND_08): SIZED_BIN_OP(&, StgInt8)
+ INSTRUCTION(bci_OP_XOR_08): SIZED_BIN_OP(^, StgInt8)
+ INSTRUCTION(bci_OP_OR_08): SIZED_BIN_OP(|, StgInt8)
+ INSTRUCTION(bci_OP_MUL_08): SIZED_BIN_OP(*, StgInt8)
+ INSTRUCTION(bci_OP_SHL_08): SIZED_BIN_OP_TY_INT(<<, StgWord8)
+ INSTRUCTION(bci_OP_LSR_08): SIZED_BIN_OP_TY_INT(>>, StgWord8)
+ INSTRUCTION(bci_OP_ASR_08): SIZED_BIN_OP_TY_INT(>>, StgInt8)
+
+ INSTRUCTION(bci_OP_NEQ_08): SIZED_BIN_OP_TY_TY_INT(!=, StgWord8)
+ INSTRUCTION(bci_OP_EQ_08): SIZED_BIN_OP_TY_TY_INT(==, StgWord8)
+ INSTRUCTION(bci_OP_U_GT_08): SIZED_BIN_OP_TY_TY_INT(>, StgWord8)
+ INSTRUCTION(bci_OP_U_GE_08): SIZED_BIN_OP_TY_TY_INT(>=, StgWord8)
+ INSTRUCTION(bci_OP_U_LT_08): SIZED_BIN_OP_TY_TY_INT(<, StgWord8)
+ INSTRUCTION(bci_OP_U_LE_08): SIZED_BIN_OP_TY_TY_INT(<=, StgWord8)
+
+ INSTRUCTION(bci_OP_S_GT_08): SIZED_BIN_OP_TY_TY_INT(>, StgInt8)
+ INSTRUCTION(bci_OP_S_GE_08): SIZED_BIN_OP_TY_TY_INT(>=, StgInt8)
+ INSTRUCTION(bci_OP_S_LT_08): SIZED_BIN_OP_TY_TY_INT(<, StgInt8)
+ INSTRUCTION(bci_OP_S_LE_08): SIZED_BIN_OP_TY_TY_INT(<=, StgInt8)
+
+ INSTRUCTION(bci_OP_NOT_08): UN_SIZED_OP(~, StgWord8)
+ INSTRUCTION(bci_OP_NEG_08): UN_SIZED_OP(-, StgInt8)
+
+ INSTRUCTION(bci_OP_INDEX_ADDR_64):
{
StgWord64* addr = (StgWord64*) SpW(0);
StgInt offset = (StgInt) SpW(1);
@@ -2736,35 +3060,35 @@ run_BCO:
Sp_addW(1);
}
SpW64(0) = *(addr+offset);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_OP_INDEX_ADDR_32:
+ INSTRUCTION(bci_OP_INDEX_ADDR_32):
{
StgWord32* addr = (StgWord32*) SpW(0);
StgInt offset = (StgInt) SpW(1);
Sp_addW(1);
SpW(0) = (StgWord) *(addr+offset);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_OP_INDEX_ADDR_16:
+ INSTRUCTION(bci_OP_INDEX_ADDR_16):
{
StgWord16* addr = (StgWord16*) SpW(0);
StgInt offset = (StgInt) SpW(1);
Sp_addW(1);
SpW(0) = (StgWord) *(addr+offset);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_OP_INDEX_ADDR_08:
+ INSTRUCTION(bci_OP_INDEX_ADDR_08):
{
StgWord8* addr = (StgWord8*) SpW(0);
StgInt offset = (StgInt) SpW(1);
Sp_addW(1);
SpW(0) = (StgWord) *(addr+offset);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_CCALL: {
+ INSTRUCTION(bci_CCALL): {
void *tok;
W_ stk_offset = BCO_GET_LARGE_ARG;
int o_itbl = BCO_GET_LARGE_ARG;
@@ -2921,25 +3245,33 @@ run_BCO:
memcpy(Sp, ret, sizeof(W_) * ret_size);
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_JMP: {
+ INSTRUCTION(bci_JMP): {
/* BCO_NEXT modifies bciPtr, so be conservative. */
int nextpc = BCO_GET_LARGE_ARG;
bciPtr = nextpc;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_CASEFAIL:
+ INSTRUCTION(bci_CASEFAIL):
barf("interpretBCO: hit a CASEFAIL");
- // Errors
+
+
+#if defined(COMPUTED_GOTO)
+ INSTRUCTION(bci_DEFAULT):
+ barf("interpretBCO: unknown or unimplemented opcode %d",
+ (int)(bci & 0xFF));
+#else
+ // Errors
default:
barf("interpretBCO: unknown or unimplemented opcode %d",
(int)(bci & 0xFF));
-
} /* switch on opcode */
+#endif
+
}
}
=====================================
rts/eventlog/EventLog.c
=====================================
@@ -197,7 +197,7 @@ static inline void postBuf(EventsBuf *eb, const StgWord8 *buf, uint32_t size)
static inline void postStringLen(EventsBuf *eb, const char *buf, StgWord len)
{
if (buf) {
- ASSERT(eb->begin + eb->size > eb->pos + len + 1);
+ ASSERT(eb->pos + len + 1 <= eb->begin + eb->size);
memcpy(eb->pos, buf, len);
eb->pos += len;
}
=====================================
rts/gen_event_types.py
=====================================
@@ -1,6 +1,7 @@
#!/usr/bin/env python
# -*- coding: utf-8 -*-
+from pathlib import Path
from typing import List, Union, Dict
from collections import namedtuple
@@ -198,17 +199,17 @@ def generate_event_types_defines() -> str:
def main() -> None:
import argparse
parser = argparse.ArgumentParser()
- parser.add_argument('--event-types-array', type=argparse.FileType('w'), metavar='FILE')
- parser.add_argument('--event-types-defines', type=argparse.FileType('w'), metavar='FILE')
+ parser.add_argument('--event-types-array', type=Path, metavar='FILE')
+ parser.add_argument('--event-types-defines', type=Path, metavar='FILE')
args = parser.parse_args()
check_events()
if args.event_types_array:
- args.event_types_array.write(generate_event_types_array())
+ args.event_types_array.write_text(generate_event_types_array())
if args.event_types_defines:
- args.event_types_defines.write(generate_event_types_defines())
+ args.event_types_defines.write_text(generate_event_types_defines())
if __name__ == '__main__':
main()
=====================================
rts/include/rts/Bytecodes.h
=====================================
@@ -23,6 +23,11 @@
I hope that's clear :-)
*/
+/*
+ Make sure to update jumptable in rts/Interpreter.c when modifying
+ bytecodes! See Note [Instruction dispatch in the bytecode interpreter]
+ for details.
+*/
#define bci_STKCHECK 1
#define bci_PUSH_L 2
#define bci_PUSH_LL 3
=====================================
testsuite/driver/runtests.py
=====================================
@@ -83,7 +83,7 @@ parser.add_argument("--way", action="append", help="just this way")
parser.add_argument("--skipway", action="append", help="skip this way")
parser.add_argument("--threads", type=int, help="threads to run simultaneously")
parser.add_argument("--verbose", type=int, choices=[0,1,2,3,4,5], help="verbose (Values 0 through 5 accepted)")
-parser.add_argument("--junit", type=argparse.FileType('wb'), help="output testsuite summary in JUnit format")
+parser.add_argument("--junit", type=Path, help="output testsuite summary in JUnit format")
parser.add_argument("--broken-test", action="append", default=[], help="a test name to mark as broken for this run")
parser.add_argument("--test-env", default='local', help="Override default chosen test-env.")
parser.add_argument("--perf-baseline", type=GitRef, metavar='COMMIT', help="Baseline commit for performance comparsons.")
@@ -91,7 +91,7 @@ perf_group.add_argument("--skip-perf-tests", action="store_true", help="skip per
perf_group.add_argument("--only-perf-tests", action="store_true", help="Only do performance tests")
parser.add_argument("--ignore-perf-failures", choices=['increases','decreases','all'],
help="Do not fail due to out-of-tolerance perf tests")
-parser.add_argument("--only-report-hadrian-deps", type=argparse.FileType('w'),
+parser.add_argument("--only-report-hadrian-deps", type=Path,
help="Dry run the testsuite and report all extra hadrian dependencies needed on the given file")
args = parser.parse_args()
@@ -615,14 +615,14 @@ else:
summary(t, f)
if args.junit:
- junit(t).write(args.junit)
- args.junit.close()
+ with args.junit.open("wb") as f:
+ junit(t).write(f)
if config.only_report_hadrian_deps:
print("WARNING - skipping all tests and only reporting required hadrian dependencies:", config.hadrian_deps)
- for d in config.hadrian_deps:
- print(d,file=config.only_report_hadrian_deps)
- config.only_report_hadrian_deps.close()
+ with config.only_report_hadrian_deps.open("w") as f:
+ for d in config.hadrian_deps:
+ print(d, file=f)
if len(t.unexpected_failures) > 0 or \
len(t.unexpected_stat_failures) > 0 or \
=====================================
testsuite/tests/driver/T24120.hs
=====================================
@@ -0,0 +1,5 @@
+-- | This should not issue an @-Wunused-packages@ warning for @system-cxx-std-lib@.
+module Main where
+
+main :: IO ()
+main = putStrLn "hello world"
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -331,3 +331,4 @@ test('T24839', [unless(arch('x86_64') or arch('aarch64'), skip), extra_files(["t
test('t25150', [extra_files(["t25150"])], multimod_compile, ['Main.hs', '-v0 -working-dir t25150/dir a.c'])
test('T25382', normal, makefile_test, [])
test('T26018', req_c, makefile_test, [])
+test('T24120', normal, compile, ['-Wunused-packages -hide-all-packages -package base -package system-cxx-std-lib'])
=====================================
testsuite/tests/rep-poly/T26528.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE GHC2024, TypeFamilies #-}
+
+module T26528 where
+
+import Data.Kind
+import GHC.Exts
+
+type F :: Type -> RuntimeRep
+type family F a where
+ F Int = LiftedRep
+
+g :: forall (r::RuntimeRep).
+ (forall (a :: TYPE r). a -> forall b. b -> b) -> Int
+g _ = 3
+{-# NOINLINE g #-}
+
+foo = g @(F Int) (\x y -> y)
=====================================
testsuite/tests/rep-poly/all.T
=====================================
@@ -42,6 +42,7 @@ test('T23883b', normal, compile_fail, [''])
test('T23883c', normal, compile_fail, [''])
test('T23903', normal, compile_fail, [''])
test('T26107', js_broken(22364), compile, ['-O'])
+test('T26528', normal, compile, [''])
test('EtaExpandDataCon', normal, compile, ['-O'])
test('EtaExpandStupid1', normal, compile, ['-Wno-deprecated-flags'])
=====================================
testsuite/tests/typecheck/should_compile/T26451.hs
=====================================
@@ -0,0 +1,34 @@
+{-# LANGUAGE ImplicitParams, TypeFamilies, FunctionalDependencies, ScopedTypeVariables #-}
+
+module T26451 where
+
+type family F a
+type instance F Bool = [Char]
+
+class C a b | b -> a
+instance C Bool Bool
+instance C Char Char
+
+eq :: forall a b. C a b => a -> b -> ()
+eq p q = ()
+
+g :: a -> F a
+g = g
+
+f (x::tx) (y::ty) -- x :: alpha y :: beta
+ = let ?v = g x -- ?ip :: F alpha
+ in (?v::[ty], eq x True)
+
+
+{- tx, and ty are unification variables
+
+Inert: [G] dg :: IP "v" (F tx)
+ [W] dw :: IP "v" [ty]
+Work-list: [W] dc1 :: C tx Bool
+ [W] dc2 :: C ty Char
+
+* Solve dc1, we get tx := Bool from fundep
+* Kick out dg
+* Solve dg to get [G] dc : IP "v" [Char]
+* Add that new dg to the inert set: that simply deletes dw!!!
+-}
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -955,3 +955,4 @@ test('T26376', normal, compile, [''])
test('T26457', normal, compile, [''])
test('T17705', normal, compile, [''])
test('T14745', normal, compile, [''])
+test('T26451', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5e5716953a15097d49f5c443abb40c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5e5716953a15097d49f5c443abb40c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T24464 at Glasgow Haskell Compiler / GHC
Commits:
60381bd4 by Simon Peyton Jones at 2025-11-06T17:44:19+00:00
More [skip ci]
- - - - -
13 changed files:
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Types/BasicTypes.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Zonk/Type.hs
Changes:
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -54,7 +54,7 @@ import GHC.Types.Name
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Utils.Misc ((<||>))
+import GHC.Utils.Misc
import Data.Function
import Data.List (sortBy)
@@ -80,12 +80,16 @@ type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = DataConCantHappen
-- ---------------------------------------------------------------------
type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey BindTag
-type instance XXValBindsLR (GhcPass pL) pR = NHsValBindsLR pL
-data NHsValBindsLR (p :: Pass) where
- NvbPs :: NHsValBindsLR 'Parsed
- NvbRn :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> NHsValBindsLR 'Renamed
- NvbTc :: [(RecFlag, LHsBinds GhcRn, Bool)] -> [LSig GhcRn] -> NHsValBindsLR 'Typechecked
+type instance XXValBindsLR (GhcPass pL) _ = HsValBindGroups pL
+
+data HsValBindGroups p -- Divided into strongly connected components
+ = HsVBG [HsValBindGroup (GhcPass p)] [LSig GhcRn]
+
+type family HsValBindGroup p
+type instance HsValBindGroup GhcPs = ()
+type instance HsValBindGroup GhcRn = (RecFlag, LHsBinds GhcRn)
+type instance HsValBindGroup GhcTc = (RecFlag, LHsBinds GhcTc, TopLevelFlag)
-- ---------------------------------------------------------------------
@@ -449,18 +453,17 @@ instance (OutputableBndrId pl, OutputableBndrId pr)
ppr (ValBinds _ binds sigs)
= pprDeclList (pprLHsBindsForUser binds sigs)
- ppr (XValBindsLR nvbs)
- = case nvbs of
- NvbPs -> empty
- NvbRn prs sigs -> ppr_vb prs sigs
- NvbTc triples sigs -> ppr_vb [(a,b) | (a,b,_)<-triples] sigs
- -- Discard closed-flag for now
+ ppr (XValBindsLR (HsVBG bs sigs))
+ = getPprDebug $ \case
+ False -> pprDeclList (pprLHsBindsForUser (concat (map snd prs)) sigs)
+ True -> -- Print with sccs showing
+ vcat (map ppr sigs) $$ vcat (map ppr_scc prs)
where
- ppr_vb prs sigs
- = getPprDebug $ \case
- False -> pprDeclList (pprLHsBindsForUser (concat (map snd prs)) sigs)
- True -> -- Print with sccs showing
- vcat (map ppr sigs) $$ vcat (map ppr_scc prs)
+ prs :: [(RecFlag, LHsBinds (GhcPass pl))]
+ prs = case ghcPass @pl of
+ GhcPs -> []
+ GhcRn -> bs
+ GhcTc -> [(a,b)|(a,b,_)<-bs] -- Discard closed-flag for now
ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
pp_rec Recursive = text "rec"
@@ -513,14 +516,12 @@ eqEmptyLocalBinds _ = False
isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool
isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs
-isEmptyValBinds (XValBindsLR NvbPs) = True
-isEmptyValBinds (XValBindsLR (NvbRn ds sigs)) = null ds && null sigs
-isEmptyValBinds (XValBindsLR (NvbTc ds sigs)) = null ds && null sigs
+isEmptyValBinds (XValBindsLR (HsVBG ds sigs)) = null ds && null sigs
emptyValBindsIn :: HsValBindsLR (GhcPass a) (GhcPass b)
emptyValBindsIn = ValBinds NoAnnSortKey [] []
emptyValBindsRn :: HsValBindsLR GhcRn GhcRn
-emptyValBindsRn = XValBindsLR (NvbRn [] [])
+emptyValBindsRn = XValBindsLR (HsVBG [] [])
emptyLHsBinds :: LHsBindsLR (GhcPass idL) idR
emptyLHsBinds = []
@@ -528,19 +529,21 @@ emptyLHsBinds = []
isEmptyLHsBinds :: LHsBindsLR (GhcPass idL) idR -> Bool
isEmptyLHsBinds = null
+hsValBindGroupsBinds :: forall p. IsPass p
+ => [HsValBindGroup (GhcPass p)] -> [LHsBind (GhcPass p)]
+hsValBindGroupsBinds binds
+ = case ghcPass @p of
+ GhcPs -> []
+ GhcRn -> concatMap snd binds
+ GhcTc -> concatMap sndOf3 binds
+
------------
plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
-> HsValBinds(GhcPass a)
plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2)
= ValBinds NoAnnSortKey (ds1 ++ ds2) (sigs1 ++ sigs2)
-plusHsValBinds (XValBindsLR nvbs1) (XValBindsLR nvbs2)
- = XValBindsLR (nvbs1 `plus` nvbs2)
- where
- plus :: NHsValBindsLR p -> NHsValBindsLR p -> NHsValBindsLR p
- NvbPs `plus` NvbPs = NvbPs
- (NvbRn ds1 sigs1) `plus` (NvbRn ds2 sigs2) = NvbRn (ds1 ++ ds2) (sigs1 ++ sigs2)
- (NvbTc ds1 sigs1) `plus` (NvbTc ds2 sigs2) = NvbTc (ds1 ++ ds2) (sigs1 ++ sigs2)
-
+plusHsValBinds (XValBindsLR (HsVBG ds1 ss1)) (XValBindsLR (HsVBG ds2 ss2))
+ = XValBindsLR (HsVBG (ds1++ds2) (ss1++ss2))
plusHsValBinds _ _
= panic "HsBinds.plusHsValBinds"
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -56,9 +57,9 @@ deriving instance Data (HsValBindsLR GhcRn GhcRn)
deriving instance Data (HsValBindsLR GhcTc GhcTc)
-- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL)
-deriving instance Data (NHsValBindsLR 'Parsed)
-deriving instance Data (NHsValBindsLR 'Renamed)
-deriving instance Data (NHsValBindsLR 'Typechecked)
+deriving instance Data (HsValBindGroups 'Parsed)
+deriving instance Data (HsValBindGroups 'Renamed)
+deriving instance Data (HsValBindGroups 'Typechecked)
-- deriving instance (DataIdLR pL pR) => Data (HsBindLR pL pR)
deriving instance Data (HsBindLR GhcPs GhcPs)
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -886,24 +886,23 @@ isInfixFunBind (FunBind { fun_matches = MG _ matches })
isInfixFunBind _ = False
-- |Return the 'SrcSpan' encompassing the contents of any enclosed binds
-spanHsLocaLBinds :: HsLocalBinds (GhcPass p) -> SrcSpan
-spanHsLocaLBinds (EmptyLocalBinds _) = noSrcSpan
+spanHsLocaLBinds :: forall p. IsPass p => HsLocalBinds (GhcPass p) -> SrcSpan
+spanHsLocaLBinds (EmptyLocalBinds _)
+ = noSrcSpan
+spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))
+ = get_bind_spans bs []
spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))
- = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)
- where
- bsSpans :: [SrcSpan]
- bsSpans = map getLocA bs
- sigsSpans :: [SrcSpan]
- sigsSpans = map getLocA sigs
-spanHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs)))
- = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)
+ = get_bind_spans bs sigs
+spanHsLocaLBinds (HsValBinds _ (XValBindsLR (HsVBG bs ss)))
+ = get_bind_spans (hsValBindGroupsBinds @p bs) ss
+
+get_bind_spans :: (HasLoc l) => [GenLocated l a] -> [GenLocated l b] -> SrcSpan
+get_bind_spans binds sigs
+ = foldr combineSrcSpans noSrcSpan (bs_spans ++ sigs_spans)
where
- bsSpans :: [SrcSpan]
- bsSpans = map getLocA $ concatMap snd bs
- sigsSpans :: [SrcSpan]
- sigsSpans = map getLocA sigs
-spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))
- = foldr combineSrcSpans noSrcSpan (map getLocA bs)
+ bs_spans, sigs_spans :: [SrcSpan]
+ bs_spans = map getLocA binds
+ sigs_spans = map getLocA sigs
------------
-- | Convenience function using 'mkFunBind'.
@@ -1075,7 +1074,7 @@ isBangedHsBind (PatBind {pat_lhs = pat})
isBangedHsBind _
= False
-collectLocalBinders :: CollectPass (GhcPass idL)
+collectLocalBinders :: (IsPass idL, CollectPass (GhcPass idL))
=> CollectFlag (GhcPass idL)
-> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
@@ -1085,14 +1084,14 @@ collectLocalBinders flag = \case
HsIPBinds {} -> []
EmptyLocalBinds _ -> []
-collectHsIdBinders :: CollectPass (GhcPass idL)
+collectHsIdBinders :: (IsPass idL, CollectPass (GhcPass idL))
=> CollectFlag (GhcPass idL)
-> HsValBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
-- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively
collectHsIdBinders flag = collect_hs_val_binders True flag
-collectHsValBinders :: CollectPass (GhcPass idL)
+collectHsValBinders :: (IsPass idL, CollectPass (GhcPass idL))
=> CollectFlag (GhcPass idL)
-> HsValBindsLR (GhcPass idL) idR
-> [IdP (GhcPass idL)]
@@ -1118,21 +1117,14 @@ collectHsBindListBinders :: forall p idR. CollectPass p
-- ^ Same as 'collectHsBindsBinders', but works over a list of bindings
collectHsBindListBinders flag = foldr (collect_bind False flag . unXRec @p) []
-collect_hs_val_binders :: CollectPass (GhcPass idL)
+collect_hs_val_binders :: forall idL idR. (IsPass idL, CollectPass (GhcPass idL))
=> Bool
-> CollectFlag (GhcPass idL)
-> HsValBindsLR (GhcPass idL) idR
-> [IdP (GhcPass idL)]
collect_hs_val_binders ps flag = \case
- ValBinds _ binds _ -> collect_binds ps flag binds []
- XValBindsLR (NValBinds binds _) -> collect_out_binds ps flag binds
-
-collect_out_binds :: forall p. CollectPass p
- => Bool
- -> CollectFlag p
- -> [(RecFlag, LHsBinds p)]
- -> [IdP p]
-collect_out_binds ps flag = foldr (collect_binds ps flag . snd) []
+ ValBinds _ binds _ -> collect_binds ps flag binds []
+ XValBindsLR (HsVBG grps _) -> collect_binds ps flag (hsValBindGroupsBinds @idL grps) []
collect_binds :: forall p idR. CollectPass p
=> Bool
@@ -1529,8 +1521,8 @@ hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)
-- ^ Collects record pattern-synonym selectors only; the pattern synonym
-- names are collected by 'collectHsValBinders'.
hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
-hsPatSynSelectors (XValBindsLR (NValBinds binds _))
- = foldr addPatSynSelector [] . concat $ map snd binds
+hsPatSynSelectors (XValBindsLR (HsVBG grps _))
+ = foldr addPatSynSelector [] $ hsValBindGroupsBinds grps
addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [FieldOcc p] -> [FieldOcc p]
addPatSynSelector bind sels
@@ -1538,11 +1530,10 @@ addPatSynSelector bind sels
= map recordPatSynField as ++ sels
| otherwise = sels
-getPatSynBinds :: forall id. UnXRec id
- => [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
+getPatSynBinds :: [(RecFlag, LHsBinds GhcRn)] -> [PatSynBind GhcRn GhcRn]
getPatSynBinds binds
= [ psb | (_, lbinds) <- binds
- , (unXRec @id -> (PatSynBind _ psb)) <- lbinds ]
+ , L _ (PatSynBind _ psb) <- lbinds ]
-------------------
hsLInstDeclBinders :: (IsPass p, OutputableBndrId p)
@@ -1813,8 +1804,8 @@ lStmtsImplicits = hs_lstmts
hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR)
-> [(SrcSpan, [ImplicitFieldBinders])]
-hsValBindsImplicits (XValBindsLR (NvbRn binds _))
- = concatMap (lhsBindsImplicits . snd) binds
+hsValBindsImplicits (XValBindsLR (HsVBG grps _))
+ = lhsBindsImplicits (hsValBindGroupsBinds grps)
hsValBindsImplicits (ValBinds _ binds _)
= lhsBindsImplicits binds
=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -525,12 +525,12 @@ ungroup (HsGroup {..}) =
mkDecls (ValD noExtField) (valbinds hs_valds)
where
typesigs :: HsValBinds GhcRn -> [LSig GhcRn]
- typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig
+ typesigs (XValBindsLR (HsVBG _ sig)) = filter (isUserSig . unLoc) sig
typesigs ValBinds{} = error "expected XValBindsLR"
valbinds :: HsValBinds GhcRn -> [LHsBind GhcRn]
- valbinds (XValBindsLR (NValBinds binds _)) =
- concat . snd . unzip $ binds
+ valbinds (XValBindsLR (HsVBG grps _)) =
+ concat . snd . unzip $ grps
valbinds ValBinds{} = error "expected XValBindsLR"
-- | Collect docs and attach them to the right declarations.
=====================================
compiler/GHC/HsToCore/Pmc/Desugar.hs
=====================================
@@ -380,8 +380,8 @@ sequenceGrdDagMapM f as = sequenceGrdDags <$> traverse f as
-- recursion, pattern bindings etc.
-- See Note [Long-distance information for HsLocalBinds].
desugarLocalBinds :: HsLocalBinds GhcTc -> DsM GrdDag
-desugarLocalBinds (HsValBinds _ (XValBindsLR (NValBinds binds _))) =
- sequenceGrdDagMapM (sequenceGrdDagMapM go) (map snd binds)
+desugarLocalBinds (HsValBinds _ (XValBindsLR (HsVBG grps _))) =
+ sequenceGrdDagMapM go (hsValBindGroupsBinds grps)
where
go :: LHsBind GhcTc -> DsM GrdDag
go (L _ FunBind{fun_id = L _ x, fun_matches = mg})
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE NondecreasingIndentation, DataKinds #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -850,15 +850,12 @@ addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x)
addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
-> TM (HsValBindsLR GhcTc (GhcPass b))
-addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
- b <- liftM2 NValBinds
- (mapM (\ (rec,binds') ->
- liftM2 (,)
- (return rec)
- (addTickLHsBinds binds'))
- binds)
- (return sigs)
- return $ XValBindsLR b
+addTickHsValBinds (XValBindsLR (HsVBG grps sigs)) = do
+ grps' <- mapM (\ (rec,binds,static) ->
+ do { binds' <- addTickLHsBinds binds
+ ; return (rec,binds',static) })
+ grps
+ return $ XValBindsLR (HsVBG grps' sigs)
addTickHsValBinds _ = panic "addTickHsValBinds"
addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
@@ -1422,7 +1419,8 @@ instance CollectFldBinders (HsLocalBinds GhcTc) where
collectFldBinds EmptyLocalBinds{} = emptyVarEnv
instance CollectFldBinders (HsValBinds GhcTc) where
collectFldBinds (ValBinds _ bnds _) = collectFldBinds bnds
- collectFldBinds (XValBindsLR (NValBinds bnds _)) = collectFldBinds (map snd bnds)
+ collectFldBinds (XValBindsLR (HsVBG grps _))
+ = collectFldBinds (hsValBindGroupsBinds @'Typechecked grps)
instance CollectFldBinders (HsBind GhcTc) where
collectFldBinds PatBind{ pat_lhs } = collectFldBinds pat_lhs
collectFldBinds (XHsBindsLR AbsBinds{ abs_exports, abs_binds }) =
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -430,7 +430,7 @@ getRealSpan :: SrcSpan -> Maybe Span
getRealSpan (RealSrcSpan sp _) = Just sp
getRealSpan _ = Nothing
-grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns)
+grhss_span :: (IsPass p, Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns)
=> GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan
grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (NE.map getLocA xs)
@@ -1437,7 +1437,7 @@ instance HiePass p => ToHie (RScoped (HsLocalBinds (GhcPass p))) where
valBinds
]
-scopeHsLocaLBinds :: HsLocalBinds (GhcPass p) -> Scope
+scopeHsLocaLBinds :: forall p. IsPass p => HsLocalBinds (GhcPass p) -> Scope
scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))
= foldr combineScopes NoScope (bsScope ++ sigsScope)
where
@@ -1445,11 +1445,11 @@ scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))
bsScope = map (mkScope . getLoc) bs
sigsScope :: [Scope]
sigsScope = map (mkScope . getLocA) sigs
-scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs)))
+scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (HsVBG grps sigs)))
= foldr combineScopes NoScope (bsScope ++ sigsScope)
where
bsScope :: [Scope]
- bsScope = map (mkScope . getLoc) $ concatMap snd bs
+ bsScope = map (mkScope . getLoc) (hsValBindGroupsBinds @p grps)
sigsScope :: [Scope]
sigsScope = map (mkScope . getLocA) sigs
@@ -1473,9 +1473,9 @@ instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) whe
]
XValBindsLR x -> [ toHie $ RS sc x ]
-instance HiePass p => ToHie (RScoped (NHsValBindsLR (GhcPass p))) where
- toHie (RS sc (NValBinds binds sigs)) = concatM $
- [ toHie (concatMap (map (BC RegularBind sc) . snd) binds)
+instance HiePass p => ToHie (RScoped (HsValBindGroups p)) where
+ toHie (RS sc (HsVBG binds sigs)) = concatM $
+ [ toHie (map (BC RegularBind sc) (hsValBindGroupsBinds @p binds))
, toHie $ fmap (SC (SI BindSig Nothing)) sigs
]
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -225,7 +225,7 @@ rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs
-- Return a single HsBindGroup with empty binds and renamed signatures
rnTopBindsBoot bound_names (ValBinds _ _ sigs)
= do { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs
- ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) }
+ ; return (XValBindsLR (HsVBG [] sigs'), usesOnly fvs) }
rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b)
{-
@@ -356,7 +356,7 @@ rnValBindsRHS ctxt (ValBinds _ mbinds sigs)
-- so that the binders are removed from
-- the uses in the sigs
- ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) } }
+ ; return (XValBindsLR (HsVBG anal_binds sigs'), valbind'_dus) } }
rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -182,7 +182,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
-- (F) Rename Value declarations right-hand sides
traceRn "Start rnmono" empty ;
let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
- (rn_val_decls@(XValBindsLR (NValBinds _ sigs')), bind_dus) <- if is_boot
+ (rn_val_decls@(XValBindsLR (HsVBG _ sigs')), bind_dus) <- if is_boot
-- For an hs-boot, use tc_bndrs (which collects how we're renamed
-- signatures), since val_bndr_set is empty (there are no x = ...
-- bindings in an hs-boot.)
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -59,7 +59,7 @@ import GHC.Core.Multiplicity
import GHC.Core.FamInstEnv( normaliseType )
import GHC.Core.Class ( Class )
import GHC.Core.Coercion( mkSymCo )
-import GHC.Core.Type (mkStrLitTy, mkCastTy)
+import GHC.Core.Type (mkStrLitTy, mkCastTy, definitelyLiftedType)
import GHC.Core.TyCo.Ppr( pprTyVars )
import GHC.Core.TyCo.Tidy( tidyOpenTypeX )
@@ -83,7 +83,6 @@ import GHC.Types.Basic
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Builtin.Names( ipClassName )
-import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import qualified GHC.LanguageExtensions as LangExt
@@ -198,7 +197,7 @@ tcTopBinds binds sigs
; let { tcg_env' = tcg_env { tcg_imp_specs
= specs ++ tcg_imp_specs tcg_env }
- `addTypecheckedBinds` map snd binds' }
+ `addTypecheckedBinds` map sndOf3 binds' }
; return (tcg_env', tcl_env) }
-- The top level bindings are flattened into a giant
@@ -229,9 +228,9 @@ tcLocalBinds (EmptyLocalBinds x) thing_inside
= do { thing <- thing_inside
; return (EmptyLocalBinds x, thing) }
-tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside
- = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
- ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) }
+tcLocalBinds (HsValBinds x (XValBindsLR (HsVBG grps sigs))) thing_inside
+ = do { (grps', thing) <- tcValBinds NotTopLevel grps sigs thing_inside
+ ; return (HsValBinds x (XValBindsLR (HsVBG grps' sigs)), thing) }
tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds"
tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
@@ -261,9 +260,9 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
tcValBinds :: TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
-> TcM thing
- -> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
+ -> TcM ([(RecFlag, LHsBinds GhcTc, TopLevelFlag)], thing)
-tcValBinds top_lvl binds sigs thing_inside
+tcValBinds top_lvl grps sigs thing_inside
= do { -- Typecheck the signatures
-- It's easier to do so now, once for all the SCCs together
-- because a single signature f,g :: <type>
@@ -281,24 +280,24 @@ tcValBinds top_lvl binds sigs thing_inside
-- only unrestricted variables.
; tcExtendSigIds top_lvl poly_ids $
do { (binds', (extra_binds', thing))
- <- tcBindGroups top_lvl sig_fn prag_fn binds $
+ <- tcBindGroups top_lvl sig_fn prag_fn grps $
do { thing <- thing_inside
-- See Note [Pattern synonym builders don't yield dependencies]
-- in GHC.Rename.Bind
; patsyn_builders <- mapM (tcPatSynBuilderBind prag_fn) patsyns
- ; let extra_binds = [ (NonRecursive, builder)
+ ; let extra_binds = [ (NonRecursive, builder, TopLevel)
| builder <- patsyn_builders ]
; return (extra_binds, thing) }
; return (binds' ++ extra_binds', thing) }}
where
- patsyns = getPatSynBinds binds
- prag_fn = mkPragEnv sigs (concatMap snd binds)
+ patsyns = getPatSynBinds grps
+ prag_fn = mkPragEnv sigs (hsValBindGroupsBinds grps)
------------------------
tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
-> [(RecFlag, LHsBinds GhcRn)] -> TcM thing
- -> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
+ -> TcM ([(RecFlag, LHsBinds GhcTc, TopLevelFlag)], thing)
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
-- Here a "strongly connected component" has the straightforward
@@ -310,9 +309,8 @@ tcBindGroups _ _ _ [] thing_inside
; return ([], thing) }
tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
- = do { -- See Note [Closed binder groups]
- ; (group', (groups', thing))
- <- tc_group top_lvl sig_fn prag_fn group closed $
+ = do { (group', (groups', thing))
+ <- tc_group top_lvl sig_fn prag_fn group $
tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
; return (group' : groups', thing) }
@@ -336,30 +334,54 @@ before we sub-divide it based on what type signatures it has.
tc_group :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> (RecFlag, LHsBinds GhcRn) -> TcM thing
- -> TcM ((RecFlag, LHsBinds GhcTc, Bool), thing)
-
+ -> TcM ((RecFlag, LHsBinds GhcTc, TopLevelFlag), thing)
-- Typecheck one strongly-connected component of the original program.
+tc_group top_lvl sig_fn prag_fn (rec_flag, binds) thing_inside
+ = case rec_flag of
+ NonRecursive -> tc_nonrec_group top_lvl sig_fn prag_fn binds thing_inside
+ Recursive -> tc_rec_group top_lvl sig_fn prag_fn binds thing_inside
+
+---------------------
+tc_nonrec_group :: forall thing.
+ TopLevelFlag -> TcSigFun -> TcPragEnv
+ -> LHsBinds GhcRn -> TcM thing
+ -> TcM ((RecFlag, LHsBinds GhcTc, TopLevelFlag), thing)
+tc_nonrec_group top_lvl sig_fn prag_fn [lbind] thing_inside
+ | L loc (PatSynBind _ psb) <- lbind
+ = do { (aux_binds, tcg_env) <- tcPatSynDecl (L loc psb) sig_fn prag_fn
+ ; thing <- setGblEnv tcg_env thing_inside
+ ; return ((NonRecursive, aux_binds, TopLevel), thing) }
-tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
- -- A single non-recursive binding
+ | otherwise
+ = -- A single non-recursive binding
-- We want to keep non-recursive things non-recursive
-- so that we desugar unlifted bindings correctly
- = do { type_env <- getLclTypeEnv
- ; let closed = isClosedBndrGroup type_env binds
- bind = case binds of
- [bind] -> bind
- [] -> panic "tc_group: empty list of binds"
- _ -> panic "tc_group: NonRecursive binds is not a singleton bag"
- ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed
- thing_inside
- ; return ( (NonRecursive, bind'), thing) }
-
-tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
- = -- To maximise polymorphism, we do a new
- -- strongly-connected-component analysis, this time omitting
- -- any references to variables with type signatures.
- -- (This used to be optional, but isn't now.)
- -- See Note [Polymorphic recursion] in "GHC.Hs.Binds".
+ do { type_env <- getLclTypeEnv
+ ; let closed = isClosedBndrGroup type_env [lbind]
+ ; (bind', ids) <- tcPolyBinds top_lvl sig_fn prag_fn
+ NonRecursive NonRecursive
+ closed
+ [lbind]
+
+ ; let final_closed = adjustClosedForUnlifted closed ids
+
+ ; thing <- tcExtendLetEnv top_lvl sig_fn final_closed ids thing_inside
+ ; return ( (NonRecursive, bind', sendToTopLevel final_closed), thing ) }
+
+tc_nonrec_group _ _ _ binds _ -- Non-rec groups should always be a singleton
+ = pprPanic "tc_nonrec_group" (ppr binds)
+
+---------------------
+tc_rec_group :: forall thing.
+ TopLevelFlag -> TcSigFun -> TcPragEnv
+ -> LHsBinds GhcRn -> TcM thing
+ -> TcM ((RecFlag, LHsBinds GhcTc, TopLevelFlag), thing)
+tc_rec_group top_lvl sig_fn prag_fn binds thing_inside
+ = -- For a recursive group, to maximise polymorphism, we do a new
+ -- strongly-connected-component analysis, this time omitting
+ -- any references to variables with type signatures.
+ -- (This used to be optional, but isn't now.)
+ -- See Note [Polymorphic recursion] in "GHC.Hs.Binds".
do { traceTc "tc_group rec" (pprLHsBinds binds)
; type_env <- getLclTypeEnv
; let closed = isClosedBndrGroup type_env binds
@@ -371,7 +393,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
-- Typecheck the SCCs in turn
; (binds1, thing) <- go closed sccs
- ; return ((Recursive, binds1), thing) }
+ ; return ((Recursive, binds1, sendToTopLevel closed), thing) }
-- Rec them all together
where
mbFirstPatSyn = find (isPatSyn . unLoc) binds
@@ -383,7 +405,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
go :: IsGroupClosed -> [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, thing)
go closed (scc:sccs)
- = do { (binds1, ids1) <- tc_scc scc
+ = do { (binds1, ids1) <- tc_scc closed scc
-- recursive bindings must be unrestricted
-- (the ids added to the environment here are
-- the name of the recursive definitions)
@@ -392,11 +414,11 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
; return (binds1 ++ binds2, thing) }
go _ [] = do { thing <- thing_inside; return ([], thing) }
- tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
- tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds
+ tc_scc closed (AcyclicSCC bind) = tc_sub_group NonRecursive closed [bind]
+ tc_scc closed (CyclicSCC binds) = tc_sub_group Recursive closed binds
- tc_sub_group rec_tc binds = tcPolyBinds top_lvl sig_fn prag_fn
- Recursive rec_tc closed binds
+ tc_sub_group rec_tc closed binds
+ = tcPolyBinds top_lvl sig_fn prag_fn Recursive rec_tc closed binds
recursivePatSynErr
:: SrcSpan -- ^ The location of the first pattern synonym binding
@@ -406,25 +428,6 @@ recursivePatSynErr
recursivePatSynErr loc binds
= failAt loc $ TcRnRecursivePatternSynonym binds
-tc_single :: forall thing.
- TopLevelFlag -> TcSigFun -> TcPragEnv
- -> LHsBind GhcRn -> IsGroupClosed -> TcM thing
- -> TcM (LHsBinds GhcTc, thing)
-tc_single _top_lvl sig_fn prag_fn
- (L loc (PatSynBind _ psb))
- _ thing_inside
- = do { (aux_binds, tcg_env) <- tcPatSynDecl (L loc psb) sig_fn prag_fn
- ; thing <- setGblEnv tcg_env thing_inside
- ; return (aux_binds, thing)
- }
-
-tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
- = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn
- NonRecursive NonRecursive
- closed
- [lbind]
- ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside
- ; return (binds1, thing) }
------------------------
type BKey = Int -- Just number off the bindings
@@ -432,18 +435,15 @@ type BKey = Int -- Just number off the bindings
mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)]
-- See Note [Polymorphic recursion] in "GHC.Hs.Binds".
mkEdges sig_fn binds
- = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)),
- Just key <- [lookupNameEnv key_map n], no_sig n ]
+ = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (lHsBindFreeVars bind)
+ , Just key <- [lookupNameEnv key_map n]
+ , no_sig n ]
| (bind, key) <- keyd_binds
]
-- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices
-- is still deterministic even if the edges are in nondeterministic order
-- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.
where
- bind_fvs (FunBind { fun_ext = fvs }) = fvs
- bind_fvs (PatBind { pat_ext = fvs }) = fvs
- bind_fvs _ = emptyNameSet
-
no_sig :: Name -> Bool
no_sig n = not (hasCompleteSig sig_fn n)
@@ -1818,7 +1818,7 @@ decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds
| has_mult_anns_and_pats = False
-- See (NVP1) and (NVP4) in Note [Non-variable pattern bindings aren't linear]
- | IsGroupClosed _ True <- closed
+ | IsGroupClosed _ _ True <- closed
, not (null binders) = True
-- The 'True' means that all of the group's
-- free vars have ClosedTypeId=True; so we can ignore
@@ -1855,46 +1855,51 @@ decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds
isClosedBndrGroup :: TcTypeEnv -> [LHsBind GhcRn] -> IsGroupClosed
isClosedBndrGroup type_env binds
- = IsGroupClosed fv_env type_closed
+ = IsGroupClosed is_top fv_env type_closed
where
- type_closed = allUFM (nameSetAll is_closed_type_id) fv_env
-
fv_env :: NameEnv NameSet
- fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
-
- bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]
- bindFvs (FunBind { fun_id = L _ f
- , fun_ext = fvs })
- = let open_fvs = get_open_fvs fvs
- in [(f, open_fvs)]
- bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs })
- = let open_fvs = get_open_fvs fvs
- in [(b, open_fvs) | b <- collectPatBinders CollNoDictBinders pat]
- bindFvs _
- = []
-
- get_open_fvs fvs = filterNameSet (not . is_closed) fvs
-
- is_closed :: Name -> ClosedTypeId
- is_closed name
+ fv_env = mkNameEnv $ [ (b,fvs) | (bs,fvs) <- bind_fvs, b <-bs ]
+
+ bind_fvs :: [([Name],NameSet)]
+ bind_fvs = map (get_bind_fvs . unLoc) binds
+
+ get_bind_fvs :: HsBindLR GhcRn GhcRn -> ([Name], NameSet)
+ get_bind_fvs (FunBind { fun_id = L _ f, fun_ext = fvs })
+ = ([f],fvs)
+ get_bind_fvs (PatBind { pat_lhs = pat, pat_ext = fvs })
+ = (collectPatBinders CollNoDictBinders pat, fvs)
+ get_bind_fvs _ = ([], emptyNameSet)
+
+ all_bndrs = concatMap fst bind_fvs
+ all_fvs = foldr (unionNameSet . snd) emptyNameSet bind_fvs
+ `delListFromNameSet` all_bndrs
+ -- all_fvs does not include the binders of this group
+
+ is_top | nameSetAll id_is_top all_fvs = TopLevel
+ | otherwise = NotTopLevel
+
+ id_is_top :: Name -> Bool
+ id_is_top name
| Just thing <- lookupNameEnv type_env name
= case thing of
- AGlobal {} -> True
- ATcId { tct_info = ClosedLet } -> True
- _ -> False
+ AGlobal {} -> True
+ ATcId { tct_info = LetBound { lb_top = top } } -> isTopLevel top
+ _ -> False
- | otherwise
- = True -- The free-var set for a top level binding mentions
+ | otherwise -- Imported Ids
+ = True
+ ---------------------
+ type_closed :: ClosedTypeId
+ type_closed = nameSetAll is_closed_type_id all_fvs
is_closed_type_id :: Name -> Bool
- -- We're already removed Global and ClosedLet Ids
is_closed_type_id name
| Just thing <- lookupNameEnv type_env name
= case thing of
- ATcId { tct_info = NonClosedLet _ cl } -> cl
- ATcId { tct_info = NotLetBound } -> False
- ATyVar {} -> False
+ AGlobal {} -> True
+ ATcId { tct_info = info } -> lb_closed info
+ ATyVar {} -> False
-- In-scope type variables are not closed!
_ -> pprPanic "is_closed_id" (ppr name)
@@ -1904,6 +1909,23 @@ isClosedBndrGroup type_env binds
-- These won't be in the local type env.
-- Ditto class method etc from the current module
+adjustClosedForUnlifted :: IsGroupClosed -> [Scaled TcId] -> IsGroupClosed
+adjustClosedForUnlifted closed@(IsGroupClosed top_lvl fv_env type_closed) ids
+ | TopLevel <- top_lvl
+ , all definitely_lifted ids = closed
+ | otherwise = IsGroupClosed NotTopLevel fv_env type_closed
+ where
+ definitely_lifted (Scaled _ id) = definitelyLiftedType (idType id)
+
+sendToTopLevel :: IsGroupClosed -> TopLevelFlag
+sendToTopLevel (IsGroupClosed top _ _) = top
+
+lHsBindFreeVars :: LHsBind GhcRn -> NameSet
+lHsBindFreeVars (L _ (FunBind { fun_ext = fvs })) = fvs
+lHsBindFreeVars (L _ (PatBind { pat_ext = fvs })) = fvs
+lHsBindFreeVars _ = emptyNameSet
+
+
{- Note [Always generalise top-level bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It is very confusing to apply NoGen to a top level binding. Consider (#20123):
=====================================
compiler/GHC/Tc/Types/BasicTypes.hs
=====================================
@@ -349,31 +349,33 @@ instance Outputable TcTyThing where -- Debugging only
data IdBindingInfo -- See Note [Meaning of IdBindingInfo]
= NotLetBound
- | ClosedLet -- Can definitely be moved to top level
-
- | NonClosedLet
- RhsNames -- Free vars of RHS of this Id's binding that are
- -- neither Global nor ClosedLet
- -- Used only to help with error-messages
- -- in `checkClosedInStaticForm`
-
- ClosedTypeId -- True <=> This Id has a closed type
-
- -- Generalisation of some other binding (f x = e) is OK if
- -- all free vars of `e` are ClosedTypeIds, or ClosedLet
-
--- | IsGroupClosed describes a group of mutually-recursive bindings
+ | LetBound
+ { lb_top :: TopLevelFlag
+ -- TopLevel <=> this binding may safely be moved to top level
+ -- E.g f x = let ys = reverse [1,2]
+ -- zs = reverse ys
+ -- in ...
+ -- Both ys and zs count as TopLevel
+
+ , lb_fvs :: RhsNames
+ -- Free vars of the RHS that are NotLetBound, or LetBound NotTopLevel
+ -- Used to help with error messages in `checkClosedInStaticForm`
+ -- Domain = binders of this recursive group
+
+ , lb_closed :: ClosedTypeId
+ -- True <=> this Id has a closed type
+ -- Generalisation of some other binding (f x = e) is OK if
+ -- all free vars of `e` have lb_clos=ClosedTypeId
+ }
+
+-- | IsGroupClosed describes a group of
+-- mutually-recursive /renamed/ (but not yet typechecked) bindings
data IsGroupClosed
= IsGroupClosed
- (NameEnv RhsNames) -- Free var info for the RHS of each binding in the group
+ TopLevelFlag -- TopLevel <=> all free vars are themselves TopLevel
+ (NameEnv RhsNames) -- Frees for the RHS of each binding in the group
-- (includes free vars of RHS bound in the same group)
- -- Used only to help with error-messages
- -- in `checkClosedInStaticForm`
-
- ClosedTypeId -- True <=> all the free vars of the group are
- -- imported or ClosedLet or
- -- NonClosedLet with ClosedTypeId=True.
- -- In particular, no tyvars, no NotLetBound
+ ClosedTypeId -- True <=> all the free vars of the group have closed types
type RhsNames = NameSet -- Names of variables, mentioned on the RHS of
-- a definition, that are not Global or ClosedLet
@@ -520,9 +522,9 @@ in the type environment.
instance Outputable IdBindingInfo where
ppr NotLetBound = text "NotLetBound"
- ppr ClosedLet = text "TopLevelLet"
- ppr (NonClosedLet fvs closed_type) =
- text "TopLevelLet" <+> ppr fvs <+> ppr closed_type
+ ppr (LetBound { lb_top = top_lvl, lb_fvs = fvs, lb_closed = cls })
+ = text "LetBound" <> braces (sep [ ppr top_lvl, text "closed-type=" <+> ppr cls
+ , ppr fvs ])
--------------
pprTcTyThingCategory :: TcTyThing -> SDoc
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -675,12 +675,15 @@ tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
tcExtendRecIds pairs thing_inside
= tc_extend_local_env NotTopLevel
[ (name, ATcId { tct_id = let_id
- , tct_info = NonClosedLet emptyNameSet False })
+ , tct_info = LetBound { lb_top = NotTopLevel
+ , lb_fvs = emptyNameSet
+ , lb_closed = False } })
| (name, let_id) <- pairs ] $
thing_inside
tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
-- Used for binding the Ids that have a complete user type signature
+-- within a single recursive group.
-- Does not extend the TcBinderStack
tcExtendSigIds top_lvl sig_ids thing_inside
= tc_extend_local_env top_lvl
@@ -688,16 +691,19 @@ tcExtendSigIds top_lvl sig_ids thing_inside
, tct_info = info })
| id <- sig_ids
, let closed = isTypeClosedLetBndr id
- info = NonClosedLet emptyNameSet closed ]
+ info = LetBound { lb_top = NotTopLevel
+ , lb_fvs = emptyNameSet
+ , lb_closed = closed } ]
thing_inside
tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
- -> [Scaled TcId] -> TcM a -> TcM a
+ -> [Scaled TcId] -> TcM a
+ -> TcM a
-- Used for both top-level value bindings and nested let/where-bindings
-- Used for a single NonRec or a single Rec
-- Adds to the TcBinderStack too
-tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)
+tcExtendLetEnv top_lvl _sig_fn (IsGroupClosed group_top fv_env _)
ids thing_inside
= tcExtendBinderStack [TcIdBndr id top_lvl | Scaled _ id <- ids] $
tc_extend_local_env top_lvl
@@ -706,30 +712,15 @@ tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)
| Scaled _ id <- ids ] $
foldr check_usage thing_inside scaled_names
where
- closed_let = all can_float_to_top ids
- can_float_to_top (Scaled _ id)
- = noFreeVarsOfType id_ty
- && definitelyLiftedType id_ty
- && case lookupNameEnv fvs (idName id) of
- Nothing -> True
- Just env -> isEmptyNameSet env
- where
- id_ty = idType id
-
mk_tct_info id
- | closed_let = ClosedLet
- | otherwise = NonClosedLet rhs_fvs type_closed
- where
- name = idName id
- rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet
- type_closed = isTypeClosedLetBndr id &&
- (fv_type_closed || hasCompleteSig sig_fn name)
+ = LetBound { lb_top = group_top
+ , lb_fvs = lookupNameEnv fv_env (idName id) `orElse` emptyNameSet
+ , lb_closed = isTypeClosedLetBndr id }
scaled_names = [Scaled p (idName id) | Scaled p id <- ids ]
check_usage :: Scaled Name -> TcM a -> TcM a
- check_usage (Scaled p id) thing_inside = do
- tcCheckUsage id p thing_inside
+ check_usage (Scaled p id) thing_inside = tcCheckUsage id p thing_inside
tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
-- For lambda-bound and case-bound Ids
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -679,13 +679,11 @@ zonkLocalBinds (EmptyLocalBinds x)
zonkLocalBinds (HsValBinds _ (ValBinds {}))
= panic "zonkLocalBinds" -- Not in typechecker output
-zonkLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs)))
- = do { new_binds <- traverse go binds
- ; return (HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) }
+zonkLocalBinds (HsValBinds x (XValBindsLR (HsVBG binds sigs)))
+ = do { new_binds <- mapM go binds
+ ; return (HsValBinds x (XValBindsLR (HsVBG new_binds sigs))) }
where
- go (r,b)
- = do { b' <- zonkRecMonoBinds b
- ; return (r,b') }
+ go (r,b,s) = do { b' <- zonkRecMonoBinds b; return (r,b',s) }
zonkLocalBinds (HsIPBinds x (IPBinds dict_binds binds )) = do
new_binds <- noBinders $ mapM (wrapLocZonkMA zonk_ip_bind) binds
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/60381bd4ec11f75f06de0594d3e5dab…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/60381bd4ec11f75f06de0594d3e5dab…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/ubsan-gcc] 7 commits: compiler: Exclude units with no exposed modules from unused package check
by Cheng Shao (＠TerrorJack) 06 Nov '25
by Cheng Shao (＠TerrorJack) 06 Nov '25
06 Nov '25
Cheng Shao pushed to branch wip/ubsan-gcc at Glasgow Haskell Compiler / GHC
Commits:
5cdcfaed by Ben Gamari at 2025-11-06T09:01:36-05:00
compiler: Exclude units with no exposed modules from unused package check
Such packages cannot be "used" in the Haskell sense of the word yet
are nevertheless necessary as they may provide, e.g., C object code or
link flags.
Fixes #24120.
- - - - -
74b8397a by Brandon Chinn at 2025-11-06T09:02:19-05:00
Replace deprecated argparse.FileType
- - - - -
36ddf988 by Ben Gamari at 2025-11-06T09:03:01-05:00
Bump unix submodule to 2.8.8.0
Closes #26474.
- - - - -
c32b3a29 by fendor at 2025-11-06T09:03:43-05:00
Fix assertion in `postStringLen` to account for \0 byte
We fix the assertion to handle trailing \0 bytes in `postStringLen`.
Before this change, the assertion looked like this:
ASSERT(eb->begin + eb->size > eb->pos + len + 1);
Let's assume some values to see why this is actually off by one:
eb->begin = 0
eb->size = 1
eb->pos = 0
len = 1
then the assertion would trigger correctly:
0 + 1 > 0 + 1 + 1 => 1 > 2 => false
as there is not enough space for the \0 byte (which is the trailing +1).
However, if we change `eb->size = 2`, then we do have enough space for a
string of length 1, but the assertion still fails:
0 + 2 > 0 + 1 + 1 => 2 > 2 => false
Which causes the assertion to fail if there is exactly enough space for
the string with a trailing \0 byte.
Clearly, the assertion should be `>=`!
If we switch around the operand, it should become more obvious that `<=`
is the correct comparison:
ASSERT(eb->pos + len + 1 <= eb->begin + eb->size);
This is expresses more naturally that the current position plus the
length of the string (and the null byte) must be smaller or equal to the
overall size of the buffer.
This change also is in line with the implementation in
`hasRoomForEvent` and `hasRoomForVariableEvent`:
```
StgBool hasRoomForEvent(EventsBuf *eb, EventTypeNum eNum)
{
uint32_t size = ...;
if (eb->pos + size > eb->begin + eb->size)
...
```
the check `eb->pos + size > eb->begin + eb->size` is identical to
`eb->pos + size <= eb->begin + eb->size` plus a negation.
- - - - -
3034a6f2 by Ben Gamari at 2025-11-06T09:04:24-05:00
Bump os-string submodule to 2.0.8
- - - - -
39567e85 by Cheng Shao at 2025-11-06T09:05:06-05:00
rts: use computed goto for instruction dispatch in the bytecode interpreter
This patch uses computed goto for instruction dispatch in the bytecode
interpreter. Previously instruction dispatch is done by a classic
switch loop, so executing the next instruction requires two jumps: one
to the start of the switch loop and another to the case block based on
the instruction tag. By using computed goto, we can build a jump table
consisted of code addresses indexed by the instruction tags
themselves, so executing the next instruction requires only one jump,
to the destination directly fetched from the jump table.
Closes #12953.
- - - - -
761843b0 by Cheng Shao at 2025-11-06T18:09:23+01:00
hadrian/rts: add support for building with UndefinedBehaviorSanitizer
- - - - -
13 changed files:
- compiler/GHC/Driver/Make.hs
- docs/users_guide/compare-flags.py
- hadrian/src/Flavour.hs
- libraries/os-string
- libraries/unix
- rts/Interpreter.c
- rts/eventlog/EventLog.c
- rts/gen_event_types.py
- rts/include/rts/Bytecodes.h
- rts/rts.cabal
- testsuite/driver/runtests.py
- + testsuite/tests/driver/T24120.hs
- testsuite/tests/driver/all.T
Changes:
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -474,6 +474,10 @@ warnUnusedPackages us dflags mod_graph =
ui <- lookupUnit us u
-- Which are not explicitly used
guard (Set.notMember (unitId ui) used_args)
+ -- Exclude units with no exposed modules. This covers packages which only
+ -- provide C object code or link flags (e.g. system-cxx-std-lib).
+ -- See #24120.
+ guard (not $ null $ unitExposedModules ui)
return (unitId ui, unitPackageName ui, unitPackageVersion ui, flag)
unusedArgs = sortOn (\(u,_,_,_) -> u) $ mapMaybe resolve (explicitUnits us)
=====================================
docs/users_guide/compare-flags.py
=====================================
@@ -35,7 +35,7 @@ def expected_undocumented(flag: str) -> bool:
return False
-def read_documented_flags(doc_flags) -> Set[str]:
+def read_documented_flags(doc_flags: Path) -> Set[str]:
# Map characters that mark the end of a flag
# to whitespace.
trans = str.maketrans({
@@ -44,10 +44,10 @@ def read_documented_flags(doc_flags) -> Set[str]:
'⟨': ' ',
})
return {line.translate(trans).split()[0]
- for line in doc_flags.read().split('\n')
+ for line in doc_flags.read_text(encoding="UTF-8").split('\n')
if line != ''}
-def read_ghc_flags(ghc_path: str) -> Set[str]:
+def read_ghc_flags(ghc_path: Path) -> Set[str]:
ghc_output = subprocess.check_output([ghc_path, '--show-options'])
ghci_output = subprocess.check_output([ghc_path, '--interactive', '--show-options'])
@@ -63,16 +63,16 @@ def error(s: str):
def main() -> None:
import argparse
parser = argparse.ArgumentParser()
- parser.add_argument('--ghc', type=argparse.FileType('r'),
+ parser.add_argument('--ghc', type=Path,
help='path of GHC executable',
required=True)
- parser.add_argument('--doc-flags', type=argparse.FileType(mode='r', encoding='UTF-8'),
+ parser.add_argument('--doc-flags', type=Path,
help='path of ghc-flags.txt output from Sphinx',
required=True)
args = parser.parse_args()
doc_flags = read_documented_flags(args.doc_flags)
- ghc_flags = read_ghc_flags(args.ghc.name)
+ ghc_flags = read_ghc_flags(args.ghc)
failed = False
=====================================
hadrian/src/Flavour.hs
=====================================
@@ -9,6 +9,7 @@ module Flavour
, enableThreadSanitizer
, enableLateCCS
, enableHashUnitIds
+ , enableUBSan
, enableDebugInfo, enableTickyGhc
, viaLlvmBackend
, enableProfiledGhc
@@ -53,6 +54,7 @@ flavourTransformers = M.fromList
, "no_split_sections" =: noSplitSections
, "thread_sanitizer" =: enableThreadSanitizer False
, "thread_sanitizer_cmm" =: enableThreadSanitizer True
+ , "ubsan" =: enableUBSan
, "llvm" =: viaLlvmBackend
, "profiled_ghc" =: enableProfiledGhc
, "no_dynamic_ghc" =: disableDynamicGhcPrograms
@@ -258,6 +260,20 @@ enableThreadSanitizer instrumentCmm = addArgs $ notStage0 ? mconcat
]
]
+enableUBSan :: Flavour -> Flavour
+enableUBSan =
+ addArgs $
+ notStage0
+ ? mconcat
+ [ package rts ? builder (Cabal Flags) ? arg "ubsan",
+ builder (Ghc CompileHs) ? arg "-optc-fsanitize=undefined",
+ builder (Ghc CompileCWithGhc) ? arg "-optc-fsanitize=undefined",
+ builder (Ghc CompileCppWithGhc) ? arg "optcxx-fsanitize=undefined",
+ builder (Ghc LinkHs) ? arg "-optc-fsanitize=undefined"
+ <> arg "-optl-fsanitize=undefined",
+ builder (Cc CompileC) ? arg "-fsanitize=undefined"
+ ]
+
-- | Use the LLVM backend in stages 1 and later.
viaLlvmBackend :: Flavour -> Flavour
viaLlvmBackend = addArgs $ notStage0 ? builder Ghc ? arg "-fllvm"
=====================================
libraries/os-string
=====================================
@@ -1 +1 @@
-Subproject commit 2e693aad07540173a0169971b27c9acac28eeff1
+Subproject commit c08666bf7bf528e607fc1eacc20032ec59e69df3
=====================================
libraries/unix
=====================================
@@ -1 +1 @@
-Subproject commit c9b3e95b5c15b118e55522bd92963038c6a88160
+Subproject commit 60f432b76871bd7787df07dd3e2a567caba393f5
=====================================
rts/Interpreter.c
=====================================
@@ -91,6 +91,80 @@ See also Note [Width of parameters] for some more motivation.
/* #define INTERP_STATS */
+// Note [Instruction dispatch in the bytecode interpreter]
+// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+// Like all bytecode interpreters out there, instruction dispatch is
+// the backbone of our bytecode interpreter:
+//
+// - Each instruction starts with a unique integer tag
+// - Each instruction has a piece of code to handle it
+// - Fetch next instruction's tag, interpret, repeat
+//
+// There are two classical approaches to organize the interpreter loop
+// and implement instruction dispatch:
+//
+// 1. switch-case: fetch the instruction tag, then a switch statement
+// contains each instruction's handler code as a case within it.
+// This is the simplest and most portable approach, but the
+// compiler often generates suboptimal code that involves two jumps
+// per instruction: the first one that jumps back to the switch
+// statement, followed by the second one that jumps to the handler
+// case statement.
+// 2. computed-goto (direct threaded code): GNU C has an extension
+// (https://gcc.gnu.org/onlinedocs/gcc/Labels-as-Values.html) that
+// allows storing a code label as a pointer and using the goto
+// statement to jump to such a pointer. So we can organize the
+// handler code as a code block under a label, have a pointer array
+// that maps an instruction tag to its handler's code label, then
+// instruction dispatch can happen with a single jump after a
+// memory load.
+//
+// A classical paper "The Structure and Performance of Efficient
+// Interpreters" by M. Anton Ertl and David Gregg in 2003 explains it
+// in further details with profiling data:
+// https://jilp.org/vol5/v5paper12.pdf. There exist more subtle issues
+// like interaction with modern CPU's branch predictors, though in
+// practice computed-goto does outperform switch-case, and I've
+// observed around 10%-15% wall clock time speedup in simple
+// benchmarks, so our bytecode interpreter now defaults to using
+// computed-goto when applicable, and falls back to switch-case in
+// other cases.
+//
+// The COMPUTED_GOTO macro is defined when we use computed-goto. We
+// don't do autoconf feature detection since it works with all
+// versions of gcc/clang on all platforms we currently support.
+// Exceptions include:
+//
+// - When DEBUG or other macros are enabled so that there's extra
+// logic per instruction: assertions, statistics, etc. To make
+// computed-goto support those would need us to duplicate the extra
+// code in every instruction's handler code block, not really worth
+// it when speed is not the primary concern.
+// - On wasm, because wasm prohibits goto anyway and LLVM has to lower
+// goto in C to br_table, so there's no performance benefit of
+// computed-goto, only slight penalty due to an extra load from the
+// user-defined dispatch table in the linear memory.
+//
+// The source of truth for our bytecode definition is
+// rts/include/rts/Bytecodes.h. For each bytecode `#define bci_FOO
+// tag`, we have jumptable[tag] which stores the 32-bit offset
+// `&&lbl_bci_FOO - &&lbl_bci_DEFAULT`, so the goto destination can
+// always be computed by adding the jumptable[tag] offset to the base
+// address `&&lbl_bci_DEFAULT`. Whenever you change the bytecode
+// definitions, always remember to update `jumptable` as well!
+
+#if !defined(DEBUG) && !defined(ASSERTS_ENABLED) && !defined(INTERP_STATS) && !defined(wasm32_HOST_ARCH)
+#define COMPUTED_GOTO
+#endif
+
+#if defined(COMPUTED_GOTO)
+#pragma GCC diagnostic ignored "-Wpointer-arith"
+#define INSTRUCTION(name) lbl_##name
+#define NEXT_INSTRUCTION goto *(&&lbl_bci_DEFAULT + jumptable[(bci = instrs[bciPtr++]) & 0xFF])
+#else
+#define INSTRUCTION(name) case name
+#define NEXT_INSTRUCTION goto nextInsn
+#endif
/* Sp points to the lowest live word on the stack. */
@@ -1542,7 +1616,9 @@ run_BCO:
it_lastopc = 0; /* no opcode */
#endif
+#if !defined(COMPUTED_GOTO)
nextInsn:
+#endif
ASSERT(bciPtr < bcoSize);
IF_DEBUG(interpreter,
//if (do_print_stack) {
@@ -1572,15 +1648,263 @@ run_BCO:
it_lastopc = (int)instrs[bciPtr];
#endif
- bci = BCO_NEXT;
+#if defined(COMPUTED_GOTO)
+ static const int32_t jumptable[] = {
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_STKCHECK - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_L - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_LL - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_LLL - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH8_W - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH16_W - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH32_W - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_G - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_P - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_N - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_F - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_D - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_L - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_V - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_PAD8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_PAD16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_PAD32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_UBX8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_UBX16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_UBX32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_UBX - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_N - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_F - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_D - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_L - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_V - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_P - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_PP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_PPP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_PPPP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_PPPPP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_PPPPPP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_SLIDE - &&lbl_bci_DEFAULT,
+ &&lbl_bci_ALLOC_AP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_ALLOC_AP_NOUPD - &&lbl_bci_DEFAULT,
+ &&lbl_bci_ALLOC_PAP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_MKAP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_MKPAP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_UNPACK - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PACK - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_I - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_I - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_F - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_F - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_D - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_D - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_P - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_P - &&lbl_bci_DEFAULT,
+ &&lbl_bci_CASEFAIL - &&lbl_bci_DEFAULT,
+ &&lbl_bci_JMP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_CCALL - &&lbl_bci_DEFAULT,
+ &&lbl_bci_SWIZZLE - &&lbl_bci_DEFAULT,
+ &&lbl_bci_ENTER - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_P - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_N - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_F - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_D - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_L - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_V - &&lbl_bci_DEFAULT,
+ &&lbl_bci_BRK_FUN - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_W - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_W - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_T - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_T - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_I64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_I64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_I32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_I32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_I16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_I16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_I8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_I8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_W64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_W64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_W32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_W32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_W16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_W16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_W8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_W8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PRIMCALL - &&lbl_bci_DEFAULT,
+ &&lbl_bci_BCO_NAME - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ADD_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SUB_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_AND_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_XOR_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NOT_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEG_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_MUL_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SHL_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ASR_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_LSR_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_OR_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEQ_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_EQ_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GE_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GT_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LT_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LE_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GE_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GT_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LT_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LE_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ADD_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SUB_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_AND_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_XOR_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NOT_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEG_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_MUL_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SHL_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ASR_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_LSR_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_OR_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEQ_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_EQ_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GE_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GT_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LT_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LE_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GE_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GT_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LT_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LE_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ADD_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SUB_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_AND_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_XOR_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NOT_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEG_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_MUL_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SHL_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ASR_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_LSR_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_OR_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEQ_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_EQ_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GE_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GT_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LT_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LE_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GE_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GT_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LT_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LE_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ADD_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SUB_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_AND_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_XOR_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NOT_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEG_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_MUL_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SHL_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ASR_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_LSR_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_OR_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEQ_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_EQ_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GE_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GT_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LT_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LE_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GE_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GT_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LT_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LE_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_INDEX_ADDR_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_INDEX_ADDR_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_INDEX_ADDR_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_INDEX_ADDR_64 - &&lbl_bci_DEFAULT};
+ NEXT_INSTRUCTION;
+#else
+ bci = BCO_NEXT;
/* We use the high 8 bits for flags. The highest of which is
* currently allocated to LARGE_ARGS */
ASSERT((bci & 0xFF00) == (bci & ( bci_FLAG_LARGE_ARGS )));
-
switch (bci & 0xFF) {
+#endif
/* check for a breakpoint on the beginning of a BCO */
- case bci_BRK_FUN:
+ INSTRUCTION(bci_BRK_FUN):
{
W_ arg1_brk_array, arg2_info_mod_name, arg3_info_mod_id, arg4_info_index;
#if defined(PROFILING)
@@ -1779,10 +2103,10 @@ run_BCO:
cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
// continue normal execution of the byte code instructions
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_STKCHECK: {
+ INSTRUCTION(bci_STKCHECK): {
// Explicit stack check at the beginning of a function
// *only* (stack checks in case alternatives are
// propagated to the enclosing function).
@@ -1793,27 +2117,27 @@ run_BCO:
SpW(0) = (W_)&stg_apply_interp_info;
RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
} else {
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
}
- case bci_PUSH_L: {
+ INSTRUCTION(bci_PUSH_L): {
W_ o1 = BCO_GET_LARGE_ARG;
SpW(-1) = ReadSpW(o1);
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_LL: {
+ INSTRUCTION(bci_PUSH_LL): {
W_ o1 = BCO_GET_LARGE_ARG;
W_ o2 = BCO_GET_LARGE_ARG;
SpW(-1) = ReadSpW(o1);
SpW(-2) = ReadSpW(o2);
Sp_subW(2);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_LLL: {
+ INSTRUCTION(bci_PUSH_LLL): {
W_ o1 = BCO_GET_LARGE_ARG;
W_ o2 = BCO_GET_LARGE_ARG;
W_ o3 = BCO_GET_LARGE_ARG;
@@ -1821,52 +2145,52 @@ run_BCO:
SpW(-2) = ReadSpW(o2);
SpW(-3) = ReadSpW(o3);
Sp_subW(3);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH8: {
+ INSTRUCTION(bci_PUSH8): {
W_ off = BCO_GET_LARGE_ARG;
Sp_subB(1);
*(StgWord8*)Sp = (StgWord8) (ReadSpB(off+1));
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH16: {
+ INSTRUCTION(bci_PUSH16): {
W_ off = BCO_GET_LARGE_ARG;
Sp_subB(2);
*(StgWord16*)Sp = (StgWord16) (ReadSpB(off+2));
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH32: {
+ INSTRUCTION(bci_PUSH32): {
W_ off = BCO_GET_LARGE_ARG;
Sp_subB(4);
*(StgWord32*)Sp = (StgWord32) (ReadSpB(off+4));
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH8_W: {
+ INSTRUCTION(bci_PUSH8_W): {
W_ off = BCO_GET_LARGE_ARG;
*(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord8) (ReadSpB(off)));
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH16_W: {
+ INSTRUCTION(bci_PUSH16_W): {
W_ off = BCO_GET_LARGE_ARG;
*(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord16) (ReadSpB(off)));
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH32_W: {
+ INSTRUCTION(bci_PUSH32_W): {
W_ off = BCO_GET_LARGE_ARG;
*(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord32) (ReadSpB(off)));
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_G: {
+ INSTRUCTION(bci_PUSH_G): {
W_ o1 = BCO_GET_LARGE_ARG;
StgClosure *tagged_obj = (StgClosure*) BCO_PTR(o1);
@@ -1905,10 +2229,10 @@ run_BCO:
SpW(-1) = (W_) tagged_obj;
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_P: {
+ INSTRUCTION(bci_PUSH_ALTS_P): {
W_ o_bco = BCO_GET_LARGE_ARG;
Sp_subW(2);
SpW(1) = BCO_PTR(o_bco);
@@ -1918,10 +2242,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_N: {
+ INSTRUCTION(bci_PUSH_ALTS_N): {
W_ o_bco = BCO_GET_LARGE_ARG;
SpW(-2) = (W_)&stg_ctoi_R1n_info;
SpW(-1) = BCO_PTR(o_bco);
@@ -1931,10 +2255,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_F: {
+ INSTRUCTION(bci_PUSH_ALTS_F): {
W_ o_bco = BCO_GET_LARGE_ARG;
SpW(-2) = (W_)&stg_ctoi_F1_info;
SpW(-1) = BCO_PTR(o_bco);
@@ -1944,10 +2268,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_D: {
+ INSTRUCTION(bci_PUSH_ALTS_D): {
W_ o_bco = BCO_GET_LARGE_ARG;
SpW(-2) = (W_)&stg_ctoi_D1_info;
SpW(-1) = BCO_PTR(o_bco);
@@ -1957,10 +2281,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_L: {
+ INSTRUCTION(bci_PUSH_ALTS_L): {
W_ o_bco = BCO_GET_LARGE_ARG;
SpW(-2) = (W_)&stg_ctoi_L1_info;
SpW(-1) = BCO_PTR(o_bco);
@@ -1970,10 +2294,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_V: {
+ INSTRUCTION(bci_PUSH_ALTS_V): {
W_ o_bco = BCO_GET_LARGE_ARG;
SpW(-2) = (W_)&stg_ctoi_V_info;
SpW(-1) = BCO_PTR(o_bco);
@@ -1983,10 +2307,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_T: {
+ INSTRUCTION(bci_PUSH_ALTS_T): {
W_ o_bco = BCO_GET_LARGE_ARG;
W_ tuple_info = (W_)BCO_LIT(BCO_GET_LARGE_ARG);
W_ o_tuple_bco = BCO_GET_LARGE_ARG;
@@ -2006,83 +2330,83 @@ run_BCO:
W_ ctoi_t_offset = (W_) ctoi_tuple_infos[tuple_stack_words];
SpW(-4) = ctoi_t_offset;
Sp_subW(4);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_APPLY_N:
+ INSTRUCTION(bci_PUSH_APPLY_N):
Sp_subW(1); SpW(0) = (W_)&stg_ap_n_info;
- goto nextInsn;
- case bci_PUSH_APPLY_V:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_V):
Sp_subW(1); SpW(0) = (W_)&stg_ap_v_info;
- goto nextInsn;
- case bci_PUSH_APPLY_F:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_F):
Sp_subW(1); SpW(0) = (W_)&stg_ap_f_info;
- goto nextInsn;
- case bci_PUSH_APPLY_D:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_D):
Sp_subW(1); SpW(0) = (W_)&stg_ap_d_info;
- goto nextInsn;
- case bci_PUSH_APPLY_L:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_L):
Sp_subW(1); SpW(0) = (W_)&stg_ap_l_info;
- goto nextInsn;
- case bci_PUSH_APPLY_P:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_P):
Sp_subW(1); SpW(0) = (W_)&stg_ap_p_info;
- goto nextInsn;
- case bci_PUSH_APPLY_PP:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_PP):
Sp_subW(1); SpW(0) = (W_)&stg_ap_pp_info;
- goto nextInsn;
- case bci_PUSH_APPLY_PPP:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_PPP):
Sp_subW(1); SpW(0) = (W_)&stg_ap_ppp_info;
- goto nextInsn;
- case bci_PUSH_APPLY_PPPP:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_PPPP):
Sp_subW(1); SpW(0) = (W_)&stg_ap_pppp_info;
- goto nextInsn;
- case bci_PUSH_APPLY_PPPPP:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_PPPPP):
Sp_subW(1); SpW(0) = (W_)&stg_ap_ppppp_info;
- goto nextInsn;
- case bci_PUSH_APPLY_PPPPPP:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_PPPPPP):
Sp_subW(1); SpW(0) = (W_)&stg_ap_pppppp_info;
- goto nextInsn;
+ NEXT_INSTRUCTION;
- case bci_PUSH_PAD8: {
+ INSTRUCTION(bci_PUSH_PAD8): {
Sp_subB(1);
*(StgWord8*)Sp = 0;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_PAD16: {
+ INSTRUCTION(bci_PUSH_PAD16): {
Sp_subB(2);
*(StgWord16*)Sp = 0;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_PAD32: {
+ INSTRUCTION(bci_PUSH_PAD32): {
Sp_subB(4);
*(StgWord32*)Sp = 0;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_UBX8: {
+ INSTRUCTION(bci_PUSH_UBX8): {
W_ o_lit = BCO_GET_LARGE_ARG;
Sp_subB(1);
*(StgWord8*)Sp = (StgWord8) BCO_LIT(o_lit);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_UBX16: {
+ INSTRUCTION(bci_PUSH_UBX16): {
W_ o_lit = BCO_GET_LARGE_ARG;
Sp_subB(2);
*(StgWord16*)Sp = (StgWord16) BCO_LIT(o_lit);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_UBX32: {
+ INSTRUCTION(bci_PUSH_UBX32): {
W_ o_lit = BCO_GET_LARGE_ARG;
Sp_subB(4);
*(StgWord32*)Sp = (StgWord32) BCO_LIT(o_lit);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_UBX: {
+ INSTRUCTION(bci_PUSH_UBX): {
W_ i;
W_ o_lits = BCO_GET_LARGE_ARG;
W_ n_words = BCO_GET_LARGE_ARG;
@@ -2090,10 +2414,10 @@ run_BCO:
for (i = 0; i < n_words; i++) {
SpW(i) = (W_)BCO_LIT(o_lits+i);
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_SLIDE: {
+ INSTRUCTION(bci_SLIDE): {
W_ n = BCO_GET_LARGE_ARG;
W_ by = BCO_GET_LARGE_ARG;
/*
@@ -2106,10 +2430,10 @@ run_BCO:
}
Sp_addW(by);
INTERP_TICK(it_slides);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_ALLOC_AP: {
+ INSTRUCTION(bci_ALLOC_AP): {
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
StgAP *ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
SpW(-1) = (W_)ap;
@@ -2119,10 +2443,10 @@ run_BCO:
// visible only from our stack
SET_HDR(ap, &stg_AP_info, cap->r.rCCCS)
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_ALLOC_AP_NOUPD: {
+ INSTRUCTION(bci_ALLOC_AP_NOUPD): {
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
StgAP *ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
SpW(-1) = (W_)ap;
@@ -2132,10 +2456,10 @@ run_BCO:
// visible only from our stack
SET_HDR(ap, &stg_AP_NOUPD_info, cap->r.rCCCS)
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_ALLOC_PAP: {
+ INSTRUCTION(bci_ALLOC_PAP): {
StgPAP* pap;
StgHalfWord arity = BCO_GET_LARGE_ARG;
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
@@ -2147,10 +2471,10 @@ run_BCO:
// visible only from our stack
SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS)
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_MKAP: {
+ INSTRUCTION(bci_MKAP): {
StgHalfWord i;
W_ stkoff = BCO_GET_LARGE_ARG;
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
@@ -2171,10 +2495,10 @@ run_BCO:
debugBelch("\tBuilt ");
printObj((StgClosure*)ap);
);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_MKPAP: {
+ INSTRUCTION(bci_MKPAP): {
StgHalfWord i;
W_ stkoff = BCO_GET_LARGE_ARG;
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
@@ -2198,10 +2522,10 @@ run_BCO:
debugBelch("\tBuilt ");
printObj((StgClosure*)pap);
);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_UNPACK: {
+ INSTRUCTION(bci_UNPACK): {
/* Unpack N ptr words from t.o.s constructor */
W_ i;
W_ n_words = BCO_GET_LARGE_ARG;
@@ -2210,10 +2534,10 @@ run_BCO:
for (i = 0; i < n_words; i++) {
SpW(i) = (W_)con->payload[i];
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PACK: {
+ INSTRUCTION(bci_PACK): {
W_ o_itbl = BCO_GET_LARGE_ARG;
W_ n_words = BCO_GET_LARGE_ARG;
StgConInfoTable* itbl = CON_INFO_PTR_TO_STRUCT((StgInfoTable *)BCO_LIT(o_itbl));
@@ -2244,220 +2568,220 @@ run_BCO:
debugBelch("\tBuilt ");
printObj((StgClosure*)tagged_con);
);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_P: {
+ INSTRUCTION(bci_TESTLT_P): {
unsigned int discr = BCO_NEXT;
int failto = BCO_GET_LARGE_ARG;
StgClosure* con = UNTAG_CLOSURE((StgClosure*)ReadSpW(0));
if (GET_TAG(con) >= discr) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_P: {
+ INSTRUCTION(bci_TESTEQ_P): {
unsigned int discr = BCO_NEXT;
int failto = BCO_GET_LARGE_ARG;
StgClosure* con = UNTAG_CLOSURE((StgClosure*)ReadSpW(0));
if (GET_TAG(con) != discr) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_I: {
+ INSTRUCTION(bci_TESTLT_I): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
I_ stackInt = (I_)ReadSpW(0);
if (stackInt >= (I_)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_I64: {
+ INSTRUCTION(bci_TESTLT_I64): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt64 stackInt = ReadSpW64(0);
if (stackInt >= BCO_LITI64(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_I32: {
+ INSTRUCTION(bci_TESTLT_I32): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt32 stackInt = (StgInt32) ReadSpW(0);
if (stackInt >= (StgInt32)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_I16: {
+ INSTRUCTION(bci_TESTLT_I16): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt16 stackInt = (StgInt16) ReadSpW(0);
if (stackInt >= (StgInt16)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_I8: {
+ INSTRUCTION(bci_TESTLT_I8): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt8 stackInt = (StgInt8) ReadSpW(0);
if (stackInt >= (StgInt8)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_I: {
+ INSTRUCTION(bci_TESTEQ_I): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
I_ stackInt = (I_)ReadSpW(0);
if (stackInt != (I_)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_I64: {
+ INSTRUCTION(bci_TESTEQ_I64): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt64 stackInt = ReadSpW64(0);
if (stackInt != BCO_LITI64(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_I32: {
+ INSTRUCTION(bci_TESTEQ_I32): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt32 stackInt = (StgInt32) ReadSpW(0);
if (stackInt != (StgInt32)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_I16: {
+ INSTRUCTION(bci_TESTEQ_I16): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt16 stackInt = (StgInt16) ReadSpW(0);
if (stackInt != (StgInt16)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_I8: {
+ INSTRUCTION(bci_TESTEQ_I8): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt8 stackInt = (StgInt8) ReadSpW(0);
if (stackInt != (StgInt8)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_W: {
+ INSTRUCTION(bci_TESTLT_W): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
W_ stackWord = (W_)ReadSpW(0);
if (stackWord >= (W_)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_W64: {
+ INSTRUCTION(bci_TESTLT_W64): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord64 stackWord = ReadSpW64(0);
if (stackWord >= BCO_LITW64(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_W32: {
+ INSTRUCTION(bci_TESTLT_W32): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord32 stackWord = (StgWord32) ReadSpW(0);
if (stackWord >= (StgWord32)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_W16: {
+ INSTRUCTION(bci_TESTLT_W16): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord16 stackWord = (StgInt16) ReadSpW(0);
if (stackWord >= (StgWord16)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_W8: {
+ INSTRUCTION(bci_TESTLT_W8): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord8 stackWord = (StgInt8) ReadSpW(0);
if (stackWord >= (StgWord8)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_W: {
+ INSTRUCTION(bci_TESTEQ_W): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
W_ stackWord = (W_)ReadSpW(0);
if (stackWord != (W_)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_W64: {
+ INSTRUCTION(bci_TESTEQ_W64): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord64 stackWord = ReadSpW64(0);
if (stackWord != BCO_LITW64(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_W32: {
+ INSTRUCTION(bci_TESTEQ_W32): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord32 stackWord = (StgWord32) ReadSpW(0);
if (stackWord != (StgWord32)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_W16: {
+ INSTRUCTION(bci_TESTEQ_W16): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord16 stackWord = (StgWord16) ReadSpW(0);
if (stackWord != (StgWord16)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_W8: {
+ INSTRUCTION(bci_TESTEQ_W8): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord8 stackWord = (StgWord8) ReadSpW(0);
if (stackWord != (StgWord8)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_D: {
+ INSTRUCTION(bci_TESTLT_D): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgDouble stackDbl, discrDbl;
@@ -2466,10 +2790,10 @@ run_BCO:
if (stackDbl >= discrDbl) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_D: {
+ INSTRUCTION(bci_TESTEQ_D): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgDouble stackDbl, discrDbl;
@@ -2478,10 +2802,10 @@ run_BCO:
if (stackDbl != discrDbl) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_F: {
+ INSTRUCTION(bci_TESTLT_F): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgFloat stackFlt, discrFlt;
@@ -2490,10 +2814,10 @@ run_BCO:
if (stackFlt >= discrFlt) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_F: {
+ INSTRUCTION(bci_TESTEQ_F): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgFloat stackFlt, discrFlt;
@@ -2502,11 +2826,11 @@ run_BCO:
if (stackFlt != discrFlt) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
// Control-flow ish things
- case bci_ENTER:
+ INSTRUCTION(bci_ENTER):
// Context-switch check. We put it here to ensure that
// the interpreter has done at least *some* work before
// context switching: sometimes the scheduler can invoke
@@ -2518,50 +2842,50 @@ run_BCO:
}
goto eval;
- case bci_RETURN_P:
+ INSTRUCTION(bci_RETURN_P):
tagged_obj = (StgClosure *)ReadSpW(0);
Sp_addW(1);
goto do_return_pointer;
- case bci_RETURN_N:
+ INSTRUCTION(bci_RETURN_N):
Sp_subW(1);
SpW(0) = (W_)&stg_ret_n_info;
goto do_return_nonpointer;
- case bci_RETURN_F:
+ INSTRUCTION(bci_RETURN_F):
Sp_subW(1);
SpW(0) = (W_)&stg_ret_f_info;
goto do_return_nonpointer;
- case bci_RETURN_D:
+ INSTRUCTION(bci_RETURN_D):
Sp_subW(1);
SpW(0) = (W_)&stg_ret_d_info;
goto do_return_nonpointer;
- case bci_RETURN_L:
+ INSTRUCTION(bci_RETURN_L):
Sp_subW(1);
SpW(0) = (W_)&stg_ret_l_info;
goto do_return_nonpointer;
- case bci_RETURN_V:
+ INSTRUCTION(bci_RETURN_V):
Sp_subW(1);
SpW(0) = (W_)&stg_ret_v_info;
goto do_return_nonpointer;
- case bci_RETURN_T: {
+ INSTRUCTION(bci_RETURN_T): {
/* tuple_info and tuple_bco must already be on the stack */
Sp_subW(1);
SpW(0) = (W_)&stg_ret_t_info;
goto do_return_nonpointer;
}
- case bci_BCO_NAME:
+ INSTRUCTION(bci_BCO_NAME):
bciPtr++;
- goto nextInsn;
+ NEXT_INSTRUCTION;
- case bci_SWIZZLE: {
+ INSTRUCTION(bci_SWIZZLE): {
W_ stkoff = BCO_GET_LARGE_ARG;
StgInt n = BCO_GET_LARGE_ARG;
(*(StgInt*)(SafeSpWP(stkoff))) += n;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PRIMCALL: {
+ INSTRUCTION(bci_PRIMCALL): {
Sp_subW(1);
SpW(0) = (W_)&stg_primcall_info;
RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
@@ -2577,7 +2901,7 @@ run_BCO:
ty r = op ((ty) ReadSpW(0)); \
SpW(0) = (StgWord) r; \
} \
- goto nextInsn; \
+ NEXT_INSTRUCTION; \
}
// op :: ty -> ty -> ty
@@ -2592,7 +2916,7 @@ run_BCO:
Sp_addW(1); \
SpW(0) = (StgWord) r; \
}; \
- goto nextInsn; \
+ NEXT_INSTRUCTION; \
}
// op :: ty -> Int -> ty
@@ -2607,7 +2931,7 @@ run_BCO:
Sp_addW(1); \
SpW(0) = (StgWord) r; \
}; \
- goto nextInsn; \
+ NEXT_INSTRUCTION; \
}
// op :: ty -> ty -> Int
@@ -2622,113 +2946,113 @@ run_BCO:
Sp_addW(1); \
SpW(0) = (StgWord) r; \
}; \
- goto nextInsn; \
+ NEXT_INSTRUCTION; \
}
- case bci_OP_ADD_64: SIZED_BIN_OP(+, StgInt64)
- case bci_OP_SUB_64: SIZED_BIN_OP(-, StgInt64)
- case bci_OP_AND_64: SIZED_BIN_OP(&, StgInt64)
- case bci_OP_XOR_64: SIZED_BIN_OP(^, StgInt64)
- case bci_OP_OR_64: SIZED_BIN_OP(|, StgInt64)
- case bci_OP_MUL_64: SIZED_BIN_OP(*, StgInt64)
- case bci_OP_SHL_64: SIZED_BIN_OP_TY_INT(<<, StgWord64)
- case bci_OP_LSR_64: SIZED_BIN_OP_TY_INT(>>, StgWord64)
- case bci_OP_ASR_64: SIZED_BIN_OP_TY_INT(>>, StgInt64)
-
- case bci_OP_NEQ_64: SIZED_BIN_OP_TY_TY_INT(!=, StgWord64)
- case bci_OP_EQ_64: SIZED_BIN_OP_TY_TY_INT(==, StgWord64)
- case bci_OP_U_GT_64: SIZED_BIN_OP_TY_TY_INT(>, StgWord64)
- case bci_OP_U_GE_64: SIZED_BIN_OP_TY_TY_INT(>=, StgWord64)
- case bci_OP_U_LT_64: SIZED_BIN_OP_TY_TY_INT(<, StgWord64)
- case bci_OP_U_LE_64: SIZED_BIN_OP_TY_TY_INT(<=, StgWord64)
-
- case bci_OP_S_GT_64: SIZED_BIN_OP_TY_TY_INT(>, StgInt64)
- case bci_OP_S_GE_64: SIZED_BIN_OP_TY_TY_INT(>=, StgInt64)
- case bci_OP_S_LT_64: SIZED_BIN_OP_TY_TY_INT(<, StgInt64)
- case bci_OP_S_LE_64: SIZED_BIN_OP_TY_TY_INT(<=, StgInt64)
-
- case bci_OP_NOT_64: UN_SIZED_OP(~, StgWord64)
- case bci_OP_NEG_64: UN_SIZED_OP(-, StgInt64)
-
-
- case bci_OP_ADD_32: SIZED_BIN_OP(+, StgInt32)
- case bci_OP_SUB_32: SIZED_BIN_OP(-, StgInt32)
- case bci_OP_AND_32: SIZED_BIN_OP(&, StgInt32)
- case bci_OP_XOR_32: SIZED_BIN_OP(^, StgInt32)
- case bci_OP_OR_32: SIZED_BIN_OP(|, StgInt32)
- case bci_OP_MUL_32: SIZED_BIN_OP(*, StgInt32)
- case bci_OP_SHL_32: SIZED_BIN_OP_TY_INT(<<, StgWord32)
- case bci_OP_LSR_32: SIZED_BIN_OP_TY_INT(>>, StgWord32)
- case bci_OP_ASR_32: SIZED_BIN_OP_TY_INT(>>, StgInt32)
-
- case bci_OP_NEQ_32: SIZED_BIN_OP_TY_TY_INT(!=, StgWord32)
- case bci_OP_EQ_32: SIZED_BIN_OP_TY_TY_INT(==, StgWord32)
- case bci_OP_U_GT_32: SIZED_BIN_OP_TY_TY_INT(>, StgWord32)
- case bci_OP_U_GE_32: SIZED_BIN_OP_TY_TY_INT(>=, StgWord32)
- case bci_OP_U_LT_32: SIZED_BIN_OP_TY_TY_INT(<, StgWord32)
- case bci_OP_U_LE_32: SIZED_BIN_OP_TY_TY_INT(<=, StgWord32)
-
- case bci_OP_S_GT_32: SIZED_BIN_OP_TY_TY_INT(>, StgInt32)
- case bci_OP_S_GE_32: SIZED_BIN_OP_TY_TY_INT(>=, StgInt32)
- case bci_OP_S_LT_32: SIZED_BIN_OP_TY_TY_INT(<, StgInt32)
- case bci_OP_S_LE_32: SIZED_BIN_OP_TY_TY_INT(<=, StgInt32)
-
- case bci_OP_NOT_32: UN_SIZED_OP(~, StgWord32)
- case bci_OP_NEG_32: UN_SIZED_OP(-, StgInt32)
-
-
- case bci_OP_ADD_16: SIZED_BIN_OP(+, StgInt16)
- case bci_OP_SUB_16: SIZED_BIN_OP(-, StgInt16)
- case bci_OP_AND_16: SIZED_BIN_OP(&, StgInt16)
- case bci_OP_XOR_16: SIZED_BIN_OP(^, StgInt16)
- case bci_OP_OR_16: SIZED_BIN_OP(|, StgInt16)
- case bci_OP_MUL_16: SIZED_BIN_OP(*, StgInt16)
- case bci_OP_SHL_16: SIZED_BIN_OP_TY_INT(<<, StgWord16)
- case bci_OP_LSR_16: SIZED_BIN_OP_TY_INT(>>, StgWord16)
- case bci_OP_ASR_16: SIZED_BIN_OP_TY_INT(>>, StgInt16)
-
- case bci_OP_NEQ_16: SIZED_BIN_OP_TY_TY_INT(!=, StgWord16)
- case bci_OP_EQ_16: SIZED_BIN_OP_TY_TY_INT(==, StgWord16)
- case bci_OP_U_GT_16: SIZED_BIN_OP_TY_TY_INT(>, StgWord16)
- case bci_OP_U_GE_16: SIZED_BIN_OP_TY_TY_INT(>=, StgWord16)
- case bci_OP_U_LT_16: SIZED_BIN_OP_TY_TY_INT(<, StgWord16)
- case bci_OP_U_LE_16: SIZED_BIN_OP_TY_TY_INT(<=, StgWord16)
-
- case bci_OP_S_GT_16: SIZED_BIN_OP(>, StgInt16)
- case bci_OP_S_GE_16: SIZED_BIN_OP(>=, StgInt16)
- case bci_OP_S_LT_16: SIZED_BIN_OP(<, StgInt16)
- case bci_OP_S_LE_16: SIZED_BIN_OP(<=, StgInt16)
-
- case bci_OP_NOT_16: UN_SIZED_OP(~, StgWord16)
- case bci_OP_NEG_16: UN_SIZED_OP(-, StgInt16)
-
-
- case bci_OP_ADD_08: SIZED_BIN_OP(+, StgInt8)
- case bci_OP_SUB_08: SIZED_BIN_OP(-, StgInt8)
- case bci_OP_AND_08: SIZED_BIN_OP(&, StgInt8)
- case bci_OP_XOR_08: SIZED_BIN_OP(^, StgInt8)
- case bci_OP_OR_08: SIZED_BIN_OP(|, StgInt8)
- case bci_OP_MUL_08: SIZED_BIN_OP(*, StgInt8)
- case bci_OP_SHL_08: SIZED_BIN_OP_TY_INT(<<, StgWord8)
- case bci_OP_LSR_08: SIZED_BIN_OP_TY_INT(>>, StgWord8)
- case bci_OP_ASR_08: SIZED_BIN_OP_TY_INT(>>, StgInt8)
-
- case bci_OP_NEQ_08: SIZED_BIN_OP_TY_TY_INT(!=, StgWord8)
- case bci_OP_EQ_08: SIZED_BIN_OP_TY_TY_INT(==, StgWord8)
- case bci_OP_U_GT_08: SIZED_BIN_OP_TY_TY_INT(>, StgWord8)
- case bci_OP_U_GE_08: SIZED_BIN_OP_TY_TY_INT(>=, StgWord8)
- case bci_OP_U_LT_08: SIZED_BIN_OP_TY_TY_INT(<, StgWord8)
- case bci_OP_U_LE_08: SIZED_BIN_OP_TY_TY_INT(<=, StgWord8)
-
- case bci_OP_S_GT_08: SIZED_BIN_OP_TY_TY_INT(>, StgInt8)
- case bci_OP_S_GE_08: SIZED_BIN_OP_TY_TY_INT(>=, StgInt8)
- case bci_OP_S_LT_08: SIZED_BIN_OP_TY_TY_INT(<, StgInt8)
- case bci_OP_S_LE_08: SIZED_BIN_OP_TY_TY_INT(<=, StgInt8)
-
- case bci_OP_NOT_08: UN_SIZED_OP(~, StgWord8)
- case bci_OP_NEG_08: UN_SIZED_OP(-, StgInt8)
-
- case bci_OP_INDEX_ADDR_64:
+ INSTRUCTION(bci_OP_ADD_64): SIZED_BIN_OP(+, StgInt64)
+ INSTRUCTION(bci_OP_SUB_64): SIZED_BIN_OP(-, StgInt64)
+ INSTRUCTION(bci_OP_AND_64): SIZED_BIN_OP(&, StgInt64)
+ INSTRUCTION(bci_OP_XOR_64): SIZED_BIN_OP(^, StgInt64)
+ INSTRUCTION(bci_OP_OR_64): SIZED_BIN_OP(|, StgInt64)
+ INSTRUCTION(bci_OP_MUL_64): SIZED_BIN_OP(*, StgInt64)
+ INSTRUCTION(bci_OP_SHL_64): SIZED_BIN_OP_TY_INT(<<, StgWord64)
+ INSTRUCTION(bci_OP_LSR_64): SIZED_BIN_OP_TY_INT(>>, StgWord64)
+ INSTRUCTION(bci_OP_ASR_64): SIZED_BIN_OP_TY_INT(>>, StgInt64)
+
+ INSTRUCTION(bci_OP_NEQ_64): SIZED_BIN_OP_TY_TY_INT(!=, StgWord64)
+ INSTRUCTION(bci_OP_EQ_64): SIZED_BIN_OP_TY_TY_INT(==, StgWord64)
+ INSTRUCTION(bci_OP_U_GT_64): SIZED_BIN_OP_TY_TY_INT(>, StgWord64)
+ INSTRUCTION(bci_OP_U_GE_64): SIZED_BIN_OP_TY_TY_INT(>=, StgWord64)
+ INSTRUCTION(bci_OP_U_LT_64): SIZED_BIN_OP_TY_TY_INT(<, StgWord64)
+ INSTRUCTION(bci_OP_U_LE_64): SIZED_BIN_OP_TY_TY_INT(<=, StgWord64)
+
+ INSTRUCTION(bci_OP_S_GT_64): SIZED_BIN_OP_TY_TY_INT(>, StgInt64)
+ INSTRUCTION(bci_OP_S_GE_64): SIZED_BIN_OP_TY_TY_INT(>=, StgInt64)
+ INSTRUCTION(bci_OP_S_LT_64): SIZED_BIN_OP_TY_TY_INT(<, StgInt64)
+ INSTRUCTION(bci_OP_S_LE_64): SIZED_BIN_OP_TY_TY_INT(<=, StgInt64)
+
+ INSTRUCTION(bci_OP_NOT_64): UN_SIZED_OP(~, StgWord64)
+ INSTRUCTION(bci_OP_NEG_64): UN_SIZED_OP(-, StgInt64)
+
+
+ INSTRUCTION(bci_OP_ADD_32): SIZED_BIN_OP(+, StgInt32)
+ INSTRUCTION(bci_OP_SUB_32): SIZED_BIN_OP(-, StgInt32)
+ INSTRUCTION(bci_OP_AND_32): SIZED_BIN_OP(&, StgInt32)
+ INSTRUCTION(bci_OP_XOR_32): SIZED_BIN_OP(^, StgInt32)
+ INSTRUCTION(bci_OP_OR_32): SIZED_BIN_OP(|, StgInt32)
+ INSTRUCTION(bci_OP_MUL_32): SIZED_BIN_OP(*, StgInt32)
+ INSTRUCTION(bci_OP_SHL_32): SIZED_BIN_OP_TY_INT(<<, StgWord32)
+ INSTRUCTION(bci_OP_LSR_32): SIZED_BIN_OP_TY_INT(>>, StgWord32)
+ INSTRUCTION(bci_OP_ASR_32): SIZED_BIN_OP_TY_INT(>>, StgInt32)
+
+ INSTRUCTION(bci_OP_NEQ_32): SIZED_BIN_OP_TY_TY_INT(!=, StgWord32)
+ INSTRUCTION(bci_OP_EQ_32): SIZED_BIN_OP_TY_TY_INT(==, StgWord32)
+ INSTRUCTION(bci_OP_U_GT_32): SIZED_BIN_OP_TY_TY_INT(>, StgWord32)
+ INSTRUCTION(bci_OP_U_GE_32): SIZED_BIN_OP_TY_TY_INT(>=, StgWord32)
+ INSTRUCTION(bci_OP_U_LT_32): SIZED_BIN_OP_TY_TY_INT(<, StgWord32)
+ INSTRUCTION(bci_OP_U_LE_32): SIZED_BIN_OP_TY_TY_INT(<=, StgWord32)
+
+ INSTRUCTION(bci_OP_S_GT_32): SIZED_BIN_OP_TY_TY_INT(>, StgInt32)
+ INSTRUCTION(bci_OP_S_GE_32): SIZED_BIN_OP_TY_TY_INT(>=, StgInt32)
+ INSTRUCTION(bci_OP_S_LT_32): SIZED_BIN_OP_TY_TY_INT(<, StgInt32)
+ INSTRUCTION(bci_OP_S_LE_32): SIZED_BIN_OP_TY_TY_INT(<=, StgInt32)
+
+ INSTRUCTION(bci_OP_NOT_32): UN_SIZED_OP(~, StgWord32)
+ INSTRUCTION(bci_OP_NEG_32): UN_SIZED_OP(-, StgInt32)
+
+
+ INSTRUCTION(bci_OP_ADD_16): SIZED_BIN_OP(+, StgInt16)
+ INSTRUCTION(bci_OP_SUB_16): SIZED_BIN_OP(-, StgInt16)
+ INSTRUCTION(bci_OP_AND_16): SIZED_BIN_OP(&, StgInt16)
+ INSTRUCTION(bci_OP_XOR_16): SIZED_BIN_OP(^, StgInt16)
+ INSTRUCTION(bci_OP_OR_16): SIZED_BIN_OP(|, StgInt16)
+ INSTRUCTION(bci_OP_MUL_16): SIZED_BIN_OP(*, StgInt16)
+ INSTRUCTION(bci_OP_SHL_16): SIZED_BIN_OP_TY_INT(<<, StgWord16)
+ INSTRUCTION(bci_OP_LSR_16): SIZED_BIN_OP_TY_INT(>>, StgWord16)
+ INSTRUCTION(bci_OP_ASR_16): SIZED_BIN_OP_TY_INT(>>, StgInt16)
+
+ INSTRUCTION(bci_OP_NEQ_16): SIZED_BIN_OP_TY_TY_INT(!=, StgWord16)
+ INSTRUCTION(bci_OP_EQ_16): SIZED_BIN_OP_TY_TY_INT(==, StgWord16)
+ INSTRUCTION(bci_OP_U_GT_16): SIZED_BIN_OP_TY_TY_INT(>, StgWord16)
+ INSTRUCTION(bci_OP_U_GE_16): SIZED_BIN_OP_TY_TY_INT(>=, StgWord16)
+ INSTRUCTION(bci_OP_U_LT_16): SIZED_BIN_OP_TY_TY_INT(<, StgWord16)
+ INSTRUCTION(bci_OP_U_LE_16): SIZED_BIN_OP_TY_TY_INT(<=, StgWord16)
+
+ INSTRUCTION(bci_OP_S_GT_16): SIZED_BIN_OP(>, StgInt16)
+ INSTRUCTION(bci_OP_S_GE_16): SIZED_BIN_OP(>=, StgInt16)
+ INSTRUCTION(bci_OP_S_LT_16): SIZED_BIN_OP(<, StgInt16)
+ INSTRUCTION(bci_OP_S_LE_16): SIZED_BIN_OP(<=, StgInt16)
+
+ INSTRUCTION(bci_OP_NOT_16): UN_SIZED_OP(~, StgWord16)
+ INSTRUCTION(bci_OP_NEG_16): UN_SIZED_OP(-, StgInt16)
+
+
+ INSTRUCTION(bci_OP_ADD_08): SIZED_BIN_OP(+, StgInt8)
+ INSTRUCTION(bci_OP_SUB_08): SIZED_BIN_OP(-, StgInt8)
+ INSTRUCTION(bci_OP_AND_08): SIZED_BIN_OP(&, StgInt8)
+ INSTRUCTION(bci_OP_XOR_08): SIZED_BIN_OP(^, StgInt8)
+ INSTRUCTION(bci_OP_OR_08): SIZED_BIN_OP(|, StgInt8)
+ INSTRUCTION(bci_OP_MUL_08): SIZED_BIN_OP(*, StgInt8)
+ INSTRUCTION(bci_OP_SHL_08): SIZED_BIN_OP_TY_INT(<<, StgWord8)
+ INSTRUCTION(bci_OP_LSR_08): SIZED_BIN_OP_TY_INT(>>, StgWord8)
+ INSTRUCTION(bci_OP_ASR_08): SIZED_BIN_OP_TY_INT(>>, StgInt8)
+
+ INSTRUCTION(bci_OP_NEQ_08): SIZED_BIN_OP_TY_TY_INT(!=, StgWord8)
+ INSTRUCTION(bci_OP_EQ_08): SIZED_BIN_OP_TY_TY_INT(==, StgWord8)
+ INSTRUCTION(bci_OP_U_GT_08): SIZED_BIN_OP_TY_TY_INT(>, StgWord8)
+ INSTRUCTION(bci_OP_U_GE_08): SIZED_BIN_OP_TY_TY_INT(>=, StgWord8)
+ INSTRUCTION(bci_OP_U_LT_08): SIZED_BIN_OP_TY_TY_INT(<, StgWord8)
+ INSTRUCTION(bci_OP_U_LE_08): SIZED_BIN_OP_TY_TY_INT(<=, StgWord8)
+
+ INSTRUCTION(bci_OP_S_GT_08): SIZED_BIN_OP_TY_TY_INT(>, StgInt8)
+ INSTRUCTION(bci_OP_S_GE_08): SIZED_BIN_OP_TY_TY_INT(>=, StgInt8)
+ INSTRUCTION(bci_OP_S_LT_08): SIZED_BIN_OP_TY_TY_INT(<, StgInt8)
+ INSTRUCTION(bci_OP_S_LE_08): SIZED_BIN_OP_TY_TY_INT(<=, StgInt8)
+
+ INSTRUCTION(bci_OP_NOT_08): UN_SIZED_OP(~, StgWord8)
+ INSTRUCTION(bci_OP_NEG_08): UN_SIZED_OP(-, StgInt8)
+
+ INSTRUCTION(bci_OP_INDEX_ADDR_64):
{
StgWord64* addr = (StgWord64*) SpW(0);
StgInt offset = (StgInt) SpW(1);
@@ -2736,35 +3060,35 @@ run_BCO:
Sp_addW(1);
}
SpW64(0) = *(addr+offset);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_OP_INDEX_ADDR_32:
+ INSTRUCTION(bci_OP_INDEX_ADDR_32):
{
StgWord32* addr = (StgWord32*) SpW(0);
StgInt offset = (StgInt) SpW(1);
Sp_addW(1);
SpW(0) = (StgWord) *(addr+offset);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_OP_INDEX_ADDR_16:
+ INSTRUCTION(bci_OP_INDEX_ADDR_16):
{
StgWord16* addr = (StgWord16*) SpW(0);
StgInt offset = (StgInt) SpW(1);
Sp_addW(1);
SpW(0) = (StgWord) *(addr+offset);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_OP_INDEX_ADDR_08:
+ INSTRUCTION(bci_OP_INDEX_ADDR_08):
{
StgWord8* addr = (StgWord8*) SpW(0);
StgInt offset = (StgInt) SpW(1);
Sp_addW(1);
SpW(0) = (StgWord) *(addr+offset);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_CCALL: {
+ INSTRUCTION(bci_CCALL): {
void *tok;
W_ stk_offset = BCO_GET_LARGE_ARG;
int o_itbl = BCO_GET_LARGE_ARG;
@@ -2921,25 +3245,33 @@ run_BCO:
memcpy(Sp, ret, sizeof(W_) * ret_size);
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_JMP: {
+ INSTRUCTION(bci_JMP): {
/* BCO_NEXT modifies bciPtr, so be conservative. */
int nextpc = BCO_GET_LARGE_ARG;
bciPtr = nextpc;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_CASEFAIL:
+ INSTRUCTION(bci_CASEFAIL):
barf("interpretBCO: hit a CASEFAIL");
- // Errors
+
+
+#if defined(COMPUTED_GOTO)
+ INSTRUCTION(bci_DEFAULT):
+ barf("interpretBCO: unknown or unimplemented opcode %d",
+ (int)(bci & 0xFF));
+#else
+ // Errors
default:
barf("interpretBCO: unknown or unimplemented opcode %d",
(int)(bci & 0xFF));
-
} /* switch on opcode */
+#endif
+
}
}
=====================================
rts/eventlog/EventLog.c
=====================================
@@ -197,7 +197,7 @@ static inline void postBuf(EventsBuf *eb, const StgWord8 *buf, uint32_t size)
static inline void postStringLen(EventsBuf *eb, const char *buf, StgWord len)
{
if (buf) {
- ASSERT(eb->begin + eb->size > eb->pos + len + 1);
+ ASSERT(eb->pos + len + 1 <= eb->begin + eb->size);
memcpy(eb->pos, buf, len);
eb->pos += len;
}
=====================================
rts/gen_event_types.py
=====================================
@@ -1,6 +1,7 @@
#!/usr/bin/env python
# -*- coding: utf-8 -*-
+from pathlib import Path
from typing import List, Union, Dict
from collections import namedtuple
@@ -198,17 +199,17 @@ def generate_event_types_defines() -> str:
def main() -> None:
import argparse
parser = argparse.ArgumentParser()
- parser.add_argument('--event-types-array', type=argparse.FileType('w'), metavar='FILE')
- parser.add_argument('--event-types-defines', type=argparse.FileType('w'), metavar='FILE')
+ parser.add_argument('--event-types-array', type=Path, metavar='FILE')
+ parser.add_argument('--event-types-defines', type=Path, metavar='FILE')
args = parser.parse_args()
check_events()
if args.event_types_array:
- args.event_types_array.write(generate_event_types_array())
+ args.event_types_array.write_text(generate_event_types_array())
if args.event_types_defines:
- args.event_types_defines.write(generate_event_types_defines())
+ args.event_types_defines.write_text(generate_event_types_defines())
if __name__ == '__main__':
main()
=====================================
rts/include/rts/Bytecodes.h
=====================================
@@ -23,6 +23,11 @@
I hope that's clear :-)
*/
+/*
+ Make sure to update jumptable in rts/Interpreter.c when modifying
+ bytecodes! See Note [Instruction dispatch in the bytecode interpreter]
+ for details.
+*/
#define bci_STKCHECK 1
#define bci_PUSH_L 2
#define bci_PUSH_LL 3
=====================================
rts/rts.cabal
=====================================
@@ -91,6 +91,9 @@ flag thread-sanitizer
in @rts/include/rts/TSANUtils.h@.
default: False
manual: True
+flag ubsan
+ default: False
+ manual: True
library
-- rts is a wired in package and
@@ -200,6 +203,9 @@ library
cc-options: -fsanitize=thread
ld-options: -fsanitize=thread
+ if flag(ubsan)
+ ld-options: -fsanitize=undefined
+
if os(linux)
-- the RTS depends upon libc. while this dependency is generally
-- implicitly added by `cc`, we must explicitly add it here to ensure
=====================================
testsuite/driver/runtests.py
=====================================
@@ -83,7 +83,7 @@ parser.add_argument("--way", action="append", help="just this way")
parser.add_argument("--skipway", action="append", help="skip this way")
parser.add_argument("--threads", type=int, help="threads to run simultaneously")
parser.add_argument("--verbose", type=int, choices=[0,1,2,3,4,5], help="verbose (Values 0 through 5 accepted)")
-parser.add_argument("--junit", type=argparse.FileType('wb'), help="output testsuite summary in JUnit format")
+parser.add_argument("--junit", type=Path, help="output testsuite summary in JUnit format")
parser.add_argument("--broken-test", action="append", default=[], help="a test name to mark as broken for this run")
parser.add_argument("--test-env", default='local', help="Override default chosen test-env.")
parser.add_argument("--perf-baseline", type=GitRef, metavar='COMMIT', help="Baseline commit for performance comparsons.")
@@ -91,7 +91,7 @@ perf_group.add_argument("--skip-perf-tests", action="store_true", help="skip per
perf_group.add_argument("--only-perf-tests", action="store_true", help="Only do performance tests")
parser.add_argument("--ignore-perf-failures", choices=['increases','decreases','all'],
help="Do not fail due to out-of-tolerance perf tests")
-parser.add_argument("--only-report-hadrian-deps", type=argparse.FileType('w'),
+parser.add_argument("--only-report-hadrian-deps", type=Path,
help="Dry run the testsuite and report all extra hadrian dependencies needed on the given file")
args = parser.parse_args()
@@ -615,14 +615,14 @@ else:
summary(t, f)
if args.junit:
- junit(t).write(args.junit)
- args.junit.close()
+ with args.junit.open("wb") as f:
+ junit(t).write(f)
if config.only_report_hadrian_deps:
print("WARNING - skipping all tests and only reporting required hadrian dependencies:", config.hadrian_deps)
- for d in config.hadrian_deps:
- print(d,file=config.only_report_hadrian_deps)
- config.only_report_hadrian_deps.close()
+ with config.only_report_hadrian_deps.open("w") as f:
+ for d in config.hadrian_deps:
+ print(d, file=f)
if len(t.unexpected_failures) > 0 or \
len(t.unexpected_stat_failures) > 0 or \
=====================================
testsuite/tests/driver/T24120.hs
=====================================
@@ -0,0 +1,5 @@
+-- | This should not issue an @-Wunused-packages@ warning for @system-cxx-std-lib@.
+module Main where
+
+main :: IO ()
+main = putStrLn "hello world"
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -331,3 +331,4 @@ test('T24839', [unless(arch('x86_64') or arch('aarch64'), skip), extra_files(["t
test('t25150', [extra_files(["t25150"])], multimod_compile, ['Main.hs', '-v0 -working-dir t25150/dir a.c'])
test('T25382', normal, makefile_test, [])
test('T26018', req_c, makefile_test, [])
+test('T24120', normal, compile, ['-Wunused-packages -hide-all-packages -package base -package system-cxx-std-lib'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ea3a58d23c89b00c48cfb3906abdd3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ea3a58d23c89b00c48cfb3906abdd3…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26451] Fix a horrible shadowing bug in implicit parameters
by Simon Peyton Jones (＠simonpj) 06 Nov '25
by Simon Peyton Jones (＠simonpj) 06 Nov '25
06 Nov '25
Simon Peyton Jones pushed to branch wip/T26451 at Glasgow Haskell Compiler / GHC
Commits:
8e6aec4c by Simon Peyton Jones at 2025-11-06T15:26:29+00:00
Fix a horrible shadowing bug in implicit parameters
Fixes #26451. The change is in GHC.Tc.Solver.Monad.updInertDicts
where we now do /not/ delete /Wanted/ implicit-parameeter constraints.
This bug has been in GHC since 9.8! But it's quite hard to provoke;
I contructed a tests in T26451, but it was hard to do so.
- - - - -
4 changed files:
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- + testsuite/tests/typecheck/should_compile/T26451.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -263,7 +263,9 @@ in two places:
* In `updInertDicts`, in this module, when adding [G] (?x :: ty), remove any
existing [G] (?x :: ty'), regardless of ty'.
-* Wrinkle (SIP1): we must be careful of superclasses. Consider
+There are wrinkles:
+
+* Wrinkle (SIP1): we must be careful of superclasses (#14218). Consider
f,g :: (?x::Int, C a) => a -> a
f v = let ?x = 4 in g v
@@ -271,24 +273,31 @@ in two places:
We must /not/ solve this from the Given (?x::Int, C a), because of
the intervening binding for (?x::Int). #14218.
- We deal with this by arranging that when we add [G] (?x::ty) we delete
+ We deal with this by arranging that when we add [G] (?x::ty) we /delete/
* from the inert_cans, and
* from the inert_solved_dicts
any existing [G] (?x::ty) /and/ any [G] D tys, where (D tys) has a superclass
with (?x::ty). See Note [Local implicit parameters] in GHC.Core.Predicate.
- An important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
- But it could happen for `class xx => D xx where ...` and the constraint D
- (?x :: int). This corner (constraint-kinded variables instantiated with
- implicit parameter constraints) is not well explored.
+ An very important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
+
+ But it could also happen for `class xx => D xx where ...` and the constraint
+ D (?x :: int); again see Note [Local implicit parameters]. This corner
+ (constraint-kinded variables instantiated with implicit parameter constraints)
+ is not well explored.
- Example in #14218, and #23761
+ You might worry about whether deleting an /entire/ constraint just because
+ a distant superclass has an implicit parameter might make another Wanted for
+ that constraint un-solvable. Indeed so. But for constraint tuples it doesn't
+ matter -- their entire payload is their superclasses. And the other case is
+ the ill-explored corner above.
The code that accounts for (SIP1) is in updInertDicts; in particular the call to
GHC.Core.Predicate.mentionsIP.
* Wrinkle (SIP2): we must apply this update semantics for `inert_solved_dicts`
- as well as `inert_cans`.
+ as well as `inert_cans` (#23761).
+
You might think that wouldn't be necessary, because an element of
`inert_solved_dicts` is never an implicit parameter (see
Note [Solved dictionaries] in GHC.Tc.Solver.InertSet).
@@ -301,6 +310,19 @@ in two places:
Now (C (?x::Int)) has a superclass (?x::Int). This may look exotic, but it
happens particularly for constraint tuples, like `(% ?x::Int, Eq a %)`.
+* Wrinkle (SIP3)
+ - Note that for the inert dictionaries, `inert_cans`, we must /only/ delete
+ existing /Givens/! Deleting an existing Wanted led to #26451; we just never
+ solved it!
+
+ - In contrast, the solved dictionaries, `inert_solved_dicts`, are really like
+ Givens; they may be "inherited" from outer scopes, so we must delete any
+ solved dictionaries for this implicit parameter for /both/ Givens /and/
+ Wanteds.
+
+ Otherwise the new Given doesn't properly shadow those inherited solved
+ dictionaries. Test T23761 showed this up.
+
Example 1:
Suppose we have (typecheck/should_compile/ImplicitParamFDs)
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -377,28 +377,53 @@ in GHC.Tc.Solver.Dict.
-}
updInertDicts :: DictCt -> TcS ()
-updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
- = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys)
-
- ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys
- -> -- For [G] ?x::ty, remove any dicts mentioning ?x,
- -- from /both/ inert_cans /and/ inert_solved_dicts (#23761)
- -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters]
- updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
- inerts { inert_cans = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics
- , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved }
- | otherwise
- -> return ()
+updInertDicts dict_ct
+ = do { traceTcS "Adding inert dict" (ppr dict_ct)
+
+ -- For Given implicit parameters (only), delete any existing
+ -- Givens for the same implicit parameter.
+ -- See Note [Shadowing of implicit parameters]
+ ; deleteGivenIPs dict_ct
+
-- Add the new constraint to the inert set
; updInertCans (updDicts (addDict dict_ct)) }
+
+deleteGivenIPs :: DictCt -> TcS ()
+-- Special magic when adding a Given implicit parameter to the inert set
+-- For [G] ?x::ty, remove any existing /Givens/ mentioning ?x,
+-- from /both/ inert_cans /and/ inert_solved_dicts (#23761)
+-- See Note [Shadowing of implicit parameters]
+deleteGivenIPs (DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
+ | isGiven ev
+ , Just (str_ty, _) <- isIPPred_maybe cls tys
+ = updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
+ inerts { inert_cans = updDicts (filterDicts (keep_can str_ty)) ics
+ , inert_solved_dicts = filterDicts (keep_solved str_ty) solved }
+ | otherwise
+ = return ()
where
- -- Does this class constraint or any of its superclasses mention
- -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?
- does_not_mention_ip_for :: Type -> DictCt -> Bool
- does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
- = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys
- -- See Note [Using typesAreApart when calling mightMentionIP]
- -- in GHC.Core.Predicate
+ keep_can, keep_solved :: Type -> DictCt -> Bool
+ -- keep_can: we keep an inert dictionary UNLESS
+ -- (1) it is a Given
+ -- (2) it binds an implicit parameter (?str :: ty) for the given 'str'
+ -- regardless of 'ty', possibly via its superclasses
+ -- The test is a bit conservative, hence `mightMentionIP` and `typesAreApart`
+ -- See Note [Using typesAreApart when calling mightMentionIP]
+ -- in GHC.Core.Predicate
+ --
+ -- keep_solved: same as keep_can, but for /all/ constraints not just Givens
+ --
+ -- Why two functions? See (SIP3) in Note [Shadowing of implicit parameters]
+ keep_can str (DictCt { di_ev = ev, di_cls = cls, di_tys = tys })
+ = not (isGiven ev -- (1)
+ && mentions_ip str cls tys) -- (2)
+ keep_solved str (DictCt { di_cls = cls, di_tys = tys })
+ = not (mentions_ip str cls tys)
+
+ -- mentions_ip: the inert constraint might provide evidence
+ -- for an implicit parameter (?str :: ty) for the given 'str'
+ mentions_ip str cls tys
+ = mightMentionIP (not . typesAreApart str) (const True) cls tys
updInertIrreds :: IrredCt -> TcS ()
updInertIrreds irred
=====================================
testsuite/tests/typecheck/should_compile/T26451.hs
=====================================
@@ -0,0 +1,34 @@
+{-# LANGUAGE ImplicitParams, TypeFamilies, FunctionalDependencies, ScopedTypeVariables #-}
+
+module T26451 where
+
+type family F a
+type instance F Bool = [Char]
+
+class C a b | b -> a
+instance C Bool Bool
+instance C Char Char
+
+eq :: forall a b. C a b => a -> b -> ()
+eq p q = ()
+
+g :: a -> F a
+g = g
+
+f (x::tx) (y::ty) -- x :: alpha y :: beta
+ = let ?v = g x -- ?ip :: F alpha
+ in (?v::[ty], eq x True)
+
+
+{- tx, and ty are unification variables
+
+Inert: [G] dg :: IP "v" (F tx)
+ [W] dw :: IP "v" [ty]
+Work-list: [W] dc1 :: C tx Bool
+ [W] dc2 :: C ty Char
+
+* Solve dc1, we get tx := Bool from fundep
+* Kick out dg
+* Solve dg to get [G] dc : IP "v" [Char]
+* Add that new dg to the inert set: that simply deletes dw!!!
+-}
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -955,3 +955,4 @@ test('T26376', normal, compile, [''])
test('T26457', normal, compile, [''])
test('T17705', normal, compile, [''])
test('T14745', normal, compile, [''])
+test('T26451', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e6aec4c251bc4e084af516d278e76d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e6aec4c251bc4e084af516d278e76d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26451] Fix a horrible shadowing bug in implicit parameters
by Simon Peyton Jones (＠simonpj) 06 Nov '25
by Simon Peyton Jones (＠simonpj) 06 Nov '25
06 Nov '25
Simon Peyton Jones pushed to branch wip/T26451 at Glasgow Haskell Compiler / GHC
Commits:
bf59f476 by Simon Peyton Jones at 2025-11-06T15:14:47+00:00
Fix a horrible shadowing bug in implicit parameters
Fixes #26451. The change is in GHC.Tc.Solver.Monad.updInertDicts
where we now do /not/ delete /Wanted/ implicit-parameeter constraints.
This bug has been in GHC since 9.8! But it's quite hard to provoke;
I contructed a tests in T26451, but it was hard to do so.
- - - - -
4 changed files:
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- + testsuite/tests/typecheck/should_compile/T26451.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -263,7 +263,9 @@ in two places:
* In `updInertDicts`, in this module, when adding [G] (?x :: ty), remove any
existing [G] (?x :: ty'), regardless of ty'.
-* Wrinkle (SIP1): we must be careful of superclasses. Consider
+There are wrinkles:
+
+* Wrinkle (SIP1): we must be careful of superclasses (#14218). Consider
f,g :: (?x::Int, C a) => a -> a
f v = let ?x = 4 in g v
@@ -271,24 +273,31 @@ in two places:
We must /not/ solve this from the Given (?x::Int, C a), because of
the intervening binding for (?x::Int). #14218.
- We deal with this by arranging that when we add [G] (?x::ty) we delete
+ We deal with this by arranging that when we add [G] (?x::ty) we /delete/
* from the inert_cans, and
* from the inert_solved_dicts
any existing [G] (?x::ty) /and/ any [G] D tys, where (D tys) has a superclass
with (?x::ty). See Note [Local implicit parameters] in GHC.Core.Predicate.
- An important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
- But it could happen for `class xx => D xx where ...` and the constraint D
- (?x :: int). This corner (constraint-kinded variables instantiated with
- implicit parameter constraints) is not well explored.
+ An very important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
+
+ But it could also happen for `class xx => D xx where ...` and the constraint
+ D (?x :: int); again see Note [Local implicit parameters]. This corner
+ (constraint-kinded variables instantiated with implicit parameter constraints)
+ is not well explored.
- Example in #14218, and #23761
+ You might worry about whether deleting an /entire/ constraint just because
+ a distant superclass has an implicit parameter might make another Wanted for
+ that constraint un-solvable. Indeed so. But for constraint tuples it doesn't
+ matter -- their entire payload is their superclasses. And the other case is
+ the ill-explored corner above.
The code that accounts for (SIP1) is in updInertDicts; in particular the call to
GHC.Core.Predicate.mentionsIP.
* Wrinkle (SIP2): we must apply this update semantics for `inert_solved_dicts`
- as well as `inert_cans`.
+ as well as `inert_cans` (#23761).
+
You might think that wouldn't be necessary, because an element of
`inert_solved_dicts` is never an implicit parameter (see
Note [Solved dictionaries] in GHC.Tc.Solver.InertSet).
@@ -301,6 +310,19 @@ in two places:
Now (C (?x::Int)) has a superclass (?x::Int). This may look exotic, but it
happens particularly for constraint tuples, like `(% ?x::Int, Eq a %)`.
+* Wrinkle (SIP3)
+ - Note that for the inert dictionaries, `inert_cans`, we must /only/ delete
+ existing /Givens/! Deleting an existing Wanted led to #26451; we just never
+ solved it!
+
+ - In contrast, the solved dictionaries, `inert_solved_dicts`, are really like
+ Givens; they may be "inherited" from outer scopes, so we must delete any
+ solved dictionaries for this implicit parameter for /both/ Givens /and/
+ wanteds.
+
+ Otherwise the new Given doesn't properly shadow those inherited solved
+ dictionaries. Test T23761 showed this up.
+
Example 1:
Suppose we have (typecheck/should_compile/ImplicitParamFDs)
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -377,28 +377,53 @@ in GHC.Tc.Solver.Dict.
-}
updInertDicts :: DictCt -> TcS ()
-updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
- = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys)
-
- ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys
- -> -- For [G] ?x::ty, remove any dicts mentioning ?x,
- -- from /both/ inert_cans /and/ inert_solved_dicts (#23761)
- -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters]
- updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
- inerts { inert_cans = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics
- , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved }
- | otherwise
- -> return ()
+updInertDicts dict_ct
+ = do { traceTcS "Adding inert dict" (ppr dict_ct)
+
+ -- For Given implicit parameters (only), delete any existing
+ -- Givens for the same implicit parameter.
+ -- See Note [Shadowing of implicit parameters]
+ ; deleteGivenIPs dict_ct
+
-- Add the new constraint to the inert set
; updInertCans (updDicts (addDict dict_ct)) }
+
+deleteGivenIPs :: DictCt -> TcS ()
+-- Special magic when adding a Given implicit parameter to the inert set
+-- For [G] ?x::ty, remove any existing /Givens/ mentioning ?x,
+-- from /both/ inert_cans /and/ inert_solved_dicts (#23761)
+-- See Note [Shadowing of implicit parameters]
+deleteGivenIPs (DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
+ | isGiven ev
+ , Just (str_ty, _) <- isIPPred_maybe cls tys
+ = updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
+ inerts { inert_cans = updDicts (filterDicts (keep_can str_ty)) ics
+ , inert_solved_dicts = filterDicts (keep_solved str_ty) solved }
+ | otherwise
+ = return ()
where
- -- Does this class constraint or any of its superclasses mention
- -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?
- does_not_mention_ip_for :: Type -> DictCt -> Bool
- does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
- = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys
- -- See Note [Using typesAreApart when calling mightMentionIP]
- -- in GHC.Core.Predicate
+ keep_can, keep_solved :: Type -> DictCt -> Bool
+ -- keep_can: we keep an inert dictionary UNLESS
+ -- (1) it is a Given that
+ -- (2) it binds an implicit parameter (?str :: ty) for the given 'str'
+ -- regardless of 'ty', possibly via its superclasses
+ -- The test is a bit conservative, hence `mightMentionIP` and `typesAreApart`
+ -- See Note [Using typesAreApart when calling mightMentionIP]
+ -- in GHC.Core.Predicate
+ --
+ -- keep_solved: same as keep_can, but for /all/ constraints not just Givens
+ --
+ -- Why two functions? See (SIP3) in Note [Shadowing of implicit parameters]
+ keep_can str (DictCt { di_ev = ev, di_cls = cls, di_tys = tys })
+ = not (isGiven ev -- (1)
+ && mentions_ip str cls tys) -- (2)
+ keep_solved str (DictCt { di_cls = cls, di_tys = tys })
+ = not (mentions_ip str cls tys)
+
+ -- mentions_ip: the inert constraint might provide evidence
+ -- for an implicit parameter (?str :: ty) for the given 'str'
+ mentions_ip str cls tys
+ = mightMentionIP (not . typesAreApart str) (const True) cls tys
updInertIrreds :: IrredCt -> TcS ()
updInertIrreds irred
=====================================
testsuite/tests/typecheck/should_compile/T26451.hs
=====================================
@@ -0,0 +1,34 @@
+{-# LANGUAGE ImplicitParams, TypeFamilies, FunctionalDependencies, ScopedTypeVariables #-}
+
+module T26451 where
+
+type family F a
+type instance F Bool = [Char]
+
+class C a b | b -> a
+instance C Bool Bool
+instance C Char Char
+
+eq :: forall a b. C a b => a -> b -> ()
+eq p q = ()
+
+g :: a -> F a
+g = g
+
+f (x::tx) (y::ty) -- x :: alpha y :: beta
+ = let ?v = g x -- ?ip :: F alpha
+ in (?v::[ty], eq x True)
+
+
+{- tx, and ty are unification variables
+
+Inert: [G] dg :: IP "v" (F tx)
+ [W] dw :: IP "v" [ty]
+Work-list: [W] dc1 :: C tx Bool
+ [W] dc2 :: C ty Char
+
+* Solve dc1, we get tx := Bool from fundep
+* Kick out dg
+* Solve dg to get [G] dc : IP "v" [Char]
+* Add that new dg to the inert set: that simply deletes dw!!!
+-}
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -955,3 +955,4 @@ test('T26376', normal, compile, [''])
test('T26457', normal, compile, [''])
test('T17705', normal, compile, [''])
test('T14745', normal, compile, [''])
+test('T26451', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf59f47613627378a37dd92180b4c19…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf59f47613627378a37dd92180b4c19…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/mercury-ghc910-mhu-transitive-th-deps] remove redundant core bindings typecheck in initWholeCoreBindings
by Torsten Schmits (＠torsten.schmits) 06 Nov '25
by Torsten Schmits (＠torsten.schmits) 06 Nov '25
06 Nov '25
Torsten Schmits pushed to branch wip/torsten.schmits/mercury-ghc910-mhu-transitive-th-deps at Glasgow Haskell Compiler / GHC
Commits:
4d6ffa22 by Torsten Schmits at 2025-11-06T16:10:01+01:00
remove redundant core bindings typecheck in initWholeCoreBindings
- - - - -
1 changed file:
- compiler/GHC/Driver/Main.hs
Changes:
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -1009,11 +1009,6 @@ initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = do
types_var <- newIORef (md_types details)
let kv = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])
let hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv }
- core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi
- -- MP: The NoStubs here is only from (I think) the TH `qAddForeignFilePath` feature but it's a bit unclear what to do
- -- with these files, do we have to read and serialise the foreign file? I will leave it for now until someone
- -- reports a bug.
- let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing []
-- The bytecode generation itself is lazy because otherwise even when doing
-- recompilation checking the bytecode will be generated (which slows things down a lot)
-- the laziness is OK because generateByteCode just depends on things already loaded
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4d6ffa22176b9e82588c4a58008d719…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4d6ffa22176b9e82588c4a58008d719…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26514] Make PmLit be in Ord, and use it in Map
by Simon Peyton Jones (＠simonpj) 06 Nov '25
by Simon Peyton Jones (＠simonpj) 06 Nov '25
06 Nov '25
Simon Peyton Jones pushed to branch wip/T26514 at Glasgow Haskell Compiler / GHC
Commits:
4bc8d9d5 by Simon Peyton Jones at 2025-11-06T14:20:06+00:00
Make PmLit be in Ord, and use it in Map
This MR addresses #26514, by changing from
data PmAltConSet = PACS !(UniqDSet ConLike) ![PmLit]
to
data PmAltConSet = PACS !(UniqDSet ConLike) !(Map PmLit PmLit)
This matters when doing pattern-match overlap checking, when there
is a very large set of patterns. For most programs it makes
no difference at all.
For the N=5000 case of the repro case in #26514, compiler
mutator time (with `-fno-code`) goes from 1.9s to 0.43s.
All for the price for an Ord instance for PmLit
- - - - -
3 changed files:
- compiler/GHC/HsToCore/Pmc/Solver/Types.hs
- compiler/GHC/Types/SourceText.hs
- testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr
Changes:
=====================================
compiler/GHC/HsToCore/Pmc/Solver/Types.hs
=====================================
@@ -2,6 +2,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE TypeFamilies #-}
-- | Domain types used in "GHC.HsToCore.Pmc.Solver".
-- The ultimate goal is to define 'Nabla', which models normalised refinement
@@ -32,7 +33,7 @@ module GHC.HsToCore.Pmc.Solver.Types (
PmEquality(..), eqPmAltCon,
-- *** Operations on 'PmLit'
- literalToPmLit, negatePmLit, overloadPmLit,
+ literalToPmLit, negatePmLit,
pmLitAsStringLit, coreExprAsPmLit
) where
@@ -51,13 +52,12 @@ import GHC.Core.ConLike
import GHC.Utils.Outputable
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc (lastMaybe)
-import GHC.Data.List.SetOps (unionLists)
import GHC.Data.Maybe
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Types.Literal
import GHC.Core
-import GHC.Core.TyCo.Compare( eqType )
+import GHC.Core.TyCo.Compare( eqType, nonDetCmpType )
import GHC.Core.Map.Expr
import GHC.Core.Utils (exprType)
import GHC.Builtin.Names
@@ -69,15 +69,14 @@ import GHC.Types.CompleteMatch
import GHC.Types.SourceText (SourceText(..), mkFractionalLit, FractionalLit
, fractionalLitFromRational
, FractionalExponentBase(..))
+
import Numeric (fromRat)
-import Data.Foldable (find)
import Data.Ratio
+import Data.List( find )
+import qualified Data.Map as FM
import GHC.Real (Ratio(..))
-import qualified Data.Semigroup as Semi
-
--- import GHC.Driver.Ppr
+import qualified Data.Semigroup as S
---
-- * Normalised refinement types
--
@@ -358,6 +357,13 @@ lookupSolution nabla x = case vi_pos (lookupVarInfo (nabla_tm_st nabla) x) of
| Just sol <- find isDataConSolution pos -> Just sol
| otherwise -> Just x
+
+{- *********************************************************************
+* *
+ PmLit and PmLitValue
+* *
+********************************************************************* -}
+
--------------------------------------------------------------------------------
-- The rest is just providing an IR for (overloaded!) literals and AltCons that
-- sits between Hs and Core. We need a reliable way to detect and determine
@@ -376,13 +382,64 @@ data PmLitValue
= PmLitInt Integer
| PmLitRat Rational
| PmLitChar Char
- -- We won't actually see PmLitString in the oracle since we desugar strings to
- -- lists
| PmLitString FastString
+ -- We won't actually see PmLitString in the oracle
+ -- since we desugar strings to lists
+
+ -- Overloaded literals
| PmLitOverInt Int {- How often Negated? -} Integer
| PmLitOverRat Int {- How often Negated? -} FractionalLit
| PmLitOverString FastString
+-- | Syntactic equality.
+-- We want (Ord PmLit) so that we can use (Map PmLit x) in `PmAltConSet`
+instance Eq PmLit where
+ a == b = (a `compare` b) == EQ
+instance Ord PmLit where
+ compare = cmpPmLit
+
+cmpPmLit :: PmLit -> PmLit -> Ordering
+-- This function does "syntactic comparison":
+-- For overloaded literals, compare the type and value
+-- For non-overloaded literals, just compare the values
+-- But it treats (say)
+-- (PmLit Bool (PmLitOverInt 1))
+-- (PmLit Bool (PmLitOverInt 2))
+-- as un-equal, even through (fromInteger @Bool 1)
+-- could be the same as (fromInteger @Bool 2)
+cmpPmLit (PmLit { pm_lit_ty = t1, pm_lit_val = val1 })
+ (PmLit { pm_lit_ty = t2, pm_lit_val = val2 })
+ = case (val1,val2) of
+ (PmLitInt i1, PmLitInt i2) -> i1 `compare` i2
+ (PmLitRat r1, PmLitRat r2) -> r1 `compare` r2
+ (PmLitChar c1, PmLitChar c2) -> c1 `compare` c2
+ (PmLitString s1, PmLitString s2) -> s1 `uniqCompareFS` s2
+ (PmLitOverInt n1 i1, PmLitOverInt n2 i2) -> (n1 `compare` n2) S.<>
+ (i1 `compare` i2) S.<>
+ (t1 `nonDetCmpType` t2)
+ (PmLitOverRat n1 r1, PmLitOverRat n2 r2) -> (n1 `compare` n2) S.<>
+ (r1 `compare` r2) S.<>
+ (t1 `nonDetCmpType` t2)
+ (PmLitOverString s1, PmLitOverString s2) -> (s1 `uniqCompareFS` s2) S.<>
+ (t1 `nonDetCmpType` t2)
+ (PmLitInt {}, _) -> LT
+ (PmLitRat {}, PmLitInt {}) -> GT
+ (PmLitRat {}, _) -> LT
+ (PmLitChar {}, PmLitInt {}) -> GT
+ (PmLitChar {}, PmLitRat {}) -> GT
+ (PmLitChar {}, _) -> LT
+ (PmLitString {}, PmLitInt {}) -> GT
+ (PmLitString {}, PmLitRat {}) -> GT
+ (PmLitString {}, PmLitChar {}) -> GT
+ (PmLitString {}, _) -> LT
+
+ (PmLitOverString {}, _) -> GT
+ (PmLitOverRat {}, PmLitOverString{}) -> LT
+ (PmLitOverRat {}, _) -> GT
+ (PmLitOverInt {}, PmLitOverString{}) -> LT
+ (PmLitOverInt {}, PmLitOverRat{}) -> LT
+ (PmLitOverInt {}, _) -> GT
+
-- | Undecidable semantic equality result.
-- See Note [Undecidable Equality for PmAltCons]
data PmEquality
@@ -406,7 +463,10 @@ eqPmLit :: PmLit -> PmLit -> PmEquality
eqPmLit (PmLit t1 v1) (PmLit t2 v2)
-- no haddock | pprTrace "eqPmLit" (ppr t1 <+> ppr v1 $$ ppr t2 <+> ppr v2) False = undefined
| not (t1 `eqType` t2) = Disjoint
- | otherwise = go v1 v2
+ | otherwise = eqPmLitValue v1 v2
+
+eqPmLitValue :: PmLitValue -> PmLitValue -> PmEquality
+eqPmLitValue v1 v2 = go v1 v2
where
go (PmLitInt i1) (PmLitInt i2) = decEquality (i1 == i2)
go (PmLitRat r1) (PmLitRat r2) = decEquality (r1 == r2)
@@ -420,10 +480,6 @@ eqPmLit (PmLit t1 v1) (PmLit t2 v2)
| s1 == s2 = Equal
go _ _ = PossiblyOverlap
--- | Syntactic equality.
-instance Eq PmLit where
- a == b = eqPmLit a b == Equal
-
-- | Type of a 'PmLit'
pmLitType :: PmLit -> Type
pmLitType (PmLit ty _) = ty
@@ -445,34 +501,47 @@ eqConLike (PatSynCon psc1) (PatSynCon psc2)
= Equal
eqConLike _ _ = PossiblyOverlap
+
+{- *********************************************************************
+* *
+ PmAltCon and PmAltConSet
+* *
+********************************************************************* -}
+
-- | Represents the head of a match against a 'ConLike' or literal.
-- Really similar to 'GHC.Core.AltCon'.
data PmAltCon = PmAltConLike ConLike
| PmAltLit PmLit
-data PmAltConSet = PACS !(UniqDSet ConLike) ![PmLit]
+data PmAltConSet = PACS !(UniqDSet ConLike)
+ !(FM.Map PmLit PmLit)
+-- We use a (FM.Map PmLit PmLit) here, at the cost of requiring an Ord
+-- instance for PmLit, because in extreme cases the set of PmLits can be
+-- very large. See #26514.
emptyPmAltConSet :: PmAltConSet
-emptyPmAltConSet = PACS emptyUniqDSet []
+emptyPmAltConSet = PACS emptyUniqDSet FM.empty
isEmptyPmAltConSet :: PmAltConSet -> Bool
-isEmptyPmAltConSet (PACS cls lits) = isEmptyUniqDSet cls && null lits
+isEmptyPmAltConSet (PACS cls lits)
+ = isEmptyUniqDSet cls && FM.null lits
-- | Whether there is a 'PmAltCon' in the 'PmAltConSet' that compares 'Equal' to
-- the given 'PmAltCon' according to 'eqPmAltCon'.
elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool
elemPmAltConSet (PmAltConLike cl) (PACS cls _ ) = elementOfUniqDSet cl cls
-elemPmAltConSet (PmAltLit lit) (PACS _ lits) = elem lit lits
+elemPmAltConSet (PmAltLit lit) (PACS _ lits) = isJust (FM.lookup lit lits)
extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet
extendPmAltConSet (PACS cls lits) (PmAltConLike cl)
= PACS (addOneToUniqDSet cls cl) lits
extendPmAltConSet (PACS cls lits) (PmAltLit lit)
- = PACS cls (unionLists lits [lit])
+ = PACS cls (FM.insert lit lit lits)
pmAltConSetElems :: PmAltConSet -> [PmAltCon]
pmAltConSetElems (PACS cls lits)
- = map PmAltConLike (uniqDSetToList cls) ++ map PmAltLit lits
+ = map PmAltConLike (uniqDSetToList cls) ++
+ FM.foldr ((:) . PmAltLit) [] lits
instance Outputable PmAltConSet where
ppr = ppr . pmAltConSetElems
=====================================
compiler/GHC/Types/SourceText.hs
=====================================
@@ -188,6 +188,7 @@ data FractionalLit = FL
}
deriving (Data, Show)
-- The Show instance is required for the derived GHC.Parser.Lexer.Token instance when DEBUG is on
+ -- Eq and Ord instances are done explicitly
-- See Note [FractionalLit representation] in GHC.HsToCore.Match.Literal
data FractionalExponentBase
=====================================
testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr
=====================================
@@ -1,4 +1,3 @@
-
pmcOrPats.hs:10:1: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
In an equation for ‘g’: Patterns of type ‘T’, ‘U’ not matched: A W
@@ -18,7 +17,7 @@ pmcOrPats.hs:15:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)]
pmcOrPats.hs:17:1: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
In an equation for ‘z’:
- Patterns of type ‘a’ not matched: p where p is not one of {3, 1, 2}
+ Patterns of type ‘a’ not matched: p where p is not one of {1, 2, 3}
pmcOrPats.hs:19:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)]
Pattern match is redundant
@@ -43,3 +42,4 @@ pmcOrPats.hs:21:1: warning: [GHC-61505]
• Patterns reported as unmatched might actually be matched
Suggested fix:
Increase the limit or resolve the warnings to suppress this message.
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4bc8d9d52c80c9e661a74fc01f1c1b8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4bc8d9d52c80c9e661a74fc01f1c1b8…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] rts: use computed goto for instruction dispatch in the bytecode interpreter
by Marge Bot (＠marge-bot) 06 Nov '25
by Marge Bot (＠marge-bot) 06 Nov '25
06 Nov '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
39567e85 by Cheng Shao at 2025-11-06T09:05:06-05:00
rts: use computed goto for instruction dispatch in the bytecode interpreter
This patch uses computed goto for instruction dispatch in the bytecode
interpreter. Previously instruction dispatch is done by a classic
switch loop, so executing the next instruction requires two jumps: one
to the start of the switch loop and another to the case block based on
the instruction tag. By using computed goto, we can build a jump table
consisted of code addresses indexed by the instruction tags
themselves, so executing the next instruction requires only one jump,
to the destination directly fetched from the jump table.
Closes #12953.
- - - - -
2 changed files:
- rts/Interpreter.c
- rts/include/rts/Bytecodes.h
Changes:
=====================================
rts/Interpreter.c
=====================================
@@ -91,6 +91,80 @@ See also Note [Width of parameters] for some more motivation.
/* #define INTERP_STATS */
+// Note [Instruction dispatch in the bytecode interpreter]
+// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+// Like all bytecode interpreters out there, instruction dispatch is
+// the backbone of our bytecode interpreter:
+//
+// - Each instruction starts with a unique integer tag
+// - Each instruction has a piece of code to handle it
+// - Fetch next instruction's tag, interpret, repeat
+//
+// There are two classical approaches to organize the interpreter loop
+// and implement instruction dispatch:
+//
+// 1. switch-case: fetch the instruction tag, then a switch statement
+// contains each instruction's handler code as a case within it.
+// This is the simplest and most portable approach, but the
+// compiler often generates suboptimal code that involves two jumps
+// per instruction: the first one that jumps back to the switch
+// statement, followed by the second one that jumps to the handler
+// case statement.
+// 2. computed-goto (direct threaded code): GNU C has an extension
+// (https://gcc.gnu.org/onlinedocs/gcc/Labels-as-Values.html) that
+// allows storing a code label as a pointer and using the goto
+// statement to jump to such a pointer. So we can organize the
+// handler code as a code block under a label, have a pointer array
+// that maps an instruction tag to its handler's code label, then
+// instruction dispatch can happen with a single jump after a
+// memory load.
+//
+// A classical paper "The Structure and Performance of Efficient
+// Interpreters" by M. Anton Ertl and David Gregg in 2003 explains it
+// in further details with profiling data:
+// https://jilp.org/vol5/v5paper12.pdf. There exist more subtle issues
+// like interaction with modern CPU's branch predictors, though in
+// practice computed-goto does outperform switch-case, and I've
+// observed around 10%-15% wall clock time speedup in simple
+// benchmarks, so our bytecode interpreter now defaults to using
+// computed-goto when applicable, and falls back to switch-case in
+// other cases.
+//
+// The COMPUTED_GOTO macro is defined when we use computed-goto. We
+// don't do autoconf feature detection since it works with all
+// versions of gcc/clang on all platforms we currently support.
+// Exceptions include:
+//
+// - When DEBUG or other macros are enabled so that there's extra
+// logic per instruction: assertions, statistics, etc. To make
+// computed-goto support those would need us to duplicate the extra
+// code in every instruction's handler code block, not really worth
+// it when speed is not the primary concern.
+// - On wasm, because wasm prohibits goto anyway and LLVM has to lower
+// goto in C to br_table, so there's no performance benefit of
+// computed-goto, only slight penalty due to an extra load from the
+// user-defined dispatch table in the linear memory.
+//
+// The source of truth for our bytecode definition is
+// rts/include/rts/Bytecodes.h. For each bytecode `#define bci_FOO
+// tag`, we have jumptable[tag] which stores the 32-bit offset
+// `&&lbl_bci_FOO - &&lbl_bci_DEFAULT`, so the goto destination can
+// always be computed by adding the jumptable[tag] offset to the base
+// address `&&lbl_bci_DEFAULT`. Whenever you change the bytecode
+// definitions, always remember to update `jumptable` as well!
+
+#if !defined(DEBUG) && !defined(ASSERTS_ENABLED) && !defined(INTERP_STATS) && !defined(wasm32_HOST_ARCH)
+#define COMPUTED_GOTO
+#endif
+
+#if defined(COMPUTED_GOTO)
+#pragma GCC diagnostic ignored "-Wpointer-arith"
+#define INSTRUCTION(name) lbl_##name
+#define NEXT_INSTRUCTION goto *(&&lbl_bci_DEFAULT + jumptable[(bci = instrs[bciPtr++]) & 0xFF])
+#else
+#define INSTRUCTION(name) case name
+#define NEXT_INSTRUCTION goto nextInsn
+#endif
/* Sp points to the lowest live word on the stack. */
@@ -1542,7 +1616,9 @@ run_BCO:
it_lastopc = 0; /* no opcode */
#endif
+#if !defined(COMPUTED_GOTO)
nextInsn:
+#endif
ASSERT(bciPtr < bcoSize);
IF_DEBUG(interpreter,
//if (do_print_stack) {
@@ -1572,15 +1648,263 @@ run_BCO:
it_lastopc = (int)instrs[bciPtr];
#endif
- bci = BCO_NEXT;
+#if defined(COMPUTED_GOTO)
+ static const int32_t jumptable[] = {
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_STKCHECK - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_L - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_LL - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_LLL - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH8_W - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH16_W - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH32_W - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_G - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_P - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_N - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_F - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_D - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_L - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_V - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_PAD8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_PAD16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_PAD32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_UBX8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_UBX16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_UBX32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_UBX - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_N - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_F - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_D - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_L - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_V - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_P - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_PP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_PPP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_PPPP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_PPPPP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_APPLY_PPPPPP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_SLIDE - &&lbl_bci_DEFAULT,
+ &&lbl_bci_ALLOC_AP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_ALLOC_AP_NOUPD - &&lbl_bci_DEFAULT,
+ &&lbl_bci_ALLOC_PAP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_MKAP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_MKPAP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_UNPACK - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PACK - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_I - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_I - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_F - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_F - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_D - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_D - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_P - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_P - &&lbl_bci_DEFAULT,
+ &&lbl_bci_CASEFAIL - &&lbl_bci_DEFAULT,
+ &&lbl_bci_JMP - &&lbl_bci_DEFAULT,
+ &&lbl_bci_CCALL - &&lbl_bci_DEFAULT,
+ &&lbl_bci_SWIZZLE - &&lbl_bci_DEFAULT,
+ &&lbl_bci_ENTER - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_P - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_N - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_F - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_D - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_L - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_V - &&lbl_bci_DEFAULT,
+ &&lbl_bci_BRK_FUN - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_W - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_W - &&lbl_bci_DEFAULT,
+ &&lbl_bci_RETURN_T - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PUSH_ALTS_T - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_I64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_I64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_I32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_I32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_I16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_I16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_I8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_I8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_W64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_W64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_W32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_W32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_W16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_W16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTLT_W8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_TESTEQ_W8 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_PRIMCALL - &&lbl_bci_DEFAULT,
+ &&lbl_bci_BCO_NAME - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ADD_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SUB_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_AND_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_XOR_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NOT_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEG_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_MUL_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SHL_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ASR_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_LSR_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_OR_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEQ_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_EQ_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GE_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GT_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LT_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LE_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GE_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GT_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LT_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LE_64 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ADD_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SUB_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_AND_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_XOR_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NOT_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEG_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_MUL_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SHL_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ASR_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_LSR_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_OR_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEQ_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_EQ_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GE_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GT_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LT_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LE_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GE_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GT_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LT_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LE_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ADD_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SUB_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_AND_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_XOR_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NOT_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEG_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_MUL_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SHL_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ASR_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_LSR_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_OR_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEQ_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_EQ_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GE_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GT_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LT_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LE_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GE_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GT_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LT_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LE_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ADD_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SUB_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_AND_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_XOR_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NOT_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEG_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_MUL_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_SHL_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_ASR_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_LSR_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_OR_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_NEQ_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_EQ_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GE_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_GT_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LT_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_U_LE_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GE_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_GT_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LT_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_S_LE_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_INDEX_ADDR_08 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_INDEX_ADDR_16 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_INDEX_ADDR_32 - &&lbl_bci_DEFAULT,
+ &&lbl_bci_OP_INDEX_ADDR_64 - &&lbl_bci_DEFAULT};
+ NEXT_INSTRUCTION;
+#else
+ bci = BCO_NEXT;
/* We use the high 8 bits for flags. The highest of which is
* currently allocated to LARGE_ARGS */
ASSERT((bci & 0xFF00) == (bci & ( bci_FLAG_LARGE_ARGS )));
-
switch (bci & 0xFF) {
+#endif
/* check for a breakpoint on the beginning of a BCO */
- case bci_BRK_FUN:
+ INSTRUCTION(bci_BRK_FUN):
{
W_ arg1_brk_array, arg2_info_mod_name, arg3_info_mod_id, arg4_info_index;
#if defined(PROFILING)
@@ -1779,10 +2103,10 @@ run_BCO:
cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
// continue normal execution of the byte code instructions
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_STKCHECK: {
+ INSTRUCTION(bci_STKCHECK): {
// Explicit stack check at the beginning of a function
// *only* (stack checks in case alternatives are
// propagated to the enclosing function).
@@ -1793,27 +2117,27 @@ run_BCO:
SpW(0) = (W_)&stg_apply_interp_info;
RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
} else {
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
}
- case bci_PUSH_L: {
+ INSTRUCTION(bci_PUSH_L): {
W_ o1 = BCO_GET_LARGE_ARG;
SpW(-1) = ReadSpW(o1);
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_LL: {
+ INSTRUCTION(bci_PUSH_LL): {
W_ o1 = BCO_GET_LARGE_ARG;
W_ o2 = BCO_GET_LARGE_ARG;
SpW(-1) = ReadSpW(o1);
SpW(-2) = ReadSpW(o2);
Sp_subW(2);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_LLL: {
+ INSTRUCTION(bci_PUSH_LLL): {
W_ o1 = BCO_GET_LARGE_ARG;
W_ o2 = BCO_GET_LARGE_ARG;
W_ o3 = BCO_GET_LARGE_ARG;
@@ -1821,52 +2145,52 @@ run_BCO:
SpW(-2) = ReadSpW(o2);
SpW(-3) = ReadSpW(o3);
Sp_subW(3);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH8: {
+ INSTRUCTION(bci_PUSH8): {
W_ off = BCO_GET_LARGE_ARG;
Sp_subB(1);
*(StgWord8*)Sp = (StgWord8) (ReadSpB(off+1));
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH16: {
+ INSTRUCTION(bci_PUSH16): {
W_ off = BCO_GET_LARGE_ARG;
Sp_subB(2);
*(StgWord16*)Sp = (StgWord16) (ReadSpB(off+2));
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH32: {
+ INSTRUCTION(bci_PUSH32): {
W_ off = BCO_GET_LARGE_ARG;
Sp_subB(4);
*(StgWord32*)Sp = (StgWord32) (ReadSpB(off+4));
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH8_W: {
+ INSTRUCTION(bci_PUSH8_W): {
W_ off = BCO_GET_LARGE_ARG;
*(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord8) (ReadSpB(off)));
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH16_W: {
+ INSTRUCTION(bci_PUSH16_W): {
W_ off = BCO_GET_LARGE_ARG;
*(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord16) (ReadSpB(off)));
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH32_W: {
+ INSTRUCTION(bci_PUSH32_W): {
W_ off = BCO_GET_LARGE_ARG;
*(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord32) (ReadSpB(off)));
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_G: {
+ INSTRUCTION(bci_PUSH_G): {
W_ o1 = BCO_GET_LARGE_ARG;
StgClosure *tagged_obj = (StgClosure*) BCO_PTR(o1);
@@ -1905,10 +2229,10 @@ run_BCO:
SpW(-1) = (W_) tagged_obj;
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_P: {
+ INSTRUCTION(bci_PUSH_ALTS_P): {
W_ o_bco = BCO_GET_LARGE_ARG;
Sp_subW(2);
SpW(1) = BCO_PTR(o_bco);
@@ -1918,10 +2242,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_N: {
+ INSTRUCTION(bci_PUSH_ALTS_N): {
W_ o_bco = BCO_GET_LARGE_ARG;
SpW(-2) = (W_)&stg_ctoi_R1n_info;
SpW(-1) = BCO_PTR(o_bco);
@@ -1931,10 +2255,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_F: {
+ INSTRUCTION(bci_PUSH_ALTS_F): {
W_ o_bco = BCO_GET_LARGE_ARG;
SpW(-2) = (W_)&stg_ctoi_F1_info;
SpW(-1) = BCO_PTR(o_bco);
@@ -1944,10 +2268,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_D: {
+ INSTRUCTION(bci_PUSH_ALTS_D): {
W_ o_bco = BCO_GET_LARGE_ARG;
SpW(-2) = (W_)&stg_ctoi_D1_info;
SpW(-1) = BCO_PTR(o_bco);
@@ -1957,10 +2281,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_L: {
+ INSTRUCTION(bci_PUSH_ALTS_L): {
W_ o_bco = BCO_GET_LARGE_ARG;
SpW(-2) = (W_)&stg_ctoi_L1_info;
SpW(-1) = BCO_PTR(o_bco);
@@ -1970,10 +2294,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_V: {
+ INSTRUCTION(bci_PUSH_ALTS_V): {
W_ o_bco = BCO_GET_LARGE_ARG;
SpW(-2) = (W_)&stg_ctoi_V_info;
SpW(-1) = BCO_PTR(o_bco);
@@ -1983,10 +2307,10 @@ run_BCO:
SpW(1) = (W_)cap->r.rCCCS;
SpW(0) = (W_)&stg_restore_cccs_d_info;
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_ALTS_T: {
+ INSTRUCTION(bci_PUSH_ALTS_T): {
W_ o_bco = BCO_GET_LARGE_ARG;
W_ tuple_info = (W_)BCO_LIT(BCO_GET_LARGE_ARG);
W_ o_tuple_bco = BCO_GET_LARGE_ARG;
@@ -2006,83 +2330,83 @@ run_BCO:
W_ ctoi_t_offset = (W_) ctoi_tuple_infos[tuple_stack_words];
SpW(-4) = ctoi_t_offset;
Sp_subW(4);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_APPLY_N:
+ INSTRUCTION(bci_PUSH_APPLY_N):
Sp_subW(1); SpW(0) = (W_)&stg_ap_n_info;
- goto nextInsn;
- case bci_PUSH_APPLY_V:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_V):
Sp_subW(1); SpW(0) = (W_)&stg_ap_v_info;
- goto nextInsn;
- case bci_PUSH_APPLY_F:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_F):
Sp_subW(1); SpW(0) = (W_)&stg_ap_f_info;
- goto nextInsn;
- case bci_PUSH_APPLY_D:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_D):
Sp_subW(1); SpW(0) = (W_)&stg_ap_d_info;
- goto nextInsn;
- case bci_PUSH_APPLY_L:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_L):
Sp_subW(1); SpW(0) = (W_)&stg_ap_l_info;
- goto nextInsn;
- case bci_PUSH_APPLY_P:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_P):
Sp_subW(1); SpW(0) = (W_)&stg_ap_p_info;
- goto nextInsn;
- case bci_PUSH_APPLY_PP:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_PP):
Sp_subW(1); SpW(0) = (W_)&stg_ap_pp_info;
- goto nextInsn;
- case bci_PUSH_APPLY_PPP:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_PPP):
Sp_subW(1); SpW(0) = (W_)&stg_ap_ppp_info;
- goto nextInsn;
- case bci_PUSH_APPLY_PPPP:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_PPPP):
Sp_subW(1); SpW(0) = (W_)&stg_ap_pppp_info;
- goto nextInsn;
- case bci_PUSH_APPLY_PPPPP:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_PPPPP):
Sp_subW(1); SpW(0) = (W_)&stg_ap_ppppp_info;
- goto nextInsn;
- case bci_PUSH_APPLY_PPPPPP:
+ NEXT_INSTRUCTION;
+ INSTRUCTION(bci_PUSH_APPLY_PPPPPP):
Sp_subW(1); SpW(0) = (W_)&stg_ap_pppppp_info;
- goto nextInsn;
+ NEXT_INSTRUCTION;
- case bci_PUSH_PAD8: {
+ INSTRUCTION(bci_PUSH_PAD8): {
Sp_subB(1);
*(StgWord8*)Sp = 0;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_PAD16: {
+ INSTRUCTION(bci_PUSH_PAD16): {
Sp_subB(2);
*(StgWord16*)Sp = 0;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_PAD32: {
+ INSTRUCTION(bci_PUSH_PAD32): {
Sp_subB(4);
*(StgWord32*)Sp = 0;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_UBX8: {
+ INSTRUCTION(bci_PUSH_UBX8): {
W_ o_lit = BCO_GET_LARGE_ARG;
Sp_subB(1);
*(StgWord8*)Sp = (StgWord8) BCO_LIT(o_lit);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_UBX16: {
+ INSTRUCTION(bci_PUSH_UBX16): {
W_ o_lit = BCO_GET_LARGE_ARG;
Sp_subB(2);
*(StgWord16*)Sp = (StgWord16) BCO_LIT(o_lit);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_UBX32: {
+ INSTRUCTION(bci_PUSH_UBX32): {
W_ o_lit = BCO_GET_LARGE_ARG;
Sp_subB(4);
*(StgWord32*)Sp = (StgWord32) BCO_LIT(o_lit);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PUSH_UBX: {
+ INSTRUCTION(bci_PUSH_UBX): {
W_ i;
W_ o_lits = BCO_GET_LARGE_ARG;
W_ n_words = BCO_GET_LARGE_ARG;
@@ -2090,10 +2414,10 @@ run_BCO:
for (i = 0; i < n_words; i++) {
SpW(i) = (W_)BCO_LIT(o_lits+i);
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_SLIDE: {
+ INSTRUCTION(bci_SLIDE): {
W_ n = BCO_GET_LARGE_ARG;
W_ by = BCO_GET_LARGE_ARG;
/*
@@ -2106,10 +2430,10 @@ run_BCO:
}
Sp_addW(by);
INTERP_TICK(it_slides);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_ALLOC_AP: {
+ INSTRUCTION(bci_ALLOC_AP): {
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
StgAP *ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
SpW(-1) = (W_)ap;
@@ -2119,10 +2443,10 @@ run_BCO:
// visible only from our stack
SET_HDR(ap, &stg_AP_info, cap->r.rCCCS)
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_ALLOC_AP_NOUPD: {
+ INSTRUCTION(bci_ALLOC_AP_NOUPD): {
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
StgAP *ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
SpW(-1) = (W_)ap;
@@ -2132,10 +2456,10 @@ run_BCO:
// visible only from our stack
SET_HDR(ap, &stg_AP_NOUPD_info, cap->r.rCCCS)
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_ALLOC_PAP: {
+ INSTRUCTION(bci_ALLOC_PAP): {
StgPAP* pap;
StgHalfWord arity = BCO_GET_LARGE_ARG;
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
@@ -2147,10 +2471,10 @@ run_BCO:
// visible only from our stack
SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS)
Sp_subW(1);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_MKAP: {
+ INSTRUCTION(bci_MKAP): {
StgHalfWord i;
W_ stkoff = BCO_GET_LARGE_ARG;
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
@@ -2171,10 +2495,10 @@ run_BCO:
debugBelch("\tBuilt ");
printObj((StgClosure*)ap);
);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_MKPAP: {
+ INSTRUCTION(bci_MKPAP): {
StgHalfWord i;
W_ stkoff = BCO_GET_LARGE_ARG;
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
@@ -2198,10 +2522,10 @@ run_BCO:
debugBelch("\tBuilt ");
printObj((StgClosure*)pap);
);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_UNPACK: {
+ INSTRUCTION(bci_UNPACK): {
/* Unpack N ptr words from t.o.s constructor */
W_ i;
W_ n_words = BCO_GET_LARGE_ARG;
@@ -2210,10 +2534,10 @@ run_BCO:
for (i = 0; i < n_words; i++) {
SpW(i) = (W_)con->payload[i];
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PACK: {
+ INSTRUCTION(bci_PACK): {
W_ o_itbl = BCO_GET_LARGE_ARG;
W_ n_words = BCO_GET_LARGE_ARG;
StgConInfoTable* itbl = CON_INFO_PTR_TO_STRUCT((StgInfoTable *)BCO_LIT(o_itbl));
@@ -2244,220 +2568,220 @@ run_BCO:
debugBelch("\tBuilt ");
printObj((StgClosure*)tagged_con);
);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_P: {
+ INSTRUCTION(bci_TESTLT_P): {
unsigned int discr = BCO_NEXT;
int failto = BCO_GET_LARGE_ARG;
StgClosure* con = UNTAG_CLOSURE((StgClosure*)ReadSpW(0));
if (GET_TAG(con) >= discr) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_P: {
+ INSTRUCTION(bci_TESTEQ_P): {
unsigned int discr = BCO_NEXT;
int failto = BCO_GET_LARGE_ARG;
StgClosure* con = UNTAG_CLOSURE((StgClosure*)ReadSpW(0));
if (GET_TAG(con) != discr) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_I: {
+ INSTRUCTION(bci_TESTLT_I): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
I_ stackInt = (I_)ReadSpW(0);
if (stackInt >= (I_)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_I64: {
+ INSTRUCTION(bci_TESTLT_I64): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt64 stackInt = ReadSpW64(0);
if (stackInt >= BCO_LITI64(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_I32: {
+ INSTRUCTION(bci_TESTLT_I32): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt32 stackInt = (StgInt32) ReadSpW(0);
if (stackInt >= (StgInt32)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_I16: {
+ INSTRUCTION(bci_TESTLT_I16): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt16 stackInt = (StgInt16) ReadSpW(0);
if (stackInt >= (StgInt16)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_I8: {
+ INSTRUCTION(bci_TESTLT_I8): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt8 stackInt = (StgInt8) ReadSpW(0);
if (stackInt >= (StgInt8)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_I: {
+ INSTRUCTION(bci_TESTEQ_I): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
I_ stackInt = (I_)ReadSpW(0);
if (stackInt != (I_)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_I64: {
+ INSTRUCTION(bci_TESTEQ_I64): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt64 stackInt = ReadSpW64(0);
if (stackInt != BCO_LITI64(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_I32: {
+ INSTRUCTION(bci_TESTEQ_I32): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt32 stackInt = (StgInt32) ReadSpW(0);
if (stackInt != (StgInt32)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_I16: {
+ INSTRUCTION(bci_TESTEQ_I16): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt16 stackInt = (StgInt16) ReadSpW(0);
if (stackInt != (StgInt16)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_I8: {
+ INSTRUCTION(bci_TESTEQ_I8): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgInt8 stackInt = (StgInt8) ReadSpW(0);
if (stackInt != (StgInt8)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_W: {
+ INSTRUCTION(bci_TESTLT_W): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
W_ stackWord = (W_)ReadSpW(0);
if (stackWord >= (W_)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_W64: {
+ INSTRUCTION(bci_TESTLT_W64): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord64 stackWord = ReadSpW64(0);
if (stackWord >= BCO_LITW64(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_W32: {
+ INSTRUCTION(bci_TESTLT_W32): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord32 stackWord = (StgWord32) ReadSpW(0);
if (stackWord >= (StgWord32)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_W16: {
+ INSTRUCTION(bci_TESTLT_W16): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord16 stackWord = (StgInt16) ReadSpW(0);
if (stackWord >= (StgWord16)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_W8: {
+ INSTRUCTION(bci_TESTLT_W8): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord8 stackWord = (StgInt8) ReadSpW(0);
if (stackWord >= (StgWord8)BCO_LIT(discr))
bciPtr = failto;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_W: {
+ INSTRUCTION(bci_TESTEQ_W): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
W_ stackWord = (W_)ReadSpW(0);
if (stackWord != (W_)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_W64: {
+ INSTRUCTION(bci_TESTEQ_W64): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord64 stackWord = ReadSpW64(0);
if (stackWord != BCO_LITW64(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_W32: {
+ INSTRUCTION(bci_TESTEQ_W32): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord32 stackWord = (StgWord32) ReadSpW(0);
if (stackWord != (StgWord32)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_W16: {
+ INSTRUCTION(bci_TESTEQ_W16): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord16 stackWord = (StgWord16) ReadSpW(0);
if (stackWord != (StgWord16)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_W8: {
+ INSTRUCTION(bci_TESTEQ_W8): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgWord8 stackWord = (StgWord8) ReadSpW(0);
if (stackWord != (StgWord8)BCO_LIT(discr)) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_D: {
+ INSTRUCTION(bci_TESTLT_D): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgDouble stackDbl, discrDbl;
@@ -2466,10 +2790,10 @@ run_BCO:
if (stackDbl >= discrDbl) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_D: {
+ INSTRUCTION(bci_TESTEQ_D): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgDouble stackDbl, discrDbl;
@@ -2478,10 +2802,10 @@ run_BCO:
if (stackDbl != discrDbl) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTLT_F: {
+ INSTRUCTION(bci_TESTLT_F): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgFloat stackFlt, discrFlt;
@@ -2490,10 +2814,10 @@ run_BCO:
if (stackFlt >= discrFlt) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_TESTEQ_F: {
+ INSTRUCTION(bci_TESTEQ_F): {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
StgFloat stackFlt, discrFlt;
@@ -2502,11 +2826,11 @@ run_BCO:
if (stackFlt != discrFlt) {
bciPtr = failto;
}
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
// Control-flow ish things
- case bci_ENTER:
+ INSTRUCTION(bci_ENTER):
// Context-switch check. We put it here to ensure that
// the interpreter has done at least *some* work before
// context switching: sometimes the scheduler can invoke
@@ -2518,50 +2842,50 @@ run_BCO:
}
goto eval;
- case bci_RETURN_P:
+ INSTRUCTION(bci_RETURN_P):
tagged_obj = (StgClosure *)ReadSpW(0);
Sp_addW(1);
goto do_return_pointer;
- case bci_RETURN_N:
+ INSTRUCTION(bci_RETURN_N):
Sp_subW(1);
SpW(0) = (W_)&stg_ret_n_info;
goto do_return_nonpointer;
- case bci_RETURN_F:
+ INSTRUCTION(bci_RETURN_F):
Sp_subW(1);
SpW(0) = (W_)&stg_ret_f_info;
goto do_return_nonpointer;
- case bci_RETURN_D:
+ INSTRUCTION(bci_RETURN_D):
Sp_subW(1);
SpW(0) = (W_)&stg_ret_d_info;
goto do_return_nonpointer;
- case bci_RETURN_L:
+ INSTRUCTION(bci_RETURN_L):
Sp_subW(1);
SpW(0) = (W_)&stg_ret_l_info;
goto do_return_nonpointer;
- case bci_RETURN_V:
+ INSTRUCTION(bci_RETURN_V):
Sp_subW(1);
SpW(0) = (W_)&stg_ret_v_info;
goto do_return_nonpointer;
- case bci_RETURN_T: {
+ INSTRUCTION(bci_RETURN_T): {
/* tuple_info and tuple_bco must already be on the stack */
Sp_subW(1);
SpW(0) = (W_)&stg_ret_t_info;
goto do_return_nonpointer;
}
- case bci_BCO_NAME:
+ INSTRUCTION(bci_BCO_NAME):
bciPtr++;
- goto nextInsn;
+ NEXT_INSTRUCTION;
- case bci_SWIZZLE: {
+ INSTRUCTION(bci_SWIZZLE): {
W_ stkoff = BCO_GET_LARGE_ARG;
StgInt n = BCO_GET_LARGE_ARG;
(*(StgInt*)(SafeSpWP(stkoff))) += n;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_PRIMCALL: {
+ INSTRUCTION(bci_PRIMCALL): {
Sp_subW(1);
SpW(0) = (W_)&stg_primcall_info;
RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
@@ -2577,7 +2901,7 @@ run_BCO:
ty r = op ((ty) ReadSpW(0)); \
SpW(0) = (StgWord) r; \
} \
- goto nextInsn; \
+ NEXT_INSTRUCTION; \
}
// op :: ty -> ty -> ty
@@ -2592,7 +2916,7 @@ run_BCO:
Sp_addW(1); \
SpW(0) = (StgWord) r; \
}; \
- goto nextInsn; \
+ NEXT_INSTRUCTION; \
}
// op :: ty -> Int -> ty
@@ -2607,7 +2931,7 @@ run_BCO:
Sp_addW(1); \
SpW(0) = (StgWord) r; \
}; \
- goto nextInsn; \
+ NEXT_INSTRUCTION; \
}
// op :: ty -> ty -> Int
@@ -2622,113 +2946,113 @@ run_BCO:
Sp_addW(1); \
SpW(0) = (StgWord) r; \
}; \
- goto nextInsn; \
+ NEXT_INSTRUCTION; \
}
- case bci_OP_ADD_64: SIZED_BIN_OP(+, StgInt64)
- case bci_OP_SUB_64: SIZED_BIN_OP(-, StgInt64)
- case bci_OP_AND_64: SIZED_BIN_OP(&, StgInt64)
- case bci_OP_XOR_64: SIZED_BIN_OP(^, StgInt64)
- case bci_OP_OR_64: SIZED_BIN_OP(|, StgInt64)
- case bci_OP_MUL_64: SIZED_BIN_OP(*, StgInt64)
- case bci_OP_SHL_64: SIZED_BIN_OP_TY_INT(<<, StgWord64)
- case bci_OP_LSR_64: SIZED_BIN_OP_TY_INT(>>, StgWord64)
- case bci_OP_ASR_64: SIZED_BIN_OP_TY_INT(>>, StgInt64)
-
- case bci_OP_NEQ_64: SIZED_BIN_OP_TY_TY_INT(!=, StgWord64)
- case bci_OP_EQ_64: SIZED_BIN_OP_TY_TY_INT(==, StgWord64)
- case bci_OP_U_GT_64: SIZED_BIN_OP_TY_TY_INT(>, StgWord64)
- case bci_OP_U_GE_64: SIZED_BIN_OP_TY_TY_INT(>=, StgWord64)
- case bci_OP_U_LT_64: SIZED_BIN_OP_TY_TY_INT(<, StgWord64)
- case bci_OP_U_LE_64: SIZED_BIN_OP_TY_TY_INT(<=, StgWord64)
-
- case bci_OP_S_GT_64: SIZED_BIN_OP_TY_TY_INT(>, StgInt64)
- case bci_OP_S_GE_64: SIZED_BIN_OP_TY_TY_INT(>=, StgInt64)
- case bci_OP_S_LT_64: SIZED_BIN_OP_TY_TY_INT(<, StgInt64)
- case bci_OP_S_LE_64: SIZED_BIN_OP_TY_TY_INT(<=, StgInt64)
-
- case bci_OP_NOT_64: UN_SIZED_OP(~, StgWord64)
- case bci_OP_NEG_64: UN_SIZED_OP(-, StgInt64)
-
-
- case bci_OP_ADD_32: SIZED_BIN_OP(+, StgInt32)
- case bci_OP_SUB_32: SIZED_BIN_OP(-, StgInt32)
- case bci_OP_AND_32: SIZED_BIN_OP(&, StgInt32)
- case bci_OP_XOR_32: SIZED_BIN_OP(^, StgInt32)
- case bci_OP_OR_32: SIZED_BIN_OP(|, StgInt32)
- case bci_OP_MUL_32: SIZED_BIN_OP(*, StgInt32)
- case bci_OP_SHL_32: SIZED_BIN_OP_TY_INT(<<, StgWord32)
- case bci_OP_LSR_32: SIZED_BIN_OP_TY_INT(>>, StgWord32)
- case bci_OP_ASR_32: SIZED_BIN_OP_TY_INT(>>, StgInt32)
-
- case bci_OP_NEQ_32: SIZED_BIN_OP_TY_TY_INT(!=, StgWord32)
- case bci_OP_EQ_32: SIZED_BIN_OP_TY_TY_INT(==, StgWord32)
- case bci_OP_U_GT_32: SIZED_BIN_OP_TY_TY_INT(>, StgWord32)
- case bci_OP_U_GE_32: SIZED_BIN_OP_TY_TY_INT(>=, StgWord32)
- case bci_OP_U_LT_32: SIZED_BIN_OP_TY_TY_INT(<, StgWord32)
- case bci_OP_U_LE_32: SIZED_BIN_OP_TY_TY_INT(<=, StgWord32)
-
- case bci_OP_S_GT_32: SIZED_BIN_OP_TY_TY_INT(>, StgInt32)
- case bci_OP_S_GE_32: SIZED_BIN_OP_TY_TY_INT(>=, StgInt32)
- case bci_OP_S_LT_32: SIZED_BIN_OP_TY_TY_INT(<, StgInt32)
- case bci_OP_S_LE_32: SIZED_BIN_OP_TY_TY_INT(<=, StgInt32)
-
- case bci_OP_NOT_32: UN_SIZED_OP(~, StgWord32)
- case bci_OP_NEG_32: UN_SIZED_OP(-, StgInt32)
-
-
- case bci_OP_ADD_16: SIZED_BIN_OP(+, StgInt16)
- case bci_OP_SUB_16: SIZED_BIN_OP(-, StgInt16)
- case bci_OP_AND_16: SIZED_BIN_OP(&, StgInt16)
- case bci_OP_XOR_16: SIZED_BIN_OP(^, StgInt16)
- case bci_OP_OR_16: SIZED_BIN_OP(|, StgInt16)
- case bci_OP_MUL_16: SIZED_BIN_OP(*, StgInt16)
- case bci_OP_SHL_16: SIZED_BIN_OP_TY_INT(<<, StgWord16)
- case bci_OP_LSR_16: SIZED_BIN_OP_TY_INT(>>, StgWord16)
- case bci_OP_ASR_16: SIZED_BIN_OP_TY_INT(>>, StgInt16)
-
- case bci_OP_NEQ_16: SIZED_BIN_OP_TY_TY_INT(!=, StgWord16)
- case bci_OP_EQ_16: SIZED_BIN_OP_TY_TY_INT(==, StgWord16)
- case bci_OP_U_GT_16: SIZED_BIN_OP_TY_TY_INT(>, StgWord16)
- case bci_OP_U_GE_16: SIZED_BIN_OP_TY_TY_INT(>=, StgWord16)
- case bci_OP_U_LT_16: SIZED_BIN_OP_TY_TY_INT(<, StgWord16)
- case bci_OP_U_LE_16: SIZED_BIN_OP_TY_TY_INT(<=, StgWord16)
-
- case bci_OP_S_GT_16: SIZED_BIN_OP(>, StgInt16)
- case bci_OP_S_GE_16: SIZED_BIN_OP(>=, StgInt16)
- case bci_OP_S_LT_16: SIZED_BIN_OP(<, StgInt16)
- case bci_OP_S_LE_16: SIZED_BIN_OP(<=, StgInt16)
-
- case bci_OP_NOT_16: UN_SIZED_OP(~, StgWord16)
- case bci_OP_NEG_16: UN_SIZED_OP(-, StgInt16)
-
-
- case bci_OP_ADD_08: SIZED_BIN_OP(+, StgInt8)
- case bci_OP_SUB_08: SIZED_BIN_OP(-, StgInt8)
- case bci_OP_AND_08: SIZED_BIN_OP(&, StgInt8)
- case bci_OP_XOR_08: SIZED_BIN_OP(^, StgInt8)
- case bci_OP_OR_08: SIZED_BIN_OP(|, StgInt8)
- case bci_OP_MUL_08: SIZED_BIN_OP(*, StgInt8)
- case bci_OP_SHL_08: SIZED_BIN_OP_TY_INT(<<, StgWord8)
- case bci_OP_LSR_08: SIZED_BIN_OP_TY_INT(>>, StgWord8)
- case bci_OP_ASR_08: SIZED_BIN_OP_TY_INT(>>, StgInt8)
-
- case bci_OP_NEQ_08: SIZED_BIN_OP_TY_TY_INT(!=, StgWord8)
- case bci_OP_EQ_08: SIZED_BIN_OP_TY_TY_INT(==, StgWord8)
- case bci_OP_U_GT_08: SIZED_BIN_OP_TY_TY_INT(>, StgWord8)
- case bci_OP_U_GE_08: SIZED_BIN_OP_TY_TY_INT(>=, StgWord8)
- case bci_OP_U_LT_08: SIZED_BIN_OP_TY_TY_INT(<, StgWord8)
- case bci_OP_U_LE_08: SIZED_BIN_OP_TY_TY_INT(<=, StgWord8)
-
- case bci_OP_S_GT_08: SIZED_BIN_OP_TY_TY_INT(>, StgInt8)
- case bci_OP_S_GE_08: SIZED_BIN_OP_TY_TY_INT(>=, StgInt8)
- case bci_OP_S_LT_08: SIZED_BIN_OP_TY_TY_INT(<, StgInt8)
- case bci_OP_S_LE_08: SIZED_BIN_OP_TY_TY_INT(<=, StgInt8)
-
- case bci_OP_NOT_08: UN_SIZED_OP(~, StgWord8)
- case bci_OP_NEG_08: UN_SIZED_OP(-, StgInt8)
-
- case bci_OP_INDEX_ADDR_64:
+ INSTRUCTION(bci_OP_ADD_64): SIZED_BIN_OP(+, StgInt64)
+ INSTRUCTION(bci_OP_SUB_64): SIZED_BIN_OP(-, StgInt64)
+ INSTRUCTION(bci_OP_AND_64): SIZED_BIN_OP(&, StgInt64)
+ INSTRUCTION(bci_OP_XOR_64): SIZED_BIN_OP(^, StgInt64)
+ INSTRUCTION(bci_OP_OR_64): SIZED_BIN_OP(|, StgInt64)
+ INSTRUCTION(bci_OP_MUL_64): SIZED_BIN_OP(*, StgInt64)
+ INSTRUCTION(bci_OP_SHL_64): SIZED_BIN_OP_TY_INT(<<, StgWord64)
+ INSTRUCTION(bci_OP_LSR_64): SIZED_BIN_OP_TY_INT(>>, StgWord64)
+ INSTRUCTION(bci_OP_ASR_64): SIZED_BIN_OP_TY_INT(>>, StgInt64)
+
+ INSTRUCTION(bci_OP_NEQ_64): SIZED_BIN_OP_TY_TY_INT(!=, StgWord64)
+ INSTRUCTION(bci_OP_EQ_64): SIZED_BIN_OP_TY_TY_INT(==, StgWord64)
+ INSTRUCTION(bci_OP_U_GT_64): SIZED_BIN_OP_TY_TY_INT(>, StgWord64)
+ INSTRUCTION(bci_OP_U_GE_64): SIZED_BIN_OP_TY_TY_INT(>=, StgWord64)
+ INSTRUCTION(bci_OP_U_LT_64): SIZED_BIN_OP_TY_TY_INT(<, StgWord64)
+ INSTRUCTION(bci_OP_U_LE_64): SIZED_BIN_OP_TY_TY_INT(<=, StgWord64)
+
+ INSTRUCTION(bci_OP_S_GT_64): SIZED_BIN_OP_TY_TY_INT(>, StgInt64)
+ INSTRUCTION(bci_OP_S_GE_64): SIZED_BIN_OP_TY_TY_INT(>=, StgInt64)
+ INSTRUCTION(bci_OP_S_LT_64): SIZED_BIN_OP_TY_TY_INT(<, StgInt64)
+ INSTRUCTION(bci_OP_S_LE_64): SIZED_BIN_OP_TY_TY_INT(<=, StgInt64)
+
+ INSTRUCTION(bci_OP_NOT_64): UN_SIZED_OP(~, StgWord64)
+ INSTRUCTION(bci_OP_NEG_64): UN_SIZED_OP(-, StgInt64)
+
+
+ INSTRUCTION(bci_OP_ADD_32): SIZED_BIN_OP(+, StgInt32)
+ INSTRUCTION(bci_OP_SUB_32): SIZED_BIN_OP(-, StgInt32)
+ INSTRUCTION(bci_OP_AND_32): SIZED_BIN_OP(&, StgInt32)
+ INSTRUCTION(bci_OP_XOR_32): SIZED_BIN_OP(^, StgInt32)
+ INSTRUCTION(bci_OP_OR_32): SIZED_BIN_OP(|, StgInt32)
+ INSTRUCTION(bci_OP_MUL_32): SIZED_BIN_OP(*, StgInt32)
+ INSTRUCTION(bci_OP_SHL_32): SIZED_BIN_OP_TY_INT(<<, StgWord32)
+ INSTRUCTION(bci_OP_LSR_32): SIZED_BIN_OP_TY_INT(>>, StgWord32)
+ INSTRUCTION(bci_OP_ASR_32): SIZED_BIN_OP_TY_INT(>>, StgInt32)
+
+ INSTRUCTION(bci_OP_NEQ_32): SIZED_BIN_OP_TY_TY_INT(!=, StgWord32)
+ INSTRUCTION(bci_OP_EQ_32): SIZED_BIN_OP_TY_TY_INT(==, StgWord32)
+ INSTRUCTION(bci_OP_U_GT_32): SIZED_BIN_OP_TY_TY_INT(>, StgWord32)
+ INSTRUCTION(bci_OP_U_GE_32): SIZED_BIN_OP_TY_TY_INT(>=, StgWord32)
+ INSTRUCTION(bci_OP_U_LT_32): SIZED_BIN_OP_TY_TY_INT(<, StgWord32)
+ INSTRUCTION(bci_OP_U_LE_32): SIZED_BIN_OP_TY_TY_INT(<=, StgWord32)
+
+ INSTRUCTION(bci_OP_S_GT_32): SIZED_BIN_OP_TY_TY_INT(>, StgInt32)
+ INSTRUCTION(bci_OP_S_GE_32): SIZED_BIN_OP_TY_TY_INT(>=, StgInt32)
+ INSTRUCTION(bci_OP_S_LT_32): SIZED_BIN_OP_TY_TY_INT(<, StgInt32)
+ INSTRUCTION(bci_OP_S_LE_32): SIZED_BIN_OP_TY_TY_INT(<=, StgInt32)
+
+ INSTRUCTION(bci_OP_NOT_32): UN_SIZED_OP(~, StgWord32)
+ INSTRUCTION(bci_OP_NEG_32): UN_SIZED_OP(-, StgInt32)
+
+
+ INSTRUCTION(bci_OP_ADD_16): SIZED_BIN_OP(+, StgInt16)
+ INSTRUCTION(bci_OP_SUB_16): SIZED_BIN_OP(-, StgInt16)
+ INSTRUCTION(bci_OP_AND_16): SIZED_BIN_OP(&, StgInt16)
+ INSTRUCTION(bci_OP_XOR_16): SIZED_BIN_OP(^, StgInt16)
+ INSTRUCTION(bci_OP_OR_16): SIZED_BIN_OP(|, StgInt16)
+ INSTRUCTION(bci_OP_MUL_16): SIZED_BIN_OP(*, StgInt16)
+ INSTRUCTION(bci_OP_SHL_16): SIZED_BIN_OP_TY_INT(<<, StgWord16)
+ INSTRUCTION(bci_OP_LSR_16): SIZED_BIN_OP_TY_INT(>>, StgWord16)
+ INSTRUCTION(bci_OP_ASR_16): SIZED_BIN_OP_TY_INT(>>, StgInt16)
+
+ INSTRUCTION(bci_OP_NEQ_16): SIZED_BIN_OP_TY_TY_INT(!=, StgWord16)
+ INSTRUCTION(bci_OP_EQ_16): SIZED_BIN_OP_TY_TY_INT(==, StgWord16)
+ INSTRUCTION(bci_OP_U_GT_16): SIZED_BIN_OP_TY_TY_INT(>, StgWord16)
+ INSTRUCTION(bci_OP_U_GE_16): SIZED_BIN_OP_TY_TY_INT(>=, StgWord16)
+ INSTRUCTION(bci_OP_U_LT_16): SIZED_BIN_OP_TY_TY_INT(<, StgWord16)
+ INSTRUCTION(bci_OP_U_LE_16): SIZED_BIN_OP_TY_TY_INT(<=, StgWord16)
+
+ INSTRUCTION(bci_OP_S_GT_16): SIZED_BIN_OP(>, StgInt16)
+ INSTRUCTION(bci_OP_S_GE_16): SIZED_BIN_OP(>=, StgInt16)
+ INSTRUCTION(bci_OP_S_LT_16): SIZED_BIN_OP(<, StgInt16)
+ INSTRUCTION(bci_OP_S_LE_16): SIZED_BIN_OP(<=, StgInt16)
+
+ INSTRUCTION(bci_OP_NOT_16): UN_SIZED_OP(~, StgWord16)
+ INSTRUCTION(bci_OP_NEG_16): UN_SIZED_OP(-, StgInt16)
+
+
+ INSTRUCTION(bci_OP_ADD_08): SIZED_BIN_OP(+, StgInt8)
+ INSTRUCTION(bci_OP_SUB_08): SIZED_BIN_OP(-, StgInt8)
+ INSTRUCTION(bci_OP_AND_08): SIZED_BIN_OP(&, StgInt8)
+ INSTRUCTION(bci_OP_XOR_08): SIZED_BIN_OP(^, StgInt8)
+ INSTRUCTION(bci_OP_OR_08): SIZED_BIN_OP(|, StgInt8)
+ INSTRUCTION(bci_OP_MUL_08): SIZED_BIN_OP(*, StgInt8)
+ INSTRUCTION(bci_OP_SHL_08): SIZED_BIN_OP_TY_INT(<<, StgWord8)
+ INSTRUCTION(bci_OP_LSR_08): SIZED_BIN_OP_TY_INT(>>, StgWord8)
+ INSTRUCTION(bci_OP_ASR_08): SIZED_BIN_OP_TY_INT(>>, StgInt8)
+
+ INSTRUCTION(bci_OP_NEQ_08): SIZED_BIN_OP_TY_TY_INT(!=, StgWord8)
+ INSTRUCTION(bci_OP_EQ_08): SIZED_BIN_OP_TY_TY_INT(==, StgWord8)
+ INSTRUCTION(bci_OP_U_GT_08): SIZED_BIN_OP_TY_TY_INT(>, StgWord8)
+ INSTRUCTION(bci_OP_U_GE_08): SIZED_BIN_OP_TY_TY_INT(>=, StgWord8)
+ INSTRUCTION(bci_OP_U_LT_08): SIZED_BIN_OP_TY_TY_INT(<, StgWord8)
+ INSTRUCTION(bci_OP_U_LE_08): SIZED_BIN_OP_TY_TY_INT(<=, StgWord8)
+
+ INSTRUCTION(bci_OP_S_GT_08): SIZED_BIN_OP_TY_TY_INT(>, StgInt8)
+ INSTRUCTION(bci_OP_S_GE_08): SIZED_BIN_OP_TY_TY_INT(>=, StgInt8)
+ INSTRUCTION(bci_OP_S_LT_08): SIZED_BIN_OP_TY_TY_INT(<, StgInt8)
+ INSTRUCTION(bci_OP_S_LE_08): SIZED_BIN_OP_TY_TY_INT(<=, StgInt8)
+
+ INSTRUCTION(bci_OP_NOT_08): UN_SIZED_OP(~, StgWord8)
+ INSTRUCTION(bci_OP_NEG_08): UN_SIZED_OP(-, StgInt8)
+
+ INSTRUCTION(bci_OP_INDEX_ADDR_64):
{
StgWord64* addr = (StgWord64*) SpW(0);
StgInt offset = (StgInt) SpW(1);
@@ -2736,35 +3060,35 @@ run_BCO:
Sp_addW(1);
}
SpW64(0) = *(addr+offset);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_OP_INDEX_ADDR_32:
+ INSTRUCTION(bci_OP_INDEX_ADDR_32):
{
StgWord32* addr = (StgWord32*) SpW(0);
StgInt offset = (StgInt) SpW(1);
Sp_addW(1);
SpW(0) = (StgWord) *(addr+offset);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_OP_INDEX_ADDR_16:
+ INSTRUCTION(bci_OP_INDEX_ADDR_16):
{
StgWord16* addr = (StgWord16*) SpW(0);
StgInt offset = (StgInt) SpW(1);
Sp_addW(1);
SpW(0) = (StgWord) *(addr+offset);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_OP_INDEX_ADDR_08:
+ INSTRUCTION(bci_OP_INDEX_ADDR_08):
{
StgWord8* addr = (StgWord8*) SpW(0);
StgInt offset = (StgInt) SpW(1);
Sp_addW(1);
SpW(0) = (StgWord) *(addr+offset);
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_CCALL: {
+ INSTRUCTION(bci_CCALL): {
void *tok;
W_ stk_offset = BCO_GET_LARGE_ARG;
int o_itbl = BCO_GET_LARGE_ARG;
@@ -2921,25 +3245,33 @@ run_BCO:
memcpy(Sp, ret, sizeof(W_) * ret_size);
#endif
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_JMP: {
+ INSTRUCTION(bci_JMP): {
/* BCO_NEXT modifies bciPtr, so be conservative. */
int nextpc = BCO_GET_LARGE_ARG;
bciPtr = nextpc;
- goto nextInsn;
+ NEXT_INSTRUCTION;
}
- case bci_CASEFAIL:
+ INSTRUCTION(bci_CASEFAIL):
barf("interpretBCO: hit a CASEFAIL");
- // Errors
+
+
+#if defined(COMPUTED_GOTO)
+ INSTRUCTION(bci_DEFAULT):
+ barf("interpretBCO: unknown or unimplemented opcode %d",
+ (int)(bci & 0xFF));
+#else
+ // Errors
default:
barf("interpretBCO: unknown or unimplemented opcode %d",
(int)(bci & 0xFF));
-
} /* switch on opcode */
+#endif
+
}
}
=====================================
rts/include/rts/Bytecodes.h
=====================================
@@ -23,6 +23,11 @@
I hope that's clear :-)
*/
+/*
+ Make sure to update jumptable in rts/Interpreter.c when modifying
+ bytecodes! See Note [Instruction dispatch in the bytecode interpreter]
+ for details.
+*/
#define bci_STKCHECK 1
#define bci_PUSH_L 2
#define bci_PUSH_LL 3
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/39567e85fa514c0c4dfeaf8faa586a4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/39567e85fa514c0c4dfeaf8faa586a4…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
06 Nov '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
3034a6f2 by Ben Gamari at 2025-11-06T09:04:24-05:00
Bump os-string submodule to 2.0.8
- - - - -
1 changed file:
- libraries/os-string
Changes:
=====================================
libraries/os-string
=====================================
@@ -1 +1 @@
-Subproject commit 2e693aad07540173a0169971b27c9acac28eeff1
+Subproject commit c08666bf7bf528e607fc1eacc20032ec59e69df3
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3034a6f2c461a5f5b218cba93eb4294…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3034a6f2c461a5f5b218cba93eb4294…
You're receiving this email because of your account on gitlab.haskell.org.
1
0