NCG: Split up the native code generator into arch specific modules
authorBen.Lippmeier@anu.edu.au <unknown>
Sun, 15 Feb 2009 05:51:58 +0000 (05:51 +0000)
committerBen.Lippmeier@anu.edu.au <unknown>
Sun, 15 Feb 2009 05:51:58 +0000 (05:51 +0000)
  - nativeGen/Instruction defines a type class for a generic
    instruction set. Each of the instruction sets we have,
    X86, PPC and SPARC are instances of it.

  - The register alloctors use this type class when they need
    info about a certain register or instruction, such as
    regUsage, mkSpillInstr, mkJumpInstr, patchRegs..

  - nativeGen/Platform defines some data types enumerating
    the architectures and operating systems supported by the
    native code generator.

  - DynFlags now keeps track of the current build platform, and
    the PositionIndependentCode module uses this to decide what
    to do instead of relying of #ifdefs.

  - It's not totally retargetable yet. Some info info about the
    build target is still hardwired, but I've tried to contain
    most of it to a single module, TargetRegs.

  - Moved the SPILL and RELOAD instructions into LiveInstr.

  - Reg and RegClass now have their own modules, and are shared
    across all architectures.

55 files changed:
compiler/ghc.cabal.in
compiler/main/DynFlags.hs
compiler/nativeGen/Alpha/CodeGen.hs [new file with mode: 0644]
compiler/nativeGen/Alpha/Instr.hs
compiler/nativeGen/ArchReg.hs [new file with mode: 0644]
compiler/nativeGen/AsmCodeGen.lhs
compiler/nativeGen/Instrs.hs [deleted file]
compiler/nativeGen/Instruction.hs [new file with mode: 0644]
compiler/nativeGen/MachCodeGen.hs [deleted file]
compiler/nativeGen/NCGMonad.hs
compiler/nativeGen/PIC.hs [moved from compiler/nativeGen/PositionIndependentCode.hs with 57% similarity]
compiler/nativeGen/PPC/CodeGen.hs [new file with mode: 0644]
compiler/nativeGen/PPC/Cond.hs [new file with mode: 0644]
compiler/nativeGen/PPC/Instr.hs
compiler/nativeGen/PPC/Ppr.hs
compiler/nativeGen/PPC/RegInfo.hs
compiler/nativeGen/PPC/Regs.hs
compiler/nativeGen/Platform.hs [new file with mode: 0644]
compiler/nativeGen/PprMach.hs [deleted file]
compiler/nativeGen/Reg.hs [new file with mode: 0644]
compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
compiler/nativeGen/RegAlloc/Graph/Main.hs
compiler/nativeGen/RegAlloc/Graph/Spill.hs
compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
compiler/nativeGen/RegAlloc/Graph/Stats.hs
compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs [moved from compiler/nativeGen/Regs.hs with 55% similarity]
compiler/nativeGen/RegAlloc/Linear/Base.hs
compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
compiler/nativeGen/RegAlloc/Linear/Main.hs
compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs
compiler/nativeGen/RegAlloc/Linear/StackMap.hs
compiler/nativeGen/RegAlloc/Linear/State.hs
compiler/nativeGen/RegAlloc/Linear/Stats.hs
compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs
compiler/nativeGen/RegAlloc/Liveness.hs
compiler/nativeGen/RegAllocInfo.hs [deleted file]
compiler/nativeGen/RegClass.hs [new file with mode: 0644]
compiler/nativeGen/RegsBase.hs [deleted file]
compiler/nativeGen/SPARC/CodeGen.hs [new file with mode: 0644]
compiler/nativeGen/SPARC/Cond.hs [new file with mode: 0644]
compiler/nativeGen/SPARC/Instr.hs
compiler/nativeGen/SPARC/Ppr.hs
compiler/nativeGen/SPARC/RegInfo.hs
compiler/nativeGen/SPARC/Regs.hs
compiler/nativeGen/Size.hs [new file with mode: 0644]
compiler/nativeGen/TargetReg.hs [new file with mode: 0644]
compiler/nativeGen/X86/CodeGen.hs [new file with mode: 0644]
compiler/nativeGen/X86/Cond.hs [new file with mode: 0644]
compiler/nativeGen/X86/Instr.hs
compiler/nativeGen/X86/Ppr.hs
compiler/nativeGen/X86/RegInfo.hs
compiler/nativeGen/X86/Regs.hs

index 2328eca..b276943 100644 (file)
@@ -454,31 +454,38 @@ Library
 
         Exposed-Modules:
             AsmCodeGen
-            MachCodeGen
-            Regs
-            RegsBase
-            Instrs
-            RegAllocInfo
-            PprMach
+            TargetReg
+            NCGMonad
+            Instruction
+            Size
+            Reg
+            RegClass
             PprBase
+            PIC
+            Platform
             Alpha.Regs
             Alpha.RegInfo
             Alpha.Instr
             Alpha.Ppr
+            Alpha.CodeGen
             X86.Regs
             X86.RegInfo
             X86.Instr
+            X86.Cond
             X86.Ppr
+            X86.CodeGen
             PPC.Regs
             PPC.RegInfo
             PPC.Instr
+            PPC.Cond
             PPC.Ppr
+            PPC.CodeGen
             SPARC.Regs
             SPARC.RegInfo
             SPARC.Instr
+            SPARC.Cond
             SPARC.Ppr
-            NCGMonad
-            PositionIndependentCode
+            SPARC.CodeGen
             RegAlloc.Liveness
             RegAlloc.Graph.Main
             RegAlloc.Graph.Stats
@@ -488,6 +495,7 @@ Library
             RegAlloc.Graph.Spill
             RegAlloc.Graph.SpillClean
             RegAlloc.Graph.SpillCost
+            RegAlloc.Graph.TrivColorable
             RegAlloc.Linear.Main
             RegAlloc.Linear.JoinToTargets
             RegAlloc.Linear.State
index 44bd124..eb9a182 100644 (file)
@@ -64,6 +64,7 @@ module DynFlags (
 
 #include "HsVersions.h"
 
+import Platform
 import Module
 import PackageConfig
 import PrelNames        ( mAIN, main_RDR_Unqual )
@@ -339,6 +340,7 @@ data DynFlags = DynFlags {
   specConstrCount       :: Maybe Int,   -- ^ Max number of specialisations for any one function
   liberateCaseThreshold :: Maybe Int,   -- ^ Threshold for LiberateCase
 
+  targetPlatform       :: Platform,    -- ^ The platform we're compiling for. Used by the NCG.
   stolen_x86_regs       :: Int,
   cmdlineHcIncludes     :: [String],    -- ^ @\-\#includes@
   importPaths           :: [FilePath],
@@ -584,6 +586,7 @@ defaultDynFlags =
         specConstrThreshold     = Just 200,
         specConstrCount         = Just 3,
         liberateCaseThreshold   = Just 200,
+        targetPlatform          = defaultTargetPlatform,
         stolen_x86_regs         = 4,
         cmdlineHcIncludes       = [],
         importPaths             = ["."],
diff --git a/compiler/nativeGen/Alpha/CodeGen.hs b/compiler/nativeGen/Alpha/CodeGen.hs
new file mode 100644 (file)
index 0000000..4ce774f
--- /dev/null
@@ -0,0 +1,789 @@
+module Alpha.CodeGen ()
+
+where
+
+{-
+
+getRegister :: CmmExpr -> NatM Register
+
+#if !x86_64_TARGET_ARCH
+    -- on x86_64, we have %rip for PicBaseReg, but it's not a full-featured
+    -- register, it can only be used for rip-relative addressing.
+getRegister (CmmReg (CmmGlobal PicBaseReg))
+  = do
+      reg <- getPicBaseNat wordSize
+      return (Fixed wordSize reg nilOL)
+#endif
+
+getRegister (CmmReg reg) 
+  = return (Fixed (cmmTypeSize (cmmRegType reg)) 
+                 (getRegisterReg reg) nilOL)
+
+getRegister tree@(CmmRegOff _ _) 
+  = getRegister (mangleIndexTree tree)
+
+
+#if WORD_SIZE_IN_BITS==32
+    -- for 32-bit architectuers, support some 64 -> 32 bit conversions:
+    -- TO_W_(x), TO_W_(x >> 32)
+
+getRegister (CmmMachOp (MO_UU_Conv W64 W32)
+             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 (getHiVRegFromLo rlo) code
+
+getRegister (CmmMachOp (MO_SS_Conv W64 W32)
+             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 (getHiVRegFromLo rlo) code
+
+getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 rlo code
+
+getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 rlo code       
+
+#endif
+
+-- end of machine-"independent" bit; here we go on the rest...
+
+
+getRegister (StDouble d)
+  = getBlockIdNat                  `thenNat` \ lbl ->
+    getNewRegNat PtrRep            `thenNat` \ tmp ->
+    let code dst = mkSeqInstrs [
+           LDATA RoDataSegment lbl [
+                   DATA TF [ImmLab (rational d)]
+               ],
+           LDA tmp (AddrImm (ImmCLbl lbl)),
+           LD TF dst (AddrReg tmp)]
+    in
+       return (Any FF64 code)
+
+getRegister (StPrim primop [x]) -- unary PrimOps
+  = case primop of
+      IntNegOp -> trivialUCode (NEG Q False) x
+
+      NotOp    -> trivialUCode NOT x
+
+      FloatNegOp  -> trivialUFCode FloatRep (FNEG TF) x
+      DoubleNegOp -> trivialUFCode FF64 (FNEG TF) x
+
+      OrdOp -> coerceIntCode IntRep x
+      ChrOp -> chrCode x
+
+      Float2IntOp  -> coerceFP2Int    x
+      Int2FloatOp  -> coerceInt2FP pr x
+      Double2IntOp -> coerceFP2Int    x
+      Int2DoubleOp -> coerceInt2FP pr x
+
+      Double2FloatOp -> coerceFltCode x
+      Float2DoubleOp -> coerceFltCode x
+
+      other_op -> getRegister (StCall fn CCallConv FF64 [x])
+       where
+         fn = case other_op of
+                FloatExpOp    -> fsLit "exp"
+                FloatLogOp    -> fsLit "log"
+                FloatSqrtOp   -> fsLit "sqrt"
+                FloatSinOp    -> fsLit "sin"
+                FloatCosOp    -> fsLit "cos"
+                FloatTanOp    -> fsLit "tan"
+                FloatAsinOp   -> fsLit "asin"
+                FloatAcosOp   -> fsLit "acos"
+                FloatAtanOp   -> fsLit "atan"
+                FloatSinhOp   -> fsLit "sinh"
+                FloatCoshOp   -> fsLit "cosh"
+                FloatTanhOp   -> fsLit "tanh"
+                DoubleExpOp   -> fsLit "exp"
+                DoubleLogOp   -> fsLit "log"
+                DoubleSqrtOp  -> fsLit "sqrt"
+                DoubleSinOp   -> fsLit "sin"
+                DoubleCosOp   -> fsLit "cos"
+                DoubleTanOp   -> fsLit "tan"
+                DoubleAsinOp  -> fsLit "asin"
+                DoubleAcosOp  -> fsLit "acos"
+                DoubleAtanOp  -> fsLit "atan"
+                DoubleSinhOp  -> fsLit "sinh"
+                DoubleCoshOp  -> fsLit "cosh"
+                DoubleTanhOp  -> fsLit "tanh"
+  where
+    pr = panic "MachCode.getRegister: no primrep needed for Alpha"
+
+getRegister (StPrim primop [x, y]) -- dyadic PrimOps
+  = case primop of
+      CharGtOp -> trivialCode (CMP LTT) y x
+      CharGeOp -> trivialCode (CMP LE) y x
+      CharEqOp -> trivialCode (CMP EQQ) x y
+      CharNeOp -> int_NE_code x y
+      CharLtOp -> trivialCode (CMP LTT) x y
+      CharLeOp -> trivialCode (CMP LE) x y
+
+      IntGtOp  -> trivialCode (CMP LTT) y x
+      IntGeOp  -> trivialCode (CMP LE) y x
+      IntEqOp  -> trivialCode (CMP EQQ) x y
+      IntNeOp  -> int_NE_code x y
+      IntLtOp  -> trivialCode (CMP LTT) x y
+      IntLeOp  -> trivialCode (CMP LE) x y
+
+      WordGtOp -> trivialCode (CMP ULT) y x
+      WordGeOp -> trivialCode (CMP ULE) x y
+      WordEqOp -> trivialCode (CMP EQQ)  x y
+      WordNeOp -> int_NE_code x y
+      WordLtOp -> trivialCode (CMP ULT) x y
+      WordLeOp -> trivialCode (CMP ULE) x y
+
+      AddrGtOp -> trivialCode (CMP ULT) y x
+      AddrGeOp -> trivialCode (CMP ULE) y x
+      AddrEqOp -> trivialCode (CMP EQQ)  x y
+      AddrNeOp -> int_NE_code x y
+      AddrLtOp -> trivialCode (CMP ULT) x y
+      AddrLeOp -> trivialCode (CMP ULE) x y
+       
+      FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
+      FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
+      FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
+      FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
+      FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
+      FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
+
+      DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
+      DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
+      DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
+      DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
+      DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
+      DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
+
+      IntAddOp  -> trivialCode (ADD Q False) x y
+      IntSubOp  -> trivialCode (SUB Q False) x y
+      IntMulOp  -> trivialCode (MUL Q False) x y
+      IntQuotOp -> trivialCode (DIV Q False) x y
+      IntRemOp  -> trivialCode (REM Q False) x y
+
+      WordAddOp  -> trivialCode (ADD Q False) x y
+      WordSubOp  -> trivialCode (SUB Q False) x y
+      WordMulOp  -> trivialCode (MUL Q False) x y
+      WordQuotOp -> trivialCode (DIV Q True) x y
+      WordRemOp  -> trivialCode (REM Q True) x y
+
+      FloatAddOp -> trivialFCode  W32 (FADD TF) x y
+      FloatSubOp -> trivialFCode  W32 (FSUB TF) x y
+      FloatMulOp -> trivialFCode  W32 (FMUL TF) x y
+      FloatDivOp -> trivialFCode  W32 (FDIV TF) x y
+
+      DoubleAddOp -> trivialFCode  W64 (FADD TF) x y
+      DoubleSubOp -> trivialFCode  W64 (FSUB TF) x y
+      DoubleMulOp -> trivialFCode  W64 (FMUL TF) x y
+      DoubleDivOp -> trivialFCode  W64 (FDIV TF) x y
+
+      AddrAddOp  -> trivialCode (ADD Q False) x y
+      AddrSubOp  -> trivialCode (SUB Q False) x y
+      AddrRemOp  -> trivialCode (REM Q True) x y
+
+      AndOp  -> trivialCode AND x y
+      OrOp   -> trivialCode OR  x y
+      XorOp  -> trivialCode XOR x y
+      SllOp  -> trivialCode SLL x y
+      SrlOp  -> trivialCode SRL x y
+
+      ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
+      ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
+      ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
+
+      FloatPowerOp  -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y])
+      DoublePowerOp -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y])
+  where
+    {- ------------------------------------------------------------
+       Some bizarre special code for getting condition codes into
+       registers.  Integer non-equality is a test for equality
+       followed by an XOR with 1.  (Integer comparisons always set
+       the result register to 0 or 1.)  Floating point comparisons of
+       any kind leave the result in a floating point register, so we
+       need to wrangle an integer register out of things.
+    -}
+    int_NE_code :: StixTree -> StixTree -> NatM Register
+
+    int_NE_code x y
+      = trivialCode (CMP EQQ) x y      `thenNat` \ register ->
+       getNewRegNat IntRep             `thenNat` \ tmp ->
+       let
+           code = registerCode register tmp
+           src  = registerName register tmp
+           code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
+       in
+       return (Any IntRep code__2)
+
+    {- ------------------------------------------------------------
+       Comments for int_NE_code also apply to cmpF_code
+    -}
+    cmpF_code
+       :: (Reg -> Reg -> Reg -> Instr)
+       -> Cond
+       -> StixTree -> StixTree
+       -> NatM Register
+
+    cmpF_code instr cond x y
+      = trivialFCode pr instr x y      `thenNat` \ register ->
+       getNewRegNat FF64               `thenNat` \ tmp ->
+       getBlockIdNat                   `thenNat` \ lbl ->
+       let
+           code = registerCode register tmp
+           result  = registerName register tmp
+
+           code__2 dst = code . mkSeqInstrs [
+               OR zeroh (RIImm (ImmInt 1)) dst,
+               BF cond  result (ImmCLbl lbl),
+               OR zeroh (RIReg zeroh) dst,
+               NEWBLOCK lbl]
+       in
+       return (Any IntRep code__2)
+      where
+       pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
+      ------------------------------------------------------------
+
+getRegister (CmmLoad pk mem)
+  = getAmode mem                   `thenNat` \ amode ->
+    let
+       code = amodeCode amode
+       src   = amodeAddr amode
+       size = primRepToSize pk
+       code__2 dst = code . mkSeqInstr (LD size dst src)
+    in
+    return (Any pk code__2)
+
+getRegister (StInt i)
+  | fits8Bits i
+  = let
+       code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
+    in
+    return (Any IntRep code)
+  | otherwise
+  = let
+       code dst = mkSeqInstr (LDI Q dst src)
+    in
+    return (Any IntRep code)
+  where
+    src = ImmInt (fromInteger i)
+
+getRegister leaf
+  | isJust imm
+  = let
+       code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
+    in
+    return (Any PtrRep code)
+  where
+    imm = maybeImm leaf
+    imm__2 = case imm of Just x -> x
+
+
+getAmode :: CmmExpr -> NatM Amode
+getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree)
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if alpha_TARGET_ARCH
+
+getAmode (StPrim IntSubOp [x, StInt i])
+  = getNewRegNat PtrRep                `thenNat` \ tmp ->
+    getRegister x              `thenNat` \ register ->
+    let
+       code = registerCode register tmp
+       reg  = registerName register tmp
+       off  = ImmInt (-(fromInteger i))
+    in
+    return (Amode (AddrRegImm reg off) code)
+
+getAmode (StPrim IntAddOp [x, StInt i])
+  = getNewRegNat PtrRep                `thenNat` \ tmp ->
+    getRegister x              `thenNat` \ register ->
+    let
+       code = registerCode register tmp
+       reg  = registerName register tmp
+       off  = ImmInt (fromInteger i)
+    in
+    return (Amode (AddrRegImm reg off) code)
+
+getAmode leaf
+  | isJust imm
+  = return (Amode (AddrImm imm__2) id)
+  where
+    imm = maybeImm leaf
+    imm__2 = case imm of Just x -> x
+
+getAmode other
+  = getNewRegNat PtrRep                `thenNat` \ tmp ->
+    getRegister other          `thenNat` \ register ->
+    let
+       code = registerCode register tmp
+       reg  = registerName register tmp
+    in
+    return (Amode (AddrReg reg) code)
+
+#endif /* alpha_TARGET_ARCH */
+
+
+-- -----------------------------------------------------------------------------
+-- Generating assignments
+
+-- Assignments are really at the heart of the whole code generation
+-- business.  Almost all top-level nodes of any real importance are
+-- assignments, which correspond to loads, stores, or register
+-- transfers.  If we're really lucky, some of the register transfers
+-- will go away, because we can use the destination register to
+-- complete the code generation for the right hand side.  This only
+-- fails when the right hand side is forced into a fixed register
+-- (e.g. the result of a call).
+
+assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_IntCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock
+
+assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_FltCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock
+
+
+assignIntCode pk (CmmLoad dst _) src
+  = getNewRegNat IntRep            `thenNat` \ tmp ->
+    getAmode dst                   `thenNat` \ amode ->
+    getRegister src                `thenNat` \ register ->
+    let
+       code1   = amodeCode amode []
+       dst__2  = amodeAddr amode
+       code2   = registerCode register tmp []
+       src__2  = registerName register tmp
+       sz      = primRepToSize pk
+       code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
+    in
+    return code__2
+
+assignIntCode pk dst src
+  = getRegister dst                        `thenNat` \ register1 ->
+    getRegister src                        `thenNat` \ register2 ->
+    let
+       dst__2  = registerName register1 zeroh
+       code    = registerCode register2 dst__2
+       src__2  = registerName register2 dst__2
+       code__2 = if isFixed register2
+                 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
+                 else code
+    in
+    return code__2
+
+assignFltCode pk (CmmLoad dst _) src
+  = getNewRegNat pk                `thenNat` \ tmp ->
+    getAmode dst                   `thenNat` \ amode ->
+    getRegister src                        `thenNat` \ register ->
+    let
+       code1   = amodeCode amode []
+       dst__2  = amodeAddr amode
+       code2   = registerCode register tmp []
+       src__2  = registerName register tmp
+       sz      = primRepToSize pk
+       code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
+    in
+    return code__2
+
+assignFltCode pk dst src
+  = getRegister dst                        `thenNat` \ register1 ->
+    getRegister src                        `thenNat` \ register2 ->
+    let
+       dst__2  = registerName register1 zeroh
+       code    = registerCode register2 dst__2
+       src__2  = registerName register2 dst__2
+       code__2 = if isFixed register2
+                 then code . mkSeqInstr (FMOV src__2 dst__2)
+                 else code
+    in
+    return code__2
+
+
+-- -----------------------------------------------------------------------------
+-- Generating an non-local jump
+
+-- (If applicable) Do not fill the delay slots here; you will confuse the
+-- register allocator.
+
+genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+
+genJump (CmmLabel lbl)
+  | isAsmTemp lbl = returnInstr (BR target)
+  | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
+  where
+    target = ImmCLbl lbl
+
+genJump tree
+  = getRegister tree               `thenNat` \ register ->
+    getNewRegNat PtrRep            `thenNat` \ tmp ->
+    let
+       dst    = registerName register pv
+       code   = registerCode register pv
+       target = registerName register pv
+    in
+    if isFixed register then
+       returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
+    else
+    return (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
+
+
+-- -----------------------------------------------------------------------------
+--  Unconditional branches
+
+genBranch :: BlockId -> NatM InstrBlock
+
+genBranch = return . toOL . mkBranchInstr
+
+
+-- -----------------------------------------------------------------------------
+--  Conditional jumps
+
+{-
+Conditional jumps are always to local labels, so we can use branch
+instructions.  We peek at the arguments to decide what kind of
+comparison to do.
+
+ALPHA: For comparisons with 0, we're laughing, because we can just do
+the desired conditional branch.
+
+-}
+
+
+genCondJump
+    :: BlockId     -- the branch target
+    -> CmmExpr      -- the condition on which to branch
+    -> NatM InstrBlock
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+genCondJump id (StPrim op [x, StInt 0])
+  = getRegister x                          `thenNat` \ register ->
+    getNewRegNat (registerRep register)
+                                   `thenNat` \ tmp ->
+    let
+       code   = registerCode register tmp
+       value  = registerName register tmp
+       pk     = registerRep register
+       target = ImmCLbl lbl
+    in
+    returnSeq code [BI (cmpOp op) value target]
+  where
+    cmpOp CharGtOp = GTT
+    cmpOp CharGeOp = GE
+    cmpOp CharEqOp = EQQ
+    cmpOp CharNeOp = NE
+    cmpOp CharLtOp = LTT
+    cmpOp CharLeOp = LE
+    cmpOp IntGtOp = GTT
+    cmpOp IntGeOp = GE
+    cmpOp IntEqOp = EQQ
+    cmpOp IntNeOp = NE
+    cmpOp IntLtOp = LTT
+    cmpOp IntLeOp = LE
+    cmpOp WordGtOp = NE
+    cmpOp WordGeOp = ALWAYS
+    cmpOp WordEqOp = EQQ
+    cmpOp WordNeOp = NE
+    cmpOp WordLtOp = NEVER
+    cmpOp WordLeOp = EQQ
+    cmpOp AddrGtOp = NE
+    cmpOp AddrGeOp = ALWAYS
+    cmpOp AddrEqOp = EQQ
+    cmpOp AddrNeOp = NE
+    cmpOp AddrLtOp = NEVER
+    cmpOp AddrLeOp = EQQ
+
+genCondJump lbl (StPrim op [x, StDouble 0.0])
+  = getRegister x                          `thenNat` \ register ->
+    getNewRegNat (registerRep register)
+                                   `thenNat` \ tmp ->
+    let
+       code   = registerCode register tmp
+       value  = registerName register tmp
+       pk     = registerRep register
+       target = ImmCLbl lbl
+    in
+    return (code . mkSeqInstr (BF (cmpOp op) value target))
+  where
+    cmpOp FloatGtOp = GTT
+    cmpOp FloatGeOp = GE
+    cmpOp FloatEqOp = EQQ
+    cmpOp FloatNeOp = NE
+    cmpOp FloatLtOp = LTT
+    cmpOp FloatLeOp = LE
+    cmpOp DoubleGtOp = GTT
+    cmpOp DoubleGeOp = GE
+    cmpOp DoubleEqOp = EQQ
+    cmpOp DoubleNeOp = NE
+    cmpOp DoubleLtOp = LTT
+    cmpOp DoubleLeOp = LE
+
+genCondJump lbl (StPrim op [x, y])
+  | fltCmpOp op
+  = trivialFCode pr instr x y      `thenNat` \ register ->
+    getNewRegNat FF64              `thenNat` \ tmp ->
+    let
+       code   = registerCode register tmp
+       result = registerName register tmp
+       target = ImmCLbl lbl
+    in
+    return (code . mkSeqInstr (BF cond result target))
+  where
+    pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
+
+    fltCmpOp op = case op of
+       FloatGtOp -> True
+       FloatGeOp -> True
+       FloatEqOp -> True
+       FloatNeOp -> True
+       FloatLtOp -> True
+       FloatLeOp -> True
+       DoubleGtOp -> True
+       DoubleGeOp -> True
+       DoubleEqOp -> True
+       DoubleNeOp -> True
+       DoubleLtOp -> True
+       DoubleLeOp -> True
+       _ -> False
+    (instr, cond) = case op of
+       FloatGtOp -> (FCMP TF LE, EQQ)
+       FloatGeOp -> (FCMP TF LTT, EQQ)
+       FloatEqOp -> (FCMP TF EQQ, NE)
+       FloatNeOp -> (FCMP TF EQQ, EQQ)
+       FloatLtOp -> (FCMP TF LTT, NE)
+       FloatLeOp -> (FCMP TF LE, NE)
+       DoubleGtOp -> (FCMP TF LE, EQQ)
+       DoubleGeOp -> (FCMP TF LTT, EQQ)
+       DoubleEqOp -> (FCMP TF EQQ, NE)
+       DoubleNeOp -> (FCMP TF EQQ, EQQ)
+       DoubleLtOp -> (FCMP TF LTT, NE)
+       DoubleLeOp -> (FCMP TF LE, NE)
+
+genCondJump lbl (StPrim op [x, y])
+  = trivialCode instr x y          `thenNat` \ register ->
+    getNewRegNat IntRep            `thenNat` \ tmp ->
+    let
+       code   = registerCode register tmp
+       result = registerName register tmp
+       target = ImmCLbl lbl
+    in
+    return (code . mkSeqInstr (BI cond result target))
+  where
+    (instr, cond) = case op of
+       CharGtOp -> (CMP LE, EQQ)
+       CharGeOp -> (CMP LTT, EQQ)
+       CharEqOp -> (CMP EQQ, NE)
+       CharNeOp -> (CMP EQQ, EQQ)
+       CharLtOp -> (CMP LTT, NE)
+       CharLeOp -> (CMP LE, NE)
+       IntGtOp -> (CMP LE, EQQ)
+       IntGeOp -> (CMP LTT, EQQ)
+       IntEqOp -> (CMP EQQ, NE)
+       IntNeOp -> (CMP EQQ, EQQ)
+       IntLtOp -> (CMP LTT, NE)
+       IntLeOp -> (CMP LE, NE)
+       WordGtOp -> (CMP ULE, EQQ)
+       WordGeOp -> (CMP ULT, EQQ)
+       WordEqOp -> (CMP EQQ, NE)
+       WordNeOp -> (CMP EQQ, EQQ)
+       WordLtOp -> (CMP ULT, NE)
+       WordLeOp -> (CMP ULE, NE)
+       AddrGtOp -> (CMP ULE, EQQ)
+       AddrGeOp -> (CMP ULT, EQQ)
+       AddrEqOp -> (CMP EQQ, NE)
+       AddrNeOp -> (CMP EQQ, EQQ)
+       AddrLtOp -> (CMP ULT, NE)
+       AddrLeOp -> (CMP ULE, NE)
+
+-- -----------------------------------------------------------------------------
+--  Generating C calls
+
+-- Now the biggest nightmare---calls.  Most of the nastiness is buried in
+-- @get_arg@, which moves the arguments to the correct registers/stack
+-- locations.  Apart from that, the code is easy.
+-- 
+-- (If applicable) Do not fill the delay slots here; you will confuse the
+-- register allocator.
+
+genCCall
+    :: CmmCallTarget           -- function to call
+    -> HintedCmmFormals                -- where to put the result
+    -> HintedCmmActuals                -- arguments (of mixed type)
+    -> NatM InstrBlock
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ccallResultRegs = 
+
+genCCall fn cconv result_regs args
+  = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
+                         `thenNat` \ ((unused,_), argCode) ->
+    let
+       nRegs = length allArgRegs - length unused
+       code = asmSeqThen (map ($ []) argCode)
+    in
+       returnSeq code [
+           LDA pv (AddrImm (ImmLab (ptext fn))),
+           JSR ra (AddrReg pv) nRegs,
+           LDGP gp (AddrReg ra)]
+  where
+    ------------------------
+    {- Try to get a value into a specific register (or registers) for
+       a call.  The first 6 arguments go into the appropriate
+       argument register (separate registers for integer and floating
+       point arguments, but used in lock-step), and the remaining
+       arguments are dumped to the stack, beginning at 0(sp).  Our
+       first argument is a pair of the list of remaining argument
+       registers to be assigned for this call and the next stack
+       offset to use for overflowing arguments.  This way,
+       @get_Arg@ can be applied to all of a call's arguments using
+       @mapAccumLNat@.
+    -}
+    get_arg
+       :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
+       -> StixTree             -- Current argument
+       -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
+
+    -- We have to use up all of our argument registers first...
+
+    get_arg ((iDst,fDst):dsts, offset) arg
+      = getRegister arg                            `thenNat` \ register ->
+       let
+           reg  = if isFloatType pk then fDst else iDst
+           code = registerCode register reg
+           src  = registerName register reg
+           pk   = registerRep register
+       in
+       return (
+           if isFloatType pk then
+               ((dsts, offset), if isFixed register then
+                   code . mkSeqInstr (FMOV src fDst)
+                   else code)
+           else
+               ((dsts, offset), if isFixed register then
+                   code . mkSeqInstr (OR src (RIReg src) iDst)
+                   else code))
+
+    -- Once we have run out of argument registers, we move to the
+    -- stack...
+
+    get_arg ([], offset) arg
+      = getRegister arg                        `thenNat` \ register ->
+       getNewRegNat (registerRep register)
+                                       `thenNat` \ tmp ->
+       let
+           code = registerCode register tmp
+           src  = registerName register tmp
+           pk   = registerRep register
+           sz   = primRepToSize pk
+       in
+       return (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
+
+trivialCode instr x (StInt y)
+  | fits8Bits y
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNat IntRep                `thenNat` \ tmp ->
+    let
+       code = registerCode register tmp
+       src1 = registerName register tmp
+       src2 = ImmInt (fromInteger y)
+       code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
+    in
+    return (Any IntRep code__2)
+
+trivialCode instr x y
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->
+    getNewRegNat IntRep                `thenNat` \ tmp1 ->
+    getNewRegNat IntRep                `thenNat` \ tmp2 ->
+    let
+       code1 = registerCode register1 tmp1 []
+       src1  = registerName register1 tmp1
+       code2 = registerCode register2 tmp2 []
+       src2  = registerName register2 tmp2
+       code__2 dst = asmSeqThen [code1, code2] .
+                    mkSeqInstr (instr src1 (RIReg src2) dst)
+    in
+    return (Any IntRep code__2)
+
+------------
+trivialUCode instr x
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNat IntRep                `thenNat` \ tmp ->
+    let
+       code = registerCode register tmp
+       src  = registerName register tmp
+       code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
+    in
+    return (Any IntRep code__2)
+
+------------
+trivialFCode _ instr x y
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->
+    getNewRegNat FF64  `thenNat` \ tmp1 ->
+    getNewRegNat FF64  `thenNat` \ tmp2 ->
+    let
+       code1 = registerCode register1 tmp1
+       src1  = registerName register1 tmp1
+
+       code2 = registerCode register2 tmp2
+       src2  = registerName register2 tmp2
+
+       code__2 dst = asmSeqThen [code1 [], code2 []] .
+                     mkSeqInstr (instr src1 src2 dst)
+    in
+    return (Any FF64 code__2)
+
+trivialUFCode _ instr x
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNat FF64  `thenNat` \ tmp ->
+    let
+       code = registerCode register tmp
+       src  = registerName register tmp
+       code__2 dst = code . mkSeqInstr (instr src dst)
+    in
+    return (Any FF64 code__2)
+
+#if alpha_TARGET_ARCH
+
+coerceInt2FP _ x
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNat IntRep                `thenNat` \ reg ->
+    let
+       code = registerCode register reg
+       src  = registerName register reg
+
+       code__2 dst = code . mkSeqInstrs [
+           ST Q src (spRel 0),
+           LD TF dst (spRel 0),
+           CVTxy Q TF dst dst]
+    in
+    return (Any FF64 code__2)
+
+-------------
+coerceFP2Int x
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNat FF64  `thenNat` \ tmp ->
+    let
+       code = registerCode register tmp
+       src  = registerName register tmp
+
+       code__2 dst = code . mkSeqInstrs [
+           CVTxy TF Q src tmp,
+           ST TF tmp (spRel 0),
+           LD Q dst (spRel 0)]
+    in
+    return (Any IntRep code__2)
+
+#endif /* alpha_TARGET_ARCH */
+
+
+-}
+
+
+
+
+
index e2d66d3..990ea8b 100644 (file)
 #include "nativeGen/NCG.h"
 
 module Alpha.Instr (
-       Cond(..),
-       Instr(..),
-       RI(..)
+--     Cond(..),
+--     Instr(..),
+--     RI(..)
 )
 
 where
 
+{-
 import BlockId
 import Regs
 import Cmm
@@ -138,3 +139,4 @@ data Instr
        | FUNEND CLabel
 
 
+-}
diff --git a/compiler/nativeGen/ArchReg.hs b/compiler/nativeGen/ArchReg.hs
new file mode 100644 (file)
index 0000000..7170228
--- /dev/null
@@ -0,0 +1,14 @@
+
+
+module ArchReg (
+
+)
+
+where
+
+
+class ArchReg reg format where
+       classOfReg      :: reg    -> RegClass
+       mkVReg          :: format -> VirtReg reg
+       
+       
index ce411ed..8613a8e 100644 (file)
@@ -19,21 +19,56 @@ module AsmCodeGen ( nativeCodeGen ) where
 #include "HsVersions.h"
 #include "nativeGen/NCG.h"
 
-import Instrs
-import Regs
-import MachCodeGen
-import PprMach
-import RegAllocInfo
-import NCGMonad
-import PositionIndependentCode
-import RegAlloc.Liveness
 
-import qualified RegAlloc.Linear.Main  as Linear
+#if   alpha_TARGET_ARCH
+import Alpha.CodeGen
+import Alpha.Regs
+import Alpha.RegInfo
+import Alpha.Instr
+import Alpha.Ppr
+
+#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
+import X86.CodeGen
+import X86.Regs
+import X86.RegInfo
+import X86.Instr
+import X86.Ppr
+
+#elif sparc_TARGET_ARCH
+import SPARC.CodeGen
+import SPARC.Regs
+import SPARC.RegInfo
+import SPARC.Instr
+import SPARC.Ppr
+
+#elif powerpc_TARGET_ARCH
+import PPC.CodeGen
+import PPC.Regs
+import PPC.RegInfo
+import PPC.Instr
+import PPC.Ppr
+
+#else
+#error "AsmCodeGen: unknown architecture"
+
+#endif
+
+import RegAlloc.Liveness
+import qualified RegAlloc.Linear.Main          as Linear
 
 import qualified GraphColor                    as Color
 import qualified RegAlloc.Graph.Main           as Color
 import qualified RegAlloc.Graph.Stats          as Color
 import qualified RegAlloc.Graph.Coalesce       as Color
+import qualified RegAlloc.Graph.TrivColorable  as Color
+
+import qualified TargetReg                     as Target
+
+import Platform
+import Instruction
+import PIC
+import Reg
+import NCGMonad
 
 import Cmm
 import CmmOpt          ( cmmMiniInline, cmmMachOpFold )
@@ -160,7 +195,7 @@ nativeCodeGen dflags h us cmms
 
                dumpIfSet_dyn dflags
                        Opt_D_dump_asm_conflicts "Register conflict graph"
-                       $ Color.dotGraph Color.regDotColor trivColorable
+                       $ Color.dotGraph Target.targetRegDotColor (Color.trivColorable Target.targetRegClass)
                        $ graphGlobal)
 
 
@@ -172,7 +207,7 @@ nativeCodeGen dflags h us cmms
 
        -- write out the imports
        Pretty.printDoc Pretty.LeftMode h
-               $ makeImportsDoc (concat imports)
+               $ makeImportsDoc dflags (concat imports)
 
        return  ()
 
@@ -225,13 +260,13 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
 cmmNativeGen 
        :: DynFlags
        -> UniqSupply
-       -> RawCmmTop                            -- ^ the cmm to generate code for
-       -> Int                                  -- ^ sequence number of this top thing
+       -> RawCmmTop                                    -- ^ the cmm to generate code for
+       -> Int                                          -- ^ sequence number of this top thing
        -> IO   ( UniqSupply
-               , [NatCmmTop]                   -- native code
-               , [CLabel]                      -- things imported by this cmm
-               , Maybe [Color.RegAllocStats]   -- stats for the coloring register allocator
-               , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators
+               , [NatCmmTop Instr]                     -- native code
+               , [CLabel]                              -- things imported by this cmm
+               , Maybe [Color.RegAllocStats Instr]     -- stats for the coloring register allocator
+               , Maybe [Linear.RegAllocStats])         -- stats for the linear register allocators
 
 cmmNativeGen dflags us cmm count
  = do
@@ -375,8 +410,8 @@ x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) =
 
 -- | Build a doc for all the imports.
 --
-makeImportsDoc :: [CLabel] -> Pretty.Doc
-makeImportsDoc imports
+makeImportsDoc :: DynFlags -> [CLabel] -> Pretty.Doc
+makeImportsDoc dflags imports
  = dyld_stubs imports
 
 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
