path: root/ghc/compiler/nativeGen/MachCode.lhs

%
% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[MachCode]{Generating machine code}

This is a big module, but, if you pay attention to
(a) the sectioning, (b) the type signatures, and
(c) the \tr{#if blah_TARGET_ARCH} things, the
structure should not be too overwhelming.

\begin{code}
module MachCode ( stmtsToInstrs, InstrBlock ) where

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

import Unique		( Unique )
import MachMisc		-- may differ per-platform
import MachRegs
import OrdList		( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
			  snocOL, consOL, concatOL )
import MachOp		( MachOp(..), pprMachOp )
import AbsCUtils	( magicIdPrimRep )
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 Pretty
import Outputable	( panic, pprPanic, showSDoc )
import qualified Outputable
import CmdLineOpts	( opt_Static )
import Stix		( pprStixStmt )

-- DEBUGGING ONLY
import IOExts		( trace )
import Outputable	( assertPanic )

infixr 3 `bind`
\end{code}

@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}
type InstrBlock = OrdList Instr

x `bind` f = f x

isLeft (Left _)  = True
isLeft (Right _) = False

unLeft (Left x) = x
\end{code}

Code extractor for an entire stix tree---stix statement level.

\begin{code}
stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
stmtsToInstrs stmts
   = mapNat stmtToInstrs stmts		`thenNat` \ instrss ->
     returnNat (concatOL instrss)


stmtToInstrs :: StixStmt -> NatM InstrBlock
stmtToInstrs stmt = case stmt of
    StComment s    -> returnNat (unitOL (COMMENT s))
    StSegment seg  -> returnNat (unitOL (SEGMENT seg))

    StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
                                                       LABEL lab)))
    StFunEnd lab   -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
                                    returnNat nilOL)

    StLabel lab	   -> returnNat (unitOL (LABEL lab))

    StJump dsts arg	   -> genJump dsts (derefDLL arg)
    StCondJump lab arg	   -> genCondJump lab (derefDLL arg)

    -- A call returning void, ie one done for its side-effects.  Note
    -- that this is the only StVoidable we handle.
    StVoidable (StCall fn cconv VoidRep args) 
       -> genCCall fn cconv VoidRep (map derefDLL args)

    StAssignMem pk addr src
      | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
      | ncg_target_is_32bit
        && is64BitRep pk -> assignMem_I64Code    (derefDLL addr) (derefDLL src)
      | otherwise	 -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
    StAssignReg pk reg src
      | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
      | ncg_target_is_32bit
        && is64BitRep pk -> assignReg_I64Code    reg (derefDLL src)
      | otherwise	 -> assignReg_IntCode pk reg (derefDLL src)

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

    StData kind args
      -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
	 returnNat (DATA (primRepToSize kind) imms  
                    `consOL`  concatOL codes)
      where
	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 (_UNPK_ 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}

%************************************************************************
%*									*
\subsection{General things for putting together code sequences}
%*									*
%************************************************************************

\begin{code}
mangleIndexTree :: StixExpr -> StixExpr

mangleIndexTree (StIndex pk base (StInt i))
  = StMachOp MO_Nat_Add [base, off]
  where
    off = StInt (i * toInteger (getPrimRepArrayElemSize pk))

mangleIndexTree (StIndex pk base off)
  = 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
    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}
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)
  | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
  = Just (ImmInt (fromInteger i))
  | otherwise
  = Just (ImmInteger i)

maybeImm _ = Nothing
\end{code}

%************************************************************************
%*									*
\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}
%*									*
%************************************************************************

@Register@s passed up the tree.  If the stix code forces the register
to live in a pre-decided machine register, it comes out as @Fixed@;
otherwise, it comes out as @Any@, and the parent can decide which
register to put it in.

\begin{code}
data Register
  = Fixed   PrimRep Reg InstrBlock
  | Any	    PrimRep (Reg -> InstrBlock)

registerCode :: Register -> Reg -> InstrBlock
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 (Any _ _)   reg   = reg

registerNameF (Fixed _ reg _) = reg
registerNameF (Any _ _)       = panic "registerNameF"

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

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

isAny = not . isFixed
\end{code}

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

getRegisterReg :: StixReg -> NatM Register
getRegister :: StixExpr -> NatM Register


getRegisterReg (StixMagicId mid)
  = case get_MagicId_reg_or_addr mid of
       Left (RealReg rrno) 
          -> let pk = magicIdPrimRep mid
             in  returnNat (Fixed pk (RealReg rrno) nilOL)
       Right baseRegAddr 
          -- By this stage, the only MagicIds remaining should be the
          -- ones which map to a real machine register on this platform.  Hence ...
          -> pprPanic "getRegisterReg-memory" (pprMagicId mid)

getRegisterReg (StixTemp (StixVReg u pk))
  = returnNat (Fixed pk (mkVReg u pk) nilOL)

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

-- Don't delete this -- it's very handy for debugging.
--getRegister expr 
--   | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
--   = panic "getRegister(???)"

getRegister (StReg reg) 
  = getRegisterReg reg

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
	  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)
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    let
	imm_lbl = ImmCLbl lbl

	code dst = toOL [
	    SEGMENT RoDataSegment,
	    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
    returnNat (Any PtrRep code)

-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-- end of machine-"independent" bit; here we go on the rest...

#if alpha_TARGET_ARCH

getRegister (StDouble d)
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    getNewRegNCG PtrRep    	    `thenNat` \ tmp ->
    let code dst = mkSeqInstrs [
    	    SEGMENT DataSegment,
	    LABEL lbl,
	    DATA TF [ImmLab (rational d)],
	    SEGMENT TextSegment,
	    LDA tmp (AddrImm (ImmCLbl lbl)),
	    LD TF dst (AddrReg tmp)]
    in
    	returnNat (Any DoubleRep code)

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

      NotOp    -> trivialUCode NOT x

      FloatNegOp  -> trivialUFCode FloatRep  (FNEG TF) x
      DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x

      OrdOp -> coerceIntCode IntRep x
      ChrOp -> chrCode x

      Float2IntOp  -> coerceFP2Int    x
      Int2FloatOp  -> coerceInt2FP pr x
      Double2IntOp -> coerceFP2Int    x
      Int2DoubleOp -> coerceInt2FP pr x

      Double2FloatOp -> coerceFltCode x
      Float2DoubleOp -> coerceFltCode x

      other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
	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")
  where
    pr = panic "MachCode.getRegister: no primrep needed for Alpha"

getRegister (StPrim primop [x, y]) -- dyadic PrimOps
  = case primop of
      CharGtOp -> trivialCode (CMP LTT) y x
      CharGeOp -> trivialCode (CMP LE) y x
      CharEqOp -> trivialCode (CMP EQQ) x y
      CharNeOp -> int_NE_code x y
      CharLtOp -> trivialCode (CMP LTT) x y
      CharLeOp -> trivialCode (CMP LE) x y

      IntGtOp  -> trivialCode (CMP LTT) y x
      IntGeOp  -> trivialCode (CMP LE) y x
      IntEqOp  -> trivialCode (CMP EQQ) x y
      IntNeOp  -> int_NE_code x y
      IntLtOp  -> trivialCode (CMP LTT) x y
      IntLeOp  -> trivialCode (CMP LE) x y

      WordGtOp -> trivialCode (CMP ULT) y x
      WordGeOp -> trivialCode (CMP ULE) x y
      WordEqOp -> trivialCode (CMP EQQ)  x y
      WordNeOp -> int_NE_code x y
      WordLtOp -> trivialCode (CMP ULT) x y
      WordLeOp -> trivialCode (CMP ULE) x y

      AddrGtOp -> trivialCode (CMP ULT) y x
      AddrGeOp -> trivialCode (CMP ULE) y x
      AddrEqOp -> trivialCode (CMP EQQ)  x y
      AddrNeOp -> int_NE_code x y
      AddrLtOp -> trivialCode (CMP ULT) x y
      AddrLeOp -> trivialCode (CMP ULE) x y
	
      FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
      FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
      FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
      FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
      FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
      FloatLeOp -> cmpF_code (FCMP TF LE) NE x y

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

      IntAddOp  -> trivialCode (ADD Q False) x y
      IntSubOp  -> trivialCode (SUB Q False) x y
      IntMulOp  -> trivialCode (MUL Q False) x y
      IntQuotOp -> trivialCode (DIV Q False) x y
      IntRemOp  -> trivialCode (REM Q False) x y

      WordAddOp  -> trivialCode (ADD Q False) x y
      WordSubOp  -> trivialCode (SUB Q False) x y
      WordMulOp  -> trivialCode (MUL Q False) x y
      WordQuotOp -> trivialCode (DIV Q True) x y
      WordRemOp  -> trivialCode (REM Q True) x y

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

      DoubleAddOp -> trivialFCode  DoubleRep (FADD TF) x y
      DoubleSubOp -> trivialFCode  DoubleRep (FSUB TF) x y
      DoubleMulOp -> trivialFCode  DoubleRep (FMUL TF) x y
      DoubleDivOp -> trivialFCode  DoubleRep (FDIV TF) x y

      AddrAddOp  -> trivialCode (ADD Q False) x y
      AddrSubOp  -> trivialCode (SUB Q False) x y
      AddrRemOp  -> trivialCode (REM Q True) x y

      AndOp  -> trivialCode AND x y
      OrOp   -> trivialCode OR  x y
      XorOp  -> trivialCode XOR x y
      SllOp  -> trivialCode SLL x y
      SrlOp  -> trivialCode SRL x y

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

      FloatPowerOp  -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
      DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
  where
    {- ------------------------------------------------------------
	Some bizarre special code for getting condition codes into
	registers.  Integer non-equality is a test for equality
	followed by an XOR with 1.  (Integer comparisons always set
	the result register to 0 or 1.)  Floating point comparisons of
	any kind leave the result in a floating point register, so we
	need to wrangle an integer register out of things.
    -}
    int_NE_code :: StixTree -> StixTree -> NatM Register

    int_NE_code x y
      = trivialCode (CMP EQQ) x y	`thenNat` \ register ->
	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
	returnNat (Any IntRep code__2)

    {- ------------------------------------------------------------
	Comments for int_NE_code also apply to cmpF_code
    -}
    cmpF_code
	:: (Reg -> Reg -> Reg -> Instr)
	-> Cond
	-> StixTree -> StixTree
	-> NatM Register

    cmpF_code instr cond x y
      = trivialFCode pr instr x y	`thenNat` \ register ->
	getNewRegNCG DoubleRep		`thenNat` \ tmp ->
	getNatLabelNCG			`thenNat` \ lbl ->
	let
	    code = registerCode register tmp
	    result  = registerName register tmp

	    code__2 dst = code . mkSeqInstrs [
		OR zeroh (RIImm (ImmInt 1)) dst,
		BF cond  result (ImmCLbl lbl),
		OR zeroh (RIReg zeroh) dst,
		LABEL lbl]
	in
	returnNat (Any IntRep code__2)
      where
	pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
      ------------------------------------------------------------

getRegister (StInd pk mem)
  = getAmode mem    	    	    `thenNat` \ amode ->
    let
    	code = amodeCode amode
    	src   = amodeAddr amode
    	size = primRepToSize pk
    	code__2 dst = code . mkSeqInstr (LD size dst src)
    in
    returnNat (Any pk code__2)

getRegister (StInt i)
  | fits8Bits i
  = let
    	code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
    in
    returnNat (Any IntRep code)
  | otherwise
  = let
    	code dst = mkSeqInstr (LDI Q dst src)
    in
    returnNat (Any IntRep code)
  where
    src = ImmInt (fromInteger i)

getRegister leaf
  | maybeToBool imm
  = let
    	code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
    in
    returnNat (Any PtrRep code)
  where
    imm = maybeImm leaf
    imm__2 = case imm of Just x -> x

#endif {- alpha_TARGET_ARCH -}

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

#if i386_TARGET_ARCH

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
    returnNat (Any FloatRep code)


getRegister (StDouble d)

  | 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,
	    DATA DF [ImmDouble d],
	    SEGMENT TextSegment,
	    GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
	    ]
    in
    returnNat (Any DoubleRep code)


