[project @ 2002-05-02 09:09:18 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 25d9be3..1c00641 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,77 +9,168 @@ 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 ( stmtsToInstrs, InstrBlock ) where
+

 #include "HsVersions.h"
 #include "nativeGen/NCG.h"
 
 #include "HsVersions.h"
 #include "nativeGen/NCG.h"
 

-module MachCode ( stmt2Instrs, asmVoid, InstrList(..) ) where
-
-import Ubiq{-uitious-}
-
+import Unique          ( Unique )

 import MachMisc                -- may differ per-platform
 import MachRegs
 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 CLabel          ( isAsmTemp )
-import Maybes          ( maybeToBool, expectJust )
-import OrdList         -- quite a bit of it
-import Pretty          ( prettyToUn, ppRational )
-import PrimRep         ( isFloatingRep, PrimRep(..) )
-import PrimOp          ( PrimOp(..) )
-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(..),
+                          getPrimRepArrayElemSize )
+import Stix            ( getNatLabelNCG, StixStmt(..), StixExpr(..),
+                         StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..), 
+                          DestInfo, hasDestInfo,
+                          pprStixExpr, repOfStixExpr,
+                          liftStrings,
+                          NatM, thenNat, returnNat, mapNat, 
+                          mapAndUnzipNat, mapAccumLNat,
+                          getDeltaNat, setDeltaNat, getUniqueNat,
+                          ncgPrimopMoan,
+                         ncg_target_is_32bit

                        )
                        )

-import Unpretty                ( uppPStr )
-import Util            ( panic, assertPanic )
+import Pretty
+import Outputable      ( panic, pprPanic, showSDoc )
+import qualified Outputable
+import CmdLineOpts     ( opt_Static )
+import Stix            ( pprStixStmt )
+
+-- DEBUGGING ONLY
+import IOExts          ( trace )
+import Outputable      ( assertPanic )
+import FastString
+
+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
+
+x `bind` f = f x

 
 

-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)
+isLeft (Left _)  = True
+isLeft (Right _) = False
+
+unLeft (Left x) = x
+\end{code}

 
 

-    StJump arg            -> genJump arg
-    StCondJump lab arg    -> genCondJump lab arg
-    StCall fn VoidRep args -> genCCall fn VoidRep args
+Code extractor for an entire stix tree---stix statement level.

 
 

-    StAssign pk dst src
-      | isFloatingRep pk -> assignFltCode pk dst src
-      | otherwise       -> assignIntCode pk dst src
+\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 * getPrimRepArrayElemSize 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}
 
 %************************************************************************

@@ -89,69 +180,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 (getPrimRepArrayElemSize pk))

 
 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
-    shift _            = IF_ARCH_alpha(3,2)
+    shift :: PrimRep -> Int
+    shift rep = case getPrimRepArrayElemSize 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 * getPrimRepArrayElemSize 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)

@@ -161,6 +223,223 @@ 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 -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+\end{code}
+
+%************************************************************************
+%*                                                                     *

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

@@ -179,74 +458,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)
+
+-------------

 
 

-getRegister (StReg (StixTemp u pk))
-  = returnUs (Fixed pk (UnmappedReg u pk) id)
+-- Don't delete this -- it's very handy for debugging.
+--getRegister expr 
+--   | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
+--   = panic "getRegister(???)"

 
 

-getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
+getRegister (StReg reg) 
+  = getRegisterReg reg

 
 

-getRegister (StCall fn kind args)
-  = genCCall fn kind args          `thenUs` \ call ->
-    returnUs (Fixed kind reg call)
+getRegister tree@(StIndex _ _ _) 
+  = getRegister (mangleIndexTree tree)
+
+getRegister (StCall fn cconv kind args)
+  | 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,)))
+         then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))

          else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
 
 getRegister (StString s)
          else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
 
 getRegister (StString s)

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

     let
        imm_lbl = ImmCLbl lbl
 
     let
        imm_lbl = ImmCLbl lbl
 

-       code dst = mkSeqInstrs [
-           SEGMENT DataSegment,
-           LABEL lbl,
-           ASCII True (_UNPK_ s),
-           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
-#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,
+       code dst = toOL [
+           SEGMENT RoDataSegment,

            LABEL lbl,
            LABEL lbl,

-           ASCII False (init xs),
+           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)

@@ -260,31 +558,29 @@ getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"'
 #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,

-           DATA TF [ImmLab (prettyToUn (ppRational d))],
+           DATA TF [ImmLab (rational d)],

            SEGMENT TextSegment,
            LDA tmp (AddrImm (ImmCLbl lbl)),
            LD TF dst (AddrReg tmp)]
     in
            SEGMENT TextSegment,
            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
 

@@ -302,78 +598,78 @@ getRegister (StPrim primop [x]) -- unary PrimOps
       Double2FloatOp -> coerceFltCode x
       Float2DoubleOp -> coerceFltCode x
 
       Double2FloatOp -> coerceFltCode x
       Float2DoubleOp -> coerceFltCode x
 

-      other_op -> getRegister (StCall fn 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"
 
 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
   = case primop of
   where
     pr = panic "MachCode.getRegister: no primrep needed for Alpha"
 
 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
   = case primop of

-      CharGtOp -> trivialCode (CMP LT) y x
+      CharGtOp -> trivialCode (CMP LTT) y x

       CharGeOp -> trivialCode (CMP LE) y x
       CharGeOp -> trivialCode (CMP LE) y x

-      CharEqOp -> trivialCode (CMP EQ) x y
+      CharEqOp -> trivialCode (CMP EQQ) x y

       CharNeOp -> int_NE_code x y
       CharNeOp -> int_NE_code x y

-      CharLtOp -> trivialCode (CMP LT) x y
+      CharLtOp -> trivialCode (CMP LTT) x y

       CharLeOp -> trivialCode (CMP LE) x y
 
       CharLeOp -> trivialCode (CMP LE) x y
 

-      IntGtOp  -> trivialCode (CMP LT) y x
+      IntGtOp  -> trivialCode (CMP LTT) y x

       IntGeOp  -> trivialCode (CMP LE) y x
       IntGeOp  -> trivialCode (CMP LE) y x

-      IntEqOp  -> trivialCode (CMP EQ) x y
+      IntEqOp  -> trivialCode (CMP EQQ) x y

       IntNeOp  -> int_NE_code x y
       IntNeOp  -> int_NE_code x y

-      IntLtOp  -> trivialCode (CMP LT) x y
+      IntLtOp  -> trivialCode (CMP LTT) x y

       IntLeOp  -> trivialCode (CMP LE) x y
 
       WordGtOp -> trivialCode (CMP ULT) y x
       WordGeOp -> trivialCode (CMP ULE) x y
       IntLeOp  -> trivialCode (CMP LE) x y
 
       WordGtOp -> trivialCode (CMP ULT) y x
       WordGeOp -> trivialCode (CMP ULE) x y

-      WordEqOp -> trivialCode (CMP EQ)  x y
+      WordEqOp -> trivialCode (CMP EQQ)  x y

       WordNeOp -> int_NE_code x y
       WordLtOp -> trivialCode (CMP ULT) x y
       WordLeOp -> trivialCode (CMP ULE) x y
 
       AddrGtOp -> trivialCode (CMP ULT) y x
       AddrGeOp -> trivialCode (CMP ULE) y x
       WordNeOp -> int_NE_code x y
       WordLtOp -> trivialCode (CMP ULT) x y
       WordLeOp -> trivialCode (CMP ULE) x y
 
       AddrGtOp -> trivialCode (CMP ULT) y x
       AddrGeOp -> trivialCode (CMP ULE) y x

-      AddrEqOp -> trivialCode (CMP EQ)  x y
+      AddrEqOp -> trivialCode (CMP EQQ)  x y

       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) EQ x y
