Commit 5427df8f authored by tibbe's avatar tibbe
Browse files

Merge branch 'master' of https://github.com/ghc/ghc

parents bab8dc79 acb0cd94
...@@ -35,6 +35,7 @@ module DriverPhases ( ...@@ -35,6 +35,7 @@ module DriverPhases (
#include "HsVersions.h" #include "HsVersions.h"
import {-# SOURCE #-} DynFlags
import Outputable import Outputable
import Platform import Platform
import System.FilePath import System.FilePath
...@@ -131,33 +132,39 @@ eqPhase _ _ = False ...@@ -131,33 +132,39 @@ eqPhase _ _ = False
-- Partial ordering on phases: we want to know which phases will occur before -- Partial ordering on phases: we want to know which phases will occur before
-- which others. This is used for sanity checking, to ensure that the -- which others. This is used for sanity checking, to ensure that the
-- pipeline will stop at some point (see DriverPipeline.runPipeline). -- pipeline will stop at some point (see DriverPipeline.runPipeline).
happensBefore :: Phase -> Phase -> Bool happensBefore :: DynFlags -> Phase -> Phase -> Bool
StopLn `happensBefore` _ = False happensBefore dflags p1 p2 = p1 `happensBefore'` p2
x `happensBefore` y = after_x `eqPhase` y || after_x `happensBefore` y where StopLn `happensBefore'` _ = False
where x `happensBefore'` y = after_x `eqPhase` y
after_x = nextPhase x || after_x `happensBefore'` y
where after_x = nextPhase dflags x
nextPhase :: Phase -> Phase nextPhase :: DynFlags -> Phase -> Phase
-- A conservative approximation to the next phase, used in happensBefore nextPhase dflags p
nextPhase (Unlit sf) = Cpp sf -- A conservative approximation to the next phase, used in happensBefore
nextPhase (Cpp sf) = HsPp sf = case p of
nextPhase (HsPp sf) = Hsc sf Unlit sf -> Cpp sf
nextPhase (Hsc _) = HCc Cpp sf -> HsPp sf
nextPhase Splitter = SplitAs HsPp sf -> Hsc sf
nextPhase LlvmOpt = LlvmLlc Hsc _ -> maybeHCc
nextPhase LlvmLlc = LlvmMangle Splitter -> SplitAs
nextPhase LlvmMangle = As LlvmOpt -> LlvmLlc
nextPhase SplitAs = MergeStub LlvmLlc -> LlvmMangle
nextPhase As = MergeStub LlvmMangle -> As
nextPhase Ccpp = As SplitAs -> MergeStub
nextPhase Cc = As As -> MergeStub
nextPhase Cobjc = As Ccpp -> As
nextPhase Cobjcpp = As Cc -> As
nextPhase CmmCpp = Cmm Cobjc -> As
nextPhase Cmm = HCc Cobjcpp -> As
nextPhase HCc = As CmmCpp -> Cmm
nextPhase MergeStub = StopLn Cmm -> maybeHCc
nextPhase StopLn = panic "nextPhase: nothing after StopLn" HCc -> As
MergeStub -> StopLn
StopLn -> panic "nextPhase: nothing after StopLn"
where maybeHCc = if platformUnregisterised (targetPlatform dflags)
then HCc
else As
-- the first compilation phase for a given file is determined -- the first compilation phase for a given file is determined
-- by its suffix. -- by its suffix.
......
...@@ -503,70 +503,96 @@ runPipeline ...@@ -503,70 +503,96 @@ runPipeline
-> IO (DynFlags, FilePath) -- ^ (final flags, output filename) -> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
runPipeline stop_phase hsc_env0 (input_fn, mb_phase) runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
mb_basename output maybe_loc maybe_stub_o mb_basename output maybe_loc maybe_stub_o
= do r <- runPipeline' stop_phase hsc_env0 (input_fn, mb_phase)
mb_basename output maybe_loc maybe_stub_o = do let
let dflags = extractDynFlags hsc_env0 dflags0 = hsc_dflags hsc_env0
whenCannotGenerateDynamicToo dflags $ do
-- Decide where dump files should go based on the pipeline output
dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
hsc_env = hsc_env0 {hsc_dflags = dflags}
(input_basename, suffix) = splitExtension input_fn
suffix' = drop 1 suffix -- strip off the .
basename | Just b <- mb_basename = b
| otherwise = input_basename
-- If we were given a -x flag, then use that phase to start from
start_phase = fromMaybe (startPhase suffix') mb_phase
isHaskell (Unlit _) = True
isHaskell (Cpp _) = True
isHaskell (HsPp _) = True
isHaskell (Hsc _) = True
isHaskell _ = False
isHaskellishFile = isHaskell start_phase
env = PipeEnv{ pe_isHaskellishFile = isHaskellishFile,
stop_phase,
src_basename = basename,
src_suffix = suffix',
output_spec = output }
-- We want to catch cases of "you can't get there from here" before
-- we start the pipeline, because otherwise it will just run off the
-- end.
--
-- There is a partial ordering on phases, where A < B iff A occurs
-- before B in a normal compilation pipeline.
let happensBefore' = happensBefore dflags
when (not (start_phase `happensBefore'` stop_phase)) $
throwGhcException (UsageError
("cannot compile this file to desired target: "
++ input_fn))
debugTraceMsg dflags 4 (text "Running the pipeline")
r <- runPipeline' start_phase stop_phase hsc_env env input_fn
output maybe_loc maybe_stub_o
-- If we are compiling a Haskell module, and doing
-- -dynamic-too, but couldn't do the -dynamic-too fast
-- path, then rerun the pipeline for the dyn way
let dflags = extractDynFlags hsc_env
when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do
debugTraceMsg dflags 4
(text "Running the pipeline again for -dynamic-too")
let dflags' = doDynamicToo dflags let dflags' = doDynamicToo dflags
hsc_env1 <- newHscEnv dflags' -- TODO: This should use -dyno
_ <- runPipeline' stop_phase hsc_env1 (input_fn, mb_phase) output' = case output of
mb_basename output maybe_loc maybe_stub_o SpecificFile fn -> SpecificFile (replaceExtension fn (objectSuf dflags'))
Persistent -> Persistent
Temporary -> Temporary
hsc_env' <- newHscEnv dflags'
_ <- runPipeline' start_phase stop_phase hsc_env' env input_fn
output' maybe_loc maybe_stub_o
return () return ()
return r return r
runPipeline' runPipeline'
:: Phase -- ^ When to stop :: Phase -- ^ When to start
-> Phase -- ^ When to stop
-> HscEnv -- ^ Compilation environment -> HscEnv -- ^ Compilation environment
-> (FilePath,Maybe Phase) -- ^ Input filename (and maybe -x suffix) -> PipeEnv
-> Maybe FilePath -- ^ original basename (if different from ^^^) -> FilePath -- ^ Input filename
-> PipelineOutput -- ^ Output filename -> PipelineOutput -- ^ Output filename
-> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
-> Maybe FilePath -- ^ stub object, if we have one -> Maybe FilePath -- ^ stub object, if we have one
-> IO (DynFlags, FilePath) -- ^ (final flags, output filename) -> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
runPipeline' stop_phase hsc_env0 (input_fn, mb_phase) runPipeline' start_phase stop_phase hsc_env env input_fn
mb_basename output maybe_loc maybe_stub_o output maybe_loc maybe_stub_o
= do = do
let dflags0 = hsc_dflags hsc_env0
(input_basename, suffix) = splitExtension input_fn
suffix' = drop 1 suffix -- strip off the .
basename | Just b <- mb_basename = b
| otherwise = input_basename
-- Decide where dump files should go based on the pipeline output
dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
hsc_env = hsc_env0 {hsc_dflags = dflags}
-- If we were given a -x flag, then use that phase to start from
start_phase = fromMaybe (startPhase suffix') mb_phase
-- We want to catch cases of "you can't get there from here" before
-- we start the pipeline, because otherwise it will just run off the
-- end.
--
-- There is a partial ordering on phases, where A < B iff A occurs
-- before B in a normal compilation pipeline.
when (not (start_phase `happensBefore` stop_phase)) $
throwGhcException (UsageError
("cannot compile this file to desired target: "
++ input_fn))
-- this is a function which will be used to calculate output file names -- this is a function which will be used to calculate output file names
-- as we go along (we partially apply it to some of its inputs here) -- as we go along (we partially apply it to some of its inputs here)
let get_output_fn = getOutputFilename stop_phase output basename let get_output_fn = getOutputFilename stop_phase output (src_basename env)
-- Execute the pipeline... -- Execute the pipeline...
let env = PipeEnv{ stop_phase, let state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o }
src_basename = basename,
src_suffix = suffix',
output_spec = output }
state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o }
(state', output_fn) <- unP (pipeLoop start_phase input_fn) env state (state', output_fn) <- unP (pipeLoop start_phase input_fn) env state
let PipeState{ hsc_env=hsc_env', maybe_loc } = state' let PipeState{ hsc_env=hsc_env', maybe_loc } = state'
dflags' = hsc_dflags hsc_env' dflags = hsc_dflags hsc_env'
-- Sometimes, a compilation phase doesn't actually generate any output -- Sometimes, a compilation phase doesn't actually generate any output
-- (eg. the CPP phase when -fcpp is not turned on). If we end on this -- (eg. the CPP phase when -fcpp is not turned on). If we end on this
...@@ -575,20 +601,21 @@ runPipeline' stop_phase hsc_env0 (input_fn, mb_phase) ...@@ -575,20 +601,21 @@ runPipeline' stop_phase hsc_env0 (input_fn, mb_phase)
-- further compilation stages can tell what the original filename was. -- further compilation stages can tell what the original filename was.
case output of case output of
Temporary -> Temporary ->
return (dflags', output_fn) return (dflags, output_fn)
_other -> _ ->
do final_fn <- get_output_fn dflags' stop_phase maybe_loc do final_fn <- get_output_fn dflags stop_phase maybe_loc
when (final_fn /= output_fn) $ do when (final_fn /= output_fn) $ do
let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'") let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'")
line_prag = Just ("{-# LINE 1 \"" ++ input_fn ++ "\" #-}\n") line_prag = Just ("{-# LINE 1 \"" ++ input_fn ++ "\" #-}\n")
copyWithHeader dflags msg line_prag output_fn final_fn copyWithHeader dflags msg line_prag output_fn final_fn
return (dflags', final_fn) return (dflags, final_fn)
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- The pipeline uses a monad to carry around various bits of information -- The pipeline uses a monad to carry around various bits of information
-- PipeEnv: invariant information passed down -- PipeEnv: invariant information passed down
data PipeEnv = PipeEnv { data PipeEnv = PipeEnv {
pe_isHaskellishFile :: Bool,
stop_phase :: Phase, -- ^ Stop just before this phase stop_phase :: Phase, -- ^ Stop just before this phase
src_basename :: String, -- ^ basename of original input source src_basename :: String, -- ^ basename of original input source
src_suffix :: String, -- ^ its extension src_suffix :: String, -- ^ its extension
...@@ -656,12 +683,13 @@ phaseOutputFilename next_phase = do ...@@ -656,12 +683,13 @@ phaseOutputFilename next_phase = do
pipeLoop :: Phase -> FilePath -> CompPipeline FilePath pipeLoop :: Phase -> FilePath -> CompPipeline FilePath
pipeLoop phase input_fn = do pipeLoop phase input_fn = do
PipeEnv{stop_phase} <- getPipeEnv PipeEnv{stop_phase} <- getPipeEnv
PipeState{hsc_env} <- getPipeState dflags <- getDynFlags
let happensBefore' = happensBefore dflags
case () of case () of
_ | phase `eqPhase` stop_phase -- All done _ | phase `eqPhase` stop_phase -- All done
-> return input_fn -> return input_fn
| not (phase `happensBefore` stop_phase) | not (phase `happensBefore'` stop_phase)
-- Something has gone wrong. We'll try to cover all the cases when -- Something has gone wrong. We'll try to cover all the cases when
-- this could happen, so if we reach here it is a panic. -- this could happen, so if we reach here it is a panic.
-- eg. it might happen if the -C flag is used on a source file that -- eg. it might happen if the -C flag is used on a source file that
...@@ -670,9 +698,8 @@ pipeLoop phase input_fn = do ...@@ -670,9 +698,8 @@ pipeLoop phase input_fn = do
" but I wanted to stop at phase " ++ show stop_phase) " but I wanted to stop at phase " ++ show stop_phase)
| otherwise | otherwise
-> do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 4 -> do liftIO $ debugTraceMsg dflags 4
(ptext (sLit "Running phase") <+> ppr phase) (ptext (sLit "Running phase") <+> ppr phase)
dflags <- getDynFlags
(next_phase, output_fn) <- runPhase phase input_fn dflags (next_phase, output_fn) <- runPhase phase input_fn dflags
pipeLoop next_phase output_fn pipeLoop next_phase output_fn
......
...@@ -594,6 +594,7 @@ data DynFlags = DynFlags { ...@@ -594,6 +594,7 @@ data DynFlags = DynFlags {
dynHiSuf :: String, dynHiSuf :: String,
outputFile :: Maybe String, outputFile :: Maybe String,
dynOutputFile :: Maybe String,
outputHi :: Maybe String, outputHi :: Maybe String,
dynLibLoader :: DynLibLoader, dynLibLoader :: DynLibLoader,
...@@ -1148,6 +1149,7 @@ doDynamicToo :: DynFlags -> DynFlags ...@@ -1148,6 +1149,7 @@ doDynamicToo :: DynFlags -> DynFlags
doDynamicToo dflags0 = let dflags1 = unSetGeneralFlag' Opt_Static dflags0 doDynamicToo dflags0 = let dflags1 = unSetGeneralFlag' Opt_Static dflags0
dflags2 = addWay' WayDyn dflags1 dflags2 = addWay' WayDyn dflags1
dflags3 = dflags2 { dflags3 = dflags2 {
outputFile = dynOutputFile dflags2,
hiSuf = dynHiSuf dflags2, hiSuf = dynHiSuf dflags2,
objectSuf = dynObjectSuf dflags2 objectSuf = dynObjectSuf dflags2
} }
...@@ -1226,6 +1228,7 @@ defaultDynFlags mySettings = ...@@ -1226,6 +1228,7 @@ defaultDynFlags mySettings =
pluginModNameOpts = [], pluginModNameOpts = [],
outputFile = Nothing, outputFile = Nothing,
dynOutputFile = Nothing,
outputHi = Nothing, outputHi = Nothing,
dynLibLoader = SystemDependent, dynLibLoader = SystemDependent,
dumpPrefix = Nothing, dumpPrefix = Nothing,
...@@ -1598,7 +1601,7 @@ setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, ...@@ -1598,7 +1601,7 @@ setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir,
addCmdlineFramework, addHaddockOpts, addGhciScript, addCmdlineFramework, addHaddockOpts, addGhciScript,
setInteractivePrint setInteractivePrint
:: String -> DynFlags -> DynFlags :: String -> DynFlags -> DynFlags
setOutputFile, setOutputHi, setDumpPrefixForce setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce
:: Maybe String -> DynFlags -> DynFlags :: Maybe String -> DynFlags -> DynFlags
setObjectDir f d = d{ objectDir = Just f} setObjectDir f d = d{ objectDir = Just f}
...@@ -1618,6 +1621,7 @@ setDynHiSuf f d = d{ dynHiSuf = f} ...@@ -1618,6 +1621,7 @@ setDynHiSuf f d = d{ dynHiSuf = f}
setHcSuf f d = d{ hcSuf = f} setHcSuf f d = d{ hcSuf = f}
setOutputFile f d = d{ outputFile = f} setOutputFile f d = d{ outputFile = f}
setDynOutputFile f d = d{ dynOutputFile = f}
setOutputHi f d = d{ outputHi = f} setOutputHi f d = d{ outputHi = f}
addPluginModuleName :: String -> DynFlags -> DynFlags addPluginModuleName :: String -> DynFlags -> DynFlags
...@@ -1800,11 +1804,31 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do ...@@ -1800,11 +1804,31 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
throwGhcException (CmdLineError ("combination not supported: " ++ throwGhcException (CmdLineError ("combination not supported: " ++
intercalate "/" (map wayDesc theWays))) intercalate "/" (map wayDesc theWays)))
let (dflags4, consistency_warnings) = makeDynFlagsConsistent dflags3 -- TODO: This is an ugly hack. Do something better.
-- -fPIC affects the CMM code we generate, so if
-- we are in -dynamic-too mode we need -fPIC to be on during the
-- shared part of the compilation.
let doingDynamicToo = gopt Opt_BuildDynamicToo dflags3
platform = targetPlatform dflags3
dflags4 = if doingDynamicToo
then foldr setGeneralFlag' dflags3
(wayGeneralFlags platform WayDyn)
else dflags3
liftIO $ setUnsafeGlobalDynFlags dflags4 {-
TODO: This test doesn't quite work: We don't want to give an error
when e.g. compiling a C file, only when compiling Haskell files.
when doingDynamicToo $
unless (isJust (outputFile dflags4) == isJust (dynOutputFile dflags4)) $
throwGhcException $ CmdLineError
"With -dynamic-too, must give -dyno iff giving -o"
-}
return (dflags4, leftover, consistency_warnings ++ sh_warns ++ warns) let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4
liftIO $ setUnsafeGlobalDynFlags dflags5
return (dflags5, leftover, consistency_warnings ++ sh_warns ++ warns)
updateWays :: DynFlags -> DynFlags updateWays :: DynFlags -> DynFlags
updateWays dflags updateWays dflags
...@@ -1996,6 +2020,7 @@ dynamic_flags = [ ...@@ -1996,6 +2020,7 @@ dynamic_flags = [
------- Output Redirection ------------------------------------------ ------- Output Redirection ------------------------------------------
, Flag "odir" (hasArg setObjectDir) , Flag "odir" (hasArg setObjectDir)
, Flag "o" (sepArg (setOutputFile . Just)) , Flag "o" (sepArg (setOutputFile . Just))
, Flag "dyno" (sepArg (setDynOutputFile . Just))
, Flag "ohi" (hasArg (setOutputHi . Just )) , Flag "ohi" (hasArg (setOutputHi . Just ))
, Flag "osuf" (hasArg setObjectSuf) , Flag "osuf" (hasArg setObjectSuf)
, Flag "dynosuf" (hasArg setDynObjectSuf) , Flag "dynosuf" (hasArg setDynObjectSuf)
......
...@@ -709,9 +709,9 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods ...@@ -709,9 +709,9 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
prevailing_target = hscTarget (hsc_dflags hsc_env) prevailing_target = hscTarget (hsc_dflags hsc_env)
local_target = hscTarget dflags local_target = hscTarget dflags
-- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that
-- we don't do anything dodgy: these should only work to change -- we don't do anything dodgy: these should only work to change
-- from -fvia-C to -fasm and vice-versa, otherwise we could -- from -fllvm to -fasm and vice-versa, otherwise we could
-- end up trying to link object code to byte code. -- end up trying to link object code to byte code.
target = if prevailing_target /= local_target target = if prevailing_target /= local_target
&& (not (isObjectTarget prevailing_target) && (not (isObjectTarget prevailing_target)
......
-- | Bits and pieces on the bottom of the module dependency tree. -- | Bits and pieces on the bottom of the module dependency tree.
-- Also import the required constants, so we know what we're using. -- Also import the required constants, so we know what we're using.
--
-- In the interests of cross-compilation, we want to free ourselves
-- from the autoconf generated modules like main/Constants
-- --
{-# OPTIONS -fno-warn-tabs #-} -- In the interests of cross-compilation, we want to free ourselves
-- The above warning supression flag is a temporary kludge. -- from the autoconf generated modules like main/Constants
-- 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://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module SPARC.Base ( module SPARC.Base (
wordLength, wordLength,
wordLengthInBits, wordLengthInBits,
spillAreaLength, spillAreaLength,
spillSlotSize, spillSlotSize,
extraStackArgsHere, extraStackArgsHere,
fits13Bits, fits13Bits,
is32BitInteger, is32BitInteger,
largeOffsetError largeOffsetError
) )
where where
...@@ -36,13 +29,13 @@ wordLength :: Int ...@@ -36,13 +29,13 @@ wordLength :: Int
wordLength = 4 wordLength = 4
wordLengthInBits :: Int wordLengthInBits :: Int
wordLengthInBits wordLengthInBits
= wordLength * 8 = wordLength * 8
-- Size of the available spill area -- Size of the available spill area
spillAreaLength :: DynFlags -> Int spillAreaLength :: DynFlags -> Int
spillAreaLength spillAreaLength
= rESERVED_C_STACK_BYTES = rESERVED_C_STACK_BYTES
-- | We need 8 bytes because our largest registers are 64 bit. -- | We need 8 bytes because our largest registers are 64 bit.
spillSlotSize :: Int spillSlotSize :: Int
...@@ -50,7 +43,7 @@ spillSlotSize = 8 ...@@ -50,7 +43,7 @@ spillSlotSize = 8
-- | We (allegedly) put the first six C-call arguments in registers; -- | We (allegedly) put the first six C-call arguments in registers;
-- where do we start putting the rest of them? -- where do we start putting the rest of them?
extraStackArgsHere :: Int extraStackArgsHere :: Int
extraStackArgsHere = 23 extraStackArgsHere = 23
...@@ -61,22 +54,22 @@ fits13Bits :: Integral a => a -> Bool ...@@ -61,22 +54,22 @@ fits13Bits :: Integral a => a -> Bool
fits13Bits x = x >= -4096 && x < 4096 fits13Bits x = x >= -4096 && x < 4096
-- | Check whether an integer will fit in 32 bits. -- | Check whether an integer will fit in 32 bits.
-- A CmmInt is intended to be truncated to the appropriate -- A CmmInt is intended to be truncated to the appropriate
-- number of bits, so here we truncate it to Int64. This is -- number of bits, so here we truncate it to Int64. This is
-- important because e.g. -1 as a CmmInt might be either -- important because e.g. -1 as a CmmInt might be either
-- -1 or 18446744073709551615. -- -1 or 18446744073709551615.
-- --
is32BitInteger :: Integer -> Bool is32BitInteger :: Integer -> Bool
is32BitInteger i is32BitInteger i
= i64 <= 0x7fffffff && i64 >= -0x80000000 = i64 <= 0x7fffffff && i64 >= -0x80000000
where i64 = fromIntegral i :: Int64 where i64 = fromIntegral i :: Int64
-- | Sadness. -- | Sadness.
largeOffsetError :: (Integral a, Show a) => a -> b largeOffsetError :: (Integral a, Show a) => a -> b
largeOffsetError i largeOffsetError i
= panic ("ERROR: SPARC native-code generator cannot handle large offset (" = panic ("ERROR: SPARC native-code generator cannot handle large offset ("
++ show i ++ ");\nprobably because of large constant data structures;" ++ ++ show i ++ ");\nprobably because of large constant data structures;" ++
"\nworkaround: use -fvia-C on this module.\n") "\nworkaround: use -fllvm on this module.\n")
...@@ -255,7 +255,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction ta ...@@ -255,7 +255,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction ta
dflags <- getDynFlags dflags <- getDynFlags
check (xopt Opt_GHCForeignImportPrim dflags) check (xopt Opt_GHCForeignImportPrim dflags)
(text "Use -XGHCForeignImportPrim to allow `foreign import prim'.") (text "Use -XGHCForeignImportPrim to allow `foreign import prim'.")
checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp) checkCg checkCOrAsmOrLlvmOrInterp
checkCTarget target checkCTarget target
check (playSafe safety) check (playSafe safety)
(text "The safe/unsafe annotation should not be used with `foreign import prim'.") (text "The safe/unsafe annotation should not be used with `foreign import prim'.")
...@@ -264,7 +264,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction ta ...@@ -264,7 +264,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction ta
checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
return idecl return idecl
| otherwise = do -- Normal foreign import | otherwise = do -- Normal foreign import
checkCg checkCOrAsmOrLlvmOrDotNetOrInterp checkCg checkCOrAsmOrLlvmOrInterp
cconv' <- checkCConv cconv cconv' <- checkCConv cconv
checkCTarget target checkCTarget target
dflags <- getDynFlags dflags <- getDynFlags
...@@ -283,7 +283,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction ta ...@@ -283,7 +283,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction ta
-- that the C identifier is valid for C -- that the C identifier is valid for C
checkCTarget :: CCallTarget -> TcM () checkCTarget :: CCallTarget -> TcM ()
checkCTarget (StaticTarget str _ _) = do checkCTarget (StaticTarget str _ _) = do
checkCg checkCOrAsmOrLlvmOrDotNetOrInterp checkCg checkCOrAsmOrLlvmOrInterp
check (isCLabelString str) (badCName str) check (isCLabelString str) (badCName str)