[project @ 2004-08-13 10:45:16 by simonmar]

[ghc-hetmet.git] / ghc / compiler / nativeGen / MachCode.lhs

diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index 1495416..2876efd 100644 (file)
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -1,5 +1,5 @@
 %
 %

-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998

 %
 \section[MachCode]{Generating machine code}
 
 %
 \section[MachCode]{Generating machine code}
 

@@ -9,75 +9,172 @@ This is a big module, but, if you pay attention to
 structure should not be too overwhelming.
 
 \begin{code}
 structure should not be too overwhelming.
 
 \begin{code}

-module MachCode ( stmt2Instrs, asmVoid, InstrList ) where
+module MachCode ( stmtsToInstrs, InstrBlock ) where

 
 #include "HsVersions.h"
 #include "nativeGen/NCG.h"
 
 import MachMisc                -- may differ per-platform
 import MachRegs
 
 #include "HsVersions.h"
 #include "nativeGen/NCG.h"
 
 import MachMisc                -- may differ per-platform
 import MachRegs

-
-import AbsCSyn         ( MagicId )
+import OrdList         ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
+                         snocOL, consOL, concatOL )
+import MachOp          ( MachOp(..), pprMachOp )

 import AbsCUtils       ( magicIdPrimRep )
 import AbsCUtils       ( magicIdPrimRep )

-import CallConv                ( CallConv )
-import CLabel          ( isAsmTemp, CLabel )
-import Maybes          ( maybeToBool, expectJust )
-import OrdList         -- quite a bit of it
-import PrimRep         ( isFloatingRep, PrimRep(..) )
-import PrimOp          ( PrimOp(..), showPrimOp )
-import CallConv                ( cCallConv )
-import Stix            ( getUniqLabelNCG, StixTree(..),
-                         StixReg(..), CodeSegment(..)
-                       )
-import UniqSupply      ( returnUs, thenUs, mapUs, mapAndUnzipUs,
-                         mapAccumLUs, UniqSM
+import PprAbsC         ( pprMagicId )
+import ForeignCall     ( CCallConv(..) )
+import CLabel          ( CLabel, labelDynamic )
+#if sparc_TARGET_ARCH || alpha_TARGET_ARCH
+import CLabel          ( isAsmTemp )
+#endif
+import Maybes          ( maybeToBool )
+import PrimRep         ( isFloatingRep, is64BitRep, PrimRep(..),
+#if powerpc_TARGET_ARCH
+                         getPrimRepSize,
+#endif
+                         getPrimRepSizeInBytes )
+import Stix            ( getNatLabelNCG, StixStmt(..), StixExpr(..),
+                         StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..), 
+                          DestInfo, hasDestInfo,
+                          pprStixExpr, repOfStixExpr,
+                          NatM, thenNat, returnNat, mapNat, 
+                          mapAndUnzipNat, mapAccumLNat,
+                          getDeltaNat, setDeltaNat, 
+                         IF_ARCH_powerpc(addImportNat COMMA,)
+                          ncgPrimopMoan,
+                         ncg_target_is_32bit

                        )
                        )

-import Outputable
+import Pretty
+import Outputable      ( panic, pprPanic, showSDoc )
+import qualified Outputable
+import CmdLineOpts     ( opt_Static )
+import Stix            ( pprStixStmt )
+
+import Maybe           ( fromMaybe )
+
+-- DEBUGGING ONLY
+import Outputable      ( assertPanic )
+import FastString
+import TRACE           ( trace )
+
+infixr 3 `bind`

 \end{code}
 
 \end{code}
 

-Code extractor for an entire stix tree---stix statement level.
+@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.

 
 \begin{code}
 
 \begin{code}

-stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock
+type InstrBlock = OrdList Instr

 
 

-stmt2Instrs stmt = case stmt of
-    StComment s    -> returnInstr (COMMENT s)
-    StSegment seg  -> returnInstr (SEGMENT seg)
-    StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab))
-    StFunEnd lab   -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id)
-    StLabel lab           -> returnInstr (LABEL lab)
+x `bind` f = f x

 
 

-    StJump arg            -> genJump arg
-    StCondJump lab arg    -> genCondJump lab arg
-    StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep args
+isLeft (Left _)  = True
+isLeft (Right _) = False

 
 

-    StAssign pk dst src
-      | isFloatingRep pk -> assignFltCode pk dst src
-      | otherwise       -> assignIntCode pk dst src
+unLeft (Left x) = x
+\end{code}
+
+Code extractor for an entire stix tree---stix statement level.
+
+\begin{code}
+stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
+stmtsToInstrs stmts
+   = mapNat stmtToInstrs stmts         `thenNat` \ instrss ->
+     returnNat (concatOL instrss)
+
+
+stmtToInstrs :: StixStmt -> NatM InstrBlock
+stmtToInstrs stmt = case stmt of
+    StComment s    -> returnNat (unitOL (COMMENT s))
+    StSegment seg  -> returnNat (unitOL (SEGMENT seg))
+
+    StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
+                                                       LABEL lab)))
+    StFunEnd lab   -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
+                                    returnNat nilOL)
+
+    StLabel lab           -> returnNat (unitOL (LABEL lab))
+
+    StJump dsts arg       -> genJump dsts (derefDLL arg)
+    StCondJump lab arg    -> genCondJump lab (derefDLL arg)
+
+    -- A call returning void, ie one done for its side-effects.  Note
+    -- that this is the only StVoidable we handle.
+    StVoidable (StCall fn cconv VoidRep args) 
+       -> genCCall fn cconv VoidRep (map derefDLL args)
+
+    StAssignMem pk addr src
+      | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
+      | ncg_target_is_32bit
+        && is64BitRep pk -> assignMem_I64Code    (derefDLL addr) (derefDLL src)
+      | otherwise       -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
+    StAssignReg pk reg src
+      | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
+      | ncg_target_is_32bit
+        && is64BitRep pk -> assignReg_I64Code    reg (derefDLL src)
+      | otherwise       -> assignReg_IntCode pk reg (derefDLL src)

 
     StFallThrough lbl
        -- When falling through on the Alpha, we still have to load pv
        -- with the address of the next routine, so that it can load gp.
       -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
 
     StFallThrough lbl
        -- When falling through on the Alpha, we still have to load pv
        -- with the address of the next routine, so that it can load gp.
       -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))

-       ,returnUs id)
+       ,returnNat nilOL)

 
     StData kind args
 
     StData kind args

-      -> mapAndUnzipUs getData args    `thenUs` \ (codes, imms) ->
-        returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms))
-                                   (foldr1 (.) codes xs))
+      -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
+        returnNat (DATA (primRepToSize kind) imms  
+                    `consOL`  concatOL codes)

       where
       where

-       getData :: StixTree -> UniqSM (InstrBlock, Imm)
-
-       getData (StInt i)    = returnUs (id, ImmInteger i)
-       getData (StDouble d) = returnUs (id, dblImmLit d)
-       getData (StLitLbl s) = returnUs (id, ImmLab s)
-       getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
-       getData (StCLbl l)   = returnUs (id, ImmCLbl l)
-       getData (StString s) =
-           getUniqLabelNCG                 `thenUs` \ lbl ->
-           returnUs (mkSeqInstrs [LABEL lbl,
-                                  ASCII True (_UNPK_ s)],
-                                  ImmCLbl lbl)
+       getData :: StixExpr -> NatM (InstrBlock, Imm)
+       getData (StInt i)        = returnNat (nilOL, ImmInteger i)
+       getData (StDouble d)     = returnNat (nilOL, ImmDouble d)
+       getData (StFloat d)      = returnNat (nilOL, ImmFloat d)
+       getData (StCLbl l)       = returnNat (nilOL, ImmCLbl l)
+       getData (StString s)     = panic "MachCode.stmtToInstrs: unlifted StString"
+       -- the linker can handle simple arithmetic...
+       getData (StIndex rep (StCLbl lbl) (StInt off)) =
+               returnNat (nilOL,
+                           ImmIndex lbl (fromInteger off * getPrimRepSizeInBytes rep))
+
+    -- Top-level lifted-out string.  The segment will already have been set
+    -- (see Stix.liftStrings).
+    StDataString str
+      -> returnNat (unitOL (ASCII True (unpackFS str)))
+
+#ifdef DEBUG
+    other -> pprPanic "stmtToInstrs" (pprStixStmt other)
+#endif
+
+-- Walk a Stix tree, and insert dereferences to CLabels which are marked
+-- as labelDynamic.  stmt2Instrs calls derefDLL selectively, because
+-- not all such CLabel occurrences need this dereferencing -- SRTs don't
+-- for one.
+derefDLL :: StixExpr -> StixExpr
+derefDLL tree
+   | opt_Static   -- short out the entire deal if not doing DLLs
+   = tree
+   | otherwise
+   = qq tree
+     where
+        qq t
+           = case t of
+                StCLbl lbl -> if   labelDynamic lbl
+                              then StInd PtrRep (StCLbl lbl)
+                              else t
+                -- all the rest are boring
+                StIndex pk base offset -> StIndex pk (qq base) (qq offset)
+                StMachOp mop args      -> StMachOp mop (map qq args)
+                StInd pk addr          -> StInd pk (qq addr)
+                StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args)
+                StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args)
+                StInt    _             -> t
+                StFloat  _             -> t
+                StDouble _             -> t
+                StString _             -> t
+                StReg    _             -> t
+                _                      -> pprPanic "derefDLL: unhandled case" 
+                                                   (pprStixExpr t)

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -87,79 +184,40 @@ stmt2Instrs stmt = case stmt of
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-type InstrList  = OrdList Instr
-type InstrBlock = InstrList -> InstrList
-
-asmVoid :: InstrList
-asmVoid = mkEmptyList
-
-asmInstr :: Instr -> InstrList
-asmInstr i = mkUnitList i
-
-asmSeq :: [Instr] -> InstrList
-asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
-
-asmParThen :: [InstrList] -> InstrBlock
-asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
-
-returnInstr :: Instr -> UniqSM InstrBlock
-returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
-
-returnInstrs :: [Instr] -> UniqSM InstrBlock
-returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
-
-returnSeq :: InstrBlock -> [Instr] -> UniqSM InstrBlock
-returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
-
-mkSeqInstr :: Instr -> InstrBlock
-mkSeqInstr instr code = mkSeqList (asmInstr instr) code
-
-mkSeqInstrs :: [Instr] -> InstrBlock
-mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
-\end{code}
-
-\begin{code}
-mangleIndexTree :: StixTree -> StixTree
+mangleIndexTree :: StixExpr -> StixExpr

 
 mangleIndexTree (StIndex pk base (StInt i))
 
 mangleIndexTree (StIndex pk base (StInt i))

-  = StPrim IntAddOp [base, off]
+  = StMachOp MO_Nat_Add [base, off]

   where
   where

-    off = StInt (i * sizeOf pk)
+    off = StInt (i * toInteger (getPrimRepSizeInBytes pk))

 
 

-#ifndef i386_TARGET_ARCH

 mangleIndexTree (StIndex pk base off)
 mangleIndexTree (StIndex pk base off)

-  = StPrim IntAddOp [base,
-      case pk of
-       CharRep -> off
-       _       -> let
-                       s = shift pk
-                  in
-                  ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
-                  StPrim SllOp [off, StInt s]
+  = StMachOp MO_Nat_Add [
+       base,
+       let s = shift pk
+       in  if s == 0 then off 
+                     else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]

     ]
   where
     ]
   where

-    shift DoubleRep    = 3::Integer
-    shift _            = IF_ARCH_alpha(3,2)
-#else
--- Hmm..this is an attempt at fixing Adress amodes (i.e., *[disp](base,index,<n>),
--- that do include the size of the primitive kind we're addressing. When StIndex
--- is expanded to actual code, the index (in units) is by the above code approp.
--- shifted to get the no. of bytes. Since Address amodes do contain size info
--- explicitly, we disable the shifting for x86s.
-mangleIndexTree (StIndex pk base off) = StPrim IntAddOp [base, off]
-#endif
-
+    shift :: PrimRep -> Int
+    shift rep = case getPrimRepSizeInBytes rep of
+                   1 -> 0
+                   2 -> 1
+                   4 -> 2
+                   8 -> 3
+                   other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size" 
+                                     (Outputable.int other)

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-maybeImm :: StixTree -> Maybe Imm
-
-maybeImm (StLitLbl s) = Just (ImmLab s)
-maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
-maybeImm (StCLbl   l) = Just (ImmCLbl l)
+maybeImm :: StixExpr -> Maybe Imm

 
 

+maybeImm (StCLbl l)       
+   = Just (ImmCLbl l)
+maybeImm (StIndex rep (StCLbl l) (StInt off)) 
+   = Just (ImmIndex l (fromInteger off * getPrimRepSizeInBytes rep))

 maybeImm (StInt i)
 maybeImm (StInt i)

-  | i >= toInteger minInt && i <= toInteger maxInt
+  | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)

   = Just (ImmInt (fromInteger i))
   | otherwise
   = Just (ImmInteger i)
   = Just (ImmInt (fromInteger i))
   | otherwise
   = Just (ImmInteger i)

@@ -169,6 +227,311 @@ maybeImm _ = Nothing
 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

