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
-
74b8397a
by Brandon Chinn at 2025-11-06T09:02:19-05:00
-
36ddf988
by Ben Gamari at 2025-11-06T09:03:01-05:00
-
c32b3a29
by fendor at 2025-11-06T09:03:43-05:00
-
3034a6f2
by Ben Gamari at 2025-11-06T09:04:24-05:00
-
39567e85
by Cheng Shao at 2025-11-06T09:05:06-05:00
-
1c01258b
by sheaf at 2025-11-06T15:12:54-05:00
-
c9d258d3
by Simon Peyton Jones at 2025-11-06T15:12:55-05:00
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:
| ... | ... | @@ -474,6 +474,10 @@ warnUnusedPackages us dflags mod_graph = |
| 474 | 474 | ui <- lookupUnit us u
|
| 475 | 475 | -- Which are not explicitly used
|
| 476 | 476 | guard (Set.notMember (unitId ui) used_args)
|
| 477 | + -- Exclude units with no exposed modules. This covers packages which only
|
|
| 478 | + -- provide C object code or link flags (e.g. system-cxx-std-lib).
|
|
| 479 | + -- See #24120.
|
|
| 480 | + guard (not $ null $ unitExposedModules ui)
|
|
| 477 | 481 | return (unitId ui, unitPackageName ui, unitPackageVersion ui, flag)
|
| 478 | 482 | |
| 479 | 483 | unusedArgs = sortOn (\(u,_,_,_) -> u) $ mapMaybe resolve (explicitUnits us)
|
| ... | ... | @@ -957,7 +957,7 @@ tcSynArgE :: CtOrigin |
| 957 | 957 | -> SyntaxOpType -- ^ shape it is expected to have
|
| 958 | 958 | -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments
|
| 959 | 959 | -> TcM (a, HsWrapper)
|
| 960 | - -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
|
|
| 960 | + -- ^ returns a wrapper :: (type of right shape) ~~> (type passed in)
|
|
| 961 | 961 | tcSynArgE orig op sigma_ty syn_ty thing_inside
|
| 962 | 962 | = do { (skol_wrap, (result, ty_wrapper))
|
| 963 | 963 | <- tcSkolemise Shallow GenSigCtxt sigma_ty $ \rho_ty ->
|
| ... | ... | @@ -978,10 +978,10 @@ tcSynArgE orig op sigma_ty syn_ty thing_inside |
| 978 | 978 | ; return (result, mkWpCastN list_co) }
|
| 979 | 979 | |
| 980 | 980 | go rho_ty (SynFun arg_shape res_shape)
|
| 981 | - = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty
|
|
| 981 | + = do { ( match_wrapper -- :: (arg_ty -> res_ty) ~~> rho_ty
|
|
| 982 | 982 | , ( ( (result, arg_ty, res_ty, op_mult)
|
| 983 | - , res_wrapper ) -- :: res_ty_out "->" res_ty
|
|
| 984 | - , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out
|
|
| 983 | + , res_wrapper ) -- :: res_ty_out ~~> res_ty
|
|
| 984 | + , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty ~~> arg_ty_out
|
|
| 985 | 985 | <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $
|
| 986 | 986 | \ [ExpFunPatTy arg_ty] res_ty ->
|
| 987 | 987 | do { arg_tc_ty <- expTypeToType (scaledThing arg_ty)
|
| ... | ... | @@ -1031,7 +1031,7 @@ tcSynArgA :: CtOrigin |
| 1031 | 1031 | tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside
|
| 1032 | 1032 | = do { (match_wrapper, arg_tys, res_ty)
|
| 1033 | 1033 | <- matchActualFunTys herald orig (length arg_shapes) sigma_ty
|
| 1034 | - -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
|
|
| 1034 | + -- match_wrapper :: sigma_ty ~~> (arg_tys -> res_ty)
|
|
| 1035 | 1035 | ; ((result, res_wrapper), arg_wrappers)
|
| 1036 | 1036 | <- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults ->
|
| 1037 | 1037 | tc_syn_arg res_ty res_shape $ \ res_results ->
|
| ... | ... | @@ -1061,12 +1061,12 @@ tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside |
| 1061 | 1061 | ; return (result, idHsWrapper) }
|
| 1062 | 1062 | tc_syn_arg res_ty SynRho thing_inside
|
| 1063 | 1063 | = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
|
| 1064 | - -- inst_wrap :: res_ty "->" rho_ty
|
|
| 1064 | + -- inst_wrap :: res_ty ~~> rho_ty
|
|
| 1065 | 1065 | ; result <- thing_inside [rho_ty]
|
| 1066 | 1066 | ; return (result, inst_wrap) }
|
| 1067 | 1067 | tc_syn_arg res_ty SynList thing_inside
|
| 1068 | 1068 | = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
|
| 1069 | - -- inst_wrap :: res_ty "->" rho_ty
|
|
| 1069 | + -- inst_wrap :: res_ty ~~> rho_ty
|
|
| 1070 | 1070 | ; (list_co, elt_ty) <- matchExpectedListTy rho_ty
|
| 1071 | 1071 | -- list_co :: [elt_ty] ~N rho_ty
|
| 1072 | 1072 | ; result <- thing_inside [elt_ty]
|
| ... | ... | @@ -329,7 +329,7 @@ tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl |
| 329 | 329 | -- Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind
|
| 330 | 330 | |
| 331 | 331 | | Just bndr_id <- sig_fn bndr_name -- There is a signature
|
| 332 | - = do { wrap <- tc_sub_type penv (scaledThing exp_pat_ty) (idType bndr_id)
|
|
| 332 | + = do { wrap <- tcSubTypePat_GenSigCtxt penv (scaledThing exp_pat_ty) (idType bndr_id)
|
|
| 333 | 333 | -- See Note [Subsumption check at pattern variables]
|
| 334 | 334 | ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty)
|
| 335 | 335 | ; return (wrap, bndr_id) }
|
| ... | ... | @@ -376,10 +376,12 @@ newLetBndr LetLclBndr name w ty |
| 376 | 376 | newLetBndr (LetGblBndr prags) name w ty
|
| 377 | 377 | = addInlinePrags (mkLocalId name w ty) (lookupPragEnv prags name)
|
| 378 | 378 | |
| 379 | -tc_sub_type :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
|
|
| 380 | --- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt
|
|
| 381 | --- Used during typechecking patterns
|
|
| 382 | -tc_sub_type penv t1 t2 = tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2
|
|
| 379 | +-- | A version of 'tcSubTypePat' specialised to 'GenSigCtxt'.
|
|
| 380 | +--
|
|
| 381 | +-- Used during typechecking of patterns.
|
|
| 382 | +tcSubTypePat_GenSigCtxt :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
|
|
| 383 | +tcSubTypePat_GenSigCtxt penv t1 t2 =
|
|
| 384 | + tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2
|
|
| 383 | 385 | |
| 384 | 386 | {- Note [Subsumption check at pattern variables]
|
| 385 | 387 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
| ... | ... | @@ -618,111 +620,123 @@ tc_pat :: Scaled ExpSigmaTypeFRR |
| 618 | 620 | -> Checker (Pat GhcRn) (Pat GhcTc)
|
| 619 | 621 | -- ^ Translated pattern
|
| 620 | 622 | |
| 621 | -tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
|
|
| 622 | - |
|
| 623 | - VarPat x (L l name) -> do
|
|
| 624 | - { (wrap, id) <- tcPatBndr penv name pat_ty
|
|
| 625 | - ; res <- tcCheckUsage name (scaledMult pat_ty) $
|
|
| 626 | - tcExtendIdEnv1 name id thing_inside
|
|
| 627 | - ; pat_ty <- readExpType (scaledThing pat_ty)
|
|
| 628 | - ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
|
|
| 629 | - |
|
| 630 | - ParPat x pat -> do
|
|
| 631 | - { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
|
|
| 632 | - ; return (ParPat x pat', res) }
|
|
| 633 | - |
|
| 634 | - BangPat x pat -> do
|
|
| 635 | - { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
|
|
| 636 | - ; return (BangPat x pat', res) }
|
|
| 637 | - |
|
| 638 | - OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1)
|
|
| 639 | - { let pats_list = NE.toList pats
|
|
| 640 | - ; (pats_list', (res, pat_ct)) <- tc_lpats (map (const pat_ty) pats_list) penv pats_list (captureConstraints thing_inside)
|
|
| 641 | - ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness
|
|
| 642 | - ; emitConstraints pat_ct
|
|
| 643 | - -- captureConstraints/extendConstraints:
|
|
| 644 | - -- like in Note [Hopping the LIE in lazy patterns]
|
|
| 645 | - ; pat_ty <- expTypeToType (scaledThing pat_ty)
|
|
| 646 | - ; return (OrPat pat_ty pats', res) }
|
|
| 647 | - |
|
| 648 | - LazyPat x pat -> do
|
|
| 649 | - { checkManyPattern LazyPatternReason (noLocA ps_pat) pat_ty
|
|
| 650 | - ; (pat', (res, pat_ct))
|
|
| 651 | - <- tc_lpat pat_ty (makeLazy penv) pat $
|
|
| 652 | - captureConstraints thing_inside
|
|
| 653 | - -- Ignore refined penv', revert to penv
|
|
| 654 | - |
|
| 655 | - ; emitConstraints pat_ct
|
|
| 656 | - -- captureConstraints/extendConstraints:
|
|
| 657 | - -- see Note [Hopping the LIE in lazy patterns]
|
|
| 658 | - |
|
| 659 | - -- Check that the expected pattern type is itself lifted
|
|
| 660 | - ; pat_ty <- readExpType (scaledThing pat_ty)
|
|
| 661 | - ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind
|
|
| 662 | - |
|
| 663 | - ; return ((LazyPat x pat'), res) }
|
|
| 664 | - |
|
| 665 | - WildPat _ -> do
|
|
| 666 | - { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
|
|
| 667 | - ; res <- thing_inside
|
|
| 668 | - ; pat_ty <- expTypeToType (scaledThing pat_ty)
|
|
| 669 | - ; return (WildPat pat_ty, res) }
|
|
| 670 | - |
|
| 671 | - AsPat x (L nm_loc name) pat -> do
|
|
| 672 | - { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
|
|
| 673 | - ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty)
|
|
| 674 | - ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
|
|
| 675 | - tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id))
|
|
| 676 | - penv pat thing_inside
|
|
| 677 | - -- NB: if we do inference on:
|
|
| 678 | - -- \ (y@(x::forall a. a->a)) = e
|
|
| 679 | - -- we'll fail. The as-pattern infers a monotype for 'y', which then
|
|
| 680 | - -- fails to unify with the polymorphic type for 'x'. This could
|
|
| 681 | - -- perhaps be fixed, but only with a bit more work.
|
|
| 682 | - --
|
|
| 683 | - -- If you fix it, don't forget the bindInstsOfPatIds!
|
|
| 684 | - ; pat_ty <- readExpType (scaledThing pat_ty)
|
|
| 685 | - ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) }
|
|
| 686 | - |
|
| 687 | - ViewPat _ expr pat -> do
|
|
| 688 | - { checkManyPattern ViewPatternReason (noLocA ps_pat) pat_ty
|
|
| 689 | - --
|
|
| 690 | - -- It should be possible to have view patterns at linear (or otherwise
|
|
| 691 | - -- non-Many) multiplicity. But it is not clear at the moment what
|
|
| 692 | - -- restriction need to be put in place, if any, for linear view
|
|
| 693 | - -- patterns to desugar to type-correct Core.
|
|
| 694 | - |
|
| 695 | - ; (expr', expr_rho) <- tcInferExpr IIF_ShallowRho expr
|
|
| 696 | - -- IIF_ShallowRho: do not perform deep instantiation, regardless of
|
|
| 697 | - -- DeepSubsumption (Note [View patterns and polymorphism])
|
|
| 698 | - -- But we must do top-instantiation to expose the arrow to matchActualFunTy
|
|
| 699 | - |
|
| 700 | - -- Expression must be a function
|
|
| 701 | - ; let herald = ExpectedFunTyViewPat $ unLoc expr
|
|
| 702 | - ; (expr_co1, Scaled _mult inf_arg_ty, inf_res_sigma)
|
|
| 703 | - <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_rho) expr_rho
|
|
| 704 | - -- See Note [View patterns and polymorphism]
|
|
| 705 | - -- expr_wrap1 :: expr_rho "->" (inf_arg_ty -> inf_res_sigma)
|
|
| 706 | - |
|
| 707 | - -- Check that overall pattern is more polymorphic than arg type
|
|
| 708 | - ; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty
|
|
| 709 | - -- expr_wrap2 :: pat_ty "->" inf_arg_ty
|
|
| 710 | - |
|
| 711 | - -- Pattern must have inf_res_sigma
|
|
| 712 | - ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType inf_res_sigma) penv pat thing_inside
|
|
| 713 | - |
|
| 714 | - ; let Scaled w h_pat_ty = pat_ty
|
|
| 715 | - ; pat_ty <- readExpType h_pat_ty
|
|
| 716 | - ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper
|
|
| 717 | - (Scaled w pat_ty) inf_res_sigma
|
|
| 718 | - -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"
|
|
| 719 | - -- (pat_ty -> inf_res_sigma)
|
|
| 720 | - -- NB: pat_ty comes from matchActualFunTy, so it has a
|
|
| 721 | - -- fixed RuntimeRep, as needed to call mkWpFun.
|
|
| 722 | - |
|
| 723 | - expr_wrap = expr_wrap2' <.> mkWpCastN expr_co1
|
|
| 724 | - |
|
| 725 | - ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) }
|
|
| 623 | +tc_pat scaled_exp_pat_ty@(Scaled w_pat exp_pat_ty) penv ps_pat thing_inside =
|
|
| 624 | + |
|
| 625 | + case ps_pat of
|
|
| 626 | + |
|
| 627 | + VarPat x (L l name) -> do
|
|
| 628 | + { (wrap, id) <- tcPatBndr penv name scaled_exp_pat_ty
|
|
| 629 | + ; res <- tcCheckUsage name w_pat $ tcExtendIdEnv1 name id thing_inside
|
|
| 630 | + ; pat_ty <- readExpType exp_pat_ty
|
|
| 631 | + ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
|
|
| 632 | + |
|
| 633 | + ParPat x pat -> do
|
|
| 634 | + { (pat', res) <- tc_lpat scaled_exp_pat_ty penv pat thing_inside
|
|
| 635 | + ; return (ParPat x pat', res) }
|
|
| 636 | + |
|
| 637 | + BangPat x pat -> do
|
|
| 638 | + { (pat', res) <- tc_lpat scaled_exp_pat_ty penv pat thing_inside
|
|
| 639 | + ; return (BangPat x pat', res) }
|
|
| 640 | + |
|
| 641 | + OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1)
|
|
| 642 | + { let pats_list = NE.toList pats
|
|
| 643 | + pat_exp_tys = map (const scaled_exp_pat_ty) pats_list
|
|
| 644 | + ; (pats_list', (res, pat_ct)) <- tc_lpats pat_exp_tys penv pats_list (captureConstraints thing_inside)
|
|
| 645 | + ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness
|
|
| 646 | + ; emitConstraints pat_ct
|
|
| 647 | + -- captureConstraints/extendConstraints:
|
|
| 648 | + -- like in Note [Hopping the LIE in lazy patterns]
|
|
| 649 | + ; pat_ty <- expTypeToType exp_pat_ty
|
|
| 650 | + ; return (OrPat pat_ty pats', res) }
|
|
| 651 | + |
|
| 652 | + LazyPat x pat -> do
|
|
| 653 | + { checkManyPattern LazyPatternReason (noLocA ps_pat) scaled_exp_pat_ty
|
|
| 654 | + ; (pat', (res, pat_ct))
|
|
| 655 | + <- tc_lpat scaled_exp_pat_ty (makeLazy penv) pat $
|
|
| 656 | + captureConstraints thing_inside
|
|
| 657 | + -- Ignore refined penv', revert to penv
|
|
| 658 | + |
|
| 659 | + ; emitConstraints pat_ct
|
|
| 660 | + -- captureConstraints/extendConstraints:
|
|
| 661 | + -- see Note [Hopping the LIE in lazy patterns]
|
|
| 662 | + |
|
| 663 | + -- Check that the expected pattern type is itself lifted
|
|
| 664 | + ; pat_ty <- readExpType exp_pat_ty
|
|
| 665 | + ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind
|
|
| 666 | + |
|
| 667 | + ; return ((LazyPat x pat'), res) }
|
|
| 668 | + |
|
| 669 | + WildPat _ -> do
|
|
| 670 | + { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
|
|
| 671 | + ; res <- thing_inside
|
|
| 672 | + ; pat_ty <- expTypeToType exp_pat_ty
|
|
| 673 | + ; return (WildPat pat_ty, res) }
|
|
| 674 | + |
|
| 675 | + AsPat x (L nm_loc name) pat -> do
|
|
| 676 | + { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
|
|
| 677 | + ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name scaled_exp_pat_ty)
|
|
| 678 | + ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
|
|
| 679 | + tc_lpat (Scaled w_pat (mkCheckExpType $ idType bndr_id))
|
|
| 680 | + penv pat thing_inside
|
|
| 681 | + -- NB: if we do inference on:
|
|
| 682 | + -- \ (y@(x::forall a. a->a)) = e
|
|
| 683 | + -- we'll fail. The as-pattern infers a monotype for 'y', which then
|
|
| 684 | + -- fails to unify with the polymorphic type for 'x'. This could
|
|
| 685 | + -- perhaps be fixed, but only with a bit more work.
|
|
| 686 | + --
|
|
| 687 | + -- If you fix it, don't forget the bindInstsOfPatIds!
|
|
| 688 | + ; pat_ty <- readExpType exp_pat_ty
|
|
| 689 | + ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) }
|
|
| 690 | + |
|
| 691 | + ViewPat _ view_expr inner_pat -> do
|
|
| 692 | + |
|
| 693 | + -- The pattern is a view pattern, 'pat = (view_expr -> inner_pat)'.
|
|
| 694 | + -- First infer the type of 'view_expr'; the overall type of the pattern
|
|
| 695 | + -- is the argument type of 'view_expr', and the inner pattern type is
|
|
| 696 | + -- checked against the result type of 'view_expr'.
|
|
| 697 | + |
|
| 698 | + { checkManyPattern ViewPatternReason (noLocA ps_pat) scaled_exp_pat_ty
|
|
| 699 | + -- It should be possible to have view patterns at linear (or otherwise
|
|
| 700 | + -- non-Many) multiplicity. But it is not clear at the moment what
|
|
| 701 | + -- restrictions need to be put in place, if any, for linear view
|
|
| 702 | + -- patterns to desugar to type-correct Core.
|
|
| 703 | + |
|
| 704 | + -- Infer the type of 'view_expr'.
|
|
| 705 | + ; (view_expr', view_expr_rho) <- tcInferExpr IIF_ShallowRho view_expr
|
|
| 706 | + -- IIF_ShallowRho: do not perform deep instantiation, regardless of
|
|
| 707 | + -- DeepSubsumption (Note [View patterns and polymorphism])
|
|
| 708 | + -- But we must do top-instantiation to expose the arrow to matchActualFunTy
|
|
| 709 | + |
|
| 710 | + -- 'view_expr' must be a function; expose its argument/result types
|
|
| 711 | + -- using 'matchActualFunTy'.
|
|
| 712 | + ; let herald = ExpectedFunTyViewPat $ unLoc view_expr
|
|
| 713 | + ; (view_expr_co1, Scaled _mult view_arg_ty, view_res_ty)
|
|
| 714 | + <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc view_expr)
|
|
| 715 | + (1, view_expr_rho) view_expr_rho
|
|
| 716 | + -- See Note [View patterns and polymorphism]
|
|
| 717 | + -- view_expr_co1 :: view_expr_rho ~~> (view_arg_ty -> view_res_ty)
|
|
| 718 | + |
|
| 719 | + -- Check that the overall pattern's type is more polymorphic than
|
|
| 720 | + -- the view function argument type.
|
|
| 721 | + ; view_expr_wrap2 <- tcSubTypePat_GenSigCtxt penv exp_pat_ty view_arg_ty
|
|
| 722 | + -- view_expr_wrap2 :: pat_ty ~~> view_arg_ty
|
|
| 723 | + |
|
| 724 | + -- The inner pattern must have type 'view_res_ty'.
|
|
| 725 | + ; (inner_pat', res) <- tc_lpat (Scaled w_pat (mkCheckExpType view_res_ty)) penv inner_pat thing_inside
|
|
| 726 | + |
|
| 727 | + ; pat_ty <- readExpType exp_pat_ty
|
|
| 728 | + ; let view_expr_wrap2' =
|
|
| 729 | + mkWpFun view_expr_wrap2 idHsWrapper
|
|
| 730 | + (Scaled w_pat pat_ty) view_res_ty
|
|
| 731 | + -- view_expr_wrap2' :: (view_arg_ty -> view_res_ty)
|
|
| 732 | + -- ~~> (pat_ty -> view_res_ty)
|
|
| 733 | + -- This satisfies WpFun-FRR-INVARIANT:
|
|
| 734 | + -- 'view_arg_ty' was returned by matchActualFunTy, hence FRR
|
|
| 735 | + -- 'pat_ty' was passed in and is an 'ExpSigmaTypeFRR'
|
|
| 736 | + |
|
| 737 | + view_expr_wrap = view_expr_wrap2' <.> mkWpCastN view_expr_co1
|
|
| 738 | + |
|
| 739 | + ; return $ (ViewPat pat_ty (mkLHsWrap view_expr_wrap view_expr') inner_pat', res) }
|
|
| 726 | 740 | |
| 727 | 741 | {- Note [View patterns and polymorphism]
|
| 728 | 742 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
| ... | ... | @@ -748,93 +762,91 @@ Another example is #26331. |
| 748 | 762 | |
| 749 | 763 | -- Type signatures in patterns
|
| 750 | 764 | -- See Note [Pattern coercions] below
|
| 751 | - SigPat _ pat sig_ty -> do
|
|
| 752 | - { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
|
|
| 753 | - sig_ty (scaledThing pat_ty)
|
|
| 754 | - -- Using tcExtendNameTyVarEnv is appropriate here
|
|
| 755 | - -- because we're not really bringing fresh tyvars into scope.
|
|
| 756 | - -- We're *naming* existing tyvars. Note that it is OK for a tyvar
|
|
| 757 | - -- from an outer scope to mention one of these tyvars in its kind.
|
|
| 758 | - ; (pat', res) <- tcExtendNameTyVarEnv wcs $
|
|
| 759 | - tcExtendNameTyVarEnv tv_binds $
|
|
| 760 | - tc_lpat (pat_ty `scaledSet` mkCheckExpType inner_ty) penv pat thing_inside
|
|
| 761 | - ; pat_ty <- readExpType (scaledThing pat_ty)
|
|
| 762 | - ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
|
|
| 765 | + SigPat _ pat sig_ty -> do
|
|
| 766 | + { (inner_ty, tv_binds, wcs, wrap) <-
|
|
| 767 | + tcPatSig (inPatBind penv) sig_ty exp_pat_ty
|
|
| 768 | + -- Using tcExtendNameTyVarEnv is appropriate here
|
|
| 769 | + -- because we're not really bringing fresh tyvars into scope.
|
|
| 770 | + -- We're *naming* existing tyvars. Note that it is OK for a tyvar
|
|
| 771 | + -- from an outer scope to mention one of these tyvars in its kind.
|
|
| 772 | + ; (pat', res) <- tcExtendNameTyVarEnv wcs $
|
|
| 773 | + tcExtendNameTyVarEnv tv_binds $
|
|
| 774 | + tc_lpat (Scaled w_pat $ mkCheckExpType inner_ty) penv pat thing_inside
|
|
| 775 | + ; pat_ty <- readExpType exp_pat_ty
|
|
| 776 | + ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
|
|
| 763 | 777 | |
| 764 | 778 | ------------------------
|
| 765 | 779 | -- Lists, tuples, arrays
|
| 766 | 780 | |
| 767 | 781 | -- Necessarily a built-in list pattern, not an overloaded list pattern.
|
| 768 | 782 | -- See Note [Desugaring overloaded list patterns].
|
| 769 | - ListPat _ pats -> do
|
|
| 770 | - { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty)
|
|
| 771 | - ; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty))
|
|
| 772 | - penv pats thing_inside
|
|
| 773 | - ; pat_ty <- readExpType (scaledThing pat_ty)
|
|
| 774 | - ; return (mkHsWrapPat coi
|
|
| 775 | - (ListPat elt_ty pats') pat_ty, res) }
|
|
| 776 | - |
|
| 777 | - TuplePat _ pats boxity -> do
|
|
| 778 | - { let arity = length pats
|
|
| 779 | - tc = tupleTyCon boxity arity
|
|
| 780 | - -- NB: tupleTyCon does not flatten 1-tuples
|
|
| 781 | - -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
|
|
| 782 | - ; checkTupSize arity
|
|
| 783 | - ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
|
|
| 784 | - penv (scaledThing pat_ty)
|
|
| 785 | - -- Unboxed tuples have RuntimeRep vars, which we discard:
|
|
| 786 | - -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
|
|
| 787 | - ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
|
|
| 788 | - Boxed -> arg_tys
|
|
| 789 | - ; (pats', res) <- tc_lpats (map (scaledSet pat_ty . mkCheckExpType) con_arg_tys)
|
|
| 783 | + ListPat _ pats -> do
|
|
| 784 | + { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv exp_pat_ty
|
|
| 785 | + ; (pats', res) <- tcMultiple (tc_lpat (Scaled w_pat $ mkCheckExpType elt_ty))
|
|
| 790 | 786 | penv pats thing_inside
|
| 791 | - |
|
| 792 | - ; dflags <- getDynFlags
|
|
| 793 | - |
|
| 794 | - -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
|
|
| 795 | - -- so that we can experiment with lazy tuple-matching.
|
|
| 796 | - -- This is a pretty odd place to make the switch, but
|
|
| 797 | - -- it was easy to do.
|
|
| 798 | - ; let
|
|
| 799 | - unmangled_result = TuplePat con_arg_tys pats' boxity
|
|
| 800 | - -- pat_ty /= pat_ty iff coi /= IdCo
|
|
| 801 | - possibly_mangled_result
|
|
| 802 | - | gopt Opt_IrrefutableTuples dflags &&
|
|
| 803 | - isBoxed boxity = LazyPat noExtField (noLocA unmangled_result)
|
|
| 804 | - | otherwise = unmangled_result
|
|
| 805 | - |
|
| 806 | - ; pat_ty <- readExpType (scaledThing pat_ty)
|
|
| 807 | - ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced
|
|
| 808 | - ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
|
|
| 809 | - }
|
|
| 810 | - |
|
| 811 | - SumPat _ pat alt arity -> do
|
|
| 812 | - { let tc = sumTyCon arity
|
|
| 813 | - ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
|
|
| 814 | - penv (scaledThing pat_ty)
|
|
| 815 | - ; -- Drop levity vars, we don't care about them here
|
|
| 816 | - let con_arg_tys = drop arity arg_tys
|
|
| 817 | - ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
|
|
| 818 | - penv pat thing_inside
|
|
| 819 | - ; pat_ty <- readExpType (scaledThing pat_ty)
|
|
| 820 | - ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
|
|
| 821 | - , res)
|
|
| 822 | - }
|
|
| 787 | + ; pat_ty <- readExpType exp_pat_ty
|
|
| 788 | + ; return (mkHsWrapPat coi
|
|
| 789 | + (ListPat elt_ty pats') pat_ty, res) }
|
|
| 790 | + |
|
| 791 | + TuplePat _ pats boxity -> do
|
|
| 792 | + { let arity = length pats
|
|
| 793 | + tc = tupleTyCon boxity arity
|
|
| 794 | + -- NB: tupleTyCon does not flatten 1-tuples
|
|
| 795 | + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
|
|
| 796 | + ; checkTupSize arity
|
|
| 797 | + ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv exp_pat_ty
|
|
| 798 | + -- Unboxed tuples have RuntimeRep vars, which we discard:
|
|
| 799 | + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
|
|
| 800 | + ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
|
|
| 801 | + Boxed -> arg_tys
|
|
| 802 | + ; (pats', res) <- tc_lpats (map (Scaled w_pat . mkCheckExpType) con_arg_tys)
|
|
| 803 | + penv pats thing_inside
|
|
| 804 | + |
|
| 805 | + ; dflags <- getDynFlags
|
|
| 806 | + |
|
| 807 | + -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
|
|
| 808 | + -- so that we can experiment with lazy tuple-matching.
|
|
| 809 | + -- This is a pretty odd place to make the switch, but
|
|
| 810 | + -- it was easy to do.
|
|
| 811 | + ; let
|
|
| 812 | + unmangled_result = TuplePat con_arg_tys pats' boxity
|
|
| 813 | + -- pat_ty /= pat_ty iff coi /= IdCo
|
|
| 814 | + possibly_mangled_result
|
|
| 815 | + | gopt Opt_IrrefutableTuples dflags &&
|
|
| 816 | + isBoxed boxity = LazyPat noExtField (noLocA unmangled_result)
|
|
| 817 | + | otherwise = unmangled_result
|
|
| 818 | + |
|
| 819 | + ; pat_ty <- readExpType exp_pat_ty
|
|
| 820 | + ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced
|
|
| 821 | + ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
|
|
| 822 | + }
|
|
| 823 | + |
|
| 824 | + SumPat _ pat alt arity -> do
|
|
| 825 | + { let tc = sumTyCon arity
|
|
| 826 | + ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv exp_pat_ty
|
|
| 827 | + ; -- Drop levity vars, we don't care about them here
|
|
| 828 | + let con_arg_tys = drop arity arg_tys
|
|
| 829 | + ; (pat', res) <- tc_lpat (Scaled w_pat $ mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
|
|
| 830 | + penv pat thing_inside
|
|
| 831 | + ; pat_ty <- readExpType exp_pat_ty
|
|
| 832 | + ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
|
|
| 833 | + , res)
|
|
| 834 | + }
|
|
| 823 | 835 | |
| 824 | 836 | ------------------------
|
| 825 | 837 | -- Data constructors
|
| 826 | - ConPat _ con arg_pats ->
|
|
| 827 | - tcConPat penv con pat_ty arg_pats thing_inside
|
|
| 838 | + ConPat _ con arg_pats ->
|
|
| 839 | + tcConPat penv con scaled_exp_pat_ty arg_pats thing_inside
|
|
| 828 | 840 | |
| 829 | 841 | ------------------------
|
| 830 | 842 | -- Literal patterns
|
| 831 | - LitPat x simple_lit -> do
|
|
| 832 | - { let lit_ty = hsLitType simple_lit
|
|
| 833 | - ; wrap <- tc_sub_type penv (scaledThing pat_ty) lit_ty
|
|
| 834 | - ; res <- thing_inside
|
|
| 835 | - ; pat_ty <- readExpType (scaledThing pat_ty)
|
|
| 836 | - ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
|
|
| 837 | - , res) }
|
|
| 843 | + LitPat x simple_lit -> do
|
|
| 844 | + { let lit_ty = hsLitType simple_lit
|
|
| 845 | + ; wrap <- tcSubTypePat_GenSigCtxt penv exp_pat_ty lit_ty
|
|
| 846 | + ; res <- thing_inside
|
|
| 847 | + ; pat_ty <- readExpType exp_pat_ty
|
|
| 848 | + ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
|
|
| 849 | + , res) }
|
|
| 838 | 850 | |
| 839 | 851 | ------------------------
|
| 840 | 852 | -- Overloaded patterns: n, and n+k
|
| ... | ... | @@ -854,31 +866,31 @@ Another example is #26331. |
| 854 | 866 | -- where lit_ty is the type of the overloaded literal 5.
|
| 855 | 867 | --
|
| 856 | 868 | -- When there is no negation, neg_lit_ty and lit_ty are the same
|
| 857 | - NPat _ (L l over_lit) mb_neg eq -> do
|
|
| 858 | - { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
|
|
| 859 | - -- It may be possible to refine linear pattern so that they work in
|
|
| 860 | - -- linear environments. But it is not clear how useful this is.
|
|
| 861 | - ; let orig = LiteralOrigin over_lit
|
|
| 862 | - ; ((lit', mb_neg'), eq')
|
|
| 863 | - <- tcSyntaxOp orig eq [SynType (scaledThing pat_ty), SynAny]
|
|
| 864 | - (mkCheckExpType boolTy) $
|
|
| 865 | - \ [neg_lit_ty] _ ->
|
|
| 866 | - let new_over_lit lit_ty = newOverloadedLit over_lit
|
|
| 867 | - (mkCheckExpType lit_ty)
|
|
| 868 | - in case mb_neg of
|
|
| 869 | - Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty
|
|
| 870 | - Just neg -> -- Negative literal
|
|
| 871 | - -- The 'negate' is re-mappable syntax
|
|
| 872 | - second Just <$>
|
|
| 873 | - (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
|
|
| 874 | - \ [lit_ty] _ -> new_over_lit lit_ty)
|
|
| 875 | - -- applied to a closed literal: linearity doesn't matter as
|
|
| 876 | - -- literals are typed in an empty environment, hence have
|
|
| 877 | - -- all multiplicities.
|
|
| 878 | - |
|
| 879 | - ; res <- thing_inside
|
|
| 880 | - ; pat_ty <- readExpType (scaledThing pat_ty)
|
|
| 881 | - ; return (NPat pat_ty (L l lit') mb_neg' eq', res) }
|
|
| 869 | + NPat _ (L l over_lit) mb_neg eq -> do
|
|
| 870 | + { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
|
|
| 871 | + -- It may be possible to refine linear pattern so that they work in
|
|
| 872 | + -- linear environments. But it is not clear how useful this is.
|
|
| 873 | + ; let orig = LiteralOrigin over_lit
|
|
| 874 | + ; ((lit', mb_neg'), eq')
|
|
| 875 | + <- tcSyntaxOp orig eq [SynType exp_pat_ty, SynAny]
|
|
| 876 | + (mkCheckExpType boolTy) $
|
|
| 877 | + \ [neg_lit_ty] _ ->
|
|
| 878 | + let new_over_lit lit_ty = newOverloadedLit over_lit
|
|
| 879 | + (mkCheckExpType lit_ty)
|
|
| 880 | + in case mb_neg of
|
|
| 881 | + Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty
|
|
| 882 | + Just neg -> -- Negative literal
|
|
| 883 | + -- The 'negate' is re-mappable syntax
|
|
| 884 | + second Just <$>
|
|
| 885 | + (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
|
|
| 886 | + \ [lit_ty] _ -> new_over_lit lit_ty)
|
|
| 887 | + -- applied to a closed literal: linearity doesn't matter as
|
|
| 888 | + -- literals are typed in an empty environment, hence have
|
|
| 889 | + -- all multiplicities.
|
|
| 890 | + |
|
| 891 | + ; res <- thing_inside
|
|
| 892 | + ; pat_ty <- readExpType exp_pat_ty
|
|
| 893 | + ; return (NPat pat_ty (L l lit') mb_neg' eq', res) }
|
|
| 882 | 894 | |
| 883 | 895 | {-
|
| 884 | 896 | Note [NPlusK patterns]
|
| ... | ... | @@ -904,68 +916,67 @@ AST is used for the subtraction operation. |
| 904 | 916 | -}
|
| 905 | 917 | |
| 906 | 918 | -- See Note [NPlusK patterns]
|
| 907 | - NPlusKPat _ (L nm_loc name)
|
|
| 908 | - (L loc lit) _ ge minus -> do
|
|
| 909 | - { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
|
|
| 910 | - ; let pat_exp_ty = scaledThing pat_ty
|
|
| 911 | - orig = LiteralOrigin lit
|
|
| 912 | - ; (lit1', ge')
|
|
| 913 | - <- tcSyntaxOp orig ge [SynType pat_exp_ty, SynRho]
|
|
| 914 | - (mkCheckExpType boolTy) $
|
|
| 915 | - \ [lit1_ty] _ ->
|
|
| 916 | - newOverloadedLit lit (mkCheckExpType lit1_ty)
|
|
| 917 | - ; ((lit2', minus_wrap, bndr_id), minus')
|
|
| 918 | - <- tcSyntaxOpGen orig minus [SynType pat_exp_ty, SynRho] SynAny $
|
|
| 919 | - \ [lit2_ty, var_ty] _ ->
|
|
| 920 | - do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
|
|
| 921 | - ; (wrap, bndr_id) <- setSrcSpanA nm_loc $
|
|
| 922 | - tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty)
|
|
| 923 | - -- co :: var_ty ~ idType bndr_id
|
|
| 924 | - |
|
| 925 | - -- minus_wrap is applicable to minus'
|
|
| 926 | - ; return (lit2', wrap, bndr_id) }
|
|
| 927 | - |
|
| 928 | - ; pat_ty <- readExpType pat_exp_ty
|
|
| 929 | - |
|
| 930 | - -- The Report says that n+k patterns must be in Integral
|
|
| 931 | - -- but it's silly to insist on this in the RebindableSyntax case
|
|
| 932 | - ; unlessM (xoptM LangExt.RebindableSyntax) $
|
|
| 933 | - do { icls <- tcLookupClass integralClassName
|
|
| 934 | - ; instStupidTheta orig [mkClassPred icls [pat_ty]] }
|
|
| 935 | - |
|
| 936 | - ; res <- tcExtendIdEnv1 name bndr_id thing_inside
|
|
| 937 | - |
|
| 938 | - ; let minus'' = case minus' of
|
|
| 939 | - NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus')
|
|
| 940 | - -- this should be statically avoidable
|
|
| 941 | - -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr"
|
|
| 942 | - SyntaxExprTc { syn_expr = minus'_expr
|
|
| 943 | - , syn_arg_wraps = minus'_arg_wraps
|
|
| 944 | - , syn_res_wrap = minus'_res_wrap }
|
|
| 945 | - -> SyntaxExprTc { syn_expr = minus'_expr
|
|
| 946 | - , syn_arg_wraps = minus'_arg_wraps
|
|
| 947 | - , syn_res_wrap = minus_wrap <.> minus'_res_wrap }
|
|
| 948 | - -- Oy. This should really be a record update, but
|
|
| 949 | - -- we get warnings if we try. #17783
|
|
| 950 | - pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'
|
|
| 951 | - ge' minus''
|
|
| 952 | - ; return (pat', res) }
|
|
| 919 | + NPlusKPat _ (L nm_loc name)
|
|
| 920 | + (L loc lit) _ ge minus -> do
|
|
| 921 | + { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
|
|
| 922 | + ; let orig = LiteralOrigin lit
|
|
| 923 | + ; (lit1', ge')
|
|
| 924 | + <- tcSyntaxOp orig ge [SynType exp_pat_ty, SynRho]
|
|
| 925 | + (mkCheckExpType boolTy) $
|
|
| 926 | + \ [lit1_ty] _ ->
|
|
| 927 | + newOverloadedLit lit (mkCheckExpType lit1_ty)
|
|
| 928 | + ; ((lit2', minus_wrap, bndr_id), minus')
|
|
| 929 | + <- tcSyntaxOpGen orig minus [SynType exp_pat_ty, SynRho] SynAny $
|
|
| 930 | + \ [lit2_ty, var_ty] _ ->
|
|
| 931 | + do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
|
|
| 932 | + ; (wrap, bndr_id) <- setSrcSpanA nm_loc $
|
|
| 933 | + tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty)
|
|
| 934 | + -- co :: var_ty ~ idType bndr_id
|
|
| 935 | + |
|
| 936 | + -- minus_wrap is applicable to minus'
|
|
| 937 | + ; return (lit2', wrap, bndr_id) }
|
|
| 938 | + |
|
| 939 | + ; pat_ty <- readExpType exp_pat_ty
|
|
| 940 | + |
|
| 941 | + -- The Report says that n+k patterns must be in Integral
|
|
| 942 | + -- but it's silly to insist on this in the RebindableSyntax case
|
|
| 943 | + ; unlessM (xoptM LangExt.RebindableSyntax) $
|
|
| 944 | + do { icls <- tcLookupClass integralClassName
|
|
| 945 | + ; instStupidTheta orig [mkClassPred icls [pat_ty]] }
|
|
| 946 | + |
|
| 947 | + ; res <- tcExtendIdEnv1 name bndr_id thing_inside
|
|
| 948 | + |
|
| 949 | + ; let minus'' = case minus' of
|
|
| 950 | + NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus')
|
|
| 951 | + -- this should be statically avoidable
|
|
| 952 | + -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr"
|
|
| 953 | + SyntaxExprTc { syn_expr = minus'_expr
|
|
| 954 | + , syn_arg_wraps = minus'_arg_wraps
|
|
| 955 | + , syn_res_wrap = minus'_res_wrap }
|
|
| 956 | + -> SyntaxExprTc { syn_expr = minus'_expr
|
|
| 957 | + , syn_arg_wraps = minus'_arg_wraps
|
|
| 958 | + , syn_res_wrap = minus_wrap <.> minus'_res_wrap }
|
|
| 959 | + -- Oy. This should really be a record update, but
|
|
| 960 | + -- we get warnings if we try. #17783
|
|
| 961 | + pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'
|
|
| 962 | + ge' minus''
|
|
| 963 | + ; return (pat', res) }
|
|
| 953 | 964 | |
| 954 | 965 | -- Here we get rid of it and add the finalizers to the global environment.
|
| 955 | 966 | -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
|
| 956 | - SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do
|
|
| 967 | + SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do
|
|
| 957 | 968 | { addModFinalizersWithLclEnv mod_finalizers
|
| 958 | - ; tc_pat pat_ty penv pat thing_inside }
|
|
| 969 | + ; tc_pat scaled_exp_pat_ty penv pat thing_inside }
|
|
| 959 | 970 | |
| 960 | - SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat"
|
|
| 971 | + SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat"
|
|
| 961 | 972 | |
| 962 | - EmbTyPat _ _ -> failWith TcRnIllegalTypePattern
|
|
| 973 | + EmbTyPat _ _ -> failWith TcRnIllegalTypePattern
|
|
| 963 | 974 | |
| 964 | - InvisPat _ _ -> panic "tc_pat: invisible pattern appears recursively in the pattern"
|
|
| 975 | + InvisPat _ _ -> panic "tc_pat: invisible pattern appears recursively in the pattern"
|
|
| 965 | 976 | |
| 966 | - XPat (HsPatExpanded lpat rpat) -> do
|
|
| 967 | - { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside
|
|
| 968 | - ; return (XPat $ ExpansionPat lpat rpat', res) }
|
|
| 977 | + XPat (HsPatExpanded lpat rpat) -> do
|
|
| 978 | + { (rpat', res) <- tc_pat scaled_exp_pat_ty penv rpat thing_inside
|
|
| 979 | + ; return (XPat $ ExpansionPat lpat rpat', res) }
|
|
| 969 | 980 | |
| 970 | 981 | {-
|
| 971 | 982 | 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 |
| 1295 | 1306 | |
| 1296 | 1307 | ; (univ_ty_args, ex_ty_args, val_arg_pats) <- splitConTyArgs con_like arg_pats
|
| 1297 | 1308 | |
| 1298 | - ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty'
|
|
| 1309 | + ; wrap <- tcSubTypePat_GenSigCtxt penv (scaledThing pat_ty) ty'
|
|
| 1299 | 1310 | |
| 1300 | 1311 | ; traceTc "tcPatSynPat" $
|
| 1301 | 1312 | vcat [ text "Pat syn:" <+> ppr pat_syn
|
| ... | ... | @@ -1405,8 +1416,9 @@ matchExpectedConTy :: PatEnv |
| 1405 | 1416 | -- In the case of a data family, this would
|
| 1406 | 1417 | -- mention the /family/ TyCon
|
| 1407 | 1418 | -> TcM (HsWrapper, [TcSigmaType])
|
| 1408 | --- See Note [Matching constructor patterns]
|
|
| 1409 | --- Returns a wrapper : pat_ty "->" T ty1 ... tyn
|
|
| 1419 | +-- ^ See Note [Matching constructor patterns]
|
|
| 1420 | +--
|
|
| 1421 | +-- Returns a wrapper : pat_ty ~~> T ty1 ... tyn
|
|
| 1410 | 1422 | matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty
|
| 1411 | 1423 | | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc
|
| 1412 | 1424 | -- Comments refer to Note [Matching constructor patterns]
|
| ... | ... | @@ -263,7 +263,9 @@ in two places: |
| 263 | 263 | * In `updInertDicts`, in this module, when adding [G] (?x :: ty), remove any
|
| 264 | 264 | existing [G] (?x :: ty'), regardless of ty'.
|
| 265 | 265 | |
| 266 | -* Wrinkle (SIP1): we must be careful of superclasses. Consider
|
|
| 266 | +There are wrinkles:
|
|
| 267 | + |
|
| 268 | +* Wrinkle (SIP1): we must be careful of superclasses (#14218). Consider
|
|
| 267 | 269 | f,g :: (?x::Int, C a) => a -> a
|
| 268 | 270 | f v = let ?x = 4 in g v
|
| 269 | 271 | |
| ... | ... | @@ -271,24 +273,31 @@ in two places: |
| 271 | 273 | We must /not/ solve this from the Given (?x::Int, C a), because of
|
| 272 | 274 | the intervening binding for (?x::Int). #14218.
|
| 273 | 275 | |
| 274 | - We deal with this by arranging that when we add [G] (?x::ty) we delete
|
|
| 276 | + We deal with this by arranging that when we add [G] (?x::ty) we /delete/
|
|
| 275 | 277 | * from the inert_cans, and
|
| 276 | 278 | * from the inert_solved_dicts
|
| 277 | 279 | any existing [G] (?x::ty) /and/ any [G] D tys, where (D tys) has a superclass
|
| 278 | 280 | with (?x::ty). See Note [Local implicit parameters] in GHC.Core.Predicate.
|
| 279 | 281 | |
| 280 | - An important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
|
|
| 281 | - But it could happen for `class xx => D xx where ...` and the constraint D
|
|
| 282 | - (?x :: int). This corner (constraint-kinded variables instantiated with
|
|
| 283 | - implicit parameter constraints) is not well explored.
|
|
| 282 | + An very important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
|
|
| 283 | + |
|
| 284 | + But it could also happen for `class xx => D xx where ...` and the constraint
|
|
| 285 | + D (?x :: int); again see Note [Local implicit parameters]. This corner
|
|
| 286 | + (constraint-kinded variables instantiated with implicit parameter constraints)
|
|
| 287 | + is not well explored.
|
|
| 284 | 288 | |
| 285 | - Example in #14218, and #23761
|
|
| 289 | + You might worry about whether deleting an /entire/ constraint just because
|
|
| 290 | + a distant superclass has an implicit parameter might make another Wanted for
|
|
| 291 | + that constraint un-solvable. Indeed so. But for constraint tuples it doesn't
|
|
| 292 | + matter -- their entire payload is their superclasses. And the other case is
|
|
| 293 | + the ill-explored corner above.
|
|
| 286 | 294 | |
| 287 | 295 | The code that accounts for (SIP1) is in updInertDicts; in particular the call to
|
| 288 | 296 | GHC.Core.Predicate.mentionsIP.
|
| 289 | 297 | |
| 290 | 298 | * Wrinkle (SIP2): we must apply this update semantics for `inert_solved_dicts`
|
| 291 | - as well as `inert_cans`.
|
|
| 299 | + as well as `inert_cans` (#23761).
|
|
| 300 | + |
|
| 292 | 301 | You might think that wouldn't be necessary, because an element of
|
| 293 | 302 | `inert_solved_dicts` is never an implicit parameter (see
|
| 294 | 303 | Note [Solved dictionaries] in GHC.Tc.Solver.InertSet).
|
| ... | ... | @@ -301,6 +310,19 @@ in two places: |
| 301 | 310 | Now (C (?x::Int)) has a superclass (?x::Int). This may look exotic, but it
|
| 302 | 311 | happens particularly for constraint tuples, like `(% ?x::Int, Eq a %)`.
|
| 303 | 312 | |
| 313 | +* Wrinkle (SIP3)
|
|
| 314 | + - Note that for the inert dictionaries, `inert_cans`, we must /only/ delete
|
|
| 315 | + existing /Givens/! Deleting an existing Wanted led to #26451; we just never
|
|
| 316 | + solved it!
|
|
| 317 | + |
|
| 318 | + - In contrast, the solved dictionaries, `inert_solved_dicts`, are really like
|
|
| 319 | + Givens; they may be "inherited" from outer scopes, so we must delete any
|
|
| 320 | + solved dictionaries for this implicit parameter for /both/ Givens /and/
|
|
| 321 | + Wanteds.
|
|
| 322 | + |
|
| 323 | + Otherwise the new Given doesn't properly shadow those inherited solved
|
|
| 324 | + dictionaries. Test T23761 showed this up.
|
|
| 325 | + |
|
| 304 | 326 | Example 1:
|
| 305 | 327 | |
| 306 | 328 | Suppose we have (typecheck/should_compile/ImplicitParamFDs)
|
| ... | ... | @@ -377,28 +377,53 @@ in GHC.Tc.Solver.Dict. |
| 377 | 377 | -}
|
| 378 | 378 | |
| 379 | 379 | updInertDicts :: DictCt -> TcS ()
|
| 380 | -updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
|
|
| 381 | - = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys)
|
|
| 382 | - |
|
| 383 | - ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys
|
|
| 384 | - -> -- For [G] ?x::ty, remove any dicts mentioning ?x,
|
|
| 385 | - -- from /both/ inert_cans /and/ inert_solved_dicts (#23761)
|
|
| 386 | - -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters]
|
|
| 387 | - updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
|
|
| 388 | - inerts { inert_cans = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics
|
|
| 389 | - , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved }
|
|
| 390 | - | otherwise
|
|
| 391 | - -> return ()
|
|
| 380 | +updInertDicts dict_ct
|
|
| 381 | + = do { traceTcS "Adding inert dict" (ppr dict_ct)
|
|
| 382 | + |
|
| 383 | + -- For Given implicit parameters (only), delete any existing
|
|
| 384 | + -- Givens for the same implicit parameter.
|
|
| 385 | + -- See Note [Shadowing of implicit parameters]
|
|
| 386 | + ; deleteGivenIPs dict_ct
|
|
| 387 | + |
|
| 392 | 388 | -- Add the new constraint to the inert set
|
| 393 | 389 | ; updInertCans (updDicts (addDict dict_ct)) }
|
| 390 | + |
|
| 391 | +deleteGivenIPs :: DictCt -> TcS ()
|
|
| 392 | +-- Special magic when adding a Given implicit parameter to the inert set
|
|
| 393 | +-- For [G] ?x::ty, remove any existing /Givens/ mentioning ?x,
|
|
| 394 | +-- from /both/ inert_cans /and/ inert_solved_dicts (#23761)
|
|
| 395 | +-- See Note [Shadowing of implicit parameters]
|
|
| 396 | +deleteGivenIPs (DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
|
|
| 397 | + | isGiven ev
|
|
| 398 | + , Just (str_ty, _) <- isIPPred_maybe cls tys
|
|
| 399 | + = updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
|
|
| 400 | + inerts { inert_cans = updDicts (filterDicts (keep_can str_ty)) ics
|
|
| 401 | + , inert_solved_dicts = filterDicts (keep_solved str_ty) solved }
|
|
| 402 | + | otherwise
|
|
| 403 | + = return ()
|
|
| 394 | 404 | where
|
| 395 | - -- Does this class constraint or any of its superclasses mention
|
|
| 396 | - -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?
|
|
| 397 | - does_not_mention_ip_for :: Type -> DictCt -> Bool
|
|
| 398 | - does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
|
|
| 399 | - = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys
|
|
| 400 | - -- See Note [Using typesAreApart when calling mightMentionIP]
|
|
| 401 | - -- in GHC.Core.Predicate
|
|
| 405 | + keep_can, keep_solved :: Type -> DictCt -> Bool
|
|
| 406 | + -- keep_can: we keep an inert dictionary UNLESS
|
|
| 407 | + -- (1) it is a Given
|
|
| 408 | + -- (2) it binds an implicit parameter (?str :: ty) for the given 'str'
|
|
| 409 | + -- regardless of 'ty', possibly via its superclasses
|
|
| 410 | + -- The test is a bit conservative, hence `mightMentionIP` and `typesAreApart`
|
|
| 411 | + -- See Note [Using typesAreApart when calling mightMentionIP]
|
|
| 412 | + -- in GHC.Core.Predicate
|
|
| 413 | + --
|
|
| 414 | + -- keep_solved: same as keep_can, but for /all/ constraints not just Givens
|
|
| 415 | + --
|
|
| 416 | + -- Why two functions? See (SIP3) in Note [Shadowing of implicit parameters]
|
|
| 417 | + keep_can str (DictCt { di_ev = ev, di_cls = cls, di_tys = tys })
|
|
| 418 | + = not (isGiven ev -- (1)
|
|
| 419 | + && mentions_ip str cls tys) -- (2)
|
|
| 420 | + keep_solved str (DictCt { di_cls = cls, di_tys = tys })
|
|
| 421 | + = not (mentions_ip str cls tys)
|
|
| 422 | + |
|
| 423 | + -- mentions_ip: the inert constraint might provide evidence
|
|
| 424 | + -- for an implicit parameter (?str :: ty) for the given 'str'
|
|
| 425 | + mentions_ip str cls tys
|
|
| 426 | + = mightMentionIP (not . typesAreApart str) (const True) cls tys
|
|
| 402 | 427 | |
| 403 | 428 | updInertIrreds :: IrredCt -> TcS ()
|
| 404 | 429 | updInertIrreds irred
|
| ... | ... | @@ -197,29 +197,29 @@ that it is a no-op. Here's our solution: |
| 197 | 197 | * we /must/ optimise subtype-HsWrappers (that's the point of this Note!)
|
| 198 | 198 | * there is little point in attempting to optimise any other HsWrappers
|
| 199 | 199 | |
| 200 | -Note [WpFun-RR-INVARIANT]
|
|
| 201 | -~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
| 200 | +Note [WpFun-FRR-INVARIANT]
|
|
| 201 | +~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
| 202 | 202 | Given
|
| 203 | 203 | wrap = WpFun wrap1 wrap2 sty1 ty2
|
| 204 | 204 | where: wrap1 :: exp_arg ~~> act_arg
|
| 205 | 205 | wrap2 :: act_res ~~> exp_res
|
| 206 | 206 | wrap :: (act_arg -> act_res) ~~> (exp_arg -> exp_res)
|
| 207 | 207 | we have
|
| 208 | - WpFun-RR-INVARIANT:
|
|
| 208 | + WpFun-FRR-INVARIANT:
|
|
| 209 | 209 | the input (exp_arg) and output (act_arg) types of `wrap1`
|
| 210 | 210 | both have a fixed runtime-rep
|
| 211 | 211 | |
| 212 | 212 | Reason: We desugar wrap[e] into
|
| 213 | 213 | \(x:exp_arg). wrap2[ e wrap1[x] ]
|
| 214 | -And then, because of Note [Representation polymorphism invariants], we need:
|
|
| 214 | +And then, because of Note [Representation polymorphism invariants]:
|
|
| 215 | 215 | |
| 216 | 216 | * `exp_arg` must have a fixed runtime rep,
|
| 217 | 217 | so that lambda obeys the the FRR rules
|
| 218 | 218 | |
| 219 | 219 | * `act_arg` must have a fixed runtime rep,
|
| 220 | - so the that application (e wrap1[x]) obeys the FRR tules
|
|
| 220 | + so that the application (e wrap1[x]) obeys the FRR rules
|
|
| 221 | 221 | |
| 222 | -Hence WpFun-INVARIANT.
|
|
| 222 | +Hence WpFun-FRR-INVARIANT.
|
|
| 223 | 223 | -}
|
| 224 | 224 | |
| 225 | 225 | data HsWrapper
|
| ... | ... | @@ -246,7 +246,7 @@ data HsWrapper |
| 246 | 246 | -- (WpFun wrap1 wrap2 (w, t1) t2)[e] = \(x:_w exp_arg). wrap2[ e wrap1[x] ]
|
| 247 | 247 | --
|
| 248 | 248 | -- INVARIANT: both input and output types of `wrap1` have a fixed runtime-rep
|
| 249 | - -- See Note [WpFun-RR-INVARIANT]
|
|
| 249 | + -- See Note [WpFun-FRR-INVARIANT]
|
|
| 250 | 250 | --
|
| 251 | 251 | -- Typing rules:
|
| 252 | 252 | -- If e :: act_arg -> act_res
|
| ... | ... | @@ -319,7 +319,7 @@ mkWpFun :: HsWrapper -> HsWrapper |
| 319 | 319 | -- ^ Smart constructor for `WpFun`
|
| 320 | 320 | -- Just removes clutter and optimises some common cases.
|
| 321 | 321 | --
|
| 322 | --- PRECONDITION: same as Note [WpFun-RR-INVARIANT]
|
|
| 322 | +-- PRECONDITION: same as Note [WpFun-FRR-INVARIANT]
|
|
| 323 | 323 | --
|
| 324 | 324 | -- Unfortunately, we can't check PRECONDITION with an assertion here, because of
|
| 325 | 325 | -- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
|
| ... | ... | @@ -277,7 +277,7 @@ skolemiseRequired skolem_info n_req sigma |
| 277 | 277 | topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
|
| 278 | 278 | -- Instantiate outer invisible binders (both Inferred and Specified)
|
| 279 | 279 | -- If top_instantiate ty = (wrap, inner_ty)
|
| 280 | --- then wrap :: inner_ty "->" ty
|
|
| 280 | +-- then wrap :: inner_ty ~~> ty
|
|
| 281 | 281 | -- NB: returns a type with no (=>),
|
| 282 | 282 | -- and no invisible forall at the top
|
| 283 | 283 | topInstantiate orig sigma
|
| ... | ... | @@ -66,7 +66,6 @@ module GHC.Tc.Utils.Unify ( |
| 66 | 66 | import GHC.Prelude
|
| 67 | 67 | |
| 68 | 68 | import GHC.Hs
|
| 69 | - |
|
| 70 | 69 | import GHC.Tc.Errors.Types ( ErrCtxtMsg(..) )
|
| 71 | 70 | import GHC.Tc.Errors.Ppr ( pprErrCtxtMsg )
|
| 72 | 71 | import GHC.Tc.Utils.Concrete
|
| ... | ... | @@ -256,24 +255,24 @@ matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpected |
| 256 | 255 | -- and res_ty is a RhoType
|
| 257 | 256 | -- NB: the returned type is top-instantiated; it's a RhoType
|
| 258 | 257 | matchActualFunTys herald ct_orig n_val_args_wanted top_ty
|
| 259 | - = go n_val_args_wanted [] top_ty
|
|
| 258 | + = go n_val_args_wanted top_ty
|
|
| 260 | 259 | where
|
| 261 | - go n so_far fun_ty
|
|
| 260 | + go n fun_ty
|
|
| 262 | 261 | | not (isRhoTy fun_ty)
|
| 263 | 262 | = do { (wrap1, rho) <- topInstantiate ct_orig fun_ty
|
| 264 | - ; (wrap2, arg_tys, res_ty) <- go n so_far rho
|
|
| 263 | + ; (wrap2, arg_tys, res_ty) <- go n rho
|
|
| 265 | 264 | ; return (wrap2 <.> wrap1, arg_tys, res_ty) }
|
| 266 | 265 | |
| 267 | - go 0 _ fun_ty = return (idHsWrapper, [], fun_ty)
|
|
| 266 | + go 0 fun_ty = return (idHsWrapper, [], fun_ty)
|
|
| 268 | 267 | |
| 269 | - go n so_far fun_ty
|
|
| 270 | - = do { (co1, arg_ty1, res_ty1) <- matchActualFunTy herald Nothing
|
|
| 271 | - (n_val_args_wanted, top_ty) fun_ty
|
|
| 272 | - ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1
|
|
| 273 | - ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty
|
|
| 274 | - -- NB: arg_ty1 comes from matchActualFunTy, so it has
|
|
| 275 | - -- a syntactically fixed RuntimeRep
|
|
| 276 | - ; return (wrap_fun2 <.> mkWpCastN co1, arg_ty1:arg_tys, res_ty) }
|
|
| 268 | + go n fun_ty
|
|
| 269 | + = do { (co1, arg1_ty_frr, res_ty1) <-
|
|
| 270 | + matchActualFunTy herald Nothing (n_val_args_wanted, top_ty) fun_ty
|
|
| 271 | + ; (wrap_res, arg_tys, res_ty) <- go (n-1) res_ty1
|
|
| 272 | + ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg1_ty_frr res_ty
|
|
| 273 | + -- This call to mkWpFun satisfies WpFun-FRR-INVARIANT:
|
|
| 274 | + -- 'arg1_ty_frr' comes from matchActualFunTy, so is FRR.
|
|
| 275 | + ; return (wrap_fun2 <.> mkWpCastN co1, arg1_ty_frr:arg_tys, res_ty) }
|
|
| 277 | 276 | |
| 278 | 277 | {-
|
| 279 | 278 | ************************************************************************
|
| ... | ... | @@ -866,12 +865,30 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside |
| 866 | 865 | = assert (isVisibleFunArg af) $
|
| 867 | 866 | do { let arg_pos = arity - n_req + 1 -- 1 for the first argument etc
|
| 868 | 867 | ; (arg_co, arg_ty_frr) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty
|
| 869 | - ; let arg_sty_frr = Scaled mult arg_ty_frr
|
|
| 870 | - ; (wrap_res, result) <- check (n_req - 1)
|
|
| 871 | - (mkCheckExpFunPatTy arg_sty_frr : rev_pat_tys)
|
|
| 868 | + ; let scaled_arg_ty_frr = Scaled mult arg_ty_frr
|
|
| 869 | + ; (res_wrap, result) <- check (n_req - 1)
|
|
| 870 | + (mkCheckExpFunPatTy scaled_arg_ty_frr : rev_pat_tys)
|
|
| 872 | 871 | res_ty
|
| 873 | - ; let wrap_arg = mkWpCastN arg_co
|
|
| 874 | - fun_wrap = mkWpFun wrap_arg wrap_res arg_sty_frr res_ty
|
|
| 872 | + |
|
| 873 | + -- arg_co :: arg_ty ~ arg_ty_frr
|
|
| 874 | + -- res_wrap :: act_res_ty ~~> res_ty
|
|
| 875 | + ; let fun_wrap1 -- :: (arg_ty_frr -> act_res_ty) ~~> (arg_ty_frr -> res_ty)
|
|
| 876 | + = mkWpFun idHsWrapper res_wrap scaled_arg_ty_frr res_ty
|
|
| 877 | + -- Satisfies WpFun-FRR-INVARIANT because arg_sty_frr is FRR
|
|
| 878 | + |
|
| 879 | + fun_wrap2 -- :: (arg_ty_frr -> res_ty) ~~> (arg_ty -> res_ty)
|
|
| 880 | + = mkWpCastN (mkFunCo Nominal af (mkNomReflCo mult) (mkSymCo arg_co) (mkNomReflCo res_ty))
|
|
| 881 | + |
|
| 882 | + fun_wrap -- :: (arg_ty_frr -> act_res_ty) ~~> (arg_ty -> res_ty)
|
|
| 883 | + = fun_wrap2 <.> fun_wrap1
|
|
| 884 | + |
|
| 885 | +-- NB: in the common case, 'arg_ty' is already FRR (in the sense of
|
|
| 886 | +-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete), hence 'arg_co' is 'Refl'.
|
|
| 887 | +-- Then 'fun_wrap' will collapse down to 'fun_wrap1'. This applies recursively;
|
|
| 888 | +-- as 'mkWpFun WpHole WpHole' is 'WpHole', this means that 'fun_wrap' will
|
|
| 889 | +-- typically just be 'WpHole'; no clutter.
|
|
| 890 | +-- This is important because 'matchExpectedFunTys' is called a lot.
|
|
| 891 | + |
|
| 875 | 892 | ; return (fun_wrap, result) }
|
| 876 | 893 | |
| 877 | 894 | ----------------------------
|
| ... | ... | @@ -1404,7 +1421,7 @@ tcSubTypeMono rn_expr act_ty exp_ty |
| 1404 | 1421 | |
| 1405 | 1422 | ------------------------
|
| 1406 | 1423 | tcSubTypePat :: CtOrigin -> UserTypeCtxt
|
| 1407 | - -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
|
|
| 1424 | + -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
|
|
| 1408 | 1425 | -- Used in patterns; polarity is backwards compared
|
| 1409 | 1426 | -- to tcSubType
|
| 1410 | 1427 | -- If wrap = tc_sub_type_et t1 t2
|
| ... | ... | @@ -35,7 +35,7 @@ def expected_undocumented(flag: str) -> bool: |
| 35 | 35 | |
| 36 | 36 | return False
|
| 37 | 37 | |
| 38 | -def read_documented_flags(doc_flags) -> Set[str]:
|
|
| 38 | +def read_documented_flags(doc_flags: Path) -> Set[str]:
|
|
| 39 | 39 | # Map characters that mark the end of a flag
|
| 40 | 40 | # to whitespace.
|
| 41 | 41 | trans = str.maketrans({
|
| ... | ... | @@ -44,10 +44,10 @@ def read_documented_flags(doc_flags) -> Set[str]: |
| 44 | 44 | '⟨': ' ',
|
| 45 | 45 | })
|
| 46 | 46 | return {line.translate(trans).split()[0]
|
| 47 | - for line in doc_flags.read().split('\n')
|
|
| 47 | + for line in doc_flags.read_text(encoding="UTF-8").split('\n')
|
|
| 48 | 48 | if line != ''}
|
| 49 | 49 | |
| 50 | -def read_ghc_flags(ghc_path: str) -> Set[str]:
|
|
| 50 | +def read_ghc_flags(ghc_path: Path) -> Set[str]:
|
|
| 51 | 51 | ghc_output = subprocess.check_output([ghc_path, '--show-options'])
|
| 52 | 52 | ghci_output = subprocess.check_output([ghc_path, '--interactive', '--show-options'])
|
| 53 | 53 | |
| ... | ... | @@ -63,16 +63,16 @@ def error(s: str): |
| 63 | 63 | def main() -> None:
|
| 64 | 64 | import argparse
|
| 65 | 65 | parser = argparse.ArgumentParser()
|
| 66 | - parser.add_argument('--ghc', type=argparse.FileType('r'),
|
|
| 66 | + parser.add_argument('--ghc', type=Path,
|
|
| 67 | 67 | help='path of GHC executable',
|
| 68 | 68 | required=True)
|
| 69 | - parser.add_argument('--doc-flags', type=argparse.FileType(mode='r', encoding='UTF-8'),
|
|
| 69 | + parser.add_argument('--doc-flags', type=Path,
|
|
| 70 | 70 | help='path of ghc-flags.txt output from Sphinx',
|
| 71 | 71 | required=True)
|
| 72 | 72 | args = parser.parse_args()
|
| 73 | 73 | |
| 74 | 74 | doc_flags = read_documented_flags(args.doc_flags)
|
| 75 | - ghc_flags = read_ghc_flags(args.ghc.name)
|
|
| 75 | + ghc_flags = read_ghc_flags(args.ghc)
|
|
| 76 | 76 | |
| 77 | 77 | failed = False
|
| 78 | 78 |
| 1 | -Subproject commit 2e693aad07540173a0169971b27c9acac28eeff1 |
|
| 1 | +Subproject commit c08666bf7bf528e607fc1eacc20032ec59e69df3 |
| 1 | -Subproject commit c9b3e95b5c15b118e55522bd92963038c6a88160 |
|
| 1 | +Subproject commit 60f432b76871bd7787df07dd3e2a567caba393f5 |
| ... | ... | @@ -91,6 +91,80 @@ See also Note [Width of parameters] for some more motivation. |
| 91 | 91 | |
| 92 | 92 | /* #define INTERP_STATS */
|
| 93 | 93 | |
| 94 | +// Note [Instruction dispatch in the bytecode interpreter]
|
|
| 95 | +// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
| 96 | +// Like all bytecode interpreters out there, instruction dispatch is
|
|
| 97 | +// the backbone of our bytecode interpreter:
|
|
| 98 | +//
|
|
| 99 | +// - Each instruction starts with a unique integer tag
|
|
| 100 | +// - Each instruction has a piece of code to handle it
|
|
| 101 | +// - Fetch next instruction's tag, interpret, repeat
|
|
| 102 | +//
|
|
| 103 | +// There are two classical approaches to organize the interpreter loop
|
|
| 104 | +// and implement instruction dispatch:
|
|
| 105 | +//
|
|
| 106 | +// 1. switch-case: fetch the instruction tag, then a switch statement
|
|
| 107 | +// contains each instruction's handler code as a case within it.
|
|
| 108 | +// This is the simplest and most portable approach, but the
|
|
| 109 | +// compiler often generates suboptimal code that involves two jumps
|
|
| 110 | +// per instruction: the first one that jumps back to the switch
|
|
| 111 | +// statement, followed by the second one that jumps to the handler
|
|
| 112 | +// case statement.
|
|
| 113 | +// 2. computed-goto (direct threaded code): GNU C has an extension
|
|
| 114 | +// (https://gcc.gnu.org/onlinedocs/gcc/Labels-as-Values.html) that
|
|
| 115 | +// allows storing a code label as a pointer and using the goto
|
|
| 116 | +// statement to jump to such a pointer. So we can organize the
|
|
| 117 | +// handler code as a code block under a label, have a pointer array
|
|
| 118 | +// that maps an instruction tag to its handler's code label, then
|
|
| 119 | +// instruction dispatch can happen with a single jump after a
|
|
| 120 | +// memory load.
|
|
| 121 | +//
|
|
| 122 | +// A classical paper "The Structure and Performance of Efficient
|
|
| 123 | +// Interpreters" by M. Anton Ertl and David Gregg in 2003 explains it
|
|
| 124 | +// in further details with profiling data:
|
|
| 125 | +// https://jilp.org/vol5/v5paper12.pdf. There exist more subtle issues
|
|
| 126 | +// like interaction with modern CPU's branch predictors, though in
|
|
| 127 | +// practice computed-goto does outperform switch-case, and I've
|
|
| 128 | +// observed around 10%-15% wall clock time speedup in simple
|
|
| 129 | +// benchmarks, so our bytecode interpreter now defaults to using
|
|
| 130 | +// computed-goto when applicable, and falls back to switch-case in
|
|
| 131 | +// other cases.
|
|
| 132 | +//
|
|
| 133 | +// The COMPUTED_GOTO macro is defined when we use computed-goto. We
|
|
| 134 | +// don't do autoconf feature detection since it works with all
|
|
| 135 | +// versions of gcc/clang on all platforms we currently support.
|
|
| 136 | +// Exceptions include:
|
|
| 137 | +//
|
|
| 138 | +// - When DEBUG or other macros are enabled so that there's extra
|
|
| 139 | +// logic per instruction: assertions, statistics, etc. To make
|
|
| 140 | +// computed-goto support those would need us to duplicate the extra
|
|
| 141 | +// code in every instruction's handler code block, not really worth
|
|
| 142 | +// it when speed is not the primary concern.
|
|
| 143 | +// - On wasm, because wasm prohibits goto anyway and LLVM has to lower
|
|
| 144 | +// goto in C to br_table, so there's no performance benefit of
|
|
| 145 | +// computed-goto, only slight penalty due to an extra load from the
|
|
| 146 | +// user-defined dispatch table in the linear memory.
|
|
| 147 | +//
|
|
| 148 | +// The source of truth for our bytecode definition is
|
|
| 149 | +// rts/include/rts/Bytecodes.h. For each bytecode `#define bci_FOO
|
|
| 150 | +// tag`, we have jumptable[tag] which stores the 32-bit offset
|
|
| 151 | +// `&&lbl_bci_FOO - &&lbl_bci_DEFAULT`, so the goto destination can
|
|
| 152 | +// always be computed by adding the jumptable[tag] offset to the base
|
|
| 153 | +// address `&&lbl_bci_DEFAULT`. Whenever you change the bytecode
|
|
| 154 | +// definitions, always remember to update `jumptable` as well!
|
|
| 155 | + |
|
| 156 | +#if !defined(DEBUG) && !defined(ASSERTS_ENABLED) && !defined(INTERP_STATS) && !defined(wasm32_HOST_ARCH)
|
|
| 157 | +#define COMPUTED_GOTO
|
|
| 158 | +#endif
|
|
| 159 | + |
|
| 160 | +#if defined(COMPUTED_GOTO)
|
|
| 161 | +#pragma GCC diagnostic ignored "-Wpointer-arith"
|
|
| 162 | +#define INSTRUCTION(name) lbl_##name
|
|
| 163 | +#define NEXT_INSTRUCTION goto *(&&lbl_bci_DEFAULT + jumptable[(bci = instrs[bciPtr++]) & 0xFF])
|
|
| 164 | +#else
|
|
| 165 | +#define INSTRUCTION(name) case name
|
|
| 166 | +#define NEXT_INSTRUCTION goto nextInsn
|
|
| 167 | +#endif
|
|
| 94 | 168 | |
| 95 | 169 | /* Sp points to the lowest live word on the stack. */
|
| 96 | 170 | |
| ... | ... | @@ -1542,7 +1616,9 @@ run_BCO: |
| 1542 | 1616 | it_lastopc = 0; /* no opcode */
|
| 1543 | 1617 | #endif
|
| 1544 | 1618 | |
| 1619 | +#if !defined(COMPUTED_GOTO)
|
|
| 1545 | 1620 | nextInsn:
|
| 1621 | +#endif
|
|
| 1546 | 1622 | ASSERT(bciPtr < bcoSize);
|
| 1547 | 1623 | IF_DEBUG(interpreter,
|
| 1548 | 1624 | //if (do_print_stack) {
|
| ... | ... | @@ -1572,15 +1648,263 @@ run_BCO: |
| 1572 | 1648 | it_lastopc = (int)instrs[bciPtr];
|
| 1573 | 1649 | #endif
|
| 1574 | 1650 | |
| 1575 | - bci = BCO_NEXT;
|
|
| 1651 | +#if defined(COMPUTED_GOTO)
|
|
| 1652 | + static const int32_t jumptable[] = {
|
|
| 1653 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1654 | + &&lbl_bci_STKCHECK - &&lbl_bci_DEFAULT,
|
|
| 1655 | + &&lbl_bci_PUSH_L - &&lbl_bci_DEFAULT,
|
|
| 1656 | + &&lbl_bci_PUSH_LL - &&lbl_bci_DEFAULT,
|
|
| 1657 | + &&lbl_bci_PUSH_LLL - &&lbl_bci_DEFAULT,
|
|
| 1658 | + &&lbl_bci_PUSH8 - &&lbl_bci_DEFAULT,
|
|
| 1659 | + &&lbl_bci_PUSH16 - &&lbl_bci_DEFAULT,
|
|
| 1660 | + &&lbl_bci_PUSH32 - &&lbl_bci_DEFAULT,
|
|
| 1661 | + &&lbl_bci_PUSH8_W - &&lbl_bci_DEFAULT,
|
|
| 1662 | + &&lbl_bci_PUSH16_W - &&lbl_bci_DEFAULT,
|
|
| 1663 | + &&lbl_bci_PUSH32_W - &&lbl_bci_DEFAULT,
|
|
| 1664 | + &&lbl_bci_PUSH_G - &&lbl_bci_DEFAULT,
|
|
| 1665 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1666 | + &&lbl_bci_PUSH_ALTS_P - &&lbl_bci_DEFAULT,
|
|
| 1667 | + &&lbl_bci_PUSH_ALTS_N - &&lbl_bci_DEFAULT,
|
|
| 1668 | + &&lbl_bci_PUSH_ALTS_F - &&lbl_bci_DEFAULT,
|
|
| 1669 | + &&lbl_bci_PUSH_ALTS_D - &&lbl_bci_DEFAULT,
|
|
| 1670 | + &&lbl_bci_PUSH_ALTS_L - &&lbl_bci_DEFAULT,
|
|
| 1671 | + &&lbl_bci_PUSH_ALTS_V - &&lbl_bci_DEFAULT,
|
|
| 1672 | + &&lbl_bci_PUSH_PAD8 - &&lbl_bci_DEFAULT,
|
|
| 1673 | + &&lbl_bci_PUSH_PAD16 - &&lbl_bci_DEFAULT,
|
|
| 1674 | + &&lbl_bci_PUSH_PAD32 - &&lbl_bci_DEFAULT,
|
|
| 1675 | + &&lbl_bci_PUSH_UBX8 - &&lbl_bci_DEFAULT,
|
|
| 1676 | + &&lbl_bci_PUSH_UBX16 - &&lbl_bci_DEFAULT,
|
|
| 1677 | + &&lbl_bci_PUSH_UBX32 - &&lbl_bci_DEFAULT,
|
|
| 1678 | + &&lbl_bci_PUSH_UBX - &&lbl_bci_DEFAULT,
|
|
| 1679 | + &&lbl_bci_PUSH_APPLY_N - &&lbl_bci_DEFAULT,
|
|
| 1680 | + &&lbl_bci_PUSH_APPLY_F - &&lbl_bci_DEFAULT,
|
|
| 1681 | + &&lbl_bci_PUSH_APPLY_D - &&lbl_bci_DEFAULT,
|
|
| 1682 | + &&lbl_bci_PUSH_APPLY_L - &&lbl_bci_DEFAULT,
|
|
| 1683 | + &&lbl_bci_PUSH_APPLY_V - &&lbl_bci_DEFAULT,
|
|
| 1684 | + &&lbl_bci_PUSH_APPLY_P - &&lbl_bci_DEFAULT,
|
|
| 1685 | + &&lbl_bci_PUSH_APPLY_PP - &&lbl_bci_DEFAULT,
|
|
| 1686 | + &&lbl_bci_PUSH_APPLY_PPP - &&lbl_bci_DEFAULT,
|
|
| 1687 | + &&lbl_bci_PUSH_APPLY_PPPP - &&lbl_bci_DEFAULT,
|
|
| 1688 | + &&lbl_bci_PUSH_APPLY_PPPPP - &&lbl_bci_DEFAULT,
|
|
| 1689 | + &&lbl_bci_PUSH_APPLY_PPPPPP - &&lbl_bci_DEFAULT,
|
|
| 1690 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1691 | + &&lbl_bci_SLIDE - &&lbl_bci_DEFAULT,
|
|
| 1692 | + &&lbl_bci_ALLOC_AP - &&lbl_bci_DEFAULT,
|
|
| 1693 | + &&lbl_bci_ALLOC_AP_NOUPD - &&lbl_bci_DEFAULT,
|
|
| 1694 | + &&lbl_bci_ALLOC_PAP - &&lbl_bci_DEFAULT,
|
|
| 1695 | + &&lbl_bci_MKAP - &&lbl_bci_DEFAULT,
|
|
| 1696 | + &&lbl_bci_MKPAP - &&lbl_bci_DEFAULT,
|
|
| 1697 | + &&lbl_bci_UNPACK - &&lbl_bci_DEFAULT,
|
|
| 1698 | + &&lbl_bci_PACK - &&lbl_bci_DEFAULT,
|
|
| 1699 | + &&lbl_bci_TESTLT_I - &&lbl_bci_DEFAULT,
|
|
| 1700 | + &&lbl_bci_TESTEQ_I - &&lbl_bci_DEFAULT,
|
|
| 1701 | + &&lbl_bci_TESTLT_F - &&lbl_bci_DEFAULT,
|
|
| 1702 | + &&lbl_bci_TESTEQ_F - &&lbl_bci_DEFAULT,
|
|
| 1703 | + &&lbl_bci_TESTLT_D - &&lbl_bci_DEFAULT,
|
|
| 1704 | + &&lbl_bci_TESTEQ_D - &&lbl_bci_DEFAULT,
|
|
| 1705 | + &&lbl_bci_TESTLT_P - &&lbl_bci_DEFAULT,
|
|
| 1706 | + &&lbl_bci_TESTEQ_P - &&lbl_bci_DEFAULT,
|
|
| 1707 | + &&lbl_bci_CASEFAIL - &&lbl_bci_DEFAULT,
|
|
| 1708 | + &&lbl_bci_JMP - &&lbl_bci_DEFAULT,
|
|
| 1709 | + &&lbl_bci_CCALL - &&lbl_bci_DEFAULT,
|
|
| 1710 | + &&lbl_bci_SWIZZLE - &&lbl_bci_DEFAULT,
|
|
| 1711 | + &&lbl_bci_ENTER - &&lbl_bci_DEFAULT,
|
|
| 1712 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1713 | + &&lbl_bci_RETURN_P - &&lbl_bci_DEFAULT,
|
|
| 1714 | + &&lbl_bci_RETURN_N - &&lbl_bci_DEFAULT,
|
|
| 1715 | + &&lbl_bci_RETURN_F - &&lbl_bci_DEFAULT,
|
|
| 1716 | + &&lbl_bci_RETURN_D - &&lbl_bci_DEFAULT,
|
|
| 1717 | + &&lbl_bci_RETURN_L - &&lbl_bci_DEFAULT,
|
|
| 1718 | + &&lbl_bci_RETURN_V - &&lbl_bci_DEFAULT,
|
|
| 1719 | + &&lbl_bci_BRK_FUN - &&lbl_bci_DEFAULT,
|
|
| 1720 | + &&lbl_bci_TESTLT_W - &&lbl_bci_DEFAULT,
|
|
| 1721 | + &&lbl_bci_TESTEQ_W - &&lbl_bci_DEFAULT,
|
|
| 1722 | + &&lbl_bci_RETURN_T - &&lbl_bci_DEFAULT,
|
|
| 1723 | + &&lbl_bci_PUSH_ALTS_T - &&lbl_bci_DEFAULT,
|
|
| 1724 | + &&lbl_bci_TESTLT_I64 - &&lbl_bci_DEFAULT,
|
|
| 1725 | + &&lbl_bci_TESTEQ_I64 - &&lbl_bci_DEFAULT,
|
|
| 1726 | + &&lbl_bci_TESTLT_I32 - &&lbl_bci_DEFAULT,
|
|
| 1727 | + &&lbl_bci_TESTEQ_I32 - &&lbl_bci_DEFAULT,
|
|
| 1728 | + &&lbl_bci_TESTLT_I16 - &&lbl_bci_DEFAULT,
|
|
| 1729 | + &&lbl_bci_TESTEQ_I16 - &&lbl_bci_DEFAULT,
|
|
| 1730 | + &&lbl_bci_TESTLT_I8 - &&lbl_bci_DEFAULT,
|
|
| 1731 | + &&lbl_bci_TESTEQ_I8 - &&lbl_bci_DEFAULT,
|
|
| 1732 | + &&lbl_bci_TESTLT_W64 - &&lbl_bci_DEFAULT,
|
|
| 1733 | + &&lbl_bci_TESTEQ_W64 - &&lbl_bci_DEFAULT,
|
|
| 1734 | + &&lbl_bci_TESTLT_W32 - &&lbl_bci_DEFAULT,
|
|
| 1735 | + &&lbl_bci_TESTEQ_W32 - &&lbl_bci_DEFAULT,
|
|
| 1736 | + &&lbl_bci_TESTLT_W16 - &&lbl_bci_DEFAULT,
|
|
| 1737 | + &&lbl_bci_TESTEQ_W16 - &&lbl_bci_DEFAULT,
|
|
| 1738 | + &&lbl_bci_TESTLT_W8 - &&lbl_bci_DEFAULT,
|
|
| 1739 | + &&lbl_bci_TESTEQ_W8 - &&lbl_bci_DEFAULT,
|
|
| 1740 | + &&lbl_bci_PRIMCALL - &&lbl_bci_DEFAULT,
|
|
| 1741 | + &&lbl_bci_BCO_NAME - &&lbl_bci_DEFAULT,
|
|
| 1742 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1743 | + &&lbl_bci_OP_ADD_64 - &&lbl_bci_DEFAULT,
|
|
| 1744 | + &&lbl_bci_OP_SUB_64 - &&lbl_bci_DEFAULT,
|
|
| 1745 | + &&lbl_bci_OP_AND_64 - &&lbl_bci_DEFAULT,
|
|
| 1746 | + &&lbl_bci_OP_XOR_64 - &&lbl_bci_DEFAULT,
|
|
| 1747 | + &&lbl_bci_OP_NOT_64 - &&lbl_bci_DEFAULT,
|
|
| 1748 | + &&lbl_bci_OP_NEG_64 - &&lbl_bci_DEFAULT,
|
|
| 1749 | + &&lbl_bci_OP_MUL_64 - &&lbl_bci_DEFAULT,
|
|
| 1750 | + &&lbl_bci_OP_SHL_64 - &&lbl_bci_DEFAULT,
|
|
| 1751 | + &&lbl_bci_OP_ASR_64 - &&lbl_bci_DEFAULT,
|
|
| 1752 | + &&lbl_bci_OP_LSR_64 - &&lbl_bci_DEFAULT,
|
|
| 1753 | + &&lbl_bci_OP_OR_64 - &&lbl_bci_DEFAULT,
|
|
| 1754 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1755 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1756 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1757 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1758 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1759 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1760 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1761 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1762 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1763 | + &&lbl_bci_OP_NEQ_64 - &&lbl_bci_DEFAULT,
|
|
| 1764 | + &&lbl_bci_OP_EQ_64 - &&lbl_bci_DEFAULT,
|
|
| 1765 | + &&lbl_bci_OP_U_GE_64 - &&lbl_bci_DEFAULT,
|
|
| 1766 | + &&lbl_bci_OP_U_GT_64 - &&lbl_bci_DEFAULT,
|
|
| 1767 | + &&lbl_bci_OP_U_LT_64 - &&lbl_bci_DEFAULT,
|
|
| 1768 | + &&lbl_bci_OP_U_LE_64 - &&lbl_bci_DEFAULT,
|
|
| 1769 | + &&lbl_bci_OP_S_GE_64 - &&lbl_bci_DEFAULT,
|
|
| 1770 | + &&lbl_bci_OP_S_GT_64 - &&lbl_bci_DEFAULT,
|
|
| 1771 | + &&lbl_bci_OP_S_LT_64 - &&lbl_bci_DEFAULT,
|
|
| 1772 | + &&lbl_bci_OP_S_LE_64 - &&lbl_bci_DEFAULT,
|
|
| 1773 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1774 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1775 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1776 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1777 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1778 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1779 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1780 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1781 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1782 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1783 | + &&lbl_bci_OP_ADD_32 - &&lbl_bci_DEFAULT,
|
|
| 1784 | + &&lbl_bci_OP_SUB_32 - &&lbl_bci_DEFAULT,
|
|
| 1785 | + &&lbl_bci_OP_AND_32 - &&lbl_bci_DEFAULT,
|
|
| 1786 | + &&lbl_bci_OP_XOR_32 - &&lbl_bci_DEFAULT,
|
|
| 1787 | + &&lbl_bci_OP_NOT_32 - &&lbl_bci_DEFAULT,
|
|
| 1788 | + &&lbl_bci_OP_NEG_32 - &&lbl_bci_DEFAULT,
|
|
| 1789 | + &&lbl_bci_OP_MUL_32 - &&lbl_bci_DEFAULT,
|
|
| 1790 | + &&lbl_bci_OP_SHL_32 - &&lbl_bci_DEFAULT,
|
|
| 1791 | + &&lbl_bci_OP_ASR_32 - &&lbl_bci_DEFAULT,
|
|
| 1792 | + &&lbl_bci_OP_LSR_32 - &&lbl_bci_DEFAULT,
|
|
| 1793 | + &&lbl_bci_OP_OR_32 - &&lbl_bci_DEFAULT,
|
|
| 1794 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1795 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1796 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1797 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1798 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1799 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1800 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1801 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1802 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1803 | + &&lbl_bci_OP_NEQ_32 - &&lbl_bci_DEFAULT,
|
|
| 1804 | + &&lbl_bci_OP_EQ_32 - &&lbl_bci_DEFAULT,
|
|
| 1805 | + &&lbl_bci_OP_U_GE_32 - &&lbl_bci_DEFAULT,
|
|
| 1806 | + &&lbl_bci_OP_U_GT_32 - &&lbl_bci_DEFAULT,
|
|
| 1807 | + &&lbl_bci_OP_U_LT_32 - &&lbl_bci_DEFAULT,
|
|
| 1808 | + &&lbl_bci_OP_U_LE_32 - &&lbl_bci_DEFAULT,
|
|
| 1809 | + &&lbl_bci_OP_S_GE_32 - &&lbl_bci_DEFAULT,
|
|
| 1810 | + &&lbl_bci_OP_S_GT_32 - &&lbl_bci_DEFAULT,
|
|
| 1811 | + &&lbl_bci_OP_S_LT_32 - &&lbl_bci_DEFAULT,
|
|
| 1812 | + &&lbl_bci_OP_S_LE_32 - &&lbl_bci_DEFAULT,
|
|
| 1813 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1814 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1815 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1816 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1817 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1818 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1819 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1820 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1821 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1822 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1823 | + &&lbl_bci_OP_ADD_16 - &&lbl_bci_DEFAULT,
|
|
| 1824 | + &&lbl_bci_OP_SUB_16 - &&lbl_bci_DEFAULT,
|
|
| 1825 | + &&lbl_bci_OP_AND_16 - &&lbl_bci_DEFAULT,
|
|
| 1826 | + &&lbl_bci_OP_XOR_16 - &&lbl_bci_DEFAULT,
|
|
| 1827 | + &&lbl_bci_OP_NOT_16 - &&lbl_bci_DEFAULT,
|
|
| 1828 | + &&lbl_bci_OP_NEG_16 - &&lbl_bci_DEFAULT,
|
|
| 1829 | + &&lbl_bci_OP_MUL_16 - &&lbl_bci_DEFAULT,
|
|
| 1830 | + &&lbl_bci_OP_SHL_16 - &&lbl_bci_DEFAULT,
|
|
| 1831 | + &&lbl_bci_OP_ASR_16 - &&lbl_bci_DEFAULT,
|
|
| 1832 | + &&lbl_bci_OP_LSR_16 - &&lbl_bci_DEFAULT,
|
|
| 1833 | + &&lbl_bci_OP_OR_16 - &&lbl_bci_DEFAULT,
|
|
| 1834 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1835 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1836 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1837 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1838 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1839 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1840 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1841 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1842 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1843 | + &&lbl_bci_OP_NEQ_16 - &&lbl_bci_DEFAULT,
|
|
| 1844 | + &&lbl_bci_OP_EQ_16 - &&lbl_bci_DEFAULT,
|
|
| 1845 | + &&lbl_bci_OP_U_GE_16 - &&lbl_bci_DEFAULT,
|
|
| 1846 | + &&lbl_bci_OP_U_GT_16 - &&lbl_bci_DEFAULT,
|
|
| 1847 | + &&lbl_bci_OP_U_LT_16 - &&lbl_bci_DEFAULT,
|
|
| 1848 | + &&lbl_bci_OP_U_LE_16 - &&lbl_bci_DEFAULT,
|
|
| 1849 | + &&lbl_bci_OP_S_GE_16 - &&lbl_bci_DEFAULT,
|
|
| 1850 | + &&lbl_bci_OP_S_GT_16 - &&lbl_bci_DEFAULT,
|
|
| 1851 | + &&lbl_bci_OP_S_LT_16 - &&lbl_bci_DEFAULT,
|
|
| 1852 | + &&lbl_bci_OP_S_LE_16 - &&lbl_bci_DEFAULT,
|
|
| 1853 | + &&lbl_bci_OP_ADD_08 - &&lbl_bci_DEFAULT,
|
|
| 1854 | + &&lbl_bci_OP_SUB_08 - &&lbl_bci_DEFAULT,
|
|
| 1855 | + &&lbl_bci_OP_AND_08 - &&lbl_bci_DEFAULT,
|
|
| 1856 | + &&lbl_bci_OP_XOR_08 - &&lbl_bci_DEFAULT,
|
|
| 1857 | + &&lbl_bci_OP_NOT_08 - &&lbl_bci_DEFAULT,
|
|
| 1858 | + &&lbl_bci_OP_NEG_08 - &&lbl_bci_DEFAULT,
|
|
| 1859 | + &&lbl_bci_OP_MUL_08 - &&lbl_bci_DEFAULT,
|
|
| 1860 | + &&lbl_bci_OP_SHL_08 - &&lbl_bci_DEFAULT,
|
|
| 1861 | + &&lbl_bci_OP_ASR_08 - &&lbl_bci_DEFAULT,
|
|
| 1862 | + &&lbl_bci_OP_LSR_08 - &&lbl_bci_DEFAULT,
|
|
| 1863 | + &&lbl_bci_OP_OR_08 - &&lbl_bci_DEFAULT,
|
|
| 1864 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1865 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1866 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1867 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1868 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1869 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1870 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1871 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1872 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1873 | + &&lbl_bci_OP_NEQ_08 - &&lbl_bci_DEFAULT,
|
|
| 1874 | + &&lbl_bci_OP_EQ_08 - &&lbl_bci_DEFAULT,
|
|
| 1875 | + &&lbl_bci_OP_U_GE_08 - &&lbl_bci_DEFAULT,
|
|
| 1876 | + &&lbl_bci_OP_U_GT_08 - &&lbl_bci_DEFAULT,
|
|
| 1877 | + &&lbl_bci_OP_U_LT_08 - &&lbl_bci_DEFAULT,
|
|
| 1878 | + &&lbl_bci_OP_U_LE_08 - &&lbl_bci_DEFAULT,
|
|
| 1879 | + &&lbl_bci_OP_S_GE_08 - &&lbl_bci_DEFAULT,
|
|
| 1880 | + &&lbl_bci_OP_S_GT_08 - &&lbl_bci_DEFAULT,
|
|
| 1881 | + &&lbl_bci_OP_S_LT_08 - &&lbl_bci_DEFAULT,
|
|
| 1882 | + &&lbl_bci_OP_S_LE_08 - &&lbl_bci_DEFAULT,
|
|
| 1883 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1884 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1885 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1886 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1887 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1888 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1889 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1890 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1891 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1892 | + &&lbl_bci_DEFAULT - &&lbl_bci_DEFAULT,
|
|
| 1893 | + &&lbl_bci_OP_INDEX_ADDR_08 - &&lbl_bci_DEFAULT,
|
|
| 1894 | + &&lbl_bci_OP_INDEX_ADDR_16 - &&lbl_bci_DEFAULT,
|
|
| 1895 | + &&lbl_bci_OP_INDEX_ADDR_32 - &&lbl_bci_DEFAULT,
|
|
| 1896 | + &&lbl_bci_OP_INDEX_ADDR_64 - &&lbl_bci_DEFAULT};
|
|
| 1897 | + NEXT_INSTRUCTION;
|
|
| 1898 | +#else
|
|
| 1899 | + bci = BCO_NEXT;
|
|
| 1576 | 1900 | /* We use the high 8 bits for flags. The highest of which is
|
| 1577 | 1901 | * currently allocated to LARGE_ARGS */
|
| 1578 | 1902 | ASSERT((bci & 0xFF00) == (bci & ( bci_FLAG_LARGE_ARGS )));
|
| 1579 | - |
|
| 1580 | 1903 | switch (bci & 0xFF) {
|
| 1904 | +#endif
|
|
| 1581 | 1905 | |
| 1582 | 1906 | /* check for a breakpoint on the beginning of a BCO */
|
| 1583 | - case bci_BRK_FUN:
|
|
| 1907 | + INSTRUCTION(bci_BRK_FUN):
|
|
| 1584 | 1908 | {
|
| 1585 | 1909 | W_ arg1_brk_array, arg2_info_mod_name, arg3_info_mod_id, arg4_info_index;
|
| 1586 | 1910 | #if defined(PROFILING)
|
| ... | ... | @@ -1779,10 +2103,10 @@ run_BCO: |
| 1779 | 2103 | cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
|
| 1780 | 2104 | |
| 1781 | 2105 | // continue normal execution of the byte code instructions
|
| 1782 | - goto nextInsn;
|
|
| 2106 | + NEXT_INSTRUCTION;
|
|
| 1783 | 2107 | }
|
| 1784 | 2108 | |
| 1785 | - case bci_STKCHECK: {
|
|
| 2109 | + INSTRUCTION(bci_STKCHECK): {
|
|
| 1786 | 2110 | // Explicit stack check at the beginning of a function
|
| 1787 | 2111 | // *only* (stack checks in case alternatives are
|
| 1788 | 2112 | // propagated to the enclosing function).
|
| ... | ... | @@ -1793,27 +2117,27 @@ run_BCO: |
| 1793 | 2117 | SpW(0) = (W_)&stg_apply_interp_info;
|
| 1794 | 2118 | RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
|
| 1795 | 2119 | } else {
|
| 1796 | - goto nextInsn;
|
|
| 2120 | + NEXT_INSTRUCTION;
|
|
| 1797 | 2121 | }
|
| 1798 | 2122 | }
|
| 1799 | 2123 | |
| 1800 | - case bci_PUSH_L: {
|
|
| 2124 | + INSTRUCTION(bci_PUSH_L): {
|
|
| 1801 | 2125 | W_ o1 = BCO_GET_LARGE_ARG;
|
| 1802 | 2126 | SpW(-1) = ReadSpW(o1);
|
| 1803 | 2127 | Sp_subW(1);
|
| 1804 | - goto nextInsn;
|
|
| 2128 | + NEXT_INSTRUCTION;
|
|
| 1805 | 2129 | }
|
| 1806 | 2130 | |
| 1807 | - case bci_PUSH_LL: {
|
|
| 2131 | + INSTRUCTION(bci_PUSH_LL): {
|
|
| 1808 | 2132 | W_ o1 = BCO_GET_LARGE_ARG;
|
| 1809 | 2133 | W_ o2 = BCO_GET_LARGE_ARG;
|
| 1810 | 2134 | SpW(-1) = ReadSpW(o1);
|
| 1811 | 2135 | SpW(-2) = ReadSpW(o2);
|
| 1812 | 2136 | Sp_subW(2);
|
| 1813 | - goto nextInsn;
|
|
| 2137 | + NEXT_INSTRUCTION;
|
|
| 1814 | 2138 | }
|
| 1815 | 2139 | |
| 1816 | - case bci_PUSH_LLL: {
|
|
| 2140 | + INSTRUCTION(bci_PUSH_LLL): {
|
|
| 1817 | 2141 | W_ o1 = BCO_GET_LARGE_ARG;
|
| 1818 | 2142 | W_ o2 = BCO_GET_LARGE_ARG;
|
| 1819 | 2143 | W_ o3 = BCO_GET_LARGE_ARG;
|
| ... | ... | @@ -1821,52 +2145,52 @@ run_BCO: |
| 1821 | 2145 | SpW(-2) = ReadSpW(o2);
|
| 1822 | 2146 | SpW(-3) = ReadSpW(o3);
|
| 1823 | 2147 | Sp_subW(3);
|
| 1824 | - goto nextInsn;
|
|
| 2148 | + NEXT_INSTRUCTION;
|
|
| 1825 | 2149 | }
|
| 1826 | 2150 | |
| 1827 | - case bci_PUSH8: {
|
|
| 2151 | + INSTRUCTION(bci_PUSH8): {
|
|
| 1828 | 2152 | W_ off = BCO_GET_LARGE_ARG;
|
| 1829 | 2153 | Sp_subB(1);
|
| 1830 | 2154 | *(StgWord8*)Sp = (StgWord8) (ReadSpB(off+1));
|
| 1831 | - goto nextInsn;
|
|
| 2155 | + NEXT_INSTRUCTION;
|
|
| 1832 | 2156 | }
|
| 1833 | 2157 | |
| 1834 | - case bci_PUSH16: {
|
|
| 2158 | + INSTRUCTION(bci_PUSH16): {
|
|
| 1835 | 2159 | W_ off = BCO_GET_LARGE_ARG;
|
| 1836 | 2160 | Sp_subB(2);
|
| 1837 | 2161 | *(StgWord16*)Sp = (StgWord16) (ReadSpB(off+2));
|
| 1838 | - goto nextInsn;
|
|
| 2162 | + NEXT_INSTRUCTION;
|
|
| 1839 | 2163 | }
|
| 1840 | 2164 | |
| 1841 | - case bci_PUSH32: {
|
|
| 2165 | + INSTRUCTION(bci_PUSH32): {
|
|
| 1842 | 2166 | W_ off = BCO_GET_LARGE_ARG;
|
| 1843 | 2167 | Sp_subB(4);
|
| 1844 | 2168 | *(StgWord32*)Sp = (StgWord32) (ReadSpB(off+4));
|
| 1845 | - goto nextInsn;
|
|
| 2169 | + NEXT_INSTRUCTION;
|
|
| 1846 | 2170 | }
|
| 1847 | 2171 | |
| 1848 | - case bci_PUSH8_W: {
|
|
| 2172 | + INSTRUCTION(bci_PUSH8_W): {
|
|
| 1849 | 2173 | W_ off = BCO_GET_LARGE_ARG;
|
| 1850 | 2174 | *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord8) (ReadSpB(off)));
|
| 1851 | 2175 | Sp_subW(1);
|
| 1852 | - goto nextInsn;
|
|
| 2176 | + NEXT_INSTRUCTION;
|
|
| 1853 | 2177 | }
|
| 1854 | 2178 | |
| 1855 | - case bci_PUSH16_W: {
|
|
| 2179 | + INSTRUCTION(bci_PUSH16_W): {
|
|
| 1856 | 2180 | W_ off = BCO_GET_LARGE_ARG;
|
| 1857 | 2181 | *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord16) (ReadSpB(off)));
|
| 1858 | 2182 | Sp_subW(1);
|
| 1859 | - goto nextInsn;
|
|
| 2183 | + NEXT_INSTRUCTION;
|
|
| 1860 | 2184 | }
|
| 1861 | 2185 | |
| 1862 | - case bci_PUSH32_W: {
|
|
| 2186 | + INSTRUCTION(bci_PUSH32_W): {
|
|
| 1863 | 2187 | W_ off = BCO_GET_LARGE_ARG;
|
| 1864 | 2188 | *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord32) (ReadSpB(off)));
|
| 1865 | 2189 | Sp_subW(1);
|
| 1866 | - goto nextInsn;
|
|
| 2190 | + NEXT_INSTRUCTION;
|
|
| 1867 | 2191 | }
|
| 1868 | 2192 | |
| 1869 | - case bci_PUSH_G: {
|
|
| 2193 | + INSTRUCTION(bci_PUSH_G): {
|
|
| 1870 | 2194 | W_ o1 = BCO_GET_LARGE_ARG;
|
| 1871 | 2195 | StgClosure *tagged_obj = (StgClosure*) BCO_PTR(o1);
|
| 1872 | 2196 | |
| ... | ... | @@ -1905,10 +2229,10 @@ run_BCO: |
| 1905 | 2229 | |
| 1906 | 2230 | SpW(-1) = (W_) tagged_obj;
|
| 1907 | 2231 | Sp_subW(1);
|
| 1908 | - goto nextInsn;
|
|
| 2232 | + NEXT_INSTRUCTION;
|
|
| 1909 | 2233 | }
|
| 1910 | 2234 | |
| 1911 | - case bci_PUSH_ALTS_P: {
|
|
| 2235 | + INSTRUCTION(bci_PUSH_ALTS_P): {
|
|
| 1912 | 2236 | W_ o_bco = BCO_GET_LARGE_ARG;
|
| 1913 | 2237 | Sp_subW(2);
|
| 1914 | 2238 | SpW(1) = BCO_PTR(o_bco);
|
| ... | ... | @@ -1918,10 +2242,10 @@ run_BCO: |
| 1918 | 2242 | SpW(1) = (W_)cap->r.rCCCS;
|
| 1919 | 2243 | SpW(0) = (W_)&stg_restore_cccs_d_info;
|
| 1920 | 2244 | #endif
|
| 1921 | - goto nextInsn;
|
|
| 2245 | + NEXT_INSTRUCTION;
|
|
| 1922 | 2246 | }
|
| 1923 | 2247 | |
| 1924 | - case bci_PUSH_ALTS_N: {
|
|
| 2248 | + INSTRUCTION(bci_PUSH_ALTS_N): {
|
|
| 1925 | 2249 | W_ o_bco = BCO_GET_LARGE_ARG;
|
| 1926 | 2250 | SpW(-2) = (W_)&stg_ctoi_R1n_info;
|
| 1927 | 2251 | SpW(-1) = BCO_PTR(o_bco);
|
| ... | ... | @@ -1931,10 +2255,10 @@ run_BCO: |
| 1931 | 2255 | SpW(1) = (W_)cap->r.rCCCS;
|
| 1932 | 2256 | SpW(0) = (W_)&stg_restore_cccs_d_info;
|
| 1933 | 2257 | #endif
|
| 1934 | - goto nextInsn;
|
|
| 2258 | + NEXT_INSTRUCTION;
|
|
| 1935 | 2259 | }
|
| 1936 | 2260 | |
| 1937 | - case bci_PUSH_ALTS_F: {
|
|
| 2261 | + INSTRUCTION(bci_PUSH_ALTS_F): {
|
|
| 1938 | 2262 | W_ o_bco = BCO_GET_LARGE_ARG;
|
| 1939 | 2263 | SpW(-2) = (W_)&stg_ctoi_F1_info;
|
| 1940 | 2264 | SpW(-1) = BCO_PTR(o_bco);
|
| ... | ... | @@ -1944,10 +2268,10 @@ run_BCO: |
| 1944 | 2268 | SpW(1) = (W_)cap->r.rCCCS;
|
| 1945 | 2269 | SpW(0) = (W_)&stg_restore_cccs_d_info;
|
| 1946 | 2270 | #endif
|
| 1947 | - goto nextInsn;
|
|
| 2271 | + NEXT_INSTRUCTION;
|
|
| 1948 | 2272 | }
|
| 1949 | 2273 | |
| 1950 | - case bci_PUSH_ALTS_D: {
|
|
| 2274 | + INSTRUCTION(bci_PUSH_ALTS_D): {
|
|
| 1951 | 2275 | W_ o_bco = BCO_GET_LARGE_ARG;
|
| 1952 | 2276 | SpW(-2) = (W_)&stg_ctoi_D1_info;
|
| 1953 | 2277 | SpW(-1) = BCO_PTR(o_bco);
|
| ... | ... | @@ -1957,10 +2281,10 @@ run_BCO: |
| 1957 | 2281 | SpW(1) = (W_)cap->r.rCCCS;
|
| 1958 | 2282 | SpW(0) = (W_)&stg_restore_cccs_d_info;
|
| 1959 | 2283 | #endif
|
| 1960 | - goto nextInsn;
|
|
| 2284 | + NEXT_INSTRUCTION;
|
|
| 1961 | 2285 | }
|
| 1962 | 2286 | |
| 1963 | - case bci_PUSH_ALTS_L: {
|
|
| 2287 | + INSTRUCTION(bci_PUSH_ALTS_L): {
|
|
| 1964 | 2288 | W_ o_bco = BCO_GET_LARGE_ARG;
|
| 1965 | 2289 | SpW(-2) = (W_)&stg_ctoi_L1_info;
|
| 1966 | 2290 | SpW(-1) = BCO_PTR(o_bco);
|
| ... | ... | @@ -1970,10 +2294,10 @@ run_BCO: |
| 1970 | 2294 | SpW(1) = (W_)cap->r.rCCCS;
|
| 1971 | 2295 | SpW(0) = (W_)&stg_restore_cccs_d_info;
|
| 1972 | 2296 | #endif
|
| 1973 | - goto nextInsn;
|
|
| 2297 | + NEXT_INSTRUCTION;
|
|
| 1974 | 2298 | }
|
| 1975 | 2299 | |
| 1976 | - case bci_PUSH_ALTS_V: {
|
|
| 2300 | + INSTRUCTION(bci_PUSH_ALTS_V): {
|
|
| 1977 | 2301 | W_ o_bco = BCO_GET_LARGE_ARG;
|
| 1978 | 2302 | SpW(-2) = (W_)&stg_ctoi_V_info;
|
| 1979 | 2303 | SpW(-1) = BCO_PTR(o_bco);
|
| ... | ... | @@ -1983,10 +2307,10 @@ run_BCO: |
| 1983 | 2307 | SpW(1) = (W_)cap->r.rCCCS;
|
| 1984 | 2308 | SpW(0) = (W_)&stg_restore_cccs_d_info;
|
| 1985 | 2309 | #endif
|
| 1986 | - goto nextInsn;
|
|
| 2310 | + NEXT_INSTRUCTION;
|
|
| 1987 | 2311 | }
|
| 1988 | 2312 | |
| 1989 | - case bci_PUSH_ALTS_T: {
|
|
| 2313 | + INSTRUCTION(bci_PUSH_ALTS_T): {
|
|
| 1990 | 2314 | W_ o_bco = BCO_GET_LARGE_ARG;
|
| 1991 | 2315 | W_ tuple_info = (W_)BCO_LIT(BCO_GET_LARGE_ARG);
|
| 1992 | 2316 | W_ o_tuple_bco = BCO_GET_LARGE_ARG;
|
| ... | ... | @@ -2006,83 +2330,83 @@ run_BCO: |
| 2006 | 2330 | W_ ctoi_t_offset = (W_) ctoi_tuple_infos[tuple_stack_words];
|
| 2007 | 2331 | SpW(-4) = ctoi_t_offset;
|
| 2008 | 2332 | Sp_subW(4);
|
| 2009 | - goto nextInsn;
|
|
| 2333 | + NEXT_INSTRUCTION;
|
|
| 2010 | 2334 | }
|
| 2011 | 2335 | |
| 2012 | - case bci_PUSH_APPLY_N:
|
|
| 2336 | + INSTRUCTION(bci_PUSH_APPLY_N):
|
|
| 2013 | 2337 | Sp_subW(1); SpW(0) = (W_)&stg_ap_n_info;
|
| 2014 | - goto nextInsn;
|
|
| 2015 | - case bci_PUSH_APPLY_V:
|
|
| 2338 | + NEXT_INSTRUCTION;
|
|
| 2339 | + INSTRUCTION(bci_PUSH_APPLY_V):
|
|
| 2016 | 2340 | Sp_subW(1); SpW(0) = (W_)&stg_ap_v_info;
|
| 2017 | - goto nextInsn;
|
|
| 2018 | - case bci_PUSH_APPLY_F:
|
|
| 2341 | + NEXT_INSTRUCTION;
|
|
| 2342 | + INSTRUCTION(bci_PUSH_APPLY_F):
|
|
| 2019 | 2343 | Sp_subW(1); SpW(0) = (W_)&stg_ap_f_info;
|
| 2020 | - goto nextInsn;
|
|
| 2021 | - case bci_PUSH_APPLY_D:
|
|
| 2344 | + NEXT_INSTRUCTION;
|
|
| 2345 | + INSTRUCTION(bci_PUSH_APPLY_D):
|
|
| 2022 | 2346 | Sp_subW(1); SpW(0) = (W_)&stg_ap_d_info;
|
| 2023 | - goto nextInsn;
|
|
| 2024 | - case bci_PUSH_APPLY_L:
|
|
| 2347 | + NEXT_INSTRUCTION;
|
|
| 2348 | + INSTRUCTION(bci_PUSH_APPLY_L):
|
|
| 2025 | 2349 | Sp_subW(1); SpW(0) = (W_)&stg_ap_l_info;
|
| 2026 | - goto nextInsn;
|
|
| 2027 | - case bci_PUSH_APPLY_P:
|
|
| 2350 | + NEXT_INSTRUCTION;
|
|
| 2351 | + INSTRUCTION(bci_PUSH_APPLY_P):
|
|
| 2028 | 2352 | Sp_subW(1); SpW(0) = (W_)&stg_ap_p_info;
|
| 2029 | - goto nextInsn;
|
|
| 2030 | - case bci_PUSH_APPLY_PP:
|
|
| 2353 | + NEXT_INSTRUCTION;
|
|
| 2354 | + INSTRUCTION(bci_PUSH_APPLY_PP):
|
|
| 2031 | 2355 | Sp_subW(1); SpW(0) = (W_)&stg_ap_pp_info;
|
| 2032 | - goto nextInsn;
|
|
| 2033 | - case bci_PUSH_APPLY_PPP:
|
|
| 2356 | + NEXT_INSTRUCTION;
|
|
| 2357 | + INSTRUCTION(bci_PUSH_APPLY_PPP):
|
|
| 2034 | 2358 | Sp_subW(1); SpW(0) = (W_)&stg_ap_ppp_info;
|
| 2035 | - goto nextInsn;
|
|
| 2036 | - case bci_PUSH_APPLY_PPPP:
|
|
| 2359 | + NEXT_INSTRUCTION;
|
|
| 2360 | + INSTRUCTION(bci_PUSH_APPLY_PPPP):
|
|
| 2037 | 2361 | Sp_subW(1); SpW(0) = (W_)&stg_ap_pppp_info;
|
| 2038 | - goto nextInsn;
|
|
| 2039 | - case bci_PUSH_APPLY_PPPPP:
|
|
| 2362 | + NEXT_INSTRUCTION;
|
|
| 2363 | + INSTRUCTION(bci_PUSH_APPLY_PPPPP):
|
|
| 2040 | 2364 | Sp_subW(1); SpW(0) = (W_)&stg_ap_ppppp_info;
|
| 2041 | - goto nextInsn;
|
|
| 2042 | - case bci_PUSH_APPLY_PPPPPP:
|
|
| 2365 | + NEXT_INSTRUCTION;
|
|
| 2366 | + INSTRUCTION(bci_PUSH_APPLY_PPPPPP):
|
|
| 2043 | 2367 | Sp_subW(1); SpW(0) = (W_)&stg_ap_pppppp_info;
|
| 2044 | - goto nextInsn;
|
|
| 2368 | + NEXT_INSTRUCTION;
|
|
| 2045 | 2369 | |
| 2046 | - case bci_PUSH_PAD8: {
|
|
| 2370 | + INSTRUCTION(bci_PUSH_PAD8): {
|
|
| 2047 | 2371 | Sp_subB(1);
|
| 2048 | 2372 | *(StgWord8*)Sp = 0;
|
| 2049 | - goto nextInsn;
|
|
| 2373 | + NEXT_INSTRUCTION;
|
|
| 2050 | 2374 | }
|
| 2051 | 2375 | |
| 2052 | - case bci_PUSH_PAD16: {
|
|
| 2376 | + INSTRUCTION(bci_PUSH_PAD16): {
|
|
| 2053 | 2377 | Sp_subB(2);
|
| 2054 | 2378 | *(StgWord16*)Sp = 0;
|
| 2055 | - goto nextInsn;
|
|
| 2379 | + NEXT_INSTRUCTION;
|
|
| 2056 | 2380 | }
|
| 2057 | 2381 | |
| 2058 | - case bci_PUSH_PAD32: {
|
|
| 2382 | + INSTRUCTION(bci_PUSH_PAD32): {
|
|
| 2059 | 2383 | Sp_subB(4);
|
| 2060 | 2384 | *(StgWord32*)Sp = 0;
|
| 2061 | - goto nextInsn;
|
|
| 2385 | + NEXT_INSTRUCTION;
|
|
| 2062 | 2386 | }
|
| 2063 | 2387 | |
| 2064 | - case bci_PUSH_UBX8: {
|
|
| 2388 | + INSTRUCTION(bci_PUSH_UBX8): {
|
|
| 2065 | 2389 | W_ o_lit = BCO_GET_LARGE_ARG;
|
| 2066 | 2390 | Sp_subB(1);
|
| 2067 | 2391 | *(StgWord8*)Sp = (StgWord8) BCO_LIT(o_lit);
|
| 2068 | - goto nextInsn;
|
|
| 2392 | + NEXT_INSTRUCTION;
|
|
| 2069 | 2393 | }
|
| 2070 | 2394 | |
| 2071 | - case bci_PUSH_UBX16: {
|
|
| 2395 | + INSTRUCTION(bci_PUSH_UBX16): {
|
|
| 2072 | 2396 | W_ o_lit = BCO_GET_LARGE_ARG;
|
| 2073 | 2397 | Sp_subB(2);
|
| 2074 | 2398 | *(StgWord16*)Sp = (StgWord16) BCO_LIT(o_lit);
|
| 2075 | - goto nextInsn;
|
|
| 2399 | + NEXT_INSTRUCTION;
|
|
| 2076 | 2400 | }
|
| 2077 | 2401 | |
| 2078 | - case bci_PUSH_UBX32: {
|
|
| 2402 | + INSTRUCTION(bci_PUSH_UBX32): {
|
|
| 2079 | 2403 | W_ o_lit = BCO_GET_LARGE_ARG;
|
| 2080 | 2404 | Sp_subB(4);
|
| 2081 | 2405 | *(StgWord32*)Sp = (StgWord32) BCO_LIT(o_lit);
|
| 2082 | - goto nextInsn;
|
|
| 2406 | + NEXT_INSTRUCTION;
|
|
| 2083 | 2407 | }
|
| 2084 | 2408 | |
| 2085 | - case bci_PUSH_UBX: {
|
|
| 2409 | + INSTRUCTION(bci_PUSH_UBX): {
|
|
| 2086 | 2410 | W_ i;
|
| 2087 | 2411 | W_ o_lits = BCO_GET_LARGE_ARG;
|
| 2088 | 2412 | W_ n_words = BCO_GET_LARGE_ARG;
|
| ... | ... | @@ -2090,10 +2414,10 @@ run_BCO: |
| 2090 | 2414 | for (i = 0; i < n_words; i++) {
|
| 2091 | 2415 | SpW(i) = (W_)BCO_LIT(o_lits+i);
|
| 2092 | 2416 | }
|
| 2093 | - goto nextInsn;
|
|
| 2417 | + NEXT_INSTRUCTION;
|
|
| 2094 | 2418 | }
|
| 2095 | 2419 | |
| 2096 | - case bci_SLIDE: {
|
|
| 2420 | + INSTRUCTION(bci_SLIDE): {
|
|
| 2097 | 2421 | W_ n = BCO_GET_LARGE_ARG;
|
| 2098 | 2422 | W_ by = BCO_GET_LARGE_ARG;
|
| 2099 | 2423 | /*
|
| ... | ... | @@ -2106,10 +2430,10 @@ run_BCO: |
| 2106 | 2430 | }
|
| 2107 | 2431 | Sp_addW(by);
|
| 2108 | 2432 | INTERP_TICK(it_slides);
|
| 2109 | - goto nextInsn;
|
|
| 2433 | + NEXT_INSTRUCTION;
|
|
| 2110 | 2434 | }
|
| 2111 | 2435 | |
| 2112 | - case bci_ALLOC_AP: {
|
|
| 2436 | + INSTRUCTION(bci_ALLOC_AP): {
|
|
| 2113 | 2437 | StgHalfWord n_payload = BCO_GET_LARGE_ARG;
|
| 2114 | 2438 | StgAP *ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
|
| 2115 | 2439 | SpW(-1) = (W_)ap;
|
| ... | ... | @@ -2119,10 +2443,10 @@ run_BCO: |
| 2119 | 2443 | // visible only from our stack
|
| 2120 | 2444 | SET_HDR(ap, &stg_AP_info, cap->r.rCCCS)
|
| 2121 | 2445 | Sp_subW(1);
|
| 2122 | - goto nextInsn;
|
|
| 2446 | + NEXT_INSTRUCTION;
|
|
| 2123 | 2447 | }
|
| 2124 | 2448 | |
| 2125 | - case bci_ALLOC_AP_NOUPD: {
|
|
| 2449 | + INSTRUCTION(bci_ALLOC_AP_NOUPD): {
|
|
| 2126 | 2450 | StgHalfWord n_payload = BCO_GET_LARGE_ARG;
|
| 2127 | 2451 | StgAP *ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
|
| 2128 | 2452 | SpW(-1) = (W_)ap;
|
| ... | ... | @@ -2132,10 +2456,10 @@ run_BCO: |
| 2132 | 2456 | // visible only from our stack
|
| 2133 | 2457 | SET_HDR(ap, &stg_AP_NOUPD_info, cap->r.rCCCS)
|
| 2134 | 2458 | Sp_subW(1);
|
| 2135 | - goto nextInsn;
|
|
| 2459 | + NEXT_INSTRUCTION;
|
|
| 2136 | 2460 | }
|
| 2137 | 2461 | |
| 2138 | - case bci_ALLOC_PAP: {
|
|
| 2462 | + INSTRUCTION(bci_ALLOC_PAP): {
|
|
| 2139 | 2463 | StgPAP* pap;
|
| 2140 | 2464 | StgHalfWord arity = BCO_GET_LARGE_ARG;
|
| 2141 | 2465 | StgHalfWord n_payload = BCO_GET_LARGE_ARG;
|
| ... | ... | @@ -2147,10 +2471,10 @@ run_BCO: |
| 2147 | 2471 | // visible only from our stack
|
| 2148 | 2472 | SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS)
|
| 2149 | 2473 | Sp_subW(1);
|
| 2150 | - goto nextInsn;
|
|
| 2474 | + NEXT_INSTRUCTION;
|
|
| 2151 | 2475 | }
|
| 2152 | 2476 | |
| 2153 | - case bci_MKAP: {
|
|
| 2477 | + INSTRUCTION(bci_MKAP): {
|
|
| 2154 | 2478 | StgHalfWord i;
|
| 2155 | 2479 | W_ stkoff = BCO_GET_LARGE_ARG;
|
| 2156 | 2480 | StgHalfWord n_payload = BCO_GET_LARGE_ARG;
|
| ... | ... | @@ -2171,10 +2495,10 @@ run_BCO: |
| 2171 | 2495 | debugBelch("\tBuilt ");
|
| 2172 | 2496 | printObj((StgClosure*)ap);
|
| 2173 | 2497 | );
|
| 2174 | - goto nextInsn;
|
|
| 2498 | + NEXT_INSTRUCTION;
|
|
| 2175 | 2499 | }
|
| 2176 | 2500 | |
| 2177 | - case bci_MKPAP: {
|
|
| 2501 | + INSTRUCTION(bci_MKPAP): {
|
|
| 2178 | 2502 | StgHalfWord i;
|
| 2179 | 2503 | W_ stkoff = BCO_GET_LARGE_ARG;
|
| 2180 | 2504 | StgHalfWord n_payload = BCO_GET_LARGE_ARG;
|
| ... | ... | @@ -2198,10 +2522,10 @@ run_BCO: |
| 2198 | 2522 | debugBelch("\tBuilt ");
|
| 2199 | 2523 | printObj((StgClosure*)pap);
|
| 2200 | 2524 | );
|
| 2201 | - goto nextInsn;
|
|
| 2525 | + NEXT_INSTRUCTION;
|
|
| 2202 | 2526 | }
|
| 2203 | 2527 | |
| 2204 | - case bci_UNPACK: {
|
|
| 2528 | + INSTRUCTION(bci_UNPACK): {
|
|
| 2205 | 2529 | /* Unpack N ptr words from t.o.s constructor */
|
| 2206 | 2530 | W_ i;
|
| 2207 | 2531 | W_ n_words = BCO_GET_LARGE_ARG;
|
| ... | ... | @@ -2210,10 +2534,10 @@ run_BCO: |
| 2210 | 2534 | for (i = 0; i < n_words; i++) {
|
| 2211 | 2535 | SpW(i) = (W_)con->payload[i];
|
| 2212 | 2536 | }
|
| 2213 | - goto nextInsn;
|
|
| 2537 | + NEXT_INSTRUCTION;
|
|
| 2214 | 2538 | }
|
| 2215 | 2539 | |
| 2216 | - case bci_PACK: {
|
|
| 2540 | + INSTRUCTION(bci_PACK): {
|
|
| 2217 | 2541 | W_ o_itbl = BCO_GET_LARGE_ARG;
|
| 2218 | 2542 | W_ n_words = BCO_GET_LARGE_ARG;
|
| 2219 | 2543 | StgConInfoTable* itbl = CON_INFO_PTR_TO_STRUCT((StgInfoTable *)BCO_LIT(o_itbl));
|
| ... | ... | @@ -2244,220 +2568,220 @@ run_BCO: |
| 2244 | 2568 | debugBelch("\tBuilt ");
|
| 2245 | 2569 | printObj((StgClosure*)tagged_con);
|
| 2246 | 2570 | );
|
| 2247 | - goto nextInsn;
|
|
| 2571 | + NEXT_INSTRUCTION;
|
|
| 2248 | 2572 | }
|
| 2249 | 2573 | |
| 2250 | - case bci_TESTLT_P: {
|
|
| 2574 | + INSTRUCTION(bci_TESTLT_P): {
|
|
| 2251 | 2575 | unsigned int discr = BCO_NEXT;
|
| 2252 | 2576 | int failto = BCO_GET_LARGE_ARG;
|
| 2253 | 2577 | StgClosure* con = UNTAG_CLOSURE((StgClosure*)ReadSpW(0));
|
| 2254 | 2578 | if (GET_TAG(con) >= discr) {
|
| 2255 | 2579 | bciPtr = failto;
|
| 2256 | 2580 | }
|
| 2257 | - goto nextInsn;
|
|
| 2581 | + NEXT_INSTRUCTION;
|
|
| 2258 | 2582 | }
|
| 2259 | 2583 | |
| 2260 | - case bci_TESTEQ_P: {
|
|
| 2584 | + INSTRUCTION(bci_TESTEQ_P): {
|
|
| 2261 | 2585 | unsigned int discr = BCO_NEXT;
|
| 2262 | 2586 | int failto = BCO_GET_LARGE_ARG;
|
| 2263 | 2587 | StgClosure* con = UNTAG_CLOSURE((StgClosure*)ReadSpW(0));
|
| 2264 | 2588 | if (GET_TAG(con) != discr) {
|
| 2265 | 2589 | bciPtr = failto;
|
| 2266 | 2590 | }
|
| 2267 | - goto nextInsn;
|
|
| 2591 | + NEXT_INSTRUCTION;
|
|
| 2268 | 2592 | }
|
| 2269 | 2593 | |
| 2270 | - case bci_TESTLT_I: {
|
|
| 2594 | + INSTRUCTION(bci_TESTLT_I): {
|
|
| 2271 | 2595 | int discr = BCO_GET_LARGE_ARG;
|
| 2272 | 2596 | int failto = BCO_GET_LARGE_ARG;
|
| 2273 | 2597 | I_ stackInt = (I_)ReadSpW(0);
|
| 2274 | 2598 | if (stackInt >= (I_)BCO_LIT(discr))
|
| 2275 | 2599 | bciPtr = failto;
|
| 2276 | - goto nextInsn;
|
|
| 2600 | + NEXT_INSTRUCTION;
|
|
| 2277 | 2601 | }
|
| 2278 | 2602 | |
| 2279 | - case bci_TESTLT_I64: {
|
|
| 2603 | + INSTRUCTION(bci_TESTLT_I64): {
|
|
| 2280 | 2604 | int discr = BCO_GET_LARGE_ARG;
|
| 2281 | 2605 | int failto = BCO_GET_LARGE_ARG;
|
| 2282 | 2606 | StgInt64 stackInt = ReadSpW64(0);
|
| 2283 | 2607 | if (stackInt >= BCO_LITI64(discr))
|
| 2284 | 2608 | bciPtr = failto;
|
| 2285 | - goto nextInsn;
|
|
| 2609 | + NEXT_INSTRUCTION;
|
|
| 2286 | 2610 | }
|
| 2287 | 2611 | |
| 2288 | - case bci_TESTLT_I32: {
|
|
| 2612 | + INSTRUCTION(bci_TESTLT_I32): {
|
|
| 2289 | 2613 | int discr = BCO_GET_LARGE_ARG;
|
| 2290 | 2614 | int failto = BCO_GET_LARGE_ARG;
|
| 2291 | 2615 | StgInt32 stackInt = (StgInt32) ReadSpW(0);
|
| 2292 | 2616 | if (stackInt >= (StgInt32)BCO_LIT(discr))
|
| 2293 | 2617 | bciPtr = failto;
|
| 2294 | - goto nextInsn;
|
|
| 2618 | + NEXT_INSTRUCTION;
|
|
| 2295 | 2619 | }
|
| 2296 | 2620 | |
| 2297 | - case bci_TESTLT_I16: {
|
|
| 2621 | + INSTRUCTION(bci_TESTLT_I16): {
|
|
| 2298 | 2622 | int discr = BCO_GET_LARGE_ARG;
|
| 2299 | 2623 | int failto = BCO_GET_LARGE_ARG;
|
| 2300 | 2624 | StgInt16 stackInt = (StgInt16) ReadSpW(0);
|
| 2301 | 2625 | if (stackInt >= (StgInt16)BCO_LIT(discr))
|
| 2302 | 2626 | bciPtr = failto;
|
| 2303 | - goto nextInsn;
|
|
| 2627 | + NEXT_INSTRUCTION;
|
|
| 2304 | 2628 | }
|
| 2305 | 2629 | |
| 2306 | - case bci_TESTLT_I8: {
|
|
| 2630 | + INSTRUCTION(bci_TESTLT_I8): {
|
|
| 2307 | 2631 | int discr = BCO_GET_LARGE_ARG;
|
| 2308 | 2632 | int failto = BCO_GET_LARGE_ARG;
|
| 2309 | 2633 | StgInt8 stackInt = (StgInt8) ReadSpW(0);
|
| 2310 | 2634 | if (stackInt >= (StgInt8)BCO_LIT(discr))
|
| 2311 | 2635 | bciPtr = failto;
|
| 2312 | - goto nextInsn;
|
|
| 2636 | + NEXT_INSTRUCTION;
|
|
| 2313 | 2637 | }
|
| 2314 | 2638 | |
| 2315 | - case bci_TESTEQ_I: {
|
|
| 2639 | + INSTRUCTION(bci_TESTEQ_I): {
|
|
| 2316 | 2640 | int discr = BCO_GET_LARGE_ARG;
|
| 2317 | 2641 | int failto = BCO_GET_LARGE_ARG;
|
| 2318 | 2642 | I_ stackInt = (I_)ReadSpW(0);
|
| 2319 | 2643 | if (stackInt != (I_)BCO_LIT(discr)) {
|
| 2320 | 2644 | bciPtr = failto;
|
| 2321 | 2645 | }
|
| 2322 | - goto nextInsn;
|
|
| 2646 | + NEXT_INSTRUCTION;
|
|
| 2323 | 2647 | }
|
| 2324 | 2648 | |
| 2325 | - case bci_TESTEQ_I64: {
|
|
| 2649 | + INSTRUCTION(bci_TESTEQ_I64): {
|
|
| 2326 | 2650 | int discr = BCO_GET_LARGE_ARG;
|
| 2327 | 2651 | int failto = BCO_GET_LARGE_ARG;
|
| 2328 | 2652 | StgInt64 stackInt = ReadSpW64(0);
|
| 2329 | 2653 | if (stackInt != BCO_LITI64(discr)) {
|
| 2330 | 2654 | bciPtr = failto;
|
| 2331 | 2655 | }
|
| 2332 | - goto nextInsn;
|
|
| 2656 | + NEXT_INSTRUCTION;
|
|
| 2333 | 2657 | }
|
| 2334 | 2658 | |
| 2335 | - case bci_TESTEQ_I32: {
|
|
| 2659 | + INSTRUCTION(bci_TESTEQ_I32): {
|
|
| 2336 | 2660 | int discr = BCO_GET_LARGE_ARG;
|
| 2337 | 2661 | int failto = BCO_GET_LARGE_ARG;
|
| 2338 | 2662 | StgInt32 stackInt = (StgInt32) ReadSpW(0);
|
| 2339 | 2663 | if (stackInt != (StgInt32)BCO_LIT(discr)) {
|
| 2340 | 2664 | bciPtr = failto;
|
| 2341 | 2665 | }
|
| 2342 | - goto nextInsn;
|
|
| 2666 | + NEXT_INSTRUCTION;
|
|
| 2343 | 2667 | }
|
| 2344 | 2668 | |
| 2345 | - case bci_TESTEQ_I16: {
|
|
| 2669 | + INSTRUCTION(bci_TESTEQ_I16): {
|
|
| 2346 | 2670 | int discr = BCO_GET_LARGE_ARG;
|
| 2347 | 2671 | int failto = BCO_GET_LARGE_ARG;
|
| 2348 | 2672 | StgInt16 stackInt = (StgInt16) ReadSpW(0);
|
| 2349 | 2673 | if (stackInt != (StgInt16)BCO_LIT(discr)) {
|
| 2350 | 2674 | bciPtr = failto;
|
| 2351 | 2675 | }
|
| 2352 | - goto nextInsn;
|
|
| 2676 | + NEXT_INSTRUCTION;
|
|
| 2353 | 2677 | }
|
| 2354 | 2678 | |
| 2355 | - case bci_TESTEQ_I8: {
|
|
| 2679 | + INSTRUCTION(bci_TESTEQ_I8): {
|
|
| 2356 | 2680 | int discr = BCO_GET_LARGE_ARG;
|
| 2357 | 2681 | int failto = BCO_GET_LARGE_ARG;
|
| 2358 | 2682 | StgInt8 stackInt = (StgInt8) ReadSpW(0);
|
| 2359 | 2683 | if (stackInt != (StgInt8)BCO_LIT(discr)) {
|
| 2360 | 2684 | bciPtr = failto;
|
| 2361 | 2685 | }
|
| 2362 | - goto nextInsn;
|
|
| 2686 | + NEXT_INSTRUCTION;
|
|
| 2363 | 2687 | }
|
| 2364 | 2688 | |
| 2365 | - case bci_TESTLT_W: {
|
|
| 2689 | + INSTRUCTION(bci_TESTLT_W): {
|
|
| 2366 | 2690 | int discr = BCO_GET_LARGE_ARG;
|
| 2367 | 2691 | int failto = BCO_GET_LARGE_ARG;
|
| 2368 | 2692 | W_ stackWord = (W_)ReadSpW(0);
|
| 2369 | 2693 | if (stackWord >= (W_)BCO_LIT(discr))
|
| 2370 | 2694 | bciPtr = failto;
|
| 2371 | - goto nextInsn;
|
|
| 2695 | + NEXT_INSTRUCTION;
|
|
| 2372 | 2696 | }
|
| 2373 | 2697 | |
| 2374 | - case bci_TESTLT_W64: {
|
|
| 2698 | + INSTRUCTION(bci_TESTLT_W64): {
|
|
| 2375 | 2699 | int discr = BCO_GET_LARGE_ARG;
|
| 2376 | 2700 | int failto = BCO_GET_LARGE_ARG;
|
| 2377 | 2701 | StgWord64 stackWord = ReadSpW64(0);
|
| 2378 | 2702 | if (stackWord >= BCO_LITW64(discr))
|
| 2379 | 2703 | bciPtr = failto;
|
| 2380 | - goto nextInsn;
|
|
| 2704 | + NEXT_INSTRUCTION;
|
|
| 2381 | 2705 | }
|
| 2382 | 2706 | |
| 2383 | - case bci_TESTLT_W32: {
|
|
| 2707 | + INSTRUCTION(bci_TESTLT_W32): {
|
|
| 2384 | 2708 | int discr = BCO_GET_LARGE_ARG;
|
| 2385 | 2709 | int failto = BCO_GET_LARGE_ARG;
|
| 2386 | 2710 | StgWord32 stackWord = (StgWord32) ReadSpW(0);
|
| 2387 | 2711 | if (stackWord >= (StgWord32)BCO_LIT(discr))
|
| 2388 | 2712 | bciPtr = failto;
|
| 2389 | - goto nextInsn;
|
|
| 2713 | + NEXT_INSTRUCTION;
|
|
| 2390 | 2714 | }
|
| 2391 | 2715 | |
| 2392 | - case bci_TESTLT_W16: {
|
|
| 2716 | + INSTRUCTION(bci_TESTLT_W16): {
|
|
| 2393 | 2717 | int discr = BCO_GET_LARGE_ARG;
|
| 2394 | 2718 | int failto = BCO_GET_LARGE_ARG;
|
| 2395 | 2719 | StgWord16 stackWord = (StgInt16) ReadSpW(0);
|
| 2396 | 2720 | if (stackWord >= (StgWord16)BCO_LIT(discr))
|
| 2397 | 2721 | bciPtr = failto;
|
| 2398 | - goto nextInsn;
|
|
| 2722 | + NEXT_INSTRUCTION;
|
|
| 2399 | 2723 | }
|
| 2400 | 2724 | |
| 2401 | - case bci_TESTLT_W8: {
|
|
| 2725 | + INSTRUCTION(bci_TESTLT_W8): {
|
|
| 2402 | 2726 | int discr = BCO_GET_LARGE_ARG;
|
| 2403 | 2727 | int failto = BCO_GET_LARGE_ARG;
|
| 2404 | 2728 | StgWord8 stackWord = (StgInt8) ReadSpW(0);
|
| 2405 | 2729 | if (stackWord >= (StgWord8)BCO_LIT(discr))
|
| 2406 | 2730 | bciPtr = failto;
|
| 2407 | - goto nextInsn;
|
|
| 2731 | + NEXT_INSTRUCTION;
|
|
| 2408 | 2732 | }
|
| 2409 | 2733 | |
| 2410 | - case bci_TESTEQ_W: {
|
|
| 2734 | + INSTRUCTION(bci_TESTEQ_W): {
|
|
| 2411 | 2735 | int discr = BCO_GET_LARGE_ARG;
|
| 2412 | 2736 | int failto = BCO_GET_LARGE_ARG;
|
| 2413 | 2737 | W_ stackWord = (W_)ReadSpW(0);
|
| 2414 | 2738 | if (stackWord != (W_)BCO_LIT(discr)) {
|
| 2415 | 2739 | bciPtr = failto;
|
| 2416 | 2740 | }
|
| 2417 | - goto nextInsn;
|
|
| 2741 | + NEXT_INSTRUCTION;
|
|
| 2418 | 2742 | }
|
| 2419 | 2743 | |
| 2420 | - case bci_TESTEQ_W64: {
|
|
| 2744 | + INSTRUCTION(bci_TESTEQ_W64): {
|
|
| 2421 | 2745 | int discr = BCO_GET_LARGE_ARG;
|
| 2422 | 2746 | int failto = BCO_GET_LARGE_ARG;
|
| 2423 | 2747 | StgWord64 stackWord = ReadSpW64(0);
|
| 2424 | 2748 | if (stackWord != BCO_LITW64(discr)) {
|
| 2425 | 2749 | bciPtr = failto;
|
| 2426 | 2750 | }
|
| 2427 | - goto nextInsn;
|
|
| 2751 | + NEXT_INSTRUCTION;
|
|
| 2428 | 2752 | }
|
| 2429 | 2753 | |
| 2430 | - case bci_TESTEQ_W32: {
|
|
| 2754 | + INSTRUCTION(bci_TESTEQ_W32): {
|
|
| 2431 | 2755 | int discr = BCO_GET_LARGE_ARG;
|
| 2432 | 2756 | int failto = BCO_GET_LARGE_ARG;
|
| 2433 | 2757 | StgWord32 stackWord = (StgWord32) ReadSpW(0);
|
| 2434 | 2758 | if (stackWord != (StgWord32)BCO_LIT(discr)) {
|
| 2435 | 2759 | bciPtr = failto;
|
| 2436 | 2760 | }
|
| 2437 | - goto nextInsn;
|
|
| 2761 | + NEXT_INSTRUCTION;
|
|
| 2438 | 2762 | }
|
| 2439 | 2763 | |
| 2440 | - case bci_TESTEQ_W16: {
|
|
| 2764 | + INSTRUCTION(bci_TESTEQ_W16): {
|
|
| 2441 | 2765 | int discr = BCO_GET_LARGE_ARG;
|
| 2442 | 2766 | int failto = BCO_GET_LARGE_ARG;
|
| 2443 | 2767 | StgWord16 stackWord = (StgWord16) ReadSpW(0);
|
| 2444 | 2768 | if (stackWord != (StgWord16)BCO_LIT(discr)) {
|
| 2445 | 2769 | bciPtr = failto;
|
| 2446 | 2770 | }
|
| 2447 | - goto nextInsn;
|
|
| 2771 | + NEXT_INSTRUCTION;
|
|
| 2448 | 2772 | }
|
| 2449 | 2773 | |
| 2450 | - case bci_TESTEQ_W8: {
|
|
| 2774 | + INSTRUCTION(bci_TESTEQ_W8): {
|
|
| 2451 | 2775 | int discr = BCO_GET_LARGE_ARG;
|
| 2452 | 2776 | int failto = BCO_GET_LARGE_ARG;
|
| 2453 | 2777 | StgWord8 stackWord = (StgWord8) ReadSpW(0);
|
| 2454 | 2778 | if (stackWord != (StgWord8)BCO_LIT(discr)) {
|
| 2455 | 2779 | bciPtr = failto;
|
| 2456 | 2780 | }
|
| 2457 | - goto nextInsn;
|
|
| 2781 | + NEXT_INSTRUCTION;
|
|
| 2458 | 2782 | }
|
| 2459 | 2783 | |
| 2460 | - case bci_TESTLT_D: {
|
|
| 2784 | + INSTRUCTION(bci_TESTLT_D): {
|
|
| 2461 | 2785 | int discr = BCO_GET_LARGE_ARG;
|
| 2462 | 2786 | int failto = BCO_GET_LARGE_ARG;
|
| 2463 | 2787 | StgDouble stackDbl, discrDbl;
|
| ... | ... | @@ -2466,10 +2790,10 @@ run_BCO: |
| 2466 | 2790 | if (stackDbl >= discrDbl) {
|
| 2467 | 2791 | bciPtr = failto;
|
| 2468 | 2792 | }
|
| 2469 | - goto nextInsn;
|
|
| 2793 | + NEXT_INSTRUCTION;
|
|
| 2470 | 2794 | }
|
| 2471 | 2795 | |
| 2472 | - case bci_TESTEQ_D: {
|
|
| 2796 | + INSTRUCTION(bci_TESTEQ_D): {
|
|
| 2473 | 2797 | int discr = BCO_GET_LARGE_ARG;
|
| 2474 | 2798 | int failto = BCO_GET_LARGE_ARG;
|
| 2475 | 2799 | StgDouble stackDbl, discrDbl;
|
| ... | ... | @@ -2478,10 +2802,10 @@ run_BCO: |
| 2478 | 2802 | if (stackDbl != discrDbl) {
|
| 2479 | 2803 | bciPtr = failto;
|
| 2480 | 2804 | }
|
| 2481 | - goto nextInsn;
|
|
| 2805 | + NEXT_INSTRUCTION;
|
|
| 2482 | 2806 | }
|
| 2483 | 2807 | |
| 2484 | - case bci_TESTLT_F: {
|
|
| 2808 | + INSTRUCTION(bci_TESTLT_F): {
|
|
| 2485 | 2809 | int discr = BCO_GET_LARGE_ARG;
|
| 2486 | 2810 | int failto = BCO_GET_LARGE_ARG;
|
| 2487 | 2811 | StgFloat stackFlt, discrFlt;
|
| ... | ... | @@ -2490,10 +2814,10 @@ run_BCO: |
| 2490 | 2814 | if (stackFlt >= discrFlt) {
|
| 2491 | 2815 | bciPtr = failto;
|
| 2492 | 2816 | }
|
| 2493 | - goto nextInsn;
|
|
| 2817 | + NEXT_INSTRUCTION;
|
|
| 2494 | 2818 | }
|
| 2495 | 2819 | |
| 2496 | - case bci_TESTEQ_F: {
|
|
| 2820 | + INSTRUCTION(bci_TESTEQ_F): {
|
|
| 2497 | 2821 | int discr = BCO_GET_LARGE_ARG;
|
| 2498 | 2822 | int failto = BCO_GET_LARGE_ARG;
|
| 2499 | 2823 | StgFloat stackFlt, discrFlt;
|
| ... | ... | @@ -2502,11 +2826,11 @@ run_BCO: |
| 2502 | 2826 | if (stackFlt != discrFlt) {
|
| 2503 | 2827 | bciPtr = failto;
|
| 2504 | 2828 | }
|
| 2505 | - goto nextInsn;
|
|
| 2829 | + NEXT_INSTRUCTION;
|
|
| 2506 | 2830 | }
|
| 2507 | 2831 | |
| 2508 | 2832 | // Control-flow ish things
|
| 2509 | - case bci_ENTER:
|
|
| 2833 | + INSTRUCTION(bci_ENTER):
|
|
| 2510 | 2834 | // Context-switch check. We put it here to ensure that
|
| 2511 | 2835 | // the interpreter has done at least *some* work before
|
| 2512 | 2836 | // context switching: sometimes the scheduler can invoke
|
| ... | ... | @@ -2518,50 +2842,50 @@ run_BCO: |
| 2518 | 2842 | }
|
| 2519 | 2843 | goto eval;
|
| 2520 | 2844 | |
| 2521 | - case bci_RETURN_P:
|
|
| 2845 | + INSTRUCTION(bci_RETURN_P):
|
|
| 2522 | 2846 | tagged_obj = (StgClosure *)ReadSpW(0);
|
| 2523 | 2847 | Sp_addW(1);
|
| 2524 | 2848 | goto do_return_pointer;
|
| 2525 | 2849 | |
| 2526 | - case bci_RETURN_N:
|
|
| 2850 | + INSTRUCTION(bci_RETURN_N):
|
|
| 2527 | 2851 | Sp_subW(1);
|
| 2528 | 2852 | SpW(0) = (W_)&stg_ret_n_info;
|
| 2529 | 2853 | goto do_return_nonpointer;
|
| 2530 | - case bci_RETURN_F:
|
|
| 2854 | + INSTRUCTION(bci_RETURN_F):
|
|
| 2531 | 2855 | Sp_subW(1);
|
| 2532 | 2856 | SpW(0) = (W_)&stg_ret_f_info;
|
| 2533 | 2857 | goto do_return_nonpointer;
|
| 2534 | - case bci_RETURN_D:
|
|
| 2858 | + INSTRUCTION(bci_RETURN_D):
|
|
| 2535 | 2859 | Sp_subW(1);
|
| 2536 | 2860 | SpW(0) = (W_)&stg_ret_d_info;
|
| 2537 | 2861 | goto do_return_nonpointer;
|
| 2538 | - case bci_RETURN_L:
|
|
| 2862 | + INSTRUCTION(bci_RETURN_L):
|
|
| 2539 | 2863 | Sp_subW(1);
|
| 2540 | 2864 | SpW(0) = (W_)&stg_ret_l_info;
|
| 2541 | 2865 | goto do_return_nonpointer;
|
| 2542 | - case bci_RETURN_V:
|
|
| 2866 | + INSTRUCTION(bci_RETURN_V):
|
|
| 2543 | 2867 | Sp_subW(1);
|
| 2544 | 2868 | SpW(0) = (W_)&stg_ret_v_info;
|
| 2545 | 2869 | goto do_return_nonpointer;
|
| 2546 | - case bci_RETURN_T: {
|
|
| 2870 | + INSTRUCTION(bci_RETURN_T): {
|
|
| 2547 | 2871 | /* tuple_info and tuple_bco must already be on the stack */
|
| 2548 | 2872 | Sp_subW(1);
|
| 2549 | 2873 | SpW(0) = (W_)&stg_ret_t_info;
|
| 2550 | 2874 | goto do_return_nonpointer;
|
| 2551 | 2875 | }
|
| 2552 | 2876 | |
| 2553 | - case bci_BCO_NAME:
|
|
| 2877 | + INSTRUCTION(bci_BCO_NAME):
|
|
| 2554 | 2878 | bciPtr++;
|
| 2555 | - goto nextInsn;
|
|
| 2879 | + NEXT_INSTRUCTION;
|
|
| 2556 | 2880 | |
| 2557 | - case bci_SWIZZLE: {
|
|
| 2881 | + INSTRUCTION(bci_SWIZZLE): {
|
|
| 2558 | 2882 | W_ stkoff = BCO_GET_LARGE_ARG;
|
| 2559 | 2883 | StgInt n = BCO_GET_LARGE_ARG;
|
| 2560 | 2884 | (*(StgInt*)(SafeSpWP(stkoff))) += n;
|
| 2561 | - goto nextInsn;
|
|
| 2885 | + NEXT_INSTRUCTION;
|
|
| 2562 | 2886 | }
|
| 2563 | 2887 | |
| 2564 | - case bci_PRIMCALL: {
|
|
| 2888 | + INSTRUCTION(bci_PRIMCALL): {
|
|
| 2565 | 2889 | Sp_subW(1);
|
| 2566 | 2890 | SpW(0) = (W_)&stg_primcall_info;
|
| 2567 | 2891 | RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
|
| ... | ... | @@ -2577,7 +2901,7 @@ run_BCO: |
| 2577 | 2901 | ty r = op ((ty) ReadSpW(0)); \
|
| 2578 | 2902 | SpW(0) = (StgWord) r; \
|
| 2579 | 2903 | } \
|
| 2580 | - goto nextInsn; \
|
|
| 2904 | + NEXT_INSTRUCTION; \
|
|
| 2581 | 2905 | }
|
| 2582 | 2906 | |
| 2583 | 2907 | // op :: ty -> ty -> ty
|
| ... | ... | @@ -2592,7 +2916,7 @@ run_BCO: |
| 2592 | 2916 | Sp_addW(1); \
|
| 2593 | 2917 | SpW(0) = (StgWord) r; \
|
| 2594 | 2918 | }; \
|
| 2595 | - goto nextInsn; \
|
|
| 2919 | + NEXT_INSTRUCTION; \
|
|
| 2596 | 2920 | }
|
| 2597 | 2921 | |
| 2598 | 2922 | // op :: ty -> Int -> ty
|
| ... | ... | @@ -2607,7 +2931,7 @@ run_BCO: |
| 2607 | 2931 | Sp_addW(1); \
|
| 2608 | 2932 | SpW(0) = (StgWord) r; \
|
| 2609 | 2933 | }; \
|
| 2610 | - goto nextInsn; \
|
|
| 2934 | + NEXT_INSTRUCTION; \
|
|
| 2611 | 2935 | }
|
| 2612 | 2936 | |
| 2613 | 2937 | // op :: ty -> ty -> Int
|
| ... | ... | @@ -2622,113 +2946,113 @@ run_BCO: |
| 2622 | 2946 | Sp_addW(1); \
|
| 2623 | 2947 | SpW(0) = (StgWord) r; \
|
| 2624 | 2948 | }; \
|
| 2625 | - goto nextInsn; \
|
|
| 2949 | + NEXT_INSTRUCTION; \
|
|
| 2626 | 2950 | }
|
| 2627 | 2951 | |
| 2628 | - case bci_OP_ADD_64: SIZED_BIN_OP(+, StgInt64)
|
|
| 2629 | - case bci_OP_SUB_64: SIZED_BIN_OP(-, StgInt64)
|
|
| 2630 | - case bci_OP_AND_64: SIZED_BIN_OP(&, StgInt64)
|
|
| 2631 | - case bci_OP_XOR_64: SIZED_BIN_OP(^, StgInt64)
|
|
| 2632 | - case bci_OP_OR_64: SIZED_BIN_OP(|, StgInt64)
|
|
| 2633 | - case bci_OP_MUL_64: SIZED_BIN_OP(*, StgInt64)
|
|
| 2634 | - case bci_OP_SHL_64: SIZED_BIN_OP_TY_INT(<<, StgWord64)
|
|
| 2635 | - case bci_OP_LSR_64: SIZED_BIN_OP_TY_INT(>>, StgWord64)
|
|
| 2636 | - case bci_OP_ASR_64: SIZED_BIN_OP_TY_INT(>>, StgInt64)
|
|
| 2637 | - |
|
| 2638 | - case bci_OP_NEQ_64: SIZED_BIN_OP_TY_TY_INT(!=, StgWord64)
|
|
| 2639 | - case bci_OP_EQ_64: SIZED_BIN_OP_TY_TY_INT(==, StgWord64)
|
|
| 2640 | - case bci_OP_U_GT_64: SIZED_BIN_OP_TY_TY_INT(>, StgWord64)
|
|
| 2641 | - case bci_OP_U_GE_64: SIZED_BIN_OP_TY_TY_INT(>=, StgWord64)
|
|
| 2642 | - case bci_OP_U_LT_64: SIZED_BIN_OP_TY_TY_INT(<, StgWord64)
|
|
| 2643 | - case bci_OP_U_LE_64: SIZED_BIN_OP_TY_TY_INT(<=, StgWord64)
|
|
| 2644 | - |
|
| 2645 | - case bci_OP_S_GT_64: SIZED_BIN_OP_TY_TY_INT(>, StgInt64)
|
|
| 2646 | - case bci_OP_S_GE_64: SIZED_BIN_OP_TY_TY_INT(>=, StgInt64)
|
|
| 2647 | - case bci_OP_S_LT_64: SIZED_BIN_OP_TY_TY_INT(<, StgInt64)
|
|
| 2648 | - case bci_OP_S_LE_64: SIZED_BIN_OP_TY_TY_INT(<=, StgInt64)
|
|
| 2649 | - |
|
| 2650 | - case bci_OP_NOT_64: UN_SIZED_OP(~, StgWord64)
|
|
| 2651 | - case bci_OP_NEG_64: UN_SIZED_OP(-, StgInt64)
|
|
| 2652 | - |
|
| 2653 | - |
|
| 2654 | - case bci_OP_ADD_32: SIZED_BIN_OP(+, StgInt32)
|
|
| 2655 | - case bci_OP_SUB_32: SIZED_BIN_OP(-, StgInt32)
|
|
| 2656 | - case bci_OP_AND_32: SIZED_BIN_OP(&, StgInt32)
|
|
| 2657 | - case bci_OP_XOR_32: SIZED_BIN_OP(^, StgInt32)
|
|
| 2658 | - case bci_OP_OR_32: SIZED_BIN_OP(|, StgInt32)
|
|
| 2659 | - case bci_OP_MUL_32: SIZED_BIN_OP(*, StgInt32)
|
|
| 2660 | - case bci_OP_SHL_32: SIZED_BIN_OP_TY_INT(<<, StgWord32)
|
|
| 2661 | - case bci_OP_LSR_32: SIZED_BIN_OP_TY_INT(>>, StgWord32)
|
|
| 2662 | - case bci_OP_ASR_32: SIZED_BIN_OP_TY_INT(>>, StgInt32)
|
|
| 2663 | - |
|
| 2664 | - case bci_OP_NEQ_32: SIZED_BIN_OP_TY_TY_INT(!=, StgWord32)
|
|
| 2665 | - case bci_OP_EQ_32: SIZED_BIN_OP_TY_TY_INT(==, StgWord32)
|
|
| 2666 | - case bci_OP_U_GT_32: SIZED_BIN_OP_TY_TY_INT(>, StgWord32)
|
|
| 2667 | - case bci_OP_U_GE_32: SIZED_BIN_OP_TY_TY_INT(>=, StgWord32)
|
|
| 2668 | - case bci_OP_U_LT_32: SIZED_BIN_OP_TY_TY_INT(<, StgWord32)
|
|
| 2669 | - case bci_OP_U_LE_32: SIZED_BIN_OP_TY_TY_INT(<=, StgWord32)
|
|
| 2670 | - |
|
| 2671 | - case bci_OP_S_GT_32: SIZED_BIN_OP_TY_TY_INT(>, StgInt32)
|
|
| 2672 | - case bci_OP_S_GE_32: SIZED_BIN_OP_TY_TY_INT(>=, StgInt32)
|
|
| 2673 | - case bci_OP_S_LT_32: SIZED_BIN_OP_TY_TY_INT(<, StgInt32)
|
|
| 2674 | - case bci_OP_S_LE_32: SIZED_BIN_OP_TY_TY_INT(<=, StgInt32)
|
|
| 2675 | - |
|
| 2676 | - case bci_OP_NOT_32: UN_SIZED_OP(~, StgWord32)
|
|
| 2677 | - case bci_OP_NEG_32: UN_SIZED_OP(-, StgInt32)
|
|
| 2678 | - |
|
| 2679 | - |
|
| 2680 | - case bci_OP_ADD_16: SIZED_BIN_OP(+, StgInt16)
|
|
| 2681 | - case bci_OP_SUB_16: SIZED_BIN_OP(-, StgInt16)
|
|
| 2682 | - case bci_OP_AND_16: SIZED_BIN_OP(&, StgInt16)
|
|
| 2683 | - case bci_OP_XOR_16: SIZED_BIN_OP(^, StgInt16)
|
|
| 2684 | - case bci_OP_OR_16: SIZED_BIN_OP(|, StgInt16)
|
|
| 2685 | - case bci_OP_MUL_16: SIZED_BIN_OP(*, StgInt16)
|
|
| 2686 | - case bci_OP_SHL_16: SIZED_BIN_OP_TY_INT(<<, StgWord16)
|
|
| 2687 | - case bci_OP_LSR_16: SIZED_BIN_OP_TY_INT(>>, StgWord16)
|
|
| 2688 | - case bci_OP_ASR_16: SIZED_BIN_OP_TY_INT(>>, StgInt16)
|
|
| 2689 | - |
|
| 2690 | - case bci_OP_NEQ_16: SIZED_BIN_OP_TY_TY_INT(!=, StgWord16)
|
|
| 2691 | - case bci_OP_EQ_16: SIZED_BIN_OP_TY_TY_INT(==, StgWord16)
|
|
| 2692 | - case bci_OP_U_GT_16: SIZED_BIN_OP_TY_TY_INT(>, StgWord16)
|
|
| 2693 | - case bci_OP_U_GE_16: SIZED_BIN_OP_TY_TY_INT(>=, StgWord16)
|
|
| 2694 | - case bci_OP_U_LT_16: SIZED_BIN_OP_TY_TY_INT(<, StgWord16)
|
|
| 2695 | - case bci_OP_U_LE_16: SIZED_BIN_OP_TY_TY_INT(<=, StgWord16)
|
|
| 2696 | - |
|
| 2697 | - case bci_OP_S_GT_16: SIZED_BIN_OP(>, StgInt16)
|
|
| 2698 | - case bci_OP_S_GE_16: SIZED_BIN_OP(>=, StgInt16)
|
|
| 2699 | - case bci_OP_S_LT_16: SIZED_BIN_OP(<, StgInt16)
|
|
| 2700 | - case bci_OP_S_LE_16: SIZED_BIN_OP(<=, StgInt16)
|
|
| 2701 | - |
|
| 2702 | - case bci_OP_NOT_16: UN_SIZED_OP(~, StgWord16)
|
|
| 2703 | - case bci_OP_NEG_16: UN_SIZED_OP(-, StgInt16)
|
|
| 2704 | - |
|
| 2705 | - |
|
| 2706 | - case bci_OP_ADD_08: SIZED_BIN_OP(+, StgInt8)
|
|
| 2707 | - case bci_OP_SUB_08: SIZED_BIN_OP(-, StgInt8)
|
|
| 2708 | - case bci_OP_AND_08: SIZED_BIN_OP(&, StgInt8)
|
|
| 2709 | - case bci_OP_XOR_08: SIZED_BIN_OP(^, StgInt8)
|
|
| 2710 | - case bci_OP_OR_08: SIZED_BIN_OP(|, StgInt8)
|
|
| 2711 | - case bci_OP_MUL_08: SIZED_BIN_OP(*, StgInt8)
|
|
| 2712 | - case bci_OP_SHL_08: SIZED_BIN_OP_TY_INT(<<, StgWord8)
|
|
| 2713 | - case bci_OP_LSR_08: SIZED_BIN_OP_TY_INT(>>, StgWord8)
|
|
| 2714 | - case bci_OP_ASR_08: SIZED_BIN_OP_TY_INT(>>, StgInt8)
|
|
| 2715 | - |
|
| 2716 | - case bci_OP_NEQ_08: SIZED_BIN_OP_TY_TY_INT(!=, StgWord8)
|
|
| 2717 | - case bci_OP_EQ_08: SIZED_BIN_OP_TY_TY_INT(==, StgWord8)
|
|
| 2718 | - case bci_OP_U_GT_08: SIZED_BIN_OP_TY_TY_INT(>, StgWord8)
|
|
| 2719 | - case bci_OP_U_GE_08: SIZED_BIN_OP_TY_TY_INT(>=, StgWord8)
|
|
| 2720 | - case bci_OP_U_LT_08: SIZED_BIN_OP_TY_TY_INT(<, StgWord8)
|
|
| 2721 | - case bci_OP_U_LE_08: SIZED_BIN_OP_TY_TY_INT(<=, StgWord8)
|
|
| 2722 | - |
|
| 2723 | - case bci_OP_S_GT_08: SIZED_BIN_OP_TY_TY_INT(>, StgInt8)
|
|
| 2724 | - case bci_OP_S_GE_08: SIZED_BIN_OP_TY_TY_INT(>=, StgInt8)
|
|
| 2725 | - case bci_OP_S_LT_08: SIZED_BIN_OP_TY_TY_INT(<, StgInt8)
|
|
| 2726 | - case bci_OP_S_LE_08: SIZED_BIN_OP_TY_TY_INT(<=, StgInt8)
|
|
| 2727 | - |
|
| 2728 | - case bci_OP_NOT_08: UN_SIZED_OP(~, StgWord8)
|
|
| 2729 | - case bci_OP_NEG_08: UN_SIZED_OP(-, StgInt8)
|
|
| 2730 | - |
|
| 2731 | - case bci_OP_INDEX_ADDR_64:
|
|
| 2952 | + INSTRUCTION(bci_OP_ADD_64): SIZED_BIN_OP(+, StgInt64)
|
|
| 2953 | + INSTRUCTION(bci_OP_SUB_64): SIZED_BIN_OP(-, StgInt64)
|
|
| 2954 | + INSTRUCTION(bci_OP_AND_64): SIZED_BIN_OP(&, StgInt64)
|
|
| 2955 | + INSTRUCTION(bci_OP_XOR_64): SIZED_BIN_OP(^, StgInt64)
|
|
| 2956 | + INSTRUCTION(bci_OP_OR_64): SIZED_BIN_OP(|, StgInt64)
|
|
| 2957 | + INSTRUCTION(bci_OP_MUL_64): SIZED_BIN_OP(*, StgInt64)
|
|
| 2958 | + INSTRUCTION(bci_OP_SHL_64): SIZED_BIN_OP_TY_INT(<<, StgWord64)
|
|
| 2959 | + INSTRUCTION(bci_OP_LSR_64): SIZED_BIN_OP_TY_INT(>>, StgWord64)
|
|
| 2960 | + INSTRUCTION(bci_OP_ASR_64): SIZED_BIN_OP_TY_INT(>>, StgInt64)
|
|
| 2961 | + |
|
| 2962 | + INSTRUCTION(bci_OP_NEQ_64): SIZED_BIN_OP_TY_TY_INT(!=, StgWord64)
|
|
| 2963 | + INSTRUCTION(bci_OP_EQ_64): SIZED_BIN_OP_TY_TY_INT(==, StgWord64)
|
|
| 2964 | + INSTRUCTION(bci_OP_U_GT_64): SIZED_BIN_OP_TY_TY_INT(>, StgWord64)
|
|
| 2965 | + INSTRUCTION(bci_OP_U_GE_64): SIZED_BIN_OP_TY_TY_INT(>=, StgWord64)
|
|
| 2966 | + INSTRUCTION(bci_OP_U_LT_64): SIZED_BIN_OP_TY_TY_INT(<, StgWord64)
|
|
| 2967 | + INSTRUCTION(bci_OP_U_LE_64): SIZED_BIN_OP_TY_TY_INT(<=, StgWord64)
|
|
| 2968 | + |
|
| 2969 | + INSTRUCTION(bci_OP_S_GT_64): SIZED_BIN_OP_TY_TY_INT(>, StgInt64)
|
|
| 2970 | + INSTRUCTION(bci_OP_S_GE_64): SIZED_BIN_OP_TY_TY_INT(>=, StgInt64)
|
|
| 2971 | + INSTRUCTION(bci_OP_S_LT_64): SIZED_BIN_OP_TY_TY_INT(<, StgInt64)
|
|
| 2972 | + INSTRUCTION(bci_OP_S_LE_64): SIZED_BIN_OP_TY_TY_INT(<=, StgInt64)
|
|
| 2973 | + |
|
| 2974 | + INSTRUCTION(bci_OP_NOT_64): UN_SIZED_OP(~, StgWord64)
|
|
| 2975 | + INSTRUCTION(bci_OP_NEG_64): UN_SIZED_OP(-, StgInt64)
|
|
| 2976 | + |
|
| 2977 | + |
|
| 2978 | + INSTRUCTION(bci_OP_ADD_32): SIZED_BIN_OP(+, StgInt32)
|
|
| 2979 | + INSTRUCTION(bci_OP_SUB_32): SIZED_BIN_OP(-, StgInt32)
|
|
| 2980 | + INSTRUCTION(bci_OP_AND_32): SIZED_BIN_OP(&, StgInt32)
|
|
| 2981 | + INSTRUCTION(bci_OP_XOR_32): SIZED_BIN_OP(^, StgInt32)
|
|
| 2982 | + INSTRUCTION(bci_OP_OR_32): SIZED_BIN_OP(|, StgInt32)
|
|
| 2983 | + INSTRUCTION(bci_OP_MUL_32): SIZED_BIN_OP(*, StgInt32)
|
|
| 2984 | + INSTRUCTION(bci_OP_SHL_32): SIZED_BIN_OP_TY_INT(<<, StgWord32)
|
|
| 2985 | + INSTRUCTION(bci_OP_LSR_32): SIZED_BIN_OP_TY_INT(>>, StgWord32)
|
|
| 2986 | + INSTRUCTION(bci_OP_ASR_32): SIZED_BIN_OP_TY_INT(>>, StgInt32)
|
|
| 2987 | + |
|
| 2988 | + INSTRUCTION(bci_OP_NEQ_32): SIZED_BIN_OP_TY_TY_INT(!=, StgWord32)
|
|
| 2989 | + INSTRUCTION(bci_OP_EQ_32): SIZED_BIN_OP_TY_TY_INT(==, StgWord32)
|
|
| 2990 | + INSTRUCTION(bci_OP_U_GT_32): SIZED_BIN_OP_TY_TY_INT(>, StgWord32)
|
|
| 2991 | + INSTRUCTION(bci_OP_U_GE_32): SIZED_BIN_OP_TY_TY_INT(>=, StgWord32)
|
|
| 2992 | + INSTRUCTION(bci_OP_U_LT_32): SIZED_BIN_OP_TY_TY_INT(<, StgWord32)
|
|
| 2993 | + INSTRUCTION(bci_OP_U_LE_32): SIZED_BIN_OP_TY_TY_INT(<=, StgWord32)
|
|
| 2994 | + |
|
| 2995 | + INSTRUCTION(bci_OP_S_GT_32): SIZED_BIN_OP_TY_TY_INT(>, StgInt32)
|
|
| 2996 | + INSTRUCTION(bci_OP_S_GE_32): SIZED_BIN_OP_TY_TY_INT(>=, StgInt32)
|
|
| 2997 | + INSTRUCTION(bci_OP_S_LT_32): SIZED_BIN_OP_TY_TY_INT(<, StgInt32)
|
|
| 2998 | + INSTRUCTION(bci_OP_S_LE_32): SIZED_BIN_OP_TY_TY_INT(<=, StgInt32)
|
|
| 2999 | + |
|
| 3000 | + INSTRUCTION(bci_OP_NOT_32): UN_SIZED_OP(~, StgWord32)
|
|
| 3001 | + INSTRUCTION(bci_OP_NEG_32): UN_SIZED_OP(-, StgInt32)
|
|
| 3002 | + |
|
| 3003 | + |
|
| 3004 | + INSTRUCTION(bci_OP_ADD_16): SIZED_BIN_OP(+, StgInt16)
|
|
| 3005 | + INSTRUCTION(bci_OP_SUB_16): SIZED_BIN_OP(-, StgInt16)
|
|
| 3006 | + INSTRUCTION(bci_OP_AND_16): SIZED_BIN_OP(&, StgInt16)
|
|
| 3007 | + INSTRUCTION(bci_OP_XOR_16): SIZED_BIN_OP(^, StgInt16)
|
|
| 3008 | + INSTRUCTION(bci_OP_OR_16): SIZED_BIN_OP(|, StgInt16)
|
|
| 3009 | + INSTRUCTION(bci_OP_MUL_16): SIZED_BIN_OP(*, StgInt16)
|
|
| 3010 | + INSTRUCTION(bci_OP_SHL_16): SIZED_BIN_OP_TY_INT(<<, StgWord16)
|
|
| 3011 | + INSTRUCTION(bci_OP_LSR_16): SIZED_BIN_OP_TY_INT(>>, StgWord16)
|
|
| 3012 | + INSTRUCTION(bci_OP_ASR_16): SIZED_BIN_OP_TY_INT(>>, StgInt16)
|
|
| 3013 | + |
|
| 3014 | + INSTRUCTION(bci_OP_NEQ_16): SIZED_BIN_OP_TY_TY_INT(!=, StgWord16)
|
|
| 3015 | + INSTRUCTION(bci_OP_EQ_16): SIZED_BIN_OP_TY_TY_INT(==, StgWord16)
|
|
| 3016 | + INSTRUCTION(bci_OP_U_GT_16): SIZED_BIN_OP_TY_TY_INT(>, StgWord16)
|
|
| 3017 | + INSTRUCTION(bci_OP_U_GE_16): SIZED_BIN_OP_TY_TY_INT(>=, StgWord16)
|
|
| 3018 | + INSTRUCTION(bci_OP_U_LT_16): SIZED_BIN_OP_TY_TY_INT(<, StgWord16)
|
|
| 3019 | + INSTRUCTION(bci_OP_U_LE_16): SIZED_BIN_OP_TY_TY_INT(<=, StgWord16)
|
|
| 3020 | + |
|
| 3021 | + INSTRUCTION(bci_OP_S_GT_16): SIZED_BIN_OP(>, StgInt16)
|
|
| 3022 | + INSTRUCTION(bci_OP_S_GE_16): SIZED_BIN_OP(>=, StgInt16)
|
|
| 3023 | + INSTRUCTION(bci_OP_S_LT_16): SIZED_BIN_OP(<, StgInt16)
|
|
| 3024 | + INSTRUCTION(bci_OP_S_LE_16): SIZED_BIN_OP(<=, StgInt16)
|
|
| 3025 | + |
|
| 3026 | + INSTRUCTION(bci_OP_NOT_16): UN_SIZED_OP(~, StgWord16)
|
|
| 3027 | + INSTRUCTION(bci_OP_NEG_16): UN_SIZED_OP(-, StgInt16)
|
|
| 3028 | + |
|
| 3029 | + |
|
| 3030 | + INSTRUCTION(bci_OP_ADD_08): SIZED_BIN_OP(+, StgInt8)
|
|
| 3031 | + INSTRUCTION(bci_OP_SUB_08): SIZED_BIN_OP(-, StgInt8)
|
|
| 3032 | + INSTRUCTION(bci_OP_AND_08): SIZED_BIN_OP(&, StgInt8)
|
|
| 3033 | + INSTRUCTION(bci_OP_XOR_08): SIZED_BIN_OP(^, StgInt8)
|
|
| 3034 | + INSTRUCTION(bci_OP_OR_08): SIZED_BIN_OP(|, StgInt8)
|
|
| 3035 | + INSTRUCTION(bci_OP_MUL_08): SIZED_BIN_OP(*, StgInt8)
|
|
| 3036 | + INSTRUCTION(bci_OP_SHL_08): SIZED_BIN_OP_TY_INT(<<, StgWord8)
|
|
| 3037 | + INSTRUCTION(bci_OP_LSR_08): SIZED_BIN_OP_TY_INT(>>, StgWord8)
|
|
| 3038 | + INSTRUCTION(bci_OP_ASR_08): SIZED_BIN_OP_TY_INT(>>, StgInt8)
|
|
| 3039 | + |
|
| 3040 | + INSTRUCTION(bci_OP_NEQ_08): SIZED_BIN_OP_TY_TY_INT(!=, StgWord8)
|
|
| 3041 | + INSTRUCTION(bci_OP_EQ_08): SIZED_BIN_OP_TY_TY_INT(==, StgWord8)
|
|
| 3042 | + INSTRUCTION(bci_OP_U_GT_08): SIZED_BIN_OP_TY_TY_INT(>, StgWord8)
|
|
| 3043 | + INSTRUCTION(bci_OP_U_GE_08): SIZED_BIN_OP_TY_TY_INT(>=, StgWord8)
|
|
| 3044 | + INSTRUCTION(bci_OP_U_LT_08): SIZED_BIN_OP_TY_TY_INT(<, StgWord8)
|
|
| 3045 | + INSTRUCTION(bci_OP_U_LE_08): SIZED_BIN_OP_TY_TY_INT(<=, StgWord8)
|
|
| 3046 | + |
|
| 3047 | + INSTRUCTION(bci_OP_S_GT_08): SIZED_BIN_OP_TY_TY_INT(>, StgInt8)
|
|
| 3048 | + INSTRUCTION(bci_OP_S_GE_08): SIZED_BIN_OP_TY_TY_INT(>=, StgInt8)
|
|
| 3049 | + INSTRUCTION(bci_OP_S_LT_08): SIZED_BIN_OP_TY_TY_INT(<, StgInt8)
|
|
| 3050 | + INSTRUCTION(bci_OP_S_LE_08): SIZED_BIN_OP_TY_TY_INT(<=, StgInt8)
|
|
| 3051 | + |
|
| 3052 | + INSTRUCTION(bci_OP_NOT_08): UN_SIZED_OP(~, StgWord8)
|
|
| 3053 | + INSTRUCTION(bci_OP_NEG_08): UN_SIZED_OP(-, StgInt8)
|
|
| 3054 | + |
|
| 3055 | + INSTRUCTION(bci_OP_INDEX_ADDR_64):
|
|
| 2732 | 3056 | {
|
| 2733 | 3057 | StgWord64* addr = (StgWord64*) SpW(0);
|
| 2734 | 3058 | StgInt offset = (StgInt) SpW(1);
|
| ... | ... | @@ -2736,35 +3060,35 @@ run_BCO: |
| 2736 | 3060 | Sp_addW(1);
|
| 2737 | 3061 | }
|
| 2738 | 3062 | SpW64(0) = *(addr+offset);
|
| 2739 | - goto nextInsn;
|
|
| 3063 | + NEXT_INSTRUCTION;
|
|
| 2740 | 3064 | }
|
| 2741 | 3065 | |
| 2742 | - case bci_OP_INDEX_ADDR_32:
|
|
| 3066 | + INSTRUCTION(bci_OP_INDEX_ADDR_32):
|
|
| 2743 | 3067 | {
|
| 2744 | 3068 | StgWord32* addr = (StgWord32*) SpW(0);
|
| 2745 | 3069 | StgInt offset = (StgInt) SpW(1);
|
| 2746 | 3070 | Sp_addW(1);
|
| 2747 | 3071 | SpW(0) = (StgWord) *(addr+offset);
|
| 2748 | - goto nextInsn;
|
|
| 3072 | + NEXT_INSTRUCTION;
|
|
| 2749 | 3073 | }
|
| 2750 | - case bci_OP_INDEX_ADDR_16:
|
|
| 3074 | + INSTRUCTION(bci_OP_INDEX_ADDR_16):
|
|
| 2751 | 3075 | {
|
| 2752 | 3076 | StgWord16* addr = (StgWord16*) SpW(0);
|
| 2753 | 3077 | StgInt offset = (StgInt) SpW(1);
|
| 2754 | 3078 | Sp_addW(1);
|
| 2755 | 3079 | SpW(0) = (StgWord) *(addr+offset);
|
| 2756 | - goto nextInsn;
|
|
| 3080 | + NEXT_INSTRUCTION;
|
|
| 2757 | 3081 | }
|
| 2758 | - case bci_OP_INDEX_ADDR_08:
|
|
| 3082 | + INSTRUCTION(bci_OP_INDEX_ADDR_08):
|
|
| 2759 | 3083 | {
|
| 2760 | 3084 | StgWord8* addr = (StgWord8*) SpW(0);
|
| 2761 | 3085 | StgInt offset = (StgInt) SpW(1);
|
| 2762 | 3086 | Sp_addW(1);
|
| 2763 | 3087 | SpW(0) = (StgWord) *(addr+offset);
|
| 2764 | - goto nextInsn;
|
|
| 3088 | + NEXT_INSTRUCTION;
|
|
| 2765 | 3089 | }
|
| 2766 | 3090 | |
| 2767 | - case bci_CCALL: {
|
|
| 3091 | + INSTRUCTION(bci_CCALL): {
|
|
| 2768 | 3092 | void *tok;
|
| 2769 | 3093 | W_ stk_offset = BCO_GET_LARGE_ARG;
|
| 2770 | 3094 | int o_itbl = BCO_GET_LARGE_ARG;
|
| ... | ... | @@ -2921,25 +3245,33 @@ run_BCO: |
| 2921 | 3245 | memcpy(Sp, ret, sizeof(W_) * ret_size);
|
| 2922 | 3246 | #endif
|
| 2923 | 3247 | |
| 2924 | - goto nextInsn;
|
|
| 3248 | + NEXT_INSTRUCTION;
|
|
| 2925 | 3249 | }
|
| 2926 | 3250 | |
| 2927 | - case bci_JMP: {
|
|
| 3251 | + INSTRUCTION(bci_JMP): {
|
|
| 2928 | 3252 | /* BCO_NEXT modifies bciPtr, so be conservative. */
|
| 2929 | 3253 | int nextpc = BCO_GET_LARGE_ARG;
|
| 2930 | 3254 | bciPtr = nextpc;
|
| 2931 | - goto nextInsn;
|
|
| 3255 | + NEXT_INSTRUCTION;
|
|
| 2932 | 3256 | }
|
| 2933 | 3257 | |
| 2934 | - case bci_CASEFAIL:
|
|
| 3258 | + INSTRUCTION(bci_CASEFAIL):
|
|
| 2935 | 3259 | barf("interpretBCO: hit a CASEFAIL");
|
| 2936 | 3260 | |
| 2937 | - // Errors
|
|
| 3261 | + |
|
| 3262 | + |
|
| 3263 | +#if defined(COMPUTED_GOTO)
|
|
| 3264 | + INSTRUCTION(bci_DEFAULT):
|
|
| 3265 | + barf("interpretBCO: unknown or unimplemented opcode %d",
|
|
| 3266 | + (int)(bci & 0xFF));
|
|
| 3267 | +#else
|
|
| 3268 | + // Errors
|
|
| 2938 | 3269 | default:
|
| 2939 | 3270 | barf("interpretBCO: unknown or unimplemented opcode %d",
|
| 2940 | 3271 | (int)(bci & 0xFF));
|
| 2941 | - |
|
| 2942 | 3272 | } /* switch on opcode */
|
| 3273 | +#endif
|
|
| 3274 | + |
|
| 2943 | 3275 | }
|
| 2944 | 3276 | }
|
| 2945 | 3277 |
| ... | ... | @@ -197,7 +197,7 @@ static inline void postBuf(EventsBuf *eb, const StgWord8 *buf, uint32_t size) |
| 197 | 197 | static inline void postStringLen(EventsBuf *eb, const char *buf, StgWord len)
|
| 198 | 198 | {
|
| 199 | 199 | if (buf) {
|
| 200 | - ASSERT(eb->begin + eb->size > eb->pos + len + 1);
|
|
| 200 | + ASSERT(eb->pos + len + 1 <= eb->begin + eb->size);
|
|
| 201 | 201 | memcpy(eb->pos, buf, len);
|
| 202 | 202 | eb->pos += len;
|
| 203 | 203 | }
|
| 1 | 1 | #!/usr/bin/env python
|
| 2 | 2 | # -*- coding: utf-8 -*-
|
| 3 | 3 | |
| 4 | +from pathlib import Path
|
|
| 4 | 5 | from typing import List, Union, Dict
|
| 5 | 6 | from collections import namedtuple
|
| 6 | 7 | |
| ... | ... | @@ -198,17 +199,17 @@ def generate_event_types_defines() -> str: |
| 198 | 199 | def main() -> None:
|
| 199 | 200 | import argparse
|
| 200 | 201 | parser = argparse.ArgumentParser()
|
| 201 | - parser.add_argument('--event-types-array', type=argparse.FileType('w'), metavar='FILE')
|
|
| 202 | - parser.add_argument('--event-types-defines', type=argparse.FileType('w'), metavar='FILE')
|
|
| 202 | + parser.add_argument('--event-types-array', type=Path, metavar='FILE')
|
|
| 203 | + parser.add_argument('--event-types-defines', type=Path, metavar='FILE')
|
|
| 203 | 204 | args = parser.parse_args()
|
| 204 | 205 | |
| 205 | 206 | check_events()
|
| 206 | 207 | |
| 207 | 208 | if args.event_types_array:
|
| 208 | - args.event_types_array.write(generate_event_types_array())
|
|
| 209 | + args.event_types_array.write_text(generate_event_types_array())
|
|
| 209 | 210 | |
| 210 | 211 | if args.event_types_defines:
|
| 211 | - args.event_types_defines.write(generate_event_types_defines())
|
|
| 212 | + args.event_types_defines.write_text(generate_event_types_defines())
|
|
| 212 | 213 | |
| 213 | 214 | if __name__ == '__main__':
|
| 214 | 215 | main() |
| ... | ... | @@ -23,6 +23,11 @@ |
| 23 | 23 | I hope that's clear :-)
|
| 24 | 24 | */
|
| 25 | 25 | |
| 26 | +/*
|
|
| 27 | + Make sure to update jumptable in rts/Interpreter.c when modifying
|
|
| 28 | + bytecodes! See Note [Instruction dispatch in the bytecode interpreter]
|
|
| 29 | + for details.
|
|
| 30 | +*/
|
|
| 26 | 31 | #define bci_STKCHECK 1
|
| 27 | 32 | #define bci_PUSH_L 2
|
| 28 | 33 | #define bci_PUSH_LL 3
|
| ... | ... | @@ -83,7 +83,7 @@ parser.add_argument("--way", action="append", help="just this way") |
| 83 | 83 | parser.add_argument("--skipway", action="append", help="skip this way")
|
| 84 | 84 | parser.add_argument("--threads", type=int, help="threads to run simultaneously")
|
| 85 | 85 | parser.add_argument("--verbose", type=int, choices=[0,1,2,3,4,5], help="verbose (Values 0 through 5 accepted)")
|
| 86 | -parser.add_argument("--junit", type=argparse.FileType('wb'), help="output testsuite summary in JUnit format")
|
|
| 86 | +parser.add_argument("--junit", type=Path, help="output testsuite summary in JUnit format")
|
|
| 87 | 87 | parser.add_argument("--broken-test", action="append", default=[], help="a test name to mark as broken for this run")
|
| 88 | 88 | parser.add_argument("--test-env", default='local', help="Override default chosen test-env.")
|
| 89 | 89 | 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 |
| 91 | 91 | perf_group.add_argument("--only-perf-tests", action="store_true", help="Only do performance tests")
|
| 92 | 92 | parser.add_argument("--ignore-perf-failures", choices=['increases','decreases','all'],
|
| 93 | 93 | help="Do not fail due to out-of-tolerance perf tests")
|
| 94 | -parser.add_argument("--only-report-hadrian-deps", type=argparse.FileType('w'),
|
|
| 94 | +parser.add_argument("--only-report-hadrian-deps", type=Path,
|
|
| 95 | 95 | help="Dry run the testsuite and report all extra hadrian dependencies needed on the given file")
|
| 96 | 96 | |
| 97 | 97 | args = parser.parse_args()
|
| ... | ... | @@ -615,14 +615,14 @@ else: |
| 615 | 615 | summary(t, f)
|
| 616 | 616 | |
| 617 | 617 | if args.junit:
|
| 618 | - junit(t).write(args.junit)
|
|
| 619 | - args.junit.close()
|
|
| 618 | + with args.junit.open("wb") as f:
|
|
| 619 | + junit(t).write(f)
|
|
| 620 | 620 | |
| 621 | 621 | if config.only_report_hadrian_deps:
|
| 622 | 622 | print("WARNING - skipping all tests and only reporting required hadrian dependencies:", config.hadrian_deps)
|
| 623 | - for d in config.hadrian_deps:
|
|
| 624 | - print(d,file=config.only_report_hadrian_deps)
|
|
| 625 | - config.only_report_hadrian_deps.close()
|
|
| 623 | + with config.only_report_hadrian_deps.open("w") as f:
|
|
| 624 | + for d in config.hadrian_deps:
|
|
| 625 | + print(d, file=f)
|
|
| 626 | 626 | |
| 627 | 627 | if len(t.unexpected_failures) > 0 or \
|
| 628 | 628 | len(t.unexpected_stat_failures) > 0 or \
|
| 1 | +-- | This should not issue an @-Wunused-packages@ warning for @system-cxx-std-lib@.
|
|
| 2 | +module Main where
|
|
| 3 | + |
|
| 4 | +main :: IO ()
|
|
| 5 | +main = putStrLn "hello world" |
| ... | ... | @@ -331,3 +331,4 @@ test('T24839', [unless(arch('x86_64') or arch('aarch64'), skip), extra_files(["t |
| 331 | 331 | test('t25150', [extra_files(["t25150"])], multimod_compile, ['Main.hs', '-v0 -working-dir t25150/dir a.c'])
|
| 332 | 332 | test('T25382', normal, makefile_test, [])
|
| 333 | 333 | test('T26018', req_c, makefile_test, [])
|
| 334 | +test('T24120', normal, compile, ['-Wunused-packages -hide-all-packages -package base -package system-cxx-std-lib']) |
| 1 | +{-# LANGUAGE GHC2024, TypeFamilies #-}
|
|
| 2 | + |
|
| 3 | +module T26528 where
|
|
| 4 | + |
|
| 5 | +import Data.Kind
|
|
| 6 | +import GHC.Exts
|
|
| 7 | + |
|
| 8 | +type F :: Type -> RuntimeRep
|
|
| 9 | +type family F a where
|
|
| 10 | + F Int = LiftedRep
|
|
| 11 | + |
|
| 12 | +g :: forall (r::RuntimeRep).
|
|
| 13 | + (forall (a :: TYPE r). a -> forall b. b -> b) -> Int
|
|
| 14 | +g _ = 3
|
|
| 15 | +{-# NOINLINE g #-}
|
|
| 16 | + |
|
| 17 | +foo = g @(F Int) (\x y -> y) |
| ... | ... | @@ -42,6 +42,7 @@ test('T23883b', normal, compile_fail, ['']) |
| 42 | 42 | test('T23883c', normal, compile_fail, [''])
|
| 43 | 43 | test('T23903', normal, compile_fail, [''])
|
| 44 | 44 | test('T26107', js_broken(22364), compile, ['-O'])
|
| 45 | +test('T26528', normal, compile, [''])
|
|
| 45 | 46 | |
| 46 | 47 | test('EtaExpandDataCon', normal, compile, ['-O'])
|
| 47 | 48 | test('EtaExpandStupid1', normal, compile, ['-Wno-deprecated-flags'])
|
| 1 | +{-# LANGUAGE ImplicitParams, TypeFamilies, FunctionalDependencies, ScopedTypeVariables #-}
|
|
| 2 | + |
|
| 3 | +module T26451 where
|
|
| 4 | + |
|
| 5 | +type family F a
|
|
| 6 | +type instance F Bool = [Char]
|
|
| 7 | + |
|
| 8 | +class C a b | b -> a
|
|
| 9 | +instance C Bool Bool
|
|
| 10 | +instance C Char Char
|
|
| 11 | + |
|
| 12 | +eq :: forall a b. C a b => a -> b -> ()
|
|
| 13 | +eq p q = ()
|
|
| 14 | + |
|
| 15 | +g :: a -> F a
|
|
| 16 | +g = g
|
|
| 17 | + |
|
| 18 | +f (x::tx) (y::ty) -- x :: alpha y :: beta
|
|
| 19 | + = let ?v = g x -- ?ip :: F alpha
|
|
| 20 | + in (?v::[ty], eq x True)
|
|
| 21 | + |
|
| 22 | + |
|
| 23 | +{- tx, and ty are unification variables
|
|
| 24 | + |
|
| 25 | +Inert: [G] dg :: IP "v" (F tx)
|
|
| 26 | + [W] dw :: IP "v" [ty]
|
|
| 27 | +Work-list: [W] dc1 :: C tx Bool
|
|
| 28 | + [W] dc2 :: C ty Char
|
|
| 29 | + |
|
| 30 | +* Solve dc1, we get tx := Bool from fundep
|
|
| 31 | +* Kick out dg
|
|
| 32 | +* Solve dg to get [G] dc : IP "v" [Char]
|
|
| 33 | +* Add that new dg to the inert set: that simply deletes dw!!!
|
|
| 34 | +-} |
| ... | ... | @@ -955,3 +955,4 @@ test('T26376', normal, compile, ['']) |
| 955 | 955 | test('T26457', normal, compile, [''])
|
| 956 | 956 | test('T17705', normal, compile, [''])
|
| 957 | 957 | test('T14745', normal, compile, [''])
|
| 958 | +test('T26451', normal, compile, ['']) |