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

%
% (c) The AQUA Project, Glasgow University, 1993-1995
%

\section[SparcCode]{The Native (Sparc) Machine Code}

\begin{code}
#define ILIT2(x) ILIT(x)
#include "HsVersions.h"

module SparcCode (
	Addr(..),Cond(..),Imm(..),RI(..),Size(..),
	SparcCode(..),SparcInstr(..),SparcRegs,
	strImmLit, --UNUSED: strImmLab,

    	printLabeledCodes,

	baseRegOffset, stgRegMap, callerSaves,

	is13Bits, offset,

    	kindToSize,

    	g0, o0, f0, fp, sp, argRegs,

    	freeRegs, reservedRegs,

	-- and, for self-sufficiency ...
	CLabel, CodeSegment, OrdList, PrimKind, Reg, UniqSet(..),
	UniqFM, FiniteMap, Unique, MagicId, CSeq, BitSet
    ) where

IMPORT_Trace

import AbsCSyn	    	( MagicId(..) )
import AsmRegAlloc  	( MachineCode(..), MachineRegisters(..), FutureLive(..),
    	    	    	  Reg(..), RegUsage(..), RegLiveness(..)
    	    	    	)
import BitSet	 
import CgCompInfo   	( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG )
import CLabelInfo   	( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
import FiniteMap    
import Maybes	    	( Maybe(..), maybeToBool )
import OrdList	    	( OrdList, mkUnitList, flattenOrdList )
import Outputable    
import PrimKind	    	( PrimKind(..) )
import UniqSet
import Stix
import Unpretty
import Util
\end{code}

%************************************************************************
%*									*
\subsection[SparcReg]{The Native (Sparc) Machine Register Table}
%*									*
%************************************************************************

The sparc has 64 registers of interest; 32 integer registers and 32 floating
point registers.  The mapping of STG registers to sparc machine registers
is defined in StgRegs.h.  We are, of course, prepared for any eventuality.

ToDo: Deal with stg registers that live as offsets from BaseReg!(JSM)

\begin{code}

gReg,lReg,iReg,oReg,fReg :: Int -> Int
gReg x = x
oReg x = (8 + x)
lReg x = (16 + x)
iReg x = (24 + x)
fReg x = (32 + x)

fPair :: Reg -> Reg
fPair (FixedReg i) = FixedReg (i _ADD_ ILIT(1))
fPair (MappedReg i) = MappedReg (i _ADD_ ILIT(1))

g0, fp, sp, o0, f0 :: Reg
g0 = case (gReg 0) of { IBOX(g0) -> FixedReg g0 }
fp = case (iReg 6) of { IBOX(i6) -> FixedReg i6 }
sp = case (oReg 6) of { IBOX(o6) -> FixedReg o6 }
o0 = realReg  (oReg 0)
f0 = realReg  (fReg 0)

argRegs :: [Reg]
argRegs = map realReg [oReg i | i <- [0..5]]

realReg n@IBOX(i) = if _IS_TRUE_(freeReg i) then MappedReg i else FixedReg i

\end{code}

%************************************************************************
%*									*
\subsection[TheSparcCode]{The datatype for sparc assembly language}
%*									*
%************************************************************************

Here is a definition of the Sparc assembly language.

\begin{code}

data Imm = ImmInt Int
    	 | ImmInteger Integer	      -- Sigh.
	 | ImmCLbl CLabel	      -- AbstractC Label (with baggage)
	 | ImmLab  Unpretty	      -- Simple string label (underscored)
	 | ImmLit Unpretty	      -- Simple string
	 | LO Imm		      -- Possible restrictions
	 | HI Imm
	 deriving ()

--UNUSED:strImmLab s = ImmLab (uppStr s)
strImmLit s = ImmLit (uppStr s)

data Addr = AddrRegReg Reg Reg
	  | AddrRegImm Reg Imm
	  deriving ()

data Cond = ALWAYS
	  | NEVER
	  | GEU
	  | LU
	  | EQ
	  | GT
	  | GE
	  | GU
	  | LT
	  | LE
	  | LEU
	  | NE
	  | NEG
	  | POS
	  | VC
	  | VS
	  deriving ()

data RI = RIReg Reg
	| RIImm Imm
	deriving ()

riZero :: RI -> Bool
riZero (RIImm (ImmInt 0))	    = True
riZero (RIImm (ImmInteger 0))	    = True
riZero (RIReg (FixedReg ILIT(0)))   = True
riZero _			    = False

data Size = SB
	  | HW
	  | UB
	  | UHW
	  | W
	  | D
	  | F
	  | DF
	  deriving ()

data SparcInstr =

-- Loads and stores.

		LD	      Size Addr Reg -- size, src, dst
	      | ST	      Size Reg Addr -- size, src, dst

-- Int Arithmetic.

	      | ADD	      Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst
	      | SUB	      Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst

-- Simple bit-twiddling.

	      | AND	      Bool Reg RI Reg -- cc?, src1, src2, dst
	      | ANDN	      Bool Reg RI Reg -- cc?, src1, src2, dst
	      | OR	      Bool Reg RI Reg -- cc?, src1, src2, dst
	      | ORN	      Bool Reg RI Reg -- cc?, src1, src2, dst
	      | XOR	      Bool Reg RI Reg -- cc?, src1, src2, dst
	      | XNOR	      Bool Reg RI Reg -- cc?, src1, src2, dst
	      | SLL	      Reg RI Reg -- src1, src2, dst
	      | SRL	      Reg RI Reg -- src1, src2, dst
	      | SRA	      Reg RI Reg -- src1, src2, dst
	      | SETHI	      Imm Reg -- src, dst
	      | NOP	      -- Really SETHI 0, %g0, but worth an alias

-- Float Arithmetic.

-- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single instructions
-- right up until we spit them out.

    	      | FABS	      Size Reg Reg -- src dst
	      | FADD	      Size Reg Reg Reg -- src1, src2, dst
    	      | FCMP	      Bool Size Reg Reg -- exception?, src1, src2, dst
	      | FDIV	      Size Reg Reg Reg -- src1, src2, dst
    	      | FMOV	      Size Reg Reg -- src, dst
	      | FMUL	      Size Reg Reg Reg -- src1, src2, dst
    	      | FNEG	      Size Reg Reg -- src, dst
    	      | FSQRT	      Size Reg Reg -- src, dst
	      | FSUB	      Size Reg Reg Reg -- src1, src2, dst
    	      | FxTOy	      Size Size Reg Reg -- src, dst

-- Jumping around.

	      | BI	      Cond Bool Imm -- cond, annul?, target
    	      | BF  	      Cond Bool Imm -- cond, annul?, target

	      | JMP	      Addr -- target
	      | CALL	      Imm Int Bool -- target, args, terminal

-- Pseudo-ops.

	      | LABEL CLabel
	      | COMMENT FAST_STRING
	      | SEGMENT CodeSegment
	      | ASCII Bool String   -- needs backslash conversion?
	      | DATA Size [Imm]

type SparcCode	= OrdList SparcInstr

\end{code}

%************************************************************************
%*									*
\subsection[TheSparcPretty]{Pretty-printing the Sparc Assembly Language}
%*									*
%************************************************************************

\begin{code}

printLabeledCodes :: PprStyle -> [SparcInstr] -> Unpretty
printLabeledCodes sty codes = uppAboves (map (pprSparcInstr sty) codes)

\end{code}

Printing the pieces...

\begin{code}

pprReg :: Reg -> Unpretty

pprReg (FixedReg i) = pprSparcReg i
pprReg (MappedReg i) = pprSparcReg i
pprReg other = uppStr (show other)   -- should only happen when debugging

pprSparcReg :: FAST_INT -> Unpretty
pprSparcReg i = uppPStr
    (case i of {
        ILIT( 0) -> SLIT("%g0");  ILIT( 1) -> SLIT("%g1");
	ILIT( 2) -> SLIT("%g2");  ILIT( 3) -> SLIT("%g3");
        ILIT( 4) -> SLIT("%g4");  ILIT( 5) -> SLIT("%g5");
	ILIT( 6) -> SLIT("%g6");  ILIT( 7) -> SLIT("%g7");
        ILIT( 8) -> SLIT("%o0");  ILIT( 9) -> SLIT("%o1");
	ILIT(10) -> SLIT("%o2");  ILIT(11) -> SLIT("%o3");
        ILIT(12) -> SLIT("%o4");  ILIT(13) -> SLIT("%o5");
	ILIT(14) -> SLIT("%o6");  ILIT(15) -> SLIT("%o7");
        ILIT(16) -> SLIT("%l0");  ILIT(17) -> SLIT("%l1");
	ILIT(18) -> SLIT("%l2");  ILIT(19) -> SLIT("%l3");
        ILIT(20) -> SLIT("%l4");  ILIT(21) -> SLIT("%l5");
	ILIT(22) -> SLIT("%l6");  ILIT(23) -> SLIT("%l7");
        ILIT(24) -> SLIT("%i0");  ILIT(25) -> SLIT("%i1");
	ILIT(26) -> SLIT("%i2");  ILIT(27) -> SLIT("%i3");
        ILIT(28) -> SLIT("%i4");  ILIT(29) -> SLIT("%i5");
	ILIT(30) -> SLIT("%i6");  ILIT(31) -> SLIT("%i7");
        ILIT(32) -> SLIT("%f0");  ILIT(33) -> SLIT("%f1");
	ILIT(34) -> SLIT("%f2");  ILIT(35) -> SLIT("%f3");
        ILIT(36) -> SLIT("%f4");  ILIT(37) -> SLIT("%f5");
	ILIT(38) -> SLIT("%f6");  ILIT(39) -> SLIT("%f7");
        ILIT(40) -> SLIT("%f8");  ILIT(41) -> SLIT("%f9");
	ILIT(42) -> SLIT("%f10"); ILIT(43) -> SLIT("%f11");
        ILIT(44) -> SLIT("%f12"); ILIT(45) -> SLIT("%f13");
	ILIT(46) -> SLIT("%f14"); ILIT(47) -> SLIT("%f15");
        ILIT(48) -> SLIT("%f16"); ILIT(49) -> SLIT("%f17");
	ILIT(50) -> SLIT("%f18"); ILIT(51) -> SLIT("%f19");
        ILIT(52) -> SLIT("%f20"); ILIT(53) -> SLIT("%f21");
	ILIT(54) -> SLIT("%f22"); ILIT(55) -> SLIT("%f23");
        ILIT(56) -> SLIT("%f24"); ILIT(57) -> SLIT("%f25");
	ILIT(58) -> SLIT("%f26"); ILIT(59) -> SLIT("%f27");
        ILIT(60) -> SLIT("%f28"); ILIT(61) -> SLIT("%f29");
	ILIT(62) -> SLIT("%f30"); ILIT(63) -> SLIT("%f31");
	_ -> SLIT("very naughty sparc register")
    })

pprCond :: Cond -> Unpretty
pprCond x = uppPStr
    (case x of {
	ALWAYS	-> SLIT("");	NEVER -> SLIT("n");
	GEU	-> SLIT("geu");	LU    -> SLIT("lu");
	EQ	-> SLIT("e");	GT    -> SLIT("g");
	GE	-> SLIT("ge");	GU    -> SLIT("gu");
	LT	-> SLIT("l");	LE    -> SLIT("le");
	LEU	-> SLIT("leu");	NE    -> SLIT("ne");
	NEG	-> SLIT("neg");	POS   -> SLIT("pos");
	VC	-> SLIT("vc");	VS    -> SLIT("vs")
    })

pprImm :: PprStyle -> Imm -> Unpretty

pprImm sty (ImmInt i) = uppInt i
pprImm sty (ImmInteger i) = uppInteger i

pprImm sty (LO i) =
    uppBesides [
	  pp_lo,
	  pprImm sty i,
	  uppRparen
    ]
  where
#ifdef USE_FAST_STRINGS
    pp_lo = uppPStr (_packCString (A# "%lo("#))
#else
    pp_lo = uppStr "%lo("
#endif

pprImm sty (HI i) =
    uppBesides [
	  pp_hi,
	  pprImm sty i,
	  uppRparen
    ]
  where
#ifdef USE_FAST_STRINGS
    pp_hi = uppPStr (_packCString (A# "%hi("#))
#else
    pp_hi = uppStr "%hi("
#endif

pprImm sty (ImmCLbl l) = pprCLabel sty l

pprImm (PprForAsm _ False _) (ImmLab s) = s
pprImm _                     (ImmLab s) = uppBeside (uppChar '_') s

pprImm sty (ImmLit s) = s

pprAddr :: PprStyle -> Addr -> Unpretty
pprAddr sty (AddrRegReg r1 (FixedReg ILIT(0))) = pprReg r1

pprAddr sty (AddrRegReg r1 r2) =
    uppBesides [
	pprReg r1,
	uppChar '+',
	pprReg r2
    ]

pprAddr sty (AddrRegImm r1 (ImmInt i))
    | i == 0 = pprReg r1
    | i < 0  =
	uppBesides [
	    pprReg r1,
	    uppChar '-',
	    uppInt (-i)
	]

pprAddr sty (AddrRegImm r1 (ImmInteger i))
    | i == 0 = pprReg r1
    | i < 0  =
	uppBesides [
	    pprReg r1,
	    uppChar '-',
	    uppInteger (-i)
	]

pprAddr sty (AddrRegImm r1 imm) =
    uppBesides [
	pprReg r1,
	uppChar '+',
	pprImm sty imm
    ]

pprRI :: PprStyle -> RI -> Unpretty
pprRI sty (RIReg r) = pprReg r
pprRI sty (RIImm r) = pprImm sty r

pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Unpretty
pprSizeRegReg name size reg1 reg2 =
    uppBesides [
    	uppChar '\t',
	uppPStr name,
    	(case size of
    	    F  -> uppPStr SLIT("s\t")
    	    DF -> uppPStr SLIT("d\t")),
	pprReg reg1,
	uppComma,
	pprReg reg2
    ]

pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Unpretty
pprSizeRegRegReg name size reg1 reg2 reg3 =
    uppBesides [
    	uppChar '\t',
	uppPStr name,
    	(case size of
    	    F  -> uppPStr SLIT("s\t")
    	    DF -> uppPStr SLIT("d\t")),
	pprReg reg1,
	uppComma,
	pprReg reg2,
	uppComma,
	pprReg reg3
    ]

pprRegRIReg :: PprStyle -> FAST_STRING -> Bool -> Reg -> RI -> Reg -> Unpretty
pprRegRIReg sty name b reg1 ri reg2 =
    uppBesides [
	uppChar '\t',
	uppPStr name,
	if b then uppPStr SLIT("cc\t") else uppChar '\t',
	pprReg reg1,
	uppComma,
	pprRI sty ri,
	uppComma,
	pprReg reg2
    ]

pprRIReg :: PprStyle -> FAST_STRING -> Bool -> RI -> Reg -> Unpretty
pprRIReg sty name b ri reg1 =
    uppBesides [
	uppChar '\t',
	uppPStr name,
	if b then uppPStr SLIT("cc\t") else uppChar '\t',
	pprRI sty ri,
	uppComma,
	pprReg reg1
    ]

pprSize :: Size -> Unpretty
pprSize x = uppPStr
    (case x of
	SB  -> SLIT("sb")
	HW  -> SLIT("hw")
	UB  -> SLIT("ub")
	UHW -> SLIT("uhw")
	W   -> SLIT("")
	F   -> SLIT("")
	D   -> SLIT("d")
	DF  -> SLIT("d")
    )

#ifdef USE_FAST_STRINGS
pp_ld_lbracket    = uppPStr (_packCString (A# "\tld\t["#))
pp_rbracket_comma = uppPStr (_packCString (A# "],"#))
pp_comma_lbracket = uppPStr (_packCString (A# ",["#))
pp_comma_a	  = uppPStr (_packCString (A# ",a"#))
#else
pp_ld_lbracket    = uppStr "\tld\t["
pp_rbracket_comma = uppStr "],"
pp_comma_lbracket = uppStr ",["
pp_comma_a	  = uppStr ",a"
#endif

pprSparcInstr :: PprStyle -> SparcInstr -> Unpretty

-- a clumsy hack for now, to handle possible alignment problems

pprSparcInstr sty (LD DF addr reg) | maybeToBool addrOff =
    uppBesides [
	pp_ld_lbracket,
	pprAddr sty addr,
	pp_rbracket_comma,
	pprReg reg,

	uppChar '\n',
	pp_ld_lbracket,
	pprAddr sty addr2,
	pp_rbracket_comma,
	pprReg (fPair reg)
    ]
  where
    addrOff = offset addr 4
    addr2 = case addrOff of Just x -> x

pprSparcInstr sty (LD size addr reg) =
    uppBesides [
	uppPStr SLIT("\tld"),
	pprSize size,
	uppChar '\t',
	uppLbrack,
	pprAddr sty addr,
	pp_rbracket_comma,
	pprReg reg
    ]

-- The same clumsy hack as above

pprSparcInstr sty (ST DF reg addr) | maybeToBool addrOff =
    uppBesides [
	uppPStr SLIT("\tst\t"),
	pprReg reg,
	pp_comma_lbracket,
	pprAddr sty addr,

	uppPStr SLIT("]\n\tst\t"),
	pprReg (fPair reg),
	pp_comma_lbracket,
	pprAddr sty addr2,
	uppRbrack
    ]
  where
    addrOff = offset addr 4
    addr2 = case addrOff of Just x -> x

pprSparcInstr sty (ST size reg addr) =
    uppBesides [
	uppPStr SLIT("\tst"),
	pprSize size,
	uppChar '\t',
	pprReg reg,
	pp_comma_lbracket,
	pprAddr sty addr,
	uppRbrack
    ]

pprSparcInstr sty (ADD x cc reg1 ri reg2)
 | not x && not cc && riZero ri =
    uppBesides [
	uppPStr SLIT("\tmov\t"),
	pprReg reg1,
	uppComma,
	pprReg reg2
    ]
 | otherwise = pprRegRIReg sty (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2

pprSparcInstr sty (SUB x cc reg1 ri reg2)
 | not x && cc && reg2 == g0 =
    uppBesides [
	uppPStr SLIT("\tcmp\t"),
	pprReg reg1,
	uppComma,
	pprRI sty ri
    ]
 | not x && not cc && riZero ri =
    uppBesides [
	uppPStr SLIT("\tmov\t"),
	pprReg reg1,
	uppComma,
	pprReg reg2
    ]
 | otherwise = pprRegRIReg sty (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2

pprSparcInstr sty (AND b reg1 ri reg2) = pprRegRIReg sty SLIT("and") b reg1 ri reg2
pprSparcInstr sty (ANDN b reg1 ri reg2) = pprRegRIReg sty SLIT("andn") b reg1 ri reg2

pprSparcInstr sty (OR b reg1 ri reg2)
 | not b && reg1 == g0 =
    uppBesides [
	uppPStr SLIT("\tmov\t"),
	pprRI sty ri,
	uppComma,
	pprReg reg2
    ]
 | otherwise = pprRegRIReg sty SLIT("or") b reg1 ri reg2

pprSparcInstr sty (ORN b reg1 ri reg2) = pprRegRIReg sty SLIT("orn") b reg1 ri reg2

pprSparcInstr sty (XOR b reg1 ri reg2) = pprRegRIReg sty SLIT("xor") b reg1 ri reg2
pprSparcInstr sty (XNOR b reg1 ri reg2) = pprRegRIReg sty SLIT("xnor") b reg1 ri reg2

pprSparcInstr sty (SLL reg1 ri reg2) = pprRegRIReg sty SLIT("sll") False reg1 ri reg2
pprSparcInstr sty (SRL reg1 ri reg2) = pprRegRIReg sty SLIT("srl") False reg1 ri reg2
pprSparcInstr sty (SRA reg1 ri reg2) = pprRegRIReg sty SLIT("sra") False reg1 ri reg2

pprSparcInstr sty (SETHI imm reg) =
    uppBesides [
	uppPStr SLIT("\tsethi\t"),
	pprImm sty imm,
	uppComma,
	pprReg reg
    ]

pprSparcInstr sty (NOP) = uppPStr SLIT("\tnop")

pprSparcInstr sty (FABS F reg1 reg2) = pprSizeRegReg SLIT("fabs") F reg1 reg2
pprSparcInstr sty (FABS DF reg1 reg2) =
    uppBeside (pprSizeRegReg SLIT("fabs") F reg1 reg2)
    (if (reg1 == reg2) then uppNil
     else uppBeside (uppChar '\n')
    	  (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))

pprSparcInstr sty (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3
pprSparcInstr sty (FCMP e size reg1 reg2) =
    pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2
pprSparcInstr sty (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3

pprSparcInstr sty (FMOV F reg1 reg2) = pprSizeRegReg SLIT("fmov") F reg1 reg2
pprSparcInstr sty (FMOV DF reg1 reg2) =
    uppBeside (pprSizeRegReg SLIT("fmov") F reg1 reg2)
    (if (reg1 == reg2) then uppNil
     else uppBeside (uppChar '\n')
    	  (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))

pprSparcInstr sty (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3

pprSparcInstr sty (FNEG F reg1 reg2) = pprSizeRegReg SLIT("fneg") F reg1 reg2
pprSparcInstr sty (FNEG DF reg1 reg2) =
    uppBeside (pprSizeRegReg SLIT("fneg") F reg1 reg2)
    (if (reg1 == reg2) then uppNil
     else uppBeside (uppChar '\n')
    	  (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))

pprSparcInstr sty (FSQRT size reg1 reg2) = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
pprSparcInstr sty (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
pprSparcInstr sty (FxTOy size1 size2 reg1 reg2) =
    uppBesides [
    	uppPStr SLIT("\tf"),
	uppPStr
    	(case size1 of
    	    W  -> SLIT("ito")
    	    F  -> SLIT("sto")
    	    DF -> SLIT("dto")),
	uppPStr
    	(case size2 of
    	    W  -> SLIT("i\t")
    	    F  -> SLIT("s\t")
    	    DF -> SLIT("d\t")),
	pprReg reg1,
	uppComma,
	pprReg reg2
    ]


pprSparcInstr sty (BI cond b lab) =
    uppBesides [
	uppPStr SLIT("\tb"), pprCond cond,
	if b then pp_comma_a else uppNil,
	uppChar '\t',
	pprImm sty lab
    ]

pprSparcInstr sty (BF cond b lab) =
    uppBesides [
	uppPStr SLIT("\tfb"), pprCond cond,
	if b then pp_comma_a else uppNil,
	uppChar '\t',
	pprImm sty lab
    ]

pprSparcInstr sty (JMP addr) = uppBeside (uppPStr SLIT("\tjmp\t")) (pprAddr sty addr)

pprSparcInstr sty (CALL imm n _) =
    uppBesides [
	uppPStr SLIT("\tcall\t"),
	pprImm sty imm,
	uppComma,
	uppInt n
    ]

pprSparcInstr sty (LABEL clab) =
    uppBesides [
	if (externallyVisibleCLabel clab) then
	    uppBesides [uppPStr SLIT("\t.global\t"), pprLab, uppChar '\n']
	else
	    uppNil,
    	pprLab,
	uppChar ':'
    ]
    where pprLab = pprCLabel sty clab

pprSparcInstr sty (COMMENT s) = uppBeside (uppPStr SLIT("! ")) (uppPStr s)

pprSparcInstr sty (SEGMENT TextSegment)
    = uppPStr SLIT("\t.text\n\t.align 4")

pprSparcInstr sty (SEGMENT DataSegment)
    = uppPStr SLIT("\t.data\n\t.align 8")   -- Less than 8 will break double constants

pprSparcInstr sty (ASCII False str) =
    uppBesides [
    	uppStr "\t.asciz \"",
    	uppStr str,
    	uppChar '"'
    ]

pprSparcInstr sty (ASCII True str) = uppBeside (uppStr "\t.ascii \"") (asciify str 60)
    where
    	asciify :: String -> Int -> Unpretty
    	asciify [] _ = uppStr ("\\0\"")
    	asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60)
        asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
        asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
        asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
    	asciify [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\""))
    	asciify (c:(cs@(d:_))) n | isDigit d =
    	    	    	    	    	uppBeside (uppStr (charToC c)) (asciify cs 0)
    	    	    	    	 | otherwise =
    	    	    	    	    	uppBeside (uppStr (charToC c)) (asciify cs (n-1))

pprSparcInstr sty (DATA s xs) = uppInterleave (uppChar '\n') (map pp_item xs)
    where pp_item x = case s of
	    SB -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x)
	    UB -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x)
	    W  -> uppBeside (uppPStr SLIT("\t.word\t")) (pprImm sty x)
    	    DF -> uppBeside (uppPStr SLIT("\t.double\t")) (pprImm sty x)

\end{code}

%************************************************************************
%*									*
\subsection[Schedule]{Register allocation information}
%*									*
%************************************************************************

Getting the conflicts right is a bit tedious for doubles.  We'd have to
add a conflict function to the MachineRegisters class, and we'd have to
put a PrimKind in the MappedReg datatype, or use some kludge (e.g. register
64 + n is really the same as 32 + n, except that it's used for a double,
so it also conflicts with 33 + n) to deal with it.  It's just not worth the
bother, so we just partition the free floating point registers into two
sets: one for single precision and one for double precision.  We never seem
to run out of floating point registers anyway.

\begin{code}

data SparcRegs = SRegs BitSet BitSet BitSet

instance MachineRegisters SparcRegs where
    mkMRegs xs = SRegs (mkBS ints) (mkBS singles') (mkBS doubles')
      where
    	(ints, floats) = partition (< 32) xs
    	(singles, doubles) = partition (< 48) floats
    	singles' = map (subtract 32) singles
        doubles' = map (subtract 32) (filter even doubles)

    possibleMRegs FloatKind (SRegs _ singles _) = [ x + 32 | x <- listBS singles]
    possibleMRegs DoubleKind (SRegs _ _ doubles) = [ x + 32 | x <- listBS doubles]
    possibleMRegs _ (SRegs ints _ _) = listBS ints

    useMReg (SRegs ints singles doubles) n =
    	if n _LT_ ILIT(32) then SRegs (ints `minusBS` singletonBS IBOX(n)) singles doubles
    	else if n _LT_ ILIT(48) then SRegs ints (singles `minusBS` singletonBS (IBOX(n _SUB_ ILIT(32)))) doubles
    	else SRegs ints singles (doubles `minusBS` singletonBS (IBOX(n _SUB_ ILIT(32))))

    useMRegs (SRegs ints singles doubles) xs =
    	SRegs (ints `minusBS` ints')
    	      (singles `minusBS` singles')
    	      (doubles `minusBS` doubles')
      where
        SRegs ints' singles' doubles' = mkMRegs xs

    freeMReg (SRegs ints singles doubles) n =
    	if n _LT_ ILIT(32) then SRegs (ints `unionBS` singletonBS IBOX(n)) singles doubles
    	else if n _LT_ ILIT(48) then SRegs ints (singles `unionBS` singletonBS (IBOX(n _SUB_ ILIT(32)))) doubles
    	else SRegs ints singles (doubles `unionBS` singletonBS (IBOX(n _SUB_ ILIT(32))))

    freeMRegs (SRegs ints singles doubles) xs =
        SRegs (ints `unionBS` ints')
    	      (singles `unionBS` singles')
    	      (doubles `unionBS` doubles')
      where
        SRegs ints' singles' doubles' = mkMRegs xs

instance MachineCode SparcInstr where
    -- Alas, we don't do anything clever with our OrdLists
--OLD:
--  flatten = flattenOrdList

    regUsage = sparcRegUsage
    regLiveness = sparcRegLiveness
    patchRegs = sparcPatchRegs

    -- We spill just below the frame pointer, leaving two words per spill location.
    spillReg dyn (MemoryReg i pk) = mkUnitList (ST (kindToSize pk) dyn (fpRel (-2 * i)))
    loadReg (MemoryReg i pk) dyn = mkUnitList (LD (kindToSize pk) (fpRel (-2 * i)) dyn)

-- Duznae work for offsets greater than 13 bits; we just hope for the best
fpRel :: Int -> Addr
fpRel n = AddrRegImm fp (ImmInt (n * 4))

kindToSize :: PrimKind -> Size
kindToSize PtrKind	    = W
kindToSize CodePtrKind	    = W
kindToSize DataPtrKind	    = W
kindToSize RetKind	    = W
kindToSize InfoPtrKind	    = W
kindToSize CostCentreKind   = W
kindToSize CharKind	    = UB
kindToSize IntKind	    = W
kindToSize WordKind	    = W
kindToSize AddrKind	    = W
kindToSize FloatKind	    = F
kindToSize DoubleKind	    = DF
kindToSize ArrayKind	    = W
kindToSize ByteArrayKind    = W
kindToSize StablePtrKind    = W
kindToSize MallocPtrKind    = W

\end{code}

@sparcRegUsage@ returns the sets of src and destination registers used by
a particular instruction.  Machine registers that are pre-allocated
to stgRegs are filtered out, because they are uninteresting from a
register allocation standpoint.  (We wouldn't want them to end up on
the free list!)

\begin{code}

sparcRegUsage :: SparcInstr -> RegUsage
sparcRegUsage instr = case instr of
    LD sz addr reg  	-> usage (regAddr addr, [reg])
    ST sz reg addr  	-> usage (reg : regAddr addr, [])
    ADD x cc r1 ar r2 	-> usage (r1 : regRI ar, [r2])
    SUB x cc r1 ar r2 	-> usage (r1 : regRI ar, [r2])
    AND b r1 ar r2  	-> usage (r1 : regRI ar, [r2])
    ANDN b r1 ar r2 	-> usage (r1 : regRI ar, [r2])
    OR b r1 ar r2   	-> usage (r1 : regRI ar, [r2])
    ORN b r1 ar r2  	-> usage (r1 : regRI ar, [r2])
    XOR b r1 ar r2  	-> usage (r1 : regRI ar, [r2])
    XNOR b r1 ar r2 	-> usage (r1 : regRI ar, [r2])
    SLL r1 ar r2    	-> usage (r1 : regRI ar, [r2])
    SRL r1 ar r2    	-> usage (r1 : regRI ar, [r2])
    SRA r1 ar r2    	-> usage (r1 : regRI ar, [r2])
    SETHI imm reg   	-> usage ([], [reg])
    FABS s r1 r2    	-> usage ([r1], [r2])
    FADD s r1 r2 r3 	-> usage ([r1, r2], [r3])
    FCMP e s r1 r2  	-> usage ([r1, r2], [])
    FDIV s r1 r2 r3 	-> usage ([r1, r2], [r3])
    FMOV s r1 r2    	-> usage ([r1], [r2])
    FMUL s r1 r2 r3 	-> usage ([r1, r2], [r3])
    FNEG s r1 r2    	-> usage ([r1], [r2])
    FSQRT s r1 r2   	-> usage ([r1], [r2])
    FSUB s r1 r2 r3 	-> usage ([r1, r2], [r3])
    FxTOy s1 s2 r1 r2 	-> usage ([r1], [r2])

    -- We assume that all local jumps will be BI/BF.  JMP must be out-of-line.
    JMP addr 	    	-> RU (mkUniqSet (filter interesting (regAddr addr))) freeSet

    CALL _ n True   	-> endUsage
    CALL _ n False  	-> RU (argSet n) callClobberedSet

    _ 	    	    	-> noUsage

  where
    usage (src, dst) = RU (mkUniqSet (filter interesting src))
    	    	    	  (mkUniqSet (filter interesting dst))

    interesting (FixedReg _) = False
    interesting _ = True

    regAddr (AddrRegReg r1 r2) = [r1, r2]
    regAddr (AddrRegImm r1 _)  = [r1]

    regRI (RIReg r) = [r]
    regRI  _	= []

freeRegs :: [Reg]
freeRegs = freeMappedRegs (\ x -> x) [0..63]

freeMappedRegs :: (Int -> Int) -> [Int] -> [Reg]

freeMappedRegs modify nums
  = foldr free [] nums
  where
    free n acc
      = let
	    modified_i = case (modify n) of { IBOX(x) -> x }
	in
	if _IS_TRUE_(freeReg modified_i) then (MappedReg modified_i) : acc else acc

freeSet :: UniqSet Reg
freeSet = mkUniqSet freeRegs

noUsage :: RegUsage
noUsage = RU emptyUniqSet emptyUniqSet

endUsage :: RegUsage
endUsage = RU emptyUniqSet freeSet

-- Color me CAF-like
argSet :: Int -> UniqSet Reg
argSet 0 = emptyUniqSet
argSet 1 = mkUniqSet (freeMappedRegs oReg [0])
argSet 2 = mkUniqSet (freeMappedRegs oReg [0,1])
argSet 3 = mkUniqSet (freeMappedRegs oReg [0,1,2])
argSet 4 = mkUniqSet (freeMappedRegs oReg [0,1,2,3])
argSet 5 = mkUniqSet (freeMappedRegs oReg [0,1,2,3,4])
argSet 6 = mkUniqSet (freeMappedRegs oReg [0,1,2,3,4,5])

callClobberedSet :: UniqSet Reg
callClobberedSet = mkUniqSet callClobberedRegs
  where
    callClobberedRegs = freeMappedRegs (\x -> x)
      ( oReg 7 :
    	[oReg i | i <- [0..5]] ++
    	[gReg i | i <- [1..7]] ++
    	[fReg i | i <- [0..31]] )

\end{code}

@sparcRegLiveness@ takes future liveness information and modifies it according to
the semantics of branches and labels.  (An out-of-line branch clobbers the liveness
passed back by the following instruction; a forward local branch passes back the
liveness from the target label; a conditional branch merges the liveness from the
target and the liveness from its successor; a label stashes away the current liveness
in the future liveness environment).

\begin{code}
sparcRegLiveness :: SparcInstr -> RegLiveness -> RegLiveness
sparcRegLiveness instr info@(RL live future@(FL all env)) = case instr of

    -- We assume that all local jumps will be BI/BF.  JMP must be out-of-line.

    BI ALWAYS _ (ImmCLbl lbl)	-> RL (lookup lbl) future
    BI _ _ (ImmCLbl lbl)	-> RL (lookup lbl `unionUniqSets` live) future
    BF ALWAYS _ (ImmCLbl lbl)	-> RL (lookup lbl) future
    BF _ _ (ImmCLbl lbl)	-> RL (lookup lbl `unionUniqSets` live) future
    JMP _			-> RL emptyUniqSet future
    CALL _ i True   -> RL emptyUniqSet future
    CALL _ i False  -> RL live future
    LABEL lbl	    -> RL live (FL (all `unionUniqSets` live) (addToFM env lbl live))
    _		    -> info

  where
    lookup lbl = case lookupFM env lbl of
	Just regs -> regs
	Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel (PprForAsm (\_->False) False id) lbl)) ++
                          " in future?") emptyUniqSet

\end{code}

@sparcPatchRegs@ takes an instruction (possibly with MemoryReg/UnmappedReg registers) and
changes all register references according to the supplied environment.

\begin{code}

sparcPatchRegs :: SparcInstr -> (Reg -> Reg) -> SparcInstr
sparcPatchRegs instr env = case instr of
    LD sz addr reg -> LD sz (fixAddr addr) (env reg)
    ST sz reg addr -> ST sz (env reg) (fixAddr addr)
    ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2)
    SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2)
    AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2)
    ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2)
    OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2)
    ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2)
    XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2)
    XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2)
    SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2)
    SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2)
    SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2)
    SETHI imm reg -> SETHI imm (env reg)
    FABS s r1 r2 -> FABS s (env r1) (env r2)
    FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3)
    FCMP e s r1 r2 -> FCMP e s (env r1) (env r2)
    FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3)
    FMOV s r1 r2 -> FMOV s (env r1) (env r2)
    FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3)
    FNEG s r1 r2 -> FNEG s (env r1) (env r2)
    FSQRT s r1 r2 -> FSQRT s (env r1) (env r2)
    FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3)
    FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2)
    JMP addr -> JMP (fixAddr addr)
    _ -> instr

  where
    fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)
    fixAddr (AddrRegImm r1 i)  = AddrRegImm (env r1) i

    fixRI (RIReg r) = RIReg (env r)
    fixRI other	= other
\end{code}

Sometimes, we want to be able to modify addresses at compile time.
(Okay, just for chrCode of a fetch.)

\begin{code}

#ifdef __GLASGOW_HASKELL__

{-# SPECIALIZE
    is13Bits :: Int -> Bool
  #-}
{-# SPECIALIZE
    is13Bits :: Integer -> Bool
  #-}

#endif

is13Bits :: Integral a => a -> Bool
is13Bits x = x >= -4096 && x < 4096

offset :: Addr -> Int -> Maybe Addr

offset (AddrRegImm reg (ImmInt n)) off
  | is13Bits n2 = Just (AddrRegImm reg (ImmInt n2))
  | otherwise = Nothing
  where n2 = n + off

offset (AddrRegImm reg (ImmInteger n)) off
  | is13Bits n2 = Just (AddrRegImm reg (ImmInt (fromInteger n2)))
  | otherwise = Nothing
  where n2 = n + toInteger off

offset (AddrRegReg reg (FixedReg ILIT(0))) off
  | is13Bits off = Just (AddrRegImm reg (ImmInt off))
  | otherwise = Nothing

offset _ _ = Nothing

\end{code}

If you value your sanity, do not venture below this line.

\begin{code}

-- platform.h is generate and tells us what the target architecture is
#include "../../includes/platform.h"
#include "../../includes/MachRegs.h"
#if sunos4_TARGET_OS
#include "../../includes/sparc-sun-sunos4.h"
#else
#include "../../includes/sparc-sun-solaris2.h"
#endif

-- Redefine the literals used for Sparc register names in the header
-- files.  Gag me with a spoon, eh?

#define g0 0
#define g1 1
#define g2 2
#define g3 3
#define g4 4
#define g5 5
#define g6 6
#define g7 7
#define o0 8
#define o1 9
#define o2 10
#define o3 11
#define o4 12
#define o5 13
#define o6 14
#define o7 15
#define l0 16
#define l1 17
#define l2 18
#define l3 19
#define l4 20
#define l5 21
#define l6 22
#define l7 23
#define i0 24
#define i1 25
#define i2 26
#define i3 27
#define i4 28
#define i5 29
#define i6 30
#define i7 31
#define f0 32
#define f1 33
#define f2 34
#define f3 35
#define f4 36
#define f5 37
#define f6 38
#define f7 39
#define f8 40
#define f9 41
#define f10 42
#define f11 43
#define f12 44
#define f13 45
#define f14 46
#define f15 47
#define f16 48
#define f17 49
#define f18 50
#define f19 51
#define f20 52
#define f21 53
#define f22 54
#define f23 55
#define f24 56
#define f25 57
#define f26 58
#define f27 59
#define f28 60
#define f29 61
#define f30 62
#define f31 63

baseRegOffset :: MagicId -> Int
baseRegOffset StkOReg			= OFFSET_StkO
baseRegOffset (VanillaReg _ ILIT2(1))	= OFFSET_R1
baseRegOffset (VanillaReg _ ILIT2(2))	= OFFSET_R2
baseRegOffset (VanillaReg _ ILIT2(3))	= OFFSET_R3
baseRegOffset (VanillaReg _ ILIT2(4))	= OFFSET_R4
baseRegOffset (VanillaReg _ ILIT2(5))	= OFFSET_R5
baseRegOffset (VanillaReg _ ILIT2(6))	= OFFSET_R6
baseRegOffset (VanillaReg _ ILIT2(7))	= OFFSET_R7
baseRegOffset (VanillaReg _ ILIT2(8))	= OFFSET_R8
baseRegOffset (FloatReg ILIT2(1))	= OFFSET_Flt1
baseRegOffset (FloatReg ILIT2(2))	= OFFSET_Flt2
baseRegOffset (FloatReg ILIT2(3))	= OFFSET_Flt3
baseRegOffset (FloatReg ILIT2(4))	= OFFSET_Flt4
baseRegOffset (DoubleReg ILIT2(1))	= OFFSET_Dbl1
baseRegOffset (DoubleReg ILIT2(2))	= OFFSET_Dbl2
baseRegOffset TagReg			= OFFSET_Tag
baseRegOffset RetReg			= OFFSET_Ret
baseRegOffset SpA			= OFFSET_SpA
baseRegOffset SuA			= OFFSET_SuA
baseRegOffset SpB			= OFFSET_SpB
baseRegOffset SuB			= OFFSET_SuB
baseRegOffset Hp			= OFFSET_Hp
baseRegOffset HpLim			= OFFSET_HpLim
baseRegOffset LivenessReg		= OFFSET_Liveness
baseRegOffset ActivityReg		= OFFSET_Activity
#ifdef DEBUG
baseRegOffset BaseReg			= panic "baseRegOffset:BaseReg"
baseRegOffset StdUpdRetVecReg		= panic "baseRegOffset:StgUpdRetVecReg"
baseRegOffset StkStubReg		= panic "baseRegOffset:StkStubReg"
baseRegOffset CurCostCentre		= panic "baseRegOffset:CurCostCentre"
baseRegOffset VoidReg			= panic "baseRegOffset:VoidReg"
#endif

callerSaves :: MagicId -> Bool
#ifdef CALLER_SAVES_Base
callerSaves BaseReg    	    	= True
#endif
#ifdef CALLER_SAVES_StkO
callerSaves StkOReg         	= True
#endif
#ifdef CALLER_SAVES_R1
callerSaves (VanillaReg _ ILIT2(1))	= True
#endif
#ifdef CALLER_SAVES_R2
callerSaves (VanillaReg _ ILIT2(2))    = True
#endif
#ifdef CALLER_SAVES_R3
callerSaves (VanillaReg _ ILIT2(3))    = True
#endif
#ifdef CALLER_SAVES_R4
callerSaves (VanillaReg _ ILIT2(4))    = True
#endif
#ifdef CALLER_SAVES_R5
callerSaves (VanillaReg _ ILIT2(5))    = True
#endif
#ifdef CALLER_SAVES_R6
callerSaves (VanillaReg _ ILIT2(6))    = True
#endif
#ifdef CALLER_SAVES_R7
callerSaves (VanillaReg _ ILIT2(7))	= True
#endif
#ifdef CALLER_SAVES_R8
callerSaves (VanillaReg _ ILIT2(8))    = True
#endif
#ifdef CALLER_SAVES_FltReg1
callerSaves (FloatReg ILIT2(1))   	= True
#endif
#ifdef CALLER_SAVES_FltReg2
callerSaves (FloatReg ILIT2(2))   	= True
#endif
#ifdef CALLER_SAVES_FltReg3
callerSaves (FloatReg ILIT2(3))   	= True
#endif
#ifdef CALLER_SAVES_FltReg4
callerSaves (FloatReg ILIT2(4))    	= True
#endif
#ifdef CALLER_SAVES_DblReg1
callerSaves (DoubleReg ILIT2(1))    	= True
#endif
#ifdef CALLER_SAVES_DblReg2
callerSaves (DoubleReg ILIT2(2))    	= True
#endif
#ifdef CALLER_SAVES_Tag
callerSaves TagReg      	= True
#endif
#ifdef CALLER_SAVES_Ret
callerSaves RetReg      	= True
#endif
#ifdef CALLER_SAVES_SpA
callerSaves SpA	    	    	= True
#endif
#ifdef CALLER_SAVES_SuA
callerSaves SuA	    	    	= True
#endif
#ifdef CALLER_SAVES_SpB
callerSaves SpB	    	    	= True
#endif
#ifdef CALLER_SAVES_SuB
callerSaves SuB	    	    	= True
#endif
#ifdef CALLER_SAVES_Hp
callerSaves Hp	    	    	= True
#endif
#ifdef CALLER_SAVES_HpLim
callerSaves HpLim   	    	= True
#endif
#ifdef CALLER_SAVES_Liveness
callerSaves LivenessReg	        = True
#endif
#ifdef CALLER_SAVES_Activity
callerSaves ActivityReg	        = True
#endif
#ifdef CALLER_SAVES_StdUpdRetVec
callerSaves StdUpdRetVecReg    	= True
#endif
#ifdef CALLER_SAVES_StkStub
callerSaves StkStubReg 	    	= True
#endif
callerSaves _	    	    	= False

stgRegMap :: MagicId -> Maybe Reg
#ifdef REG_Base
stgRegMap BaseReg	   = Just (FixedReg ILIT(REG_Base))
#endif
#ifdef REG_StkO
stgRegMap StkOReg   	   = Just (FixedReg ILIT(REG_StkOReg))
#endif
#ifdef REG_R1
stgRegMap (VanillaReg _ ILIT2(1)) = Just (FixedReg ILIT(REG_R1))
#endif
#ifdef REG_R2
stgRegMap (VanillaReg _ ILIT2(2)) = Just (FixedReg ILIT(REG_R2))
#endif
#ifdef REG_R3
stgRegMap (VanillaReg _ ILIT2(3)) = Just (FixedReg ILIT(REG_R3))
#endif
#ifdef REG_R4
stgRegMap (VanillaReg _ ILIT2(4)) = Just (FixedReg ILIT(REG_R4))
#endif
#ifdef REG_R5
stgRegMap (VanillaReg _ ILIT2(5)) = Just (FixedReg ILIT(REG_R5))
#endif
#ifdef REG_R6
stgRegMap (VanillaReg _ ILIT2(6)) = Just (FixedReg ILIT(REG_R6))
#endif
#ifdef REG_R7
stgRegMap (VanillaReg _ ILIT2(7)) = Just (FixedReg ILIT(REG_R7))
#endif
#ifdef REG_R8
stgRegMap (VanillaReg _ ILIT2(8)) = Just (FixedReg ILIT(REG_R8))
#endif
#ifdef REG_Flt1
stgRegMap (FloatReg ILIT2(1)) 	   = Just (FixedReg ILIT(REG_Flt1))
#endif
#ifdef REG_Flt2
stgRegMap (FloatReg ILIT2(2)) 	   = Just (FixedReg ILIT(REG_Flt2))
#endif
#ifdef REG_Flt3
stgRegMap (FloatReg ILIT2(3)) 	   = Just (FixedReg ILIT(REG_Flt3))
#endif
#ifdef REG_Flt4
stgRegMap (FloatReg ILIT2(4)) 	   = Just (FixedReg ILIT(REG_Flt4))
#endif
#ifdef REG_Dbl1
stgRegMap (DoubleReg ILIT2(1))	   = Just (FixedReg ILIT(REG_Dbl1))
#endif
#ifdef REG_Dbl2
stgRegMap (DoubleReg ILIT2(2))	   = Just (FixedReg ILIT(REG_Dbl2))
#endif
#ifdef REG_Tag
stgRegMap TagReg    	   = Just (FixedReg ILIT(REG_TagReg))
#endif
#ifdef REG_Ret
stgRegMap RetReg    	   = Just (FixedReg ILIT(REG_Ret))
#endif
#ifdef REG_SpA
stgRegMap SpA	    	   = Just (FixedReg ILIT(REG_SpA))
#endif
#ifdef REG_SuA
stgRegMap SuA	    	   = Just (FixedReg ILIT(REG_SuA))
#endif
#ifdef REG_SpB
stgRegMap SpB	    	   = Just (FixedReg ILIT(REG_SpB))
#endif
#ifdef REG_SuB
stgRegMap SuB	    	   = Just (FixedReg ILIT(REG_SuB))
#endif
#ifdef REG_Hp
stgRegMap Hp	    	   = Just (FixedReg ILIT(REG_Hp))
#endif
#ifdef REG_HpLim
stgRegMap HpLim	    	   = Just (FixedReg ILIT(REG_HpLim))
#endif
#ifdef REG_Liveness
stgRegMap LivenessReg	   = Just (FixedReg ILIT(REG_Liveness))
#endif
#ifdef REG_Activity
stgRegMap ActivityReg	   = Just (FixedReg ILIT(REG_Activity))
#endif
#ifdef REG_StdUpdRetVec
stgRegMap StdUpdRetVecReg  = Just (FixedReg ILIT(REG_StdUpdRetVec))
#endif
#ifdef REG_StkStub
stgRegMap StkStubReg	   = Just (FixedReg ILIT(REG_StkStub))
#endif
stgRegMap _		   = Nothing

\end{code}

Here is the list of registers we can use in register allocation.

\begin{code}

freeReg :: FAST_INT -> FAST_BOOL

freeReg ILIT(g0) = _FALSE_  --	%g0 is always 0.
freeReg ILIT(g5) = _FALSE_  --	%g5 is reserved (ABI).
freeReg ILIT(g6) = _FALSE_  --	%g6 is reserved (ABI).
freeReg ILIT(g7) = _FALSE_  --	%g7 is reserved (ABI).
freeReg ILIT(i6) = _FALSE_  --	%i6 is our frame pointer.
freeReg ILIT(o6) = _FALSE_  --	%o6 is our stack pointer.

#ifdef REG_Base
freeReg ILIT(REG_Base) = _FALSE_
#endif
#ifdef REG_StkO
freeReg ILIT(REG_StkO) = _FALSE_
#endif
#ifdef REG_R1
freeReg ILIT(REG_R1) = _FALSE_
#endif
#ifdef REG_R2
freeReg ILIT(REG_R2) = _FALSE_
#endif
#ifdef REG_R3
freeReg ILIT(REG_R3) = _FALSE_
#endif
#ifdef REG_R4
freeReg ILIT(REG_R4) = _FALSE_
#endif
#ifdef REG_R5
freeReg ILIT(REG_R5) = _FALSE_
#endif
#ifdef REG_R6
freeReg ILIT(REG_R6) = _FALSE_
#endif
#ifdef REG_R7
freeReg ILIT(REG_R7) = _FALSE_
#endif
#ifdef REG_R8
freeReg ILIT(REG_R8) = _FALSE_
#endif
#ifdef REG_Flt1
freeReg ILIT(REG_Flt1) = _FALSE_
#endif
#ifdef REG_Flt2
freeReg ILIT(REG_Flt2) = _FALSE_
#endif
#ifdef REG_Flt3
freeReg ILIT(REG_Flt3) = _FALSE_
#endif
#ifdef REG_Flt4
freeReg ILIT(REG_Flt4) = _FALSE_
#endif
#ifdef REG_Dbl1
freeReg ILIT(REG_Dbl1) = _FALSE_
#endif
#ifdef REG_Dbl2
freeReg ILIT(REG_Dbl2) = _FALSE_
#endif
#ifdef REG_Tag
freeReg ILIT(REG_Tag) = _FALSE_
#endif
#ifdef REG_Ret
freeReg ILIT(REG_Ret) = _FALSE_
#endif
#ifdef REG_SpA
freeReg ILIT(REG_SpA) = _FALSE_
#endif
#ifdef REG_SuA
freeReg ILIT(REG_SuA) = _FALSE_
#endif
#ifdef REG_SpB
freeReg ILIT(REG_SpB) = _FALSE_
#endif
#ifdef REG_SuB
freeReg ILIT(REG_SuB) = _FALSE_
#endif
#ifdef REG_Hp
freeReg ILIT(REG_Hp) = _FALSE_
#endif
#ifdef REG_HpLim
freeReg ILIT(REG_HpLim) = _FALSE_
#endif
#ifdef REG_Liveness
freeReg ILIT(REG_Liveness) = _FALSE_
#endif
#ifdef REG_Activity
freeReg ILIT(REG_Activity) = _FALSE_
#endif
#ifdef REG_StdUpdRetVec
freeReg ILIT(REG_StdUpdRetVec) = _FALSE_
#endif
#ifdef REG_StkStub
freeReg ILIT(REG_StkStub) = _FALSE_
#endif
freeReg n
#ifdef REG_Dbl1
  | n _EQ_ (ILIT(REG_Dbl1) _ADD_ ILIT(1)) = _FALSE_
#endif
#ifdef REG_Dbl2
  | n _EQ_ (ILIT(REG_Dbl2) _ADD_ ILIT(1)) = _FALSE_
#endif
  | otherwise = _TRUE_

reservedRegs :: [Int]
reservedRegs = [NCG_Reserved_I1, NCG_Reserved_I2,
    	    	NCG_Reserved_F1, NCG_Reserved_F2,
    	    	NCG_Reserved_D1, NCG_Reserved_D2]

\end{code}