1 -- -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow 1993-2004
5 -- This is the top-level module in the native code generator.
7 -- -----------------------------------------------------------------------------
10 module AsmCodeGen ( nativeCodeGen ) where
12 #include "HsVersions.h"
20 import RegAllocInfo ( jumpDests )
22 import PositionIndependentCode
25 import PprCmm ( pprStmt, pprCmms )
27 import CLabel ( CLabel, mkSplitMarkerLabel, mkAsmTempLabel )
28 #if powerpc_TARGET_ARCH
29 import CLabel ( mkRtsCodeLabel )
33 import Unique ( Unique, getUnique )
36 import List ( groupBy, sortBy )
37 import CLabel ( pprCLabel )
38 import ErrUtils ( dumpIfSet_dyn )
39 import DynFlags ( DynFlags, DynFlag(..), dopt )
40 import StaticFlags ( opt_Static, opt_PIC )
43 import qualified Pretty
51 import List ( intersperse )
60 The native-code generator has machine-independent and
61 machine-dependent modules.
63 This module ("AsmCodeGen") is the top-level machine-independent
64 module. Before entering machine-dependent land, we do some
65 machine-independent optimisations (defined below) on the
68 We convert to the machine-specific 'Instr' datatype with
69 'cmmCodeGen', assuming an infinite supply of registers. We then use
70 a machine-independent register allocator ('regAlloc') to rejoin
71 reality. Obviously, 'regAlloc' has machine-specific helper
72 functions (see about "RegAllocInfo" below).
74 Finally, we order the basic blocks of the function so as to minimise
75 the number of jumps between blocks, by utilising fallthrough wherever
78 The machine-dependent bits break down as follows:
80 * ["MachRegs"] Everything about the target platform's machine
81 registers (and immediate operands, and addresses, which tend to
82 intermingle/interact with registers).
84 * ["MachInstrs"] Includes the 'Instr' datatype (possibly should
85 have a module of its own), plus a miscellany of other things
86 (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)
88 * ["MachCodeGen"] is where 'Cmm' stuff turns into
91 * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
94 * ["RegAllocInfo"] In the register allocator, we manipulate
95 'MRegsState's, which are 'BitSet's, one bit per machine register.
96 When we want to say something about a specific machine register
97 (e.g., ``it gets clobbered by this instruction''), we set/unset
98 its bit. Obviously, we do this 'BitSet' thing for efficiency
101 The 'RegAllocInfo' module collects together the machine-specific
102 info needed to do register allocation.
104 * ["RegisterAlloc"] The (machine-independent) register allocator.
107 -- -----------------------------------------------------------------------------
108 -- Top-level of the native codegen
110 -- NB. We *lazilly* compile each block of code for space reasons.
112 nativeCodeGen :: DynFlags -> [Cmm] -> UniqSupply -> IO Pretty.Doc
113 nativeCodeGen dflags cmms us
114 = let ((ppr_cmms, insn_sdoc, imports), _) = initUs us $
115 cgCmm (concat (map add_split cmms))
117 cgCmm :: [CmmTop] -> UniqSM (Cmm, Pretty.Doc, [CLabel])
119 lazyMapUs (cmmNativeGen dflags) tops `thenUs` \ results ->
120 let (cmms,docs,imps) = unzip3 results in
121 returnUs (Cmm cmms, my_vcat docs, concat imps)
123 dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmms [ppr_cmms])
124 return (insn_sdoc Pretty.$$ dyld_stubs imports
125 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
126 -- On recent versions of Darwin, the linker supports
127 -- dead-stripping of code and data on a per-symbol basis.
128 -- There's a hack to make this work in PprMach.pprNatCmmTop.
129 Pretty.$$ Pretty.text ".subsections_via_symbols"
136 | dopt Opt_SplitObjs dflags = split_marker : tops
139 split_marker = CmmProc [] mkSplitMarkerLabel [] []
141 -- Generate "symbol stubs" for all external symbols that might
142 -- come from a dynamic library.
143 {- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
144 map head $ group $ sort imps-}
146 -- (Hack) sometimes two Labels pretty-print the same, but have
147 -- different uniques; so we compare their text versions...
149 | needImportedSymbols
151 (pprGotDeclaration :) $
152 map (pprImportedSymbol . fst . head) $
153 groupBy (\(_,a) (_,b) -> a == b) $
154 sortBy (\(_,a) (_,b) -> compare a b) $
160 where doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
161 astyle = mkCodeStyle AsmStyle
164 my_vcat sds = Pretty.vcat sds
166 my_vcat sds = Pretty.vcat (
169 Pretty.$$ Pretty.ptext SLIT("# ___ncg_debug_marker")
170 Pretty.$$ Pretty.char ' '
177 -- Complete native code generation phase for a single top-level chunk
180 cmmNativeGen :: DynFlags -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [CLabel])
181 cmmNativeGen dflags cmm
182 = {-# SCC "fixAssigns" #-}
183 fixAssignsTop cmm `thenUs` \ fixed_cmm ->
184 {-# SCC "genericOpt" #-}
185 cmmToCmm fixed_cmm `bind` \ (cmm, imports) ->
186 (if dopt Opt_D_dump_opt_cmm dflags -- space leak avoidance
188 else CmmData Text []) `bind` \ ppr_cmm ->
189 {-# SCC "genMachCode" #-}
190 genMachCode cmm `thenUs` \ (pre_regalloc, lastMinuteImports) ->
191 {-# SCC "regAlloc" #-}
192 map regAlloc pre_regalloc `bind` \ with_regs ->
193 {-# SCC "sequenceBlocks" #-}
194 map sequenceTop with_regs `bind` \ sequenced ->
195 {-# SCC "x86fp_kludge" #-}
196 map x86fp_kludge sequenced `bind` \ final_mach_code ->
198 Pretty.vcat (map pprNatCmmTop final_mach_code) `bind` \ final_sdoc ->
200 returnUs (ppr_cmm, final_sdoc Pretty.$$ Pretty.text "", lastMinuteImports ++ imports)
202 x86fp_kludge :: NatCmmTop -> NatCmmTop
203 x86fp_kludge top@(CmmData _ _) = top
205 x86fp_kludge top@(CmmProc info lbl params code) =
206 CmmProc info lbl params (map bb_i386_insert_ffrees code)
208 bb_i386_insert_ffrees (BasicBlock id instrs) =
209 BasicBlock id (i386_insert_ffrees instrs)
211 x86fp_kludge top = top
214 -- -----------------------------------------------------------------------------
215 -- Sequencing the basic blocks
217 -- Cmm BasicBlocks are self-contained entities: they always end in a
218 -- jump, either non-local or to another basic block in the same proc.
219 -- In this phase, we attempt to place the basic blocks in a sequence
220 -- such that as many of the local jumps as possible turn into
223 sequenceTop :: NatCmmTop -> NatCmmTop
224 sequenceTop top@(CmmData _ _) = top
225 sequenceTop (CmmProc info lbl params blocks) =
226 CmmProc info lbl params (sequenceBlocks blocks)
228 -- The algorithm is very simple (and stupid): we make a graph out of
229 -- the blocks where there is an edge from one block to another iff the
230 -- first block ends by jumping to the second. Then we topologically
231 -- sort this graph. Then traverse the list: for each block, we first
232 -- output the block, then if it has an out edge, we move the
233 -- destination of the out edge to the front of the list, and continue.
235 sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock]
236 sequenceBlocks [] = []
237 sequenceBlocks (entry:blocks) =
238 seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
239 -- the first block is the entry point ==> it must remain at the start.
241 sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])]
242 sccBlocks blocks = stronglyConnCompR (map mkNode blocks)
244 getOutEdges :: [Instr] -> [Unique]
245 getOutEdges instrs = case jumpDests (last instrs) [] of
246 [one] -> [getUnique one]
248 -- we're only interested in the last instruction of
249 -- the block, and only if it has a single destination.
251 mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
254 seqBlocks ((block,_,[]) : rest)
255 = block : seqBlocks rest
256 seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
257 | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
258 | otherwise = block : seqBlocks rest'
260 (can_fallthrough, rest') = reorder next [] rest
261 -- TODO: we should do a better job for cycles; try to maximise the
262 -- fallthroughs within a loop.
263 seqBlocks _ = panic "AsmCodegen:seqBlocks"
265 reorder id accum [] = (False, reverse accum)
266 reorder id accum (b@(block,id',out) : rest)
267 | id == id' = (True, (block,id,out) : reverse accum ++ rest)
268 | otherwise = reorder id (b:accum) rest
270 -- -----------------------------------------------------------------------------
271 -- Instruction selection
273 -- Native code instruction selection for a chunk of stix code. For
274 -- this part of the computation, we switch from the UniqSM monad to
275 -- the NatM monad. The latter carries not only a Unique, but also an
276 -- Int denoting the current C stack pointer offset in the generated
277 -- code; this is needed for creating correct spill offsets on
278 -- architectures which don't offer, or for which it would be
279 -- prohibitively expensive to employ, a frame pointer register. Viz,
282 -- The offset is measured in bytes, and indicates the difference
283 -- between the current (simulated) C stack-ptr and the value it was at
284 -- the beginning of the block. For stacks which grow down, this value
285 -- should be either zero or negative.
287 -- Switching between the two monads whilst carrying along the same
288 -- Unique supply breaks abstraction. Is that bad?
290 genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [CLabel])
292 genMachCode cmm_top initial_us
293 = let initial_st = mkNatM_State initial_us 0
294 (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
295 final_us = natm_us final_st
296 final_delta = natm_delta final_st
297 final_imports = natm_imports final_st
300 then ((new_tops, final_imports), final_us)
301 else pprPanic "genMachCode: nonzero final delta"
304 -- -----------------------------------------------------------------------------
305 -- Fixup assignments to global registers so that they assign to
306 -- locations within the RegTable, if appropriate.
308 -- Note that we currently don't fixup reads here: they're done by
309 -- the generic optimiser below, to avoid having two separate passes
312 fixAssignsTop :: CmmTop -> UniqSM CmmTop
313 fixAssignsTop top@(CmmData _ _) = returnUs top
314 fixAssignsTop (CmmProc info lbl params blocks) =
315 mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
316 returnUs (CmmProc info lbl params blocks')
318 fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock
319 fixAssignsBlock (BasicBlock id stmts) =
320 fixAssigns stmts `thenUs` \ stmts' ->
321 returnUs (BasicBlock id stmts')
323 fixAssigns :: [CmmStmt] -> UniqSM [CmmStmt]
325 mapUs fixAssign stmts `thenUs` \ stmtss ->
326 returnUs (concat stmtss)
328 fixAssign :: CmmStmt -> UniqSM [CmmStmt]
329 fixAssign (CmmAssign (CmmGlobal BaseReg) src)
330 = panic "cmmStmtConFold: assignment to BaseReg";
332 fixAssign (CmmAssign (CmmGlobal reg) src)
333 | Left realreg <- reg_or_addr
334 = returnUs [CmmAssign (CmmGlobal reg) src]
335 | Right baseRegAddr <- reg_or_addr
336 = returnUs [CmmStore baseRegAddr src]
337 -- Replace register leaves with appropriate StixTrees for
338 -- the given target. GlobalRegs which map to a reg on this
339 -- arch are left unchanged. Assigning to BaseReg is always
340 -- illegal, so we check for that.
342 reg_or_addr = get_GlobalReg_reg_or_addr reg
344 fixAssign (CmmCall target results args vols)
345 = mapAndUnzipUs fixResult results `thenUs` \ (results',stores) ->
346 returnUs (CmmCall target results' args vols : concat stores)
348 fixResult g@(CmmGlobal reg,hint) =
349 case get_GlobalReg_reg_or_addr reg of
350 Left realreg -> returnUs (g, [])
352 getUniqueUs `thenUs` \ uq ->
353 let local = CmmLocal (LocalReg uq (globalRegRep reg)) in
354 returnUs ((local,hint),
355 [CmmStore baseRegAddr (CmmReg local)])
359 fixAssign other_stmt = returnUs [other_stmt]
361 -- -----------------------------------------------------------------------------
362 -- Generic Cmm optimiser
368 (b) Simple inlining: a temporary which is assigned to and then
369 used, once, can be shorted.
370 (c) Replacement of references to GlobalRegs which do not have
371 machine registers by the appropriate memory load (eg.
372 Hp ==> *(BaseReg + 34) ).
373 (d) Position independent code and dynamic linking
374 (i) introduce the appropriate indirections
375 and position independent refs
376 (ii) compile a list of imported symbols
378 Ideas for other things we could do (ToDo):
380 - shortcut jumps-to-jumps
381 - eliminate dead code blocks
384 cmmToCmm :: CmmTop -> (CmmTop, [CLabel])
385 cmmToCmm top@(CmmData _ _) = (top, [])
386 cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
387 blocks' <- mapM cmmBlockConFold (cmmPeep blocks)
388 return $ CmmProc info lbl params blocks'
390 newtype CmmOptM a = CmmOptM ([CLabel] -> (# a, [CLabel] #))
392 instance Monad CmmOptM where
393 return x = CmmOptM $ \imports -> (# x,imports #)
395 CmmOptM $ \imports ->
399 CmmOptM g' -> g' imports'
401 addImportCmmOpt :: CLabel -> CmmOptM ()
402 addImportCmmOpt lbl = CmmOptM $ \imports -> (# (), lbl:imports #)
404 runCmmOpt :: CmmOptM a -> (a, [CLabel])
405 runCmmOpt (CmmOptM f) = case f [] of
406 (# result, imports #) -> (result, imports)
408 cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
409 cmmBlockConFold (BasicBlock id stmts) = do
410 stmts' <- mapM cmmStmtConFold stmts
411 return $ BasicBlock id stmts'
416 -> do src' <- cmmExprConFold False src
417 return $ case src' of
418 CmmReg reg' | reg == reg' -> CmmNop
419 new_src -> CmmAssign reg new_src
422 -> do addr' <- cmmExprConFold False addr
423 src' <- cmmExprConFold False src
424 return $ CmmStore addr' src'
427 -> do addr' <- cmmExprConFold True addr
428 return $ CmmJump addr' regs
430 CmmCall target regs args vols
431 -> do target' <- case target of
432 CmmForeignCall e conv -> do
433 e' <- cmmExprConFold True e
434 return $ CmmForeignCall e' conv
435 other -> return other
436 args' <- mapM (\(arg, hint) -> do
437 arg' <- cmmExprConFold False arg
438 return (arg', hint)) args
439 return $ CmmCall target' regs args' vols
441 CmmCondBranch test dest
442 -> do test' <- cmmExprConFold False test
443 return $ case test' of
444 CmmLit (CmmInt 0 _) ->
445 CmmComment (mkFastString ("deleted: " ++
446 showSDoc (pprStmt stmt)))
448 CmmLit (CmmInt n _) -> CmmBranch dest
449 other -> CmmCondBranch test' dest
452 -> do expr' <- cmmExprConFold False expr
453 return $ CmmSwitch expr' ids
459 cmmExprConFold isJumpTarget expr
462 -> do addr' <- cmmExprConFold False addr
463 return $ CmmLoad addr' rep
466 -- For MachOps, we first optimize the children, and then we try
467 -- our hand at some constant-folding.
468 -> do args' <- mapM (cmmExprConFold False) args
469 return $ cmmMachOpFold mop args'
471 CmmLit (CmmLabel lbl)
472 -> cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
473 CmmLit (CmmLabelOff lbl off)
474 -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
475 return $ cmmMachOpFold (MO_Add wordRep) [
477 (CmmLit $ CmmInt (fromIntegral off) wordRep)
480 #if powerpc_TARGET_ARCH
481 -- On powerpc (non-PIC), it's easier to jump directly to a label than
482 -- to use the register table, so we replace these registers
483 -- with the corresponding labels:
484 CmmReg (CmmGlobal GCEnter1)
486 -> cmmExprConFold isJumpTarget $
487 CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
488 CmmReg (CmmGlobal GCFun)
490 -> cmmExprConFold isJumpTarget $
491 CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
494 CmmReg (CmmGlobal mid)
495 -- Replace register leaves with appropriate StixTrees for
496 -- the given target. MagicIds which map to a reg on this
497 -- arch are left unchanged. For the rest, BaseReg is taken
498 -- to mean the address of the reg table in MainCapability,
499 -- and for all others we generate an indirection to its
500 -- location in the register table.
501 -> case get_GlobalReg_reg_or_addr mid of
502 Left realreg -> return expr
505 BaseReg -> cmmExprConFold False baseRegAddr
506 other -> cmmExprConFold False (CmmLoad baseRegAddr
508 -- eliminate zero offsets
510 -> cmmExprConFold False (CmmReg reg)
512 CmmRegOff (CmmGlobal mid) offset
513 -- RegOf leaves are just a shorthand form. If the reg maps
514 -- to a real reg, we keep the shorthand, otherwise, we just
515 -- expand it and defer to the above code.
516 -> case get_GlobalReg_reg_or_addr mid of
517 Left realreg -> return expr
519 -> cmmExprConFold False (CmmMachOp (MO_Add wordRep) [
520 CmmReg (CmmGlobal mid),
521 CmmLit (CmmInt (fromIntegral offset)
527 -- -----------------------------------------------------------------------------
528 -- MachOp constant folder
530 -- Now, try to constant-fold the MachOps. The arguments have already
531 -- been optimized and folded.
534 :: MachOp -- The operation from an CmmMachOp
535 -> [CmmExpr] -- The optimized arguments
538 cmmMachOpFold op arg@[CmmLit (CmmInt x rep)]
540 MO_S_Neg r -> CmmLit (CmmInt (-x) rep)
541 MO_Not r -> CmmLit (CmmInt (complement x) rep)
543 -- these are interesting: we must first narrow to the
544 -- "from" type, in order to truncate to the correct size.
545 -- The final narrow/widen to the destination type
546 -- is implicit in the CmmLit.
547 MO_S_Conv from to -> CmmLit (CmmInt (narrowS from x) to)
548 MO_U_Conv from to -> CmmLit (CmmInt (narrowU from x) to)
549 _ -> panic "cmmMachOpFold: unknown unary op"
551 -- Eliminate conversion NOPs
552 cmmMachOpFold (MO_S_Conv rep1 rep2) [x] | rep1 == rep2 = x
553 cmmMachOpFold (MO_U_Conv rep1 rep2) [x] | rep1 == rep2 = x
555 -- Eliminate nested conversions where possible
556 cmmMachOpFold conv_outer args@[CmmMachOp conv_inner [x]]
557 | Just (rep1,rep2,signed1) <- isIntConversion conv_inner,
558 Just (_, rep3,signed2) <- isIntConversion conv_outer
560 -- widen then narrow to the same size is a nop
561 _ | rep1 < rep2 && rep1 == rep3 -> x
562 -- Widen then narrow to different size: collapse to single conversion
563 -- but remember to use the signedness from the widening, just in case
564 -- the final conversion is a widen.
565 | rep1 < rep2 && rep2 > rep3 ->
566 cmmMachOpFold (intconv signed1 rep1 rep3) [x]
567 -- Nested widenings: collapse if the signedness is the same
568 | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->
569 cmmMachOpFold (intconv signed1 rep1 rep3) [x]
570 -- Nested narrowings: collapse
571 | rep1 > rep2 && rep2 > rep3 ->
572 cmmMachOpFold (MO_U_Conv rep1 rep3) [x]
574 CmmMachOp conv_outer args
576 isIntConversion (MO_U_Conv rep1 rep2) = Just (rep1,rep2,False)
577 isIntConversion (MO_S_Conv rep1 rep2) = Just (rep1,rep2,True)
578 isIntConversion _ = Nothing
580 intconv True = MO_S_Conv
581 intconv False = MO_U_Conv
583 -- ToDo: a narrow of a load can be collapsed into a narrow load, right?
584 -- but what if the architecture only supports word-sized loads, should
585 -- we do the transformation anyway?
587 cmmMachOpFold mop args@[CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
589 -- for comparisons: don't forget to narrow the arguments before
590 -- comparing, since they might be out of range.
591 MO_Eq r -> CmmLit (CmmInt (if x_u == y_u then 1 else 0) wordRep)
592 MO_Ne r -> CmmLit (CmmInt (if x_u /= y_u then 1 else 0) wordRep)
594 MO_U_Gt r -> CmmLit (CmmInt (if x_u > y_u then 1 else 0) wordRep)
595 MO_U_Ge r -> CmmLit (CmmInt (if x_u >= y_u then 1 else 0) wordRep)
596 MO_U_Lt r -> CmmLit (CmmInt (if x_u < y_u then 1 else 0) wordRep)
597 MO_U_Le r -> CmmLit (CmmInt (if x_u <= y_u then 1 else 0) wordRep)
599 MO_S_Gt r -> CmmLit (CmmInt (if x_s > y_s then 1 else 0) wordRep)
600 MO_S_Ge r -> CmmLit (CmmInt (if x_s >= y_s then 1 else 0) wordRep)
601 MO_S_Lt r -> CmmLit (CmmInt (if x_s < y_s then 1 else 0) wordRep)
602 MO_S_Le r -> CmmLit (CmmInt (if x_s <= y_s then 1 else 0) wordRep)
604 MO_Add r -> CmmLit (CmmInt (x + y) r)
605 MO_Sub r -> CmmLit (CmmInt (x - y) r)
606 MO_Mul r -> CmmLit (CmmInt (x * y) r)
607 MO_S_Quot r | y /= 0 -> CmmLit (CmmInt (x `quot` y) r)
608 MO_S_Rem r | y /= 0 -> CmmLit (CmmInt (x `rem` y) r)
610 MO_And r -> CmmLit (CmmInt (x .&. y) r)
611 MO_Or r -> CmmLit (CmmInt (x .|. y) r)
612 MO_Xor r -> CmmLit (CmmInt (x `xor` y) r)
614 MO_Shl r -> CmmLit (CmmInt (x `shiftL` fromIntegral y) r)
615 MO_U_Shr r -> CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)
616 MO_S_Shr r -> CmmLit (CmmInt (x `shiftR` fromIntegral y) r)
618 other -> CmmMachOp mop args
627 -- When possible, shift the constants to the right-hand side, so that we
628 -- can match for strength reductions. Note that the code generator will
629 -- also assume that constants have been shifted to the right when
632 cmmMachOpFold op [x@(CmmLit _), y]
633 | not (isLit y) && isCommutableMachOp op
634 = cmmMachOpFold op [y, x]
636 -- Turn (a+b)+c into a+(b+c) where possible. Because literals are
637 -- moved to the right, it is more likely that we will find
638 -- opportunities for constant folding when the expression is
641 -- ToDo: this appears to introduce a quadratic behaviour due to the
642 -- nested cmmMachOpFold. Can we fix this?
644 -- Why do we check isLit arg1? If arg1 is a lit, it means that arg2
645 -- is also a lit (otherwise arg1 would be on the right). If we
646 -- put arg1 on the left of the rearranged expression, we'll get into a
647 -- loop: (x1+x2)+x3 => x1+(x2+x3) => (x2+x3)+x1 => x2+(x3+x1) ...
649 cmmMachOpFold mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
650 | mop1 == mop2 && isAssociativeMachOp mop1 && not (isLit arg1)
651 = cmmMachOpFold mop1 [arg1, cmmMachOpFold mop2 [arg2,arg3]]
653 -- Make a RegOff if we can
654 cmmMachOpFold (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]
655 = CmmRegOff reg (fromIntegral (narrowS rep n))
656 cmmMachOpFold (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
657 = CmmRegOff reg (off + fromIntegral (narrowS rep n))
658 cmmMachOpFold (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]
659 = CmmRegOff reg (- fromIntegral (narrowS rep n))
660 cmmMachOpFold (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
661 = CmmRegOff reg (off - fromIntegral (narrowS rep n))
663 -- Fold label(+/-)offset into a CmmLit where possible
665 cmmMachOpFold (MO_Add _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
666 = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
667 cmmMachOpFold (MO_Add _) [CmmLit (CmmInt i rep), CmmLit (CmmLabel lbl)]
668 = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
669 cmmMachOpFold (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
670 = CmmLit (CmmLabelOff lbl (fromIntegral (negate (narrowU rep i))))
672 -- We can often do something with constants of 0 and 1 ...
674 cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 0 _))]
685 MO_Ne r | isComparisonExpr x -> x
686 MO_Eq r | Just x' <- maybeInvertConditionalExpr x -> x'
687 MO_U_Gt r | isComparisonExpr x -> x
688 MO_S_Gt r | isComparisonExpr x -> x
689 MO_U_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
690 MO_S_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
691 MO_U_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
692 MO_S_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
693 MO_U_Le r | Just x' <- maybeInvertConditionalExpr x -> x'
694 MO_S_Le r | Just x' <- maybeInvertConditionalExpr x -> x'
695 other -> CmmMachOp mop args
697 cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 1 rep))]
702 MO_S_Rem r -> CmmLit (CmmInt 0 rep)
703 MO_U_Rem r -> CmmLit (CmmInt 0 rep)
704 MO_Ne r | Just x' <- maybeInvertConditionalExpr x -> x'
705 MO_Eq r | isComparisonExpr x -> x
706 MO_U_Lt r | Just x' <- maybeInvertConditionalExpr x -> x'
707 MO_S_Lt r | Just x' <- maybeInvertConditionalExpr x -> x'
708 MO_U_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
709 MO_S_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
710 MO_U_Le r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
711 MO_S_Le r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
712 MO_U_Ge r | isComparisonExpr x -> x
713 MO_S_Ge r | isComparisonExpr x -> x
714 other -> CmmMachOp mop args
716 -- Now look for multiplication/division by powers of 2 (integers).
718 cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt n _))]
721 -> case exactLog2 n of
723 Just p -> CmmMachOp (MO_Shl rep) [x, CmmLit (CmmInt p rep)]
725 -> case exactLog2 n of
727 Just p -> CmmMachOp (MO_S_Shr rep) [x, CmmLit (CmmInt p rep)]
731 unchanged = CmmMachOp mop args
733 -- Anything else is just too hard.
735 cmmMachOpFold mop args = CmmMachOp mop args
737 -- -----------------------------------------------------------------------------
740 -- This algorithm for determining the $\log_2$ of exact powers of 2 comes
741 -- from GCC. It requires bit manipulation primitives, and we use GHC
742 -- extensions. Tough.
744 -- Used to be in MachInstrs --SDM.
745 -- ToDo: remove use of unboxery --SDM.
750 exactLog2 :: Integer -> Maybe Integer
752 = if (x <= 0 || x >= 2147483648) then
755 case iUnbox (fromInteger x) of { x# ->
756 if (w2i ((i2w x#) `and#` (i2w (0# -# x#))) /=# x#) then
759 Just (toInteger (iBox (pow2 x#)))
762 pow2 x# | x# ==# 1# = 0#
763 | otherwise = 1# +# pow2 (w2i (i2w x# `shiftRL#` 1#))
766 -- -----------------------------------------------------------------------------
767 -- widening / narrowing
769 narrowU :: MachRep -> Integer -> Integer
770 narrowU I8 x = fromIntegral (fromIntegral x :: Word8)
771 narrowU I16 x = fromIntegral (fromIntegral x :: Word16)
772 narrowU I32 x = fromIntegral (fromIntegral x :: Word32)
773 narrowU I64 x = fromIntegral (fromIntegral x :: Word64)
774 narrowU _ _ = panic "narrowTo"
776 narrowS :: MachRep -> Integer -> Integer
777 narrowS I8 x = fromIntegral (fromIntegral x :: Int8)
778 narrowS I16 x = fromIntegral (fromIntegral x :: Int16)
779 narrowS I32 x = fromIntegral (fromIntegral x :: Int32)
780 narrowS I64 x = fromIntegral (fromIntegral x :: Int64)
781 narrowS _ _ = panic "narrowTo"
783 -- -----------------------------------------------------------------------------
786 -- This pass inlines assignments to temporaries that are used just
787 -- once in the very next statement only. Generalising this would be
788 -- quite difficult (have to take into account aliasing of memory
789 -- writes, and so on), but at the moment it catches a number of useful
790 -- cases and lets the code generator generate much better code.
792 -- NB. This assumes that temporaries are single-assignment.
794 cmmPeep :: [CmmBasicBlock] -> [CmmBasicBlock]
795 cmmPeep blocks = map do_inline blocks
797 blockUses (BasicBlock _ stmts)
798 = foldr (plusUFM_C (+)) emptyUFM (map getStmtUses stmts)
800 uses = foldr (plusUFM_C (+)) emptyUFM (map blockUses blocks)
802 do_inline (BasicBlock id stmts)
803 = BasicBlock id (cmmMiniInline uses stmts)
806 cmmMiniInline :: UniqFM Int -> [CmmStmt] -> [CmmStmt]
807 cmmMiniInline uses [] = []
808 cmmMiniInline uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
809 | Just 1 <- lookupUFM uses u,
810 Just stmts' <- lookForInline u expr stmts
813 trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $
815 cmmMiniInline uses stmts'
817 cmmMiniInline uses (stmt:stmts)
818 = stmt : cmmMiniInline uses stmts
821 -- Try to inline a temporary assignment. We can skip over assignments to
822 -- other tempoararies, because we know that expressions aren't side-effecting
823 -- and temporaries are single-assignment.
824 lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _)) rhs) : rest)
826 = case lookupUFM (getExprUses rhs) u of
827 Just 1 -> Just (inlineStmt u expr stmt : rest)
828 _other -> case lookForInline u expr rest of
830 Just stmts -> Just (stmt:stmts)
832 lookForInline u expr (CmmNop : rest)
833 = lookForInline u expr rest
835 lookForInline u expr (stmt:stmts)
836 = case lookupUFM (getStmtUses stmt) u of
837 Just 1 -> Just (inlineStmt u expr stmt : stmts)
840 -- -----------------------------------------------------------------------------
841 -- Boring Cmm traversals for collecting usage info and substitutions.
843 getStmtUses :: CmmStmt -> UniqFM Int
844 getStmtUses (CmmAssign _ e) = getExprUses e
845 getStmtUses (CmmStore e1 e2) = plusUFM_C (+) (getExprUses e1) (getExprUses e2)
846 getStmtUses (CmmCall target _ es _)
847 = plusUFM_C (+) (uses target) (getExprsUses (map fst es))
848 where uses (CmmForeignCall e _) = getExprUses e
850 getStmtUses (CmmCondBranch e _) = getExprUses e
851 getStmtUses (CmmSwitch e _) = getExprUses e
852 getStmtUses (CmmJump e _) = getExprUses e
853 getStmtUses _ = emptyUFM
855 getExprUses :: CmmExpr -> UniqFM Int
856 getExprUses (CmmReg (CmmLocal (LocalReg u _))) = unitUFM u 1
857 getExprUses (CmmRegOff (CmmLocal (LocalReg u _)) _) = unitUFM u 1
858 getExprUses (CmmLoad e _) = getExprUses e
859 getExprUses (CmmMachOp _ es) = getExprsUses es
860 getExprUses _other = emptyUFM
862 getExprsUses es = foldr (plusUFM_C (+)) emptyUFM (map getExprUses es)
864 inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
865 inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e)
866 inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2)
867 inlineStmt u a (CmmCall target regs es vols)
868 = CmmCall (infn target) regs es' vols
869 where infn (CmmForeignCall fn cconv) = CmmForeignCall fn cconv
870 infn (CmmPrim p) = CmmPrim p
871 es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ]
872 inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d
873 inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d
874 inlineStmt u a (CmmJump e d) = CmmJump (inlineExpr u a e) d
875 inlineStmt u a other_stmt = other_stmt
877 inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr
878 inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _)))
881 inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off)
882 | u == u' = CmmMachOp (MO_Add rep) [a, CmmLit (CmmInt (fromIntegral off) rep)]
884 inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep
885 inlineExpr u a (CmmMachOp op es) = CmmMachOp op (map (inlineExpr u a) es)
886 inlineExpr u a other_expr = other_expr
888 -- -----------------------------------------------------------------------------
893 isLit (CmmLit _) = True
896 isComparisonExpr :: CmmExpr -> Bool
897 isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
898 isComparisonExpr _other = False
900 maybeInvertConditionalExpr :: CmmExpr -> Maybe CmmExpr
901 maybeInvertConditionalExpr (CmmMachOp op args)
902 | Just op' <- maybeInvertComparison op = Just (CmmMachOp op' args)
903 maybeInvertConditionalExpr _ = Nothing