summaryrefslogtreecommitdiff
path: root/compiler/nativeGen
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/nativeGen')
-rw-r--r--compiler/nativeGen/AsmCodeGen.lhs76
-rw-r--r--compiler/nativeGen/CPrim.hs9
-rw-r--r--compiler/nativeGen/NCGMonad.hs42
-rw-r--r--compiler/nativeGen/PIC.hs82
-rw-r--r--compiler/nativeGen/PPC/CodeGen.hs11
-rw-r--r--compiler/nativeGen/SPARC/CodeGen.hs3
-rw-r--r--compiler/nativeGen/X86/CodeGen.hs35
-rw-r--r--compiler/nativeGen/X86/Instr.hs3
-rw-r--r--compiler/nativeGen/X86/Ppr.hs1
9 files changed, 156 insertions, 106 deletions
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 34c43090e8..a999f8f45a 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -151,14 +151,14 @@ data NcgImpl statics instr jumpDest = NcgImpl {
}
--------------------
-nativeCodeGen :: DynFlags -> Handle -> UniqSupply
+nativeCodeGen :: DynFlags -> Module -> Handle -> UniqSupply
-> Stream IO RawCmmGroup ()
-> IO UniqSupply
-nativeCodeGen dflags h us cmms
+nativeCodeGen dflags this_mod h us cmms
= let platform = targetPlatform dflags
nCG' :: (Outputable statics, Outputable instr, Instruction instr)
=> NcgImpl statics instr jumpDest -> IO UniqSupply
- nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
+ nCG' ncgImpl = nativeCodeGen' dflags this_mod ncgImpl h us cmms
in case platformArch platform of
ArchX86 -> nCG' (x86NcgImpl dflags)
ArchX86_64 -> nCG' (x86_64NcgImpl dflags)
@@ -255,19 +255,20 @@ type NativeGenAcc statics instr
nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
+ -> Module
-> NcgImpl statics instr jumpDest
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> IO UniqSupply
-nativeCodeGen' dflags ncgImpl h us cmms
+nativeCodeGen' dflags this_mod ncgImpl h us cmms
= do
let split_cmms = Stream.map add_split cmms
-- BufHandle is a performance hack. We could hide it inside
-- Pretty if it weren't for the fact that we do lots of little
-- printDocs here (in order to do codegen in constant space).
bufh <- newBufHandle h
- (ngs, us') <- cmmNativeGenStream dflags ncgImpl bufh us split_cmms ([], [])
+ (ngs, us') <- cmmNativeGenStream dflags this_mod ncgImpl bufh us split_cmms ([], [])
finishNativeGen dflags ncgImpl bufh ngs
return us'
@@ -335,6 +336,7 @@ finishNativeGen dflags ncgImpl bufh@(BufHandle _ _ h) (imports, prof)
cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
+ -> Module
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
@@ -342,19 +344,20 @@ cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply)
-cmmNativeGenStream dflags ncgImpl h us cmm_stream ngs@(impAcc, profAcc)
+cmmNativeGenStream dflags this_mod ncgImpl h us cmm_stream ngs@(impAcc, profAcc)
= do r <- Stream.runStream cmm_stream
case r of
Left () ->
return ((reverse impAcc, reverse profAcc) , us)
Right (cmms, cmm_stream') -> do
- (ngs',us') <- cmmNativeGens dflags ncgImpl h us cmms ngs 0
- cmmNativeGenStream dflags ncgImpl h us' cmm_stream' ngs'
+ (ngs',us') <- cmmNativeGens dflags this_mod ncgImpl h us cmms ngs 0
+ cmmNativeGenStream dflags this_mod ncgImpl h us' cmm_stream' ngs'
-- | Do native code generation on all these cmms.
--
cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
+ -> Module
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
@@ -363,13 +366,13 @@ cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
-> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
-cmmNativeGens _ _ _ us [] ngs _
+cmmNativeGens _ _ _ _ us [] ngs _
= return (ngs, us)
-cmmNativeGens dflags ncgImpl h us (cmm : cmms) (impAcc, profAcc) count
+cmmNativeGens dflags this_mod ncgImpl h us (cmm : cmms) (impAcc, profAcc) count
= do
(us', native, imports, colorStats, linearStats)
- <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count
+ <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags this_mod ncgImpl us cmm count
{-# SCC "pprNativeCode" #-} Pretty.bufLeftRender h
$ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
@@ -386,7 +389,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) (impAcc, profAcc) count
-- force evaluation all this stuff to avoid space leaks
{-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports)
- cmmNativeGens dflags ncgImpl h
+ cmmNativeGens dflags this_mod ncgImpl h
us' cmms ((imports : impAcc),
((lsPprNative, colorStats, linearStats) : profAcc))
count'
@@ -401,6 +404,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) (impAcc, profAcc) count
cmmNativeGen
:: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
+ -> Module
-> NcgImpl statics instr jumpDest
-> UniqSupply
-> RawCmmDecl -- ^ the cmm to generate code for
@@ -411,7 +415,7 @@ cmmNativeGen
, Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
, Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators
-cmmNativeGen dflags ncgImpl us cmm count
+cmmNativeGen dflags this_mod ncgImpl us cmm count
= do
let platform = targetPlatform dflags
@@ -423,7 +427,7 @@ cmmNativeGen dflags ncgImpl us cmm count
-- cmm to cmm optimisations
let (opt_cmm, imports) =
{-# SCC "cmmToCmm" #-}
- cmmToCmm dflags fixed_cmm
+ cmmToCmm dflags this_mod fixed_cmm
dumpIfSet_dyn dflags
Opt_D_dump_opt_cmm "Optimised Cmm"
@@ -432,7 +436,7 @@ cmmNativeGen dflags ncgImpl us cmm count
-- generate native code from cmm
let ((native, lastMinuteImports), usGen) =
{-# SCC "genMachCode" #-}
- initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm
+ initUs us $ genMachCode dflags this_mod (cmmTopCodeGen ncgImpl) opt_cmm
dumpIfSet_dyn dflags
Opt_D_dump_asm_native "Native code"
@@ -816,15 +820,16 @@ apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks))
genMachCode
:: DynFlags
+ -> Module
-> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> RawCmmDecl
-> UniqSM
( [NatCmmDecl statics instr]
, [CLabel])
-genMachCode dflags cmmTopCodeGen cmm_top
+genMachCode dflags this_mod cmmTopCodeGen cmm_top
= do { initial_us <- getUs
- ; let initial_st = mkNatM_State initial_us 0 dflags
+ ; let initial_st = mkNatM_State initial_us 0 dflags this_mod
(new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
final_delta = natm_delta final_st
final_imports = natm_imports final_st
@@ -858,31 +863,36 @@ Ideas for other things we could do (put these in Hoopl please!):
temp assignments, and certain assigns to mem...)
-}
-cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel])
-cmmToCmm _ top@(CmmData _ _) = (top, [])
-cmmToCmm dflags (CmmProc info lbl live graph) = runCmmOpt dflags $ do
- blocks' <- mapM cmmBlockConFold (toBlockList graph)
- return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')
+cmmToCmm :: DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])
+cmmToCmm _ _ top@(CmmData _ _) = (top, [])
+cmmToCmm dflags this_mod (CmmProc info lbl live graph)
+ = runCmmOpt dflags this_mod $
+ do blocks' <- mapM cmmBlockConFold (toBlockList graph)
+ return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')
-newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
+newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> (# a, [CLabel] #))
instance Monad CmmOptM where
- return x = CmmOptM $ \(imports, _) -> (# x,imports #)
+ return x = CmmOptM $ \_ _ imports -> (# x, imports #)
(CmmOptM f) >>= g =
- CmmOptM $ \(imports, dflags) ->
- case f (imports, dflags) of
+ CmmOptM $ \dflags this_mod imports ->
+ case f dflags this_mod imports of
(# x, imports' #) ->
case g x of
- CmmOptM g' -> g' (imports', dflags)
+ CmmOptM g' -> g' dflags this_mod imports'
+
+instance CmmMakeDynamicReferenceM CmmOptM where
+ addImport = addImportCmmOpt
+ getThisModule = CmmOptM $ \_ this_mod imports -> (# this_mod, imports #)
addImportCmmOpt :: CLabel -> CmmOptM ()
-addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #)
+addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> (# (), lbl:imports #)
instance HasDynFlags CmmOptM where
- getDynFlags = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
+ getDynFlags = CmmOptM $ \dflags _ imports -> (# dflags, imports #)
-runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
-runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
+runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel])
+runCmmOpt dflags this_mod (CmmOptM f) = case f dflags this_mod [] of
(# result, imports #) -> (result, imports)
cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
@@ -986,10 +996,10 @@ cmmExprNative referenceKind expr = do
CmmLit (CmmLabel lbl)
-> do
- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
+ cmmMakeDynamicReference dflags referenceKind lbl
CmmLit (CmmLabelOff lbl off)
-> do
- dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
+ dynRef <- cmmMakeDynamicReference dflags referenceKind lbl
-- need to optimize here, since it's late
return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [
dynRef,
diff --git a/compiler/nativeGen/CPrim.hs b/compiler/nativeGen/CPrim.hs
index dd9d38f434..a6f4cab7bd 100644
--- a/compiler/nativeGen/CPrim.hs
+++ b/compiler/nativeGen/CPrim.hs
@@ -1,6 +1,7 @@
-- | Generating C symbol names emitted by the compiler.
module CPrim
( popCntLabel
+ , bSwapLabel
, word2FloatLabel
) where
@@ -16,6 +17,14 @@ popCntLabel w = "hs_popcnt" ++ pprWidth w
pprWidth W64 = "64"
pprWidth w = pprPanic "popCntLabel: Unsupported word width " (ppr w)
+bSwapLabel :: Width -> String
+bSwapLabel w = "hs_bswap" ++ pprWidth w
+ where
+ pprWidth W16 = "16"
+ pprWidth W32 = "32"
+ pprWidth W64 = "64"
+ pprWidth w = pprPanic "bSwapLabel: Unsupported word width " (ppr w)
+
word2FloatLabel :: Width -> String
word2FloatLabel w = "hs_word2float" ++ pprWidth w
where
diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs
index 619bf9a5fc..fec6805b4e 100644
--- a/compiler/nativeGen/NCGMonad.hs
+++ b/compiler/nativeGen/NCGMonad.hs
@@ -16,6 +16,7 @@ module NCGMonad (
mapAccumLNat,
setDeltaNat,
getDeltaNat,
+ getThisModuleNat,
getBlockIdNat,
getNewLabelNat,
getNewRegNat,
@@ -38,14 +39,16 @@ import CLabel ( CLabel, mkAsmTempLabel )
import UniqSupply
import Unique ( Unique )
import DynFlags
+import Module
data NatM_State
= NatM_State {
- natm_us :: UniqSupply,
- natm_delta :: Int,
- natm_imports :: [(CLabel)],
- natm_pic :: Maybe Reg,
- natm_dflags :: DynFlags
+ natm_us :: UniqSupply,
+ natm_delta :: Int,
+ natm_imports :: [(CLabel)],
+ natm_pic :: Maybe Reg,
+ natm_dflags :: DynFlags,
+ natm_this_module :: Module
}
newtype NatM result = NatM (NatM_State -> (result, NatM_State))
@@ -53,9 +56,9 @@ newtype NatM result = NatM (NatM_State -> (result, NatM_State))
unNat :: NatM a -> NatM_State -> (a, NatM_State)
unNat (NatM a) = a
-mkNatM_State :: UniqSupply -> Int -> DynFlags -> NatM_State
-mkNatM_State us delta dflags
- = NatM_State us delta [] Nothing dflags
+mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> NatM_State
+mkNatM_State us delta dflags this_mod
+ = NatM_State us delta [] Nothing dflags this_mod
initNat :: NatM_State -> NatM a -> (a, NatM_State)
initNat init_st m
@@ -89,30 +92,29 @@ mapAccumLNat f b (x:xs)
return (b__3, x__2:xs__2)
getUniqueNat :: NatM Unique
-getUniqueNat = NatM $ \ (NatM_State us delta imports pic dflags) ->
- case takeUniqFromSupply us of
- (uniq, us') -> (uniq, (NatM_State us' delta imports pic dflags))
+getUniqueNat = NatM $ \ st ->
+ case takeUniqFromSupply $ natm_us st of
+ (uniq, us') -> (uniq, st {natm_us = us'})
instance HasDynFlags NatM where
- getDynFlags = NatM $ \ (NatM_State us delta imports pic dflags) ->
- (dflags, (NatM_State us delta imports pic dflags))
+ getDynFlags = NatM $ \ st -> (natm_dflags st, st)
getDeltaNat :: NatM Int
-getDeltaNat
- = NatM $ \ st -> (natm_delta st, st)
+getDeltaNat = NatM $ \ st -> (natm_delta st, st)
setDeltaNat :: Int -> NatM ()
-setDeltaNat delta
- = NatM $ \ (NatM_State us _ imports pic dflags) ->
- ((), NatM_State us delta imports pic dflags)
+setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta})
+
+
+getThisModuleNat :: NatM Module
+getThisModuleNat = NatM $ \ st -> (natm_this_module st, st)
addImportNat :: CLabel -> NatM ()
addImportNat imp
- = NatM $ \ (NatM_State us delta imports pic dflags) ->
- ((), NatM_State us delta (imp:imports) pic dflags)
+ = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st})
getBlockIdNat :: NatM BlockId
diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs
index 5fff8cbdbb..b36c0ae1e8 100644
--- a/compiler/nativeGen/PIC.hs
+++ b/compiler/nativeGen/PIC.hs
@@ -35,6 +35,7 @@
module PIC (
cmmMakeDynamicReference,
+ CmmMakeDynamicReferenceM(..),
ReferenceKind(..),
needImportedSymbols,
pprImportedSymbol,
@@ -69,6 +70,7 @@ import CLabel ( mkForeignLabel )
import BasicTypes
+import Module
import Outputable
@@ -96,26 +98,32 @@ data ReferenceKind
| JumpReference
deriving(Eq)
+class Monad m => CmmMakeDynamicReferenceM m where
+ addImport :: CLabel -> m ()
+ getThisModule :: m Module
-cmmMakeDynamicReference, cmmMakeDynamicReference'
- :: Monad m => DynFlags
- -> (CLabel -> m ()) -- a monad & a function
- -- used for recording imported symbols
- -> ReferenceKind -- whether this is the target of a jump
- -> CLabel -- the label
- -> m CmmExpr
+instance CmmMakeDynamicReferenceM NatM where
+ addImport = addImportNat
+ getThisModule = getThisModuleNat
-cmmMakeDynamicReference = cmmMakeDynamicReference'
+cmmMakeDynamicReference
+ :: CmmMakeDynamicReferenceM m
+ => DynFlags
+ -> ReferenceKind -- whether this is the target of a jump
+ -> CLabel -- the label
+ -> m CmmExpr
-cmmMakeDynamicReference' dflags addImport referenceKind lbl
+cmmMakeDynamicReference dflags referenceKind lbl
| Just _ <- dynamicLinkerLabelInfo lbl
= return $ CmmLit $ CmmLabel lbl -- already processed it, pass through
| otherwise
- = case howToAccessLabel
+ = do this_mod <- getThisModule
+ case howToAccessLabel
dflags
(platformArch $ targetPlatform dflags)
(platformOS $ targetPlatform dflags)
+ this_mod
referenceKind lbl of
AccessViaStub -> do
@@ -186,7 +194,7 @@ data LabelAccessStyle
| AccessDirectly
howToAccessLabel
- :: DynFlags -> Arch -> OS -> ReferenceKind -> CLabel -> LabelAccessStyle
+ :: DynFlags -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle
-- Windows
@@ -210,7 +218,7 @@ howToAccessLabel
-- into the same .exe file. In this case we always access symbols directly,
-- and never use __imp_SYMBOL.
--
-howToAccessLabel dflags _ OSMinGW32 _ lbl
+howToAccessLabel dflags _ OSMinGW32 this_mod _ lbl
-- Assume all symbols will be in the same PE, so just access them directly.
| gopt Opt_Static dflags
@@ -218,7 +226,7 @@ howToAccessLabel dflags _ OSMinGW32 _ lbl
-- If the target symbol is in another PE we need to access it via the
-- appropriate __imp_SYMBOL pointer.
- | labelDynamic dflags (thisPackage dflags) lbl
+ | labelDynamic dflags (thisPackage dflags) this_mod lbl
= AccessViaSymbolPtr
-- Target symbol is in the same PE as the caller, so just access it directly.
@@ -234,9 +242,9 @@ howToAccessLabel dflags _ OSMinGW32 _ lbl
-- It is always possible to access something indirectly,
-- even when it's not necessary.
--
-howToAccessLabel dflags arch OSDarwin DataReference lbl
+howToAccessLabel dflags arch OSDarwin this_mod DataReference lbl
-- data access to a dynamic library goes via a symbol pointer
- | labelDynamic dflags (thisPackage dflags) lbl
+ | labelDynamic dflags (thisPackage dflags) this_mod lbl
= AccessViaSymbolPtr
-- when generating PIC code, all cross-module data references must
@@ -255,21 +263,21 @@ howToAccessLabel dflags arch OSDarwin DataReference lbl
| otherwise
= AccessDirectly
-howToAccessLabel dflags arch OSDarwin JumpReference lbl
+howToAccessLabel dflags arch OSDarwin this_mod JumpReference lbl
-- dyld code stubs don't work for tailcalls because the
-- stack alignment is only right for regular calls.
-- Therefore, we have to go via a symbol pointer:
| arch == ArchX86 || arch == ArchX86_64
- , labelDynamic dflags (thisPackage dflags) lbl
+ , labelDynamic dflags (thisPackage dflags) this_mod lbl
= AccessViaSymbolPtr
-howToAccessLabel dflags arch OSDarwin _ lbl
+howToAccessLabel dflags arch OSDarwin this_mod _ lbl
-- Code stubs are the usual method of choice for imported code;
-- not needed on x86_64 because Apple's new linker, ld64, generates
-- them automatically.
| arch /= ArchX86_64
- , labelDynamic dflags (thisPackage dflags) lbl
+ , labelDynamic dflags (thisPackage dflags) this_mod lbl
= AccessViaStub
| otherwise
@@ -286,7 +294,7 @@ howToAccessLabel dflags arch OSDarwin _ lbl
-- from position independent code. It is also required from the main program
-- when dynamic libraries containing Haskell code are used.
-howToAccessLabel _ ArchPPC_64 os kind _
+howToAccessLabel _ ArchPPC_64 os _ kind _
| osElfTarget os
= if kind == DataReference
-- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC
@@ -294,7 +302,7 @@ howToAccessLabel _ ArchPPC_64 os kind _
-- actually, .label instead of label
else AccessDirectly
-howToAccessLabel dflags _ os _ _
+howToAccessLabel dflags _ os _ _ _
-- no PIC -> the dynamic linker does everything for us;
-- if we don't dynamically link to Haskell code,
-- it actually manages to do so without messing thins up.
@@ -302,11 +310,11 @@ howToAccessLabel dflags _ os _ _
, not (gopt Opt_PIC dflags) && gopt Opt_Static dflags
= AccessDirectly
-howToAccessLabel dflags arch os DataReference lbl
+howToAccessLabel dflags arch os this_mod DataReference lbl
| osElfTarget os
= case () of
-- A dynamic label needs to be accessed via a symbol pointer.
- _ | labelDynamic dflags (thisPackage dflags) lbl
+ _ | labelDynamic dflags (thisPackage dflags) this_mod lbl
-> AccessViaSymbolPtr
-- For PowerPC32 -fPIC, we have to access even static data
@@ -332,24 +340,24 @@ howToAccessLabel dflags arch os DataReference lbl
-- (AccessDirectly, because we get an implicit symbol stub)
-- and calling functions from PIC code on non-i386 platforms (via a symbol stub)
-howToAccessLabel dflags arch os CallReference lbl
+howToAccessLabel dflags arch os this_mod CallReference lbl
| osElfTarget os
- , labelDynamic dflags (thisPackage dflags) lbl && not (gopt Opt_PIC dflags)
+ , labelDynamic dflags (thisPackage dflags) this_mod lbl && not (gopt Opt_PIC dflags)
= AccessDirectly
| osElfTarget os
, arch /= ArchX86
- , labelDynamic dflags (thisPackage dflags) lbl && gopt Opt_PIC dflags
+ , labelDynamic dflags (thisPackage dflags) this_mod lbl && gopt Opt_PIC dflags
= AccessViaStub
-howToAccessLabel dflags _ os _ lbl
+howToAccessLabel dflags _ os this_mod _ lbl
| osElfTarget os
- = if labelDynamic dflags (thisPackage dflags) lbl
+ = if labelDynamic dflags (thisPackage dflags) this_mod lbl
then AccessViaSymbolPtr
else AccessDirectly
-- all other platforms
-howToAccessLabel dflags _ _ _ _
+howToAccessLabel dflags _ _ _ _ _
| not (gopt Opt_PIC dflags)
= AccessDirectly
@@ -771,19 +779,11 @@ initializePicBase_x86 ArchX86 os picReg
BasicBlock bID (X86.FETCHGOT picReg : insns)
initializePicBase_x86 ArchX86 OSDarwin picReg
- (CmmProc info lab live (ListGraph blocks) : statics)
- = return (CmmProc info lab live (ListGraph blocks') : statics)
-
- where blocks' = case blocks of
- [] -> []
- (b:bs) -> fetchPC b : map maybeFetchPC bs
-
- maybeFetchPC b@(BasicBlock bID _)
- | bID `mapMember` info = fetchPC b
- | otherwise = b
+ (CmmProc info lab live (ListGraph (entry:blocks)) : statics)
+ = return (CmmProc info lab live (ListGraph (block':blocks)) : statics)
- fetchPC (BasicBlock bID insns) =
- BasicBlock bID (X86.FETCHPC picReg : insns)
+ where BasicBlock bID insns = entry
+ block' = BasicBlock bID (X86.FETCHPC picReg : insns)
initializePicBase_x86 _ _ _ _
= panic "initializePicBase_x86: not needed"
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index 92eff362f8..65533d8f9a 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -561,7 +561,7 @@ getRegister' _ (CmmLit (CmmInt i rep))
getRegister' _ (CmmLit (CmmFloat f frep)) = do
lbl <- getNewLabelNat
dflags <- getDynFlags
- dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
+ dynRef <- cmmMakeDynamicReference dflags DataReference lbl
Amode addr addr_code <- getAmode dynRef
let size = floatSize frep
code dst =
@@ -913,7 +913,7 @@ genCCall' _ _ (PrimTarget MO_Touch) _ _
= return $ nilOL
genCCall' dflags gcp target dest_regs args0
- = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps)
+ = ASSERT(not $ any (`elem` [II16]) $ map cmmTypeSize argReps)
-- we rely on argument promotion in the codeGen
do
(finalStack,passArgumentsCode,usedRegs) <- passArguments
@@ -1107,7 +1107,7 @@ genCCall' dflags gcp target dest_regs args0
outOfLineMachOp mop =
do
dflags <- getDynFlags
- mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $
+ mopExpr <- cmmMakeDynamicReference dflags CallReference $
mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction
let mopLabelOrExpr = case mopExpr of
CmmLit (CmmLabel lbl) -> Left lbl
@@ -1155,6 +1155,7 @@ genCCall' dflags gcp target dest_regs args0
MO_Memset -> (fsLit "memset", False)
MO_Memmove -> (fsLit "memmove", False)
+ MO_BSwap w -> (fsLit $ bSwapLabel w, False)
MO_PopCnt w -> (fsLit $ popCntLabel w, False)
MO_S_QuotRem {} -> unsupported
@@ -1179,7 +1180,7 @@ genSwitch dflags expr ids
tmp <- getNewRegNat II32
lbl <- getNewLabelNat
dflags <- getDynFlags
- dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
+ dynRef <- cmmMakeDynamicReference dflags DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
let code = e_code `appOL` t_code `appOL` toOL [
SLW tmp reg (RIImm (ImmInt 2)),
@@ -1382,7 +1383,7 @@ coerceInt2FP fromRep toRep x = do
itmp <- getNewRegNat II32
ftmp <- getNewRegNat FF64
dflags <- getDynFlags
- dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
+ dynRef <- cmmMakeDynamicReference dflags DataReference lbl
Amode addr addr_code <- getAmode dynRef
let
code' dst = code `appOL` maybe_exts `appOL` toOL [
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index 30ffcd9d9a..5d2b9a9d6d 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -588,7 +588,7 @@ outOfLineMachOp mop
= outOfLineMachOp_table mop
dflags <- getDynFlags
- mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference
+ mopExpr <- cmmMakeDynamicReference dflags CallReference
$ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction
let mopLabelOrExpr
@@ -647,6 +647,7 @@ outOfLineMachOp_table mop
MO_Memset -> fsLit "memset"
MO_Memmove -> fsLit "memmove"
+ MO_BSwap w -> fsLit $ bSwapLabel w
MO_PopCnt w -> fsLit $ popCntLabel w
MO_S_QuotRem {} -> unsupported
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index 36aebea2c7..f6143d3fb9 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -1170,7 +1170,6 @@ memConstant align lit = do
(addr, addr_code) <- if target32Bit (targetPlatform dflags)
then do dynRef <- cmmMakeDynamicReference
dflags
- addImportNat
DataReference
lbl
Amode addr addr_code <- getAmode dynRef
@@ -1659,6 +1658,29 @@ genCCall _ (PrimTarget MO_Touch) _ _ = return nilOL
genCCall _ (PrimTarget MO_Prefetch_Data) _ _ = return nilOL
+genCCall is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] = do
+ dflags <- getDynFlags
+ let platform = targetPlatform dflags
+ let dst_r = getRegisterReg platform False (CmmLocal dst)
+ case width of
+ W64 | is32Bit -> do
+ ChildCode64 vcode rlo <- iselExpr64 src
+ let dst_rhi = getHiVRegFromLo dst_r
+ rhi = getHiVRegFromLo rlo
+ return $ vcode `appOL`
+ toOL [ MOV II32 (OpReg rlo) (OpReg dst_rhi),
+ MOV II32 (OpReg rhi) (OpReg dst_r),
+ BSWAP II32 dst_rhi,
+ BSWAP II32 dst_r ]
+ W16 -> do code_src <- getAnyReg src
+ return $ code_src dst_r `appOL`
+ unitOL (BSWAP II32 dst_r) `appOL`
+ unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r))
+ _ -> do code_src <- getAnyReg src
+ return $ code_src dst_r `appOL` unitOL (BSWAP size dst_r)
+ where
+ size = intSize width
+
genCCall is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]
args@[src] = do
sse4_2 <- sse4_2Enabled
@@ -1677,7 +1699,7 @@ genCCall is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]
unitOL (POPCNT size (OpReg src_r)
(getRegisterReg platform False (CmmLocal dst))))
else do
- targetExpr <- cmmMakeDynamicReference dflags addImportNat
+ targetExpr <- cmmMakeDynamicReference dflags
CallReference lbl
let target = ForeignTarget targetExpr (ForeignConvention CCallConv
[NoHint] [NoHint]
@@ -1689,7 +1711,7 @@ genCCall is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]
genCCall is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args = do
dflags <- getDynFlags
- targetExpr <- cmmMakeDynamicReference dflags addImportNat
+ targetExpr <- cmmMakeDynamicReference dflags
CallReference lbl
let target = ForeignTarget targetExpr (ForeignConvention CCallConv
[NoHint] [NoHint]
@@ -1835,7 +1857,7 @@ genCCall32' dflags target dest_regs args = do
use_sse2 <- sse2Enabled
push_codes <- mapM (push_arg use_sse2) (reverse prom_args)
delta <- getDeltaNat
- MASSERT (delta == delta0 - tot_arg_size)
+ MASSERT(delta == delta0 - tot_arg_size)
-- deal with static vs dynamic call targets
(callinsns,cconv) <-
@@ -2271,7 +2293,7 @@ outOfLineCmmOp :: CallishMachOp -> Maybe CmmFormal -> [CmmActual] -> NatM InstrB
outOfLineCmmOp mop res args
= do
dflags <- getDynFlags
- targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl
+ targetExpr <- cmmMakeDynamicReference dflags CallReference lbl
let target = ForeignTarget targetExpr
(ForeignConvention CCallConv [] [] CmmMayReturn)
@@ -2326,6 +2348,7 @@ outOfLineCmmOp mop res args
MO_Memmove -> fsLit "memmove"
MO_PopCnt _ -> fsLit "popcnt"
+ MO_BSwap _ -> fsLit "bswap"
MO_UF_Conv _ -> unsupported
@@ -2351,7 +2374,7 @@ genSwitch dflags expr ids
(reg,e_code) <- getSomeReg expr
lbl <- getNewLabelNat
dflags <- getDynFlags
- dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
+ dynRef <- cmmMakeDynamicReference dflags DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
(EAIndex reg (wORD_SIZE dflags)) (ImmInt 0))
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index 76f0e8bd91..266a4ea58a 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -208,6 +208,7 @@ data Instr
| XOR Size Operand Operand
| NOT Size Operand
| NEGI Size Operand -- NEG instruction (name clash with Cond)
+ | BSWAP Size Reg
-- Shifts (amount may be immediate or %cl only)
| SHL Size Operand{-amount-} Operand
@@ -351,6 +352,7 @@ x86_regUsageOfInstr platform instr
XOR _ src dst -> usageRM src dst
NOT _ op -> usageM op
+ BSWAP _ reg -> mkRU [reg] [reg]
NEGI _ op -> usageM op
SHL _ imm dst -> usageRM imm dst
SAR _ imm dst -> usageRM imm dst
@@ -489,6 +491,7 @@ x86_patchRegsOfInstr instr env
OR sz src dst -> patch2 (OR sz) src dst
XOR sz src dst -> patch2 (XOR sz) src dst
NOT sz op -> patch1 (NOT sz) op
+ BSWAP sz reg -> BSWAP sz (env reg)
NEGI sz op -> patch1 (NEGI sz) op
SHL sz imm dst -> patch1 (SHL sz imm) dst
SAR sz imm dst -> patch1 (SAR sz imm) dst
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index 75d18a1ff4..7f9c6901da 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -578,6 +578,7 @@ pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst
pprInstr (POPCNT size src dst) = pprOpOp (sLit "popcnt") size src (OpReg dst)
pprInstr (NOT size op) = pprSizeOp (sLit "not") size op
+pprInstr (BSWAP size op) = pprSizeOp (sLit "bswap") size (OpReg op)
pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op
pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst
View Lorry Controller Status