@@ -410,13 +445,16 @@ makeImportsDoc imports
 {-      dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
                                    map head $ group $ sort imps-}
 
+       arch    = platformArch  $ targetPlatform dflags
+       os      = platformOS    $ targetPlatform dflags
+       
        -- (Hack) sometimes two Labels pretty-print the same, but have
        -- different uniques; so we compare their text versions...
        dyld_stubs imps
-               | needImportedSymbols
+               | needImportedSymbols arch os
                = Pretty.vcat $
-                       (pprGotDeclaration :) $
-                       map (pprImportedSymbol . fst . head) $
+                       (pprGotDeclaration arch os :) $
+                       map ( pprImportedSymbol arch os . fst . head) $
                        groupBy (\(_,a) (_,b) -> a == b) $
                        sortBy (\(_,a) (_,b) -> compare a b) $
                        map doPpr $
@@ -437,7 +475,11 @@ makeImportsDoc imports
 -- such that as many of the local jumps as possible turn into
 -- fallthroughs.
 
-sequenceTop :: NatCmmTop -> NatCmmTop
+sequenceTop 
+       :: Instruction instr
+       => NatCmmTop instr
+       -> NatCmmTop instr
+
 sequenceTop top@(CmmData _ _) = top
 sequenceTop (CmmProc info lbl params (ListGraph blocks)) = 
   CmmProc info lbl params (ListGraph $ makeFarBranches $ sequenceBlocks blocks)
@@ -452,21 +494,36 @@ sequenceTop (CmmProc info lbl params (ListGraph blocks)) =
 -- FYI, the classic layout for basic blocks uses postorder DFS; this
 -- algorithm is implemented in cmm/ZipCfg.hs (NR 6 Sep 2007).
 
-sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock]
+sequenceBlocks 
+       :: Instruction instr
+       => [NatBasicBlock instr] 
+       -> [NatBasicBlock instr]
+
 sequenceBlocks [] = []
 sequenceBlocks (entry:blocks) = 
   seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
   -- the first block is the entry point ==> it must remain at the start.
 
-sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])]
+
+sccBlocks 
+       :: Instruction instr
+       => [NatBasicBlock instr] 
+       -> [SCC ( NatBasicBlock instr
+               , Unique
+               , [Unique])]
+
 sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
 
-getOutEdges :: [Instr] -> [Unique]
-getOutEdges instrs = case jumpDests (last instrs) [] of
-                       [one] -> [getUnique one]
-                       _many -> []
-               -- we're only interested in the last instruction of
-               -- the block, and only if it has a single destination.
+-- we're only interested in the last instruction of
+-- the block, and only if it has a single destination.
+getOutEdges 
+       :: Instruction instr
+       => [instr] -> [Unique]
+
+getOutEdges instrs 
+       = case jumpDestsOfInstr (last instrs) of
+               [one] -> [getUnique one]
+               _many -> []
 
 mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
 