-      FloatGeOp -> cmpF_code (FCMP TF LT) EQ x y
-      FloatEqOp -> cmpF_code (FCMP TF EQ) NE x y
-      FloatNeOp -> cmpF_code (FCMP TF EQ) EQ x y
-      FloatLtOp -> cmpF_code (FCMP TF LT) 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
+      FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
+      FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y

       FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
 
       FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
 

-      DoubleGtOp -> cmpF_code (FCMP TF LE) EQ x y
-      DoubleGeOp -> cmpF_code (FCMP TF LT) EQ x y
-      DoubleEqOp -> cmpF_code (FCMP TF EQ) NE x y
-      DoubleNeOp -> cmpF_code (FCMP TF EQ) EQ x y
-      DoubleLtOp -> cmpF_code (FCMP TF LT) NE x y
+      DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
+      DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
+      DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
+      DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
+      DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y

       DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
 
       IntAddOp  -> trivialCode (ADD Q False) x y
       DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
 
       IntAddOp  -> trivialCode (ADD Q False) x y

@@ -382,6 +678,12 @@ 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
+

       FloatAddOp -> trivialFCode  FloatRep (FADD TF) x y
       FloatSubOp -> trivialFCode  FloatRep (FSUB TF) x y
       FloatMulOp -> trivialFCode  FloatRep (FMUL TF) x y
       FloatAddOp -> trivialFCode  FloatRep (FADD TF) x y
       FloatSubOp -> trivialFCode  FloatRep (FSUB TF) x y
       FloatMulOp -> trivialFCode  FloatRep (FMUL TF) x y

@@ -392,18 +694,22 @@ 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
       AndOp  -> trivialCode AND x y
       OrOp   -> trivialCode OR  x y

+      XorOp  -> trivialCode XOR x y

       SllOp  -> trivialCode SLL x y
       SllOp  -> trivialCode SLL x y

-      SraOp  -> trivialCode SRA x y

       SrlOp  -> trivialCode SRL x y
 
       SrlOp  -> trivialCode SRL x y
 

-      ISllOp -> panic "AlphaGen:isll"
-      ISraOp -> panic "AlphaGen:isra"
-      ISrlOp -> panic "AlphaGen:isrl"
+      ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
+      ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
+      ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"

 
 

-      FloatPowerOp  -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
-      DoublePowerOp -> getRegister (StCall SLIT("pow") 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

@@ -413,17 +719,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 EQ) 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

@@ -432,48 +738,48 @@ 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
 
            code__2 dst = code . mkSeqInstrs [
        let
            code = registerCode register tmp
            result  = registerName register tmp
 
            code__2 dst = code . mkSeqInstrs [

-               OR zero (RIImm (ImmInt 1)) dst,
-               BF cond result (ImmCLbl lbl),
-               OR zero (RIReg zero) dst,
+               OR zeroh (RIImm (ImmInt 1)) dst,
+               BF cond  result (ImmCLbl lbl),
+               OR zeroh (RIReg zeroh) dst,

                LABEL lbl]
        in
                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
 
 getRegister (StInt i)
   | fits8Bits i
   = let

-       code dst = mkSeqInstr (OR zero (RIImm src) dst)
+       code dst = mkSeqInstr (OR zeroh (RIImm src) dst)

     in
     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)
 

@@ -482,562 +788,681 @@ 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
 
 #endif {- alpha_TARGET_ARCH -}
   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
 
 #endif {- alpha_TARGET_ARCH -}

+

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

-#if i386_TARGET_ARCH

 
 

-getRegister (StReg (StixTemp u pk)) = returnUs (Fixed pk (UnmappedReg u pk) id)
+#if i386_TARGET_ARCH

 
 

-getRegister (StDouble 0.0)
-  = let
-       code dst = mkSeqInstrs [FLDZ]
+getRegister (StFloat f)
+  = getNatLabelNCG                 `thenNat` \ lbl ->
+    let code dst = toOL [
+           SEGMENT DataSegment,
+           LABEL lbl,
+           DATA F [ImmFloat f],
+           SEGMENT TextSegment,
+           GLD F (ImmAddr (ImmCLbl lbl) 0) dst
+           ]

     in
     in

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

 
 

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

 
 getRegister (StDouble d)
 
 getRegister (StDouble d)

-  = getUniqLabelNCG                `thenUs` \ lbl ->
-    --getNewRegNCG PtrRep          `thenUs` \ tmp ->
-    let code dst = mkSeqInstrs [
+
+  | d == 0.0
+  = let code dst = unitOL (GLDZ dst)
+    in  returnNat (Any DoubleRep code)
+
+  | d == 1.0
+  = let code dst = unitOL (GLD1 dst)
+    in  returnNat (Any DoubleRep code)
+
+  | otherwise
+  = getNatLabelNCG                 `thenNat` \ lbl ->
+    let code dst = toOL [

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

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

            SEGMENT TextSegment,
            SEGMENT TextSegment,

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

            ]
     in
            ]
     in

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

 
 

-getRegister (StPrim primop [x]) -- unary PrimOps
-  = case primop of
-      IntNegOp  -> trivialUCode (NEGI L) x
-      IntAbsOp  -> absIntCode x

 
 

