Stop exporting, and stop using, functions marked as deprecated
[ghc.git] / compiler / nativeGen / PPC / Instr.hs
1 {-# LANGUAGE CPP #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Machine-dependent assembly language
6 --
7 -- (c) The University of Glasgow 1993-2004
8 --
9 -----------------------------------------------------------------------------
10
11 #include "HsVersions.h"
12 #include "nativeGen/NCG.h"
13
14 module PPC.Instr (
15 archWordSize,
16 RI(..),
17 Instr(..),
18 maxSpillSlots,
19 allocMoreStack,
20 makeFarBranches
21 )
22
23 where
24
25 import PPC.Regs
26 import PPC.Cond
27 import Instruction
28 import Size
29 import TargetReg
30 import RegClass
31 import Reg
32
33 import CodeGen.Platform
34 import BlockId
35 import DynFlags
36 import Cmm
37 import CmmInfo
38 import FastString
39 import CLabel
40 import Outputable
41 import Platform
42 import FastBool
43 import UniqFM (listToUFM, lookupUFM)
44 import UniqSupply
45
46 import Control.Monad (replicateM)
47 import Data.Maybe (fromMaybe)
48
49 --------------------------------------------------------------------------------
50 -- Size of a PPC memory address, in bytes.
51 --
52 archWordSize :: Size
53 archWordSize = II32
54
55
56 -- | Instruction instance for powerpc
57 instance Instruction Instr where
58 regUsageOfInstr = ppc_regUsageOfInstr
59 patchRegsOfInstr = ppc_patchRegsOfInstr
60 isJumpishInstr = ppc_isJumpishInstr
61 jumpDestsOfInstr = ppc_jumpDestsOfInstr
62 patchJumpInstr = ppc_patchJumpInstr
63 mkSpillInstr = ppc_mkSpillInstr
64 mkLoadInstr = ppc_mkLoadInstr
65 takeDeltaInstr = ppc_takeDeltaInstr
66 isMetaInstr = ppc_isMetaInstr
67 mkRegRegMoveInstr _ = ppc_mkRegRegMoveInstr
68 takeRegRegMoveInstr = ppc_takeRegRegMoveInstr
69 mkJumpInstr = ppc_mkJumpInstr
70 mkStackAllocInstr = ppc_mkStackAllocInstr
71 mkStackDeallocInstr = ppc_mkStackDeallocInstr
72
73
74 ppc_mkStackAllocInstr :: Platform -> Int -> Instr
75 ppc_mkStackAllocInstr platform amount
76 = case platformArch platform of
77 ArchPPC -> -- SUB II32 (OpImm (ImmInt amount)) (OpReg esp)
78 ADD sp sp (RIImm (ImmInt (-amount)))
79 arch -> panic $ "ppc_mkStackAllocInstr " ++ show arch
80
81 ppc_mkStackDeallocInstr :: Platform -> Int -> Instr
82 ppc_mkStackDeallocInstr platform amount
83 = case platformArch platform of
84 ArchPPC -> -- ADD II32 (OpImm (ImmInt amount)) (OpReg esp)
85 ADD sp sp (RIImm (ImmInt amount))
86 arch -> panic $ "ppc_mkStackDeallocInstr " ++ show arch
87
88 --
89 -- See note [extra spill slots] in X86/Instr.hs
90 --
91 allocMoreStack
92 :: Platform
93 -> Int
94 -> NatCmmDecl statics PPC.Instr.Instr
95 -> UniqSM (NatCmmDecl statics PPC.Instr.Instr)
96
97 allocMoreStack _ _ top@(CmmData _ _) = return top
98 allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do
99 let
100 infos = mapKeys info
101 entries = case code of
102 [] -> infos
103 BasicBlock entry _ : _ -- first block is the entry point
104 | entry `elem` infos -> infos
105 | otherwise -> entry : infos
106
107 uniqs <- replicateM (length entries) getUniqueM
108
109 let
110 delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up
111 where x = slots * spillSlotSize -- sp delta
112
113 alloc = mkStackAllocInstr platform delta
114 dealloc = mkStackDeallocInstr platform delta
115
116 new_blockmap :: BlockEnv BlockId
117 new_blockmap = mapFromList (zip entries (map mkBlockId uniqs))
118
119 insert_stack_insns (BasicBlock id insns)
120 | Just new_blockid <- mapLookup id new_blockmap
121 = [ BasicBlock id [alloc, BCC ALWAYS new_blockid]
122 , BasicBlock new_blockid block'
123 ]
124 | otherwise
125 = [ BasicBlock id block' ]
126 where
127 block' = foldr insert_dealloc [] insns
128
129 insert_dealloc insn r
130 -- BCTR might or might not be a non-local jump. For
131 -- "labeled-goto" we use JMP, and for "computed-goto" we
132 -- use MTCTR followed by BCTR. See 'PPC.CodeGen.genJump'.
133 = case insn of
134 JMP _ -> dealloc : insn : r
135 BCTR [] Nothing -> dealloc : insn : r
136 BCTR ids label -> BCTR (map (fmap retarget) ids) label : r
137 BCCFAR cond b -> BCCFAR cond (retarget b) : r
138 BCC cond b -> BCC cond (retarget b) : r
139 _ -> insn : r
140 -- BL and BCTRL are call-like instructions rather than
141 -- jumps, and are used only for C calls.
142
143 retarget :: BlockId -> BlockId
144 retarget b
145 = fromMaybe b (mapLookup b new_blockmap)
146
147 new_code
148 = concatMap insert_stack_insns code
149
150 -- in
151 return (CmmProc info lbl live (ListGraph new_code))
152
153
154 -- -----------------------------------------------------------------------------
155 -- Machine's assembly language
156
157 -- We have a few common "instructions" (nearly all the pseudo-ops) but
158 -- mostly all of 'Instr' is machine-specific.
159
160 -- Register or immediate
161 data RI
162 = RIReg Reg
163 | RIImm Imm
164
165 data Instr
166 -- comment pseudo-op
167 = COMMENT FastString
168
169 -- some static data spat out during code
170 -- generation. Will be extracted before
171 -- pretty-printing.
172 | LDATA Section CmmStatics
173
174 -- start a new basic block. Useful during
175 -- codegen, removed later. Preceding
176 -- instruction should be a jump, as per the
177 -- invariants for a BasicBlock (see Cmm).
178 | NEWBLOCK BlockId
179
180 -- specify current stack offset for
181 -- benefit of subsequent passes
182 | DELTA Int
183
184 -- Loads and stores.
185 | LD Size Reg AddrMode -- Load size, dst, src
186 | LA Size Reg AddrMode -- Load arithmetic size, dst, src
187 | ST Size Reg AddrMode -- Store size, src, dst
188 | STU Size Reg AddrMode -- Store with Update size, src, dst
189 | LIS Reg Imm -- Load Immediate Shifted dst, src
190 | LI Reg Imm -- Load Immediate dst, src
191 | MR Reg Reg -- Move Register dst, src -- also for fmr
192
193 | CMP Size Reg RI -- size, src1, src2
194 | CMPL Size Reg RI -- size, src1, src2
195
196 | BCC Cond BlockId
197 | BCCFAR Cond BlockId
198 | JMP CLabel -- same as branch,
199 -- but with CLabel instead of block ID
200 | MTCTR Reg
201 | BCTR [Maybe BlockId] (Maybe CLabel) -- with list of local destinations, and jump table location if necessary
202 | BL CLabel [Reg] -- with list of argument regs
203 | BCTRL [Reg]
204
205 | ADD Reg Reg RI -- dst, src1, src2
206 | ADDC Reg Reg Reg -- (carrying) dst, src1, src2
207 | ADDE Reg Reg Reg -- (extend) dst, src1, src2
208 | ADDIS Reg Reg Imm -- Add Immediate Shifted dst, src1, src2
209 | SUBF Reg Reg Reg -- dst, src1, src2 ; dst = src2 - src1
210 | MULLW Reg Reg RI
211 | DIVW Reg Reg Reg
212 | DIVWU Reg Reg Reg
213
214 | MULLW_MayOflo Reg Reg Reg
215 -- dst = 1 if src1 * src2 overflows
216 -- pseudo-instruction; pretty-printed as:
217 -- mullwo. dst, src1, src2
218 -- mfxer dst
219 -- rlwinm dst, dst, 2, 31,31
220
221 | AND Reg Reg RI -- dst, src1, src2
222 | OR Reg Reg RI -- dst, src1, src2
223 | XOR Reg Reg RI -- dst, src1, src2
224 | XORIS Reg Reg Imm -- XOR Immediate Shifted dst, src1, src2
225
226 | EXTS Size Reg Reg
227
228 | NEG Reg Reg
229 | NOT Reg Reg
230
231 | SLW Reg Reg RI -- shift left word
232 | SRW Reg Reg RI -- shift right word
233 | SRAW Reg Reg RI -- shift right arithmetic word
234
235 | RLWINM Reg Reg Int Int Int -- Rotate Left Word Immediate then AND with Mask
236
237 | FADD Size Reg Reg Reg
238 | FSUB Size Reg Reg Reg
239 | FMUL Size Reg Reg Reg
240 | FDIV Size Reg Reg Reg
241 | FNEG Reg Reg -- negate is the same for single and double prec.
242
243 | FCMP Reg Reg
244
245 | FCTIWZ Reg Reg -- convert to integer word
246 | FRSP Reg Reg -- reduce to single precision
247 -- (but destination is a FP register)
248
249 | CRNOR Int Int Int -- condition register nor
250 | MFCR Reg -- move from condition register
251
252 | MFLR Reg -- move from link register
253 | FETCHPC Reg -- pseudo-instruction:
254 -- bcl to next insn, mflr reg
255
256 | LWSYNC -- memory barrier
257
258
259 -- | Get the registers that are being used by this instruction.
260 -- regUsage doesn't need to do any trickery for jumps and such.
261 -- Just state precisely the regs read and written by that insn.
262 -- The consequences of control flow transfers, as far as register
263 -- allocation goes, are taken care of by the register allocator.
264 --
265 ppc_regUsageOfInstr :: Platform -> Instr -> RegUsage
266 ppc_regUsageOfInstr platform instr
267 = case instr of
268 LD _ reg addr -> usage (regAddr addr, [reg])
269 LA _ reg addr -> usage (regAddr addr, [reg])
270 ST _ reg addr -> usage (reg : regAddr addr, [])
271 STU _ reg addr -> usage (reg : regAddr addr, [])
272 LIS reg _ -> usage ([], [reg])
273 LI reg _ -> usage ([], [reg])
274 MR reg1 reg2 -> usage ([reg2], [reg1])
275 CMP _ reg ri -> usage (reg : regRI ri,[])
276 CMPL _ reg ri -> usage (reg : regRI ri,[])
277 BCC _ _ -> noUsage
278 BCCFAR _ _ -> noUsage
279 MTCTR reg -> usage ([reg],[])
280 BCTR _ _ -> noUsage
281 BL _ params -> usage (params, callClobberedRegs platform)
282 BCTRL params -> usage (params, callClobberedRegs platform)
283
284 ADD reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
285 ADDC reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
286 ADDE reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
287 ADDIS reg1 reg2 _ -> usage ([reg2], [reg1])
288 SUBF reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
289 MULLW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
290 DIVW reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
291 DIVWU reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
292
293 MULLW_MayOflo reg1 reg2 reg3
294 -> usage ([reg2,reg3], [reg1])
295 AND reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
296 OR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
297 XOR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
298 XORIS reg1 reg2 _ -> usage ([reg2], [reg1])
299 EXTS _ reg1 reg2 -> usage ([reg2], [reg1])
300 NEG reg1 reg2 -> usage ([reg2], [reg1])
301 NOT reg1 reg2 -> usage ([reg2], [reg1])
302 SLW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
303 SRW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
304 SRAW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
305 RLWINM reg1 reg2 _ _ _ -> usage ([reg2], [reg1])
306
307 FADD _ r1 r2 r3 -> usage ([r2,r3], [r1])
308 FSUB _ r1 r2 r3 -> usage ([r2,r3], [r1])
309 FMUL _ r1 r2 r3 -> usage ([r2,r3], [r1])
310 FDIV _ r1 r2 r3 -> usage ([r2,r3], [r1])
311 FNEG r1 r2 -> usage ([r2], [r1])
312 FCMP r1 r2 -> usage ([r1,r2], [])
313 FCTIWZ r1 r2 -> usage ([r2], [r1])
314 FRSP r1 r2 -> usage ([r2], [r1])
315 MFCR reg -> usage ([], [reg])
316 MFLR reg -> usage ([], [reg])
317 FETCHPC reg -> usage ([], [reg])
318 _ -> noUsage
319 where
320 usage (src, dst) = RU (filter (interesting platform) src)
321 (filter (interesting platform) dst)
322 regAddr (AddrRegReg r1 r2) = [r1, r2]
323 regAddr (AddrRegImm r1 _) = [r1]
324
325 regRI (RIReg r) = [r]
326 regRI _ = []
327
328 interesting :: Platform -> Reg -> Bool
329 interesting _ (RegVirtual _) = True
330 interesting platform (RegReal (RealRegSingle i))
331 = isFastTrue (freeReg platform i)
332
333 interesting _ (RegReal (RealRegPair{}))
334 = panic "PPC.Instr.interesting: no reg pairs on this arch"
335
336
337
338 -- | Apply a given mapping to all the register references in this
339 -- instruction.
340 ppc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
341 ppc_patchRegsOfInstr instr env
342 = case instr of
343 LD sz reg addr -> LD sz (env reg) (fixAddr addr)
344 LA sz reg addr -> LA sz (env reg) (fixAddr addr)
345 ST sz reg addr -> ST sz (env reg) (fixAddr addr)
346 STU sz reg addr -> STU sz (env reg) (fixAddr addr)
347 LIS reg imm -> LIS (env reg) imm
348 LI reg imm -> LI (env reg) imm
349 MR reg1 reg2 -> MR (env reg1) (env reg2)
350 CMP sz reg ri -> CMP sz (env reg) (fixRI ri)
351 CMPL sz reg ri -> CMPL sz (env reg) (fixRI ri)
352 BCC cond lbl -> BCC cond lbl
353 BCCFAR cond lbl -> BCCFAR cond lbl
354 MTCTR reg -> MTCTR (env reg)
355 BCTR targets lbl -> BCTR targets lbl
356 BL imm argRegs -> BL imm argRegs -- argument regs
357 BCTRL argRegs -> BCTRL argRegs -- cannot be remapped
358 ADD reg1 reg2 ri -> ADD (env reg1) (env reg2) (fixRI ri)
359 ADDC reg1 reg2 reg3 -> ADDC (env reg1) (env reg2) (env reg3)
360 ADDE reg1 reg2 reg3 -> ADDE (env reg1) (env reg2) (env reg3)
361 ADDIS reg1 reg2 imm -> ADDIS (env reg1) (env reg2) imm
362 SUBF reg1 reg2 reg3 -> SUBF (env reg1) (env reg2) (env reg3)
363 MULLW reg1 reg2 ri -> MULLW (env reg1) (env reg2) (fixRI ri)
364 DIVW reg1 reg2 reg3 -> DIVW (env reg1) (env reg2) (env reg3)
365 DIVWU reg1 reg2 reg3 -> DIVWU (env reg1) (env reg2) (env reg3)
366 MULLW_MayOflo reg1 reg2 reg3
367 -> MULLW_MayOflo (env reg1) (env reg2) (env reg3)
368 AND reg1 reg2 ri -> AND (env reg1) (env reg2) (fixRI ri)
369 OR reg1 reg2 ri -> OR (env reg1) (env reg2) (fixRI ri)
370 XOR reg1 reg2 ri -> XOR (env reg1) (env reg2) (fixRI ri)
371 XORIS reg1 reg2 imm -> XORIS (env reg1) (env reg2) imm
372 EXTS sz reg1 reg2 -> EXTS sz (env reg1) (env reg2)
373 NEG reg1 reg2 -> NEG (env reg1) (env reg2)
374 NOT reg1 reg2 -> NOT (env reg1) (env reg2)
375 SLW reg1 reg2 ri -> SLW (env reg1) (env reg2) (fixRI ri)
376 SRW reg1 reg2 ri -> SRW (env reg1) (env reg2) (fixRI ri)
377 SRAW reg1 reg2 ri -> SRAW (env reg1) (env reg2) (fixRI ri)
378 RLWINM reg1 reg2 sh mb me
379 -> RLWINM (env reg1) (env reg2) sh mb me
380 FADD sz r1 r2 r3 -> FADD sz (env r1) (env r2) (env r3)
381 FSUB sz r1 r2 r3 -> FSUB sz (env r1) (env r2) (env r3)
382 FMUL sz r1 r2 r3 -> FMUL sz (env r1) (env r2) (env r3)
383 FDIV sz r1 r2 r3 -> FDIV sz (env r1) (env r2) (env r3)
384 FNEG r1 r2 -> FNEG (env r1) (env r2)
385 FCMP r1 r2 -> FCMP (env r1) (env r2)
386 FCTIWZ r1 r2 -> FCTIWZ (env r1) (env r2)
387 FRSP r1 r2 -> FRSP (env r1) (env r2)
388 MFCR reg -> MFCR (env reg)
389 MFLR reg -> MFLR (env reg)
390 FETCHPC reg -> FETCHPC (env reg)
391 _ -> instr
392 where
393 fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)
394 fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i
395
396 fixRI (RIReg r) = RIReg (env r)
397 fixRI other = other
398
399
400 --------------------------------------------------------------------------------
401 -- | Checks whether this instruction is a jump/branch instruction.
402 -- One that can change the flow of control in a way that the
403 -- register allocator needs to worry about.
404 ppc_isJumpishInstr :: Instr -> Bool
405 ppc_isJumpishInstr instr
406 = case instr of
407 BCC{} -> True
408 BCCFAR{} -> True
409 BCTR{} -> True
410 BCTRL{} -> True
411 BL{} -> True
412 JMP{} -> True
413 _ -> False
414
415
416 -- | Checks whether this instruction is a jump/branch instruction.
417 -- One that can change the flow of control in a way that the
418 -- register allocator needs to worry about.
419 ppc_jumpDestsOfInstr :: Instr -> [BlockId]
420 ppc_jumpDestsOfInstr insn
421 = case insn of
422 BCC _ id -> [id]
423 BCCFAR _ id -> [id]
424 BCTR targets _ -> [id | Just id <- targets]
425 _ -> []
426
427
428 -- | Change the destination of this jump instruction.
429 -- Used in the linear allocator when adding fixup blocks for join
430 -- points.
431 ppc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
432 ppc_patchJumpInstr insn patchF
433 = case insn of
434 BCC cc id -> BCC cc (patchF id)
435 BCCFAR cc id -> BCCFAR cc (patchF id)
436 BCTR ids lbl -> BCTR (map (fmap patchF) ids) lbl
437 _ -> insn
438
439
440 -- -----------------------------------------------------------------------------
441
442 -- | An instruction to spill a register into a spill slot.
443 ppc_mkSpillInstr
444 :: DynFlags
445 -> Reg -- register to spill
446 -> Int -- current stack delta
447 -> Int -- spill slot to use
448 -> Instr
449
450 ppc_mkSpillInstr dflags reg delta slot
451 = let platform = targetPlatform dflags
452 off = spillSlotToOffset slot
453 in
454 let sz = case targetClassOfReg platform reg of
455 RcInteger -> II32
456 RcDouble -> FF64
457 _ -> panic "PPC.Instr.mkSpillInstr: no match"
458 in ST sz reg (AddrRegImm sp (ImmInt (off-delta)))
459
460
461 ppc_mkLoadInstr
462 :: DynFlags
463 -> Reg -- register to load
464 -> Int -- current stack delta
465 -> Int -- spill slot to use
466 -> Instr
467
468 ppc_mkLoadInstr dflags reg delta slot
469 = let platform = targetPlatform dflags
470 off = spillSlotToOffset slot
471 in
472 let sz = case targetClassOfReg platform reg of
473 RcInteger -> II32
474 RcDouble -> FF64
475 _ -> panic "PPC.Instr.mkLoadInstr: no match"
476 in LD sz reg (AddrRegImm sp (ImmInt (off-delta)))
477
478
479 -- | The maximum number of bytes required to spill a register. PPC32
480 -- has 32-bit GPRs and 64-bit FPRs, while PPC64 has 64-bit GPRs and
481 -- 64-bit FPRs. So the maximum is 8 regardless of platforms unlike
482 -- x86. Note that AltiVec's vector registers are 128-bit wide so we
483 -- must not use this to spill them.
484 spillSlotSize :: Int
485 spillSlotSize = 8
486
487 -- | The number of spill slots available without allocating more.
488 maxSpillSlots :: DynFlags -> Int
489 maxSpillSlots dflags
490 = ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize) - 1
491 -- = 0 -- useful for testing allocMoreStack
492
493 -- | The number of bytes that the stack pointer should be aligned
494 -- to. This is 16 both on PPC32 and PPC64 at least for Darwin, but I'm
495 -- not sure this is correct for other OSes.
496 stackAlign :: Int
497 stackAlign = 16
498
499 -- | Convert a spill slot number to a *byte* offset, with no sign.
500 spillSlotToOffset :: Int -> Int
501 spillSlotToOffset slot
502 = 64 + spillSlotSize * slot
503
504
505 --------------------------------------------------------------------------------
506 -- | See if this instruction is telling us the current C stack delta
507 ppc_takeDeltaInstr
508 :: Instr
509 -> Maybe Int
510
511 ppc_takeDeltaInstr instr
512 = case instr of
513 DELTA i -> Just i
514 _ -> Nothing
515
516
517 ppc_isMetaInstr
518 :: Instr
519 -> Bool
520
521 ppc_isMetaInstr instr
522 = case instr of
523 COMMENT{} -> True
524 LDATA{} -> True
525 NEWBLOCK{} -> True
526 DELTA{} -> True
527 _ -> False
528
529
530 -- | Copy the value in a register to another one.
531 -- Must work for all register classes.
532 ppc_mkRegRegMoveInstr
533 :: Reg
534 -> Reg
535 -> Instr
536
537 ppc_mkRegRegMoveInstr src dst
538 = MR dst src
539
540
541 -- | Make an unconditional jump instruction.
542 -- For architectures with branch delay slots, its ok to put
543 -- a NOP after the jump. Don't fill the delay slot with an
544 -- instruction that references regs or you'll confuse the
545 -- linear allocator.
546 ppc_mkJumpInstr
547 :: BlockId
548 -> [Instr]
549
550 ppc_mkJumpInstr id
551 = [BCC ALWAYS id]
552
553
554 -- | Take the source and destination from this reg -> reg move instruction
555 -- or Nothing if it's not one
556 ppc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)
557 ppc_takeRegRegMoveInstr (MR dst src) = Just (src,dst)
558 ppc_takeRegRegMoveInstr _ = Nothing
559
560 -- -----------------------------------------------------------------------------
561 -- Making far branches
562
563 -- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
564 -- big, we have to work around this limitation.
565
566 makeFarBranches
567 :: BlockEnv CmmStatics
568 -> [NatBasicBlock Instr]
569 -> [NatBasicBlock Instr]
570 makeFarBranches info_env blocks
571 | last blockAddresses < nearLimit = blocks
572 | otherwise = zipWith handleBlock blockAddresses blocks
573 where
574 blockAddresses = scanl (+) 0 $ map blockLen blocks
575 blockLen (BasicBlock _ instrs) = length instrs
576
577 handleBlock addr (BasicBlock id instrs)
578 = BasicBlock id (zipWith makeFar [addr..] instrs)
579
580 makeFar _ (BCC ALWAYS tgt) = BCC ALWAYS tgt
581 makeFar addr (BCC cond tgt)
582 | abs (addr - targetAddr) >= nearLimit
583 = BCCFAR cond tgt
584 | otherwise
585 = BCC cond tgt
586 where Just targetAddr = lookupUFM blockAddressMap tgt
587 makeFar _ other = other
588
589 -- 8192 instructions are allowed; let's keep some distance, as
590 -- we have a few pseudo-insns that are pretty-printed as
591 -- multiple instructions, and it's just not worth the effort
592 -- to calculate things exactly
593 nearLimit = 7000 - mapSize info_env * maxRetInfoTableSizeW
594
595 blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses