diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs
index 6db7b790bc2ee3947a9d91aaa020a94debe74109..b9a2c8c1d181b169068724fe9f4c8cc62d2c1e2a 100644
--- a/ghc/compiler/nativeGen/AbsCStixGen.lhs
+++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs
@@ -216,9 +216,16 @@ Here we handle top-level things, like @CCodeBlock@s and
= returnUs (\xs -> table ++ xs)
where
table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
- map (\amode -> StData (getAmodeRep amode) [a2stix amode]) amodes ++
+ map do_one_amode amodes ++
[StData PtrRep (padding_wds ++ static_link)]
+ do_one_amode amode
+ = StData (promote_to_word (getAmodeRep amode)) [a2stix amode]
+
+ -- We need to promote any item smaller than a word to a word
+ promote_to_word CharRep = WordRep
+ promote_to_word other = other
+
-- always at least one padding word: this is the static link field
-- for the garbage collector.
padding_wds = if closureUpdReqd cl_info then
diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index 8e15db82754fec02947a9b965c936c88099bafbe..17f184ad6231af668765c403992fe3b078d4f0d0 100644
--- a/ghc/compiler/nativeGen/AsmCodeGen.lhs
+++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs
@@ -95,7 +95,7 @@ nativeCodeGen absC us
insn_sdoc = my_vcat insn_sdocs
stix_sdoc = vcat stix_sdocs
-# if NCG_DEBUG
+# if 1 /* ifdef NCG_DEBUG */
my_trace m x = trace m x
my_vcat sds = vcat (intersperse (char ' '
$$ ptext SLIT("# ___ncg_debug_marker")
diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
index e466f4e698b166afe6ac2da40d553d2bcd0700e9..92f395a3a075f214af978d8a5d4e407d289b121b 100644
--- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs
+++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
@@ -59,11 +59,13 @@ runRegAllocate
-> [Instr]
runRegAllocate regs find_reserve_regs instrs
- = case simpleAlloc of
+ = --trace ("runRegAllocate: " ++ show regs) (
+ case simpleAlloc of
Just simple -> --trace "SIMPLE"
simple
Nothing -> --trace "GENERAL"
(tryGeneral reserves)
+ --)
where
tryGeneral []
= error "nativeGen: spilling failed. Workaround: compile with -fvia-C.\n"
@@ -137,7 +139,8 @@ doSimpleAlloc available_real_regs instrs
(i2:ris_done) is
where
isFloatingOrReal reg
- = isRealReg reg || regClass reg == RcFloating
+ = isRealReg reg || regClass reg == RcFloat
+ || regClass reg == RcDouble
rds_l = regSetToList rds
wrs_l = regSetToList wrs
@@ -222,7 +225,7 @@ doGeneralAlloc all_regs reserve_regs instrs
++ " using "
++ showSDoc (hsep (map ppr reserve_regs))
-# ifdef NCG_DEBUG
+# if 1 /* ifdef DEBUG */
maybetrace msg x = trace msg x
# else
maybetrace msg x = x
diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index 85373b18a0da8a37d803a1a62c2e47b363484cdc..3fd6dd9dd6c8928e8cfdecd643f67a6556027201 100644
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -95,6 +95,7 @@ stmt2Instrs stmt = case stmt of
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) =
getNatLabelNCG `thenNat` \ lbl ->
@@ -128,6 +129,7 @@ derefDLL tree
StInd pk addr -> StInd pk (qq addr)
StCall who cc pk args -> StCall who cc pk (map qq args)
StInt _ -> t
+ StFloat _ -> t
StDouble _ -> t
StString _ -> t
StReg _ -> t
@@ -898,6 +900,19 @@ getRegister leaf
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#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 ->
@@ -911,33 +926,42 @@ getRegister (StDouble d)
in
returnNat (Any DoubleRep code)
+-- The 6-word scratch area is immediately below the frame pointer.
+-- Below that is the spill area.
+getRegister (StScratchWord i)
+ | i >= 0 && i < 6
+ = let j = i+1
+ code dst = unitOL (fpRelEA j dst)
+ in
+ returnNat (Any PtrRep code)
+
+
getRegister (StPrim primop [x]) -- unary PrimOps
= case primop of
- IntNegOp -> trivialUCode (SUB False False g0) x
- NotOp -> trivialUCode (XNOR False g0) x
-
- FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
+ IntNegOp -> trivialUCode (SUB False False g0) x
+ NotOp -> trivialUCode (XNOR False g0) x
- DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
+ FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
+ DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
- OrdOp -> coerceIntCode IntRep x
- ChrOp -> chrCode x
+ OrdOp -> coerceIntCode IntRep x
+ ChrOp -> chrCode x
- Float2IntOp -> coerceFP2Int x
- Int2FloatOp -> coerceInt2FP FloatRep x
- Double2IntOp -> coerceFP2Int x
- Int2DoubleOp -> coerceInt2FP DoubleRep x
+ Float2IntOp -> coerceFP2Int x
+ Int2FloatOp -> coerceInt2FP FloatRep x
+ Double2IntOp -> coerceFP2Int x
+ Int2DoubleOp -> coerceInt2FP DoubleRep x
other_op ->
let
- fixed_x = if is_float_op -- promote to double
- then StPrim Float2DoubleOp [x]
- else x
+ fixed_x = if is_float_op -- promote to double
+ then StPrim Float2DoubleOp [x]
+ else x
in
- getRegister (StCall fn cCallConv DoubleRep [x])
+ getRegister (StCall fn cCallConv DoubleRep [fixed_x])
where
(is_float_op, fn)
= case primop of
@@ -959,7 +983,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps
DoubleExpOp -> (False, SLIT("exp"))
DoubleLogOp -> (False, SLIT("log"))
- DoubleSqrtOp -> (True, SLIT("sqrt"))
+ DoubleSqrtOp -> (False, SLIT("sqrt"))
DoubleSinOp -> (False, SLIT("sin"))
DoubleCosOp -> (False, SLIT("cos"))
@@ -972,7 +996,10 @@ getRegister (StPrim primop [x]) -- unary PrimOps
DoubleSinhOp -> (False, SLIT("sinh"))
DoubleCoshOp -> (False, SLIT("cosh"))
DoubleTanhOp -> (False, SLIT("tanh"))
- _ -> panic ("Monadic PrimOp not handled: " ++ show primop)
+
+ other
+ -> pprPanic "getRegister(sparc,monadicprimop)"
+ (pprStixTree (StPrim primop [x]))
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
@@ -1046,10 +1073,16 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
- FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
+ FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
+ [promote x, promote y])
where promote x = StPrim Float2DoubleOp [x]
- DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
--- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!"
+ DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
+ [x, y])
+
+ other
+ -> pprPanic "getRegister(sparc,dyadic primop)"
+ (pprStixTree (StPrim primop [x, y]))
+
where
imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
@@ -1079,6 +1112,8 @@ getRegister leaf
OR False dst (RIImm (LO imm__2)) dst]
in
returnNat (Any PtrRep code)
+ | otherwise
+ = pprPanic "getRegister(sparc)" (pprStixTree leaf)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
@@ -2394,21 +2429,27 @@ genCCall fn cconv kind args
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
-
--- Implement this! It should be im MachRegs.lhs, not here.
-allArgRegs :: [Reg]
-allArgRegs = error "nativeGen(sparc): allArgRegs"
-
genCCall fn cconv kind args
= mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
`thenNat` \ ((unused,_), argCode) ->
let
nRegs = length allArgRegs - length unused
- call = CALL fn__2 nRegs False
+ call = unitOL (CALL fn__2 nRegs False)
code = concatOL argCode
- in
- returnNat (code `snocOL` call `snocOL` NOP)
+
+ -- 3 because in the worst case, %o0 .. %o5 will only use up 3 args
+ (move_sp_down, move_sp_up)
+ = let nn = length args - 3
+ in if nn <= 0
+ then (nilOL, nilOL)
+ else (unitOL (moveSp (-(2*nn))), unitOL (moveSp (2*nn)))
+ in
+ returnNat (move_sp_down `appOL`
+ 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
@@ -2429,6 +2470,9 @@ genCCall fn cconv kind args
offset to use for overflowing arguments. This way,
@get_arg@ can be applied to all of a call's arguments using
@mapAccumL@.
+
+ If we have to put args on the stack, move %o6==%sp down by
+ 8 x the number of args, to ensure there's enough space.
-}
get_arg
:: ([Reg],Int) -- Argument registers and stack offset (accumulator)
@@ -2453,23 +2497,27 @@ genCCall fn cconv kind args
case dsts of
[] -> ( ([], offset + 1),
code `snocOL`
- -- conveniently put the second part in the right stack
- -- location, and load the first part into %o5
- ST DF src (spRel (offset - 1)) `snocOL`
- LD W (spRel (offset - 1)) dst
+ -- put the second part in the right stack
+ -- and load the first part into %o5
+ FMOV DF src f0 `snocOL`
+ ST F f0 (spRel offset) `snocOL`
+ LD W (spRel offset) dst `snocOL`
+ ST F (fPair f0) (spRel offset)
)
(dst__2:dsts__2)
-> ( (dsts__2, offset),
- code `snocOL`
- ST DF src (spRel (-2)) `snocOL`
- LD W (spRel (-2)) dst `snocOL`
- LD W (spRel (-1)) dst__2
+ code `snocOL`
+ FMOV DF src f0 `snocOL`
+ ST F f0 (spRel 16) `snocOL`
+ LD W (spRel 16) dst `snocOL`
+ ST F (fPair f0) (spRel 16) `snocOL`
+ LD W (spRel 16) dst__2
)
FloatRep
-> ( (dsts, offset),
code `snocOL`
- ST F src (spRel (-2)) `snocOL`
- LD W (spRel (-2)) dst
+ ST F src (spRel 16) `snocOL`
+ LD W (spRel 16) dst
)
_ -> ( (dsts, offset),
if isFixed register
diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs
index b9c69e739784db179ecf0dcd38556ddb044d683b..0d39e9cd21df77b2febb80b45a8b7a877c26ba28 100644
--- a/ghc/compiler/nativeGen/MachMisc.lhs
+++ b/ghc/compiler/nativeGen/MachMisc.lhs
@@ -31,7 +31,7 @@ module MachMisc (
#if i386_TARGET_ARCH
#endif
#if sparc_TARGET_ARCH
- RI(..), riZero
+ RI(..), riZero, fpRelEA, moveSp, fPair
#endif
) where
@@ -45,6 +45,9 @@ import Literal ( mkMachInt, Literal(..) )
import MachRegs ( stgReg, callerSaves, RegLoc(..),
Imm(..), Reg(..),
MachRegsAddr(..)
+# if sparc_TARGET_ARCH
+ ,fp, sp
+# endif
)
import PrimRep ( PrimRep(..) )
import SMRep ( SMRep(..) )
@@ -52,7 +55,7 @@ import Stix ( StixTree(..), StixReg(..), CodeSegment )
import Panic ( panic )
import Char ( isDigit )
import GlaExts ( word2Int#, int2Word#, shiftRL#, and#, (/=#) )
-import Outputable ( text )
+import Outputable ( text, pprPanic, ppr )
import IOExts ( trace )
\end{code}
@@ -639,5 +642,21 @@ riZero (RIImm (ImmInteger 0)) = True
riZero (RIReg (RealReg 0)) = True
riZero _ = False
+-- Calculate the effective address which would be used by the
+-- corresponding fpRel sequence. fpRel is in MachRegs.lhs,
+-- alas -- can't have fpRelEA here because of module dependencies.
+fpRelEA :: Int -> Reg -> Instr
+fpRelEA n dst
+ = ADD False False fp (RIImm (ImmInt (n * BYTES_PER_WORD))) dst
+
+-- Code to shift the stack pointer by n words.
+moveSp :: Int -> Instr
+moveSp n
+ = ADD False False sp (RIImm (ImmInt (n * BYTES_PER_WORD))) sp
+
+-- Produce the second-half-of-a-double register given the first half.
+fPair :: Reg -> Reg
+fPair (RealReg n) | n >= 32 && n `mod` 2 == 0 = RealReg (n+1)
+fPair other = pprPanic "fPair(sparc NCG)" (ppr other)
#endif {- sparc_TARGET_ARCH -}
\end{code}
diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs
index cb8006a47ae486c13292dfef49a42e9e1d41ae3f..fba477fb1b4ef8d5d0a063008c7871b8b0864c8a 100644
--- a/ghc/compiler/nativeGen/MachRegs.lhs
+++ b/ghc/compiler/nativeGen/MachRegs.lhs
@@ -16,7 +16,7 @@ module MachRegs (
RegClass(..), regClass,
Reg(..), isRealReg, isVirtualReg,
- allocatableRegs,
+ allocatableRegs, argRegs, allArgRegs, callClobberedRegs,
Imm(..),
MachRegsAddr(..),
@@ -47,7 +47,7 @@ module MachRegs (
#if sparc_TARGET_ARCH
, fits13Bits
, fpRel, gReg, iReg, lReg, oReg, largeOffsetError
- , fp, g0, o0, f0
+ , fp, sp, g0, g1, g2, o0, f0, f6, f8, f26, f27
#endif
) where
@@ -76,6 +76,7 @@ data Imm
-- Bool==True ==> in a different DLL
| ImmLit SDoc -- Simple string
| ImmIndex CLabel Int
+ | ImmFloat Rational
| ImmDouble Rational
IF_ARCH_sparc(
| LO Imm -- Possible restrictions...
@@ -150,13 +151,8 @@ fits8Bits i = i >= -256 && i < 256
#endif
#if sparc_TARGET_ARCH
-{-# SPECIALIZE
- fits13Bits :: Int -> Bool
- #-}
-{-# SPECIALIZE
- fits13Bits :: Integer -> Bool
- #-}
+{-# SPECIALIZE fits13Bits :: Int -> Bool, Integer -> Bool #-}
fits13Bits :: Integral a => a -> Bool
fits13Bits x = x >= -4096 && x < 4096
@@ -261,50 +257,74 @@ Virtual regs can be of either class, so that info is attached.
data RegClass
= RcInteger
- | RcFloating
+ | RcFloat
+ | RcDouble
deriving Eq
data Reg
= RealReg Int
| VirtualRegI Unique
| VirtualRegF Unique
+ | VirtualRegD Unique
+
+unRealReg (RealReg i) = i
+unRealReg vreg = pprPanic "unRealReg on VirtualReg" (ppr vreg)
mkVReg :: Unique -> PrimRep -> Reg
mkVReg u pk
- = if isFloatingRep pk then VirtualRegF u else VirtualRegI u
+#if sparc_TARGET_ARCH
+ = case pk of
+ FloatRep -> VirtualRegF u
+ DoubleRep -> VirtualRegD u
+ other -> VirtualRegI u
+#else
+ = if isFloatingRep pk then VirtualRegD u else VirtualRegI u
+#endif
isVirtualReg (RealReg _) = False
isVirtualReg (VirtualRegI _) = True
isVirtualReg (VirtualRegF _) = True
+isVirtualReg (VirtualRegD _) = True
isRealReg = not . isVirtualReg
getNewRegNCG :: PrimRep -> NatM Reg
getNewRegNCG pk
- = if isFloatingRep pk
- then getUniqueNat `thenNat` \ u -> returnNat (VirtualRegF u)
- else getUniqueNat `thenNat` \ u -> returnNat (VirtualRegI u)
+ = getUniqueNat `thenNat` \ u -> returnNat (mkVReg u pk)
instance Eq Reg where
(==) (RealReg i1) (RealReg i2) = i1 == i2
(==) (VirtualRegI u1) (VirtualRegI u2) = u1 == u2
(==) (VirtualRegF u1) (VirtualRegF u2) = u1 == u2
+ (==) (VirtualRegD u1) (VirtualRegD u2) = u1 == u2
(==) reg1 reg2 = False
instance Ord Reg where
compare (RealReg i1) (RealReg i2) = compare i1 i2
compare (RealReg _) (VirtualRegI _) = LT
compare (RealReg _) (VirtualRegF _) = LT
+ compare (RealReg _) (VirtualRegD _) = LT
+
compare (VirtualRegI _) (RealReg _) = GT
compare (VirtualRegI u1) (VirtualRegI u2) = compare u1 u2
compare (VirtualRegI _) (VirtualRegF _) = LT
+ compare (VirtualRegI _) (VirtualRegD _) = LT
+
compare (VirtualRegF _) (RealReg _) = GT
compare (VirtualRegF _) (VirtualRegI _) = GT
compare (VirtualRegF u1) (VirtualRegF u2) = compare u1 u2
+ compare (VirtualRegF _) (VirtualRegD _) = LT
+
+ compare (VirtualRegD _) (RealReg _) = GT
+ compare (VirtualRegD _) (VirtualRegI _) = GT
+ compare (VirtualRegD _) (VirtualRegF _) = GT
+ compare (VirtualRegD u1) (VirtualRegD u2) = compare u1 u2
+
instance Show Reg where
showsPrec _ (RealReg i) = showString (showReg i)
showsPrec _ (VirtualRegI u) = showString "%vI_" . shows u
showsPrec _ (VirtualRegF u) = showString "%vF_" . shows u
+ showsPrec _ (VirtualRegD u) = showString "%vD_" . shows u
instance Outputable Reg where
ppr r = text (show r)
@@ -313,6 +333,7 @@ instance Uniquable Reg where
getUnique (RealReg i) = mkPseudoUnique2 i
getUnique (VirtualRegI u) = u
getUnique (VirtualRegF u) = u
+ getUnique (VirtualRegD u) = u
\end{code}
** Machine-specific Reg stuff: **
@@ -371,9 +392,10 @@ fake3 = RealReg 11
fake4 = RealReg 12
fake5 = RealReg 13
-regClass (RealReg i) = if i < 8 then RcInteger else RcFloating
+regClass (RealReg i) = if i < 8 then RcInteger else RcDouble
regClass (VirtualRegI u) = RcInteger
-regClass (VirtualRegF u) = RcFloating
+regClass (VirtualRegF u) = RcFloat
+regClass (VirtualRegD u) = RcDouble
regNames
= ["%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "%ebp", "%esp",
@@ -391,9 +413,11 @@ showReg n
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. When (if?) the sparc nativegen is
-ever revived, we should just treat it as if it has 16 floating
-regs, and use them in pairs.
+prepared for any eventuality.
+
+The whole fp-register pairing thing on sparcs is a huge nuisance. See
+fptools/ghc/includes/MachRegs.h for a description of what's going on
+here.
\begin{code}
#if sparc_TARGET_ARCH
@@ -405,24 +429,45 @@ lReg x = (16 + x)
iReg x = (24 + x)
fReg x = (32 + x)
--- CHECK THIS
-regClass (RealReg i) = if i < 32 then RcInteger else RcFloating
+nCG_FirstFloatReg :: Int
+nCG_FirstFloatReg = unRealReg NCG_FirstFloatReg
+
regClass (VirtualRegI u) = RcInteger
-regClass (VirtualRegF u) = RcFloating
+regClass (VirtualRegF u) = RcFloat
+regClass (VirtualRegD u) = RcDouble
+regClass (RealReg i) | i < 32 = RcInteger
+ | i < nCG_FirstFloatReg = RcDouble
+ | otherwise = RcFloat
--- FIX THIS
showReg :: Int -> String
showReg n
- = if n >= 0 && n < 64
- then "%sparc_real_reg_" ++ show n
- else "%unknown_sparc_real_reg_" ++ show n
+ | n >= 0 && n < 8 = "%g" ++ show n
+ | n >= 8 && n < 16 = "%o" ++ show (n-8)
+ | n >= 16 && n < 24 = "%l" ++ show (n-16)
+ | n >= 24 && n < 32 = "%i" ++ show (n-24)
+ | n >= 32 && n < 64 = "%f" ++ show (n-32)
+ | otherwise = "%unknown_sparc_real_reg_" ++ show n
+
+g0, g1, g2, fp, sp, o0, f0, f1, f6, f8, f22, f26, f27 :: Reg
+
+f6 = RealReg (fReg 6)
+f8 = RealReg (fReg 8)
+f22 = RealReg (fReg 22)
+f26 = RealReg (fReg 26)
+f27 = RealReg (fReg 27)
-g0, fp, sp, o0, f0 :: Reg
-g0 = RealReg (gReg 0)
-fp = RealReg (iReg 6)
-sp = RealReg (oReg 6)
-o0 = RealReg (oReg 0)
-f0 = RealReg (fReg 0)
+
+-- g0 is useful for codegen; is always zero, and writes to it vanish.
+g0 = RealReg (gReg 0)
+g1 = RealReg (gReg 1)
+g2 = RealReg (gReg 2)
+
+-- FP, SP, int and float return (from C) regs.
+fp = RealReg (iReg 6)
+sp = RealReg (oReg 6)
+o0 = RealReg (oReg 0)
+f0 = RealReg (fReg 0)
+f1 = RealReg (fReg 1)
#endif
\end{code}
@@ -513,16 +558,17 @@ names in the header files. Gag me with a spoon, eh?
#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 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
@@ -545,6 +591,7 @@ names in the header files. Gag me with a spoon, eh?
#define f29 61
#define f30 62
#define f31 63
+
#endif
\end{code}
@@ -748,19 +795,15 @@ magicIdRegMaybe _ = Nothing
\begin{code}
-------------------------------
-#if 0
-freeRegs :: [Reg]
-freeRegs
- = freeMappedRegs IF_ARCH_alpha( [0..63],
- IF_ARCH_i386( [0..13],
- IF_ARCH_sparc( [0..63],)))
-#endif
-- allMachRegs is the complete set of machine regs.
allMachRegNos :: [Int]
allMachRegNos
= IF_ARCH_alpha( [0..63],
IF_ARCH_i386( [0..13],
- IF_ARCH_sparc( [0..63],)))
+ IF_ARCH_sparc( ([0..31]
+ ++ [f0,f2 .. nCG_FirstFloatReg-1]
+ ++ [nCG_FirstFloatReg .. f31]),
+ )))
-- allocatableRegs is allMachRegNos with the fixed-use regs removed.
allocatableRegs :: [Reg]
allocatableRegs
@@ -769,10 +812,9 @@ allocatableRegs
-------------------------------
-#if 0
callClobberedRegs :: [Reg]
callClobberedRegs
- = freeMappedRegs
+ =
#if alpha_TARGET_ARCH
[0, 1, 2, 3, 4, 5, 6, 7, 8,
16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
@@ -781,58 +823,67 @@ callClobberedRegs
fReg 24, fReg 25, fReg 26, fReg 27, fReg 28, fReg 29, fReg 30]
#endif {- alpha_TARGET_ARCH -}
#if i386_TARGET_ARCH
- [{-none-}]
+ -- caller-saves registers
+ [eax,ecx,edx,fake0,fake1,fake2,fake3,fake4,fake5]
#endif {- i386_TARGET_ARCH -}
#if sparc_TARGET_ARCH
- ( oReg 7 :
- [oReg i | i <- [0..5]] ++
- [gReg i | i <- [1..7]] ++
- [fReg i | i <- [0..31]] )
+ map RealReg
+ ( oReg 7 :
+ [oReg i | i <- [0..5]] ++
+ [gReg i | i <- [1..7]] ++
+ [fReg i | i <- [0..31]] )
#endif {- sparc_TARGET_ARCH -}
-#endif
-------------------------------
-#if 0
+-- argRegs is the set of regs which are read for an n-argument call to C.
+-- For archs which pass all args on the stack (x86), is empty.
+-- Sparc passes up to the first 6 args in regs.
+-- Dunno about Alpha.
argRegs :: Int -> [Reg]
-argRegs 0 = []
#if i386_TARGET_ARCH
-argRegs _ = panic "MachRegs.argRegs: doesn't work on I386"
-#else
+argRegs _ = panic "MachRegs.argRegs(x86): should not be used!"
+#endif
+
#if alpha_TARGET_ARCH
+argRegs 0 = []
argRegs 1 = freeMappedRegs [16, fReg 16]
argRegs 2 = freeMappedRegs [16, 17, fReg 16, fReg 17]
argRegs 3 = freeMappedRegs [16, 17, 18, fReg 16, fReg 17, fReg 18]
argRegs 4 = freeMappedRegs [16, 17, 18, 19, fReg 16, fReg 17, fReg 18, fReg 19]
argRegs 5 = freeMappedRegs [16, 17, 18, 19, 20, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20]
argRegs 6 = freeMappedRegs [16, 17, 18, 19, 20, 21, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21]
+argRegs _ = panic "MachRegs.argRegs(alpha): don't know about >6 arguments!"
#endif {- alpha_TARGET_ARCH -}
+
#if sparc_TARGET_ARCH
-argRegs 1 = freeMappedRegs (map oReg [0])
-argRegs 2 = freeMappedRegs (map oReg [0,1])
-argRegs 3 = freeMappedRegs (map oReg [0,1,2])
-argRegs 4 = freeMappedRegs (map oReg [0,1,2,3])
-argRegs 5 = freeMappedRegs (map oReg [0,1,2,3,4])
-argRegs 6 = freeMappedRegs (map oReg [0,1,2,3,4,5])
+argRegs 0 = []
+argRegs 1 = map (RealReg . oReg) [0]
+argRegs 2 = map (RealReg . oReg) [0,1]
+argRegs 3 = map (RealReg . oReg) [0,1,2]
+argRegs 4 = map (RealReg . oReg) [0,1,2,3]
+argRegs 5 = map (RealReg . oReg) [0,1,2,3,4]
+argRegs 6 = map (RealReg . oReg) [0,1,2,3,4,5]
+argRegs _ = panic "MachRegs.argRegs(sparc): don't know about >6 arguments!"
#endif {- sparc_TARGET_ARCH -}
-argRegs _ = panic "MachRegs.argRegs: don't know about >6 arguments!"
-#endif {- i386_TARGET_ARCH -}
-#endif
--------------------------------
-#if 0
+
+-------------------------------
+-- all of the arg regs ??
#if alpha_TARGET_ARCH
allArgRegs :: [(Reg, Reg)]
-
allArgRegs = [(realReg i, realReg (fReg i)) | i <- [16..21]]
#endif {- alpha_TARGET_ARCH -}
#if sparc_TARGET_ARCH
allArgRegs :: [Reg]
-
-allArgRegs = map realReg [oReg i | i <- [0..5]]
+allArgRegs = map RealReg [oReg i | i <- [0..5]]
#endif {- sparc_TARGET_ARCH -}
+
+#if linux_TARGET_ARCH
+allArgRegs :: [Reg]
+allArgRegs = panic "MachRegs.allArgRegs(x86): should not be used!"
#endif
\end{code}
@@ -859,6 +910,8 @@ 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.
+freeReg ILIT(f0) = _FALSE_ -- %f0/%f1 are the C fp return registers.
+freeReg ILIT(f1) = _FALSE_
#endif
#ifdef REG_Base
@@ -921,15 +974,5 @@ freeReg ILIT(REG_Hp) = _FALSE_
#ifdef REG_HpLim
freeReg ILIT(REG_HpLim) = _FALSE_
#endif
-freeReg n
- -- we hang onto two double regs for dedicated
- -- use; this is not necessary on Alphas and
- -- may not be on other non-SPARCs.
-#ifdef REG_D1
- | n _EQ_ (ILIT(REG_D1) _ADD_ ILIT(1)) = _FALSE_
-#endif
-#ifdef REG_D2
- | n _EQ_ (ILIT(REG_D2) _ADD_ ILIT(1)) = _FALSE_
-#endif
- | otherwise = _TRUE_
+freeReg n = _TRUE_
\end{code}
diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
index af8c5b30f0f4c0544bd841581dbbe46e188e2e60..820a6390b52b6e3f8474a530241e097d4fb77964 100644
--- a/ghc/compiler/nativeGen/PprMach.lhs
+++ b/ghc/compiler/nativeGen/PprMach.lhs
@@ -26,7 +26,7 @@ import Outputable
import ST
import MutableArray
-import Char ( ord )
+import Char ( chr, ord )
\end{code}
%************************************************************************
@@ -377,14 +377,14 @@ pprInstr (DELTA d)
pprInstr (SEGMENT TextSegment)
= IF_ARCH_alpha(ptext SLIT("\t.text\n\t.align 3") {-word boundary-}
- ,IF_ARCH_sparc(ptext SLIT("\t.text\n\t.align 4") {-word boundary-}
+ ,IF_ARCH_sparc(ptext SLIT(".text\n\t.align 4") {-word boundary-}
,IF_ARCH_i386((text ".text\n\t.align 4,0x90") {-needs per-OS variation!-}
,)))
pprInstr (SEGMENT DataSegment)
= ptext
IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
- ,IF_ARCH_sparc(SLIT("\t.data\n\t.align 8") {-<8 will break double constants -}
+ ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
,IF_ARCH_i386(SLIT(".data\n\t.align 4")
,)))
@@ -399,7 +399,7 @@ pprInstr (LABEL clab)
hcat [ptext
IF_ARCH_alpha(SLIT("\t.globl\t")
,IF_ARCH_i386(SLIT(".globl ")
- ,IF_ARCH_sparc(SLIT("\t.global\t")
+ ,IF_ARCH_sparc(SLIT(".global\t")
,)))
, pp_lab, char '\n'],
pp_lab,
@@ -410,6 +410,9 @@ pprInstr (ASCII False{-no backslash conversion-} str)
= hcat [ ptext SLIT("\t.asciz "), char '\"', text str, char '"' ]
pprInstr (ASCII True str)
+#if 0
+ -- The Solaris assembler doesn't understand \x escapes in
+ -- strings.
= asciify str
where
asciify :: String -> SDoc
@@ -423,47 +426,51 @@ pprInstr (ASCII True str)
in this $$ asciify rest
asciify_char :: Char -> String
asciify_char c = '\\' : 'x' : hshow (ord c)
+#endif
+ = vcat (map do1 (str ++ [chr 0]))
+ where
+ do1 :: Char -> SDoc
+ do1 c = text "\t.byte\t0x" <> text (hshow (ord c))
- hshow :: Int -> String
- hshow n | n >= 0 && n <= 255
- = [ tab !! (n `div` 16), tab !! (n `mod` 16)]
- tab = "0123456789abcdef"
-
+ hshow :: Int -> String
+ hshow n | n >= 0 && n <= 255
+ = [ tab !! (n `div` 16), tab !! (n `mod` 16)]
+ tab = "0123456789ABCDEF"
pprInstr (DATA s xs)
= vcat (concatMap (ppr_item s) xs)
where
+
#if alpha_TARGET_ARCH
ppr_item = error "ppr_item on Alpha"
-#if 0
- This needs to be fixed.
- B -> SLIT("\t.byte\t")
- BU -> SLIT("\t.byte\t")
- Q -> SLIT("\t.quad\t")
- TF -> SLIT("\t.t_floating\t")
-#endif
#endif
#if sparc_TARGET_ARCH
- ppr_item = error "ppr_item on Sparc"
-#if 0
- This needs to be fixed.
- B -> SLIT("\t.byte\t")
- BU -> SLIT("\t.byte\t")
- W -> SLIT("\t.word\t")
- DF -> SLIT("\t.double\t")
-#endif
+ -- copy n paste of x86 version
+ ppr_item B x = [text "\t.byte\t" <> pprImm x]
+ ppr_item W x = [text "\t.long\t" <> pprImm x]
+ ppr_item F (ImmFloat r)
+ = let bs = floatToBytes (fromRational r)
+ in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+ ppr_item DF (ImmDouble r)
+ = let bs = doubleToBytes (fromRational r)
+ in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
#endif
#if i386_TARGET_ARCH
ppr_item B x = [text "\t.byte\t" <> pprImm x]
ppr_item L x = [text "\t.long\t" <> pprImm x]
- ppr_item F (ImmDouble r)
+ ppr_item F (ImmFloat r)
= let bs = floatToBytes (fromRational r)
in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
ppr_item DF (ImmDouble r)
= let bs = doubleToBytes (fromRational r)
in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+#endif
+ -- floatToBytes and doubleToBytes convert to the host's byte
+ -- order. Providing that we're not cross-compiling for a
+ -- target with the opposite endianness, this should work ok
+ -- on all targets.
floatToBytes :: Float -> [Int]
floatToBytes f
= runST (do
@@ -492,8 +499,6 @@ pprInstr (DATA s xs)
return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])
)
-#endif
-
-- fall through to rest of (machine-specific) pprInstr...
\end{code}
@@ -1345,61 +1350,69 @@ pprCondInstr name cond arg
-- reads (bytearrays).
--
+-- Translate to the following:
+-- add g1,g2,g1
+-- ld [g1],%fn
+-- ld [g1+4],%f(n+1)
+-- sub g1,g2,g1 -- to restore g1
pprInstr (LD DF (AddrRegReg g1 g2) reg)
- = hcat [
- ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1, char '\n',
- pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg, char '\n',
- pp_ld_lbracket, pprReg g1, ptext SLIT("+4]"), comma, pprReg (fPair reg)
+ = vcat [
+ hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
+ hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
+ hcat [pp_ld_lbracket, pprReg g1, ptext SLIT("+4]"), comma, pprReg (fPair reg)],
+ hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
]
+-- Translate to
+-- ld [addr],%fn
+-- ld [addr+4],%f(n+1)
pprInstr (LD DF addr reg) | maybeToBool off_addr
- = hcat [
- pp_ld_lbracket,
- pprAddr addr,
- pp_rbracket_comma,
- pprReg reg,
-
- char '\n',
- pp_ld_lbracket,
- pprAddr addr2,
- pp_rbracket_comma,
- pprReg (fPair reg)
+ = vcat [
+ hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
+ hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)]
]
where
off_addr = addrOffset addr 4
addr2 = case off_addr of Just x -> x
+
pprInstr (LD size addr reg)
= hcat [
- ptext SLIT("\tld"),
- pprSize size,
- char '\t',
- lbrack,
- pprAddr addr,
- pp_rbracket_comma,
- pprReg reg
+ ptext SLIT("\tld"),
+ pprSize size,
+ char '\t',
+ lbrack,
+ pprAddr addr,
+ pp_rbracket_comma,
+ pprReg reg
]
-- The same clumsy hack as above
+-- Translate to the following:
+-- add g1,g2,g1
+-- st %fn,[g1]
+-- st %f(n+1),[g1+4]
+-- sub g1,g2,g1 -- to restore g1
pprInstr (ST DF reg (AddrRegReg g1 g2))
- = hcat [
- ptext SLIT("\tadd\t"),
- pprReg g1,comma,pprReg g2,comma,pprReg g1, char '\n',
- ptext SLIT("\tst\t"),
- pprReg reg, pp_comma_lbracket, pprReg g1,
- ptext SLIT("]\n\tst\t"),
- pprReg (fPair reg), pp_comma_lbracket, pprReg g1, ptext SLIT("+4]")
+ = vcat [
+ hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
+ hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
+ pprReg g1, rbrack],
+ hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
+ pprReg g1, ptext SLIT("+4]")],
+ hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
]
+-- Translate to
+-- st %fn,[addr]
+-- st %f(n+1),[addr+4]
pprInstr (ST DF reg addr) | maybeToBool off_addr
- = hcat [
- ptext SLIT("\tst\t"),
- pprReg reg, pp_comma_lbracket, pprAddr addr,
-
- ptext SLIT("]\n\tst\t"),
- pprReg (fPair reg), pp_comma_lbracket,
- pprAddr addr2, rbrack
+ = vcat [
+ hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
+ pprAddr addr, rbrack],
+ hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
+ pprAddr addr2, rbrack]
]
where
off_addr = addrOffset addr 4
@@ -1411,13 +1424,13 @@ pprInstr (ST DF reg addr) | maybeToBool off_addr
pprInstr (ST size reg addr)
= hcat [
- ptext SLIT("\tst"),
- pprStSize size,
- char '\t',
- pprReg reg,
- pp_comma_lbracket,
- pprAddr addr,
- rbrack
+ ptext SLIT("\tst"),
+ pprStSize size,
+ char '\t',
+ pprReg reg,
+ pp_comma_lbracket,
+ pprAddr addr,
+ rbrack
]
pprInstr (ADD x cc reg1 ri reg2)
@@ -1536,11 +1549,6 @@ pprInstr (CALL imm n _)
Continue with SPARC-only printing bits and bobs:
\begin{code}
--- Get rid of this fPair nonsense, don't reimplement it. It's an
--- entirely unnecessary complication. I just put this here so it will
--- at least compile on Sparcs. JRS, 000616.
-fPair = error "nativeGen(sparc): unimp fPair"
-
pprRI :: RI -> SDoc
pprRI (RIReg r) = pprReg r
pprRI (RIImm r) = pprImm r
diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs
index 1013252337816c6926fddb474b8fb1f566635936..a401f852feb9b2d6d6bada5b9c6ee23ef5e69182 100644
--- a/ghc/compiler/nativeGen/RegAllocInfo.lhs
+++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs
@@ -150,6 +150,7 @@ regUsage :: Instr -> RegUsage
interesting (VirtualRegI _) = True
interesting (VirtualRegF _) = True
+interesting (VirtualRegD _) = True
interesting (RealReg (I# i)) = _IS_TRUE_(freeReg i)
#if alpha_TARGET_ARCH
@@ -313,9 +314,6 @@ regUsage instr = case instr of
usageM (OpReg reg) = mkRU [reg] [reg]
usageM (OpAddr ea) = mkRU (use_EA ea) []
- -- caller-saves registers
- callClobberedRegs = [eax,ecx,edx,fake0,fake1,fake2,fake3,fake4,fake5]
-
-- Registers defd when an operand is written.
def_W (OpReg reg) = [reg]
def_W (OpAddr ea) = []
@@ -348,38 +346,36 @@ hasFixedEDX instr
#if sparc_TARGET_ARCH
regUsage 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])
+ 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])
+ 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])
+ 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 -> noUsage
+ JMP addr -> usage (regAddr addr, [])
- -- I don't understand this terminal vs non-terminal distinction for
- -- CALLs is. Fix. JRS, 000616.
- CALL _ n True -> error "nativeGen(sparc): unimp regUsage CALL"
- CALL _ n False -> error "nativeGen(sparc): unimp regUsage CALL"
+ CALL _ n True -> noUsage
+ CALL _ n False -> usage (argRegs n, callClobberedRegs)
_ -> noUsage
where
@@ -439,10 +435,9 @@ findReservedRegs instrs
error "findReservedRegs: alpha"
#endif
#if sparc_TARGET_ARCH
- = --[[NCG_Reserved_I1, NCG_Reserved_I2,
- -- NCG_Reserved_F1, NCG_Reserved_F2,
- -- NCG_Reserved_D1, NCG_Reserved_D2]]
- error "findReservedRegs: sparc"
+ = [[NCG_SpillTmp_I1, NCG_SpillTmp_I2,
+ NCG_SpillTmp_D1, NCG_SpillTmp_D2,
+ NCG_SpillTmp_F1, NCG_SpillTmp_F2]]
#endif
#if i386_TARGET_ARCH
-- We can use %fake4 and %fake5 safely for float temps.
@@ -535,9 +530,20 @@ insnFuture insn
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
- -- We assume that all local jumps will be BI/BF. JMP must be out-of-line.
+ -- We assume that all local jumps will be BI/BF.
+ BI ALWAYS _ (ImmCLbl clbl) -> Branch clbl
+ BI other _ (ImmCLbl clbl) -> NextOrBranch clbl
+ BI other _ _ -> panic "nativeGen(sparc):insnFuture(BI)"
+
+ BF ALWAYS _ (ImmCLbl clbl) -> Branch clbl
+ BF other _ (ImmCLbl clbl) -> NextOrBranch clbl
+ BF other _ _ -> panic "nativeGen(sparc):insnFuture(BF)"
+
+ -- JMP and CALL(terminal) must be out-of-line.
+ JMP _ -> NoFuture
+ CALL _ _ True -> NoFuture
- boring -> error "nativeGen(sparc): unimp insnFuture"
+ boring -> Next
#endif {- sparc_TARGET_ARCH -}
\end{code}
@@ -752,8 +758,11 @@ StixInteger) use this as a temp location. Leave 8 words (ie, 64 bytes
for a 64-bit arch) of slop.
\begin{code}
+spillSlotSize :: Int
+spillSlotSize = IF_ARCH_alpha( 8, IF_ARCH_sparc( 8, IF_ARCH_i386( 12, )))
+
maxSpillSlots :: Int
-maxSpillSlots = (rESERVED_C_STACK_BYTES - 64) `div` 12
+maxSpillSlots = ((rESERVED_C_STACK_BYTES - 64) `div` spillSlotSize) - 1
-- convert a spill slot number to a *byte* offset, with no sign:
-- decide on a per arch basis whether you are spilling above or below
@@ -761,7 +770,7 @@ maxSpillSlots = (rESERVED_C_STACK_BYTES - 64) `div` 12
spillSlotToOffset :: Int -> Int
spillSlotToOffset slot
| slot >= 0 && slot < maxSpillSlots
- = 64 + 12 * slot
+ = 64 + spillSlotSize * slot
| otherwise
= pprPanic "spillSlotToOffset:"
(text "invalid spill location: " <> int slot)
@@ -791,8 +800,13 @@ spillReg vreg_to_slot_map delta dyn vreg
else MOV L (OpReg dyn) (OpAddr (spRel off_w))
{-SPARC: spill below frame pointer leaving 2 words/spill-}
- ,IF_ARCH_sparc( ST (error "get sz from regClass vreg")
- dyn (fpRel (- (off `div` 4)))
+ ,IF_ARCH_sparc(
+ let off_w = 1 + (off `div` 4)
+ sz = case regClass vreg of
+ RcInteger -> W
+ RcFloat -> F
+ RcDouble -> DF
+ in ST sz dyn (fpRel (- off_w))
,)))
@@ -802,12 +816,19 @@ loadReg vreg_to_slot_map delta vreg dyn
off = spillSlotToOffset slot_no
in
IF_ARCH_alpha( LD sz dyn (spRel (- (off `div` 8)))
+
,IF_ARCH_i386 ( let off_w = (off-delta) `div` 4
in
if regClass vreg == RcFloating
then GLD F80 (spRel off_w) dyn
else MOV L (OpAddr (spRel off_w)) (OpReg dyn)
- ,IF_ARCH_sparc( LD (error "get sz from regClass vreg")
- (fpRel (- (off `div` 4))) dyn
- ,)))
+
+ ,IF_ARCH_sparc(
+ let off_w = 1 + (off `div` 4)
+ sz = case regClass vreg of
+ RcInteger -> W
+ RcFloat -> F
+ RcDouble -> DF
+ in LD sz (fpRel (- off_w)) dyn
+ ,)))
\end{code}
diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs
index dfb2ba6aec9e2e083cef914d0db46ea0a53bd45c..e90a6d6add69375f888310fbb1252f6106b5ee32 100644
--- a/ghc/compiler/nativeGen/Stix.lhs
+++ b/ghc/compiler/nativeGen/Stix.lhs
@@ -53,6 +53,7 @@ data StixTree
-- We can tag the leaves with constants/immediates.
| StInt Integer -- ** add Kind at some point
+ | StFloat Rational
| StDouble Rational
| StString FAST_STRING
| StCLbl CLabel -- labels that we might index into
@@ -136,6 +137,7 @@ pprStixTree t
= case t of
StSegment cseg -> paren (ppCodeSegment cseg)
StInt i -> paren (integer i)
+ StFloat rat -> paren (text "Float" <+> rational rat)
StDouble rat -> paren (text "Double" <+> rational rat)
StString str -> paren (text "Str" <+> ptext str)
StComment str -> paren (text "Comment" <+> ptext str)
@@ -268,6 +270,7 @@ stixCountTempUses u t
StSegment _ -> 0
StInt _ -> 0
+ StFloat _ -> 0
StDouble _ -> 0
StString _ -> 0
StCLbl _ -> 0
@@ -311,6 +314,7 @@ stixMapUniques f t
StSegment _ -> t
StInt _ -> t
+ StFloat _ -> t
StDouble _ -> t
StString _ -> t
StCLbl _ -> t
diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index 1de49fc7b4fde625a2bd6c20823a427284307441..7576dd80757b833568dbde243667f8d251260dc8 100644
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -270,7 +270,10 @@ primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs
[] -> StCall fn cconv VoidRep args
[lhs] ->
let lhs' = amodeToStix lhs
- pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
+ pk = case getAmodeRep lhs of
+ FloatRep -> FloatRep
+ DoubleRep -> DoubleRep
+ other -> IntRep
in
StAssign pk lhs' (StCall fn cconv pk args)
\end{code}
@@ -432,7 +435,7 @@ amodeToStix (CLit core)
MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
MachLitLit s _ -> litLitErr
MachLabel l -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
- MachFloat d -> StDouble d
+ MachFloat d -> StFloat d
MachDouble d -> StDouble d
_ -> panic "amodeToStix:core literal"
diff --git a/ghc/includes/MachRegs.h b/ghc/includes/MachRegs.h
index 3a57495dd7518f8eaf9ab9b4cd4e8a2ee2abbdf5..c3a3ce38aea19ccb97fdc9ebeccefc3ae21ae655 100644
--- a/ghc/includes/MachRegs.h
+++ b/ghc/includes/MachRegs.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: MachRegs.h,v 1.8 2000/04/14 15:10:20 sewardj Exp $
+ * $Id: MachRegs.h,v 1.9 2000/07/11 15:26:33 sewardj Exp $
*
* (c) The GHC Team, 1998-1999
*
@@ -414,6 +414,37 @@
Note: %g3 is *definitely* clobbered in the builtin divide code (and
our save/restore machinery is NOT GOOD ENOUGH for that); discretion
being the better part of valor, we also don't take %g4.
+
+ The paired nature of the floating point registers causes complications for
+ the native code genertor. For convenience, we pretend that the first 22
+ fp regs %f0 .. %f21 are actually 11 double regs, and the remaining 10 are
+ float (single) regs. The NCG acts accordingly. That means that the
+ following FP assignment is rather fragile, and should only be changed
+ with extreme care. The current scheme is:
+
+ %f0 /%f1 FP return from C
+ %f2 /%f3 D1
+ %f4 /%f5 D2
+ %f6 /%f7 ncg double spill tmp #1
+ %f8 /%f9 ncg double spill tmp #2
+ %f10/%f11 allocatable
+ %f12/%f13 allocatable
+ %f14/%f15 allocatable
+ %f16/%f17 allocatable
+ %f18/%f19 allocatable
+ %f20/%f21 allocatable
+
+ %f22 F1
+ %f23 F2
+ %f24 F3
+ %f25 F4
+ %f26 ncg single spill tmp #1
+ %f27 ncg single spill tmp #2
+ %f28 allocatable
+ %f29 allocatable
+ %f30 allocatable
+ %f31 allocatable
+
-------------------------------------------------------------------------- */
#if sparc_TARGET_ARCH
@@ -438,12 +469,12 @@
#define REG_R7 l7
#define REG_R8 i5
-#define REG_F1 f2
-#define REG_F2 f3
-#define REG_F3 f4
-#define REG_F4 f5
-#define REG_D1 f6
-#define REG_D2 f8
+#define REG_F1 f22
+#define REG_F2 f23
+#define REG_F3 f24
+#define REG_F4 f25
+#define REG_D1 f2
+#define REG_D2 f4
#define REG_Sp i0
#define REG_Su i1
@@ -452,12 +483,14 @@
#define REG_Hp i3
#define REG_HpLim i4
-#define NCG_Reserved_I1 g1
-#define NCG_Reserved_I2 g2
-#define NCG_Reserved_F1 f14
-#define NCG_Reserved_F2 f15
-#define NCG_Reserved_D1 f16
-#define NCG_Reserved_D2 f18
+#define NCG_SpillTmp_I1 g1
+#define NCG_SpillTmp_I2 g2
+#define NCG_SpillTmp_F1 f26
+#define NCG_SpillTmp_F2 f27
+#define NCG_SpillTmp_D1 f6
+#define NCG_SpillTmp_D2 f8
+
+#define NCG_FirstFloatReg f22
#endif /* sparc */