-      NotOp    -> trivialUCode (NOT L) x
+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

 
 

-      FloatNegOp  -> trivialUFCode FloatRep FCHS x
-      FloatSqrtOp -> trivialUFCode FloatRep FSQRT x
-      DoubleNegOp -> trivialUFCode DoubleRep FCHS x
+      MO_Flt_Neg  -> trivialUFCode FloatRep  (GNEG F) x
+      MO_Dbl_Neg  -> trivialUFCode DoubleRep (GNEG DF) x

 
 

-      DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
+      MO_Flt_Sqrt -> trivialUFCode FloatRep  (GSQRT F) x
+      MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x

 
 

-      OrdOp -> coerceIntCode IntRep x
-      ChrOp -> chrCode x
+      MO_Flt_Sin  -> trivialUFCode FloatRep  (GSIN F) x
+      MO_Dbl_Sin  -> trivialUFCode DoubleRep (GSIN DF) x

 
 

-      Float2IntOp  -> coerceFP2Int x
-      Int2FloatOp  -> coerceInt2FP FloatRep x
-      Double2IntOp -> coerceFP2Int x
-      Int2DoubleOp -> coerceInt2FP DoubleRep x
+      MO_Flt_Cos  -> trivialUFCode FloatRep  (GCOS F) x
+      MO_Dbl_Cos  -> trivialUFCode DoubleRep (GCOS DF) x

 
 

-      Double2FloatOp -> coerceFltCode x
-      Float2DoubleOp -> coerceFltCode x
+      MO_Flt_Tan  -> trivialUFCode FloatRep  (GTAN F) x
+      MO_Dbl_Tan  -> trivialUFCode DoubleRep (GTAN DF) x

 
 

-      other_op ->
-        let
-           fixed_x = if is_float_op  -- promote to double
-                         then StPrim Float2DoubleOp [x]
-                         else x
-       in
-       getRegister (StCall fn DoubleRep [x])
-       where
-       (is_float_op, fn)
-         = case primop of
-             FloatExpOp    -> (True,  SLIT("exp"))
-             FloatLogOp    -> (True,  SLIT("log"))
+      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

 
 

-             FloatSinOp    -> (True,  SLIT("sin"))
-             FloatCosOp    -> (True,  SLIT("cos"))
-             FloatTanOp    -> (True,  SLIT("tan"))
+      -- Conversions which are a nop on x86
+      MO_NatS_to_32U  -> conversionNop WordRep   x
+      MO_32U_to_NatS  -> conversionNop IntRep    x

 
 

-             FloatAsinOp   -> (True,  SLIT("asin"))
-             FloatAcosOp   -> (True,  SLIT("acos"))
-             FloatAtanOp   -> (True,  SLIT("atan"))
+      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

 
 

-             FloatSinhOp   -> (True,  SLIT("sinh"))
-             FloatCoshOp   -> (True,  SLIT("cosh"))
-             FloatTanhOp   -> (True,  SLIT("tanh"))
+      MO_Dbl_to_Flt   -> conversionNop FloatRep  x
+      MO_Flt_to_Dbl   -> conversionNop DoubleRep x

 
 

-             DoubleExpOp   -> (False, SLIT("exp"))
-             DoubleLogOp   -> (False, SLIT("log"))
+      -- 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

 
 

-             DoubleSinOp   -> (False, SLIT("sin"))
-             DoubleCosOp   -> (False, SLIT("cos"))
-             DoubleTanOp   -> (False, SLIT("tan"))
+      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)
+         = 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.)
+       -}         
+      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
+    promote x = StMachOp MO_Flt_to_Dbl [x]
+    demote x  = StMachOp MO_Dbl_to_Flt [x]

 
 

-             DoubleAsinOp  -> (False, SLIT("asin"))
-             DoubleAcosOp  -> (False, SLIT("acos"))
-             DoubleAtanOp  -> (False, SLIT("atan"))
+    --------------------
+    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)

 
 

-             DoubleSinhOp  -> (False, SLIT("sinh"))
-             DoubleCoshOp  -> (False, SLIT("cosh"))
-             DoubleTanhOp  -> (False, SLIT("tanh"))
+    --------------------
+    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
+      = 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) -}
+      -- 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-}
+     = 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
+       returnNat (Any IntRep code__2)

 
 

-getRegister (StPrim primop [x, y]) -- dyadic PrimOps
-  = case primop of
-      CharGtOp -> condIntReg GT x y
-      CharGeOp -> condIntReg GE x y
-      CharEqOp -> condIntReg EQ x y
-      CharNeOp -> condIntReg NE x y
-      CharLtOp -> condIntReg LT x y
-      CharLeOp -> condIntReg LE x y
-
-      IntGtOp  -> condIntReg GT x y
-      IntGeOp  -> condIntReg GE x y
-      IntEqOp  -> condIntReg EQ x y
-      IntNeOp  -> condIntReg NE x y
-      IntLtOp  -> condIntReg LT x y
-      IntLeOp  -> condIntReg LE x y
-
-      WordGtOp -> condIntReg GU  x y
-      WordGeOp -> condIntReg GEU x y
-      WordEqOp -> condIntReg EQ  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 EQ  x y
-      AddrNeOp -> condIntReg NE  x y
-      AddrLtOp -> condIntReg LU  x y
-      AddrLeOp -> condIntReg LEU x y
-
-      FloatGtOp -> condFltReg GT x y
-      FloatGeOp -> condFltReg GE x y
-      FloatEqOp -> condFltReg EQ x y
-      FloatNeOp -> condFltReg NE x y
-      FloatLtOp -> condFltReg LT x y
-      FloatLeOp -> condFltReg LE x y
-
-      DoubleGtOp -> condFltReg GT x y
-      DoubleGeOp -> condFltReg GE x y
-      DoubleEqOp -> condFltReg EQ x y
-      DoubleNeOp -> condFltReg NE x y
-      DoubleLtOp -> condFltReg LT 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-}
-      SllOp -> trivialCode (SHL L) x y {-False-}
-      SraOp -> trivialCode (SAR L) x y {-False-}
-      SrlOp -> trivialCode (SHR L) x y {-False-}
-
-      ISllOp -> panic "I386Gen:isll"
-      ISraOp -> panic "I386Gen:isra"
-      ISrlOp -> panic "I386Gen:isrl"
-
-      FloatPowerOp  -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
-                      where promote x = StPrim Float2DoubleOp [x]
-      DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
-  where
-    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 (Addr (Just src1) Nothing src2)) (OpReg dst))
+           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 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)]
-       in
-       returnUs (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 (Addr (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 (Addr (Just src1) Nothing src2)) (OpReg dst))
+           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)

 
 

