diff options
39 files changed, 680 insertions, 584 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 08014229e9..b0543ed88e 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -10,6 +10,9 @@ module Coverage (addTicksToBinds, hpcInitCode) where #ifdef GHCI import qualified GHCi import GHCi.RemoteTypes +import Data.Array +import ByteCodeTypes +import GHC.Stack.CCS #endif import Type import HsSyn @@ -37,14 +40,14 @@ import Maybes import CLabel import Util -import Data.Array import Data.Time +import Foreign.C import System.Directory import Trace.Hpc.Mix import Trace.Hpc.Util -import BreakArray +import qualified Data.ByteString as B import Data.Map (Map) import qualified Data.Map as Map @@ -65,7 +68,7 @@ addTicksToBinds -- hasn't set it), so we have to work from this set. -> [TyCon] -- Type constructor in this module -> LHsBinds Id - -> IO (LHsBinds Id, HpcInfo, ModBreaks) + -> IO (LHsBinds Id, HpcInfo, Maybe ModBreaks) addTicksToBinds hsc_env mod mod_loc exports tyCons binds | let dflags = hsc_dflags hsc_env @@ -73,7 +76,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds Just orig_file <- ml_hs_file mod_loc = do if "boot" `isSuffixOf` orig_file - then return (binds, emptyHpcInfo False, emptyModBreaks) + then return (binds, emptyHpcInfo False, Nothing) else do us <- mkSplitUniqSupply 'C' -- for cost centres @@ -93,7 +96,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds , density = mkDensity tickish dflags , this_mod = mod , tickishType = tickish - } +} (binds',_,st') = unTM (addTickLHsBinds binds) env st in (binds', st') @@ -113,9 +116,9 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (pprLHsBinds binds1) - return (binds1, HpcInfo tickCount hashNo, modBreaks) + return (binds1, HpcInfo tickCount hashNo, Just modBreaks) - | otherwise = return (binds, emptyHpcInfo False, emptyModBreaks) + | otherwise = return (binds, emptyHpcInfo False, Nothing) guessSourceFile :: LHsBinds Id -> FilePath -> FilePath guessSourceFile binds orig_file = @@ -131,12 +134,13 @@ guessSourceFile binds orig_file = mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks +#ifndef GHCI +mkModBreaks _hsc_env _mod _count _entries = return emptyModBreaks +#else mkModBreaks hsc_env mod count entries | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do - breakArray <- newBreakArray (length entries) -#ifdef GHCI + breakArray <- GHCi.newBreakArray hsc_env (length entries) ccs <- mkCCSArray hsc_env mod count entries -#endif let locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ] varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ] @@ -146,31 +150,30 @@ mkModBreaks hsc_env mod count entries , modBreaks_locs = locsTicks , modBreaks_vars = varsTicks , modBreaks_decls = declsTicks -#ifdef GHCI , modBreaks_ccs = ccs -#endif } | otherwise = return emptyModBreaks -#ifdef GHCI mkCCSArray :: HscEnv -> Module -> Int -> [MixEntry_] - -> IO (Array BreakIndex RemotePtr {- CCostCentre -}) + -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre)) mkCCSArray hsc_env modul count entries = do if interpreterProfiled (hsc_dflags hsc_env) then do let module_bs = fastStringToByteString (moduleNameFS (moduleName modul)) - c_module <- GHCi.mallocData hsc_env module_bs - costcentres <- mapM (mkCostCentre hsc_env (toRemotePtr c_module)) entries + c_module <- GHCi.mallocData hsc_env (module_bs `B.snoc` 0) + -- NB. null-terminate the string + costcentres <- + mapM (mkCostCentre hsc_env (castRemotePtr c_module)) entries return (listArray (0,count-1) costcentres) else do return (listArray (0,-1) []) where mkCostCentre :: HscEnv - -> RemotePtr {- CChar -} + -> RemotePtr CChar -> MixEntry_ - -> IO (RemotePtr {- CCostCentre -}) + -> IO (RemotePtr GHC.Stack.CCS.CostCentre) mkCostCentre hsc_env@HscEnv{..} c_module (srcspan, decl_path, _, _) = do let name = concat (intersperse "." decl_path) src = showSDoc hsc_dflags (ppr srcspan) @@ -1010,9 +1013,7 @@ data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes coveragePasses :: DynFlags -> [TickishType] coveragePasses dflags = - ifa (hscTarget dflags == HscInterpreted && - not (gopt Opt_ExternalInterpreter dflags)) Breakpoints $ - -- TODO: breakpoints don't work with -fexternal-interpreter yet + ifa (hscTarget dflags == HscInterpreted) Breakpoints $ ifa (gopt Opt_Hpc dflags) HpcTicks $ ifa (gopt Opt_SccProfilingOn dflags && profAuto dflags /= NoProfAuto) ProfNotes $ diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index d7fff69c86..da6085d2be 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -302,7 +302,7 @@ deSugar hsc_env <- if not (isHsBootOrSig hsc_src) then addTicksToBinds hsc_env mod mod_loc export_set (typeEnvTyCons type_env) binds - else return (binds, hpcInfo, emptyModBreaks) + else return (binds, hpcInfo, Nothing) ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $ do { ds_ev_binds <- dsEvBinds ev_binds diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 4264b667e7..d0e74b0d08 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -306,7 +306,6 @@ Library TcIface FlagChecker Annotations - BreakArray CmdLineParser CodeOutput Config diff --git a/compiler/ghc.mk b/compiler/ghc.mk index e4d9ee4a3e..c11a36c7a3 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -454,7 +454,6 @@ compiler_stage2_dll0_MODULES = \ BasicTypes \ Binary \ BooleanFormula \ - BreakArray \ BufWrite \ Class \ CmdLineParser \ diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs index 41450530fd..6974620dc5 100644 --- a/compiler/ghci/ByteCodeAsm.hs +++ b/compiler/ghci/ByteCodeAsm.hs @@ -32,6 +32,7 @@ import DynFlags import Outputable import Platform import Util +import Unique -- From iserv import SizedSeq @@ -86,11 +87,18 @@ bcoFreeNames bco -- bytecode address in this BCO. -- Top level assembler fn. -assembleBCOs :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode -assembleBCOs hsc_env proto_bcos tycons = do +assembleBCOs + :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> Maybe ModBreaks + -> IO CompiledByteCode +assembleBCOs hsc_env proto_bcos tycons modbreaks = do itblenv <- mkITbls hsc_env tycons bcos <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos - return (ByteCode bcos itblenv (concat (map protoBCOFFIs proto_bcos))) + return CompiledByteCode + { bc_bcos = bcos + , bc_itbls = itblenv + , bc_ffis = concat (map protoBCOFFIs proto_bcos) + , bc_breaks = modbreaks + } assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do @@ -356,11 +364,11 @@ assembleI dflags i = case i of RETURN_UBX rep -> emit (return_ubx rep) [] CCALL off m_addr i -> do np <- addr m_addr emit bci_CCALL [SmallOp off, Op np, SmallOp i] - BRK_FUN array index info cc -> do p1 <- ptr (BCOPtrArray array) - p2 <- ptr (BCOPtrBreakInfo info) - np <- addr cc - emit bci_BRK_FUN [Op p1, SmallOp index, - Op p2, Op np] + BRK_FUN index uniq cc -> do p1 <- ptr BCOPtrBreakArray + q <- int (getKey uniq) + np <- addr cc + emit bci_BRK_FUN [Op p1, SmallOp index, + Op q, Op np] where literal (MachLabel fs (Just sz) _) @@ -474,14 +482,7 @@ mkLitI64 dflags ii | otherwise = panic "mkLitI64: Bad wORD_SIZE" -mkLitI i - = runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 i - i_arr <- castSTUArray arr - w0 <- readArray i_arr 0 - return [w0 :: Word] - ) +mkLitI i = [fromIntegral i :: Word] iNTERP_STACK_CHECK_THRESH :: Int iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index 4311fcddea..4c9e0b4ea9 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, MagicHash #-} +{-# LANGUAGE CPP, MagicHash, RecordWildCards #-} -- -- (c) The University of Glasgow 2002-2006 -- @@ -44,6 +44,7 @@ import StgCmmLayout ( ArgRep(..), toArgRep, argRepSizeW ) import SMRep import Bitmap import OrdList +import Maybes import Data.List import Foreign @@ -51,16 +52,17 @@ import Control.Monad import Data.Char import UniqSupply -import BreakArray -import Data.Maybe import Module import Control.Arrow ( second ) import Data.Array import Data.Map (Map) +import Data.IntMap (IntMap) import qualified Data.Map as Map +import qualified Data.IntMap as IntMap import qualified FiniteMap as Map import Data.Ord +import GHC.Stack.CCS -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module @@ -69,9 +71,9 @@ byteCodeGen :: HscEnv -> Module -> CoreProgram -> [TyCon] - -> ModBreaks + -> Maybe ModBreaks -> IO CompiledByteCode -byteCodeGen hsc_env this_mod binds tycs modBreaks +byteCodeGen hsc_env this_mod binds tycs mb_modBreaks = do let dflags = hsc_dflags hsc_env showPass dflags "ByteCodeGen" @@ -79,8 +81,9 @@ byteCodeGen hsc_env this_mod binds tycs modBreaks | (bndr, rhs) <- flattenBinds binds] us <- mkSplitUniqSupply 'y' - (BcM_State _hsc_env _us _this_mod _final_ctr ffis _, proto_bcos) - <- runBc hsc_env us this_mod modBreaks (mapM schemeTopBind flatBinds) + (BcM_State{..}, proto_bcos) <- + runBc hsc_env us this_mod mb_modBreaks $ + mapM schemeTopBind flatBinds when (notNull ffis) (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") @@ -89,12 +92,14 @@ byteCodeGen hsc_env this_mod binds tycs modBreaks "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos))) assembleBCOs hsc_env proto_bcos tycs + (case modBreaks of + Nothing -> Nothing + Just mb -> Just mb{ modBreaks_breakInfo = breakInfo }) -- ----------------------------------------------------------------------------- -- Generating byte code for an expression --- Returns: (the root BCO for this expression, --- a list of auxilary BCOs resulting from compiling closures) +-- Returns: the root BCO for this expression coreExprToBCOs :: HscEnv -> Module -> CoreExpr @@ -111,8 +116,8 @@ coreExprToBCOs hsc_env this_mod expr -- the uniques are needed to generate fresh variables when we introduce new -- let bindings for ticked expressions us <- mkSplitUniqSupply 'y' - (BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco) - <- runBc hsc_env us this_mod emptyModBreaks $ + (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ , proto_bco) + <- runBc hsc_env us this_mod Nothing $ schemeTopBind (invented_id, simpleFreeVars expr) when (notNull mallocd) @@ -331,22 +336,18 @@ schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList schemeER_wrk d p rhs | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs = do code <- schemeE (fromIntegral d) 0 p newRhs - flag_arr <- getBreakArray cc_arr <- getCCArray - this_mod <- getCurrentModule + this_mod <- moduleName <$> getCurrentModule let idOffSets = getVarOffSets d p fvs - let breakInfo = BreakInfo - { breakInfo_module = this_mod - , breakInfo_number = tick_no - , breakInfo_vars = idOffSets - , breakInfo_resty = exprType (deAnnotate' newRhs) + let breakInfo = CgBreakInfo + { cgb_vars = idOffSets + , cgb_resty = exprType (deAnnotate' newRhs) } + newBreakInfo tick_no breakInfo dflags <- getDynFlags let cc | interpreterProfiled dflags = cc_arr ! tick_no | otherwise = toRemotePtr nullPtr - let breakInstr = case flag_arr of - BA arr# -> - BRK_FUN arr# (fromIntegral tick_no) breakInfo cc + let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc return $ breakInstr `consOL` code | otherwise = schemeE (fromIntegral d) 0 p rhs @@ -1642,7 +1643,8 @@ data BcM_State , nextlabel :: Word16 -- for generating local labels , ffis :: [FFIInfo] -- ffi info blocks, to free later -- Should be free()d when it is GCd - , modBreaks :: ModBreaks -- info about breakpoints + , modBreaks :: Maybe ModBreaks -- info about breakpoints + , breakInfo :: IntMap CgBreakInfo } newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) @@ -1652,10 +1654,10 @@ ioToBc io = BcM $ \st -> do x <- io return (st, x) -runBc :: HscEnv -> UniqSupply -> Module -> ModBreaks -> BcM r +runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks -> BcM r -> IO (BcM_State, r) runBc hsc_env us this_mod modBreaks (BcM m) - = m (BcM_State hsc_env us this_mod 0 [] modBreaks) + = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty) thenBc :: BcM a -> (a -> BcM b) -> BcM b thenBc (BcM expr) cont = BcM $ \st0 -> do @@ -1695,7 +1697,7 @@ emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name) emitBc bco = BcM $ \st -> return (st{ffis=[]}, bco (ffis st)) -recordFFIBc :: RemotePtr -> BcM () +recordFFIBc :: RemotePtr C_ffi_cif -> BcM () recordFFIBc a = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ()) @@ -1711,11 +1713,15 @@ getLabelsBc n = BcM $ \st -> let ctr = nextlabel st in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) -getBreakArray :: BcM BreakArray -getBreakArray = BcM $ \st -> return (st, modBreaks_flags (modBreaks st)) +getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre)) +getCCArray = BcM $ \st -> + let breaks = expectJust "ByteCodeGen.getCCArray" $ modBreaks st in + return (st, modBreaks_ccs breaks) -getCCArray :: BcM (Array BreakIndex RemotePtr {- CCostCentre -}) -getCCArray = BcM $ \st -> return (st, modBreaks_ccs (modBreaks st)) + +newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM () +newBreakInfo ix info = BcM $ \st -> + return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ()) newUnique :: BcM Unique newUnique = BcM $ diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs index 74c4f9692e..985bec4429 100644 --- a/compiler/ghci/ByteCodeInstr.hs +++ b/compiler/ghci/ByteCodeInstr.hs @@ -14,11 +14,13 @@ module ByteCodeInstr ( import ByteCodeTypes import GHCi.RemoteTypes +import GHCi.FFI (C_ffi_cif) import StgCmmLayout ( ArgRep(..) ) import PprCore import Outputable import FastString import Name +import Unique import Id import CoreSyn import Literal @@ -27,8 +29,8 @@ import VarSet import PrimOp import SMRep -import GHC.Exts import Data.Word +import GHC.Stack.CCS (CostCentre) -- ---------------------------------------------------------------------------- -- Bytecode instructions @@ -125,7 +127,7 @@ data BCInstr -- For doing calls to C (via glue code generated by libffi) | CCALL Word16 -- stack frame size - RemotePtr -- addr of the glue code + (RemotePtr C_ffi_cif) -- addr of the glue code Word16 -- whether or not the call is interruptible -- (XXX: inefficient, but I don't know -- what the alignment constraints are.) @@ -140,7 +142,7 @@ data BCInstr | RETURN_UBX ArgRep -- return an unlifted value, here's its rep -- Breakpoints - | BRK_FUN (MutableByteArray# RealWorld) Word16 BreakInfo RemotePtr + | BRK_FUN Word16 Unique (RemotePtr CostCentre) -- ----------------------------------------------------------------------------- -- Printing bytecode instructions @@ -240,7 +242,7 @@ instance Outputable BCInstr where ppr ENTER = text "ENTER" ppr RETURN = text "RETURN" ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk - ppr (BRK_FUN _breakArray index info _cc) = text "BRK_FUN" <+> text "<array>" <+> ppr index <+> ppr info <+> text "<cc>" + ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>" -- ----------------------------------------------------------------------------- -- The stack use, in words, of each bytecode insn. These _must_ be diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs index 5a3e6d3e1a..4e1c828a4d 100644 --- a/compiler/ghci/ByteCodeItbls.hs +++ b/compiler/ghci/ByteCodeItbls.hs @@ -11,7 +11,6 @@ module ByteCodeItbls ( mkITbls ) where import ByteCodeTypes import GHCi -import GHCi.RemoteTypes import DynFlags import HscTypes import Name ( Name, getName ) @@ -70,4 +69,4 @@ make_constr_itbls hsc_env cons = descr = dataConIdentity dcon r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really conNo descr) - return (getName dcon, ItblPtr (fromRemotePtr r)) + return (getName dcon, ItblPtr r) diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs index aa92ecc610..74f490b8fd 100644 --- a/compiler/ghci/ByteCodeLink.hs +++ b/compiler/ghci/ByteCodeLink.hs @@ -22,6 +22,7 @@ module ByteCodeLink ( import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.InfoTable +import GHCi.BreakArray import SizedSeq import GHCi @@ -60,15 +61,16 @@ extendClosureEnv cl_env pairs -} linkBCO - :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> UnlinkedBCO + :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray + -> UnlinkedBCO -> IO ResolvedBCO -linkBCO hsc_env ie ce bco_ix +linkBCO hsc_env ie ce bco_ix breakarray (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do lits <- mapM (lookupLiteral hsc_env ie) (ssElts lits0) - ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix) (ssElts ptrs0) + ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0) return (ResolvedBCO arity insns bitmap - (listArray (0, fromIntegral (sizeSS lits0)-1) lits) - (addListToSS emptySS ptrs)) + (listArray (0, fromIntegral (sizeSS lits0)-1) lits) + (addListToSS emptySS ptrs)) lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word lookupLiteral _ _ (BCONPtrWord lit) = return lit @@ -79,7 +81,7 @@ lookupLiteral hsc_env ie (BCONPtrItbl nm) = do Ptr a# <- lookupIE hsc_env ie nm return (W# (int2Word# (addr2Int# a#))) lookupLiteral hsc_env _ (BCONPtrStr bs) = do - fromIntegral . ptrToWordPtr <$> mallocData hsc_env bs + fromIntegral . ptrToWordPtr . fromRemotePtr <$> mallocData hsc_env bs lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ()) lookupStaticPtr hsc_env addr_of_label_string = do @@ -89,26 +91,26 @@ lookupStaticPtr hsc_env addr_of_label_string = do Nothing -> linkFail "ByteCodeLink: can't find label" (unpackFS addr_of_label_string) -lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr a) +lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ()) lookupIE hsc_env ie con_nm = case lookupNameEnv ie con_nm of - Just (_, ItblPtr a) -> return (castPtr (conInfoPtr a)) + Just (_, ItblPtr a) -> return (conInfoPtr (fromRemotePtr (castRemotePtr a))) Nothing -> do -- try looking up in the object files. let sym_to_find1 = nameToCLabel con_nm "con_info" m <- lookupSymbol hsc_env sym_to_find1 case m of - Just addr -> return (castPtr addr) + Just addr -> return addr Nothing -> do -- perhaps a nullary constructor? let sym_to_find2 = nameToCLabel con_nm "static_info" n <- lookupSymbol hsc_env sym_to_find2 case n of - Just addr -> return (castPtr addr) + Just addr -> return addr Nothing -> linkFail "ByteCodeLink.lookupIE" (unpackFS sym_to_find1 ++ " or " ++ unpackFS sym_to_find2) -lookupPrimOp :: HscEnv -> PrimOp -> IO RemotePtr +lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ()) lookupPrimOp hsc_env primop = do let sym_to_find = primopToCLabel primop "closure" m <- lookupSymbol hsc_env (mkFastString sym_to_find) @@ -117,13 +119,14 @@ lookupPrimOp hsc_env primop = do Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find resolvePtr - :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> BCOPtr + :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray + -> BCOPtr -> IO ResolvedBCOPtr -resolvePtr hsc_env _ie ce bco_ix (BCOPtrName nm) +resolvePtr hsc_env _ie ce bco_ix _ (BCOPtrName nm) | Just ix <- lookupNameEnv bco_ix nm = return (ResolvedBCORef ix) -- ref to another BCO in this group | Just (_, rhv) <- lookupNameEnv ce nm = - return (ResolvedBCOPtr (unsafeForeignHValueToHValueRef rhv)) + return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv)) | otherwise = ASSERT2(isExternalName nm, ppr nm) do let sym_to_find = nameToCLabel nm "closure" @@ -131,14 +134,12 @@ resolvePtr hsc_env _ie ce bco_ix (BCOPtrName nm) case m of Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p)) Nothing -> linkFail "ByteCodeLink.lookupCE" (unpackFS sym_to_find) -resolvePtr hsc_env _ _ _ (BCOPtrPrimOp op) = +resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) = ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op -resolvePtr hsc_env ie ce bco_ix (BCOPtrBCO bco) = - ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix bco -resolvePtr _ _ _ _ (BCOPtrBreakInfo break_info) = - return (ResolvedBCOPtrLocal (unsafeCoerce# break_info)) -resolvePtr _ _ _ _ (BCOPtrArray break_array) = - return (ResolvedBCOPtrLocal (unsafeCoerce# break_array)) +resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) = + ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco +resolvePtr _ _ _ _ breakarray BCOPtrBreakArray = + return (ResolvedBCOPtrBreakArray breakarray) linkFail :: String -> String -> IO a linkFail who what diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs index 500fd77c5b..944000a24b 100644 --- a/compiler/ghci/ByteCodeTypes.hs +++ b/compiler/ghci/ByteCodeTypes.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MagicHash, RecordWildCards #-} -- -- (c) The University of Glasgow 2002-2006 -- @@ -8,43 +8,55 @@ module ByteCodeTypes ( CompiledByteCode(..), FFIInfo(..) , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..) , ItblEnv, ItblPtr(..) - , BreakInfo(..) + , CgBreakInfo(..) + , ModBreaks (..), BreakIndex, emptyModBreaks + , CCostCentre ) where import FastString import Id -import Module import Name import NameEnv import Outputable import PrimOp import SizedSeq import Type +import SrcLoc +import GHCi.BreakArray import GHCi.RemoteTypes +import GHCi.FFI +import GHCi.InfoTable import Foreign +import Data.Array import Data.Array.Base ( UArray(..) ) import Data.ByteString (ByteString) -import GHC.Exts +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import GHC.Stack.CCS +-- ----------------------------------------------------------------------------- +-- Compiled Byte Code -data CompiledByteCode - = ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings - ItblEnv -- A mapping from DataCons to their itbls - [FFIInfo] -- ffi blocks we allocated +data CompiledByteCode = CompiledByteCode + { bc_bcos :: [UnlinkedBCO] -- Bunch of interpretable bindings + , bc_itbls :: ItblEnv -- A mapping from DataCons to their itbls + , bc_ffis :: [FFIInfo] -- ffi blocks we allocated + , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not + -- creating breakpoints, for some reason) + } -- ToDo: we're not tracking strings that we malloc'd - -newtype FFIInfo = FFIInfo RemotePtr +newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif) deriving Show instance Outputable CompiledByteCode where - ppr (ByteCode bcos _ _) = ppr bcos + ppr CompiledByteCode{..} = ppr bc_bcos type ItblEnv = NameEnv (Name, ItblPtr) -- We need the Name in the range so we know which -- elements to filter out when unloading a module -newtype ItblPtr = ItblPtr (Ptr ()) deriving Show +newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable) deriving Show data UnlinkedBCO = UnlinkedBCO { @@ -60,8 +72,7 @@ data BCOPtr = BCOPtrName Name | BCOPtrPrimOp PrimOp | BCOPtrBCO UnlinkedBCO - | BCOPtrBreakInfo BreakInfo - | BCOPtrArray (MutableByteArray# RealWorld) + | BCOPtrBreakArray -- a pointer to this module's BreakArray data BCONPtr = BCONPtrWord Word @@ -69,12 +80,11 @@ data BCONPtr | BCONPtrItbl Name | BCONPtrStr ByteString -data BreakInfo - = BreakInfo - { breakInfo_module :: Module - , breakInfo_number :: {-# UNPACK #-} !Int - , breakInfo_vars :: [(Id,Word16)] - , breakInfo_resty :: Type +-- | Information about a breakpoint that we know at code-generation time +data CgBreakInfo + = CgBreakInfo + { cgb_vars :: [(Id,Word16)] + , cgb_resty :: Type } instance Outputable UnlinkedBCO where @@ -83,9 +93,46 @@ instance Outputable UnlinkedBCO where ppr (sizeSS lits), text "lits", ppr (sizeSS ptrs), text "ptrs" ] -instance Outputable BreakInfo where - ppr info = text "BreakInfo" <+> - parens (ppr (breakInfo_module info) <+> - ppr (breakInfo_number info) <+> - ppr (breakInfo_vars info) <+> - ppr (breakInfo_resty info)) +instance Outputable CgBreakInfo where + ppr info = text "CgBreakInfo" <+> + parens (ppr (cgb_vars info) <+> + ppr (cgb_resty info)) + +-- ----------------------------------------------------------------------------- +-- Breakpoints + +-- | Breakpoint index +type BreakIndex = Int + +-- | C CostCentre type +data CCostCentre + +-- | All the information about the breakpoints for a module +data ModBreaks + = ModBreaks + { modBreaks_flags :: ForeignRef BreakArray + -- ^ The array of flags, one per breakpoint, + -- indicating which breakpoints are enabled. + , modBreaks_locs :: !(Array BreakIndex SrcSpan) + -- ^ An array giving the source span of each breakpoint. + , modBreaks_vars :: !(Array BreakIndex [OccName]) + -- ^ An array giving the names of the free variables at each breakpoint. + , modBreaks_decls :: !(Array BreakIndex [String]) + -- ^ An array giving the names of the declarations enclosing each breakpoint. + , modBreaks_ccs :: !(Array BreakIndex (RemotePtr CostCentre)) + -- ^ Array pointing to cost centre for each breakpoint + , modBreaks_breakInfo :: IntMap CgBreakInfo + -- ^ info about each breakpoint from the bytecode generator + } + +-- | Construct an empty ModBreaks +emptyModBreaks :: ModBreaks +emptyModBreaks = ModBreaks + { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised" + -- ToDo: can we avoid this? + , modBreaks_locs = array (0,-1) [] + , modBreaks_vars = array (0,-1) [] + , modBreaks_decls = array (0,-1) [] + , modBreaks_ccs = array (0,-1) [] + , modBreaks_breakInfo = IntMap.empty + } diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 5c6a02d3ff..81aab36ea9 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -119,7 +119,7 @@ bindSuspensions t = do let ids = [ mkVanillaGlobal name ty | (name,ty) <- zip names tys] new_ic = extendInteractiveContextWithIds ictxt ids - fhvs <- liftIO $ mapM (mkFinalizedHValue hsc_env <=< mkHValueRef) hvals + fhvs <- liftIO $ mapM (mkFinalizedHValue hsc_env <=< mkRemoteRef) hvals liftIO $ extendLinkEnv (zip names fhvs) modifySession $ \_ -> hsc_env {hsc_IC = new_ic } return t' @@ -173,7 +173,7 @@ showTerm term = do let noop_log _ _ _ _ _ = return () expr = "show " ++ showPpr dflags bname _ <- GHC.setSessionDynFlags dflags{log_action=noop_log} - fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkHValueRef val + fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkRemoteRef val txt_ <- withExtendedLinkEnv [(bname, fhv)] (GHC.compileExpr expr) let myprec = 10 -- application precedence. TODO Infix constructors diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs index b7e0eb33f5..2b4abddc0f 100644 --- a/compiler/ghci/GHCi.hs +++ b/compiler/ghci/GHCi.hs @@ -6,7 +6,7 @@ -- module GHCi ( -- * High-level interface to the interpreter - evalStmt, EvalStatus(..), EvalResult(..), EvalExpr(..) + evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..) , resumeStmt , abandonStmt , evalIO @@ -15,6 +15,9 @@ module GHCi , mallocData , mkCostCentre , costCentreStackInfo + , newBreakArray + , enableBreakpoint + , breakpointStatus -- * The object-code linker , initObjLinker @@ -43,6 +46,7 @@ module GHCi import GHCi.Message import GHCi.Run import GHCi.RemoteTypes +import GHCi.BreakArray (BreakArray) import HscTypes import UniqFM import Panic @@ -62,6 +66,8 @@ import Data.Binary import Data.ByteString (ByteString) import Data.IORef import Foreign +import Foreign.C +import GHC.Stack.CCS (CostCentre,CostCentreStack) import System.Exit #ifndef mingw32_HOST_OS import Data.Maybe @@ -178,7 +184,8 @@ withIServ HscEnv{..} action = -- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for -- each of the results. evalStmt - :: HscEnv -> Bool -> EvalExpr ForeignHValue -> IO (EvalStatus [ForeignHValue]) + :: HscEnv -> Bool -> EvalExpr ForeignHValue + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) evalStmt hsc_env step foreign_expr = do let dflags = hsc_dflags hsc_env status <- withExpr foreign_expr $ \expr -> @@ -187,29 +194,32 @@ evalStmt hsc_env step foreign_expr = do where withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a withExpr (EvalThis fhv) cont = - withForeignHValue fhv $ \hvref -> cont (EvalThis hvref) + withForeignRef fhv $ \hvref -> cont (EvalThis hvref) withExpr (EvalApp fl fr) cont = withExpr fl $ \fl' -> withExpr fr $ \fr' -> cont (EvalApp fl' fr') -resumeStmt :: HscEnv -> Bool -> ForeignHValue -> IO (EvalStatus [ForeignHValue]) +resumeStmt + :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef]) + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) resumeStmt hsc_env step resume_ctxt = do let dflags = hsc_dflags hsc_env - status <- withForeignHValue resume_ctxt $ \rhv -> + status <- withForeignRef resume_ctxt $ \rhv -> iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv) handleEvalStatus hsc_env status -abandonStmt :: HscEnv -> ForeignHValue -> IO () +abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO () abandonStmt hsc_env resume_ctxt = do - withForeignHValue resume_ctxt $ \rhv -> + withForeignRef resume_ctxt $ \rhv -> iservCmd hsc_env (AbandonStmt rhv) handleEvalStatus - :: HscEnv -> EvalStatus [HValueRef] -> IO (EvalStatus [ForeignHValue]) + :: HscEnv -> EvalStatus [HValueRef] + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) handleEvalStatus hsc_env status = case status of - EvalBreak a b c d e -> return (EvalBreak a b c d e) + EvalBreak a b c d e f -> return (EvalBreak a b c d e f) EvalComplete alloc res -> EvalComplete alloc <$> addFinalizer res where @@ -220,38 +230,53 @@ handleEvalStatus hsc_env status = -- | Execute an action of type @IO ()@ evalIO :: HscEnv -> ForeignHValue -> IO () evalIO hsc_env fhv = do - liftIO $ withForeignHValue fhv $ \fhv -> + liftIO $ withForeignRef fhv $ \fhv -> iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult -- | Execute an action of type @IO String@ evalString :: HscEnv -> ForeignHValue -> IO String evalString hsc_env fhv = do - liftIO $ withForeignHValue fhv $ \fhv -> + liftIO $ withForeignRef fhv $ \fhv -> iservCmd hsc_env (EvalString fhv) >>= fromEvalResult -- | Execute an action of type @String -> IO String@ evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String evalStringToIOString hsc_env fhv str = do - liftIO $ withForeignHValue fhv $ \fhv -> + liftIO $ withForeignRef fhv $ \fhv -> iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult -- | Allocate and store the given bytes in memory, returning a pointer -- to the memory in the remote process. -mallocData :: HscEnv -> ByteString -> IO (Ptr ()) -mallocData hsc_env bs = fromRemotePtr <$> iservCmd hsc_env (MallocData bs) +mallocData :: HscEnv -> ByteString -> IO (RemotePtr ()) +mallocData hsc_env bs = iservCmd hsc_env (MallocData bs) mkCostCentre - :: HscEnv -> RemotePtr {- CChar -} -> String -> String - -> IO RemotePtr {- CCostCentre -} + :: HscEnv -> RemotePtr CChar -> String -> String -> IO (RemotePtr CostCentre) mkCostCentre hsc_env c_module name src = iservCmd hsc_env (MkCostCentre c_module name src) -costCentreStackInfo :: HscEnv -> RemotePtr {- CCostCentreStack -} -> IO [String] +costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String] costCentreStackInfo hsc_env ccs = iservCmd hsc_env (CostCentreStackInfo ccs) +newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray) +newBreakArray hsc_env size = do + breakArray <- iservCmd hsc_env (NewBreakArray size) + mkFinalizedHValue hsc_env breakArray + +enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO () +enableBreakpoint hsc_env ref ix b = do + withForeignRef ref $ \breakarray -> + iservCmd hsc_env (EnableBreakpoint breakarray ix b) + +breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool +breakpointStatus hsc_env ref ix = do + withForeignRef ref $ \breakarray -> + iservCmd hsc_env (BreakpointStatus breakarray ix) + + -- ----------------------------------------------------------------------------- -- Interface to the object-code linker @@ -459,14 +484,15 @@ principle it would probably be ok, but it seems less hairy this way. -- | Creates a 'ForeignHValue' that will automatically release the -- 'HValueRef' when it is no longer referenced. -mkFinalizedHValue :: HscEnv -> HValueRef -> IO ForeignHValue -mkFinalizedHValue HscEnv{..} hvref = mkForeignHValue hvref free +mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a) +mkFinalizedHValue HscEnv{..} rref = mkForeignRef rref free where !external = gopt Opt_ExternalInterpreter hsc_dflags + hvref = toHValueRef rref free :: IO () free - | not external = freeHValueRef hvref + | not external = freeRemoteRef hvref | otherwise = modifyMVar_ hsc_iserv $ \mb_iserv -> case mb_iserv of @@ -481,19 +507,19 @@ freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs) -- | Convert a 'ForeignHValue' to an 'HValue' directly. This only works -- when the interpreter is running in the same process as the compiler, -- so it fails when @-fexternal-interpreter@ is on. -wormhole :: DynFlags -> ForeignHValue -> IO HValue -wormhole dflags r = wormholeRef dflags (unsafeForeignHValueToHValueRef r) +wormhole :: DynFlags -> ForeignRef a -> IO a +wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r) -- | Convert an 'HValueRef' to an 'HValue' directly. This only works -- when the interpreter is running in the same process as the compiler, -- so it fails when @-fexternal-interpreter@ is on. -wormholeRef :: DynFlags -> HValueRef -> IO HValue +wormholeRef :: DynFlags -> RemoteRef a -> IO a wormholeRef dflags r | gopt Opt_ExternalInterpreter dflags = throwIO (InstallationError "this operation requires -fno-external-interpreter") | otherwise - = localHValueRef r + = localRef r -- ----------------------------------------------------------------------------- -- Misc utils diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs index 7e86e1135f..8f1107fc26 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections #-} +{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-} {-# OPTIONS_GHC -fno-cse #-} -- -- (c) The University of Glasgow 2002-2006 @@ -496,7 +496,10 @@ linkExpr hsc_env span root_ul_bco -- Link the necessary packages and linkables - ; [(_,root_hvref)] <- linkSomeBCOs hsc_env ie ce [root_ul_bco] + ; let nobreakarray = error "no break array" + bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)] + ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco + ; [root_hvref] <- iservCmd hsc_env (CreateBCOs [resolved]) ; fhv <- mkFinalizedHValue hsc_env root_hvref ; return (pls, fhv) }}} @@ -703,7 +706,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods ********************************************************************* -} linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () -linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv _) = do +linkDecls hsc_env span cbc@CompiledByteCode{..} = do -- Initialise the linker (if it's not been done already) initDynLinker hsc_env @@ -717,17 +720,17 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv _) = do else do -- Link the expression itself - let ie = plusNameEnv (itbl_env pls) itblEnv + let ie = plusNameEnv (itbl_env pls) bc_itbls ce = closure_env pls -- Link the necessary packages and linkables - new_bindings <- linkSomeBCOs hsc_env ie ce unlinkedBCOs + new_bindings <- linkSomeBCOs hsc_env ie ce [cbc] nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs , itbl_env = ie } return (pls2, ()) where - free_names = concatMap (nameSetElems . bcoFreeNames) unlinkedBCOs + free_names = concatMap (nameSetElems . bcoFreeNames) bc_bcos needed_mods :: [Module] needed_mods = [ nameModule n | n <- free_names, @@ -914,12 +917,11 @@ dynLinkBCOs hsc_env pls bcos = do cbcs = map byteCodeOfObject unlinkeds - ul_bcos = [b | ByteCode bs _ _ <- cbcs, b <- bs] - ies = [ie | ByteCode _ ie _ <- cbcs] + ies = map bc_itbls cbcs gce = closure_env pls final_ie = foldr plusNameEnv (itbl_env pls) ies - names_and_refs <- linkSomeBCOs hsc_env final_ie gce ul_bcos + names_and_refs <- linkSomeBCOs hsc_env final_ie gce cbcs -- We only want to add the external ones to the ClosureEnv let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs @@ -929,28 +931,36 @@ dynLinkBCOs hsc_env pls bcos = do -- Wrap finalizers on the ones we want to keep new_binds <- makeForeignNamedHValueRefs hsc_env to_add - let pls2 = pls1 { closure_env = extendClosureEnv gce new_binds, - itbl_env = final_ie } - - return pls2 + return pls1 { closure_env = extendClosureEnv gce new_binds, + itbl_env = final_ie } -- Link a bunch of BCOs and return references to their values linkSomeBCOs :: HscEnv -> ItblEnv -> ClosureEnv - -> [UnlinkedBCO] + -> [CompiledByteCode] -> IO [(Name,HValueRef)] -- The returned HValueRefs are associated 1-1 with -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO -linkSomeBCOs _ _ _ [] = return [] -linkSomeBCOs hsc_env ie ce ul_bcos = do - let names = map unlinkedBCOName ul_bcos - bco_ix = mkNameEnv (zip names [0..]) - resolved <- mapM (linkBCO hsc_env ie ce bco_ix) ul_bcos - hvrefs <- iservCmd hsc_env (CreateBCOs resolved) - return (zip names hvrefs) +linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods [] + where + fun CompiledByteCode{..} inner accum = + case bc_breaks of + Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum) + Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray -> + inner ((breakarray, bc_bcos) : accum) + + do_link [] = return [] + do_link mods = do + let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ] + names = map (unlinkedBCOName . snd) flat + bco_ix = mkNameEnv (zip names [0..]) + resolved <- sequence [ linkBCO hsc_env ie ce bco_ix breakarray bco + | (breakarray, bco) <- flat ] + hvrefs <- iservCmd hsc_env (CreateBCOs resolved) + return (zip names hvrefs) -- | Useful to apply to the result of 'linkSomeBCOs' makeForeignNamedHValueRefs diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 17a72143b4..047e12e146 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -177,7 +177,7 @@ compileOne' m_tc_result mHscMessage let linkable = LM o_time this_mod [DotO object_filename] return hmi0 { hm_linkable = Just linkable } (HscRecomp cgguts summary, HscInterpreted) -> do - (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env cgguts summary + (hasStub, comp_bc) <- hscInteractive hsc_env cgguts summary stub_o <- case hasStub of Nothing -> return [] @@ -185,7 +185,7 @@ compileOne' m_tc_result mHscMessage stub_o <- compileStub hsc_env stub_c return [DotO stub_o] - let hs_unlinked = [BCOs comp_bc modBreaks] + let hs_unlinked = [BCOs comp_bc] unlinked_time = ms_hs_date summary -- Why do we use the timestamp of the source file here, -- rather than the current time? This works better in diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 957f48c6e1..31f809c716 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -145,7 +145,6 @@ module GHC ( modInfoModBreaks, ModBreaks(..), BreakIndex, BreakInfo(breakInfo_number, breakInfo_module), - BreakArray, setBreakOn, setBreakOff, getBreak, InteractiveEval.back, InteractiveEval.forward, @@ -290,8 +289,8 @@ module GHC ( #ifdef GHCI import ByteCodeTypes -import BreakArray import InteractiveEval +import InteractiveEvalTypes import TcRnDriver ( runTcInteractive ) import GHCi import GHCi.RemoteTypes diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 558341aebc..7807f653e3 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1284,7 +1284,7 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do hscInteractive :: HscEnv -> CgGuts -> ModSummary - -> IO (Maybe FilePath, CompiledByteCode, ModBreaks) + -> IO (Maybe FilePath, CompiledByteCode) #ifdef GHCI hscInteractive hsc_env cgguts mod_summary = do let dflags = hsc_dflags hsc_env @@ -1311,7 +1311,7 @@ hscInteractive hsc_env cgguts mod_summary = do ------------------ Create f-x-dynamic C-side stuff --- (_istub_h_exists, istub_c_exists) <- outputForeignStubs dflags this_mod location foreign_stubs - return (istub_c_exists, comp_bc, mod_breaks) + return (istub_c_exists, comp_bc) #else hscInteractive _ _ = panic "GHC not compiled with interpreter" #endif @@ -1705,7 +1705,7 @@ mkModGuts mod safe binds = mg_warns = NoWarnings, mg_anns = [], mg_hpc_info = emptyHpcInfo False, - mg_modBreaks = emptyModBreaks, + mg_modBreaks = Nothing, mg_vect_info = noVectInfo, mg_inst_env = emptyInstEnv, mg_fam_inst_env = emptyFamInstEnv, diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 0a7682157e..9e049209f8 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -111,8 +111,7 @@ module HscTypes ( HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage, -- * Breakpoints - ModBreaks (..), BreakIndex, emptyModBreaks, - CCostCentre, + ModBreaks (..), emptyModBreaks, -- * Vectorisation information VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo, @@ -134,7 +133,7 @@ module HscTypes ( #include "HsVersions.h" #ifdef GHCI -import ByteCodeTypes ( CompiledByteCode ) +import ByteCodeTypes import InteractiveEvalTypes ( Resume ) import GHCi.Message ( Pipe ) import GHCi.RemoteTypes @@ -176,7 +175,6 @@ import IfaceSyn import CoreSyn ( CoreRule, CoreVect ) import Maybes import Outputable -import BreakArray import SrcLoc -- import Unique import UniqFM @@ -195,7 +193,6 @@ import GHC.Serialized ( Serialized ) import Foreign import Control.Monad ( guard, liftM, when, ap ) import Control.Concurrent -import Data.Array ( Array, array ) import Data.IORef import Data.Time import Data.Typeable ( Typeable ) @@ -1099,7 +1096,7 @@ data ModGuts mg_warns :: !Warnings, -- ^ Warnings declared in the module mg_anns :: [Annotation], -- ^ Annotations declared in this module mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module - mg_modBreaks :: !ModBreaks, -- ^ Breakpoints for the module + mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module mg_vect_decls:: ![CoreVect], -- ^ Vectorisation declarations in this module -- (produced by desugarer & consumed by vectoriser) mg_vect_info :: !VectInfo, -- ^ Pool of vectorised declarations in the module @@ -1157,7 +1154,7 @@ data CgGuts cg_dep_pkgs :: ![UnitId], -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information - cg_modBreaks :: !ModBreaks -- ^ Module breakpoints + cg_modBreaks :: !(Maybe ModBreaks) -- ^ Module breakpoints } ----------------------------------- @@ -2819,12 +2816,16 @@ data Unlinked = DotO FilePath -- ^ An object file (.o) | DotA FilePath -- ^ Static archive file (.a) | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) - | BCOs CompiledByteCode ModBreaks -- ^ A byte-code object, lives only in memory + | BCOs CompiledByteCode -- ^ A byte-code object, lives only in memory #ifndef GHCI data CompiledByteCode = CompiledByteCodeUndefined -_unused :: CompiledByteCode -_unused = CompiledByteCodeUndefined +_unusedCompiledByteCode :: CompiledByteCode +_unusedCompiledByteCode = CompiledByteCodeUndefined + +data ModBreaks = ModBreaksUndefined +emptyModBreaks :: ModBreaks +emptyModBreaks = ModBreaksUndefined #endif instance Outputable Unlinked where @@ -2832,9 +2833,9 @@ instance Outputable Unlinked where ppr (DotA path) = text "DotA" <+> text path ppr (DotDLL path) = text "DotDLL" <+> text path #ifdef GHCI - ppr (BCOs bcos _) = text "BCOs" <+> ppr bcos + ppr (BCOs bcos) = text "BCOs" <+> ppr bcos #else - ppr (BCOs _ _) = text "No byte code" + ppr (BCOs _) = text "No byte code" #endif -- | Is this an actual file on disk we can link in somehow? @@ -2857,50 +2858,6 @@ nameOfObject other = pprPanic "nameOfObject" (ppr other) -- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable byteCodeOfObject :: Unlinked -> CompiledByteCode -byteCodeOfObject (BCOs bc _) = bc -byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) - -{- -************************************************************************ -* * -\subsection{Breakpoint Support} -* * -************************************************************************ --} +byteCodeOfObject (BCOs bc) = bc +byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) --- | Breakpoint index -type BreakIndex = Int - --- | C CostCentre type -data CCostCentre - --- | All the information about the breakpoints for a given module -data ModBreaks - = ModBreaks - { modBreaks_flags :: BreakArray - -- ^ The array of flags, one per breakpoint, - -- indicating which breakpoints are enabled. - , modBreaks_locs :: !(Array BreakIndex SrcSpan) - -- ^ An array giving the source span of each breakpoint. - , modBreaks_vars :: !(Array BreakIndex [OccName]) - -- ^ An array giving the names of the free variables at each breakpoint. - , modBreaks_decls :: !(Array BreakIndex [String]) - -- ^ An array giving the names of the declarations enclosing each breakpoint. -#ifdef GHCI - , modBreaks_ccs :: !(Array BreakIndex (RemotePtr {- CCostCentre -})) - -- ^ Array pointing to cost centre for each breakpoint -#endif - } - --- | Construct an empty ModBreaks -emptyModBreaks :: ModBreaks -emptyModBreaks = ModBreaks - { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised" - -- ToDo: can we avoid this? - , modBreaks_locs = array (0,-1) [] - , modBreaks_vars = array (0,-1) [] - , modBreaks_decls = array (0,-1) [] -#ifdef GHCI - , modBreaks_ccs = array (0,-1) [] -#endif - } diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 7839f1b9ed..e1f2cfcbd0 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples, - RecordWildCards #-} + RecordWildCards, BangPatterns #-} -- ----------------------------------------------------------------------------- -- @@ -84,7 +84,6 @@ import UniqFM import Maybes import ErrUtils import SrcLoc -import BreakArray import RtClosureInspect import Outputable import FastString @@ -95,6 +94,7 @@ import qualified Parser (parseStmt, parseModule, parseDeclaration) import System.Directory import Data.Dynamic import Data.Either +import qualified Data.IntMap as IntMap import Data.List (find,intercalate) import StringBuffer (stringToStringBuffer) import Control.Monad @@ -110,27 +110,23 @@ getResumeContext :: GhcMonad m => m [Resume] getResumeContext = withSession (return . ic_resume . hsc_IC) mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History -mkHistory hsc_env hval bi = let - decls = findEnclosingDecls hsc_env bi - in History hval bi decls - +mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi) getHistoryModule :: History -> Module getHistoryModule = breakInfo_module . historyBreakInfo getHistorySpan :: HscEnv -> History -> SrcSpan -getHistorySpan hsc_env hist = - let inf = historyBreakInfo hist - num = breakInfo_number inf - in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of - Just hmi -> modBreaks_locs (getModBreaks hmi) ! num - _ -> panic "getHistorySpan" +getHistorySpan hsc_env History{..} = + let BreakInfo{..} = historyBreakInfo in + case lookupUFM (hsc_HPT hsc_env) (moduleName breakInfo_module) of + Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number + _ -> panic "getHistorySpan" getModBreaks :: HomeModInfo -> ModBreaks getModBreaks hmi | Just linkable <- hm_linkable hmi, - [BCOs _ modBreaks] <- linkableUnlinked linkable - = modBreaks + [BCOs cbc] <- linkableUnlinked linkable + = fromMaybe emptyModBreaks (bc_breaks cbc) | otherwise = emptyModBreaks -- probably object code @@ -139,11 +135,11 @@ getModBreaks hmi -- by the coverage pass, which gives the list of lexically-enclosing bindings -- for each tick. findEnclosingDecls :: HscEnv -> BreakInfo -> [String] -findEnclosingDecls hsc_env inf = +findEnclosingDecls hsc_env (BreakInfo modl ix) = let hmi = expectJust "findEnclosingDecls" $ - lookupUFM (hsc_HPT hsc_env) (moduleName $ breakInfo_module inf) + lookupUFM (hsc_HPT hsc_env) (moduleName modl) mb = getModBreaks hmi - in modBreaks_decls mb ! breakInfo_number inf + in modBreaks_decls mb ! ix -- | Update fixity environment in the current interactive context. updateFixityEnv :: GhcMonad m => FixityEnv -> m () @@ -286,7 +282,8 @@ emptyHistory size = nilBL size handleRunStatus :: GhcMonad m => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id] - -> EvalStatus [ForeignHValue] -> BoundedList History + -> EvalStatus_ [ForeignHValue] [HValueRef] + -> BoundedList History -> m ExecResult handleRunStatus step expr bindings final_ids status history @@ -294,24 +291,26 @@ handleRunStatus step expr bindings final_ids status history | otherwise = not_tracing where tracing - | EvalBreak is_exception apStack_ref info_ref resume_ctxt _ccs <- status + | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status , not is_exception = do hsc_env <- getSession - let dflags = hsc_dflags hsc_env - info_hv <- liftIO $ wormholeRef dflags info_ref - let info = unsafeCoerce# info_hv :: BreakInfo - b <- liftIO $ isBreakEnabled hsc_env info + let hmi = expectJust "handleRunStatus" $ + lookupUFM (hsc_HPT hsc_env) (mkUniqueGrimily mod_uniq) + modl = mi_module (hm_iface hmi) + breaks = getModBreaks hmi + + b <- liftIO $ + breakpointStatus hsc_env (modBreaks_flags breaks) ix if b then not_tracing -- This breakpoint is explicitly enabled; we want to stop -- instead of just logging it. else do apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref - let history' = mkHistory hsc_env apStack_fhv info `consBL` history - -- probably better make history strict here, otherwise - -- our BoundedList will be pointless. - _ <- liftIO $ evaluate history' + let bi = BreakInfo modl ix + !history' = mkHistory hsc_env apStack_fhv bi `consBL` history + -- history is strict, otherwise our BoundedList is pointless. fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt status <- liftIO $ GHCi.resumeStmt hsc_env True fhv handleRunStatus RunAndLogSteps expr bindings final_ids @@ -321,23 +320,24 @@ handleRunStatus step expr bindings final_ids status history not_tracing -- Hit a breakpoint - | EvalBreak is_exception apStack_ref info_ref resume_ctxt ccs <- status + | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status = do hsc_env <- getSession - let dflags = hsc_dflags hsc_env - info_hv <- liftIO $ wormholeRef dflags info_ref - let info = unsafeCoerce# info_hv :: BreakInfo resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref - let mb_info | is_exception = Nothing - | otherwise = Just info + let hmi = expectJust "handleRunStatus" $ + lookupUFM (hsc_HPT hsc_env) (mkUniqueGrimily mod_uniq) + modl = mi_module (hm_iface hmi) + bp | is_exception = Nothing + | otherwise = Just (BreakInfo modl ix) (hsc_env1, names, span, decl) <- liftIO $ - bindLocalsAtBreakpoint hsc_env apStack_fhv mb_info + bindLocalsAtBreakpoint hsc_env apStack_fhv bp let resume = Resume { resumeStmt = expr, resumeContext = resume_ctxt_fhv , resumeBindings = bindings, resumeFinalIds = final_ids - , resumeApStack = apStack_fhv, resumeBreakInfo = mb_info + , resumeApStack = apStack_fhv + , resumeBreakInfo = bp , resumeSpan = span, resumeHistory = toListBL history , resumeDecl = decl , resumeCCS = ccs @@ -345,7 +345,7 @@ handleRunStatus step expr bindings final_ids status history hsc_env2 = pushResume hsc_env1 resume modifySession (\_ -> hsc_env2) - return (ExecBreak names mb_info) + return (ExecBreak names bp) -- Completed successfully | EvalComplete allocs (EvalSuccess hvals) <- status @@ -364,16 +364,6 @@ handleRunStatus step expr bindings final_ids status history | otherwise = panic "not_tracing" -- actually exhaustive, but GHC can't tell -isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool -isBreakEnabled hsc_env inf = - case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of - Just hmi -> do - w <- getBreak (modBreaks_flags (getModBreaks hmi)) - (breakInfo_number inf) - case w of Just n -> return (n /= 0); _other -> return False - _ -> - return False - resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult resume canLogSpan step = execResultToRunResult <$> resumeExec canLogSpan step @@ -407,17 +397,17 @@ resumeExec canLogSpan step case r of Resume { resumeStmt = expr, resumeContext = fhv , resumeBindings = bindings, resumeFinalIds = final_ids - , resumeApStack = apStack, resumeBreakInfo = info + , resumeApStack = apStack, resumeBreakInfo = mb_brkpt , resumeSpan = span , resumeHistory = hist } -> do withVirtualCWD $ do status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv let prevHistoryLst = fromListBL 50 hist - hist' = case info of + hist' = case mb_brkpt of Nothing -> prevHistoryLst - Just i + Just bi | not $canLogSpan span -> prevHistoryLst - | otherwise -> mkHistory hsc_env apStack i `consBL` + | otherwise -> mkHistory hsc_env apStack bi `consBL` fromListBL 50 hist handleRunStatus step expr bindings final_ids status hist' @@ -461,14 +451,16 @@ moveHist fn = do if new_ix == 0 then case r of Resume { resumeApStack = apStack, - resumeBreakInfo = mb_info } -> - update_ic apStack mb_info + resumeBreakInfo = mb_brkpt } -> + update_ic apStack mb_brkpt else case history !! (new_ix - 1) of - History apStack info _ -> - update_ic apStack (Just info) + History{..} -> + update_ic historyApStack (Just historyBreakInfo) + -- ----------------------------------------------------------------------------- -- After stopping at a breakpoint, add free variables to the environment + result_fs :: FastString result_fs = fsLit "_result" @@ -494,25 +486,24 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do ictxt0 = hsc_IC hsc_env ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id] - -- Linker.extendLinkEnv [(exn_name, apStack)] return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>") -- Just case: we stopped at a breakpoint, we have information about the location -- of the breakpoint and the free variables of the expression. -bindLocalsAtBreakpoint hsc_env apStack_fhv (Just info) = do +bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do let - mod_name = moduleName (breakInfo_module info) hmi = expectJust "bindLocalsAtBreakpoint" $ - lookupUFM (hsc_HPT hsc_env) mod_name + lookupUFM (hsc_HPT hsc_env) (moduleName breakInfo_module) breaks = getModBreaks hmi - index = breakInfo_number info - vars = breakInfo_vars info - result_ty = breakInfo_resty info - occs = modBreaks_vars breaks ! index - span = modBreaks_locs breaks ! index - decl = intercalate "." $ modBreaks_decls breaks ! index + info = expectJust "bindLocalsAtBreakpoint2" $ + IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks) + vars = cgb_vars info + result_ty = cgb_resty info + occs = modBreaks_vars breaks ! breakInfo_number + span = modBreaks_locs breaks ! breakInfo_number + decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number -- Filter out any unboxed ids; -- we can't bind these at the prompt @@ -554,7 +545,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just info) = do ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids names = map idName new_ids - fhvs <- mapM (mkFinalizedHValue hsc_env <=< mkHValueRef) + fhvs <- mapM (mkFinalizedHValue hsc_env <=< mkRemoteRef) (catMaybes mb_hValues) Linker.extendLinkEnv (zip names fhvs) when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)] diff --git a/compiler/main/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs index 4372891bd8..34ae2ccaa0 100644 --- a/compiler/main/InteractiveEvalTypes.hs +++ b/compiler/main/InteractiveEvalTypes.hs @@ -11,23 +11,25 @@ module InteractiveEvalTypes ( #ifdef GHCI Resume(..), History(..), ExecResult(..), - SingleStep(..), isStep, ExecOptions(..) + SingleStep(..), isStep, ExecOptions(..), + BreakInfo(..) #endif ) where #ifdef GHCI import GHCi.RemoteTypes -import GHCi.Message (EvalExpr) +import GHCi.Message (EvalExpr, ResumeContext) import Id import Name +import Module import RdrName import Type -import ByteCodeTypes import SrcLoc import Exception import Data.Word +import GHC.Stack.CCS data ExecOptions = ExecOptions @@ -56,27 +58,32 @@ data ExecResult , breakInfo :: Maybe BreakInfo } -data Resume - = Resume { - resumeStmt :: String, -- the original statement - resumeContext :: ForeignHValue, -- thread running the computation - resumeBindings :: ([TyThing], GlobalRdrEnv), - resumeFinalIds :: [Id], -- [Id] to bind on completion - resumeApStack :: ForeignHValue, -- The object from which we can get +data BreakInfo = BreakInfo + { breakInfo_module :: Module + , breakInfo_number :: Int + } + +data Resume = Resume + { resumeStmt :: String -- the original statement + , resumeContext :: ForeignRef (ResumeContext [HValueRef]) + , resumeBindings :: ([TyThing], GlobalRdrEnv) + , resumeFinalIds :: [Id] -- [Id] to bind on completion + , resumeApStack :: ForeignHValue -- The object from which we can get -- value of the free variables. - resumeBreakInfo :: Maybe BreakInfo, + , resumeBreakInfo :: Maybe BreakInfo -- the breakpoint we stopped at + -- (module, index) -- (Nothing <=> exception) - resumeSpan :: SrcSpan, -- just a copy of the SrcSpan + , resumeSpan :: SrcSpan -- just a copy of the SrcSpan -- from the ModBreaks, -- otherwise it's a pain to -- fetch the ModDetails & -- ModBreaks to get this. - resumeDecl :: String, -- ditto - resumeCCS :: RemotePtr {- CostCentreStack -}, - resumeHistory :: [History], - resumeHistoryIx :: Int -- 0 <==> at the top of the history - } + , resumeDecl :: String -- ditto + , resumeCCS :: RemotePtr CostCentreStack + , resumeHistory :: [History] + , resumeHistoryIx :: Int -- 0 <==> at the top of the history + } data History = History { diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index bc2870ba10..6beff7f0db 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -177,6 +177,7 @@ import qualified Control.Monad.Fail as MonadFail import Data.Map ( Map ) import Data.Dynamic ( Dynamic ) import Data.Typeable ( TypeRep ) +import GHCi.Message import GHCi.RemoteTypes import qualified Language.Haskell.TH as TH @@ -496,7 +497,7 @@ data TcGblEnv -- ^ Template Haskell module finalizers tcg_th_state :: TcRef (Map TypeRep Dynamic), - tcg_th_remote_state :: TcRef (Maybe ForeignHValue), + tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))), -- ^ Template Haskell state #endif /* GHCI */ diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 63a3371dd1..cdb47901c0 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -913,7 +913,7 @@ finishTH = do case th_state of Nothing -> return () -- TH was not started, nothing to do Just fhv -> do - liftIO $ withForeignHValue fhv $ \rhv -> + liftIO $ withForeignRef fhv $ \rhv -> writeIServ i (putMessage (FinishTH rhv)) () <- runRemoteTH i writeTcRef (tcg_th_remote_state tcg) Nothing @@ -946,8 +946,8 @@ runTH ty fhv = do rstate <- getTHState i loc <- TH.qLocation liftIO $ - withForeignHValue rstate $ \state_hv -> - withForeignHValue fhv $ \q_hv -> + withForeignRef rstate $ \state_hv -> + withForeignRef fhv $ \q_hv -> writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc))) bs <- runRemoteTH i return $! runGet get (LB.fromStrict bs) @@ -966,7 +966,7 @@ runRemoteTH iserv = do liftIO $ writeIServ iserv (put r) runRemoteTH iserv -getTHState :: IServ -> TcM ForeignHValue +getTHState :: IServ -> TcM (ForeignRef (IORef QState)) getTHState i = do tcg <- getGblEnv th_state <- readTcRef (tcg_th_remote_state tcg) @@ -563,7 +563,10 @@ BOOT_PKG_CONSTRAINTS := \ --constraint "$p == $(shell grep -i "^Version:" libraries/$d/$p.cabal | sed "s/[^0-9.]//g")")) # The actual .a and .so/.dll files: needed for dependencies. -ALL_STAGE1_LIBS = $(foreach lib,$(PACKAGES_STAGE1),$(libraries/$(lib)_dist-install_v_LIB)) +$(foreach way,$(GhcLibWays),$(eval ALL_STAGE1_$(way)_LIBS = $$(foreach lib,$$(PACKAGES_STAGE1),$$(libraries/$$(lib)_dist-install_$(way)_LIB)))) + +ALL_STAGE1_LIBS = $(ALL_STAGE1_v_LIBS) + ifeq "$(BuildSharedLibs)" "YES" ALL_STAGE1_LIBS += $(foreach lib,$(PACKAGES_STAGE1),$(libraries/$(lib)_dist-install_dyn_LIB)) endif diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 4fcbe6d7fe..7bd9bbeb77 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -39,6 +39,8 @@ import Debugger -- The GHC interface import GHCi +import GHCi.RemoteTypes +import GHCi.BreakArray import DynFlags import ErrUtils import GhcMonad ( modifySession ) @@ -58,7 +60,6 @@ import PrelNames import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName ) import SrcLoc import qualified Lexer -import ByteCodeTypes (BreakInfo(..)) import StringBuffer import Outputable hiding ( printForUser, printForUserPartWay, bold ) @@ -2651,7 +2652,7 @@ pprStopped res = <> text (GHC.resumeDecl res)) <> char ',' <+> ppr (GHC.resumeSpan res) where - mb_mod_name = moduleName <$> breakInfo_module <$> GHC.resumeBreakInfo res + mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res showPackages :: GHCi () showPackages = do @@ -3094,24 +3095,19 @@ findBreakAndSet md lookupTickTree = do some -> mapM_ (breakAt breakArray) some where breakAt breakArray (tick, pan) = do - success <- liftIO $ setBreakFlag True breakArray tick - if success - then do - (alreadySet, nm) <- - recordBreak $ BreakLocation - { breakModule = md - , breakLoc = RealSrcSpan pan - , breakTick = tick - , onBreakCmd = "" - } - printForUser $ - text "Breakpoint " <> ppr nm <> - if alreadySet - then text " was already set at " <> ppr pan - else text " activated at " <> ppr pan - else do - printForUser $ text "Breakpoint could not be activated at" - <+> ppr pan + setBreakFlag True breakArray tick + (alreadySet, nm) <- + recordBreak $ BreakLocation + { breakModule = md + , breakLoc = RealSrcSpan pan + , breakTick = tick + , onBreakCmd = "" + } + printForUser $ + text "Breakpoint " <> ppr nm <> + if alreadySet + then text " was already set at " <> ppr pan + else text " activated at " <> ppr pan -- When a line number is specified, the current policy for choosing -- the best breakpoint is this: @@ -3390,12 +3386,13 @@ deleteBreak identity = do mapM_ (turnOffBreak.snd) this setGHCiState $ st { breaks = rest } -turnOffBreak :: BreakLocation -> GHCi Bool +turnOffBreak :: BreakLocation -> GHCi () turnOffBreak loc = do (arr, _) <- getModBreak (breakModule loc) - liftIO $ setBreakFlag False arr (breakTick loc) + hsc_env <- GHC.getSession + liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False -getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan) +getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan) getModBreak m = do Just mod_info <- GHC.getModuleInfo m let modBreaks = GHC.modInfoModBreaks mod_info @@ -3403,11 +3400,10 @@ getModBreak m = do let ticks = GHC.modBreaks_locs modBreaks return (arr, ticks) -setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool -setBreakFlag toggle arr i - | toggle = GHC.setBreakOn arr i - | otherwise = GHC.setBreakOff arr i - +setBreakFlag :: Bool -> ForeignRef BreakArray -> Int -> GHCi () +setBreakFlag toggle arr i = do + hsc_env <- GHC.getSession + liftIO $ enableBreakpoint hsc_env arr i toggle -- --------------------------------------------------------------------------- -- User code exception handling diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index 2a2372d5f9..87b6d27c5d 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -118,7 +118,7 @@ data GHCiState = GHCiState noBuffering :: ForeignHValue } -type TickArray = Array Int [(BreakIndex,RealSrcSpan)] +type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)] -- | A GHCi command data Command diff --git a/compiler/main/BreakArray.hs b/libraries/ghci/GHCi/BreakArray.hs index 447490266c..311bbd6c5e 100644 --- a/compiler/main/BreakArray.hs +++ b/libraries/ghci/GHCi/BreakArray.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} ------------------------------------------------------------------------------- @@ -15,22 +16,17 @@ -- ------------------------------------------------------------------------------- -module BreakArray +module GHCi.BreakArray ( BreakArray -#ifdef GHCI (BA) -- constructor is exported only for ByteCodeGen -#endif , newBreakArray -#ifdef GHCI , getBreak , setBreakOn , setBreakOff , showBreakArray -#endif ) where -#ifdef GHCI import Control.Monad import Data.Word import GHC.Word @@ -116,17 +112,3 @@ readBA# array i = IO $ \s -> readBreakArray :: BreakArray -> Int -> IO Word8 readBreakArray (BA array) (I# i) = readBA# array i - -#else /* !GHCI */ - --- stub implementation to make main/, etc., code happier. --- IOArray and IOUArray are increasingly non-portable, --- still don't have quite the same interface, and (for GHCI) --- presumably have a different representation. -data BreakArray = Unspecified - -newBreakArray :: Int -> IO BreakArray -newBreakArray _ = return Unspecified - -#endif /* GHCI */ - diff --git a/libraries/ghci/GHCi/CreateBCO.hs b/libraries/ghci/GHCi/CreateBCO.hs index 6a9b79ae62..9501b5f0a7 100644 --- a/libraries/ghci/GHCi/CreateBCO.hs +++ b/libraries/ghci/GHCi/CreateBCO.hs @@ -14,6 +14,7 @@ module GHCi.CreateBCO (createBCOs) where import GHCi.ResolvedBCO import GHCi.RemoteTypes +import GHCi.BreakArray import SizedSeq import System.IO (fixIO) @@ -31,7 +32,7 @@ createBCOs bcos = do hvals <- fixIO $ \hvs -> do let arr = listArray (0, n_bcos-1) hvs mapM (createBCO arr) bcos - mapM mkHValueRef hvals + mapM mkRemoteRef hvals createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue createBCO arr bco @@ -85,15 +86,16 @@ mkPtrsArray arr n_ptrs ptrs = do fill (ResolvedBCORef n) i = writePtrsArrayHValue i (arr ! n) marr -- must be lazy! fill (ResolvedBCOPtr r) i = do - hv <- localHValueRef r + hv <- localRef r writePtrsArrayHValue i hv marr fill (ResolvedBCOStaticPtr r) i = do writePtrsArrayPtr i (fromRemotePtr r) marr fill (ResolvedBCOPtrBCO bco) i = do BCO bco# <- linkBCO' arr bco writePtrsArrayBCO i bco# marr - fill (ResolvedBCOPtrLocal hv) i = do - writePtrsArrayHValue i hv marr + fill (ResolvedBCOPtrBreakArray r) i = do + BA mba <- localRef r + writePtrsArrayMBA i mba marr zipWithM_ fill ptrs [0..] return marr @@ -123,6 +125,10 @@ writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s -> data BCO = BCO BCO# +writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO () +writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s -> + case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #) + newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO newBCO instrs lits ptrs arity bitmap = IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of diff --git a/libraries/ghci/GHCi/FFI.hsc b/libraries/ghci/GHCi/FFI.hsc index 36619aeb5d..7fd75bb8e4 100644 --- a/libraries/ghci/GHCi/FFI.hsc +++ b/libraries/ghci/GHCi/FFI.hsc @@ -12,6 +12,7 @@ module GHCi.FFI ( FFIType(..) , FFIConv(..) + , C_ffi_cif , prepForeignCall , freeForeignCallInfo ) where @@ -47,7 +48,7 @@ prepForeignCall :: FFIConv -> [FFIType] -- arg types -> FFIType -- result type - -> IO (Ptr ()) -- token for making calls (must be freed by caller) + -> IO (Ptr C_ffi_cif) -- token for making calls (must be freed by caller) prepForeignCall cconv arg_types result_type = do let n_args = length arg_types @@ -60,7 +61,7 @@ prepForeignCall cconv arg_types result_type = do then throwIO (ErrorCall ("prepForeignCallFailed: " ++ show r)) else return (castPtr cif) -freeForeignCallInfo :: Ptr () -> IO () +freeForeignCallInfo :: Ptr C_ffi_cif -> IO () freeForeignCallInfo p = do free ((#ptr ffi_cif, arg_types) p) free p diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc index 0244990ae0..cc57aff9f7 100644 --- a/libraries/ghci/GHCi/InfoTable.hsc +++ b/libraries/ghci/GHCi/InfoTable.hsc @@ -25,7 +25,7 @@ mkConInfoTable -> Int -- non-ptr words -> Int -- constr tag -> [Word8] -- con desc - -> IO (Ptr ()) + -> IO (Ptr StgInfoTable) -- resulting info table is allocated with allocateExec(), and -- should be freed with freeExec(). diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs index 37c9f0c209..59d6483089 100644 --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -4,19 +4,24 @@ module GHCi.Message ( Message(..), Msg(..) - , EvalStatus(..), EvalResult(..), EvalOpts(..), EvalExpr(..) + , EvalStatus_(..), EvalStatus, EvalResult(..), EvalOpts(..), EvalExpr(..) , SerializableException(..) , THResult(..), THResultType(..) + , ResumeContext(..) + , QState(..) , getMessage, putMessage , Pipe(..), remoteCall, readPipe, writePipe ) where import GHCi.RemoteTypes import GHCi.ResolvedBCO +import GHCi.InfoTable (StgInfoTable) import GHCi.FFI import GHCi.TH.Binary () +import GHCi.BreakArray import GHC.LanguageExtensions +import Control.Concurrent import Control.Exception import Data.Binary import Data.Binary.Get @@ -24,9 +29,12 @@ import Data.Binary.Put import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB +import Data.Dynamic import Data.IORef -import Data.Typeable +import Data.Map (Map) +import Foreign.C import GHC.Generics +import GHC.Stack.CCS import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH import System.Exit @@ -45,14 +53,14 @@ data Message a where -- These all invoke the corresponding functions in the RTS Linker API. InitLinker :: Message () - LookupSymbol :: String -> Message (Maybe RemotePtr) + LookupSymbol :: String -> Message (Maybe (RemotePtr ())) LookupClosure :: String -> Message (Maybe HValueRef) LoadDLL :: String -> Message (Maybe String) LoadArchive :: String -> Message () -- error? LoadObj :: String -> Message () -- error? UnloadObj :: String -> Message () -- error? - AddLibrarySearchPath :: String -> Message RemotePtr - RemoveLibrarySearchPath :: RemotePtr -> Message Bool + AddLibrarySearchPath :: String -> Message (RemotePtr ()) + RemoveLibrarySearchPath :: RemotePtr () -> Message Bool ResolveObjs :: Message Bool FindSystemLibrary :: String -> Message (Maybe String) @@ -65,13 +73,13 @@ data Message a where FreeHValueRefs :: [HValueRef] -> Message () -- | Malloc some data and return a 'RemotePtr' to it - MallocData :: ByteString -> Message RemotePtr + MallocData :: ByteString -> Message (RemotePtr ()) -- | Calls 'GHCi.FFI.prepareForeignCall' - PrepFFI :: FFIConv -> [FFIType] -> FFIType -> Message RemotePtr + PrepFFI :: FFIConv -> [FFIType] -> FFIType -> Message (RemotePtr C_ffi_cif) -- | Free data previously created by 'PrepFFI' - FreeFFI :: RemotePtr -> Message () + FreeFFI :: RemotePtr C_ffi_cif -> Message () -- | Create an info table for a constructor MkConInfoTable @@ -79,7 +87,7 @@ data Message a where -> Int -- non-ptr words -> Int -- constr tag -> [Word8] -- constructor desccription - -> Message RemotePtr + -> Message (RemotePtr StgInfoTable) -- | Evaluate a statement EvalStmt @@ -90,12 +98,12 @@ data Message a where -- | Resume evaluation of a statement after a breakpoint ResumeStmt :: EvalOpts - -> HValueRef {- ResumeContext -} + -> RemoteRef (ResumeContext [HValueRef]) -> Message (EvalStatus [HValueRef]) -- | Abandon evaluation of a statement after a breakpoint AbandonStmt - :: HValueRef {- ResumeContext -} + :: RemoteRef (ResumeContext [HValueRef]) -> Message () -- | Evaluate something of type @IO String@ @@ -116,23 +124,41 @@ data Message a where -- | Create a CostCentre MkCostCentre - :: RemotePtr -- module, RemotePtr so it can be shared + :: RemotePtr CChar -- module, RemotePtr so it can be shared -> String -- name -> String -- SrcSpan - -> Message RemotePtr + -> Message (RemotePtr CostCentre) -- | Show a 'CostCentreStack' as a @[String]@ CostCentreStackInfo - :: RemotePtr {- from EvalBreak -} + :: RemotePtr CostCentreStack -> Message [String] + -- | Create a new array of breakpoint flags + NewBreakArray + :: Int -- size + -> Message (RemoteRef BreakArray) + + -- | Enable a breakpoint + EnableBreakpoint + :: RemoteRef BreakArray + -> Int -- index + -> Bool -- on or off + -> Message () + + -- | Query the status of a breakpoint (True <=> enabled) + BreakpointStatus + :: RemoteRef BreakArray + -> Int -- index + -> Message Bool -- True <=> enabled + -- Template Haskell ------------------------------------------- -- | Start a new TH module, return a state token that should be - StartTH :: Message HValueRef {- GHCiQState -} + StartTH :: Message (RemoteRef (IORef QState)) -- | Run TH module finalizers, and free the HValueRef - FinishTH :: HValueRef {- GHCiQState -} -> Message () + FinishTH :: RemoteRef (IORef QState) -> Message () -- | Evaluate a TH computation. -- @@ -142,7 +168,7 @@ data Message a where -- they did, we have to serialize the value anyway, so we might -- as well serialize it to force it. RunTH - :: HValueRef {- GHCiQState -} + :: RemoteRef (IORef QState) -> HValueRef {- e.g. TH.Q TH.Exp -} -> THResultType -> Maybe TH.Loc @@ -186,6 +212,12 @@ data EvalOpts = EvalOpts instance Binary EvalOpts +data ResumeContext a = ResumeContext + { resumeBreakMVar :: MVar () + , resumeStatusMVar :: MVar (EvalStatus a) + , resumeThreadId :: ThreadId + } + -- | We can pass simple expressions to EvalStmt, consisting of values -- and application. This allows us to wrap the statement to be -- executed in another function, which is used by GHCi to implement @@ -198,16 +230,19 @@ data EvalExpr a instance Binary a => Binary (EvalExpr a) -data EvalStatus a +type EvalStatus a = EvalStatus_ a a + +data EvalStatus_ a b = EvalComplete Word64 (EvalResult a) | EvalBreak Bool HValueRef{- AP_STACK -} - HValueRef{- BreakInfo -} - HValueRef{- ResumeContext -} - RemotePtr -- Cost centre stack + Int {- break index -} + Int {- uniq of ModuleName -} + (RemoteRef (ResumeContext b)) + (RemotePtr CostCentreStack) -- Cost centre stack deriving (Generic, Show) -instance Binary a => Binary (EvalStatus a) +instance Binary a => Binary (EvalStatus_ a b) data EvalResult a = EvalException SerializableException @@ -248,6 +283,18 @@ data THResultType = THExp | THPat | THType | THDec | THAnnWrapper instance Binary THResultType +data QState = QState + { qsMap :: Map TypeRep Dynamic + -- ^ persistent data between splices in a module + , qsFinalizers :: [TH.Q ()] + -- ^ registered finalizers (in reverse order) + , qsLocation :: Maybe TH.Loc + -- ^ location for current splice, if any + , qsPipe :: Pipe + -- ^ pipe to communicate with GHC + } +instance Show QState where show _ = "<QState>" + data Msg = forall a . (Binary a, Show a) => Msg (Message a) getMessage :: Get Msg @@ -280,25 +327,28 @@ getMessage = do 23 -> Msg <$> (EvalIO <$> get) 24 -> Msg <$> (MkCostCentre <$> get <*> get <*> get) 25 -> Msg <$> (CostCentreStackInfo <$> get) - 26 -> Msg <$> return StartTH - 27 -> Msg <$> FinishTH <$> get - 28 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get) - 29 -> Msg <$> NewName <$> get - 30 -> Msg <$> (Report <$> get <*> get) - 31 -> Msg <$> (LookupName <$> get <*> get) - 32 -> Msg <$> Reify <$> get - 33 -> Msg <$> ReifyFixity <$> get - 34 -> Msg <$> (ReifyInstances <$> get <*> get) - 35 -> Msg <$> ReifyRoles <$> get - 36 -> Msg <$> (ReifyAnnotations <$> get <*> get) - 37 -> Msg <$> ReifyModule <$> get - 38 -> Msg <$> ReifyConStrictness <$> get - 39 -> Msg <$> AddDependentFile <$> get - 40 -> Msg <$> AddTopDecls <$> get - 41 -> Msg <$> (IsExtEnabled <$> get) - 42 -> Msg <$> return ExtsEnabled - 43 -> Msg <$> return QDone - 44 -> Msg <$> QException <$> get + 26 -> Msg <$> (NewBreakArray <$> get) + 27 -> Msg <$> (EnableBreakpoint <$> get <*> get <*> get) + 28 -> Msg <$> (BreakpointStatus <$> get <*> get) + 29 -> Msg <$> return StartTH + 30 -> Msg <$> FinishTH <$> get + 31 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get) + 32 -> Msg <$> NewName <$> get + 33 -> Msg <$> (Report <$> get <*> get) + 34 -> Msg <$> (LookupName <$> get <*> get) + 35 -> Msg <$> Reify <$> get + 36 -> Msg <$> ReifyFixity <$> get + 37 -> Msg <$> (ReifyInstances <$> get <*> get) + 38 -> Msg <$> ReifyRoles <$> get + 39 -> Msg <$> (ReifyAnnotations <$> get <*> get) + 40 -> Msg <$> ReifyModule <$> get + 41 -> Msg <$> ReifyConStrictness <$> get + 42 -> Msg <$> AddDependentFile <$> get + 43 -> Msg <$> AddTopDecls <$> get + 44 -> Msg <$> (IsExtEnabled <$> get) + 45 -> Msg <$> return ExtsEnabled + 46 -> Msg <$> return QDone + 47 -> Msg <$> QException <$> get _ -> Msg <$> QFail <$> get putMessage :: Message a -> Put @@ -327,28 +377,31 @@ putMessage m = case m of EvalString val -> putWord8 21 >> put val EvalStringToString str val -> putWord8 22 >> put str >> put val EvalIO val -> putWord8 23 >> put val - MkCostCentre name mod src -> putWord8 24 >> put name >> put mod >> put src + MkCostCentre mod name src -> putWord8 24 >> put mod >> put name >> put src CostCentreStackInfo ptr -> putWord8 25 >> put ptr - StartTH -> putWord8 26 - FinishTH val -> putWord8 27 >> put val - RunTH st q loc ty -> putWord8 28 >> put st >> put q >> put loc >> put ty - NewName a -> putWord8 29 >> put a - Report a b -> putWord8 30 >> put a >> put b - LookupName a b -> putWord8 31 >> put a >> put b - Reify a -> putWord8 32 >> put a - ReifyFixity a -> putWord8 33 >> put a - ReifyInstances a b -> putWord8 34 >> put a >> put b - ReifyRoles a -> putWord8 35 >> put a - ReifyAnnotations a b -> putWord8 36 >> put a >> put b - ReifyModule a -> putWord8 37 >> put a - ReifyConStrictness a -> putWord8 38 >> put a - AddDependentFile a -> putWord8 39 >> put a - AddTopDecls a -> putWord8 40 >> put a - IsExtEnabled a -> putWord8 41 >> put a - ExtsEnabled -> putWord8 42 - QDone -> putWord8 43 - QException a -> putWord8 44 >> put a - QFail a -> putWord8 45 >> put a + NewBreakArray sz -> putWord8 26 >> put sz + EnableBreakpoint arr ix b -> putWord8 27 >> put arr >> put ix >> put b + BreakpointStatus arr ix -> putWord8 28 >> put arr >> put ix + StartTH -> putWord8 29 + FinishTH val -> putWord8 30 >> put val + RunTH st q loc ty -> putWord8 31 >> put st >> put q >> put loc >> put ty + NewName a -> putWord8 32 >> put a + Report a b -> putWord8 33 >> put a >> put b + LookupName a b -> putWord8 34 >> put a >> put b + Reify a -> putWord8 35 >> put a + ReifyFixity a -> putWord8 36 >> put a + ReifyInstances a b -> putWord8 37 >> put a >> put b + ReifyRoles a -> putWord8 38 >> put a + ReifyAnnotations a b -> putWord8 39 >> put a >> put b + ReifyModule a -> putWord8 40 >> put a + ReifyConStrictness a -> putWord8 41 >> put a + AddDependentFile a -> putWord8 42 >> put a + AddTopDecls a -> putWord8 43 >> put a + IsExtEnabled a -> putWord8 44 >> put a + ExtsEnabled -> putWord8 45 + QDone -> putWord8 46 + QException a -> putWord8 47 >> put a + QFail a -> putWord8 48 >> put a -- ----------------------------------------------------------------------------- -- Reading/writing messages diff --git a/libraries/ghci/GHCi/ObjLink.hs b/libraries/ghci/GHCi/ObjLink.hs index 710cffd1a6..d422813fa9 100644 --- a/libraries/ghci/GHCi/ObjLink.hs +++ b/libraries/ghci/GHCi/ObjLink.hs @@ -52,7 +52,7 @@ lookupClosure str = do case m of Nothing -> return Nothing Just (Ptr addr) -> case addrToAny# addr of - (# a #) -> Just <$> mkHValueRef (HValue a) + (# a #) -> Just <$> mkRemoteRef (HValue a) prefixUnderscore :: String -> String prefixUnderscore diff --git a/libraries/ghci/GHCi/RemoteTypes.hs b/libraries/ghci/GHCi/RemoteTypes.hs index 920ce93fe6..ea91f19a2b 100644 --- a/libraries/ghci/GHCi/RemoteTypes.hs +++ b/libraries/ghci/GHCi/RemoteTypes.hs @@ -1,16 +1,19 @@ {-# LANGUAGE CPP, StandaloneDeriving, GeneralizedNewtypeDeriving #-} module GHCi.RemoteTypes - ( RemotePtr(..), toRemotePtr, fromRemotePtr + ( RemotePtr(..), toRemotePtr, fromRemotePtr, castRemotePtr , HValue(..) - , HValueRef, mkHValueRef, localHValueRef, freeHValueRef - , ForeignHValue, mkForeignHValue, withForeignHValue - , unsafeForeignHValueToHValueRef, finalizeForeignHValue + , RemoteRef, mkRemoteRef, localRef, freeRemoteRef + , HValueRef, toHValueRef + , ForeignRef, mkForeignRef, withForeignRef + , ForeignHValue + , unsafeForeignRefToRemoteRef, finalizeForeignRef ) where import Data.Word import Foreign hiding (newForeignPtr) import Foreign.Concurrent import Data.Binary +import Unsafe.Coerce import GHC.Exts import GHC.ForeignPtr @@ -22,19 +25,22 @@ import GHC.ForeignPtr #include "MachDeps.h" #if SIZEOF_HSINT == 4 -newtype RemotePtr = RemotePtr Word32 +newtype RemotePtr a = RemotePtr Word32 #elif SIZEOF_HSINT == 8 -newtype RemotePtr = RemotePtr Word64 +newtype RemotePtr a = RemotePtr Word64 #endif -toRemotePtr :: Ptr a -> RemotePtr +toRemotePtr :: Ptr a -> RemotePtr a toRemotePtr p = RemotePtr (fromIntegral (ptrToWordPtr p)) -fromRemotePtr :: RemotePtr -> Ptr a +fromRemotePtr :: RemotePtr a -> Ptr a fromRemotePtr (RemotePtr p) = wordPtrToPtr (fromIntegral p) -deriving instance Show RemotePtr -deriving instance Binary RemotePtr +castRemotePtr :: RemotePtr a -> RemotePtr b +castRemotePtr (RemotePtr a) = RemotePtr a + +deriving instance Show (RemotePtr a) +deriving instance Binary (RemotePtr a) -- ----------------------------------------------------------------------------- -- HValueRef @@ -44,48 +50,57 @@ newtype HValue = HValue Any instance Show HValue where show _ = "<HValue>" -newtype HValueRef = HValueRef RemotePtr +-- | A reference to a remote value. These are allocated and freed explicitly. +newtype RemoteRef a = RemoteRef (RemotePtr ()) deriving (Show, Binary) --- | Make a reference to a local HValue that we can send remotely. +-- We can discard type information if we want +toHValueRef :: RemoteRef a -> RemoteRef HValue +toHValueRef = unsafeCoerce + +-- For convenience +type HValueRef = RemoteRef HValue + +-- | Make a reference to a local value that we can send remotely. -- This reference will keep the value that it refers to alive until --- 'freeHValueRef' is called. -mkHValueRef :: HValue -> IO HValueRef -mkHValueRef (HValue hv) = do - sp <- newStablePtr hv - return $! HValueRef (toRemotePtr (castStablePtrToPtr sp)) +-- 'freeRemoteRef' is called. +mkRemoteRef :: a -> IO (RemoteRef a) +mkRemoteRef a = do + sp <- newStablePtr a + return $! RemoteRef (toRemotePtr (castStablePtrToPtr sp)) -- | Convert an HValueRef to an HValue. Should only be used if the HValue -- originated in this process. -localHValueRef :: HValueRef -> IO HValue -localHValueRef (HValueRef w) = do - p <- deRefStablePtr (castPtrToStablePtr (fromRemotePtr w)) - return (HValue p) +localRef :: RemoteRef a -> IO a +localRef (RemoteRef w) = + deRefStablePtr (castPtrToStablePtr (fromRemotePtr w)) -- | Release an HValueRef that originated in this process -freeHValueRef :: HValueRef -> IO () -freeHValueRef (HValueRef w) = +freeRemoteRef :: RemoteRef a -> IO () +freeRemoteRef (RemoteRef w) = freeStablePtr (castPtrToStablePtr (fromRemotePtr w)) -- | An HValueRef with a finalizer -newtype ForeignHValue = ForeignHValue (ForeignPtr ()) +newtype ForeignRef a = ForeignRef (ForeignPtr ()) + +type ForeignHValue = ForeignRef HValue --- | Create a 'ForeignHValue' from an 'HValueRef'. The finalizer +-- | Create a 'ForeignRef' from a 'RemoteRef'. The finalizer -- should arrange to call 'freeHValueRef' on the 'HValueRef'. (since -- this function needs to be called in the process that created the -- 'HValueRef', it cannot be called directly from the finalizer). -mkForeignHValue :: HValueRef -> IO () -> IO ForeignHValue -mkForeignHValue (HValueRef hvref) finalizer = - ForeignHValue <$> newForeignPtr (fromRemotePtr hvref) finalizer +mkForeignRef :: RemoteRef a -> IO () -> IO (ForeignRef a) +mkForeignRef (RemoteRef hvref) finalizer = + ForeignRef <$> newForeignPtr (fromRemotePtr hvref) finalizer -- | Use a 'ForeignHValue' -withForeignHValue :: ForeignHValue -> (HValueRef -> IO a) -> IO a -withForeignHValue (ForeignHValue fp) f = - withForeignPtr fp (f . HValueRef . toRemotePtr) +withForeignRef :: ForeignRef a -> (RemoteRef a -> IO b) -> IO b +withForeignRef (ForeignRef fp) f = + withForeignPtr fp (f . RemoteRef . toRemotePtr) -unsafeForeignHValueToHValueRef :: ForeignHValue -> HValueRef -unsafeForeignHValueToHValueRef (ForeignHValue fp) = - HValueRef (toRemotePtr (unsafeForeignPtrToPtr fp)) +unsafeForeignRefToRemoteRef :: ForeignRef a -> RemoteRef a +unsafeForeignRefToRemoteRef (ForeignRef fp) = + RemoteRef (toRemotePtr (unsafeForeignPtrToPtr fp)) -finalizeForeignHValue :: ForeignHValue -> IO () -finalizeForeignHValue (ForeignHValue fp) = finalizeForeignPtr fp +finalizeForeignRef :: ForeignRef a -> IO () +finalizeForeignRef (ForeignRef fp) = finalizeForeignPtr fp diff --git a/libraries/ghci/GHCi/ResolvedBCO.hs b/libraries/ghci/GHCi/ResolvedBCO.hs index 9234210418..a349dedaba 100644 --- a/libraries/ghci/GHCi/ResolvedBCO.hs +++ b/libraries/ghci/GHCi/ResolvedBCO.hs @@ -6,6 +6,7 @@ module GHCi.ResolvedBCO import SizedSeq import GHCi.RemoteTypes +import GHCi.BreakArray import Data.Array.Unboxed import Data.Binary @@ -32,31 +33,14 @@ instance Binary ResolvedBCO data ResolvedBCOPtr = ResolvedBCORef Int -- ^ reference to the Nth BCO in the current set - | ResolvedBCOPtr HValueRef + | ResolvedBCOPtr (RemoteRef HValue) -- ^ reference to a previously created BCO - | ResolvedBCOStaticPtr RemotePtr + | ResolvedBCOStaticPtr (RemotePtr ()) -- ^ reference to a static ptr | ResolvedBCOPtrBCO ResolvedBCO -- ^ a nested BCO - | ResolvedBCOPtrLocal HValue - -- ^ something local, cannot be serialized + | ResolvedBCOPtrBreakArray (RemoteRef BreakArray) + -- ^ Resolves to the MutableArray# inside the BreakArray deriving (Generic, Show) --- Manual Binary instance is needed because we cannot serialize --- ResolvedBCOPtrLocal. This will go away once we have support for --- remote breakpoints. -instance Binary ResolvedBCOPtr where - put (ResolvedBCORef a) = putWord8 0 >> put a - put (ResolvedBCOPtr a) = putWord8 1 >> put a - put (ResolvedBCOStaticPtr a) = putWord8 2 >> put a - put (ResolvedBCOPtrBCO a) = putWord8 3 >> put a - put (ResolvedBCOPtrLocal _) = - error "Cannot serialize a local pointer. Use -fno-external-interpreter?" - - get = do - w <- getWord8 - case w of - 0 -> ResolvedBCORef <$> get - 1 -> ResolvedBCOPtr <$> get - 2 -> ResolvedBCOStaticPtr <$> get - _ -> ResolvedBCOPtrBCO <$> get +instance Binary ResolvedBCOPtr diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs index 8934437a10..865072ea7d 100644 --- a/libraries/ghci/GHCi/Run.hs +++ b/libraries/ghci/GHCi/Run.hs @@ -16,6 +16,7 @@ import GHCi.Message import GHCi.ObjLink import GHCi.RemoteTypes import GHCi.TH +import GHCi.BreakArray import Control.Concurrent import Control.DeepSeq @@ -50,16 +51,26 @@ run m = case m of ResolveObjs -> resolveObjs FindSystemLibrary str -> findSystemLibrary str CreateBCOs bco -> createBCOs bco - FreeHValueRefs rs -> mapM_ freeHValueRef rs + FreeHValueRefs rs -> mapM_ freeRemoteRef rs EvalStmt opts r -> evalStmt opts r ResumeStmt opts r -> resumeStmt opts r AbandonStmt r -> abandonStmt r EvalString r -> evalString r EvalStringToString r s -> evalStringToString r s EvalIO r -> evalIO r - MkCostCentre name mod src -> - toRemotePtr <$> mkCostCentre (fromRemotePtr name) mod src + MkCostCentre mod name src -> + toRemotePtr <$> mkCostCentre (fromRemotePtr mod) name src CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr) + NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz + EnableBreakpoint ref ix b -> do + arr <- localRef ref + _ <- if b then setBreakOn arr ix else setBreakOff arr ix + return () + BreakpointStatus ref ix -> do + arr <- localRef ref; r <- getBreak arr ix + case r of + Nothing -> return False + Just w -> return (w /= 0) MallocData bs -> mkString bs PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res FreeFFI p -> freeForeignCallInfo (fromRemotePtr p) @@ -73,9 +84,9 @@ evalStmt opts expr = do io <- mkIO expr sandboxIO opts $ do rs <- unsafeCoerce io :: IO [HValue] - mapM mkHValueRef rs + mapM mkRemoteRef rs where - mkIO (EvalThis href) = localHValueRef href + mkIO (EvalThis href) = localRef href mkIO (EvalApp l r) = do l' <- mkIO l r' <- mkIO r @@ -83,19 +94,19 @@ evalStmt opts expr = do evalIO :: HValueRef -> IO (EvalResult ()) evalIO r = do - io <- localHValueRef r + io <- localRef r tryEval (unsafeCoerce io :: IO ()) evalString :: HValueRef -> IO (EvalResult String) evalString r = do - io <- localHValueRef r + io <- localRef r tryEval $ do r <- unsafeCoerce io :: IO String evaluate (force r) evalStringToString :: HValueRef -> String -> IO (EvalResult String) evalStringToString r str = do - io <- localHValueRef r + io <- localRef r tryEval $ do r <- (unsafeCoerce io :: String -> IO String) str evaluate (force r) @@ -232,17 +243,17 @@ withBreakAction opts breakMVar statusMVar act -- might be a bit surprising. The exception flag is turned off -- as soon as it is hit, or in resetBreakAction below. - onBreak is_exception info apStack = do + onBreak :: BreakpointCallback + onBreak ix# uniq# is_exception apStack = do tid <- myThreadId let resume = ResumeContext { resumeBreakMVar = breakMVar , resumeStatusMVar = statusMVar , resumeThreadId = tid } - resume_r <- mkHValueRef (unsafeCoerce resume) - apStack_r <- mkHValueRef apStack - info_r <- mkHValueRef info + resume_r <- mkRemoteRef resume + apStack_r <- mkRemoteRef apStack ccs <- toRemotePtr <$> getCCSOf apStack - putMVar statusMVar $ EvalBreak is_exception apStack_r info_r resume_r ccs + putMVar statusMVar $ EvalBreak is_exception apStack_r (I# ix#) (I# uniq#) resume_r ccs takeMVar breakMVar resetBreakAction stablePtr = do @@ -251,15 +262,11 @@ withBreakAction opts breakMVar statusMVar act resetStepFlag freeStablePtr stablePtr -data ResumeContext a = ResumeContext - { resumeBreakMVar :: MVar () - , resumeStatusMVar :: MVar (EvalStatus a) - , resumeThreadId :: ThreadId - } - -resumeStmt :: EvalOpts -> HValueRef -> IO (EvalStatus [HValueRef]) +resumeStmt + :: EvalOpts -> RemoteRef (ResumeContext [HValueRef]) + -> IO (EvalStatus [HValueRef]) resumeStmt opts hvref = do - ResumeContext{..} <- unsafeCoerce (localHValueRef hvref) + ResumeContext{..} <- localRef hvref withBreakAction opts resumeBreakMVar resumeStatusMVar $ mask_ $ do putMVar resumeBreakMVar () -- this awakens the stopped thread... @@ -277,9 +284,9 @@ resumeStmt opts hvref = do -- step is necessary to prevent race conditions with -- -fbreak-on-exception (see #5975). -- See test break010. -abandonStmt :: HValueRef -> IO () +abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO () abandonStmt hvref = do - ResumeContext{..} <- unsafeCoerce (localHValueRef hvref) + ResumeContext{..} <- localRef hvref killThread resumeThreadId putMVar resumeBreakMVar () _ <- takeMVar resumeStatusMVar @@ -293,35 +300,35 @@ setStepFlag = poke stepFlag 1 resetStepFlag :: IO () resetStepFlag = poke stepFlag 0 +type BreakpointCallback = Int# -> Int# -> Bool -> HValue -> IO () + foreign import ccall "&rts_breakpoint_io_action" - breakPointIOAction :: Ptr (StablePtr (Bool -> HValue -> HValue -> IO ())) + breakPointIOAction :: Ptr (StablePtr BreakpointCallback) -noBreakStablePtr :: StablePtr (Bool -> HValue -> HValue -> IO ()) +noBreakStablePtr :: StablePtr BreakpointCallback noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction -noBreakAction :: Bool -> HValue -> HValue -> IO () -noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint" -noBreakAction True _ _ = return () -- exception: just continue +noBreakAction :: BreakpointCallback +noBreakAction _ _ False _ = putStrLn "*** Ignoring breakpoint" +noBreakAction _ _ True _ = return () -- exception: just continue -- Malloc and copy the bytes. We don't have any way to monitor the -- lifetime of this memory, so it just leaks. -mkString :: ByteString -> IO RemotePtr +mkString :: ByteString -> IO (RemotePtr ()) mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do ptr <- mallocBytes len copyBytes ptr cstr len - return (toRemotePtr ptr) - -data CCostCentre + return (castRemotePtr (toRemotePtr ptr)) -mkCostCentre :: Ptr CChar -> String -> String -> IO (Ptr CCostCentre) +mkCostCentre :: Ptr CChar -> String -> String -> IO (Ptr CostCentre) #if defined(PROFILING) -mkCostCentre c_module srcspan decl_path = do +mkCostCentre c_module decl_path srcspan = do c_name <- newCString decl_path c_srcspan <- newCString srcspan c_mkCostCentre c_name c_module c_srcspan foreign import ccall unsafe "mkCostCentre" - c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CCostCentre) + c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre) #else mkCostCentre _ _ _ = return nullPtr #endif diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs index 717192e39d..799bd6261b 100644 --- a/libraries/ghci/GHCi/TH.hs +++ b/libraries/ghci/GHCi/TH.hs @@ -28,18 +28,6 @@ import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH import Unsafe.Coerce -data QState = QState - { qsMap :: Map TypeRep Dynamic - -- ^ persistent data between splices in a module - , qsFinalizers :: [TH.Q ()] - -- ^ registered finalizers (in reverse order) - , qsLocation :: Maybe TH.Loc - -- ^ location for current splice, if any - , qsPipe :: Pipe - -- ^ pipe to communicate with GHC - } -instance Show QState where show _ = "<QState>" - initQState :: Pipe -> QState initQState p = QState M.empty [] Nothing p @@ -133,41 +121,41 @@ instance TH.Quasi GHCiQ where qIsExtEnabled x = ghcCmd (IsExtEnabled x) qExtsEnabled = ghcCmd ExtsEnabled -startTH :: IO HValueRef +startTH :: IO (RemoteRef (IORef QState)) startTH = do r <- newIORef (initQState (error "startTH: no pipe")) - mkHValueRef (unsafeCoerce r) + mkRemoteRef r -finishTH :: Pipe -> HValueRef -> IO () +finishTH :: Pipe -> RemoteRef (IORef QState) -> IO () finishTH pipe rstate = do - qstateref <- unsafeCoerce <$> localHValueRef rstate + qstateref <- localRef rstate qstate <- readIORef qstateref _ <- runGHCiQ runModFinalizers qstate { qsPipe = pipe } - freeHValueRef rstate + freeRemoteRef rstate return () runTH - :: Pipe -> HValueRef -> HValueRef + :: Pipe -> RemoteRef (IORef QState) -> HValueRef -> THResultType -> Maybe TH.Loc -> IO ByteString runTH pipe rstate rhv ty mb_loc = do - hv <- localHValueRef rhv + hv <- localRef rhv case ty of THExp -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp) THPat -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat) THType -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type) THDec -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec]) THAnnWrapper -> do - hv <- unsafeCoerce <$> localHValueRef rhv + hv <- unsafeCoerce <$> localRef rhv case hv :: AnnotationWrapper of AnnotationWrapper thing -> return $! LB.toStrict (runPut (put (toSerialized serializeWithData thing))) -runTHQ :: Binary a => Pipe -> HValueRef -> Maybe TH.Loc -> TH.Q a +runTHQ :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a -> IO ByteString runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do - qstateref <- unsafeCoerce <$> localHValueRef rstate + qstateref <- localRef rstate qstate <- readIORef qstateref let st = qstate { qsLocation = mb_loc, qsPipe = pipe } (r,new_state) <- runGHCiQ (TH.runQ ghciq) st diff --git a/libraries/ghci/ghci.cabal.in b/libraries/ghci/ghci.cabal.in index 85698c0db3..547374a894 100644 --- a/libraries/ghci/ghci.cabal.in +++ b/libraries/ghci/ghci.cabal.in @@ -42,6 +42,7 @@ library UnboxedTuples exposed-modules: + GHCi.BreakArray GHCi.Message GHCi.ResolvedBCO GHCi.RemoteTypes diff --git a/rts/Exception.cmm b/rts/Exception.cmm index 8d19c143ee..a89bd19eb3 100644 --- a/rts/Exception.cmm +++ b/rts/Exception.cmm @@ -524,14 +524,17 @@ retry_pop_stack: // be per-thread. CInt[rts_stop_on_exception] = 0; ("ptr" ioAction) = ccall deRefStablePtr (W_[rts_breakpoint_io_action] "ptr"); - Sp = Sp - WDS(6); - Sp(5) = exception; - Sp(4) = stg_raise_ret_info; - Sp(3) = exception; // the AP_STACK - Sp(2) = ghczmprim_GHCziTypes_True_closure; // dummy breakpoint info - Sp(1) = ghczmprim_GHCziTypes_True_closure; // True <=> a breakpoint + Sp = Sp - WDS(9); + Sp(8) = exception; + Sp(7) = stg_raise_ret_info; + Sp(6) = exception; + Sp(5) = ghczmprim_GHCziTypes_True_closure; // True <=> a breakpoint + Sp(4) = stg_ap_ppv_info; + Sp(3) = 0; + Sp(2) = stg_ap_n_info; + Sp(1) = 0; R1 = ioAction; - jump RET_LBL(stg_ap_pppv) [R1]; + jump RET_LBL(stg_ap_n) [R1]; } } diff --git a/rts/Interpreter.c b/rts/Interpreter.c index 37fef9c65e..21d7527541 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -928,7 +928,7 @@ run_BCO: /* check for a breakpoint on the beginning of a let binding */ case bci_BRK_FUN: { - int arg1_brk_array, arg2_array_index, arg3_freeVars; + int arg1_brk_array, arg2_array_index, arg3_module_uniq; #ifdef PROFILING int arg4_cc; #endif @@ -946,7 +946,7 @@ run_BCO: arg1_brk_array = BCO_GET_LARGE_ARG; arg2_array_index = BCO_NEXT; - arg3_freeVars = BCO_GET_LARGE_ARG; + arg3_module_uniq = BCO_GET_LARGE_ARG; #ifdef PROFILING arg4_cc = BCO_GET_LARGE_ARG; #else @@ -1002,20 +1002,31 @@ run_BCO: new_aps->payload[i] = (StgClosure *)Sp[i-2]; } - // prepare the stack so that we can call the - // rts_breakpoint_io_action and ensure that the stack is - // in a reasonable state for the GC and so that - // execution of this BCO can continue when we resume - ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action); - Sp -= 8; - Sp[7] = (W_)obj; - Sp[6] = (W_)&stg_apply_interp_info; - Sp[5] = (W_)new_aps; // the AP_STACK - Sp[4] = (W_)BCO_PTR(arg3_freeVars); // the info about local vars of the breakpoint - Sp[3] = (W_)False_closure; // True <=> a breakpoint - Sp[2] = (W_)&stg_ap_pppv_info; - Sp[1] = (W_)ioAction; // apply the IO action to its two arguments above - Sp[0] = (W_)&stg_enter_info; // get ready to run the IO action + // Arrange the stack to call the breakpoint IO action, and + // continue execution of this BCO when the IO action returns. + // + // ioAction :: Bool -- exception? + // -> HValue -- the AP_STACK, or exception + // -> Int -- the breakpoint index (arg2) + // -> Int -- the module uniq (arg3) + // -> IO () + // + ioAction = (StgClosure *) deRefStablePtr ( + rts_breakpoint_io_action); + + Sp -= 11; + Sp[10] = (W_)obj; + Sp[9] = (W_)&stg_apply_interp_info; + Sp[8] = (W_)new_aps; + Sp[7] = (W_)False_closure; // True <=> a breakpoint + Sp[6] = (W_)&stg_ap_ppv_info; + Sp[5] = (W_)BCO_LIT(arg3_module_uniq); + Sp[4] = (W_)&stg_ap_n_info; + Sp[3] = (W_)arg2_array_index; + Sp[2] = (W_)&stg_ap_n_info; + Sp[1] = (W_)ioAction; + Sp[0] = (W_)&stg_enter_info; + // set the flag in the TSO to say that we are now // stopping at a breakpoint so that when we resume // we don't stop on the same breakpoint that we diff --git a/rules/build-prog.mk b/rules/build-prog.mk index 8352d88412..74bcc4a367 100644 --- a/rules/build-prog.mk +++ b/rules/build-prog.mk @@ -278,10 +278,10 @@ endif # $1_$2_PROG_NEEDS_C_WRAPPER ifneq "$$(CLEANING)" "YES" ifneq "$3" "0" ifneq "$$($1_$2_HS_SRCS)" "" -ifeq "$$(strip $$(ALL_STAGE1_LIBS))" "" -$$(error ordering failure in $1 ($2): ALL_STAGE1_LIBS is empty) +ifeq "$$(strip $$(ALL_STAGE1_$$($1_$2_PROGRAM_WAY)_LIBS))" "" +$$(error ordering failure in $1 ($2): ALL_STAGE1_$$($1_$2_PROGRAM_WAY)_LIBS is empty) endif -$1/$2/build/tmp/$$($1_$2_PROG) : $$(ALL_STAGE1_LIBS) $$(ALL_RTS_LIBS) $$(OTHER_LIBS) +$1/$2/build/tmp/$$($1_$2_PROG) : $$(ALL_STAGE1_$$($1_$2_PROGRAM_WAY)_LIBS) $$(ALL_RTS_LIBS) endif endif endif diff --git a/testsuite/tests/ghci.debugger/scripts/break021.stdout b/testsuite/tests/ghci.debugger/scripts/break021.stdout index cc680a5b30..712417852d 100644 --- a/testsuite/tests/ghci.debugger/scripts/break021.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break021.stdout @@ -55,7 +55,7 @@ _result :: m () = _ ^^^^^^^ 7 line2 0 Stopped in Main.line1, break020.hs:3:11-19 -_result :: m () = _ +_result :: IO () = _ 2 3 line1 _ = return () ^^^^^^^^^ @@ -67,7 +67,7 @@ _result :: m () = _ ^^^^^^^ 8 Stopped in Main.line2, break020.hs:4:11-19 -_result :: m () = _ +_result :: IO () = _ 3 line1 _ = return () 4 line2 _ = return () ^^^^^^^^^ |