getRegister (StMachOp mop [x]) -- unary MachOps
  = case mop of
      MO_NatS_Neg  -> trivialUCode (NEGI L) x
      MO_Nat_Not   -> trivialUCode (NOT L) x
      MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x

      MO_Flt_Neg  -> trivialUFCode FloatRep  (GNEG F) x
      MO_Dbl_Neg  -> trivialUFCode DoubleRep (GNEG DF) x

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

      MO_Flt_Sin  -> trivialUFCode FloatRep  (GSIN F) x
      MO_Dbl_Sin  -> trivialUFCode DoubleRep (GSIN DF) x

      MO_Flt_Cos  -> trivialUFCode FloatRep  (GCOS F) x
      MO_Dbl_Cos  -> trivialUFCode DoubleRep (GCOS DF) x

      MO_Flt_Tan  -> trivialUFCode FloatRep  (GTAN F) x
      MO_Dbl_Tan  -> trivialUFCode DoubleRep (GTAN DF) x

      MO_Flt_to_NatS -> coerceFP2Int FloatRep x
      MO_NatS_to_Flt -> coerceInt2FP FloatRep x
      MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
      MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x

      -- Conversions which are a nop on x86
      MO_NatS_to_32U  -> conversionNop WordRep   x
      MO_32U_to_NatS  -> conversionNop IntRep    x

      MO_NatU_to_NatS -> conversionNop IntRep    x
      MO_NatS_to_NatU -> conversionNop WordRep   x
      MO_NatP_to_NatU -> conversionNop WordRep   x
      MO_NatU_to_NatP -> conversionNop PtrRep    x
      MO_NatS_to_NatP -> conversionNop PtrRep    x
      MO_NatP_to_NatS -> conversionNop IntRep    x

      MO_Dbl_to_Flt   -> conversionNop FloatRep  x
      MO_Flt_to_Dbl   -> conversionNop DoubleRep x

      -- sign-extending widenings
      MO_8U_to_NatU   -> integerExtend False 24 x
      MO_8S_to_NatS   -> integerExtend True  24 x
      MO_16U_to_NatU  -> integerExtend False 16 x
      MO_16S_to_NatS  -> integerExtend True  16 x
      MO_8U_to_32U    -> integerExtend False 24 x

      other_op 
         -> getRegister (
               (if is_float_op then demote else id)
               (StCall (Left fn) CCallConv DoubleRep 
                       [(if is_float_op then promote else id) x])
            )
      where
        integerExtend signed nBits x
           = getRegister (
                StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) 
                         [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
             )

        conversionNop new_rep expr
            = getRegister expr		`thenNat` \ e_code ->
              returnNat (swizzleRegisterRep e_code new_rep)

        promote x = StMachOp MO_Flt_to_Dbl [x]
        demote  x = StMachOp MO_Dbl_to_Flt [x]
	(is_float_op, fn)
	  = case mop of
	      MO_Flt_Exp   -> (True,  SLIT("exp"))
	      MO_Flt_Log   -> (True,  SLIT("log"))

	      MO_Flt_Asin  -> (True,  SLIT("asin"))
	      MO_Flt_Acos  -> (True,  SLIT("acos"))
	      MO_Flt_Atan  -> (True,  SLIT("atan"))

	      MO_Flt_Sinh  -> (True,  SLIT("sinh"))
	      MO_Flt_Cosh  -> (True,  SLIT("cosh"))
	      MO_Flt_Tanh  -> (True,  SLIT("tanh"))

	      MO_Dbl_Exp   -> (False, SLIT("exp"))
	      MO_Dbl_Log   -> (False, SLIT("log"))

	      MO_Dbl_Asin  -> (False, SLIT("asin"))
	      MO_Dbl_Acos  -> (False, SLIT("acos"))
	      MO_Dbl_Atan  -> (False, SLIT("atan"))

	      MO_Dbl_Sinh  -> (False, SLIT("sinh"))
	      MO_Dbl_Cosh  -> (False, SLIT("cosh"))
	      MO_Dbl_Tanh  -> (False, SLIT("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 SLIT("pow")) CCallConv DoubleRep 
                                         [promote x, promote y])
                                 )
      MO_Dbl_Pwr -> getRegister (StCall (Left SLIT("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]

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

    --------------------
    shift_code :: (Imm -> Operand -> Instr)
	       -> StixExpr
	       -> StixExpr
	       -> NatM Register

      {- Case1: shift length as immediate -}
      -- Code is the same as the first eq. for trivialCode -- sigh.
    shift_code instr x y{-amount-}
      | maybeToBool imm
      = 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 (_PK_ "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 (_PK_ "end shift sequence")
                    ]
       in
       returnNat (Any IntRep code__2)

    --------------------
    add_code :: Size -> StixExpr -> StixExpr -> NatM Register

    add_code sz x (StInt y)
      = getRegister x		`thenNat` \ register ->
	getNewRegNCG IntRep	`thenNat` \ tmp ->
	let
	    code = registerCode register tmp
	    src1 = registerName register tmp
	    src2 = ImmInt (fromInteger y)
	    code__2 dst 
               = code `snocOL`
		 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
                        (OpReg dst)
	in
	returnNat (Any IntRep code__2)

    add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y

    --------------------
    sub_code :: Size -> StixExpr -> StixExpr -> NatM Register

    sub_code sz x (StInt y)
      = getRegister x		`thenNat` \ register ->
	getNewRegNCG IntRep	`thenNat` \ tmp ->
	let
	    code = registerCode register tmp
	    src1 = registerName register tmp
	    src2 = ImmInt (-(fromInteger y))
	    code__2 dst 
               = code `snocOL`
		 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
                        (OpReg dst)
	in
	returnNat (Any IntRep code__2)

    sub_code sz x y = trivialCode (SUB sz) Nothing x y

getRegister (StInd pk mem)
  | not (is64BitRep pk)
  = getAmode mem    	    	    `thenNat` \ amode ->
    let
    	code = amodeCode amode
    	src  = amodeAddr amode
    	size = primRepToSize pk
    	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)
    	code dst 
           | i == 0
           = unitOL (XOR L (OpReg dst) (OpReg dst))
           | otherwise
           = unitOL (MOV L (OpImm src) (OpReg dst))
    in
    	returnNat (Any IntRep code)

getRegister leaf
  | maybeToBool imm
  = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
    in
    	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 -}

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

#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)
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    getNewRegNCG PtrRep    	    `thenNat` \ tmp ->
    let code dst = toOL [
    	    SEGMENT DataSegment,
	    LABEL lbl,
	    DATA DF [ImmDouble d],
	    SEGMENT TextSegment,
	    SETHI (HI (ImmCLbl lbl)) tmp,
	    LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
    in
    	returnNat (Any DoubleRep code)


getRegister (StMachOp mop [x]) -- unary PrimOps
  = case mop of
      MO_NatS_Neg      -> trivialUCode (SUB False False g0) x
      MO_Nat_Not       -> trivialUCode (XNOR False g0) x

      MO_Flt_Neg       -> trivialUFCode FloatRep (FNEG F) x
      MO_Dbl_Neg       -> trivialUFCode DoubleRep (FNEG DF) x

      MO_Dbl_to_Flt    -> coerceDbl2Flt x
      MO_Flt_to_Dbl    -> coerceFlt2Dbl x

      MO_Flt_to_NatS   -> coerceFP2Int FloatRep x
      MO_NatS_to_Flt   -> coerceInt2FP FloatRep x
      MO_Dbl_to_NatS   -> coerceFP2Int DoubleRep x
      MO_NatS_to_Dbl   -> coerceInt2FP DoubleRep x

      -- Conversions which are a nop on sparc
      MO_32U_to_NatS   -> conversionNop IntRep   x
      MO_NatS_to_32U   -> conversionNop WordRep  x

      MO_NatU_to_NatS -> conversionNop IntRep    x
      MO_NatS_to_NatU -> conversionNop WordRep   x
      MO_NatP_to_NatU -> conversionNop WordRep   x
      MO_NatU_to_NatP -> conversionNop PtrRep    x
      MO_NatS_to_NatP -> conversionNop PtrRep    x
      MO_NatP_to_NatS -> conversionNop IntRep    x

      -- sign-extending widenings
      MO_8U_to_NatU   -> integerExtend False 24 x
      MO_8S_to_NatS   -> integerExtend True  24 x
      MO_16U_to_NatU  -> integerExtend False 16 x
      MO_16S_to_NatS  -> integerExtend True  16 x

      other_op ->
        let fixed_x = if   is_float_op  -- promote to double
                      then StMachOp MO_Flt_to_Dbl [x]
                      else x
	in
	getRegister (StCall 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)

	(is_float_op, fn)
	  = case mop of
	      MO_Flt_Exp    -> (True,  SLIT("exp"))
	      MO_Flt_Log    -> (True,  SLIT("log"))
	      MO_Flt_Sqrt   -> (True,  SLIT("sqrt"))

	      MO_Flt_Sin    -> (True,  SLIT("sin"))
	      MO_Flt_Cos    -> (True,  SLIT("cos"))
	      MO_Flt_Tan    -> (True,  SLIT("tan"))

	      MO_Flt_Asin   -> (True,  SLIT("asin"))
	      MO_Flt_Acos   -> (True,  SLIT("acos"))
	      MO_Flt_Atan   -> (True,  SLIT("atan"))

	      MO_Flt_Sinh   -> (True,  SLIT("sinh"))
	      MO_Flt_Cosh   -> (True,  SLIT("cosh"))
	      MO_Flt_Tanh   -> (True,  SLIT("tanh"))

	      MO_Dbl_Exp    -> (False, SLIT("exp"))
	      MO_Dbl_Log    -> (False, SLIT("log"))
	      MO_Dbl_Sqrt   -> (False, SLIT("sqrt"))

	      MO_Dbl_Sin    -> (False, SLIT("sin"))
	      MO_Dbl_Cos    -> (False, SLIT("cos"))
	      MO_Dbl_Tan    -> (False, SLIT("tan"))

	      MO_Dbl_Asin   -> (False, SLIT("asin"))
	      MO_Dbl_Acos   -> (False, SLIT("acos"))
	      MO_Dbl_Atan   -> (False, SLIT("atan"))

	      MO_Dbl_Sinh   -> (False, SLIT("sinh"))
	      MO_Dbl_Cosh   -> (False, SLIT("cosh"))
	      MO_Dbl_Tanh   -> (False, SLIT("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 SLIT(".div")  x y
      MO_NatS_Rem  -> idiv SLIT(".rem")  x y
      MO_NatU_Quot -> idiv SLIT(".udiv")  x y
      MO_NatU_Rem  -> idiv SLIT(".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 SLIT("pow") CCallConv DoubleRep 
                                           [promote x, promote y])
		       where promote x = StMachOp MO_Flt_to_Dbl [x]
      MO_Dbl_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep 
                                           [x, y])

      other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
  where
    idiv fn x y = getRegister (StCall 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)
  = getAmode mem    	    	    `thenNat` \ amode ->
    let
    	code = amodeCode amode
    	src   = amodeAddr amode
    	size = primRepToSize pk
    	code__2 dst = code `snocOL` LD size src dst
    in
    	returnNat (Any pk code__2)

getRegister (StInt i)
  | fits13Bits i
  = let
    	src = ImmInt (fromInteger i)
    	code dst = unitOL (OR False g0 (RIImm src) dst)
    in
    	returnNat (Any IntRep code)

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

#endif {- sparc_TARGET_ARCH -}

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

\end{code}

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

@Amode@s: Memory addressing modes passed up the tree.
\begin{code}
data Amode = Amode MachRegsAddr InstrBlock

amodeAddr (Amode addr _) = addr
amodeCode (Amode _ code) = code
\end{code}

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}
getAmode :: StixExpr -> NatM Amode

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

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

#if alpha_TARGET_ARCH

getAmode (StPrim IntSubOp [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
    returnNat (Amode (AddrRegImm reg off) code)

getAmode (StPrim IntAddOp [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
    returnNat (Amode (AddrRegImm reg off) code)

getAmode leaf
  | maybeToBool imm
  = returnNat (Amode (AddrImm imm__2) id)
  where
    imm = maybeImm leaf
    imm__2 = case imm of Just x -> x

getAmode other
  = getNewRegNCG PtrRep		`thenNat` \ tmp ->
    getRegister other		`thenNat` \ register ->
    let
    	code = registerCode register tmp
    	reg  = registerName register tmp
    in
    returnNat (Amode (AddrReg reg) code)

#endif {- alpha_TARGET_ARCH -}

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

#if i386_TARGET_ARCH

-- 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
    returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)

getAmode (StMachOp MO_Nat_Add [x, StInt i])
  | maybeToBool imm
  = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
  where
    imm    = maybeImm x
    imm__2 = case imm of Just x -> x

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
    returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)

getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
  | shift == 0 || shift == 1 || shift == 2 || shift == 3
  = getNewRegNCG PtrRep		`thenNat` \ tmp1 ->
    getNewRegNCG IntRep    	`thenNat` \ tmp2 ->
    getRegister x    	    	`thenNat` \ register1 ->
    getRegister y    	    	`thenNat` \ register2 ->
    let
    	code1 = registerCode register1 tmp1
    	reg1  = registerName register1 tmp1
    	code2 = registerCode register2 tmp2
    	reg2  = registerName register2 tmp2
    	code__2 = code1 `appOL` code2
        base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
    in
    returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
               code__2)

getAmode leaf
  | maybeToBool imm
  = returnNat (Amode (ImmAddr imm__2 0) nilOL)
  where
    imm    = maybeImm leaf
    imm__2 = case imm of Just x -> x

getAmode other
  = getNewRegNCG PtrRep		`thenNat` \ tmp ->
    getRegister other		`thenNat` \ register ->
    let
    	code = registerCode register tmp
    	reg  = registerName register tmp
    in
    returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)

#endif {- i386_TARGET_ARCH -}

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

#if sparc_TARGET_ARCH

getAmode (StMachOp MO_Nat_Sub [x, StInt i])
  | fits13Bits (-i)
  = getNewRegNCG PtrRep		`thenNat` \ tmp ->
    getRegister x		`thenNat` \ register ->
    let
    	code = registerCode register tmp
    	reg  = registerName register tmp
    	off  = ImmInt (-(fromInteger i))
    in
    returnNat (Amode (AddrRegImm reg off) code)


getAmode (StMachOp MO_Nat_Add [x, StInt i])
  | fits13Bits i
  = getNewRegNCG PtrRep		`thenNat` \ tmp ->
    getRegister x		`thenNat` \ register ->
    let
    	code = registerCode register tmp
    	reg  = registerName register tmp
    	off  = ImmInt (fromInteger i)
    in
    returnNat (Amode (AddrRegImm reg off) code)

getAmode (StMachOp MO_Nat_Add [x, y])
  = getNewRegNCG PtrRep    	`thenNat` \ tmp1 ->
    getNewRegNCG IntRep    	`thenNat` \ tmp2 ->
    getRegister x    	    	`thenNat` \ register1 ->
    getRegister y    	    	`thenNat` \ register2 ->
    let
    	code1 = registerCode register1 tmp1
    	reg1  = registerName register1 tmp1
    	code2 = registerCode register2 tmp2
    	reg2  = registerName register2 tmp2
    	code__2 = code1 `appOL` code2
    in
    returnNat (Amode (AddrRegReg reg1 reg2) code__2)

getAmode leaf
  | maybeToBool imm
  = getNewRegNCG PtrRep    	    `thenNat` \ tmp ->
    let
    	code = unitOL (SETHI (HI imm__2) tmp)
    in
    returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
  where
    imm    = maybeImm leaf
    imm__2 = case imm of Just x -> x

getAmode other
  = getNewRegNCG PtrRep		`thenNat` \ tmp ->
    getRegister other		`thenNat` \ register ->
    let
    	code = registerCode register tmp
    	reg  = registerName register tmp
    	off  = ImmInt 0
    in
    returnNat (Amode (AddrRegImm reg off) code)

#endif {- sparc_TARGET_ARCH -}

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

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

Condition codes passed up the tree.
\begin{code}
data CondCode = CondCode Bool Cond InstrBlock

condName  (CondCode _ cond _)	  = cond
condFloat (CondCode is_float _ _) = is_float
condCode  (CondCode _ _ code)	  = code
\end{code}

Set up a condition code for a conditional branch.

\begin{code}
getCondCode :: StixExpr -> NatM CondCode

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

#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!

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
 
      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 -}

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

% -----------------

@cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
passed back up the tree.

\begin{code}
condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode

#if alpha_TARGET_ARCH
condIntCode = panic "MachCode.condIntCode: not on Alphas"
condFltCode = panic "MachCode.condFltCode: not on Alphas"
#endif {- alpha_TARGET_ARCH -}

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

-- memory vs immediate
condIntCode cond (StInd pk x) y
  | Just i <- maybeImm y
  = getAmode x			`thenNat` \ amode ->
    let
    	code1 = amodeCode amode
    	x__2  = amodeAddr amode
        sz    = primRepToSize pk
    	code__2 = code1 `snocOL`
    	    	  CMP sz (OpImm i) (OpAddr x__2)
    in
    returnNat (CondCode False cond code__2)

-- anything vs zero
condIntCode cond x (StInt 0)
  = getRegister x		`thenNat` \ register1 ->
    getNewRegNCG IntRep		`thenNat` \ tmp1 ->
    let
	code1 = registerCode register1 tmp1
	src1  = registerName register1 tmp1
	code__2 = code1 `snocOL`
    	    	  TEST L (OpReg src1) (OpReg src1)
    in
    returnNat (CondCode False cond code__2)

-- anything vs immediate
condIntCode cond x y
  | Just i <- maybeImm y
  = getRegister x		`thenNat` \ register1 ->
    getNewRegNCG IntRep		`thenNat` \ tmp1 ->
    let
	code1 = registerCode register1 tmp1
	src1  = registerName register1 tmp1
	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
  = getRegister x		`thenNat` \ register1 ->
    getRegister y		`thenNat` \ register2 ->
    getNewRegNCG IntRep		`thenNat` \ tmp1 ->
    getNewRegNCG IntRep		`thenNat` \ tmp2 ->
    let
	code1 = registerCode register1 tmp1
	src1  = registerName register1 tmp1
	code2 = registerCode register2 tmp2
	src2  = registerName register2 tmp2
	code__2 = code1 `snocOL`
                  MOV L (OpReg src1) (OpReg tmp1) `appOL`
                  code2 `snocOL`
    	    	  CMP L (OpReg src2) (OpReg tmp1)
    in
    returnNat (CondCode False cond code__2)

-----------
condFltCode cond x y
  = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
    getRegister x		`thenNat` \ register1 ->
    getRegister y		`thenNat` \ register2 ->
    getNewRegNCG (registerRep register1)
      	    	        	`thenNat` \ tmp1 ->
    getNewRegNCG (registerRep register2)
     	    	        	`thenNat` \ tmp2 ->
    getNewRegNCG DoubleRep	`thenNat` \ tmp ->
    let
    	code1 = registerCode register1 tmp1
    	src1  = registerName register1 tmp1

    	code2 = registerCode register2 tmp2
    	src2  = registerName register2 tmp2

    	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 -}

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

