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 CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_Static,
40 opt_EnsureSplittableC, 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 | opt_EnsureSplittableC = 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 -- ToDo: eliminate multiple conversions. Be careful though: can't remove
556 -- a narrowing, and can't remove conversions to/from floating point types.
558 -- ToDo: eliminate nested comparisons:
559 -- CmmMachOp MO_Lt [CmmMachOp MO_Eq [x,y], CmmLit (CmmInt 0 _)]
560 -- turns into a simple equality test.
562 cmmMachOpFold mop args@[CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
564 -- for comparisons: don't forget to narrow the arguments before
565 -- comparing, since they might be out of range.
566 MO_Eq r -> CmmLit (CmmInt (if x_u == y_u then 1 else 0) wordRep)
567 MO_Ne r -> CmmLit (CmmInt (if x_u /= y_u then 1 else 0) wordRep)
569 MO_U_Gt r -> CmmLit (CmmInt (if x_u > y_u then 1 else 0) wordRep)
570 MO_U_Ge r -> CmmLit (CmmInt (if x_u >= y_u then 1 else 0) wordRep)
571 MO_U_Lt r -> CmmLit (CmmInt (if x_u < y_u then 1 else 0) wordRep)
572 MO_U_Le r -> CmmLit (CmmInt (if x_u <= y_u then 1 else 0) wordRep)
574 MO_S_Gt r -> CmmLit (CmmInt (if x_s > y_s then 1 else 0) wordRep)
575 MO_S_Ge r -> CmmLit (CmmInt (if x_s >= y_s then 1 else 0) wordRep)
576 MO_S_Lt r -> CmmLit (CmmInt (if x_s < y_s then 1 else 0) wordRep)
577 MO_S_Le r -> CmmLit (CmmInt (if x_s <= y_s then 1 else 0) wordRep)
579 MO_Add r -> CmmLit (CmmInt (x + y) r)
580 MO_Sub r -> CmmLit (CmmInt (x - y) r)
581 MO_Mul r -> CmmLit (CmmInt (x * y) r)
582 MO_S_Quot r | y /= 0 -> CmmLit (CmmInt (x `quot` y) r)
583 MO_S_Rem r | y /= 0 -> CmmLit (CmmInt (x `rem` y) r)
585 MO_And r -> CmmLit (CmmInt (x .&. y) r)
586 MO_Or r -> CmmLit (CmmInt (x .|. y) r)
587 MO_Xor r -> CmmLit (CmmInt (x `xor` y) r)
589 MO_Shl r -> CmmLit (CmmInt (x `shiftL` fromIntegral y) r)
590 MO_U_Shr r -> CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)
591 MO_S_Shr r -> CmmLit (CmmInt (x `shiftR` fromIntegral y) r)
593 other -> CmmMachOp mop args
602 -- When possible, shift the constants to the right-hand side, so that we
603 -- can match for strength reductions. Note that the code generator will
604 -- also assume that constants have been shifted to the right when
607 cmmMachOpFold op [x@(CmmLit _), y]
608 | not (isLit y) && isCommutableMachOp op
609 = cmmMachOpFold op [y, x]
611 -- Turn (a+b)+c into a+(b+c) where possible. Because literals are
612 -- moved to the right, it is more likely that we will find
613 -- opportunities for constant folding when the expression is
616 -- ToDo: this appears to introduce a quadratic behaviour due to the
617 -- nested cmmMachOpFold. Can we fix this?
619 -- Why do we check isLit arg1? If arg1 is a lit, it means that arg2
620 -- is also a lit (otherwise arg1 would be on the right). If we
621 -- put arg1 on the left of the rearranged expression, we'll get into a
622 -- loop: (x1+x2)+x3 => x1+(x2+x3) => (x2+x3)+x1 => x2+(x3+x1) ...
624 cmmMachOpFold mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
625 | mop1 == mop2 && isAssociativeMachOp mop1 && not (isLit arg1)
626 = cmmMachOpFold mop1 [arg1, cmmMachOpFold mop2 [arg2,arg3]]
628 -- Make a RegOff if we can
629 cmmMachOpFold (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]
630 = CmmRegOff reg (fromIntegral (narrowS rep n))
631 cmmMachOpFold (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
632 = CmmRegOff reg (off + fromIntegral (narrowS rep n))
633 cmmMachOpFold (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]
634 = CmmRegOff reg (- fromIntegral (narrowS rep n))
635 cmmMachOpFold (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
636 = CmmRegOff reg (off - fromIntegral (narrowS rep n))
638 -- Fold label(+/-)offset into a CmmLit where possible
640 cmmMachOpFold (MO_Add _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
641 = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
642 cmmMachOpFold (MO_Add _) [CmmLit (CmmInt i rep), CmmLit (CmmLabel lbl)]
643 = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
644 cmmMachOpFold (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
645 = CmmLit (CmmLabelOff lbl (fromIntegral (negate (narrowU rep i))))
647 -- We can often do something with constants of 0 and 1 ...
649 cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 0 _))]
660 MO_Ne r | isComparisonExpr x -> x
661 MO_Eq r | Just x' <- maybeInvertConditionalExpr x -> x'
662 MO_U_Gt r | isComparisonExpr x -> x
663 MO_S_Gt r | isComparisonExpr x -> x
664 MO_U_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
665 MO_S_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
666 MO_U_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
667 MO_S_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
668 MO_U_Le r | Just x' <- maybeInvertConditionalExpr x -> x'
669 MO_S_Le r | Just x' <- maybeInvertConditionalExpr x -> x'
670 other -> CmmMachOp mop args
672 cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 1 rep))]
677 MO_S_Rem r -> CmmLit (CmmInt 0 rep)
678 MO_U_Rem r -> CmmLit (CmmInt 0 rep)
679 MO_Ne r | Just x' <- maybeInvertConditionalExpr x -> x'
680 MO_Eq r | isComparisonExpr x -> x
681 MO_U_Lt r | Just x' <- maybeInvertConditionalExpr x -> x'
682 MO_S_Lt r | Just x' <- maybeInvertConditionalExpr x -> x'
683 MO_U_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
684 MO_S_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
685 MO_U_Le r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
686 MO_S_Le r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
687 MO_U_Ge r | isComparisonExpr x -> x
688 MO_S_Ge r | isComparisonExpr x -> x
689 other -> CmmMachOp mop args
691 -- Now look for multiplication/division by powers of 2 (integers).
693 cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt n _))]
696 -> case exactLog2 n of
698 Just p -> CmmMachOp (MO_Shl rep) [x, CmmLit (CmmInt p rep)]
700 -> case exactLog2 n of
702 Just p -> CmmMachOp (MO_S_Shr rep) [x, CmmLit (CmmInt p rep)]
706 unchanged = CmmMachOp mop args
708 -- Anything else is just too hard.
710 cmmMachOpFold mop args = CmmMachOp mop args
712 -- -----------------------------------------------------------------------------
715 -- This algorithm for determining the $\log_2$ of exact powers of 2 comes
716 -- from GCC. It requires bit manipulation primitives, and we use GHC
717 -- extensions. Tough.
719 -- Used to be in MachInstrs --SDM.
720 -- ToDo: remove use of unboxery --SDM.
725 exactLog2 :: Integer -> Maybe Integer
727 = if (x <= 0 || x >= 2147483648) then
730 case iUnbox (fromInteger x) of { x# ->
731 if (w2i ((i2w x#) `and#` (i2w (0# -# x#))) /=# x#) then
734 Just (toInteger (iBox (pow2 x#)))
737 pow2 x# | x# ==# 1# = 0#
738 | otherwise = 1# +# pow2 (w2i (i2w x# `shiftRL#` 1#))
741 -- -----------------------------------------------------------------------------
742 -- widening / narrowing
744 narrowU :: MachRep -> Integer -> Integer
745 narrowU I8 x = fromIntegral (fromIntegral x :: Word8)
746 narrowU I16 x = fromIntegral (fromIntegral x :: Word16)
747 narrowU I32 x = fromIntegral (fromIntegral x :: Word32)
748 narrowU I64 x = fromIntegral (fromIntegral x :: Word64)
749 narrowU _ _ = panic "narrowTo"
751 narrowS :: MachRep -> Integer -> Integer
752 narrowS I8 x = fromIntegral (fromIntegral x :: Int8)
753 narrowS I16 x = fromIntegral (fromIntegral x :: Int16)
754 narrowS I32 x = fromIntegral (fromIntegral x :: Int32)
755 narrowS I64 x = fromIntegral (fromIntegral x :: Int64)
756 narrowS _ _ = panic "narrowTo"
758 -- -----------------------------------------------------------------------------
761 -- This pass inlines assignments to temporaries that are used just
762 -- once in the very next statement only. Generalising this would be
763 -- quite difficult (have to take into account aliasing of memory
764 -- writes, and so on), but at the moment it catches a number of useful
765 -- cases and lets the code generator generate much better code.
767 -- NB. This assumes that temporaries are single-assignment.
769 cmmPeep :: [CmmBasicBlock] -> [CmmBasicBlock]
770 cmmPeep blocks = map do_inline blocks
772 blockUses (BasicBlock _ stmts)
773 = foldr (plusUFM_C (+)) emptyUFM (map getStmtUses stmts)
775 uses = foldr (plusUFM_C (+)) emptyUFM (map blockUses blocks)
777 do_inline (BasicBlock id stmts)
778 = BasicBlock id (cmmMiniInline uses stmts)
781 cmmMiniInline :: UniqFM Int -> [CmmStmt] -> [CmmStmt]
782 cmmMiniInline uses [] = []
783 cmmMiniInline uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
784 | Just 1 <- lookupUFM uses u,
785 Just stmts' <- lookForInline u expr stmts
788 trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $
790 cmmMiniInline uses stmts'
792 cmmMiniInline uses (stmt:stmts)
793 = stmt : cmmMiniInline uses stmts
796 -- Try to inline a temporary assignment. We can skip over assignments to
797 -- other tempoararies, because we know that expressions aren't side-effecting
798 -- and temporaries are single-assignment.
799 lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _)) rhs) : rest)
801 = case lookupUFM (getExprUses rhs) u of
802 Just 1 -> Just (inlineStmt u expr stmt : rest)
803 _other -> case lookForInline u expr rest of
805 Just stmts -> Just (stmt:stmts)
807 lookForInline u expr (CmmNop : rest)
808 = lookForInline u expr rest
810 lookForInline u expr (stmt:stmts)
811 = case lookupUFM (getStmtUses stmt) u of
812 Just 1 -> Just (inlineStmt u expr stmt : stmts)
815 -- -----------------------------------------------------------------------------
816 -- Boring Cmm traversals for collecting usage info and substitutions.
818 getStmtUses :: CmmStmt -> UniqFM Int
819 getStmtUses (CmmAssign _ e) = getExprUses e
820 getStmtUses (CmmStore e1 e2) = plusUFM_C (+) (getExprUses e1) (getExprUses e2)
821 getStmtUses (CmmCall target _ es _)
822 = plusUFM_C (+) (uses target) (getExprsUses (map fst es))
823 where uses (CmmForeignCall e _) = getExprUses e
825 getStmtUses (CmmCondBranch e _) = getExprUses e
826 getStmtUses (CmmSwitch e _) = getExprUses e
827 getStmtUses (CmmJump e _) = getExprUses e
828 getStmtUses _ = emptyUFM
830 getExprUses :: CmmExpr -> UniqFM Int
831 getExprUses (CmmReg (CmmLocal (LocalReg u _))) = unitUFM u 1
832 getExprUses (CmmRegOff (CmmLocal (LocalReg u _)) _) = unitUFM u 1
833 getExprUses (CmmLoad e _) = getExprUses e
834 getExprUses (CmmMachOp _ es) = getExprsUses es
835 getExprUses _other = emptyUFM
837 getExprsUses es = foldr (plusUFM_C (+)) emptyUFM (map getExprUses es)
839 inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
840 inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e)
841 inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2)
842 inlineStmt u a (CmmCall target regs es vols)
843 = CmmCall (infn target) regs es' vols
844 where infn (CmmForeignCall fn cconv) = CmmForeignCall fn cconv
845 infn (CmmPrim p) = CmmPrim p
846 es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ]
847 inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d
848 inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d
849 inlineStmt u a (CmmJump e d) = CmmJump (inlineExpr u a e) d
850 inlineStmt u a other_stmt = other_stmt
852 inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr
853 inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _)))
856 inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off)
857 | u == u' = CmmMachOp (MO_Add rep) [a, CmmLit (CmmInt (fromIntegral off) rep)]
859 inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep
860 inlineExpr u a (CmmMachOp op es) = CmmMachOp op (map (inlineExpr u a) es)
861 inlineExpr u a other_expr = other_expr
863 -- -----------------------------------------------------------------------------
868 isLit (CmmLit _) = True
871 isComparisonExpr :: CmmExpr -> Bool
872 isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
873 isComparisonExpr _other = False
875 maybeInvertConditionalExpr :: CmmExpr -> Maybe CmmExpr
876 maybeInvertConditionalExpr (CmmMachOp op args)
877 | Just op' <- maybeInvertComparison op = Just (CmmMachOp op' args)
878 maybeInvertConditionalExpr _ = Nothing