@@ -494,7 +551,10 @@ reorder id accum (b@(block,id',out) : rest)
 -- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
 -- big, we have to work around this limitation.
 
-makeFarBranches :: [NatBasicBlock] -> [NatBasicBlock]
+makeFarBranches 
+       :: Instruction instr
+       => [NatBasicBlock instr] 
+       -> [NatBasicBlock instr]
 
 #if powerpc_TARGET_ARCH
 makeFarBranches blocks
@@ -530,7 +590,11 @@ makeFarBranches = id
 -- -----------------------------------------------------------------------------
 -- Shortcut branches
 
-shortcutBranches :: DynFlags -> [NatCmmTop] -> [NatCmmTop]
+shortcutBranches 
+       :: DynFlags 
+       -> [NatCmmTop Instr] 
+       -> [NatCmmTop Instr]
+
 shortcutBranches dflags tops
   | optLevel dflags < 1 = tops    -- only with -O or higher
   | otherwise           = map (apply_mapping mapping) tops'
@@ -589,12 +653,17 @@ apply_mapping ufm (CmmProc info lbl params (ListGraph blocks))
 -- Switching between the two monads whilst carrying along the same
 -- Unique supply breaks abstraction.  Is that bad?
 
-genMachCode :: DynFlags -> RawCmmTop -> UniqSM ([NatCmmTop], [CLabel])
+genMachCode 
+       :: DynFlags 
+       -> RawCmmTop 
+       -> UniqSM 
+               ( [NatCmmTop Instr]
+               , [CLabel])
 
 genMachCode dflags cmm_top
   = do { initial_us <- getUs
        ; let initial_st           = mkNatM_State initial_us 0 dflags
-             (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
+             (new_tops, final_st) = initNat initial_st (cmmTopCodeGen dflags cmm_top)
              final_delta          = natm_delta final_st
              final_imports        = natm_imports final_st
        ; if   final_delta == 0
diff --git a/compiler/nativeGen/Instrs.hs b/compiler/nativeGen/Instrs.hs
deleted file mode 100644 (file)
index 3f38a36..0000000
+++ /dev/null
@@ -1,97 +0,0 @@
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
------------------------------------------------------------------------------
---
--- Machine-dependent assembly language
---
--- (c) The University of Glasgow 1993-2004
---
------------------------------------------------------------------------------
-
-#include "nativeGen/NCG.h"
-
-
-module Instrs (
-       NatCmm,
-       NatCmmTop,
-       NatBasicBlock,
-       condUnsigned,
-       condToSigned,
-       condToUnsigned,
-
-#if   alpha_TARGET_ARCH
-       module Alpha.Instr
-#elif powerpc_TARGET_ARCH
-       module PPC.Instr
-#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
-       module X86.Instr
-#elif sparc_TARGET_ARCH
-       module SPARC.Instr
-#else
-#error "Instrs: not defined for this architecture"
-#endif
-)
-
-where
-
-#include "HsVersions.h"
-
-import BlockId
-import Regs
-import Cmm
-import CLabel           ( CLabel, pprCLabel )
-import Panic           ( panic )
-import Outputable
-import FastString
-import Constants       ( wORD_SIZE )
-
-import GHC.Exts
-
-#if   alpha_TARGET_ARCH
-import Alpha.Instr
-#elif powerpc_TARGET_ARCH
-import PPC.Instr
-#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
-import X86.Instr
-#elif sparc_TARGET_ARCH
-import SPARC.Instr
-#else
-#error "Instrs: not defined for this architecture"
-#endif
-
-
--- Our flavours of the Cmm types
--- Type synonyms for Cmm populated with native code
-
-type NatCmm        = GenCmm CmmStatic [CmmStatic] (ListGraph Instr)
-type NatCmmTop     = GenCmmTop CmmStatic [CmmStatic] (ListGraph Instr)
-type NatBasicBlock = GenBasicBlock Instr
-
-
--- Condition utils
-condUnsigned GU  = True
-condUnsigned LU  = True
-condUnsigned GEU = True
-condUnsigned LEU = True
-condUnsigned _   = False
-
-condToSigned GU  = GTT
-condToSigned LU  = LTT
-condToSigned GEU = GE
-condToSigned LEU = LE
-condToSigned x   = x
-
-condToUnsigned GTT = GU
-condToUnsigned LTT = LU
-condToUnsigned GE  = GEU
-condToUnsigned LE  = LEU
-condToUnsigned x   = x
-
-
-
-
diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs
new file mode 100644 (file)
index 0000000..22c37a5
--- /dev/null
@@ -0,0 +1,159 @@
+
+module Instruction (
+       RegUsage(..),
+       noUsage,
+       NatCmm,
+       NatCmmTop,
+       NatBasicBlock,
+       Instruction(..)
+)
+
+where
+
+import Reg
+
+import BlockId
+import Cmm
+
+-- | Holds a list of source and destination registers used by a
+--     particular instruction. 
+--
+--   Machine registers that are pre-allocated to stgRegs are filtered
+--     out, because they are uninteresting from a register allocation
+--     standpoint.  (We wouldn't want them to end up on the free list!) 
+--
+--   As far as we are concerned, the fixed registers simply don't exist
+--     (for allocation purposes, anyway).
+--
+data RegUsage 
+       = RU [Reg] [Reg]
+
+-- | No regs read or written to.
+noUsage :: RegUsage
+noUsage  = RU [] []
+
+
+-- Our flavours of the Cmm types
+-- Type synonyms for Cmm populated with native code
+type NatCmm instr
+       = GenCmm
+               CmmStatic
+               [CmmStatic]
+               (ListGraph instr)
+
+type NatCmmTop instr
+       = GenCmmTop
+               CmmStatic
+               [CmmStatic]
+               (ListGraph instr)
+
+
+type NatBasicBlock instr
+       = GenBasicBlock instr
+
+
+
+
+-- | Common things that we can do with instructions, on all architectures.
+--     These are used by the shared parts of the native code generator,
+--     specifically the register allocators.
+--
+class  Instruction instr where
+       
+       -- | Get the registers that are being used by this instruction.
+       --      regUsage doesn't need to do any trickery for jumps and such.  
+       --      Just state precisely the regs read and written by that insn.  
+       --      The consequences of control flow transfers, as far as register
+       --      allocation goes, are taken care of by the register allocator.
+       --
+       regUsageOfInstr
+               :: instr        
+               -> RegUsage
+
+
+       -- | Apply a given mapping to all the register references in this
+       --      instruction.
+       patchRegsOfInstr
+               :: instr 
+               -> (Reg -> Reg) 
+               -> instr
+
+       
+       -- | Checks whether this instruction is a jump/branch instruction. 
+       --      One that can change the flow of control in a way that the 
+       --      register allocator needs to worry about. 
+       isJumpishInstr
+               :: instr -> Bool
+
+
+       -- | Give the possible destinations of this jump instruction.
+       --      Must be defined for all jumpish instructions.
+       jumpDestsOfInstr
+               :: instr -> [BlockId]
+       
+
+       -- | Change the destination of this jump instruction.
+       --      Used in the linear allocator when adding fixup blocks for join
+       --      points.
+       patchJumpInstr
+               :: instr
+               -> (BlockId -> BlockId)
+               -> instr
+
+               
+       -- | An instruction to spill a register into a spill slot.
+       mkSpillInstr    
+               :: Reg          -- ^ the reg to spill
+               -> Int          -- ^ the current stack delta
+               -> Int          -- ^ spill slot to use
+               -> instr
+
+               
+       -- | An instruction to reload a register from a spill slot.
+       mkLoadInstr     
+               :: Reg          -- ^ the reg to reload.
+               -> Int          -- ^ the current stack delta
+               -> Int          -- ^ the spill slot to use
+               -> instr
+
+       -- | See if this instruction is telling us the current C stack delta
+       takeDeltaInstr 
+               :: instr
+               -> Maybe Int
+
+       -- | Check whether this instruction is some meta thing inserted into 
+       --      the instruction stream for other purposes.
+       --
+       --      Not something that has to be treated as a real machine instruction
+       --      and have its registers allocated.
+       --
+       --      eg, comments, delta, ldata, etc. 
+       isMetaInstr     
+               :: instr
+               -> Bool
+               
+
+               
+       -- | Copy the value in a register to another one.
+       --      Must work for all register classes.
+       mkRegRegMoveInstr
+               :: Reg          -- ^ source register
+               -> Reg          -- ^ destination register
+               -> instr
+
+       -- | Take the source and destination from this reg -> reg move instruction
+       --      or Nothing if it's not one
+       takeRegRegMoveInstr
+               :: instr
+               -> Maybe (Reg, Reg)
+               
+       -- | Make an unconditional jump instruction.
+       --      For architectures with branch delay slots, its ok to put
+       --      a NOP after the jump. Don't fill the delay slot with an
+       --      instruction that references regs or you'll confuse the 
+       --      linear allocator.
+       mkJumpInstr     
+               :: BlockId
+               -> [instr]
+               
+               
diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs
deleted file mode 100644 (file)
index d94a906..0000000
+++ /dev/null
@@ -1,5199 +0,0 @@
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
------------------------------------------------------------------------------
---
--- Generating machine code (instruction selection)
---
--- (c) The University of Glasgow 1996-2004
---
------------------------------------------------------------------------------
-
--- This is a big module, but, if you pay attention to
--- (a) the sectioning, (b) the type signatures, and
--- (c) the #if blah_TARGET_ARCH} things, the
--- structure should not be too overwhelming.
-
-module MachCodeGen ( cmmTopCodeGen, InstrBlock ) where
-
-#include "HsVersions.h"
-#include "nativeGen/NCG.h"
-#include "MachDeps.h"
-
--- NCG stuff:
-import Instrs
-import Regs
-import NCGMonad
-import PositionIndependentCode
-import RegAllocInfo    ( mkBranchInstr, mkRegRegMoveInstr )
-import PprMach
-
--- Our intermediate code:
-import BlockId
-import PprCmm          ( pprExpr )
-import Cmm
-import CLabel
-import ClosureInfo     ( C_SRT(..) )
-
--- The rest:
-import BasicTypes
-import StaticFlags     ( opt_PIC )
-import ForeignCall     ( CCallConv(..) )
-import OrdList
-import Pretty
-import qualified Outputable as O
-import Outputable
-import FastString
-import FastBool                ( isFastTrue )
-import Constants       ( wORD_SIZE )
-
-import Debug.Trace     ( trace )
-
-import Control.Monad   ( mapAndUnzipM )
-import Data.Maybe      ( fromJust )
-import Data.Bits
-import Data.Word
-import Data.Int
-
-
--- -----------------------------------------------------------------------------
--- Top-level of the instruction selector
-
--- | 'InstrBlock's are the insn sequences generated by the insn selectors.
--- They are really trees of insns to facilitate fast appending, where a
--- left-to-right traversal (pre-order?) yields the insns in the correct
--- order.
-
-type InstrBlock = OrdList Instr
-
-cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop]
-cmmTopCodeGen (CmmProc info lab params (ListGraph blocks)) = do
-  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
-  picBaseMb <- getPicBaseMaybeNat
-  let proc = CmmProc info lab params (ListGraph $ concat nat_blocks)
-      tops = proc : concat statics
-  case picBaseMb of
-      Just picBase -> initializePicBase picBase tops
-      Nothing -> return tops
-  
-cmmTopCodeGen (CmmData sec dat) = do
-  return [CmmData sec dat]  -- no translation, we just use CmmStatic
-
-basicBlockCodeGen :: CmmBasicBlock -> NatM ([NatBasicBlock],[NatCmmTop])
-basicBlockCodeGen (BasicBlock id stmts) = do
-  instrs <- stmtsToInstrs stmts
-  -- code generation may introduce new basic block boundaries, which
-  -- are indicated by the NEWBLOCK instruction.  We must split up the
-  -- instruction stream into basic blocks again.  Also, we extract
-  -- LDATAs here too.
-  let
-       (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
-       
-       mkBlocks (NEWBLOCK id) (instrs,blocks,statics) 
-         = ([], BasicBlock id instrs : blocks, statics)
-       mkBlocks (LDATA sec dat) (instrs,blocks,statics) 
-         = (instrs, blocks, CmmData sec dat:statics)
-       mkBlocks instr (instrs,blocks,statics)
-         = (instr:instrs, blocks, statics)
-  -- in
-  return (BasicBlock id top : other_blocks, statics)
-
-stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
-stmtsToInstrs stmts
-   = do instrss <- mapM stmtToInstrs stmts
-        return (concatOL instrss)
-
-stmtToInstrs :: CmmStmt -> NatM InstrBlock
-stmtToInstrs stmt = case stmt of
-    CmmNop        -> return nilOL
-    CmmComment s   -> return (unitOL (COMMENT s))
-
-    CmmAssign reg src
-      | isFloatType ty -> assignReg_FltCode size reg src
-#if WORD_SIZE_IN_BITS==32
-      | isWord64 ty    -> assignReg_I64Code      reg src
-#endif
-      | otherwise       -> assignReg_IntCode size reg src
-       where ty = cmmRegType reg
-             size = cmmTypeSize ty
-
-    CmmStore addr src
-      | isFloatType ty -> assignMem_FltCode size addr src
-#if WORD_SIZE_IN_BITS==32
-      | isWord64 ty     -> assignMem_I64Code      addr src
-#endif
-      | otherwise       -> assignMem_IntCode size addr src
-       where ty = cmmExprType src
-             size = cmmTypeSize ty
-
-    CmmCall target result_regs args _ _
-       -> genCCall target result_regs args
-
-    CmmBranch id         -> genBranch id
-    CmmCondBranch arg id  -> genCondJump id arg
-    CmmSwitch arg ids     -> genSwitch arg ids
-    CmmJump arg params   -> genJump arg
-    CmmReturn params     ->
-      panic "stmtToInstrs: return statement should have been cps'd away"
-
--- -----------------------------------------------------------------------------
--- General things for putting together code sequences
-
--- Expand CmmRegOff.  ToDo: should we do it this way around, or convert
--- CmmExprs into CmmRegOff?
-mangleIndexTree :: CmmExpr -> CmmExpr
-mangleIndexTree (CmmRegOff reg off)
-  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
-  where width = typeWidth (cmmRegType reg)
-
--- -----------------------------------------------------------------------------
---  Code gen for 64-bit arithmetic on 32-bit platforms
-
-{-
-Simple support for generating 64-bit code (ie, 64 bit values and 64
-bit assignments) on 32-bit platforms.  Unlike the main code generator
-we merely shoot for generating working code as simply as possible, and
-pay little attention to code quality.  Specifically, there is no
-attempt to deal cleverly with the fixed-vs-floating register
-distinction; all values are generated into (pairs of) floating
-registers, even if this would mean some redundant reg-reg moves as a
-result.  Only one of the VRegUniques is returned, since it will be
-of the VRegUniqueLo form, and the upper-half VReg can be determined
-by applying getHiVRegFromLo to it.
--}
-
-data ChildCode64       -- a.k.a "Register64"
-   = ChildCode64 
-        InstrBlock     -- code
-        Reg            -- the lower 32-bit temporary which contains the
-                       -- result; use getHiVRegFromLo to find the other
-                       -- VRegUnique.  Rules of this simplified insn
-                       -- selection game are therefore that the returned
-                       -- Reg may be modified
-
-#if WORD_SIZE_IN_BITS==32
-assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
-assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
-#endif
-
-#ifndef x86_64_TARGET_ARCH
-iselExpr64        :: CmmExpr -> NatM ChildCode64
-#endif
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
-assignMem_I64Code addrTree valueTree = do
-  Amode addr addr_code <- getAmode addrTree
-  ChildCode64 vcode rlo <- iselExpr64 valueTree
-  let 
-        rhi = getHiVRegFromLo rlo
-
-        -- Little-endian store
-        mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)
-        mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))
-  -- in
-  return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
-
-
-assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
-   ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
-   let 
-         r_dst_lo = mkVReg u_dst II32
-         r_dst_hi = getHiVRegFromLo r_dst_lo
-         r_src_hi = getHiVRegFromLo r_src_lo
-         mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)
-         mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)
-   -- in
-   return (
-        vcode `snocOL` mov_lo `snocOL` mov_hi
-     )
-
-assignReg_I64Code lvalue valueTree
-   = panic "assignReg_I64Code(i386): invalid lvalue"
-
-------------
-
-iselExpr64 (CmmLit (CmmInt i _)) = do
-  (rlo,rhi) <- getNewRegPairNat II32
-  let
-       r = fromIntegral (fromIntegral i :: Word32)
-       q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32)
-       code = toOL [
-               MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),
-               MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)
-               ]
-  -- in
-  return (ChildCode64 code rlo)
-
-iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do
-   Amode addr addr_code <- getAmode addrTree
-   (rlo,rhi) <- getNewRegPairNat II32
-   let 
-        mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)
-        mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)
-   -- in
-   return (
-            ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) 
-                        rlo
-     )
-
-iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty
-   = return (ChildCode64 nilOL (mkVReg vu II32))
-         
--- we handle addition, but rather badly
-iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do
-   ChildCode64 code1 r1lo <- iselExpr64 e1
-   (rlo,rhi) <- getNewRegPairNat II32
-   let
-       r = fromIntegral (fromIntegral i :: Word32)
-       q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32)
-       r1hi = getHiVRegFromLo r1lo
-       code =  code1 `appOL`
-               toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),
-                      ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),
-                      MOV II32 (OpReg r1hi) (OpReg rhi),
-                      ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]
-   -- in
-   return (ChildCode64 code rlo)
-
-iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
-   ChildCode64 code1 r1lo <- iselExpr64 e1
-   ChildCode64 code2 r2lo <- iselExpr64 e2
-   (rlo,rhi) <- getNewRegPairNat II32
-   let
-       r1hi = getHiVRegFromLo r1lo
-       r2hi = getHiVRegFromLo r2lo
-       code =  code1 `appOL`
-               code2 `appOL`
-               toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),
-                      ADD II32 (OpReg r2lo) (OpReg rlo),
-                      MOV II32 (OpReg r1hi) (OpReg rhi),
-                      ADC II32 (OpReg r2hi) (OpReg rhi) ]
-   -- in
-   return (ChildCode64 code rlo)
-
-iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do
-     fn <- getAnyReg expr
-     r_dst_lo <-  getNewRegNat II32
-     let r_dst_hi = getHiVRegFromLo r_dst_lo
-         code = fn r_dst_lo
-     return (
-             ChildCode64 (code `snocOL` 
-                          MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi))
-                          r_dst_lo
-            )
-
-iselExpr64 expr
-   = pprPanic "iselExpr64(i386)" (ppr expr)
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-assignMem_I64Code addrTree valueTree = do
-     Amode addr addr_code <- getAmode addrTree
-     ChildCode64 vcode rlo <- iselExpr64 valueTree  
-     (src, code) <- getSomeReg addrTree
-     let 
-         rhi = getHiVRegFromLo rlo
-         -- Big-endian store
-         mov_hi = ST II32 rhi (AddrRegImm src (ImmInt 0))
-         mov_lo = ST II32 rlo (AddrRegImm src (ImmInt 4))
-     return (vcode `appOL` code `snocOL` mov_hi `snocOL` mov_lo)
-
-assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
-     ChildCode64 vcode r_src_lo <- iselExpr64 valueTree    
-     let 
-         r_dst_lo = mkVReg u_dst (cmmTypeSize pk)
-         r_dst_hi = getHiVRegFromLo r_dst_lo
-         r_src_hi = getHiVRegFromLo r_src_lo
-         mov_lo = mkMOV r_src_lo r_dst_lo
-         mov_hi = mkMOV r_src_hi r_dst_hi
-         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
-     return (vcode `snocOL` mov_hi `snocOL` mov_lo)
-assignReg_I64Code lvalue valueTree
-   = panic "assignReg_I64Code(sparc): invalid lvalue"
-
-
--- Load a 64 bit word
-iselExpr64 (CmmLoad addrTree ty) 
- | isWord64 ty
- = do  Amode amode addr_code   <- getAmode addrTree
-       let result
-
-               | AddrRegReg r1 r2      <- amode
-               = do    rlo     <- getNewRegNat II32
-                       tmp     <- getNewRegNat II32
-                       let rhi = getHiVRegFromLo rlo
-
-                       return  $ ChildCode64 
-                               (        addr_code 
-                               `appOL`  toOL
-                                        [ ADD False False r1 (RIReg r2) tmp
-                                        , LD II32 (AddrRegImm tmp (ImmInt 0)) rhi
-                                        , LD II32 (AddrRegImm tmp (ImmInt 4)) rlo ])
-                               rlo
-
-               | AddrRegImm r1 (ImmInt i) <- amode
-               = do    rlo     <- getNewRegNat II32
-                       let rhi = getHiVRegFromLo rlo
-                       
-                       return  $ ChildCode64 
-                               (        addr_code 
-                               `appOL`  toOL
-                                        [ LD II32 (AddrRegImm r1 (ImmInt $ 0 + i)) rhi
-                                        , LD II32 (AddrRegImm r1 (ImmInt $ 4 + i)) rlo ])
-                               rlo
-               
-       result
-
-
--- Add a literal to a 64 bit integer
-iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) 
- = do  ChildCode64 code1 r1_lo <- iselExpr64 e1
-       let r1_hi       = getHiVRegFromLo r1_lo
-       
-       r_dst_lo        <- getNewRegNat II32
-       let r_dst_hi    =  getHiVRegFromLo r_dst_lo 
-       
-       return  $ ChildCode64
-                       ( toOL
-                       [ ADD False False r1_lo (RIImm (ImmInteger i)) r_dst_lo
-                       , ADD True  False r1_hi (RIReg g0)         r_dst_hi ])
-                       r_dst_lo
-
-
--- Addition of II64
-iselExpr64 (CmmMachOp (MO_Add width) [e1, e2])
- = do  ChildCode64 code1 r1_lo <- iselExpr64 e1
-       let r1_hi       = getHiVRegFromLo r1_lo
-
-       ChildCode64 code2 r2_lo <- iselExpr64 e2
-       let r2_hi       = getHiVRegFromLo r2_lo
-       
-       r_dst_lo        <- getNewRegNat II32
-       let r_dst_hi    = getHiVRegFromLo r_dst_lo
-       
-       let code =      code1
-               `appOL` code2
-               `appOL` toOL
-                       [ ADD False False r1_lo (RIReg r2_lo) r_dst_lo
-                       , ADD True  False r1_hi (RIReg r2_hi) r_dst_hi ]
-       
-       return  $ ChildCode64 code r_dst_lo
-
-
-iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty))) | isWord64 ty = do
-     r_dst_lo <-  getNewRegNat II32
-     let r_dst_hi = getHiVRegFromLo r_dst_lo
-         r_src_lo = mkVReg uq II32
-         r_src_hi = getHiVRegFromLo r_src_lo
-         mov_lo = mkMOV r_src_lo r_dst_lo
-         mov_hi = mkMOV r_src_hi r_dst_hi
-         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
-     return (
-            ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo
-         )
-
--- Convert something into II64
-iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) 
- = do
-       r_dst_lo        <- getNewRegNat II32
-       let r_dst_hi    = getHiVRegFromLo r_dst_lo
-
-       -- compute expr and load it into r_dst_lo
-       (a_reg, a_code) <- getSomeReg expr
-
-       let code        = a_code
-               `appOL` toOL
-                       [ mkRegRegMoveInstr g0    r_dst_hi      -- clear high 32 bits
-                       , mkRegRegMoveInstr a_reg r_dst_lo ]
-                       
-       return  $ ChildCode64 code r_dst_lo
-
-
-iselExpr64 expr
-   = pprPanic "iselExpr64(sparc)" (ppr expr)
-
-#endif /* sparc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if powerpc_TARGET_ARCH
-
-getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)
-getI64Amodes addrTree = do
-    Amode hi_addr addr_code <- getAmode addrTree
-    case addrOffset hi_addr 4 of
-        Just lo_addr -> return (hi_addr, lo_addr, addr_code)
-        Nothing      -> do (hi_ptr, code) <- getSomeReg addrTree
-                           return (AddrRegImm hi_ptr (ImmInt 0),
-                                   AddrRegImm hi_ptr (ImmInt 4),
-                                   code)
-
-assignMem_I64Code addrTree valueTree = do
-        (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
-       ChildCode64 vcode rlo <- iselExpr64 valueTree
-       let 
-               rhi = getHiVRegFromLo rlo
-
-               -- Big-endian store
-               mov_hi = ST II32 rhi hi_addr
-               mov_lo = ST II32 rlo lo_addr
-       -- in
-       return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
-
-assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
-   ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
-   let 
-         r_dst_lo = mkVReg u_dst II32
-         r_dst_hi = getHiVRegFromLo r_dst_lo
-         r_src_hi = getHiVRegFromLo r_src_lo
-         mov_lo = MR r_dst_lo r_src_lo
-         mov_hi = MR r_dst_hi r_src_hi
-   -- in
-   return (
-        vcode `snocOL` mov_lo `snocOL` mov_hi
-     )
-
-assignReg_I64Code lvalue valueTree
-   = panic "assignReg_I64Code(powerpc): invalid lvalue"
-
-
--- Don't delete this -- it's very handy for debugging.
---iselExpr64 expr 
---   | trace ("iselExpr64: " ++ showSDoc (pprCmmExpr expr)) False
---   = panic "iselExpr64(???)"
-
-iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do
-    (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
-    (rlo, rhi) <- getNewRegPairNat II32
-    let mov_hi = LD II32 rhi hi_addr
-        mov_lo = LD II32 rlo lo_addr
-    return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) 
-                         rlo
-
-iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty
-   = return (ChildCode64 nilOL (mkVReg vu II32))
-
-iselExpr64 (CmmLit (CmmInt i _)) = do
-  (rlo,rhi) <- getNewRegPairNat II32
-  let
-       half0 = fromIntegral (fromIntegral i :: Word16)
-       half1 = fromIntegral ((fromIntegral i `shiftR` 16) :: Word16)
-       half2 = fromIntegral ((fromIntegral i `shiftR` 32) :: Word16)
-       half3 = fromIntegral ((fromIntegral i `shiftR` 48) :: Word16)
-       
-       code = toOL [
-               LIS rlo (ImmInt half1),
-               OR rlo rlo (RIImm $ ImmInt half0),
-               LIS rhi (ImmInt half3),
-               OR rlo rlo (RIImm $ ImmInt half2)
-               ]
-  -- in
-  return (ChildCode64 code rlo)
-
-iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
-   ChildCode64 code1 r1lo <- iselExpr64 e1
-   ChildCode64 code2 r2lo <- iselExpr64 e2
-   (rlo,rhi) <- getNewRegPairNat II32
-   let
-       r1hi = getHiVRegFromLo r1lo
-       r2hi = getHiVRegFromLo r2lo
-       code =  code1 `appOL`
-               code2 `appOL`
-               toOL [ ADDC rlo r1lo r2lo,
-                      ADDE rhi r1hi r2hi ]
-   -- in
-   return (ChildCode64 code rlo)
-
-iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do
-    (expr_reg,expr_code) <- getSomeReg expr
-    (rlo, rhi) <- getNewRegPairNat II32
-    let mov_hi = LI rhi (ImmInt 0)
-        mov_lo = MR rlo expr_reg
-    return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
-                         rlo
-iselExpr64 expr
-   = pprPanic "iselExpr64(powerpc)" (ppr expr)
-
-#endif /* powerpc_TARGET_ARCH */
-
-
--- -----------------------------------------------------------------------------
--- The 'Register' type
-
--- 'Register's passed up the tree.  If the stix code forces the register
--- to live in a pre-decided machine register, it comes out as @Fixed@;
--- otherwise, it comes out as @Any@, and the parent can decide which
--- register to put it in.
-
-data Register
-  = Fixed   Size Reg InstrBlock
-  | Any            Size (Reg -> InstrBlock)
-
-swizzleRegisterRep :: Register -> Size -> Register
--- Change the width; it's a no-op
-swizzleRegisterRep (Fixed _ reg code) size = Fixed size reg code
-swizzleRegisterRep (Any _ codefn)     size = Any   size codefn
-
-
--- -----------------------------------------------------------------------------
--- Utils based on getRegister, below
-
--- The dual to getAnyReg: compute an expression into a register, but
--- we don't mind which one it is.
-getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
-getSomeReg expr = do
-  r <- getRegister expr
-  case r of
-    Any rep code -> do
-       tmp <- getNewRegNat rep
-       return (tmp, code tmp)
-    Fixed _ reg code -> 
-       return (reg, code)
-
--- -----------------------------------------------------------------------------
--- Grab the Reg for a CmmReg
-
-getRegisterReg :: CmmReg -> Reg
-
-getRegisterReg (CmmLocal (LocalReg u pk))
-  = mkVReg u (cmmTypeSize pk)
-
-getRegisterReg (CmmGlobal mid)
-  = case get_GlobalReg_reg_or_addr mid of
-       Left (RealReg rrno) -> RealReg rrno
-       _other -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
-          -- By this stage, the only MagicIds remaining should be the
-          -- ones which map to a real machine register on this
-          -- platform.  Hence ...
-
-
--- -----------------------------------------------------------------------------
--- Generate code to get a subtree into a Register
-
--- Don't delete this -- it's very handy for debugging.
---getRegister expr 
---   | trace ("getRegister: " ++ showSDoc (pprCmmExpr expr)) False
---   = panic "getRegister(???)"
-
-getRegister :: CmmExpr -> NatM Register
-
-#if !x86_64_TARGET_ARCH
-    -- on x86_64, we have %rip for PicBaseReg, but it's not a full-featured
-    -- register, it can only be used for rip-relative addressing.
-getRegister (CmmReg (CmmGlobal PicBaseReg))
-  = do
-      reg <- getPicBaseNat wordSize
-      return (Fixed wordSize reg nilOL)
-#endif
-
-getRegister (CmmReg reg) 
-  = return (Fixed (cmmTypeSize (cmmRegType reg)) 
-                 (getRegisterReg reg) nilOL)
-
-getRegister tree@(CmmRegOff _ _) 
-  = getRegister (mangleIndexTree tree)
-
-
-#if WORD_SIZE_IN_BITS==32
-    -- for 32-bit architectuers, support some 64 -> 32 bit conversions:
-    -- TO_W_(x), TO_W_(x >> 32)
-
-getRegister (CmmMachOp (MO_UU_Conv W64 W32)
-             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
-  ChildCode64 code rlo <- iselExpr64 x
-  return $ Fixed II32 (getHiVRegFromLo rlo) code
-
-getRegister (CmmMachOp (MO_SS_Conv W64 W32)
-             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
-  ChildCode64 code rlo <- iselExpr64 x
-  return $ Fixed II32 (getHiVRegFromLo rlo) code
-
-getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do
-  ChildCode64 code rlo <- iselExpr64 x
-  return $ Fixed II32 rlo code
-
-getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do
-  ChildCode64 code rlo <- iselExpr64 x
-  return $ Fixed II32 rlo code       
-
-#endif
-
--- end of machine-"independent" bit; here we go on the rest...
-
-#if alpha_TARGET_ARCH
-
-getRegister (StDouble d)
-  = getBlockIdNat                  `thenNat` \ lbl ->
-    getNewRegNat PtrRep            `thenNat` \ tmp ->
-    let code dst = mkSeqInstrs [
-           LDATA RoDataSegment lbl [
-                   DATA TF [ImmLab (rational d)]
-               ],
-           LDA tmp (AddrImm (ImmCLbl lbl)),
-           LD TF dst (AddrReg tmp)]
-    in
-       return (Any FF64 code)
-
-getRegister (StPrim primop [x]) -- unary PrimOps
-  = case primop of
-      IntNegOp -> trivialUCode (NEG Q False) x
-
-      NotOp    -> trivialUCode NOT x
-
-      FloatNegOp  -> trivialUFCode FloatRep (FNEG TF) x
-      DoubleNegOp -> trivialUFCode FF64 (FNEG TF) x
-
-      OrdOp -> coerceIntCode IntRep x
-      ChrOp -> chrCode x
-
-      Float2IntOp  -> coerceFP2Int    x
-      Int2FloatOp  -> coerceInt2FP pr x
-      Double2IntOp -> coerceFP2Int    x
-      Int2DoubleOp -> coerceInt2FP pr x
-
-      Double2FloatOp -> coerceFltCode x
-      Float2DoubleOp -> coerceFltCode x
-
-      other_op -> getRegister (StCall fn CCallConv FF64 [x])
-       where
-         fn = case other_op of
-                FloatExpOp    -> fsLit "exp"
-                FloatLogOp    -> fsLit "log"
-                FloatSqrtOp   -> fsLit "sqrt"
-                FloatSinOp    -> fsLit "sin"
-                FloatCosOp    -> fsLit "cos"
-                FloatTanOp    -> fsLit "tan"
-                FloatAsinOp   -> fsLit "asin"
-                FloatAcosOp   -> fsLit "acos"
-                FloatAtanOp   -> fsLit "atan"
-                FloatSinhOp   -> fsLit "sinh"
-                FloatCoshOp   -> fsLit "cosh"
-                FloatTanhOp   -> fsLit "tanh"
-                DoubleExpOp   -> fsLit "exp"
-                DoubleLogOp   -> fsLit "log"
-                DoubleSqrtOp  -> fsLit "sqrt"
-                DoubleSinOp   -> fsLit "sin"
-                DoubleCosOp   -> fsLit "cos"
-                DoubleTanOp   -> fsLit "tan"
-                DoubleAsinOp  -> fsLit "asin"
-                DoubleAcosOp  -> fsLit "acos"
-                DoubleAtanOp  -> fsLit "atan"
-                DoubleSinhOp  -> fsLit "sinh"
-                DoubleCoshOp  -> fsLit "cosh"
-                DoubleTanhOp  -> fsLit "tanh"
-  where
-    pr = panic "MachCode.getRegister: no primrep needed for Alpha"
-
-getRegister (StPrim primop [x, y]) -- dyadic PrimOps
-  = case primop of
-      CharGtOp -> trivialCode (CMP LTT) y x
-      CharGeOp -> trivialCode (CMP LE) y x
-      CharEqOp -> trivialCode (CMP EQQ) x y
-      CharNeOp -> int_NE_code x y
-      CharLtOp -> trivialCode (CMP LTT) x y
-      CharLeOp -> trivialCode (CMP LE) x y
-
-      IntGtOp  -> trivialCode (CMP LTT) y x
-      IntGeOp  -> trivialCode (CMP LE) y x
-      IntEqOp  -> trivialCode (CMP EQQ) x y
-      IntNeOp  -> int_NE_code x y
-      IntLtOp  -> trivialCode (CMP LTT) x y
-      IntLeOp  -> trivialCode (CMP LE) x y
-
-      WordGtOp -> trivialCode (CMP ULT) y x
-      WordGeOp -> trivialCode (CMP ULE) x y
-      WordEqOp -> trivialCode (CMP EQQ)  x y
-      WordNeOp -> int_NE_code x y
-      WordLtOp -> trivialCode (CMP ULT) x y
-      WordLeOp -> trivialCode (CMP ULE) x y
-
-      AddrGtOp -> trivialCode (CMP ULT) y x
-      AddrGeOp -> trivialCode (CMP ULE) y x
-      AddrEqOp -> trivialCode (CMP EQQ)  x y
-      AddrNeOp -> int_NE_code x y
-      AddrLtOp -> trivialCode (CMP ULT) x y
-      AddrLeOp -> trivialCode (CMP ULE) x y
-       
-      FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
-      FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
-      FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
-      FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
-      FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
-      FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
-
-      DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
-      DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
-      DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
-      DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
-      DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
-      DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
-
-      IntAddOp  -> trivialCode (ADD Q False) x y
-      IntSubOp  -> trivialCode (SUB Q False) x y
-      IntMulOp  -> trivialCode (MUL Q False) x y
-      IntQuotOp -> trivialCode (DIV Q False) x y
-      IntRemOp  -> trivialCode (REM Q False) x y
-
-      WordAddOp  -> trivialCode (ADD Q False) x y
-      WordSubOp  -> trivialCode (SUB Q False) x y
-      WordMulOp  -> trivialCode (MUL Q False) x y
-      WordQuotOp -> trivialCode (DIV Q True) x y
-      WordRemOp  -> trivialCode (REM Q True) x y
-
-      FloatAddOp -> trivialFCode  W32 (FADD TF) x y
-      FloatSubOp -> trivialFCode  W32 (FSUB TF) x y
-      FloatMulOp -> trivialFCode  W32 (FMUL TF) x y
-      FloatDivOp -> trivialFCode  W32 (FDIV TF) x y
-
-      DoubleAddOp -> trivialFCode  W64 (FADD TF) x y
-      DoubleSubOp -> trivialFCode  W64 (FSUB TF) x y
-      DoubleMulOp -> trivialFCode  W64 (FMUL TF) x y
-      DoubleDivOp -> trivialFCode  W64 (FDIV TF) x y
-
-      AddrAddOp  -> trivialCode (ADD Q False) x y
-      AddrSubOp  -> trivialCode (SUB Q False) x y
-      AddrRemOp  -> trivialCode (REM Q True) x y
-
-      AndOp  -> trivialCode AND x y
-      OrOp   -> trivialCode OR  x y
-      XorOp  -> trivialCode XOR x y
-      SllOp  -> trivialCode SLL x y
-      SrlOp  -> trivialCode SRL x y
-
-      ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
-      ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
-      ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
-
-      FloatPowerOp  -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y])
-      DoublePowerOp -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y])
-  where
-    {- ------------------------------------------------------------
-       Some bizarre special code for getting condition codes into
-       registers.  Integer non-equality is a test for equality
-       followed by an XOR with 1.  (Integer comparisons always set
-       the result register to 0 or 1.)  Floating point comparisons of
-       any kind leave the result in a floating point register, so we
-       need to wrangle an integer register out of things.
-    -}
-    int_NE_code :: StixTree -> StixTree -> NatM Register
-
-    int_NE_code x y
-      = trivialCode (CMP EQQ) x y      `thenNat` \ register ->
-       getNewRegNat IntRep             `thenNat` \ tmp ->
-       let
-           code = registerCode register tmp
-           src  = registerName register tmp
-           code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
-       in
-       return (Any IntRep code__2)
-
-    {- ------------------------------------------------------------
-       Comments for int_NE_code also apply to cmpF_code
-    -}
-    cmpF_code
-       :: (Reg -> Reg -> Reg -> Instr)
-       -> Cond
-       -> StixTree -> StixTree
-       -> NatM Register
-
-    cmpF_code instr cond x y
-      = trivialFCode pr instr x y      `thenNat` \ register ->
-       getNewRegNat FF64               `thenNat` \ tmp ->
-       getBlockIdNat                   `thenNat` \ lbl ->
-       let
-           code = registerCode register tmp
-           result  = registerName register tmp
-
-           code__2 dst = code . mkSeqInstrs [
-               OR zeroh (RIImm (ImmInt 1)) dst,
-               BF cond  result (ImmCLbl lbl),
-               OR zeroh (RIReg zeroh) dst,
-               NEWBLOCK lbl]
-       in
-       return (Any IntRep code__2)
-      where
-       pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
-      ------------------------------------------------------------
-
-getRegister (CmmLoad pk mem)
-  = getAmode mem                   `thenNat` \ amode ->
-    let
-       code = amodeCode amode
-       src   = amodeAddr amode
-       size = primRepToSize pk
-       code__2 dst = code . mkSeqInstr (LD size dst src)
-    in
-    return (Any pk code__2)
-
-getRegister (StInt i)
-  | fits8Bits i
-  = let
-       code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
-    in
-    return (Any IntRep code)
-  | otherwise
-  = let
-       code dst = mkSeqInstr (LDI Q dst src)
-    in
-    return (Any IntRep code)
-  where
-    src = ImmInt (fromInteger i)
-
-getRegister leaf
-  | isJust imm
-  = let
-       code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
-    in
-    return (Any PtrRep code)
-  where
-    imm = maybeImm leaf
-    imm__2 = case imm of Just x -> x
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
-getRegister (CmmLit (CmmFloat f W32)) = do
-    lbl <- getNewLabelNat
-    dflags <- getDynFlagsNat
-    dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
-    Amode addr addr_code <- getAmode dynRef
-    let code dst =
-           LDATA ReadOnlyData
-                       [CmmDataLabel lbl,
-                        CmmStaticLit (CmmFloat f W32)]
-           `consOL` (addr_code `snocOL`
-           GLD FF32 addr dst)
-    -- in
-    return (Any FF32 code)
-
-
-getRegister (CmmLit (CmmFloat d W64))
-  | d == 0.0
-  = let code dst = unitOL (GLDZ dst)
-    in  return (Any FF64 code)
-
-  | d == 1.0
-  = let code dst = unitOL (GLD1 dst)
-    in  return (Any FF64 code)
-
-  | otherwise = do
-    lbl <- getNewLabelNat
-    dflags <- getDynFlagsNat
-    dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
-    Amode addr addr_code <- getAmode dynRef
-    let code dst =
-           LDATA ReadOnlyData
-                       [CmmDataLabel lbl,
-                        CmmStaticLit (CmmFloat d W64)]
-           `consOL` (addr_code `snocOL`
-           GLD FF64 addr dst)
-    -- in
-    return (Any FF64 code)
-
-#endif /* i386_TARGET_ARCH */
-
-#if x86_64_TARGET_ARCH
-
-getRegister (CmmLit (CmmFloat 0.0 w)) = do
-   let size = floatSize w
-       code dst = unitOL  (XOR size (OpReg dst) (OpReg dst))
-       -- I don't know why there are xorpd, xorps, and pxor instructions.
-       -- They all appear to do the same thing --SDM
-   return (Any size code)
-
-getRegister (CmmLit (CmmFloat f w)) = do
-    lbl <- getNewLabelNat
-    let code dst = toOL [
-           LDATA ReadOnlyData
-                       [CmmDataLabel lbl,
-                        CmmStaticLit (CmmFloat f w)],
-           MOV size (OpAddr (ripRel (ImmCLbl lbl))) (OpReg dst)
-           ]
-    -- in
-    return (Any size code)
-  where size = floatSize w
-
-#endif /* x86_64_TARGET_ARCH */
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-
--- catch simple cases of zero- or sign-extended load
-getRegister (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do
-  code <- intLoadCode (MOVZxL II8) addr
-  return (Any II32 code)
-
-getRegister (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do
-  code <- intLoadCode (MOVSxL II8) addr
-  return (Any II32 code)
-
-getRegister (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do
-  code <- intLoadCode (MOVZxL II16) addr
-  return (Any II32 code)
-
-getRegister (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do
-  code <- intLoadCode (MOVSxL II16) addr
-  return (Any II32 code)
-
-#endif
-
-#if x86_64_TARGET_ARCH
-
--- catch simple cases of zero- or sign-extended load
-getRegister (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _]) = do
-  code <- intLoadCode (MOVZxL II8) addr
-  return (Any II64 code)
-
-getRegister (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _]) = do
-  code <- intLoadCode (MOVSxL II8) addr
-  return (Any II64 code)
-
-getRegister (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _]) = do
-  code <- intLoadCode (MOVZxL II16) addr
-  return (Any II64 code)
-
-getRegister (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _]) = do
-  code <- intLoadCode (MOVSxL II16) addr
-  return (Any II64 code)
-
-getRegister (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _]) = do
-  code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend
-  return (Any II64 code)
-
-getRegister (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _]) = do
-  code <- intLoadCode (MOVSxL II32) addr
-  return (Any II64 code)
-
-#endif
-
-#if x86_64_TARGET_ARCH
-getRegister (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),
-                                     CmmLit displacement])
-    = return $ Any II64 (\dst -> unitOL $
-        LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))
-#endif
-
-#if x86_64_TARGET_ARCH
-getRegister (CmmMachOp (MO_F_Neg W32) [x]) = do
-  x_code <- getAnyReg x
-  lbl <- getNewLabelNat
-  let
-    code dst = x_code dst `appOL` toOL [
-       -- This is how gcc does it, so it can't be that bad:
-       LDATA ReadOnlyData16 [
-               CmmAlign 16,
-               CmmDataLabel lbl,
-               CmmStaticLit (CmmInt 0x80000000 W32),
-               CmmStaticLit (CmmInt 0 W32),
-               CmmStaticLit (CmmInt 0 W32),
-               CmmStaticLit (CmmInt 0 W32)
-       ],
-       XOR FF32 (OpAddr (ripRel (ImmCLbl lbl))) (OpReg dst)
-               -- xorps, so we need the 128-bit constant
-               -- ToDo: rip-relative
-       ]
-  --
-  return (Any FF32 code)
-
-getRegister (CmmMachOp (MO_F_Neg W64) [x]) = do
-  x_code <- getAnyReg x
-  lbl <- getNewLabelNat
-  let
-       -- This is how gcc does it, so it can't be that bad:
-    code dst = x_code dst `appOL` toOL [
-       LDATA ReadOnlyData16 [
-               CmmAlign 16,
-               CmmDataLabel lbl,
-               CmmStaticLit (CmmInt 0x8000000000000000 W64),
-               CmmStaticLit (CmmInt 0 W64)
-       ],
-               -- gcc puts an unpck here.  Wonder if we need it.
-       XOR FF64 (OpAddr (ripRel (ImmCLbl lbl))) (OpReg dst)
-               -- xorpd, so we need the 128-bit constant
-       ]
-  --
-  return (Any FF64 code)
-#endif
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-
-getRegister (CmmMachOp mop [x]) -- unary MachOps
-  = case mop of
-#if i386_TARGET_ARCH
-      MO_F_Neg W32 -> trivialUFCode FF32 (GNEG FF32) x
-      MO_F_Neg W64 -> trivialUFCode FF64 (GNEG FF64) x
-#endif
-
-      MO_S_Neg w -> triv_ucode NEGI (intSize w)
-      MO_F_Neg w -> triv_ucode NEGI (floatSize w)
-      MO_Not w   -> triv_ucode NOT  (intSize w)
-
-      -- Nop conversions
-      MO_UU_Conv W32 W8  -> toI8Reg  W32 x
-      MO_SS_Conv W32 W8  -> toI8Reg  W32 x
-      MO_UU_Conv W16 W8  -> toI8Reg  W16 x
-      MO_SS_Conv W16 W8  -> toI8Reg  W16 x
-      MO_UU_Conv W32 W16 -> toI16Reg W32 x
-      MO_SS_Conv W32 W16 -> toI16Reg W32 x
-
-#if x86_64_TARGET_ARCH
-      MO_UU_Conv W64 W32 -> conversionNop II64 x
-      MO_SS_Conv W64 W32 -> conversionNop II64 x
-      MO_UU_Conv W64 W16 -> toI16Reg W64 x
-      MO_SS_Conv W64 W16 -> toI16Reg W64 x
-      MO_UU_Conv W64 W8  -> toI8Reg  W64 x
-      MO_SS_Conv W64 W8  -> toI8Reg  W64 x
-#endif
-
-      MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intSize rep1) x
-      MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intSize rep1) x
-
-      -- widenings
-      MO_UU_Conv W8  W32 -> integerExtend W8  W32 MOVZxL x
-      MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x
-      MO_UU_Conv W8  W16 -> integerExtend W8  W16 MOVZxL x
-
-      MO_SS_Conv W8  W32 -> integerExtend W8  W32 MOVSxL x
-      MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x
-      MO_SS_Conv W8  W16 -> integerExtend W8  W16 MOVSxL x
-
-#if x86_64_TARGET_ARCH
-      MO_UU_Conv W8  W64 -> integerExtend W8  W64 MOVZxL x
-      MO_UU_Conv W16 W64 -> integerExtend W16 W64 MOVZxL x
-      MO_UU_Conv W32 W64 -> integerExtend W32 W64 MOVZxL x
-      MO_SS_Conv W8  W64 -> integerExtend W8  W64 MOVSxL x
-      MO_SS_Conv W16 W64 -> integerExtend W16 W64 MOVSxL x
-      MO_SS_Conv W32 W64 -> integerExtend W32 W64 MOVSxL x
-       -- for 32-to-64 bit zero extension, amd64 uses an ordinary movl.
-       -- However, we don't want the register allocator to throw it
-       -- away as an unnecessary reg-to-reg move, so we keep it in
-       -- the form of a movzl and print it as a movl later.
-#endif
-
-#if i386_TARGET_ARCH
-      MO_FF_Conv W32 W64 -> conversionNop FF64 x
-      MO_FF_Conv W64 W32 -> conversionNop FF32 x
-#else
-      MO_FF_Conv W32 W64 -> coerceFP2FP W64 x
-      MO_FF_Conv W64 W32 -> coerceFP2FP W32 x
-#endif
-
-      MO_FS_Conv from to -> coerceFP2Int from to x
-      MO_SF_Conv from to -> coerceInt2FP from to x
-
-      other -> pprPanic "getRegister" (pprMachOp mop)
-   where
-       triv_ucode :: (Size -> Operand -> Instr) -> Size -> NatM Register
-       triv_ucode instr size = trivialUCode size (instr size) x
-
-       -- signed or unsigned extension.
-       integerExtend :: Width -> Width
-                     -> (Size -> Operand -> Operand -> Instr)
-                     -> CmmExpr -> NatM Register
-       integerExtend from to instr expr = do
-           (reg,e_code) <- if from == W8 then getByteReg expr
-                                         else getSomeReg expr
-           let 
-               code dst = 
-                 e_code `snocOL`
-                 instr (intSize from) (OpReg reg) (OpReg dst)
-           return (Any (intSize to) code)
-
-       toI8Reg :: Width -> CmmExpr -> NatM Register
-       toI8Reg new_rep expr
-            = do codefn <- getAnyReg expr
-                return (Any (intSize new_rep) codefn)
-               -- HACK: use getAnyReg to get a byte-addressable register.
-               -- If the source was a Fixed register, this will add the
-               -- mov instruction to put it into the desired destination.
-               -- We're assuming that the destination won't be a fixed
-               -- non-byte-addressable register; it won't be, because all
-               -- fixed registers are word-sized.
-
-       toI16Reg = toI8Reg -- for now
-
-       conversionNop :: Size -> CmmExpr -> NatM Register
-        conversionNop new_size expr
-            = do e_code <- getRegister expr
-                 return (swizzleRegisterRep e_code new_size)
-
-
-getRegister e@(CmmMachOp mop [x, y]) -- dyadic MachOps
-  = case mop of
-      MO_F_Eq w -> condFltReg EQQ x y
-      MO_F_Ne w -> condFltReg NE x y
-      MO_F_Gt w -> condFltReg GTT x y
-      MO_F_Ge w -> condFltReg GE x y
-      MO_F_Lt w -> condFltReg LTT x y
-      MO_F_Le w -> condFltReg LE x y
-
-      MO_Eq rep   -> condIntReg EQQ x y
-      MO_Ne rep   -> condIntReg NE x y
-
-      MO_S_Gt rep -> condIntReg GTT x y
-      MO_S_Ge rep -> condIntReg GE x y
-      MO_S_Lt rep -> condIntReg LTT x y
-      MO_S_Le rep -> condIntReg LE x y
-
-      MO_U_Gt rep -> condIntReg GU  x y
-      MO_U_Ge rep -> condIntReg GEU x y
-      MO_U_Lt rep -> condIntReg LU  x y
-      MO_U_Le rep -> condIntReg LEU x y
-
-#if i386_TARGET_ARCH
-      MO_F_Add w -> trivialFCode w GADD x y
-      MO_F_Sub w -> trivialFCode w GSUB x y
-      MO_F_Quot w -> trivialFCode w GDIV x y
-      MO_F_Mul w -> trivialFCode w GMUL x y
-#endif
-
-#if x86_64_TARGET_ARCH
-      MO_F_Add w -> trivialFCode w ADD x y
-      MO_F_Sub w -> trivialFCode w SUB x y
-      MO_F_Quot w -> trivialFCode w FDIV x y
-      MO_F_Mul w -> trivialFCode w MUL x y
-#endif
-
-      MO_Add rep -> add_code rep x y
-      MO_Sub rep -> sub_code rep x y
-
-      MO_S_Quot rep -> div_code rep True  True  x y
-      MO_S_Rem  rep -> div_code rep True  False x y
-      MO_U_Quot rep -> div_code rep False True  x y
-      MO_U_Rem  rep -> div_code rep False False x y
-
-      MO_S_MulMayOflo rep -> imulMayOflo rep x y
-
-      MO_Mul rep -> triv_op rep IMUL
-      MO_And rep -> triv_op rep AND
-      MO_Or  rep -> triv_op rep OR
-      MO_Xor rep -> triv_op rep XOR
-
-       {- Shift ops on x86s have constraints on their source, it
-          either has to be Imm, CL or 1
-           => trivialCode is not restrictive enough (sigh.)
-       -}         
-      MO_Shl rep   -> shift_code rep SHL x y {-False-}
-      MO_U_Shr rep -> shift_code rep SHR x y {-False-}
-      MO_S_Shr rep -> shift_code rep SAR x y {-False-}
-
-      other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)
-  where
-    --------------------
-    triv_op width instr = trivialCode width op (Just op) x y
-                       where op   = instr (intSize width)
-
-    imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
-    imulMayOflo rep a b = do
-         (a_reg, a_code) <- getNonClobberedReg a
-         b_code <- getAnyReg b
-         let 
-            shift_amt  = case rep of
-                          W32 -> 31
-                          W64 -> 63
-                          _ -> panic "shift_amt"
-
-            size = intSize rep
-             code = a_code `appOL` b_code eax `appOL`
-                        toOL [
-                          IMUL2 size (OpReg a_reg),   -- result in %edx:%eax
-                           SAR size (OpImm (ImmInt shift_amt)) (OpReg eax),
-                               -- sign extend lower part
-                           SUB size (OpReg edx) (OpReg eax)
-                               -- compare against upper
-                           -- eax==0 if high part == sign extended low part
-                        ]
-         -- in
-        return (Fixed size eax code)
-
-    --------------------
-    shift_code :: Width
-              -> (Size -> Operand -> Operand -> Instr)
-              -> CmmExpr
-              -> CmmExpr
-              -> NatM Register
-
-    {- Case1: shift length as immediate -}
-    shift_code width instr x y@(CmmLit lit) = do
-         x_code <- getAnyReg x
-         let
-              size = intSize width
-              code dst
-                 = x_code dst `snocOL` 
-                   instr size (OpImm (litToImm lit)) (OpReg dst)
-         -- in
-         return (Any size code)
-        
-    {- Case2: shift length is complex (non-immediate)
-      * y must go in %ecx.
-      * we cannot do y first *and* put its result in %ecx, because
-        %ecx might be clobbered by x.
-      * if we do y second, then x cannot be 
-        in a clobbered reg.  Also, we cannot clobber x's reg
-        with the instruction itself.
-      * so we can either:
-        - do y first, put its result in a fresh tmp, then copy it to %ecx later
-        - do y second and put its result into %ecx.  x gets placed in a fresh
-          tmp.  This is likely to be better, becuase the reg alloc can
-          eliminate this reg->reg move here (it won't eliminate the other one,
-          because the move is into the fixed %ecx).
-    -}
-    shift_code width instr x y{-amount-} = do
-        x_code <- getAnyReg x
-       let size = intSize width
-       tmp <- getNewRegNat size
-        y_code <- getAnyReg y
-       let 
-          code = x_code tmp `appOL`
-                 y_code ecx `snocOL`
-                 instr size (OpReg ecx) (OpReg tmp)
-        -- in
-        return (Fixed size tmp code)
-
-    --------------------
-    add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
-    add_code rep x (CmmLit (CmmInt y _))
-       | is32BitInteger y = add_int rep x y
-    add_code rep x y = trivialCode rep (ADD size) (Just (ADD size)) x y
-      where size = intSize rep
-
-    --------------------
-    sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
-    sub_code rep x (CmmLit (CmmInt y _))
-       | is32BitInteger (-y) = add_int rep x (-y)
-    sub_code rep x y = trivialCode rep (SUB (intSize rep)) Nothing x y
-
-    -- our three-operand add instruction:
-    add_int width x y = do
-       (x_reg, x_code) <- getSomeReg x
-       let
-           size = intSize width
-           imm = ImmInt (fromInteger y)
-           code dst
-               = x_code `snocOL`
-                LEA size
-                       (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))
-                        (OpReg dst)
-       -- 
-       return (Any size code)
-
-    ----------------------
-    div_code width signed quotient x y = do
-          (y_op, y_code) <- getRegOrMem y -- cannot be clobbered
-          x_code <- getAnyReg x
-          let
-            size = intSize width
-            widen | signed    = CLTD size
-                  | otherwise = XOR size (OpReg edx) (OpReg edx)
-
-            instr | signed    = IDIV
-                  | otherwise = DIV
-
-            code = y_code `appOL`
-                   x_code eax `appOL`
-                   toOL [widen, instr size y_op]
-
-            result | quotient  = eax
-                   | otherwise = edx
-
-          -- in
-           return (Fixed size result code)
-
-
-getRegister (CmmLoad mem pk)
-  | isFloatType pk
-  = do
-    Amode src mem_code <- getAmode mem
-    let
-       size = cmmTypeSize pk
-       code dst = mem_code `snocOL` 
-                  IF_ARCH_i386(GLD size src dst,
-                               MOV size (OpAddr src) (OpReg dst))
-    return (Any size code)
-
-#if i386_TARGET_ARCH
-getRegister (CmmLoad mem pk)
-  | not (isWord64 pk)
-  = do 
-    code <- intLoadCode instr mem
-    return (Any size code)
-  where
-    width = typeWidth pk
-    size = intSize width
-    instr = case width of
-               W8     -> MOVZxL II8
-               _other -> MOV size
-       -- We always zero-extend 8-bit loads, if we
-       -- can't think of anything better.  This is because
-       -- we can't guarantee access to an 8-bit variant of every register
-       -- (esi and edi don't have 8-bit variants), so to make things
-       -- simpler we do our 8-bit arithmetic with full 32-bit registers.
-#endif
-
-#if x86_64_TARGET_ARCH
--- Simpler memory load code on x86_64
-getRegister (CmmLoad mem pk)
-  = do 
-    code <- intLoadCode (MOV size) mem
-    return (Any size code)
-  where size = intSize $ typeWidth pk
-#endif
-
-getRegister (CmmLit (CmmInt 0 width))
-  = let
-       size = intSize width
-
-       -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits
-       adj_size = case size of II64 -> II32; _ -> size
-       size1 = IF_ARCH_i386( size, adj_size ) 
-       code dst 
-           = unitOL (XOR size1 (OpReg dst) (OpReg dst))
-    in
-       return (Any size code)
-
-#if x86_64_TARGET_ARCH
-  -- optimisation for loading small literals on x86_64: take advantage
-  -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit
-  -- instruction forms are shorter.
-getRegister (CmmLit lit) 
-  | isWord64 (cmmLitType lit), not (isBigLit lit)
-  = let 
-       imm = litToImm lit
-       code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))
-    in
-       return (Any II64 code)
-  where
-   isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff
-   isBigLit _ = False
-       -- note1: not the same as (not.is32BitLit), because that checks for
-       -- signed literals that fit in 32 bits, but we want unsigned
-       -- literals here.
-       -- note2: all labels are small, because we're assuming the
-       -- small memory model (see gcc docs, -mcmodel=small).
-#endif
-
-getRegister (CmmLit lit)
-  = let 
-       size = cmmTypeSize (cmmLitType lit)
-       imm = litToImm lit
-       code dst = unitOL (MOV size (OpImm imm) (OpReg dst))
-    in
-       return (Any size code)
-
-getRegister other = pprPanic "getRegister(x86)" (ppr other)
-
-
-intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr
-   -> NatM (Reg -> InstrBlock)
-intLoadCode instr mem = do
-  Amode src mem_code <- getAmode mem
-  return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))
-
--- Compute an expression into *any* register, adding the appropriate
--- move instruction if necessary.
-getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)
-getAnyReg expr = do
-  r <- getRegister expr
-  anyReg r
-
-anyReg :: Register -> NatM (Reg -> InstrBlock)
-anyReg (Any _ code)          = return code
-anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)
-
--- A bit like getSomeReg, but we want a reg that can be byte-addressed.
--- Fixed registers might not be byte-addressable, so we make sure we've
--- got a temporary, inserting an extra reg copy if necessary.
-getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)
-#if x86_64_TARGET_ARCH
-getByteReg = getSomeReg -- all regs are byte-addressable on x86_64
-#else
-getByteReg expr = do
-  r <- getRegister expr
-  case r of
-    Any rep code -> do
-       tmp <- getNewRegNat rep
-       return (tmp, code tmp)
-    Fixed rep reg code 
-       | isVirtualReg reg -> return (reg,code)
-       | otherwise -> do
-           tmp <- getNewRegNat rep
-           return (tmp, code `snocOL` reg2reg rep reg tmp)
-       -- ToDo: could optimise slightly by checking for byte-addressable
-       -- real registers, but that will happen very rarely if at all.
-#endif
-
--- Another variant: this time we want the result in a register that cannot
--- be modified by code to evaluate an arbitrary expression.
-getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)
-getNonClobberedReg expr = do
-  r <- getRegister expr
-  case r of
-    Any rep code -> do
-       tmp <- getNewRegNat rep
-       return (tmp, code tmp)
-    Fixed rep reg code
-       -- only free regs can be clobbered
-       | RealReg rr <- reg, isFastTrue (freeReg rr) -> do
-               tmp <- getNewRegNat rep
-               return (tmp, code `snocOL` reg2reg rep reg tmp)
-       | otherwise -> 
-               return (reg, code)
-
-reg2reg :: Size -> Reg -> Reg -> Instr
-reg2reg size src dst 
-#if i386_TARGET_ARCH
-  | isFloatSize size = GMOV src dst
-#endif
-  | otherwise       = MOV size (OpReg src) (OpReg dst)
-
-#endif /* i386_TARGET_ARCH || x86_64_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
--- getRegister :: CmmExpr -> NatM Register
-
--- Load a literal float into a float register.
---     The actual literal is stored in a new data area, and we load it 
---     at runtime.
-getRegister (CmmLit (CmmFloat f W32)) = do
-
-    -- a label for the new data area
-    lbl <- getNewLabelNat
-    tmp <- getNewRegNat II32
-
-    let code dst = toOL [
-            -- the data area         
-           LDATA ReadOnlyData
-                       [CmmDataLabel lbl,
-                        CmmStaticLit (CmmFloat f W32)],
-
-            -- load the literal
-           SETHI (HI (ImmCLbl lbl)) tmp,
-           LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] 
-
-    return (Any FF32 code)
-
-getRegister (CmmLit (CmmFloat d W64)) = do
-    lbl <- getNewLabelNat
-    tmp <- getNewRegNat II32
-    let code dst = toOL [
-           LDATA ReadOnlyData
-                       [CmmDataLabel lbl,
-                        CmmStaticLit (CmmFloat d W64)],
-           SETHI (HI (ImmCLbl lbl)) tmp,
-           LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] 
-    return (Any FF64 code)
-
-getRegister (CmmMachOp mop [x]) -- unary MachOps
-  = case mop of
-      MO_F_Neg W32     -> trivialUFCode FF32 (FNEG FF32) x
-      MO_F_Neg W64     -> trivialUFCode FF64 (FNEG FF64) x
-
-      MO_S_Neg rep     -> trivialUCode (intSize rep) (SUB False False g0) x
-      MO_Not rep       -> trivialUCode (intSize rep) (XNOR False g0) x
-
-      MO_FF_Conv W64 W32-> coerceDbl2Flt x
-      MO_FF_Conv W32 W64-> coerceFlt2Dbl x
-
-      MO_FS_Conv from to -> coerceFP2Int from to x
-      MO_SF_Conv from to -> coerceInt2FP from to x
-
-      -- Conversions which are a nop on sparc
-      MO_UU_Conv from to
-       | from == to    -> conversionNop (intSize to)  x
-      MO_UU_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8))
-      MO_UU_Conv W32 to -> conversionNop (intSize to) x
-      MO_SS_Conv W32 to -> conversionNop (intSize to) x
-
-      MO_UU_Conv W8  to@W32  -> conversionNop (intSize to)  x
-      MO_UU_Conv W16 to@W32  -> conversionNop (intSize to)  x
-      MO_UU_Conv W8  to@W16  -> conversionNop (intSize to)  x
-
-      -- sign extension
-      MO_SS_Conv W8  W32  -> integerExtend W8  W32 x
-      MO_SS_Conv W16 W32  -> integerExtend W16 W32 x
-      MO_SS_Conv W8  W16  -> integerExtend W8  W16 x
-
-      other_op -> panic ("Unknown unary mach op: " ++ show mop)
-    where
-
-       -- | sign extend and widen
-       integerExtend 
-               :: Width                -- ^ width of source expression
-               -> Width                -- ^ width of result
-               -> CmmExpr              -- ^ source expression
-               -> NatM Register        
-
-       integerExtend from to expr
-        = do   -- load the expr into some register
-               (reg, e_code)   <- getSomeReg expr
-               tmp             <- getNewRegNat II32
-               let bitCount
-                       = case (from, to) of
-                               (W8,  W32)      -> 24
-                               (W16, W32)      -> 16
-                               (W8,  W16)      -> 24
-               let code dst
-                       = e_code        
-
-                       -- local shift word left to load the sign bit
-                       `snocOL`  SLL reg (RIImm (ImmInt bitCount)) tmp
-                       
-                       -- arithmetic shift right to sign extend
-                       `snocOL`  SRA tmp (RIImm (ImmInt bitCount)) dst
-                       
-               return (Any (intSize to) code)
-                               
-
-        conversionNop new_rep expr
-            = do e_code <- getRegister expr
-                 return (swizzleRegisterRep e_code new_rep)
-
-getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps
-  = case mop of
-      MO_Eq rep -> condIntReg EQQ x y
-      MO_Ne rep -> condIntReg NE x y
-
-      MO_S_Gt rep -> condIntReg GTT x y
-      MO_S_Ge rep -> condIntReg GE x y
-      MO_S_Lt rep -> condIntReg LTT x y
-      MO_S_Le rep -> condIntReg LE x y
-             
-      MO_U_Gt W32  -> condIntReg GTT x y
-      MO_U_Ge W32  -> condIntReg GE x y
-      MO_U_Lt W32  -> condIntReg LTT x y
-      MO_U_Le W32  -> condIntReg LE x y
-
-      MO_U_Gt W16 -> condIntReg GU  x y
-      MO_U_Ge W16 -> condIntReg GEU x y
-      MO_U_Lt W16 -> condIntReg LU  x y
-      MO_U_Le W16 -> condIntReg LEU x y
-
-      MO_Add W32 -> trivialCode W32 (ADD False False) x y
-      MO_Sub W32 -> trivialCode W32 (SUB False False) x y
-
-      MO_S_MulMayOflo rep -> imulMayOflo rep x y
-
-      MO_S_Quot W32    -> idiv True  False x y
-      MO_U_Quot W32    -> idiv False False x y
-       
-      MO_S_Rem  W32    -> irem True  x y
-      MO_U_Rem W32     -> irem False x y
-       
-      MO_F_Eq w -> condFltReg EQQ x y
-      MO_F_Ne w -> condFltReg NE x y
-
-      MO_F_Gt w -> condFltReg GTT x y
-      MO_F_Ge w -> condFltReg GE x y 
-      MO_F_Lt w -> condFltReg LTT x y
-      MO_F_Le w -> condFltReg LE x y
-
-      MO_F_Add  w  -> trivialFCode w FADD x y
-      MO_F_Sub  w  -> trivialFCode w FSUB x y
-      MO_F_Mul  w  -> trivialFCode w FMUL x y
-      MO_F_Quot w  -> trivialFCode w FDIV x y
-
-      MO_And rep   -> trivialCode rep (AND False) x y
-      MO_Or rep    -> trivialCode rep (OR  False) x y
-      MO_Xor rep   -> trivialCode rep (XOR False) x y
-
-      MO_Mul rep -> trivialCode rep (SMUL False) x y
-
-      MO_Shl rep   -> trivialCode rep SLL  x y
-      MO_U_Shr rep   -> trivialCode rep SRL x y
-      MO_S_Shr rep   -> trivialCode rep SRA x y
-
-{-
-      MO_F32_Pwr  -> getRegister (StCall (Left (fsLit "pow")) CCallConv FF64 
-                                         [promote x, promote y])
-                      where promote x = CmmMachOp MO_F32_to_Dbl [x]
-      MO_F64_Pwr -> getRegister (StCall (Left (fsLit "pow")) CCallConv FF64 
-                                        [x, y])
--}
-      other -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop)
-  where
-    -- idiv fn x y = getRegister (StCall (Left fn) CCallConv II32 [x, y])
-
-
-    -- | Generate an integer division instruction.
-    idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register
-       
-    -- For unsigned division with a 32 bit numerator, 
-    --         we can just clear the Y register.
-    idiv False cc x y = do
-       (a_reg, a_code)         <- getSomeReg x
-               (b_reg, b_code)         <- getSomeReg y
-       
-       let code dst
-               =       a_code 
-               `appOL` b_code  
-               `appOL` toOL
-                       [ WRY  g0 g0
-                       , UDIV cc a_reg (RIReg b_reg) dst]
-                       
-       return (Any II32 code)
-       
-
-    -- For _signed_ division with a 32 bit numerator,
-    --         we have to sign extend the numerator into the Y register.
-    idiv True cc x y = do
-       (a_reg, a_code)         <- getSomeReg x
-               (b_reg, b_code)         <- getSomeReg y
-       
-       tmp                     <- getNewRegNat II32
-       
-       let code dst
-               =       a_code 
-               `appOL` b_code  
-               `appOL` toOL
-                       [ SRA  a_reg (RIImm (ImmInt 16)) tmp            -- sign extend
-                       , SRA  tmp   (RIImm (ImmInt 16)) tmp
-
-                       , WRY  tmp g0                           
-                       , SDIV cc a_reg (RIReg b_reg) dst]
-                       
-       return (Any II32 code)
-
-
-    -- | Do an integer remainder.
-    --
-    --  NOTE:  The SPARC v8 architecture manual says that integer division
-    --         instructions _may_ generate a remainder, depending on the implementation.
-    --         If so it is _recommended_ that the remainder is placed in the Y register.
-    --
-    --          The UltraSparc 2007 manual says Y is _undefined_ after division.
-    --
-    --         The SPARC T2 doesn't store the remainder, not sure about the others. 
-    --         It's probably best not to worry about it, and just generate our own
-    --         remainders. 
-    --
-    irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register
-
-    -- For unsigned operands: 
-    --         Division is between a 64 bit numerator and a 32 bit denominator, 
-    --         so we still have to clear the Y register.
-    irem False x y = do
-       (a_reg, a_code) <- getSomeReg x
-       (b_reg, b_code) <- getSomeReg y
-
-       tmp_reg         <- getNewRegNat II32
-
-       let code dst
-               =       a_code
-               `appOL` b_code
-               `appOL` toOL
-                       [ WRY   g0 g0
-                       , UDIV  False         a_reg (RIReg b_reg) tmp_reg
-                       , UMUL  False       tmp_reg (RIReg b_reg) tmp_reg
-                       , SUB   False False   a_reg (RIReg tmp_reg) dst]
-    
-       return  (Any II32 code)
-
-    
-    -- For signed operands:
-    --         Make sure to sign extend into the Y register, or the remainder
-    --         will have the wrong sign when the numerator is negative.
-    --
-    -- TODO:   When sign extending, GCC only shifts the a_reg right by 17 bits,
-    --         not the full 32. Not sure why this is, something to do with overflow?
-    --         If anyone cares enough about the speed of signed remainder they
-    --         can work it out themselves (then tell me). -- BL 2009/01/20
-    
-    irem True x y = do
-       (a_reg, a_code) <- getSomeReg x
-       (b_reg, b_code) <- getSomeReg y
-       
-       tmp1_reg        <- getNewRegNat II32
-       tmp2_reg        <- getNewRegNat II32
-               
-       let code dst
-               =       a_code
-               `appOL` b_code
-               `appOL` toOL
-                       [ SRA   a_reg      (RIImm (ImmInt 16)) tmp1_reg -- sign extend
-                       , SRA   tmp1_reg   (RIImm (ImmInt 16)) tmp1_reg -- sign extend
-                       , WRY   tmp1_reg g0
-
-                       , SDIV  False          a_reg (RIReg b_reg)    tmp2_reg  
-                       , SMUL  False       tmp2_reg (RIReg b_reg)    tmp2_reg
-                       , SUB   False False    a_reg (RIReg tmp2_reg) dst]
-                       
-       return (Any II32 code)
-   
-
-    imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
-    imulMayOflo rep a b = do
-         (a_reg, a_code) <- getSomeReg a
-        (b_reg, b_code) <- getSomeReg b
-        res_lo <- getNewRegNat II32
-        res_hi <- getNewRegNat II32
-        let
-           shift_amt  = case rep of
-                         W32 -> 31
-                         W64 -> 63
-                         _ -> panic "shift_amt"
-           code dst = a_code `appOL` b_code `appOL`
-                       toOL [
-                           SMUL False a_reg (RIReg b_reg) res_lo,
-                           RDY res_hi,
-                           SRA res_lo (RIImm (ImmInt shift_amt)) res_lo,
-                           SUB False False res_lo (RIReg res_hi) dst
-                        ]
-         return (Any II32 code)
-
-getRegister (CmmLoad mem pk) = do
-    Amode src code <- getAmode mem
-    let
-       code__2 dst     = code `snocOL` LD (cmmTypeSize pk) src dst
-    return (Any (cmmTypeSize pk) code__2)
-
-getRegister (CmmLit (CmmInt i _))
-  | fits13Bits i
-  = let
-       src = ImmInt (fromInteger i)
-       code dst = unitOL (OR False g0 (RIImm src) dst)
-    in
-       return (Any II32 code)
-
-getRegister (CmmLit lit)
-  = let rep = cmmLitType lit
-       imm = litToImm lit
-       code dst = toOL [
-           SETHI (HI imm) dst,
-           OR False dst (RIImm (LO imm)) dst]
-    in return (Any II32 code)
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-getRegister (CmmLoad mem pk)
-  | not (isWord64 pk)
-  = do
-        Amode addr addr_code <- getAmode mem
-        let code dst = ASSERT((regClass dst == RcDouble) == isFloatType pk)
-                       addr_code `snocOL` LD size dst addr
-        return (Any size code)
-          where size = cmmTypeSize pk
-
--- catch simple cases of zero- or sign-extended load
-getRegister (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do
-    Amode addr addr_code <- getAmode mem
-    return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))
-
--- Note: there is no Load Byte Arithmetic instruction, so no signed case here
-
-getRegister (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do
-    Amode addr addr_code <- getAmode mem
-    return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr))
-
-getRegister (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do
-    Amode addr addr_code <- getAmode mem
-    return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr))
-
-getRegister (CmmMachOp mop [x]) -- unary MachOps
-  = case mop of
-      MO_Not rep   -> triv_ucode_int rep NOT
-
-      MO_F_Neg w   -> triv_ucode_float w FNEG
-      MO_S_Neg w   -> triv_ucode_int   w NEG
-
-      MO_FF_Conv W64 W32 -> trivialUCode  FF32 FRSP x
-      MO_FF_Conv W32 W64 -> conversionNop FF64 x
-
-      MO_FS_Conv from to -> coerceFP2Int from to x
-      MO_SF_Conv from to -> coerceInt2FP from to x
-
-      MO_SS_Conv from to
-        | from == to    -> conversionNop (intSize to) x
-
-        -- narrowing is a nop: we treat the high bits as undefined
-      MO_SS_Conv W32 to -> conversionNop (intSize to) x
-      MO_SS_Conv W16 W8 -> conversionNop II8 x
-      MO_SS_Conv W8  to -> triv_ucode_int to (EXTS II8)
-      MO_SS_Conv W16 to -> triv_ucode_int to (EXTS II16)
-
-      MO_UU_Conv from to
-        | from == to -> conversionNop (intSize to) x
-        -- narrowing is a nop: we treat the high bits as undefined
-      MO_UU_Conv W32 to -> conversionNop (intSize to) x
-      MO_UU_Conv W16 W8 -> conversionNop II8 x
-      MO_UU_Conv W8 to  -> trivialCode to False AND x (CmmLit (CmmInt 255 W32))
-      MO_UU_Conv W16 to -> trivialCode to False AND x (CmmLit (CmmInt 65535 W32)) 
-
-    where
-       triv_ucode_int   width instr = trivialUCode (intSize   width) instr x
-       triv_ucode_float width instr = trivialUCode (floatSize width) instr x
-
-        conversionNop new_size expr
-            = do e_code <- getRegister expr
-                 return (swizzleRegisterRep e_code new_size)
-
-getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps
-  = case mop of
-      MO_F_Eq w -> condFltReg EQQ x y
-      MO_F_Ne w -> condFltReg NE  x y
-      MO_F_Gt w -> condFltReg GTT x y
-      MO_F_Ge w -> condFltReg GE  x y
-      MO_F_Lt w -> condFltReg LTT x y
-      MO_F_Le w -> condFltReg LE  x y
-
-      MO_Eq rep -> condIntReg EQQ  (extendUExpr rep x) (extendUExpr rep y)
-      MO_Ne rep -> condIntReg NE   (extendUExpr rep x) (extendUExpr rep y)
-
-      MO_S_Gt rep -> condIntReg GTT  (extendSExpr rep x) (extendSExpr rep y)
-      MO_S_Ge rep -> condIntReg GE   (extendSExpr rep x) (extendSExpr rep y)
-      MO_S_Lt rep -> condIntReg LTT  (extendSExpr rep x) (extendSExpr rep y)
-      MO_S_Le rep -> condIntReg LE   (extendSExpr rep x) (extendSExpr rep y)
-
-      MO_U_Gt rep -> condIntReg GU   (extendUExpr rep x) (extendUExpr rep y)
-      MO_U_Ge rep -> condIntReg GEU  (extendUExpr rep x) (extendUExpr rep y)
-      MO_U_Lt rep -> condIntReg LU   (extendUExpr rep x) (extendUExpr rep y)
-      MO_U_Le rep -> condIntReg LEU  (extendUExpr rep x) (extendUExpr rep y)
-
-      MO_F_Add w  -> triv_float w FADD
-      MO_F_Sub w  -> triv_float w FSUB
-      MO_F_Mul w  -> triv_float w FMUL
-      MO_F_Quot w -> triv_float w FDIV
-      
-         -- optimize addition with 32-bit immediate
-         -- (needed for PIC)
-      MO_Add W32 ->
-        case y of
-          CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate W32 True (-imm)
-            -> trivialCode W32 True ADD x (CmmLit $ CmmInt imm immrep)
-          CmmLit lit
-            -> do
-                (src, srcCode) <- getSomeReg x
-                let imm = litToImm lit
-                    code dst = srcCode `appOL` toOL [
-                                    ADDIS dst src (HA imm),
-                                    ADD dst dst (RIImm (LO imm))
-                                ]
-                return (Any II32 code)
-          _ -> trivialCode W32 True ADD x y
-
-      MO_Add rep -> trivialCode rep True ADD x y
-      MO_Sub rep ->
-        case y of    -- subfi ('substract from' with immediate) doesn't exist
-          CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (-imm)
-            -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep)
-          _ -> trivialCodeNoImm' (intSize rep) SUBF y x
-
-      MO_Mul rep -> trivialCode rep True MULLW x y
-
-      MO_S_MulMayOflo W32 -> trivialCodeNoImm' II32 MULLW_MayOflo x y
-      
-      MO_S_MulMayOflo rep -> panic "S_MulMayOflo (rep /= II32): not implemented"
-      MO_U_MulMayOflo rep -> panic "U_MulMayOflo: not implemented"
-
-      MO_S_Quot rep -> trivialCodeNoImm' (intSize rep) DIVW (extendSExpr rep x) (extendSExpr rep y)
-      MO_U_Quot rep -> trivialCodeNoImm' (intSize rep) DIVWU (extendUExpr rep x) (extendUExpr rep y)
-      
-      MO_S_Rem rep -> remainderCode rep DIVW (extendSExpr rep x) (extendSExpr rep y)
-      MO_U_Rem rep -> remainderCode rep DIVWU (extendUExpr rep x) (extendUExpr rep y)
-      
-      MO_And rep   -> trivialCode rep False AND x y
-      MO_Or rep    -> trivialCode rep False OR x y
-      MO_Xor rep   -> trivialCode rep False XOR x y
-
-      MO_Shl rep   -> trivialCode rep False SLW x y
-      MO_S_Shr rep -> trivialCode rep False SRAW (extendSExpr rep x) y
-      MO_U_Shr rep -> trivialCode rep False SRW (extendUExpr rep x) y
-  where
-    triv_float :: Width -> (Size -> Reg -> Reg -> Reg -> Instr) -> NatM Register
-    triv_float width instr = trivialCodeNoImm (floatSize width) instr x y
-
-getRegister (CmmLit (CmmInt i rep))
-  | Just imm <- makeImmediate rep True i
-  = let
-       code dst = unitOL (LI dst imm)
-    in
-       return (Any (intSize rep) code)
-
-getRegister (CmmLit (CmmFloat f frep)) = do
-    lbl <- getNewLabelNat
-    dflags <- getDynFlagsNat
-    dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
-    Amode addr addr_code <- getAmode dynRef
-    let size = floatSize frep
-        code dst = 
-           LDATA ReadOnlyData  [CmmDataLabel lbl,
-                                CmmStaticLit (CmmFloat f frep)]
-            `consOL` (addr_code `snocOL` LD size dst addr)
-    return (Any size code)
-
-getRegister (CmmLit lit)
-  = let rep = cmmLitType lit
-        imm = litToImm lit
-        code dst = toOL [
-              LIS dst (HA imm),
-              ADD dst dst (RIImm (LO imm))
-          ]
-    in return (Any (cmmTypeSize rep) code)
-
-getRegister other = pprPanic "getRegister(ppc)" (pprExpr other)
-    
-    -- extend?Rep: wrap integer expression of type rep
-    -- in a conversion to II32
-extendSExpr W32 x = x
-extendSExpr rep x = CmmMachOp (MO_SS_Conv rep W32) [x]
-extendUExpr W32 x = x
-extendUExpr rep x = CmmMachOp (MO_UU_Conv rep W32) [x]
-
-#endif /* powerpc_TARGET_ARCH */
-
-
--- -----------------------------------------------------------------------------
---  The 'Amode' type: Memory addressing modes passed up the tree.
-
-data Amode = Amode AddrMode InstrBlock
-
-{-
-Now, given a tree (the argument to an CmmLoad) that references memory,
-produce a suitable addressing mode.
-
-A Rule of the Game (tm) for Amodes: use of the addr bit must
-immediately follow use of the code part, since the code part puts
-values in registers which the addr then refers to.  So you can't put
-anything in between, lest it overwrite some of those registers.  If
-you need to do some other computation between the code part and use of
-the addr bit, first store the effective address from the amode in a
-temporary, then do the other computation, and then use the temporary:
-
-    code
-    LEA amode, tmp
-    ... other computation ...
-    ... (tmp) ...
--}
-
-getAmode :: CmmExpr -> NatM Amode
-getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree)
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-getAmode (StPrim IntSubOp [x, StInt i])
-  = getNewRegNat PtrRep                `thenNat` \ tmp ->
-    getRegister x              `thenNat` \ register ->
-    let
-       code = registerCode register tmp
-       reg  = registerName register tmp
-       off  = ImmInt (-(fromInteger i))
-    in
-    return (Amode (AddrRegImm reg off) code)
-
-getAmode (StPrim IntAddOp [x, StInt i])
-  = getNewRegNat PtrRep                `thenNat` \ tmp ->
-    getRegister x              `thenNat` \ register ->
-    let
-       code = registerCode register tmp
-       reg  = registerName register tmp
-       off  = ImmInt (fromInteger i)
-    in
-    return (Amode (AddrRegImm reg off) code)
-
-getAmode leaf
-  | isJust imm
-  = return (Amode (AddrImm imm__2) id)
-  where
-    imm = maybeImm leaf
-    imm__2 = case imm of Just x -> x
-
-getAmode other
-  = getNewRegNat PtrRep                `thenNat` \ tmp ->
-    getRegister other          `thenNat` \ register ->
-    let
-       code = registerCode register tmp
-       reg  = registerName register tmp
-    in
-    return (Amode (AddrReg reg) code)
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if x86_64_TARGET_ARCH
-
-getAmode (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),
-                                     CmmLit displacement])
-    = return $ Amode (ripRel (litToImm displacement)) nilOL
-
-#endif
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-
--- This is all just ridiculous, since it carefully undoes 
--- what mangleIndexTree has just done.
-getAmode (CmmMachOp (MO_Sub rep) [x, CmmLit lit@(CmmInt i _)])
-  | is32BitLit lit
-  -- ASSERT(rep == II32)???
-  = do (x_reg, x_code) <- getSomeReg x
-       let off = ImmInt (-(fromInteger i))
-       return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)
-  
-getAmode (CmmMachOp (MO_Add rep) [x, CmmLit lit@(CmmInt i _)])
-  | is32BitLit lit
-  -- ASSERT(rep == II32)???
-  = do (x_reg, x_code) <- getSomeReg x
-       let off = ImmInt (fromInteger i)
-       return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)
-
--- Turn (lit1 << n  + lit2) into  (lit2 + lit1 << n) so it will be 
--- recognised by the next rule.
-getAmode (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _),
-                                 b@(CmmLit _)])
-  = getAmode (CmmMachOp (MO_Add rep) [b,a])
-
-getAmode (CmmMachOp (MO_Add rep) [x, CmmMachOp (MO_Shl _) 
-                                       [y, CmmLit (CmmInt shift _)]])
-  | shift == 0 || shift == 1 || shift == 2 || shift == 3
-  = x86_complex_amode x y shift 0
-
-getAmode (CmmMachOp (MO_Add rep) 
-                [x, CmmMachOp (MO_Add _)
-                        [CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)],
-                         CmmLit (CmmInt offset _)]])
-  | shift == 0 || shift == 1 || shift == 2 || shift == 3
-  && is32BitInteger offset
-  = x86_complex_amode x y shift offset
-
-getAmode (CmmMachOp (MO_Add rep) [x,y])
-  = x86_complex_amode x y 0 0
-
-getAmode (CmmLit lit) | is32BitLit lit
-  = return (Amode (ImmAddr (litToImm lit) 0) nilOL)
-
-getAmode expr = do
-  (reg,code) <- getSomeReg expr
-  return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)
-
-
-x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode
-x86_complex_amode base index shift offset
-  = do (x_reg, x_code) <- getNonClobberedReg base
-       -- x must be in a temp, because it has to stay live over y_code
-       -- we could compre x_reg and y_reg and do something better here...
-       (y_reg, y_code) <- getSomeReg index
-       let
-          code = x_code `appOL` y_code
-           base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8
-       return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))
-               code)
-
-#endif /* i386_TARGET_ARCH || x86_64_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-getAmode (CmmMachOp (MO_Sub rep) [x, CmmLit (CmmInt i _)])
-  | fits13Bits (-i)
-  = do
-       (reg, code) <- getSomeReg x
-       let
-         off  = ImmInt (-(fromInteger i))
-       return (Amode (AddrRegImm reg off) code)
-
-
-getAmode (CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt i _)])
-  | fits13Bits i
-  = do
-       (reg, code) <- getSomeReg x
-       let
-        off  = ImmInt (fromInteger i)
-       return (Amode (AddrRegImm reg off) code)
-
-getAmode (CmmMachOp (MO_Add rep) [x, y])
-  = do
-    (regX, codeX) <- getSomeReg x
-    (regY, codeY) <- getSomeReg y
-    let
-       code = codeX `appOL` codeY
-    return (Amode (AddrRegReg regX regY) code)
-
-getAmode (CmmLit lit)
-  = do
-       let imm__2      = litToImm lit
-       tmp1    <- getNewRegNat II32
-       tmp2    <- getNewRegNat II32
-
-       let code = toOL [ SETHI (HI imm__2) tmp1
-                       , OR    False tmp1 (RIImm (LO imm__2)) tmp2]
-               
-       return (Amode (AddrRegReg tmp2 g0) code)
-
-getAmode other
-  = do
-       (reg, code) <- getSomeReg other
-       let
-           off  = ImmInt 0
-       return (Amode (AddrRegImm reg off) code)
-
-#endif /* sparc_TARGET_ARCH */
-
-#ifdef powerpc_TARGET_ARCH
-getAmode (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)])
-  | Just off <- makeImmediate W32 True (-i)
-  = do
-        (reg, code) <- getSomeReg x
-        return (Amode (AddrRegImm reg off) code)
-
-
-getAmode (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)])
-  | Just off <- makeImmediate W32 True i
-  = do
-        (reg, code) <- getSomeReg x
-        return (Amode (AddrRegImm reg off) code)
-
-   -- optimize addition with 32-bit immediate
-   -- (needed for PIC)
-getAmode (CmmMachOp (MO_Add W32) [x, CmmLit lit])
-  = do
-        tmp <- getNewRegNat II32
-        (src, srcCode) <- getSomeReg x
-        let imm = litToImm lit
-            code = srcCode `snocOL` ADDIS tmp src (HA imm)
-        return (Amode (AddrRegImm tmp (LO imm)) code)
-
-getAmode (CmmLit lit)
-  = do
-        tmp <- getNewRegNat II32
-        let imm = litToImm lit
-            code = unitOL (LIS tmp (HA imm))
-        return (Amode (AddrRegImm tmp (LO imm)) code)
-    
-getAmode (CmmMachOp (MO_Add W32) [x, y])
-  = do
-        (regX, codeX) <- getSomeReg x
-        (regY, codeY) <- getSomeReg y
-        return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
-    
-getAmode other
-  = do
-        (reg, code) <- getSomeReg other
-        let
-            off  = ImmInt 0
-        return (Amode (AddrRegImm reg off) code)
-#endif /* powerpc_TARGET_ARCH */
-
--- -----------------------------------------------------------------------------
--- getOperand: sometimes any operand will do.
-
--- getNonClobberedOperand: the value of the operand will remain valid across
--- the computation of an arbitrary expression, unless the expression
--- is computed directly into a register which the operand refers to
--- (see trivialCode where this function is used for an example).
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-
-getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)
-#if x86_64_TARGET_ARCH
-getNonClobberedOperand (CmmLit lit)
-  | isSuitableFloatingPointLit lit = do
-    lbl <- getNewLabelNat
-    let code = unitOL (LDATA ReadOnlyData  [CmmDataLabel lbl,
-                                          CmmStaticLit lit])
-    return (OpAddr (ripRel (ImmCLbl lbl)), code)
-#endif
-getNonClobberedOperand (CmmLit lit)
-  | is32BitLit lit && not (isFloatType (cmmLitType lit)) =
-    return (OpImm (litToImm lit), nilOL)
-getNonClobberedOperand (CmmLoad mem pk) 
-  | IF_ARCH_i386(not (isFloatType pk) && not (isWord64 pk), True) = do
-    Amode src mem_code <- getAmode mem
-    (src',save_code) <- 
-       if (amodeCouldBeClobbered src) 
-               then do
-                  tmp <- getNewRegNat wordSize
-                  return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),
-                          unitOL (LEA II32 (OpAddr src) (OpReg tmp)))
-               else
-                  return (src, nilOL)
-    return (OpAddr src', save_code `appOL` mem_code)
-getNonClobberedOperand e = do
-    (reg, code) <- getNonClobberedReg e
-    return (OpReg reg, code)
-
-amodeCouldBeClobbered :: AddrMode -> Bool
-amodeCouldBeClobbered amode = any regClobbered (addrModeRegs amode)
-
-regClobbered (RealReg rr) = isFastTrue (freeReg rr)
-regClobbered _ = False
-
--- getOperand: the operand is not required to remain valid across the
--- computation of an arbitrary expression.
-getOperand :: CmmExpr -> NatM (Operand, InstrBlock)
-#if x86_64_TARGET_ARCH
-getOperand (CmmLit lit)
-  | isSuitableFloatingPointLit lit = do
-    lbl <- getNewLabelNat
-    let code = unitOL (LDATA ReadOnlyData  [CmmDataLabel lbl,
-                                          CmmStaticLit lit])
-    return (OpAddr (ripRel (ImmCLbl lbl)), code)
-#endif
-getOperand (CmmLit lit)
-  | is32BitLit lit && not (isFloatType (cmmLitType lit)) = do
-    return (OpImm (litToImm lit), nilOL)
-getOperand (CmmLoad mem pk)
-  | IF_ARCH_i386(not (isFloatType pk) && not (isWord64 pk), True) = do
-    Amode src mem_code <- getAmode mem
-    return (OpAddr src, mem_code)
-getOperand e = do
-    (reg, code) <- getSomeReg e
-    return (OpReg reg, code)
-
-isOperand :: CmmExpr -> Bool
-isOperand (CmmLoad _ _) = True
-isOperand (CmmLit lit)  = is32BitLit lit
-                         || isSuitableFloatingPointLit lit
-isOperand _             = False
-
--- if we want a floating-point literal as an operand, we can
--- use it directly from memory.  However, if the literal is
--- zero, we're better off generating it into a register using
--- xor.
-isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0
-isSuitableFloatingPointLit _ = False
-
-getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)
-getRegOrMem (CmmLoad mem pk)
-  | IF_ARCH_i386(not (isFloatType pk) && not (isWord64 pk), True) = do
-    Amode src mem_code <- getAmode mem
-    return (OpAddr src, mem_code)
-getRegOrMem e = do
-    (reg, code) <- getNonClobberedReg e
-    return (OpReg reg, code)
-
-#if x86_64_TARGET_ARCH
-is32BitLit (CmmInt i W64) = is32BitInteger i
-   -- assume that labels are in the range 0-2^31-1: this assumes the
-   -- small memory model (see gcc docs, -mcmodel=small).
-#endif
-is32BitLit x = True
-#endif
-
-is32BitInteger :: Integer -> Bool
-is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000
-  where i64 = fromIntegral i :: Int64
-  -- a CmmInt is intended to be truncated to the appropriate 
-  -- number of bits, so here we truncate it to Int64.  This is
-  -- important because e.g. -1 as a CmmInt might be either
-  -- -1 or 18446744073709551615.
-
--- -----------------------------------------------------------------------------
---  The 'CondCode' type:  Condition codes passed up the tree.
-
-data CondCode = CondCode Bool Cond InstrBlock
-
--- Set up a condition code for a conditional branch.
-
-getCondCode :: CmmExpr -> NatM CondCode
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-getCondCode = panic "MachCode.getCondCode: not on Alphas"
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
--- yes, they really do seem to want exactly the same!
-
-getCondCode (CmmMachOp mop [x, y])
-  = 
-    case mop of
-      MO_F_Eq W32 -> condFltCode EQQ x y
-      MO_F_Ne W32 -> condFltCode NE  x y
-      MO_F_Gt W32 -> condFltCode GTT x y
-      MO_F_Ge W32 -> condFltCode GE  x y
-      MO_F_Lt W32 -> condFltCode LTT x y
-      MO_F_Le W32 -> condFltCode LE  x y
-
-      MO_F_Eq W64 -> condFltCode EQQ x y
-      MO_F_Ne W64 -> condFltCode NE  x y
-      MO_F_Gt W64 -> condFltCode GTT x y
-      MO_F_Ge W64 -> condFltCode GE  x y
-      MO_F_Lt W64 -> condFltCode LTT x y
-      MO_F_Le W64 -> condFltCode LE  x y
-
-      MO_Eq rep -> condIntCode EQQ  x y
-      MO_Ne rep -> condIntCode NE   x y
-
-      MO_S_Gt rep -> condIntCode GTT  x y
-      MO_S_Ge rep -> condIntCode GE   x y
-      MO_S_Lt rep -> condIntCode LTT  x y
-      MO_S_Le rep -> condIntCode LE   x y
-
-      MO_U_Gt rep -> condIntCode GU   x y
-      MO_U_Ge rep -> condIntCode GEU  x y
-      MO_U_Lt rep -> condIntCode LU   x y
-      MO_U_Le rep -> condIntCode LEU  x y
-
-      other -> pprPanic "getCondCode(x86,x86_64,sparc)" (ppr (CmmMachOp mop [x,y]))
-
-getCondCode other =  pprPanic "getCondCode(2)(x86,sparc)" (ppr other)
-
-#elif powerpc_TARGET_ARCH
-
--- almost the same as everywhere else - but we need to
--- extend small integers to 32 bit first
-
-getCondCode (CmmMachOp mop [x, y])
-  = case mop of
-      MO_F_Eq W32 -> condFltCode EQQ x y
-      MO_F_Ne W32 -> condFltCode NE  x y
-      MO_F_Gt W32 -> condFltCode GTT x y
-      MO_F_Ge W32 -> condFltCode GE  x y
-      MO_F_Lt W32 -> condFltCode LTT x y
-      MO_F_Le W32 -> condFltCode LE  x y
-
-      MO_F_Eq W64 -> condFltCode EQQ x y
-      MO_F_Ne W64 -> condFltCode NE  x y
-      MO_F_Gt W64 -> condFltCode GTT x y
-      MO_F_Ge W64 -> condFltCode GE  x y
-      MO_F_Lt W64 -> condFltCode LTT x y
-      MO_F_Le W64 -> condFltCode LE  x y
-
-      MO_Eq rep -> condIntCode EQQ  (extendUExpr rep x) (extendUExpr rep y)
-      MO_Ne rep -> condIntCode NE   (extendUExpr rep x) (extendUExpr rep y)
-
-      MO_S_Gt rep -> condIntCode GTT  (extendSExpr rep x) (extendSExpr rep y)
-      MO_S_Ge rep -> condIntCode GE   (extendSExpr rep x) (extendSExpr rep y)
-      MO_S_Lt rep -> condIntCode LTT  (extendSExpr rep x) (extendSExpr rep y)
-      MO_S_Le rep -> condIntCode LE   (extendSExpr rep x) (extendSExpr rep y)
-
-      MO_U_Gt rep -> condIntCode GU   (extendUExpr rep x) (extendUExpr rep y)
-      MO_U_Ge rep -> condIntCode GEU  (extendUExpr rep x) (extendUExpr rep y)
-      MO_U_Lt rep -> condIntCode LU   (extendUExpr rep x) (extendUExpr rep y)
-      MO_U_Le rep -> condIntCode LEU  (extendUExpr rep x) (extendUExpr rep y)
-
-      other -> pprPanic "getCondCode(powerpc)" (pprMachOp mop)
-
-getCondCode other =  panic "getCondCode(2)(powerpc)"
-
-
-#endif
-
-
--- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
--- passed back up the tree.
-
-condIntCode, condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
-
-#if alpha_TARGET_ARCH
-condIntCode = panic "MachCode.condIntCode: not on Alphas"
-condFltCode = panic "MachCode.condFltCode: not on Alphas"
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-
--- memory vs immediate
-condIntCode cond (CmmLoad x pk) (CmmLit lit) | is32BitLit lit = do
-    Amode x_addr x_code <- getAmode x
-    let
-       imm  = litToImm lit
-       code = x_code `snocOL`
-                 CMP (cmmTypeSize pk) (OpImm imm) (OpAddr x_addr)
-    --
-    return (CondCode False cond code)
-
--- anything vs zero, using a mask
--- TODO: Add some sanity checking!!!!
-condIntCode cond (CmmMachOp (MO_And rep) [x,o2]) (CmmLit (CmmInt 0 pk))
-    | (CmmLit lit@(CmmInt mask pk2)) <- o2, is32BitLit lit
-    = do
-      (x_reg, x_code) <- getSomeReg x
-      let
-         code = x_code `snocOL`
-                TEST (intSize pk) (OpImm (ImmInteger mask)) (OpReg x_reg)
-      --
-      return (CondCode False cond code)
-
--- anything vs zero
-condIntCode cond x (CmmLit (CmmInt 0 pk)) = do
-    (x_reg, x_code) <- getSomeReg x
-    let
-       code = x_code `snocOL`
-                 TEST (intSize pk) (OpReg x_reg) (OpReg x_reg)
-    --
-    return (CondCode False cond code)
-
--- anything vs operand
-condIntCode cond x y | isOperand y = do
-    (x_reg, x_code) <- getNonClobberedReg x
-    (y_op,  y_code) <- getOperand y    
-    let
-       code = x_code `appOL` y_code `snocOL`
-                  CMP (cmmTypeSize (cmmExprType x)) y_op (OpReg x_reg)
-    -- in
-    return (CondCode False cond code)
-
--- anything vs anything
-condIntCode cond x y = do
-  (y_reg, y_code) <- getNonClobberedReg y
-  (x_op, x_code) <- getRegOrMem x
-  let
-       code = y_code `appOL`
-              x_code `snocOL`
-                 CMP (cmmTypeSize (cmmExprType x)) (OpReg y_reg) x_op
-  -- in
-  return (CondCode False cond code)
-#endif
-
-#if i386_TARGET_ARCH
-condFltCode cond x y 
-  = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) do
-  (x_reg, x_code) <- getNonClobberedReg x
-  (y_reg, y_code) <- getSomeReg y
-  let
-       code = x_code `appOL` y_code `snocOL`
-               GCMP cond x_reg y_reg
-  -- The GCMP insn does the test and sets the zero flag if comparable
-  -- and true.  Hence we always supply EQQ as the condition to test.
-  return (CondCode True EQQ code)
-#endif /* i386_TARGET_ARCH */
-
-#if x86_64_TARGET_ARCH
--- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be
--- an operand, but the right must be a reg.  We can probably do better
--- than this general case...
-condFltCode cond x y = do
-  (x_reg, x_code) <- getNonClobberedReg x
-  (y_op, y_code) <- getOperand y
-  let
-       code = x_code `appOL`
-              y_code `snocOL`
-                 CMP (floatSize $ cmmExprWidth x) y_op (OpReg x_reg)
-       -- NB(1): we need to use the unsigned comparison operators on the
-       -- result of this comparison.
-  -- in
-  return (CondCode True (condToUnsigned cond) code)
-#endif
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-condIntCode cond x (CmmLit (CmmInt y rep))
-  | fits13Bits y
-  = do
-       (src1, code) <- getSomeReg x
-       let
-           src2 = ImmInt (fromInteger y)
-           code' = code `snocOL` SUB False True src1 (RIImm src2) g0
-       return (CondCode False cond code')
-
-condIntCode cond x y = do
-    (src1, code1) <- getSomeReg x
-    (src2, code2) <- getSomeReg y
-    let
-       code__2 = code1 `appOL` code2 `snocOL`
-                 SUB False True src1 (RIReg src2) g0
-    return (CondCode False cond code__2)
-
------------
-condFltCode cond x y = do
-    (src1, code1) <- getSomeReg x
-    (src2, code2) <- getSomeReg y
-    tmp <- getNewRegNat FF64
-    let
-       promote x = FxTOy FF32 FF64 x tmp
-
-       pk1   = cmmExprType x
-       pk2   = cmmExprType y
-
-       code__2 =
-               if pk1 `cmmEqType` pk2 then
-                   code1 `appOL` code2 `snocOL`
-                   FCMP True (cmmTypeSize pk1) src1 src2
-               else if typeWidth pk1 == W32 then
-                   code1 `snocOL` promote src1 `appOL` code2 `snocOL`
-                   FCMP True FF64 tmp src2
-               else
-                   code1 `appOL` code2 `snocOL` promote src2 `snocOL`
-                   FCMP True FF64 src1 tmp
-    return (CondCode True cond code__2)
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
---  ###FIXME: I16 and I8!
-condIntCode cond x (CmmLit (CmmInt y rep))
-  | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y
-  = do
-        (src1, code) <- getSomeReg x
-        let
-            code' = code `snocOL` 
-                (if condUnsigned cond then CMPL else CMP) II32 src1 (RIImm src2)
-        return (CondCode False cond code')
-
-condIntCode cond x y = do
-    (src1, code1) <- getSomeReg x
-    (src2, code2) <- getSomeReg y
-    let
-       code' = code1 `appOL` code2 `snocOL`
-                 (if condUnsigned cond then CMPL else CMP) II32 src1 (RIReg src2)
-    return (CondCode False cond code')
-
-condFltCode cond x y = do
-    (src1, code1) <- getSomeReg x
-    (src2, code2) <- getSomeReg y
-    let
-       code'  = code1 `appOL` code2 `snocOL` FCMP src1 src2
-       code'' = case cond of -- twiddle CR to handle unordered case
-                    GE -> code' `snocOL` CRNOR ltbit eqbit gtbit
-                   LE -> code' `snocOL` CRNOR gtbit eqbit ltbit
-                   _ -> code'
-                 where
-                    ltbit = 0 ; eqbit = 2 ; gtbit = 1
-    return (CondCode True cond code'')
-
-#endif /* powerpc_TARGET_ARCH */
-
--- -----------------------------------------------------------------------------
--- Generating assignments
-
--- Assignments are really at the heart of the whole code generation
--- business.  Almost all top-level nodes of any real importance are
--- assignments, which correspond to loads, stores, or register
--- transfers.  If we're really lucky, some of the register transfers
--- will go away, because we can use the destination register to
--- complete the code generation for the right hand side.  This only
--- fails when the right hand side is forced into a fixed register
--- (e.g. the result of a call).
-
-assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
-assignReg_IntCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock
-
-assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
-assignReg_FltCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-assignIntCode pk (CmmLoad dst _) src
-  = getNewRegNat IntRep            `thenNat` \ tmp ->
-    getAmode dst                   `thenNat` \ amode ->
-    getRegister src                `thenNat` \ register ->
-    let
-       code1   = amodeCode amode []
-       dst__2  = amodeAddr amode
-       code2   = registerCode register tmp []
-       src__2  = registerName register tmp
-       sz      = primRepToSize pk
-       code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
-    in
-    return code__2
-
-assignIntCode pk dst src
-  = getRegister dst                        `thenNat` \ register1 ->
-    getRegister src                        `thenNat` \ register2 ->
-    let
-       dst__2  = registerName register1 zeroh
-       code    = registerCode register2 dst__2
-       src__2  = registerName register2 dst__2
-       code__2 = if isFixed register2
-                 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
-                 else code
-    in
-    return code__2
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-
--- integer assignment to memory
-
--- specific case of adding/subtracting an integer to a particular address.
--- ToDo: catch other cases where we can use an operation directly on a memory 
--- address.
-assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _,
-                                                 CmmLit (CmmInt i _)])
-   | addr == addr2, pk /= II64 || is32BitInteger i,
-     Just instr <- check op
-   = do Amode amode code_addr <- getAmode addr
-        let code = code_addr `snocOL`
-                   instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)
-        return code
-   where
-        check (MO_Add _) = Just ADD
-        check (MO_Sub _) = Just SUB
-        check _ = Nothing
-        -- ToDo: more?
-
--- general case
-assignMem_IntCode pk addr src = do
-    Amode addr code_addr <- getAmode addr
-    (code_src, op_src)   <- get_op_RI src
-    let
-       code = code_src `appOL`
-              code_addr `snocOL`
-                  MOV pk op_src (OpAddr addr)
-       -- NOTE: op_src is stable, so it will still be valid
-       -- after code_addr.  This may involve the introduction 
-       -- of an extra MOV to a temporary register, but we hope
-       -- the register allocator will get rid of it.
-    --
-    return code
-  where
-    get_op_RI :: CmmExpr -> NatM (InstrBlock,Operand)  -- code, operator
-    get_op_RI (CmmLit lit) | is32BitLit lit
-      = return (nilOL, OpImm (litToImm lit))
-    get_op_RI op
-      = do (reg,code) <- getNonClobberedReg op
-          return (code, OpReg reg)
-
-
--- Assign; dst is a reg, rhs is mem
-assignReg_IntCode pk reg (CmmLoad src _) = do
-  load_code <- intLoadCode (MOV pk) src
-  return (load_code (getRegisterReg reg))
-
--- dst is a reg, but src could be anything
-assignReg_IntCode pk reg src = do
-  code <- getAnyReg src
-  return (code (getRegisterReg reg))
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-assignMem_IntCode pk addr src = do
-    (srcReg, code) <- getSomeReg src
-    Amode dstAddr addr_code <- getAmode addr
-    return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
-
-assignReg_IntCode pk reg src = do
-    r <- getRegister src
-    return $ case r of
-       Any _ code         -> code dst
-       Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst
-    where
-      dst = getRegisterReg reg
-
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-
-assignMem_IntCode pk addr src = do
-    (srcReg, code) <- getSomeReg src
-    Amode dstAddr addr_code <- getAmode addr
-    return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
-
--- dst is a reg, but src could be anything
-assignReg_IntCode pk reg src
-    = do
-        r <- getRegister src
-        return $ case r of
-            Any _ code         -> code dst
-            Fixed _ freg fcode -> fcode `snocOL` MR dst freg
-    where
-        dst = getRegisterReg reg
-
-#endif /* powerpc_TARGET_ARCH */
-
-
--- -----------------------------------------------------------------------------
--- Floating-point assignments
-
-#if alpha_TARGET_ARCH
-
-assignFltCode pk (CmmLoad dst _) src
-  = getNewRegNat pk                `thenNat` \ tmp ->
-    getAmode dst                   `thenNat` \ amode ->
-    getRegister src                        `thenNat` \ register ->
-    let
-       code1   = amodeCode amode []
-       dst__2  = amodeAddr amode
-       code2   = registerCode register tmp []
-       src__2  = registerName register tmp
-       sz      = primRepToSize pk
-       code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
-    in
-    return code__2
-
-assignFltCode pk dst src
-  = getRegister dst                        `thenNat` \ register1 ->
-    getRegister src                        `thenNat` \ register2 ->
-    let
-       dst__2  = registerName register1 zeroh
-       code    = registerCode register2 dst__2
-       src__2  = registerName register2 dst__2
-       code__2 = if isFixed register2
-                 then code . mkSeqInstr (FMOV src__2 dst__2)
-                 else code
-    in
-    return code__2
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-
--- Floating point assignment to memory
-assignMem_FltCode pk addr src = do
-  (src_reg, src_code) <- getNonClobberedReg src
-  Amode addr addr_code <- getAmode addr
-  let
-       code = src_code `appOL`
-              addr_code `snocOL`
-                IF_ARCH_i386(GST pk src_reg addr,
-                            MOV pk (OpReg src_reg) (OpAddr addr))
-  return code
-
--- Floating point assignment to a register/temporary
-assignReg_FltCode pk reg src = do
-  src_code <- getAnyReg src
-  return (src_code (getRegisterReg reg))
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
--- Floating point assignment to memory
-assignMem_FltCode pk addr src = do
-    Amode dst__2 code1 <- getAmode addr
-    (src__2, code2) <- getSomeReg src
-    tmp1 <- getNewRegNat pk
-    let
-       pk__2   = cmmExprType src
-       code__2 = code1 `appOL` code2 `appOL`
-           if   sizeToWidth pk == typeWidth pk__2 
-            then unitOL (ST pk src__2 dst__2)
-           else toOL   [ FxTOy (cmmTypeSize pk__2) pk src__2 tmp1
-                       , ST    pk tmp1 dst__2]
-    return code__2
-
--- Floating point assignment to a register/temporary
-assignReg_FltCode pk dstCmmReg srcCmmExpr = do
-    srcRegister <- getRegister srcCmmExpr
-    let dstReg = getRegisterReg dstCmmReg
-
-    return $ case srcRegister of
-        Any _ code                 -> code dstReg
-       Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-
--- Easy, isn't it?
-assignMem_FltCode = assignMem_IntCode
-assignReg_FltCode = assignReg_IntCode
-
-#endif /* powerpc_TARGET_ARCH */
-
-
--- -----------------------------------------------------------------------------
--- Generating an non-local jump
-
--- (If applicable) Do not fill the delay slots here; you will confuse the
--- register allocator.
-
-genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-genJump (CmmLabel lbl)
-  | isAsmTemp lbl = returnInstr (BR target)
-  | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
-  where
-    target = ImmCLbl lbl
-
-genJump tree
-  = getRegister tree               `thenNat` \ register ->
-    getNewRegNat PtrRep            `thenNat` \ tmp ->
-    let
-       dst    = registerName register pv
-       code   = registerCode register pv
-       target = registerName register pv
-    in
-    if isFixed register then
-       returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
-    else
-    return (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-
-genJump (CmmLoad mem pk) = do
-  Amode target code <- getAmode mem
-  return (code `snocOL` JMP (OpAddr target))
-
-genJump (CmmLit lit) = do
-  return (unitOL (JMP (OpImm (litToImm lit))))
-
-genJump expr = do
-  (reg,code) <- getSomeReg expr
-  return (code `snocOL` JMP (OpReg reg))
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-genJump (CmmLit (CmmLabel lbl))
-  = return (toOL [CALL (Left target) 0 True, NOP])
-  where
-    target = ImmCLbl lbl
-
-genJump tree
-  = do
-        (target, code) <- getSomeReg tree
-       return (code `snocOL` JMP (AddrRegReg target g0)  `snocOL` NOP)
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-genJump (CmmLit (CmmLabel lbl))
-  = return (unitOL $ JMP lbl)
-
-genJump tree
-  = do
-        (target,code) <- getSomeReg tree
-        return (code `snocOL` MTCTR target `snocOL` BCTR [])
-#endif /* powerpc_TARGET_ARCH */
-
-
--- -----------------------------------------------------------------------------
---  Unconditional branches
-
-genBranch :: BlockId -> NatM InstrBlock
-
-genBranch = return . toOL . mkBranchInstr
-
--- -----------------------------------------------------------------------------
---  Conditional jumps
-
-{-
-Conditional jumps are always to local labels, so we can use branch
-instructions.  We peek at the arguments to decide what kind of
-comparison to do.
-
-ALPHA: For comparisons with 0, we're laughing, because we can just do
-the desired conditional branch.
-
-I386: First, we have to ensure that the condition
-codes are set according to the supplied comparison operation.
-
-SPARC: First, we have to ensure that the condition codes are set
-according to the supplied comparison operation.  We generate slightly
-different code for floating point comparisons, because a floating
-point operation cannot directly precede a @BF@.  We assume the worst
-and fill that slot with a @NOP@.
-
-SPARC: Do not fill the delay slots here; you will confuse the register
-allocator.
--}
-
-
-genCondJump
-    :: BlockId     -- the branch target
-    -> CmmExpr      -- the condition on which to branch
-    -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-genCondJump id (StPrim op [x, StInt 0])
-  = getRegister x                          `thenNat` \ register ->
-    getNewRegNat (registerRep register)
-                                   `thenNat` \ tmp ->
-    let
-       code   = registerCode register tmp
-       value  = registerName register tmp
-       pk     = registerRep register
-       target = ImmCLbl lbl
-    in
-    returnSeq code [BI (cmpOp op) value target]
-  where
-    cmpOp CharGtOp = GTT
-    cmpOp CharGeOp = GE
-    cmpOp CharEqOp = EQQ
-    cmpOp CharNeOp = NE
-    cmpOp CharLtOp = LTT
-    cmpOp CharLeOp = LE
-    cmpOp IntGtOp = GTT
-    cmpOp IntGeOp = GE
-    cmpOp IntEqOp = EQQ
-    cmpOp IntNeOp = NE
-    cmpOp IntLtOp = LTT
-    cmpOp IntLeOp = LE
-    cmpOp WordGtOp = NE
-    cmpOp WordGeOp = ALWAYS
-    cmpOp WordEqOp = EQQ
-    cmpOp WordNeOp = NE
-    cmpOp WordLtOp = NEVER
-    cmpOp WordLeOp = EQQ
-    cmpOp AddrGtOp = NE
-    cmpOp AddrGeOp = ALWAYS
-    cmpOp AddrEqOp = EQQ
-    cmpOp AddrNeOp = NE
-    cmpOp AddrLtOp = NEVER
-    cmpOp AddrLeOp = EQQ
-
-genCondJump lbl (StPrim op [x, StDouble 0.0])
-  = getRegister x                          `thenNat` \ register ->
-    getNewRegNat (registerRep register)
-                                   `thenNat` \ tmp ->
-    let
-       code   = registerCode register tmp
-       value  = registerName register tmp
-       pk     = registerRep register
-       target = ImmCLbl lbl
-    in
-    return (code . mkSeqInstr (BF (cmpOp op) value target))
-  where
-    cmpOp FloatGtOp = GTT
-    cmpOp FloatGeOp = GE
-    cmpOp FloatEqOp = EQQ
-    cmpOp FloatNeOp = NE
-    cmpOp FloatLtOp = LTT
-    cmpOp FloatLeOp = LE
-    cmpOp DoubleGtOp = GTT
-    cmpOp DoubleGeOp = GE
-    cmpOp DoubleEqOp = EQQ
-    cmpOp DoubleNeOp = NE
-    cmpOp DoubleLtOp = LTT
-    cmpOp DoubleLeOp = LE
-
-genCondJump lbl (StPrim op [x, y])
-  | fltCmpOp op
-  = trivialFCode pr instr x y      `thenNat` \ register ->
-    getNewRegNat FF64              `thenNat` \ tmp ->
-    let
-       code   = registerCode register tmp
-       result = registerName register tmp
-       target = ImmCLbl lbl
-    in
-    return (code . mkSeqInstr (BF cond result target))
-  where
-    pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
-
-    fltCmpOp op = case op of
-       FloatGtOp -> True
-       FloatGeOp -> True
-       FloatEqOp -> True
-       FloatNeOp -> True
-       FloatLtOp -> True
-       FloatLeOp -> True
-       DoubleGtOp -> True
-       DoubleGeOp -> True
-       DoubleEqOp -> True
-       DoubleNeOp -> True
-       DoubleLtOp -> True
-       DoubleLeOp -> True
-       _ -> False
-    (instr, cond) = case op of
-       FloatGtOp -> (FCMP TF LE, EQQ)
-       FloatGeOp -> (FCMP TF LTT, EQQ)
-       FloatEqOp -> (FCMP TF EQQ, NE)
-       FloatNeOp -> (FCMP TF EQQ, EQQ)
-       FloatLtOp -> (FCMP TF LTT, NE)
-       FloatLeOp -> (FCMP TF LE, NE)
-       DoubleGtOp -> (FCMP TF LE, EQQ)
-       DoubleGeOp -> (FCMP TF LTT, EQQ)
-       DoubleEqOp -> (FCMP TF EQQ, NE)
-       DoubleNeOp -> (FCMP TF EQQ, EQQ)
-       DoubleLtOp -> (FCMP TF LTT, NE)
-       DoubleLeOp -> (FCMP TF LE, NE)
-
-genCondJump lbl (StPrim op [x, y])
-  = trivialCode instr x y          `thenNat` \ register ->
-    getNewRegNat IntRep            `thenNat` \ tmp ->
-    let
-       code   = registerCode register tmp
-       result = registerName register tmp
-       target = ImmCLbl lbl
-    in
-    return (code . mkSeqInstr (BI cond result target))
-  where
-    (instr, cond) = case op of
-       CharGtOp -> (CMP LE, EQQ)
-       CharGeOp -> (CMP LTT, EQQ)
-       CharEqOp -> (CMP EQQ, NE)
-       CharNeOp -> (CMP EQQ, EQQ)
-       CharLtOp -> (CMP LTT, NE)
-       CharLeOp -> (CMP LE, NE)
-       IntGtOp -> (CMP LE, EQQ)
-       IntGeOp -> (CMP LTT, EQQ)
-       IntEqOp -> (CMP EQQ, NE)
-       IntNeOp -> (CMP EQQ, EQQ)
-       IntLtOp -> (CMP LTT, NE)
-       IntLeOp -> (CMP LE, NE)
-       WordGtOp -> (CMP ULE, EQQ)
-       WordGeOp -> (CMP ULT, EQQ)
-       WordEqOp -> (CMP EQQ, NE)
-       WordNeOp -> (CMP EQQ, EQQ)
-       WordLtOp -> (CMP ULT, NE)
-       WordLeOp -> (CMP ULE, NE)
-       AddrGtOp -> (CMP ULE, EQQ)
-       AddrGeOp -> (CMP ULT, EQQ)
-       AddrEqOp -> (CMP EQQ, NE)
-       AddrNeOp -> (CMP EQQ, EQQ)
-       AddrLtOp -> (CMP ULT, NE)
-       AddrLeOp -> (CMP ULE, NE)
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
-genCondJump id bool = do
-  CondCode _ cond code <- getCondCode bool
-  return (code `snocOL` JXX cond id)
-
-#endif
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if x86_64_TARGET_ARCH
-
-genCondJump id bool = do
-  CondCode is_float cond cond_code <- getCondCode bool
-  if not is_float
-    then
-       return (cond_code `snocOL` JXX cond id)
-    else do
-       lbl <- getBlockIdNat
-
-       -- see comment with condFltReg
-       let code = case cond of
-                       NE  -> or_unordered
-                       GU  -> plain_test
-                       GEU -> plain_test
-                       _   -> and_ordered
-
-           plain_test = unitOL (
-                 JXX cond id
-               )
-           or_unordered = toOL [
-                 JXX cond id,
-                 JXX PARITY id
-               ]
-           and_ordered = toOL [
-                 JXX PARITY lbl,
-                 JXX cond id,
-                 JXX ALWAYS lbl,
-                 NEWBLOCK lbl
-               ]
-       return (cond_code `appOL` code)
-
-#endif
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-genCondJump bid bool = do
-  CondCode is_float cond code <- getCondCode bool
-  return (
-       code `appOL` 
-       toOL (
-         if   is_float
-         then [NOP, BF cond False bid, NOP]
-         else [BI cond False bid, NOP]
-       )
-    )
-
-#endif /* sparc_TARGET_ARCH */
-
-
-#if powerpc_TARGET_ARCH
-
-genCondJump id bool = do
-  CondCode is_float cond code <- getCondCode bool
-  return (code `snocOL` BCC cond id)
-
-#endif /* powerpc_TARGET_ARCH */
-
-
--- -----------------------------------------------------------------------------
---  Generating C calls
-
--- Now the biggest nightmare---calls.  Most of the nastiness is buried in
--- @get_arg@, which moves the arguments to the correct registers/stack
--- locations.  Apart from that, the code is easy.
--- 
--- (If applicable) Do not fill the delay slots here; you will confuse the
--- register allocator.
-
-genCCall
-    :: CmmCallTarget           -- function to call
-    -> HintedCmmFormals                -- where to put the result
-    -> HintedCmmActuals                -- arguments (of mixed type)
-    -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-ccallResultRegs = 
-
-genCCall fn cconv result_regs args
-  = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
-                         `thenNat` \ ((unused,_), argCode) ->
-    let
-       nRegs = length allArgRegs - length unused
-       code = asmSeqThen (map ($ []) argCode)
-    in
-       returnSeq code [
-           LDA pv (AddrImm (ImmLab (ptext fn))),
-           JSR ra (AddrReg pv) nRegs,
-           LDGP gp (AddrReg ra)]
-  where
-    ------------------------
-    {- Try to get a value into a specific register (or registers) for
-       a call.  The first 6 arguments go into the appropriate
-       argument register (separate registers for integer and floating
-       point arguments, but used in lock-step), and the remaining
-       arguments are dumped to the stack, beginning at 0(sp).  Our
-       first argument is a pair of the list of remaining argument
-       registers to be assigned for this call and the next stack
-       offset to use for overflowing arguments.  This way,
-       @get_Arg@ can be applied to all of a call's arguments using
-       @mapAccumLNat@.
-    -}
-    get_arg
-       :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
-       -> StixTree             -- Current argument
-       -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
-
-    -- We have to use up all of our argument registers first...
-
-    get_arg ((iDst,fDst):dsts, offset) arg
-      = getRegister arg                            `thenNat` \ register ->
-       let
-           reg  = if isFloatType pk then fDst else iDst
-           code = registerCode register reg
-           src  = registerName register reg
-           pk   = registerRep register
-       in
-       return (
-           if isFloatType pk then
-               ((dsts, offset), if isFixed register then
-                   code . mkSeqInstr (FMOV src fDst)
-                   else code)
-           else
-               ((dsts, offset), if isFixed register then
-                   code . mkSeqInstr (OR src (RIReg src) iDst)
-                   else code))
-
-    -- Once we have run out of argument registers, we move to the
-    -- stack...
-
-    get_arg ([], offset) arg
-      = getRegister arg                        `thenNat` \ register ->
-       getNewRegNat (registerRep register)
-                                       `thenNat` \ tmp ->
-       let
-           code = registerCode register tmp
-           src  = registerName register tmp
-           pk   = registerRep register
-           sz   = primRepToSize pk
-       in
-       return (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
-genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL
-       -- write barrier compiles to no code on x86/x86-64; 
-       -- we keep it this long in order to prevent earlier optimisations.
-
--- we only cope with a single result for foreign calls
-genCCall (CmmPrim op) [CmmHinted r _] args = do
-  l1 <- getNewLabelNat
-  l2 <- getNewLabelNat
-  case op of
-       MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args
-       MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args
-       
-       MO_F32_Sin  -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args
-       MO_F64_Sin  -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args
-
-       MO_F32_Cos  -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args
-       MO_F64_Cos  -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args
-
-       MO_F32_Tan  -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args
-       MO_F64_Tan  -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args
-       
-       other_op    -> outOfLineFloatOp op r args
- where
-  actuallyInlineFloatOp instr size [CmmHinted x _]
-       = do res <- trivialUFCode size (instr size) x
-            any <- anyReg res
-            return (any (getRegisterReg (CmmLocal r)))
-
-genCCall target dest_regs args = do
-    let
-        sizes               = map (arg_size . cmmExprType . hintlessCmm) (reverse args)
-#if !darwin_TARGET_OS        
-        tot_arg_size        = sum sizes
-#else
-        raw_arg_size        = sum sizes
-        tot_arg_size        = roundTo 16 raw_arg_size
-        arg_pad_size        = tot_arg_size - raw_arg_size
-    delta0 <- getDeltaNat
-    setDeltaNat (delta0 - arg_pad_size)
-#endif
-
-    push_codes <- mapM push_arg (reverse args)
-    delta <- getDeltaNat
-
-    -- in
-    -- deal with static vs dynamic call targets
-    (callinsns,cconv) <-
-      case target of
-       -- CmmPrim -> ...
-        CmmCallee (CmmLit (CmmLabel lbl)) conv
-           -> -- ToDo: stdcall arg sizes
-             return (unitOL (CALL (Left fn_imm) []), conv)
-          where fn_imm = ImmCLbl lbl
-        CmmCallee expr conv
-           -> do { (dyn_c, dyn_r) <- get_op expr
-                 ; ASSERT( isWord32 (cmmExprType expr) )
-                   return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }
-
-    let        push_code
-#if darwin_TARGET_OS
-            | arg_pad_size /= 0
-            = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),
-                    DELTA (delta0 - arg_pad_size)]
-              `appOL` concatOL push_codes
-            | otherwise
-#endif
-            = concatOL push_codes
-       call = callinsns `appOL`
-               toOL (
-                       -- Deallocate parameters after call for ccall;
-                       -- but not for stdcall (callee does it)
-                  (if cconv == StdCallConv || tot_arg_size==0 then [] else 
-                  [ADD II32 (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
-                  ++
-                  [DELTA (delta + tot_arg_size)]
-               )
-    -- in
-    setDeltaNat (delta + tot_arg_size)
-
-    let
-       -- assign the results, if necessary
-       assign_code []     = nilOL
-       assign_code [CmmHinted dest _hint]
-         | isFloatType ty = unitOL (GMOV fake0 r_dest)
-         | isWord64 ty    = toOL [MOV II32 (OpReg eax) (OpReg r_dest),
-                                   MOV II32 (OpReg edx) (OpReg r_dest_hi)]
-         | otherwise      = unitOL (MOV (intSize w) (OpReg eax) (OpReg r_dest))
-         where 
-               ty = localRegType dest
-               w  = typeWidth ty
-               r_dest_hi = getHiVRegFromLo r_dest
-               r_dest    = getRegisterReg (CmmLocal dest)
-       assign_code many = panic "genCCall.assign_code many"
-
-    return (push_code `appOL` 
-           call `appOL` 
-           assign_code dest_regs)
-
-  where
-    arg_size :: CmmType -> Int -- Width in bytes
-    arg_size ty = widthInBytes (typeWidth ty)
-
-    roundTo a x | x `mod` a == 0 = x
-                | otherwise = x + a - (x `mod` a)
-
-
-    push_arg :: HintedCmmActual {-current argument-}
-                    -> NatM InstrBlock  -- code
-
-    push_arg (CmmHinted arg _hint) -- we don't need the hints on x86
-      | isWord64 arg_ty = do
-        ChildCode64 code r_lo <- iselExpr64 arg
-        delta <- getDeltaNat
-        setDeltaNat (delta - 8)
-        let 
-            r_hi = getHiVRegFromLo r_lo
-        -- in
-       return (       code `appOL`
-                       toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),
-                             PUSH II32 (OpReg r_lo), DELTA (delta - 8),
-                            DELTA (delta-8)]
-            )
-
-      | otherwise = do
-        (code, reg) <- get_op arg
-        delta <- getDeltaNat
-        let size = arg_size arg_ty     -- Byte size
-        setDeltaNat (delta-size)
-        if (isFloatType arg_ty)
-           then return (code `appOL`
-                        toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),
-                              DELTA (delta-size),
-                              GST (floatSize (typeWidth arg_ty))
-                                 reg (AddrBaseIndex (EABaseReg esp) 
-                                                        EAIndexNone
-                                                        (ImmInt 0))]
-                       )
-           else return (code `snocOL`
-                        PUSH II32 (OpReg reg) `snocOL`
-                        DELTA (delta-size)
-                       )
-      where
-         arg_ty = cmmExprType arg
-
-    ------------
-    get_op :: CmmExpr -> NatM (InstrBlock, Reg) -- code, reg
-    get_op op = do
-        (reg,code) <- getSomeReg op
-       return (code, reg)
-
-#endif /* i386_TARGET_ARCH */
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-
-outOfLineFloatOp :: CallishMachOp -> CmmFormal -> HintedCmmActuals
-  -> NatM InstrBlock
-outOfLineFloatOp mop res args
-  = do
-      dflags <- getDynFlagsNat
-      targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl
-      let target = CmmCallee targetExpr CCallConv
-        
-      if isFloat64 (localRegType res)
-        then
-          stmtToInstrs (CmmCall target [CmmHinted res NoHint] args CmmUnsafe CmmMayReturn)
-        else do
-          uq <- getUniqueNat
-          let 
-            tmp = LocalReg uq f64
-          -- in
-          code1 <- stmtToInstrs (CmmCall target [CmmHinted tmp NoHint] args CmmUnsafe CmmMayReturn)
-          code2 <- stmtToInstrs (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp)))
-          return (code1 `appOL` code2)
-  where
-       lbl = mkForeignLabel fn Nothing False IsFunction
-
-       fn = case mop of
-             MO_F32_Sqrt  -> fsLit "sqrtf"
-             MO_F32_Sin   -> fsLit "sinf"
-             MO_F32_Cos   -> fsLit "cosf"
-             MO_F32_Tan   -> fsLit "tanf"
-             MO_F32_Exp   -> fsLit "expf"
-             MO_F32_Log   -> fsLit "logf"
-
-             MO_F32_Asin  -> fsLit "asinf"
-             MO_F32_Acos  -> fsLit "acosf"
-             MO_F32_Atan  -> fsLit "atanf"
-
-             MO_F32_Sinh  -> fsLit "sinhf"
-             MO_F32_Cosh  -> fsLit "coshf"
-             MO_F32_Tanh  -> fsLit "tanhf"
-             MO_F32_Pwr   -> fsLit "powf"
-
-             MO_F64_Sqrt  -> fsLit "sqrt"
-             MO_F64_Sin   -> fsLit "sin"
-             MO_F64_Cos   -> fsLit "cos"
-             MO_F64_Tan   -> fsLit "tan"
-             MO_F64_Exp   -> fsLit "exp"
-             MO_F64_Log   -> fsLit "log"
-
-             MO_F64_Asin  -> fsLit "asin"
-             MO_F64_Acos  -> fsLit "acos"
-             MO_F64_Atan  -> fsLit "atan"
-
-             MO_F64_Sinh  -> fsLit "sinh"
-             MO_F64_Cosh  -> fsLit "cosh"
-             MO_F64_Tanh  -> fsLit "tanh"
-             MO_F64_Pwr   -> fsLit "pow"
-
-#endif /* i386_TARGET_ARCH || x86_64_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if x86_64_TARGET_ARCH
-
-genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL
-       -- write barrier compiles to no code on x86/x86-64; 
-       -- we keep it this long in order to prevent earlier optimisations.
-
-
-genCCall (CmmPrim op) [CmmHinted r _] args = 
-  outOfLineFloatOp op r args
-
-genCCall target dest_regs args = do
-
-       -- load up the register arguments
-    (stack_args, aregs, fregs, load_args_code)
-        <- load_args args allArgRegs allFPArgRegs nilOL
-
-    let
-       fp_regs_used  = reverse (drop (length fregs) (reverse allFPArgRegs))
-       int_regs_used = reverse (drop (length aregs) (reverse allArgRegs))
-       arg_regs = [eax] ++ int_regs_used ++ fp_regs_used
-               -- for annotating the call instruction with
-
-       sse_regs = length fp_regs_used
-
-       tot_arg_size = arg_size * length stack_args
-
-       -- On entry to the called function, %rsp should be aligned
-       -- on a 16-byte boundary +8 (i.e. the first stack arg after
-       -- the return address is 16-byte aligned).  In STG land
-       -- %rsp is kept 16-byte aligned (see StgCRun.c), so we just
-       -- need to make sure we push a multiple of 16-bytes of args,
-       -- plus the return address, to get the correct alignment.
-       -- Urg, this is hard.  We need to feed the delta back into
-       -- the arg pushing code.
-    (real_size, adjust_rsp) <-
-       if tot_arg_size `rem` 16 == 0
-           then return (tot_arg_size, nilOL)
-           else do -- we need to adjust...
-               delta <- getDeltaNat
-               setDeltaNat (delta-8)
-               return (tot_arg_size+8, toOL [
-                               SUB II64 (OpImm (ImmInt 8)) (OpReg rsp),
-                               DELTA (delta-8)
-                       ])
-
-       -- push the stack args, right to left
-    push_code <- push_args (reverse stack_args) nilOL
-    delta <- getDeltaNat
-
-    -- deal with static vs dynamic call targets
-    (callinsns,cconv) <-
-      case target of
-       -- CmmPrim -> ...
-        CmmCallee (CmmLit (CmmLabel lbl)) conv
-           -> -- ToDo: stdcall arg sizes
-             return (unitOL (CALL (Left fn_imm) arg_regs), conv)
-          where fn_imm = ImmCLbl lbl
-        CmmCallee expr conv
-           -> do (dyn_r, dyn_c) <- getSomeReg expr
-                return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)
-
-    let
-       -- The x86_64 ABI requires us to set %al to the number of SSE
-       -- registers that contain arguments, if the called routine
-       -- is a varargs function.  We don't know whether it's a
-       -- varargs function or not, so we have to assume it is.
-       --
-       -- It's not safe to omit this assignment, even if the number
-       -- of SSE regs in use is zero.  If %al is larger than 8
-       -- on entry to a varargs function, seg faults ensue.
-       assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))
-
-    let call = callinsns `appOL`
-               toOL (
-                       -- Deallocate parameters after call for ccall;
-                       -- but not for stdcall (callee does it)
-                  (if cconv == StdCallConv || real_size==0 then [] else 
-                  [ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)])
-                  ++
-                  [DELTA (delta + real_size)]
-               )
-    -- in
-    setDeltaNat (delta + real_size)
-
-    let
-       -- assign the results, if necessary
-       assign_code []     = nilOL
-       assign_code [CmmHinted dest _hint] = 
-         case typeWidth rep of
-               W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest))
-               W64 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest))
-               _ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest))
-         where 
-               rep = localRegType dest
-               r_dest = getRegisterReg (CmmLocal dest)
-       assign_code many = panic "genCCall.assign_code many"
-
-    return (load_args_code     `appOL` 
-           adjust_rsp          `appOL`
-           push_code           `appOL`
-           assign_eax sse_regs `appOL`
-           call                `appOL` 
-           assign_code dest_regs)
-
-  where
-    arg_size = 8 -- always, at the mo
-
-    load_args :: [CmmHinted CmmExpr]
-             -> [Reg]                  -- int regs avail for args
-             -> [Reg]                  -- FP regs avail for args
-             -> InstrBlock
-             -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock)
-    load_args args [] [] code     =  return (args, [], [], code)
-       -- no more regs to use
-    load_args [] aregs fregs code =  return ([], aregs, fregs, code)
-       -- no more args to push
-    load_args ((CmmHinted arg hint) : rest) aregs fregs code
-       | isFloatType arg_rep = 
-       case fregs of
-         [] -> push_this_arg
-         (r:rs) -> do
-            arg_code <- getAnyReg arg
-            load_args rest aregs rs (code `appOL` arg_code r)
-       | otherwise =
-       case aregs of
-         [] -> push_this_arg
-         (r:rs) -> do
-            arg_code <- getAnyReg arg
-            load_args rest rs fregs (code `appOL` arg_code r)
-       where
-         arg_rep = cmmExprType arg
-
-         push_this_arg = do
-           (args',ars,frs,code') <- load_args rest aregs fregs code
-           return ((CmmHinted arg hint):args', ars, frs, code')
-
-    push_args [] code = return code
-    push_args ((CmmHinted arg hint):rest) code
-       | isFloatType arg_rep = do
-        (arg_reg, arg_code) <- getSomeReg arg
-         delta <- getDeltaNat
-         setDeltaNat (delta-arg_size)
-        let code' = code `appOL` arg_code `appOL` toOL [
-                       SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) ,
-                       DELTA (delta-arg_size),
-                       MOV (floatSize width) (OpReg arg_reg) (OpAddr  (spRel 0))]
-        push_args rest code'
-
-       | otherwise = do
-       -- we only ever generate word-sized function arguments.  Promotion
-       -- has already happened: our Int8# type is kept sign-extended
-       -- in an Int#, for example.
-        ASSERT(width == W64) return ()
-        (arg_op, arg_code) <- getOperand arg
-         delta <- getDeltaNat
-         setDeltaNat (delta-arg_size)
-        let code' = code `appOL` arg_code `appOL` toOL [
-                        PUSH II64 arg_op, 
-                       DELTA (delta-arg_size)]
-        push_args rest code'
-       where
-         arg_rep = cmmExprType arg
-         width = typeWidth arg_rep
-#endif
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-{- 
-   The SPARC calling convention is an absolute
-   nightmare.  The first 6x32 bits of arguments are mapped into
-   %o0 through %o5, and the remaining arguments are dumped to the
-   stack, beginning at [%sp+92].  (Note that %o6 == %sp.)
-
-   If we have to put args on the stack, move %o6==%sp down by
-   the number of words to go on the stack, to ensure there's enough space.
-
-   According to Fraser and Hanson's lcc book, page 478, fig 17.2,
-   16 words above the stack pointer is a word for the address of
-   a structure return value.  I use this as a temporary location
-   for moving values from float to int regs.  Certainly it isn't
-   safe to put anything in the 16 words starting at %sp, since
-   this area can get trashed at any time due to window overflows
-   caused by signal handlers.
-
-   A final complication (if the above isn't enough) is that 
-   we can't blithely calculate the arguments one by one into
-   %o0 .. %o5.  Consider the following nested calls:
-
-       fff a (fff b c)
-
-   Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately
-   the inner call will itself use %o0, which trashes the value put there
-   in preparation for the outer call.  Upshot: we need to calculate the
-   args into temporary regs, and move those to arg regs or onto the
-   stack only immediately prior to the call proper.  Sigh.
-
-genCCall
-    :: CmmCallTarget           -- function to call
-    -> HintedCmmFormals                -- where to put the result
-    -> HintedCmmActuals                -- arguments (of mixed type)
-    -> NatM InstrBlock
-
--}
-
-
--- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream
--- are guaranteed to take place before writes afterwards (unlike on PowerPC). 
--- Ref: Section 8.4 of the SPARC V9 Architecture manual.
---
--- In the SPARC case we don't need a barrier.
---
-genCCall (CmmPrim (MO_WriteBarrier)) _ _
- = do  return nilOL
-
-genCCall target dest_regs argsAndHints 
- = do          
-       -- strip hints from the arg regs
-       let args :: [CmmExpr]
-           args  = map hintlessCmm argsAndHints
-
-
-       -- work out the arguments, and assign them to integer regs
-       argcode_and_vregs       <- mapM arg_to_int_vregs args
-       let (argcodes, vregss)  = unzip argcode_and_vregs
-       let vregs               = concat vregss
-
-       let n_argRegs           = length allArgRegs
-       let n_argRegs_used      = min (length vregs) n_argRegs
-
-
-       -- deal with static vs dynamic call targets
-       callinsns <- case target of
-               CmmCallee (CmmLit (CmmLabel lbl)) conv -> 
-                       return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
-
-               CmmCallee expr conv 
-                -> do  (dyn_c, [dyn_r]) <- arg_to_int_vregs expr
-                       return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
-
-               CmmPrim mop 
-                -> do  res     <- outOfLineFloatOp mop
-                       lblOrMopExpr <- case res of
-                               Left lbl -> do
-                                       return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
-
-                               Right mopExpr -> do
-                                       (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr
-                                       return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
-
-                       return lblOrMopExpr
-
-       let argcode = concatOL argcodes
-
-       let (move_sp_down, move_sp_up)
-                  = let diff = length vregs - n_argRegs
-                        nn   = if odd diff then diff + 1 else diff -- keep 8-byte alignment
-                    in  if   nn <= 0
-                        then (nilOL, nilOL)
-                        else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
-
-        let transfer_code
-               = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
-                               
-       return 
-        $      argcode                 `appOL`
-               move_sp_down            `appOL`
-               transfer_code           `appOL`
-               callinsns               `appOL`
-               unitOL NOP              `appOL`
-               move_sp_up              `appOL`
-               assign_code dest_regs
-
-
--- | Generate code to calculate an argument, and move it into one
---     or two integer vregs.
-arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg])
-arg_to_int_vregs arg
-
-       -- If the expr produces a 64 bit int, then we can just use iselExpr64
-       | isWord64 (cmmExprType arg)
-       = do    (ChildCode64 code r_lo) <- iselExpr64 arg
-               let r_hi                = getHiVRegFromLo r_lo
-               return (code, [r_hi, r_lo])
-
-       | otherwise
-       = do    (src, code)     <- getSomeReg arg
-               tmp             <- getNewRegNat (cmmTypeSize $ cmmExprType arg)
-               let pk          = cmmExprType arg
-
-               case cmmTypeSize pk of
-
-                -- Load a 64 bit float return value into two integer regs.
-                FF64 -> do
-                       v1 <- getNewRegNat II32
-                       v2 <- getNewRegNat II32
-
-                       let Just f0_high = fPair f0
-                       
-                       let code2 = 
-                               code                            `snocOL`
-                               FMOV FF64 src f0                `snocOL`
-                               ST   FF32  f0 (spRel 16)        `snocOL`
-                               LD   II32  (spRel 16) v1        `snocOL`
-                               ST   FF32  f0_high (spRel 16)   `snocOL`
-                               LD   II32  (spRel 16) v2
-
-                       return  (code2, [v1,v2])
-
-                -- Load a 32 bit float return value into an integer reg
-                FF32 -> do
-                       v1 <- getNewRegNat II32
-                       
-                       let code2 =
-                               code                            `snocOL`
-                               ST   FF32  src (spRel 16)       `snocOL`
-                               LD   II32  (spRel 16) v1
-                               
-                       return (code2, [v1])
-
-                -- Move an integer return value into its destination reg.
-                other -> do
-                       v1 <- getNewRegNat II32
-                       
-                       let code2 = 
-                               code                            `snocOL`
-                               OR False g0 (RIReg src) v1
-                       
-                       return (code2, [v1])
-
-
--- | Move args from the integer vregs into which they have been 
---     marshalled, into %o0 .. %o5, and the rest onto the stack.
---
-move_final :: [Reg] -> [Reg] -> Int -> [Instr]
-
--- all args done
-move_final [] _ offset          
-       = []
-
--- out of aregs; move to stack
-move_final (v:vs) [] offset     
-       = ST II32 v (spRel offset)
-       : move_final vs [] (offset+1)
-
--- move into an arg (%o[0..5]) reg
-move_final (v:vs) (a:az) offset 
-       = OR False g0 (RIReg v) a
-       : move_final vs az offset
-
-
--- | Assign results returned from the call into their 
---     desination regs.
---
-assign_code :: [CmmHinted LocalReg] -> OrdList Instr
-assign_code [] = nilOL
-
-assign_code [CmmHinted dest _hint]     
- = let rep     = localRegType dest
-       width   = typeWidth rep
-       r_dest  = getRegisterReg (CmmLocal dest)
-
-       result
-               | isFloatType rep 
-               , W32   <- width
-               = unitOL $ FMOV FF32 (RealReg $ fReg 0) r_dest
-
-               | isFloatType rep
-               , W64   <- width
-               = unitOL $ FMOV FF64 (RealReg $ fReg 0) r_dest
-
-               | not $ isFloatType rep
-               , W32   <- width
-               = unitOL $ mkRegRegMoveInstr (RealReg $ oReg 0) r_dest
-
-               | not $ isFloatType rep
-               , W64           <- width
-               , r_dest_hi     <- getHiVRegFromLo r_dest
-               = toOL  [ mkRegRegMoveInstr (RealReg $ oReg 0) r_dest_hi
-                       , mkRegRegMoveInstr (RealReg $ oReg 1) r_dest]
-   in  result
-
-
--- | Generate a call to implement an out-of-line floating point operation
-outOfLineFloatOp 
-       :: CallishMachOp 
-       -> NatM (Either CLabel CmmExpr)
-
-outOfLineFloatOp mop 
- = do  let functionName
-               = outOfLineFloatOp_table mop
-       
-       dflags  <- getDynFlagsNat
-       mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference 
-               $  mkForeignLabel functionName Nothing True IsFunction
-
-       let mopLabelOrExpr 
-               = case mopExpr of
-                       CmmLit (CmmLabel lbl)   -> Left lbl
-                        _                      -> Right mopExpr
-
-       return mopLabelOrExpr
-
-
--- | Decide what C function to use to implement a CallishMachOp
---
-outOfLineFloatOp_table 
-       :: CallishMachOp
-       -> FastString
-       
-outOfLineFloatOp_table mop
- = case mop of
-       MO_F32_Exp    -> fsLit "expf"
-       MO_F32_Log    -> fsLit "logf"
-       MO_F32_Sqrt   -> fsLit "sqrtf"
-       MO_F32_Pwr    -> fsLit "powf"
-
-       MO_F32_Sin    -> fsLit "sinf"
-       MO_F32_Cos    -> fsLit "cosf"
-       MO_F32_Tan    -> fsLit "tanf"
-
-       MO_F32_Asin   -> fsLit "asinf"
-       MO_F32_Acos   -> fsLit "acosf"
-       MO_F32_Atan   -> fsLit "atanf"
-
-       MO_F32_Sinh   -> fsLit "sinhf"
-       MO_F32_Cosh   -> fsLit "coshf"
-       MO_F32_Tanh   -> fsLit "tanhf"
-
-       MO_F64_Exp    -> fsLit "exp"
-       MO_F64_Log    -> fsLit "log"
-       MO_F64_Sqrt   -> fsLit "sqrt"
-       MO_F64_Pwr    -> fsLit "pow"
-
-       MO_F64_Sin    -> fsLit "sin"
-       MO_F64_Cos    -> fsLit "cos"
-       MO_F64_Tan    -> fsLit "tan"
-
-       MO_F64_Asin   -> fsLit "asin"
-       MO_F64_Acos   -> fsLit "acos"
-       MO_F64_Atan   -> fsLit "atan"
-
-       MO_F64_Sinh   -> fsLit "sinh"
-       MO_F64_Cosh   -> fsLit "cosh"
-       MO_F64_Tanh   -> fsLit "tanh"
-
-       other -> pprPanic "outOfLineFloatOp(sparc): Unknown callish mach op "
-                       (pprCallishMachOp mop)
-
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-
-#if darwin_TARGET_OS || linux_TARGET_OS
-{-
-    The PowerPC calling convention for Darwin/Mac OS X
-    is described in Apple's document
-    "Inside Mac OS X - Mach-O Runtime Architecture".
-    
-    PowerPC Linux uses the System V Release 4 Calling Convention
-    for PowerPC. It is described in the
-    "System V Application Binary Interface PowerPC Processor Supplement".
-
-    Both conventions are similar:
-    Parameters may be passed in general-purpose registers starting at r3, in
-    floating point registers starting at f1, or on the stack. 
-    
-    But there are substantial differences:
-    * The number of registers used for parameter passing and the exact set of
-      nonvolatile registers differs (see MachRegs.lhs).
-    * On Darwin, stack space is always reserved for parameters, even if they are
-      passed in registers. The called routine may choose to save parameters from
-      registers to the corresponding space on the stack.
-    * On Darwin, a corresponding amount of GPRs is skipped when a floating point
-      parameter is passed in an FPR.
-    * SysV insists on either passing I64 arguments on the stack, or in two GPRs,
-      starting with an odd-numbered GPR. It may skip a GPR to achieve this.
-      Darwin just treats an I64 like two separate II32s (high word first).
-    * I64 and FF64 arguments are 8-byte aligned on the stack for SysV, but only
-      4-byte aligned like everything else on Darwin.
-    * The SysV spec claims that FF32 is represented as FF64 on the stack. GCC on
-      PowerPC Linux does not agree, so neither do we.
-      
-    According to both conventions, The parameter area should be part of the
-    caller's stack frame, allocated in the caller's prologue code (large enough
-    to hold the parameter lists for all called routines). The NCG already
-    uses the stack for register spilling, leaving 64 bytes free at the top.
-    If we need a larger parameter area than that, we just allocate a new stack
-    frame just before ccalling.
--}
-
-
-genCCall (CmmPrim MO_WriteBarrier) _ _ 
- = return $ unitOL LWSYNC
-
-genCCall target dest_regs argsAndHints
-  = ASSERT (not $ any (`elem` [II8,II16]) $ map cmmTypeSize argReps)
-        -- we rely on argument promotion in the codeGen
-    do
-        (finalStack,passArgumentsCode,usedRegs) <- passArguments
-                                                        (zip args argReps)
-                                                        allArgRegs allFPArgRegs
-                                                        initialStackOffset
-                                                        (toOL []) []
-                                                
-        (labelOrExpr, reduceToFF32) <- case target of
-            CmmCallee (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False)
-            CmmCallee expr conv -> return  (Right expr, False)
-            CmmPrim mop -> outOfLineFloatOp mop
-                                                        
-        let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode
-            codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32
-
-        case labelOrExpr of
-            Left lbl -> do
-               return (         codeBefore
-                        `snocOL` BL lbl usedRegs
-                        `appOL`         codeAfter)
-            Right dyn -> do
-               (dynReg, dynCode) <- getSomeReg dyn
-               return (         dynCode
-                       `snocOL` MTCTR dynReg
-                        `appOL`         codeBefore
-                        `snocOL` BCTRL usedRegs
-                        `appOL`         codeAfter)
-    where
-#if darwin_TARGET_OS
-        initialStackOffset = 24
-           -- size of linkage area + size of arguments, in bytes       
-       stackDelta _finalStack = roundTo 16 $ (24 +) $ max 32 $ sum $
-                                map (widthInBytes . typeWidth) argReps
-#elif linux_TARGET_OS
-        initialStackOffset = 8
-        stackDelta finalStack = roundTo 16 finalStack
-#endif
-       args = map hintlessCmm argsAndHints
-       argReps = map cmmExprType args
-
-       roundTo a x | x `mod` a == 0 = x
-                   | otherwise = x + a - (x `mod` a)
-
-        move_sp_down finalStack
-               | delta > 64 =
-                        toOL [STU II32 sp (AddrRegImm sp (ImmInt (-delta))),
-                             DELTA (-delta)]
-              | otherwise = nilOL
-              where delta = stackDelta finalStack
-       move_sp_up finalStack
-              | delta > 64 =
-                        toOL [ADD sp sp (RIImm (ImmInt delta)),
-                              DELTA 0]
-              | otherwise = nilOL
-              where delta = stackDelta finalStack
-              
-
-        passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed)
-        passArguments ((arg,arg_ty):args) gprs fprs stackOffset
-               accumCode accumUsed | isWord64 arg_ty =
-            do
-                ChildCode64 code vr_lo <- iselExpr64 arg
-                let vr_hi = getHiVRegFromLo vr_lo
-
-#if darwin_TARGET_OS                
-                passArguments args
-                              (drop 2 gprs)
-                              fprs
-                              (stackOffset+8)
-                              (accumCode `appOL` code
-                                    `snocOL` storeWord vr_hi gprs stackOffset
-                                    `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
-                              ((take 2 gprs) ++ accumUsed)
-            where
-                storeWord vr (gpr:_) offset = MR gpr vr
-                storeWord vr [] offset = ST II32 vr (AddrRegImm sp (ImmInt offset))
-                
-#elif linux_TARGET_OS
-                let stackOffset' = roundTo 8 stackOffset
-                    stackCode = accumCode `appOL` code
-                        `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset'))
-                        `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4)))
-                    regCode hireg loreg =
-                        accumCode `appOL` code
-                            `snocOL` MR hireg vr_hi
-                            `snocOL` MR loreg vr_lo
-                                        
-                case gprs of
-                    hireg : loreg : regs | even (length gprs) ->
-                        passArguments args regs fprs stackOffset
-                                      (regCode hireg loreg) (hireg : loreg : accumUsed)
-                    _skipped : hireg : loreg : regs ->
-                        passArguments args regs fprs stackOffset
-                                      (regCode hireg loreg) (hireg : loreg : accumUsed)
-                    _ -> -- only one or no regs left
-                        passArguments args [] fprs (stackOffset'+8)
-                                      stackCode accumUsed
-#endif
-        
-        passArguments ((arg,rep):args) gprs fprs stackOffset accumCode accumUsed
-            | reg : _ <- regs = do
-                register <- getRegister arg
-                let code = case register of
-                            Fixed _ freg fcode -> fcode `snocOL` MR reg freg
-                            Any _ acode -> acode reg
-                passArguments args
-                              (drop nGprs gprs)
-                              (drop nFprs fprs)
-#if darwin_TARGET_OS
-        -- The Darwin ABI requires that we reserve stack slots for register parameters
-                              (stackOffset + stackBytes)
-#elif linux_TARGET_OS
-        -- ... the SysV ABI doesn't.
-                              stackOffset
-#endif
-                              (accumCode `appOL` code)
-                              (reg : accumUsed)
-            | otherwise = do
-                (vr, code) <- getSomeReg arg
-                passArguments args
-                              (drop nGprs gprs)
-                              (drop nFprs fprs)
-                              (stackOffset' + stackBytes)
-                              (accumCode `appOL` code `snocOL` ST (cmmTypeSize rep) vr stackSlot)
-                              accumUsed
-            where
-#if darwin_TARGET_OS
-        -- stackOffset is at least 4-byte aligned
-        -- The Darwin ABI is happy with that.
-                stackOffset' = stackOffset
-#else
-        -- ... the SysV ABI requires 8-byte alignment for doubles.
-                stackOffset' | isFloatType rep && typeWidth rep == W64 =
-                                roundTo 8 stackOffset
-                             | otherwise  =           stackOffset
-#endif
-                stackSlot = AddrRegImm sp (ImmInt stackOffset')
-                (nGprs, nFprs, stackBytes, regs) = case cmmTypeSize rep of
-                    II32 -> (1, 0, 4, gprs)
-#if darwin_TARGET_OS
-        -- The Darwin ABI requires that we skip a corresponding number of GPRs when
-        -- we use the FPRs.
-                    FF32 -> (1, 1, 4, fprs)
-                    FF64 -> (2, 1, 8, fprs)
-#elif linux_TARGET_OS
-        -- ... the SysV ABI doesn't.
-                    FF32 -> (0, 1, 4, fprs)
-                    FF64 -> (0, 1, 8, fprs)
-#endif
-        
-        moveResult reduceToFF32 =
-            case dest_regs of
-                [] -> nilOL
-                [CmmHinted dest _hint]
-                    | reduceToFF32 && isFloat32 rep   -> unitOL (FRSP r_dest f1)
-                    | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1)
-                    | isWord64 rep -> toOL [MR (getHiVRegFromLo r_dest) r3,
-                                          MR r_dest r4]
-                    | otherwise -> unitOL (MR r_dest r3)
-                    where rep = cmmRegType (CmmLocal dest)
-                          r_dest = getRegisterReg (CmmLocal dest)
-                          
-        outOfLineFloatOp mop =
-            do
-                dflags <- getDynFlagsNat
-                mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $
-                              mkForeignLabel functionName Nothing True IsFunction
-                let mopLabelOrExpr = case mopExpr of
-                        CmmLit (CmmLabel lbl) -> Left lbl
-                        _ -> Right mopExpr
-                return (mopLabelOrExpr, reduce)
-            where
-                (functionName, reduce) = case mop of
-                    MO_F32_Exp   -> (fsLit "exp", True)
-                    MO_F32_Log   -> (fsLit "log", True)
-                    MO_F32_Sqrt  -> (fsLit "sqrt", True)
-                        
-                    MO_F32_Sin   -> (fsLit "sin", True)
-                    MO_F32_Cos   -> (fsLit "cos", True)
-                    MO_F32_Tan   -> (fsLit "tan", True)
-                    
-                    MO_F32_Asin  -> (fsLit "asin", True)
-                    MO_F32_Acos  -> (fsLit "acos", True)
-                    MO_F32_Atan  -> (fsLit "atan", True)
-                    
-                    MO_F32_Sinh  -> (fsLit "sinh", True)
-                    MO_F32_Cosh  -> (fsLit "cosh", True)
-                    MO_F32_Tanh  -> (fsLit "tanh", True)
-                    MO_F32_Pwr   -> (fsLit "pow", True)
-                        
-                    MO_F64_Exp   -> (fsLit "exp", False)
-                    MO_F64_Log   -> (fsLit "log", False)
-                    MO_F64_Sqrt  -> (fsLit "sqrt", False)
-                        
-                    MO_F64_Sin   -> (fsLit "sin", False)
-                    MO_F64_Cos   -> (fsLit "cos", False)
-                    MO_F64_Tan   -> (fsLit "tan", False)
-                     
-                    MO_F64_Asin  -> (fsLit "asin", False)
-                    MO_F64_Acos  -> (fsLit "acos", False)
-                    MO_F64_Atan  -> (fsLit "atan", False)
-                    
-                    MO_F64_Sinh  -> (fsLit "sinh", False)
-                    MO_F64_Cosh  -> (fsLit "cosh", False)
-                    MO_F64_Tanh  -> (fsLit "tanh", False)
-                    MO_F64_Pwr   -> (fsLit "pow", False)
-                    other -> pprPanic "genCCall(ppc): unknown callish op"
-                                    (pprCallishMachOp other)
-
-#endif /* darwin_TARGET_OS || linux_TARGET_OS */
-                
-#endif /* powerpc_TARGET_ARCH */
-
-
--- -----------------------------------------------------------------------------
--- Generating a table-branch
-
-genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-genSwitch expr ids
-  | opt_PIC
-  = do
-        (reg,e_code) <- getSomeReg expr
-        lbl <- getNewLabelNat
-        dflags <- getDynFlagsNat
-        dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
-        (tableReg,t_code) <- getSomeReg $ dynRef
-        let
-            jumpTable = map jumpTableEntryRel ids
-            
-            jumpTableEntryRel Nothing
-                = CmmStaticLit (CmmInt 0 wordWidth)
-            jumpTableEntryRel (Just (BlockId id))
-                = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
-                where blockLabel = mkAsmTempLabel id
-
-            op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
-                                       (EAIndex reg wORD_SIZE) (ImmInt 0))
-
-#if x86_64_TARGET_ARCH
-#if darwin_TARGET_OS
-    -- on Mac OS X/x86_64, put the jump table in the text section
-    -- to work around a limitation of the linker.
-    -- ld64 is unable to handle the relocations for
-    --     .quad L1 - L0
-    -- if L0 is not preceded by a non-anonymous label in its section.
-    
-            code = e_code `appOL` t_code `appOL` toOL [
-                            ADD (intSize wordWidth) op (OpReg tableReg),
-                            JMP_TBL (OpReg tableReg) [ id | Just id <- ids ],
-                            LDATA Text (CmmDataLabel lbl : jumpTable)
-                    ]
-#else
-    -- HACK: On x86_64 binutils<2.17 is only able to generate PC32
-    -- relocations, hence we only get 32-bit offsets in the jump
-    -- table. As these offsets are always negative we need to properly
-    -- sign extend them to 64-bit. This hack should be removed in
-    -- conjunction with the hack in PprMach.hs/pprDataItem once
-    -- binutils 2.17 is standard.
-            code = e_code `appOL` t_code `appOL` toOL [
-                           LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
-                           MOVSxL II32
-                                  (OpAddr (AddrBaseIndex (EABaseReg tableReg)
-                                                         (EAIndex reg wORD_SIZE) (ImmInt 0)))
-                                  (OpReg reg),
-                           ADD (intSize wordWidth) (OpReg reg) (OpReg tableReg),
-                           JMP_TBL (OpReg tableReg) [ id | Just id <- ids ]
-                  ]
-#endif
-#else
-            code = e_code `appOL` t_code `appOL` toOL [
-                            LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
-                            ADD (intSize wordWidth) op (OpReg tableReg),
-                            JMP_TBL (OpReg tableReg) [ id | Just id <- ids ]
-                    ]
-#endif
-        return code
-  | otherwise
-  = do
-        (reg,e_code) <- getSomeReg expr
-        lbl <- getNewLabelNat
-        let
-            jumpTable = map jumpTableEntry ids
-            op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl))
-            code = e_code `appOL` toOL [
-                    LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
-                    JMP_TBL op [ id | Just id <- ids ]
-                 ]
-        -- in
-        return code
-#elif powerpc_TARGET_ARCH
-genSwitch expr ids 
-  | opt_PIC
-  = do
-        (reg,e_code) <- getSomeReg expr
-        tmp <- getNewRegNat II32
-        lbl <- getNewLabelNat
-        dflags <- getDynFlagsNat
-        dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
-        (tableReg,t_code) <- getSomeReg $ dynRef
-        let
-            jumpTable = map jumpTableEntryRel ids
-            
-            jumpTableEntryRel Nothing
-                = CmmStaticLit (CmmInt 0 wordWidth)
-            jumpTableEntryRel (Just (BlockId id))
-                = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
-                where blockLabel = mkAsmTempLabel id
-
-            code = e_code `appOL` t_code `appOL` toOL [
-                            LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
-                            SLW tmp reg (RIImm (ImmInt 2)),
-                            LD II32 tmp (AddrRegReg tableReg tmp),
-                            ADD tmp tmp (RIReg tableReg),
-                            MTCTR tmp,
-                            BCTR [ id | Just id <- ids ]
-                    ]
-        return code
-  | otherwise
-  = do
-        (reg,e_code) <- getSomeReg expr
-        tmp <- getNewRegNat II32
-        lbl <- getNewLabelNat
-        let
-            jumpTable = map jumpTableEntry ids
-        
-            code = e_code `appOL` toOL [
-                            LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
-                            SLW tmp reg (RIImm (ImmInt 2)),
-                            ADDIS tmp tmp (HA (ImmCLbl lbl)),
-                            LD II32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
-                            MTCTR tmp,
-                            BCTR [ id | Just id <- ids ]
-                    ]
-        return code
-#elif sparc_TARGET_ARCH
-genSwitch expr ids
-       | opt_PIC
-       = error "MachCodeGen: sparc genSwitch PIC not finished\n"
-  
-       | otherwise
-       = do    (e_reg, e_code) <- getSomeReg expr
-
-               base_reg        <- getNewRegNat II32
-               offset_reg      <- getNewRegNat II32
-               dst             <- getNewRegNat II32
-
-               label           <- getNewLabelNat
-               let jumpTable   = map jumpTableEntry ids
-
-               return $ e_code `appOL`
-                toOL   
-                       -- the jump table
-                       [ LDATA ReadOnlyData (CmmDataLabel label : jumpTable)
-
-                       -- load base of jump table
-                       , SETHI (HI (ImmCLbl label)) base_reg
-                       , OR    False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
-                       
-                       -- the addrs in the table are 32 bits wide..
-                       , SLL   e_reg (RIImm $ ImmInt 2) offset_reg
-
-                       -- load and jump to the destination
-                       , LD      II32 (AddrRegReg base_reg offset_reg) dst
-                       , JMP_TBL (AddrRegImm dst (ImmInt 0)) [i | Just i <- ids]
-                       , NOP ]
-
-#else
-#error "ToDo: genSwitch"
-#endif
-
-
--- | Convert a BlockId to some CmmStatic data
-jumpTableEntry :: Maybe BlockId -> CmmStatic
-jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth)
-jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel)
-    where blockLabel = mkAsmTempLabel id
-
--- -----------------------------------------------------------------------------
--- Support bits
--- -----------------------------------------------------------------------------
-
-
--- -----------------------------------------------------------------------------
--- 'condIntReg' and 'condFltReg': condition codes into registers
-
--- Turn those condition codes into integers now (when they appear on
--- the right hand side of an assignment).
--- 
--- (If applicable) Do not fill the delay slots here; you will confuse the
--- register allocator.
-
-condIntReg, condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-condIntReg = panic "MachCode.condIntReg (not on Alpha)"
-condFltReg = panic "MachCode.condFltReg (not on Alpha)"
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-
-condIntReg cond x y = do
-  CondCode _ cond cond_code <- condIntCode cond x y
-  tmp <- getNewRegNat II8
-  let 
-       code dst = cond_code `appOL` toOL [
-                   SETCC cond (OpReg tmp),
-                   MOVZxL II8 (OpReg tmp) (OpReg dst)
-                 ]
-  -- in
-  return (Any II32 code)
-
-#endif
-
-#if i386_TARGET_ARCH
-
-condFltReg cond x y = do
-  CondCode _ cond cond_code <- condFltCode cond x y
-  tmp <- getNewRegNat II8
-  let 
-       code dst = cond_code `appOL` toOL [
-                   SETCC cond (OpReg tmp),
-                   MOVZxL II8 (OpReg tmp) (OpReg dst)
-                 ]
-  -- in
-  return (Any II32 code)
-
-#endif
-
-#if x86_64_TARGET_ARCH
-
-condFltReg cond x y = do
-  CondCode _ cond cond_code <- condFltCode cond x y
-  tmp1 <- getNewRegNat wordSize
-  tmp2 <- getNewRegNat wordSize
-  let 
-       -- We have to worry about unordered operands (eg. comparisons
-       -- against NaN).  If the operands are unordered, the comparison
-       -- sets the parity flag, carry flag and zero flag.
-       -- All comparisons are supposed to return false for unordered
-       -- operands except for !=, which returns true.
-       --
-       -- Optimisation: we don't have to test the parity flag if we
-       -- know the test has already excluded the unordered case: eg >
-       -- and >= test for a zero carry flag, which can only occur for
-       -- ordered operands.
-       --
-       -- ToDo: by reversing comparisons we could avoid testing the
-       -- parity flag in more cases.
-
-       code dst = 
-          cond_code `appOL` 
-            (case cond of
-               NE  -> or_unordered dst
-               GU  -> plain_test   dst
-               GEU -> plain_test   dst
-               _   -> and_ordered  dst)
-
-       plain_test dst = toOL [
-                   SETCC cond (OpReg tmp1),
-                   MOVZxL II8 (OpReg tmp1) (OpReg dst)
-                ]
-       or_unordered dst = toOL [
-                   SETCC cond (OpReg tmp1),
-                   SETCC PARITY (OpReg tmp2),
-                   OR II8 (OpReg tmp1) (OpReg tmp2),
-                   MOVZxL II8 (OpReg tmp2) (OpReg dst)
-                 ]
-       and_ordered dst = toOL [
-                   SETCC cond (OpReg tmp1),
-                   SETCC NOTPARITY (OpReg tmp2),
-                   AND II8 (OpReg tmp1) (OpReg tmp2),
-                   MOVZxL II8 (OpReg tmp2) (OpReg dst)
-                 ]
-  -- in
-  return (Any II32 code)
-
-#endif
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-condIntReg EQQ x (CmmLit (CmmInt 0 d)) = do
-    (src, code) <- getSomeReg x
-    tmp <- getNewRegNat II32
-    let
-       code__2 dst = code `appOL` toOL [
-           SUB False True g0 (RIReg src) g0,
-           SUB True False g0 (RIImm (ImmInt (-1))) dst]
-    return (Any II32 code__2)
-
-condIntReg EQQ x y = do
-    (src1, code1) <- getSomeReg x
-    (src2, code2) <- getSomeReg y
-    tmp1 <- getNewRegNat II32
-    tmp2 <- getNewRegNat II32
-    let
-       code__2 dst = code1 `appOL` code2 `appOL` toOL [
-           XOR False src1 (RIReg src2) dst,
-           SUB False True g0 (RIReg dst) g0,
-           SUB True False g0 (RIImm (ImmInt (-1))) dst]
-    return (Any II32 code__2)
-
-condIntReg NE x (CmmLit (CmmInt 0 d)) = do
-    (src, code) <- getSomeReg x
-    tmp <- getNewRegNat II32
-    let
-       code__2 dst = code `appOL` toOL [
-           SUB False True g0 (RIReg src) g0,
-           ADD True False g0 (RIImm (ImmInt 0)) dst]
-    return (Any II32 code__2)
-
-condIntReg NE x y = do
-    (src1, code1) <- getSomeReg x
-    (src2, code2) <- getSomeReg y
-    tmp1 <- getNewRegNat II32
-    tmp2 <- getNewRegNat II32
-    let
-       code__2 dst = code1 `appOL` code2 `appOL` toOL [
-           XOR False src1 (RIReg src2) dst,
-           SUB False True g0 (RIReg dst) g0,
-           ADD True False g0 (RIImm (ImmInt 0)) dst]
-    return (Any II32 code__2)
-
-condIntReg cond x y = do
-    bid1@(BlockId lbl1) <- getBlockIdNat
-    bid2@(BlockId lbl2) <- getBlockIdNat
-    CondCode _ cond cond_code <- condIntCode cond x y
-    let
-       code__2 dst = cond_code `appOL` toOL [
-           BI cond False bid1, NOP,
-           OR False g0 (RIImm (ImmInt 0)) dst,
-           BI ALWAYS False bid2, NOP,
-           NEWBLOCK bid1,
-           OR False g0 (RIImm (ImmInt 1)) dst,
-           NEWBLOCK bid2]
-    return (Any II32 code__2)
-
-condFltReg cond x y = do
-    bid1@(BlockId lbl1) <- getBlockIdNat
-    bid2@(BlockId lbl2) <- getBlockIdNat
-    CondCode _ cond cond_code <- condFltCode cond x y
-    let
-       code__2 dst = cond_code `appOL` toOL [ 
-           NOP,
-           BF cond False bid1, NOP,
-           OR False g0 (RIImm (ImmInt 0)) dst,
-           BI ALWAYS False bid2, NOP,
-           NEWBLOCK bid1,
-           OR False g0 (RIImm (ImmInt 1)) dst,
-           NEWBLOCK bid2]
-    return (Any II32 code__2)
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-condReg getCond = do
-    lbl1 <- getBlockIdNat
-    lbl2 <- getBlockIdNat
-    CondCode _ cond cond_code <- getCond
-    let
-{-        code dst = cond_code `appOL` toOL [
-                BCC cond lbl1,
-                LI dst (ImmInt 0),
-                BCC ALWAYS lbl2,
-                NEWBLOCK lbl1,
-                LI dst (ImmInt 1),
-                BCC ALWAYS lbl2,
-                NEWBLOCK lbl2
-            ]-}
-        code dst = cond_code
-            `appOL` negate_code
-            `appOL` toOL [
-                MFCR dst,
-                RLWINM dst dst (bit + 1) 31 31
-            ]
-        
-        negate_code | do_negate = unitOL (CRNOR bit bit bit)
-                    | otherwise = nilOL
-                    
-        (bit, do_negate) = case cond of
-            LTT -> (0, False)
-            LE  -> (1, True)
-            EQQ -> (2, False)
-            GE  -> (0, True)
-            GTT -> (1, False)
-            
-            NE  -> (2, True)
-            
-            LU  -> (0, False)
-            LEU -> (1, True)
-            GEU -> (0, True)
-            GU  -> (1, False)
-                
-    return (Any II32 code)
-    
-condIntReg cond x y = condReg (condIntCode cond x y)
-condFltReg cond x y = condReg (condFltCode cond x y)
-#endif /* powerpc_TARGET_ARCH */
-
-
--- -----------------------------------------------------------------------------
--- 'trivial*Code': deal with trivial instructions
-
--- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
--- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
--- Only look for constants on the right hand side, because that's
--- where the generic optimizer will have put them.
-
--- Similarly, for unary instructions, we don't have to worry about
--- matching an StInt as the argument, because genericOpt will already
--- have handled the constant-folding.
-
-trivialCode
-    :: Width   -- Int only 
-    -> IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
-      ,IF_ARCH_i386 ((Operand -> Operand -> Instr) 
-                     -> Maybe (Operand -> Operand -> Instr)
-      ,IF_ARCH_x86_64 ((Operand -> Operand -> Instr) 
-                     -> Maybe (Operand -> Operand -> Instr)
-      ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
-      ,IF_ARCH_powerpc(Bool -> (Reg -> Reg -> RI -> Instr)
-      ,)))))
-    -> CmmExpr -> CmmExpr -- the two arguments
-    -> NatM Register
-
-#ifndef powerpc_TARGET_ARCH
-trivialFCode
-    :: Width   -- Floating point only
-    -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
-      ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
-      ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
-      ,IF_ARCH_x86_64 ((Size -> Operand -> Operand -> Instr)
-      ,))))
-    -> CmmExpr -> CmmExpr -- the two arguments
-    -> NatM Register
-#endif
-
-trivialUCode
-    :: Size
-    -> IF_ARCH_alpha((RI -> Reg -> Instr)
-      ,IF_ARCH_i386 ((Operand -> Instr)
-      ,IF_ARCH_x86_64 ((Operand -> Instr)
-      ,IF_ARCH_sparc((RI -> Reg -> Instr)
-      ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
-      ,)))))
-    -> CmmExpr -- the one argument
-    -> NatM Register
-
-#ifndef powerpc_TARGET_ARCH
-trivialUFCode
-    :: Size
-    -> IF_ARCH_alpha((Reg -> Reg -> Instr)
-      ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
-      ,IF_ARCH_x86_64 ((Reg -> Reg -> Instr)
-      ,IF_ARCH_sparc((Reg -> Reg -> Instr)
-      ,))))
-    -> CmmExpr -- the one argument
-    -> NatM Register
-#endif
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-trivialCode instr x (StInt y)
-  | fits8Bits y
-  = getRegister x              `thenNat` \ register ->
-    getNewRegNat IntRep                `thenNat` \ tmp ->
-    let
-       code = registerCode register tmp
-       src1 = registerName register tmp
-       src2 = ImmInt (fromInteger y)
-       code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
-    in
-    return (Any IntRep code__2)
-
-trivialCode instr x y
-  = getRegister x              `thenNat` \ register1 ->
-    getRegister y              `thenNat` \ register2 ->
-    getNewRegNat IntRep                `thenNat` \ tmp1 ->
-    getNewRegNat IntRep                `thenNat` \ tmp2 ->
-    let
-       code1 = registerCode register1 tmp1 []
-       src1  = registerName register1 tmp1
-       code2 = registerCode register2 tmp2 []
-       src2  = registerName register2 tmp2
-       code__2 dst = asmSeqThen [code1, code2] .
-                    mkSeqInstr (instr src1 (RIReg src2) dst)
-    in
-    return (Any IntRep code__2)
-
-------------
-trivialUCode instr x
-  = getRegister x              `thenNat` \ register ->
-    getNewRegNat IntRep                `thenNat` \ tmp ->
-    let
-       code = registerCode register tmp
-       src  = registerName register tmp
-       code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
-    in
-    return (Any IntRep code__2)
-
-------------
-trivialFCode _ instr x y
-  = getRegister x              `thenNat` \ register1 ->
-    getRegister y              `thenNat` \ register2 ->
-    getNewRegNat FF64  `thenNat` \ tmp1 ->
-    getNewRegNat FF64  `thenNat` \ tmp2 ->
-    let
-       code1 = registerCode register1 tmp1
-       src1  = registerName register1 tmp1
-
-       code2 = registerCode register2 tmp2
-       src2  = registerName register2 tmp2
-
-       code__2 dst = asmSeqThen [code1 [], code2 []] .
-                     mkSeqInstr (instr src1 src2 dst)
-    in
-    return (Any FF64 code__2)
-
-trivialUFCode _ instr x
-  = getRegister x              `thenNat` \ register ->
-    getNewRegNat FF64  `thenNat` \ tmp ->
-    let
-       code = registerCode register tmp
-       src  = registerName register tmp
-       code__2 dst = code . mkSeqInstr (instr src dst)
-    in
-    return (Any FF64 code__2)
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-
-{-
-The Rules of the Game are:
-
-* You cannot assume anything about the destination register dst;
-  it may be anything, including a fixed reg.
-
-* You may compute an operand into a fixed reg, but you may not 
-  subsequently change the contents of that fixed reg.  If you
-  want to do so, first copy the value either to a temporary
-  or into dst.  You are free to modify dst even if it happens
-  to be a fixed reg -- that's not your problem.
-
-* You cannot assume that a fixed reg will stay live over an
-  arbitrary computation.  The same applies to the dst reg.
-
-* Temporary regs obtained from getNewRegNat are distinct from 
-  each other and from all other regs, and stay live over 
-  arbitrary computations.
-
---------------------
-
-SDM's version of The Rules:
-
-* If getRegister returns Any, that means it can generate correct
-  code which places the result in any register, period.  Even if that
-  register happens to be read during the computation.
-
-  Corollary #1: this means that if you are generating code for an
-  operation with two arbitrary operands, you cannot assign the result
-  of the first operand into the destination register before computing
-  the second operand.  The second operand might require the old value
-  of the destination register.
-
-  Corollary #2: A function might be able to generate more efficient
-  code if it knows the destination register is a new temporary (and
-  therefore not read by any of the sub-computations).
-
-* If getRegister returns Any, then the code it generates may modify only:
-       (a) fresh temporaries
-       (b) the destination register
-       (c) known registers (eg. %ecx is used by shifts)
-  In particular, it may *not* modify global registers, unless the global
-  register happens to be the destination register.
--}
-
-trivialCode width instr (Just revinstr) (CmmLit lit_a) b
-  | is32BitLit lit_a = do
-  b_code <- getAnyReg b
-  let
-       code dst 
-        = b_code dst `snocOL`
-           revinstr (OpImm (litToImm lit_a)) (OpReg dst)
-  -- in
-  return (Any (intSize width) code)
-
-trivialCode width instr maybe_revinstr a b
-  = genTrivialCode (intSize width) instr a b
-
--- This is re-used for floating pt instructions too.
-genTrivialCode rep instr a b = do
-  (b_op, b_code) <- getNonClobberedOperand b
-  a_code <- getAnyReg a
-  tmp <- getNewRegNat rep
-  let
-     -- We want the value of b to stay alive across the computation of a.
-     -- But, we want to calculate a straight into the destination register,
-     -- because the instruction only has two operands (dst := dst `op` src).
-     -- The troublesome case is when the result of b is in the same register
-     -- as the destination reg.  In this case, we have to save b in a
-     -- new temporary across the computation of a.
-     code dst
-       | dst `regClashesWithOp` b_op =
-               b_code `appOL`
-               unitOL (MOV rep b_op (OpReg tmp)) `appOL`
-               a_code dst `snocOL`
-               instr (OpReg tmp) (OpReg dst)
-       | otherwise =
-               b_code `appOL`
-               a_code dst `snocOL`
-               instr b_op (OpReg dst)
-  -- in
-  return (Any rep code)
-
-reg `regClashesWithOp` OpReg reg2   = reg == reg2
-reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)
-reg `regClashesWithOp` _            = False
-
------------
-
-trivialUCode rep instr x = do
-  x_code <- getAnyReg x
-  let
-     code dst =
-       x_code dst `snocOL`
-       instr (OpReg dst)
-  return (Any rep code)
-
------------
-
-#if i386_TARGET_ARCH
-
-trivialFCode width instr x y = do
-  (x_reg, x_code) <- getNonClobberedReg x -- these work for float regs too
-  (y_reg, y_code) <- getSomeReg y
-  let
-     size = floatSize width
-     code dst =
-       x_code `appOL`
-       y_code `snocOL`
-       instr size x_reg y_reg dst
-  return (Any size code)
-
-#endif
-
-#if x86_64_TARGET_ARCH
-trivialFCode pk instr x y 
-  = genTrivialCode size (instr size) x y
-  where size = floatSize pk
-#endif
-
--------------
-
-trivialUFCode size instr x = do
-  (x_reg, x_code) <- getSomeReg x
-  let
-     code dst =
-       x_code `snocOL`
-       instr x_reg dst
-  -- in
-  return (Any size code)
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-trivialCode pk instr x (CmmLit (CmmInt y d))
-  | fits13Bits y
-  = do
-      (src1, code) <- getSomeReg x
-      tmp <- getNewRegNat II32
-      let
-       src2 = ImmInt (fromInteger y)
-       code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
-      return (Any II32 code__2)
-
-trivialCode pk instr x y = do
-    (src1, code1) <- getSomeReg x
-    (src2, code2) <- getSomeReg y
-    tmp1 <- getNewRegNat II32
-    tmp2 <- getNewRegNat II32
-    let
-       code__2 dst = code1 `appOL` code2 `snocOL`
-                     instr src1 (RIReg src2) dst
-    return (Any II32 code__2)
-
-------------
-trivialFCode pk instr x y = do
-    (src1, code1) <- getSomeReg x
-    (src2, code2) <- getSomeReg y
-    tmp1 <- getNewRegNat (cmmTypeSize $ cmmExprType x)
-    tmp2 <- getNewRegNat (cmmTypeSize $ cmmExprType y)
-    tmp <- getNewRegNat FF64
-    let
-       promote x = FxTOy FF32 FF64 x tmp
-
-       pk1   = cmmExprType x
-       pk2   = cmmExprType y
-
-       code__2 dst =
-               if pk1 `cmmEqType` pk2 then
-                   code1 `appOL` code2 `snocOL`
-                   instr (floatSize pk) src1 src2 dst
-               else if typeWidth pk1 == W32 then
-                   code1 `snocOL` promote src1 `appOL` code2 `snocOL`
-                   instr FF64 tmp src2 dst
-               else
-                   code1 `appOL` code2 `snocOL` promote src2 `snocOL`
-                   instr FF64 src1 tmp dst
-    return (Any (cmmTypeSize $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64) 
-               code__2)
-
-------------
-trivialUCode size instr x = do
-    (src, code) <- getSomeReg x
-    tmp <- getNewRegNat size
-    let
-       code__2 dst = code `snocOL` instr (RIReg src) dst
-    return (Any size code__2)
-
--------------
-trivialUFCode pk instr x = do
-    (src, code) <- getSomeReg x
-    tmp <- getNewRegNat pk
-    let
-       code__2 dst = code `snocOL` instr src dst
-    return (Any pk code__2)
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-
-{-
-Wolfgang's PowerPC version of The Rules:
-
-A slightly modified version of The Rules to take advantage of the fact
-that PowerPC instructions work on all registers and don't implicitly
-clobber any fixed registers.
-
-* The only expression for which getRegister returns Fixed is (CmmReg reg).
-
-* If getRegister returns Any, then the code it generates may modify only:
-       (a) fresh temporaries
-       (b) the destination register
-  It may *not* modify global registers, unless the global
-  register happens to be the destination register.
-  It may not clobber any other registers. In fact, only ccalls clobber any
-  fixed registers.
-  Also, it may not modify the counter register (used by genCCall).
-  
-  Corollary: If a getRegister for a subexpression returns Fixed, you need
-  not move it to a fresh temporary before evaluating the next subexpression.
-  The Fixed register won't be modified.
-  Therefore, we don't need a counterpart for the x86's getStableReg on PPC.
-  
-* SDM's First Rule is valid for PowerPC, too: subexpressions can depend on
-  the value of the destination register.
--}
-
-trivialCode rep signed instr x (CmmLit (CmmInt y _))
-    | Just imm <- makeImmediate rep signed y 
-    = do
-        (src1, code1) <- getSomeReg x
-        let code dst = code1 `snocOL` instr dst src1 (RIImm imm)
-        return (Any (intSize rep) code)
-  
-trivialCode rep signed instr x y = do
-    (src1, code1) <- getSomeReg x
-    (src2, code2) <- getSomeReg y
-    let code dst = code1 `appOL` code2 `snocOL` instr dst src1 (RIReg src2)
-    return (Any (intSize rep) code)
-
-trivialCodeNoImm' :: Size -> (Reg -> Reg -> Reg -> Instr)
-                -> CmmExpr -> CmmExpr -> NatM Register
-trivialCodeNoImm' size instr x y = do
-    (src1, code1) <- getSomeReg x
-    (src2, code2) <- getSomeReg y
-    let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2
-    return (Any size code)
-    
-trivialCodeNoImm :: Size -> (Size -> Reg -> Reg -> Reg -> Instr)
-                -> CmmExpr -> CmmExpr -> NatM Register
-trivialCodeNoImm size instr x y = trivialCodeNoImm' size (instr size) x y
-    
-trivialUCode rep instr x = do
-    (src, code) <- getSomeReg x
-    let code' dst = code `snocOL` instr dst src
-    return (Any rep code')
-    
--- There is no "remainder" instruction on the PPC, so we have to do
--- it the hard way.
--- The "div" parameter is the division instruction to use (DIVW or DIVWU)
-
-remainderCode :: Width -> (Reg -> Reg -> Reg -> Instr)
-    -> CmmExpr -> CmmExpr -> NatM Register
-remainderCode rep div x y = do
-    (src1, code1) <- getSomeReg x
-    (src2, code2) <- getSomeReg y
-    let code dst = code1 `appOL` code2 `appOL` toOL [
-                div dst src1 src2,
-                MULLW dst dst (RIReg src2),
-                SUBF dst dst src1
-            ]
-    return (Any (intSize rep) code)
-
-#endif /* powerpc_TARGET_ARCH */
-
-
--- -----------------------------------------------------------------------------
---  Coercing to/from integer/floating-point...
-
--- When going to integer, we truncate (round towards 0).
-
--- @coerce(Int2FP|FP2Int)@ are more complicated integer/float
--- conversions.  We have to store temporaries in memory to move
--- between the integer and the floating point register sets.
-
--- @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
--- pretend, on sparc at least, that double and float regs are seperate
--- kinds, so the value has to be computed into one kind before being
--- explicitly "converted" to live in the other kind.
-
-coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
-coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
-
-#if sparc_TARGET_ARCH
-coerceDbl2Flt :: CmmExpr -> NatM Register
-coerceFlt2Dbl :: CmmExpr -> NatM Register
-#endif
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-coerceInt2FP _ x
-  = getRegister x              `thenNat` \ register ->
-    getNewRegNat IntRep                `thenNat` \ reg ->
-    let
-       code = registerCode register reg
-       src  = registerName register reg
-
-       code__2 dst = code . mkSeqInstrs [
-           ST Q src (spRel 0),
-           LD TF dst (spRel 0),
-           CVTxy Q TF dst dst]
-    in
-    return (Any FF64 code__2)
-
--------------
-coerceFP2Int x
-  = getRegister x              `thenNat` \ register ->
-    getNewRegNat FF64  `thenNat` \ tmp ->
-    let
-       code = registerCode register tmp
-       src  = registerName register tmp
-
-       code__2 dst = code . mkSeqInstrs [
-           CVTxy TF Q src tmp,
-           ST TF tmp (spRel 0),
-           LD Q dst (spRel 0)]
-    in
-    return (Any IntRep code__2)
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
-coerceInt2FP from to x = do
-  (x_reg, x_code) <- getSomeReg x
-  let
-        opc  = case to of W32 -> GITOF; W64 -> GITOD
-        code dst = x_code `snocOL` opc x_reg dst
-       -- ToDo: works for non-II32 reps?
-  return (Any (floatSize to) code)
-
-------------
-
-coerceFP2Int from to x = do
-  (x_reg, x_code) <- getSomeReg x
-  let
-        opc  = case from of W32 -> GFTOI; W64 -> GDTOI
-        code dst = x_code `snocOL` opc x_reg dst
-       -- ToDo: works for non-II32 reps?
-  -- in
-  return (Any (intSize to) code)
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if x86_64_TARGET_ARCH
-
-coerceFP2Int from to x = do
-  (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand
-  let
-        opc  = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ
-        code dst = x_code `snocOL` opc x_op dst
-  -- in
-  return (Any (intSize to) code) -- works even if the destination rep is <II32
-
-coerceInt2FP from to x = do
-  (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand
-  let
-        opc  = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD
-        code dst = x_code `snocOL` opc x_op dst
-  -- in
-  return (Any (floatSize to) code) -- works even if the destination rep is <II32
-
-coerceFP2FP :: Width -> CmmExpr -> NatM Register
-coerceFP2FP to x = do
-  (x_reg, x_code) <- getSomeReg x
-  let
-        opc  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD
-        code dst = x_code `snocOL` opc x_reg dst
-  -- in
-  return (Any (floatSize to) code)
-#endif
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-coerceInt2FP width1 width2 x = do
-    (src, code) <- getSomeReg x
-    let
-       code__2 dst = code `appOL` toOL [
-           ST (intSize width1) src (spRel (-2)),
-           LD (intSize width1) (spRel (-2)) dst,
-           FxTOy (intSize width1) (floatSize width2) dst dst]
-    return (Any (floatSize $ width2) code__2)
-
-
--- | Coerce a floating point value to integer
---
---   NOTE: On sparc v9 there are no instructions to move a value from an
---        FP register directly to an int register, so we have to use a load/store.
---
-coerceFP2Int width1 width2 x 
- = do  let fsize1      = floatSize width1
-           fsize2      = floatSize width2
-       
-            isize2     = intSize   width2
-
-       (fsrc, code)    <- getSomeReg x
-       fdst            <- getNewRegNat fsize2
-    
-       let code2 dst   
-               =       code
-               `appOL` toOL
-                       -- convert float to int format, leaving it in a float reg.
-                       [ FxTOy fsize1 isize2 fsrc fdst
-
-                       -- store the int into mem, then load it back to move
-                       --      it into an actual int reg.
-                       , ST    fsize2 fdst (spRel (-2))
-                       , LD    isize2 (spRel (-2)) dst]
-
-       return (Any isize2 code2)
-
-------------
-coerceDbl2Flt x = do
-    (src, code) <- getSomeReg x
-    return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst)) 
-
-------------
-coerceFlt2Dbl x = do
-    (src, code) <- getSomeReg x
-    return (Any FF64 (\dst -> code `snocOL` FxTOy FF32 FF64 src dst))
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-coerceInt2FP fromRep toRep x = do
-    (src, code) <- getSomeReg x
-    lbl <- getNewLabelNat
-    itmp <- getNewRegNat II32
-    ftmp <- getNewRegNat FF64
-    dflags <- getDynFlagsNat
-    dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
-    Amode addr addr_code <- getAmode dynRef
-    let
-       code' dst = code `appOL` maybe_exts `appOL` toOL [
-               LDATA ReadOnlyData
-                               [CmmDataLabel lbl,
-                                CmmStaticLit (CmmInt 0x43300000 W32),
-                                CmmStaticLit (CmmInt 0x80000000 W32)],
-               XORIS itmp src (ImmInt 0x8000),
-               ST II32 itmp (spRel 3),
-               LIS itmp (ImmInt 0x4330),
-               ST II32 itmp (spRel 2),
-               LD FF64 ftmp (spRel 2)
-            ] `appOL` addr_code `appOL` toOL [
-               LD FF64 dst addr,
-               FSUB FF64 dst ftmp dst
-           ] `appOL` maybe_frsp dst
-            
-        maybe_exts = case fromRep of
-                        W8 ->  unitOL $ EXTS II8 src src
-                        W16 -> unitOL $ EXTS II16 src src
-                        W32 -> nilOL
-        maybe_frsp dst = case toRep of
-                        W32 -> unitOL $ FRSP dst dst
-                        W64 -> nilOL
-    return (Any (floatSize toRep) code')
-
-coerceFP2Int fromRep toRep x = do
-    -- the reps don't really matter: F*->FF64 and II32->I* are no-ops
-    (src, code) <- getSomeReg x
-    tmp <- getNewRegNat FF64
-    let
-       code' dst = code `appOL` toOL [
-               -- convert to int in FP reg
-           FCTIWZ tmp src,
-               -- store value (64bit) from FP to stack
-           ST FF64 tmp (spRel 2),
-               -- read low word of value (high word is undefined)
-           LD II32 dst (spRel 3)]      
-    return (Any (intSize toRep) code')
-#endif /* powerpc_TARGET_ARCH */
-
-
--- -----------------------------------------------------------------------------
--- eXTRA_STK_ARGS_HERE
-
--- We (allegedly) put the first six C-call arguments in registers;
--- where do we start putting the rest of them?
-
--- Moved from Instrs (SDM):
-
-#if alpha_TARGET_ARCH || sparc_TARGET_ARCH
-eXTRA_STK_ARGS_HERE :: Int
-eXTRA_STK_ARGS_HERE
-  = IF_ARCH_alpha(0, IF_ARCH_sparc(23, ???))
-#endif
index d19cda4..ed59d2b 100644 (file)
@@ -10,28 +10,43 @@ module NCGMonad (
        NatM_State(..), mkNatM_State,
 
        NatM, -- instance Monad
-       initNat, addImportNat, getUniqueNat,
-       mapAccumLNat, setDeltaNat, getDeltaNat,
-       getBlockIdNat, getNewLabelNat, getNewRegNat, getNewRegPairNat,
-       getPicBaseMaybeNat, getPicBaseNat, getDynFlagsNat
- ) where
+       initNat, 
+       addImportNat, 
+       getUniqueNat,
+       mapAccumLNat, 
+       setDeltaNat, 
+       getDeltaNat,
+       getBlockIdNat, 
+       getNewLabelNat, 
+       getNewRegNat, 
+       getNewRegPairNat,
+       getPicBaseMaybeNat, 
+       getPicBaseNat, 
+       getDynFlagsNat
+) 
+where
   
 #include "HsVersions.h"
 
+import Reg
+import Size
+import TargetReg
+
 import BlockId
 import CLabel          ( CLabel, mkAsmTempLabel )
-import Regs
 import UniqSupply
 import Unique          ( Unique )
 import DynFlags
 
-data NatM_State = NatM_State {
-                       natm_us      :: UniqSupply,
-                       natm_delta   :: Int,
-                       natm_imports :: [(CLabel)],
-                       natm_pic     :: Maybe Reg,
-                       natm_dflags  :: DynFlags
-               }
+data NatM_State 
+       = NatM_State {
+               natm_us      :: UniqSupply,
+               natm_delta   :: Int,
+               natm_imports :: [(CLabel)],
+               natm_pic     :: Maybe Reg,
+               natm_dflags  :: DynFlags
+       }
 
 newtype NatM result = NatM (NatM_State -> (result, NatM_State))
 
@@ -39,22 +54,27 @@ unNat :: NatM a -> NatM_State -> (a, NatM_State)
 unNat (NatM a) = a
 
 mkNatM_State :: UniqSupply -> Int -> DynFlags -> NatM_State
-mkNatM_State us delta dflags = NatM_State us delta [] Nothing dflags
+mkNatM_State us delta dflags 
+       = NatM_State us delta [] Nothing dflags
 
 initNat :: NatM_State -> NatM a -> (a, NatM_State)
-initNat init_st m = case unNat m init_st of { (r,st) -> (r,st) }
+initNat init_st m 
+       = case unNat m init_st of { (r,st) -> (r,st) }
+
 
 instance Monad NatM where
   (>>=) = thenNat
   return = returnNat
 
+
 thenNat :: NatM a -> (a -> NatM b) -> NatM b
 thenNat expr cont
-  = NatM $ \st -> case unNat expr st of
+       = NatM $ \st -> case unNat expr st of
                        (result, st') -> unNat (cont result) st'
 
 returnNat :: a -> NatM a
-returnNat result = NatM $ \st ->  (result, st)
+returnNat result 
+       = NatM $ \st ->  (result, st)
 
 mapAccumLNat :: (acc -> x -> NatM (acc, y))
                 -> acc
@@ -75,43 +95,64 @@ getUniqueNat = NatM $ \ (NatM_State us delta imports pic dflags) ->
 
 
 getDynFlagsNat :: NatM DynFlags
-getDynFlagsNat = NatM $ \ (NatM_State us delta imports pic dflags) ->
-                         (dflags, (NatM_State us delta imports pic dflags))
+getDynFlagsNat 
+       = NatM $ \ (NatM_State us delta imports pic dflags) ->
+                 (dflags, (NatM_State us delta imports pic dflags))
+
 
 getDeltaNat :: NatM Int
-getDeltaNat = NatM $ \ st -> (natm_delta st, st)
+getDeltaNat 
+       = NatM $ \ st -> (natm_delta st, st)
+
 
 setDeltaNat :: Int -> NatM ()
-setDeltaNat delta = NatM $ \ (NatM_State us _ imports pic dflags) ->
-   ((), NatM_State us delta imports pic dflags)
+setDeltaNat delta 
+       = NatM $ \ (NatM_State us _ imports pic dflags) ->
+                  ((), NatM_State us delta imports pic dflags)
+
 
 addImportNat :: CLabel -> NatM ()
-addImportNat imp = NatM $ \ (NatM_State us delta imports pic dflags) ->
-   ((), NatM_State us delta (imp:imports) pic dflags)
+addImportNat imp 
+       = NatM $ \ (NatM_State us delta imports pic dflags) ->
+                  ((), NatM_State us delta (imp:imports) pic dflags)
+
 
 getBlockIdNat :: NatM BlockId
-getBlockIdNat = do u <- getUniqueNat; return (BlockId u)
+getBlockIdNat 
+ = do  u <- getUniqueNat
+       return (BlockId u)
+
 
 getNewLabelNat :: NatM CLabel
-getNewLabelNat = do u <- getUniqueNat; return (mkAsmTempLabel u)
+getNewLabelNat 
+ = do  u <- getUniqueNat
+       return (mkAsmTempLabel u)
+
 
 getNewRegNat :: Size -> NatM Reg
-getNewRegNat rep = do u <- getUniqueNat; return (mkVReg u rep)
+getNewRegNat rep 
+ = do  u <- getUniqueNat
+       return (targetMkVReg u rep)
+
 
 getNewRegPairNat :: Size -> NatM (Reg,Reg)
-getNewRegPairNat rep = do 
-  u <- getUniqueNat
-  let lo = mkVReg u rep; hi = getHiVRegFromLo lo
-  return (lo,hi)
+getNewRegPairNat rep 
+ = do  u       <- getUniqueNat
+       let lo  = targetMkVReg u rep; hi = getHiVRegFromLo lo
+       return (lo,hi)
+
 
 getPicBaseMaybeNat :: NatM (Maybe Reg)
-getPicBaseMaybeNat = NatM (\state -> (natm_pic state, state))
+getPicBaseMaybeNat 
+       = NatM (\state -> (natm_pic state, state))
+
 
 getPicBaseNat :: Size -> NatM Reg
-getPicBaseNat rep = do
-  mbPicBase <- getPicBaseMaybeNat
-  case mbPicBase of
-        Just picBase -> return picBase
-        Nothing -> do
-            reg <- getNewRegNat rep
-            NatM (\state -> (reg, state { natm_pic = Just reg }))
+getPicBaseNat rep 
+ = do  mbPicBase <- getPicBaseMaybeNat
+       case mbPicBase of
+               Just picBase -> return picBase
+               Nothing 
+                -> do
+                       reg <- getNewRegNat rep
+                       NatM (\state -> (reg, state { natm_pic = Just reg }))
similarity index 57%
rename from compiler/nativeGen/PositionIndependentCode.hs
rename to compiler/nativeGen/PIC.hs
index a1e11d8..98e4f9f 100644 (file)
@@ -1,24 +1,9 @@
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
-module PositionIndependentCode (
-        cmmMakeDynamicReference,
-        ReferenceKind(..),
-        needImportedSymbols,
-        pprImportedSymbol,
-        pprGotDeclaration,
-        initializePicBase
-     ) where
-
-#include "HsVersions.h"
-
 {-
   This module handles generation of position independent code and
   dynamic-linking related issues for the native code generator.
+
+  This depends both the architecture and OS, so we define it here
+  instead of in one of the architecture specific modules.
   
   Things outside this module which are related to this:
   
@@ -53,7 +38,30 @@ module PositionIndependentCode (
       and ppc-linux).
 -}
 
-#include "nativeGen/NCG.h"
+module PIC (
+        cmmMakeDynamicReference,
+        ReferenceKind(..),
+        needImportedSymbols,
+        pprImportedSymbol,
+        pprGotDeclaration,
+
+        initializePicBase_ppc,
+        initializePicBase_x86
+)
+
+where
+
+import qualified PPC.Instr     as PPC
+import qualified PPC.Regs      as PPC
+
+import qualified X86.Instr     as X86
+
+import Platform
+import Instruction
+import Size
+import Reg
+import NCGMonad
+
 
 import Cmm
 import CLabel           ( CLabel, pprCLabel,
@@ -61,13 +69,8 @@ import CLabel           ( CLabel, pprCLabel,
                           dynamicLinkerLabelInfo, mkPicBaseLabel,
                           labelDynamic, externallyVisibleCLabel )
 
-#if linux_TARGET_OS
 import CLabel           ( mkForeignLabel )
-#endif
 
-import Regs
-import Instrs
-import NCGMonad         ( NatM, getNewRegNat, getNewLabelNat )
 
 import StaticFlags     ( opt_PIC, opt_Static )
 import BasicTypes
@@ -80,8 +83,7 @@ import DynFlags
 import FastString
 
 
--- The most important function here is cmmMakeDynamicReference.
-
+--------------------------------------------------------------------------------
 -- It gets called by the cmmToCmm pass for every CmmLabel in the Cmm
 -- code. It does The Right Thing(tm) to convert the CmmLabel into a
 -- position-independent, dynamic-linking-aware reference to the thing
@@ -94,10 +96,12 @@ import FastString
 -- - addImportCmmOpt for the CmmOptM monad
 -- - addImportNat for the NatM monad.
 
-data ReferenceKind = DataReference
-                   | CallReference
-                   | JumpReference
-                   deriving(Eq)
+data ReferenceKind 
+       = DataReference
+        | CallReference
+        | JumpReference
+        deriving(Eq)
+
 
 cmmMakeDynamicReference
   :: Monad m => DynFlags
@@ -110,80 +114,98 @@ cmmMakeDynamicReference
 cmmMakeDynamicReference dflags addImport referenceKind lbl
   | Just _ <- dynamicLinkerLabelInfo lbl
   = return $ CmmLit $ CmmLabel lbl   -- already processed it, pass through
-  | otherwise = case howToAccessLabel dflags referenceKind lbl of
+
+  | otherwise 
+  = case howToAccessLabel 
+               dflags 
+               (platformArch $ targetPlatform dflags)
+               (platformOS   $ targetPlatform dflags)
+               referenceKind lbl of
+
         AccessViaStub -> do
               let stub = mkDynamicLinkerLabel CodeStub lbl
               addImport stub
               return $ CmmLit $ CmmLabel stub
+
         AccessViaSymbolPtr -> do
               let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl
               addImport symbolPtr
-              return $ CmmLoad (cmmMakePicReference symbolPtr) bWord
+              return $ CmmLoad (cmmMakePicReference dflags symbolPtr) bWord
+
         AccessDirectly -> case referenceKind of
                 -- for data, we might have to make some calculations:
-              DataReference -> return $ cmmMakePicReference lbl  
+              DataReference -> return $ cmmMakePicReference dflags lbl  
                 -- all currently supported processors support
                 -- PC-relative branch and call instructions,
                 -- so just jump there if it's a call or a jump
               _ -> return $ CmmLit $ CmmLabel lbl
-  
--- -------------------------------------------------------------------
-  
+
+
+-- -----------------------------------------------------------------------------
 -- Create a position independent reference to a label.
 -- (but do not bother with dynamic linking).
 -- We calculate the label's address by adding some (platform-dependent)
 -- offset to our base register; this offset is calculated by
 -- the function picRelative in the platform-dependent part below.
 
-cmmMakePicReference :: CLabel -> CmmExpr
-  
-#if !mingw32_TARGET_OS
+cmmMakePicReference :: DynFlags -> CLabel -> CmmExpr
+cmmMakePicReference dflags lbl
+
         -- Windows doesn't need PIC,
         -- everything gets relocated at runtime
+       | OSMinGW32     <- platformOS $ targetPlatform dflags
+       = CmmLit $ CmmLabel lbl
 
-cmmMakePicReference lbl
-    | (opt_PIC || not opt_Static) && absoluteLabel lbl = CmmMachOp (MO_Add wordWidth) [
-            CmmReg (CmmGlobal PicBaseReg),
-            CmmLit $ picRelative lbl
-        ]
-    where
-        absoluteLabel lbl = case dynamicLinkerLabelInfo lbl of
-                                Just (GotSymbolPtr, _) -> False
-                                Just (GotSymbolOffset, _) -> False
-                                _ -> True
 
-#endif
-cmmMakePicReference lbl = CmmLit $ CmmLabel lbl
+       | (opt_PIC || not opt_Static) && absoluteLabel lbl 
+       = CmmMachOp (MO_Add wordWidth) 
+               [ CmmReg (CmmGlobal PicBaseReg)
+               , CmmLit $ picRelative 
+                               (platformArch   $ targetPlatform dflags)
+                               (platformOS     $ targetPlatform dflags)
+                               lbl ]
 
--- ===================================================================
--- Platform dependent stuff
--- ===================================================================
+       | otherwise
+       = CmmLit $ CmmLabel lbl
+  
+  
+absoluteLabel :: CLabel -> Bool
+absoluteLabel lbl 
+ = case dynamicLinkerLabelInfo lbl of
+       Just (GotSymbolPtr, _)          -> False
+       Just (GotSymbolOffset, _)       -> False
+       _                               -> True
 
+
+--------------------------------------------------------------------------------
 -- Knowledge about how special dynamic linker labels like symbol
 -- pointers, code stubs and GOT offsets look like is located in the
 -- module CLabel.
 
--- -------------------------------------------------------------------
-
 -- We have to decide which labels need to be accessed
 -- indirectly or via a piece of stub code.
+data LabelAccessStyle 
+       = AccessViaStub
+       | AccessViaSymbolPtr
+       | AccessDirectly
 
-data LabelAccessStyle = AccessViaStub
-                      | AccessViaSymbolPtr
-                      | AccessDirectly
+howToAccessLabel 
+       :: DynFlags -> Arch -> OS -> ReferenceKind -> CLabel -> LabelAccessStyle
 
-howToAccessLabel :: DynFlags -> ReferenceKind -> CLabel -> LabelAccessStyle
-
-#if mingw32_TARGET_OS
 -- Windows
 -- 
 -- We need to use access *exactly* those things that
 -- are imported from a DLL via an __imp_* label.
 -- There are no stubs for imported code.
+--
+howToAccessLabel dflags _ OSMinGW32 _ lbl
+       | labelDynamic (thisPackage dflags) lbl 
+       = AccessViaSymbolPtr
+
+       | otherwise
+       = AccessDirectly
+
 
-howToAccessLabel dflags _ lbl | labelDynamic (thisPackage dflags) lbl = AccessViaSymbolPtr
-                             | otherwise        = AccessDirectly
-#elif darwin_TARGET_OS
 -- Mach-O (Darwin, Mac OS X)
 --
 -- Indirect access is required in the following cases:
@@ -191,54 +213,48 @@ howToAccessLabel dflags _ lbl | labelDynamic (thisPackage dflags) lbl = AccessVi
 --  * (not on x86_64) data from a different module, if we're generating PIC code
 -- It is always possible to access something indirectly,
 -- even when it's not necessary.
+--
+howToAccessLabel dflags arch OSDarwin DataReference lbl
+       -- data access to a dynamic library goes via a symbol pointer
+       | labelDynamic (thisPackage dflags) lbl 
+       = AccessViaSymbolPtr
+
+       -- when generating PIC code, all cross-module data references must
+       -- must go via a symbol pointer, too, because the assembler
+       -- cannot generate code for a label difference where one
+       -- label is undefined. Doesn't apply t x86_64.
+       -- Unfortunately, we don't know whether it's cross-module,
+       -- so we do it for all externally visible labels.
+       -- This is a slight waste of time and space, but otherwise
+       -- we'd need to pass the current Module all the way in to
+       -- this function.
+       | arch /= ArchX86_64
+       , opt_PIC && externallyVisibleCLabel lbl 
+       = AccessViaSymbolPtr
+        
+       | otherwise 
+       = AccessDirectly
+
+howToAccessLabel dflags arch OSDarwin JumpReference lbl
+       -- dyld code stubs don't work for tailcalls because the
+       -- stack alignment is only right for regular calls.
+       -- Therefore, we have to go via a symbol pointer:
+       | arch == ArchX86 || arch == ArchX86_64
+       , labelDynamic (thisPackage dflags) lbl
+       = AccessViaSymbolPtr
+           
+
+howToAccessLabel dflags arch OSDarwin _ lbl
+       -- Code stubs are the usual method of choice for imported code;
+       -- not needed on x86_64 because Apple's new linker, ld64, generates
+       -- them automatically.
+       | arch /= ArchX86_64
+       , labelDynamic (thisPackage dflags) lbl
+       = AccessViaStub
+
+       | otherwise
+       = AccessDirectly
 
-howToAccessLabel dflags DataReference lbl
-      -- data access to a dynamic library goes via a symbol pointer
-    | labelDynamic (thisPackage dflags) lbl = AccessViaSymbolPtr
-    
-#if !x86_64_TARGET_ARCH
-      -- when generating PIC code, all cross-module data references must
-      -- must go via a symbol pointer, too, because the assembler
-      -- cannot generate code for a label difference where one
-      -- label is undefined. Doesn't apply t x86_64.
-      -- Unfortunately, we don't know whether it's cross-module,
-      -- so we do it for all externally visible labels.
-      -- This is a slight waste of time and space, but otherwise
-      -- we'd need to pass the current Module all the way in to
-      -- this function.
-    | opt_PIC && externallyVisibleCLabel lbl = AccessViaSymbolPtr
-#endif
-    | otherwise = AccessDirectly
-
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-    -- dyld code stubs don't work for tailcalls because the
-    -- stack alignment is only right for regular calls.
-    -- Therefore, we have to go via a symbol pointer:
-howToAccessLabel dflags JumpReference lbl
-    | labelDynamic (thisPackage dflags) lbl
-    = AccessViaSymbolPtr
-#endif
-
-howToAccessLabel dflags _ lbl
-#if !x86_64_TARGET_ARCH
-    -- Code stubs are the usual method of choice for imported code;
-    -- not needed on x86_64 because Apple's new linker, ld64, generates
-    -- them automatically.
-    | labelDynamic (thisPackage dflags) lbl
-    = AccessViaStub
-#endif
-    | otherwise
-    = AccessDirectly
-
-
-#elif linux_TARGET_OS && powerpc64_TARGET_ARCH
--- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC
-
-howToAccessLabel _ DataReference lbl = AccessViaSymbolPtr
-howToAccessLabel _ _ lbl = AccessDirectly -- actually, .label instead of label
-
-#elif linux_TARGET_OS
 -- ELF (Linux)
 --
 -- ELF tries to pretend to the main application code that dynamic linking does 
@@ -250,63 +266,82 @@ howToAccessLabel _ _ lbl = AccessDirectly -- actually, .label instead of label
 -- from position independent code. It is also required from the main program
 -- when dynamic libraries containing Haskell code are used.
 
-howToAccessLabel _ _ lbl
+howToAccessLabel _ ArchPPC_64 OSLinux kind _
+
+       -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC
+       | DataReference <- kind
+       = AccessViaSymbolPtr
+       
+       -- actually, .label instead of label
+       | otherwise
+       = AccessDirectly 
+
+howToAccessLabel _ _ OSLinux _ _
        -- no PIC -> the dynamic linker does everything for us;
        --           if we don't dynamically link to Haskell code,
        --           it actually manages to do so without messing thins up.
-    | not opt_PIC && opt_Static = AccessDirectly
-   
-howToAccessLabel dflags DataReference lbl
-       -- A dynamic label needs to be accessed via a symbol pointer.
-    | labelDynamic (thisPackage dflags) lbl = AccessViaSymbolPtr
-#if powerpc_TARGET_ARCH
+       | not opt_PIC && opt_Static 
+       = AccessDirectly
+
+howToAccessLabel dflags arch OSLinux DataReference lbl
+       -- A dynamic label needs to be accessed via a symbol pointer.
+       | labelDynamic (thisPackage dflags) lbl 
+       = AccessViaSymbolPtr
+
        -- For PowerPC32 -fPIC, we have to access even static data
        -- via a symbol pointer (see below for an explanation why
        -- PowerPC32 Linux is especially broken).
-    | opt_PIC = AccessViaSymbolPtr
-#endif
-    | otherwise = AccessDirectly
-
-
--- In most cases, we have to avoid symbol stubs on ELF, for the following reasons:
--- * on i386, the position-independent symbol stubs in the Procedure Linkage Table
---   require the address of the GOT to be loaded into register %ebx on entry.
--- * The linker will take any reference to the symbol stub as a hint that
---   the label in question is a code label. When linking executables, this
---   will cause the linker to replace even data references to the label with
---   references to the symbol stub.
-
--- This leaves calling a (foreign) function from non-PIC code
--- (AccessDirectly, because we get an implicit symbol stub)
--- and calling functions from PIC code on non-i386 platforms (via a symbol stub) 
-
-howToAccessLabel dflags CallReference lbl
-    | labelDynamic (thisPackage dflags) lbl && not opt_PIC
-    = AccessDirectly
-#if !i386_TARGET_ARCH
-    | labelDynamic (thisPackage dflags) lbl && opt_PIC
-    = AccessViaStub
-#endif
-
-howToAccessLabel dflags _ lbl
-    | labelDynamic (thisPackage dflags) lbl = AccessViaSymbolPtr
-    | otherwise = AccessDirectly
-#else
---
+       | arch == ArchPPC
+       , opt_PIC
+       = AccessViaSymbolPtr
+       
+       | otherwise 
+       = AccessDirectly
+
+
+       -- In most cases, we have to avoid symbol stubs on ELF, for the following reasons:
+       -- * on i386, the position-independent symbol stubs in the Procedure Linkage Table
+       --   require the address of the GOT to be loaded into register %ebx on entry.
+       -- * The linker will take any reference to the symbol stub as a hint that
+       --   the label in question is a code label. When linking executables, this
+       --   will cause the linker to replace even data references to the label with
+       --   references to the symbol stub.
+
+       -- This leaves calling a (foreign) function from non-PIC code
+       -- (AccessDirectly, because we get an implicit symbol stub)
+       -- and calling functions from PIC code on non-i386 platforms (via a symbol stub) 
+
+howToAccessLabel dflags arch OSLinux CallReference lbl
+       | labelDynamic (thisPackage dflags) lbl && not opt_PIC
+       = AccessDirectly
+
+       | arch /= ArchX86
+       , labelDynamic (thisPackage dflags) lbl && opt_PIC
+       = AccessViaStub
+
+howToAccessLabel dflags _ OSLinux _ lbl
+       | labelDynamic (thisPackage dflags) lbl 
+       = AccessViaSymbolPtr
+
+       | otherwise 
+       = AccessDirectly
+
 -- all other platforms
---
-howToAccessLabel _ _ _
-        | not opt_PIC = AccessDirectly
-        | otherwise   = panic "howToAccessLabel: PIC not defined for this platform"
-#endif
+howToAccessLabel _ _ _ _ _
+       | not opt_PIC 
+       = AccessDirectly
+       
+       | otherwise
+       = panic "howToAccessLabel: PIC not defined for this platform"
+
+
 
 -- -------------------------------------------------------------------
+-- | Says what we we have to add to our 'PIC base register' in order to
+--     get the address of a label.
 
--- What do we have to add to our 'PIC base register' in order to
--- get the address of a label?
+picRelative :: Arch -> OS -> CLabel -> CmmLit
 
-picRelative :: CLabel -> CmmLit
-#if darwin_TARGET_OS && !x86_64_TARGET_ARCH
 -- Darwin, but not x86_64:
 -- The PIC base register points to the PIC base label at the beginning
 -- of the current CmmTop. We just have to use a label difference to
@@ -314,21 +349,21 @@ picRelative :: CLabel -> CmmLit
 -- We have already made sure that all labels that are not from the current
 -- module are accessed indirectly ('as' can't calculate differences between
 -- undefined labels).
+picRelative arch OSDarwin lbl
+       | arch /= ArchX86_64
+       = CmmLabelDiffOff lbl mkPicBaseLabel 0
+       
 
-picRelative lbl
-  = CmmLabelDiffOff lbl mkPicBaseLabel 0
-
-#elif powerpc_TARGET_ARCH && linux_TARGET_OS
 -- PowerPC Linux:
 -- The PIC base register points to our fake GOT. Use a label difference
 -- to get the offset.
 -- We have made sure that *everything* is accessed indirectly, so this
 -- is only used for offsets from the GOT to symbol pointers inside the
 -- GOT.
-picRelative lbl
-  = CmmLabelDiffOff lbl gotLabel 0
+picRelative ArchPPC OSLinux lbl
+       = CmmLabelDiffOff lbl gotLabel 0
+
 
-#elif linux_TARGET_OS || (darwin_TARGET_OS && x86_64_TARGET_ARCH)
 -- Most Linux versions:
 -- The PIC base register points to the GOT. Use foo@got for symbol
 -- pointers, and foo@gotoff for everything else.
@@ -336,61 +371,116 @@ picRelative lbl
 -- The PIC base register is %rip, we use foo@gotpcrel for symbol pointers,
 -- and a GotSymbolOffset label for other things.
 -- For reasons of tradition, the symbol offset label is written as a plain label.
+picRelative arch os lbl
+       | os == OSLinux || (os == OSDarwin && arch == ArchX86_64)
+       = let   result
+                       | Just (SymbolPtr, lbl') <- dynamicLinkerLabelInfo lbl
+                       = CmmLabel $ mkDynamicLinkerLabel GotSymbolPtr lbl'
 
-picRelative lbl
-  | Just (SymbolPtr, lbl') <- dynamicLinkerLabelInfo lbl
-  = CmmLabel $ mkDynamicLinkerLabel GotSymbolPtr lbl'
-  | otherwise
-  = CmmLabel $ mkDynamicLinkerLabel GotSymbolOffset lbl
+                       | otherwise
+                       = CmmLabel $ mkDynamicLinkerLabel GotSymbolOffset lbl
+                       
+         in    result
+
+picRelative _ _ _
+       = panic "PositionIndependentCode.picRelative undefined for this platform"
 
-#else
-picRelative lbl = panic "PositionIndependentCode.picRelative"
-#endif
 
--- -------------------------------------------------------------------
 
--- What do we have to add to every assembly file we generate?
+--------------------------------------------------------------------------------
 
 -- utility function for pretty-printing asm-labels,
 -- copied from PprMach
-asmSDoc d = Outputable.withPprStyleDoc (
-             Outputable.mkCodeStyle Outputable.AsmStyle) d
-pprCLabel_asm l = asmSDoc (pprCLabel l)
+--
+asmSDoc :: Outputable.SDoc -> Doc
+asmSDoc d 
+       = Outputable.withPprStyleDoc 
+               (Outputable.mkCodeStyle Outputable.AsmStyle) d
+
+pprCLabel_asm :: CLabel -> Doc
+pprCLabel_asm l 
+       = asmSDoc (pprCLabel l)
+
+
+needImportedSymbols :: Arch -> OS -> Bool
+needImportedSymbols arch os
+       | os    == OSDarwin
+       , arch  /= ArchX86_64
+       = True
+       
+       -- PowerPC Linux: -fPIC or -dynamic
+       | os    == OSLinux
+       , arch  == ArchPPC
+       = opt_PIC || not opt_Static
+
+       -- i386 (and others?): -dynamic but not -fPIC
+       | os    == OSLinux
+       , arch  /= ArchPPC_64
+       = not opt_Static && not opt_PIC
+
+       | otherwise
+       = False
 
+-- gotLabel
+-- The label used to refer to our "fake GOT" from
+-- position-independent code.
+gotLabel :: CLabel
+gotLabel 
+       = mkForeignLabel -- HACK: it's not really foreign
+               (fsLit ".LCTOC1") Nothing False IsData
 
-#if darwin_TARGET_OS && !x86_64_TARGET_ARCH
 
-needImportedSymbols = True
 
+--------------------------------------------------------------------------------
 -- We don't need to declare any offset tables.
 -- However, for PIC on x86, we need a small helper function.
-#if i386_TARGET_ARCH
-pprGotDeclaration
-    | opt_PIC
-    = vcat [
-        ptext (sLit ".section __TEXT,__textcoal_nt,coalesced,no_toc"),
-        ptext (sLit ".weak_definition ___i686.get_pc_thunk.ax"),
-        ptext (sLit ".private_extern ___i686.get_pc_thunk.ax"),
-        ptext (sLit "___i686.get_pc_thunk.ax:"),
-            ptext (sLit "\tmovl (%esp), %eax"),
-            ptext (sLit "\tret")
-    ]
-    | otherwise = Pretty.empty
-#else
-pprGotDeclaration = Pretty.empty
-#endif
+pprGotDeclaration :: Arch -> OS -> Doc
+pprGotDeclaration ArchX86 OSDarwin
+       | opt_PIC
+       = vcat [
+               ptext (sLit ".section __TEXT,__textcoal_nt,coalesced,no_toc"),
+               ptext (sLit ".weak_definition ___i686.get_pc_thunk.ax"),
+               ptext (sLit ".private_extern ___i686.get_pc_thunk.ax"),
+               ptext (sLit "___i686.get_pc_thunk.ax:"),
+               ptext (sLit "\tmovl (%esp), %eax"),
+               ptext (sLit "\tret") ]
+
+       | otherwise
+       = empty
+       
+               
+-- pprGotDeclaration
+-- Output whatever needs to be output once per .s file.
+-- The .LCTOC1 label is defined to point 32768 bytes into the table,
+-- to make the most of the PPC's 16-bit displacements.
+-- Only needed for PIC.
+pprGotDeclaration arch OSLinux
+       | arch  /= ArchPPC_64
+       , not opt_PIC 
+       = Pretty.empty
+
+       | arch  /= ArchPPC_64
+       = vcat [
+               ptext (sLit ".section \".got2\",\"aw\""),
+               ptext (sLit ".LCTOC1 = .+32768") ]
+
+pprGotDeclaration _ _
+       = panic "pprGotDeclaration: no match"   
 
+
+--------------------------------------------------------------------------------
 -- On Darwin, we have to generate our own stub code for lazy binding..
 -- For each processor architecture, there are two versions, one for PIC
 -- and one for non-PIC.
 --
 -- Whenever you change something in this assembler output, make sure
 -- the splitter in driver/split/ghc-split.lprl recognizes the new output
-pprImportedSymbol importedLbl
-#if powerpc_TARGET_ARCH
-    | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl
-    = case opt_PIC of
-        False ->
+
+pprImportedSymbol :: Arch -> OS -> CLabel -> Doc
+pprImportedSymbol ArchPPC OSDarwin importedLbl
+       | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl
+       = case opt_PIC of
+           False ->
             vcat [
                 ptext (sLit ".symbol_stub"),
                 ptext (sLit "L") <> pprCLabel_asm lbl <> ptext (sLit "$stub:"),
@@ -404,7 +494,7 @@ pprImportedSymbol importedLbl
                         <> ptext (sLit "$lazy_ptr)"),
                     ptext (sLit "\tbctr")
             ]
-        True ->
+           True ->
             vcat [
                 ptext (sLit ".section __TEXT,__picsymbolstub1,")
                   <> ptext (sLit "symbol_stubs,pure_instructions,32"),
@@ -424,16 +514,27 @@ pprImportedSymbol importedLbl
                     ptext (sLit "\tmtctr r12"),
                     ptext (sLit "\tbctr")
             ]
-    $+$ vcat [
-        ptext (sLit ".lazy_symbol_pointer"),
-        ptext (sLit "L") <> pprCLabel_asm lbl <> ptext (sLit "$lazy_ptr:"),
-            ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm lbl,
-            ptext (sLit "\t.long dyld_stub_binding_helper")
-    ]
-#elif i386_TARGET_ARCH
-    | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl
-    = case opt_PIC of
-        False ->
+         $+$ vcat [
+               ptext (sLit ".lazy_symbol_pointer"),
+               ptext (sLit "L") <> pprCLabel_asm lbl <> ptext (sLit "$lazy_ptr:"),
+               ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm lbl,
+               ptext (sLit "\t.long dyld_stub_binding_helper")]
+
+       | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl
+       = vcat [
+               ptext (sLit ".non_lazy_symbol_pointer"),
+               char 'L' <> pprCLabel_asm lbl <> ptext (sLit "$non_lazy_ptr:"),
+               ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm lbl,
+               ptext (sLit "\t.long\t0")]
+
+       | otherwise 
+       = empty
+
+               
+pprImportedSymbol ArchX86 OSDarwin importedLbl
+       | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl
+       = case opt_PIC of
+           False ->
             vcat [
                 ptext (sLit ".symbol_stub"),
                 ptext (sLit "L") <> pprCLabel_asm lbl <> ptext (sLit "$stub:"),
@@ -446,7 +547,7 @@ pprImportedSymbol importedLbl
                         <> ptext (sLit "$lazy_ptr"),
                     ptext (sLit "\tjmp dyld_stub_binding_helper")
             ]
-        True ->
+           True ->
             vcat [
                 ptext (sLit ".section __TEXT,__picsymbolstub2,")
                     <> ptext (sLit "symbol_stubs,pure_instructions,25"),
@@ -464,27 +565,28 @@ pprImportedSymbol importedLbl
                     ptext (sLit "\tpushl %eax"),
                     ptext (sLit "\tjmp dyld_stub_binding_helper")
             ]
-    $+$ vcat [        ptext (sLit ".section __DATA, __la_sym_ptr")
+         $+$ vcat [        ptext (sLit ".section __DATA, __la_sym_ptr")
                     <> (if opt_PIC then int 2 else int 3)
                     <> ptext (sLit ",lazy_symbol_pointers"),
-        ptext (sLit "L") <> pprCLabel_asm lbl <> ptext (sLit "$lazy_ptr:"),
-            ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm lbl,
-            ptext (sLit "\t.long L") <> pprCLabel_asm lbl
-                    <> ptext (sLit "$stub_binder")
-    ]
-#endif
--- We also have to declare our symbol pointers ourselves:
-    | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl
-    = vcat [
-        ptext (sLit ".non_lazy_symbol_pointer"),
-        char 'L' <> pprCLabel_asm lbl <> ptext (sLit "$non_lazy_ptr:"),
-           ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm lbl,
-            ptext (sLit "\t.long\t0")
-    ]
-
-    | otherwise = empty
-
-#elif linux_TARGET_OS && !powerpc64_TARGET_ARCH
+               ptext (sLit "L") <> pprCLabel_asm lbl <> ptext (sLit "$lazy_ptr:"),
+                   ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm lbl,
+                   ptext (sLit "\t.long L") <> pprCLabel_asm lbl
+                    <> ptext (sLit "$stub_binder")]
+
+       | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl
+       = vcat [
+               ptext (sLit ".non_lazy_symbol_pointer"),
+               char 'L' <> pprCLabel_asm lbl <> ptext (sLit "$non_lazy_ptr:"),
+               ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm lbl,
+               ptext (sLit "\t.long\t0")]
+
+       | otherwise 
+       = empty
+
+
+pprImportedSymbol _ OSDarwin _
+       = empty
+       
 
 -- ELF / Linux
 --
@@ -514,64 +616,29 @@ pprImportedSymbol importedLbl
 -- When needImportedSymbols is defined,
 -- the NCG will keep track of all DynamicLinkerLabels it uses
 -- and output each of them using pprImportedSymbol.
-#if powerpc_TARGET_ARCH
-    -- PowerPC Linux: -fPIC or -dynamic
-needImportedSymbols = opt_PIC || not opt_Static
-#else
-    -- i386 (and others?): -dynamic but not -fPIC
-needImportedSymbols = not opt_Static && not opt_PIC
-#endif
 
--- gotLabel
--- The label used to refer to our "fake GOT" from
--- position-independent code.
-gotLabel = mkForeignLabel -- HACK: it's not really foreign
-                           (fsLit ".LCTOC1") Nothing False IsData
+pprImportedSymbol ArchPPC_64 OSLinux _
+       = empty
 
--- pprGotDeclaration
--- Output whatever needs to be output once per .s file.
--- The .LCTOC1 label is defined to point 32768 bytes into the table,
--- to make the most of the PPC's 16-bit displacements.
--- Only needed for PIC.
-
-pprGotDeclaration
-    | not opt_PIC = Pretty.empty
-    | otherwise = vcat [
-        ptext (sLit ".section \".got2\",\"aw\""),
-        ptext (sLit ".LCTOC1 = .+32768")
-    ]
-
--- We generate one .long/.quad literal for every symbol we import;
--- the dynamic linker will relocate those addresses.
-
-pprImportedSymbol importedLbl
-    | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl
-    = vcat [
-        ptext (sLit ".section \".got2\", \"aw\""),
-        ptext (sLit ".LC_") <> pprCLabel_asm lbl <> char ':',
-        ptext symbolSize <+> pprCLabel_asm lbl
-    ]
-
--- PLT code stubs are generated automatically by the dynamic linker.
-    | otherwise = empty
-    where
-      symbolSize = case wordWidth of
+pprImportedSymbol _ OSLinux importedLbl
+       | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl
+       = let   symbolSize = case wordWidth of
                     W32 -> sLit "\t.long"
                     W64 -> sLit "\t.quad"
                     _ -> panic "Unknown wordRep in pprImportedSymbol"
 
-#else
-
--- For all other currently supported platforms, we don't need to do
--- anything at all.
+         in vcat [
+               ptext (sLit ".section \".got2\", \"aw\""),
+               ptext (sLit ".LC_") <> pprCLabel_asm lbl <> char ':',
+               ptext symbolSize <+> pprCLabel_asm lbl ]
 
-needImportedSymbols = False
-pprGotDeclaration = Pretty.empty
-pprImportedSymbol _ = empty
-#endif
+       -- PLT code stubs are generated automatically by the dynamic linker.
+       | otherwise = empty
 
--- -------------------------------------------------------------------
+pprImportedSymbol _ _ _
+       = panic "PIC.pprImportedSymbol: no match"
 
+--------------------------------------------------------------------------------
 -- Generate code to calculate the address that should be put in the
 -- PIC base register.
 -- This is called by MachCodeGen for every CmmProc that accessed the
@@ -581,10 +648,6 @@ pprImportedSymbol _ = empty
 -- It is assumed that the first NatCmmTop in the input list is a Proc
 -- and the rest are CmmDatas.
 
-initializePicBase :: Reg -> [NatCmmTop] -> NatM [NatCmmTop]
-
-#if darwin_TARGET_OS
-
 -- Darwin is simple: just fetch the address of a local label.
 -- The FETCHPC pseudo-instruction is expanded to multiple instructions
 -- during pretty-printing so that we don't have to deal with the
@@ -598,12 +661,7 @@ initializePicBase :: Reg -> [NatCmmTop] -> NatM [NatCmmTop]
 --          call 1f
 --      1:  popl %picReg
 
-initializePicBase picReg (CmmProc info lab params (ListGraph blocks) : statics)
-    = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics)
-    where BasicBlock bID insns = head blocks
-          b' = BasicBlock bID (FETCHPC picReg : insns)
 
-#elif powerpc_TARGET_ARCH && linux_TARGET_OS
 
 -- Get a pointer to our own fake GOT, which is defined on a per-module basis.
 -- This is exactly how GCC does it, and it's quite horrible:
@@ -612,7 +670,13 @@ initializePicBase picReg (CmmProc info lab params (ListGraph blocks) : statics)
 -- define in .text space right next to the proc. This .long literal contains
 -- the (32-bit) offset from our local label to our global offset table
 -- (.LCTOC1 aka gotOffLabel).
-initializePicBase picReg
+
+initializePicBase_ppc 
+       :: Arch -> OS -> Reg 
+       -> [NatCmmTop PPC.Instr] 
+       -> NatM [NatCmmTop PPC.Instr]
+
+initializePicBase_ppc ArchPPC OSLinux picReg
     (CmmProc info lab params (ListGraph blocks) : statics)
     = do
         gotOffLabel <- getNewLabelNat
@@ -624,16 +688,33 @@ initializePicBase picReg
                                                          mkPicBaseLabel
                                                          0)
                         ]
-            offsetToOffset = ImmConstantDiff (ImmCLbl gotOffLabel)
-                                             (ImmCLbl mkPicBaseLabel)
-            BasicBlock bID insns = head blocks
-            b' = BasicBlock bID (FETCHPC picReg
-                               : LD wordSize tmp
-                                    (AddrRegImm picReg offsetToOffset)
-                               : ADD picReg picReg (RIReg tmp)
+            offsetToOffset
+                       = PPC.ImmConstantDiff 
+                               (PPC.ImmCLbl gotOffLabel)
+                               (PPC.ImmCLbl mkPicBaseLabel)
+
+            BasicBlock bID insns 
+                       = head blocks
+
+            b' = BasicBlock bID (PPC.FETCHPC picReg
+                               : PPC.LD PPC.archWordSize tmp
+                                    (PPC.AddrRegImm picReg offsetToOffset)
+                               : PPC.ADD picReg picReg (PPC.RIReg tmp)
                                : insns)
+
         return (CmmProc info lab params (ListGraph (b' : tail blocks)) : gotOffset : statics)
-#elif i386_TARGET_ARCH && linux_TARGET_OS
+
+initializePicBase_ppc ArchPPC OSDarwin picReg
+       (CmmProc info lab params (ListGraph blocks) : statics)
+       = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics)
+
+       where   BasicBlock bID insns = head blocks
+               b' = BasicBlock bID (PPC.FETCHPC picReg : insns)
+
+
+initializePicBase_ppc _ _ _ _
+       = panic "initializePicBase_ppc: not needed"
+
 
 -- We cheat a bit here by defining a pseudo-instruction named FETCHGOT
 -- which pretty-prints as:
@@ -642,13 +723,24 @@ initializePicBase picReg
 --              addl __GLOBAL_OFFSET_TABLE__+.-1b, %picReg
 -- (See PprMach.lhs)
 
-initializePicBase picReg (CmmProc info lab params (ListGraph blocks) : statics)
+initializePicBase_x86
+       :: Arch -> OS -> Reg 
+       -> [NatCmmTop X86.Instr] 
+       -> NatM [NatCmmTop X86.Instr]
+
+initializePicBase_x86 ArchX86 OSLinux picReg 
+       (CmmProc info lab params (ListGraph blocks) : statics)
     = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics)
     where BasicBlock bID insns = head blocks
-          b' = BasicBlock bID (FETCHGOT picReg : insns)
+          b' = BasicBlock bID (X86.FETCHGOT picReg : insns)
+
+initializePicBase_x86 ArchX86 OSDarwin picReg
+       (CmmProc info lab params (ListGraph blocks) : statics)
+       = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics)
+
+       where   BasicBlock bID insns = head blocks
+               b' = BasicBlock bID (X86.FETCHPC picReg : insns)
 
-#else
-initializePicBase picReg proc = panic "initializePicBase"
+initializePicBase_x86 _ _ _ _
+       = panic "initializePicBase_x86: not needed"
 
--- mingw32_TARGET_OS: not needed, won't be called
-#endif
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
new file mode 100644 (file)
index 0000000..6661a3e
--- /dev/null
@@ -0,0 +1,1364 @@
+{-# OPTIONS -w #-}
+
+-----------------------------------------------------------------------------
+--
+-- Generating machine code (instruction selection)
+--
+-- (c) The University of Glasgow 1996-2004
+--
+-----------------------------------------------------------------------------
+
+-- This is a big module, but, if you pay attention to
+-- (a) the sectioning, (b) the type signatures, and
+-- (c) the #if blah_TARGET_ARCH} things, the
+-- structure should not be too overwhelming.
+
+module PPC.CodeGen ( 
+       cmmTopCodeGen, 
+       InstrBlock 
+) 
+
+where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+#include "MachDeps.h"
+
+-- NCG stuff:
+import PPC.Instr
+import PPC.Cond
+import PPC.Regs
+import PPC.RegInfo
+import NCGMonad
+import Instruction
+import PIC
+import Size
+import RegClass
+import Reg
+import Platform
+
+-- Our intermediate code:
+import BlockId
+import PprCmm          ( pprExpr )
+import Cmm
+import CLabel
+
+-- The rest:
+import StaticFlags     ( opt_PIC )
+import OrdList
+import qualified Outputable as O
+import Outputable
+import DynFlags
+
+import Control.Monad   ( mapAndUnzipM )
+import Data.Bits
+import Data.Int
+import Data.Word
+
+-- -----------------------------------------------------------------------------
+-- Top-level of the instruction selector
+
+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
+-- They are really trees of insns to facilitate fast appending, where a
+-- left-to-right traversal (pre-order?) yields the insns in the correct
+-- order.
+
+cmmTopCodeGen 
+       :: DynFlags 
+       -> RawCmmTop 
+       -> NatM [NatCmmTop Instr]
+
+cmmTopCodeGen dflags (CmmProc info lab params (ListGraph blocks)) = do
+  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
+  picBaseMb <- getPicBaseMaybeNat
+  let proc = CmmProc info lab params (ListGraph $ concat nat_blocks)
+      tops = proc : concat statics
+      os   = platformOS $ targetPlatform dflags
+  case picBaseMb of
+      Just picBase -> initializePicBase_ppc ArchPPC os picBase tops
+      Nothing -> return tops
+  
+cmmTopCodeGen dflags (CmmData sec dat) = do
+  return [CmmData sec dat]  -- no translation, we just use CmmStatic
+
+basicBlockCodeGen 
+       :: CmmBasicBlock 
+       -> NatM ( [NatBasicBlock Instr]
+               , [NatCmmTop Instr])
+
+basicBlockCodeGen (BasicBlock id stmts) = do
+  instrs <- stmtsToInstrs stmts
+  -- code generation may introduce new basic block boundaries, which
+  -- are indicated by the NEWBLOCK instruction.  We must split up the
+  -- instruction stream into basic blocks again.  Also, we extract
+  -- LDATAs here too.
+  let
+       (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
+       
+       mkBlocks (NEWBLOCK id) (instrs,blocks,statics) 
+         = ([], BasicBlock id instrs : blocks, statics)
+       mkBlocks (LDATA sec dat) (instrs,blocks,statics) 
+         = (instrs, blocks, CmmData sec dat:statics)
+       mkBlocks instr (instrs,blocks,statics)
+         = (instr:instrs, blocks, statics)
+  -- in
+  return (BasicBlock id top : other_blocks, statics)
+
+stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
+stmtsToInstrs stmts
+   = do instrss <- mapM stmtToInstrs stmts
+        return (concatOL instrss)
+
+stmtToInstrs :: CmmStmt -> NatM InstrBlock
+stmtToInstrs stmt = case stmt of
+    CmmNop        -> return nilOL
+    CmmComment s   -> return (unitOL (COMMENT s))
+
+    CmmAssign reg src
+      | isFloatType ty -> assignReg_FltCode size reg src
+#if WORD_SIZE_IN_BITS==32
+      | isWord64 ty    -> assignReg_I64Code      reg src
+#endif
+      | otherwise       -> assignReg_IntCode size reg src
+       where ty = cmmRegType reg
+             size = cmmTypeSize ty
+
+    CmmStore addr src
+      | isFloatType ty -> assignMem_FltCode size addr src
+#if WORD_SIZE_IN_BITS==32
+      | isWord64 ty     -> assignMem_I64Code      addr src
+#endif
+      | otherwise       -> assignMem_IntCode size addr src
+       where ty = cmmExprType src
+             size = cmmTypeSize ty
+
+    CmmCall target result_regs args _ _
+       -> genCCall target result_regs args
+
+    CmmBranch id         -> genBranch id
+    CmmCondBranch arg id  -> genCondJump id arg
+    CmmSwitch arg ids     -> genSwitch arg ids
+    CmmJump arg params   -> genJump arg
+    CmmReturn params     ->
+      panic "stmtToInstrs: return statement should have been cps'd away"
+
+
+--------------------------------------------------------------------------------
+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
+--     They are really trees of insns to facilitate fast appending, where a
+--     left-to-right traversal yields the insns in the correct order.
+--
+type InstrBlock 
+       = OrdList Instr
+
+
+-- | Register's passed up the tree.  If the stix code forces the register
+--     to live in a pre-decided machine register, it comes out as @Fixed@;
+--     otherwise, it comes out as @Any@, and the parent can decide which
+--     register to put it in.
+--
+data Register
+       = Fixed Size Reg InstrBlock
+       | Any   Size (Reg -> InstrBlock)
+
+
+swizzleRegisterRep :: Register -> Size -> Register
+swizzleRegisterRep (Fixed _ reg code) size = Fixed size reg code
+swizzleRegisterRep (Any _ codefn)     size = Any   size codefn
+
+
+-- | Grab the Reg for a CmmReg
+getRegisterReg :: CmmReg -> Reg
+
+getRegisterReg (CmmLocal (LocalReg u pk))
+  = mkVReg u (cmmTypeSize pk)
+
+getRegisterReg (CmmGlobal mid)
+  = case get_GlobalReg_reg_or_addr mid of
+       Left (RealReg rrno) -> RealReg rrno
+       _other -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
+          -- By this stage, the only MagicIds remaining should be the
+          -- ones which map to a real machine register on this
+          -- platform.  Hence ...
+
+
+{-
+Now, given a tree (the argument to an CmmLoad) that references memory,
+produce a suitable addressing mode.
+
+A Rule of the Game (tm) for Amodes: use of the addr bit must
+immediately follow use of the code part, since the code part puts
+values in registers which the addr then refers to.  So you can't put
+anything in between, lest it overwrite some of those registers.  If
+you need to do some other computation between the code part and use of
+the addr bit, first store the effective address from the amode in a
+temporary, then do the other computation, and then use the temporary:
+
+    code
+    LEA amode, tmp
+    ... other computation ...
+    ... (tmp) ...
+-}
+
+
+-- | Check whether an integer will fit in 32 bits.
+--     A CmmInt is intended to be truncated to the appropriate 
+--     number of bits, so here we truncate it to Int64.  This is
+--     important because e.g. -1 as a CmmInt might be either
+--     -1 or 18446744073709551615.
+--
+is32BitInteger :: Integer -> Bool
+is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000
+  where i64 = fromIntegral i :: Int64
+
+
+-- | Convert a BlockId to some CmmStatic data
+jumpTableEntry :: Maybe BlockId -> CmmStatic
+jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth)
+jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel)
+    where blockLabel = mkAsmTempLabel id
+
+
+
+-- -----------------------------------------------------------------------------
+-- General things for putting together code sequences
+
+-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert
+-- CmmExprs into CmmRegOff?
+mangleIndexTree :: CmmExpr -> CmmExpr
+mangleIndexTree (CmmRegOff reg off)
+  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
+  where width = typeWidth (cmmRegType reg)
+
+mangleIndexTree _
+       = panic "PPC.CodeGen.mangleIndexTree: no match"
+
+-- -----------------------------------------------------------------------------
+--  Code gen for 64-bit arithmetic on 32-bit platforms
+
+{-
+Simple support for generating 64-bit code (ie, 64 bit values and 64
+bit assignments) on 32-bit platforms.  Unlike the main code generator
+we merely shoot for generating working code as simply as possible, and
+pay little attention to code quality.  Specifically, there is no
+attempt to deal cleverly with the fixed-vs-floating register
+distinction; all values are generated into (pairs of) floating
+registers, even if this would mean some redundant reg-reg moves as a
+result.  Only one of the VRegUniques is returned, since it will be
+of the VRegUniqueLo form, and the upper-half VReg can be determined
+by applying getHiVRegFromLo to it.
+-}
+
+data ChildCode64       -- a.k.a "Register64"
+      = ChildCode64 
+          InstrBlock   -- code
+          Reg          -- the lower 32-bit temporary which contains the
+                       -- result; use getHiVRegFromLo to find the other
+                       -- VRegUnique.  Rules of this simplified insn
+                       -- selection game are therefore that the returned
+                       -- Reg may be modified
+
+
+-- | The dual to getAnyReg: compute an expression into a register, but
+--     we don't mind which one it is.
+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
+getSomeReg expr = do
+  r <- getRegister expr
+  case r of
+    Any rep code -> do
+       tmp <- getNewRegNat rep
+       return (tmp, code tmp)
+    Fixed _ reg code -> 
+       return (reg, code)
+
+getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)
+getI64Amodes addrTree = do
+    Amode hi_addr addr_code <- getAmode addrTree
+    case addrOffset hi_addr 4 of
+        Just lo_addr -> return (hi_addr, lo_addr, addr_code)
+        Nothing      -> do (hi_ptr, code) <- getSomeReg addrTree
+                           return (AddrRegImm hi_ptr (ImmInt 0),
+                                   AddrRegImm hi_ptr (ImmInt 4),
+                                   code)
+
+
+assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
+assignMem_I64Code addrTree valueTree = do
+        (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
+       ChildCode64 vcode rlo <- iselExpr64 valueTree
+       let 
+               rhi = getHiVRegFromLo rlo
+
+               -- Big-endian store
+               mov_hi = ST II32 rhi hi_addr
+               mov_lo = ST II32 rlo lo_addr
+       -- in
+       return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
+
+
+assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
+assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
+   ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
+   let 
+         r_dst_lo = mkVReg u_dst II32
+         r_dst_hi = getHiVRegFromLo r_dst_lo
+         r_src_hi = getHiVRegFromLo r_src_lo
+         mov_lo = MR r_dst_lo r_src_lo
+         mov_hi = MR r_dst_hi r_src_hi
+   -- in
+   return (
+        vcode `snocOL` mov_lo `snocOL` mov_hi
+     )
+
+assignReg_I64Code lvalue valueTree
+   = panic "assignReg_I64Code(powerpc): invalid lvalue"
+
+
+iselExpr64        :: CmmExpr -> NatM ChildCode64
+iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do
+    (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
+    (rlo, rhi) <- getNewRegPairNat II32
+    let mov_hi = LD II32 rhi hi_addr
+        mov_lo = LD II32 rlo lo_addr
+    return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) 
+                         rlo
+
+iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty
+   = return (ChildCode64 nilOL (mkVReg vu II32))
+
+iselExpr64 (CmmLit (CmmInt i _)) = do
+  (rlo,rhi) <- getNewRegPairNat II32
+  let
+       half0 = fromIntegral (fromIntegral i :: Word16)
+       half1 = fromIntegral ((fromIntegral i `shiftR` 16) :: Word16)
+       half2 = fromIntegral ((fromIntegral i `shiftR` 32) :: Word16)
+       half3 = fromIntegral ((fromIntegral i `shiftR` 48) :: Word16)
+       
+       code = toOL [
+               LIS rlo (ImmInt half1),
+               OR rlo rlo (RIImm $ ImmInt half0),
+               LIS rhi (ImmInt half3),
+               OR rlo rlo (RIImm $ ImmInt half2)
+               ]
+  -- in
+  return (ChildCode64 code rlo)
+
+iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
+   ChildCode64 code1 r1lo <- iselExpr64 e1
+   ChildCode64 code2 r2lo <- iselExpr64 e2
+   (rlo,rhi) <- getNewRegPairNat II32
+   let
+       r1hi = getHiVRegFromLo r1lo
+       r2hi = getHiVRegFromLo r2lo
+       code =  code1 `appOL`
+               code2 `appOL`
+               toOL [ ADDC rlo r1lo r2lo,
+                      ADDE rhi r1hi r2hi ]
+   -- in
+   return (ChildCode64 code rlo)
+
+iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do
+    (expr_reg,expr_code) <- getSomeReg expr
+    (rlo, rhi) <- getNewRegPairNat II32
+    let mov_hi = LI rhi (ImmInt 0)
+        mov_lo = MR rlo expr_reg
+    return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
+                         rlo
+iselExpr64 expr
+   = pprPanic "iselExpr64(powerpc)" (ppr expr)
+
+
+
+getRegister :: CmmExpr -> NatM Register
+
+getRegister (CmmReg reg) 
+  = return (Fixed (cmmTypeSize (cmmRegType reg)) 
+                 (getRegisterReg reg) nilOL)
+
+getRegister tree@(CmmRegOff _ _) 
+  = getRegister (mangleIndexTree tree)
+
+
+#if WORD_SIZE_IN_BITS==32
+    -- for 32-bit architectuers, support some 64 -> 32 bit conversions:
+    -- TO_W_(x), TO_W_(x >> 32)
+
+getRegister (CmmMachOp (MO_UU_Conv W64 W32)
+             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 (getHiVRegFromLo rlo) code
+
+getRegister (CmmMachOp (MO_SS_Conv W64 W32)
+             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 (getHiVRegFromLo rlo) code
+
+getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 rlo code
+
+getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 rlo code       
+
+#endif
+
+
+getRegister (CmmLoad mem pk)
+  | not (isWord64 pk)
+  = do
+        Amode addr addr_code <- getAmode mem
+        let code dst = ASSERT((regClass dst == RcDouble) == isFloatType pk)
+                       addr_code `snocOL` LD size dst addr
+        return (Any size code)
+          where size = cmmTypeSize pk
+
+-- catch simple cases of zero- or sign-extended load
+getRegister (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode mem
+    return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))
+
+-- Note: there is no Load Byte Arithmetic instruction, so no signed case here
+
+getRegister (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode mem
+    return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr))
+
+getRegister (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode mem
+    return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr))
+
+getRegister (CmmMachOp mop [x]) -- unary MachOps
+  = case mop of
+      MO_Not rep   -> triv_ucode_int rep NOT
+
+      MO_F_Neg w   -> triv_ucode_float w FNEG
+      MO_S_Neg w   -> triv_ucode_int   w NEG
+
+      MO_FF_Conv W64 W32 -> trivialUCode  FF32 FRSP x
+      MO_FF_Conv W32 W64 -> conversionNop FF64 x
+
+      MO_FS_Conv from to -> coerceFP2Int from to x
+      MO_SF_Conv from to -> coerceInt2FP from to x
+
+      MO_SS_Conv from to
+        | from == to    -> conversionNop (intSize to) x
+
+        -- narrowing is a nop: we treat the high bits as undefined
+      MO_SS_Conv W32 to -> conversionNop (intSize to) x
+      MO_SS_Conv W16 W8 -> conversionNop II8 x
+      MO_SS_Conv W8  to -> triv_ucode_int to (EXTS II8)
+      MO_SS_Conv W16 to -> triv_ucode_int to (EXTS II16)
+
+      MO_UU_Conv from to
+        | from == to -> conversionNop (intSize to) x
+        -- narrowing is a nop: we treat the high bits as undefined
+      MO_UU_Conv W32 to -> conversionNop (intSize to) x
+      MO_UU_Conv W16 W8 -> conversionNop II8 x
+      MO_UU_Conv W8 to  -> trivialCode to False AND x (CmmLit (CmmInt 255 W32))
+      MO_UU_Conv W16 to -> trivialCode to False AND x (CmmLit (CmmInt 65535 W32)) 
+      _        -> panic "PPC.CodeGen.getRegister: no match"
+
+    where
+       triv_ucode_int   width instr = trivialUCode (intSize   width) instr x
+       triv_ucode_float width instr = trivialUCode (floatSize width) instr x
+
+        conversionNop new_size expr
+            = do e_code <- getRegister expr
+                 return (swizzleRegisterRep e_code new_size)
+
+getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps
+  = case mop of
+      MO_F_Eq w -> condFltReg EQQ x y
+      MO_F_Ne w -> condFltReg NE  x y
+      MO_F_Gt w -> condFltReg GTT x y
+      MO_F_Ge w -> condFltReg GE  x y
+      MO_F_Lt w -> condFltReg LTT x y
+      MO_F_Le w -> condFltReg LE  x y
+
+      MO_Eq rep -> condIntReg EQQ  (extendUExpr rep x) (extendUExpr rep y)
+      MO_Ne rep -> condIntReg NE   (extendUExpr rep x) (extendUExpr rep y)
+
+      MO_S_Gt rep -> condIntReg GTT  (extendSExpr rep x) (extendSExpr rep y)
+      MO_S_Ge rep -> condIntReg GE   (extendSExpr rep x) (extendSExpr rep y)
+      MO_S_Lt rep -> condIntReg LTT  (extendSExpr rep x) (extendSExpr rep y)
+      MO_S_Le rep -> condIntReg LE   (extendSExpr rep x) (extendSExpr rep y)
+
+      MO_U_Gt rep -> condIntReg GU   (extendUExpr rep x) (extendUExpr rep y)
+      MO_U_Ge rep -> condIntReg GEU  (extendUExpr rep x) (extendUExpr rep y)
+      MO_U_Lt rep -> condIntReg LU   (extendUExpr rep x) (extendUExpr rep y)
+      MO_U_Le rep -> condIntReg LEU  (extendUExpr rep x) (extendUExpr rep y)
+
+      MO_F_Add w  -> triv_float w FADD
+      MO_F_Sub w  -> triv_float w FSUB
+      MO_F_Mul w  -> triv_float w FMUL
+      MO_F_Quot w -> triv_float w FDIV
+      
+         -- optimize addition with 32-bit immediate
+         -- (needed for PIC)
+      MO_Add W32 ->
+        case y of
+          CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate W32 True (-imm)
+            -> trivialCode W32 True ADD x (CmmLit $ CmmInt imm immrep)
+          CmmLit lit
+            -> do
+                (src, srcCode) <- getSomeReg x
+                let imm = litToImm lit
+                    code dst = srcCode `appOL` toOL [
+                                    ADDIS dst src (HA imm),
+                                    ADD dst dst (RIImm (LO imm))
+                                ]
+                return (Any II32 code)
+          _ -> trivialCode W32 True ADD x y
+
+      MO_Add rep -> trivialCode rep True ADD x y
+      MO_Sub rep ->
+        case y of    -- subfi ('substract from' with immediate) doesn't exist
+          CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (-imm)
+            -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep)
+          _ -> trivialCodeNoImm' (intSize rep) SUBF y x
+
+      MO_Mul rep -> trivialCode rep True MULLW x y
+
+      MO_S_MulMayOflo W32 -> trivialCodeNoImm' II32 MULLW_MayOflo x y
+      
+      MO_S_MulMayOflo rep -> panic "S_MulMayOflo (rep /= II32): not implemented"
+      MO_U_MulMayOflo rep -> panic "U_MulMayOflo: not implemented"
+
+      MO_S_Quot rep -> trivialCodeNoImm' (intSize rep) DIVW (extendSExpr rep x) (extendSExpr rep y)
+      MO_U_Quot rep -> trivialCodeNoImm' (intSize rep) DIVWU (extendUExpr rep x) (extendUExpr rep y)
+      
+      MO_S_Rem rep -> remainderCode rep DIVW (extendSExpr rep x) (extendSExpr rep y)
+      MO_U_Rem rep -> remainderCode rep DIVWU (extendUExpr rep x) (extendUExpr rep y)
+      
+      MO_And rep   -> trivialCode rep False AND x y
+      MO_Or rep    -> trivialCode rep False OR x y
+      MO_Xor rep   -> trivialCode rep False XOR x y
+
+      MO_Shl rep   -> trivialCode rep False SLW x y
+      MO_S_Shr rep -> trivialCode rep False SRAW (extendSExpr rep x) y
+      MO_U_Shr rep -> trivialCode rep False SRW (extendUExpr rep x) y
+      _                -> panic "PPC.CodeGen.getRegister: no match"
+
+  where
+    triv_float :: Width -> (Size -> Reg -> Reg -> Reg -> Instr) -> NatM Register
+    triv_float width instr = trivialCodeNoImm (floatSize width) instr x y
+
+getRegister (CmmLit (CmmInt i rep))
+  | Just imm <- makeImmediate rep True i
+  = let
+       code dst = unitOL (LI dst imm)
+    in
+       return (Any (intSize rep) code)
+
+getRegister (CmmLit (CmmFloat f frep)) = do
+    lbl <- getNewLabelNat
+    dflags <- getDynFlagsNat
+    dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
+    Amode addr addr_code <- getAmode dynRef
+    let size = floatSize frep
+        code dst = 
+           LDATA ReadOnlyData  [CmmDataLabel lbl,
+                                CmmStaticLit (CmmFloat f frep)]
+            `consOL` (addr_code `snocOL` LD size dst addr)
+    return (Any size code)
+
+getRegister (CmmLit lit)
+  = let rep = cmmLitType lit
+        imm = litToImm lit
+        code dst = toOL [
+              LIS dst (HA imm),
+              ADD dst dst (RIImm (LO imm))
+          ]
+    in return (Any (cmmTypeSize rep) code)
+
+getRegister other = pprPanic "getRegister(ppc)" (pprExpr other)
+    
+    -- extend?Rep: wrap integer expression of type rep
+    -- in a conversion to II32
+extendSExpr W32 x = x
+extendSExpr rep x = CmmMachOp (MO_SS_Conv rep W32) [x]
+extendUExpr W32 x = x
+extendUExpr rep x = CmmMachOp (MO_UU_Conv rep W32) [x]
+
+-- -----------------------------------------------------------------------------
+--  The 'Amode' type: Memory addressing modes passed up the tree.
+
+data Amode 
+       = Amode AddrMode InstrBlock
+
+{-
+Now, given a tree (the argument to an CmmLoad) that references memory,
+produce a suitable addressing mode.
+
+A Rule of the Game (tm) for Amodes: use of the addr bit must
+immediately follow use of the code part, since the code part puts
+values in registers which the addr then refers to.  So you can't put
+anything in between, lest it overwrite some of those registers.  If
+you need to do some other computation between the code part and use of
+the addr bit, first store the effective address from the amode in a
+temporary, then do the other computation, and then use the temporary:
+
+    code
+    LEA amode, tmp
+    ... other computation ...
+    ... (tmp) ...
+-}
+
+getAmode :: CmmExpr -> NatM Amode
+getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree)
+
+getAmode (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)])
+  | Just off <- makeImmediate W32 True (-i)
+  = do
+        (reg, code) <- getSomeReg x
+        return (Amode (AddrRegImm reg off) code)
+
+
+getAmode (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)])
+  | Just off <- makeImmediate W32 True i
+  = do
+        (reg, code) <- getSomeReg x
+        return (Amode (AddrRegImm reg off) code)
+
+   -- optimize addition with 32-bit immediate
+   -- (needed for PIC)
+getAmode (CmmMachOp (MO_Add W32) [x, CmmLit lit])
+  = do
+        tmp <- getNewRegNat II32
+        (src, srcCode) <- getSomeReg x
+        let imm = litToImm lit
+            code = srcCode `snocOL` ADDIS tmp src (HA imm)
+        return (Amode (AddrRegImm tmp (LO imm)) code)
+
+getAmode (CmmLit lit)
+  = do
+        tmp <- getNewRegNat II32
+        let imm = litToImm lit
+            code = unitOL (LIS tmp (HA imm))
+        return (Amode (AddrRegImm tmp (LO imm)) code)
+    
+getAmode (CmmMachOp (MO_Add W32) [x, y])
+  = do
+        (regX, codeX) <- getSomeReg x
+        (regY, codeY) <- getSomeReg y
+        return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
+    
+getAmode other
+  = do
+        (reg, code) <- getSomeReg other
+        let
+            off  = ImmInt 0
+        return (Amode (AddrRegImm reg off) code)
+
+
+
+--  The 'CondCode' type:  Condition codes passed up the tree.
+data CondCode  
+       = CondCode Bool Cond InstrBlock
+
+-- Set up a condition code for a conditional branch.
+
+getCondCode :: CmmExpr -> NatM CondCode
+
+-- almost the same as everywhere else - but we need to
+-- extend small integers to 32 bit first
+
+getCondCode (CmmMachOp mop [x, y])
+  = case mop of
+      MO_F_Eq W32 -> condFltCode EQQ x y
+      MO_F_Ne W32 -> condFltCode NE  x y
+      MO_F_Gt W32 -> condFltCode GTT x y
+      MO_F_Ge W32 -> condFltCode GE  x y
+      MO_F_Lt W32 -> condFltCode LTT x y
+      MO_F_Le W32 -> condFltCode LE  x y
+
+      MO_F_Eq W64 -> condFltCode EQQ x y
+      MO_F_Ne W64 -> condFltCode NE  x y
+      MO_F_Gt W64 -> condFltCode GTT x y
+      MO_F_Ge W64 -> condFltCode GE  x y
+      MO_F_Lt W64 -> condFltCode LTT x y
+      MO_F_Le W64 -> condFltCode LE  x y
+
+      MO_Eq rep -> condIntCode EQQ  (extendUExpr rep x) (extendUExpr rep y)
+      MO_Ne rep -> condIntCode NE   (extendUExpr rep x) (extendUExpr rep y)
+
+      MO_S_Gt rep -> condIntCode GTT  (extendSExpr rep x) (extendSExpr rep y)
+      MO_S_Ge rep -> condIntCode GE   (extendSExpr rep x) (extendSExpr rep y)
+      MO_S_Lt rep -> condIntCode LTT  (extendSExpr rep x) (extendSExpr rep y)
+      MO_S_Le rep -> condIntCode LE   (extendSExpr rep x) (extendSExpr rep y)
+
+      MO_U_Gt rep -> condIntCode GU   (extendUExpr rep x) (extendUExpr rep y)
+      MO_U_Ge rep -> condIntCode GEU  (extendUExpr rep x) (extendUExpr rep y)
+      MO_U_Lt rep -> condIntCode LU   (extendUExpr rep x) (extendUExpr rep y)
+      MO_U_Le rep -> condIntCode LEU  (extendUExpr rep x) (extendUExpr rep y)
+
+      other -> pprPanic "getCondCode(powerpc)" (pprMachOp mop)
+
+getCondCode other =  panic "getCondCode(2)(powerpc)"
+
+
+
+-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
+-- passed back up the tree.
+
+condIntCode, condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
+
+--  ###FIXME: I16 and I8!
+condIntCode cond x (CmmLit (CmmInt y rep))
+  | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y
+  = do
+        (src1, code) <- getSomeReg x
+        let
+            code' = code `snocOL` 
+                (if condUnsigned cond then CMPL else CMP) II32 src1 (RIImm src2)
+        return (CondCode False cond code')
+
+condIntCode cond x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let
+       code' = code1 `appOL` code2 `snocOL`
+                 (if condUnsigned cond then CMPL else CMP) II32 src1 (RIReg src2)
+    return (CondCode False cond code')
+
+condFltCode cond x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let
+       code'  = code1 `appOL` code2 `snocOL` FCMP src1 src2
+       code'' = case cond of -- twiddle CR to handle unordered case
+                    GE -> code' `snocOL` CRNOR ltbit eqbit gtbit
+                   LE -> code' `snocOL` CRNOR gtbit eqbit ltbit
+                   _ -> code'
+                 where
+                    ltbit = 0 ; eqbit = 2 ; gtbit = 1
+    return (CondCode True cond code'')
+
+
+
+-- -----------------------------------------------------------------------------
+-- Generating assignments
+
+-- Assignments are really at the heart of the whole code generation
+-- business.  Almost all top-level nodes of any real importance are
+-- assignments, which correspond to loads, stores, or register
+-- transfers.  If we're really lucky, some of the register transfers
+-- will go away, because we can use the destination register to
+-- complete the code generation for the right hand side.  This only
+-- fails when the right hand side is forced into a fixed register
+-- (e.g. the result of a call).
+
+assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_IntCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock
+
+assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_FltCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock
+
+assignMem_IntCode pk addr src = do
+    (srcReg, code) <- getSomeReg src
+    Amode dstAddr addr_code <- getAmode addr
+    return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
+
+-- dst is a reg, but src could be anything
+assignReg_IntCode _ reg src
+    = do
+        r <- getRegister src
+        return $ case r of
+            Any _ code         -> code dst
+            Fixed _ freg fcode -> fcode `snocOL` MR dst freg
+    where
+        dst = getRegisterReg reg
+
+
+
+-- Easy, isn't it?
+assignMem_FltCode = assignMem_IntCode
+assignReg_FltCode = assignReg_IntCode
+
+
+
+genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
+
+genJump (CmmLit (CmmLabel lbl))
+  = return (unitOL $ JMP lbl)
+
+genJump tree
+  = do
+        (target,code) <- getSomeReg tree
+        return (code `snocOL` MTCTR target `snocOL` BCTR [])
+
+
+-- -----------------------------------------------------------------------------
+--  Unconditional branches
+genBranch :: BlockId -> NatM InstrBlock
+genBranch = return . toOL . mkJumpInstr
+
+
+-- -----------------------------------------------------------------------------
+--  Conditional jumps
+
+{-
+Conditional jumps are always to local labels, so we can use branch
+instructions.  We peek at the arguments to decide what kind of
+comparison to do.
+
+SPARC: First, we have to ensure that the condition codes are set
+according to the supplied comparison operation.  We generate slightly
+different code for floating point comparisons, because a floating
+point operation cannot directly precede a @BF@.  We assume the worst
+and fill that slot with a @NOP@.
+
+SPARC: Do not fill the delay slots here; you will confuse the register
+allocator.
+-}
+
+
+genCondJump
+    :: BlockId     -- the branch target
+    -> CmmExpr      -- the condition on which to branch
+    -> NatM InstrBlock
+
+genCondJump id bool = do
+  CondCode _ cond code <- getCondCode bool
+  return (code `snocOL` BCC cond id)
+
+
+
+-- -----------------------------------------------------------------------------
+--  Generating C calls
+
+-- Now the biggest nightmare---calls.  Most of the nastiness is buried in
+-- @get_arg@, which moves the arguments to the correct registers/stack
+-- locations.  Apart from that, the code is easy.
+-- 
+-- (If applicable) Do not fill the delay slots here; you will confuse the
+-- register allocator.
+
+genCCall
+    :: CmmCallTarget           -- function to call
+    -> HintedCmmFormals                -- where to put the result
+    -> HintedCmmActuals                -- arguments (of mixed type)
+    -> NatM InstrBlock
+
+
+#if darwin_TARGET_OS || linux_TARGET_OS
+{-
+    The PowerPC calling convention for Darwin/Mac OS X
+    is described in Apple's document
+    "Inside Mac OS X - Mach-O Runtime Architecture".
+    
+    PowerPC Linux uses the System V Release 4 Calling Convention
+    for PowerPC. It is described in the
+    "System V Application Binary Interface PowerPC Processor Supplement".
+