+\subsection{The @Register64@ type}
+%*                                                                     *
+%************************************************************************
+
+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.
+
+\begin{code}
+
+data ChildCode64       -- a.k.a "Register64"
+   = ChildCode64 
+        InstrBlock     -- code
+        VRegUnique     -- unique for 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 VRegUnique may be modified
+
+assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock
+assignReg_I64Code :: StixReg  -> StixExpr -> NatM InstrBlock
+iselExpr64        :: StixExpr -> NatM ChildCode64
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if i386_TARGET_ARCH
+
+assignMem_I64Code addrTree valueTree
+   = iselExpr64 valueTree              `thenNat` \ (ChildCode64 vcode vrlo) ->
+     getRegister addrTree              `thenNat` \ register_addr ->
+     getNewRegNCG IntRep               `thenNat` \ t_addr ->
+     let rlo = VirtualRegI vrlo
+         rhi = getHiVRegFromLo rlo
+         code_addr = registerCode register_addr t_addr
+         reg_addr  = registerName register_addr t_addr
+         -- Little-endian store
+         mov_lo = MOV L (OpReg rlo)
+                        (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
+         mov_hi = MOV L (OpReg rhi)
+                        (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
+     in
+         returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi)
+
+assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
+   = iselExpr64 valueTree              `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
+     let 
+         r_dst_lo = mkVReg u_dst IntRep
+         r_src_lo = VirtualRegI vr_src_lo
+         r_dst_hi = getHiVRegFromLo r_dst_lo
+         r_src_hi = getHiVRegFromLo r_src_lo
+         mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
+         mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
+     in
+         returnNat (
+            vcode `snocOL` mov_lo `snocOL` mov_hi
+         )
+
+assignReg_I64Code lvalue valueTree
+   = pprPanic "assignReg_I64Code(i386): invalid lvalue"
+              (pprStixReg lvalue)
+
+
+
+iselExpr64 (StInd pk addrTree)
+   | is64BitRep pk
+   = getRegister addrTree              `thenNat` \ register_addr ->
+     getNewRegNCG IntRep               `thenNat` \ t_addr ->
+     getNewRegNCG IntRep               `thenNat` \ rlo ->
+     let rhi = getHiVRegFromLo rlo
+         code_addr = registerCode register_addr t_addr
+         reg_addr  = registerName register_addr t_addr
+         mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
+                        (OpReg rlo)
+         mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
+                        (OpReg rhi)
+     in
+         returnNat (
+            ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi) 
+                        (getVRegUnique rlo)
+         )
+
+iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
+   | is64BitRep pk
+   = getNewRegNCG IntRep               `thenNat` \ r_dst_lo ->
+     let r_dst_hi = getHiVRegFromLo r_dst_lo
+         r_src_lo = mkVReg vu IntRep
+         r_src_hi = getHiVRegFromLo r_src_lo
+         mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
+         mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
+     in
+         returnNat (
+            ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo)
+         )
+         
+iselExpr64 (StCall fn cconv kind args)
+  | is64BitRep kind
+  = genCCall fn cconv kind args                        `thenNat` \ call ->
+    getNewRegNCG IntRep                                `thenNat` \ r_dst_lo ->
+    let r_dst_hi = getHiVRegFromLo r_dst_lo
+        mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo)
+        mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi)
+    in
+    returnNat (
+       ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi) 
+                   (getVRegUnique r_dst_lo)
+    )
+
+iselExpr64 expr
+   = pprPanic "iselExpr64(i386)" (pprStixExpr expr)
+
+#endif /* i386_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if sparc_TARGET_ARCH
+
+assignMem_I64Code addrTree valueTree
+   = iselExpr64 valueTree              `thenNat` \ (ChildCode64 vcode vrlo) ->
+     getRegister addrTree              `thenNat` \ register_addr ->
+     getNewRegNCG IntRep               `thenNat` \ t_addr ->
+     let rlo = VirtualRegI vrlo
+         rhi = getHiVRegFromLo rlo
+         code_addr = registerCode register_addr t_addr
+         reg_addr  = registerName register_addr t_addr
+         -- Big-endian store
+         mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
+         mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
+     in
+         returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
+
+
+assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
+   = iselExpr64 valueTree              `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
+     let 
+         r_dst_lo = mkVReg u_dst IntRep
+         r_src_lo = VirtualRegI vr_src_lo
+         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
+     in
+         returnNat (
+            vcode `snocOL` mov_hi `snocOL` mov_lo
+         )
+assignReg_I64Code lvalue valueTree
+   = pprPanic "assignReg_I64Code(sparc): invalid lvalue"
+              (pprStixReg lvalue)
+
+
+-- Don't delete this -- it's very handy for debugging.
+--iselExpr64 expr 
+--   | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
+--   = panic "iselExpr64(???)"
+
+iselExpr64 (StInd pk addrTree)
+   | is64BitRep pk
+   = getRegister addrTree              `thenNat` \ register_addr ->
+     getNewRegNCG IntRep               `thenNat` \ t_addr ->
+     getNewRegNCG IntRep               `thenNat` \ rlo ->
+     let rhi = getHiVRegFromLo rlo
+         code_addr = registerCode register_addr t_addr
+         reg_addr  = registerName register_addr t_addr
+         mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi
+         mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo
+     in
+         returnNat (
+            ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo) 
+                        (getVRegUnique rlo)
+         )
+
+iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
+   | is64BitRep pk
+   = getNewRegNCG IntRep               `thenNat` \ r_dst_lo ->
+     let r_dst_hi = getHiVRegFromLo r_dst_lo
+         r_src_lo = mkVReg vu IntRep
+         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
+     in
+         returnNat (
+            ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
+         )
+
+iselExpr64 (StCall fn cconv kind args)
+  | is64BitRep kind
+  = genCCall fn cconv kind args                        `thenNat` \ call ->
+    getNewRegNCG IntRep                                `thenNat` \ r_dst_lo ->
+    let r_dst_hi = getHiVRegFromLo r_dst_lo
+        mov_lo = mkMOV o0 r_dst_lo
+        mov_hi = mkMOV o1 r_dst_hi
+        mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
+    in
+    returnNat (
+       ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo) 
+                   (getVRegUnique r_dst_lo)
+    )
+
+iselExpr64 expr
+   = pprPanic "iselExpr64(sparc)" (pprStixExpr expr)
+
+#endif /* sparc_TARGET_ARCH */
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if powerpc_TARGET_ARCH
+
+assignMem_I64Code addrTree valueTree
+   = iselExpr64 valueTree              `thenNat` \ (ChildCode64 vcode vrlo) ->
+     getRegister addrTree              `thenNat` \ register_addr ->
+     getNewRegNCG IntRep               `thenNat` \ t_addr ->
+     let rlo = VirtualRegI vrlo
+         rhi = getHiVRegFromLo rlo
+         code_addr = registerCode register_addr t_addr
+         reg_addr  = registerName register_addr t_addr
+         -- Big-endian store
+         mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
+         mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
+     in
+         returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
+
+
+assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
+   = iselExpr64 valueTree              `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
+     let 
+         r_dst_lo = mkVReg u_dst IntRep
+         r_src_lo = VirtualRegI vr_src_lo
+         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
+         returnNat (
+            vcode `snocOL` mov_hi `snocOL` mov_lo
+         )
+assignReg_I64Code lvalue valueTree
+   = pprPanic "assignReg_I64Code(powerpc): invalid lvalue"
+              (pprStixReg lvalue)
+
+
+-- Don't delete this -- it's very handy for debugging.
+--iselExpr64 expr 
+--   | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
+--   = panic "iselExpr64(???)"
+
+iselExpr64 (StInd pk addrTree)
+   | is64BitRep pk
+   = getRegister addrTree              `thenNat` \ register_addr ->
+     getNewRegNCG IntRep               `thenNat` \ t_addr ->
+     getNewRegNCG IntRep               `thenNat` \ rlo ->
+     let rhi = getHiVRegFromLo rlo
+         code_addr = registerCode register_addr t_addr
+         reg_addr  = registerName register_addr t_addr
+         mov_hi = LD W rhi (AddrRegImm reg_addr (ImmInt 0))
+         mov_lo = LD W rlo (AddrRegImm reg_addr (ImmInt 4))
+     in
+         returnNat (
+            ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo) 
+                        (getVRegUnique rlo)
+         )
+
+iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
+   | is64BitRep pk
+   = getNewRegNCG IntRep               `thenNat` \ r_dst_lo ->
+     let r_dst_hi = getHiVRegFromLo r_dst_lo
+         r_src_lo = mkVReg vu IntRep
+         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
+         returnNat (
+            ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
+         )
+
+iselExpr64 (StCall fn cconv kind args)
+  | is64BitRep kind
+  = genCCall fn cconv kind args                        `thenNat` \ call ->
+    getNewRegNCG IntRep                                `thenNat` \ r_dst_lo ->
+    let r_dst_hi = getHiVRegFromLo r_dst_lo
+        mov_lo = MR r_dst_lo r4
+        mov_hi = MR r_dst_hi r3
+    in
+    returnNat (
+       ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo) 
+                   (getVRegUnique r_dst_lo)
+    )
+
+iselExpr64 expr
+   = pprPanic "iselExpr64(powerpc)" (pprStixExpr expr)
+
+#endif /* powerpc_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+\end{code}
+
+%************************************************************************
+%*                                                                     *

 \subsection{The @Register@ type}
 %*                                                                     *
 %************************************************************************
 \subsection{The @Register@ type}
 %*                                                                     *
 %************************************************************************

@@ -187,50 +550,93 @@ registerCode :: Register -> Reg -> InstrBlock
 registerCode (Fixed _ _ code) reg = code
 registerCode (Any _ code) reg = code reg
 
 registerCode (Fixed _ _ code) reg = code
 registerCode (Any _ code) reg = code reg
 

+registerCodeF (Fixed _ _ code) = code
+registerCodeF (Any _ _)        = panic "registerCodeF"
+
+registerCodeA (Any _ code)  = code
+registerCodeA (Fixed _ _ _) = panic "registerCodeA"
+

 registerName :: Register -> Reg -> Reg
 registerName (Fixed _ reg _) _ = reg
 registerName :: Register -> Reg -> Reg
 registerName (Fixed _ reg _) _ = reg

-registerName (Any   _ _)   reg = reg
+registerName (Any _ _)   reg   = reg
+
+registerNameF (Fixed _ reg _) = reg
+registerNameF (Any _ _)       = panic "registerNameF"

 
 registerRep :: Register -> PrimRep
 registerRep (Fixed pk _ _) = pk
 registerRep (Any   pk _) = pk
 
 
 registerRep :: Register -> PrimRep
 registerRep (Fixed pk _ _) = pk
 registerRep (Any   pk _) = pk
 

-isFixed :: Register -> Bool
+swizzleRegisterRep :: Register -> PrimRep -> Register
+swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
+swizzleRegisterRep (Any _ codefn)     rep = Any rep codefn
+
+{-# INLINE registerCode  #-}
+{-# INLINE registerCodeF #-}
+{-# INLINE registerName  #-}
+{-# INLINE registerNameF #-}
+{-# INLINE registerRep   #-}
+{-# INLINE isFixed       #-}
+{-# INLINE isAny         #-}
+
+isFixed, isAny :: Register -> Bool

 isFixed (Fixed _ _ _) = True
 isFixed (Any _ _)     = False
 isFixed (Fixed _ _ _) = True
 isFixed (Any _ _)     = False

+
+isAny = not . isFixed

 \end{code}
 
 Generate code to get a subtree into a @Register@:
 \begin{code}
 \end{code}
 
 Generate code to get a subtree into a @Register@:
 \begin{code}

-getRegister :: StixTree -> UniqSM Register

 
 

-getRegister (StReg (StixMagicId stgreg))
-  = case (magicIdRegMaybe stgreg) of
-      Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id)
-      -- cannae be Nothing
+getRegisterReg :: StixReg -> NatM Register
+getRegister :: StixExpr -> NatM Register
+
+
+getRegisterReg (StixMagicId mid)
+  = case get_MagicId_reg_or_addr mid of
+       Left (RealReg rrno) 
+          -> let pk = magicIdPrimRep mid
+             in  returnNat (Fixed pk (RealReg rrno) nilOL)
+       Right baseRegAddr 
+          -- By this stage, the only MagicIds remaining should be the
+          -- ones which map to a real machine register on this platform.  Hence ...
+          -> pprPanic "getRegisterReg-memory" (pprMagicId mid)
+
+getRegisterReg (StixTemp (StixVReg u pk))
+  = returnNat (Fixed pk (mkVReg u pk) nilOL)
+
+-------------
+
+-- Don't delete this -- it's very handy for debugging.
+--getRegister expr 
+--   | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
+--   = panic "getRegister(???)"

 
 

-getRegister (StReg (StixTemp u pk))
-  = returnUs (Fixed pk (UnmappedReg u pk) id)
+getRegister (StReg reg) 
+  = getRegisterReg reg

 
 

-getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
+getRegister tree@(StIndex _ _ _) 
+  = getRegister (mangleIndexTree tree)

 
 getRegister (StCall fn cconv kind args)
 
 getRegister (StCall fn cconv kind args)

-  = genCCall fn cconv kind args            `thenUs` \ call ->
-    returnUs (Fixed kind reg call)
+  | not (ncg_target_is_32bit && is64BitRep kind)
+  = genCCall fn cconv kind args            `thenNat` \ call ->
+    returnNat (Fixed kind reg call)

   where
     reg = if isFloatingRep kind
   where
     reg = if isFloatingRep kind

-         then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,)))
-         else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
+         then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0, IF_ARCH_powerpc( f1,))))
+         else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0, IF_ARCH_powerpc( r3,))))

 
 getRegister (StString s)
 
 getRegister (StString s)

-  = getUniqLabelNCG                `thenUs` \ lbl ->
+  = getNatLabelNCG                 `thenNat` \ lbl ->

     let
        imm_lbl = ImmCLbl lbl
 
     let
        imm_lbl = ImmCLbl lbl
 

-       code dst = mkSeqInstrs [
-           SEGMENT DataSegment,
+       code dst = toOL [
+           SEGMENT RoDataSegment,

            LABEL lbl,
            LABEL lbl,

-           ASCII True (_UNPK_ s),
+           ASCII True (unpackFS s),

            SEGMENT TextSegment,
 #if alpha_TARGET_ARCH
            LDA dst (AddrImm imm_lbl)
            SEGMENT TextSegment,
 #if alpha_TARGET_ARCH
            LDA dst (AddrImm imm_lbl)

@@ -242,43 +648,22 @@ getRegister (StString s)
            SETHI (HI imm_lbl) dst,
            OR False dst (RIImm (LO imm_lbl)) dst
 #endif
            SETHI (HI imm_lbl) dst,
            OR False dst (RIImm (LO imm_lbl)) dst
 #endif

-           ]
-    in
-    returnUs (Any PtrRep code)
-
-getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"'
-  = getUniqLabelNCG                `thenUs` \ lbl ->
-    let 
-       imm_lbl = ImmCLbl lbl
-
-       code dst = mkSeqInstrs [
-           SEGMENT DataSegment,
-           LABEL lbl,
-           ASCII False (init xs),
-           SEGMENT TextSegment,
-#if alpha_TARGET_ARCH
-           LDA dst (AddrImm imm_lbl)
-#endif
-#if i386_TARGET_ARCH
-           MOV L (OpImm imm_lbl) (OpReg dst)
-#endif
-#if sparc_TARGET_ARCH
-           SETHI (HI imm_lbl) dst,
-           OR False dst (RIImm (LO imm_lbl)) dst
+#if powerpc_TARGET_ARCH
+           LIS dst (HI imm_lbl),
+           OR dst dst (RIImm (LO imm_lbl))

 #endif
            ]
     in
 #endif
            ]
     in

-    returnUs (Any PtrRep code)
-  where
-    xs = _UNPK_ (_TAIL_ s)
+    returnNat (Any PtrRep code)

 
 

+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 -- end of machine-"independent" bit; here we go on the rest...
 
 #if alpha_TARGET_ARCH
 
 getRegister (StDouble d)
 -- end of machine-"independent" bit; here we go on the rest...
 
 #if alpha_TARGET_ARCH
 
 getRegister (StDouble d)

-  = getUniqLabelNCG                `thenUs` \ lbl ->
-    getNewRegNCG PtrRep            `thenUs` \ tmp ->
+  = getNatLabelNCG                 `thenNat` \ lbl ->
+    getNewRegNCG PtrRep            `thenNat` \ tmp ->

     let code dst = mkSeqInstrs [
            SEGMENT DataSegment,
            LABEL lbl,
     let code dst = mkSeqInstrs [
            SEGMENT DataSegment,
            LABEL lbl,

@@ -287,12 +672,11 @@ getRegister (StDouble d)
            LDA tmp (AddrImm (ImmCLbl lbl)),
            LD TF dst (AddrReg tmp)]
     in
            LDA tmp (AddrImm (ImmCLbl lbl)),
            LD TF dst (AddrReg tmp)]
     in

-       returnUs (Any DoubleRep code)
+       returnNat (Any DoubleRep code)

 
 getRegister (StPrim primop [x]) -- unary PrimOps
   = case primop of
       IntNegOp -> trivialUCode (NEG Q False) x
 
 getRegister (StPrim primop [x]) -- unary PrimOps
   = case primop of
       IntNegOp -> trivialUCode (NEG Q False) x

-      IntAbsOp -> trivialUCode (ABS Q) x

 
       NotOp    -> trivialUCode NOT x
 
 
       NotOp    -> trivialUCode NOT x
 

@@ -310,33 +694,33 @@ getRegister (StPrim primop [x]) -- unary PrimOps
       Double2FloatOp -> coerceFltCode x
       Float2DoubleOp -> coerceFltCode x
 
       Double2FloatOp -> coerceFltCode x
       Float2DoubleOp -> coerceFltCode x
 

-      other_op -> getRegister (StCall fn cconv DoubleRep [x])
+      other_op -> getRegister (StCall fn CCallConv DoubleRep [x])

        where
          fn = case other_op of
        where
          fn = case other_op of

-                FloatExpOp    -> SLIT("exp")
-                FloatLogOp    -> SLIT("log")
-                FloatSqrtOp   -> SLIT("sqrt")
-                FloatSinOp    -> SLIT("sin")
-                FloatCosOp    -> SLIT("cos")
-                FloatTanOp    -> SLIT("tan")
-                FloatAsinOp   -> SLIT("asin")
-                FloatAcosOp   -> SLIT("acos")
-                FloatAtanOp   -> SLIT("atan")
-                FloatSinhOp   -> SLIT("sinh")
-                FloatCoshOp   -> SLIT("cosh")
-                FloatTanhOp   -> SLIT("tanh")
-                DoubleExpOp   -> SLIT("exp")
-                DoubleLogOp   -> SLIT("log")
-                DoubleSqrtOp  -> SLIT("sqrt")
-                DoubleSinOp   -> SLIT("sin")
-                DoubleCosOp   -> SLIT("cos")
-                DoubleTanOp   -> SLIT("tan")
-                DoubleAsinOp  -> SLIT("asin")
-                DoubleAcosOp  -> SLIT("acos")
-                DoubleAtanOp  -> SLIT("atan")
-                DoubleSinhOp  -> SLIT("sinh")
-                DoubleCoshOp  -> SLIT("cosh")
-                DoubleTanhOp  -> SLIT("tanh")
+                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"
 
   where
     pr = panic "MachCode.getRegister: no primrep needed for Alpha"
 

@@ -369,7 +753,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       AddrNeOp -> int_NE_code x y
       AddrLtOp -> trivialCode (CMP ULT) x y
       AddrLeOp -> trivialCode (CMP ULE) 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
       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

@@ -390,6 +774,9 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       IntQuotOp -> trivialCode (DIV Q False) x y
       IntRemOp  -> trivialCode (REM 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
 
       WordQuotOp -> trivialCode (DIV Q True) x y
       WordRemOp  -> trivialCode (REM Q True) x y
 

@@ -403,6 +790,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       DoubleMulOp -> trivialFCode  DoubleRep (FMUL TF) x y
       DoubleDivOp -> trivialFCode  DoubleRep (FDIV TF) x y
 
       DoubleMulOp -> trivialFCode  DoubleRep (FMUL TF) x y
       DoubleDivOp -> trivialFCode  DoubleRep (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
       AndOp  -> trivialCode AND x y
       OrOp   -> trivialCode OR  x y
       XorOp  -> trivialCode XOR x y

@@ -413,8 +804,8 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
       ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
 
       ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
       ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
 

-      FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
-      DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
+      FloatPowerOp  -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
+      DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])

   where
     {- ------------------------------------------------------------
        Some bizarre special code for getting condition codes into
   where
     {- ------------------------------------------------------------
        Some bizarre special code for getting condition codes into

@@ -424,17 +815,17 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
        any kind leave the result in a floating point register, so we
        need to wrangle an integer register out of things.
     -}
        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 -> UniqSM Register
+    int_NE_code :: StixTree -> StixTree -> NatM Register

 
     int_NE_code x y
 
     int_NE_code x y

-      = trivialCode (CMP EQQ) x y      `thenUs` \ register ->
-       getNewRegNCG IntRep             `thenUs` \ tmp ->
+      = trivialCode (CMP EQQ) x y      `thenNat` \ register ->
+       getNewRegNCG IntRep             `thenNat` \ tmp ->

        let
            code = registerCode register tmp
            src  = registerName register tmp
            code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
        in
        let
            code = registerCode register tmp
            src  = registerName register tmp
            code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
        in

-       returnUs (Any IntRep code__2)
+       returnNat (Any IntRep code__2)

 
     {- ------------------------------------------------------------
        Comments for int_NE_code also apply to cmpF_code
 
     {- ------------------------------------------------------------
        Comments for int_NE_code also apply to cmpF_code

@@ -443,12 +834,12 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
        :: (Reg -> Reg -> Reg -> Instr)
        -> Cond
        -> StixTree -> StixTree
        :: (Reg -> Reg -> Reg -> Instr)
        -> Cond
        -> StixTree -> StixTree

-       -> UniqSM Register
+       -> NatM Register

 
     cmpF_code instr cond x y
 
     cmpF_code instr cond x y

-      = trivialFCode pr instr x y      `thenUs` \ register ->
-       getNewRegNCG DoubleRep          `thenUs` \ tmp ->
-       getUniqLabelNCG                 `thenUs` \ lbl ->
+      = trivialFCode pr instr x y      `thenNat` \ register ->
+       getNewRegNCG DoubleRep          `thenNat` \ tmp ->
+       getNatLabelNCG                  `thenNat` \ lbl ->

        let
            code = registerCode register tmp
            result  = registerName register tmp
        let
            code = registerCode register tmp
            result  = registerName register tmp

@@ -459,32 +850,32 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
                OR zeroh (RIReg zeroh) dst,
                LABEL lbl]
        in
                OR zeroh (RIReg zeroh) dst,
                LABEL lbl]
        in

-       returnUs (Any IntRep code__2)
+       returnNat (Any IntRep code__2)

       where
        pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
       ------------------------------------------------------------
 
 getRegister (StInd pk mem)
       where
        pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
       ------------------------------------------------------------
 
 getRegister (StInd pk mem)

-  = getAmode mem                   `thenUs` \ amode ->
+  = getAmode mem                   `thenNat` \ amode ->

     let
        code = amodeCode amode
        src   = amodeAddr amode
        size = primRepToSize pk
        code__2 dst = code . mkSeqInstr (LD size dst src)
     in
     let
        code = amodeCode amode
        src   = amodeAddr amode
        size = primRepToSize pk
        code__2 dst = code . mkSeqInstr (LD size dst src)
     in

-    returnUs (Any pk code__2)
+    returnNat (Any pk code__2)

 
 getRegister (StInt i)
   | fits8Bits i
   = let
        code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
     in
 
 getRegister (StInt i)
   | fits8Bits i
   = let
        code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
     in

-    returnUs (Any IntRep code)
+    returnNat (Any IntRep code)

   | otherwise
   = let
        code dst = mkSeqInstr (LDI Q dst src)
     in
   | otherwise
   = let
        code dst = mkSeqInstr (LDI Q dst src)
     in

-    returnUs (Any IntRep code)
+    returnNat (Any IntRep code)

   where
     src = ImmInt (fromInteger i)
 
   where
     src = ImmInt (fromInteger i)
 

@@ -493,629 +884,911 @@ getRegister leaf
   = let
        code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
     in
   = let
        code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
     in

-    returnUs (Any PtrRep code)
+    returnNat (Any PtrRep code)

   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
 
   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
 

-#endif {- alpha_TARGET_ARCH -}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if i386_TARGET_ARCH
+#endif /* alpha_TARGET_ARCH */

 
 

-getRegister (StDouble 0.0)
-  = let
-       code dst = mkSeqInstrs [FLDZ]
-    in
-    returnUs (Any DoubleRep code)
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 
 

-getRegister (StDouble 1.0)
-  = let
-       code dst = mkSeqInstrs [FLD1]
-    in
-    returnUs (Any DoubleRep code)
+#if i386_TARGET_ARCH

 
 

-getRegister (StDouble d)
-  = getUniqLabelNCG                `thenUs` \ lbl ->
-    --getNewRegNCG PtrRep          `thenUs` \ tmp ->
-    let code dst = mkSeqInstrs [
+getRegister (StFloat f)
+  = getNatLabelNCG                 `thenNat` \ lbl ->
+    let code dst = toOL [

            SEGMENT DataSegment,
            LABEL lbl,
            SEGMENT DataSegment,
            LABEL lbl,

-           DATA DF [dblImmLit d],
+           DATA F [ImmFloat f],

            SEGMENT TextSegment,
            SEGMENT TextSegment,

-           FLD DF (OpImm (ImmCLbl lbl))
+           GLD F (ImmAddr (ImmCLbl lbl) 0) dst

            ]
     in
            ]
     in

-    returnUs (Any DoubleRep code)
+    returnNat (Any FloatRep code)

 
 

-getRegister (StPrim primop [x]) -- unary PrimOps
-  = case primop of
-      IntNegOp  -> trivialUCode (NEGI L) x
-      IntAbsOp  -> absIntCode x
-
-      NotOp    -> trivialUCode (NOT L) x
-
-      FloatNegOp  -> trivialUFCode FloatRep FCHS x
-      FloatSqrtOp -> trivialUFCode FloatRep FSQRT x
-      DoubleNegOp -> trivialUFCode DoubleRep FCHS x

 
 

-      DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
-
-      OrdOp -> coerceIntCode IntRep x
-      ChrOp -> chrCode x
+getRegister (StDouble d)

 
 

-      Float2IntOp  -> coerceFP2Int x
-      Int2FloatOp  -> coerceInt2FP FloatRep x
-      Double2IntOp -> coerceFP2Int x
-      Int2DoubleOp -> coerceInt2FP DoubleRep x
+  | d == 0.0
+  = let code dst = unitOL (GLDZ dst)
+    in  returnNat (Any DoubleRep code)

 
 

-      Double2FloatOp -> coerceFltCode x
-      Float2DoubleOp -> coerceFltCode x
+  | d == 1.0
+  = let code dst = unitOL (GLD1 dst)
+    in  returnNat (Any DoubleRep code)

 
 

-      other_op ->
-        let
-           fixed_x = if is_float_op  -- promote to double
-                         then StPrim Float2DoubleOp [x]
-                         else x
-       in
-       getRegister (StCall fn cCallConv DoubleRep [x])
-       where
+  | otherwise
+  = getNatLabelNCG                 `thenNat` \ lbl ->
+    let code dst = toOL [
+           SEGMENT DataSegment,
+           LABEL lbl,
+           DATA DF [ImmDouble d],
+           SEGMENT TextSegment,
+           GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
+           ]
+    in
+    returnNat (Any DoubleRep code)
+
+
+getRegister (StMachOp mop [x]) -- unary MachOps
+  = case mop of
+      MO_NatS_Neg  -> trivialUCode (NEGI L) x
+      MO_Nat_Not   -> trivialUCode (NOT L) x
+      MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x
+
+      MO_Flt_Neg  -> trivialUFCode FloatRep  (GNEG F) x
+      MO_Dbl_Neg  -> trivialUFCode DoubleRep (GNEG DF) x
+
+      MO_Flt_Sqrt -> trivialUFCode FloatRep  (GSQRT F) x
+      MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
+
+      MO_Flt_Sin  -> trivialUFCode FloatRep  (GSIN F) x
+      MO_Dbl_Sin  -> trivialUFCode DoubleRep (GSIN DF) x
+
+      MO_Flt_Cos  -> trivialUFCode FloatRep  (GCOS F) x
+      MO_Dbl_Cos  -> trivialUFCode DoubleRep (GCOS DF) x
+
+      MO_Flt_Tan  -> trivialUFCode FloatRep  (GTAN F) x
+      MO_Dbl_Tan  -> trivialUFCode DoubleRep (GTAN DF) x
+
+      MO_Flt_to_NatS -> coerceFP2Int FloatRep x
+      MO_NatS_to_Flt -> coerceInt2FP FloatRep x
+      MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
+      MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
+
+      -- Conversions which are a nop on x86
+      MO_32U_to_NatS  -> conversionNop IntRep    x
+      MO_32S_to_NatS  -> conversionNop IntRep    x
+      MO_NatS_to_32U  -> conversionNop WordRep   x
+      MO_32U_to_NatU  -> conversionNop WordRep   x
+
+      MO_NatU_to_NatS -> conversionNop IntRep    x
+      MO_NatS_to_NatU -> conversionNop WordRep   x
+      MO_NatP_to_NatU -> conversionNop WordRep   x
+      MO_NatU_to_NatP -> conversionNop PtrRep    x
+      MO_NatS_to_NatP -> conversionNop PtrRep    x
+      MO_NatP_to_NatS -> conversionNop IntRep    x
+
+      MO_Dbl_to_Flt   -> conversionNop FloatRep  x
+      MO_Flt_to_Dbl   -> conversionNop DoubleRep x
+
+      -- sign-extending widenings
+      MO_8U_to_NatU   -> integerExtend False 24 x
+      MO_8S_to_NatS   -> integerExtend True  24 x
+      MO_16U_to_NatU  -> integerExtend False 16 x
+      MO_16S_to_NatS  -> integerExtend True  16 x
+      MO_8U_to_32U    -> integerExtend False 24 x
+
+      other_op 
+         -> getRegister (
+               (if is_float_op then demote else id)
+               (StCall (Left fn) CCallConv DoubleRep 
+                       [(if is_float_op then promote else id) x])
+            )
+      where
+        integerExtend signed nBits x
+           = getRegister (
+                StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) 
+                         [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
+             )
+
+        conversionNop new_rep expr
+            = getRegister expr         `thenNat` \ e_code ->
+              returnNat (swizzleRegisterRep e_code new_rep)
+
+        promote x = StMachOp MO_Flt_to_Dbl [x]
+        demote  x = StMachOp MO_Dbl_to_Flt [x]

        (is_float_op, fn)
        (is_float_op, fn)

-         = case primop of
-             FloatExpOp    -> (True,  SLIT("exp"))
-             FloatLogOp    -> (True,  SLIT("log"))
-
-             FloatSinOp    -> (True,  SLIT("sin"))
-             FloatCosOp    -> (True,  SLIT("cos"))
-             FloatTanOp    -> (True,  SLIT("tan"))
-
-             FloatAsinOp   -> (True,  SLIT("asin"))
-             FloatAcosOp   -> (True,  SLIT("acos"))
-             FloatAtanOp   -> (True,  SLIT("atan"))
-
-             FloatSinhOp   -> (True,  SLIT("sinh"))
-             FloatCoshOp   -> (True,  SLIT("cosh"))
-             FloatTanhOp   -> (True,  SLIT("tanh"))
-
-             DoubleExpOp   -> (False, SLIT("exp"))
-             DoubleLogOp   -> (False, SLIT("log"))
-
-             DoubleSinOp   -> (False, SLIT("sin"))
-             DoubleCosOp   -> (False, SLIT("cos"))
-             DoubleTanOp   -> (False, SLIT("tan"))
-
-             DoubleAsinOp  -> (False, SLIT("asin"))
-             DoubleAcosOp  -> (False, SLIT("acos"))
-             DoubleAtanOp  -> (False, SLIT("atan"))
-
-             DoubleSinhOp  -> (False, SLIT("sinh"))
-             DoubleCoshOp  -> (False, SLIT("cosh"))
-             DoubleTanhOp  -> (False, SLIT("tanh"))
-
-getRegister (StPrim primop [x, y]) -- dyadic PrimOps
-  = case primop of
-      CharGtOp -> condIntReg GTT x y
-      CharGeOp -> condIntReg GE x y
-      CharEqOp -> condIntReg EQQ x y
-      CharNeOp -> condIntReg NE x y
-      CharLtOp -> condIntReg LTT x y
-      CharLeOp -> condIntReg LE x y
-
-      IntGtOp  -> condIntReg GTT x y
-      IntGeOp  -> condIntReg GE x y
-      IntEqOp  -> condIntReg EQQ x y
-      IntNeOp  -> condIntReg NE x y
-      IntLtOp  -> condIntReg LTT x y
-      IntLeOp  -> condIntReg LE x y
-
-      WordGtOp -> condIntReg GU  x y
-      WordGeOp -> condIntReg GEU x y
-      WordEqOp -> condIntReg EQQ  x y
-      WordNeOp -> condIntReg NE  x y
-      WordLtOp -> condIntReg LU  x y
-      WordLeOp -> condIntReg LEU x y
-
-      AddrGtOp -> condIntReg GU  x y
-      AddrGeOp -> condIntReg GEU x y
-      AddrEqOp -> condIntReg EQQ  x y
-      AddrNeOp -> condIntReg NE  x y
-      AddrLtOp -> condIntReg LU  x y
-      AddrLeOp -> condIntReg LEU x y
-
-      FloatGtOp -> condFltReg GTT x y
-      FloatGeOp -> condFltReg GE x y
-      FloatEqOp -> condFltReg EQQ x y
-      FloatNeOp -> condFltReg NE x y
-      FloatLtOp -> condFltReg LTT x y
-      FloatLeOp -> condFltReg LE x y
-
-      DoubleGtOp -> condFltReg GTT x y
-      DoubleGeOp -> condFltReg GE x y
-      DoubleEqOp -> condFltReg EQQ x y
-      DoubleNeOp -> condFltReg NE x y
-      DoubleLtOp -> condFltReg LTT x y
-      DoubleLeOp -> condFltReg LE x y
-
-      IntAddOp  -> {- ToDo: fix this, whatever it is (WDP 96/04)...
-                  -- this should be optimised by the generic Opts,
-                  -- I don't know why it is not (sometimes)!
-                  case args of
-                   [x, StInt 0] -> getRegister x
-                   _ -> add_code L x y
-                  -}
-                  add_code  L x y
-
-      IntSubOp  -> sub_code  L x y
-      IntQuotOp -> quot_code L x y True{-division-}
-      IntRemOp  -> quot_code L x y False{-remainder-}
-      IntMulOp  -> trivialCode (IMUL L) x y {-True-}
-
-      FloatAddOp -> trivialFCode  FloatRep  FADD FADD  FADDP FADDP  x y
-      FloatSubOp -> trivialFCode  FloatRep  FSUB FSUBR FSUBP FSUBRP x y
-      FloatMulOp -> trivialFCode  FloatRep  FMUL FMUL  FMULP FMULP  x y
-      FloatDivOp -> trivialFCode  FloatRep  FDIV FDIVR FDIVP FDIVRP x y
-
-      DoubleAddOp -> trivialFCode DoubleRep FADD FADD  FADDP FADDP  x y
-      DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y
-      DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL  FMULP FMULP  x y
-      DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y
-
-      AndOp -> trivialCode (AND L) x y {-True-}
-      OrOp  -> trivialCode (OR L)  x y {-True-}
-      XorOp -> trivialCode (XOR L) x y {-True-}
+         = case mop of
+             MO_Flt_Exp   -> (True,  FSLIT("exp"))
+             MO_Flt_Log   -> (True,  FSLIT("log"))
+
+             MO_Flt_Asin  -> (True,  FSLIT("asin"))
+             MO_Flt_Acos  -> (True,  FSLIT("acos"))
+             MO_Flt_Atan  -> (True,  FSLIT("atan"))
+
+             MO_Flt_Sinh  -> (True,  FSLIT("sinh"))
+             MO_Flt_Cosh  -> (True,  FSLIT("cosh"))
+             MO_Flt_Tanh  -> (True,  FSLIT("tanh"))
+
+             MO_Dbl_Exp   -> (False, FSLIT("exp"))
+             MO_Dbl_Log   -> (False, FSLIT("log"))
+
+             MO_Dbl_Asin  -> (False, FSLIT("asin"))
+             MO_Dbl_Acos  -> (False, FSLIT("acos"))
+             MO_Dbl_Atan  -> (False, FSLIT("atan"))
+
+             MO_Dbl_Sinh  -> (False, FSLIT("sinh"))
+             MO_Dbl_Cosh  -> (False, FSLIT("cosh"))
+             MO_Dbl_Tanh  -> (False, FSLIT("tanh"))
+
+              other -> pprPanic "getRegister(x86) - binary StMachOp (2)" 
+                                (pprMachOp mop)
+
+
+getRegister (StMachOp mop [x, y]) -- dyadic MachOps
+  = case mop of
+      MO_32U_Gt  -> condIntReg GTT x y
+      MO_32U_Ge  -> condIntReg GE x y
+      MO_32U_Eq  -> condIntReg EQQ x y
+      MO_32U_Ne  -> condIntReg NE x y
+      MO_32U_Lt  -> condIntReg LTT x y
+      MO_32U_Le  -> condIntReg LE x y
+
+      MO_Nat_Eq   -> condIntReg EQQ x y
+      MO_Nat_Ne   -> condIntReg NE x y
+
+      MO_NatS_Gt  -> condIntReg GTT x y
+      MO_NatS_Ge  -> condIntReg GE x y
+      MO_NatS_Lt  -> condIntReg LTT x y
+      MO_NatS_Le  -> condIntReg LE x y
+
+      MO_NatU_Gt  -> condIntReg GU  x y
+      MO_NatU_Ge  -> condIntReg GEU x y
+      MO_NatU_Lt  -> condIntReg LU  x y
+      MO_NatU_Le  -> condIntReg LEU x y
+
+      MO_Flt_Gt -> condFltReg GTT x y
+      MO_Flt_Ge -> condFltReg GE x y
+      MO_Flt_Eq -> condFltReg EQQ x y
+      MO_Flt_Ne -> condFltReg NE x y
+      MO_Flt_Lt -> condFltReg LTT x y
+      MO_Flt_Le -> condFltReg LE x y
+
+      MO_Dbl_Gt -> condFltReg GTT x y
+      MO_Dbl_Ge -> condFltReg GE x y
+      MO_Dbl_Eq -> condFltReg EQQ x y
+      MO_Dbl_Ne -> condFltReg NE x y
+      MO_Dbl_Lt -> condFltReg LTT x y
+      MO_Dbl_Le -> condFltReg LE x y
+
+      MO_Nat_Add   -> add_code L x y
+      MO_Nat_Sub   -> sub_code L x y
+      MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
+      MO_NatS_Rem  -> trivialCode (IREM L) Nothing x y
+      MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
+      MO_NatU_Rem  -> trivialCode (REM L) Nothing x y
+      MO_NatS_Mul  -> let op = IMUL L in trivialCode op (Just op) x y
+      MO_NatU_Mul  -> let op = MUL L in trivialCode op (Just op) x y
+      MO_NatS_MulMayOflo -> imulMayOflo x y
+
+      MO_Flt_Add -> trivialFCode  FloatRep  GADD x y
+      MO_Flt_Sub -> trivialFCode  FloatRep  GSUB x y
+      MO_Flt_Mul -> trivialFCode  FloatRep  GMUL x y
+      MO_Flt_Div -> trivialFCode  FloatRep  GDIV x y
+
+      MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
+      MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
+      MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
+      MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
+
+      MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
+      MO_Nat_Or  -> let op = OR  L in trivialCode op (Just op) x y
+      MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y

 
        {- Shift ops on x86s have constraints on their source, it
           either has to be Imm, CL or 1
            => trivialCode's is not restrictive enough (sigh.)
 
        {- Shift ops on x86s have constraints on their source, it
           either has to be Imm, CL or 1
            => trivialCode's is not restrictive enough (sigh.)

-       -}
-          
-      SllOp -> shift_code (SHL L) x y {-False-}
-      SrlOp -> shift_code (SHR L) x y {-False-}
-
-      ISllOp -> shift_code (SHL L) x y {-False-}  --was:panic "I386Gen:isll"
-      ISraOp -> shift_code (SAR L) x y {-False-}  --was:panic "I386Gen:isra"
-      ISrlOp -> shift_code (SHR L) x y {-False-}  --was:panic "I386Gen:isrl"
-
-      FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
-                      where promote x = StPrim Float2DoubleOp [x]
-      DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
+       -}         
+      MO_Nat_Shl  -> shift_code (SHL L) x y {-False-}
+      MO_Nat_Shr  -> shift_code (SHR L) x y {-False-}
+      MO_Nat_Sar  -> shift_code (SAR L) x y {-False-}
+
+      MO_Flt_Pwr  -> getRegister (demote 
+                                 (StCall (Left FSLIT("pow")) CCallConv DoubleRep 
+                                         [promote x, promote y])
+                                 )
+      MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep 
+                                        [x, y])
+      other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)

   where
   where

-    shift_code :: (Operand -> Operand -> Instr)
-              -> StixTree
-              -> StixTree
-              -> UniqSM Register
+    promote x = StMachOp MO_Flt_to_Dbl [x]
+    demote x  = StMachOp MO_Dbl_to_Flt [x]
+
+    --------------------
+    imulMayOflo :: StixExpr -> StixExpr -> NatM Register
+    imulMayOflo a1 a2
+       = getNewRegNCG IntRep           `thenNat` \ t1 ->
+         getNewRegNCG IntRep           `thenNat` \ t2 ->
+         getNewRegNCG IntRep           `thenNat` \ res_lo ->
+         getNewRegNCG IntRep           `thenNat` \ res_hi ->
+         getRegister a1                        `thenNat` \ reg1 ->
+         getRegister a2                `thenNat` \ reg2 ->
+         let code1 = registerCode reg1 t1
+             code2 = registerCode reg2 t2
+             src1  = registerName reg1 t1
+             src2  = registerName reg2 t2
+             code dst = code1 `appOL` code2 `appOL`
+                        toOL [
+                           MOV L (OpReg src1) (OpReg res_hi),
+                           MOV L (OpReg src2) (OpReg res_lo),
+                           IMUL64 res_hi res_lo,               -- result in res_hi:res_lo
+                           SAR L (ImmInt 31) (OpReg res_lo),   -- sign extend lower part
+                           SUB L (OpReg res_hi) (OpReg res_lo),        -- compare against upper
+                           MOV L (OpReg res_lo) (OpReg dst)
+                           -- dst==0 if high part == sign extended low part
+                        ]
+         in
+            returnNat (Any IntRep code)
+
+    --------------------
+    shift_code :: (Imm -> Operand -> Instr)
+              -> StixExpr
+              -> StixExpr
+              -> NatM Register
+

       {- Case1: shift length as immediate -}
       -- Code is the same as the first eq. for trivialCode -- sigh.
     shift_code instr x y{-amount-}
       | maybeToBool imm
       {- Case1: shift length as immediate -}
       -- Code is the same as the first eq. for trivialCode -- sigh.
     shift_code instr x y{-amount-}
       | maybeToBool imm

-      = getRegister x          `thenUs` \ register ->
-       let
-           op_imm = OpImm imm__2
-           code__2 dst = 
-               let
-                code  = registerCode  register dst
-                src   = registerName  register dst
-               in
-               mkSeqInstr (COMMENT SLIT("shift_code")) . 
-               code .
-               if isFixed register && src /= dst
-               then
-                  mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
-                               instr op_imm  (OpReg dst)]
-               else
-                  mkSeqInstr (instr op_imm (OpReg src)) 
-       in
-        returnUs (Any IntRep code__2)
+      = getRegister x                     `thenNat` \ regx ->
+        let mkcode dst
+              = if   isAny regx
+                then registerCodeA regx dst  `bind` \ code_x ->
+                     code_x `snocOL`
+                     instr imm__2 (OpReg dst)
+                else registerCodeF regx      `bind` \ code_x ->
+                     registerNameF regx      `bind` \ r_x ->
+                     code_x `snocOL`
+                     MOV L (OpReg r_x) (OpReg dst) `snocOL`
+                     instr imm__2 (OpReg dst)
+        in
+        returnNat (Any IntRep mkcode)        

       where
        imm = maybeImm y
        imm__2 = case imm of Just x -> x
 
       {- Case2: shift length is complex (non-immediate) -}
       where
        imm = maybeImm y
        imm__2 = case imm of Just x -> x
 
       {- Case2: shift length is complex (non-immediate) -}

+      -- Since ECX is always used as a spill temporary, we can't
+      -- use it here to do non-immediate shifts.  No big deal --
+      -- they are only very rare, and we can use an equivalent
+      -- test-and-jump sequence which doesn't use ECX.
+      -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE, 
+      -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER

     shift_code instr x y{-amount-}
     shift_code instr x y{-amount-}

-     = getRegister y           `thenUs` \ register1 ->  
-       getRegister x           `thenUs` \ register2 ->
---       getNewRegNCG IntRep   `thenUs` \ dst ->
-       let
-       -- Note: we force the shift length to be loaded
-       -- into ECX, so that we can use CL when shifting.
-       -- (only register location we are allowed
-       -- to put shift amounts.)
-       -- 
-       -- The shift instruction is fed ECX as src reg,
-       -- but we coerce this into CL when printing out.
-       src1    = registerName register1 ecx
-       code1   = if src1 /= ecx then -- if it is not in ecx already, force it!
-                   registerCode register1 ecx .
-                   mkSeqInstr (MOV L (OpReg src1) (OpReg ecx))
-                 else 
-                   registerCode register1 ecx
-       code__2 = 
-                     let
-                      code2 = registerCode register2 eax
-                      src2  = registerName register2 eax
-                     in
-                     code1 . code2 .
-                     mkSeqInstr (instr (OpReg ecx) (OpReg eax))
+     = getRegister x   `thenNat` \ register1 ->
+       getRegister y   `thenNat` \ register2 ->
+       getNatLabelNCG  `thenNat` \ lbl_test3 ->
+       getNatLabelNCG  `thenNat` \ lbl_test2 ->
+       getNatLabelNCG  `thenNat` \ lbl_test1 ->
+       getNatLabelNCG  `thenNat` \ lbl_test0 ->
+       getNatLabelNCG  `thenNat` \ lbl_after ->
+       getNewRegNCG IntRep   `thenNat` \ tmp ->
+       let code__2 dst
+              = let src_val  = registerName register1 dst
+                    code_val = registerCode register1 dst
+                    src_amt  = registerName register2 tmp
+                    code_amt = registerCode register2 tmp
+                    r_dst    = OpReg dst
+                    r_tmp    = OpReg tmp
+                in
+                    code_amt `snocOL`
+                    MOV L (OpReg src_amt) r_tmp `appOL`
+                    code_val `snocOL`
+                    MOV L (OpReg src_val) r_dst `appOL`
+                    toOL [
+                       COMMENT (mkFastString "begin shift sequence"),
+                       MOV L (OpReg src_val) r_dst,
+                       MOV L (OpReg src_amt) r_tmp,
+
+                       BT L (ImmInt 4) r_tmp,
+                       JXX GEU lbl_test3,
+                       instr (ImmInt 16) r_dst,
+
+                       LABEL lbl_test3,
+                       BT L (ImmInt 3) r_tmp,
+                       JXX GEU lbl_test2,
+                       instr (ImmInt 8) r_dst,
+
+                       LABEL lbl_test2,
+                       BT L (ImmInt 2) r_tmp,
+                       JXX GEU lbl_test1,
+                       instr (ImmInt 4) r_dst,
+
+                       LABEL lbl_test1,
+                       BT L (ImmInt 1) r_tmp,
+                       JXX GEU lbl_test0,
+                       instr (ImmInt 2) r_dst,
+
+                       LABEL lbl_test0,
+                       BT L (ImmInt 0) r_tmp,
+                       JXX GEU lbl_after,
+                       instr (ImmInt 1) r_dst,
+                       LABEL lbl_after,
+                                           
+                       COMMENT (mkFastString "end shift sequence")
+                    ]

        in
        in

-       returnUs (Fixed IntRep eax code__2)
+       returnNat (Any IntRep code__2)

 
 

-    add_code :: Size -> StixTree -> StixTree -> UniqSM Register
+    --------------------
+    add_code :: Size -> StixExpr -> StixExpr -> NatM Register

 
     add_code sz x (StInt y)
 
     add_code sz x (StInt y)

-      = getRegister x          `thenUs` \ register ->
-       getNewRegNCG IntRep     `thenUs` \ tmp ->
+      = getRegister x          `thenNat` \ register ->
+       getNewRegNCG IntRep     `thenNat` \ tmp ->

        let
            code = registerCode register tmp
            src1 = registerName register tmp
            src2 = ImmInt (fromInteger y)
        let
            code = registerCode register tmp
            src1 = registerName register tmp
            src2 = ImmInt (fromInteger y)

-           code__2 dst = code .
-                         mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst))
-       in
-       returnUs (Any IntRep code__2)
-
-    add_code sz x (StInd _ mem)
-      = getRegister x          `thenUs` \ register1 ->
-       --getNewRegNCG (registerRep register1)
-       --                      `thenUs` \ tmp1 ->
-       getAmode mem            `thenUs` \ amode ->
-       let
-           code2 = amodeCode amode
-           src2  = amodeAddr amode
-
---         fixedname  = registerName register1 eax
-           code__2 dst = let code1 = registerCode register1 dst
-                             src1  = registerName register1 dst
-                         in asmParThen [code2 asmVoid,code1 asmVoid] .
-                            if isFixed register1 && src1 /= dst
-                            then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
-                                              ADD sz (OpAddr src2)  (OpReg dst)]
-                            else
-                                   mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
+           code__2 dst 
+               = code `snocOL`
+                LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
+                        (OpReg dst)

        in
        in

-       returnUs (Any IntRep code__2)
+       returnNat (Any IntRep code__2)

 
 

-    add_code sz (StInd _ mem) y
-      = getRegister y          `thenUs` \ register2 ->
-       --getNewRegNCG (registerRep register2)
-       --                      `thenUs` \ tmp2 ->
-       getAmode mem            `thenUs` \ amode ->
-       let
-           code1 = amodeCode amode
-           src1  = amodeAddr amode
-
---         fixedname  = registerName register2 eax
-           code__2 dst = let code2 = registerCode register2 dst
-                             src2  = registerName register2 dst
-                         in asmParThen [code1 asmVoid,code2 asmVoid] .
-                            if isFixed register2 && src2 /= dst
-                            then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
-                                              ADD sz (OpAddr src1)  (OpReg dst)]
-                            else
-                                   mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
-       in
-       returnUs (Any IntRep code__2)
-
-    add_code sz x y
-      = getRegister x          `thenUs` \ register1 ->
-       getRegister y           `thenUs` \ register2 ->
-       getNewRegNCG IntRep     `thenUs` \ tmp1 ->
-       getNewRegNCG IntRep     `thenUs` \ tmp2 ->
-       let
-           code1 = registerCode register1 tmp1 asmVoid
-           src1  = registerName register1 tmp1
-           code2 = registerCode register2 tmp2 asmVoid
-           src2  = registerName register2 tmp2
-           code__2 dst = asmParThen [code1, code2] .
-                         mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
-       in
-       returnUs (Any IntRep code__2)
+    add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y

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

-    sub_code :: Size -> StixTree -> StixTree -> UniqSM Register
+    sub_code :: Size -> StixExpr -> StixExpr -> NatM Register

 
     sub_code sz x (StInt y)
 
     sub_code sz x (StInt y)

-      = getRegister x          `thenUs` \ register ->
-       getNewRegNCG IntRep     `thenUs` \ tmp ->
+      = getRegister x          `thenNat` \ register ->
+       getNewRegNCG IntRep     `thenNat` \ tmp ->

        let
            code = registerCode register tmp
            src1 = registerName register tmp
            src2 = ImmInt (-(fromInteger y))
        let
            code = registerCode register tmp
            src1 = registerName register tmp
            src2 = ImmInt (-(fromInteger y))

-           code__2 dst = code .
-                         mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst))
-       in
-       returnUs (Any IntRep code__2)
-
-    sub_code sz x y = trivialCode (SUB sz) x y {-False-}
-
-    --------------------
-    quot_code
-       :: Size
-       -> StixTree -> StixTree
-       -> Bool -- True => division, False => remainder operation
-       -> UniqSM Register
-
-    -- x must go into eax, edx must be a sign-extension of eax, and y
-    -- should go in some other register (or memory), so that we get
-    -- edx:eax / reg -> eax (remainder in edx) Currently we chose to
-    -- put y in memory (if it is not there already)
-
-    quot_code sz x (StInd pk mem) is_division
-      = getRegister x          `thenUs` \ register1 ->
-       getNewRegNCG IntRep     `thenUs` \ tmp1 ->
-       getAmode mem            `thenUs` \ amode ->
-       let
-           code1   = registerCode register1 tmp1 asmVoid
-           src1    = registerName register1 tmp1
-           code2   = amodeCode amode asmVoid
-           src2    = amodeAddr amode
-           code__2 = asmParThen [code1, code2] .
-                     mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
-                                  CLTD,
-                                  IDIV sz (OpAddr src2)]
-       in
-       returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
-
-    quot_code sz x (StInt i) is_division
-      = getRegister x          `thenUs` \ register1 ->
-       getNewRegNCG IntRep     `thenUs` \ tmp1 ->
-       let
-           code1   = registerCode register1 tmp1 asmVoid
-           src1    = registerName register1 tmp1
-           src2    = ImmInt (fromInteger i)
-           code__2 = asmParThen [code1] .
-                     mkSeqInstrs [-- we put src2 in (ebx)
-                                  MOV L (OpImm src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
-                                  MOV L (OpReg src1) (OpReg eax),
-                                  CLTD,
-                                  IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+           code__2 dst 
+               = code `snocOL`
+                LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
+                        (OpReg dst)

        in
        in

-       returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
+       returnNat (Any IntRep code__2)

 
 

-    quot_code sz x y is_division
-      = getRegister x          `thenUs` \ register1 ->
-       getNewRegNCG IntRep     `thenUs` \ tmp1 ->
-       getRegister y           `thenUs` \ register2 ->
-       getNewRegNCG IntRep     `thenUs` \ tmp2 ->
-       let
-           code1   = registerCode register1 tmp1 asmVoid
-           src1    = registerName register1 tmp1
-           code2   = registerCode register2 tmp2 asmVoid
-           src2    = registerName register2 tmp2
-           code__2 = asmParThen [code1, code2] .
-                     if src2 == ecx || src2 == esi
-                     then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
-                                        CLTD,
-                                        IDIV sz (OpReg src2)]
-                     else mkSeqInstrs [ -- we put src2 in (ebx)
-                                        MOV L (OpReg src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
-                                        MOV L (OpReg src1) (OpReg eax),
-                                        CLTD,
-                                        IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))]
-       in
-       returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
-       -----------------------
+    sub_code sz x y = trivialCode (SUB sz) Nothing x y

 
 getRegister (StInd pk mem)
 
 getRegister (StInd pk mem)

-  = getAmode mem                   `thenUs` \ amode ->
+  | not (is64BitRep pk)
+  = getAmode mem                   `thenNat` \ amode ->

     let
        code = amodeCode amode
     let
        code = amodeCode amode

-       src   = amodeAddr amode
+       src  = amodeAddr amode

        size = primRepToSize pk
        size = primRepToSize pk

-       code__2 dst = code .
-                     if pk == DoubleRep || pk == FloatRep
-                     then mkSeqInstr (FLD {-DF-} size (OpAddr src))
-                     else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
+       code__2 dst = code `snocOL`
+                     if   pk == DoubleRep || pk == FloatRep
+                     then GLD size src dst
+                     else (case size of
+                               B  -> MOVSxL B
+                               Bu -> MOVZxL Bu
+                               W  -> MOVSxL W
+                               Wu -> MOVZxL Wu
+                               L  -> MOV L
+                               Lu -> MOV L)
+                               (OpAddr src) (OpReg dst)

     in
     in

-       returnUs (Any pk code__2)
-
+       returnNat (Any pk code__2)

 
 getRegister (StInt i)
   = let
        src = ImmInt (fromInteger i)
 
 getRegister (StInt i)
   = let
        src = ImmInt (fromInteger i)

-       code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
+       code dst 
+           | i == 0
+           = unitOL (XOR L (OpReg dst) (OpReg dst))
+           | otherwise
+           = unitOL (MOV L (OpImm src) (OpReg dst))

     in
     in

-       returnUs (Any IntRep code)
+       returnNat (Any IntRep code)

 
 getRegister leaf
   | maybeToBool imm
 
 getRegister leaf
   | maybeToBool imm

-  = let
-       code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
+  = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))

     in
     in

-       returnUs (Any PtrRep code)
+       returnNat (Any PtrRep code)
+  | otherwise
+  = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)

   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
 
   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
 

-#endif {- i386_TARGET_ARCH -}
+#endif /* i386_TARGET_ARCH */
+

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

+

 #if sparc_TARGET_ARCH
 
 #if sparc_TARGET_ARCH
 

+getRegister (StFloat d)
+  = getNatLabelNCG                 `thenNat` \ lbl ->
+    getNewRegNCG PtrRep            `thenNat` \ tmp ->
+    let code dst = toOL [
+           SEGMENT DataSegment,
+           LABEL lbl,
+           DATA F [ImmFloat d],
+           SEGMENT TextSegment,
+           SETHI (HI (ImmCLbl lbl)) tmp,
+           LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
+    in
+       returnNat (Any FloatRep code)
+

 getRegister (StDouble d)
 getRegister (StDouble d)

-  = getUniqLabelNCG                `thenUs` \ lbl ->
-    getNewRegNCG PtrRep            `thenUs` \ tmp ->
-    let code dst = mkSeqInstrs [
+  = getNatLabelNCG                 `thenNat` \ lbl ->
+    getNewRegNCG PtrRep            `thenNat` \ tmp ->
+    let code dst = toOL [

            SEGMENT DataSegment,
            LABEL lbl,
            SEGMENT DataSegment,
            LABEL lbl,

-           DATA DF [dblImmLit d],
+           DATA DF [ImmDouble d],

            SEGMENT TextSegment,
            SETHI (HI (ImmCLbl lbl)) tmp,
            LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
     in
            SEGMENT TextSegment,
            SETHI (HI (ImmCLbl lbl)) tmp,
            LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
     in

-       returnUs (Any DoubleRep code)
-
-getRegister (StPrim primop [x]) -- unary PrimOps
-  = case primop of
-      IntNegOp -> trivialUCode (SUB False False g0) x
-      IntAbsOp -> absIntCode x
-      NotOp    -> trivialUCode (XNOR False g0) x
-
-      FloatNegOp  -> trivialUFCode FloatRep (FNEG F) x
-
-      DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
-
-      Double2FloatOp -> trivialUFCode FloatRep  (FxTOy DF F) x
-      Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
-
-      OrdOp -> coerceIntCode IntRep x
-      ChrOp -> chrCode x
-
-      Float2IntOp  -> coerceFP2Int x
-      Int2FloatOp  -> coerceInt2FP FloatRep x
-      Double2IntOp -> coerceFP2Int x
-      Int2DoubleOp -> coerceInt2FP DoubleRep x
+       returnNat (Any DoubleRep code)
+
+
+getRegister (StMachOp mop [x]) -- unary PrimOps
+  = case mop of
+      MO_NatS_Neg      -> trivialUCode (SUB False False g0) x
+      MO_Nat_Not       -> trivialUCode (XNOR False g0) x
+      MO_32U_to_8U     -> trivialCode (AND False) x (StInt 255)
+
+      MO_Flt_Neg       -> trivialUFCode FloatRep (FNEG F) x
+      MO_Dbl_Neg       -> trivialUFCode DoubleRep (FNEG DF) x
+
+      MO_Dbl_to_Flt    -> coerceDbl2Flt x
+      MO_Flt_to_Dbl    -> coerceFlt2Dbl x
+
+      MO_Flt_to_NatS   -> coerceFP2Int FloatRep x
+      MO_NatS_to_Flt   -> coerceInt2FP FloatRep x
+      MO_Dbl_to_NatS   -> coerceFP2Int DoubleRep x
+      MO_NatS_to_Dbl   -> coerceInt2FP DoubleRep x
+
+      -- Conversions which are a nop on sparc
+      MO_32U_to_NatS   -> conversionNop IntRep   x
+      MO_32S_to_NatS  -> conversionNop IntRep   x
+      MO_NatS_to_32U   -> conversionNop WordRep  x
+      MO_32U_to_NatU   -> conversionNop WordRep  x
+
+      MO_NatU_to_NatS -> conversionNop IntRep    x
+      MO_NatS_to_NatU -> conversionNop WordRep   x
+      MO_NatP_to_NatU -> conversionNop WordRep   x
+      MO_NatU_to_NatP -> conversionNop PtrRep    x
+      MO_NatS_to_NatP -> conversionNop PtrRep    x
+      MO_NatP_to_NatS -> conversionNop IntRep    x
+
+      -- sign-extending widenings
+      MO_8U_to_32U    -> integerExtend False 24 x
+      MO_8U_to_NatU   -> integerExtend False 24 x
+      MO_8S_to_NatS   -> integerExtend True  24 x
+      MO_16U_to_NatU  -> integerExtend False 16 x
+      MO_16S_to_NatS  -> integerExtend True  16 x

 
       other_op ->
 
       other_op ->

-        let
-           fixed_x = if is_float_op  -- promote to double
-                         then StPrim Float2DoubleOp [x]
-                         else x
+        let fixed_x = if   is_float_op  -- promote to double
+                      then StMachOp MO_Flt_to_Dbl [x]
+                      else x

        in
        in

-       getRegister (StCall fn cCallConv DoubleRep [x])
-       where
-       (is_float_op, fn)
-         = case primop of
-             FloatExpOp    -> (True,  SLIT("exp"))
-             FloatLogOp    -> (True,  SLIT("log"))
-             FloatSqrtOp   -> (True,  SLIT("sqrt"))
-
-             FloatSinOp    -> (True,  SLIT("sin"))
-             FloatCosOp    -> (True,  SLIT("cos"))
-             FloatTanOp    -> (True,  SLIT("tan"))
+       getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x])
+    where
+        integerExtend signed nBits x
+           = getRegister (
+                StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) 
+                         [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
+             )
+        conversionNop new_rep expr
+            = getRegister expr         `thenNat` \ e_code ->
+              returnNat (swizzleRegisterRep e_code new_rep)

 
 

-             FloatAsinOp   -> (True,  SLIT("asin"))
-             FloatAcosOp   -> (True,  SLIT("acos"))
-             FloatAtanOp   -> (True,  SLIT("atan"))
+       (is_float_op, fn)
+         = case mop of
+             MO_Flt_Exp    -> (True,  FSLIT("exp"))
+             MO_Flt_Log    -> (True,  FSLIT("log"))
+             MO_Flt_Sqrt   -> (True,  FSLIT("sqrt"))
+
+             MO_Flt_Sin    -> (True,  FSLIT("sin"))
+             MO_Flt_Cos    -> (True,  FSLIT("cos"))
+             MO_Flt_Tan    -> (True,  FSLIT("tan"))
+
+             MO_Flt_Asin   -> (True,  FSLIT("asin"))
+             MO_Flt_Acos   -> (True,  FSLIT("acos"))
+             MO_Flt_Atan   -> (True,  FSLIT("atan"))
+
+             MO_Flt_Sinh   -> (True,  FSLIT("sinh"))
+             MO_Flt_Cosh   -> (True,  FSLIT("cosh"))
+             MO_Flt_Tanh   -> (True,  FSLIT("tanh"))
+
+             MO_Dbl_Exp    -> (False, FSLIT("exp"))
+             MO_Dbl_Log    -> (False, FSLIT("log"))
+             MO_Dbl_Sqrt   -> (False, FSLIT("sqrt"))
+
+             MO_Dbl_Sin    -> (False, FSLIT("sin"))
+             MO_Dbl_Cos    -> (False, FSLIT("cos"))
+             MO_Dbl_Tan    -> (False, FSLIT("tan"))
+
+             MO_Dbl_Asin   -> (False, FSLIT("asin"))
+             MO_Dbl_Acos   -> (False, FSLIT("acos"))
+             MO_Dbl_Atan   -> (False, FSLIT("atan"))
+
+             MO_Dbl_Sinh   -> (False, FSLIT("sinh"))
+             MO_Dbl_Cosh   -> (False, FSLIT("cosh"))
+             MO_Dbl_Tanh   -> (False, FSLIT("tanh"))
+
+              other -> pprPanic "getRegister(sparc) - binary StMachOp (2)" 
+                                (pprMachOp mop)
+
+
+getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
+  = case mop of
+      MO_32U_Gt  -> condIntReg GTT x y
+      MO_32U_Ge  -> condIntReg GE x y
+      MO_32U_Eq  -> condIntReg EQQ x y
+      MO_32U_Ne  -> condIntReg NE x y
+      MO_32U_Lt  -> condIntReg LTT x y
+      MO_32U_Le  -> condIntReg LE x y
+
+      MO_Nat_Eq   -> condIntReg EQQ x y
+      MO_Nat_Ne   -> condIntReg NE x y
+
+      MO_NatS_Gt  -> condIntReg GTT x y
+      MO_NatS_Ge  -> condIntReg GE x y
+      MO_NatS_Lt  -> condIntReg LTT x y
+      MO_NatS_Le  -> condIntReg LE x y
+
+      MO_NatU_Gt  -> condIntReg GU  x y
+      MO_NatU_Ge  -> condIntReg GEU x y
+      MO_NatU_Lt  -> condIntReg LU  x y
+      MO_NatU_Le  -> condIntReg LEU x y
+
+      MO_Flt_Gt -> condFltReg GTT x y
+      MO_Flt_Ge -> condFltReg GE x y
+      MO_Flt_Eq -> condFltReg EQQ x y
+      MO_Flt_Ne -> condFltReg NE x y
+      MO_Flt_Lt -> condFltReg LTT x y
+      MO_Flt_Le -> condFltReg LE x y
+
+      MO_Dbl_Gt -> condFltReg GTT x y
+      MO_Dbl_Ge -> condFltReg GE x y
+      MO_Dbl_Eq -> condFltReg EQQ x y
+      MO_Dbl_Ne -> condFltReg NE x y
+      MO_Dbl_Lt -> condFltReg LTT x y
+      MO_Dbl_Le -> condFltReg LE x y
+
+      MO_Nat_Add -> trivialCode (ADD False False) x y
+      MO_Nat_Sub -> trivialCode (SUB False False) x y
+
+      MO_NatS_Mul  -> trivialCode (SMUL False) x y
+      MO_NatU_Mul  -> trivialCode (UMUL False) x y
+      MO_NatS_MulMayOflo -> imulMayOflo x y
+
+      -- ToDo: teach about V8+ SPARC div instructions
+      MO_NatS_Quot -> idiv FSLIT(".div")  x y
+      MO_NatS_Rem  -> idiv FSLIT(".rem")  x y
+      MO_NatU_Quot -> idiv FSLIT(".udiv")  x y
+      MO_NatU_Rem  -> idiv FSLIT(".urem")  x y
+
+      MO_Flt_Add   -> trivialFCode FloatRep  FADD x y
+      MO_Flt_Sub   -> trivialFCode FloatRep  FSUB x y
+      MO_Flt_Mul   -> trivialFCode FloatRep  FMUL x y
+      MO_Flt_Div   -> trivialFCode FloatRep  FDIV x y
+
+      MO_Dbl_Add   -> trivialFCode DoubleRep FADD x y
+      MO_Dbl_Sub   -> trivialFCode DoubleRep FSUB x y
+      MO_Dbl_Mul   -> trivialFCode DoubleRep FMUL x y
+      MO_Dbl_Div   -> trivialFCode DoubleRep FDIV x y
+
+      MO_Nat_And   -> trivialCode (AND False) x y
+      MO_Nat_Or    -> trivialCode (OR  False) x y
+      MO_Nat_Xor   -> trivialCode (XOR False) x y
+
+      MO_Nat_Shl   -> trivialCode SLL x y
+      MO_Nat_Shr   -> trivialCode SRL x y
+      MO_Nat_Sar   -> trivialCode SRA x y
+
+      MO_Flt_Pwr  -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep 
+                                         [promote x, promote y])
+                      where promote x = StMachOp MO_Flt_to_Dbl [x]
+      MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep 
+                                        [x, y])
+
+      other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
+  where
+    idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])

 
 

-             FloatSinhOp   -> (True,  SLIT("sinh"))
-             FloatCoshOp   -> (True,  SLIT("cosh"))
-             FloatTanhOp   -> (True,  SLIT("tanh"))
+    --------------------
+    imulMayOflo :: StixExpr -> StixExpr -> NatM Register
+    imulMayOflo a1 a2
+       = getNewRegNCG IntRep           `thenNat` \ t1 ->
+         getNewRegNCG IntRep           `thenNat` \ t2 ->
+         getNewRegNCG IntRep           `thenNat` \ res_lo ->
+         getNewRegNCG IntRep           `thenNat` \ res_hi ->
+         getRegister a1                        `thenNat` \ reg1 ->
+         getRegister a2                `thenNat` \ reg2 ->
+         let code1 = registerCode reg1 t1
+             code2 = registerCode reg2 t2
+             src1  = registerName reg1 t1
+             src2  = registerName reg2 t2
+             code dst = code1 `appOL` code2 `appOL`
+                        toOL [
+                           SMUL False src1 (RIReg src2) res_lo,
+                           RDY res_hi,
+                           SRA res_lo (RIImm (ImmInt 31)) res_lo,
+                           SUB False False res_lo (RIReg res_hi) dst
+                        ]
+         in
+            returnNat (Any IntRep code)

 
 

-             DoubleExpOp   -> (False, SLIT("exp"))
-             DoubleLogOp   -> (False, SLIT("log"))
-             DoubleSqrtOp  -> (True,  SLIT("sqrt"))
+getRegister (StInd pk mem)
+  = getAmode mem                   `thenNat` \ amode ->
+    let
+       code = amodeCode amode
+       src   = amodeAddr amode
+       size = primRepToSize pk
+       code__2 dst = code `snocOL` LD size src dst
+    in
+       returnNat (Any pk code__2)

 
 

-             DoubleSinOp   -> (False, SLIT("sin"))
-             DoubleCosOp   -> (False, SLIT("cos"))
-             DoubleTanOp   -> (False, SLIT("tan"))
+getRegister (StInt i)
+  | fits13Bits i
+  = let
+       src = ImmInt (fromInteger i)
+       code dst = unitOL (OR False g0 (RIImm src) dst)
+    in
+       returnNat (Any IntRep code)

 
 

-             DoubleAsinOp  -> (False, SLIT("asin"))
-             DoubleAcosOp  -> (False, SLIT("acos"))
-             DoubleAtanOp  -> (False, SLIT("atan"))
+getRegister leaf
+  | maybeToBool imm
+  = let
+       code dst = toOL [
+           SETHI (HI imm__2) dst,
+           OR False dst (RIImm (LO imm__2)) dst]
+    in
+       returnNat (Any PtrRep code)
+  | otherwise
+  = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
+  where
+    imm = maybeImm leaf
+    imm__2 = case imm of Just x -> x

 
 

-             DoubleSinhOp  -> (False, SLIT("sinh"))
-             DoubleCoshOp  -> (False, SLIT("cosh"))
-             DoubleTanhOp  -> (False, SLIT("tanh"))
-             _             -> panic ("Monadic PrimOp not handled: " ++ showPrimOp primop)
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+getRegister (StMachOp mop [x]) -- unary MachOps
+  = case mop of
+      MO_NatS_Neg  -> trivialUCode NEG x
+      MO_Nat_Not   -> trivialUCode NOT x
+      MO_32U_to_8U     -> trivialCode AND x (StInt 255)
+
+      MO_Flt_to_NatS -> coerceFP2Int FloatRep x
+      MO_NatS_to_Flt -> coerceInt2FP FloatRep x
+      MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
+      MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
+
+      -- Conversions which are a nop on PPC
+      MO_NatS_to_32U  -> conversionNop WordRep   x
+      MO_32U_to_NatS  -> conversionNop IntRep    x
+      MO_32U_to_NatU  -> conversionNop WordRep   x
+
+      MO_NatU_to_NatS -> conversionNop IntRep    x
+      MO_NatS_to_NatU -> conversionNop WordRep   x
+      MO_NatP_to_NatU -> conversionNop WordRep   x
+      MO_NatU_to_NatP -> conversionNop PtrRep    x
+      MO_NatS_to_NatP -> conversionNop PtrRep    x
+      MO_NatP_to_NatS -> conversionNop IntRep    x
+
+      MO_Dbl_to_Flt   -> conversionNop FloatRep  x
+      MO_Flt_to_Dbl   -> conversionNop DoubleRep x
+
+      -- sign-extending widenings      ###PPC This is inefficient: use ext* instructions
+      MO_8U_to_NatU   -> integerExtend False 24 x
+      MO_8S_to_NatS   -> integerExtend True  24 x
+      MO_16U_to_NatU  -> integerExtend False 16 x
+      MO_16S_to_NatS  -> integerExtend True  16 x
+      MO_8U_to_32U    -> integerExtend False 24 x
+
+      MO_Flt_Neg      -> trivialUFCode FloatRep FNEG x
+      MO_Dbl_Neg      -> trivialUFCode FloatRep FNEG x
+
+      other_op -> getRegister (StCall (Left fn) CCallConv DoubleRep [x])
+    where
+        integerExtend signed nBits x
+           = getRegister (
+                StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) 
+                         [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
+             )
+        conversionNop new_rep expr
+            = getRegister expr         `thenNat` \ e_code ->
+              returnNat (swizzleRegisterRep e_code new_rep)

 
 

-getRegister (StPrim primop [x, y]) -- dyadic PrimOps
-  = case primop of
-      CharGtOp -> condIntReg GTT x y
-      CharGeOp -> condIntReg GE x y
-      CharEqOp -> condIntReg EQQ x y
-      CharNeOp -> condIntReg NE x y
-      CharLtOp -> condIntReg LTT x y
-      CharLeOp -> condIntReg LE x y
-
-      IntGtOp  -> condIntReg GTT x y
-      IntGeOp  -> condIntReg GE x y
-      IntEqOp  -> condIntReg EQQ x y
-      IntNeOp  -> condIntReg NE x y
-      IntLtOp  -> condIntReg LTT x y
-      IntLeOp  -> condIntReg LE x y
-
-      WordGtOp -> condIntReg GU  x y
-      WordGeOp -> condIntReg GEU x y
-      WordEqOp -> condIntReg EQQ  x y
-      WordNeOp -> condIntReg NE  x y
-      WordLtOp -> condIntReg LU  x y
-      WordLeOp -> condIntReg LEU x y
-
-      AddrGtOp -> condIntReg GU  x y
-      AddrGeOp -> condIntReg GEU x y
-      AddrEqOp -> condIntReg EQQ  x y
-      AddrNeOp -> condIntReg NE  x y
-      AddrLtOp -> condIntReg LU  x y
-      AddrLeOp -> condIntReg LEU x y
-
-      FloatGtOp -> condFltReg GTT x y
-      FloatGeOp -> condFltReg GE x y
-      FloatEqOp -> condFltReg EQQ x y
-      FloatNeOp -> condFltReg NE x y
-      FloatLtOp -> condFltReg LTT x y
-      FloatLeOp -> condFltReg LE x y
-
-      DoubleGtOp -> condFltReg GTT x y
-      DoubleGeOp -> condFltReg GE x y
-      DoubleEqOp -> condFltReg EQQ x y
-      DoubleNeOp -> condFltReg NE x y
-      DoubleLtOp -> condFltReg LTT x y
-      DoubleLeOp -> condFltReg LE x y
-
-      IntAddOp -> trivialCode (ADD False False) x y
-      IntSubOp -> trivialCode (SUB False False) x y
-
-       -- ToDo: teach about V8+ SPARC mul/div instructions
-      IntMulOp    -> imul_div SLIT(".umul") x y
-      IntQuotOp   -> imul_div SLIT(".div")  x y
-      IntRemOp    -> imul_div SLIT(".rem")  x y
-
-      FloatAddOp  -> trivialFCode FloatRep  FADD x y
-      FloatSubOp  -> trivialFCode FloatRep  FSUB x y
-      FloatMulOp  -> trivialFCode FloatRep  FMUL x y
-      FloatDivOp  -> trivialFCode FloatRep  FDIV x y
-
-      DoubleAddOp -> trivialFCode DoubleRep FADD x y
-      DoubleSubOp -> trivialFCode DoubleRep FSUB x y
-      DoubleMulOp -> trivialFCode DoubleRep FMUL x y
-      DoubleDivOp -> trivialFCode DoubleRep FDIV x y
-
-      AndOp -> trivialCode (AND False) x y
-      OrOp  -> trivialCode (OR  False) x y
-      XorOp -> trivialCode (XOR False) x y
-      SllOp -> trivialCode SLL x y
-      SrlOp -> trivialCode SRL x y
-
-      ISllOp -> trivialCode SLL x y  --was: panic "SparcGen:isll"
-      ISraOp -> trivialCode SRA x y  --was: panic "SparcGen:isra"
-      ISrlOp -> trivialCode SRL x y  --was: panic "SparcGen:isrl"
-
-      FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
-                      where promote x = StPrim Float2DoubleOp [x]
-      DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
---      _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!"
-  where
-    imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
+       (is_float_op, fn)
+         = case mop of
+             MO_Flt_Exp    -> (True,  FSLIT("exp"))
+             MO_Flt_Log    -> (True,  FSLIT("log"))
+             MO_Flt_Sqrt   -> (True,  FSLIT("sqrt"))
+
+             MO_Flt_Sin    -> (True,  FSLIT("sin"))
+             MO_Flt_Cos    -> (True,  FSLIT("cos"))
+             MO_Flt_Tan    -> (True,  FSLIT("tan"))
+
+             MO_Flt_Asin   -> (True,  FSLIT("asin"))
+             MO_Flt_Acos   -> (True,  FSLIT("acos"))
+             MO_Flt_Atan   -> (True,  FSLIT("atan"))
+
+             MO_Flt_Sinh   -> (True,  FSLIT("sinh"))
+             MO_Flt_Cosh   -> (True,  FSLIT("cosh"))
+             MO_Flt_Tanh   -> (True,  FSLIT("tanh"))
+
+             MO_Dbl_Exp    -> (False, FSLIT("exp"))
+             MO_Dbl_Log    -> (False, FSLIT("log"))
+             MO_Dbl_Sqrt   -> (False, FSLIT("sqrt"))
+
+             MO_Dbl_Sin    -> (False, FSLIT("sin"))
+             MO_Dbl_Cos    -> (False, FSLIT("cos"))
+             MO_Dbl_Tan    -> (False, FSLIT("tan"))
+
+             MO_Dbl_Asin   -> (False, FSLIT("asin"))
+             MO_Dbl_Acos   -> (False, FSLIT("acos"))
+             MO_Dbl_Atan   -> (False, FSLIT("atan"))
+
+             MO_Dbl_Sinh   -> (False, FSLIT("sinh"))
+             MO_Dbl_Cosh   -> (False, FSLIT("cosh"))
+             MO_Dbl_Tanh   -> (False, FSLIT("tanh"))
+             
+             other -> pprPanic "getRegister(powerpc) - unary StMachOp" 
+                                (pprMachOp mop)
+
+
+getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
+  = case mop of
+      MO_32U_Gt  -> condIntReg GTT x y
+      MO_32U_Ge  -> condIntReg GE x y
+      MO_32U_Eq  -> condIntReg EQQ x y
+      MO_32U_Ne  -> condIntReg NE x y
+      MO_32U_Lt  -> condIntReg LTT x y
+      MO_32U_Le  -> condIntReg LE x y
+
+      MO_Nat_Eq   -> condIntReg EQQ x y
+      MO_Nat_Ne   -> condIntReg NE x y
+
+      MO_NatS_Gt  -> condIntReg GTT x y
+      MO_NatS_Ge  -> condIntReg GE x y
+      MO_NatS_Lt  -> condIntReg LTT x y
+      MO_NatS_Le  -> condIntReg LE x y
+
+      MO_NatU_Gt  -> condIntReg GU  x y
+      MO_NatU_Ge  -> condIntReg GEU x y
+      MO_NatU_Lt  -> condIntReg LU  x y
+      MO_NatU_Le  -> condIntReg LEU x y
+
+      MO_Flt_Gt -> condFltReg GTT x y
+      MO_Flt_Ge -> condFltReg GE x y
+      MO_Flt_Eq -> condFltReg EQQ x y
+      MO_Flt_Ne -> condFltReg NE x y
+      MO_Flt_Lt -> condFltReg LTT x y
+      MO_Flt_Le -> condFltReg LE x y
+
+      MO_Dbl_Gt -> condFltReg GTT x y
+      MO_Dbl_Ge -> condFltReg GE x y
+      MO_Dbl_Eq -> condFltReg EQQ x y
+      MO_Dbl_Ne -> condFltReg NE x y
+      MO_Dbl_Lt -> condFltReg LTT x y
+      MO_Dbl_Le -> condFltReg LE x y
+
+      MO_Nat_Add -> trivialCode ADD x y
+      MO_Nat_Sub -> fromMaybe (trivialCode2 SUBF y x) $
+        case y of    -- subfi ('substract from' with immediate) doesn't exist
+          StInt imm -> if fits16Bits imm && imm /= (-32768)
+            then Just $ trivialCode ADD x (StInt (-imm))
+            else Nothing
+          _ -> Nothing
+
+      MO_NatS_Mul -> trivialCode MULLW x y
+      MO_NatU_Mul -> trivialCode MULLW x y
+      -- MO_NatS_MulMayOflo -> 
+
+      MO_NatS_Quot -> trivialCode2 DIVW x y
+      MO_NatU_Quot -> trivialCode2 DIVWU x y
+      
+      MO_NatS_Rem  -> remainderCode DIVW x y
+      MO_NatU_Rem  -> remainderCode DIVWU x y
+      
+      MO_Nat_And   -> trivialCode AND x y
+      MO_Nat_Or    -> trivialCode OR x y
+      MO_Nat_Xor   -> trivialCode XOR x y
+
+      MO_Nat_Shl   -> trivialCode SLW x y
+      MO_Nat_Shr   -> trivialCode SRW x y
+      MO_Nat_Sar   -> trivialCode SRAW x y
+                           
+      MO_Flt_Add   -> trivialFCode FloatRep  FADD x y
+      MO_Flt_Sub   -> trivialFCode FloatRep  FSUB x y
+      MO_Flt_Mul   -> trivialFCode FloatRep  FMUL x y
+      MO_Flt_Div   -> trivialFCode FloatRep  FDIV x y
+
+      MO_Dbl_Add   -> trivialFCode DoubleRep FADD x y
+      MO_Dbl_Sub   -> trivialFCode DoubleRep FSUB x y
+      MO_Dbl_Mul   -> trivialFCode DoubleRep FMUL x y
+      MO_Dbl_Div   -> trivialFCode DoubleRep FDIV x y
+
+      MO_Flt_Pwr  -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep 
+                                         [x, y])
+      MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep 
+                                        [x, y])
+       
+      other -> pprPanic "getRegister(powerpc) - binary StMachOp (1)" (pprMachOp mop)

 
 getRegister (StInd pk mem)
 
 getRegister (StInd pk mem)

-  = getAmode mem                   `thenUs` \ amode ->
+  = getAmode mem                   `thenNat` \ amode ->

     let
        code = amodeCode amode
        src   = amodeAddr amode
        size = primRepToSize pk
     let
        code = amodeCode amode
        src   = amodeAddr amode
        size = primRepToSize pk

-       code__2 dst = code . mkSeqInstr (LD size src dst)
+       code__2 dst = code `snocOL` LD size dst src

     in
     in

-       returnUs (Any pk code__2)
+       returnNat (Any pk code__2)

 
 getRegister (StInt i)
 
 getRegister (StInt i)

-  | fits13Bits i
+  | fits16Bits i

   = let
        src = ImmInt (fromInteger i)
   = let
        src = ImmInt (fromInteger i)

-       code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
+       code dst = unitOL (LI dst src)
+    in
+       returnNat (Any IntRep code)
+
+getRegister (StFloat d)
+  = getNatLabelNCG                 `thenNat` \ lbl ->
+    getNewRegNCG PtrRep            `thenNat` \ tmp ->
+    let code dst = toOL [
+           SEGMENT RoDataSegment,
+           LABEL lbl,
+           DATA F [ImmFloat d],
+           SEGMENT TextSegment,
+           LIS tmp (HA (ImmCLbl lbl)),
+           LD F dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
+    in
+       returnNat (Any FloatRep code)
+
+getRegister (StDouble d)
+  = getNatLabelNCG                 `thenNat` \ lbl ->
+    getNewRegNCG PtrRep            `thenNat` \ tmp ->
+    let code dst = toOL [
+           SEGMENT RoDataSegment,
+           LABEL lbl,
+           DATA DF [ImmDouble d],
+           SEGMENT TextSegment,
+           LIS tmp (HA (ImmCLbl lbl)),
+           LD DF dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]

     in
     in

-       returnUs (Any IntRep code)
+       returnNat (Any DoubleRep code)

 
 getRegister leaf
   | maybeToBool imm
   = let
 
 getRegister leaf
   | maybeToBool imm
   = let

-       code dst = mkSeqInstrs [
-           SETHI (HI imm__2) dst,
-           OR False dst (RIImm (LO imm__2)) dst]
+       code dst = toOL [
+           LIS dst (HI imm__2),
+           OR dst dst (RIImm (LO imm__2))]

     in
     in

-       returnUs (Any PtrRep code)
+       returnNat (Any PtrRep code)
+  | otherwise
+  = ncgPrimopMoan "getRegister(powerpc)" (pprStixExpr leaf)

   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x

+#endif /* powerpc_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 
 

-#endif {- sparc_TARGET_ARCH -}

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -1135,180 +1808,245 @@ amodeCode (Amode _ code) = code
 Now, given a tree (the argument to an StInd) that references memory,
 produce a suitable addressing mode.
 
 Now, given a tree (the argument to an StInd) 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) ...
+

 \begin{code}
 \begin{code}

-getAmode :: StixTree -> UniqSM Amode
+getAmode :: StixExpr -> NatM Amode

 
 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
 
 
 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
 

+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+

 #if alpha_TARGET_ARCH
 
 getAmode (StPrim IntSubOp [x, StInt i])
 #if alpha_TARGET_ARCH
 
 getAmode (StPrim IntSubOp [x, StInt i])

-  = getNewRegNCG PtrRep                `thenUs` \ tmp ->
-    getRegister x              `thenUs` \ register ->
+  = getNewRegNCG PtrRep                `thenNat` \ tmp ->
+    getRegister x              `thenNat` \ register ->

     let
        code = registerCode register tmp
        reg  = registerName register tmp
        off  = ImmInt (-(fromInteger i))
     in
     let
        code = registerCode register tmp
        reg  = registerName register tmp
        off  = ImmInt (-(fromInteger i))
     in

-    returnUs (Amode (AddrRegImm reg off) code)
+    returnNat (Amode (AddrRegImm reg off) code)

 
 getAmode (StPrim IntAddOp [x, StInt i])
 
 getAmode (StPrim IntAddOp [x, StInt i])

-  = getNewRegNCG PtrRep                `thenUs` \ tmp ->
-    getRegister x              `thenUs` \ register ->
+  = getNewRegNCG PtrRep                `thenNat` \ tmp ->
+    getRegister x              `thenNat` \ register ->

     let
        code = registerCode register tmp
        reg  = registerName register tmp
        off  = ImmInt (fromInteger i)
     in
     let
        code = registerCode register tmp
        reg  = registerName register tmp
        off  = ImmInt (fromInteger i)
     in

-    returnUs (Amode (AddrRegImm reg off) code)
+    returnNat (Amode (AddrRegImm reg off) code)

 
 getAmode leaf
   | maybeToBool imm
 
 getAmode leaf
   | maybeToBool imm

-  = returnUs (Amode (AddrImm imm__2) id)
+  = returnNat (Amode (AddrImm imm__2) id)

   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
 
 getAmode other
   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
 
 getAmode other

-  = getNewRegNCG PtrRep                `thenUs` \ tmp ->
-    getRegister other          `thenUs` \ register ->
+  = getNewRegNCG PtrRep                `thenNat` \ tmp ->
+    getRegister other          `thenNat` \ register ->

     let
        code = registerCode register tmp
        reg  = registerName register tmp
     in
     let
        code = registerCode register tmp
        reg  = registerName register tmp
     in

-    returnUs (Amode (AddrReg reg) code)
+    returnNat (Amode (AddrReg reg) code)
+
+#endif /* alpha_TARGET_ARCH */

 
 

-#endif {- alpha_TARGET_ARCH -}

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

+

 #if i386_TARGET_ARCH
 
 #if i386_TARGET_ARCH
 

-getAmode (StPrim IntSubOp [x, StInt i])
-  = getNewRegNCG PtrRep                `thenUs` \ tmp ->
-    getRegister x              `thenUs` \ register ->
+-- This is all just ridiculous, since it carefully undoes 
+-- what mangleIndexTree has just done.
+getAmode (StMachOp MO_Nat_Sub [x, StInt i])
+  = getNewRegNCG PtrRep                `thenNat` \ tmp ->
+    getRegister x              `thenNat` \ register ->

     let
        code = registerCode register tmp
        reg  = registerName register tmp
        off  = ImmInt (-(fromInteger i))
     in
     let
        code = registerCode register tmp
        reg  = registerName register tmp
        off  = ImmInt (-(fromInteger i))
     in

-    returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
+    returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)

 
 

-getAmode (StPrim IntAddOp [x, StInt i])
+getAmode (StMachOp MO_Nat_Add [x, StInt i])

   | maybeToBool imm
   | maybeToBool imm

-  = let
-       code = mkSeqInstrs []
-    in
-    returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
+  = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)

   where
     imm    = maybeImm x
     imm__2 = case imm of Just x -> x
 
   where
     imm    = maybeImm x
     imm__2 = case imm of Just x -> x
 

-getAmode (StPrim IntAddOp [x, StInt i])
-  = getNewRegNCG PtrRep                `thenUs` \ tmp ->
-    getRegister x              `thenUs` \ register ->
+getAmode (StMachOp MO_Nat_Add [x, StInt i])
+  = getNewRegNCG PtrRep                `thenNat` \ tmp ->
+    getRegister x              `thenNat` \ register ->

     let
        code = registerCode register tmp
        reg  = registerName register tmp
        off  = ImmInt (fromInteger i)
     in
     let
        code = registerCode register tmp
        reg  = registerName register tmp
        off  = ImmInt (fromInteger i)
     in

-    returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
-
-getAmode (StPrim IntAddOp [x, y])
-  = getNewRegNCG PtrRep                `thenUs` \ tmp1 ->
-    getNewRegNCG IntRep        `thenUs` \ tmp2 ->
-    getRegister x              `thenUs` \ register1 ->
-    getRegister y              `thenUs` \ register2 ->
+    returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
+
+getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
+  | shift == 0 || shift == 1 || shift == 2 || shift == 3
+  = getNewRegNCG PtrRep                `thenNat` \ tmp1 ->
+    getNewRegNCG IntRep        `thenNat` \ tmp2 ->
+    getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->

     let
     let

-       code1 = registerCode register1 tmp1 asmVoid
+       code1 = registerCode register1 tmp1

        reg1  = registerName register1 tmp1
        reg1  = registerName register1 tmp1

-       code2 = registerCode register2 tmp2 asmVoid
+       code2 = registerCode register2 tmp2

        reg2  = registerName register2 tmp2
        reg2  = registerName register2 tmp2

-       code__2 = asmParThen [code1, code2]
+       code__2 = code1 `appOL` code2
+        base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8

     in
     in

-    returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
+    returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
+               code__2)

 
 getAmode leaf
   | maybeToBool imm
 
 getAmode leaf
   | maybeToBool imm

-  = let
-       code = mkSeqInstrs []
-    in
-    returnUs (Amode (ImmAddr imm__2 0) code)
+  = returnNat (Amode (ImmAddr imm__2 0) nilOL)

   where
     imm    = maybeImm leaf
     imm__2 = case imm of Just x -> x
 
 getAmode other
   where
     imm    = maybeImm leaf
     imm__2 = case imm of Just x -> x
 
 getAmode other

-  = getNewRegNCG PtrRep                `thenUs` \ tmp ->
-    getRegister other          `thenUs` \ register ->
+  = getNewRegNCG PtrRep                `thenNat` \ tmp ->
+    getRegister other          `thenNat` \ register ->

     let
        code = registerCode register tmp
        reg  = registerName register tmp
     let
        code = registerCode register tmp
        reg  = registerName register tmp

-       off  = Nothing

     in
     in

-    returnUs (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
+    returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
+
+#endif /* i386_TARGET_ARCH */

 
 

-#endif {- i386_TARGET_ARCH -}

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

+

 #if sparc_TARGET_ARCH
 
 #if sparc_TARGET_ARCH
 

-getAmode (StPrim IntSubOp [x, StInt i])
+getAmode (StMachOp MO_Nat_Sub [x, StInt i])

   | fits13Bits (-i)
   | fits13Bits (-i)

-  = getNewRegNCG PtrRep                `thenUs` \ tmp ->
-    getRegister x              `thenUs` \ register ->
+  = getNewRegNCG PtrRep                `thenNat` \ tmp ->
+    getRegister x              `thenNat` \ register ->

     let
        code = registerCode register tmp
        reg  = registerName register tmp
        off  = ImmInt (-(fromInteger i))
     in
     let
        code = registerCode register tmp
        reg  = registerName register tmp
        off  = ImmInt (-(fromInteger i))
     in

-    returnUs (Amode (AddrRegImm reg off) code)
+    returnNat (Amode (AddrRegImm reg off) code)

 
 
 
 

-getAmode (StPrim IntAddOp [x, StInt i])
+getAmode (StMachOp MO_Nat_Add [x, StInt i])

   | fits13Bits i
   | fits13Bits i

-  = getNewRegNCG PtrRep                `thenUs` \ tmp ->
-    getRegister x              `thenUs` \ register ->
+  = getNewRegNCG PtrRep                `thenNat` \ tmp ->
+    getRegister x              `thenNat` \ register ->

     let
        code = registerCode register tmp
        reg  = registerName register tmp
        off  = ImmInt (fromInteger i)
     in
     let
        code = registerCode register tmp
        reg  = registerName register tmp
        off  = ImmInt (fromInteger i)
     in

-    returnUs (Amode (AddrRegImm reg off) code)
+    returnNat (Amode (AddrRegImm reg off) code)

 
 

-getAmode (StPrim IntAddOp [x, y])
-  = getNewRegNCG PtrRep        `thenUs` \ tmp1 ->
-    getNewRegNCG IntRep        `thenUs` \ tmp2 ->
-    getRegister x              `thenUs` \ register1 ->
-    getRegister y              `thenUs` \ register2 ->
+getAmode (StMachOp MO_Nat_Add [x, y])
+  = getNewRegNCG PtrRep        `thenNat` \ tmp1 ->
+    getNewRegNCG IntRep        `thenNat` \ tmp2 ->
+    getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->

     let
     let

-       code1 = registerCode register1 tmp1 asmVoid
+       code1 = registerCode register1 tmp1

        reg1  = registerName register1 tmp1
        reg1  = registerName register1 tmp1

-       code2 = registerCode register2 tmp2 asmVoid
+       code2 = registerCode register2 tmp2

        reg2  = registerName register2 tmp2
        reg2  = registerName register2 tmp2

-       code__2 = asmParThen [code1, code2]
+       code__2 = code1 `appOL` code2
+    in
+    returnNat (Amode (AddrRegReg reg1 reg2) code__2)
+
+getAmode leaf
+  | maybeToBool imm
+  = getNewRegNCG PtrRep            `thenNat` \ tmp ->
+    let
+       code = unitOL (SETHI (HI imm__2) tmp)
+    in
+    returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
+  where
+    imm    = maybeImm leaf
+    imm__2 = case imm of Just x -> x
+
+getAmode other
+  = getNewRegNCG PtrRep                `thenNat` \ tmp ->
+    getRegister other          `thenNat` \ register ->
+    let
+       code = registerCode register tmp
+       reg  = registerName register tmp
+       off  = ImmInt 0
+    in
+    returnNat (Amode (AddrRegImm reg off) code)
+
+#endif /* sparc_TARGET_ARCH */
+
+#ifdef powerpc_TARGET_ARCH
+getAmode (StMachOp MO_Nat_Sub [x, StInt i])
+  | fits16Bits (-i)
+  = getNewRegNCG PtrRep                `thenNat` \ tmp ->
+    getRegister x              `thenNat` \ register ->
+    let
+       code = registerCode register tmp
+       reg  = registerName register tmp
+       off  = ImmInt (-(fromInteger i))
+    in
+    returnNat (Amode (AddrRegImm reg off) code)
+
+
+getAmode (StMachOp MO_Nat_Add [x, StInt i])
+  | fits16Bits i
+  = getNewRegNCG PtrRep                `thenNat` \ tmp ->
+    getRegister x              `thenNat` \ register ->
+    let
+       code = registerCode register tmp
+       reg  = registerName register tmp
+       off  = ImmInt (fromInteger i)

     in
     in

-    returnUs (Amode (AddrRegReg reg1 reg2) code__2)
+    returnNat (Amode (AddrRegImm reg off) code)

 
 getAmode leaf
   | maybeToBool imm
 
 getAmode leaf
   | maybeToBool imm

-  = getNewRegNCG PtrRep            `thenUs` \ tmp ->
+  = getNewRegNCG PtrRep            `thenNat` \ tmp ->

     let
     let

-       code = mkSeqInstr (SETHI (HI imm__2) tmp)
+       code = unitOL (LIS tmp (HA imm__2))

     in
     in

-    returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
+    returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)

   where
     imm    = maybeImm leaf
     imm__2 = case imm of Just x -> x
 
 getAmode other
   where
     imm    = maybeImm leaf
     imm__2 = case imm of Just x -> x
 
 getAmode other

-  = getNewRegNCG PtrRep                `thenUs` \ tmp ->
-    getRegister other          `thenUs` \ register ->
+  = getNewRegNCG PtrRep                `thenNat` \ tmp ->
+    getRegister other          `thenNat` \ register ->

     let
        code = registerCode register tmp
        reg  = registerName register tmp
        off  = ImmInt 0
     in
     let
        code = registerCode register tmp
        reg  = registerName register tmp
        off  = ImmInt 0
     in

-    returnUs (Amode (AddrRegImm reg off) code)
+    returnNat (Amode (AddrRegImm reg off) code)
+#endif /* powerpc_TARGET_ARCH */

 
 

-#endif {- sparc_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -1321,69 +2059,71 @@ Condition codes passed up the tree.
 \begin{code}
 data CondCode = CondCode Bool Cond InstrBlock
 
 \begin{code}
 data CondCode = CondCode Bool Cond InstrBlock
 

-condName  (CondCode _ cond _)     = cond
+condName  (CondCode _ cond _)    = cond

 condFloat (CondCode is_float _ _) = is_float
 condFloat (CondCode is_float _ _) = is_float

-condCode  (CondCode _ _ code)     = code
+condCode  (CondCode _ _ code)    = code

 \end{code}
 
 Set up a condition code for a conditional branch.
 
 \begin{code}
 \end{code}
 
 Set up a condition code for a conditional branch.
 
 \begin{code}

-getCondCode :: StixTree -> UniqSM CondCode
+getCondCode :: StixExpr -> NatM CondCode
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 
 #if alpha_TARGET_ARCH
 getCondCode = panic "MachCode.getCondCode: not on Alphas"
 
 #if alpha_TARGET_ARCH
 getCondCode = panic "MachCode.getCondCode: not on Alphas"

-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */
+

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

-#if i386_TARGET_ARCH || sparc_TARGET_ARCH
+#if i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH

 -- yes, they really do seem to want exactly the same!
 
 -- yes, they really do seem to want exactly the same!
 

-getCondCode (StPrim primop [x, y])
-  = case primop of
-      CharGtOp -> condIntCode GTT  x y
-      CharGeOp -> condIntCode GE  x y
-      CharEqOp -> condIntCode EQQ  x y
-      CharNeOp -> condIntCode NE  x y
-      CharLtOp -> condIntCode LTT  x y
-      CharLeOp -> condIntCode LE  x y
+getCondCode (StMachOp mop [x, y])
+  = case mop of
+      MO_32U_Gt -> condIntCode GTT  x y
+      MO_32U_Ge -> condIntCode GE   x y
+      MO_32U_Eq -> condIntCode EQQ  x y
+      MO_32U_Ne -> condIntCode NE   x y
+      MO_32U_Lt -> condIntCode LTT  x y
+      MO_32U_Le -> condIntCode LE   x y

  
  

-      IntGtOp  -> condIntCode GTT  x y
-      IntGeOp  -> condIntCode GE  x y
-      IntEqOp  -> condIntCode EQQ  x y
-      IntNeOp  -> condIntCode NE  x y
-      IntLtOp  -> condIntCode LTT  x y
-      IntLeOp  -> condIntCode LE  x y
-
-      WordGtOp -> condIntCode GU  x y
-      WordGeOp -> condIntCode GEU x y
-      WordEqOp -> condIntCode EQQ  x y
-      WordNeOp -> condIntCode NE  x y
-      WordLtOp -> condIntCode LU  x y
-      WordLeOp -> condIntCode LEU x y
-
-      AddrGtOp -> condIntCode GU  x y
-      AddrGeOp -> condIntCode GEU x y
-      AddrEqOp -> condIntCode EQQ  x y
-      AddrNeOp -> condIntCode NE  x y
-      AddrLtOp -> condIntCode LU  x y
-      AddrLeOp -> condIntCode LEU x y
-
-      FloatGtOp -> condFltCode GTT x y
-      FloatGeOp -> condFltCode GE x y
-      FloatEqOp -> condFltCode EQQ x y
-      FloatNeOp -> condFltCode NE x y
-      FloatLtOp -> condFltCode LTT x y
-      FloatLeOp -> condFltCode LE x y
-
-      DoubleGtOp -> condFltCode GTT x y
-      DoubleGeOp -> condFltCode GE x y
-      DoubleEqOp -> condFltCode EQQ x y
-      DoubleNeOp -> condFltCode NE x y
-      DoubleLtOp -> condFltCode LTT x y
-      DoubleLeOp -> condFltCode LE x y
-
-#endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
+      MO_Nat_Eq  -> condIntCode EQQ  x y
+      MO_Nat_Ne  -> condIntCode NE   x y
+
+      MO_NatS_Gt -> condIntCode GTT  x y
+      MO_NatS_Ge -> condIntCode GE   x y
+      MO_NatS_Lt -> condIntCode LTT  x y
+      MO_NatS_Le -> condIntCode LE   x y
+
+      MO_NatU_Gt -> condIntCode GU   x y
+      MO_NatU_Ge -> condIntCode GEU  x y
+      MO_NatU_Lt -> condIntCode LU   x y
+      MO_NatU_Le -> condIntCode LEU  x y
+
+      MO_Flt_Gt -> condFltCode GTT x y
+      MO_Flt_Ge -> condFltCode GE  x y
+      MO_Flt_Eq -> condFltCode EQQ x y
+      MO_Flt_Ne -> condFltCode NE  x y
+      MO_Flt_Lt -> condFltCode LTT x y
+      MO_Flt_Le -> condFltCode LE  x y
+
+      MO_Dbl_Gt -> condFltCode GTT x y
+      MO_Dbl_Ge -> condFltCode GE  x y
+      MO_Dbl_Eq -> condFltCode EQQ x y
+      MO_Dbl_Ne -> condFltCode NE  x y
+      MO_Dbl_Lt -> condFltCode LTT x y
+      MO_Dbl_Le -> condFltCode LE  x y
+
+      other -> pprPanic "getCondCode(x86,sparc,powerpc)" (pprMachOp mop)
+
+getCondCode other =  pprPanic "getCondCode(2)(x86,sparc,powerpc)" (pprStixExpr other)
+
+#endif /* i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH */
+
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 \end{code}
 
 % -----------------
 \end{code}
 
 % -----------------

@@ -1392,199 +2132,201 @@ getCondCode (StPrim primop [x, y])
 passed back up the tree.
 
 \begin{code}
 passed back up the tree.
 
 \begin{code}

-condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode
+condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode

 
 #if alpha_TARGET_ARCH
 condIntCode = panic "MachCode.condIntCode: not on Alphas"
 condFltCode = panic "MachCode.condFltCode: not on Alphas"
 
 #if alpha_TARGET_ARCH
 condIntCode = panic "MachCode.condIntCode: not on Alphas"
 condFltCode = panic "MachCode.condFltCode: not on Alphas"

-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */

 
 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 #if i386_TARGET_ARCH
 
 
 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 #if i386_TARGET_ARCH
 

-condIntCode cond (StInd _ x) y
-  | maybeToBool imm
-  = getAmode x                 `thenUs` \ amode ->
+-- memory vs immediate
+condIntCode cond (StInd pk x) y
+  | Just i <- maybeImm y
+  = getAmode x                 `thenNat` \ amode ->

     let
     let

-       code1 = amodeCode amode asmVoid
-       y__2  = amodeAddr amode
-       code__2 = asmParThen [code1] .
-                 mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
+       code1 = amodeCode amode
+       x__2  = amodeAddr amode
+        sz    = primRepToSize pk
+       code__2 = code1 `snocOL`
+                 CMP sz (OpImm i) (OpAddr x__2)

     in
     in

-    returnUs (CondCode False cond code__2)
-  where
-    imm    = maybeImm y
-    imm__2 = case imm of Just x -> x
+    returnNat (CondCode False cond code__2)

 
 

+-- anything vs zero

 condIntCode cond x (StInt 0)
 condIntCode cond x (StInt 0)

-  = getRegister x              `thenUs` \ register1 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp1 ->
+  = getRegister x              `thenNat` \ register1 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp1 ->

     let
     let

-       code1 = registerCode register1 tmp1 asmVoid
+       code1 = registerCode register1 tmp1

        src1  = registerName register1 tmp1
        src1  = registerName register1 tmp1

-       code__2 = asmParThen [code1] .
-               mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
+       code__2 = code1 `snocOL`
+                 TEST L (OpReg src1) (OpReg src1)

     in
     in

-    returnUs (CondCode False cond code__2)
+    returnNat (CondCode False cond code__2)

 
 

+-- anything vs immediate

 condIntCode cond x y
 condIntCode cond x y

-  | maybeToBool imm
-  = getRegister x              `thenUs` \ register1 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp1 ->
+  | Just i <- maybeImm y
+  = getRegister x              `thenNat` \ register1 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp1 ->

     let
     let

-       code1 = registerCode register1 tmp1 asmVoid
+       code1 = registerCode register1 tmp1

        src1  = registerName register1 tmp1
        src1  = registerName register1 tmp1

-       code__2 = asmParThen [code1] .
-               mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
+       code__2 = code1 `snocOL`
+                  CMP L (OpImm i) (OpReg src1)

     in
     in

-    returnUs (CondCode False cond code__2)
-  where
-    imm    = maybeImm y
-    imm__2 = case imm of Just x -> x
+    returnNat (CondCode False cond code__2)

 
 

-condIntCode cond (StInd _ x) y
-  = getAmode x                 `thenUs` \ amode ->
-    getRegister y              `thenUs` \ register2 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp2 ->
+-- memory vs anything
+condIntCode cond (StInd pk x) y
+  = getAmode x                 `thenNat` \ amode_x ->
+    getRegister y              `thenNat` \ reg_y ->
+    getNewRegNCG IntRep                `thenNat` \ tmp ->

     let
     let

-       code1 = amodeCode amode asmVoid
-       src1  = amodeAddr amode
-       code2 = registerCode register2 tmp2 asmVoid
-       src2  = registerName register2 tmp2
-       code__2 = asmParThen [code1, code2] .
-                 mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
+       c_x   = amodeCode amode_x
+       am_x  = amodeAddr amode_x
+       c_y   = registerCode reg_y tmp
+       r_y   = registerName reg_y tmp
+        sz    = primRepToSize pk
+
+        -- optimisation: if there's no code for x, just an amode,
+        -- use whatever reg y winds up in.  Assumes that c_y doesn't
+        -- clobber any regs in the amode am_x, which I'm not sure is
+        -- justified.  The otherwise clause makes the same assumption.
+       code__2 | isNilOL c_x 
+                = c_y `snocOL`
+                  CMP sz (OpReg r_y) (OpAddr am_x)
+
+                | otherwise
+                = c_y `snocOL` 
+                  MOV L (OpReg r_y) (OpReg tmp) `appOL`
+                  c_x `snocOL`
+                 CMP sz (OpReg tmp) (OpAddr am_x)

     in
     in

-    returnUs (CondCode False cond code__2)
-
-condIntCode cond y (StInd _ x)
-  = getAmode x                 `thenUs` \ amode ->
-    getRegister y              `thenUs` \ register2 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp2 ->
+    returnNat (CondCode False cond code__2)
+
+-- anything vs memory
+-- 
+condIntCode cond y (StInd pk x)
+  = getAmode x                 `thenNat` \ amode_x ->
+    getRegister y              `thenNat` \ reg_y ->
+    getNewRegNCG IntRep                `thenNat` \ tmp ->

     let
     let

-       code1 = amodeCode amode asmVoid
-       src1  = amodeAddr amode
-       code2 = registerCode register2 tmp2 asmVoid
-       src2  = registerName register2 tmp2
-       code__2 = asmParThen [code1, code2] .
-                 mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
+       c_x   = amodeCode amode_x
+       am_x  = amodeAddr amode_x
+       c_y   = registerCode reg_y tmp
+       r_y   = registerName reg_y tmp
+        sz    = primRepToSize pk
+        -- same optimisation and nagging doubts as previous clause
+       code__2 | isNilOL c_x
+                = c_y `snocOL`
+                  CMP sz (OpAddr am_x) (OpReg r_y)
+
+                | otherwise
+                = c_y `snocOL` 
+                  MOV L (OpReg r_y) (OpReg tmp) `appOL`
+                  c_x `snocOL`
+                 CMP sz (OpAddr am_x) (OpReg tmp)

     in
     in

-    returnUs (CondCode False cond code__2)
+    returnNat (CondCode False cond code__2)

 
 

+-- anything vs anything

 condIntCode cond x y
 condIntCode cond x y

-  = getRegister x              `thenUs` \ register1 ->
-    getRegister y              `thenUs` \ register2 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp1 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp2 ->
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp1 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp2 ->

     let
     let

-       code1 = registerCode register1 tmp1 asmVoid
+       code1 = registerCode register1 tmp1

        src1  = registerName register1 tmp1
        src1  = registerName register1 tmp1

-       code2 = registerCode register2 tmp2 asmVoid
+       code2 = registerCode register2 tmp2

        src2  = registerName register2 tmp2
        src2  = registerName register2 tmp2

-       code__2 = asmParThen [code1, code2] .
-               mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
+       code__2 = code1 `snocOL`
+                  MOV L (OpReg src1) (OpReg tmp1) `appOL`
+                  code2 `snocOL`
+                 CMP L (OpReg src2) (OpReg tmp1)

     in
     in

-    returnUs (CondCode False cond code__2)
+    returnNat (CondCode False cond code__2)

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

-
-condFltCode cond x (StDouble 0.0)
-  = getRegister x              `thenUs` \ register1 ->
-    getNewRegNCG (registerRep register1)
-                               `thenUs` \ tmp1 ->
-    let
-       pk1   = registerRep register1
-       code1 = registerCode register1 tmp1
-       src1  = registerName register1 tmp1
-
-       code__2 = asmParThen [code1 asmVoid] .
-                 mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ?
-                              FNSTSW,
-                              --AND HB (OpImm (ImmInt 68)) (OpReg eax),
-                              --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
-                              SAHF
-                             ]
-    in
-    returnUs (CondCode True (fix_FP_cond cond) code__2)
-

 condFltCode cond x y
 condFltCode cond x y

-  = getRegister x              `thenUs` \ register1 ->
-    getRegister y              `thenUs` \ register2 ->
+  = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
+    getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->

     getNewRegNCG (registerRep register1)
     getNewRegNCG (registerRep register1)

-                               `thenUs` \ tmp1 ->
+                               `thenNat` \ tmp1 ->

     getNewRegNCG (registerRep register2)
     getNewRegNCG (registerRep register2)

-                               `thenUs` \ tmp2 ->
+                               `thenNat` \ tmp2 ->
+    getNewRegNCG DoubleRep     `thenNat` \ tmp ->

     let
     let

-       pk1   = registerRep register1

        code1 = registerCode register1 tmp1
        src1  = registerName register1 tmp1
 
        code2 = registerCode register2 tmp2
        src2  = registerName register2 tmp2
 
        code1 = registerCode register1 tmp1
        src1  = registerName register1 tmp1
 
        code2 = registerCode register2 tmp2
        src2  = registerName register2 tmp2
 

-       code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
-                 mkSeqInstrs [FUCOMPP,
-                              FNSTSW,
-                              --AND HB (OpImm (ImmInt 68)) (OpReg eax),
-                              --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
-                              SAHF
-                             ]
+       code__2 | isAny register1
+                = code1 `appOL`   -- result in tmp1
+                  code2 `snocOL`
+                 GCMP cond tmp1 src2
+                  
+                | otherwise
+                = code1 `snocOL` 
+                  GMOV src1 tmp1 `appOL`
+                  code2 `snocOL`
+                 GCMP cond tmp1 src2

     in
     in

-    returnUs (CondCode True (fix_FP_cond cond) code__2)
-
-{- On the 486, the flags set by FP compare are the unsigned ones!
-   (This looks like a HACK to me.  WDP 96/03)
--}
-
-fix_FP_cond :: Cond -> Cond
+    -- 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.
+    returnNat (CondCode True EQQ code__2)

 
 

-fix_FP_cond GE  = GEU
-fix_FP_cond GTT  = GU
-fix_FP_cond LTT  = LU
-fix_FP_cond LE  = LEU
-fix_FP_cond any = any
+#endif /* i386_TARGET_ARCH */

 
 

-#endif {- i386_TARGET_ARCH -}

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

+

 #if sparc_TARGET_ARCH
 
 condIntCode cond x (StInt y)
   | fits13Bits y
 #if sparc_TARGET_ARCH
 
 condIntCode cond x (StInt y)
   | fits13Bits y

-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG IntRep                `thenUs` \ tmp ->
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG IntRep                `thenNat` \ tmp ->

     let
        code = registerCode register tmp
        src1 = registerName register tmp
        src2 = ImmInt (fromInteger y)
     let
        code = registerCode register tmp
        src1 = registerName register tmp
        src2 = ImmInt (fromInteger y)

-       code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
+       code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0

     in
     in

-    returnUs (CondCode False cond code__2)
+    returnNat (CondCode False cond code__2)

 
 condIntCode cond x y
 
 condIntCode cond x y

-  = getRegister x              `thenUs` \ register1 ->
-    getRegister y              `thenUs` \ register2 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp1 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp2 ->
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp1 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp2 ->

     let
     let

-       code1 = registerCode register1 tmp1 asmVoid
+       code1 = registerCode register1 tmp1

        src1  = registerName register1 tmp1
        src1  = registerName register1 tmp1

-       code2 = registerCode register2 tmp2 asmVoid
+       code2 = registerCode register2 tmp2

        src2  = registerName register2 tmp2
        src2  = registerName register2 tmp2

-       code__2 = asmParThen [code1, code2] .
-               mkSeqInstr (SUB False True src1 (RIReg src2) g0)
+       code__2 = code1 `appOL` code2 `snocOL`
+                 SUB False True src1 (RIReg src2) g0

     in
     in

-    returnUs (CondCode False cond code__2)
+    returnNat (CondCode False cond code__2)

 
 -----------
 condFltCode cond x y
 
 -----------
 condFltCode cond x y

-  = getRegister x              `thenUs` \ register1 ->
-    getRegister y              `thenUs` \ register2 ->
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->

     getNewRegNCG (registerRep register1)
     getNewRegNCG (registerRep register1)

-                               `thenUs` \ tmp1 ->
+                               `thenNat` \ tmp1 ->

     getNewRegNCG (registerRep register2)
     getNewRegNCG (registerRep register2)

-                               `thenUs` \ tmp2 ->
-    getNewRegNCG DoubleRep     `thenUs` \ tmp ->
+                               `thenNat` \ tmp2 ->
+    getNewRegNCG DoubleRep     `thenNat` \ tmp ->

     let
     let

-       promote x = asmInstr (FxTOy F DF x tmp)
+       promote x = FxTOy F DF x tmp

 
        pk1   = registerRep register1
        code1 = registerCode register1 tmp1
 
        pk1   = registerRep register1
        code1 = registerCode register1 tmp1

@@ -1596,18 +2338,70 @@ condFltCode cond x y
 
        code__2 =
                if pk1 == pk2 then
 
        code__2 =
                if pk1 == pk2 then

-                   asmParThen [code1 asmVoid, code2 asmVoid] .
-                   mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
+                   code1 `appOL` code2 `snocOL`
+                   FCMP True (primRepToSize pk1) src1 src2

                else if pk1 == FloatRep then
                else if pk1 == FloatRep then

-                   asmParThen [code1 (promote src1), code2 asmVoid] .
-                   mkSeqInstr (FCMP True DF tmp src2)
+                   code1 `snocOL` promote src1 `appOL` code2 `snocOL`
+                   FCMP True DF tmp src2

                else
                else

-                   asmParThen [code1 asmVoid, code2 (promote src2)] .
-                   mkSeqInstr (FCMP True DF src1 tmp)
+                   code1 `appOL` code2 `snocOL` promote src2 `snocOL`
+                   FCMP True DF src1 tmp
+    in
+    returnNat (CondCode True cond code__2)
+
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+
+condIntCode cond x (StInt y)
+  | fits16Bits y
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG IntRep                `thenNat` \ tmp ->
+    let
+       code = registerCode register tmp
+       src1 = registerName register tmp
+       src2 = ImmInt (fromInteger y)
+       code__2 = code `snocOL` 
+           (if condUnsigned cond then CMPL else CMP) W src1 (RIImm src2)
+    in
+    returnNat (CondCode False cond code__2)
+
+condIntCode cond x y
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp1 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp2 ->
+    let
+       code1 = registerCode register1 tmp1
+       src1  = registerName register1 tmp1
+       code2 = registerCode register2 tmp2
+       src2  = registerName register2 tmp2
+       code__2 = code1 `appOL` code2 `snocOL`
+                 (if condUnsigned cond then CMPL else CMP) W src1 (RIReg src2)
+    in
+    returnNat (CondCode False cond code__2)
+
+condFltCode cond x y
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->
+    getNewRegNCG (registerRep register1)
+                               `thenNat` \ tmp1 ->
+    getNewRegNCG (registerRep register2)
+                               `thenNat` \ tmp2 ->
+    let
+       code1 = registerCode register1 tmp1
+       src1  = registerName register1 tmp1
+       code2 = registerCode register2 tmp2
+       src2  = registerName register2 tmp2
+       code__2 = code1 `appOL` code2 `snocOL`
+                 FCMP src1 src2

     in
     in

-    returnUs (CondCode True cond code__2)
+    returnNat (CondCode False cond code__2)

 
 

-#endif {- sparc_TARGET_ARCH -}
+#endif /* powerpc_TARGET_ARCH */
+
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -1625,28 +2419,33 @@ 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).
 
 \begin{code}
 hand side is forced into a fixed register (e.g. the result of a call).
 
 \begin{code}

-assignIntCode, assignFltCode
-       :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock
+assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
+assignReg_IntCode :: PrimRep -> StixReg  -> StixExpr -> NatM InstrBlock
+
+assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
+assignReg_FltCode :: PrimRep -> StixReg  -> StixExpr -> NatM InstrBlock
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 
 #if alpha_TARGET_ARCH
 
 assignIntCode pk (StInd _ dst) src
 
 #if alpha_TARGET_ARCH
 
 assignIntCode pk (StInd _ dst) src

-  = getNewRegNCG IntRep            `thenUs` \ tmp ->
-    getAmode dst                   `thenUs` \ amode ->
-    getRegister src                `thenUs` \ register ->
+  = getNewRegNCG IntRep            `thenNat` \ tmp ->
+    getAmode dst                   `thenNat` \ amode ->
+    getRegister src                `thenNat` \ register ->

     let
     let

-       code1   = amodeCode amode asmVoid
+       code1   = amodeCode amode []

        dst__2  = amodeAddr amode
        dst__2  = amodeAddr amode

-       code2   = registerCode register tmp asmVoid
+       code2   = registerCode register tmp []

        src__2  = registerName register tmp
        sz      = primRepToSize pk
        src__2  = registerName register tmp
        sz      = primRepToSize pk

-       code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
+       code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)

     in
     in

-    returnUs code__2
+    returnNat code__2

 
 assignIntCode pk dst src
 
 assignIntCode pk dst src

-  = getRegister dst                        `thenUs` \ register1 ->
-    getRegister src                        `thenUs` \ register2 ->
+  = getRegister dst                        `thenNat` \ register1 ->
+    getRegister src                        `thenNat` \ register2 ->

     let
        dst__2  = registerName register1 zeroh
        code    = registerCode register2 dst__2
     let
        dst__2  = registerName register1 zeroh
        code    = registerCode register2 dst__2

@@ -1655,132 +2454,191 @@ assignIntCode pk dst src
                  then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
                  else code
     in
                  then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
                  else code
     in

-    returnUs code__2
+    returnNat code__2
+
+#endif /* alpha_TARGET_ARCH */

 
 

-#endif {- alpha_TARGET_ARCH -}

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

+

 #if i386_TARGET_ARCH
 
 #if i386_TARGET_ARCH
 

-assignIntCode pk (StInd _ dst) src
-  = getAmode dst               `thenUs` \ amode ->
-    get_op_RI src              `thenUs` \ (codesrc, opsrc, sz) ->
+-- non-FP assignment to memory
+assignMem_IntCode pk addr src
+  = getAmode addr              `thenNat` \ amode ->
+    get_op_RI src              `thenNat` \ (codesrc, opsrc) ->
+    getNewRegNCG PtrRep         `thenNat` \ tmp ->

     let
     let

-       code1   = amodeCode amode asmVoid
-       dst__2  = amodeAddr amode
-       code__2 = asmParThen [code1, codesrc asmVoid] .
-                 mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
+        -- In general, if the address computation for dst may require
+        -- some insns preceding the addressing mode itself.  So there's
+        -- no guarantee that the code for dst and the code for src won't
+        -- write the same register.  This means either the address or 
+        -- the value needs to be copied into a temporary.  We detect the
+        -- common case where the amode has no code, and elide the copy.
+       codea   = amodeCode amode
+       dst__a  = amodeAddr amode
+
+       code    | isNilOL codea
+                = codesrc `snocOL`
+                 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
+                | otherwise
+                = codea `snocOL` 
+                  LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
+                  codesrc `snocOL`
+                  MOV (primRepToSize pk) opsrc 
+                      (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))

     in
     in

-    returnUs code__2
+    returnNat code

   where
     get_op_RI
   where
     get_op_RI

-       :: StixTree
-       -> UniqSM (InstrBlock,Operand, Size)    -- code, operator, size
+       :: StixExpr
+       -> NatM (InstrBlock,Operand)    -- code, operator

 
     get_op_RI op
 
     get_op_RI op

-      | maybeToBool imm
-      = returnUs (asmParThen [], OpImm imm_op, L)
-      where
-       imm    = maybeImm op
-       imm_op = case imm of Just x -> x
+      | Just x <- maybeImm op
+      = returnNat (nilOL, OpImm x)

 
     get_op_RI op
 
     get_op_RI op

-      = getRegister op                 `thenUs` \ register ->
+      = getRegister op                 `thenNat` \ register ->

        getNewRegNCG (registerRep register)
        getNewRegNCG (registerRep register)

-                                       `thenUs` \ tmp ->
-       let
-           code = registerCode register tmp
+                                       `thenNat` \ tmp ->
+       let code = registerCode register tmp

            reg  = registerName register tmp
            reg  = registerName register tmp

-           pk   = registerRep  register
-           sz   = primRepToSize pk

        in
        in

-       returnUs (code, OpReg reg, sz)
+       returnNat (code, OpReg reg)

 
 

-assignIntCode pk dst (StInd _ src)
-  = getNewRegNCG IntRep            `thenUs` \ tmp ->
-    getAmode src                   `thenUs` \ amode ->
-    getRegister dst                        `thenUs` \ register ->
+-- Assign; dst is a reg, rhs is mem
+assignReg_IntCode pk reg (StInd pks src)
+  = getNewRegNCG PtrRep            `thenNat` \ tmp ->
+    getAmode src                   `thenNat` \ amode ->
+    getRegisterReg reg             `thenNat` \ reg_dst ->

     let
     let

-       code1   = amodeCode amode asmVoid
-       src__2  = amodeAddr amode
-       code2   = registerCode register tmp asmVoid
-       dst__2  = registerName register tmp
+       c_addr  = amodeCode amode
+       am_addr = amodeAddr amode
+       r_dst = registerName reg_dst tmp
+       szs   = primRepToSize pks
+        opc   = case szs of
+            B  -> MOVSxL B
+            Bu -> MOVZxL Bu
+            W  -> MOVSxL W
+            Wu -> MOVZxL Wu
+            L  -> MOV L
+            Lu -> MOV L
+
+       code  = c_addr `snocOL`
+                opc (OpAddr am_addr) (OpReg r_dst)
+    in
+    returnNat code
+
+-- dst is a reg, but src could be anything
+assignReg_IntCode pk reg src
+  = getRegisterReg reg             `thenNat` \ registerd ->
+    getRegister src                `thenNat` \ registers ->
+    getNewRegNCG IntRep            `thenNat` \ tmp ->
+    let 
+        r_dst = registerName registerd tmp
+        r_src = registerName registers r_dst
+        c_src = registerCode registers r_dst
+         
+        code = c_src `snocOL` 
+               MOV L (OpReg r_src) (OpReg r_dst)
+    in
+    returnNat code
+
+#endif /* i386_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if sparc_TARGET_ARCH
+
+assignMem_IntCode pk addr src
+  = getNewRegNCG IntRep                    `thenNat` \ tmp ->
+    getAmode addr                          `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
        sz      = primRepToSize pk

