From: sewardj Date: Tue, 11 Jul 2000 15:26:33 +0000 (+0000) Subject: [project @ 2000-07-11 15:26:33 by sewardj] X-Git-Tag: Approximately_9120_patches~4044 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=6254fd4ab7c5798599e58b48896c9e284222f26f;p=ghc-hetmet.git [project @ 2000-07-11 15:26:33 by sewardj] Fix up the sparc native code generator. Mostly dull stuff. Notable changes: * Cleaned up ccall mechanism for sparc somewhat. * Rearranged assignment of sparc floating point registers (includes/MachRegs.h) so the NCG's register allocator can handle the double-single pairing issue without modification. Split VirtualRegF into VirtualRegF and VirtualRegD, and split RcFloating into RcFloat and RcDouble. Net effect is that there are now three register classes -- int, float and double, and we pretend that sparc has some float and some double real regs. * (A fix for all platforms): propagate MachFloats through as StFloats, not StDoubles. Amazingly, until now literal floats had been converted to and treated as doubles, including in ccalls. --- diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 6db7b79..b9a2c8c 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 8e15db8..17f184a 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 e466f4e..92f395a 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 85373b1..3fd6dd9 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 b9c69e7..0d39e9c 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 cb8006a..fba477f 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 af8c5b3..820a639 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 1013252..a401f85 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 dfb2ba6..e90a6d6 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 1de49fc..7576dd8 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 3a57495..c3a3ce3 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 */