RegAllocLinear.hs 36.6 KB
Newer Older
1
{-# OPTIONS -fno-warn-missing-signatures #-}
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
-----------------------------------------------------------------------------
--
-- The register allocator
--
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------

{-
The algorithm is roughly:
 
  1) Compute strongly connected components of the basic block list.

  2) Compute liveness (mapping from pseudo register to
     point(s) of death?).

  3) Walk instructions in each basic block.  We keep track of
	(a) Free real registers (a bitmap?)
	(b) Current assignment of temporaries to machine registers and/or
	    spill slots (call this the "assignment").
     	(c) Partial mapping from basic block ids to a virt-to-loc mapping.
	    When we first encounter a branch to a basic block,
	    we fill in its entry in this table with the current mapping.

     For each instruction:
	(a) For each real register clobbered by this instruction:
	    If a temporary resides in it,
		If the temporary is live after this instruction,
		    Move the temporary to another (non-clobbered & free) reg,
		    or spill it to memory.  Mark the temporary as residing
		    in both memory and a register if it was spilled (it might
		    need to be read by this instruction).
	    (ToDo: this is wrong for jump instructions?)

	(b) For each temporary *read* by the instruction:
	    If the temporary does not have a real register allocation:
		- Allocate a real register from the free list.  If
		  the list is empty:
		  - Find a temporary to spill.  Pick one that is
		    not used in this instruction (ToDo: not
		    used for a while...)
		  - generate a spill instruction
		- If the temporary was previously spilled,
		  generate an instruction to read the temp from its spill loc.
	    (optimisation: if we can see that a real register is going to
            be used soon, then don't use it for allocation).

	(c) Update the current assignment

	(d) If the intstruction is a branch:
	      if the destination block already has a register assignment,
	        Generate a new block with fixup code and redirect the
		jump to the new block.
	      else,
		Update the block id->assignment mapping with the current
		assignment.

	(e) Delete all register assignments for temps which are read
	    (only) and die here.  Update the free register list.

	(f) Mark all registers clobbered by this instruction as not free,
	    and mark temporaries which have been spilled due to clobbering
	    as in memory (step (a) marks then as in both mem & reg).

66
	(g) For each temporary *written* by this instruction:
67
68
	    Allocate a real register as for (b), spilling something
	    else if necessary.
69
70
71
		- except when updating the assignment, drop any memory
		  locations that the temporary was previously in, since
		  they will be no longer valid after this instruction.
72
73
74
75
76
77
78
79
80
81
82
83

	(h) Delete all register assignments for temps which are
	    written and die here (there should rarely be any).  Update
	    the free register list.

	(i) Rewrite the instruction with the new mapping.

	(j) For each spilled reg known to be now dead, re-add its stack slot
	    to the free list.

-}

84
module RegAllocLinear (
85
  	regAlloc,
86
	RegAllocStats, pprStats
87
88
89
90
  ) where

#include "HsVersions.h"

91
import BlockId
92
93
94
import MachRegs
import MachInstrs
import RegAllocInfo
95
import RegLiveness
96
import Cmm hiding (RegSet)
97
98

import Digraph
99
import Unique		( Uniquable(getUnique), Unique )
100
import UniqSet
101
import UniqFM
102
import UniqSupply
103
import Outputable
104
import State
105
import FastString
106

107
108
109
import Data.Maybe
import Data.List
import Control.Monad
Simon Marlow's avatar
Simon Marlow committed
110
111
import Data.Word
import Data.Bits
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142


-- -----------------------------------------------------------------------------
-- The free register set

-- This needs to be *efficient*

{- Here's an inefficient 'executable specification' of the FreeRegs data type:
type FreeRegs = [RegNo]

noFreeRegs = 0
releaseReg n f = if n `elem` f then f else (n : f)
initFreeRegs = allocatableRegs
getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
allocateReg f r = filter (/= r) f
-}

#if defined(powerpc_TARGET_ARCH)

-- The PowerPC has 32 integer and 32 floating point registers.
-- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much
-- better.
-- Note that when getFreeRegs scans for free registers, it starts at register
-- 31 and counts down. This is a hack for the PowerPC - the higher-numbered
-- registers are callee-saves, while the lower regs are caller-saves, so it
-- makes sense to start at the high end.
-- Apart from that, the code does nothing PowerPC-specific, so feel free to
-- add your favourite platform to the #if (if you have 64 registers but only
-- 32-bit words).

data FreeRegs = FreeRegs !Word32 !Word32
143
	      deriving( Show )	-- The Show is used in an ASSERT
144

145
noFreeRegs :: FreeRegs
146
noFreeRegs = FreeRegs 0 0
147
148

releaseReg :: RegNo -> FreeRegs -> FreeRegs
149
150
151
152
153
154
155
releaseReg r (FreeRegs g f)
    | r > 31    = FreeRegs g (f .|. (1 `shiftL` (fromIntegral r - 32)))
    | otherwise = FreeRegs (g .|. (1 `shiftL` fromIntegral r)) f
    
initFreeRegs :: FreeRegs
initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs

156
getFreeRegs :: RegClass -> FreeRegs -> [RegNo]	-- lazilly
157
158
159
getFreeRegs cls (FreeRegs g f)
    | RcDouble <- cls = go f (0x80000000) 63
    | RcInteger <- cls = go g (0x80000000) 31
160
    | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad cls" (ppr cls)
161
    where
162
        go _ 0 _ = []
