Commit 72e46baf authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of http://darcs.haskell.org/ghc

parents 1bbdbe55 41448969
This diff is collapsed.
module CodeGen.Platform (callerSaves, activeStgRegs, haveRegBase) where
module CodeGen.Platform
(callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg)
where
import CmmExpr
import FastBool
import Platform
import Reg
import qualified CodeGen.Platform.ARM as ARM
import qualified CodeGen.Platform.PPC as PPC
......@@ -71,3 +75,37 @@ haveRegBase platform
| otherwise -> NoRegs.haveRegBase
globalRegMaybe :: Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe platform
| platformUnregisterised platform = NoRegs.globalRegMaybe
| otherwise
= case platformArch platform of
ArchX86 -> X86.globalRegMaybe
ArchX86_64 -> X86_64.globalRegMaybe
ArchSPARC -> SPARC.globalRegMaybe
ArchARM {} -> ARM.globalRegMaybe
arch
| arch `elem` [ArchPPC, ArchPPC_64] ->
case platformOS platform of
OSDarwin -> PPC_Darwin.globalRegMaybe
_ -> PPC.globalRegMaybe
| otherwise -> NoRegs.globalRegMaybe
freeReg :: Platform -> RegNo -> FastBool
freeReg platform
| platformUnregisterised platform = NoRegs.freeReg
| otherwise
= case platformArch platform of
ArchX86 -> X86.freeReg
ArchX86_64 -> X86_64.freeReg
ArchSPARC -> SPARC.freeReg
ArchARM {} -> ARM.freeReg
arch
| arch `elem` [ArchPPC, ArchPPC_64] ->
case platformOS platform of
OSDarwin -> PPC_Darwin.freeReg
_ -> PPC.freeReg
| otherwise -> NoRegs.freeReg
module CodeGen.Platform.ARM where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_arm 1
#include "../../../../includes/CodeGen.Platform.hs"
......
module CodeGen.Platform.NoRegs where
import CmmExpr
#define MACHREGS_NO_REGS 1
#include "../../../../includes/CodeGen.Platform.hs"
module CodeGen.Platform.PPC where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_powerpc 1
#include "../../../../includes/CodeGen.Platform.hs"
......
module CodeGen.Platform.PPC_Darwin where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_powerpc 1
#define MACHREGS_darwin 1
......
module CodeGen.Platform.SPARC where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_sparc 1
#include "../../../../includes/CodeGen.Platform.hs"
......
module CodeGen.Platform.X86 where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_i386 1
#include "../../../../includes/CodeGen.Platform.hs"
......
module CodeGen.Platform.X86_64 where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_x86_64 1
#include "../../../../includes/CodeGen.Platform.hs"
......
......@@ -46,6 +46,7 @@ import DynFlags
import Util
import Pair
import Outputable
import Platform
import FastString
import Config
import Data.Bits
......@@ -156,7 +157,7 @@ corePrepPgm :: DynFlags -> HscEnv -> CoreProgram -> [TyCon] -> IO CoreProgram
corePrepPgm dflags hsc_env binds data_tycons = do
showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env
initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
let implicit_binds = mkDataConWorkers data_tycons
-- NB: we must feed mkImplicitBinds through corePrep too
......@@ -174,7 +175,7 @@ corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr dflags hsc_env expr = do
showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env
initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)
dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
return new_expr
......@@ -401,6 +402,8 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
; return (floats3, bndr', rhs') }
where
platform = targetPlatform (cpe_dynFlags env)
arity = idArity bndr -- We must match this arity
---------------------
......@@ -422,7 +425,7 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
= return (floats, rhs)
-- So the top-level binding is marked NoCafRefs
| Just (floats', rhs') <- canFloatFromNoCaf floats rhs
| Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs
= return (floats', rhs')
| otherwise
......@@ -1069,9 +1072,9 @@ dropDeadCodeAlts alts = (alts', unionVarSets fvss)
where !(e', fvs) = dropDeadCode e
-------------------------------------------
canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
-- Note [CafInfo and floating]
canFloatFromNoCaf (Floats ok_to_spec fs) rhs
canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
| OkToSpec <- ok_to_spec -- Worth trying
, Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
= Just (Floats OkToSpec fs', subst_expr subst rhs)
......@@ -1114,7 +1117,7 @@ canFloatFromNoCaf (Floats ok_to_spec fs) rhs
-- We can only float to top level from a NoCaf thing if
-- the new binding is static. However it can't mention
-- any non-static things or it would *already* be Caffy
rhs_ok = rhsIsStatic (\_ -> False)
rhs_ok = rhsIsStatic platform (\_ -> False)
wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
wantFloatNested is_rec strict_or_unlifted floats rhs
......@@ -1148,31 +1151,38 @@ allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
-- The environment
-- ---------------------------------------------------------------------------
data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
Id -- mkIntegerId
data CorePrepEnv = CPE {
cpe_dynFlags :: DynFlags,
cpe_env :: (IdEnv Id), -- Clone local Ids
cpe_mkIntegerId :: Id
}
mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv hsc_env
mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv dflags hsc_env
= do mkIntegerId <- liftM tyThingId
$ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName)
return $ CPE emptyVarEnv mkIntegerId
return $ CPE {
cpe_dynFlags = dflags,
cpe_env = emptyVarEnv,
cpe_mkIntegerId = mkIntegerId
}
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv (CPE env mkIntegerId) id id'
= CPE (extendVarEnv env id id') mkIntegerId
extendCorePrepEnv cpe id id'
= cpe { cpe_env = extendVarEnv (cpe_env cpe) id id' }
extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
extendCorePrepEnvList (CPE env mkIntegerId) prs
= CPE (extendVarEnvList env prs) mkIntegerId
extendCorePrepEnvList cpe prs
= cpe { cpe_env = extendVarEnvList (cpe_env cpe) prs }
lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
lookupCorePrepEnv (CPE env _) id
= case lookupVarEnv env id of
lookupCorePrepEnv cpe id
= case lookupVarEnv (cpe_env cpe) id of
Nothing -> id
Just id' -> id'
getMkIntegerId :: CorePrepEnv -> Id
getMkIntegerId (CPE _ mkIntegerId) = mkIntegerId
getMkIntegerId = cpe_mkIntegerId
------------------------------------------------------------------------------
-- Cloning binders
......
......@@ -66,6 +66,7 @@ import Outputable
import TysPrim
import FastString
import Maybes
import Platform
import Util
import Pair
import Data.Word
......@@ -1733,7 +1734,7 @@ and 'execute' it rather than allocating it statically.
-- | This function is called only on *top-level* right-hand sides.
-- Returns @True@ if the RHS can be allocated statically in the output,
-- with no thunks involved at all.
rhsIsStatic :: (Name -> Bool) -> CoreExpr -> Bool
rhsIsStatic :: Platform -> (Name -> Bool) -> CoreExpr -> Bool
-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
-- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
-- update flag on it and (iii) in DsExpr to decide how to expand
......@@ -1788,7 +1789,7 @@ rhsIsStatic :: (Name -> Bool) -> CoreExpr -> Bool
--
-- c) don't look through unfolding of f in (f x).
rhsIsStatic _is_dynamic_name rhs = is_static False rhs
rhsIsStatic platform is_dynamic_name rhs = is_static False rhs
where
is_static :: Bool -- True <=> in a constructor argument; must be atomic
-> CoreExpr -> Bool
......@@ -1813,9 +1814,8 @@ rhsIsStatic _is_dynamic_name rhs = is_static False rhs
is_static in_arg other_expr = go other_expr 0
where
go (Var f) n_val_args
#if mingw32_TARGET_OS
| not (_is_dynamic_name (idName f))
#endif
| (platformOS platform /= OSMinGW32) ||
not (is_dynamic_name (idName f))
= saturated_data_con f n_val_args
|| (in_arg && n_val_args == 0)
-- A naked un-applied variable is *not* deemed a static RHS
......
......@@ -509,7 +509,6 @@ Library
PPC.CodeGen
SPARC.Base
SPARC.Regs
SPARC.RegPlate
SPARC.Imm
SPARC.AddrMode
SPARC.Cond
......
......@@ -51,6 +51,7 @@ import qualified Maybes
import UniqSet
import FastString
import Config
import Platform
import SysTools
import PrelNames
......@@ -302,12 +303,13 @@ reallyInitDynLinker dflags =
; classified_ld_inputs <- mapM (classifyLdInput dflags) cmdline_ld_inputs
-- (e) Link any MacOS frameworks
; let framework_paths
| isDarwinTarget = frameworkPaths dflags
| otherwise = []
; let frameworks
| isDarwinTarget = cmdlineFrameworks dflags
| otherwise = []
; let platform = targetPlatform dflags
; let framework_paths = case platformOS platform of
OSDarwin -> frameworkPaths dflags
_ -> []
; let frameworks = case platformOS platform of
OSDarwin -> cmdlineFrameworks dflags
_ -> []
-- Finally do (c),(d),(e)
; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
++ libspecs
......@@ -353,12 +355,13 @@ users?
classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec)
classifyLdInput dflags f
| isObjectFilename f = return (Just (Object f))
| isDynLibFilename f = return (Just (DLLPath f))
| isObjectFilename platform f = return (Just (Object f))
| isDynLibFilename platform f = return (Just (DLLPath f))
| otherwise = do
log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
(text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
return Nothing
where platform = targetPlatform dflags
preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
preloadLib dflags lib_paths framework_paths lib_spec
......@@ -375,7 +378,7 @@ preloadLib dflags lib_paths framework_paths lib_spec
else "not found")
DLL dll_unadorned
-> do maybe_errstr <- loadDLL (mkSOName dll_unadorned)
-> do maybe_errstr <- loadDLL (mkSOName platform dll_unadorned)
case maybe_errstr of
Nothing -> maybePutStrLn dflags "done"
Just mm -> preloadFailed mm lib_paths lib_spec
......@@ -386,15 +389,18 @@ preloadLib dflags lib_paths framework_paths lib_spec
Nothing -> maybePutStrLn dflags "done"
Just mm -> preloadFailed mm lib_paths lib_spec
Framework framework
| isDarwinTarget
-> do maybe_errstr <- loadFramework framework_paths framework
Framework framework ->
case platformOS (targetPlatform dflags) of
OSDarwin ->
do maybe_errstr <- loadFramework framework_paths framework
case maybe_errstr of
Nothing -> maybePutStrLn dflags "done"
Just mm -> preloadFailed mm framework_paths lib_spec
| otherwise -> panic "preloadLib Framework"
_ -> panic "preloadLib Framework"
where
platform = targetPlatform dflags
preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
preloadFailed sys_errmsg paths spec
= do maybePutStr dflags "failed.\n"
......@@ -968,7 +974,7 @@ data LibrarySpec
-- just to get the DLL handle into the list.
partOfGHCi :: [PackageName]
partOfGHCi
| isWindowsTarget || isDarwinTarget = []
| isWindowsHost || isDarwinHost = []
| otherwise = map PackageName
["base", "template-haskell", "editline"]
......@@ -1033,7 +1039,8 @@ linkPackages' dflags new_pks pls = do
linkPackage :: DynFlags -> PackageConfig -> IO ()
linkPackage dflags pkg
= do
let dirs = Packages.libraryDirs pkg
let platform = targetPlatform dflags
dirs = Packages.libraryDirs pkg
let hs_libs = Packages.hsLibraries pkg
-- The FFI GHCi import lib isn't needed as
......@@ -1070,8 +1077,8 @@ linkPackage dflags pkg
-- See comments with partOfGHCi
when (packageName pkg `notElem` partOfGHCi) $ do
loadFrameworks pkg
mapM_ load_dyn (known_dlls ++ map mkSOName dlls)
loadFrameworks platform pkg
mapM_ load_dyn (known_dlls ++ map (mkSOName platform) dlls)
-- After loading all the DLLs, we can load the static objects.
-- Ordering isn't important here, because we do one final link
......@@ -1096,10 +1103,11 @@ load_dyn dll = do r <- loadDLL dll
Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: "
++ dll ++ " (" ++ err ++ ")" ))
loadFrameworks :: InstalledPackageInfo_ ModuleName -> IO ()
loadFrameworks pkg
| isDarwinTarget = mapM_ load frameworks
| otherwise = return ()
loadFrameworks :: Platform -> InstalledPackageInfo_ ModuleName -> IO ()
loadFrameworks platform pkg
= case platformOS platform of
OSDarwin -> mapM_ load frameworks
_ -> return ()
where
fw_dirs = Packages.frameworkDirs pkg
frameworks = Packages.frameworks pkg
......@@ -1142,9 +1150,9 @@ 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 hs_dyn_lib_name
mk_hs_dyn_lib_path dir = dir </> mkSOName platform hs_dyn_lib_name
so_name = mkSOName lib
so_name = mkSOName platform lib
mk_dyn_lib_path dir = dir </> so_name
findObject = liftM (fmap Object) $ findFile mk_obj_path dirs
......@@ -1160,6 +1168,8 @@ locateLib dflags is_hs dirs lib
Just x -> return x
Nothing -> g
platform = targetPlatform dflags
searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)
searchForLibUsingGcc dflags so dirs = do
str <- askCc dflags (map (FileOption "-L") dirs
......@@ -1174,11 +1184,12 @@ searchForLibUsingGcc dflags so dirs = do
-- ----------------------------------------------------------------------------
-- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
mkSOName :: FilePath -> FilePath
mkSOName root
| isDarwinTarget = ("lib" ++ root) <.> "dylib"
| isWindowsTarget = root <.> "dll"
| otherwise = ("lib" ++ root) <.> "so"
mkSOName :: Platform -> FilePath -> FilePath
mkSOName platform root
= case platformOS platform of
OSDarwin -> ("lib" ++ root) <.> "dylib"
OSMinGW32 -> root <.> "dll"
_ -> ("lib" ++ root) <.> "so"
-- Darwin / MacOS X only: load a framework
-- a framework is a dynamic library packaged inside a directory of the same
......
......@@ -15,6 +15,7 @@ import LlvmCodeGen.Regs
import CLabel
import OldCmm
import Platform
import FastString
import Outputable
......@@ -37,41 +38,29 @@ pprLlvmHeader =
-- | LLVM module layout description for the host target
moduleLayout :: SDoc
moduleLayout =
#if i386_TARGET_ARCH
#if darwin_TARGET_OS
text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:128:128-n8:16:32\""
$+$ text "target triple = \"i386-apple-darwin9.8\""
#elif mingw32_TARGET_OS
text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-f80:128:128-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\""
$+$ text "target triple = \"i686-pc-win32\""
#else /* Linux */
text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\""
$+$ text "target triple = \"i386-pc-linux-gnu\""
#endif
#elif x86_64_TARGET_ARCH
#if darwin_TARGET_OS
text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\""
$+$ text "target triple = \"x86_64-apple-darwin10.0.0\""
#else /* Linux */
text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\""
$+$ text "target triple = \"x86_64-linux-gnu\""
#endif
#elif defined (arm_TARGET_ARCH)
#if linux_TARGET_OS
text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
$+$ text "target triple = \"arm-unknown-linux-gnueabi\""
#endif
#else
-- FIX: Other targets
empty
#endif
moduleLayout = sdocWithPlatform $ \platform ->
case platform of
Platform { platformArch = ArchX86, platformOS = OSDarwin } ->
text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:128:128-n8:16:32\""
$+$ text "target triple = \"i386-apple-darwin9.8\""
Platform { platformArch = ArchX86, platformOS = OSMinGW32 } ->
text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-f80:128:128-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\""
$+$ text "target triple = \"i686-pc-win32\""
Platform { platformArch = ArchX86, platformOS = OSLinux } ->
text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\""
$+$ text "target triple = \"i386-pc-linux-gnu\""
Platform { platformArch = ArchX86_64, platformOS = OSDarwin } ->
text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\""
$+$ text "target triple = \"x86_64-apple-darwin10.0.0\""
Platform { platformArch = ArchX86_64, platformOS = OSLinux } ->
text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\""
$+$ text "target triple = \"x86_64-linux-gnu\""
Platform { platformArch = ArchARM {}, platformOS = OSLinux } ->
text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
$+$ text "target triple = \"arm-unknown-linux-gnueabi\""
_ ->
-- FIX: Other targets
empty
-- | Pretty print LLVM data code
......
......@@ -36,6 +36,7 @@ module DriverPhases (
#include "HsVersions.h"
import Outputable
import Platform
import System.FilePath
-----------------------------------------------------------------------------
......@@ -228,49 +229,47 @@ extcoreish_suffixes = [ "hcr" ]
-- Will not be deleted as temp files:
haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ]
objish_suffixes :: [String]
objish_suffixes :: Platform -> [String]
-- Use the appropriate suffix for the system on which
-- the GHC-compiled code will run
#if mingw32_TARGET_OS || cygwin32_TARGET_OS
objish_suffixes = [ "o", "O", "obj", "OBJ" ]
#else
objish_suffixes = [ "o" ]
#endif
objish_suffixes platform = case platformOS platform of
OSMinGW32 -> [ "o", "O", "obj", "OBJ" ]
_ -> [ "o" ]
dynlib_suffixes :: [String]
#ifdef mingw32_TARGET_OS
dynlib_suffixes = ["dll", "DLL"]
#elif defined(darwin_TARGET_OS)
dynlib_suffixes = ["dylib"]
#else
dynlib_suffixes = ["so"]
#endif
dynlib_suffixes :: Platform -> [String]
dynlib_suffixes platform = case platformOS platform of
OSMinGW32 -> ["dll", "DLL"]
OSDarwin -> ["dylib"]
_ -> ["so"]
isHaskellishSuffix, isHaskellSrcSuffix, isCishSuffix, isExtCoreSuffix,
isObjectSuffix, isHaskellUserSrcSuffix, isDynLibSuffix
isHaskellUserSrcSuffix
:: String -> Bool
isHaskellishSuffix s = s `elem` haskellish_suffixes
isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes
isCishSuffix s = s `elem` cish_suffixes
isExtCoreSuffix s = s `elem` extcoreish_suffixes
isObjectSuffix s = s `elem` objish_suffixes
isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes
isDynLibSuffix s = s `elem` dynlib_suffixes
isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool
isObjectSuffix platform s = s `elem` objish_suffixes platform
isDynLibSuffix platform s = s `elem` dynlib_suffixes platform
isSourceSuffix :: String -> Bool
isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff
isHaskellishFilename, isHaskellSrcFilename, isCishFilename,
isExtCoreFilename, isObjectFilename, isHaskellUserSrcFilename,
isDynLibFilename, isSourceFilename
isExtCoreFilename, isHaskellUserSrcFilename, isSourceFilename
:: FilePath -> Bool
-- takeExtension return .foo, so we drop 1 to get rid of the .
isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f)
isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f)
isCishFilename f = isCishSuffix (drop 1 $ takeExtension f)
isExtCoreFilename f = isExtCoreSuffix (drop 1 $ takeExtension f)
isObjectFilename f = isObjectSuffix (drop 1 $ takeExtension f)
isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f)
isDynLibFilename f = isDynLibSuffix (drop 1 $ takeExtension f)
isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f)
isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool
isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f)
isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f)
......@@ -47,6 +47,7 @@ import Module
import Packages( isDllName )
import HscTypes
import Maybes
import Platform
import UniqSupply
import ErrUtils (Severity(..))
import Outputable
......@@ -1048,34 +1049,37 @@ tidyTopBinds hsc_env unfold_env init_occ_env binds
$ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName)
return $ tidy mkIntegerId init_env binds
where
platform = targetPlatform (hsc_dflags hsc_env)
init_env = (init_occ_env, emptyVarEnv)
this_pkg = thisPackage (hsc_dflags hsc_env)
tidy _ env [] = (env, [])
tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind this_pkg mkIntegerId unfold_env env b
tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind platform this_pkg mkIntegerId unfold_env env b
(env2, bs') = tidy mkIntegerId env1 bs
in
(env2, b':bs')
------------------------
tidyTopBind :: PackageId
tidyTopBind :: Platform
-> PackageId
-> Id
-> UnfoldEnv
-> TidyEnv
-> CoreBind
-> (TidyEnv, CoreBind)
tidyTopBind this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs)
tidyTopBind platform this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs)
= (tidy_env2, NonRec bndr' rhs')
where
Just (name',show_unfold) = lookupVarEnv unfold_env bndr
caf_info = hasCafRefs this_pkg (mkIntegerId, subst1) (idArity bndr) rhs
caf_info = hasCafRefs platform this_pkg (mkIntegerId, subst1) (idArity bndr) rhs
(bndr', rhs') = tidyTopPair show_unfold tidy_env2 caf_info name' (bndr, rhs)
subst2 = extendVarEnv subst1 bndr bndr'