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

Commits:

6 changed files:

Changes:

  • compiler/GHC/HsToCore.hs
    ... ... @@ -97,8 +97,8 @@ import GHC.Unit.Module.Deps
    97 97
    98 98 
     import Data.List (partition)
    99 99 
     import Data.IORef
    100 
    -import Data.Traversable (for)
    101 100 
     import GHC.Iface.Make (mkRecompUsageInfo)
    101 
    +import GHC.Runtime.Interpreter (interpreterProfiled)
    102 102
    103 103 
     {-
    104 104 
     ************************************************************************
    ... ... @@ -162,13 +162,12 @@ deSugar hsc_env
    162 162 
                                            mod mod_loc
    163 163 
                                            export_set (typeEnvTyCons type_env) binds
    164 164 
                                   else return (binds, Nothing)
    165 
    -        ; modBreaks <- for
    166 
    -           [ (i, s)
    167 
    -           | i <- hsc_interp hsc_env
    168 
    -           , (_, s) <- m_tickInfo
    169 
    -           , breakpointsAllowed dflags
    170 
    -           ]
    171 
    -           $ \(interp, specs) -> mkModBreaks interp mod specs
    165 
    +        ; let modBreaks
    166 
    +                | Just (_, specs) <- m_tickInfo
    167 
    +                , breakpointsAllowed dflags
    168 
    +                = Just $ mkModBreaks (interpreterProfiled $ hscInterp hsc_env) mod specs
    169 
    +                | otherwise
    170 
    +                = Nothing
    172 171
    173 172 
             ; ds_hpc_info <- case m_tickInfo of
    174 173 
                 Just (orig_file2, ticks)

  • compiler/GHC/HsToCore/Breakpoints.hs
    ... ... @@ -33,14 +33,6 @@ import GHC.Unit.Module (Module)
    33 33 
     import GHC.Utils.Outputable
    34 34 
     import Data.List (intersperse)
    35 35
    36 
    -import GHCi.BreakArray (BreakArray)
    37 
    -import GHCi.RemoteTypes (ForeignRef)
    38 
    -
    39 
    --- TODO: Break this cycle
    40 
    -import {-# SOURCE #-} GHC.Runtime.Interpreter.Types (Interp, interpreterProfiled)
    41 
    -import {-# SOURCE #-} qualified GHC.Runtime.Interpreter as GHCi (newBreakArray)
    42 
    -import Data.Array.Base (numElements)
    43 
    -
    44 36 
     --------------------------------------------------------------------------------
    45 37 
     -- ModBreaks
    46 38 
     --------------------------------------------------------------------------------
    ... ... @@ -58,10 +50,7 @@ import Data.Array.Base (numElements)
    58 50 
     -- and 'modBreaks_decls'.
    59 51 
     data ModBreaks
    60 52 
        = ModBreaks
    61 
    -   { modBreaks_flags  :: ForeignRef BreakArray
    62 
    -        -- ^ The array of flags, one per breakpoint,
    63 
    -        -- indicating which breakpoints are enabled.
    64 
    -   , modBreaks_locs   :: !(Array BreakTickIndex SrcSpan)
    53 
    +   { modBreaks_locs   :: !(Array BreakTickIndex SrcSpan)
    65 54 
             -- ^ An array giving the source span of each breakpoint.
    66 55 
        , modBreaks_vars   :: !(Array BreakTickIndex [OccName])
    67 56 
             -- ^ An array giving the names of the free variables at each breakpoint.
    ... ... @@ -83,40 +72,31 @@ data ModBreaks
    83 72 
     -- generator needs to encode this information for each expression, the data is
    84 73 
     -- allocated remotely in GHCi's address space and passed to the codegen as
    85 74 
     -- foreign pointers.
    86 
    -mkModBreaks :: Interp -> Module -> SizedSeq Tick -> IO ModBreaks
    87 
    -mkModBreaks interp mod extendedMixEntries
    88 
    -  = do
    89 
    -    let count = fromIntegral $ sizeSS extendedMixEntries
    75 
    +mkModBreaks :: Bool {-^ Whether the interpreter is profiled and thus if we should include store a CCS array -}
    76 
    +            -> Module -> SizedSeq Tick -> ModBreaks
    77 
    +mkModBreaks interpreterProfiled modl extendedMixEntries
    78 
    +  = let count = fromIntegral $ sizeSS extendedMixEntries
    90 79 
             entries = ssElts extendedMixEntries
    91 
    -    let
    92 
    -           locsTicks  = listArray (0,count-1) [ tick_loc  t | t <- entries ]
    93 
    -           varsTicks  = listArray (0,count-1) [ tick_ids  t | t <- entries ]
    94 
    -           declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ]
    95 
    -           ccs
    96 
    -             | interpreterProfiled interp =
    97 
    -                 listArray
    98 
    -                   (0, count - 1)
    99 
    -                   [ ( concat $ intersperse "." $ tick_path t,
    100 
    -                       renderWithContext defaultSDocContext $ ppr $ tick_loc t
    101 
    -                     )
    102 
    -                   | t <- entries
    103 
    -                   ]
    104 
    -             | otherwise = listArray (0, -1) []
    105 
    -    hydrateModBreaks interp $
    106 
    -      ModBreaks
    107 
    -        { modBreaks_flags = undefined,
    108 
    -          modBreaks_locs = locsTicks,
    109 
    -          modBreaks_vars = varsTicks,
    110 
    -          modBreaks_decls = declsTicks,
    111 
    -          modBreaks_ccs = ccs,
    112 
    -          modBreaks_module = mod
    113 
    -        }
    114 
    -
    115 
    -hydrateModBreaks :: Interp -> ModBreaks -> IO ModBreaks
    116 
    -hydrateModBreaks interp ModBreaks {..} = do
    117 
    -  let count = numElements modBreaks_locs
    118 
    -  modBreaks_flags <- GHCi.newBreakArray interp count
    119 
    -  pure ModBreaks {..}
    80 
    +        locsTicks  = listArray (0,count-1) [ tick_loc  t | t <- entries ]
    81 
    +        varsTicks  = listArray (0,count-1) [ tick_ids  t | t <- entries ]
    82 
    +        declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ]
    83 
    +        ccs
    84 
    +          | interpreterProfiled =
    85 
    +              listArray
    86 
    +                (0, count - 1)
    87 
    +                [ ( concat $ intersperse "." $ tick_path t,
    88 
    +                    renderWithContext defaultSDocContext $ ppr $ tick_loc t
    89 
    +                  )
    90 
    +                | t <- entries
    91 
    +                ]
    92 
    +          | otherwise = listArray (0, -1) []
    93 
    +     in ModBreaks
    94 
    +      { modBreaks_locs   = locsTicks
    95 
    +      , modBreaks_vars   = varsTicks
    96 
    +      , modBreaks_decls  = declsTicks
    97 
    +      , modBreaks_ccs    = ccs
    98 
    +      , modBreaks_module = modl
    99 
    +      }
    120 100
    121 101 
     {-
    122 102 
     Note [Field modBreaks_decls]

  • compiler/GHC/Linker/Loader.hs
    ... ... @@ -28,6 +28,7 @@ module GHC.Linker.Loader
    28 28 
        , extendLoadedEnv
    29 29 
        , deleteFromLoadedEnv
    30 30 
        -- * Internals
    31 
    +   , allocateBreakArrays
    31 32 
        , rmDupLinkables
    32 33 
        , modifyLoaderState
    33 34 
        , initLinkDepsOpts
    ... ... @@ -122,8 +123,8 @@ import System.Win32.Info (getSystemDirectory)
    122 123 
     import GHC.Utils.Exception
    123 124 
     import GHC.Unit.Home.Graph (lookupHug, unitEnv_foldWithKey)
    124 125 
     import GHC.Driver.Downsweep
    125 
    -
    126 
    -
    126 
    +import qualified GHC.Runtime.Interpreter as GHCi
    127 
    +import Data.Array.Base (numElements)
    127 128
    128 129 
     -- Note [Linkers and loaders]
    129 130 
     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -696,16 +697,8 @@ loadDecls interp hsc_env span linkable = do
    696 697 
               let le  = linker_env pls
    697 698 
               le2_itbl_env <- linkITbls interp (itbl_env le) (concat $ map bc_itbls cbcs)
    698 699 
               le2_addr_env <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le) cbcs
    699 
    -          le2_breakarray_env <-
    700 
    -            allocateBreakArrays
    701 
    -              interp
    702 
    -              (catMaybes $ map bc_breaks cbcs)
    703 
    -              (breakarray_env le)
    704 
    -          le2_ccs_env <-
    705 
    -            allocateCCS
    706 
    -              interp
    707 
    -              (catMaybes $ map bc_breaks cbcs)
    708 
    -              (ccs_env le)
    700 
    +          le2_breakarray_env <- allocateBreakArrays interp (breakarray_env le) (catMaybes $ map bc_breaks cbcs)
    701 
    +          le2_ccs_env        <- allocateCCS         interp (ccs_env le)        (catMaybes $ map bc_breaks cbcs)
    709 702 
               let le2 = le { itbl_env = le2_itbl_env
    710 703 
                            , addr_env = le2_addr_env
    711 704 
                            , breakarray_env = le2_breakarray_env
    ... ... @@ -933,12 +926,8 @@ dynLinkBCOs interp pls bcos = do
    933 926 
                 le1 = linker_env pls
    934 927 
             ie2 <- linkITbls interp (itbl_env le1) (concatMap bc_itbls cbcs)
    935 928 
             ae2 <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le1) cbcs
    936 
    -        be2 <-
    937 
    -          allocateBreakArrays
    938 
    -            interp
    939 
    -            (catMaybes $ map bc_breaks cbcs)
    940 
    -            (breakarray_env le1)
    941 
    -        ce2 <- allocateCCS interp (catMaybes $ map bc_breaks cbcs) (ccs_env le1)
    929 
    +        be2 <- allocateBreakArrays interp (breakarray_env le1) (catMaybes $ map bc_breaks cbcs)
    930 
    +        ce2 <- allocateCCS         interp (ccs_env le1)        (catMaybes $ map bc_breaks cbcs)
    942 931 
             let le2 = le1 { itbl_env = ie2, addr_env = ae2, breakarray_env = be2, ccs_env = ce2 }
    943 932
    944 933 
             names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs
    ... ... @@ -1656,30 +1645,34 @@ allocateTopStrings interp topStrings prev_env = do
    1656 1645 
       where
    1657 1646 
         mk_entry nm ptr = (nm, (nm, AddrPtr ptr))
    1658 1647
    1659 
    --- | Given a list of 'ModBreaks' collected from a list of
    1660 
    --- 'CompiledByteCode', allocate the 'BreakArray'.
    1648 
    +-- | Given a list of 'InternalModBreaks' collected from a list of
    1649 
    +-- 'CompiledByteCode', allocate the 'BreakArray' used to trigger breakpoints.
    1661 1650 
     allocateBreakArrays ::
    1662 1651 
       Interp ->
    1663 
    -  [InternalModBreaks] ->
    1664 1652 
       ModuleEnv (ForeignRef BreakArray) ->
    1653 
    +  [InternalModBreaks] ->
    1665 1654 
       IO (ModuleEnv (ForeignRef BreakArray))
    1666 
    -allocateBreakArrays _interp mbs be =
    1655 
    +allocateBreakArrays interp =
    1667 1656 
       foldlM
    1668 
    -    ( \be0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} ->
    1669 
    -        evaluate $ extendModuleEnv be0 modBreaks_module modBreaks_flags
    1657 
    +    ( \be0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} -> do
    1658 
    +        -- If no BreakArray is assigned to this module yet, create one
    1659 
    +        if not $ elemModuleEnv modBreaks_module be0 then do
    1660 
    +          let count = numElements modBreaks_locs
    1661 
    +          breakArray <- GHCi.newBreakArray interp count
    1662 
    +          evaluate $ extendModuleEnv be0 modBreaks_module breakArray
    1663 
    +        else
    1664 
    +          return be0
    1670 1665 
         )
    1671 
    -    be
    1672 
    -    mbs
    1673 1666
    1674 
    --- | Given a list of 'ModBreaks' collected from a list of
    1675 
    --- 'CompiledByteCode', allocate the 'CostCentre' arrays when profiling
    1676 
    --- is enabled.
    1667 
    +-- | Given a list of 'InternalModBreaks' collected from a list
    1668 
    +-- of 'CompiledByteCode', allocate the 'CostCentre' arrays when profiling is
    1669 
    +-- enabled.
    1677 1670 
     allocateCCS ::
    1678 1671 
       Interp ->
    1679 
    -  [InternalModBreaks] ->
    1680 1672 
       ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)) ->
    1673 
    +  [InternalModBreaks] ->
    1681 1674 
       IO (ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)))
    1682 
    -allocateCCS interp mbs ce
    1675 
    +allocateCCS interp ce mbss
    1683 1676 
       | interpreterProfiled interp =
    1684 1677 
           foldlM
    1685 1678 
             ( \ce0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} -> do
    ... ... @@ -1688,12 +1681,15 @@ allocateCCS interp mbs ce
    1688 1681 
                     interp
    1689 1682 
                     (moduleNameString $ moduleName modBreaks_module)
    1690 1683 
                     (elems modBreaks_ccs)
    1691 
    -            evaluate $
    1692 
    -              extendModuleEnv ce0 modBreaks_module $
    1693 
    -                listArray
    1694 
    -                  (0, length ccs - 1)
    1695 
    -                  ccs
    1684 
    +            if not $ elemModuleEnv modBreaks_module ce0 then do
    1685 
    +              evaluate $
    1686 
    +                extendModuleEnv ce0 modBreaks_module $
    1687 
    +                  listArray
    1688 
    +                    (0, length ccs - 1)
    1689 
    +                    ccs
    1690 
    +            else
    1691 
    +              return ce0
    1696 1692 
             )
    1697 1693 
             ce
    1698 
    -        mbs
    1694 
    +        mbss
    1699 1695 
       | otherwise = pure ce

  • compiler/GHC/Runtime/Eval.hs
    ... ... @@ -64,6 +64,7 @@ import GHCi.RemoteTypes
    64 64 
     import GHC.ByteCode.Types
    65 65
    66 66 
     import GHC.Linker.Loader as Loader
    67 
    +import GHC.Linker.Types (LinkerEnv(..))
    67 68
    68 69 
     import GHC.Hs
    69 70
    ... ... @@ -126,6 +127,7 @@ import GHC.Tc.Utils.Instantiate (instDFunType)
    126 127 
     import GHC.Tc.Utils.Monad
    127 128
    128 129 
     import GHC.IfaceToCore
    130 
    +import GHC.ByteCode.Breakpoints
    129 131
    130 132 
     import Control.Monad
    131 133 
     import Data.Dynamic
    ... ... @@ -134,7 +136,7 @@ import Data.List (find,intercalate)
    134 136 
     import Data.List.NonEmpty (NonEmpty)
    135 137 
     import Unsafe.Coerce ( unsafeCoerce )
    136 138 
     import qualified GHC.Unit.Home.Graph as HUG
    137 
    -import GHC.ByteCode.Breakpoints
    139 
    +import GHCi.BreakArray (BreakArray)
    138 140
    139 141 
     -- -----------------------------------------------------------------------------
    140 142 
     -- running a statement interactively
    ... ... @@ -348,13 +350,14 @@ handleRunStatus step expr bindings final_ids status history0 = do
    348 350 
         EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do
    349 351 
           let ibi = evalBreakpointToId eval_break
    350 352 
           let hug = hsc_HUG hsc_env
    351 
    -      tick_brks <- liftIO $ readModBreaks hug (ibi_tick_mod ibi)
    353 
    +      tick_brks  <- liftIO $ readModBreaks hug (ibi_tick_mod ibi)
    354 
    +      breakArray <- getBreakArray interp (toBreakpointId ibi) tick_brks
    352 355 
           let
    353 356 
             span = getBreakLoc ibi tick_brks
    354 357 
             decl = intercalate "." $ getBreakDecls ibi tick_brks
    355 358
    356 359 
           -- Was this breakpoint explicitly enabled (ie. in @BreakArray@)?
    357 
    -      bactive <- liftIO $ breakpointStatus interp (modBreaks_flags $ imodBreaks_modBreaks tick_brks) (ibi_tick_index ibi)
    360 
    +      bactive <- liftIO $ breakpointStatus interp breakArray (ibi_info_index ibi)
    358 361
    359 362 
           apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
    360 363 
           resume_ctxt_fhv   <- liftIO $ mkFinalizedHValue interp resume_ctxt
    ... ... @@ -462,9 +465,24 @@ setupBreakpoint :: GhcMonad m => Interp -> BreakpointId -> Int -> m () -- #191
    462 465 
     setupBreakpoint interp bi cnt = do
    463 466 
       hug <- hsc_HUG <$> getSession
    464 467 
       modBreaks <- liftIO $ readModBreaks hug (bi_tick_mod bi)
    465 
    -  let breakarray = modBreaks_flags $ imodBreaks_modBreaks modBreaks
    466 
    -  _ <- liftIO $ GHCi.storeBreakpoint interp breakarray (bi_tick_index bi) cnt
    467 
    -  pure ()
    468 
    +  breakArray <- getBreakArray interp bi modBreaks
    469 
    +  liftIO $ GHCi.storeBreakpoint interp breakArray (bi_tick_index bi) cnt
    470 
    +
    471 
    +getBreakArray :: GhcMonad m => Interp -> BreakpointId -> InternalModBreaks -> m (ForeignRef BreakArray)
    472 
    +getBreakArray interp BreakpointId{bi_tick_mod} imbs = do
    473 
    +
    474 
    +  liftIO $ modifyLoaderState interp $ \ld_st -> do
    475 
    +    let le = linker_env ld_st
    476 
    +
    477 
    +    -- Recall that BreakArrays are allocated only at BCO link time, so if we
    478 
    +    -- haven't linked the BCOs we intend to break at yet, we allocate the arrays here.
    479 
    +    ba_env <- allocateBreakArrays interp (breakarray_env le) [imbs]
    480 
    +
    481 
    +    return
    482 
    +      ( ld_st { linker_env = le{breakarray_env = ba_env} }
    483 
    +      , expectJust {- just computed -} $
    484 
    +        lookupModuleEnv ba_env bi_tick_mod
    485 
    +      )
    468 486
    469 487 
     back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
    470 488 
     back n = moveHist (+n)

  • compiler/GHC/Runtime/Interpreter.hs-boot deleted
    1 
    -module GHC.Runtime.Interpreter where
    2 
    -
    3 
    -import {-# SOURCE #-} GHC.Runtime.Interpreter.Types
    4 
    -import Data.Int (Int)
    5 
    -import GHC.Base (IO)
    6 
    -import GHCi.BreakArray (BreakArray)
    7 
    -import GHCi.RemoteTypes (ForeignRef)
    8 
    -
    9 
    -newBreakArray :: Interp -> Int -> IO (ForeignRef BreakArray)
    10 
    -

  • compiler/GHC/Runtime/Interpreter/Types.hs-boot deleted
    1 
    -module GHC.Runtime.Interpreter.Types where
    2 
    -
    3 
    -import Data.Bool
    4 
    -
    5 
    -data Interp
    6 
    -interpreterProfiled :: Interp -> Bool

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