module AsmCodeGen ( nativeCodeGen ) where
#include "HsVersions.h"
-#include "NCG.h"
+#include "nativeGen/NCG.h"
import MachInstrs
import MachRegs
import List ( intersperse )
#endif
-import DATA_INT
-import DATA_WORD
-import DATA_BITS
-import GLAEXTS
+import Data.Int
+import Data.Word
+import Data.Bits
+import GHC.Exts
{-
The native-code generator has machine-independent and
-- 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.text cProjectVersion
in Pretty.text ".ident" Pretty.<+>
Pretty.doubleQuotes compilerIdent
+#endif
)
}
sequenceTop :: NatCmmTop -> NatCmmTop
sequenceTop top@(CmmData _ _) = top
sequenceTop (CmmProc info lbl params blocks) =
- CmmProc info lbl params (sequenceBlocks blocks)
+ CmmProc info lbl params (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
| id == id' = (True, (block,id,out) : reverse accum ++ rest)
| otherwise = reorder id (b:accum) rest
+
+-- -----------------------------------------------------------------------------
+-- Making far branches
+
+-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
+-- big, we have to work around this limitation.
+
+makeFarBranches :: [NatBasicBlock] -> [NatBasicBlock]
+
+#if powerpc_TARGET_ARCH
+makeFarBranches blocks
+ | last blockAddresses < nearLimit = blocks
+ | otherwise = zipWith handleBlock blockAddresses blocks
+ where
+ blockAddresses = scanl (+) 0 $ map blockLen blocks
+ blockLen (BasicBlock _ instrs) = length instrs
+
+ handleBlock addr (BasicBlock id instrs)
+ = BasicBlock id (zipWith makeFar [addr..] instrs)
+
+ makeFar addr (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
+
+ nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
+ -- distance, as we have a few pseudo-insns that are
+ -- pretty-printed as multiple instructions,
+ -- and it's just not worth the effort to calculate
+ -- things exactly
+
+ blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
+#else
+makeFarBranches = id
+#endif
+
-- -----------------------------------------------------------------------------
-- Instruction selection
genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [CLabel])
-genMachCode cmm_top initial_us
- = let initial_st = mkNatM_State initial_us 0
- (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
- final_us = natm_us final_st
- final_delta = natm_delta final_st
- final_imports = natm_imports final_st
- in
- if final_delta == 0
- then ((new_tops, final_imports), final_us)
- else pprPanic "genMachCode: nonzero final delta"
- (int final_delta)
+genMachCode cmm_top
+ = do { initial_us <- getUs
+ ; let initial_st = mkNatM_State initial_us 0
+ (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
+ final_us = natm_us final_st
+ final_delta = natm_delta final_st
+ final_imports = natm_imports final_st
+ ; if final_delta == 0
+ then return (new_tops, final_imports)
+ else pprPanic "genMachCode: nonzero final delta" (int final_delta)
+ }
-- -----------------------------------------------------------------------------
-- Fixup assignments to global registers so that they assign to
cmmStmtConFold stmt
= case stmt of
CmmAssign reg src
- -> do src' <- cmmExprConFold False src
+ -> do src' <- cmmExprConFold DataReference src
return $ case src' of
CmmReg reg' | reg == reg' -> CmmNop
new_src -> CmmAssign reg new_src
CmmStore addr src
- -> do addr' <- cmmExprConFold False addr
- src' <- cmmExprConFold False src
+ -> do addr' <- cmmExprConFold DataReference addr
+ src' <- cmmExprConFold DataReference src
return $ CmmStore addr' src'
CmmJump addr regs
- -> do addr' <- cmmExprConFold True addr
+ -> do addr' <- cmmExprConFold JumpReference addr
return $ CmmJump addr' regs
CmmCall target regs args vols
-> do target' <- case target of
CmmForeignCall e conv -> do
- e' <- cmmExprConFold True e
+ e' <- cmmExprConFold CallReference e
return $ CmmForeignCall e' conv
other -> return other
args' <- mapM (\(arg, hint) -> do
- arg' <- cmmExprConFold False arg
+ arg' <- cmmExprConFold DataReference arg
return (arg', hint)) args
return $ CmmCall target' regs args' vols
CmmCondBranch test dest
- -> do test' <- cmmExprConFold False test
+ -> do test' <- cmmExprConFold DataReference test
return $ case test' of
CmmLit (CmmInt 0 _) ->
CmmComment (mkFastString ("deleted: " ++
other -> CmmCondBranch test' dest
CmmSwitch expr ids
- -> do expr' <- cmmExprConFold False expr
+ -> do expr' <- cmmExprConFold DataReference expr
return $ CmmSwitch expr' ids
other
-> return other
-cmmExprConFold isJumpTarget expr
+cmmExprConFold referenceKind expr
= case expr of
CmmLoad addr rep
- -> do addr' <- cmmExprConFold False addr
+ -> do addr' <- cmmExprConFold DataReference addr
return $ CmmLoad addr' rep
CmmMachOp mop args
-- For MachOps, we first optimize the children, and then we try
-- our hand at some constant-folding.
- -> do args' <- mapM (cmmExprConFold False) args
+ -> do args' <- mapM (cmmExprConFold DataReference) args
return $ cmmMachOpFold mop args'
CmmLit (CmmLabel lbl)
- -> cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
+ -> cmmMakeDynamicReference addImportCmmOpt referenceKind lbl
CmmLit (CmmLabelOff lbl off)
- -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
+ -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt referenceKind lbl
return $ cmmMachOpFold (MO_Add wordRep) [
dynRef,
(CmmLit $ CmmInt (fromIntegral off) wordRep)
-- with the corresponding labels:
CmmReg (CmmGlobal GCEnter1)
| not opt_PIC
- -> cmmExprConFold isJumpTarget $
+ -> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
| not opt_PIC
- -> cmmExprConFold isJumpTarget $
+ -> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
#endif
Left realreg -> return expr
Right baseRegAddr
-> case mid of
- BaseReg -> cmmExprConFold False baseRegAddr
- other -> cmmExprConFold False (CmmLoad baseRegAddr
- (globalRegRep mid))
+ BaseReg -> cmmExprConFold DataReference baseRegAddr
+ other -> cmmExprConFold DataReference
+ (CmmLoad baseRegAddr (globalRegRep mid))
-- eliminate zero offsets
CmmRegOff reg 0
- -> cmmExprConFold False (CmmReg reg)
+ -> cmmExprConFold referenceKind (CmmReg reg)
CmmRegOff (CmmGlobal mid) offset
-- RegOf leaves are just a shorthand form. If the reg maps
-> case get_GlobalReg_reg_or_addr mid of
Left realreg -> return expr
Right baseRegAddr
- -> cmmExprConFold False (CmmMachOp (MO_Add wordRep) [
+ -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordRep) [
CmmReg (CmmGlobal mid),
CmmLit (CmmInt (fromIntegral offset)
wordRep)])