-       code__2 = asmParThen [code1, code2] .
-                 mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
+       code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2

     in
     in

-    returnUs code__2
+    returnNat code__2

 
 

-assignIntCode pk dst src
-  = getRegister dst                        `thenUs` \ register1 ->
-    getRegister src                        `thenUs` \ register2 ->
-    getNewRegNCG IntRep            `thenUs` \ tmp ->
+assignReg_IntCode pk reg src
+  = getRegister src                        `thenNat` \ register2 ->
+    getRegisterReg reg                     `thenNat` \ register1 ->
+    getNewRegNCG IntRep                    `thenNat` \ tmp ->

     let
        dst__2  = registerName register1 tmp
        code    = registerCode register2 dst__2
        src__2  = registerName register2 dst__2
     let
        dst__2  = registerName register1 tmp
        code    = registerCode register2 dst__2
        src__2  = registerName register2 dst__2

-       code__2 = if isFixed register2 && dst__2 /= src__2
-                 then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
+       code__2 = if isFixed register2
+                 then code `snocOL` OR False g0 (RIReg src__2) dst__2

                  else code
     in
                  else code
     in

-    returnUs code__2
+    returnNat code__2

 
 

-#endif {- i386_TARGET_ARCH -}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if sparc_TARGET_ARCH
+#endif /* sparc_TARGET_ARCH */

 
 

