+-- -----------------------------------------------------------------------------
+-- Sequencing the basic blocks
+
+-- Cmm BasicBlocks are self-contained entities: they always end in a
+-- jump, either non-local or to another basic block in the same proc.
+-- In this phase, we attempt to place the basic blocks in a sequence
+-- such that as many of the local jumps as possible turn into
+-- fallthroughs.
+
+sequenceTop :: NatCmmTop -> NatCmmTop
+sequenceTop top@(CmmData _ _) = top
+sequenceTop (CmmProc info lbl params blocks) =
+ CmmProc info lbl params (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
+-- first block ends by jumping to the second. Then we topologically
+-- sort this graph. Then traverse the list: for each block, we first
+-- output the block, then if it has an out edge, we move the
+-- destination of the out edge to the front of the list, and continue.
+
+sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock]
+sequenceBlocks [] = []
+sequenceBlocks (entry:blocks) =
+ seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
+ -- the first block is the entry point ==> it must remain at the start.
+
+sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])]
+sccBlocks blocks = stronglyConnCompR (map mkNode blocks)
+
+getOutEdges :: [Instr] -> [Unique]
+getOutEdges instrs = case jumpDests (last instrs) [] of
+ [one] -> [getUnique one]
+ _many -> []
+ -- we're only interested in the last instruction of
+ -- the block, and only if it has a single destination.
+
+mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
+
+seqBlocks [] = []
+seqBlocks ((block,_,[]) : rest)
+ = block : seqBlocks rest
+seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
+ | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
+ | otherwise = block : seqBlocks rest'
+ where
+ (can_fallthrough, rest') = reorder next [] rest
+ -- TODO: we should do a better job for cycles; try to maximise the
+ -- fallthroughs within a loop.
+seqBlocks _ = panic "AsmCodegen:seqBlocks"
+
+reorder id 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
+
+-- -----------------------------------------------------------------------------
+-- Instruction selection
+
+-- Native code instruction selection for a chunk of stix code. For
+-- this part of the computation, we switch from the UniqSM monad to
+-- the NatM monad. The latter carries not only a Unique, but also an
+-- Int denoting the current C stack pointer offset in the generated
+-- code; this is needed for creating correct spill offsets on
+-- architectures which don't offer, or for which it would be
+-- prohibitively expensive to employ, a frame pointer register. Viz,
+-- x86.
+
+-- The offset is measured in bytes, and indicates the difference
+-- between the current (simulated) C stack-ptr and the value it was at
+-- the beginning of the block. For stacks which grow down, this value
+-- should be either zero or negative.
+
+-- Switching between the two monads whilst carrying along the same
+-- Unique supply breaks abstraction. Is that bad?
+
+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)
+
+-- -----------------------------------------------------------------------------
+-- 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 :: CmmTop -> UniqSM CmmTop
+fixAssignsTop top@(CmmData _ _) = returnUs top
+fixAssignsTop (CmmProc info lbl params blocks) =
+ mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
+ returnUs (CmmProc info lbl params 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 BaseReg) src)
+ = panic "cmmStmtConFold: assignment to BaseReg";
+
+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 (CmmCall target results args vols)
+ = mapAndUnzipUs fixResult results `thenUs` \ (results',stores) ->
+ returnUs (caller_save ++
+ CmmCall target results' args vols :
+ caller_restore ++
+ concat stores)
+ where
+ -- we also save/restore any caller-saves STG registers here
+ (caller_save, caller_restore) = callerSaveVolatileRegs vols
+
+ fixResult g@(CmmGlobal reg,hint) =
+ case get_GlobalReg_reg_or_addr reg of
+ Left realreg -> returnUs (g, [])
+ Right baseRegAddr ->
+ getUniqueUs `thenUs` \ uq ->
+ let local = CmmLocal (LocalReg uq (globalRegRep reg)) in
+ returnUs ((local,hint),
+ [CmmStore baseRegAddr (CmmReg local)])
+ fixResult other =
+ returnUs (other,[])
+
+fixAssign other_stmt = returnUs [other_stmt]
+
+-- -----------------------------------------------------------------------------
+-- Generic Cmm optimiser
+
+{-
+Here we do:
+
+ (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
+ (i) introduce the appropriate indirections
+ and position independent refs
+ (ii) compile a list of imported symbols
+
+Ideas for other things we could do (ToDo):
+
+ - 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 :: CmmTop -> (CmmTop, [CLabel])
+cmmToCmm top@(CmmData _ _) = (top, [])
+cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
+ blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
+ return $ CmmProc info lbl params blocks'
+
+newtype CmmOptM a = CmmOptM ([CLabel] -> (# a, [CLabel] #))
+
+instance Monad CmmOptM where
+ return x = CmmOptM $ \imports -> (# x,imports #)
+ (CmmOptM f) >>= g =
+ CmmOptM $ \imports ->
+ case f imports of
+ (# x, imports' #) ->
+ case g x of
+ CmmOptM g' -> g' imports'
+
+addImportCmmOpt :: CLabel -> CmmOptM ()
+addImportCmmOpt lbl = CmmOptM $ \imports -> (# (), lbl:imports #)
+
+runCmmOpt :: CmmOptM a -> (a, [CLabel])
+runCmmOpt (CmmOptM f) = case f [] of
+ (# result, imports #) -> (result, imports)
+
+cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
+cmmBlockConFold (BasicBlock id stmts) = do
+ stmts' <- mapM cmmStmtConFold stmts
+ return $ BasicBlock id stmts'
+
+cmmStmtConFold stmt
+ = case stmt of
+ CmmAssign reg src
+ -> do src' <- cmmExprConFold False 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
+ return $ CmmStore addr' src'
+
+ CmmJump addr regs
+ -> do addr' <- cmmExprConFold True addr
+ return $ CmmJump addr' regs
+
+ CmmCall target regs args vols
+ -> do target' <- case target of
+ CmmForeignCall e conv -> do
+ e' <- cmmExprConFold True e
+ return $ CmmForeignCall e' conv
+ other -> return other
+ args' <- mapM (\(arg, hint) -> do
+ arg' <- cmmExprConFold False arg
+ return (arg', hint)) args
+ return $ CmmCall target' regs args' vols
+
+ CmmCondBranch test dest
+ -> do test' <- cmmExprConFold False test
+ return $ case test' of
+ CmmLit (CmmInt 0 _) ->
+ CmmComment (mkFastString ("deleted: " ++
+ showSDoc (pprStmt stmt)))
+
+ CmmLit (CmmInt n _) -> CmmBranch dest
+ other -> CmmCondBranch test' dest
+
+ CmmSwitch expr ids
+ -> do expr' <- cmmExprConFold False expr
+ return $ CmmSwitch expr' ids
+
+ other
+ -> return other
+
+
+cmmExprConFold isJumpTarget expr
+ = case expr of
+ CmmLoad addr rep
+ -> do addr' <- cmmExprConFold False 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
+ return $ cmmMachOpFold mop args'
+
+ CmmLit (CmmLabel lbl)
+ -> cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
+ CmmLit (CmmLabelOff lbl off)
+ -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
+ return $ cmmMachOpFold (MO_Add wordRep) [
+ dynRef,
+ (CmmLit $ CmmInt (fromIntegral off) wordRep)
+ ]
+
+#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:
+ CmmReg (CmmGlobal GCEnter1)
+ | not opt_PIC
+ -> cmmExprConFold isJumpTarget $
+ CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
+ CmmReg (CmmGlobal GCFun)
+ | not opt_PIC
+ -> cmmExprConFold isJumpTarget $
+ CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
+#endif