-    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 (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
-                                  MOV L (OpReg src1) (OpReg eax),
-                                  CLTD,
-                                  IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
-       in
-       returnUs (Fixed IntRep (if is_division then eax else edx) 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 (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
-                                        MOV L (OpReg src1) (OpReg eax),
-                                        CLTD,
-                                        IDIV sz (OpAddr (Addr (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))
-    in
-       returnUs (Any pk code__2)
-
+       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
+       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
 
 #endif {- i386_TARGET_ARCH -}
   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
 
 #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
+       returnNat (Any DoubleRep code)

 
 

-      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
-
-      other_op ->
-        let
-           fixed_x = if is_float_op  -- promote to double
-                         then StPrim Float2DoubleOp [x]
-                         else x
-       in
-       getRegister (StCall fn DoubleRep [x])
-       where
-       (is_float_op, fn)
-         = case primop of
-             FloatExpOp    -> (True,  SLIT("exp"))
-             FloatLogOp    -> (True,  SLIT("log"))
+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)

 
 

-             FloatSinOp    -> (True,  SLIT("sin"))
-             FloatCosOp    -> (True,  SLIT("cos"))
-             FloatTanOp    -> (True,  SLIT("tan"))
+      MO_Flt_Neg       -> trivialUFCode FloatRep (FNEG F) x
+      MO_Dbl_Neg       -> trivialUFCode DoubleRep (FNEG DF) x

 
 

-             FloatAsinOp   -> (True,  SLIT("asin"))
-             FloatAcosOp   -> (True,  SLIT("acos"))
-             FloatAtanOp   -> (True,  SLIT("atan"))
+      MO_Dbl_to_Flt    -> coerceDbl2Flt x
+      MO_Flt_to_Dbl    -> coerceFlt2Dbl x

 
 

-             FloatSinhOp   -> (True,  SLIT("sinh"))
-             FloatCoshOp   -> (True,  SLIT("cosh"))
-             FloatTanhOp   -> (True,  SLIT("tanh"))
+      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

 
 

-             DoubleExpOp   -> (False, SLIT("exp"))
-             DoubleLogOp   -> (False, SLIT("log"))
+      -- Conversions which are a nop on sparc
+      MO_32U_to_NatS   -> conversionNop IntRep   x
+      MO_NatS_to_32U   -> conversionNop WordRep  x

 
 

-             DoubleSinOp   -> (False, SLIT("sin"))
-             DoubleCosOp   -> (False, SLIT("cos"))
-             DoubleTanOp   -> (False, SLIT("tan"))
+      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

 
 

-             DoubleAsinOp  -> (False, SLIT("asin"))
-             DoubleAcosOp  -> (False, SLIT("acos"))
-             DoubleAtanOp  -> (False, SLIT("atan"))
+      -- 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

 
 

-             DoubleSinhOp  -> (False, SLIT("sinh"))
-             DoubleCoshOp  -> (False, SLIT("cosh"))
-             DoubleTanhOp  -> (False, SLIT("tanh"))
+      other_op ->
+        let fixed_x = if   is_float_op  -- promote to double
+                      then StMachOp MO_Flt_to_Dbl [x]
+                      else x
+       in
+       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)

 
 

-getRegister (StPrim primop [x, y]) -- dyadic PrimOps
-  = case primop of
-      CharGtOp -> condIntReg GT x y
-      CharGeOp -> condIntReg GE x y
-      CharEqOp -> condIntReg EQ x y
-      CharNeOp -> condIntReg NE x y
-      CharLtOp -> condIntReg LT x y
-      CharLeOp -> condIntReg LE x y
-
-      IntGtOp  -> condIntReg GT x y
-      IntGeOp  -> condIntReg GE x y
-      IntEqOp  -> condIntReg EQ x y
-      IntNeOp  -> condIntReg NE x y
-      IntLtOp  -> condIntReg LT x y
-      IntLeOp  -> condIntReg LE x y
-
-      WordGtOp -> condIntReg GU  x y
-      WordGeOp -> condIntReg GEU x y
-      WordEqOp -> condIntReg EQ  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 EQ  x y
-      AddrNeOp -> condIntReg NE  x y
-      AddrLtOp -> condIntReg LU  x y
-      AddrLeOp -> condIntReg LEU x y
-
-      FloatGtOp -> condFltReg GT x y
-      FloatGeOp -> condFltReg GE x y
-      FloatEqOp -> condFltReg EQ x y
-      FloatNeOp -> condFltReg NE x y
-      FloatLtOp -> condFltReg LT x y
-      FloatLeOp -> condFltReg LE x y
-
-      DoubleGtOp -> condFltReg GT x y
-      DoubleGeOp -> condFltReg GE x y
-      DoubleEqOp -> condFltReg EQ x y
-      DoubleNeOp -> condFltReg NE x y
-      DoubleLtOp -> condFltReg LT 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
-      SllOp -> trivialCode SLL x y
-      SraOp -> trivialCode SRA x y
-      SrlOp -> trivialCode SRL x y
-
-      ISllOp -> panic "SparcGen:isll"
-      ISraOp -> panic "SparcGen:isra"
-      ISrlOp -> panic "SparcGen:isrl"
-
-      FloatPowerOp  -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
-                      where promote x = StPrim Float2DoubleOp [x]
-      DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [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(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
   where

-    imul_div fn x y = getRegister (StCall fn IntRep [x, y])
+    idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])
+
+    --------------------
+    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)

 
 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 src dst

     in
     in

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

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

-       code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
+       code dst = unitOL (OR False g0 (RIImm src) dst)

     in
     in

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

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

-       code dst = mkSeqInstrs [
+       code dst = toOL [

            SETHI (HI imm__2) dst,
            OR False dst (RIImm (LO imm__2)) dst]
     in
            SETHI (HI imm__2) dst,
            OR False dst (RIImm (LO imm__2)) dst]
     in

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

   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
 
 #endif {- sparc_TARGET_ARCH -}
   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
 
 #endif {- sparc_TARGET_ARCH -}

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

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

@@ -1048,7 +1473,7 @@ getRegister leaf
 
 @Amode@s: Memory addressing modes passed up the tree.
 \begin{code}
 
 @Amode@s: Memory addressing modes passed up the tree.
 \begin{code}

-data Amode = Amode Addr InstrBlock
+data Amode = Amode MachRegsAddr InstrBlock

 
 amodeAddr (Amode addr _) = addr
 amodeCode (Amode _ code) = code
 
 amodeAddr (Amode addr _) = addr
 amodeCode (Amode _ code) = code

@@ -1057,180 +1482,199 @@ 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 (Addr (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 (Addr (Just reg) Nothing off) code)
+    returnNat (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 ->
+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 (Addr (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 (Addr (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
     in

-    returnUs (Amode (AddrRegReg reg1 reg2) code__2)
+    returnNat (Amode (AddrRegReg reg1 reg2) code__2)

 
 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 (SETHI (HI imm__2) tmp)

     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 {- sparc_TARGET_ARCH -}
 
 #endif {- sparc_TARGET_ARCH -}

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

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

@@ -1243,69 +1687,70 @@ 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"
 #endif {- alpha_TARGET_ARCH -}
 
 #if alpha_TARGET_ARCH
 getCondCode = panic "MachCode.getCondCode: not on Alphas"
 #endif {- alpha_TARGET_ARCH -}

+

 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
 -- yes, they really do seem to want exactly the same!
 
 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
 -- yes, they really do seem to want exactly the same!
 

-getCondCode (StPrim primop [x, y])
-  = case primop of
-      CharGtOp -> condIntCode GT  x y
-      CharGeOp -> condIntCode GE  x y
-      CharEqOp -> condIntCode EQ  x y
-      CharNeOp -> condIntCode NE  x y
-      CharLtOp -> condIntCode LT  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 GT  x y
-      IntGeOp  -> condIntCode GE  x y
-      IntEqOp  -> condIntCode EQ  x y
-      IntNeOp  -> condIntCode NE  x y
-      IntLtOp  -> condIntCode LT  x y
-      IntLeOp  -> condIntCode LE  x y
-
-      WordGtOp -> condIntCode GU  x y
-      WordGeOp -> condIntCode GEU x y
-      WordEqOp -> condIntCode EQ  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 EQ  x y
-      AddrNeOp -> condIntCode NE  x y
-      AddrLtOp -> condIntCode LU  x y
-      AddrLeOp -> condIntCode LEU x y
-
-      FloatGtOp -> condFltCode GT x y
-      FloatGeOp -> condFltCode GE x y
-      FloatEqOp -> condFltCode EQ x y
-      FloatNeOp -> condFltCode NE x y
-      FloatLtOp -> condFltCode LT x y
-      FloatLeOp -> condFltCode LE x y
-
-      DoubleGtOp -> condFltCode GT x y
-      DoubleGeOp -> condFltCode GE x y
-      DoubleEqOp -> condFltCode EQ x y
-      DoubleNeOp -> condFltCode NE x y
-      DoubleLtOp -> condFltCode LT x y
-      DoubleLeOp -> condFltCode LE x y
+      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)" (pprMachOp mop)
+
+getCondCode other =  pprPanic "getCondCode(2)(x86,sparc)" (pprStixExpr other)

 
 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
 
 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}

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

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

@@ -1314,7 +1759,7 @@ 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"
 
 #if alpha_TARGET_ARCH
 condIntCode = panic "MachCode.condIntCode: not on Alphas"

@@ -1324,189 +1769,191 @@ condFltCode = panic "MachCode.condFltCode: not on Alphas"
 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 #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))
-    in
-    returnUs (CondCode False cond code__2)
-  where
-    imm    = maybeImm y
-    imm__2 = case imm of Just x -> x
-
-condIntCode cond (StInd _ x) y
-  = getAmode x                 `thenUs` \ amode ->
-    getRegister y              `thenUs` \ register2 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp2 ->
-    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))
-    in
-    returnUs (CondCode False cond code__2)
-
-condIntCode cond y (StInd _ x)
-  = getAmode x                 `thenUs` \ amode ->
-    getRegister y              `thenUs` \ register2 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp2 ->
-    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))
-    in
-    returnUs (CondCode False cond code__2)
-
+       code__2 = code1 `snocOL`
+                  CMP L (OpImm i) (OpReg src1)
+    in
+    returnNat (CondCode False cond code__2)
+
+-- memory vs anything
+condIntCode cond (StInd pk x) y
+  = getAmode x                 `thenNat` \ amode_x ->
+    getRegister y              `thenNat` \ reg_y ->
+    getNewRegNCG IntRep                `thenNat` \ tmp ->
+    let
+       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
+    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
+       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
+    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
-                             ]
-    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
-
-fix_FP_cond GE  = GEU
-fix_FP_cond GT  = GU
-fix_FP_cond LT  = LU
-fix_FP_cond LE  = LEU
-fix_FP_cond any = any
+       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
+    -- 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)

 
 #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

