Rodrigo Mesquita pushed to branch wip/romes/step-out-9 at Glasgow Haskell Compiler / GHC

Commits:

1 changed file:

Changes:

  • compiler/GHC/StgToByteCode.hs
    ... ... @@ -4,13 +4,14 @@
    4 4 
     {-# LANGUAGE LambdaCase                 #-}
    5 5 
     {-# LANGUAGE RecordWildCards            #-}
    6 6 
     {-# LANGUAGE FlexibleContexts           #-}
    7 
    +{-# LANGUAGE DerivingVia #-}
    7 8
    8 9 
     --
    9 10 
     --  (c) The University of Glasgow 2002-2006
    10 11 
     --
    11 12
    12 13 
     -- | GHC.StgToByteCode: Generate bytecode from STG
    13 
    -module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where
    14 
    +module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen ) where
    14 15
    15 16 
     import GHC.Prelude
    16 17
    ... ... @@ -96,6 +97,10 @@ import GHC.Stg.Syntax
    96 97 
     import qualified Data.IntSet as IntSet
    97 98 
     import GHC.CoreToIface
    98 99
    100 
    +import Control.Monad.IO.Class
    101 
    +import Control.Monad.Trans.Reader (ReaderT(..))
    102 
    +import Control.Monad.Trans.State  (StateT(..))
    103 
    +
    99 104 
     -- -----------------------------------------------------------------------------
    100 105 
     -- Generating byte code for a complete module
    101 106
    ... ... @@ -120,7 +125,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries
    120 125 
                 flattenBind (StgNonRec b e) = [(b,e)]
    121 126 
                 flattenBind (StgRec bs)     = bs
    122 127
    123 
    -        (BcM_State{..}, proto_bcos) <-
    128 
    +        (proto_bcos, BcM_State{..}) <-
    124 129 
                runBc hsc_env this_mod mb_modBreaks $ do
    125 130 
                  let flattened_binds = concatMap flattenBind (reverse lifted_binds)
    126 131 
                  FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds
    ... ... @@ -312,7 +317,7 @@ schemeTopBind (id, rhs)
    312 317 
             -- because mkConAppCode treats nullary constructor applications
    313 318 
             -- by just re-using the single top-level definition.  So
    314 319 
             -- for the worker itself, we must allocate it directly.
    315 
    -    -- ioToBc (putStrLn $ "top level BCO")
    320 
    +    -- liftIO (putStrLn $ "top level BCO")
    316 321 
         pure (mkProtoBCO platform add_bco_name
    317 322 
                            (getName id) (toOL [PACK data_con 0, RETURN P])
    318 323 
                            (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
    ... ... @@ -449,7 +454,7 @@ break_info hsc_env mod current_mod current_mod_breaks
    449 454 
       | mod == current_mod
    450 455 
       = pure current_mod_breaks
    451 456 
       | otherwise
    452 
    -  = ioToBc (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case
    457 
    +  = liftIO (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case
    453 458 
           Just hp -> pure $ getModBreaks hp
    454 459 
           Nothing -> pure Nothing
    455 460
    ... ... @@ -642,8 +647,8 @@ schemeE d s p (StgLet _ext binds body) = do
    642 647 
          return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
    643 648
    644 649 
     schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs)
    645 
    -   = pprPanic "schemeE: Breakpoint without let binding: " $
    646 
    -            ppr bp_id <> text " forgot to run bcPrep?"
    650 
    +   = pprPanic "schemeE: Breakpoint without let binding:"
    651 
    +        (ppr bp_id <+> text "forgot to run bcPrep?")
    647 652
    648 653 
     -- ignore other kinds of tick
    649 654 
     schemeE d s p (StgTick _ rhs) = schemeE d s p rhs
    ... ... @@ -2627,63 +2632,38 @@ typeArgReps platform = map (toArgRep platform) . typePrimRep
    2627 2632 
     -- -----------------------------------------------------------------------------
    2628 2633 
     -- The bytecode generator's monad
    2629 2634
    2635 
    +-- | Read only environment for generating ByteCode
    2636 
    +data BcM_Env
    2637 
    +   = BcM_Env
    2638 
    +        { bcm_hsc_env    :: HscEnv
    2639 
    +        , bcm_module     :: Module -- current module (for breakpoints)
    2640 
    +        }
    2641 
    +
    2630 2642 
     data BcM_State
    2631 2643 
        = BcM_State
    2632 
    -        { bcm_hsc_env :: HscEnv
    2633 
    -        , thisModule  :: Module          -- current module (for breakpoints)
    2634 
    -        , nextlabel   :: Word32          -- for generating local labels
    2635 
    -        , modBreaks   :: Maybe ModBreaks -- info about breakpoints
    2636 
    -
    2637 
    -        , breakInfo   :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence.
    2638 
    -                                            -- Indexed with breakpoint *info* index.
    2639 
    -                                            -- See Note [Breakpoint identifiers]
    2640 
    -                                            -- in GHC.Types.Breakpoint
    2641 
    -        , breakInfoIdx :: !Int              -- ^ Next index for breakInfo array
    2644 
    +        { nextlabel      :: !Word32 -- ^ For generating local labels
    2645 
    +        , breakInfoIdx   :: !Int    -- ^ Next index for breakInfo array
    2646 
    +        , modBreaks      :: Maybe ModBreaks -- info about breakpoints
    2647 
    +
    2648 
    +        , breakInfo      :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence.
    2649 
    +                                               -- Indexed with breakpoint *info* index.
    2650 
    +                                               -- See Note [Breakpoint identifiers]
    2651 
    +                                               -- in GHC.Types.Breakpoint
    2642 2652 
             }
    2643 2653
    2644 
    -newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor)
    2645 
    -
    2646 
    -ioToBc :: IO a -> BcM a
    2647 
    -ioToBc io = BcM $ \st -> do
    2648 
    -  x <- io
    2649 
    -  return (st, x)
    2650 
    -
    2651 
    -runBc :: HscEnv -> Module -> Maybe ModBreaks
    2652 
    -      -> BcM r
    2653 
    -      -> IO (BcM_State, r)
    2654 
    -runBc hsc_env this_mod modBreaks (BcM m)
    2655 
    -   = m (BcM_State hsc_env this_mod 0 modBreaks IntMap.empty 0)
    2654 
    +newtype BcM r = BcM (BcM_Env -> BcM_State -> IO (r, BcM_State))
    2655 
    +  deriving (Functor, Applicative, Monad, MonadIO)
    2656 
    +    via (ReaderT BcM_Env (StateT BcM_State IO))
    2656 2657
    2657 
    -thenBc :: BcM a -> (a -> BcM b) -> BcM b
    2658 
    -thenBc (BcM expr) cont = BcM $ \st0 -> do
    2659 
    -  (st1, q) <- expr st0
    2660 
    -  let BcM k = cont q
    2661 
    -  (st2, r) <- k st1
    2662 
    -  return (st2, r)
    2663 
    -
    2664 
    -thenBc_ :: BcM a -> BcM b -> BcM b
    2665 
    -thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
    2666 
    -  (st1, _) <- expr st0
    2667 
    -  (st2, r) <- cont st1
    2668 
    -  return (st2, r)
    2669 
    -
    2670 
    -returnBc :: a -> BcM a
    2671 
    -returnBc result = BcM $ \st -> (return (st, result))
    2672 
    -
    2673 
    -instance Applicative BcM where
    2674 
    -    pure = returnBc
    2675 
    -    (<*>) = ap
    2676 
    -    (*>) = thenBc_
    2677 
    -
    2678 
    -instance Monad BcM where
    2679 
    -  (>>=) = thenBc
    2680 
    -  (>>)  = (*>)
    2658 
    +runBc :: HscEnv -> Module -> Maybe ModBreaks -> BcM r -> IO (r, BcM_State)
    2659 
    +runBc hsc_env this_mod mbs (BcM m)
    2660 
    +   = m (BcM_Env hsc_env this_mod) (BcM_State 0 0 mbs IntMap.empty)
    2681 2661
    2682 2662 
     instance HasDynFlags BcM where
    2683 
    -    getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))
    2663 
    +    getDynFlags = hsc_dflags <$> getHscEnv
    2684 2664
    2685 2665 
     getHscEnv :: BcM HscEnv
    2686 
    -getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)
    2666 
    +getHscEnv = BcM $ \env st -> return (bcm_hsc_env env, st)
    2687 2667
    2688 2668 
     getProfile :: BcM Profile
    2689 2669 
     getProfile = targetProfile <$> getDynFlags
    ... ... @@ -2696,31 +2676,31 @@ shouldAddBcoName = do
    2696 2676 
         else return Nothing
    2697 2677
    2698 2678 
     getLabelBc :: BcM LocalLabel
    2699 
    -getLabelBc
    2700 
    -  = BcM $ \st -> do let nl = nextlabel st
    2701 
    -                    when (nl == maxBound) $
    2702 
    -                        panic "getLabelBc: Ran out of labels"
    2703 
    -                    return (st{nextlabel = nl + 1}, LocalLabel nl)
    2679 
    +getLabelBc = BcM $ \_ st ->
    2680 
    +  do let nl = nextlabel st
    2681 
    +     when (nl == maxBound) $
    2682 
    +         panic "getLabelBc: Ran out of labels"
    2683 
    +     return (LocalLabel nl, st{nextlabel = nl + 1})
    2704 2684
    2705 2685 
     getLabelsBc :: Word32 -> BcM [LocalLabel]
    2706 
    -getLabelsBc n
    2707 
    -  = BcM $ \st -> let ctr = nextlabel st
    2708 
    -                 in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1])
    2686 
    +getLabelsBc n = BcM $ \_ st ->
    2687 
    +  let ctr = nextlabel st
    2688 
    +   in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n})
    2709 2689
    2710 2690 
     newBreakInfo :: CgBreakInfo -> BcM Int
    2711 
    -newBreakInfo info = BcM $ \st ->
    2691 
    +newBreakInfo info = BcM $ \_ st ->
    2712 2692 
       let ix = breakInfoIdx st
    2713 2693 
           st' = st
    2714 
    -              { breakInfo = IntMap.insert ix info (breakInfo st)
    2715 
    -              , breakInfoIdx = ix + 1
    2716 
    -              }
    2717 
    -  in return (st', ix)
    2694 
    +        { breakInfo = IntMap.insert ix info (breakInfo st)
    2695 
    +        , breakInfoIdx = ix + 1
    2696 
    +        }
    2697 
    +  in return (ix, st')
    2718 2698
    2719 2699 
     getCurrentModule :: BcM Module
    2720 
    -getCurrentModule = BcM $ \st -> return (st, thisModule st)
    2700 
    +getCurrentModule = BcM $ \env st -> return (bcm_module env, st)
    2721 2701
    2722 2702 
     getCurrentModBreaks :: BcM (Maybe ModBreaks)
    2723 
    -getCurrentModBreaks = BcM $ \st -> return (st, modBreaks st)
    2703 
    +getCurrentModBreaks = BcM $ \_env st -> return (modBreaks st, st)
    2724 2704
    2725 2705 
     tickFS :: FastString
    2726 2706 
     tickFS = fsLit "ticked"

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