-assignIntCode pk (StInd _ dst) src
-  = getNewRegNCG IntRep            `thenUs` \ tmp ->
-    getAmode dst                   `thenUs` \ amode ->
-    getRegister src                        `thenUs` \ register ->
+#if powerpc_TARGET_ARCH
+
+assignMem_IntCode pk addr src
+  = getNewRegNCG IntRep                    `thenNat` \ tmp ->
+    getAmode addr                          `thenNat` \ amode ->
+    getRegister src                        `thenNat` \ register ->

     let
     let

-       code1   = amodeCode amode asmVoid
+       code1   = amodeCode amode

        dst__2  = amodeAddr amode
        dst__2  = amodeAddr amode

-       code2   = registerCode register tmp asmVoid
+       code2   = registerCode register tmp

        src__2  = registerName register tmp
        sz      = primRepToSize pk
        src__2  = registerName register tmp
        sz      = primRepToSize pk

-       code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
+       code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2

     in
     in

-    returnUs code__2
+    returnNat code__2

 
 

-assignIntCode pk dst src
-  = getRegister dst                        `thenUs` \ register1 ->
-    getRegister src                        `thenUs` \ register2 ->
+assignReg_IntCode pk reg src
+  = getRegister src                        `thenNat` \ register2 ->
+    getRegisterReg reg                     `thenNat` \ register1 ->

     let
     let

