-- -----------------------------------------------------------------------------
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module AsmCodeGen ( nativeCodeGen ) where
#include "HsVersions.h"
#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
import X86.CodeGen
import X86.Regs
-import X86.RegInfo
import X86.Instr
import X86.Ppr
#elif sparc_TARGET_ARCH
import SPARC.CodeGen
+import SPARC.CodeGen.Expand
import SPARC.Regs
import SPARC.Instr
import SPARC.Ppr
import qualified GraphColor as Color
import qualified RegAlloc.Graph.Main as Color
import qualified RegAlloc.Graph.Stats as Color
-import qualified RegAlloc.Graph.Coalesce as Color
import qualified RegAlloc.Graph.TrivColorable as Color
-import qualified SPARC.CodeGen.Expand as SPARC
-
import TargetReg
import Platform
import Instruction
import PIC
import Reg
-import RegClass
import NCGMonad
import BlockId
+import CgUtils ( fixStgRegisters )
import Cmm
import CmmOpt ( cmmMiniInline, cmmMachOpFold )
import PprCmm
import CLabel
-import State
import UniqFM
import Unique ( Unique, getUnique )
import StaticFlags ( opt_Static, opt_PIC )
#endif
import Util
+#if !defined(darwin_TARGET_OS)
import Config ( cProjectVersion )
-import Module
+#endif
import Digraph
import qualified Pretty
--import OrdList
import Data.List
-import Data.Int
-import Data.Word
-import Data.Bits
import Data.Maybe
-import GHC.Exts
import Control.Monad
import System.IO
-- | Do native code generation on all these cmms.
--
-cmmNativeGens dflags h us [] impAcc profAcc count
+cmmNativeGens :: DynFlags
+ -> BufHandle
+ -> UniqSupply
+ -> [RawCmmTop]
+ -> [[CLabel]]
+ -> [ ([NatCmmTop Instr],
+ Maybe [Color.RegAllocStats Instr],
+ Maybe [Linear.RegAllocStats]) ]
+ -> Int
+ -> IO ( [[CLabel]],
+ [([NatCmmTop Instr],
+ Maybe [Color.RegAllocStats Instr],
+ Maybe [Linear.RegAllocStats])] )
+
+cmmNativeGens _ _ _ [] impAcc profAcc _
= return (reverse impAcc, reverse profAcc)
cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
= do
-- rewrite assignments to global regs
- let (fixed_cmm, usFix) =
- {-# SCC "fixAssignsTop" #-}
- initUs us $ fixAssignsTop cmm
+ let fixed_cmm =
+ {-# SCC "fixStgRegisters" #-}
+ fixStgRegisters cmm
-- cmm to cmm optimisations
let (opt_cmm, imports) =
-- generate native code from cmm
let ((native, lastMinuteImports), usGen) =
{-# SCC "genMachCode" #-}
- initUs usFix $ genMachCode dflags opt_cmm
+ initUs us $ genMachCode dflags opt_cmm
dumpIfSet_dyn dflags
Opt_D_dump_asm_native "Native code"
(vcat $ map (docToSDoc . pprNatCmmTop) native)
-
-- tag instructions with register liveness information
let (withLiveness, usLive) =
{-# SCC "regLiveness" #-}
- initUs usGen $ mapUs regLiveness native
+ initUs usGen
+ $ mapUs regLiveness
+ $ map natCmmTopToLive native
dumpIfSet_dyn dflags
Opt_D_dump_asm_liveness "Liveness annotations added"
(vcat $ map ppr withLiveness)
-
-- allocate registers
(alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
emptyUFM
$ allocatableRegs
-
-- do the graph coloring register allocation
let ((alloced, regAllocStats), usAlloc)
= {-# SCC "RegAlloc" #-}
#if sparc_TARGET_ARCH
let expanded =
{-# SCC "sparc_expand" #-}
- map SPARC.expandTop kludged
+ map expandTop kludged
dumpIfSet_dyn dflags
Opt_D_dump_asm_expanded "Synthetic instructions expanded"
#if i386_TARGET_ARCH
x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr
x86fp_kludge top@(CmmData _ _) = top
-x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) =
+x86fp_kludge (CmmProc info lbl params (ListGraph code)) =
CmmProc info lbl params (ListGraph $ i386_insert_ffrees code)
#endif
[one] -> [getUnique one]
_many -> []
+mkNode :: (Instruction t)
+ => GenBasicBlock t
+ -> (GenBasicBlock t, Unique, [Unique])
mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
+seqBlocks :: (Eq t) => [(GenBasicBlock t1, t, [t])] -> [GenBasicBlock t1]
seqBlocks [] = []
seqBlocks ((block,_,[]) : rest)
= block : seqBlocks rest
-- fallthroughs within a loop.
seqBlocks _ = panic "AsmCodegen:seqBlocks"
-reorder id accum [] = (False, reverse accum)
+reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
+reorder _ accum [] = (False, reverse accum)
reorder id accum (b@(block,id',out) : rest)
| id == id' = (True, (block,id,out) : reverse accum ++ rest)
| otherwise = reorder id (b:accum) rest
(tops', mappings) = mapAndUnzip build_mapping tops
mapping = foldr plusUFM emptyUFM mappings
+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)
mapping = foldl add emptyUFM shortcut_blocks
add ufm (id,dest) = addToUFM ufm id dest
+apply_mapping :: UniqFM JumpDest
+ -> GenCmmTop CmmStatic h (ListGraph Instr)
+ -> GenCmmTop CmmStatic h (ListGraph Instr)
apply_mapping ufm (CmmData sec statics)
= CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
-- we need to get the jump tables, so apply the mapping to the entries
else pprPanic "genMachCode: nonzero final delta" (int final_delta)
}
--- -----------------------------------------------------------------------------
--- Fixup assignments to global registers so that they assign to
--- locations within the RegTable, if appropriate.
-
--- Note that we currently don't fixup reads here: they're done by
--- the generic optimiser below, to avoid having two separate passes
--- over the Cmm.
-
-fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
-fixAssignsTop top@(CmmData _ _) = returnUs top
-fixAssignsTop (CmmProc info lbl params (ListGraph blocks)) =
- mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
- returnUs (CmmProc info lbl params (ListGraph blocks'))
-
-fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock
-fixAssignsBlock (BasicBlock id stmts) =
- fixAssigns stmts `thenUs` \ stmts' ->
- returnUs (BasicBlock id stmts')
-
-fixAssigns :: [CmmStmt] -> UniqSM [CmmStmt]
-fixAssigns stmts =
- mapUs fixAssign stmts `thenUs` \ stmtss ->
- returnUs (concat stmtss)
-
-fixAssign :: CmmStmt -> UniqSM [CmmStmt]
-fixAssign (CmmAssign (CmmGlobal reg) src)
- | Left realreg <- reg_or_addr
- = returnUs [CmmAssign (CmmGlobal reg) src]
- | Right baseRegAddr <- reg_or_addr
- = returnUs [CmmStore baseRegAddr src]
- -- Replace register leaves with appropriate StixTrees for
- -- the given target. GlobalRegs which map to a reg on this
- -- arch are left unchanged. Assigning to BaseReg is always
- -- illegal, so we check for that.
- where
- reg_or_addr = get_GlobalReg_reg_or_addr reg
-
-fixAssign other_stmt = returnUs [other_stmt]
-- -----------------------------------------------------------------------------
-- Generic Cmm optimiser
(a) Constant folding
(b) Simple inlining: a temporary which is assigned to and then
used, once, can be shorted.
- (c) Replacement of references to GlobalRegs which do not have
- machine registers by the appropriate memory load (eg.
- Hp ==> *(BaseReg + 34) ).
- (d) Position independent code and dynamic linking
+ (c) Position independent code and dynamic linking
(i) introduce the appropriate indirections
and position independent refs
(ii) compile a list of imported symbols
CmmOptM g' -> g' (imports', dflags)
addImportCmmOpt :: CLabel -> CmmOptM ()
-addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #)
+addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #)
getDynFlagsCmmOpt :: CmmOptM DynFlags
getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
stmts' <- mapM cmmStmtConFold stmts
return $ BasicBlock id stmts'
+cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt
cmmStmtConFold stmt
= case stmt of
CmmAssign reg src
CmmComment (mkFastString ("deleted: " ++
showSDoc (pprStmt stmt)))
- CmmLit (CmmInt n _) -> CmmBranch dest
- other -> CmmCondBranch test' dest
+ CmmLit (CmmInt _ _) -> CmmBranch dest
+ _other -> CmmCondBranch test' dest
CmmSwitch expr ids
-> do expr' <- cmmExprConFold DataReference expr
-> return other
+cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold referenceKind expr
= case expr of
CmmLoad addr rep
CmmReg (CmmGlobal EagerBlackholeInfo)
| not opt_PIC
-> cmmExprConFold referenceKind $
- CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_EAGER_BLACKHOLE_INFO")))
+ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
CmmReg (CmmGlobal GCEnter1)
| not opt_PIC
-> cmmExprConFold referenceKind $
- CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_enter_1")))
+ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
| not opt_PIC
-> cmmExprConFold referenceKind $
- CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_fun")))
+ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
#endif
- CmmReg (CmmGlobal mid)
- -- Replace register leaves with appropriate StixTrees for
- -- the given target. MagicIds which map to a reg on this
- -- arch are left unchanged. For the rest, BaseReg is taken
- -- to mean the address of the reg table in MainCapability,
- -- and for all others we generate an indirection to its
- -- location in the register table.
- -> case get_GlobalReg_reg_or_addr mid of
- Left realreg -> return expr
- Right baseRegAddr
- -> case mid of
- BaseReg -> cmmExprConFold DataReference baseRegAddr
- other -> cmmExprConFold DataReference
- (CmmLoad baseRegAddr (globalRegType mid))
- -- eliminate zero offsets
- CmmRegOff reg 0
- -> cmmExprConFold referenceKind (CmmReg reg)
-
- CmmRegOff (CmmGlobal mid) offset
- -- RegOf leaves are just a shorthand form. If the reg maps
- -- to a real reg, we keep the shorthand, otherwise, we just
- -- expand it and defer to the above code.
- -> case get_GlobalReg_reg_or_addr mid of
- Left realreg -> return expr
- Right baseRegAddr
- -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordWidth) [
- CmmReg (CmmGlobal mid),
- CmmLit (CmmInt (fromIntegral offset)
- wordWidth)])
other
-> return other
--- -----------------------------------------------------------------------------
--- Utils
-
-bind f x = x $! f
-
\end{code}