Implemented and fixed bugs in CmmInfo handling
[ghc.git] / compiler / nativeGen / AsmCodeGen.lhs
1 -- -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow 1993-2004
4 -- 
5 -- This is the top-level module in the native code generator.
6 --
7 -- -----------------------------------------------------------------------------
8
9 \begin{code}
10 module AsmCodeGen ( nativeCodeGen ) where
11
12 #include "HsVersions.h"
13 #include "nativeGen/NCG.h"
14
15 import MachInstrs
16 import MachRegs
17 import MachCodeGen
18 import PprMach
19 import RegisterAlloc
20 import RegAllocInfo
21 import NCGMonad
22 import PositionIndependentCode
23
24 import Cmm
25 import CmmOpt           ( cmmMiniInline, cmmMachOpFold )
26 import PprCmm           ( pprStmt, pprCmms )
27 import MachOp
28 import CLabel
29
30 import UniqFM
31 import Unique           ( Unique, getUnique )
32 import UniqSupply
33 import FastTypes
34 import List             ( groupBy, sortBy )
35 import ErrUtils         ( dumpIfSet_dyn )
36 import DynFlags
37 import StaticFlags      ( opt_Static, opt_PIC )
38 import Util
39 import Config           ( cProjectVersion )
40
41 import Digraph
42 import qualified Pretty
43 import Outputable
44 import FastString
45
46 -- DEBUGGING ONLY
47 --import OrdList
48
49 #ifdef NCG_DEBUG
50 import List             ( intersperse )
51 #endif
52
53 import Data.Int
54 import Data.Word
55 import Data.Bits
56 import GHC.Exts
57
58 {-
59 The native-code generator has machine-independent and
60 machine-dependent modules.
61
62 This module ("AsmCodeGen") is the top-level machine-independent
63 module.  Before entering machine-dependent land, we do some
64 machine-independent optimisations (defined below) on the
65 'CmmStmts's.
66
67 We convert to the machine-specific 'Instr' datatype with
68 'cmmCodeGen', assuming an infinite supply of registers.  We then use
69 a machine-independent register allocator ('regAlloc') to rejoin
70 reality.  Obviously, 'regAlloc' has machine-specific helper
71 functions (see about "RegAllocInfo" below).
72
73 Finally, we order the basic blocks of the function so as to minimise
74 the number of jumps between blocks, by utilising fallthrough wherever
75 possible.
76
77 The machine-dependent bits break down as follows:
78
79   * ["MachRegs"]  Everything about the target platform's machine
80     registers (and immediate operands, and addresses, which tend to
81     intermingle/interact with registers).
82
83   * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should
84     have a module of its own), plus a miscellany of other things
85     (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)
86
87   * ["MachCodeGen"]  is where 'Cmm' stuff turns into
88     machine instructions.
89
90   * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
91     a 'Doc').
92
93   * ["RegAllocInfo"] In the register allocator, we manipulate
94     'MRegsState's, which are 'BitSet's, one bit per machine register.
95     When we want to say something about a specific machine register
96     (e.g., ``it gets clobbered by this instruction''), we set/unset
97     its bit.  Obviously, we do this 'BitSet' thing for efficiency
98     reasons.
99
100     The 'RegAllocInfo' module collects together the machine-specific
101     info needed to do register allocation.
102
103    * ["RegisterAlloc"] The (machine-independent) register allocator.
104 -}
105
106 -- -----------------------------------------------------------------------------
107 -- Top-level of the native codegen
108
109 -- NB. We *lazilly* compile each block of code for space reasons.
110
111 nativeCodeGen :: DynFlags -> [RawCmm] -> UniqSupply -> IO Pretty.Doc
112 nativeCodeGen dflags cmms us
113   = let (res, _) = initUs us $
114            cgCmm (concat (map add_split cmms))
115
116         cgCmm :: [RawCmmTop] -> UniqSM (RawCmm, Pretty.Doc, [CLabel])
117         cgCmm tops = 
118            lazyMapUs (cmmNativeGen dflags) tops  `thenUs` \ results -> 
119            case unzip3 results of { (cmms,docs,imps) ->
120            returnUs (Cmm cmms, my_vcat docs, concat imps)
121            }
122     in 
123     case res of { (ppr_cmms, insn_sdoc, imports) -> do
124     dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmms [ppr_cmms])
125     return (insn_sdoc Pretty.$$ dyld_stubs imports
126 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
127                 -- On recent versions of Darwin, the linker supports
128                 -- dead-stripping of code and data on a per-symbol basis.
129                 -- There's a hack to make this work in PprMach.pprNatCmmTop.
130             Pretty.$$ Pretty.text ".subsections_via_symbols"
131 #endif
132 #if HAVE_GNU_NONEXEC_STACK
133                 -- On recent GNU ELF systems one can mark an object file
134                 -- as not requiring an executable stack. If all objects
135                 -- linked into a program have this note then the program
136                 -- will not use an executable stack, which is good for
137                 -- security. GHC generated code does not need an executable
138                 -- stack so add the note in:
139             Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits"
140 #endif
141 #if !defined(darwin_TARGET_OS)
142                 -- And just because every other compiler does, lets stick in
143                 -- an identifier directive: .ident "GHC x.y.z"
144             Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
145                                           Pretty.text cProjectVersion
146                        in Pretty.text ".ident" Pretty.<+>
147                           Pretty.doubleQuotes compilerIdent
148 #endif
149             )
150    }
151
152   where
153
154     add_split (Cmm tops)
155         | dopt Opt_SplitObjs dflags = split_marker : tops
156         | otherwise                 = tops
157
158     split_marker = CmmProc [] mkSplitMarkerLabel [] []
159
160          -- Generate "symbol stubs" for all external symbols that might
161          -- come from a dynamic library.
162 {-    dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
163                                     map head $ group $ sort imps-}
164                                     
165         -- (Hack) sometimes two Labels pretty-print the same, but have
166         -- different uniques; so we compare their text versions...
167     dyld_stubs imps 
168         | needImportedSymbols
169           = Pretty.vcat $
170             (pprGotDeclaration :) $
171             map (pprImportedSymbol . fst . head) $
172             groupBy (\(_,a) (_,b) -> a == b) $
173             sortBy (\(_,a) (_,b) -> compare a b) $
174             map doPpr $
175             imps
176         | otherwise
177           = Pretty.empty
178         
179         where doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
180               astyle = mkCodeStyle AsmStyle
181
182 #ifndef NCG_DEBUG
183     my_vcat sds = Pretty.vcat sds
184 #else
185     my_vcat sds = Pretty.vcat (
186                       intersperse (
187                          Pretty.char ' ' 
188                             Pretty.$$ Pretty.ptext SLIT("# ___ncg_debug_marker")
189                             Pretty.$$ Pretty.char ' '
190                       ) 
191                       sds
192                    )
193 #endif
194
195
196 -- Complete native code generation phase for a single top-level chunk
197 -- of Cmm.
198
199 cmmNativeGen :: DynFlags -> RawCmmTop -> UniqSM (RawCmmTop, Pretty.Doc, [CLabel])
200 cmmNativeGen dflags cmm
201    = {-# SCC "fixAssigns"       #-} 
202         fixAssignsTop cmm            `thenUs` \ fixed_cmm ->
203      {-# SCC "genericOpt"       #-} 
204         cmmToCmm fixed_cmm           `bind`   \ (cmm, imports) ->
205         (if dopt Opt_D_dump_opt_cmm dflags  -- space leak avoidance
206            then cmm 
207            else CmmData Text [])     `bind`   \ ppr_cmm ->
208      {-# SCC "genMachCode"      #-}
209         genMachCode cmm              `thenUs` \ (pre_regalloc, lastMinuteImports) ->
210      {-# SCC "regAlloc"         #-}
211         mapUs regAlloc pre_regalloc `thenUs`   \ with_regs ->
212      {-# SCC "shortcutBranches"   #-}
213         shortcutBranches dflags with_regs `bind` \ shorted -> 
214      {-# SCC "sequenceBlocks"   #-}
215         map sequenceTop shorted        `bind`   \ sequenced ->
216      {-# SCC "x86fp_kludge"     #-}
217         map x86fp_kludge sequenced   `bind`   \ final_mach_code ->
218      {-# SCC "vcat"             #-}
219         Pretty.vcat (map pprNatCmmTop final_mach_code)  `bind`   \ final_sdoc ->
220
221         returnUs (ppr_cmm, final_sdoc Pretty.$$ Pretty.text "", lastMinuteImports ++ imports)
222      where
223         x86fp_kludge :: NatCmmTop -> NatCmmTop
224         x86fp_kludge top@(CmmData _ _) = top
225 #if i386_TARGET_ARCH
226         x86fp_kludge top@(CmmProc info lbl params code) = 
227                 CmmProc info lbl params (map bb_i386_insert_ffrees code)
228                 where
229                   bb_i386_insert_ffrees (BasicBlock id instrs) =
230                         BasicBlock id (i386_insert_ffrees instrs)
231 #else
232         x86fp_kludge top =  top
233 #endif
234
235 -- -----------------------------------------------------------------------------
236 -- Sequencing the basic blocks
237
238 -- Cmm BasicBlocks are self-contained entities: they always end in a
239 -- jump, either non-local or to another basic block in the same proc.
240 -- In this phase, we attempt to place the basic blocks in a sequence
241 -- such that as many of the local jumps as possible turn into
242 -- fallthroughs.
243
244 sequenceTop :: NatCmmTop -> NatCmmTop
245 sequenceTop top@(CmmData _ _) = top
246 sequenceTop (CmmProc info lbl params blocks) = 
247   CmmProc info lbl params (makeFarBranches $ sequenceBlocks blocks)
248
249 -- The algorithm is very simple (and stupid): we make a graph out of
250 -- the blocks where there is an edge from one block to another iff the
251 -- first block ends by jumping to the second.  Then we topologically
252 -- sort this graph.  Then traverse the list: for each block, we first
253 -- output the block, then if it has an out edge, we move the
254 -- destination of the out edge to the front of the list, and continue.
255
256 sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock]
257 sequenceBlocks [] = []
258 sequenceBlocks (entry:blocks) = 
259   seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
260   -- the first block is the entry point ==> it must remain at the start.
261
262 sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])]
263 sccBlocks blocks = stronglyConnCompR (map mkNode blocks)
264
265 getOutEdges :: [Instr] -> [Unique]
266 getOutEdges instrs = case jumpDests (last instrs) [] of
267                         [one] -> [getUnique one]
268                         _many -> []
269                 -- we're only interested in the last instruction of
270                 -- the block, and only if it has a single destination.
271
272 mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
273
274 seqBlocks [] = []
275 seqBlocks ((block,_,[]) : rest)
276   = block : seqBlocks rest
277 seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
278   | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
279   | otherwise       = block : seqBlocks rest'
280   where
281         (can_fallthrough, rest') = reorder next [] rest
282           -- TODO: we should do a better job for cycles; try to maximise the
283           -- fallthroughs within a loop.
284 seqBlocks _ = panic "AsmCodegen:seqBlocks"
285
286 reorder id accum [] = (False, reverse accum)
287 reorder id accum (b@(block,id',out) : rest)
288   | id == id'  = (True, (block,id,out) : reverse accum ++ rest)
289   | otherwise  = reorder id (b:accum) rest
290
291
292 -- -----------------------------------------------------------------------------
293 -- Making far branches
294
295 -- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
296 -- big, we have to work around this limitation.
297
298 makeFarBranches :: [NatBasicBlock] -> [NatBasicBlock]
299
300 #if powerpc_TARGET_ARCH
301 makeFarBranches blocks
302     | last blockAddresses < nearLimit = blocks
303     | otherwise = zipWith handleBlock blockAddresses blocks
304     where
305         blockAddresses = scanl (+) 0 $ map blockLen blocks
306         blockLen (BasicBlock _ instrs) = length instrs
307         
308         handleBlock addr (BasicBlock id instrs)
309                 = BasicBlock id (zipWith makeFar [addr..] instrs)
310         
311         makeFar addr (BCC ALWAYS tgt) = BCC ALWAYS tgt
312         makeFar addr (BCC cond tgt)
313             | abs (addr - targetAddr) >= nearLimit
314             = BCCFAR cond tgt
315             | otherwise
316             = BCC cond tgt
317             where Just targetAddr = lookupUFM blockAddressMap tgt
318         makeFar addr other            = other
319         
320         nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
321                          -- distance, as we have a few pseudo-insns that are
322                          -- pretty-printed as multiple instructions,
323                          -- and it's just not worth the effort to calculate
324                          -- things exactly
325         
326         blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
327 #else
328 makeFarBranches = id
329 #endif
330
331 -- -----------------------------------------------------------------------------
332 -- Shortcut branches
333
334 shortcutBranches :: DynFlags -> [NatCmmTop] -> [NatCmmTop]
335 shortcutBranches dflags tops
336   | optLevel dflags < 1 = tops    -- only with -O or higher
337   | otherwise           = map (apply_mapping mapping) tops'
338   where
339     (tops', mappings) = mapAndUnzip build_mapping tops
340     mapping = foldr plusUFM emptyUFM mappings
341
342 build_mapping top@(CmmData _ _) = (top, emptyUFM)
343 build_mapping (CmmProc info lbl params [])
344   = (CmmProc info lbl params [], emptyUFM)
345 build_mapping (CmmProc info lbl params (head:blocks))
346   = (CmmProc info lbl params (head:others), mapping)
347         -- drop the shorted blocks, but don't ever drop the first one,
348         -- because it is pointed to by a global label.
349   where
350     -- find all the blocks that just consist of a jump that can be
351     -- shorted.
352     (shortcut_blocks, others) = partitionWith split blocks
353     split (BasicBlock id [insn]) | Just dest <- canShortcut insn 
354                                  = Left (id,dest)
355     split other = Right other
356
357     -- build a mapping from BlockId to JumpDest for shorting branches
358     mapping = foldl add emptyUFM shortcut_blocks
359     add ufm (id,dest) = addToUFM ufm id dest
360     
361 apply_mapping ufm (CmmData sec statics) 
362   = CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
363   -- we need to get the jump tables, so apply the mapping to the entries
364   -- of a CmmData too.
365 apply_mapping ufm (CmmProc info lbl params blocks)
366   = CmmProc info lbl params (map short_bb blocks)
367   where
368     short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
369     short_insn i = shortcutJump (lookupUFM ufm) i
370                  -- shortcutJump should apply the mapping repeatedly,
371                  -- just in case we can short multiple branches.
372
373 -- -----------------------------------------------------------------------------
374 -- Instruction selection
375
376 -- Native code instruction selection for a chunk of stix code.  For
377 -- this part of the computation, we switch from the UniqSM monad to
378 -- the NatM monad.  The latter carries not only a Unique, but also an
379 -- Int denoting the current C stack pointer offset in the generated
380 -- code; this is needed for creating correct spill offsets on
381 -- architectures which don't offer, or for which it would be
382 -- prohibitively expensive to employ, a frame pointer register.  Viz,
383 -- x86.
384
385 -- The offset is measured in bytes, and indicates the difference
386 -- between the current (simulated) C stack-ptr and the value it was at
387 -- the beginning of the block.  For stacks which grow down, this value
388 -- should be either zero or negative.
389
390 -- Switching between the two monads whilst carrying along the same
391 -- Unique supply breaks abstraction.  Is that bad?
392
393 genMachCode :: RawCmmTop -> UniqSM ([NatCmmTop], [CLabel])
394
395 genMachCode cmm_top
396   = do  { initial_us <- getUs
397         ; let initial_st           = mkNatM_State initial_us 0
398               (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
399               final_us             = natm_us final_st
400               final_delta          = natm_delta final_st
401               final_imports        = natm_imports final_st
402         ; if   final_delta == 0
403           then return (new_tops, final_imports)
404           else pprPanic "genMachCode: nonzero final delta" (int final_delta)
405     }
406
407 -- -----------------------------------------------------------------------------
408 -- Fixup assignments to global registers so that they assign to 
409 -- locations within the RegTable, if appropriate.
410
411 -- Note that we currently don't fixup reads here: they're done by
412 -- the generic optimiser below, to avoid having two separate passes
413 -- over the Cmm.
414
415 fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
416 fixAssignsTop top@(CmmData _ _) = returnUs top
417 fixAssignsTop (CmmProc info lbl params blocks) =
418   mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
419   returnUs (CmmProc info lbl params blocks')
420
421 fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock
422 fixAssignsBlock (BasicBlock id stmts) =
423   fixAssigns stmts `thenUs` \ stmts' ->
424   returnUs (BasicBlock id stmts')
425
426 fixAssigns :: [CmmStmt] -> UniqSM [CmmStmt]
427 fixAssigns stmts =
428   mapUs fixAssign stmts `thenUs` \ stmtss ->
429   returnUs (concat stmtss)
430
431 fixAssign :: CmmStmt -> UniqSM [CmmStmt]
432 fixAssign (CmmAssign (CmmGlobal reg) src)
433   | Left  realreg <- reg_or_addr
434   = returnUs [CmmAssign (CmmGlobal reg) src]
435   | Right baseRegAddr <- reg_or_addr
436   = returnUs [CmmStore baseRegAddr src]
437            -- Replace register leaves with appropriate StixTrees for
438            -- the given target. GlobalRegs which map to a reg on this
439            -- arch are left unchanged.  Assigning to BaseReg is always
440            -- illegal, so we check for that.
441   where
442         reg_or_addr = get_GlobalReg_reg_or_addr reg
443
444 fixAssign other_stmt = returnUs [other_stmt]
445
446 -- -----------------------------------------------------------------------------
447 -- Generic Cmm optimiser
448
449 {-
450 Here we do:
451
452   (a) Constant folding
453   (b) Simple inlining: a temporary which is assigned to and then
454       used, once, can be shorted.
455   (c) Replacement of references to GlobalRegs which do not have
456       machine registers by the appropriate memory load (eg.
457       Hp ==>  *(BaseReg + 34) ).
458   (d) Position independent code and dynamic linking
459         (i)  introduce the appropriate indirections
460              and position independent refs
461         (ii) compile a list of imported symbols
462
463 Ideas for other things we could do (ToDo):
464
465   - shortcut jumps-to-jumps
466   - eliminate dead code blocks
467   - simple CSE: if an expr is assigned to a temp, then replace later occs of
468     that expr with the temp, until the expr is no longer valid (can push through
469     temp assignments, and certain assigns to mem...)
470 -}
471
472 cmmToCmm :: RawCmmTop -> (RawCmmTop, [CLabel])
473 cmmToCmm top@(CmmData _ _) = (top, [])
474 cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
475   blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
476   return $ CmmProc info lbl params blocks'
477
478 newtype CmmOptM a = CmmOptM ([CLabel] -> (# a, [CLabel] #))
479
480 instance Monad CmmOptM where
481   return x = CmmOptM $ \imports -> (# x,imports #)
482   (CmmOptM f) >>= g =
483     CmmOptM $ \imports ->
484                 case f imports of
485                   (# x, imports' #) ->
486                     case g x of
487                       CmmOptM g' -> g' imports'
488
489 addImportCmmOpt :: CLabel -> CmmOptM ()
490 addImportCmmOpt lbl = CmmOptM $ \imports -> (# (), lbl:imports #)
491
492 runCmmOpt :: CmmOptM a -> (a, [CLabel])
493 runCmmOpt (CmmOptM f) = case f [] of
494                         (# result, imports #) -> (result, imports)
495
496 cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
497 cmmBlockConFold (BasicBlock id stmts) = do
498   stmts' <- mapM cmmStmtConFold stmts
499   return $ BasicBlock id stmts'
500
501 cmmStmtConFold stmt
502    = case stmt of
503         CmmAssign reg src
504            -> do src' <- cmmExprConFold DataReference src
505                  return $ case src' of
506                    CmmReg reg' | reg == reg' -> CmmNop
507                    new_src -> CmmAssign reg new_src
508
509         CmmStore addr src
510            -> do addr' <- cmmExprConFold DataReference addr
511                  src'  <- cmmExprConFold DataReference src
512                  return $ CmmStore addr' src'
513
514         CmmJump addr regs
515            -> do addr' <- cmmExprConFold JumpReference addr
516                  return $ CmmJump addr' regs
517
518         CmmCall target regs args srt
519            -> do target' <- case target of
520                               CmmForeignCall e conv -> do
521                                 e' <- cmmExprConFold CallReference e
522                                 return $ CmmForeignCall e' conv
523                               other -> return other
524                  args' <- mapM (\(arg, hint) -> do
525                                   arg' <- cmmExprConFold DataReference arg
526                                   return (arg', hint)) args
527                  return $ CmmCall target' regs args' srt
528
529         CmmCondBranch test dest
530            -> do test' <- cmmExprConFold DataReference test
531                  return $ case test' of
532                    CmmLit (CmmInt 0 _) -> 
533                      CmmComment (mkFastString ("deleted: " ++ 
534                                         showSDoc (pprStmt stmt)))
535
536                    CmmLit (CmmInt n _) -> CmmBranch dest
537                    other -> CmmCondBranch test' dest
538
539         CmmSwitch expr ids
540            -> do expr' <- cmmExprConFold DataReference expr
541                  return $ CmmSwitch expr' ids
542
543         other
544            -> return other
545
546
547 cmmExprConFold referenceKind expr
548    = case expr of
549         CmmLoad addr rep
550            -> do addr' <- cmmExprConFold DataReference addr
551                  return $ CmmLoad addr' rep
552
553         CmmMachOp mop args
554            -- For MachOps, we first optimize the children, and then we try 
555            -- our hand at some constant-folding.
556            -> do args' <- mapM (cmmExprConFold DataReference) args
557                  return $ cmmMachOpFold mop args'
558
559         CmmLit (CmmLabel lbl)
560            -> cmmMakeDynamicReference addImportCmmOpt referenceKind lbl
561         CmmLit (CmmLabelOff lbl off)
562            -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt referenceKind lbl
563                  return $ cmmMachOpFold (MO_Add wordRep) [
564                      dynRef,
565                      (CmmLit $ CmmInt (fromIntegral off) wordRep)
566                    ]
567
568 #if powerpc_TARGET_ARCH
569            -- On powerpc (non-PIC), it's easier to jump directly to a label than
570            -- to use the register table, so we replace these registers
571            -- with the corresponding labels:
572         CmmReg (CmmGlobal GCEnter1)
573           | not opt_PIC
574           -> cmmExprConFold referenceKind $
575              CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1"))) 
576         CmmReg (CmmGlobal GCFun)
577           | not opt_PIC
578           -> cmmExprConFold referenceKind $
579              CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
580 #endif
581
582         CmmReg (CmmGlobal mid)
583            -- Replace register leaves with appropriate StixTrees for
584            -- the given target.  MagicIds which map to a reg on this
585            -- arch are left unchanged.  For the rest, BaseReg is taken
586            -- to mean the address of the reg table in MainCapability,
587            -- and for all others we generate an indirection to its
588            -- location in the register table.
589            -> case get_GlobalReg_reg_or_addr mid of
590                  Left  realreg -> return expr
591                  Right baseRegAddr 
592                     -> case mid of 
593                           BaseReg -> cmmExprConFold DataReference baseRegAddr
594                           other   -> cmmExprConFold DataReference
595                                         (CmmLoad baseRegAddr (globalRegRep mid))
596            -- eliminate zero offsets
597         CmmRegOff reg 0
598            -> cmmExprConFold referenceKind (CmmReg reg)
599
600         CmmRegOff (CmmGlobal mid) offset
601            -- RegOf leaves are just a shorthand form. If the reg maps
602            -- to a real reg, we keep the shorthand, otherwise, we just
603            -- expand it and defer to the above code. 
604            -> case get_GlobalReg_reg_or_addr mid of
605                 Left  realreg -> return expr
606                 Right baseRegAddr
607                    -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordRep) [
608                                         CmmReg (CmmGlobal mid),
609                                         CmmLit (CmmInt (fromIntegral offset)
610                                                        wordRep)])
611         other
612            -> return other
613
614 -- -----------------------------------------------------------------------------
615 -- Utils
616
617 bind f x = x $! f
618
619 \end{code}
620