-       dst__2  = registerName register1 g0
+       dst__2  = registerName register1 (panic "###PPC where are we assigning this int???")

        code    = registerCode register2 dst__2
        src__2  = registerName register2 dst__2
        code__2 = if isFixed register2
        code    = registerCode register2 dst__2
        src__2  = registerName register2 dst__2
        code__2 = if isFixed register2

-                 then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
+                 then code `snocOL` MR dst__2 src__2

                  else code
     in
                  else code
     in

-    returnUs code__2
+    returnNat code__2
+
+#endif /* powerpc_TARGET_ARCH */

 
 

-#endif {- sparc_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 \end{code}
 
 % --------------------------------
 Floating-point assignments:
 % --------------------------------
 \end{code}
 
 % --------------------------------
 Floating-point assignments:
 % --------------------------------

+

 \begin{code}
 \begin{code}

+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 #if alpha_TARGET_ARCH
 
 assignFltCode pk (StInd _ dst) src
 #if alpha_TARGET_ARCH
 
 assignFltCode pk (StInd _ dst) src

-  = getNewRegNCG pk                `thenUs` \ tmp ->
-    getAmode dst                   `thenUs` \ amode ->
-    getRegister src                        `thenUs` \ register ->
+  = getNewRegNCG pk                `thenNat` \ tmp ->
+    getAmode dst                   `thenNat` \ amode ->
+    getRegister src                        `thenNat` \ register ->

     let
     let

-       code1   = amodeCode amode asmVoid
+       code1   = amodeCode amode []

        dst__2  = amodeAddr amode
        dst__2  = amodeAddr amode

-       code2   = registerCode register tmp asmVoid
+       code2   = registerCode register tmp []

        src__2  = registerName register tmp
        sz      = primRepToSize pk
        src__2  = registerName register tmp
        sz      = primRepToSize pk

-       code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
+       code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)

     in
     in

-    returnUs code__2
+    returnNat code__2

 
 assignFltCode pk dst src
 
 assignFltCode pk dst src

-  = getRegister dst                        `thenUs` \ register1 ->
-    getRegister src                        `thenUs` \ register2 ->
+  = getRegister dst                        `thenNat` \ register1 ->
+    getRegister src                        `thenNat` \ register2 ->

     let
        dst__2  = registerName register1 zeroh
        code    = registerCode register2 dst__2
     let
        dst__2  = registerName register1 zeroh
        code    = registerCode register2 dst__2

@@ -1789,129 +2647,149 @@ assignFltCode pk dst src
                  then code . mkSeqInstr (FMOV src__2 dst__2)
                  else code
     in
                  then code . mkSeqInstr (FMOV src__2 dst__2)
                  else code
     in

-    returnUs code__2
+    returnNat code__2
+
+#endif /* alpha_TARGET_ARCH */

 
 

-#endif {- alpha_TARGET_ARCH -}

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

-#if i386_TARGET_ARCH

 
 

-assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
-  = getNewRegNCG IntRep            `thenUs` \ tmp ->
-    getAmode src                   `thenUs` \ amodesrc ->
-    getAmode dst                   `thenUs` \ amodedst ->
-    --getRegister src                      `thenUs` \ register ->
-    let
-       codesrc1 = amodeCode amodesrc asmVoid
-       addrsrc1 = amodeAddr amodesrc
-       codedst1 = amodeCode amodedst asmVoid
-       addrdst1 = amodeAddr amodedst
-       addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x
-       addrdst2 = case (addrOffset addrdst1 4) of Just x -> x
-
-       code__2 = asmParThen [codesrc1, codedst1] .
-                 mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
-                               MOV L (OpReg tmp) (OpAddr addrdst1)]
-                              ++
-                              if pk == DoubleRep
-                              then [MOV L (OpAddr addrsrc2) (OpReg tmp),
-                                    MOV L (OpReg tmp) (OpAddr addrdst2)]
-                              else [])
-    in
-    returnUs code__2
+#if i386_TARGET_ARCH

 
 

-assignFltCode pk (StInd _ dst) src
-  = --getNewRegNCG pk              `thenUs` \ tmp ->
-    getAmode dst                   `thenUs` \ amode ->
-    getRegister src                        `thenUs` \ register ->
+-- Floating point assignment to memory
+assignMem_FltCode pk addr src
+   = getRegister src      `thenNat`  \ reg_src  ->
+     getRegister addr     `thenNat`  \ reg_addr ->
+     getNewRegNCG pk      `thenNat`  \ tmp_src  ->
+     getNewRegNCG PtrRep  `thenNat`  \ tmp_addr ->
+     let r_src  = registerName reg_src tmp_src
+         c_src  = registerCode reg_src tmp_src
+         r_addr = registerName reg_addr tmp_addr
+         c_addr = registerCode reg_addr tmp_addr
+         sz     = primRepToSize pk
+
+         code = c_src  `appOL`
+                -- no need to preserve r_src across the addr computation,
+                -- since r_src must be a float reg 
+                -- whilst r_addr is an int reg
+                c_addr `snocOL`
+                GST sz r_src 
+                       (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
+     in
+     returnNat code
+
+-- Floating point assignment to a register/temporary
+assignReg_FltCode pk reg src
+  = getRegisterReg reg             `thenNat` \ reg_dst ->
+    getRegister src                `thenNat` \ reg_src ->
+    getNewRegNCG pk                 `thenNat` \ tmp ->

     let
     let

-       sz      = primRepToSize pk
-       dst__2  = amodeAddr amode
-
-       code1   = amodeCode amode asmVoid
-       code2   = registerCode register {-tmp-}st0 asmVoid
+       r_dst = registerName reg_dst tmp
+       r_src = registerName reg_src r_dst
+       c_src = registerCode reg_src r_dst

 
 

-       --src__2= registerName register tmp
-       pk__2   = registerRep register
-       sz__2   = primRepToSize pk__2
-
-       code__2 = asmParThen [code1, code2] .
-                 mkSeqInstr (FSTP sz (OpAddr dst__2))
+       code = if   isFixed reg_src
+               then c_src `snocOL` GMOV r_src r_dst
+               else c_src

     in
     in

-    returnUs code__2
-
-assignFltCode pk dst src
-  = getRegister dst                        `thenUs` \ register1 ->
-    getRegister src                        `thenUs` \ register2 ->
-    --getNewRegNCG (registerRep register2)
-    --                             `thenUs` \ tmp ->
-    let
-       sz      = primRepToSize pk
-       dst__2  = registerName register1 st0 --tmp
+    returnNat code

 
 

-       code    = registerCode register2 dst__2
-       src__2  = registerName register2 dst__2

 
 

-       code__2 = code
-    in
-    returnUs code__2
+#endif /* i386_TARGET_ARCH */

 
 

-#endif {- i386_TARGET_ARCH -}

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

+

 #if sparc_TARGET_ARCH
 
 #if sparc_TARGET_ARCH
 

-assignFltCode pk (StInd _ dst) src
-  = getNewRegNCG pk                `thenUs` \ tmp1 ->
-    getAmode dst                   `thenUs` \ amode ->
-    getRegister src                `thenUs` \ register ->
+-- Floating point assignment to memory
+assignMem_FltCode pk addr src
+  = getNewRegNCG pk                `thenNat` \ tmp1 ->
+    getAmode addr                  `thenNat` \ amode ->
+    getRegister src                `thenNat` \ register ->

     let
        sz      = primRepToSize pk
        dst__2  = amodeAddr amode
 
     let
        sz      = primRepToSize pk
        dst__2  = amodeAddr amode
 

-       code1   = amodeCode amode asmVoid
-       code2   = registerCode register tmp1 asmVoid
+       code1   = amodeCode amode
+       code2   = registerCode register tmp1

 
        src__2  = registerName register tmp1
        pk__2   = registerRep register
        sz__2   = primRepToSize pk__2
 
 
        src__2  = registerName register tmp1
        pk__2   = registerRep register
        sz__2   = primRepToSize pk__2
 

-       code__2 = asmParThen [code1, code2] .
-           if pk == pk__2 then
-                   mkSeqInstr (ST sz src__2 dst__2)
-           else
-               mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
+       code__2 = code1 `appOL` code2 `appOL`
+           if   pk == pk__2 
+            then unitOL (ST sz src__2 dst__2)
+           else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]

     in
     in

