summaryrefslogtreecommitdiff
path: root/compiler/ghci
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/ghci')
-rw-r--r--compiler/ghci/ByteCodeGen.lhs23
-rw-r--r--compiler/ghci/ByteCodeInstr.lhs176
-rw-r--r--compiler/ghci/ByteCodeLink.lhs6
-rw-r--r--compiler/ghci/DebuggerUtils.hs2
-rw-r--r--compiler/ghci/Linker.lhs109
-rw-r--r--compiler/ghci/RtClosureInspect.hs170
6 files changed, 218 insertions, 268 deletions
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index d4a58044f5..645a0d8118 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -6,13 +6,6 @@ ByteCodeGen: Generate bytecode from Core
\begin{code}
{-# LANGUAGE CPP, MagicHash #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
#include "HsVersions.h"
@@ -278,7 +271,7 @@ collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet)
collect (_, e) = go [] e
where
go xs e | Just e' <- bcView e = go xs e'
- go xs (AnnLam x (_,e))
+ go xs (AnnLam x (_,e))
| UbxTupleRep _ <- repType (idType x)
= unboxedTupleException
| otherwise
@@ -820,8 +813,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
MASSERT(isAlgCase)
rhs_code <- schemeE (d_alts + size) s p' rhs
return (my_discr alt, unitOL (UNPACK (trunc16 size)) `appOL` rhs_code)
- where
- real_bndrs = filterOut isTyVar bndrs
+ where
+ real_bndrs = filterOut isTyVar bndrs
my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
my_discr (DataAlt dc, _, _)
@@ -1253,8 +1246,8 @@ pushAtom d p e
| Just e' <- bcView e
= pushAtom d p e'
-pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things,
- = return (nilOL, 0) -- treated just like a variable V
+pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things,
+ = return (nilOL, 0) -- treated just like a variable V
pushAtom d p (AnnVar v)
| UnaryRep rep_ty <- repType (idType v)
@@ -1564,12 +1557,12 @@ isVAtom :: AnnExpr' Var ann -> Bool
isVAtom e | Just e' <- bcView e = isVAtom e'
isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v)
isVAtom (AnnCoercion {}) = True
-isVAtom _ = False
+isVAtom _ = False
atomPrimRep :: AnnExpr' Id ann -> PrimRep
atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
-atomPrimRep (AnnVar v) = bcIdPrimRep v
-atomPrimRep (AnnLit l) = typePrimRep (literalType l)
+atomPrimRep (AnnVar v) = bcIdPrimRep v
+atomPrimRep (AnnLit l) = typePrimRep (literalType l)
atomPrimRep (AnnCoercion {}) = VoidRep
atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other)))
diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs
index 548c29f514..5535d58453 100644
--- a/compiler/ghci/ByteCodeInstr.lhs
+++ b/compiler/ghci/ByteCodeInstr.lhs
@@ -5,23 +5,15 @@ ByteCodeInstrs: Bytecode instruction definitions
\begin{code}
{-# LANGUAGE CPP, MagicHash #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
{-# OPTIONS_GHC -funbox-strict-fields #-}
-
-module ByteCodeInstr (
- BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..)
+module ByteCodeInstr (
+ BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..)
) where
#include "HsVersions.h"
#include "../includes/MachDeps.h"
-import ByteCodeItbls ( ItblPtr )
+import ByteCodeItbls ( ItblPtr )
import StgCmmLayout ( ArgRep(..) )
import PprCore
@@ -44,17 +36,17 @@ import Data.Word
-- ----------------------------------------------------------------------------
-- Bytecode instructions
-data ProtoBCO a
- = ProtoBCO {
- protoBCOName :: a, -- name, in some sense
- protoBCOInstrs :: [BCInstr], -- instrs
- -- arity and GC info
- protoBCOBitmap :: [StgWord],
- protoBCOBitmapSize :: Word16,
- protoBCOArity :: Int,
- -- what the BCO came from
- protoBCOExpr :: Either [AnnAlt Id VarSet] (AnnExpr Id VarSet),
- -- malloc'd pointers
+data ProtoBCO a
+ = ProtoBCO {
+ protoBCOName :: a, -- name, in some sense
+ protoBCOInstrs :: [BCInstr], -- instrs
+ -- arity and GC info
+ protoBCOBitmap :: [StgWord],
+ protoBCOBitmapSize :: Word16,
+ protoBCOArity :: Int,
+ -- what the BCO came from
+ protoBCOExpr :: Either [AnnAlt Id VarSet] (AnnExpr Id VarSet),
+ -- malloc'd pointers
protoBCOPtrs :: [Either ItblPtr (Ptr ())]
}
@@ -80,14 +72,14 @@ data BCInstr
-- Pushing literals
| PUSH_UBX (Either Literal (Ptr ())) Word16
- -- push this int/float/double/addr, on the stack. Word16
- -- is # of words to copy from literal pool. Eitherness reflects
- -- the difficulty of dealing with MachAddr here, mostly due to
- -- the excessive (and unnecessary) restrictions imposed by the
- -- designers of the new Foreign library. In particular it is
- -- quite impossible to convert an Addr to any other integral
- -- type, and it appears impossible to get hold of the bits of
- -- an addr, even though we need to assemble BCOs.
+ -- push this int/float/double/addr, on the stack. Word16
+ -- is # of words to copy from literal pool. Eitherness reflects
+ -- the difficulty of dealing with MachAddr here, mostly due to
+ -- the excessive (and unnecessary) restrictions imposed by the
+ -- designers of the new Foreign library. In particular it is
+ -- quite impossible to convert an Addr to any other integral
+ -- type, and it appears impossible to get hold of the bits of
+ -- an addr, even though we need to assemble BCOs.
-- various kinds of application
| PUSH_APPLY_N
@@ -112,8 +104,8 @@ data BCInstr
| MKPAP !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-}
| UNPACK !Word16 -- unpack N words from t.o.s Constr
| PACK DataCon !Word16
- -- after assembly, the DataCon is an index into the
- -- itbl array
+ -- after assembly, the DataCon is an index into the
+ -- itbl array
-- For doing case trees
| LABEL LocalLabel
| TESTLT_I Int LocalLabel
@@ -147,13 +139,13 @@ data BCInstr
-- To Infinity And Beyond
| ENTER
- | RETURN -- return a lifted value
+ | RETURN -- return a lifted value
| RETURN_UBX ArgRep -- return an unlifted value, here's its rep
- -- Breakpoints
+ -- Breakpoints
| BRK_FUN (MutableByteArray# RealWorld) Word16 BreakInfo
-data BreakInfo
+data BreakInfo
= BreakInfo
{ breakInfo_module :: Module
, breakInfo_number :: {-# UNPACK #-} !Int
@@ -173,8 +165,8 @@ instance Outputable BreakInfo where
instance Outputable a => Outputable (ProtoBCO a) where
ppr (ProtoBCO name instrs bitmap bsize arity origin malloced)
- = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
- <+> text (show malloced) <> colon)
+ = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
+ <+> text (show malloced) <> colon)
$$ nest 3 (case origin of
Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';'))
(map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}'
@@ -212,8 +204,8 @@ instance Outputable BCInstr where
ppr (PUSH_L offset) = text "PUSH_L " <+> ppr offset
ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> ppr o1 <+> ppr o2
ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3
- ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
- ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers."
+ ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
+ ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers."
<> ppr op
ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco)
ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco)
@@ -221,23 +213,23 @@ instance Outputable BCInstr where
ppr (PUSH_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> text (show aa)
- ppr PUSH_APPLY_N = text "PUSH_APPLY_N"
- ppr PUSH_APPLY_V = text "PUSH_APPLY_V"
- ppr PUSH_APPLY_F = text "PUSH_APPLY_F"
- ppr PUSH_APPLY_D = text "PUSH_APPLY_D"
- ppr PUSH_APPLY_L = text "PUSH_APPLY_L"
- ppr PUSH_APPLY_P = text "PUSH_APPLY_P"
- ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP"
- ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP"
- ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP"
- ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP"
- ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP"
+ ppr PUSH_APPLY_N = text "PUSH_APPLY_N"
+ ppr PUSH_APPLY_V = text "PUSH_APPLY_V"
+ ppr PUSH_APPLY_F = text "PUSH_APPLY_F"
+ ppr PUSH_APPLY_D = text "PUSH_APPLY_D"
+ ppr PUSH_APPLY_L = text "PUSH_APPLY_L"
+ ppr PUSH_APPLY_P = text "PUSH_APPLY_P"
+ ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP"
+ ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP"
+ ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP"
+ ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP"
+ ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP"
ppr (SLIDE n d) = text "SLIDE " <+> ppr n <+> ppr d
ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> ppr sz
ppr (ALLOC_AP_NOUPD sz) = text "ALLOC_AP_NOUPD " <+> ppr sz
ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> ppr arity <+> ppr sz
- ppr (MKAP offset sz) = text "MKAP " <+> ppr sz <+> text "words,"
+ ppr (MKAP offset sz) = text "MKAP " <+> ppr sz <+> text "words,"
<+> ppr offset <+> text "stkoff"
ppr (MKPAP offset sz) = text "MKPAP " <+> ppr sz <+> text "words,"
<+> ppr offset <+> text "stkoff"
@@ -256,8 +248,8 @@ instance Outputable BCInstr where
ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab
ppr CASEFAIL = text "CASEFAIL"
ppr (JMP lab) = text "JMP" <+> ppr lab
- ppr (CCALL off marshall_addr int) = text "CCALL " <+> ppr off
- <+> text "marshall code at"
+ ppr (CCALL off marshall_addr int) = text "CCALL " <+> ppr off
+ <+> text "marshall code at"
<+> text (show marshall_addr)
<+> (if int == 1
then text "(interruptible)"
@@ -265,7 +257,7 @@ instance Outputable BCInstr where
ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
<+> text "by" <+> ppr n
ppr ENTER = text "ENTER"
- ppr RETURN = text "RETURN"
+ ppr RETURN = text "RETURN"
ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk
ppr (BRK_FUN _breakArray index info) = text "BRK_FUN" <+> text "<array>" <+> ppr index <+> ppr info
@@ -284,54 +276,54 @@ protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))
bciStackUse :: BCInstr -> Word
bciStackUse STKCHECK{} = 0
-bciStackUse PUSH_L{} = 1
-bciStackUse PUSH_LL{} = 2
+bciStackUse PUSH_L{} = 1
+bciStackUse PUSH_LL{} = 2
bciStackUse PUSH_LLL{} = 3
-bciStackUse PUSH_G{} = 1
+bciStackUse PUSH_G{} = 1
bciStackUse PUSH_PRIMOP{} = 1
-bciStackUse PUSH_BCO{} = 1
+bciStackUse PUSH_BCO{} = 1
bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco
bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
bciStackUse (PUSH_UBX _ nw) = fromIntegral nw
-bciStackUse PUSH_APPLY_N{} = 1
-bciStackUse PUSH_APPLY_V{} = 1
-bciStackUse PUSH_APPLY_F{} = 1
-bciStackUse PUSH_APPLY_D{} = 1
-bciStackUse PUSH_APPLY_L{} = 1
-bciStackUse PUSH_APPLY_P{} = 1
-bciStackUse PUSH_APPLY_PP{} = 1
-bciStackUse PUSH_APPLY_PPP{} = 1
-bciStackUse PUSH_APPLY_PPPP{} = 1
-bciStackUse PUSH_APPLY_PPPPP{} = 1
-bciStackUse PUSH_APPLY_PPPPPP{} = 1
+bciStackUse PUSH_APPLY_N{} = 1
+bciStackUse PUSH_APPLY_V{} = 1
+bciStackUse PUSH_APPLY_F{} = 1
+bciStackUse PUSH_APPLY_D{} = 1
+bciStackUse PUSH_APPLY_L{} = 1
+bciStackUse PUSH_APPLY_P{} = 1
+bciStackUse PUSH_APPLY_PP{} = 1
+bciStackUse PUSH_APPLY_PPP{} = 1
+bciStackUse PUSH_APPLY_PPPP{} = 1
+bciStackUse PUSH_APPLY_PPPPP{} = 1
+bciStackUse PUSH_APPLY_PPPPPP{} = 1
bciStackUse ALLOC_AP{} = 1
bciStackUse ALLOC_AP_NOUPD{} = 1
bciStackUse ALLOC_PAP{} = 1
bciStackUse (UNPACK sz) = fromIntegral sz
-bciStackUse LABEL{} = 0
-bciStackUse TESTLT_I{} = 0
-bciStackUse TESTEQ_I{} = 0
-bciStackUse TESTLT_W{} = 0
-bciStackUse TESTEQ_W{} = 0
-bciStackUse TESTLT_F{} = 0
-bciStackUse TESTEQ_F{} = 0
-bciStackUse TESTLT_D{} = 0
-bciStackUse TESTEQ_D{} = 0
-bciStackUse TESTLT_P{} = 0
-bciStackUse TESTEQ_P{} = 0
-bciStackUse CASEFAIL{} = 0
-bciStackUse JMP{} = 0
-bciStackUse ENTER{} = 0
-bciStackUse RETURN{} = 0
-bciStackUse RETURN_UBX{} = 1
-bciStackUse CCALL{} = 0
-bciStackUse SWIZZLE{} = 0
-bciStackUse BRK_FUN{} = 0
+bciStackUse LABEL{} = 0
+bciStackUse TESTLT_I{} = 0
+bciStackUse TESTEQ_I{} = 0
+bciStackUse TESTLT_W{} = 0
+bciStackUse TESTEQ_W{} = 0
+bciStackUse TESTLT_F{} = 0
+bciStackUse TESTEQ_F{} = 0
+bciStackUse TESTLT_D{} = 0
+bciStackUse TESTEQ_D{} = 0
+bciStackUse TESTLT_P{} = 0
+bciStackUse TESTEQ_P{} = 0
+bciStackUse CASEFAIL{} = 0
+bciStackUse JMP{} = 0
+bciStackUse ENTER{} = 0
+bciStackUse RETURN{} = 0
+bciStackUse RETURN_UBX{} = 1
+bciStackUse CCALL{} = 0
+bciStackUse SWIZZLE{} = 0
+bciStackUse BRK_FUN{} = 0
-- These insns actually reduce stack use, but we need the high-tide level,
-- so can't use this info. Not that it matters much.
-bciStackUse SLIDE{} = 0
-bciStackUse MKAP{} = 0
-bciStackUse MKPAP{} = 0
-bciStackUse PACK{} = 1 -- worst case is PACK 0 words
+bciStackUse SLIDE{} = 0
+bciStackUse MKAP{} = 0
+bciStackUse MKPAP{} = 0
+bciStackUse PACK{} = 1 -- worst case is PACK 0 words
\end{code}
diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs
index d508a1c5aa..cbedb717fe 100644
--- a/compiler/ghci/ByteCodeLink.lhs
+++ b/compiler/ghci/ByteCodeLink.lhs
@@ -260,13 +260,13 @@ linkFail who what
-- HACKS!!! ToDo: cleaner
nameToCLabel :: Name -> String{-suffix-} -> String
nameToCLabel n suffix
- = if pkgid /= mainPackageId
+ = if pkgid /= mainPackageKey
then package_part ++ '_': qual_name
else qual_name
where
- pkgid = modulePackageId mod
+ pkgid = modulePackageKey mod
mod = ASSERT( isExternalName n ) nameModule n
- package_part = zString (zEncodeFS (packageIdFS (modulePackageId mod)))
+ package_part = zString (zEncodeFS (packageKeyFS (modulePackageKey mod)))
module_part = zString (zEncodeFS (moduleNameFS (moduleName mod)))
occ_part = zString (zEncodeFS (occNameFS (nameOccName n)))
qual_name = module_part ++ '_':occ_part ++ '_':suffix
diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs
index 67767e41b9..9ccb113314 100644
--- a/compiler/ghci/DebuggerUtils.hs
+++ b/compiler/ghci/DebuggerUtils.hs
@@ -46,7 +46,7 @@ dataConInfoPtrToName x = do
modFS = mkFastStringByteList mod
occFS = mkFastStringByteList occ
occName = mkOccNameFS OccName.dataName occFS
- modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS)
+ modName = mkModule (fsToPackageKey pkgFS) (mkModuleNameFS modFS)
return (Left $ showSDoc dflags $ ppr modName <> dot <> ppr occName)
`recoverM` (Right `fmap` lookupOrig modName occName)
diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index 162c349a8d..40b83bbbae 100644
--- a/compiler/ghci/Linker.lhs
+++ b/compiler/ghci/Linker.lhs
@@ -59,7 +59,6 @@ import Control.Monad
import Data.IORef
import Data.List
-import qualified Data.Map as Map
import Control.Concurrent.MVar
import System.FilePath
@@ -70,7 +69,7 @@ import System.Directory hiding (findFile)
import System.Directory
#endif
-import Distribution.Package hiding (depends, PackageId)
+import Distribution.Package hiding (depends, mkPackageKey, PackageKey)
import Exception
\end{code}
@@ -124,12 +123,8 @@ data PersistentLinkerState
-- The currently-loaded packages; always object code
-- Held, as usual, in dependency order; though I am not sure if
-- that is really important
- pkgs_loaded :: ![PackageId],
-
- -- we need to remember the name of the last temporary DLL/.so
- -- so we can link it
- last_temp_so :: !(Maybe FilePath)
- }
+ pkgs_loaded :: ![PackageKey]
+ }
emptyPLS :: DynFlags -> PersistentLinkerState
emptyPLS _ = PersistentLinkerState {
@@ -137,18 +132,17 @@ emptyPLS _ = PersistentLinkerState {
itbl_env = emptyNameEnv,
pkgs_loaded = init_pkgs,
bcos_loaded = [],
- objs_loaded = [],
- last_temp_so = Nothing }
+ objs_loaded = [] }
-- Packages that don't need loading, because the compiler
-- shares them with the interpreted program.
--
-- The linker's symbol table is populated with RTS symbols using an
-- explicit list. See rts/Linker.c for details.
- where init_pkgs = [rtsPackageId]
+ where init_pkgs = [rtsPackageKey]
-extendLoadedPkgs :: [PackageId] -> IO ()
+extendLoadedPkgs :: [PackageKey] -> IO ()
extendLoadedPkgs pkgs =
modifyPLS_ $ \s ->
return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
@@ -320,14 +314,14 @@ reallyInitDynLinker dflags =
; if null cmdline_lib_specs then return pls
else do
- { pls1 <- foldM (preloadLib dflags lib_paths framework_paths) pls cmdline_lib_specs
+ { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
; maybePutStr dflags "final link ... "
; ok <- resolveObjs
; if succeeded ok then maybePutStrLn dflags "done"
else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")
- ; return pls1
+ ; return pls
}}
@@ -366,21 +360,19 @@ classifyLdInput dflags f
return Nothing
where platform = targetPlatform dflags
-preloadLib :: DynFlags -> [String] -> [String] -> PersistentLinkerState -> LibrarySpec -> IO (PersistentLinkerState)
-preloadLib dflags lib_paths framework_paths pls lib_spec
+preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
+preloadLib dflags lib_paths framework_paths lib_spec
= do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
case lib_spec of
Object static_ish
- -> do (b, pls1) <- preload_static lib_paths static_ish
+ -> do b <- preload_static lib_paths static_ish
maybePutStrLn dflags (if b then "done"
else "not found")
- return pls1
Archive static_ish
-> do b <- preload_static_archive lib_paths static_ish
maybePutStrLn dflags (if b then "done"
else "not found")
- return pls
DLL dll_unadorned
-> do maybe_errstr <- loadDLL (mkSOName platform dll_unadorned)
@@ -396,14 +388,12 @@ preloadLib dflags lib_paths framework_paths pls lib_spec
case err2 of
Nothing -> maybePutStrLn dflags "done"
Just _ -> preloadFailed mm lib_paths lib_spec
- return pls
DLLPath dll_path
-> do maybe_errstr <- loadDLL dll_path
case maybe_errstr of
Nothing -> maybePutStrLn dflags "done"
Just mm -> preloadFailed mm lib_paths lib_spec
- return pls
Framework framework ->
if platformUsesFrameworks (targetPlatform dflags)
@@ -411,7 +401,6 @@ preloadLib dflags lib_paths framework_paths pls lib_spec
case maybe_errstr of
Nothing -> maybePutStrLn dflags "done"
Just mm -> preloadFailed mm framework_paths lib_spec
- return pls
else panic "preloadLib Framework"
where
@@ -431,13 +420,11 @@ preloadLib dflags lib_paths framework_paths pls lib_spec
-- Not interested in the paths in the static case.
preload_static _paths name
= do b <- doesFileExist name
- if not b then return (False, pls)
- else if dynamicGhc
- then do pls1 <- dynLoadObjs dflags pls [name]
- return (True, pls1)
- else do loadObj name
- return (True, pls)
-
+ if not b then return False
+ else do if dynamicGhc
+ then dynLoadObjs dflags [name]
+ else loadObj name
+ return True
preload_static_archive _paths name
= do b <- doesFileExist name
if not b then return False
@@ -539,7 +526,7 @@ getLinkDeps :: HscEnv -> HomePackageTable
-> Maybe FilePath -- replace object suffices?
-> SrcSpan -- for error messages
-> [Module] -- If you need these
- -> IO ([Linkable], [PackageId]) -- ... then link these first
+ -> IO ([Linkable], [PackageKey]) -- ... then link these first
-- Fails with an IO exception if it can't find enough files
getLinkDeps hsc_env hpt pls replace_osuf span mods
@@ -577,8 +564,8 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
-- tree recursively. See bug #936, testcase ghci/prog007.
follow_deps :: [Module] -- modules to follow
-> UniqSet ModuleName -- accum. module dependencies
- -> UniqSet PackageId -- accum. package dependencies
- -> IO ([ModuleName], [PackageId]) -- result
+ -> UniqSet PackageKey -- accum. package dependencies
+ -> IO ([ModuleName], [PackageKey]) -- result
follow_deps [] acc_mods acc_pkgs
= return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
follow_deps (mod:mods) acc_mods acc_pkgs
@@ -592,7 +579,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
when (mi_boot iface) $ link_boot_mod_error mod
let
- pkg = modulePackageId mod
+ pkg = modulePackageKey mod
deps = mi_deps iface
pkg_deps = dep_pkgs deps
@@ -804,8 +791,8 @@ dynLinkObjs dflags pls objs = do
wanted_objs = map nameOfObject unlinkeds
if dynamicGhc
- then do pls2 <- dynLoadObjs dflags pls1 wanted_objs
- return (pls2, Succeeded)
+ then do dynLoadObjs dflags wanted_objs
+ return (pls1, Succeeded)
else do mapM_ loadObj wanted_objs
-- Link them all together
@@ -819,11 +806,9 @@ dynLinkObjs dflags pls objs = do
pls2 <- unload_wkr dflags [] pls1
return (pls2, Failed)
-
-dynLoadObjs :: DynFlags -> PersistentLinkerState -> [FilePath]
- -> IO PersistentLinkerState
-dynLoadObjs _ pls [] = return pls
-dynLoadObjs dflags pls objs = do
+dynLoadObjs :: DynFlags -> [FilePath] -> IO ()
+dynLoadObjs _ [] = return ()
+dynLoadObjs dflags objs = do
let platform = targetPlatform dflags
soFile <- newTempName dflags (soExt platform)
let -- When running TH for a non-dynamic way, we still need to make
@@ -831,22 +816,10 @@ dynLoadObjs dflags pls objs = do
-- Opt_Static off
dflags1 = gopt_unset dflags Opt_Static
dflags2 = dflags1 {
- -- We don't want the original ldInputs in
- -- (they're already linked in), but we do want
- -- to link against the previous dynLoadObjs
- -- library if there was one, so that the linker
- -- can resolve dependencies when it loads this
- -- library.
- ldInputs =
- case last_temp_so pls of
- Nothing -> []
- Just so ->
- let (lp, l) = splitFileName so in
- [ Option ("-L" ++ lp)
- , Option ("-Wl,-rpath")
- , Option ("-Wl," ++ lp)
- , Option ("-l:" ++ l)
- ],
+ -- We don't want to link the ldInputs in; we'll
+ -- be calling dynLoadObjs with any objects that
+ -- need to be linked.
+ ldInputs = [],
-- Even if we're e.g. profiling, we still want
-- the vanilla dynamic libraries, so we set the
-- ways / build tag to be just WayDyn.
@@ -858,7 +831,7 @@ dynLoadObjs dflags pls objs = do
consIORef (filesToNotIntermediateClean dflags) soFile
m <- loadDLL soFile
case m of
- Nothing -> return pls { last_temp_so = Just soFile }
+ Nothing -> return ()
Just err -> panic ("Loading temp shared object failed: " ++ err)
rmDupLinkables :: [Linkable] -- Already loaded
@@ -1071,7 +1044,7 @@ showLS (Framework nm) = "(framework) " ++ nm
-- automatically, and it doesn't matter what order you specify the input
-- packages.
--
-linkPackages :: DynFlags -> [PackageId] -> IO ()
+linkPackages :: DynFlags -> [PackageKey] -> IO ()
-- NOTE: in fact, since each module tracks all the packages it depends on,
-- we don't really need to use the package-config dependencies.
--
@@ -1087,16 +1060,13 @@ linkPackages dflags new_pkgs = do
modifyPLS_ $ \pls -> do
linkPackages' dflags new_pkgs pls
-linkPackages' :: DynFlags -> [PackageId] -> PersistentLinkerState
+linkPackages' :: DynFlags -> [PackageKey] -> PersistentLinkerState
-> IO PersistentLinkerState
linkPackages' dflags new_pks pls = do
pkgs' <- link (pkgs_loaded pls) new_pks
return $! pls { pkgs_loaded = pkgs' }
where
- pkg_map = pkgIdMap (pkgState dflags)
- ipid_map = installedPackageIdMap (pkgState dflags)
-
- link :: [PackageId] -> [PackageId] -> IO [PackageId]
+ link :: [PackageKey] -> [PackageKey] -> IO [PackageKey]
link pkgs new_pkgs =
foldM link_one pkgs new_pkgs
@@ -1104,17 +1074,16 @@ linkPackages' dflags new_pks pls = do
| new_pkg `elem` pkgs -- Already linked
= return pkgs
- | Just pkg_cfg <- lookupPackage pkg_map new_pkg
+ | Just pkg_cfg <- lookupPackage dflags new_pkg
= do { -- Link dependents first
- pkgs' <- link pkgs [ Maybes.expectJust "link_one" $
- Map.lookup ipid ipid_map
+ pkgs' <- link pkgs [ resolveInstalledPackageId dflags ipid
| ipid <- depends pkg_cfg ]
-- Now link the package itself
; linkPackage dflags pkg_cfg
; return (new_pkg : pkgs') }
| otherwise
- = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
+ = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ packageKeyString new_pkg))
linkPackage :: DynFlags -> PackageConfig -> IO ()
@@ -1235,7 +1204,9 @@ locateLib dflags is_hs dirs lib
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
+ mk_dyn_lib_path dir = case (arch, os) of
+ (ArchX86_64, OSSolaris2) -> dir </> ("64/" ++ so_name)
+ _ -> dir </> so_name
findObject = liftM (fmap Object) $ findFile mk_obj_path dirs
findDynObject = liftM (fmap Object) $ findFile mk_dyn_obj_path dirs
@@ -1252,6 +1223,8 @@ locateLib dflags is_hs dirs lib
Nothing -> g
platform = targetPlatform dflags
+ arch = platformArch platform
+ os = platformOS platform
searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)
searchForLibUsingGcc dflags so dirs = do
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index a2f9af92f1..dde813d31d 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -7,14 +7,6 @@
-- Pepe Iborra (supported by Google SoC) 2006
--
-----------------------------------------------------------------------------
-
-{-# OPTIONS_GHC -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module RtClosureInspect(
cvObtainTerm, -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
cvReconstructType,
@@ -85,9 +77,9 @@ import System.IO.Unsafe
data Term = Term { ty :: RttiType
, dc :: Either String DataCon
-- Carries a text representation if the datacon is
- -- not exported by the .hi file, which is the case
+ -- not exported by the .hi file, which is the case
-- for private constructors in -O0 compiled libraries
- , val :: HValue
+ , val :: HValue
, subTerms :: [Term] }
| Prim { ty :: RttiType
@@ -142,20 +134,20 @@ instance Outputable (Term) where
-------------------------------------------------------------------------
-- Runtime Closure Datatype and functions for retrieving closure related stuff
-------------------------------------------------------------------------
-data ClosureType = Constr
- | Fun
- | Thunk Int
+data ClosureType = Constr
+ | Fun
+ | Thunk Int
| ThunkSelector
- | Blackhole
- | AP
- | PAP
- | Indirection Int
+ | Blackhole
+ | AP
+ | PAP
+ | Indirection Int
| MutVar Int
| MVar Int
| Other Int
deriving (Show, Eq)
-data Closure = Closure { tipe :: ClosureType
+data Closure = Closure { tipe :: ClosureType
, infoPtr :: Ptr ()
, infoTable :: StgInfoTable
, ptrs :: Array Int HValue
@@ -163,7 +155,7 @@ data Closure = Closure { tipe :: ClosureType
}
instance Outputable ClosureType where
- ppr = text . show
+ ppr = text . show
#include "../includes/rts/storage/ClosureTypes.h"
@@ -175,7 +167,7 @@ pAP_CODE = PAP
getClosureData :: DynFlags -> a -> IO Closure
getClosureData dflags a =
- case unpackClosure# a of
+ case unpackClosure# a of
(# iptr, ptrs, nptrs #) -> do
let iptr'
| ghciTablesNextToCode =
@@ -194,11 +186,11 @@ getClosureData dflags a =
nptrs_data = [W# (indexWordArray# nptrs i)
| I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ]
ASSERT(elems >= 0) return ()
- ptrsList `seq`
+ ptrsList `seq`
return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
readCType :: Integral a => a -> ClosureType
-readCType i
+readCType i
| i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
| i >= FUN && i <= FUN_STATIC = Fun
| i >= THUNK && i < THUNK_SELECTOR = Thunk i'
@@ -212,7 +204,7 @@ readCType i
| i == MVAR_CLEAN || i == MVAR_DIRTY = MVar i'
| otherwise = Other i'
where i' = fromIntegral i
-
+
isConstr, isIndirection, isThunk :: ClosureType -> Bool
isConstr Constr = True
isConstr _ = False
@@ -240,7 +232,7 @@ unsafeDeepSeq :: a -> b -> b
unsafeDeepSeq = unsafeDeepSeq1 2
where unsafeDeepSeq1 0 a b = seq a $! b
unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
- | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
+ | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
-- | unsafePerformIO (isFullyEvaluated a) = b
| otherwise = case unsafePerformIO (getClosureData a) of
closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
@@ -315,7 +307,7 @@ mapTermTypeM f = foldTermM TermFoldM {
termTyVars :: Term -> TyVarSet
termTyVars = foldTerm TermFold {
- fTerm = \ty _ _ tt ->
+ fTerm = \ty _ _ tt ->
tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
fSuspension = \_ ty _ _ -> tyVarsOfType ty,
fPrim = \ _ _ -> emptyVarEnv,
@@ -347,21 +339,21 @@ ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
tt_docs <- mapM (y app_prec) tt
return $ cparen (not (null tt) && p >= app_prec)
(text dc_tag <+> pprDeeperList fsep tt_docs)
-
-ppr_termM y p Term{dc=Right dc, subTerms=tt}
+
+ppr_termM y p Term{dc=Right dc, subTerms=tt}
{- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
- = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
- <+> hsep (map (ppr_term1 True) tt)
+ = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
+ <+> hsep (map (ppr_term1 True) tt)
-} -- TODO Printing infix constructors properly
| null sub_terms_to_show
= return (ppr dc)
- | otherwise
+ | otherwise
= do { tt_docs <- mapM (y app_prec) sub_terms_to_show
; return $ cparen (p >= app_prec) $
sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] }
where
- sub_terms_to_show -- Don't show the dictionary arguments to
- -- constructors unless -dppr-debug is on
+ sub_terms_to_show -- Don't show the dictionary arguments to
+ -- constructors unless -dppr-debug is on
| opt_PprStyle_Debug = tt
| otherwise = dropList (dataConTheta dc) tt
@@ -378,9 +370,9 @@ ppr_termM _ _ t = ppr_termM1 t
ppr_termM1 :: Monad m => Term -> m SDoc
-ppr_termM1 Prim{value=words, ty=ty} =
+ppr_termM1 Prim{value=words, ty=ty} =
return $ repPrim (tyConAppTyCon ty) words
-ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
+ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
ppr_termM1 Suspension{ty=ty, bound_to=Just n}
-- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
@@ -392,7 +384,7 @@ ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
| Just (tc,_) <- tcSplitTyConApp_maybe ty
, ASSERT(isNewTyCon tc) True
- , Just new_dc <- tyConSingleDataCon_maybe tc = do
+ , Just new_dc <- tyConSingleDataCon_maybe tc = do
real_term <- y max_prec t
return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
@@ -401,11 +393,11 @@ pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
-- Custom Term Pretty Printers
-------------------------------------------------------
--- We can want to customize the representation of a
--- term depending on its type.
+-- We can want to customize the representation of a
+-- term depending on its type.
-- However, note that custom printers have to work with
-- type representations, instead of directly with types.
--- We cannot use type classes here, unless we employ some
+-- We cannot use type classes here, unless we employ some
-- typerep trickery (e.g. Weirich's RepLib tricks),
-- which I didn't. Therefore, this code replicates a lot
-- of what type classes provide for free.
@@ -413,7 +405,7 @@ pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
type CustomTermPrinter m = TermPrinterM m
-> [Precedence -> Term -> (m (Maybe SDoc))]
--- | Takes a list of custom printers with a explicit recursion knot and a term,
+-- | Takes a list of custom printers with a explicit recursion knot and a term,
-- and returns the output of the first successful printer, or the default printer
cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
cPprTerm printers_ = go 0 where
@@ -430,7 +422,7 @@ cPprTerm printers_ = go 0 where
-- Default set of custom printers. Note that the recursion knot is explicit
cPprTermBase :: forall m. Monad m => CustomTermPrinter m
cPprTermBase y =
- [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
+ [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
. mapM (y (-1))
. subTerms)
, ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
@@ -441,7 +433,7 @@ cPprTermBase y =
, ifTerm (isTyCon doubleTyCon . ty) ppr_double
, ifTerm (isIntegerTy . ty) ppr_integer
]
- where
+ where
ifTerm :: (Term -> Bool)
-> (Precedence -> Term -> m SDoc)
-> Precedence -> Term -> m (Maybe SDoc)
@@ -449,11 +441,11 @@ cPprTermBase y =
| pred t = Just `liftM` f prec t
ifTerm _ _ _ _ = return Nothing
- isTupleTy ty = fromMaybe False $ do
- (tc,_) <- tcSplitTyConApp_maybe ty
+ isTupleTy ty = fromMaybe False $ do
+ (tc,_) <- tcSplitTyConApp_maybe ty
return (isBoxedTupleTyCon tc)
- isTyCon a_tc ty = fromMaybe False $ do
+ isTyCon a_tc ty = fromMaybe False $ do
(tc,_) <- tcSplitTyConApp_maybe ty
return (a_tc == tc)
@@ -461,7 +453,7 @@ cPprTermBase y =
(tc,_) <- tcSplitTyConApp_maybe ty
return (tyConName tc == integerTyConName)
- ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer
+ ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer
:: Precedence -> Term -> m SDoc
ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v)))
ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')
@@ -474,16 +466,16 @@ cPprTermBase y =
ppr_list p (Term{subTerms=[h,t]}) = do
let elems = h : getListTerms t
isConsLast = not(termType(last elems) `eqType` termType h)
- is_string = all (isCharTy . ty) elems
+ is_string = all (isCharTy . ty) elems
print_elems <- mapM (y cons_prec) elems
if is_string
then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))
else if isConsLast
- then return $ cparen (p >= cons_prec)
- $ pprDeeperList fsep
+ then return $ cparen (p >= cons_prec)
+ $ pprDeeperList fsep
$ punctuate (space<>colon) print_elems
- else return $ brackets
+ else return $ brackets
$ pprDeeperList fcat
$ punctuate comma print_elems
@@ -524,9 +516,9 @@ repPrim t = rep where
| t == mVarPrimTyCon = text "<mVar>"
| t == tVarPrimTyCon = text "<tVar>"
| otherwise = char '<' <> ppr t <> char '>'
- where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
--- This ^^^ relies on the representation of Haskell heap values being
--- the same as in a C array.
+ where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
+-- This ^^^ relies on the representation of Haskell heap values being
+-- the same as in a C array.
-----------------------------------
-- Type Reconstruction
@@ -537,14 +529,14 @@ The algorithm walks the heap generating a set of equations, which
are solved with syntactic unification.
A type reconstruction equation looks like:
- <datacon reptype> = <actual heap contents>
+ <datacon reptype> = <actual heap contents>
The full equation set is generated by traversing all the subterms, starting
from a given term.
The only difficult part is that newtypes are only found in the lhs of equations.
-Right hand sides are missing them. We can either (a) drop them from the lhs, or
-(b) reconstruct them in the rhs when possible.
+Right hand sides are missing them. We can either (a) drop them from the lhs, or
+(b) reconstruct them in the rhs when possible.
The function congruenceNewtypes takes a shot at (b)
-}
@@ -574,7 +566,7 @@ runTR hsc_env thing = do
runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
runTR_maybe hsc_env thing_inside
- = do { (_errs, res) <- initTc hsc_env HsSrcFile False
+ = do { (_errs, res) <- initTc hsc_env HsSrcFile False
(icInteractiveModule (hsc_IC hsc_env))
thing_inside
; return res }
@@ -583,17 +575,17 @@ traceTR :: SDoc -> TR ()
traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
--- Semantically different to recoverM in TcRnMonad
+-- Semantically different to recoverM in TcRnMonad
-- recoverM retains the errors in the first action,
-- whereas recoverTc here does not
recoverTR :: TR a -> TR a -> TR a
-recoverTR recover thing = do
+recoverTR recover thing = do
(_,mb_res) <- tryTcErrs thing
- case mb_res of
+ case mb_res of
Nothing -> recover
Just res -> return res
-trIO :: IO a -> TR a
+trIO :: IO a -> TR a
trIO = liftTcM . liftIO
liftTcM :: TcM a -> TR a
@@ -608,17 +600,17 @@ instTyVars :: [TyVar] -> TR ([TcTyVar], [TcType], TvSubst)
instTyVars = liftTcM . tcInstTyVars
type RttiInstantiation = [(TcTyVar, TyVar)]
- -- Associates the typechecker-world meta type variables
- -- (which are mutable and may be refined), to their
+ -- Associates the typechecker-world meta type variables
+ -- (which are mutable and may be refined), to their
-- debugger-world RuntimeUnk counterparts.
-- If the TcTyVar has not been refined by the runtime type
-- elaboration, then we want to turn it back into the
-- original RuntimeUnk
--- | Returns the instantiated type scheme ty', and the
+-- | Returns the instantiated type scheme ty', and the
-- mapping from new (instantiated) -to- old (skolem) type variables
instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
-instScheme (tvs, ty)
+instScheme (tvs, ty)
= liftTcM $ do { (tvs', _, subst) <- tcInstTyVars tvs
; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]
; return (substTy subst ty, rtti_inst) }
@@ -698,7 +690,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
text "Term obtained: " <> ppr term $$
text "Type obtained: " <> ppr (termType term))
return term
- where
+ where
dflags = hsc_dflags hsc_env
go :: Int -> Type -> Type -> HValue -> TcM Term
@@ -715,7 +707,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
clos <- trIO $ getClosureData dflags a
return (Suspension (tipe clos) my_ty a Nothing)
go max_depth my_ty old_ty a = do
- let monomorphic = not(isTyVarTy my_ty)
+ let monomorphic = not(isTyVarTy my_ty)
-- This ^^^ is a convention. The ancestor tests for
-- monomorphism and passes a type instead of a tv
clos <- trIO $ getClosureData dflags a
@@ -735,14 +727,14 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
-> do
-- Deal with the MutVar# primitive
- -- It does not have a constructor at all,
+ -- It does not have a constructor at all,
-- so we simulate the following one
-- MutVar# :: contents_ty -> MutVar# s contents_ty
traceTR (text "Following a MutVar")
contents_tv <- newVar liftedTypeKind
contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
- (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
+ (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
contents_ty (mkTyConApp tycon [world,contents_ty])
addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
x <- go (pred max_depth) contents_tv contents_ty contents
@@ -762,12 +754,12 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
-- In such case, we return a best approximation:
-- ignore the unpointed args, and recover the pointeds
-- This preserves laziness, and should be safe.
- traceTR (text "Not constructor" <+> ppr dcname)
+ traceTR (text "Not constructor" <+> ppr dcname)
let dflags = hsc_dflags hsc_env
tag = showPpr dflags dcname
- vars <- replicateM (length$ elems$ ptrs clos)
+ vars <- replicateM (length$ elems$ ptrs clos)
(newVar liftedTypeKind)
- subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
+ subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
| (i, tv) <- zip [0..] vars]
return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
Just dc -> do
@@ -875,7 +867,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
int max_depth <> text " steps")
search stop expand l d =
- case viewl l of
+ case viewl l of
EmptyL -> return ()
x :< xx -> unlessM stop $ do
new <- expand x
@@ -921,7 +913,7 @@ findPtrTys i ty
| Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
, isUnboxedTupleTyCon tc
= findPtrTyss i elem_tys
-
+
| otherwise
= case repType ty of
UnaryRep rep_ty | typePrimRep rep_ty == PtrRep -> return (i + 1, [(i, ty)])
@@ -954,7 +946,7 @@ getDataConArgTys :: DataCon -> Type -> TR [Type]
-- I believe that con_app_ty should not have any enclosing foralls
getDataConArgTys dc con_app_ty
= do { let UnaryRep rep_con_app_ty = repType con_app_ty
- ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty
+ ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty
$$ ppr (tcSplitTyConApp_maybe rep_con_app_ty)))
; (_, _, subst) <- instTyVars (univ_tvs ++ ex_tvs)
; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc))
@@ -975,7 +967,7 @@ Consider a GADT (cf Trac #7386)
...
In getDataConArgTys
-* con_app_ty is the known type (from outside) of the constructor application,
+* con_app_ty is the known type (from outside) of the constructor application,
say D [Int] Int
* The data constructor MkT has a (representation) dataConTyCon = DList,
@@ -984,7 +976,7 @@ In getDataConArgTys
MkT :: a -> DList a (Maybe a)
...
-So the dataConTyCon of the data constructor, DList, differs from
+So the dataConTyCon of the data constructor, DList, differs from
the "outside" type, D. So we can't straightforwardly decompose the
"outside" type, and we end up in the "_" branch of the case.
@@ -1126,9 +1118,9 @@ check2 (_, rtti_ty) (_, old_ty)
-- Dealing with newtypes
--------------------------
{-
- congruenceNewtypes does a parallel fold over two Type values,
- compensating for missing newtypes on both sides.
- This is necessary because newtypes are not present
+ congruenceNewtypes does a parallel fold over two Type values,
+ compensating for missing newtypes on both sides.
+ This is necessary because newtypes are not present
in runtime, but sometimes there is evidence available.
Evidence can come from DataCon signatures or
from compile-time type inference.
@@ -1174,8 +1166,8 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
return (mkFunTy r1' r2')
-- TyconApp Inductive case; this is the interesting bit.
| Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
- , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
- , tycon_l /= tycon_r
+ , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
+ , tycon_l /= tycon_r
= upgrade tycon_l r
| otherwise = return r
@@ -1185,7 +1177,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
| not (isNewTyCon new_tycon) = do
traceTR (text "(Upgrade) Not matching newtype evidence: " <>
ppr new_tycon <> text " for " <> ppr ty)
- return ty
+ return ty
| otherwise = do
traceTR (text "(Upgrade) upgraded " <> ppr ty <>
text " in presence of newtype evidence " <> ppr new_tycon)
@@ -1193,7 +1185,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
let ty' = mkTyConApp new_tycon vars
UnaryRep rep_ty = repType ty'
_ <- liftTcM (unifyType ty rep_ty)
- -- assumes that reptype doesn't ^^^^ touch tyconApp args
+ -- assumes that reptype doesn't ^^^^ touch tyconApp args
return ty'
@@ -1205,7 +1197,7 @@ zonkTerm = foldTermM (TermFoldM
return (Suspension ct ty v b)
, fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' ->
return$ NewtypeWrap ty' dc t
- , fRefWrapM = \ty t -> return RefWrap `ap`
+ , fRefWrapM = \ty t -> return RefWrap `ap`
zonkRttiType ty `ap` return t
, fPrimM = (return.) . Prim })
@@ -1214,13 +1206,13 @@ zonkRttiType :: TcType -> TcM Type
-- by skolems, safely out of Meta-tyvar-land
zonkRttiType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_meta)
where
- zonk_unbound_meta tv
+ zonk_unbound_meta tv
= ASSERT( isTcTyVar tv )
do { tv' <- skolemiseUnboundMetaTyVar tv RuntimeUnk
- -- This is where RuntimeUnks are born:
- -- otherwise-unconstrained unification variables are
- -- turned into RuntimeUnks as they leave the
- -- typechecker's monad
+ -- This is where RuntimeUnks are born:
+ -- otherwise-unconstrained unification variables are
+ -- turned into RuntimeUnks as they leave the
+ -- typechecker's monad
; return (mkTyVarTy tv') }
--------------------------------------------------------------------------------
View Lorry Controller Status