#if sparc_TARGET_ARCH

condIntCode cond x (StInt y)
  | fits13Bits y
  = getRegister x		`thenNat` \ register ->
    getNewRegNCG IntRep		`thenNat` \ tmp ->
    let
	code = registerCode register tmp
	src1 = registerName register tmp
    	src2 = ImmInt (fromInteger y)
	code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
    in
    returnNat (CondCode False cond code__2)

condIntCode cond x y
  = getRegister x		`thenNat` \ register1 ->
    getRegister y		`thenNat` \ register2 ->
    getNewRegNCG IntRep		`thenNat` \ tmp1 ->
    getNewRegNCG IntRep		`thenNat` \ tmp2 ->
    let
	code1 = registerCode register1 tmp1
	src1  = registerName register1 tmp1
	code2 = registerCode register2 tmp2
	src2  = registerName register2 tmp2
	code__2 = code1 `appOL` code2 `snocOL`
    	    	  SUB False True src1 (RIReg src2) g0
    in
    returnNat (CondCode False cond code__2)

-----------
condFltCode cond x y
  = getRegister x		`thenNat` \ register1 ->
    getRegister y		`thenNat` \ register2 ->
    getNewRegNCG (registerRep register1)
      	    	        	`thenNat` \ tmp1 ->
    getNewRegNCG (registerRep register2)
     	    	        	`thenNat` \ tmp2 ->
    getNewRegNCG DoubleRep	`thenNat` \ tmp ->
    let
    	promote x = FxTOy F DF x tmp

    	pk1   = registerRep register1
    	code1 = registerCode register1 tmp1
    	src1  = registerName register1 tmp1

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

    	code__2 =
		if pk1 == pk2 then
    	            code1 `appOL` code2 `snocOL`
    	    	    FCMP True (primRepToSize pk1) src1 src2
    	    	else if pk1 == FloatRep then
    	    	    code1 `snocOL` promote src1 `appOL` code2 `snocOL`
    	    	    FCMP True DF tmp src2
    	    	else
    	    	    code1 `appOL` code2 `snocOL` promote src2 `snocOL`
    	    	    FCMP True DF src1 tmp
    in
    returnNat (CondCode True cond code__2)