-    returnUs code__2
+    returnNat code__2

 
 

-assignFltCode pk dst src
-  = getRegister dst                        `thenUs` \ register1 ->
-    getRegister src                        `thenUs` \ register2 ->
+-- Floating point assignment to a register/temporary
+-- Why is this so bizarrely ugly?
+assignReg_FltCode pk reg src
+  = getRegisterReg reg                     `thenNat` \ register1 ->
+    getRegister src                        `thenNat` \ register2 ->

     let 
         pk__2   = registerRep register2 
         sz__2   = primRepToSize pk__2
     in
     let 
         pk__2   = registerRep register2 
         sz__2   = primRepToSize pk__2
     in

-    getNewRegNCG pk__2                      `thenUs` \ tmp ->
+    getNewRegNCG pk__2                      `thenNat` \ tmp ->

     let
        sz      = primRepToSize pk
        dst__2  = registerName register1 g0    -- must be Fixed
     let
        sz      = primRepToSize pk
        dst__2  = registerName register1 g0    -- must be Fixed

- 
-

        reg__2  = if pk /= pk__2 then tmp else dst__2
        reg__2  = if pk /= pk__2 then tmp else dst__2

- 

        code    = registerCode register2 reg__2
        code    = registerCode register2 reg__2

-

        src__2  = registerName register2 reg__2
        src__2  = registerName register2 reg__2

-

        code__2 = 
                if pk /= pk__2 then
        code__2 = 
                if pk /= pk__2 then

-                    code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
+                    code `snocOL` FxTOy sz__2 sz src__2 dst__2

                else if isFixed register2 then
                else if isFixed register2 then

-                    code . mkSeqInstr (FMOV sz src__2 dst__2)
+                    code `snocOL` FMOV sz src__2 dst__2

                else
                     code
     in
                else
                     code
     in

-    returnUs code__2
+    returnNat code__2
+
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+
+-- Floating point assignment to memory
+assignMem_FltCode pk addr src
+  = getNewRegNCG pk                `thenNat` \ tmp1 ->
+    getAmode addr                  `thenNat` \ amode ->
+    getRegister src                `thenNat` \ register ->
+    let
+       sz      = primRepToSize pk
+       dst__2  = amodeAddr amode
+
+       code1   = amodeCode amode
+       code2   = registerCode register tmp1
+
+       src__2  = registerName register tmp1
+       pk__2   = registerRep register
+
+       code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
+    in
+    returnNat code__2

 
 

-#endif {- sparc_TARGET_ARCH -}
+-- Floating point assignment to a register/temporary
+assignReg_FltCode pk reg src
+  = getRegisterReg reg             `thenNat` \ reg_dst ->
+    getRegister src                `thenNat` \ reg_src ->
+    getNewRegNCG pk                 `thenNat` \ tmp ->
+    let
+       r_dst = registerName reg_dst tmp
+       r_src = registerName reg_src r_dst
+       c_src = registerCode reg_src r_dst
+
+       code = if   isFixed reg_src
+               then c_src `snocOL` MR r_dst r_src
+               else c_src
+    in
+    returnNat code
+#endif /* powerpc_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -1929,7 +2807,9 @@ branch instruction.  Other CLabels are assumed to be far away.
 register allocator.
 
 \begin{code}
 register allocator.
 
 \begin{code}

-genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
+genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 
 #if alpha_TARGET_ARCH
 
 
 #if alpha_TARGET_ARCH
 

@@ -1940,8 +2820,8 @@ genJump (StCLbl lbl)
     target = ImmCLbl lbl
 
 genJump tree
     target = ImmCLbl lbl
 
 genJump tree

-  = getRegister tree                       `thenUs` \ register ->
-    getNewRegNCG PtrRep            `thenUs` \ tmp ->
+  = getRegister tree               `thenNat` \ register ->
+    getNewRegNCG PtrRep            `thenNat` \ tmp ->

     let
        dst    = registerName register pv
        code   = registerCode register pv
     let
        dst    = registerName register pv
        code   = registerCode register pv

@@ -1950,64 +2830,80 @@ genJump tree
     if isFixed register then
        returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
     else
     if isFixed register then
        returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
     else

-    returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
+    returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
+
+#endif /* alpha_TARGET_ARCH */

 
 

-#endif {- alpha_TARGET_ARCH -}

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

-#if i386_TARGET_ARCH

 
 

-{-
-genJump (StCLbl lbl)
-  | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
-  | otherwise     = returnInstrs [JMP (OpImm target)]
-  where
-    target = ImmCLbl lbl
--}
+#if i386_TARGET_ARCH

 
 

-genJump (StInd pk mem)
-  = getAmode mem                   `thenUs` \ amode ->
+genJump dsts (StInd pk mem)
+  = getAmode mem                   `thenNat` \ amode ->

     let
        code   = amodeCode amode
        target = amodeAddr amode
     in
     let
        code   = amodeCode amode
        target = amodeAddr amode
     in

-    returnSeq code [JMP (OpAddr target)]
+    returnNat (code `snocOL` JMP dsts (OpAddr target))

 
 

-genJump tree
+genJump dsts tree

   | maybeToBool imm
   | maybeToBool imm

-  = returnInstr (JMP (OpImm target))
+  = returnNat (unitOL (JMP dsts (OpImm target)))

 
   | otherwise
 
   | otherwise

-  = getRegister tree                       `thenUs` \ register ->
-    getNewRegNCG PtrRep            `thenUs` \ tmp ->
+  = getRegister tree               `thenNat` \ register ->
+    getNewRegNCG PtrRep            `thenNat` \ tmp ->

     let
        code   = registerCode register tmp
        target = registerName register tmp
     in
     let
        code   = registerCode register tmp
        target = registerName register tmp
     in

-    returnSeq code [JMP (OpReg target)]
+    returnNat (code `snocOL` JMP dsts (OpReg target))

   where
     imm    = maybeImm tree
     target = case imm of Just x -> x
 
   where
     imm    = maybeImm tree
     target = case imm of Just x -> x
 

-#endif {- i386_TARGET_ARCH -}
+#endif /* i386_TARGET_ARCH */
+

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

+

 #if sparc_TARGET_ARCH
 
 #if sparc_TARGET_ARCH
 

-genJump (StCLbl lbl)
-  | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
-  | otherwise     = returnInstrs [CALL target 0 True, NOP]
+genJump dsts (StCLbl lbl)
+  | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
+  | isAsmTemp lbl    = returnNat (toOL [BI ALWAYS False target, NOP])
+  | otherwise        = returnNat (toOL [CALL (Left target) 0 True, NOP])

   where
     target = ImmCLbl lbl
 
   where
     target = ImmCLbl lbl
 

-genJump tree
-  = getRegister tree                       `thenUs` \ register ->
-    getNewRegNCG PtrRep            `thenUs` \ tmp ->
+genJump dsts tree
+  = getRegister tree                       `thenNat` \ register ->
+    getNewRegNCG PtrRep            `thenNat` \ tmp ->
+    let
+       code   = registerCode register tmp
+       target = registerName register tmp
+    in
+    returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
+
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+genJump dsts (StCLbl lbl)
+  | hasDestInfo dsts = panic "genJump(powerpc): CLbl and dsts"
+  | otherwise        = returnNat (toOL [BCC ALWAYS lbl])
+
+genJump dsts tree
+  = getRegister tree                       `thenNat` \ register ->
+    getNewRegNCG PtrRep            `thenNat` \ tmp ->

     let
        code   = registerCode register tmp
        target = registerName register tmp
     in
     let
        code   = registerCode register tmp
        target = registerName register tmp
     in

-    returnSeq code [JMP (AddrRegReg target g0), NOP]
+    returnNat (code `snocOL` MTCTR target `snocOL` BCTR dsts)
+#endif /* sparc_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 
 

-#endif {- sparc_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -2038,15 +2934,17 @@ allocator.
 \begin{code}
 genCondJump
     :: CLabel      -- the branch target
 \begin{code}
 genCondJump
     :: CLabel      -- the branch target

-    -> StixTree     -- the condition on which to branch
-    -> UniqSM InstrBlock
+    -> StixExpr     -- the condition on which to branch
+    -> NatM InstrBlock
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 
 #if alpha_TARGET_ARCH
 
 genCondJump lbl (StPrim op [x, StInt 0])
 
 #if alpha_TARGET_ARCH
 
 genCondJump lbl (StPrim op [x, StInt 0])

-  = getRegister x                          `thenUs` \ register ->
+  = getRegister x                          `thenNat` \ register ->

     getNewRegNCG (registerRep register)
     getNewRegNCG (registerRep register)

-                                   `thenUs` \ tmp ->
+                                   `thenNat` \ tmp ->

     let
        code   = registerCode register tmp
        value  = registerName register tmp
     let
        code   = registerCode register tmp
        value  = registerName register tmp

@@ -2081,16 +2979,16 @@ genCondJump lbl (StPrim op [x, StInt 0])
     cmpOp AddrLeOp = EQQ
 
 genCondJump lbl (StPrim op [x, StDouble 0.0])
     cmpOp AddrLeOp = EQQ
 
 genCondJump lbl (StPrim op [x, StDouble 0.0])

-  = getRegister x                          `thenUs` \ register ->
+  = getRegister x                          `thenNat` \ register ->

     getNewRegNCG (registerRep register)
     getNewRegNCG (registerRep register)

-                                   `thenUs` \ tmp ->
+                                   `thenNat` \ tmp ->

     let
        code   = registerCode register tmp
        value  = registerName register tmp
        pk     = registerRep register
        target = ImmCLbl lbl
     in
     let
        code   = registerCode register tmp
        value  = registerName register tmp
        pk     = registerRep register
        target = ImmCLbl lbl
     in

-    returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
+    returnNat (code . mkSeqInstr (BF (cmpOp op) value target))

   where
     cmpOp FloatGtOp = GTT
     cmpOp FloatGeOp = GE
   where
     cmpOp FloatGtOp = GTT
     cmpOp FloatGeOp = GE

@@ -2107,14 +3005,14 @@ genCondJump lbl (StPrim op [x, StDouble 0.0])
 
 genCondJump lbl (StPrim op [x, y])
   | fltCmpOp op
 
 genCondJump lbl (StPrim op [x, y])
   | fltCmpOp op

-  = trivialFCode pr instr x y      `thenUs` \ register ->
-    getNewRegNCG DoubleRep         `thenUs` \ tmp ->
+  = trivialFCode pr instr x y      `thenNat` \ register ->
+    getNewRegNCG DoubleRep         `thenNat` \ tmp ->

     let
        code   = registerCode register tmp
        result = registerName register tmp
        target = ImmCLbl lbl
     in
     let
        code   = registerCode register tmp
        result = registerName register tmp
        target = ImmCLbl lbl
     in

-    returnUs (code . mkSeqInstr (BF cond result target))
+    returnNat (code . mkSeqInstr (BF cond result target))

   where
     pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
 
   where
     pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
 

@@ -2147,14 +3045,14 @@ genCondJump lbl (StPrim op [x, y])
        DoubleLeOp -> (FCMP TF LE, NE)
 
 genCondJump lbl (StPrim op [x, y])
        DoubleLeOp -> (FCMP TF LE, NE)
 
 genCondJump lbl (StPrim op [x, y])

-  = trivialCode instr x y          `thenUs` \ register ->
-    getNewRegNCG IntRep            `thenUs` \ tmp ->
+  = trivialCode instr x y          `thenNat` \ register ->
+    getNewRegNCG IntRep            `thenNat` \ tmp ->

     let
        code   = registerCode register tmp
        result = registerName register tmp
        target = ImmCLbl lbl
     in
     let
        code   = registerCode register tmp
        result = registerName register tmp
        target = ImmCLbl lbl
     in

-    returnUs (code . mkSeqInstr (BI cond result target))
+    returnNat (code . mkSeqInstr (BI cond result target))

   where
     (instr, cond) = case op of
        CharGtOp -> (CMP LE, EQQ)
   where
     (instr, cond) = case op of
        CharGtOp -> (CMP LE, EQQ)

@@ -2182,38 +3080,61 @@ genCondJump lbl (StPrim op [x, y])
        AddrLtOp -> (CMP ULT, NE)
        AddrLeOp -> (CMP ULE, NE)
 
        AddrLtOp -> (CMP ULT, NE)
        AddrLeOp -> (CMP ULE, NE)
 

-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */
+

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

+

 #if i386_TARGET_ARCH
 
 genCondJump lbl bool
 #if i386_TARGET_ARCH
 
 genCondJump lbl bool

-  = getCondCode bool               `thenUs` \ condition ->
+  = getCondCode bool               `thenNat` \ condition ->

     let
        code   = condCode condition
        cond   = condName condition
     let
        code   = condCode condition
        cond   = condName condition

-       target = ImmCLbl lbl

     in
     in

-    returnSeq code [JXX cond lbl]
+    returnNat (code `snocOL` JXX cond lbl)
+
+#endif /* i386_TARGET_ARCH */

 
 

-#endif {- i386_TARGET_ARCH -}

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

+

 #if sparc_TARGET_ARCH
 
 genCondJump lbl bool
 #if sparc_TARGET_ARCH
 
 genCondJump lbl bool

-  = getCondCode bool               `thenUs` \ condition ->
+  = getCondCode bool               `thenNat` \ condition ->

     let
        code   = condCode condition
        cond   = condName condition
        target = ImmCLbl lbl
     in
     let
        code   = condCode condition
        cond   = condName condition
        target = ImmCLbl lbl
     in

-    returnSeq code (
-    if condFloat condition then
-       [NOP, BF cond False target, NOP]
-    else
-       [BI cond False target, NOP]
+    returnNat (
+       code `appOL` 
+       toOL (
+         if   condFloat condition 
+         then [NOP, BF cond False target, NOP]
+         else [BI cond False target, NOP]
+       )

     )
 
     )
 

-#endif {- sparc_TARGET_ARCH -}
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+
+genCondJump lbl bool
+  = getCondCode bool               `thenNat` \ condition ->
+    let
+       code   = condCode condition
+       cond   = condName condition
+       target = ImmCLbl lbl
+    in
+    returnNat (
+       code `snocOL` BCC cond lbl    )
+
+#endif /* powerpc_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -2231,20 +3152,22 @@ register allocator.
 
 \begin{code}
 genCCall
 
 \begin{code}
 genCCall

-    :: FAST_STRING     -- function to call
-    -> CallConv
+    :: (Either FastString StixExpr)    -- function to call
+    -> CCallConv

     -> PrimRep         -- type of the result
     -> PrimRep         -- type of the result

-    -> [StixTree]      -- arguments (of mixed type)
-    -> UniqSM InstrBlock
+    -> [StixExpr]      -- arguments (of mixed type)
+    -> NatM InstrBlock
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 
 #if alpha_TARGET_ARCH
 
 genCCall fn cconv kind args
 
 #if alpha_TARGET_ARCH
 
 genCCall fn cconv kind args

-  = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
-                                   `thenUs` \ ((unused,_), argCode) ->
+  = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
+                         `thenNat` \ ((unused,_), argCode) ->

     let
        nRegs = length allArgRegs - length unused
     let
        nRegs = length allArgRegs - length unused

-       code = asmParThen (map ($ asmVoid) argCode)
+       code = asmSeqThen (map ($ []) argCode)

     in
        returnSeq code [
            LDA pv (AddrImm (ImmLab (ptext fn))),
     in
        returnSeq code [
            LDA pv (AddrImm (ImmLab (ptext fn))),

@@ -2261,24 +3184,24 @@ genCCall fn cconv kind args
        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
        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

-       @mapAccumLUs@.
+       @mapAccumLNat@.

     -}
     get_arg
        :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
        -> StixTree             -- Current argument
     -}
     get_arg
        :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
        -> StixTree             -- Current argument

-       -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
+       -> 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
 
     -- We have to use up all of our argument registers first...
 
     get_arg ((iDst,fDst):dsts, offset) arg

-      = getRegister arg                            `thenUs` \ register ->
+      = getRegister arg                            `thenNat` \ register ->

        let
            reg  = if isFloatingRep pk then fDst else iDst
            code = registerCode register reg
            src  = registerName register reg
            pk   = registerRep register
        in
        let
            reg  = if isFloatingRep pk then fDst else iDst
            code = registerCode register reg
            src  = registerName register reg
            pk   = registerRep register
        in

-       returnUs (
+       returnNat (

            if isFloatingRep pk then
                ((dsts, offset), if isFixed register then
                    code . mkSeqInstr (FMOV src fDst)
            if isFloatingRep pk then
                ((dsts, offset), if isFixed register then
                    code . mkSeqInstr (FMOV src fDst)

@@ -2292,197 +3215,503 @@ genCCall fn cconv kind args
     -- stack...
 
     get_arg ([], offset) arg
     -- stack...
 
     get_arg ([], offset) arg

-      = getRegister arg                        `thenUs` \ register ->
+      = getRegister arg                        `thenNat` \ register ->

        getNewRegNCG (registerRep register)
        getNewRegNCG (registerRep register)

-                                       `thenUs` \ tmp ->
+                                       `thenNat` \ tmp ->

        let
            code = registerCode register tmp
            src  = registerName register tmp
            pk   = registerRep register
            sz   = primRepToSize pk
        in
        let
            code = registerCode register tmp
            src  = registerName register tmp
            pk   = registerRep register
            sz   = primRepToSize pk
        in

-       returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
+       returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
+
+#endif /* alpha_TARGET_ARCH */

 
 

-#endif {- alpha_TARGET_ARCH -}

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

+

 #if i386_TARGET_ARCH
 
 #if i386_TARGET_ARCH
 

-genCCall fn cconv kind [StInt i]
-  | fn == SLIT ("PerformGC_wrapper")
-  = let
-     call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
-            CALL (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))]
+genCCall fn cconv ret_rep args
+  = mapNat push_arg
+           (reverse args)      `thenNat` \ sizes_n_codes ->
+    getDeltaNat                `thenNat` \ delta ->
+    let (sizes, push_codes) = unzip sizes_n_codes
+        tot_arg_size        = sum sizes

     in
     in

-    returnInstrs call
-
-{- OLD:
-  = getUniqLabelNCG                        `thenUs` \ lbl ->
-    let
-       call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
-               MOV L (OpImm (ImmCLbl lbl))
-                     -- this is hardwired
-                     (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 104))),
-               JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
-               LABEL lbl]
+    -- deal with static vs dynamic call targets
+    (case fn of
+        Left t_static 
+           -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
+        Right dyn 
+           -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
+              ASSERT(case dyn_rep of { L -> True; _ -> False})
+              returnNat (dyn_c `snocOL` CALL (Right dyn_r))
+    ) 
+                               `thenNat` \ callinsns ->
+    let        push_code = concatOL push_codes
+       call = callinsns `appOL`
+               toOL (
+                       -- Deallocate parameters after call for ccall;
+                       -- but not for stdcall (callee does it)
+                  (if cconv == StdCallConv then [] else 
+                  [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
+                  ++
+                  [DELTA (delta + tot_arg_size)]
+               )

     in
     in

-    returnInstrs call
--}
+    setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
+    returnNat (push_code `appOL` call)

 
 

-genCCall fn cconv kind args
-  = mapUs get_call_arg args `thenUs` \ argCode ->
-    let
-       nargs = length args
-
-{- OLD: Since there's no attempt at stealing %esp at the moment, 
-   restoring %esp from MainRegTable.rCstkptr is not done.  -- SOF 97/09
-   (ditto for saving away old-esp in MainRegTable.Hp (!!) )
-       code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))),
-                       MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
-                                  ]
-                          ]
--}
-       code2 = asmParThen (map ($ asmVoid) (reverse argCode))
-       call = [CALL fn__2 ,
-               -- pop args; all args word sized?
-               ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp) --,
-               
-               -- Don't restore %esp (see above)
-               -- MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
-               ]
-    in
-    returnSeq (code2) call

   where
     -- function names that begin with '.' are assumed to be special
     -- internally generated names like '.mul,' which don't get an
     -- underscore prefix
     -- ToDo:needed (WDP 96/03) ???
   where
     -- function names that begin with '.' are assumed to be special
     -- internally generated names like '.mul,' which don't get an
     -- underscore prefix
     -- ToDo:needed (WDP 96/03) ???

-    fn__2 = case (_HEAD_ fn) of
-             '.' -> ImmLit (ptext fn)
-             _   -> ImmLab (ptext fn)
+    fn_u  = unpackFS (unLeft fn)
+    fn__2 tot_arg_size
+       | head fn_u == '.'
+       = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
+       | otherwise     -- General case
+       = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))

 
 

-    ------------
-    get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock  -- code
+    stdcallsize tot_arg_size
+       | cconv == StdCallConv = '@':show tot_arg_size
+       | otherwise            = ""

 
 

-    get_call_arg arg
-      = get_op arg             `thenUs` \ (code, op, sz) ->
-       returnUs (code . mkSeqInstr (PUSH sz op))
+    arg_size DF = 8
+    arg_size F  = 4
+    arg_size _  = 4

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

-    get_op
-       :: StixTree
-       -> UniqSM (InstrBlock,Operand, Size)    -- code, operator, size
-
-    get_op (StInt i)
-      = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
+    push_arg :: StixExpr{-current argument-}
+                    -> NatM (Int, InstrBlock)  -- argsz, code
+
+    push_arg arg
+      | is64BitRep arg_rep
+      = iselExpr64 arg                 `thenNat` \ (ChildCode64 code vr_lo) ->
+        getDeltaNat                    `thenNat` \ delta ->
+        setDeltaNat (delta - 8)                `thenNat` \ _ ->
+        let r_lo = VirtualRegI vr_lo
+            r_hi = getHiVRegFromLo r_lo
+        in  returnNat (8,
+                       code `appOL`
+                       toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
+                             PUSH L (OpReg r_lo), DELTA (delta - 8)]
+            )
+      | otherwise
+      = get_op arg                     `thenNat` \ (code, reg, sz) ->
+        getDeltaNat                    `thenNat` \ delta ->
+        arg_size sz                    `bind`    \ size ->
+        setDeltaNat (delta-size)       `thenNat` \ _ ->
+        if   (case sz of DF -> True; F -> True; _ -> False)
+        then returnNat (size,
+                        code `appOL`
+                        toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
+                              DELTA (delta-size),
+                              GST sz reg (AddrBaseIndex (Just esp) 
+                                                        Nothing 
+                                                        (ImmInt 0))]
+                       )
+        else returnNat (size,
+                        code `snocOL`
+                        PUSH L (OpReg reg) `snocOL`
+                        DELTA (delta-size)
+                       )
+      where
+         arg_rep = repOfStixExpr arg

 
 

-    get_op (StInd pk mem)
-      = getAmode mem           `thenUs` \ amode ->
-       let
-           code = amodeCode amode --asmVoid
-           addr = amodeAddr amode
-           sz   = primRepToSize pk
-       in
-       returnUs (code, OpAddr addr, sz)
+    ------------
+    get_op
+       :: StixExpr
+       -> NatM (InstrBlock, Reg, Size) -- code, reg, size

 
     get_op op
 
     get_op op

-      = getRegister op         `thenUs` \ register ->
+      = getRegister op         `thenNat` \ register ->

        getNewRegNCG (registerRep register)
        getNewRegNCG (registerRep register)

-                               `thenUs` \ tmp ->
+                               `thenNat` \ tmp ->

        let
            code = registerCode register tmp
            reg  = registerName register tmp
            pk   = registerRep  register
            sz   = primRepToSize pk
        in
        let
            code = registerCode register tmp
            reg  = registerName register tmp
            pk   = registerRep  register
            sz   = primRepToSize pk
        in

-       returnUs (code, OpReg reg, sz)
+       returnNat (code, reg, sz)
+
+#endif /* i386_TARGET_ARCH */

 
 

-#endif {- i386_TARGET_ARCH -}

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

+

 #if sparc_TARGET_ARCH
 #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 fn cconv kind args
 
 genCCall fn cconv kind args

-  = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
-                                   `thenUs` \ ((unused,_), argCode) ->
+  = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
+    let 
+        (argcodes, vregss) = unzip argcode_and_vregs
+        n_argRegs          = length allArgRegs
+        n_argRegs_used     = min (length vregs) n_argRegs
+        vregs              = concat vregss
+    in
+    -- deal with static vs dynamic call targets
+    (case fn of
+        Left t_static
+           -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
+        Right dyn
+           -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
+              returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
+    )
+                               `thenNat` \ callinsns ->

     let
     let

-       nRegs = length allArgRegs - length unused
-       call = CALL fn__2 nRegs False
-       code = asmParThen (map ($ asmVoid) argCode)
+        argcode = concatOL argcodes
+        (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)))
+        transfer_code
+           = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)

     in
     in

-       returnSeq code [call, NOP]
+        returnNat (argcode       `appOL`
+                   move_sp_down  `appOL`
+                   transfer_code `appOL`
+                   callinsns     `appOL`
+                   unitOL NOP    `appOL`
+                   move_sp_up)

   where
   where

-    -- function names that begin with '.' are assumed to be special
-    -- internally generated names like '.mul,' which don't get an
-    -- underscore prefix
-    -- ToDo:needed (WDP 96/03) ???
-    fn__2 = case (_HEAD_ fn) of
-             '.' -> ImmLit (ptext fn)
-             _   -> ImmLab (ptext fn)
-
-    ------------------------------------
-    {-  Try to get a value into a specific register (or registers) for
-       a call.  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.)  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
-       @mapAccumL@.
-    -}
-    get_arg
-       :: ([Reg],Int)  -- Argument registers and stack offset (accumulator)
-       -> StixTree     -- Current argument
-       -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
-
-    -- We have to use up all of our argument registers first...
+     -- function names that begin with '.' are assumed to be special
+     -- internally generated names like '.mul,' which don't get an
+     -- underscore prefix
+     -- ToDo:needed (WDP 96/03) ???
+     fn_static = unLeft fn
+     fn__2 = case (headFS fn_static) of
+               '.' -> ImmLit (ftext fn_static)
+               _   -> ImmLab False (ftext fn_static)
+
+     -- 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]
+
+     move_final [] _ offset          -- all args done
+        = []
+
+     move_final (v:vs) [] offset     -- out of aregs; move to stack
+        = ST W v (spRel offset)
+          : move_final vs [] (offset+1)
+
+     move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
+        = OR False g0 (RIReg v) a
+          : move_final vs az offset
+
+     -- generate code to calculate an argument, and move it into one
+     -- or two integer vregs.
+     arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
+     arg_to_int_vregs arg
+        | is64BitRep (repOfStixExpr arg)
+        = iselExpr64 arg               `thenNat` \ (ChildCode64 code vr_lo) ->
+          let r_lo = VirtualRegI vr_lo
+              r_hi = getHiVRegFromLo r_lo
+          in  returnNat (code, [r_hi, r_lo])
+        | otherwise
+        = getRegister arg                     `thenNat` \ register ->
+          getNewRegNCG (registerRep register) `thenNat` \ tmp ->
+          let code = registerCode register tmp
+              src  = registerName register tmp
+              pk   = registerRep register
+          in
+          -- the value is in src.  Get it into 1 or 2 int vregs.
+          case pk of
+             DoubleRep -> 
+                getNewRegNCG WordRep  `thenNat` \ v1 ->
+                getNewRegNCG WordRep  `thenNat` \ v2 ->
+                returnNat (
+                   code                          `snocOL`
+                   FMOV DF src f0                `snocOL`
+                   ST   F  f0 (spRel 16)         `snocOL`
+                   LD   W  (spRel 16) v1         `snocOL`
+                   ST   F  (fPair f0) (spRel 16) `snocOL`
+                   LD   W  (spRel 16) v2
+                   ,
+                   [v1,v2]
+                )
+             FloatRep -> 
+                getNewRegNCG WordRep  `thenNat` \ v1 ->
+                returnNat (
+                   code                    `snocOL`
+                   ST   F  src (spRel 16)  `snocOL`
+                   LD   W  (spRel 16) v1
+                   ,
+                   [v1]
+                )
+             other ->
+                getNewRegNCG WordRep  `thenNat` \ v1 ->
+                returnNat (
+                   code `snocOL` OR False g0 (RIReg src) v1
+                   , 
+                   [v1]
+                )
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+
+#if darwin_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".
+    Parameters may be passed in general-purpose registers, in
+    floating point registers, or on the stack. 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.
+    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 space that we should use as a parameter area for register
+    spilling, so we allocate a new stack frame just before ccalling.
+    That way we don't need to decide beforehand how much space to
+    reserve for parameters.
+-}

 
 

