    module Alpha.CodeGen ()

    where

    {-

    getRegister :: CmmExpr -> NatM Register

    #if !x86_64_TARGET_ARCH
        -- on x86_64, we have %rip for PicBaseReg, but it's not a full-featured
        -- register, it can only be used for rip-relative addressing.
    getRegister (CmmReg (CmmGlobal PicBaseReg))
      = do
          reg <- getPicBaseNat wordSize
          return (Fixed wordSize reg nilOL)
    #endif

    getRegister (CmmReg reg)
      = return (Fixed (cmmTypeSize (cmmRegType reg))
    		  (getRegisterReg reg) nilOL)

    getRegister tree@(CmmRegOff _ _)
      = getRegister (mangleIndexTree tree)

    #if WORD_SIZE_IN_BITS==32
        -- for 32-bit architectuers, support some 64 -> 32 bit conversions:
        -- TO_W_(x), TO_W_(x >> 32)

    getRegister (CmmMachOp (MO_UU_Conv W64 W32)
                 [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
      ChildCode64 code rlo <- iselExpr64 x
      return $ Fixed II32 (getHiVRegFromLo rlo) code

    getRegister (CmmMachOp (MO_SS_Conv W64 W32)
                 [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
      ChildCode64 code rlo <- iselExpr64 x
      return $ Fixed II32 (getHiVRegFromLo rlo) code

    getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do
      ChildCode64 code rlo <- iselExpr64 x
      return $ Fixed II32 rlo code

    getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do
      ChildCode64 code rlo <- iselExpr64 x
      return $ Fixed II32 rlo code

    #endif

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

    getRegister (StDouble d)
      = getBlockIdNat 	    	    `thenNat` \ lbl ->
        getNewRegNat PtrRep    	    `thenNat` \ tmp ->
        let code dst = mkSeqInstrs [
    	    LDATA RoDataSegment lbl [
    		    DATA TF [ImmLab (rational d)]
    		],
    	    LDA tmp (AddrImm (ImmCLbl lbl)),
    	    LD TF dst (AddrReg tmp)]
        in
        	return (Any FF64 code)

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

          NotOp    -> trivialUCode NOT x

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

          OrdOp -> coerceIntCode IntRep x
          ChrOp -> chrCode x

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

          Double2FloatOp -> coerceFltCode x
          Float2DoubleOp -> coerceFltCode x

          other_op -> getRegister (StCall fn CCallConv FF64 [x])
    	where
    	  fn = case other_op of
    		 FloatExpOp    -> fsLit "exp"
    		 FloatLogOp    -> fsLit "log"
    		 FloatSqrtOp   -> fsLit "sqrt"
    		 FloatSinOp    -> fsLit "sin"
    		 FloatCosOp    -> fsLit "cos"
    		 FloatTanOp    -> fsLit "tan"
    		 FloatAsinOp   -> fsLit "asin"
    		 FloatAcosOp   -> fsLit "acos"
    		 FloatAtanOp   -> fsLit "atan"
    		 FloatSinhOp   -> fsLit "sinh"
    		 FloatCoshOp   -> fsLit "cosh"
    		 FloatTanhOp   -> fsLit "tanh"
    		 DoubleExpOp   -> fsLit "exp"
    		 DoubleLogOp   -> fsLit "log"
    		 DoubleSqrtOp  -> fsLit "sqrt"
    		 DoubleSinOp   -> fsLit "sin"
    		 DoubleCosOp   -> fsLit "cos"
    		 DoubleTanOp   -> fsLit "tan"
    		 DoubleAsinOp  -> fsLit "asin"
    		 DoubleAcosOp  -> fsLit "acos"
    		 DoubleAtanOp  -> fsLit "atan"
    		 DoubleSinhOp  -> fsLit "sinh"
    		 DoubleCoshOp  -> fsLit "cosh"
    		 DoubleTanhOp  -> fsLit "tanh"
      where
        pr = panic "MachCode.getRegister: no primrep needed for Alpha"

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

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

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

          AddrGtOp -> trivialCode (CMP ULT) y x
          AddrGeOp -> trivialCode (CMP ULE) y x
          AddrEqOp -> trivialCode (CMP EQQ)  x y
          AddrNeOp -> int_NE_code x y
          AddrLtOp -> trivialCode (CMP ULT) x y
          AddrLeOp -> trivialCode (CMP ULE) x y

          FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
          FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
          FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
          FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
          FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
          FloatLeOp -> cmpF_code (FCMP TF LE) NE x y

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

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

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

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

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

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

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

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

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

        int_NE_code x y
          = trivialCode (CMP EQQ) x y	`thenNat` \ register ->
    	getNewRegNat IntRep		`thenNat` \ tmp ->
    	let
    	    code = registerCode register tmp
    	    src  = registerName register tmp
    	    code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
    	in
    	return (Any IntRep code__2)

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

        cmpF_code instr cond x y
          = trivialFCode pr instr x y	`thenNat` \ register ->
    	getNewRegNat FF64		`thenNat` \ tmp ->
    	getBlockIdNat			`thenNat` \ lbl ->
    	let
    	    code = registerCode register tmp
    	    result  = registerName register tmp

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

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

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

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

    getAmode :: CmmExpr -> NatM Amode
    getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree)

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

    #if alpha_TARGET_ARCH

    getAmode (StPrim IntSubOp [x, StInt i])
      = getNewRegNat PtrRep		`thenNat` \ tmp ->
        getRegister x		`thenNat` \ register ->
        let
        	code = registerCode register tmp
        	reg  = registerName register tmp
        	off  = ImmInt (-(fromInteger i))
        in
        return (Amode (AddrRegImm reg off) code)

    getAmode (StPrim IntAddOp [x, StInt i])
      = getNewRegNat PtrRep		`thenNat` \ tmp ->
        getRegister x		`thenNat` \ register ->
        let
        	code = registerCode register tmp
        	reg  = registerName register tmp
        	off  = ImmInt (fromInteger i)
        in
        return (Amode (AddrRegImm reg off) code)

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

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

    #endif /* alpha_TARGET_ARCH */

    -- -----------------------------------------------------------------------------
    -- Generating assignments

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

    assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
    assignReg_IntCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock

    assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
    assignReg_FltCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock

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

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

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

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

    -- -----------------------------------------------------------------------------
    -- Generating an non-local jump

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

    genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock

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

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

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

    -- -----------------------------------------------------------------------------
    --  Unconditional branches

    genBranch :: BlockId -> NatM InstrBlock

    genBranch = return . toOL . mkBranchInstr

    -- -----------------------------------------------------------------------------
    --  Conditional jumps

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

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

    -}

    genCondJump
        :: BlockId	    -- the branch target
        -> CmmExpr      -- the condition on which to branch
        -> NatM InstrBlock

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

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

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

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

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

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

    -- -----------------------------------------------------------------------------
    --  Generating C calls

    -- Now the biggest nightmare---calls.  Most of the nastiness is buried in
    -- @get_arg@, which moves the arguments to the correct registers/stack
    -- locations.  Apart from that, the code is easy.
    --
    -- (If applicable) Do not fill the delay slots here; you will confuse the
    -- register allocator.

    genCCall
        :: CmmCallTarget		-- function to call
        -> HintedCmmFormals		-- where to put the result
        -> HintedCmmActuals		-- arguments (of mixed type)
        -> NatM InstrBlock

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

    ccallResultRegs =

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

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

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

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

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

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

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

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

    ------------
    trivialFCode _ instr x y
      = getRegister x		`thenNat` \ register1 ->
        getRegister y		`thenNat` \ register2 ->
        getNewRegNat FF64	`thenNat` \ tmp1 ->
        getNewRegNat FF64	`thenNat` \ tmp2 ->
        let
        	code1 = registerCode register1 tmp1
        	src1  = registerName register1 tmp1

        	code2 = registerCode register2 tmp2
        	src2  = registerName register2 tmp2

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

    trivialUFCode _ instr x
      = getRegister x		`thenNat` \ register ->
        getNewRegNat FF64	`thenNat` \ tmp ->
        let
        	code = registerCode register tmp
        	src  = registerName register tmp
        	code__2 dst = code . mkSeqInstr (instr src dst)
        in
        return (Any FF64 code__2)

    #if alpha_TARGET_ARCH

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

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

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

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

    #endif /* alpha_TARGET_ARCH */

    -}