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

Commits:

10 changed files:

Changes:

  • compiler/GHC/ByteCode/Linker.hs
    ... ... @@ -58,15 +58,16 @@ linkBCO
    58 58 
       :: Interp
    59 59 
       -> PkgsLoaded
    60 60 
       -> LinkerEnv
    61 
    +  -> LinkedBreaks
    61 62 
       -> NameEnv Int
    62 63 
       -> UnlinkedBCO
    63 64 
       -> IO ResolvedBCO
    64 
    -linkBCO interp pkgs_loaded le bco_ix
    65 
    +linkBCO interp pkgs_loaded le lb bco_ix
    65 66 
                (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
    66 67 
       -- fromIntegral Word -> Word64 should be a no op if Word is Word64
    67 68 
       -- otherwise it will result in a cast to longlong on 32bit systems.
    68 
    -  (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (elemsFlatBag lits0)
    69 
    -  ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix) (elemsFlatBag ptrs0)
    69 
    +  (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le lb) (elemsFlatBag lits0)
    70 
    +  ptrs <- mapM (resolvePtr interp pkgs_loaded le lb bco_ix) (elemsFlatBag ptrs0)
    70 71 
       let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits
    71 72 
       return $ ResolvedBCO { resolvedBCOIsLE   = isLittleEndian
    72 73 
                            , resolvedBCOArity  = arity
    ... ... @@ -76,8 +77,8 @@ linkBCO interp pkgs_loaded le bco_ix
    76 77 
                            , resolvedBCOPtrs   = addListToSS emptySS ptrs
    77 78 
                            }
    78 79
    79 
    -lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word
    80 
    -lookupLiteral interp pkgs_loaded le ptr = case ptr of
    80 
    +lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> LinkedBreaks -> BCONPtr -> IO Word
    81 
    +lookupLiteral interp pkgs_loaded le lb ptr = case ptr of
    81 82 
       BCONPtrWord lit -> return lit
    82 83 
       BCONPtrLbl  sym -> do
    83 84 
         Ptr a# <- lookupStaticPtr interp sym
    ... ... @@ -99,7 +100,7 @@ lookupLiteral interp pkgs_loaded le ptr = case ptr of
    99 100 
         pure $ fromIntegral p
    100 101 
       BCONPtrCostCentre BreakpointId{..}
    101 102 
         | interpreterProfiled interp -> do
    102 
    -        case expectJust (lookupModuleEnv (ccs_env le) bi_tick_mod) ! bi_tick_index of
    103 
    +        case expectJust (lookupModuleEnv (ccs_env lb) bi_tick_mod) ! bi_tick_index of
    103 104 
               RemotePtr p -> pure $ fromIntegral p
    104 105 
         | otherwise ->
    105 106 
             case toRemotePtr nullPtr of
    ... ... @@ -158,10 +159,11 @@ resolvePtr
    158 159 
       :: Interp
    159 160 
       -> PkgsLoaded
    160 161 
       -> LinkerEnv
    162 
    +  -> LinkedBreaks
    161 163 
       -> NameEnv Int
    162 164 
       -> BCOPtr
    163 165 
       -> IO ResolvedBCOPtr
    164 
    -resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
    166 
    +resolvePtr interp pkgs_loaded le lb bco_ix ptr = case ptr of
    165 167 
       BCOPtrName nm
    166 168 
         | Just ix <- lookupNameEnv bco_ix nm
    167 169 
         -> return (ResolvedBCORef ix) -- ref to another BCO in this group
    ... ... @@ -182,10 +184,10 @@ resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
    182 184 
         -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op
    183 185
    184 186 
       BCOPtrBCO bco
    185 
    -    -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix bco
    187 
    +    -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le lb bco_ix bco
    186 188
    187 189 
       BCOPtrBreakArray tick_mod ->
    188 
    -    withForeignRef (expectJust (lookupModuleEnv (breakarray_env le) tick_mod)) $
    190 
    +    withForeignRef (expectJust (lookupModuleEnv (breakarray_env lb) tick_mod)) $
    189 191 
           \ba -> pure $ ResolvedBCOPtrBreakArray ba
    190 192
    191 193 
     -- | Look up the address of a Haskell symbol in the currently

  • 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 
     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -177,13 +178,15 @@ emptyLoaderState = LoaderState
    177 178 
          { closure_env = emptyNameEnv
    178 179 
          , itbl_env    = emptyNameEnv
    179 180 
          , addr_env    = emptyNameEnv
    180 
    -     , breakarray_env = emptyModuleEnv
    181 
    -     , ccs_env        = emptyModuleEnv
    182 181 
          }
    183 182 
        , pkgs_loaded = init_pkgs
    184 183 
        , bcos_loaded = emptyModuleEnv
    185 184 
        , objs_loaded = emptyModuleEnv
    186 185 
        , temp_sos = []
    186 
    +   , linked_breaks = LinkedBreaks
    187 
    +     { breakarray_env = emptyModuleEnv
    188 
    +     , ccs_env        = emptyModuleEnv
    189 
    +     }
    187 190 
        }
    188 191 
       -- Packages that don't need loading, because the compiler
    189 192 
       -- shares them with the interpreted program.
    ... ... @@ -694,28 +697,22 @@ loadDecls interp hsc_env span linkable = do
    694 697 
             else do
    695 698 
               -- Link the expression itself
    696 699 
               let le  = linker_env pls
    700 
    +          let lb  = linked_breaks pls
    697 701 
               le2_itbl_env <- linkITbls interp (itbl_env le) (concat $ map bc_itbls cbcs)
    698 702 
               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)
    703 
    +          le2_breakarray_env <- allocateBreakArrays interp (breakarray_env lb) (catMaybes $ map bc_breaks cbcs)
    704 
    +          le2_ccs_env        <- allocateCCS         interp (ccs_env lb)        (catMaybes $ map bc_breaks cbcs)
    709 705 
               let le2 = le { itbl_env = le2_itbl_env
    710 
    -                       , addr_env = le2_addr_env
    711 
    -                       , breakarray_env = le2_breakarray_env
    706 
    +                       , addr_env = le2_addr_env }
    707 
    +          let lb2 = lb { breakarray_env = le2_breakarray_env
    712 708 
                            , ccs_env = le2_ccs_env }
    713 709
    714 710 
               -- Link the necessary packages and linkables
    715 
    -          new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs
    711 
    +          new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 lb2 cbcs
    716 712 
               nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings
    717 713 
               let ce2  = extendClosureEnv (closure_env le2) nms_fhvs
    718 
    -              !pls2 = pls { linker_env = le2 { closure_env = ce2 } }
    714 
    +              !pls2 = pls { linker_env = le2 { closure_env = ce2 }
    715 
    +                          , linked_breaks = lb2 }
    719 716 
               return (pls2, (nms_fhvs, links_needed, units_needed))
    720 717 
       where
    721 718 
         cbcs = linkableBCOs linkable
    ... ... @@ -931,17 +928,15 @@ dynLinkBCOs interp pls bcos = do
    931 928
    932 929
    933 930 
                 le1 = linker_env pls
    931 
    +            lb1 = linked_breaks pls
    934 932 
             ie2 <- linkITbls interp (itbl_env le1) (concatMap bc_itbls cbcs)
    935 933 
             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)
    942 
    -        let le2 = le1 { itbl_env = ie2, addr_env = ae2, breakarray_env = be2, ccs_env = ce2 }
    934 
    +        be2 <- allocateBreakArrays interp (breakarray_env lb1) (catMaybes $ map bc_breaks cbcs)
    935 
    +        ce2 <- allocateCCS         interp (ccs_env lb1)        (catMaybes $ map bc_breaks cbcs)
    936 
    +        let le2 = le1 { itbl_env = ie2, addr_env = ae2 }
    937 
    +        let lb2 = lb1 { breakarray_env = be2, ccs_env = ce2 }
    943 938
    944 
    -        names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs
    939 
    +        names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 lb2 cbcs
    945 940
    946 941 
             -- We only want to add the external ones to the ClosureEnv
    947 942 
             let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs
    ... ... @@ -952,19 +947,21 @@ dynLinkBCOs interp pls bcos = do
    952 947 
             new_binds <- makeForeignNamedHValueRefs interp to_add
    953 948
    954 949 
             let ce2 = extendClosureEnv (closure_env le2) new_binds
    955 
    -        return $! pls1 { linker_env = le2 { closure_env = ce2 } }
    950 
    +        return $! pls1 { linker_env = le2 { closure_env = ce2 }
    951 
    +                       , linked_breaks = lb2 }
    956 952
    957 953 
     -- Link a bunch of BCOs and return references to their values
    958 954 
     linkSomeBCOs :: Interp
    959 955 
                  -> PkgsLoaded
    960 956 
                  -> LinkerEnv
    957 
    +             -> LinkedBreaks
    961 958 
                  -> [CompiledByteCode]
    962 959 
                  -> IO [(Name,HValueRef)]
    963 960 
                             -- The returned HValueRefs are associated 1-1 with
    964 961 
                             -- the incoming unlinked BCOs.  Each gives the
    965 962 
                             -- value of the corresponding unlinked BCO
    966 963
    967 
    -linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods []
    964 
    +linkSomeBCOs interp pkgs_loaded le lb mods = foldr fun do_link mods []
    968 965 
      where
    969 966 
       fun CompiledByteCode{..} inner accum =
    970 967 
         inner (Foldable.toList bc_bcos : accum)
    ... ... @@ -974,7 +971,7 @@ linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods []
    974 971 
         let flat = [ bco | bcos <- mods, bco <- bcos ]
    975 972 
             names = map unlinkedBCOName flat
    976 973 
             bco_ix = mkNameEnv (zip names [0..])
    977 
    -    resolved <- sequence [ linkBCO interp pkgs_loaded le bco_ix bco | bco <- flat ]
    974 
    +    resolved <- sequence [ linkBCO interp pkgs_loaded le lb bco_ix bco | bco <- flat ]
    978 975 
         hvrefs <- createBCOs interp resolved
    979 976 
         return (zip names hvrefs)
    980 977
    ... ... @@ -1072,9 +1069,13 @@ unload_wkr interp keep_linkables pls@LoaderState{..} = do
    1072 1069 
           keep_name n = isExternalName n &&
    1073 1070 
                         nameModule n `elemModuleEnv` remaining_bcos_loaded
    1074 1071
    1075 
    -      !new_pls = pls { linker_env = filterLinkerEnv keep_name linker_env,
    1076 
    -                       bcos_loaded = remaining_bcos_loaded,
    1077 
    -                       objs_loaded = remaining_objs_loaded }
    1072 
    +      keep_mod :: Module -> Bool
    1073 
    +      keep_mod m = m `elemModuleEnv` remaining_bcos_loaded
    1074 
    +
    1075 
    +      !new_pls = pls { linker_env    = filterLinkerEnv keep_name linker_env,
    1076 
    +                       linked_breaks = filterLinkedBreaks keep_mod linked_breaks,
    1077 
    +                       bcos_loaded   = remaining_bcos_loaded,
    1078 
    +                       objs_loaded   = remaining_objs_loaded }
    1078 1079
    1079 1080 
       return new_pls
    1080 1081 
       where
    ... ... @@ -1656,30 +1657,34 @@ allocateTopStrings interp topStrings prev_env = do
    1656 1657 
       where
    1657 1658 
         mk_entry nm ptr = (nm, (nm, AddrPtr ptr))
    1658 1659
    1659 
    --- | Given a list of 'ModBreaks' collected from a list of
    1660 
    --- 'CompiledByteCode', allocate the 'BreakArray'.
    1660 
    +-- | Given a list of 'InternalModBreaks' collected from a list of
    1661 
    +-- 'CompiledByteCode', allocate the 'BreakArray' used to trigger breakpoints.
    1661 1662 
     allocateBreakArrays ::
    1662 1663 
       Interp ->
    1663 
    -  [InternalModBreaks] ->
    1664 1664 
       ModuleEnv (ForeignRef BreakArray) ->
    1665 
    +  [InternalModBreaks] ->
    1665 1666 
       IO (ModuleEnv (ForeignRef BreakArray))
    1666 
    -allocateBreakArrays _interp mbs be =
    1667 
    +allocateBreakArrays interp =
    1667 1668 
       foldlM
    1668 
    -    ( \be0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} ->
    1669 
    -        evaluate $ extendModuleEnv be0 modBreaks_module modBreaks_flags
    1669 
    +    ( \be0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} -> do
    1670 
    +        -- If no BreakArray is assigned to this module yet, create one
    1671 
    +        if not $ elemModuleEnv modBreaks_module be0 then do
    1672 
    +          let count = numElements modBreaks_locs
    1673 
    +          breakArray <- GHCi.newBreakArray interp count
    1674 
    +          evaluate $ extendModuleEnv be0 modBreaks_module breakArray
    1675 
    +        else
    1676 
    +          return be0
    1670 1677 
         )
    1671 
    -    be
    1672 
    -    mbs
    1673 1678
    1674 
    --- | Given a list of 'ModBreaks' collected from a list of
    1675 
    --- 'CompiledByteCode', allocate the 'CostCentre' arrays when profiling
    1676 
    --- is enabled.
    1679 
    +-- | Given a list of 'InternalModBreaks' collected from a list
    1680 
    +-- of 'CompiledByteCode', allocate the 'CostCentre' arrays when profiling is
    1681 
    +-- enabled.
    1677 1682 
     allocateCCS ::
    1678 1683 
       Interp ->
    1679 
    -  [InternalModBreaks] ->
    1680 1684 
       ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)) ->
    1685 
    +  [InternalModBreaks] ->
    1681 1686 
       IO (ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)))
    1682 
    -allocateCCS interp mbs ce
    1687 
    +allocateCCS interp ce mbss
    1683 1688 
       | interpreterProfiled interp =
    1684 1689 
           foldlM
    1685 1690 
             ( \ce0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} -> do
    ... ... @@ -1688,12 +1693,15 @@ allocateCCS interp mbs ce
    1688 1693 
                     interp
    1689 1694 
                     (moduleNameString $ moduleName modBreaks_module)
    1690 1695 
                     (elems modBreaks_ccs)
    1691 
    -            evaluate $
    1692 
    -              extendModuleEnv ce0 modBreaks_module $
    1693 
    -                listArray
    1694 
    -                  (0, length ccs - 1)
    1695 
    -                  ccs
    1696 
    +            if not $ elemModuleEnv modBreaks_module ce0 then do
    1697 
    +              evaluate $
    1698 
    +                extendModuleEnv ce0 modBreaks_module $
    1699 
    +                  listArray
    1700 
    +                    (0, length ccs - 1)
    1701 
    +                    ccs
    1702 
    +            else
    1703 
    +              return ce0
    1696 1704 
             )
    1697 1705 
             ce
    1698 
    -        mbs
    1706 
    +        mbss
    1699 1707 
       | otherwise = pure ce

  • compiler/GHC/Linker/Types.hs
    ... ... @@ -18,6 +18,8 @@ module GHC.Linker.Types
    18 18 
        , ClosureEnv
    19 19 
        , emptyClosureEnv
    20 20 
        , extendClosureEnv
    21 
    +   , LinkedBreaks(..)
    22 
    +   , filterLinkedBreaks
    21 23 
        , LinkableSet
    22 24 
        , mkLinkableSet
    23 25 
        , unionLinkableSet
    ... ... @@ -159,6 +161,9 @@ data LoaderState = LoaderState
    159 161 
         , temp_sos :: ![(FilePath, String)]
    160 162 
             -- ^ We need to remember the name of previous temporary DLL/.so
    161 163 
             -- libraries so we can link them (see #10322)
    164 
    +
    165 
    +    , linked_breaks :: !LinkedBreaks
    166 
    +        -- ^ Mapping from loaded modules to their breakpoint arrays
    162 167 
         }
    163 168
    164 169 
     uninitializedLoader :: IO Loader
    ... ... @@ -184,20 +189,13 @@ data LinkerEnv = LinkerEnv
    184 189 
       , addr_env    :: !AddrEnv
    185 190 
           -- ^ Like 'closure_env' and 'itbl_env', but for top-level 'Addr#' literals,
    186 191 
           -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.
    187 
    -
    188 
    -  , breakarray_env :: !(ModuleEnv (ForeignRef BreakArray))
    189 
    -      -- ^ Each 'Module's remote pointer of 'BreakArray'.
    190 
    -
    191 
    -  , ccs_env :: !(ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)))
    192 
    -      -- ^ Each 'Module's array of remote pointers of 'CostCentre'.
    193 
    -      -- Untouched when not profiling.
    194 192 
       }
    195 193
    196 194 
     filterLinkerEnv :: (Name -> Bool) -> LinkerEnv -> LinkerEnv
    197 
    -filterLinkerEnv f le = le
    198 
    -  { closure_env = filterNameEnv (f . fst) (closure_env le)
    199 
    -  , itbl_env    = filterNameEnv (f . fst) (itbl_env le)
    200 
    -  , addr_env    = filterNameEnv (f . fst) (addr_env le)
    195 
    +filterLinkerEnv f (LinkerEnv closure_e itbl_e addr_e) = LinkerEnv
    196 
    +  { closure_env = filterNameEnv (f . fst) closure_e
    197 
    +  , itbl_env    = filterNameEnv (f . fst) itbl_e
    198 
    +  , addr_env    = filterNameEnv (f . fst) addr_e
    201 199 
       }
    202 200
    203 201 
     type ClosureEnv = NameEnv (Name, ForeignHValue)
    ... ... @@ -209,6 +207,29 @@ extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
    209 207 
     extendClosureEnv cl_env pairs
    210 208 
       = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
    211 209
    210 
    +-- | 'BreakArray's and CCSs are allocated per-module at link-time.
    211 
    +--
    212 
    +-- Specifically, a module's 'BreakArray' is allocated either:
    213 
    +--  - When a BCO for that module is linked
    214 
    +--  - When :break is used on a given module *before* the BCO has been linked.
    215 
    +--
    216 
    +-- We keep this structure in the 'LoaderState'
    217 
    +data LinkedBreaks
    218 
    +  = LinkedBreaks
    219 
    +  { breakarray_env :: !(ModuleEnv (ForeignRef BreakArray))
    220 
    +      -- ^ Each 'Module's remote pointer of 'BreakArray'.
    221 
    +
    222 
    +  , ccs_env :: !(ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)))
    223 
    +      -- ^ Each 'Module's array of remote pointers of 'CostCentre'.
    224 
    +      -- Untouched when not profiling.
    225 
    +  }
    226 
    +
    227 
    +filterLinkedBreaks :: (Module -> Bool) -> LinkedBreaks -> LinkedBreaks
    228 
    +filterLinkedBreaks f (LinkedBreaks ba_e ccs_e) = LinkedBreaks
    229 
    +  { breakarray_env = filterModuleEnv (\m _ -> f m) ba_e
    230 
    +  , ccs_env        = filterModuleEnv (\m _ -> f m) ccs_e
    231 
    +  }
    232 
    +
    212 233 
     type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo
    213 234
    214 235 
     data LoadedPkgInfo

  • 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 (LinkedBreaks (..))
    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 <- liftIO $ 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_tick_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,29 @@ 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 <- liftIO $ getBreakArray interp bi modBreaks
    469 
    +  liftIO $ GHCi.storeBreakpoint interp breakArray (bi_tick_index bi) cnt
    470 
    +
    471 
    +getBreakArray :: Interp -> BreakpointId -> InternalModBreaks -> IO (ForeignRef BreakArray)
    472 
    +getBreakArray interp BreakpointId{bi_tick_mod} imbs = do
    473 
    +  breaks0 <- linked_breaks . fromMaybe (panic "Loader not initialised") <$> getLoaderState interp
    474 
    +  case lookupModuleEnv (breakarray_env breaks0) bi_tick_mod of
    475 
    +    Just ba -> return ba
    476 
    +    Nothing -> do
    477 
    +      modifyLoaderState interp $ \ld_st -> do
    478 
    +        let lb = linked_breaks ld_st
    479 
    +
    480 
    +        -- Recall that BreakArrays are allocated only at BCO link time, so if we
    481 
    +        -- haven't linked the BCOs we intend to break at yet, we allocate the arrays here.
    482 
    +        ba_env <- allocateBreakArrays interp (breakarray_env lb) [imbs]
    483 
    +
    484 
    +        let ld_st' = ld_st { linked_breaks = lb{breakarray_env = ba_env} }
    485 
    +        let ba = expectJust {- just computed -} $ lookupModuleEnv ba_env bi_tick_mod
    486 
    +
    487 
    +        return
    488 
    +          ( ld_st'
    489 
    +          , ba
    490 
    +          )
    468 491
    469 492 
     back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
    470 493 
     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

  • testsuite/tests/count-deps/CountDepsAst.stdout
    ... ... @@ -5,6 +5,7 @@ GHC.Builtin.Types
    5 5 
     GHC.Builtin.Types.Literals
    6 6 
     GHC.Builtin.Types.Prim
    7 7 
     GHC.Builtin.Uniques
    8 
    +GHC.ByteCode.Breakpoints
    8 9 
     GHC.ByteCode.Types
    9 10 
     GHC.Cmm.BlockId
    10 11 
     GHC.Cmm.CLabel
    ... ... @@ -110,6 +111,8 @@ GHC.Hs.Pat
    110 111 
     GHC.Hs.Specificity
    111 112 
     GHC.Hs.Type
    112 113 
     GHC.Hs.Utils
    114 
    +GHC.HsToCore.Breakpoints
    115 
    +GHC.HsToCore.Ticks
    113 116 
     GHC.Iface.Errors.Types
    114 117 
     GHC.Iface.Ext.Fields
    115 118 
     GHC.Iface.Flags
    ... ... @@ -150,7 +153,6 @@ GHC.Tc.Zonk.Monad
    150 153 
     GHC.Types.Annotations
    151 154 
     GHC.Types.Avail
    152 155 
     GHC.Types.Basic
    153 
    -GHC.Types.Breakpoint
    154 156 
     GHC.Types.CostCentre
    155 157 
     GHC.Types.CostCentre.State
    156 158 
     GHC.Types.Cpr

  • testsuite/tests/count-deps/CountDepsParser.stdout
    ... ... @@ -5,6 +5,7 @@ GHC.Builtin.Types
    5 5 
     GHC.Builtin.Types.Literals
    6 6 
     GHC.Builtin.Types.Prim
    7 7 
     GHC.Builtin.Uniques
    8 
    +GHC.ByteCode.Breakpoints
    8 9 
     GHC.ByteCode.Types
    9 10 
     GHC.Cmm.BlockId
    10 11 
     GHC.Cmm.CLabel
    ... ... @@ -114,8 +115,10 @@ GHC.Hs.Pat
    114 115 
     GHC.Hs.Specificity
    115 116 
     GHC.Hs.Type
    116 117 
     GHC.Hs.Utils
    118 
    +GHC.HsToCore.Breakpoints
    117 119 
     GHC.HsToCore.Errors.Types
    118 120 
     GHC.HsToCore.Pmc.Solver.Types
    121 
    +GHC.HsToCore.Ticks
    119 122 
     GHC.Iface.Errors.Types
    120 123 
     GHC.Iface.Ext.Fields
    121 124 
     GHC.Iface.Flags
    ... ... @@ -171,7 +174,6 @@ GHC.Tc.Zonk.Monad
    171 174 
     GHC.Types.Annotations
    172 175 
     GHC.Types.Avail
    173 176 
     GHC.Types.Basic
    174 
    -GHC.Types.Breakpoint
    175 177 
     GHC.Types.CompleteMatch
    176 178 
     GHC.Types.CostCentre
    177 179 
     GHC.Types.CostCentre.State

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