@@ -1518,18 +1965,20 @@ 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
     in

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

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

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

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

@@ -1547,289 +1996,307 @@ 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
     let

-       dst__2  = registerName register1 zero
+       dst__2  = registerName register1 zeroh

        code    = registerCode register2 dst__2
        src__2  = registerName register2 dst__2
        code__2 = if isFixed register2
                  then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
                  else code
     in
        code    = registerCode register2 dst__2
        src__2  = registerName register2 dst__2
        code__2 = if isFixed register2
                  then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
                  else code
     in

-    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) ->
-    let
-       code1   = amodeCode amode asmVoid
-       dst__2  = amodeAddr amode
-       code__2 = asmParThen [code1, codesrc asmVoid] .
-                 mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
-    in
-    returnUs code__2
+-- 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
+        -- 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
+    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)
-
-assignIntCode pk dst (StInd _ src)
-  = getNewRegNCG IntRep            `thenUs` \ tmp ->
-    getAmode src                   `thenUs` \ amode ->
-    getRegister dst                        `thenUs` \ register ->
-    let
-       code1   = amodeCode amode asmVoid
-       src__2  = amodeAddr amode
-       code2   = registerCode register tmp asmVoid
-       dst__2  = registerName register tmp
-       sz      = primRepToSize pk
-       code__2 = asmParThen [code1, code2] .
-                 mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
-    in
-    returnUs code__2
-
-assignIntCode pk dst src
-  = getRegister dst                        `thenUs` \ register1 ->
-    getRegister src                        `thenUs` \ register2 ->
-    getNewRegNCG IntRep            `thenUs` \ tmp ->
-    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))
-                 else code
+       returnNat (code, OpReg reg)
+
+-- 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
+       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
     in

-    returnUs code__2
+    returnNat code

 
 #endif {- i386_TARGET_ARCH -}
 
 #endif {- i386_TARGET_ARCH -}