-    get_arg (dst:dsts, offset) arg
-      = getRegister arg                        `thenUs` \ register ->
-       getNewRegNCG (registerRep register)
-                                       `thenUs` \ tmp ->
+genCCall fn cconv kind args
+  = mapNat prepArg args `thenNat` \ preppedArgs ->
+    let
+       (argReps,argCodes,vregs) = unzip3 preppedArgs
+
+           -- size of linkage area + size of arguments, in bytes
+       stackDelta = roundTo16 $ (24 +) $ max 32 $ (4 *) $ sum $ map getPrimRepSize argReps
+       roundTo16 x | x `mod` 16 == 0 = x
+                   | otherwise = x + 16 - (x `mod` 16)
+
+       move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
+       move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
+
+       (moveFinalCode,usedRegs) = move_final
+                                       (zip vregs argReps)
+                                       allArgRegs allFPArgRegs
+                                       eXTRA_STK_ARGS_HERE
+                                       (toOL []) []
+
+       passArguments = concatOL argCodes
+           `appOL` move_sp_down
+           `appOL` moveFinalCode
+    in 
+       case fn of
+           Left lbl ->
+               addImportNat lbl                        `thenNat` \ _ ->
+               returnNat (passArguments
+                           `snocOL`    BL (ImmLit $ ftext 
+                                            (FSLIT("L_")
+                                            `appendFS` lbl
+                                            `appendFS` FSLIT("$stub")))
+                                          usedRegs
+                           `appOL`     move_sp_up)
+           Right dyn ->
+               getRegister dyn                         `thenNat` \ dynReg ->
+               getNewRegNCG (registerRep dynReg)       `thenNat` \ tmp ->
+               returnNat (registerCode dynReg tmp
+                           `appOL`     passArguments
+                           `snocOL`    MTCTR (registerName dynReg tmp)
+                           `snocOL`    BCTRL usedRegs
+                           `appOL`     move_sp_up)
+    where
+    prepArg arg
+        | is64BitRep (repOfStixExpr arg)
+        = iselExpr64 arg               `thenNat` \ (ChildCode64 code vr_lo) ->
+          let r_lo = VirtualRegI vr_lo
+              r_hi = getHiVRegFromLo r_lo
+          in  returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
+       | otherwise
+       = getRegister arg                       `thenNat` \ register ->
+         getNewRegNCG (registerRep register)   `thenNat` \ tmp ->
+         returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
+    move_final [] _ _ _ accumCode accumUsed = (accumCode, accumUsed)
+    move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
+       | not (is64BitRep rep) =
+       case rep of
+           FloatRep ->
+               move_final vregs (drop 1 gprs) (drop 1 fprs) (stackOffset+4)
+                   (accumCode `snocOL`
+                       (case fprs of
+                           fpr : fprs -> MR fpr vr
+                           [] -> ST F vr (AddrRegImm sp (ImmInt stackOffset))))
+                   ((take 1 fprs) ++ accumUsed)
+           DoubleRep ->
+               move_final vregs (drop 2 gprs) (drop 1 fprs) (stackOffset+8)
+                   (accumCode `snocOL`
+                       (case fprs of
+                           fpr : fprs -> MR fpr vr
+                           [] -> ST DF vr (AddrRegImm sp (ImmInt stackOffset))))
+                   ((take 1 fprs) ++ accumUsed)
+           VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
+           _ ->
+               move_final vregs (drop 1 gprs) fprs (stackOffset+4)
+                   (accumCode `snocOL`
+                       (case gprs of
+                           gpr : gprs -> MR gpr vr
+                           [] -> ST W vr (AddrRegImm sp (ImmInt stackOffset))))
+                   ((take 1 gprs) ++ accumUsed)
+               
+    move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
+       | is64BitRep rep =

        let
        let

-           reg  = if isFloatingRep pk then tmp else dst
-           code = registerCode register reg
-           src  = registerName register reg
-           pk   = registerRep register
+           storeWord vr (gpr:_) offset = MR gpr vr
+           storeWord vr [] offset = ST W vr (AddrRegImm sp (ImmInt offset))

        in
        in