#endif {- sparc_TARGET_ARCH -}

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

%************************************************************************
%*									*
\subsection{Generating assignments}
%*									*
%************************************************************************

Assignments are really at the heart of the whole code generation
business.  Almost all top-level nodes of any real importance are
assignments, which correspond to loads, stores, or register transfers.
If we're really lucky, some of the register transfers will go away,
because we can use the destination register to complete the code
generation for the right hand side.  This only fails when the right
hand side is forced into a fixed register (e.g. the result of a call).

\begin{code}
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
  = getNewRegNCG IntRep    	    `thenNat` \ tmp ->
    getAmode dst    	    	    `thenNat` \ amode ->
    getRegister src	     	    `thenNat` \ register ->
    let
    	code1   = amodeCode amode []
    	dst__2  = amodeAddr amode
    	code2   = registerCode register tmp []
    	src__2  = registerName register tmp
    	sz      = primRepToSize pk
    	code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
    in
    returnNat code__2

assignIntCode pk dst src
  = getRegister dst	    	    	    `thenNat` \ register1 ->
    getRegister src	    	    	    `thenNat` \ register2 ->
    let
    	dst__2  = registerName register1 zeroh
    	code    = registerCode register2 dst__2
    	src__2  = registerName register2 dst__2
    	code__2 = if isFixed register2
		  then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
    	    	  else code
    in
    returnNat code__2

#endif {- alpha_TARGET_ARCH -}

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

#if i386_TARGET_ARCH

-- 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
	:: StixExpr
	-> NatM (InstrBlock,Operand)	-- code, operator

    get_op_RI op
      | Just x <- maybeImm op
      = returnNat (nilOL, OpImm x)

    get_op_RI op
      = getRegister op			`thenNat` \ register ->
	getNewRegNCG (registerRep register)
					`thenNat` \ tmp ->
	let code = registerCode register tmp
	    reg  = registerName register tmp
	in
	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
    returnNat code

#endif {- i386_TARGET_ARCH -}

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

#if sparc_TARGET_ARCH