+

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

+

 #if sparc_TARGET_ARCH
 
 #if sparc_TARGET_ARCH
 

-assignIntCode pk (StInd _ dst) src
-  = getNewRegNCG IntRep            `thenUs` \ tmp ->
-    getAmode dst                   `thenUs` \ amode ->
-    getRegister src                        `thenUs` \ register ->
+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
        dst__2  = registerName register1 g0
        code    = registerCode register2 dst__2
        src__2  = registerName register2 dst__2
        code__2 = if isFixed register2
     let
        dst__2  = registerName register1 g0
        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` OR False g0 (RIReg src__2) dst__2

                  else code
     in
                  else code
     in

-    returnUs code__2
+    returnNat code__2

 
 #endif {- sparc_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)
-    in
-    returnUs code__2
-
-assignFltCode pk dst src
-  = getRegister dst                        `thenUs` \ register1 ->
-    getRegister src                        `thenUs` \ register2 ->
-    let
-       dst__2  = registerName register1 zero
-       code    = registerCode register2 dst__2
-       src__2  = registerName register2 dst__2
-       code__2 = if isFixed register2
-                 then code . mkSeqInstr (FMOV src__2 dst__2)
-                 else code
-    in
-    returnUs code__2
-
-#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
-
-assignFltCode pk (StInd _ dst) src
-  = --getNewRegNCG pk              `thenUs` \ tmp ->
-    getAmode dst                   `thenUs` \ amode ->
-    getRegister src                        `thenUs` \ register ->
-    let
-       sz      = primRepToSize pk
-       dst__2  = amodeAddr amode
-
-       code1   = amodeCode amode asmVoid
-       code2   = registerCode register {-tmp-}st0 asmVoid
-
-       --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__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 ->
-    --getNewRegNCG (registerRep register2)
-    --                             `thenUs` \ tmp ->
+  = getRegister dst                        `thenNat` \ register1 ->
+    getRegister src                        `thenNat` \ register2 ->

     let
     let

-       sz      = primRepToSize pk
-       dst__2  = registerName register1 st0 --tmp
-
+       dst__2  = registerName register1 zeroh

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

-
-       code__2 = code
+       code__2 = if isFixed register2
+                 then code . mkSeqInstr (FMOV src__2 dst__2)
+                 else code

     in
     in

-    returnUs code__2
+    returnNat code__2
+
+#endif {- alpha_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if i386_TARGET_ARCH
+
+-- 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
+       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` GMOV r_src r_dst
+               else c_src
+    in
+    returnNat code
+

 
 #endif {- i386_TARGET_ARCH -}
 
 #endif {- i386_TARGET_ARCH -}

+

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

+

 #if sparc_TARGET_ARCH
 
 #if sparc_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
+  = 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 tmp asmVoid
+       code1   = amodeCode amode
+       code2   = registerCode register tmp1

 
 

-       src__2  = registerName register tmp
+       src__2  = registerName register tmp1

        pk__2   = registerRep register
        sz__2   = primRepToSize pk__2
 
        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 tmp, ST sz tmp 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 ->
-    getNewRegNCG (registerRep register2)
-                                   `thenUs` \ tmp ->
+-- 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
+    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
        src__2  = registerName register2 reg__2
        code    = registerCode register2 reg__2
        src__2  = registerName register2 reg__2

-       pk__2   = registerRep register2
-       sz__2   = primRepToSize pk__2
-
-       code__2 = if pk /= pk__2 then
-                    code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
+       code__2 = 
+               if pk /= pk__2 then
+                    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 -}
 
 #endif {- sparc_TARGET_ARCH -}

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

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

@@ -1847,85 +2314,86 @@ 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
 
 genJump (StCLbl lbl)
   | isAsmTemp lbl = returnInstr (BR target)
 
 #if alpha_TARGET_ARCH
 
 genJump (StCLbl lbl)
   | isAsmTemp lbl = returnInstr (BR target)

-  | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zero (AddrReg pv) 0]
+  | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]

   where
     target = ImmCLbl lbl
 
 genJump tree
   where
     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
        target = registerName register pv
     in
     if isFixed register then
     let
        dst    = registerName register pv
        code   = registerCode register pv
        target = registerName register pv
     in
     if isFixed register then

-       returnSeq code [OR dst (RIReg dst) pv, JMP zero (AddrReg pv) 0]
+       returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]

     else
     else

