diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/main/DriverPhases.hs | 59 | ||||
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 149 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 60 | ||||
| -rw-r--r-- | compiler/main/GhcMake.hs | 4 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 3 | ||||
| -rw-r--r-- | compiler/nativeGen/SPARC/Base.hs | 55 | ||||
| -rw-r--r-- | compiler/nativeGen/X86/CodeGen.hs | 12 | ||||
| -rw-r--r-- | compiler/prelude/PrelRules.lhs | 24 | ||||
| -rw-r--r-- | compiler/typecheck/TcForeign.lhs | 18 | ||||
| -rw-r--r-- | compiler/typecheck/TcValidity.lhs | 8 | ||||
| -rw-r--r-- | compiler/types/FunDeps.lhs | 66 |
11 files changed, 303 insertions, 155 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] |