assignMem_IntCode pk addr src
  = getNewRegNCG IntRep 	   	    `thenNat` \ tmp ->
    getAmode addr	    	    	    `thenNat` \ amode ->
    getRegister src	    	    	    `thenNat` \ register ->
    let
    	code1   = amodeCode amode
    	dst__2  = amodeAddr amode
    	code2   = registerCode register tmp
    	src__2  = registerName register tmp
    	sz      = primRepToSize pk
    	code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
    in
    returnNat code__2

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
		  then code `snocOL` OR False g0 (RIReg src__2) dst__2
    	    	  else code
    in
    returnNat code__2

#endif {- sparc_TARGET_ARCH -}

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

% --------------------------------
Floating-point assignments:
% --------------------------------

\begin{code}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if alpha_TARGET_ARCH

assignFltCode pk (StInd _ dst) src
  = getNewRegNCG pk        	    `thenNat` \ tmp ->
    getAmode dst    	    	    `thenNat` \ amode ->
    getRegister src	    	    	    `thenNat` \ register ->
    let
    	code1   = amodeCode amode []
    	dst__2  = amodeAddr amode
    	code2   = registerCode register tmp []
    	src__2  = registerName register tmp
    	sz      = primRepToSize pk
    	code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
    in
    returnNat code__2

assignFltCode pk dst src
  = getRegister dst	    	    	    `thenNat` \ register1 ->
    getRegister src	    	    	    `thenNat` \ register2 ->
    let
    	dst__2  = registerName register1 zeroh
    	code    = registerCode register2 dst__2
    	src__2  = registerName register2 dst__2
    	code__2 = if isFixed register2
		  then code . mkSeqInstr (FMOV src__2 dst__2)
		  else code
    in
    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 -}

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

#if sparc_TARGET_ARCH

-- Floating point assignment to memory
assignMem_FltCode pk addr src
  = getNewRegNCG pk        	    `thenNat` \ tmp1 ->
    getAmode addr    	    	    `thenNat` \ amode ->
    getRegister src	      	    `thenNat` \ register ->
    let
    	sz      = primRepToSize pk
    	dst__2  = amodeAddr amode

    	code1   = amodeCode amode
    	code2   = registerCode register tmp1

    	src__2  = registerName register tmp1
    	pk__2   = registerRep register
    	sz__2   = primRepToSize pk__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
    returnNat code__2

-- 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
    	reg__2 	= if pk /= pk__2 then tmp else dst__2
    	code   	= registerCode register2 reg__2
    	src__2 	= registerName register2 reg__2
	code__2 = 
	        if pk /= pk__2 then
		     code `snocOL` FxTOy sz__2 sz src__2 dst__2
    	    	else if isFixed register2 then
		     code `snocOL` FMOV sz src__2 dst__2
    	    	else
		     code
    in
    returnNat code__2

#endif {- sparc_TARGET_ARCH -}

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

%************************************************************************
%*									*
\subsection{Generating an unconditional branch}
%*									*
%************************************************************************

We accept two types of targets: an immediate CLabel or a tree that
gets evaluated into a register.  Any CLabels which are AsmTemporaries
are assumed to be in the local block of code, close enough for a
branch instruction.  Other CLabels are assumed to be far away.

(If applicable) Do not fill the delay slots here; you will confuse the
register allocator.

\begin{code}
genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock

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

#if alpha_TARGET_ARCH

genJump (StCLbl lbl)
  | isAsmTemp lbl = returnInstr (BR target)
  | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
  where
    target = ImmCLbl lbl

genJump tree
  = getRegister tree	     	    `thenNat` \ register ->
    getNewRegNCG PtrRep    	    `thenNat` \ tmp ->
    let
    	dst    = registerName register pv
    	code   = registerCode register pv
    	target = registerName register pv
    in
    if isFixed register then
	returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
    else
    returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))

#endif {- alpha_TARGET_ARCH -}

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

#if i386_TARGET_ARCH

genJump dsts (StInd pk mem)
  = getAmode mem    	    	    `thenNat` \ amode ->
    let
    	code   = amodeCode amode
    	target = amodeAddr amode
    in
    returnNat (code `snocOL` JMP dsts (OpAddr target))

genJump dsts tree
  | maybeToBool imm
  = returnNat (unitOL (JMP dsts (OpImm target)))

  | otherwise
  = getRegister tree	    	    `thenNat` \ register ->
    getNewRegNCG PtrRep    	    `thenNat` \ tmp ->
    let
    	code   = registerCode register tmp
    	target = registerName register tmp
    in
    returnNat (code `snocOL` JMP dsts (OpReg target))
  where
    imm    = maybeImm tree
    target = case imm of Just x -> x

#endif {- i386_TARGET_ARCH -}

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

#if sparc_TARGET_ARCH

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 target 0 True, NOP])
  where
    target = ImmCLbl lbl

genJump dsts tree
  = getRegister tree	    	    	    `thenNat` \ register ->
    getNewRegNCG PtrRep    	    `thenNat` \ tmp ->
    let
    	code   = registerCode register tmp
    	target = registerName register tmp
    in
    returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)

#endif {- sparc_TARGET_ARCH -}

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

%************************************************************************
%*									*
\subsection{Conditional jumps}
%*									*
%************************************************************************

Conditional jumps are always to local labels, so we can use branch
instructions.  We peek at the arguments to decide what kind of
comparison to do.

ALPHA: For comparisons with 0, we're laughing, because we can just do
the desired conditional branch.

I386: First, we have to ensure that the condition
codes are set according to the supplied comparison operation.

SPARC: First, we have to ensure that the condition codes are set
according to the supplied comparison operation.  We generate slightly
different code for floating point comparisons, because a floating
point operation cannot directly precede a @BF@.  We assume the worst
and fill that slot with a @NOP@.

SPARC: Do not fill the delay slots here; you will confuse the register
allocator.

\begin{code}
genCondJump
    :: CLabel	    -- the branch target
    -> StixExpr     -- the condition on which to branch
    -> NatM InstrBlock

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

#if alpha_TARGET_ARCH

genCondJump lbl (StPrim op [x, StInt 0])
  = getRegister x	  	    	    `thenNat` \ register ->
    getNewRegNCG (registerRep register)
    	    	        	    `thenNat` \ tmp ->
    let
    	code   = registerCode register tmp
    	value  = registerName register tmp
    	pk     = registerRep register
	target = ImmCLbl lbl
    in
    returnSeq code [BI (cmpOp op) value target]
  where
    cmpOp CharGtOp = GTT
    cmpOp CharGeOp = GE
    cmpOp CharEqOp = EQQ
    cmpOp CharNeOp = NE
    cmpOp CharLtOp = LTT
    cmpOp CharLeOp = LE
    cmpOp IntGtOp = GTT
    cmpOp IntGeOp = GE
    cmpOp IntEqOp = EQQ
    cmpOp IntNeOp = NE
    cmpOp IntLtOp = LTT
    cmpOp IntLeOp = LE
    cmpOp WordGtOp = NE
    cmpOp WordGeOp = ALWAYS
    cmpOp WordEqOp = EQQ
    cmpOp WordNeOp = NE
    cmpOp WordLtOp = NEVER
    cmpOp WordLeOp = EQQ
    cmpOp AddrGtOp = NE
    cmpOp AddrGeOp = ALWAYS
    cmpOp AddrEqOp = EQQ
    cmpOp AddrNeOp = NE
    cmpOp AddrLtOp = NEVER
    cmpOp AddrLeOp = EQQ

genCondJump lbl (StPrim op [x, StDouble 0.0])
  = getRegister x	  	    	    `thenNat` \ register ->
    getNewRegNCG (registerRep register)
    	    	        	    `thenNat` \ tmp ->
    let
    	code   = registerCode register tmp
    	value  = registerName register tmp
    	pk     = registerRep register
	target = ImmCLbl lbl
    in
    returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
  where
    cmpOp FloatGtOp = GTT
    cmpOp FloatGeOp = GE
    cmpOp FloatEqOp = EQQ
    cmpOp FloatNeOp = NE
    cmpOp FloatLtOp = LTT
    cmpOp FloatLeOp = LE
    cmpOp DoubleGtOp = GTT
    cmpOp DoubleGeOp = GE
    cmpOp DoubleEqOp = EQQ
    cmpOp DoubleNeOp = NE
    cmpOp DoubleLtOp = LTT
    cmpOp DoubleLeOp = LE