-    returnUs (code . mkSeqInstr (JMP zero (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
 
 #endif {- i386_TARGET_ARCH -}
   where
     imm    = maybeImm tree
     target = case imm of Just x -> x
 
 #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
     let
        code   = registerCode register tmp
        target = registerName register tmp
     in

-    returnSeq code [JMP (AddrRegReg target g0), NOP]
+    returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)

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

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

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

@@ -1956,15 +2424,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

@@ -1973,66 +2443,66 @@ genCondJump lbl (StPrim op [x, StInt 0])
     in
     returnSeq code [BI (cmpOp op) value target]
   where
     in
     returnSeq code [BI (cmpOp op) value target]
   where

-    cmpOp CharGtOp = GT
+    cmpOp CharGtOp = GTT

     cmpOp CharGeOp = GE
     cmpOp CharGeOp = GE

-    cmpOp CharEqOp = EQ
+    cmpOp CharEqOp = EQQ

     cmpOp CharNeOp = NE
     cmpOp CharNeOp = NE

-    cmpOp CharLtOp = LT
+    cmpOp CharLtOp = LTT

     cmpOp CharLeOp = LE
     cmpOp CharLeOp = LE

-    cmpOp IntGtOp = GT
+    cmpOp IntGtOp = GTT

     cmpOp IntGeOp = GE
     cmpOp IntGeOp = GE

-    cmpOp IntEqOp = EQ
+    cmpOp IntEqOp = EQQ

     cmpOp IntNeOp = NE
     cmpOp IntNeOp = NE

-    cmpOp IntLtOp = LT
+    cmpOp IntLtOp = LTT

     cmpOp IntLeOp = LE
     cmpOp WordGtOp = NE
     cmpOp WordGeOp = ALWAYS
     cmpOp IntLeOp = LE
     cmpOp WordGtOp = NE
     cmpOp WordGeOp = ALWAYS

-    cmpOp WordEqOp = EQ
+    cmpOp WordEqOp = EQQ

     cmpOp WordNeOp = NE
     cmpOp WordLtOp = NEVER
     cmpOp WordNeOp = NE
     cmpOp WordLtOp = NEVER

-    cmpOp WordLeOp = EQ
+    cmpOp WordLeOp = EQQ

     cmpOp AddrGtOp = NE
     cmpOp AddrGeOp = ALWAYS
     cmpOp AddrGtOp = NE
     cmpOp AddrGeOp = ALWAYS

-    cmpOp AddrEqOp = EQ
+    cmpOp AddrEqOp = EQQ

     cmpOp AddrNeOp = NE
     cmpOp AddrLtOp = NEVER
     cmpOp AddrNeOp = NE
     cmpOp AddrLtOp = NEVER

-    cmpOp AddrLeOp = EQ
+    cmpOp AddrLeOp = EQQ

 
 genCondJump lbl (StPrim op [x, StDouble 0.0])
 
 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
   where

-    cmpOp FloatGtOp = GT
+    cmpOp FloatGtOp = GTT

     cmpOp FloatGeOp = GE
     cmpOp FloatGeOp = GE

-    cmpOp FloatEqOp = EQ
+    cmpOp FloatEqOp = EQQ

     cmpOp FloatNeOp = NE
     cmpOp FloatNeOp = NE

-    cmpOp FloatLtOp = LT
+    cmpOp FloatLtOp = LTT

     cmpOp FloatLeOp = LE
     cmpOp FloatLeOp = LE

-    cmpOp DoubleGtOp = GT
+    cmpOp DoubleGtOp = GTT

     cmpOp DoubleGeOp = GE
     cmpOp DoubleGeOp = GE

-    cmpOp DoubleEqOp = EQ
+    cmpOp DoubleEqOp = EQQ

     cmpOp DoubleNeOp = NE
     cmpOp DoubleNeOp = NE

-    cmpOp DoubleLtOp = LT
+    cmpOp DoubleLtOp = LTT

     cmpOp DoubleLeOp = LE
 
 genCondJump lbl (StPrim op [x, y])
   | fltCmpOp op
     cmpOp DoubleLeOp = LE
 
 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"
 

@@ -2051,87 +2521,94 @@ genCondJump lbl (StPrim op [x, y])
        DoubleLeOp -> True
        _ -> False
     (instr, cond) = case op of
        DoubleLeOp -> True
        _ -> False
     (instr, cond) = case op of

-       FloatGtOp -> (FCMP TF LE, EQ)
-       FloatGeOp -> (FCMP TF LT, EQ)
-       FloatEqOp -> (FCMP TF EQ, NE)
-       FloatNeOp -> (FCMP TF EQ, EQ)
-       FloatLtOp -> (FCMP TF LT, NE)
+       FloatGtOp -> (FCMP TF LE, EQQ)
+       FloatGeOp -> (FCMP TF LTT, EQQ)
+       FloatEqOp -> (FCMP TF EQQ, NE)
+       FloatNeOp -> (FCMP TF EQQ, EQQ)
+       FloatLtOp -> (FCMP TF LTT, NE)

        FloatLeOp -> (FCMP TF LE, NE)
        FloatLeOp -> (FCMP TF LE, NE)

-       DoubleGtOp -> (FCMP TF LE, EQ)
-       DoubleGeOp -> (FCMP TF LT, EQ)
-       DoubleEqOp -> (FCMP TF EQ, NE)
-       DoubleNeOp -> (FCMP TF EQ, EQ)
-       DoubleLtOp -> (FCMP TF LT, NE)
+       DoubleGtOp -> (FCMP TF LE, EQQ)
+       DoubleGeOp -> (FCMP TF LTT, EQQ)
+       DoubleEqOp -> (FCMP TF EQQ, NE)
+       DoubleNeOp -> (FCMP TF EQQ, EQQ)
+       DoubleLtOp -> (FCMP TF LTT, NE)

        DoubleLeOp -> (FCMP TF LE, NE)
 
 genCondJump lbl (StPrim op [x, y])
        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
   where
     (instr, cond) = case op of

-       CharGtOp -> (CMP LE, EQ)
-       CharGeOp -> (CMP LT, EQ)
-       CharEqOp -> (CMP EQ, NE)
-       CharNeOp -> (CMP EQ, EQ)
-       CharLtOp -> (CMP LT, NE)
+       CharGtOp -> (CMP LE, EQQ)
+       CharGeOp -> (CMP LTT, EQQ)
+       CharEqOp -> (CMP EQQ, NE)
+       CharNeOp -> (CMP EQQ, EQQ)
+       CharLtOp -> (CMP LTT, NE)

        CharLeOp -> (CMP LE, NE)
        CharLeOp -> (CMP LE, NE)

-       IntGtOp -> (CMP LE, EQ)
-       IntGeOp -> (CMP LT, EQ)
-       IntEqOp -> (CMP EQ, NE)
-       IntNeOp -> (CMP EQ, EQ)
-       IntLtOp -> (CMP LT, NE)
+       IntGtOp -> (CMP LE, EQQ)
+       IntGeOp -> (CMP LTT, EQQ)
+       IntEqOp -> (CMP EQQ, NE)
+       IntNeOp -> (CMP EQQ, EQQ)
+       IntLtOp -> (CMP LTT, NE)

        IntLeOp -> (CMP LE, NE)
        IntLeOp -> (CMP LE, NE)

-       WordGtOp -> (CMP ULE, EQ)
-       WordGeOp -> (CMP ULT, EQ)
-       WordEqOp -> (CMP EQ, NE)
-       WordNeOp -> (CMP EQ, EQ)
+       WordGtOp -> (CMP ULE, EQQ)
+       WordGeOp -> (CMP ULT, EQQ)
+       WordEqOp -> (CMP EQQ, NE)
+       WordNeOp -> (CMP EQQ, EQQ)

        WordLtOp -> (CMP ULT, NE)
        WordLeOp -> (CMP ULE, NE)
        WordLtOp -> (CMP ULT, NE)
        WordLeOp -> (CMP ULE, NE)

-       AddrGtOp -> (CMP ULE, EQ)
-       AddrGeOp -> (CMP ULT, EQ)
-       AddrEqOp -> (CMP EQ, NE)
-       AddrNeOp -> (CMP EQ, EQ)
+       AddrGtOp -> (CMP ULE, EQQ)
+       AddrGeOp -> (CMP ULT, EQQ)
+       AddrEqOp -> (CMP EQQ, NE)
+       AddrNeOp -> (CMP EQQ, EQQ)

        AddrLtOp -> (CMP ULT, NE)
        AddrLeOp -> (CMP ULE, NE)
 
 #endif {- alpha_TARGET_ARCH -}
        AddrLtOp -> (CMP ULT, NE)
        AddrLeOp -> (CMP ULE, NE)
 
 #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 -}

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

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

@@ -2149,22 +2626,25 @@ register allocator.
 
 \begin{code}
 genCCall
 
 \begin{code}
 genCCall

-    :: FAST_STRING     -- function to call
+    :: (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
 
 
 #if alpha_TARGET_ARCH
 

-genCCall fn kind args
-  = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
-                                   `thenUs` \ ((unused,_), argCode) ->
+genCCall fn cconv kind args
+  = 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 [
     in
        returnSeq code [

-           LDA pv (AddrImm (ImmLab (uppPStr fn))),
+           LDA pv (AddrImm (ImmLab (ptext fn))),

            JSR ra (AddrReg pv) nRegs,
            LDGP gp (AddrReg ra)]
   where
            JSR ra (AddrReg pv) nRegs,
            LDGP gp (AddrReg ra)]
   where

@@ -2178,24 +2658,24 @@ genCCall fn 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)

@@ -2209,181 +2689,273 @@ genCCall fn 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 kind [StInt i]
-  | fn == SLIT ("PerformGC_wrapper")
-  = getUniqLabelNCG                        `thenUs` \ lbl ->
-    let
-       call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
-               MOV L (OpImm (ImmCLbl lbl))
-                     -- this is hardwired
-                     (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
-               JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
-               LABEL lbl]
-    in
-    returnInstrs call
+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
+    -- 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
+    setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
+    returnNat (push_code `appOL` call)

 
 

-genCCall fn kind args
-  = mapUs get_call_arg args `thenUs` \ argCode ->
-    let
-       nargs = length args
-       code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
-                       MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
-                                  ]
-                          ]
-       code2 = asmParThen (map ($ asmVoid) (reverse argCode))
-       call = [CALL fn__2 -- ,
-               -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
-               -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
-               ]
-    in
-    returnSeq (code1 . 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 (uppPStr fn)
-             _   -> ImmLab (uppPStr 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 kind args
-  = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
-                                   `thenUs` \ ((unused,_), argCode) ->
-    let
-       nRegs = length allArgRegs - length unused
-       call = CALL fn__2 nRegs False
-       code = asmParThen (map ($ asmVoid) argCode)
-    in
-       returnSeq code [call, NOP]
+genCCall fn cconv kind args
+  = 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
+        argcode = concatOL argcodes
+        (move_sp_down, move_sp_up)
+           = let nn = length vregs - n_argRegs 
+                                   + 1 -- (for the road)
+             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
+        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 (uppPStr fn)
-             _   -> ImmLab (uppPStr 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...
-
-    get_arg (dst:dsts, offset) arg
-      = getRegister arg                        `thenUs` \ register ->
-       getNewRegNCG (registerRep register)
-                                       `thenUs` \ tmp ->
-       let
-           reg  = if isFloatingRep pk then tmp else dst
-           code = registerCode register reg
-           src  = registerName register reg
-           pk   = registerRep register
-       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))
-
-    -- Once we have run out of argument registers, we move to the
-    -- stack...
-
-    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)))
-
+     -- 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 -}
 #endif {- sparc_TARGET_ARCH -}

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

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

