diff options
Diffstat (limited to 'compiler/ghci')
| -rw-r--r-- | compiler/ghci/ByteCodeAsm.lhs | 18 | ||||
| -rw-r--r-- | compiler/ghci/DebuggerUtils.hs | 4 | ||||
| -rw-r--r-- | compiler/ghci/Linker.lhs | 32 | ||||
| -rw-r--r-- | compiler/ghci/RtClosureInspect.hs | 2 |
4 files changed, 34 insertions, 22 deletions
diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 955119768d..e3119a7842 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -41,8 +41,10 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.State.Strict import Data.Array.MArray -import Data.Array.Unboxed ( listArray ) + +import qualified Data.Array.Unboxed as Array import Data.Array.Base ( UArray(..) ) + import Data.Array.Unsafe( castSTUArray ) import Foreign @@ -156,16 +158,16 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm dflags long_jumps env asm -- precomputed size should be equal to final size - ASSERT (n_insns == sizeSS final_insns) return () + ASSERT(n_insns == sizeSS final_insns) return () let asm_insns = ssElts final_insns barr a = case a of UArray _lo _hi _n b -> b - insns_arr = listArray (0, n_insns - 1) asm_insns + insns_arr = Array.listArray (0, n_insns - 1) asm_insns !insns_barr = barr insns_arr bitmap_arr = mkBitmapArray dflags bsize bitmap - !bitmap_barr = barr bitmap_arr + !bitmap_barr = toByteArray bitmap_arr ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs @@ -176,9 +178,15 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d return ul_bco +#if __GLASGOW_HASKELL__ > 706 +mkBitmapArray :: DynFlags -> Word16 -> [StgWord] -> UArrayStgWord Int +mkBitmapArray dflags bsize bitmap + = SMRep.listArray (0, length bitmap) (toStgWord dflags (toInteger bsize) : bitmap) +#else mkBitmapArray :: DynFlags -> Word16 -> [StgWord] -> UArray Int StgWord mkBitmapArray dflags bsize bitmap - = listArray (0, length bitmap) (toStgWord dflags (toInteger bsize) : bitmap) + = Array.listArray (0, length bitmap) (toStgWord dflags (toInteger bsize) : bitmap) +#endif -- instrs nonptrs ptrs type AsmState = (SizedSeq Word16, diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs index 7a03bbcdc2..3d73e69e2b 100644 --- a/compiler/ghci/DebuggerUtils.hs +++ b/compiler/ghci/DebuggerUtils.hs @@ -115,14 +115,14 @@ dataConInfoPtrToName x = do -- Warning: this code assumes that the string is well formed. parse :: [Word8] -> ([Word8], [Word8], [Word8]) parse input - = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ) + = ASSERT(all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ) where dot = fromIntegral (ord '.') (pkg, rest1) = break (== fromIntegral (ord ':')) input (mod, occ) = (concat $ intersperse [dot] $ reverse modWords, occWord) where - (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1)) + (modWords, occWord) = ASSERT(length rest1 > 0) (parseModOcc [] (tail rest1)) parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8]) -- We only look for dots if str could start with a module name, -- i.e. if it starts with an upper case character. diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index ffe43e07ba..192df2ee57 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -291,15 +291,14 @@ reallyInitDynLinker dflags = ; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0 -- (c) Link libraries from the command-line - ; let optl = getOpts dflags opt_l - ; let minus_ls = [ lib | '-':'l':lib <- optl ] + ; let cmdline_ld_inputs = ldInputs dflags + ; let minus_ls = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] ; let lib_paths = libraryPaths dflags ; libspecs <- mapM (locateLib dflags False lib_paths) minus_ls -- (d) Link .o files from the command-line - ; let cmdline_ld_inputs = ldInputs dflags - - ; classified_ld_inputs <- mapM (classifyLdInput dflags) cmdline_ld_inputs + ; classified_ld_inputs <- mapM (classifyLdInput dflags) + [ f | FileOption _ f <- cmdline_ld_inputs ] -- (e) Link any MacOS frameworks ; let platform = targetPlatform dflags @@ -637,8 +636,8 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods return lnk adjust_ul new_osuf (DotO file) = do - MASSERT (osuf `isSuffixOf` file) - let file_base = reverse (drop (length osuf + 1) (reverse file)) + MASSERT(osuf `isSuffixOf` file) + let file_base = dropTail (length osuf + 1) file new_file = file_base <.> new_osuf ok <- doesFileExist new_file if (not ok) @@ -786,7 +785,7 @@ dynLinkObjs dflags pls objs = do if cDYNAMIC_GHC_PROGRAMS then do dynLoadObjs dflags wanted_objs - return (pls, Succeeded) + return (pls1, Succeeded) else do mapM_ loadObj wanted_objs -- Link them all together @@ -801,6 +800,7 @@ dynLinkObjs dflags pls objs = do return (pls2, Failed) dynLoadObjs :: DynFlags -> [FilePath] -> IO () +dynLoadObjs _ [] = return () dynLoadObjs dflags objs = do let platform = targetPlatform dflags soFile <- newTempName dflags (soExt platform) @@ -896,7 +896,7 @@ linkSomeBCOs dflags toplevs_only ie ce_in ul_bcos else ce_all_additions ce_out = -- make sure we're not inserting duplicate names into the -- closure environment, which leads to trouble. - ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions)) + ASSERT(all (not . (`elemNameEnv` ce_in)) (map fst ce_additions)) extendClosureEnv ce_in ce_additions return (ce_out, hvals) @@ -968,6 +968,9 @@ unload_wkr _ linkables pls maybeUnload :: [Linkable] -> Linkable -> IO Bool maybeUnload keep_linkables lnk | linkableInSet lnk keep_linkables = return True + -- We don't do any cleanup when linking objects with the dynamic linker. + -- Doing so introduces extra complexity for not much benefit. + | cDYNAMIC_GHC_PROGRAMS = return False | otherwise = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk] -- The components of a BCO linkable may contain @@ -1195,7 +1198,7 @@ locateLib dflags is_hs dirs lib mk_arch_path dir = dir </> ("lib" ++ lib <.> "a") hs_dyn_lib_name = lib ++ "-ghc" ++ cProjectVersion - mk_hs_dyn_lib_path dir = dir </> mkSOName platform hs_dyn_lib_name + mk_hs_dyn_lib_path dir = dir </> mkHsSOName platform hs_dyn_lib_name so_name = mkSOName platform lib mk_dyn_lib_path dir = dir </> so_name @@ -1272,12 +1275,13 @@ findFile mk_file_path (dir : dirs) \begin{code} maybePutStr :: DynFlags -> String -> IO () -maybePutStr dflags s | verbosity dflags > 0 = putStr s - | otherwise = return () +maybePutStr dflags s + = when (verbosity dflags > 0) $ + do let act = log_action dflags + act dflags SevInteractive noSrcSpan defaultUserStyle (text s) maybePutStrLn :: DynFlags -> String -> IO () -maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s - | otherwise = return () +maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n") \end{code} %************************************************************************ diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index d6cbf87fcc..746a547a5b 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -1264,7 +1264,7 @@ unlessM condM acc = condM >>= \c -> unless c acc -- Strict application of f at index i appArr :: Ix i => (e -> a) -> Array i e -> Int -> a appArr f a@(Array _ _ _ ptrs#) i@(I# i#) - = ASSERT2 (i < length(elems a), ppr(length$ elems a, i)) + = ASSERT2(i < length(elems a), ppr(length$ elems a, i)) case indexArray# ptrs# i# of (# e #) -> f e |