genCondJump lbl (StPrim op [x, y])
  | fltCmpOp op
  = trivialFCode pr instr x y 	    `thenNat` \ register ->
    getNewRegNCG DoubleRep    	    `thenNat` \ tmp ->
    let
    	code   = registerCode register tmp
    	result = registerName register tmp
	target = ImmCLbl lbl
    in
    returnNat (code . mkSeqInstr (BF cond result target))
  where
    pr = panic "trivialU?FCode: does not use PrimRep on Alpha"

    fltCmpOp op = case op of
	FloatGtOp -> True
	FloatGeOp -> True
	FloatEqOp -> True
	FloatNeOp -> True
	FloatLtOp -> True
	FloatLeOp -> True
	DoubleGtOp -> True
	DoubleGeOp -> True
	DoubleEqOp -> True
	DoubleNeOp -> True
	DoubleLtOp -> True
	DoubleLeOp -> True
	_ -> False
    (instr, cond) = case op of
	FloatGtOp -> (FCMP TF LE, EQQ)
	FloatGeOp -> (FCMP TF LTT, EQQ)
	FloatEqOp -> (FCMP TF EQQ, NE)
	FloatNeOp -> (FCMP TF EQQ, EQQ)
	FloatLtOp -> (FCMP TF LTT, NE)
	FloatLeOp -> (FCMP TF LE, NE)
	DoubleGtOp -> (FCMP TF LE, EQQ)
	DoubleGeOp -> (FCMP TF LTT, EQQ)
	DoubleEqOp -> (FCMP TF EQQ, NE)
	DoubleNeOp -> (FCMP TF EQQ, EQQ)
	DoubleLtOp -> (FCMP TF LTT, NE)
	DoubleLeOp -> (FCMP TF LE, NE)

genCondJump lbl (StPrim op [x, y])
  = trivialCode instr x y    	    `thenNat` \ register ->
    getNewRegNCG IntRep    	    `thenNat` \ tmp ->
    let
    	code   = registerCode register tmp
    	result = registerName register tmp
	target = ImmCLbl lbl
    in
    returnNat (code . mkSeqInstr (BI cond result target))
  where
    (instr, cond) = case op of
	CharGtOp -> (CMP LE, EQQ)
	CharGeOp -> (CMP LTT, EQQ)
	CharEqOp -> (CMP EQQ, NE)
	CharNeOp -> (CMP EQQ, EQQ)
	CharLtOp -> (CMP LTT, NE)
	CharLeOp -> (CMP LE, NE)
	IntGtOp -> (CMP LE, EQQ)
	IntGeOp -> (CMP LTT, EQQ)
	IntEqOp -> (CMP EQQ, NE)
	IntNeOp -> (CMP EQQ, EQQ)
	IntLtOp -> (CMP LTT, NE)
	IntLeOp -> (CMP LE, NE)
	WordGtOp -> (CMP ULE, EQQ)
	WordGeOp -> (CMP ULT, EQQ)
	WordEqOp -> (CMP EQQ, NE)
	WordNeOp -> (CMP EQQ, EQQ)
	WordLtOp -> (CMP ULT, NE)
	WordLeOp -> (CMP ULE, NE)
	AddrGtOp -> (CMP ULE, EQQ)
	AddrGeOp -> (CMP ULT, EQQ)
	AddrEqOp -> (CMP EQQ, NE)
	AddrNeOp -> (CMP EQQ, EQQ)
	AddrLtOp -> (CMP ULT, NE)
	AddrLeOp -> (CMP ULE, NE)

#endif {- alpha_TARGET_ARCH -}

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

#if i386_TARGET_ARCH

genCondJump lbl bool
  = getCondCode bool  	    	    `thenNat` \ condition ->
    let
    	code   = condCode condition
    	cond   = condName condition
    in
    returnNat (code `snocOL` JXX cond lbl)

#endif {- i386_TARGET_ARCH -}

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

#if sparc_TARGET_ARCH

genCondJump lbl bool
  = getCondCode bool  	    	    `thenNat` \ condition ->
    let
    	code   = condCode condition
    	cond   = condName condition
	target = ImmCLbl lbl
    in
    returnNat (
       code `appOL` 
       toOL (
         if   condFloat condition 
         then [NOP, BF cond False target, NOP]
         else [BI cond False target, NOP]
       )
    )

#endif {- sparc_TARGET_ARCH -}

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

%************************************************************************
%*									*
\subsection{Generating C calls}
%*									*
%************************************************************************

Now the biggest nightmare---calls.  Most of the nastiness is buried in
@get_arg@, which moves the arguments to the correct registers/stack
locations.  Apart from that, the code is easy.

(If applicable) Do not fill the delay slots here; you will confuse the
register allocator.

\begin{code}
genCCall
    :: (Either FAST_STRING StixExpr)	-- function to call
    -> CCallConv
    -> PrimRep		-- type of the result
    -> [StixExpr]	-- arguments (of mixed type)
    -> NatM InstrBlock

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

#if alpha_TARGET_ARCH

genCCall fn cconv kind args
  = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
    	    	  	  `thenNat` \ ((unused,_), argCode) ->
    let
    	nRegs = length allArgRegs - length unused
    	code = asmSeqThen (map ($ []) argCode)
    in
    	returnSeq code [
    	    LDA pv (AddrImm (ImmLab (ptext fn))),
    	    JSR ra (AddrReg pv) nRegs,
    	    LDGP gp (AddrReg ra)]
  where
    ------------------------
    {-	Try to get a value into a specific register (or registers) for
	a call.  The first 6 arguments go into the appropriate
	argument register (separate registers for integer and floating
	point arguments, but used in lock-step), and the remaining
	arguments are dumped to the stack, beginning at 0(sp).  Our
	first argument is a pair of the list of remaining argument
	registers to be assigned for this call and the next stack
	offset to use for overflowing arguments.  This way,
	@get_Arg@ can be applied to all of a call's arguments using
	@mapAccumLNat@.
    -}
    get_arg
	:: ([(Reg,Reg)], Int)	-- Argument registers and stack offset (accumulator)
	-> StixTree		-- Current argument
	-> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code

    -- We have to use up all of our argument registers first...

    get_arg ((iDst,fDst):dsts, offset) arg
      = getRegister arg	    	    	    `thenNat` \ register ->
	let
	    reg  = if isFloatingRep pk then fDst else iDst
	    code = registerCode register reg
	    src  = registerName register reg
	    pk   = registerRep register
	in
	returnNat (
	    if isFloatingRep pk then
		((dsts, offset), if isFixed register then
		    code . mkSeqInstr (FMOV src fDst)
		    else code)
	    else
		((dsts, offset), if isFixed register then
		    code . mkSeqInstr (OR src (RIReg src) iDst)
		    else code))

    -- Once we have run out of argument registers, we move to the
    -- stack...

    get_arg ([], offset) arg
      = getRegister arg			`thenNat` \ register ->
	getNewRegNCG (registerRep register)
					`thenNat` \ tmp ->
	let
	    code = registerCode register tmp
	    src  = registerName register tmp
	    pk   = registerRep register
	    sz   = primRepToSize pk
	in
	returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))

#endif {- alpha_TARGET_ARCH -}

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

#if i386_TARGET_ARCH

genCCall fn cconv ret_rep [StInt i]
  | isLeft fn && unLeft fn == SLIT ("PerformGC_wrapper")
  = let call = toOL [
                  MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
	          CALL (Left (ImmLit (ptext (if   underscorePrefix 
                                       then (SLIT ("_PerformGC_wrapper"))
                                       else (SLIT ("PerformGC_wrapper"))))))
               ]
    in
    returnNat 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(dyn_rep == L)
              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)

  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_u  = _UNPK_ (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))

    stdcallsize tot_arg_size
       | cconv == StdCallConv = '@':show tot_arg_size
       | otherwise            = ""

    arg_size DF = 8
    arg_size F  = 4
    arg_size _  = 4

    ------------
    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
	:: StixExpr
	-> NatM (InstrBlock, Reg, Size) -- code, reg, size

    get_op op
      = getRegister op		`thenNat` \ register ->
	getNewRegNCG (registerRep register)
				`thenNat` \ tmp ->
	let
	    code = registerCode register tmp
	    reg  = registerName register tmp
	    pk   = registerRep  register
	    sz   = primRepToSize pk
	in
	returnNat (code, reg, sz)

#endif {- i386_TARGET_ARCH -}

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

#if sparc_TARGET_ARCH
{- 
   The SPARC calling convention is an absolute
   nightmare.  The first 6x32 bits of arguments are mapped into
   %o0 through %o5, and the remaining arguments are dumped to the
   stack, beginning at [%sp+92].  (Note that %o6 == %sp.)

   If we have to put args on the stack, move %o6==%sp down by
   the number of words to go on the stack, to ensure there's enough space.

   According to Fraser and Hanson's lcc book, page 478, fig 17.2,
   16 words above the stack pointer is a word for the address of
   a structure return value.  I use this as a temporary location
   for moving values from float to int regs.  Certainly it isn't
   safe to put anything in the 16 words starting at %sp, since
   this area can get trashed at any time due to window overflows
   caused by signal handlers.

   A final complication (if the above isn't enough) is that 
   we can't blithely calculate the arguments one by one into
   %o0 .. %o5.  Consider the following nested calls:

       fff a (fff b c)

   Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately
   the inner call will itself use %o0, which trashes the value put there
   in preparation for the outer call.  Upshot: we need to calculate the
   args into temporary regs, and move those to arg regs or onto the
   stack only immediately prior to the call proper.  Sigh.
-}

genCCall fn cconv kind args
  = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
    let (argcodes, vregss) = unzip argcode_and_vregs
        argcode            = concatOL argcodes
        vregs              = concat vregss
        n_argRegs          = length allArgRegs
        n_argRegs_used     = min (length vregs) n_argRegs
        (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)
        call
           = unitOL (CALL fn__2 n_argRegs_used False)
    in
        returnNat (argcode       `appOL`
                   move_sp_down  `appOL`
                   transfer_code `appOL`
                   call          `appOL`
                   unitOL NOP    `appOL`
                   move_sp_up)
  where
     -- function names that begin with '.' are assumed to be special
     -- internally generated names like '.mul,' which don't get an
     -- underscore prefix
     -- ToDo:needed (WDP 96/03) ???
     fn__2 = case (_HEAD_ fn) of
	        '.' -> ImmLit (ptext fn)
	        _   -> ImmLab False (ptext fn)

     -- 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 -}

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