@@ -2405,7 +2977,9 @@ 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)"
 
 #if alpha_TARGET_ARCH
 condIntReg = panic "MachCode.condIntReg (not on Alpha)"

@@ -2413,33 +2987,30 @@ 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,

@@ -2447,78 +3018,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
 
 #if sparc_TARGET_ARCH
 

-condIntReg EQ x (StInt 0)
-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG IntRep                `thenUs` \ tmp ->
+condIntReg EQQ x (StInt 0)
+  = 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 EQ x y
-  = getRegister x              `thenUs` \ register1 ->
-    getRegister y              `thenUs` \ register2 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp1 ->
-    getNewRegNCG IntRep                `thenUs` \ tmp2 ->
+condIntReg EQQ x y
+  = 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,

@@ -2526,16 +3099,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,

@@ -2544,9 +3117,11 @@ 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 -}
 
 #endif {- sparc_TARGET_ARCH -}

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

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

@@ -2567,89 +3142,87 @@ 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
+    -> 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-}
+      ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)

       ,)))
       ,)))

-    -> StixTree -> StixTree -- the two arguments
-    -> UniqSM Register
+    -> 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
+    -> 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
+    -> 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

@@ -2657,263 +3230,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
-    in
-    returnUs (Any pk1 code__2)
+       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

 
 

--------------
-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]
+           -- be paranoid (and inefficient)
+           | otherwise
+           = code1 `snocOL` GMOV src1 tmp1  `appOL`
+             code2 `snocOL`
+             instr (primRepToSize pk) tmp1 src2 dst

     in
     in

-    returnUs (Any pk code__2)
+    returnNat (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

@@ -2925,40 +3481,42 @@ 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 -}

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

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

@@ -2967,45 +3525,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

@@ -3015,12 +3559,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

@@ -3030,219 +3574,100 @@ 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 (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
-                     FILD (primRepToSize pk) (Addr (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 = let
-                     in code . mkSeqInstrs [
-                               FRNDINT,
-                               FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)),
-                               MOV L (OpAddr (Addr (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.
-
-\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)
-    in
-    returnUs (Any IntRep code__2)
-
-#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))
-    in
-    returnUs (Any IntRep code__2)
+    returnNat (Any IntRep code__2)

 
 

-#endif {- i386_TARGET_ARCH -}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if 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]
+------------
+coerceDbl2Flt x
+  = getRegister x              `thenNat` \ register ->
+    getNewRegNCG DoubleRep     `thenNat` \ tmp ->
+    let code = registerCode register tmp
+        src  = registerName register tmp

     in
     in

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

 
 

-chrCode x
-  = getRegister x              `thenUs` \ register ->
-    getNewRegNCG IntRep                `thenUs` \ reg ->
-    let
-       code = registerCode register reg
-       src  = registerName register reg
-       code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
+------------
+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 {- sparc_TARGET_ARCH -}
 
 #endif {- sparc_TARGET_ARCH -}

-\end{code}
-
-%************************************************************************
-%*                                                                     *
-\subsubsection{Absolute value on integers}
-%*                                                                     *
-%************************************************************************
-
-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 ->
-    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]
-    in
-    returnUs (Any IntRep code__2)
-
-#endif {- sparc_TARGET_ARCH -}

 \end{code}
 \end{code}