-       returnUs (case pk of
-           DoubleRep ->
-               case dsts of
-                   [] -> (([], offset + 1), code . mkSeqInstrs [
-                           -- conveniently put the second part in the right stack
-                           -- location, and load the first part into %o5
-                           ST DF src (spRel (offset - 1)),
-                           LD W (spRel (offset - 1)) dst])
-                   (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
-                           ST DF src (spRel (-2)),
-                           LD W (spRel (-2)) dst,
-                           LD W (spRel (-1)) dst__2])
-           FloatRep -> ((dsts, offset), code . mkSeqInstrs [
-                           ST F src (spRel (-2)),
-                           LD W (spRel (-2)) dst])
-           _ -> ((dsts, offset), if isFixed register then
-                                 code . mkSeqInstr (OR False g0 (RIReg src) dst)
-                                 else code))
+           move_final vregs (drop 2 gprs) fprs (stackOffset+8)
+               (accumCode
+                   `snocOL` storeWord vr_hi gprs stackOffset
+                   `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
+               ((take 2 gprs) ++ accumUsed)
+#else

 
 

-    -- Once we have run out of argument registers, we move to the
-    -- stack...
+{-
+    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".
+    
+    Like the Darwin/Mac OS X code above, this allocates a new stack frame
+    so that the parameter area doesn't conflict with the spill slots.
+-}

 
 

-    get_arg ([], offset) arg
-      = getRegister arg                        `thenUs` \ register ->
-       getNewRegNCG (registerRep register)
-                                       `thenUs` \ tmp ->
-       let
-           code  = registerCode register tmp
-           src   = registerName register tmp
-           pk    = registerRep register
-           sz    = primRepToSize pk
-           words = if pk == DoubleRep then 2 else 1
-       in
-       returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
+genCCall fn cconv kind args
+  = mapNat prepArg args `thenNat` \ preppedArgs ->
+    let
+       (argReps,argCodes,vregs) = unzip3 preppedArgs
+
+           -- size of linkage area + size of arguments, in bytes
+       stackDelta = roundTo16 finalStack
+       roundTo16 x | x `mod` 16 == 0 = x
+                   | otherwise = x + 16 - (x `mod` 16)
+
+       move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
+       move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
+
+       (moveFinalCode,usedRegs,finalStack) =
+            move_final (zip vregs argReps)
+                      allArgRegs allFPArgRegs
+                      eXTRA_STK_ARGS_HERE
+                      (toOL []) []
+
+       passArguments = concatOL argCodes
+           `appOL` move_sp_down
+           `appOL` moveFinalCode
+    in 
+       case fn of
+           Left lbl ->
+               addImportNat lbl                        `thenNat` \ _ ->
+               returnNat (passArguments
+                           `snocOL`    BL (ImmLit $ ftext  lbl)
+                                          usedRegs
+                           `appOL`     move_sp_up)
+           Right dyn ->
+               getRegister dyn                         `thenNat` \ dynReg ->
+               getNewRegNCG (registerRep dynReg)       `thenNat` \ tmp ->
+               returnNat (registerCode dynReg tmp
+                           `appOL`     passArguments
+                           `snocOL`    MTCTR (registerName dynReg tmp)
+                           `snocOL`    BCTRL usedRegs
+                           `appOL`     move_sp_up)
+    where
+    prepArg arg
+        | is64BitRep (repOfStixExpr arg)
+        = iselExpr64 arg               `thenNat` \ (ChildCode64 code vr_lo) ->
+          let r_lo = VirtualRegI vr_lo
+              r_hi = getHiVRegFromLo r_lo
+          in  returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
+       | otherwise
+       = getRegister arg                       `thenNat` \ register ->
+         getNewRegNCG (registerRep register)   `thenNat` \ tmp ->
+         returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
+    move_final [] _ _ stackOffset accumCode accumUsed = (accumCode, accumUsed, stackOffset)
+    move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
+       | not (is64BitRep rep) =
+       case rep of
+           FloatRep ->
+                case fprs of
+                    fpr : fprs' -> move_final vregs gprs fprs' stackOffset
+                                              (accumCode `snocOL` MR fpr vr)
+                                              (fpr : accumUsed)
+                    [] -> move_final vregs gprs fprs (stackOffset+4)
+                                     (accumCode `snocOL`
+                                        ST F vr (AddrRegImm sp (ImmInt stackOffset)))
+                                     accumUsed
+           DoubleRep ->
+                case fprs of
+                    fpr : fprs' -> move_final vregs gprs fprs' stackOffset
+                                              (accumCode `snocOL` MR fpr vr)
+                                              (fpr : accumUsed)
+                    [] -> move_final vregs gprs fprs (stackOffset+8)
+                                     (accumCode `snocOL`
+                                        ST DF vr (AddrRegImm sp (ImmInt stackOffset)))
+                                     accumUsed
+           VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
+           _ ->
+                case gprs of
+                    gpr : gprs' -> move_final vregs gprs' fprs stackOffset
+                                              (accumCode `snocOL` MR gpr vr)
+                                              (gpr : accumUsed)
+                    [] -> move_final vregs gprs fprs (stackOffset+4)
+                                     (accumCode `snocOL`
+                                        ST W vr (AddrRegImm sp (ImmInt stackOffset)))
+                                     accumUsed
+               
+    move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
+       | is64BitRep rep =
+            case gprs of
+                hireg : loreg : regs | even (length gprs) ->
+                    move_final vregs regs fprs stackOffset
+                               (regCode hireg loreg) accumUsed
+                _skipped : hireg : loreg : regs ->
+                    move_final vregs regs fprs stackOffset
+                               (regCode hireg loreg) accumUsed
+                _ -> -- only one or no regs left
+                    move_final vregs [] fprs (stackOffset+8)
+                               stackCode accumUsed
+       where
+            stackCode =
+                accumCode
+                    `snocOL` ST W vr_hi (AddrRegImm sp (ImmInt stackOffset))
+                    `snocOL` ST W vr_lo (AddrRegImm sp (ImmInt (stackOffset+4)))
+            regCode hireg loreg =
+                accumCode
+                    `snocOL` MR hireg vr_hi
+                    `snocOL` MR loreg vr_lo
+
+#endif                
+                
+#endif /* powerpc_TARGET_ARCH */

 
 

-#endif {- sparc_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -2504,41 +3733,40 @@ the right hand side of an assignment).
 register allocator.
 
 \begin{code}
 register allocator.
 
 \begin{code}

-condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
+condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 
 #if alpha_TARGET_ARCH
 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
 
 #if alpha_TARGET_ARCH
 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
 condFltReg = panic "MachCode.condFltReg (not on Alpha)"

-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */

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

+

 #if i386_TARGET_ARCH
 
 condIntReg cond x y
 #if i386_TARGET_ARCH
 
 condIntReg cond x y

-  = condIntCode cond x y       `thenUs` \ condition ->
-    getNewRegNCG IntRep                `thenUs` \ tmp ->
-    --getRegister dst          `thenUs` \ register ->
+  = condIntCode cond x y       `thenNat` \ condition ->
+    getNewRegNCG IntRep                `thenNat` \ tmp ->

     let
     let

-       --code2 = registerCode register tmp asmVoid
-       --dst__2  = registerName register tmp

        code = condCode condition
        cond = condName condition
        code = condCode condition
        cond = condName condition

-       -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
-       code__2 dst = code . mkSeqInstrs [
+       code__2 dst = code `appOL` toOL [

            SETCC cond (OpReg tmp),
            AND L (OpImm (ImmInt 1)) (OpReg tmp),
            MOV L (OpReg tmp) (OpReg dst)]
     in
            SETCC cond (OpReg tmp),
            AND L (OpImm (ImmInt 1)) (OpReg tmp),
            MOV L (OpReg tmp) (OpReg dst)]
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)

 
 condFltReg cond x y
 
 condFltReg cond x y

-  = getUniqLabelNCG            `thenUs` \ lbl1 ->
-    getUniqLabelNCG            `thenUs` \ lbl2 ->
-    condFltCode cond x y       `thenUs` \ condition ->
+  = getNatLabelNCG             `thenNat` \ lbl1 ->
+    getNatLabelNCG             `thenNat` \ lbl2 ->
+    condFltCode cond x y       `thenNat` \ condition ->

     let
        code = condCode condition
        cond = condName condition
     let
        code = condCode condition
        cond = condName condition

-       code__2 dst = code . mkSeqInstrs [
+       code__2 dst = code `appOL` toOL [

            JXX cond lbl1,
            MOV L (OpImm (ImmInt 0)) (OpReg dst),
            JXX ALWAYS lbl2,
            JXX cond lbl1,
            MOV L (OpImm (ImmInt 0)) (OpReg dst),
            JXX ALWAYS lbl2,

@@ -2546,78 +3774,80 @@ condFltReg cond x y
            MOV L (OpImm (ImmInt 1)) (OpReg dst),
            LABEL lbl2]
     in
            MOV L (OpImm (ImmInt 1)) (OpReg dst),
            LABEL lbl2]
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)
+
+#endif /* i386_TARGET_ARCH */

 
 

-#endif {- i386_TARGET_ARCH -}

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

+

 #if sparc_TARGET_ARCH
 
 condIntReg EQQ x (StInt 0)
 #if sparc_TARGET_ARCH
 
 condIntReg EQQ x (StInt 0)

-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG IntRep                `thenUs` \ tmp ->
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG IntRep                `thenNat` \ tmp ->

     let
        code = registerCode register tmp
        src  = registerName register tmp
     let
        code = registerCode register tmp
        src  = registerName register tmp

-       code__2 dst = code . mkSeqInstrs [
+       code__2 dst = code `appOL` toOL [

            SUB False True g0 (RIReg src) g0,
            SUB True False g0 (RIImm (ImmInt (-1))) dst]
     in
            SUB False True g0 (RIReg src) g0,
            SUB True False g0 (RIImm (ImmInt (-1))) dst]
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)

 
 condIntReg EQQ x y
 
 condIntReg EQQ x y

-  = getRegister x              `thenUs` \ register1 ->
-    getRegister y              `thenUs` \ register2 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp1 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp2 ->
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp1 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp2 ->

     let
     let

-       code1 = registerCode register1 tmp1 asmVoid
+       code1 = registerCode register1 tmp1

        src1  = registerName register1 tmp1
        src1  = registerName register1 tmp1

-       code2 = registerCode register2 tmp2 asmVoid
+       code2 = registerCode register2 tmp2

        src2  = registerName register2 tmp2
        src2  = registerName register2 tmp2

-       code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
+       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]
     in
            XOR False src1 (RIReg src2) dst,
            SUB False True g0 (RIReg dst) g0,
            SUB True False g0 (RIImm (ImmInt (-1))) dst]
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)

 
 condIntReg NE x (StInt 0)
 
 condIntReg NE x (StInt 0)

-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG IntRep        `thenUs` \ tmp ->
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG IntRep        `thenNat` \ tmp ->

     let
        code = registerCode register tmp
        src  = registerName register tmp
     let
        code = registerCode register tmp
        src  = registerName register tmp

-       code__2 dst = code . mkSeqInstrs [
+       code__2 dst = code `appOL` toOL [

            SUB False True g0 (RIReg src) g0,
            ADD True False g0 (RIImm (ImmInt 0)) dst]
     in
            SUB False True g0 (RIReg src) g0,
            ADD True False g0 (RIImm (ImmInt 0)) dst]
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)

 
 condIntReg NE x y
 
 condIntReg NE x y

-  = getRegister x              `thenUs` \ register1 ->
-    getRegister y              `thenUs` \ register2 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp1 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp2 ->
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp1 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp2 ->

     let
     let

-       code1 = registerCode register1 tmp1 asmVoid
+       code1 = registerCode register1 tmp1

        src1  = registerName register1 tmp1
        src1  = registerName register1 tmp1

-       code2 = registerCode register2 tmp2 asmVoid
+       code2 = registerCode register2 tmp2

        src2  = registerName register2 tmp2
        src2  = registerName register2 tmp2

-       code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
+       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]
     in
            XOR False src1 (RIReg src2) dst,
            SUB False True g0 (RIReg dst) g0,
            ADD True False g0 (RIImm (ImmInt 0)) dst]
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)

 
 condIntReg cond x y
 
 condIntReg cond x y

-  = getUniqLabelNCG            `thenUs` \ lbl1 ->
-    getUniqLabelNCG            `thenUs` \ lbl2 ->
-    condIntCode cond x y       `thenUs` \ condition ->
+  = getNatLabelNCG             `thenNat` \ lbl1 ->
+    getNatLabelNCG             `thenNat` \ lbl2 ->
+    condIntCode cond x y       `thenNat` \ condition ->

     let
        code = condCode condition
        cond = condName condition
     let
        code = condCode condition
        cond = condName condition

-       code__2 dst = code . mkSeqInstrs [
+       code__2 dst = code `appOL` toOL [

            BI cond False (ImmCLbl lbl1), NOP,
            OR False g0 (RIImm (ImmInt 0)) dst,
            BI ALWAYS False (ImmCLbl lbl2), NOP,
            BI cond False (ImmCLbl lbl1), NOP,
            OR False g0 (RIImm (ImmInt 0)) dst,
            BI ALWAYS False (ImmCLbl lbl2), NOP,

@@ -2625,16 +3855,16 @@ condIntReg cond x y
            OR False g0 (RIImm (ImmInt 1)) dst,
            LABEL lbl2]
     in
            OR False g0 (RIImm (ImmInt 1)) dst,
            LABEL lbl2]
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)

 
 condFltReg cond x y
 
 condFltReg cond x y

-  = getUniqLabelNCG            `thenUs` \ lbl1 ->
-    getUniqLabelNCG            `thenUs` \ lbl2 ->
-    condFltCode cond x y       `thenUs` \ condition ->
+  = getNatLabelNCG             `thenNat` \ lbl1 ->
+    getNatLabelNCG             `thenNat` \ lbl2 ->
+    condFltCode cond x y       `thenNat` \ condition ->

     let
        code = condCode condition
        cond = condName condition
     let
        code = condCode condition
        cond = condName condition

-       code__2 dst = code . mkSeqInstrs [
+       code__2 dst = code `appOL` toOL [

            NOP,
            BF cond False (ImmCLbl lbl1), NOP,
            OR False g0 (RIImm (ImmInt 0)) dst,
            NOP,
            BF cond False (ImmCLbl lbl1), NOP,
            OR False g0 (RIImm (ImmInt 0)) dst,

@@ -2643,9 +3873,39 @@ condFltReg cond x y
            OR False g0 (RIImm (ImmInt 1)) dst,
            LABEL lbl2]
     in
            OR False g0 (RIImm (ImmInt 1)) dst,
            LABEL lbl2]
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)
+
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+condIntReg cond x y
+  = getNatLabelNCG             `thenNat` \ lbl ->
+    condIntCode cond x y       `thenNat` \ condition ->
+    let
+       code = condCode condition
+       cond = condName condition
+       code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
+           BCC cond lbl,
+           LI dst (ImmInt 0),
+           LABEL lbl]
+    in
+    returnNat (Any IntRep code__2)
+
+condFltReg cond x y
+  = getNatLabelNCG             `thenNat` \ lbl ->
+    condFltCode cond x y       `thenNat` \ condition ->
+    let
+       code = condCode condition
+       cond = condName condition
+       code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
+           BCC cond lbl,
+           LI dst (ImmInt 0),
+           LABEL lbl]
+    in
+    returnNat (Any IntRep code__2)
+#endif /* powerpc_TARGET_ARCH */

 
 

-#endif {- sparc_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -2666,89 +3926,91 @@ have handled the constant-folding.
 \begin{code}
 trivialCode
     :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
 \begin{code}
 trivialCode
     :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)

-      ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
+      ,IF_ARCH_i386 ((Operand -> Operand -> Instr) 
+                     -> Maybe (Operand -> Operand -> Instr)

       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)

-      ,)))
-    -> StixTree -> StixTree -- the two arguments
-    -> UniqSM Register
+      ,IF_ARCH_powerpc((Reg -> Reg -> RI -> Instr)
+      ,))))
+    -> StixExpr -> StixExpr -- the two arguments
+    -> NatM Register

 
 trivialFCode
     :: PrimRep
     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
 
 trivialFCode
     :: PrimRep
     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)

-      ,IF_ARCH_i386 (
-             {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
-              (Size -> Operand -> Instr)
-           -> (Size -> Operand -> Instr) {-reversed instr-}
-           -> Instr {-pop-}
-           -> Instr {-reversed instr: pop-}
-      ,)))
-    -> StixTree -> StixTree -- the two arguments
-    -> UniqSM Register
+      ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
+      ,IF_ARCH_powerpc((Size -> Reg -> Reg -> Reg -> Instr)
+      ,))))
+    -> StixExpr -> StixExpr -- the two arguments
+    -> NatM Register

 
 trivialUCode
     :: IF_ARCH_alpha((RI -> Reg -> Instr)
       ,IF_ARCH_i386 ((Operand -> Instr)
       ,IF_ARCH_sparc((RI -> Reg -> Instr)
 
 trivialUCode
     :: IF_ARCH_alpha((RI -> Reg -> Instr)
       ,IF_ARCH_i386 ((Operand -> Instr)
       ,IF_ARCH_sparc((RI -> Reg -> Instr)

-      ,)))
-    -> StixTree        -- the one argument
-    -> UniqSM Register
+      ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
+      ,))))
+    -> StixExpr        -- the one argument
+    -> NatM Register

 
 trivialUFCode
     :: PrimRep
     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
 
 trivialUFCode
     :: PrimRep
     -> IF_ARCH_alpha((Reg -> Reg -> Instr)

-      ,IF_ARCH_i386 (Instr
+      ,IF_ARCH_i386 ((Reg -> Reg -> Instr)

       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
       ,IF_ARCH_sparc((Reg -> Reg -> Instr)

-      ,)))
-    -> StixTree -- the one argument
-    -> UniqSM Register
+      ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
+      ,))))
+    -> StixExpr -- the one argument
+    -> NatM Register
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 
 #if alpha_TARGET_ARCH
 
 trivialCode instr x (StInt y)
   | fits8Bits y
 
 #if alpha_TARGET_ARCH
 
 trivialCode instr x (StInt y)
   | fits8Bits y

-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG IntRep                `thenUs` \ tmp ->
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG 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
     let
        code = registerCode register tmp
        src1 = registerName register tmp
        src2 = ImmInt (fromInteger y)
        code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)

 
 trivialCode instr x y
 
 trivialCode instr x y

-  = getRegister x              `thenUs` \ register1 ->
-    getRegister y              `thenUs` \ register2 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp1 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp2 ->
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp1 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp2 ->

     let
     let

-       code1 = registerCode register1 tmp1 asmVoid
+       code1 = registerCode register1 tmp1 []

        src1  = registerName register1 tmp1
        src1  = registerName register1 tmp1

-       code2 = registerCode register2 tmp2 asmVoid
+       code2 = registerCode register2 tmp2 []

        src2  = registerName register2 tmp2
        src2  = registerName register2 tmp2

-       code__2 dst = asmParThen [code1, code2] .
+       code__2 dst = asmSeqThen [code1, code2] .

                     mkSeqInstr (instr src1 (RIReg src2) dst)
     in
                     mkSeqInstr (instr src1 (RIReg src2) dst)
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)

 
 ------------
 trivialUCode instr x
 
 ------------
 trivialUCode instr x

-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG IntRep                `thenUs` \ tmp ->
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG IntRep                `thenNat` \ tmp ->

     let
        code = registerCode register tmp
        src  = registerName register tmp
        code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
     in
     let
        code = registerCode register tmp
        src  = registerName register tmp
        code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)

 
 ------------
 trivialFCode _ instr x y
 
 ------------
 trivialFCode _ instr x y

-  = getRegister x              `thenUs` \ register1 ->
-    getRegister y              `thenUs` \ register2 ->
-    getNewRegNCG DoubleRep     `thenUs` \ tmp1 ->
-    getNewRegNCG DoubleRep     `thenUs` \ tmp2 ->
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->
+    getNewRegNCG DoubleRep     `thenNat` \ tmp1 ->
+    getNewRegNCG DoubleRep     `thenNat` \ tmp2 ->

     let
        code1 = registerCode register1 tmp1
        src1  = registerName register1 tmp1
     let
        code1 = registerCode register1 tmp1
        src1  = registerName register1 tmp1

@@ -2756,263 +4018,246 @@ trivialFCode _ instr x y
        code2 = registerCode register2 tmp2
        src2  = registerName register2 tmp2
 
        code2 = registerCode register2 tmp2
        src2  = registerName register2 tmp2
 

-       code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
+       code__2 dst = asmSeqThen [code1 [], code2 []] .

                      mkSeqInstr (instr src1 src2 dst)
     in
                      mkSeqInstr (instr src1 src2 dst)
     in

-    returnUs (Any DoubleRep code__2)
+    returnNat (Any DoubleRep code__2)

 
 trivialUFCode _ instr x
 
 trivialUFCode _ instr x

-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG DoubleRep     `thenUs` \ tmp ->
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG DoubleRep     `thenNat` \ tmp ->

     let
        code = registerCode register tmp
        src  = registerName register tmp
        code__2 dst = code . mkSeqInstr (instr src dst)
     in
     let
        code = registerCode register tmp
        src  = registerName register tmp
        code__2 dst = code . mkSeqInstr (instr src dst)
     in

-    returnUs (Any DoubleRep code__2)
+    returnNat (Any DoubleRep code__2)
+
+#endif /* alpha_TARGET_ARCH */

 
 

-#endif {- alpha_TARGET_ARCH -}

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

+

 #if i386_TARGET_ARCH
 #if i386_TARGET_ARCH

+\end{code}
+The Rules of the Game are:

 
 

-trivialCode instr x y
-  | maybeToBool imm
-  = getRegister x              `thenUs` \ register1 ->
-    --getNewRegNCG IntRep      `thenUs` \ tmp1 ->
-    let
---     fixedname  = registerName register1 eax
-       code__2 dst = let code1 = registerCode register1 dst
-                         src1  = registerName register1 dst
-                     in code1 .
-                        if isFixed register1 && src1 /= dst
-                        then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
-                                          instr (OpImm imm__2) (OpReg dst)]
-                        else
-                               mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
-    in
-    returnUs (Any IntRep code__2)
-  where
-    imm = maybeImm y
-    imm__2 = case imm of Just x -> x
+* You cannot assume anything about the destination register dst;
+  it may be anything, including a fixed reg.

 
 

-trivialCode instr x y
-  | maybeToBool imm
-  = getRegister y              `thenUs` \ register1 ->
-    --getNewRegNCG IntRep      `thenUs` \ tmp1 ->
-    let
---     fixedname  = registerName register1 eax
-       code__2 dst = let code1 = registerCode register1 dst
-                         src1  = registerName register1 dst
-                     in code1 .
-                        if isFixed register1 && src1 /= dst
-                        then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
-                                          instr (OpImm imm__2) (OpReg dst)]
-                        else
-                               mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
-    in
-    returnUs (Any IntRep code__2)
-  where
-    imm = maybeImm x
-    imm__2 = case imm of Just x -> x
+* 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.

 
 

-trivialCode instr x (StInd pk mem)
-  = getRegister x              `thenUs` \ register ->
-    --getNewRegNCG IntRep      `thenUs` \ tmp ->
-    getAmode mem               `thenUs` \ amode ->
-    let
---     fixedname  = registerName register eax
-       code2 = amodeCode amode asmVoid
-       src2  = amodeAddr amode
-       code__2 dst = let code1 = registerCode register dst asmVoid
-                         src1  = registerName register dst
-                     in asmParThen [code1, code2] .
-                        if isFixed register && src1 /= dst
-                        then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
-                                          instr (OpAddr src2)  (OpReg dst)]
-                        else
-                               mkSeqInstr (instr (OpAddr src2) (OpReg src1))
-    in
-    returnUs (Any pk code__2)
-
-trivialCode instr (StInd pk mem) y
-  = getRegister y              `thenUs` \ register ->
-    --getNewRegNCG IntRep      `thenUs` \ tmp ->
-    getAmode mem               `thenUs` \ amode ->
-    let
---     fixedname  = registerName register eax
-       code2 = amodeCode amode asmVoid
-       src2  = amodeAddr amode
-       code__2 dst = let
-                         code1 = registerCode register dst asmVoid
-                         src1  = registerName register dst
-                     in asmParThen [code1, code2] .
-                        if isFixed register && src1 /= dst
-                        then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
-                                          instr (OpAddr src2)  (OpReg dst)]
-                        else
-                               mkSeqInstr (instr (OpAddr src2) (OpReg src1))
-    in
-    returnUs (Any pk code__2)
+* 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 getNewRegNCG are distinct from 
+  each other and from all other regs, and stay live over 
+  arbitrary computations.
+
+\begin{code}
+
+trivialCode instr maybe_revinstr a b
+
+  | is_imm_b
+  = getRegister a                         `thenNat` \ rega ->
+    let mkcode dst
+          = if   isAny rega 
+            then registerCode rega dst      `bind` \ code_a ->
+                 code_a `snocOL`
+                 instr (OpImm imm_b) (OpReg dst)
+            else registerCodeF rega         `bind` \ code_a ->
+                 registerNameF rega         `bind` \ r_a ->
+                 code_a `snocOL`
+                 MOV L (OpReg r_a) (OpReg dst) `snocOL`
+                 instr (OpImm imm_b) (OpReg dst)
+    in
+    returnNat (Any IntRep mkcode)
+              
+  | is_imm_a
+  = getRegister b                         `thenNat` \ regb ->
+    getNewRegNCG IntRep                   `thenNat` \ tmp ->
+    let revinstr_avail = maybeToBool maybe_revinstr
+        revinstr       = case maybe_revinstr of Just ri -> ri
+        mkcode dst
+          | revinstr_avail
+          = if   isAny regb
+            then registerCode regb dst      `bind` \ code_b ->
+                 code_b `snocOL`
+                 revinstr (OpImm imm_a) (OpReg dst)
+            else registerCodeF regb         `bind` \ code_b ->
+                 registerNameF regb         `bind` \ r_b ->
+                 code_b `snocOL`
+                 MOV L (OpReg r_b) (OpReg dst) `snocOL`
+                 revinstr (OpImm imm_a) (OpReg dst)
+          
+          | otherwise
+          = if   isAny regb
+            then registerCode regb tmp      `bind` \ code_b ->
+                 code_b `snocOL`
+                 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
+                 instr (OpReg tmp) (OpReg dst)
+            else registerCodeF regb         `bind` \ code_b ->
+                 registerNameF regb         `bind` \ r_b ->
+                 code_b `snocOL`
+                 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
+                 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
+                 instr (OpReg tmp) (OpReg dst)
+    in
+    returnNat (Any IntRep mkcode)
+
+  | otherwise
+  = getRegister a                         `thenNat` \ rega ->
+    getRegister b                         `thenNat` \ regb ->
+    getNewRegNCG IntRep                   `thenNat` \ tmp ->
+    let mkcode dst
+          = case (isAny rega, isAny regb) of
+              (True, True) 
+                 -> registerCode regb tmp   `bind` \ code_b ->
+                    registerCode rega dst   `bind` \ code_a ->
+                    code_b `appOL`
+                    code_a `snocOL`
+                    instr (OpReg tmp) (OpReg dst)
+              (True, False)
+                 -> registerCode  rega tmp  `bind` \ code_a ->
+                    registerCodeF regb      `bind` \ code_b ->
+                    registerNameF regb      `bind` \ r_b ->
+                    code_a `appOL`
+                    code_b `snocOL`
+                    instr (OpReg r_b) (OpReg tmp) `snocOL`
+                    MOV L (OpReg tmp) (OpReg dst)
+              (False, True)
+                 -> registerCode  regb tmp  `bind` \ code_b ->
+                    registerCodeF rega      `bind` \ code_a ->
+                    registerNameF rega      `bind` \ r_a ->
+                    code_b `appOL`
+                    code_a `snocOL`
+                    MOV L (OpReg r_a) (OpReg dst) `snocOL`
+                    instr (OpReg tmp) (OpReg dst)
+              (False, False)
+                 -> registerCodeF  rega     `bind` \ code_a ->
+                    registerNameF  rega     `bind` \ r_a ->
+                    registerCodeF  regb     `bind` \ code_b ->
+                    registerNameF  regb     `bind` \ r_b ->
+                    code_a `snocOL`
+                    MOV L (OpReg r_a) (OpReg tmp) `appOL`
+                    code_b `snocOL`
+                    instr (OpReg r_b) (OpReg tmp) `snocOL`
+                    MOV L (OpReg tmp) (OpReg dst)
+    in
+    returnNat (Any IntRep mkcode)
+
+    where
+       maybe_imm_a = maybeImm a
+       is_imm_a    = maybeToBool maybe_imm_a
+       imm_a       = case maybe_imm_a of Just imm -> imm
+
+       maybe_imm_b = maybeImm b
+       is_imm_b    = maybeToBool maybe_imm_b
+       imm_b       = case maybe_imm_b of Just imm -> imm

 
 

-trivialCode instr x y
-  = getRegister x              `thenUs` \ register1 ->
-    getRegister y              `thenUs` \ register2 ->
-    --getNewRegNCG IntRep      `thenUs` \ tmp1 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp2 ->
-    let
---     fixedname  = registerName register1 eax
-       code2 = registerCode register2 tmp2 asmVoid
-       src2  = registerName register2 tmp2
-       code__2 dst = let
-                         code1 = registerCode register1 dst asmVoid
-                         src1  = registerName register1 dst
-                     in asmParThen [code1, code2] .
-                        if isFixed register1 && src1 /= dst
-                        then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
-                                          instr (OpReg src2)  (OpReg dst)]
-                        else
-                               mkSeqInstr (instr (OpReg src2) (OpReg src1))
-    in
-    returnUs (Any IntRep code__2)

 
 -----------
 trivialUCode instr x
 
 -----------
 trivialUCode instr x

-  = getRegister x              `thenUs` \ register ->
---    getNewRegNCG IntRep      `thenUs` \ tmp ->
+  = getRegister x              `thenNat` \ register ->

     let
     let

---     fixedname = registerName register eax
-       code__2 dst = let
-                         code = registerCode register dst
+       code__2 dst = let code = registerCode register dst

                          src  = registerName register dst
                          src  = registerName register dst

-                     in code . if isFixed register && dst /= src
-                               then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
-                                                 instr (OpReg dst)]
-                               else mkSeqInstr (instr (OpReg src))
+                     in code `appOL`
+                         if   isFixed register && dst /= src
+                        then toOL [MOV L (OpReg src) (OpReg dst),
+                                   instr (OpReg dst)]
+                        else unitOL (instr (OpReg src))

     in
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)

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

-trivialFCode pk _ instrr _ _ (StInd pk' mem) y
-  = getRegister y              `thenUs` \ register2 ->
-    --getNewRegNCG (registerRep register2)
-    --                         `thenUs` \ tmp2 ->
-    getAmode mem               `thenUs` \ amode ->
-    let
-       code1 = amodeCode amode
-       src1  = amodeAddr amode
-
-       code__2 dst = let
-                         code2 = registerCode register2 dst
-                         src2  = registerName register2 dst
-                     in asmParThen [code1 asmVoid,code2 asmVoid] .
-                        mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
-    in
-    returnUs (Any pk code__2)
-
-trivialFCode pk instr _ _ _ x (StInd pk' mem)
-  = getRegister x              `thenUs` \ register1 ->
-    --getNewRegNCG (registerRep register1)
-    --                         `thenUs` \ tmp1 ->
-    getAmode mem               `thenUs` \ amode ->
-    let
-       code2 = amodeCode amode
-       src2  = amodeAddr amode
-
-       code__2 dst = let
-                         code1 = registerCode register1 dst
-                         src1  = registerName register1 dst
-                     in asmParThen [code2 asmVoid,code1 asmVoid] .
-                        mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
-    in
-    returnUs (Any pk code__2)
-
-trivialFCode pk _ _ _ instrpr x y
-  = getRegister x              `thenUs` \ register1 ->
-    getRegister y              `thenUs` \ register2 ->
-    --getNewRegNCG (registerRep register1)
-    --                         `thenUs` \ tmp1 ->
-    --getNewRegNCG (registerRep register2)
-    --                         `thenUs` \ tmp2 ->
-    getNewRegNCG DoubleRep     `thenUs` \ tmp ->
+trivialFCode pk instr x y
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->
+    getNewRegNCG DoubleRep     `thenNat` \ tmp1 ->
+    getNewRegNCG DoubleRep     `thenNat` \ tmp2 ->

     let
     let

-       pk1   = registerRep register1
-       code1 = registerCode register1 st0 --tmp1
-       src1  = registerName register1 st0 --tmp1
+       code1 = registerCode register1 tmp1
+       src1  = registerName register1 tmp1

 
 

-       pk2   = registerRep register2
+       code2 = registerCode register2 tmp2
+       src2  = registerName register2 tmp2

 
 

-       code__2 dst = let
-                         code2 = registerCode register2 dst
-                         src2  = registerName register2 dst
-                     in asmParThen [code1 asmVoid, code2 asmVoid] .
-                        mkSeqInstr instrpr
+       code__2 dst
+           -- treat the common case specially: both operands in
+           -- non-fixed regs.
+           | isAny register1 && isAny register2
+           = code1 `appOL` 
+             code2 `snocOL`
+            instr (primRepToSize pk) src1 src2 dst
+
+           -- be paranoid (and inefficient)
+           | otherwise
+           = code1 `snocOL` GMOV src1 tmp1  `appOL`
+             code2 `snocOL`
+             instr (primRepToSize pk) tmp1 src2 dst

     in
     in

-    returnUs (Any pk1 code__2)
+    returnNat (Any pk code__2)

 
 

--------------
-trivialUFCode pk instr (StInd pk' mem)
-  = getAmode mem               `thenUs` \ amode ->
-    let
-       code = amodeCode amode
-       src  = amodeAddr amode
-       code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
-                                         instr]
-    in
-    returnUs (Any pk code__2)

 
 

+-------------

 trivialUFCode pk instr x
 trivialUFCode pk instr x

-  = getRegister x              `thenUs` \ register ->
-    --getNewRegNCG pk          `thenUs` \ tmp ->
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG pk            `thenNat` \ tmp ->

     let
     let

-       code__2 dst = let
-                         code = registerCode register dst
-                         src  = registerName register dst
-                     in code . mkSeqInstrs [instr]
+       code = registerCode register tmp
+       src  = registerName register tmp
+       code__2 dst = code `snocOL` instr src dst

     in
     in

-    returnUs (Any pk code__2)
+    returnNat (Any pk code__2)
+
+#endif /* i386_TARGET_ARCH */

 
 

-#endif {- i386_TARGET_ARCH -}

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

+

 #if sparc_TARGET_ARCH
 
 trivialCode instr x (StInt y)
   | fits13Bits y
 #if sparc_TARGET_ARCH
 
 trivialCode instr x (StInt y)
   | fits13Bits y

-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG IntRep                `thenUs` \ tmp ->
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG IntRep                `thenNat` \ tmp ->

     let
        code = registerCode register tmp
        src1 = registerName register tmp
        src2 = ImmInt (fromInteger y)
     let
        code = registerCode register tmp
        src1 = registerName register tmp
        src2 = ImmInt (fromInteger y)

-       code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
+       code__2 dst = code `snocOL` instr src1 (RIImm src2) dst

     in
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)

 
 trivialCode instr x y
 
 trivialCode instr x y

-  = getRegister x              `thenUs` \ register1 ->
-    getRegister y              `thenUs` \ register2 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp1 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp2 ->
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp1 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp2 ->

     let
     let

-       code1 = registerCode register1 tmp1 asmVoid
+       code1 = registerCode register1 tmp1

        src1  = registerName register1 tmp1
        src1  = registerName register1 tmp1

-       code2 = registerCode register2 tmp2 asmVoid
+       code2 = registerCode register2 tmp2

        src2  = registerName register2 tmp2
        src2  = registerName register2 tmp2

-       code__2 dst = asmParThen [code1, code2] .
-                    mkSeqInstr (instr src1 (RIReg src2) dst)
+       code__2 dst = code1 `appOL` code2 `snocOL`
+                     instr src1 (RIReg src2) dst

     in
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)

 
 ------------
 trivialFCode pk instr x y
 
 ------------
 trivialFCode pk instr x y

-  = getRegister x              `thenUs` \ register1 ->
-    getRegister y              `thenUs` \ register2 ->
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->

     getNewRegNCG (registerRep register1)
     getNewRegNCG (registerRep register1)

-                               `thenUs` \ tmp1 ->
+                               `thenNat` \ tmp1 ->

     getNewRegNCG (registerRep register2)
     getNewRegNCG (registerRep register2)

-                               `thenUs` \ tmp2 ->
-    getNewRegNCG DoubleRep     `thenUs` \ tmp ->
+                               `thenNat` \ tmp2 ->
+    getNewRegNCG DoubleRep     `thenNat` \ tmp ->

     let
     let

-       promote x = asmInstr (FxTOy F DF x tmp)
+       promote x = FxTOy F DF x tmp

 
        pk1   = registerRep register1
        code1 = registerCode register1 tmp1
 
        pk1   = registerRep register1
        code1 = registerCode register1 tmp1

@@ -3024,40 +4269,160 @@ trivialFCode pk instr x y
 
        code__2 dst =
                if pk1 == pk2 then
 
        code__2 dst =
                if pk1 == pk2 then

-                   asmParThen [code1 asmVoid, code2 asmVoid] .
-                   mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
+                   code1 `appOL` code2 `snocOL`
+                   instr (primRepToSize pk) src1 src2 dst

                else if pk1 == FloatRep then
                else if pk1 == FloatRep then

-                   asmParThen [code1 (promote src1), code2 asmVoid] .
-                   mkSeqInstr (instr DF tmp src2 dst)
+                   code1 `snocOL` promote src1 `appOL` code2 `snocOL`
+                   instr DF tmp src2 dst

                else
                else

-                   asmParThen [code1 asmVoid, code2 (promote src2)] .
-                   mkSeqInstr (instr DF src1 tmp dst)
+                   code1 `appOL` code2 `snocOL` promote src2 `snocOL`
+                   instr DF src1 tmp dst

     in
     in

-    returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
+    returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)

 
 ------------
 trivialUCode instr x
 
 ------------
 trivialUCode instr x

-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG IntRep                `thenUs` \ tmp ->
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG IntRep                `thenNat` \ tmp ->

     let
        code = registerCode register tmp
        src  = registerName register tmp
     let
        code = registerCode register tmp
        src  = registerName register tmp

-       code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
+       code__2 dst = code `snocOL` instr (RIReg src) dst

     in
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)

 
 -------------
 trivialUFCode pk instr x
 
 -------------
 trivialUFCode pk instr x

-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG pk            `thenUs` \ tmp ->
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG pk            `thenNat` \ tmp ->

     let
        code = registerCode register tmp
        src  = registerName register tmp
     let
        code = registerCode register tmp
        src  = registerName register tmp

-       code__2 dst = code . mkSeqInstr (instr src dst)
+       code__2 dst = code `snocOL` instr src dst

     in
     in

-    returnUs (Any pk code__2)
+    returnNat (Any pk code__2)

 
 

-#endif {- sparc_TARGET_ARCH -}
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+trivialCode instr x (StInt y)
+  | fits16Bits y
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG IntRep                `thenNat` \ tmp ->
+    let
+       code = registerCode register tmp
+       src1 = registerName register tmp
+       src2 = ImmInt (fromInteger y)
+       code__2 dst = code `snocOL` instr dst src1 (RIImm src2)
+    in
+    returnNat (Any IntRep code__2)
+
+trivialCode instr x y
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp1 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp2 ->
+    let
+       code1 = registerCode register1 tmp1
+       src1  = registerName register1 tmp1
+       code2 = registerCode register2 tmp2
+       src2  = registerName register2 tmp2
+       code__2 dst = code1 `appOL` code2 `snocOL`
+                     instr dst src1 (RIReg src2)
+    in
+    returnNat (Any IntRep code__2)
+
+trivialCode2 :: (Reg -> Reg -> Reg -> Instr)
+    -> StixExpr -> StixExpr -> NatM Register
+trivialCode2 instr x y
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp1 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp2 ->
+    let
+       code1 = registerCode register1 tmp1
+       src1  = registerName register1 tmp1
+       code2 = registerCode register2 tmp2
+       src2  = registerName register2 tmp2
+       code__2 dst = code1 `appOL` code2 `snocOL`
+                     instr dst src1 src2
+    in
+    returnNat (Any IntRep code__2)
+    
+trivialFCode pk instr x y
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->
+    getNewRegNCG (registerRep register1)
+                               `thenNat` \ tmp1 ->
+    getNewRegNCG (registerRep register2)
+                               `thenNat` \ tmp2 ->
+    -- getNewRegNCG DoubleRep          `thenNat` \ tmp ->
+    let
+       -- promote x = FxTOy F DF x tmp
+
+       pk1   = registerRep register1
+       code1 = registerCode register1 tmp1
+       src1  = registerName register1 tmp1
+
+       pk2   = registerRep register2
+       code2 = registerCode register2 tmp2
+       src2  = registerName register2 tmp2
+
+       dstRep = if pk1 == FloatRep && pk2 == FloatRep then FloatRep else DoubleRep
+
+       code__2 dst =
+                   code1 `appOL` code2 `snocOL`
+                   instr (primRepToSize dstRep) dst src1 src2
+    in
+    returnNat (Any dstRep code__2)
+
+trivialUCode instr x
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG IntRep                `thenNat` \ tmp ->
+    let
+       code = registerCode register tmp
+       src  = registerName register tmp
+       code__2 dst = code `snocOL` instr dst src
+    in
+    returnNat (Any IntRep code__2)
+trivialUFCode pk instr x
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG (registerRep register)
+                               `thenNat` \ tmp ->
+    let
+       code = registerCode register tmp
+       src  = registerName register tmp
+       code__2 dst = code `snocOL` instr dst src
+    in
+    returnNat (Any pk code__2)
+  
+-- 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 :: (Reg -> Reg -> Reg -> Instr)
+    -> StixExpr -> StixExpr -> NatM Register
+remainderCode div x y
+  = getRegister x              `thenNat` \ register1 ->
+    getRegister y              `thenNat` \ register2 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp1 ->
+    getNewRegNCG IntRep                `thenNat` \ tmp2 ->
+    let
+       code1 = registerCode register1 tmp1
+       src1  = registerName register1 tmp1
+       code2 = registerCode register2 tmp2
+       src2  = registerName register2 tmp2
+       code__2 dst = code1 `appOL` code2 `appOL` toOL [
+               div dst src1 src2,
+               MULLW dst dst (RIReg src2),
+               SUBF dst dst src1
+           ]
+    in
+    returnNat (Any IntRep code__2)
+
+#endif /* powerpc_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -3066,45 +4431,31 @@ trivialUFCode pk instr x
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-@coerce(Int|Flt)Code@ are simple coercions that don't require any code
-to be generated.  Here we just change the type on the Register passed
-on up.  The code is machine-independent.
-

 @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.
 
 @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.
+

 \begin{code}
 \begin{code}

-coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
-coerceFltCode ::           StixTree -> UniqSM Register
-
-coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
-coerceFP2Int ::           StixTree -> UniqSM Register
-
-coerceIntCode pk x
-  = getRegister x              `thenUs` \ register ->
-    returnUs (
-    case register of
-       Fixed _ reg code -> Fixed pk reg code
-       Any   _ code     -> Any   pk code
-    )
+coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
+coerceFP2Int :: PrimRep -> StixExpr -> NatM Register

 
 

--------------
-coerceFltCode x
-  = getRegister x              `thenUs` \ register ->
-    returnUs (
-    case register of
-       Fixed _ reg code -> Fixed DoubleRep reg code
-       Any   _ code     -> Any   DoubleRep code
-    )
+coerceDbl2Flt :: StixExpr -> NatM Register
+coerceFlt2Dbl :: StixExpr -> NatM Register

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+

 #if alpha_TARGET_ARCH
 
 coerceInt2FP _ x
 #if alpha_TARGET_ARCH
 
 coerceInt2FP _ x

-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG IntRep                `thenUs` \ reg ->
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG IntRep                `thenNat` \ reg ->

     let
        code = registerCode register reg
        src  = registerName register reg
     let
        code = registerCode register reg
        src  = registerName register reg

@@ -3114,12 +4465,12 @@ coerceInt2FP _ x
            LD TF dst (spRel 0),
            CVTxy Q TF dst dst]
     in
            LD TF dst (spRel 0),
            CVTxy Q TF dst dst]
     in

-    returnUs (Any DoubleRep code__2)
+    returnNat (Any DoubleRep code__2)

 
 -------------
 coerceFP2Int x
 
 -------------
 coerceFP2Int x

-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG DoubleRep     `thenUs` \ tmp ->
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG DoubleRep     `thenNat` \ tmp ->

     let
        code = registerCode register tmp
        src  = registerName register tmp
     let
        code = registerCode register tmp
        src  = registerName register tmp

@@ -3129,219 +4480,149 @@ coerceFP2Int x
            ST TF tmp (spRel 0),
            LD Q dst (spRel 0)]
     in
            ST TF tmp (spRel 0),
            LD Q dst (spRel 0)]
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)
+
+#endif /* alpha_TARGET_ARCH */

 
 

-#endif {- alpha_TARGET_ARCH -}

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

+

 #if i386_TARGET_ARCH
 
 coerceInt2FP pk x
 #if i386_TARGET_ARCH
 
 coerceInt2FP pk x

-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG IntRep                `thenUs` \ reg ->
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG IntRep                `thenNat` \ reg ->

     let
        code = registerCode register reg
        src  = registerName register reg
     let
        code = registerCode register reg
        src  = registerName register reg

-
-       code__2 dst = code . mkSeqInstrs [
-       -- to fix: should spill instead of using R1
-                     MOV L (OpReg src) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
-                     FILD (primRepToSize pk) (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
+        opc  = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
+        code__2 dst = code `snocOL` opc src dst

     in
     in

-    returnUs (Any pk code__2)
+    returnNat (Any pk code__2)

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

-coerceFP2Int x
-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG DoubleRep     `thenUs` \ tmp ->
+coerceFP2Int fprep x
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG DoubleRep     `thenNat` \ tmp ->

     let
        code = registerCode register tmp
        src  = registerName register tmp
        pk   = registerRep register
 
     let
        code = registerCode register tmp
        src  = registerName register tmp
        pk   = registerRep register
 

-       code__2 dst = code . mkSeqInstrs [
-                               FRNDINT,
-                               FIST L (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)),
-                               MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
+        opc  = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
+        code__2 dst = code `snocOL` opc src dst

     in
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)
+
+------------
+coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
+coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
+
+#endif /* i386_TARGET_ARCH */

 
 

-#endif {- i386_TARGET_ARCH -}

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

+

 #if sparc_TARGET_ARCH
 
 coerceInt2FP pk x
 #if sparc_TARGET_ARCH
 
 coerceInt2FP pk x

-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG IntRep                `thenUs` \ reg ->
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG IntRep                `thenNat` \ reg ->

     let
        code = registerCode register reg
        src  = registerName register reg
 
     let
        code = registerCode register reg
        src  = registerName register reg
 

-       code__2 dst = code . mkSeqInstrs [
+       code__2 dst = code `appOL` toOL [

            ST W src (spRel (-2)),
            LD W (spRel (-2)) dst,
            FxTOy W (primRepToSize pk) dst dst]
     in
            ST W src (spRel (-2)),
            LD W (spRel (-2)) dst,
            FxTOy W (primRepToSize pk) dst dst]
     in

-    returnUs (Any pk code__2)
+    returnNat (Any pk code__2)

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

-coerceFP2Int x
-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG IntRep                `thenUs` \ reg ->
-    getNewRegNCG FloatRep      `thenUs` \ tmp ->
+coerceFP2Int fprep x
+  = ASSERT(fprep == DoubleRep || fprep == FloatRep)
+    getRegister x              `thenNat` \ register ->
+    getNewRegNCG fprep         `thenNat` \ reg ->
+    getNewRegNCG FloatRep      `thenNat` \ tmp ->

     let
        code = registerCode register reg
        src  = registerName register reg
     let
        code = registerCode register reg
        src  = registerName register reg

-       pk   = registerRep  register
-
-       code__2 dst = code . mkSeqInstrs [
-           FxTOy (primRepToSize pk) W src tmp,
+       code__2 dst = code `appOL` toOL [
+           FxTOy (primRepToSize fprep) W src tmp,

            ST W tmp (spRel (-2)),
            LD W (spRel (-2)) dst]
     in
            ST W tmp (spRel (-2)),
            LD W (spRel (-2)) dst]
     in

-    returnUs (Any IntRep code__2)
-
-#endif {- sparc_TARGET_ARCH -}
-\end{code}
-
-%************************************************************************
-%*                                                                     *
-\subsubsection{Coercing integer to @Char@...}
-%*                                                                     *
-%************************************************************************
-
-Integer to character conversion.  Where applicable, we try to do this
-in one step if the original object is in memory.
+    returnNat (Any IntRep code__2)

 
 

-\begin{code}
-chrCode :: StixTree -> UniqSM Register
-
-#if alpha_TARGET_ARCH
-
-chrCode x
-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG IntRep                `thenUs` \ reg ->
-    let
-       code = registerCode register reg
-       src  = registerName register reg
-       code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
+------------
+coerceDbl2Flt x
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG DoubleRep     `thenNat` \ tmp ->
+    let code = registerCode register tmp
+        src  = registerName register tmp

     in
     in

-    returnUs (Any IntRep code__2)
+        returnNat (Any FloatRep 
+                       (\dst -> code `snocOL` FxTOy DF F src dst)) 

 
 

-#endif {- alpha_TARGET_ARCH -}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if i386_TARGET_ARCH
-
-chrCode x
-  = getRegister x              `thenUs` \ register ->
-    --getNewRegNCG IntRep      `thenUs` \ reg ->
-    let
---     fixedname = registerName register eax
-       code__2 dst = let
-                         code = registerCode register dst
-                         src  = registerName register dst
-                     in code .
-                        if isFixed register && src /= dst
-                        then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
-                                          AND L (OpImm (ImmInt 255)) (OpReg dst)]
-                        else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
+------------
+coerceFlt2Dbl x
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG FloatRep      `thenNat` \ tmp ->
+    let code = registerCode register tmp
+        src  = registerName register tmp

     in
     in

-    returnUs (Any IntRep code__2)
+        returnNat (Any DoubleRep
+                       (\dst -> code `snocOL` FxTOy F DF src dst)) 

 
 

-#endif {- i386_TARGET_ARCH -}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if sparc_TARGET_ARCH
+#endif /* sparc_TARGET_ARCH */

 
 

-chrCode (StInd pk mem)
-  = getAmode mem               `thenUs` \ amode ->
-    let
-       code    = amodeCode amode
-       src     = amodeAddr amode
-       src_off = addrOffset src 3
-       src__2  = case src_off of Just x -> x
-       code__2 dst = if maybeToBool src_off then
-                       code . mkSeqInstr (LD BU src__2 dst)
-                   else
-                       code . mkSeqInstrs [
-                           LD (primRepToSize pk) src dst,
-                           AND False dst (RIImm (ImmInt 255)) dst]
-    in
-    returnUs (Any pk code__2)
-
-chrCode x
-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG IntRep                `thenUs` \ reg ->
+#if powerpc_TARGET_ARCH
+coerceInt2FP pk x
+  = ASSERT(pk == DoubleRep)
+    getRegister x                  `thenNat` \ register ->
+    getNewRegNCG IntRep                    `thenNat` \ reg ->
+    getNatLabelNCG                 `thenNat` \ lbl ->
+    getNewRegNCG PtrRep            `thenNat` \ itmp ->
+    getNewRegNCG DoubleRep         `thenNat` \ ftmp ->

     let
     let

-       code = registerCode register reg
+        code = registerCode register reg

        src  = registerName register reg
        src  = registerName register reg

-       code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
+       code__2 dst = code `appOL` toOL [
+               SEGMENT RoDataSegment,
+               LABEL lbl,
+               DATA W [ImmInt 0x43300000, ImmInt 0x80000000],
+               SEGMENT TextSegment,
+               XORIS itmp src (ImmInt 0x8000),
+               ST W itmp (spRel (-1)),
+               LIS itmp (ImmInt 0x4330),
+               ST W itmp (spRel (-2)),
+               LD DF ftmp (spRel (-2)),
+               LIS itmp (HA (ImmCLbl lbl)),
+               LD DF dst (AddrRegImm itmp (LO (ImmCLbl lbl))),
+               FSUB DF dst ftmp dst
+           ]

     in
     in

-    returnUs (Any IntRep code__2)
-
-#endif {- sparc_TARGET_ARCH -}
-\end{code}
-
-%************************************************************************
-%*                                                                     *
-\subsubsection{Absolute value on integers}
-%*                                                                     *
-%************************************************************************
+       returnNat (Any DoubleRep code__2)

 
 

-Absolute value on integers, mostly for gmp size check macros.  Again,
-the argument cannot be an StInt, because genericOpt already folded
-constants.
-
-If applicable, do not fill the delay slots here; you will confuse the
-register allocator.
-
-\begin{code}
-absIntCode :: StixTree -> UniqSM Register
-
-#if alpha_TARGET_ARCH
-absIntCode = panic "MachCode.absIntCode: not on Alphas"
-#endif {- alpha_TARGET_ARCH -}
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if i386_TARGET_ARCH
-
-absIntCode x
-  = getRegister x              `thenUs` \ register ->
-    --getNewRegNCG IntRep      `thenUs` \ reg ->
-    getUniqLabelNCG            `thenUs` \ lbl ->
-    let
-       code__2 dst = let code = registerCode register dst
-                         src  = registerName register dst
-                     in code . if isFixed register && dst /= src
-                               then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
-                                                 TEST L (OpReg dst) (OpReg dst),
-                                                 JXX GE lbl,
-                                                 NEGI L (OpReg dst),
-                                                 LABEL lbl]
-                               else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
-                                                 JXX GE lbl,
-                                                 NEGI L (OpReg src),
-                                                 LABEL lbl]
-    in
-    returnUs (Any IntRep code__2)
-
-#endif {- i386_TARGET_ARCH -}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if sparc_TARGET_ARCH
-
-absIntCode x
-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG IntRep                `thenUs` \ reg ->
-    getUniqLabelNCG            `thenUs` \ lbl ->
+coerceFP2Int fprep x
+  = ASSERT(fprep == DoubleRep || fprep == FloatRep)
+    getRegister x              `thenNat` \ register ->
+    getNewRegNCG fprep         `thenNat` \ reg ->
+    getNewRegNCG DoubleRep     `thenNat` \ tmp ->

     let
        code = registerCode register reg
        src  = registerName register reg
     let
        code = registerCode register reg
        src  = registerName register reg

-       code__2 dst = code . mkSeqInstrs [
-           SUB False True g0 (RIReg src) dst,
-           BI GE False (ImmCLbl lbl), NOP,
-           OR False g0 (RIReg src) dst,
-           LABEL lbl]
+       code__2 dst = code `appOL` toOL [
+               -- convert to int in FP reg
+           FCTIWZ tmp src,
+               -- store value (64bit) from FP to stack
+           ST DF tmp (spRel (-2)),
+               -- read low word of value (high word is undefined)
+           LD W dst (spRel (-1))]      

     in
     in

-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)
+coerceDbl2Flt x                = panic "###PPC MachCode.coerceDbl2Flt"
+coerceFlt2Dbl x                = panic "###PPC MachCode.coerceFlt2Dbl"
+#endif /* powerpc_TARGET_ARCH */

 
 

-#endif {- sparc_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 \end{code}
 \end{code}

-