%************************************************************************
%*									*
\subsection{Support bits}
%*									*
%************************************************************************

%************************************************************************
%*									*
\subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
%*									*
%************************************************************************

Turn those condition codes into integers now (when they appear on
the right hand side of an assignment).

(If applicable) Do not fill the delay slots here; you will confuse the
register allocator.

\begin{code}
condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register

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

#if alpha_TARGET_ARCH
condIntReg = panic "MachCode.condIntReg (not on Alpha)"
condFltReg = panic "MachCode.condFltReg (not on Alpha)"
#endif {- alpha_TARGET_ARCH -}

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

#if i386_TARGET_ARCH

condIntReg cond x y
  = condIntCode cond x y	`thenNat` \ condition ->
    getNewRegNCG IntRep		`thenNat` \ tmp ->
    let
	code = condCode condition
	cond = condName condition
	code__2 dst = code `appOL` toOL [
	    SETCC cond (OpReg tmp),
	    AND L (OpImm (ImmInt 1)) (OpReg tmp),
	    MOV L (OpReg tmp) (OpReg dst)]
    in
    returnNat (Any IntRep code__2)

condFltReg cond x y
  = getNatLabelNCG		`thenNat` \ lbl1 ->
    getNatLabelNCG	    	`thenNat` \ lbl2 ->
    condFltCode cond x y 	`thenNat` \ condition ->
    let
    	code = condCode condition
    	cond = condName condition
    	code__2 dst = code `appOL` toOL [
	    JXX cond lbl1,
	    MOV L (OpImm (ImmInt 0)) (OpReg dst),
	    JXX ALWAYS lbl2,
	    LABEL lbl1,
	    MOV L (OpImm (ImmInt 1)) (OpReg dst),
	    LABEL lbl2]
    in
    returnNat (Any IntRep code__2)

#endif {- i386_TARGET_ARCH -}

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

#if sparc_TARGET_ARCH

condIntReg EQQ x (StInt 0)
  = getRegister x		`thenNat` \ register ->
    getNewRegNCG IntRep		`thenNat` \ tmp ->
    let
	code = registerCode register tmp
	src  = registerName register tmp
	code__2 dst = code `appOL` toOL [
    	    SUB False True g0 (RIReg src) g0,
    	    SUB True False g0 (RIImm (ImmInt (-1))) dst]
    in
    returnNat (Any IntRep code__2)

condIntReg EQQ x y
  = getRegister x		`thenNat` \ register1 ->
    getRegister y		`thenNat` \ register2 ->
    getNewRegNCG IntRep		`thenNat` \ tmp1 ->
    getNewRegNCG IntRep		`thenNat` \ tmp2 ->
    let
    	code1 = registerCode register1 tmp1
    	src1  = registerName register1 tmp1
    	code2 = registerCode register2 tmp2
    	src2  = registerName register2 tmp2
    	code__2 dst = code1 `appOL` code2 `appOL` toOL [
    	    XOR False src1 (RIReg src2) dst,
    	    SUB False True g0 (RIReg dst) g0,
    	    SUB True False g0 (RIImm (ImmInt (-1))) dst]
    in
    returnNat (Any IntRep code__2)

condIntReg NE x (StInt 0)
  = getRegister x    	    	`thenNat` \ register ->
    getNewRegNCG IntRep   	`thenNat` \ tmp ->
    let
    	code = registerCode register tmp
    	src  = registerName register tmp
    	code__2 dst = code `appOL` toOL [
    	    SUB False True g0 (RIReg src) g0,
    	    ADD True False g0 (RIImm (ImmInt 0)) dst]
    in
    returnNat (Any IntRep code__2)

condIntReg NE x y
  = getRegister x	    	`thenNat` \ register1 ->
    getRegister y	    	`thenNat` \ register2 ->
    getNewRegNCG IntRep        	`thenNat` \ tmp1 ->
    getNewRegNCG IntRep        	`thenNat` \ tmp2 ->
    let
	code1 = registerCode register1 tmp1
	src1  = registerName register1 tmp1
	code2 = registerCode register2 tmp2
	src2  = registerName register2 tmp2
	code__2 dst = code1 `appOL` code2 `appOL` toOL [
    	    XOR False src1 (RIReg src2) dst,
    	    SUB False True g0 (RIReg dst) g0,
    	    ADD True False g0 (RIImm (ImmInt 0)) dst]
    in
    returnNat (Any IntRep code__2)

condIntReg cond x y
  = getNatLabelNCG		`thenNat` \ lbl1 ->
    getNatLabelNCG	    	`thenNat` \ lbl2 ->
    condIntCode cond x y 	`thenNat` \ condition ->
    let
	code = condCode condition
	cond = condName condition
	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,
	    LABEL lbl1,
	    OR False g0 (RIImm (ImmInt 1)) dst,
	    LABEL lbl2]
    in
    returnNat (Any IntRep code__2)

condFltReg cond x y
  = getNatLabelNCG		`thenNat` \ lbl1 ->
    getNatLabelNCG	    	`thenNat` \ lbl2 ->
    condFltCode cond x y 	`thenNat` \ condition ->
    let
    	code = condCode condition
    	cond = condName condition
    	code__2 dst = code `appOL` toOL [
    	    NOP,
	    BF cond False (ImmCLbl lbl1), NOP,
	    OR False g0 (RIImm (ImmInt 0)) dst,
	    BI ALWAYS False (ImmCLbl lbl2), NOP,
	    LABEL lbl1,
	    OR False g0 (RIImm (ImmInt 1)) dst,
	    LABEL lbl2]
    in
    returnNat (Any IntRep code__2)

#endif {- sparc_TARGET_ARCH -}

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

%************************************************************************
%*									*
\subsubsection{@trivial*Code@: deal with trivial instructions}
%*									*
%************************************************************************

Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
@trivialUCode@, unary fl-pt:@trivialUFCode@) instructions.  Only look
for constants on the right hand side, because that's where the generic
optimizer will have put them.

Similarly, for unary instructions, we don't have to worry about
matching an StInt as the argument, because genericOpt will already
have handled the constant-folding.

\begin{code}
trivialCode
    :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
      ,IF_ARCH_i386 ((Operand -> Operand -> Instr) 
                     -> Maybe (Operand -> Operand -> Instr)
      ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
      ,)))
    -> StixExpr -> StixExpr -- the two arguments
    -> NatM Register

trivialFCode
    :: PrimRep
    -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
      ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
      ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
      ,)))
    -> StixExpr -> StixExpr -- the two arguments
    -> NatM Register

trivialUCode
    :: IF_ARCH_alpha((RI -> Reg -> Instr)
      ,IF_ARCH_i386 ((Operand -> Instr)
      ,IF_ARCH_sparc((RI -> Reg -> Instr)
      ,)))
    -> StixExpr	-- the one argument
    -> NatM Register

trivialUFCode
    :: PrimRep
    -> IF_ARCH_alpha((Reg -> Reg -> Instr)
      ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
      ,IF_ARCH_sparc((Reg -> Reg -> Instr)
      ,)))
    -> StixExpr -- the one argument
    -> NatM Register

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

#if alpha_TARGET_ARCH

trivialCode instr x (StInt y)
  | fits8Bits y
  = getRegister x		`thenNat` \ register ->
    getNewRegNCG IntRep		`thenNat` \ tmp ->
    let
    	code = registerCode register tmp
    	src1 = registerName register tmp
    	src2 = ImmInt (fromInteger y)
    	code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
    in
    returnNat (Any IntRep code__2)

trivialCode instr x y
  = getRegister x		`thenNat` \ register1 ->
    getRegister y		`thenNat` \ register2 ->
    getNewRegNCG IntRep		`thenNat` \ tmp1 ->
    getNewRegNCG IntRep		`thenNat` \ tmp2 ->
    let
    	code1 = registerCode register1 tmp1 []
    	src1  = registerName register1 tmp1
    	code2 = registerCode register2 tmp2 []
    	src2  = registerName register2 tmp2
    	code__2 dst = asmSeqThen [code1, code2] .
    	    	     mkSeqInstr (instr src1 (RIReg src2) dst)
    in
    returnNat (Any IntRep code__2)