163
164
165
        go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1)
                 | otherwise    = go x (m `shiftR` 1) $! i-1

166
167
allocateReg :: RegNo -> FreeRegs -> FreeRegs
allocateReg r (FreeRegs g f) 
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
    | r > 31    = FreeRegs g (f .&. complement (1 `shiftL` (fromIntegral r - 32)))
    | otherwise = FreeRegs (g .&. complement (1 `shiftL` fromIntegral r)) f

#else

-- If we have less than 32 registers, or if we have efficient 64-bit words,
-- we will just use a single bitfield.

#if defined(alpha_TARGET_ARCH)
type FreeRegs = Word64
#else
type FreeRegs = Word32
#endif

noFreeRegs :: FreeRegs
noFreeRegs = 0

releaseReg :: RegNo -> FreeRegs -> FreeRegs
releaseReg n f = f .|. (1 `shiftL` n)

initFreeRegs :: FreeRegs
initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs

getFreeRegs :: RegClass -> FreeRegs -> [RegNo]	-- lazilly
getFreeRegs cls f = go f 0
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
193
  where go 0 _ = []
194
195
196
197
198
199
200
201
        go n m 
	  | n .&. 1 /= 0 && regClass (RealReg m) == cls
	  = m : (go (n `shiftR` 1) $! (m+1))
	  | otherwise
	  = go (n `shiftR` 1) $! (m+1)
	-- ToDo: there's no point looking through all the integer registers
	-- in order to find a floating-point one.

202
203
204
allocateReg :: RegNo -> FreeRegs -> FreeRegs
allocateReg r f = f .&. complement (1 `shiftL` fromIntegral r)

205
206
207
#endif

-- -----------------------------------------------------------------------------
208
-- The assignment of virtual registers to stack slots
209

210
211
212
-- We have lots of stack slots. Memory-to-memory moves are a pain on most
-- architectures. Therefore, we avoid having to generate memory-to-memory moves
-- by simply giving every virtual register its own stack slot.
213

214
215
216
217
-- The StackMap stack map keeps track of virtual register - stack slot
-- associations and of which stack slots are still free. Once it has been
-- associated, a stack slot is never "freed" or removed from the StackMap again,
-- it remains associated until we are done with the current CmmProc.
218

219
220
type StackSlot = Int
data StackMap = StackMap [StackSlot] (UniqFM StackSlot)
221

222
223
emptyStackMap :: StackMap
emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM
224

225
getStackSlotFor :: StackMap -> Unique -> (StackMap,Int)
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
226
getStackSlotFor (StackMap [] _) _
227
228
	= panic "RegAllocLinear.getStackSlotFor: out of stack slots, try -fregs-graph"
        -- This happens with darcs' SHA1.hs, see #1993
229

230
getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg =
231
232
    case lookupUFM reserved reg of
    	Just slot -> (fs,slot)
233
    	Nothing -> (StackMap stack' (addToUFM reserved reg freeSlot), freeSlot)
234

235
236
237
-- -----------------------------------------------------------------------------
-- Top level of the register allocator

238
239
240
-- Allocate registers
regAlloc 
	:: LiveCmmTop
241
	-> UniqSM (NatCmmTop, Maybe RegAllocStats)
242

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
243
regAlloc (CmmData sec d) 
244
245
246
 	= return
		( CmmData sec d
		, Nothing )
247
	
248
regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph []))
249
	= return
250
		( CmmProc info lbl params (ListGraph [])
251
		, Nothing )
252
	
253
regAlloc (CmmProc static lbl params (ListGraph comps))
254
255
256
257
258
259
	| LiveInfo info (Just first_id) block_live	<- static
	= do	
 		-- do register allocation on each component.
		(final_blocks, stats)
			<- linearRegAlloc block_live 
			$ map (\b -> case b of 
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
260
261
					BasicBlock _ [b]	-> AcyclicSCC b
					BasicBlock _ bs		-> CyclicSCC  bs)
