#include "nativeGen/NCG.h"
-#if alpha_TARGET_ARCH
-import Alpha.CodeGen
-import Alpha.Regs
-import Alpha.RegInfo
-import Alpha.Instr
-
-#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
+#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
import X86.CodeGen
import X86.Regs
import X86.Instr
import TargetReg
import Platform
+import Config
import Instruction
import PIC
import Reg
import BlockId
import CgUtils ( fixStgRegisters )
-import Cmm
-import CmmOpt ( cmmMiniInline, cmmMachOpFold )
-import PprCmm
+import OldCmm
+import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold )
+import OldPprCmm
import CLabel
import UniqFM
import Unique ( Unique, getUnique )
import UniqSupply
import DynFlags
-#if powerpc_TARGET_ARCH
-import StaticFlags ( opt_Static, opt_PIC )
-#endif
+import StaticFlags
import Util
-#if !defined(darwin_TARGET_OS)
-import Config ( cProjectVersion )
-#endif
import Digraph
import qualified Pretty
import FastString
import UniqSet
import ErrUtils
+import Module
-- DEBUGGING ONLY
--import OrdList
| dopt Opt_SplitObjs dflags = split_marker : tops
| otherwise = tops
- split_marker = CmmProc [] mkSplitMarkerLabel [] (ListGraph [])
+ split_marker = CmmProc [] mkSplitMarkerLabel (ListGraph [])
-- | Do native code generation on all these cmms.
, Nothing
, mPprStats)
+ ---- x86fp_kludge. This pass inserts ffree instructions to clear
+ ---- the FPU stack on x86. The x86 ABI requires that the FPU stack
+ ---- is clear, and library functions can return odd results if it
+ ---- isn't.
+ ----
+ ---- NB. must happen before shortcutBranches, because that
+ ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.
+ let kludged =
+#if i386_TARGET_ARCH
+ {-# SCC "x86fp_kludge" #-}
+ map x86fp_kludge alloced
+#else
+ alloced
+#endif
+
+ ---- generate jump tables
+ let tabled =
+ {-# SCC "generateJumpTables" #-}
+ generateJumpTables kludged
+
---- shortcut branches
let shorted =
{-# SCC "shortcutBranches" #-}
- shortcutBranches dflags alloced
+ shortcutBranches dflags tabled
---- sequence blocks
let sequenced =
{-# SCC "sequenceBlocks" #-}
map sequenceTop shorted
- ---- x86fp_kludge
- let kludged =
-#if i386_TARGET_ARCH
- {-# SCC "x86fp_kludge" #-}
- map x86fp_kludge sequenced
-#else
- sequenced
-#endif
-
- ---- expansion of SPARC synthetic instrs
+ ---- expansion of SPARC synthetic instrs
#if sparc_TARGET_ARCH
let expanded =
{-# SCC "sparc_expand" #-}
- map expandTop kludged
+ map expandTop sequenced
dumpIfSet_dyn dflags
Opt_D_dump_asm_expanded "Synthetic instructions expanded"
(vcat $ map (docToSDoc . pprNatCmmTop) expanded)
#else
let expanded =
- kludged
+ sequenced
#endif
return ( usAlloc
#if i386_TARGET_ARCH
x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr
x86fp_kludge top@(CmmData _ _) = top
-x86fp_kludge (CmmProc info lbl params (ListGraph code)) =
- CmmProc info lbl params (ListGraph $ i386_insert_ffrees code)
+x86fp_kludge (CmmProc info lbl (ListGraph code)) =
+ CmmProc info lbl (ListGraph $ i386_insert_ffrees code)
#endif
-- stack so add the note in:
Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits"
#endif
-#if !defined(darwin_TARGET_OS)
-- And just because every other compiler does, lets stick in
-- an identifier directive: .ident "GHC x.y.z"
- Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
+ Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
Pretty.text cProjectVersion
in Pretty.text ".ident" Pretty.<+>
Pretty.doubleQuotes compilerIdent
-#endif
where
-- Generate "symbol stubs" for all external symbols that might
| otherwise
= Pretty.empty
- doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
+ doPpr lbl = (lbl, renderWithStyle (pprCLabel lbl) astyle)
astyle = mkCodeStyle AsmStyle
-> NatCmmTop Instr
sequenceTop top@(CmmData _ _) = top
-sequenceTop (CmmProc info lbl params (ListGraph blocks)) =
- CmmProc info lbl params (ListGraph $ makeFarBranches $ sequenceBlocks blocks)
+sequenceTop (CmmProc info lbl (ListGraph blocks)) =
+ CmmProc info lbl (ListGraph $ makeFarBranches $ sequenceBlocks blocks)
-- The algorithm is very simple (and stupid): we make a graph out of
-- the blocks where there is an edge from one block to another iff the
-- destination of the out edge to the front of the list, and continue.
-- FYI, the classic layout for basic blocks uses postorder DFS; this
--- algorithm is implemented in cmm/ZipCfg.hs (NR 6 Sep 2007).
+-- algorithm is implemented in Hoopl.
sequenceBlocks
:: Instruction instr
handleBlock addr (BasicBlock id instrs)
= BasicBlock id (zipWith makeFar [addr..] instrs)
- makeFar addr (BCC ALWAYS tgt) = BCC ALWAYS tgt
+ makeFar _ (BCC ALWAYS tgt) = BCC ALWAYS tgt
makeFar addr (BCC cond tgt)
| abs (addr - targetAddr) >= nearLimit
= BCCFAR cond tgt
| otherwise
= BCC cond tgt
where Just targetAddr = lookupUFM blockAddressMap tgt
- makeFar addr other = other
+ makeFar _ other = other
nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
-- distance, as we have a few pseudo-insns that are
#endif
-- -----------------------------------------------------------------------------
+-- Generate jump tables
+
+-- Analyzes all native code and generates data sections for all jump
+-- table instructions.
+generateJumpTables
+ :: [NatCmmTop Instr] -> [NatCmmTop Instr]
+generateJumpTables xs = concatMap f xs
+ where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
+ f p = [p]
+ g (BasicBlock _ xs) = catMaybes (map generateJumpTableForInstr xs)
+
+-- -----------------------------------------------------------------------------
-- Shortcut branches
shortcutBranches
build_mapping :: GenCmmTop d t (ListGraph Instr)
-> (GenCmmTop d t (ListGraph Instr), UniqFM JumpDest)
build_mapping top@(CmmData _ _) = (top, emptyUFM)
-build_mapping (CmmProc info lbl params (ListGraph []))
- = (CmmProc info lbl params (ListGraph []), emptyUFM)
-build_mapping (CmmProc info lbl params (ListGraph (head:blocks)))
- = (CmmProc info lbl params (ListGraph (head:others)), mapping)
+build_mapping (CmmProc info lbl (ListGraph []))
+ = (CmmProc info lbl (ListGraph []), emptyUFM)
+build_mapping (CmmProc info lbl (ListGraph (head:blocks)))
+ = (CmmProc info lbl (ListGraph (head:others)), mapping)
-- drop the shorted blocks, but don't ever drop the first one,
-- because it is pointed to by a global label.
where
(_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
| Just (DestBlockId dest) <- canShortcut insn,
- (elemBlockSet dest s) || dest == id -- loop checks
+ (setMember dest s) || dest == id -- loop checks
= (s, shortcut_blocks, b : others)
split (s, shortcut_blocks, others) (BasicBlock id [insn])
| Just dest <- canShortcut insn
- = (extendBlockSet s id, (id,dest) : shortcut_blocks, others)
+ = (setInsert id s, (id,dest) : shortcut_blocks, others)
split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
= CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
-- we need to get the jump tables, so apply the mapping to the entries
-- of a CmmData too.
-apply_mapping ufm (CmmProc info lbl params (ListGraph blocks))
- = CmmProc info lbl params (ListGraph $ map short_bb blocks)
+apply_mapping ufm (CmmProc info lbl (ListGraph blocks))
+ = CmmProc info lbl (ListGraph $ map short_bb blocks)
where
short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
short_insn i = shortcutJump (lookupUFM ufm) i
else pprPanic "genMachCode: nonzero final delta" (int final_delta)
}
-
-- -----------------------------------------------------------------------------
-- Generic Cmm optimiser
and position independent refs
(ii) compile a list of imported symbols
-Ideas for other things we could do (ToDo):
+Ideas for other things we could do:
- shortcut jumps-to-jumps
- - eliminate dead code blocks
- simple CSE: if an expr is assigned to a temp, then replace later occs of
that expr with the temp, until the expr is no longer valid (can push through
temp assignments, and certain assigns to mem...)
cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
cmmToCmm _ top@(CmmData _ _) = (top, [])
-cmmToCmm dflags (CmmProc info lbl params (ListGraph blocks)) = runCmmOpt dflags $ do
- blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
- return $ CmmProc info lbl params (ListGraph blocks')
+cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
+ blocks' <- mapM cmmBlockConFold (cmmMiniInline (cmmEliminateDeadBlocks blocks))
+ return $ CmmProc info lbl (ListGraph blocks')
newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
-cmmExprConFold referenceKind expr
- = case expr of
+cmmExprConFold referenceKind expr = do
+ dflags <- getDynFlagsCmmOpt
+ let arch = platformArch (targetPlatform dflags)
+ case expr of
CmmLoad addr rep
-> do addr' <- cmmExprConFold DataReference addr
return $ CmmLoad addr' rep
CmmLit (CmmLabel lbl)
-> do
- dflags <- getDynFlagsCmmOpt
cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
CmmLit (CmmLabelOff lbl off)
-> do
- dflags <- getDynFlagsCmmOpt
dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
return $ cmmMachOpFold (MO_Add wordWidth) [
dynRef,
(CmmLit $ CmmInt (fromIntegral off) wordWidth)
]
-#if powerpc_TARGET_ARCH
- -- On powerpc (non-PIC), it's easier to jump directly to a label than
- -- to use the register table, so we replace these registers
- -- with the corresponding labels:
+ -- On powerpc (non-PIC), it's easier to jump directly to a label than
+ -- to use the register table, so we replace these registers
+ -- with the corresponding labels:
CmmReg (CmmGlobal EagerBlackholeInfo)
- | not opt_PIC
+ | arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
CmmReg (CmmGlobal GCEnter1)
- | not opt_PIC
+ | arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
- | not opt_PIC
+ | arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
-#endif
other
-> return other
projects / ghc-hetmet.git / blobdiff