------------
trivialUCode instr x
  = getRegister x		`thenNat` \ register ->
    getNewRegNCG IntRep		`thenNat` \ tmp ->
    let
    	code = registerCode register tmp
    	src  = registerName register tmp
    	code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
    in
    returnNat (Any IntRep code__2)

------------
trivialFCode _ instr x y
  = 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

    	code2 = registerCode register2 tmp2
    	src2  = registerName register2 tmp2

    	code__2 dst = asmSeqThen [code1 [], code2 []] .
    	    	      mkSeqInstr (instr src1 src2 dst)
    in
    returnNat (Any DoubleRep code__2)

trivialUFCode _ instr x
  = 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
    returnNat (Any DoubleRep code__2)

#endif {- alpha_TARGET_ARCH -}

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

#if i386_TARGET_ARCH
\end{code}
The Rules of the Game are:

* You cannot assume anything about the destination register dst;
  it may be anything, including a fixed reg.

* You may compute an operand into a fixed reg, but you may not 
  subsequently change the contents of that fixed reg.  If you
  want to do so, first copy the value either to a temporary
  or into dst.  You are free to modify dst even if it happens
  to be a fixed reg -- that's not your problem.

* You cannot assume that a fixed reg will stay live over an
  arbitrary computation.  The same applies to the dst reg.

* Temporary regs obtained from 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


-----------
trivialUCode instr x
  = getRegister x		`thenNat` \ register ->
    let
    	code__2 dst = let code = registerCode register dst
		      	  src  = registerName register dst
		      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
    returnNat (Any IntRep code__2)

-----------
trivialFCode pk instr x y
  = 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

    	code2 = registerCode register2 tmp2
    	src2  = registerName register2 tmp2

    	code__2 dst
           -- treat the common case specially: both operands in
           -- non-fixed regs.
           | isAny register1 && isAny register2
           = code1 `appOL` 
             code2 `snocOL`
    	     instr (primRepToSize pk) src1 src2 dst

           -- be paranoid (and inefficient)
           | otherwise
           = code1 `snocOL` GMOV src1 tmp1  `appOL`
             code2 `snocOL`
             instr (primRepToSize pk) tmp1 src2 dst
    in
    returnNat (Any pk code__2)


-------------
trivialUFCode pk instr x
  = getRegister x		`thenNat` \ register ->
    getNewRegNCG pk		`thenNat` \ tmp ->
    let
    	code = registerCode register tmp
    	src  = registerName register tmp
    	code__2 dst = code `snocOL` instr src dst
    in
    returnNat (Any pk code__2)

#endif {- i386_TARGET_ARCH -}

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

#if sparc_TARGET_ARCH

trivialCode instr x (StInt y)
  | fits13Bits y
  = getRegister x		`thenNat` \ register ->
    getNewRegNCG IntRep		`thenNat` \ tmp ->
    let
    	code = registerCode register tmp
    	src1 = registerName register tmp
    	src2 = ImmInt (fromInteger y)
    	code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
    in
    returnNat (Any IntRep code__2)

trivialCode instr x y
  = getRegister x		`thenNat` \ register1 ->
    getRegister y		`thenNat` \ register2 ->
    getNewRegNCG IntRep		`thenNat` \ tmp1 ->
    getNewRegNCG IntRep		`thenNat` \ tmp2 ->
    let
    	code1 = registerCode register1 tmp1
    	src1  = registerName register1 tmp1
    	code2 = registerCode register2 tmp2
    	src2  = registerName register2 tmp2
    	code__2 dst = code1 `appOL` code2 `snocOL`
    	    	      instr src1 (RIReg src2) dst
    in
    returnNat (Any IntRep code__2)

------------
trivialFCode pk instr x y
  = getRegister x		`thenNat` \ register1 ->
    getRegister y		`thenNat` \ register2 ->
    getNewRegNCG (registerRep register1)
      	    	        	`thenNat` \ tmp1 ->
    getNewRegNCG (registerRep register2)
     	    	        	`thenNat` \ tmp2 ->
    getNewRegNCG DoubleRep   	`thenNat` \ tmp ->
    let
    	promote x = FxTOy F DF x tmp

    	pk1   = registerRep register1
    	code1 = registerCode register1 tmp1
    	src1  = registerName register1 tmp1

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

    	code__2 dst =
    	    	if pk1 == pk2 then
    	            code1 `appOL` code2 `snocOL`
    	    	    instr (primRepToSize pk) src1 src2 dst
    	    	else if pk1 == FloatRep then
    	    	    code1 `snocOL` promote src1 `appOL` code2 `snocOL`
    	    	    instr DF tmp src2 dst
    	    	else
    	    	    code1 `appOL` code2 `snocOL` promote src2 `snocOL`
    	    	    instr DF src1 tmp dst
    in
    returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)

------------
trivialUCode instr x
  = getRegister x		`thenNat` \ register ->
    getNewRegNCG IntRep		`thenNat` \ tmp ->
    let
    	code = registerCode register tmp
    	src  = registerName register tmp
    	code__2 dst = code `snocOL` instr (RIReg src) dst
    in
    returnNat (Any IntRep code__2)

-------------
trivialUFCode pk instr x
  = getRegister x		`thenNat` \ register ->
    getNewRegNCG pk		`thenNat` \ tmp ->
    let
    	code = registerCode register tmp
    	src  = registerName register tmp
    	code__2 dst = code `snocOL` instr src dst
    in
    returnNat (Any pk code__2)

#endif {- sparc_TARGET_ARCH -}

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

%************************************************************************
%*									*
\subsubsection{Coercing to/from integer/floating-point...}
%*									*
%************************************************************************

@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}
coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
coerceFP2Int :: PrimRep -> StixExpr -> NatM Register

coerceDbl2Flt :: StixExpr -> NatM Register
coerceFlt2Dbl :: StixExpr -> NatM Register
\end{code}

\begin{code}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

#if alpha_TARGET_ARCH

coerceInt2FP _ x
  = getRegister x		`thenNat` \ register ->
    getNewRegNCG IntRep		`thenNat` \ reg ->
    let
    	code = registerCode register reg
    	src  = registerName register reg

    	code__2 dst = code . mkSeqInstrs [
    	    ST Q src (spRel 0),
    	    LD TF dst (spRel 0),
    	    CVTxy Q TF dst dst]
    in
    returnNat (Any DoubleRep code__2)

-------------
coerceFP2Int x
  = getRegister x		`thenNat` \ register ->
    getNewRegNCG DoubleRep	`thenNat` \ tmp ->
    let
    	code = registerCode register tmp
    	src  = registerName register tmp

    	code__2 dst = code . mkSeqInstrs [
    	    CVTxy TF Q src tmp,
    	    ST TF tmp (spRel 0),
    	    LD Q dst (spRel 0)]
    in
    returnNat (Any IntRep code__2)

#endif {- alpha_TARGET_ARCH -}

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

#if i386_TARGET_ARCH

coerceInt2FP pk x
  = getRegister x		`thenNat` \ register ->
    getNewRegNCG IntRep		`thenNat` \ reg ->
    let
    	code = registerCode register reg
    	src  = registerName register reg
        opc  = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
        code__2 dst = code `snocOL` opc src dst
    in
    returnNat (Any pk code__2)

------------
coerceFP2Int fprep x
  = getRegister x		`thenNat` \ register ->
    getNewRegNCG DoubleRep	`thenNat` \ tmp ->
    let
    	code = registerCode register tmp
    	src  = registerName register tmp
    	pk   = registerRep register

        opc  = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
        code__2 dst = code `snocOL` opc src dst
    in
    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 -}

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

#if sparc_TARGET_ARCH

coerceInt2FP pk x
  = getRegister x		`thenNat` \ register ->
    getNewRegNCG IntRep		`thenNat` \ reg ->
    let
    	code = registerCode register reg
    	src  = registerName register reg

    	code__2 dst = code `appOL` toOL [
    	    ST W src (spRel (-2)),
    	    LD W (spRel (-2)) dst,
    	    FxTOy W (primRepToSize pk) dst dst]
    in
    returnNat (Any pk code__2)

------------
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
    	code__2 dst = code `appOL` toOL [
    	    FxTOy (primRepToSize fprep) W src tmp,
    	    ST W tmp (spRel (-2)),
    	    LD W (spRel (-2)) dst]
    in
    returnNat (Any IntRep code__2)

------------
coerceDbl2Flt x
  = getRegister x		`thenNat` \ register ->
    getNewRegNCG DoubleRep	`thenNat` \ tmp ->
    let code = registerCode register tmp
        src  = registerName register tmp
    in
        returnNat (Any FloatRep 
                       (\dst -> code `snocOL` FxTOy DF F src dst)) 

------------
coerceFlt2Dbl x
  = getRegister x		`thenNat` \ register ->
    getNewRegNCG FloatRep	`thenNat` \ tmp ->
    let code = registerCode register tmp
        src  = registerName register tmp
    in
        returnNat (Any DoubleRep
                       (\dst -> code `snocOL` FxTOy F DF src dst)) 

#endif {- sparc_TARGET_ARCH -}

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