262
263
264
265
266
267
268
			$ comps

		-- make sure the block that was first in the input list
		--	stays at the front of the output
		let ((first':_), rest')
				= partition ((== first_id) . blockId) final_blocks

269
		return	( CmmProc info lbl params (ListGraph (first' : rest'))
270
			, Just stats)
271
	
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
272
273
274
-- bogus. to make non-exhaustive match warning go away.
regAlloc (CmmProc _ _ _ _)
	= panic "RegAllocLinear.regAlloc: no match"
275

276

277
278
279
280
281
282
283
-- -----------------------------------------------------------------------------
-- Linear sweep to allocate registers

data Loc = InReg   {-# UNPACK #-} !RegNo
	 | InMem   {-# UNPACK #-} !Int		-- stack slot
	 | InBoth  {-# UNPACK #-} !RegNo
		   {-# UNPACK #-} !Int		-- stack slot
284
  deriving (Eq, Show, Ord)
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300

{- 
A temporary can be marked as living in both a register and memory
(InBoth), for example if it was recently loaded from a spill location.
This makes it cheap to spill (no save instruction required), but we
have to be careful to turn this into InReg if the value in the
register is changed.

This is also useful when a temporary is about to be clobbered.  We
save it in a spill location, but mark it as InBoth because the current
instruction might still want to read it.
-}

instance Outputable Loc where
  ppr l = text (show l)

301
302
303

-- | Do register allocation on some basic blocks.
--
304
linearRegAlloc
305
306
307
308
309
310
	:: BlockMap RegSet		-- ^ live regs on entry to each basic block
	-> [SCC LiveBasicBlock]		-- ^ instructions annotated with "deaths"
	-> UniqSM ([NatBasicBlock], RegAllocStats)

linearRegAlloc block_live sccs
 = do	us	<- getUs
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
311
 	let (_, _, stats, blocks) =
312
313
314
315
316
		runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us
			$ linearRA_SCCs block_live [] sccs

	return	(blocks, stats)

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
317
linearRA_SCCs _ blocksAcc []
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
	= return $ reverse blocksAcc

linearRA_SCCs block_live blocksAcc (AcyclicSCC block : sccs) 
 = do	blocks'	<- processBlock block_live block
	linearRA_SCCs block_live 
		((reverse blocks') ++ blocksAcc)
		sccs

linearRA_SCCs block_live blocksAcc (CyclicSCC blocks : sccs) 
 = do	blockss' <- mapM (processBlock block_live) blocks
	linearRA_SCCs block_live
		(reverse (concat blockss') ++ blocksAcc)
		sccs
		

-- | Do register allocation on this basic block
--
processBlock
	:: BlockMap RegSet 		-- ^ live regs on entry to each basic block
	-> LiveBasicBlock 		-- ^ block to do register allocation on
	-> RegM [NatBasicBlock]		-- ^ block with registers allocated

processBlock block_live (BasicBlock id instrs)
 = do 	initBlock id
 	(instrs', fixups)
		<- linearRA block_live [] [] instrs

	return	$ BasicBlock id instrs' : fixups


-- | Load the freeregs and current reg assignment into the RegM state
--	for the basic block with this BlockId.
initBlock :: BlockId -> RegM ()
initBlock id
 = do	block_assig	<- getBlockAssigR
  	case lookupUFM block_assig id of
	        -- no prior info about this block: assume everything is
	        -- free and the assignment is empty.
	 	Nothing
		 -> do	setFreeRegsR	initFreeRegs
		 	setAssigR	emptyRegMap

		-- load info about register assignments leading into this block.
		Just (freeregs, assig)
		 -> do	setFreeRegsR 	freeregs
			setAssigR	assig


linearRA
	:: BlockMap RegSet
	-> [Instr] -> [NatBasicBlock] -> [LiveInstr]
369
	-> RegM ([Instr], [NatBasicBlock])
370

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
371
linearRA _          instr_acc fixups []
372
373
374
375
376
	= return (reverse instr_acc, fixups)

linearRA block_live instr_acc fixups (instr:instrs)
 = do	(instr_acc', new_fixups) <- raInsn block_live instr_acc instr
	linearRA block_live instr_acc' (new_fixups++fixups) instrs
377
378
379
380

-- -----------------------------------------------------------------------------
-- Register allocation for a single instruction

381
type BlockAssignment = BlockMap (FreeRegs, RegMap Loc)
382
383
384

raInsn  :: BlockMap RegSet		-- Live temporaries at each basic block
	-> [Instr]			-- new instructions (accum.)
385
	-> LiveInstr 			-- the instruction (with "deaths")
386
387
388
389
390
	-> RegM (
	     [Instr],			-- new instructions
	     [NatBasicBlock]		-- extra fixup blocks
	   )

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
391
raInsn _     new_instrs (Instr (COMMENT _) Nothing)
392
393
 = return (new_instrs, [])

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
394
raInsn _     new_instrs (Instr (DELTA n) Nothing)  
395
 = do
396
397
398
    setDeltaR n
    return (new_instrs, [])

399
400
raInsn block_live new_instrs (Instr instr (Just live))
 = do
401
402
403
404
    assig    <- getAssigR

    -- If we have a reg->reg move between virtual registers, where the
    -- src register is not live after this instruction, and the dst
405
406
407
408
409
    -- register does not already have an assignment,
    -- and the source register is assigned to a register, not to a spill slot,
    -- then we can eliminate the instruction.
    -- (we can't eliminitate it if the source register is on the stack, because
    --  we do not want to use one spill slot for different virtual registers)
410
    case isRegRegMove instr of
411
	Just (src,dst)	| src `elementOfUniqSet` (liveDieRead live), 
412
		  	  isVirtualReg dst,
413
414
		 	  not (dst `elemUFM` assig),
		 	  Just (InReg _) <- (lookupUFM assig src) -> do
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
	   case src of
	      RealReg i -> setAssigR (addToUFM assig dst (InReg i))
		-- if src is a fixed reg, then we just map dest to this
		-- reg in the assignment.  src must be an allocatable reg,
		-- otherwise it wouldn't be in r_dying.
	      _virt -> case lookupUFM assig src of
		         Nothing -> panic "raInsn"
			 Just loc ->
			   setAssigR (addToUFM (delFromUFM assig src) dst loc)

	   -- we have elimianted this instruction
	   {-
	   freeregs <- getFreeRegsR
    	   assig <- getAssigR
	   pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
	   -}
	   return (new_instrs, [])
432

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
433
	_ -> genRaInsn block_live new_instrs instr 
434
435
436
437
			(uniqSetToList $ liveDieRead live) 
			(uniqSetToList $ liveDieWrite live)


Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
438
raInsn _ _ li
439
	= pprPanic "raInsn" (text "no match for:" <> ppr li)
440
441


442
443
444
445
genRaInsn block_live new_instrs instr r_dying w_dying =
    case regUsage instr              of { RU read written ->
    case partition isRealReg written of { (real_written1,virt_written) ->
    do
446
447
448
449
450
451
452
453
454
455
    let 
	real_written = [ r | RealReg r <- real_written1 ]

	-- we don't need to do anything with real registers that are
	-- only read by this instr.  (the list is typically ~2 elements,
	-- so using nub isn't a problem).
	virt_read = nub (filter isVirtualReg read)
    -- in

    -- (a) save any temporaries which will be clobbered by this instruction
456
    clobber_saves <- saveClobberedTemps real_written r_dying
457

458
459
460
461
462
    {-
    freeregs <- getFreeRegsR
    assig <- getAssigR
    pprTrace "raInsn" (docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ ppr virt_read <+> ppr virt_written $$ text (show freeregs) $$ ppr assig) $ do
    -}
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479

    -- (b), (c) allocate real regs for all regs read by this instruction.
    (r_spills, r_allocd) <- 
	allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read

    -- (d) Update block map for new destinations
    -- NB. do this before removing dead regs from the assignment, because
    -- these dead regs might in fact be live in the jump targets (they're
    -- only dead in the code that follows in the current basic block).
    (fixup_blocks, adjusted_instr)
	<- joinToTargets block_live [] instr (jumpDests instr [])

    -- (e) Delete all register assignments for temps which are read
    --     (only) and die here.  Update the free register list.
    releaseRegs r_dying

    -- (f) Mark regs which are clobbered as unallocatable
480
    clobberRegs real_written
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506

    -- (g) Allocate registers for temporaries *written* (only)
    (w_spills, w_allocd) <- 
	allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written

    -- (h) Release registers for temps which are written here and not
    -- used again.
    releaseRegs w_dying

    let
	-- (i) Patch the instruction
	patch_map = listToUFM   [ (t,RealReg r) | 
				  (t,r) <- zip virt_read r_allocd
					  ++ zip virt_written w_allocd ]

	patched_instr = patchRegs adjusted_instr patchLookup
	patchLookup x = case lookupUFM patch_map x of
				Nothing -> x
				Just y  -> y
    -- in

    -- pprTrace "patched" (docToSDoc (pprInstr patched_instr)) $ do

    -- (j) free up stack slots for dead spilled regs
    -- TODO (can't be bothered right now)

507
508
509
510
511
512
513
514
515
    -- erase reg->reg moves where the source and destination are the same.
    --	If the src temp didn't die in this instr but happened to be allocated
    --	to the same real reg as the destination, then we can erase the move anyway.
	squashed_instr	= case isRegRegMove patched_instr of
				Just (src, dst)
				 | src == dst	-> []
				_		-> [patched_instr]

    return (squashed_instr ++ w_spills ++ reverse r_spills
516
517
		 ++ clobber_saves ++ new_instrs,
	    fixup_blocks)
518
  }}
519
520
521
522
523
524
525
526
527

-- -----------------------------------------------------------------------------
-- releaseRegs

releaseRegs regs = do
  assig <- getAssigR
  free <- getFreeRegsR
  loop assig free regs 
 where
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
528
  loop _     free _ | free `seq` False = undefined
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
  loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
  loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs
  loop assig free (r:rs) = 
     case lookupUFM assig r of
	Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs
	Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs
	_other            -> loop (delFromUFM assig r) free rs

-- -----------------------------------------------------------------------------
-- Clobber real registers

{-
For each temp in a register that is going to be clobbered:
  - if the temp dies after this instruction, do nothing
  - otherwise, put it somewhere safe (another reg if possible,
    otherwise spill and record InBoth in the assignment).

for allocateRegs on the temps *read*,
  - clobbered regs are allocatable.

for allocateRegs on the temps *written*, 
  - clobbered regs are not allocatable.
-}

saveClobberedTemps
   :: [RegNo]		   -- real registers clobbered by this instruction
   -> [Reg]		   -- registers which are no longer live after this insn
556
557
   -> RegM [Instr] 	   -- return: instructions to spill any temps that will
		 	   -- be clobbered.
558

559
saveClobberedTemps [] _ = return [] -- common case
560
561
562
563
564
565
566
saveClobberedTemps clobbered dying =  do
  assig <- getAssigR
  let
	to_spill  = [ (temp,reg) | (temp, InReg reg) <- ufmToList assig,
				   reg `elem` clobbered,
				   temp `notElem` map getUnique dying  ]
  -- in
567
  (instrs,assig') <- clobber assig [] to_spill
568
  setAssigR assig'
569
  return instrs
570
 where
571
572
  clobber assig instrs [] = return (instrs,assig)
  clobber assig instrs ((temp,reg):rest)
573
574
    = do
	--ToDo: copy it to another register if possible
575
576
577
578
	(spill,slot) <- spillR (RealReg reg) temp
	recordSpill (SpillClobber temp)

	let new_assign	= addToUFM assig temp (InBoth reg slot)
579
	clobber new_assign (spill : COMMENT (fsLit "spill clobber") : instrs) rest
580

581
582
583
clobberRegs :: [RegNo] -> RegM ()
clobberRegs [] = return () -- common case
clobberRegs clobbered = do
584
  freeregs <- getFreeRegsR
585
  setFreeRegsR $! foldr allocateReg freeregs clobbered
586
  assig <- getAssigR
587
588
589
590
591
592
593
594
595
596
597
  setAssigR $! clobber assig (ufmToList assig)
 where
    -- if the temp was InReg and clobbered, then we will have
    -- saved it in saveClobberedTemps above.  So the only case
    -- we have to worry about here is InBoth.  Note that this
    -- also catches temps which were loaded up during allocation
    -- of read registers, not just those saved in saveClobberedTemps.
  clobber assig [] = assig
  clobber assig ((temp, InBoth reg slot) : rest)
	| reg `elem` clobbered
	= clobber (addToUFM assig temp (InMem slot)) rest
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
598
  clobber assig (_:rest)
599
	= clobber assig rest 
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618

-- -----------------------------------------------------------------------------
-- allocateRegsAndSpill

-- This function does several things:
--   For each temporary referred to by this instruction,
--   we allocate a real register (spilling another temporary if necessary).
--   We load the temporary up from memory if necessary.
--   We also update the register assignment in the process, and
--   the list of free registers and free stack slots.

allocateRegsAndSpill
	:: Bool			-- True <=> reading (load up spilled regs)
	-> [Reg]		-- don't push these out
	-> [Instr]		-- spill insns
	-> [RegNo]		-- real registers allocated (accum.)
	-> [Reg]		-- temps to allocate
	-> RegM ([Instr], [RegNo])

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
619
allocateRegsAndSpill _       _    spills alloc []
620
621
622
623
624
625
626
627
628
629
  = return (spills,reverse alloc)

allocateRegsAndSpill reading keep spills alloc (r:rs) = do
  assig <- getAssigR
  case lookupUFM assig r of
  -- case (1a): already in a register
     Just (InReg my_reg) ->
	allocateRegsAndSpill reading keep spills (my_reg:alloc) rs

  -- case (1b): already in a register (and memory)
630
  -- NB1. if we're writing this register, update its assignemnt to be
631
  -- InReg, because the memory value is no longer valid.
632
633
  -- NB2. This is why we must process written registers here, even if they
  -- are also read by the same instruction.
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
634
     Just (InBoth my_reg _) -> do
635
	when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
636
637
638
639
640
641
642
643
644
645
   	allocateRegsAndSpill reading keep spills (my_reg:alloc) rs

  -- Not already in a register, so we need to find a free one...
     loc -> do
	freeregs <- getFreeRegsR

        case getFreeRegs (regClass r) freeregs of

      	-- case (2): we have a free register
      	  my_reg:_ -> do
646
    	    spills'   <- loadTemp reading r loc my_reg spills
647
648
649
	    let new_loc 
		 | Just (InMem slot) <- loc, reading = InBoth my_reg slot
		 | otherwise		             = InReg my_reg
650
	    setAssigR (addToUFM assig r $! new_loc)
651
	    setFreeRegsR (allocateReg my_reg freeregs)
652
653
654
655
656
657
658
659
660
661
662
663
664
    	    allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs

        -- case (3): we need to push something out to free up a register
          [] -> do
	    let
	      keep' = map getUnique keep
	      candidates1 = [ (temp,reg,mem)
			    | (temp, InBoth reg mem) <- ufmToList assig,
			      temp `notElem` keep', regClass (RealReg reg) == regClass r ]
	      candidates2 = [ (temp,reg)
			    | (temp, InReg reg) <- ufmToList assig,
			      temp `notElem` keep', regClass (RealReg reg) == regClass r  ]
	    -- in
665
666
	    ASSERT2(not (null candidates1 && null candidates2), 
		    text (show freeregs) <+> ppr r <+> ppr assig) do
667
668
669
670
671
672
673

	    case candidates1 of

	     -- we have a temporary that is in both register and mem,
	     -- just free up its register for use.
	     -- 
	     (temp,my_reg,slot):_ -> do
674
    	        spills' <- loadTemp reading r loc my_reg spills
675
676
677
678
679
680
681
682
683
    	        let	
	          assig1  = addToUFM assig temp (InMem slot)
	          assig2  = addToUFM assig1 r (InReg my_reg)
 	        -- in
		setAssigR assig2
		allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs

	     -- otherwise, we need to spill a temporary that currently
	     -- resides in a register.
684
685


686
	     [] -> do
687
688
689
690
691
692
693
694
695

		-- TODO: plenty of room for optimisation in choosing which temp
	        -- to spill.  We just pick the first one that isn't used in 
	        -- the current instruction for now.

	        let (temp_to_push_out, my_reg) = myHead "regalloc" candidates2

    	        (spill_insn, slot) <- spillR (RealReg my_reg) temp_to_push_out
		let spill_store	 = (if reading then id else reverse)
696
					[ COMMENT (fsLit "spill alloc") 
697
698
699
700
701
702
703
704
					, spill_insn ]

		-- record that this temp was spilled
		recordSpill (SpillAlloc temp_to_push_out)

		-- update the register assignment
    	        let assig1  = addToUFM assig temp_to_push_out	(InMem slot)
	        let assig2  = addToUFM assig1 r			(InReg my_reg)
705
	        setAssigR assig2
706
707
708
709
710
711

		-- if need be, load up a spilled temp into the reg we've just freed up.
    	        spills' <- loadTemp reading r loc my_reg spills

 	        allocateRegsAndSpill reading keep
			(spill_store ++ spills')
712
		 	(my_reg:alloc) rs
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727


-- | Load up a spilled temporary if we need to.
loadTemp
	:: Bool
	-> Reg 		-- the temp being loaded
	-> Maybe Loc	-- the current location of this temp
	-> RegNo	-- the hreg to load the temp into
	-> [Instr]
	-> RegM [Instr]

loadTemp True vreg (Just (InMem slot)) hreg spills
 = do
 	insn <- loadR (RealReg hreg) slot
	recordSpill (SpillLoad $ getUnique vreg)
728
	return	$  COMMENT (fsLit "spill load") : insn : spills
729
730
731
732

loadTemp _ _ _ _ spills =
   return spills

733

734
myHead s [] = panic s
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
735
myHead _ (x:_) = x
736

737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
-- -----------------------------------------------------------------------------
-- Joining a jump instruction to its targets

-- The first time we encounter a jump to a particular basic block, we
-- record the assignment of temporaries.  The next time we encounter a
-- jump to the same block, we compare our current assignment to the
-- stored one.  They might be different if spilling has occrred in one
-- branch; so some fixup code will be required to match up the
-- assignments.

joinToTargets
	:: BlockMap RegSet
	-> [NatBasicBlock]
	-> Instr
	-> [BlockId]
	-> RegM ([NatBasicBlock], Instr)

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
754
joinToTargets _          new_blocks instr []
755
  = return (new_blocks, instr)
756

757
758
759
760
761
762
joinToTargets block_live new_blocks instr (dest:dests) = do
  block_assig <- getBlockAssigR
  assig <- getAssigR
  let
	-- adjust the assignment to remove any registers which are not
	-- live on entry to the destination block.
763
	adjusted_assig = filterUFM_Directly still_live assig
764
765

	live_set = lookItUp "joinToTargets" block_live dest
766
767
768
769
770
771
772
773
774
775
776
	still_live uniq _ = uniq `elemUniqSet_Directly` live_set

	-- and free up those registers which are now free.
	to_free =
	  [ r | (reg, loc) <- ufmToList assig, 
		not (elemUniqSet_Directly reg live_set), 
		r <- regsOfLoc loc ]

	regsOfLoc (InReg r)    = [r]
	regsOfLoc (InBoth r _) = [r]
	regsOfLoc (InMem _)    = []
777
778
779
780
781
782
  -- in
  case lookupUFM block_assig dest of
	-- Nothing <=> this is the first time we jumped to this
	-- block.
	Nothing -> do
	  freeregs <- getFreeRegsR
783
	  let freeregs' = foldr releaseReg freeregs to_free 
784
	  setBlockAssigR (addToUFM block_assig dest 
785
				(freeregs',adjusted_assig))
786
787
	  joinToTargets block_live new_blocks instr dests

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
788
	Just (_, dest_assig)
789
790

	   -- the assignments match
791
	   | ufmToList dest_assig == ufmToList adjusted_assig
792
793
794
	   -> joinToTargets block_live new_blocks instr dests

	   -- need fixup code
795
	   | otherwise
796
	   -> do
797
798
	       delta <- getDeltaR
	       
799
               let graph = makeRegMovementGraph adjusted_assig dest_assig
800
	       let sccs  = stronglyConnCompFromEdgedVerticesR graph
801
802
	       fixUpInstrs <- mapM (handleComponent delta instr) sccs

803
804
	       block_id <- getUniqueR
	       let block = BasicBlock (BlockId block_id) $
805
	               concat fixUpInstrs ++ mkBranchInstr dest
806

807
	       let instr' = patchJump instr dest (BlockId block_id)
808

809
	       joinToTargets block_live (block : new_blocks) instr' dests
810
811


Ian Lynagh's avatar
Ian Lynagh committed
812
-- | Construct a graph of register\/spill movements.
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
--
-- 	We cut some corners by
-- 	a) not handling cyclic components
-- 	b) not handling memory-to-memory moves.
--
-- 	Cyclic components seem to occur only very rarely,
-- 	and we don't need memory-to-memory moves because we
-- 	make sure that every temporary always gets its own
-- 	stack slot.

makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [(Unique, Loc, [Loc])]
makeRegMovementGraph adjusted_assig dest_assig
 = let
 	mkNodes src vreg
	 = expandNode vreg src
	 $ lookupWithDefaultUFM_Directly
           	dest_assig
Ian Lynagh's avatar
Ian Lynagh committed
830
                (panic "RegAllocLinear.makeRegMovementGraph")
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
		vreg

   in	[ node 	| (vreg, src) <- ufmToList adjusted_assig
 		, node <- mkNodes src vreg ]

-- The InBoth handling is a little tricky here.  If
-- the destination is InBoth, then we must ensure that
-- the value ends up in both locations.  An InBoth
-- destination must conflict with an InReg or InMem
-- source, so we expand an InBoth destination as
-- necessary.  An InBoth source is slightly different:
-- we only care about the register that the source value
-- is in, so that we can move it to the destinations.

expandNode vreg loc@(InReg src) (InBoth dst mem)
	| src == dst = [(vreg, loc, [InMem mem])]
	| otherwise  = [(vreg, loc, [InReg dst, InMem mem])]

expandNode vreg loc@(InMem src) (InBoth dst mem)
	| src == mem = [(vreg, loc, [InReg dst])]
	| otherwise  = [(vreg, loc, [InReg dst, InMem mem])]

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
853
expandNode _        (InBoth _ src) (InMem dst)
854
855
	| src == dst = [] -- guaranteed to be true

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
856
expandNode _        (InBoth src _) (InReg dst)
857
858
	| src == dst = []

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
859
expandNode vreg     (InBoth src _) dst
860
861
862
863
864
865
866
867
868
869
870
	= expandNode vreg (InReg src) dst

expandNode vreg src dst
	| src == dst = []
	| otherwise  = [(vreg, src, [dst])]


-- | Make a move instruction between these two locations so we
--	can join together allocations for different basic blocks.
--
makeMove :: Int -> Unique -> Loc -> Loc -> RegM Instr
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
871
makeMove _     vreg (InReg src) (InReg dst)
872
873
874
875
876
877
878
879
880
881
882
 = do	recordSpill (SpillJoinRR vreg)
 	return	$ mkRegRegMoveInstr (RealReg src) (RealReg dst)

makeMove delta vreg (InMem src) (InReg dst)
 = do	recordSpill (SpillJoinRM vreg)
 	return	$ mkLoadInstr (RealReg dst) delta src

makeMove delta vreg (InReg src) (InMem dst)
 = do	recordSpill (SpillJoinRM vreg)
	return	$ mkSpillInstr (RealReg src) delta dst

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
883
makeMove _     vreg src dst
884
885
886
887
888
889
890
891
	= panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("
		++ show dst ++ ")"
		++ " (workaround: use -fviaC)"


-- we have eliminated any possibility of single-node cylces
-- in expandNode above.
handleComponent :: Int -> Instr -> SCC (Unique, Loc, [Loc]) -> RegM [Instr]
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
892
handleComponent delta _  (AcyclicSCC (vreg,src,dsts))
893
894
895
896
897
898
899
	 = mapM (makeMove delta vreg src) dsts

-- we can not have cycles that involve memory
-- locations as source nor as single destination
-- because memory locations (stack slots) are
-- allocated exclusively for a virtual register and
-- therefore can not require a fixup
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
900
handleComponent delta instr (CyclicSCC ((vreg, (InReg sreg),dsts):rest))
901
902
 = do
	spill_id <- getUniqueR
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
903
	(_, slot) 		<- spillR (RealReg sreg) spill_id
904
	remainingFixUps 	<- mapM (handleComponent delta instr) (stronglyConnCompFromEdgedVerticesR rest)
905
906
907
908
909
910
911
912
	restoreAndFixInstr 	<- getRestoreMoves dsts slot
	return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr)

	where
	getRestoreMoves [r@(InReg reg), mem@(InMem _)] slot
	 = do
		restoreToReg 	<- loadR (RealReg reg) slot
		moveInstr	<- makeMove delta vreg r mem
913
		return $ [COMMENT (fsLit "spill join move"), restoreToReg, moveInstr]
914
915
916
917
918
919
920
921

	getRestoreMoves [InReg reg] slot
		= loadR (RealReg reg) slot >>= return . (:[])

	getRestoreMoves [InMem _] _ 	= panic "getRestoreMoves can not handle memory only restores"
	getRestoreMoves _ _ 		= panic "getRestoreMoves unknown case"


Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
922
handleComponent _ _ (CyclicSCC _)
923
924
925
 = panic "Register Allocator: handleComponent cyclic"


926
927
928
929
930
931
932
933
934
935
936
937

-- -----------------------------------------------------------------------------
-- The register allocator's monad.  

-- Here we keep all the state that the register allocator keeps track
-- of as it walks the instructions in a basic block.

data RA_State 
  = RA_State {
	ra_blockassig :: BlockAssignment,
		-- The current mapping from basic blocks to 
		-- the register assignments at the beginning of that block.
938
	ra_freeregs   :: {-#UNPACK#-}!FreeRegs,	-- free machine registers
939
940
	ra_assig      :: RegMap Loc,	-- assignment of temps to locations
	ra_delta      :: Int,		-- current stack delta
941
	ra_stack      :: StackMap,	-- free stack slots for spilling
942
	ra_us         :: UniqSupply,    -- unique supply for generating names
943
	                                -- for fixup blocks.
944
945
946
947
948

	-- Record why things were spilled, for -ddrop-asm-stats.
	-- 	Just keep a list here instead of a map of regs -> reasons.
	-- 	We don't want to slow down the allocator if we're not going to emit the stats.
	ra_spills     :: [SpillReason]
949
950
951
952
  }

newtype RegM a = RegM { unReg :: RA_State -> (# RA_State, a #) }

953

954
955
956
957
instance Monad RegM where
  m >>= k   =  RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
  return a  =  RegM $ \s -> (# s, a #)

958
runR :: BlockAssignment -> FreeRegs -> RegMap Loc -> StackMap -> UniqSupply
959
  -> RegM a -> (BlockAssignment, StackMap, RegAllocStats, a)
960
runR block_assig freeregs assig stack us thing =
961
  case unReg thing (RA_State{ ra_blockassig=block_assig, ra_freeregs=freeregs,
962
			ra_assig=assig, ra_delta=0{-???-}, ra_stack=stack,
963
			ra_us = us, ra_spills = [] }) of
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
964
	(# state'@RA_State{ ra_blockassig=block_assig, ra_stack=stack' }, returned_thing #)
965
		-> (block_assig, stack', makeRAStats state', returned_thing)
966

967
968
spillR :: Reg -> Unique -> RegM (Instr, Int)
spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
969
  let (stack',slot) = getStackSlotFor stack temp
970
971
972
973
974
      instr  = mkSpillInstr reg delta slot
  in
  (# s{ra_stack=stack'}, (instr,slot) #)

loadR :: Reg -> Int -> RegM Instr
Michael D. Adams's avatar
Michael D. Adams committed
975
loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
  (# s, mkLoadInstr reg delta slot #)

getFreeRegsR :: RegM FreeRegs
getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
  (# s, freeregs #)

setFreeRegsR :: FreeRegs -> RegM ()
setFreeRegsR regs = RegM $ \ s ->
  (# s{ra_freeregs = regs}, () #)

getAssigR :: RegM (RegMap Loc)
getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
  (# s, assig #)

setAssigR :: RegMap Loc -> RegM ()
setAssigR assig = RegM $ \ s ->
  (# s{ra_assig=assig}, () #)

getBlockAssigR :: RegM BlockAssignment
getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
  (# s, assig #)

setBlockAssigR :: BlockAssignment -> RegM ()
setBlockAssigR assig = RegM $ \ s ->
  (# s{ra_blockassig = assig}, () #)

setDeltaR :: Int -> RegM ()
setDeltaR n = RegM $ \ s ->
  (# s{ra_delta = n}, () #)

1006
1007
1008
1009
1010
1011
1012
1013
getDeltaR :: RegM Int
getDeltaR = RegM $ \s -> (# s, ra_delta s #)

getUniqueR :: RegM Unique
getUniqueR = RegM $ \s ->
  case splitUniqSupply (ra_us s) of
    (us1, us2) -> (# s{ra_us = us2}, uniqFromSupply us1 #)

1014
1015
1016
-- | Record that a spill instruction was inserted, for profiling.
recordSpill :: SpillReason -> RegM ()
recordSpill spill
1017
 	= RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062

-- -----------------------------------------------------------------------------

-- | Reasons why instructions might be inserted by the spiller.
--	Used when generating stats for -ddrop-asm-stats.
--
data SpillReason
	= SpillAlloc	!Unique	-- ^ vreg was spilled to a slot so we could use its
				--	current hreg for another vreg
	| SpillClobber	!Unique	-- ^ vreg was moved because its hreg was clobbered
	| SpillLoad	!Unique	-- ^ vreg was loaded from a spill slot

	| SpillJoinRR	!Unique	-- ^ reg-reg move inserted during join to targets
	| SpillJoinRM	!Unique	-- ^ reg-mem move inserted during join to targets


-- | Used to carry interesting stats out of the register allocator.
data RegAllocStats
	= RegAllocStats
	{ ra_spillInstrs	:: UniqFM [Int] }


-- | Make register allocator stats from its final state.
makeRAStats :: RA_State -> RegAllocStats
makeRAStats state
	= RegAllocStats
	{ ra_spillInstrs	= binSpillReasons (ra_spills state) }


-- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
binSpillReasons
	:: [SpillReason] -> UniqFM [Int]

binSpillReasons reasons
	= addListToUFM_C
		(zipWith (+))
		emptyUFM
		(map (\reason -> case reason of
			SpillAlloc r	-> (r, [1, 0, 0, 0, 0])
			SpillClobber r	-> (r, [0, 1, 0, 0, 0])
			SpillLoad r	-> (r, [0, 0, 1, 0, 0])
			SpillJoinRR r	-> (r, [0, 0, 0, 1, 0])
			SpillJoinRM r	-> (r, [0, 0, 0, 0, 1])) reasons)


1063
1064
1065
1066
1067
-- | Count reg-reg moves remaining in this code.
countRegRegMovesNat :: NatCmmTop -> Int
countRegRegMovesNat cmm
	= execState (mapGenBlockTopM countBlock cmm) 0
 where
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
1068
1069
 	countBlock b@(BasicBlock _ instrs)
	 = do	mapM_ countInstr instrs
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
	 	return	b

	countInstr instr
		| Just _	<- isRegRegMove instr
		= do	modify (+ 1)
			return instr

		| otherwise
		=	return instr


1081
-- | Pretty print some RegAllocStats
1082
1083
1084
1085
pprStats :: [NatCmmTop] -> [RegAllocStats] -> SDoc
pprStats code statss
 = let	-- sum up all the instrs inserted by the spiller
 	spills		= foldl' (plusUFM_C (zipWith (+)))
1086
1087
1088
1089
1090
1091
1092
 				emptyUFM
			$ map ra_spillInstrs statss

	spillTotals	= foldl' (zipWith (+))
				[0, 0, 0, 0, 0]
			$ eltsUFM spills

1093
1094
1095
	-- count how many reg-reg-moves remain in the code
	moves		= sum $ map countRegRegMovesNat code

1096
1097
1098
1099
	pprSpill (reg, spills)
		= parens $ (hcat $ punctuate (text ", ")  (doubleQuotes (ppr reg) : map ppr spills))

   in	(  text "-- spills-added-total"
1100
1101
	$$ text "--    (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)"
	$$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves])))
1102
1103
1104
1105
1106
1107
1108
1109
	$$ text ""
	$$ text "-- spills-added"
   	$$ text "--    (reg_name, allocs, clobbers, loads, joinRR, joinRM)"
	$$ (vcat $ map pprSpill
   		 $ ufmToList spills)
	$$ text "")


1110
1111
1112
-- -----------------------------------------------------------------------------
-- Utils

Ian Lynagh's avatar
Ian Lynagh committed
1113
my_fromJust :: String -> SDoc -> Maybe a -> a
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1114
my_fromJust _ _ (Just x) = x
Ian Lynagh's avatar
Ian Lynagh committed
1115
my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
1116
1117
1118

lookItUp :: Uniquable b => String -> UniqFM a -> b -> a
lookItUp str fm x = my_fromJust str (ppr (getUnique x)) (lookupUFM fm x)