summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/main/DriverPhases.hs59
-rw-r--r--compiler/main/DriverPipeline.hs149
-rw-r--r--compiler/main/DynFlags.hs60
-rw-r--r--compiler/main/GhcMake.hs4
-rw-r--r--compiler/main/HscMain.hs3
-rw-r--r--compiler/nativeGen/SPARC/Base.hs55
-rw-r--r--compiler/nativeGen/X86/CodeGen.hs12
-rw-r--r--compiler/prelude/PrelRules.lhs24
-rw-r--r--compiler/typecheck/TcForeign.lhs18
-rw-r--r--compiler/typecheck/TcValidity.lhs8
-rw-r--r--compiler/types/FunDeps.lhs66
-rw-r--r--docs/users_guide/flags.xml7
-rw-r--r--docs/users_guide/packages.xml4
-rw-r--r--docs/users_guide/sooner.xml2
-rw-r--r--ghc.mk4
-rw-r--r--ghc/Main.hs10
m---------libraries/bytestring0
m---------libraries/terminfo0
-rw-r--r--mk/config.mk.in2
-rw-r--r--rules/build-package-way.mk2
-rw-r--r--rules/build-package.mk2
-rw-r--r--rules/build-prog.mk2
-rw-r--r--rules/hi-rule.mk46
-rw-r--r--rules/hs-suffix-rules-srcdir.mk2
-rw-r--r--rules/hs-suffix-rules.mk6
25 files changed, 359 insertions, 188 deletions
diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs
index a1eac536b6..2de19b9795 100644
--- a/compiler/main/DriverPhases.hs
+++ b/compiler/main/DriverPhases.hs
@@ -35,6 +35,7 @@ module DriverPhases (
#include "HsVersions.h"
+import {-# SOURCE #-} DynFlags
import Outputable
import Platform
import System.FilePath
@@ -131,33 +132,39 @@ eqPhase _ _ = False
-- 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
-- pipeline will stop at some point (see DriverPipeline.runPipeline).
-happensBefore :: Phase -> Phase -> Bool
-StopLn `happensBefore` _ = False
-x `happensBefore` y = after_x `eqPhase` y || after_x `happensBefore` y
- where
- after_x = nextPhase x
+happensBefore :: DynFlags -> Phase -> Phase -> Bool
+happensBefore dflags p1 p2 = p1 `happensBefore'` p2
+ where StopLn `happensBefore'` _ = False
+ x `happensBefore'` y = after_x `eqPhase` y
+ || after_x `happensBefore'` y
+ where after_x = nextPhase dflags x
-nextPhase :: Phase -> Phase
--- A conservative approximation to the next phase, used in happensBefore
-nextPhase (Unlit sf) = Cpp sf
-nextPhase (Cpp sf) = HsPp sf
-nextPhase (HsPp sf) = Hsc sf
-nextPhase (Hsc _) = HCc
-nextPhase Splitter = SplitAs
-nextPhase LlvmOpt = LlvmLlc
-nextPhase LlvmLlc = LlvmMangle
-nextPhase LlvmMangle = As
-nextPhase SplitAs = MergeStub
-nextPhase As = MergeStub
-nextPhase Ccpp = As
-nextPhase Cc = As
-nextPhase Cobjc = As
-nextPhase Cobjcpp = As
-nextPhase CmmCpp = Cmm
-nextPhase Cmm = HCc
-nextPhase HCc = As
-nextPhase MergeStub = StopLn
-nextPhase StopLn = panic "nextPhase: nothing after StopLn"
+nextPhase :: DynFlags -> Phase -> Phase
+nextPhase dflags p
+ -- A conservative approximation to the next phase, used in happensBefore
+ = case p of
+ Unlit sf -> Cpp sf
+ Cpp sf -> HsPp sf
+ HsPp sf -> Hsc sf
+ Hsc _ -> maybeHCc
+ Splitter -> SplitAs
+ LlvmOpt -> LlvmLlc
+ LlvmLlc -> LlvmMangle
+ LlvmMangle -> As
+ SplitAs -> MergeStub
+ As -> MergeStub
+ Ccpp -> As
+ Cc -> As
+ Cobjc -> As
+ Cobjcpp -> As
+ CmmCpp -> Cmm
+ Cmm -> maybeHCc
+ 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
-- by its suffix.
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 849532de79..b128c1f107 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -503,70 +503,96 @@ runPipeline
-> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
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
- let dflags = extractDynFlags hsc_env0
- whenCannotGenerateDynamicToo dflags $ do
+
+ = do let
+ dflags0 = hsc_dflags hsc_env0
+
+ -- 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
- hsc_env1 <- newHscEnv dflags'
- _ <- runPipeline' stop_phase hsc_env1 (input_fn, mb_phase)
- mb_basename output maybe_loc maybe_stub_o
+ -- TODO: This should use -dyno
+ output' = case output of
+ 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 r
runPipeline'
- :: Phase -- ^ When to stop
+ :: Phase -- ^ When to start
+ -> Phase -- ^ When to stop
-> HscEnv -- ^ Compilation environment
- -> (FilePath,Maybe Phase) -- ^ Input filename (and maybe -x suffix)
- -> Maybe FilePath -- ^ original basename (if different from ^^^)
+ -> PipeEnv
+ -> FilePath -- ^ Input filename
-> PipelineOutput -- ^ Output filename
-> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
-> Maybe FilePath -- ^ stub object, if we have one
- -> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
-runPipeline' stop_phase hsc_env0 (input_fn, mb_phase)
- mb_basename output maybe_loc maybe_stub_o
+ -> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
+runPipeline' start_phase stop_phase hsc_env env input_fn
+ output maybe_loc maybe_stub_o
= 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
-- 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...
- let env = PipeEnv{ stop_phase,
- src_basename = basename,
- src_suffix = suffix',
- output_spec = output }
-
- state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o }
+ let state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o }
(state', output_fn) <- unP (pipeLoop start_phase input_fn) env 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
-- (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)
-- further compilation stages can tell what the original filename was.
case output of
Temporary ->
- return (dflags', output_fn)
- _other ->
- do final_fn <- get_output_fn dflags' stop_phase maybe_loc
+ return (dflags, output_fn)
+ _ ->
+ do final_fn <- get_output_fn dflags stop_phase maybe_loc
when (final_fn /= output_fn) $ do
let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'")
line_prag = Just ("{-# LINE 1 \"" ++ input_fn ++ "\" #-}\n")
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
-- PipeEnv: invariant information passed down
data PipeEnv = PipeEnv {
+ pe_isHaskellishFile :: Bool,
stop_phase :: Phase, -- ^ Stop just before this phase
src_basename :: String, -- ^ basename of original input source
src_suffix :: String, -- ^ its extension
@@ -656,12 +683,13 @@ phaseOutputFilename next_phase = do
pipeLoop :: Phase -> FilePath -> CompPipeline FilePath
pipeLoop phase input_fn = do
PipeEnv{stop_phase} <- getPipeEnv
- PipeState{hsc_env} <- getPipeState
+ dflags <- getDynFlags
+ let happensBefore' = happensBefore dflags
case () of
_ | phase `eqPhase` stop_phase -- All done
-> 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
-- 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
@@ -670,9 +698,8 @@ pipeLoop phase input_fn = do
" but I wanted to stop at phase " ++ show stop_phase)
| otherwise
- -> do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 4
+ -> do liftIO $ debugTraceMsg dflags 4
(ptext (sLit "Running phase") <+> ppr phase)
- dflags <- getDynFlags
(next_phase, output_fn) <- runPhase phase input_fn dflags
pipeLoop next_phase output_fn
@@ -1457,6 +1484,12 @@ runPhase MergeStub input_fn dflags
panic "runPhase(MergeStub): no stub"
Just stub_o -> do
liftIO $ joinObjectFiles dflags [input_fn, stub_o] output_fn
+ whenGeneratingDynamicToo dflags $ do
+ liftIO $ debugTraceMsg dflags 4
+ (text "Merging stub again for -dynamic-too")
+ let dyn_input_fn = replaceExtension input_fn (dynObjectSuf dflags)
+ dyn_output_fn = replaceExtension output_fn (dynObjectSuf dflags)
+ liftIO $ joinObjectFiles dflags [dyn_input_fn, stub_o] dyn_output_fn
return (StopLn, output_fn)
-- warning suppression
@@ -1956,12 +1989,20 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do
-- remember, in code we *compile*, the HOST is the same our TARGET,
-- and BUILD is the same as our HOST.
+ let sse2 = isSse2Enabled dflags
+ sse4_2 = isSse4_2Enabled dflags
+ sse_defs =
+ [ "-D__SSE__=1" | sse2 || sse4_2 ] ++
+ [ "-D__SSE2__=1" | sse2 || sse4_2 ] ++
+ [ "-D__SSE4_2__=1" | sse4_2 ]
+
cpp_prog ( map SysTools.Option verbFlags
++ map SysTools.Option include_paths
++ map SysTools.Option hsSourceCppOpts
++ map SysTools.Option target_defs
++ map SysTools.Option hscpp_opts
++ map SysTools.Option cc_opts
+ ++ map SysTools.Option sse_defs
++ [ SysTools.Option "-x"
, SysTools.Option "c"
, SysTools.Option input_fn
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 35386296f0..4edeb23ef4 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -118,6 +118,10 @@ module DynFlags (
tAG_MASK,
mAX_PTR_TAG,
tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD,
+
+ -- * SSE
+ isSse2Enabled,
+ isSse4_2Enabled,
) where
#include "HsVersions.h"
@@ -590,6 +594,7 @@ data DynFlags = DynFlags {
dynHiSuf :: String,
outputFile :: Maybe String,
+ dynOutputFile :: Maybe String,
outputHi :: Maybe String,
dynLibLoader :: DynLibLoader,
@@ -1144,6 +1149,7 @@ doDynamicToo :: DynFlags -> DynFlags
doDynamicToo dflags0 = let dflags1 = unSetGeneralFlag' Opt_Static dflags0
dflags2 = addWay' WayDyn dflags1
dflags3 = dflags2 {
+ outputFile = dynOutputFile dflags2,
hiSuf = dynHiSuf dflags2,
objectSuf = dynObjectSuf dflags2
}
@@ -1222,6 +1228,7 @@ defaultDynFlags mySettings =
pluginModNameOpts = [],
outputFile = Nothing,
+ dynOutputFile = Nothing,
outputHi = Nothing,
dynLibLoader = SystemDependent,
dumpPrefix = Nothing,
@@ -1594,7 +1601,7 @@ setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir,
addCmdlineFramework, addHaddockOpts, addGhciScript,
setInteractivePrint
:: String -> DynFlags -> DynFlags
-setOutputFile, setOutputHi, setDumpPrefixForce
+setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce
:: Maybe String -> DynFlags -> DynFlags
setObjectDir f d = d{ objectDir = Just f}
@@ -1614,6 +1621,7 @@ setDynHiSuf f d = d{ dynHiSuf = f}
setHcSuf f d = d{ hcSuf = f}
setOutputFile f d = d{ outputFile = f}
+setDynOutputFile f d = d{ dynOutputFile = f}
setOutputHi f d = d{ outputHi = f}
addPluginModuleName :: String -> DynFlags -> DynFlags
@@ -1796,11 +1804,31 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
throwGhcException (CmdLineError ("combination not supported: " ++
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
+
+ {-
+ 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"
+ -}
+
+ let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4
- liftIO $ setUnsafeGlobalDynFlags dflags4
+ liftIO $ setUnsafeGlobalDynFlags dflags5
- return (dflags4, leftover, consistency_warnings ++ sh_warns ++ warns)
+ return (dflags5, leftover, consistency_warnings ++ sh_warns ++ warns)
updateWays :: DynFlags -> DynFlags
updateWays dflags
@@ -1992,6 +2020,7 @@ dynamic_flags = [
------- Output Redirection ------------------------------------------
, Flag "odir" (hasArg setObjectDir)
, Flag "o" (sepArg (setOutputFile . Just))
+ , Flag "dyno" (sepArg (setDynOutputFile . Just))
, Flag "ohi" (hasArg (setOutputHi . Just ))
, Flag "osuf" (hasArg setObjectSuf)
, Flag "dynosuf" (hasArg setDynObjectSuf)
@@ -2153,6 +2182,11 @@ dynamic_flags = [
, Flag "monly-4-regs" (NoArg (addWarn "The -monly-4-regs flag does nothing; it will be removed in a future GHC release"))
, Flag "msse2" (NoArg (setGeneralFlag Opt_SSE2))
, Flag "msse4.2" (NoArg (setGeneralFlag Opt_SSE4_2))
+ -- at some point we should probably have a single SSE flag that
+ -- contains the SSE version, instead of having a different flag
+ -- per version. That would make it easier to e.g. check if SSE2 is
+ -- enabled as you wouldn't have to check if either Opt_SSE2 or
+ -- Opt_SSE4_2 is set (as the latter implies the former).
------ Warning opts -------------------------------------------------
, Flag "W" (NoArg (mapM_ setWarningFlag minusWOpts))
@@ -3371,3 +3405,21 @@ makeDynFlagsConsistent dflags
arch = platformArch platform
os = platformOS platform
+-- -----------------------------------------------------------------------------
+-- SSE
+
+isSse2Enabled :: DynFlags -> Bool
+isSse2Enabled dflags = isSse4_2Enabled dflags || isSse2Enabled'
+ where
+ isSse2Enabled' = case platformArch (targetPlatform dflags) of
+ ArchX86_64 -> -- SSE2 is fixed on for x86_64. It would be
+ -- possible to make it optional, but we'd need to
+ -- fix at least the foreign call code where the
+ -- calling convention specifies the use of xmm regs,
+ -- and possibly other places.
+ True
+ ArchX86 -> gopt Opt_SSE2 dflags
+ _ -> False
+
+isSse4_2Enabled :: DynFlags -> Bool
+isSse4_2Enabled dflags = gopt Opt_SSE4_2 dflags
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 34898a92a3..80227cd3f3 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -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)
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
- -- 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.
target = if prevailing_target /= local_target
&& (not (isObjectTarget prevailing_target)
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 2a838168dd..3562f27d5c 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1250,8 +1250,9 @@ hscWriteIface iface no_change mod_summary = do
-- TODO: We should do a no_change check for the dynamic
-- interface file too
let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)
+ dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile
dynDflags = doDynamicToo dflags
- writeIfaceFile dynDflags dynIfaceFile iface
+ writeIfaceFile dynDflags dynIfaceFile' iface
-- | Compile to hard-code.
hscGenHardCode :: CgGuts -> ModSummary
diff --git a/compiler/nativeGen/SPARC/Base.hs b/compiler/nativeGen/SPARC/Base.hs
index aa7b057e69..96fb5e7797 100644
--- a/compiler/nativeGen/SPARC/Base.hs
+++ b/compiler/nativeGen/SPARC/Base.hs
@@ -1,26 +1,19 @@
-- | Bits and pieces on the bottom of the module dependency tree.
--- 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
+-- Also import the required constants, so we know what we're using.
--
-{-# OPTIONS -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://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
+-- In the interests of cross-compilation, we want to free ourselves
+-- from the autoconf generated modules like main/Constants
module SPARC.Base (
- wordLength,
- wordLengthInBits,
- spillAreaLength,
- spillSlotSize,
- extraStackArgsHere,
- fits13Bits,
- is32BitInteger,
- largeOffsetError
+ wordLength,
+ wordLengthInBits,
+ spillAreaLength,
+ spillSlotSize,
+ extraStackArgsHere,
+ fits13Bits,
+ is32BitInteger,
+ largeOffsetError
)
where
@@ -36,13 +29,13 @@ wordLength :: Int
wordLength = 4
wordLengthInBits :: Int
-wordLengthInBits
- = wordLength * 8
+wordLengthInBits
+ = wordLength * 8
-- Size of the available spill area
spillAreaLength :: DynFlags -> Int
spillAreaLength
- = rESERVED_C_STACK_BYTES
+ = rESERVED_C_STACK_BYTES
-- | We need 8 bytes because our largest registers are 64 bit.
spillSlotSize :: Int
@@ -50,7 +43,7 @@ spillSlotSize = 8
-- | 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 = 23
@@ -61,22 +54,22 @@ fits13Bits :: Integral a => a -> Bool
fits13Bits x = x >= -4096 && x < 4096
-- | Check whether an integer will fit in 32 bits.
--- A CmmInt is intended to be truncated to the appropriate
--- number of bits, so here we truncate it to Int64. This is
--- important because e.g. -1 as a CmmInt might be either
--- -1 or 18446744073709551615.
+-- A CmmInt is intended to be truncated to the appropriate
+-- number of bits, so here we truncate it to Int64. This is
+-- important because e.g. -1 as a CmmInt might be either
+-- -1 or 18446744073709551615.
--
is32BitInteger :: Integer -> Bool
-is32BitInteger i
- = i64 <= 0x7fffffff && i64 >= -0x80000000
- where i64 = fromIntegral i :: Int64
+is32BitInteger i
+ = i64 <= 0x7fffffff && i64 >= -0x80000000
+ where i64 = fromIntegral i :: Int64
-- | Sadness.
largeOffsetError :: (Integral a, Show a) => a -> b
largeOffsetError i
= panic ("ERROR: SPARC native-code generator cannot handle large offset ("
- ++ show i ++ ");\nprobably because of large constant data structures;" ++
- "\nworkaround: use -fvia-C on this module.\n")
+ ++ show i ++ ");\nprobably because of large constant data structures;" ++
+ "\nworkaround: use -fllvm on this module.\n")
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index 30cf060e74..d01470926b 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -71,20 +71,12 @@ is32BitPlatform = do
sse2Enabled :: NatM Bool
sse2Enabled = do
dflags <- getDynFlags
- case platformArch (targetPlatform dflags) of
- ArchX86_64 -> -- SSE2 is fixed on for x86_64. It would be
- -- possible to make it optional, but we'd need to
- -- fix at least the foreign call code where the
- -- calling convention specifies the use of xmm regs,
- -- and possibly other places.
- return True
- ArchX86 -> return (gopt Opt_SSE2 dflags || gopt Opt_SSE4_2 dflags)
- _ -> panic "sse2Enabled: Not an X86* arch"
+ return (isSse2Enabled dflags)
sse4_2Enabled :: NatM Bool
sse4_2Enabled = do
dflags <- getDynFlags
- return (gopt Opt_SSE4_2 dflags)
+ return (isSse4_2Enabled dflags)
if_sse2 :: NatM a -> NatM a -> NatM a
if_sse2 sse2 x87 = do
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index b58eb0a47e..b21d546ef7 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -142,28 +142,28 @@ primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit
, inversePrimOp Word2IntOp ]
primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit
, subsumedByPrimOp Narrow8IntOp
- , subsumedByPrimOp Narrow16IntOp
- , subsumedByPrimOp Narrow32IntOp ]
+ , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp
+ , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp ]
primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit
- , Narrow16IntOp `subsumesPrimOp` Narrow8IntOp
+ , subsumedByPrimOp Narrow8IntOp
, subsumedByPrimOp Narrow16IntOp
- , subsumedByPrimOp Narrow32IntOp ]
+ , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp ]
primOpRules nm Narrow32IntOp = mkPrimOpRule nm 1 [ liftLit narrow32IntLit
- , Narrow32IntOp `subsumesPrimOp` Narrow8IntOp
- , Narrow32IntOp `subsumesPrimOp` Narrow16IntOp
+ , subsumedByPrimOp Narrow8IntOp
+ , subsumedByPrimOp Narrow16IntOp
, subsumedByPrimOp Narrow32IntOp
, removeOp32 ]
primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit
, subsumedByPrimOp Narrow8WordOp
- , subsumedByPrimOp Narrow16WordOp
- , subsumedByPrimOp Narrow32WordOp ]
+ , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp
+ , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp ]
primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit
- , Narrow16WordOp `subsumesPrimOp` Narrow8WordOp
+ , subsumedByPrimOp Narrow8WordOp
, subsumedByPrimOp Narrow16WordOp
- , subsumedByPrimOp Narrow32WordOp ]
+ , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp ]
primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit
- , Narrow32WordOp `subsumesPrimOp` Narrow8WordOp
- , Narrow32WordOp `subsumesPrimOp` Narrow16WordOp
+ , subsumedByPrimOp Narrow8WordOp
+ , subsumedByPrimOp Narrow16WordOp
, subsumedByPrimOp Narrow32WordOp
, removeOp32 ]
primOpRules nm OrdOp = mkPrimOpRule nm 1 [ liftLit char2IntLit
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 4ac5f48dd6..b1aef2fd77 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -255,7 +255,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction ta
dflags <- getDynFlags
check (xopt Opt_GHCForeignImportPrim dflags)
(text "Use -XGHCForeignImportPrim to allow `foreign import prim'.")
- checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp)
+ checkCg checkCOrAsmOrLlvmOrInterp
checkCTarget target
check (playSafe safety)
(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
checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
return idecl
| otherwise = do -- Normal foreign import
- checkCg checkCOrAsmOrLlvmOrDotNetOrInterp
+ checkCg checkCOrAsmOrLlvmOrInterp
cconv' <- checkCConv cconv
checkCTarget target
dflags <- getDynFlags
@@ -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
checkCTarget :: CCallTarget -> TcM ()
checkCTarget (StaticTarget str _ _) = do
- checkCg checkCOrAsmOrLlvmOrDotNetOrInterp
+ checkCg checkCOrAsmOrLlvmOrInterp
check (isCLabelString str) (badCName str)
checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
@@ -427,7 +427,7 @@ checkCOrAsmOrLlvm HscC = Nothing
checkCOrAsmOrLlvm HscAsm = Nothing
checkCOrAsmOrLlvm HscLlvm = Nothing
checkCOrAsmOrLlvm _
- = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
+ = Just (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)")
checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc
checkCOrAsmOrLlvmOrInterp HscC = Nothing
@@ -435,15 +435,7 @@ checkCOrAsmOrLlvmOrInterp HscAsm = Nothing
checkCOrAsmOrLlvmOrInterp HscLlvm = Nothing
checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing
checkCOrAsmOrLlvmOrInterp _
- = Just (text "requires interpreted, C, Llvm or native code generation")
-
-checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
-checkCOrAsmOrLlvmOrDotNetOrInterp HscC = Nothing
-checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm = Nothing
-checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm = Nothing
-checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing
-checkCOrAsmOrLlvmOrDotNetOrInterp _
- = Just (text "requires interpreted, C, Llvm or native code generation")
+ = Just (text "requires interpreted, unregisterised, llvm or native code generation")
checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
checkCg check = do
diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs
index 80e7aa0415..44d7d4c6db 100644
--- a/compiler/typecheck/TcValidity.lhs
+++ b/compiler/typecheck/TcValidity.lhs
@@ -827,7 +827,9 @@ checkValidInstance ctxt hs_type ty
-- in the constraint than in the head
; undecidable_ok <- xoptM Opt_UndecidableInstances
; if undecidable_ok
- then checkAmbiguity ctxt ty
+ then do checkAmbiguity ctxt ty
+ checkTc (checkInstLiberalCoverage clas theta inst_tys)
+ (instTypeErr clas inst_tys liberal_msg)
else do { checkInstTermination inst_tys theta
; checkTc (checkInstCoverage clas inst_tys)
(instTypeErr clas inst_tys msg) }
@@ -837,6 +839,10 @@ checkValidInstance ctxt hs_type ty
msg = parens (vcat [ptext (sLit "the Coverage Condition fails for one of the functional dependencies;"),
undecidableMsg])
+ liberal_msg = vcat
+ [ ptext $ sLit "Multiple uses of this instance may be inconsistent"
+ , ptext $ sLit "with the functional dependencies of the class."
+ ]
-- The location of the "head" of the instance
head_loc = case hs_type of
L _ (HsForAllTy _ _ _ (L loc _)) -> loc
diff --git a/compiler/types/FunDeps.lhs b/compiler/types/FunDeps.lhs
index 09d0be07bb..fe8781b1f8 100644
--- a/compiler/types/FunDeps.lhs
+++ b/compiler/types/FunDeps.lhs
@@ -19,7 +19,7 @@ module FunDeps (
FDEq (..),
Equation(..), pprEquation,
oclose, improveFromInstEnv, improveFromAnother,
- checkInstCoverage, checkFunDeps,
+ checkInstCoverage, checkInstLiberalCoverage, checkFunDeps,
pprFundeps
) where
@@ -145,6 +145,53 @@ oclose preds fixed_tvs
ClassPred cls tys -> [(cls, tys)]
TuplePred ts -> concatMap classesOfPredTy ts
_ -> []
+
+-- An alternative implementation of `oclose`. Differences:
+-- 1. The empty set of variables is allowed to determine stuff,
+-- 2. We also use equality predicates as FDs.
+--
+-- I (Iavor) believe that this is the correct implementation of oclose.
+-- For 1: the above argument about `t` being monomorphic seems incorrect.
+-- The correct behavior is to quantify over `t`, even though we know that
+-- it may be instantiated to at most one type. The point is that we might
+-- only find out what that type is later, at the call site to the function.
+-- In general, we should be quantifying all variables that are (i) not in
+-- mentioned in the environment, and (ii) not FD-determined by something in
+-- the environment.
+-- For 2: This is just a nicity, but it makes things a bit more general:
+-- if we have an assumption `t1 ~ t2`, then we use the fact that if we know
+-- `t1` we also know `t2` and the other way.
+
+oclose1 :: [PredType] -> TyVarSet -> TyVarSet
+oclose1 preds fixed_tvs
+ | null tv_fds = fixed_tvs -- Fast escape hatch for common case.
+ | otherwise = loop fixed_tvs
+ where
+ loop fixed_tvs
+ | new_fixed_tvs `subVarSet` fixed_tvs = fixed_tvs
+ | otherwise = loop new_fixed_tvs
+ where new_fixed_tvs = foldl extend fixed_tvs tv_fds
+
+ extend fixed_tvs (ls,rs)
+ | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` rs
+ | otherwise = fixed_tvs
+
+ tv_fds :: [(TyVarSet,TyVarSet)]
+ tv_fds = [ (tyVarsOfTypes xs, tyVarsOfTypes ys)
+ | (xs, ys) <- concatMap deterimned preds
+ ]
+
+ deterimned :: PredType -> [([Type],[Type])]
+ deterimned pred
+ = case classifyPredType pred of
+ ClassPred cls tys ->
+ do let (cls_tvs, cls_fds) = classTvsFds cls
+ fd <- cls_fds
+ return (instFD fd cls_tvs tys)
+ EqPred t1 t2 -> [([t1],[t2]), ([t2],[t1])]
+ TuplePred ts -> concatMap deterimned ts
+ _ -> []
+
\end{code}
@@ -471,6 +518,23 @@ checkInstCoverage clas inst_taus
fundep_ok fd = tyVarsOfTypes rs `subVarSet` tyVarsOfTypes ls
where
(ls,rs) = instFD fd tyvars inst_taus
+
+checkInstLiberalCoverage :: Class -> [PredType] -> [Type] -> Bool
+-- Check that the Liberal Coverage Condition is obeyed in an instance decl
+-- For example, if we have:
+-- class C a b | a -> b
+-- instance theta => C t1 t2
+-- Then we require fv(t2) `subset` oclose(fv(t1), theta)
+-- This ensures the self-consistency of the instance, but
+-- it does not guarantee termination.
+-- See Note [Coverage Condition] below
+
+checkInstLiberalCoverage clas theta inst_taus
+ = all fundep_ok fds
+ where
+ (tyvars, fds) = classTvsFds clas
+ fundep_ok fd = tyVarsOfTypes rs `subVarSet` oclose1 theta (tyVarsOfTypes ls)
+ where (ls,rs) = instFD fd tyvars inst_taus
\end{code}
Note [Coverage condition]
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index e084315586..5e2e52d38d 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -460,8 +460,9 @@
<tbody>
<row>
<entry><option>-fforce-recomp</option></entry>
- <entry>Turn off recompilation checking; implied by any
- <option>-ddump-X</option> option</entry>
+ <entry>Turn off recompilation checking. This is implied by any
+ <option>-ddump-X</option> option when compiling a single
+ file (i.e. when using <literal>-c</literal>).</entry>
<entry>dynamic</entry>
<entry><option>-fno-force-recomp</option></entry>
</row>
@@ -638,7 +639,7 @@
</row>
<row>
<entry><option>-no-auto-link-packages</option></entry>
- <entry>Don't automatically link in the haskell98 package.</entry>
+ <entry>Don't automatically link in the base and rts packages.</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
diff --git a/docs/users_guide/packages.xml b/docs/users_guide/packages.xml
index d1df2d4712..c6a1d089a2 100644
--- a/docs/users_guide/packages.xml
+++ b/docs/users_guide/packages.xml
@@ -252,8 +252,8 @@ exposed-modules: Network.BSD,
</indexterm></term>
<listitem>
<para>By default, GHC will automatically link in the
- <literal>haskell98</literal> package. This flag disables that
- behaviour.</para>
+ <literal>base</literal> and <literal>rts</literal> packages.
+ This flag disables that behaviour.</para>
</listitem>
</varlistentry>
diff --git a/docs/users_guide/sooner.xml b/docs/users_guide/sooner.xml
index ad798aca32..4a6430c9db 100644
--- a/docs/users_guide/sooner.xml
+++ b/docs/users_guide/sooner.xml
@@ -295,7 +295,7 @@ f (Wibble x y) # ugly, and proud of it
<literal>Strictness: &lt;string&gt;</literal>. The
<literal>&lt;string&gt;</literal> gives the strictness of
the function's arguments: see <ulink url="http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/Demand">
- the GHC Commentary</ulink> for a description of the stricntess notation.
+ the GHC Commentary</ulink> for a description of the strictness notation.
</para>
<para>For an &ldquo;unpackable&rdquo;
diff --git a/ghc.mk b/ghc.mk
index f4a7a61400..d71d8c944d 100644
--- a/ghc.mk
+++ b/ghc.mk
@@ -229,10 +229,6 @@ ifneq "$(CLEANING)" "YES"
include rules/hs-suffix-rules-srcdir.mk
include rules/hs-suffix-rules.mk
include rules/hi-rule.mk
-
-$(foreach way,$(ALL_WAYS),\
- $(eval $(call hi-rule,$(way))))
-
include rules/c-suffix-rules.mk
include rules/cmm-suffix-rules.mk
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 05a986daae..cca4581061 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -545,7 +545,7 @@ mode_flags =
addFlag "-no-link" f))
, Flag "M" (PassFlag (setMode doMkDependHSMode))
, Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))
- , Flag "C" (PassFlag setGenerateC)
+ , Flag "C" (PassFlag (setMode (stopBeforeMode HCc)))
, Flag "S" (PassFlag (setMode (stopBeforeMode As)))
, Flag "-make" (PassFlag (setMode doMakeMode))
, Flag "-interactive" (PassFlag (setMode doInteractiveMode))
@@ -553,14 +553,6 @@ mode_flags =
, Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
]
-setGenerateC :: String -> EwM ModeM ()
-setGenerateC f = do -- TODO: We used to warn and ignore when
- -- unregisterised, but we no longer know whether
- -- we are unregisterised at this point. Should
- -- we check later on?
- setMode (stopBeforeMode HCc) f
- addFlag "-fvia-C" f
-
setMode :: Mode -> String -> EwM ModeM ()
setMode newMode newFlag = liftEwM $ do
(mModeFlag, errs, flags') <- getCmdLineState
diff --git a/libraries/bytestring b/libraries/bytestring
-Subproject 6bd69fe27af33e878e38f4c579983f6a23120a8
+Subproject aaf84424aee2bac53b5121115b95ae47bcce17a
diff --git a/libraries/terminfo b/libraries/terminfo
-Subproject 579d2c324e69856ff8d1ea8b5036e30c920e197
+Subproject 116d3ee6840d52bab69c880d775ae290a20d64b
diff --git a/mk/config.mk.in b/mk/config.mk.in
index 3d7918d001..19c369dbfa 100644
--- a/mk/config.mk.in
+++ b/mk/config.mk.in
@@ -233,6 +233,8 @@ include $(TOP)/mk/install.mk
# portable as possible.
BeConservative = NO
+ExtraMakefileSanityChecks = NO
+
#
# Building various ways?
# (right now, empty if not).
diff --git a/rules/build-package-way.mk b/rules/build-package-way.mk
index 76598debfa..aade4e93af 100644
--- a/rules/build-package-way.mk
+++ b/rules/build-package-way.mk
@@ -17,8 +17,6 @@ $(call profStart, build-package-way($1,$2,$3))
$(call distdir-way-opts,$1,$2,$3,$4)
$(call hs-suffix-rules,$1,$2,$3)
-$$(foreach dir,$$($1_$2_HS_SRC_DIRS),\
- $$(eval $$(call hs-suffix-rules-srcdir,$1,$2,$3,$$(dir))))
$(call hs-objs,$1,$2,$3)
diff --git a/rules/build-package.mk b/rules/build-package.mk
index c0b9902b55..e64754cb3f 100644
--- a/rules/build-package.mk
+++ b/rules/build-package.mk
@@ -43,8 +43,6 @@ $(call clean-target,$1,$2,$1/$2)
distclean : clean_$1_$2_config
-maintainer-clean : distclean
-
.PHONY: clean_$1_$2_config
clean_$1_$2_config:
$$(call removeFiles,$1/config.log $1/config.status $(wildcard $1/include/Hs*Config.h))
diff --git a/rules/build-prog.mk b/rules/build-prog.mk
index 2c1836abed..4111e172b9 100644
--- a/rules/build-prog.mk
+++ b/rules/build-prog.mk
@@ -155,8 +155,6 @@ endif
endif
$(call hs-suffix-rules,$1,$2,$$($1_$2_PROGRAM_WAY))
-$$(foreach dir,$$($1_$2_HS_SRC_DIRS),\
- $$(eval $$(call hs-suffix-rules-srcdir,$1,$2,$$($1_$2_PROGRAM_WAY),$$(dir))))
$(call c-objs,$1,$2,$$($1_$2_PROGRAM_WAY))
$(call hs-objs,$1,$2,$$($1_$2_PROGRAM_WAY))
diff --git a/rules/hi-rule.mk b/rules/hi-rule.mk
index 35baffd11a..e478c17aea 100644
--- a/rules/hi-rule.mk
+++ b/rules/hi-rule.mk
@@ -32,11 +32,13 @@
# exit 1; \
# fi
#
-# This version adds a useful sanity check; but it is also expensive on
-# Windows where spawning a shell takes a while (about 0.3s). We'd
-# like to avoid the shell if necessary. This also hides the message
-# "nothing to be done for 'all'", since make thinks it has actually done
-# something.
+# This version adds a useful sanity check, and is a good solution,
+# except that it means spawning a shell. This can be expensive,
+# especially on Windows where spawning a shell takes about 0.3s.
+# We'd like to avoid the shell if necessary. This also hides the
+# message "nothing to be done for 'all'", since make thinks it has
+# actually done something. Therefore we only use this version
+# if ExtraMakefileSanityChecks is enabled.
#
# %.hi : %.o
#
@@ -61,12 +63,40 @@
# the ';' at the end signifies an "empty command" (see the GNU make
# documentation). An empty command is enough to get GNU make to think
# it has updated %.hi, but without actually spawning a shell to do so.
+#
+# However, given that rule, make thinks that it can make .hi files
+# for any object file, even if the object file was created from e.g.
+# a C source file. We therefore also add a dependency on the .hs/.lhs
+# source file, which means we finally end up with rules like:
+#
+# a/%.hi : a/%.o b/%.hs ;
+
+define hi-rule # $1 = source directory, $2 = object directory, $3 = way
+
+$(call hi-rule-helper,$2/%.$$($3_hisuf) : $2/%.$$($3_osuf) $1/%.hs)
+$(call hi-rule-helper,$2/%.$$($3_hisuf) : $2/%.$$($3_osuf) $1/%.lhs)
+
+$(call hi-rule-helper,$2/%.$$($3_way_)hi-boot : $2/%.$$($3_way_)o-boot $1/%.hs)
+$(call hi-rule-helper,$2/%.$$($3_way_)hi-boot : $2/%.$$($3_way_)o-boot $1/%.lhs)
-define hi-rule # $1 = way
+endef
+
+ifeq "$(ExtraMakefileSanityChecks)" "NO"
-%.$$($1_hisuf) : %.$$($1_osuf) ;
+define hi-rule-helper # $1 = rule header
+$1 ;
+endef
-%.$$($1_way_)hi-boot : %.$$($1_way_)o-boot ;
+else
+
+define hi-rule-helper # $1 = rule header
+$1
+ @if [ ! -f $$@ ] ; then \
+ echo "Panic! $$< exists, but $$@ does not."; \
+ exit 1; \
+ fi
endef
+endif
+
diff --git a/rules/hs-suffix-rules-srcdir.mk b/rules/hs-suffix-rules-srcdir.mk
index 94a41d5e73..776d1ce0f6 100644
--- a/rules/hs-suffix-rules-srcdir.mk
+++ b/rules/hs-suffix-rules-srcdir.mk
@@ -52,6 +52,8 @@ $1/$2/build/%.$$($3_hcsuf) : $1/$4/%.hs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$(
$1/$2/build/%.$$($3_hcsuf) : $1/$4/%.lhs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP)
$$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -C $$< -o $$@
+$(call hi-rule,$1/$4,$1/$2/build,$3)
+
endif
# XXX: for some reason these get used in preference to the direct
diff --git a/rules/hs-suffix-rules.mk b/rules/hs-suffix-rules.mk
index 9d547533fe..fead7d1d41 100644
--- a/rules/hs-suffix-rules.mk
+++ b/rules/hs-suffix-rules.mk
@@ -28,8 +28,14 @@ $1/$2/build/%.$$($3_hcsuf) : $1/$2/build/autogen/%.hs $$(LAX_DEPS_FOLLOW) $$($1_
$1/$2/build/%.$$($3_osuf) : $1/$2/build/autogen/%.hs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP)
$$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@
+$(call hi-rule,$1/$2/build,$1/$2/build,$3)
+$(call hi-rule,$1/$2/build/autogen,$1/$2/build,$3)
+
endif
endif
+$$(foreach dir,$$($1_$2_HS_SRC_DIRS),\
+ $$(eval $$(call hs-suffix-rules-srcdir,$1,$2,$3,$$(dir))))
+
endef # hs-suffix-rules
View Lorry Controller Status