diff options
| -rw-r--r-- | ghc/compiler/nativeGen/AsmCodeGen.lhs | 78 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/MachCode.lhs | 375 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/MachMisc.lhs | 67 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/MachRegs.lhs | 40 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/PprMach.lhs | 242 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/RegAllocInfo.lhs | 150 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/StixPrim.lhs | 2 |
7 files changed, 442 insertions, 512 deletions
diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index 9309d475db..13a59ef22b 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -84,18 +84,10 @@ nativeCodeGen :: AbstractC -> UniqSupply -> (SDoc, SDoc) nativeCodeGen absC us = let (stixRaw, us1) = initUs us (genCodeAbstractC absC) stixOpt = map (map genericOpt) stixRaw - stixFinal = map x86floatFix stixOpt - insns = initUs_ us1 (codeGen stixFinal) - debug_stix = vcat (map pprStixTrees stixFinal) + insns = initUs_ us1 (codeGen stixOpt) + debug_stix = vcat (map pprStixTrees stixOpt) in (debug_stix, insns) - -#if i386_TARGET_ARCH -x86floatFix = floatFix -#else -x86floatFix = id -#endif - \end{code} @codeGen@ is the top-level code-generation function: @@ -108,7 +100,10 @@ codeGen stixFinal static_instrss = scheduleMachCode dynamic_codes docs = map (vcat . map pprInstr) static_instrss in - returnUs (vcat (intersperse (char ' ' $$ char ' ') docs)) + returnUs (vcat (intersperse (char ' ' + $$ text "# ___stg_split_marker" + $$ char ' ') + docs)) \end{code} Top level code generator for a chunk of stix code: @@ -292,64 +287,3 @@ Anything else is just too hard. \begin{code} primOpt op args = StPrim op args \end{code} - ------------------------------------------------------------------------------ -Fix up floating point operations for x86. - -The problem is that the code generator can't handle the weird register -naming scheme for floating point registers on the x86, so we have to -deal with memory-resident floating point values wherever possible. - -We therefore can't stand references to floating-point kinded temporary -variables, and try to translate them into memory addresses wherever -possible. - -\begin{code} -floatFix :: [StixTree] -> [StixTree] -floatFix trees = fltFix emptyUFM trees - -fltFix :: UniqFM StixTree -- mapping tmp vars to memory locations - -> [StixTree] - -> [StixTree] -fltFix locs [] = [] - --- The case we're interested in: loading a temporary from a memory --- address. Eliminate the instruction and replace all future references --- to the temporary with the memory address. -fltFix locs ((StAssign rep (StReg (StixTemp uq _)) loc) : trees) - | isFloatingRep rep = fltFix (addToUFM locs uq loc) trees - -fltFix locs ((StAssign rep src dst) : trees) - = StAssign rep (fltFix1 locs src) (fltFix1 locs dst) : fltFix locs trees - -fltFix locs (tree : trees) - = fltFix1 locs tree : fltFix locs trees - - -fltFix1 :: UniqFM StixTree -> StixTree -> StixTree -fltFix1 locs r@(StReg (StixTemp uq rep)) - | isFloatingRep rep = case lookupUFM locs uq of - Nothing -> panic "fltFix1" - Just tree -> tree - -fltFix1 locs (StIndex rep l r) = - StIndex rep (fltFix1 locs l) (fltFix1 locs r) - -fltFix1 locs (StInd rep tree) = - StInd rep (fltFix1 locs tree) - -fltFix1 locs (StAssign rep dst src) = panic "fltFix1: StAssign" - -fltFix1 locs (StJump tree) = StJump (fltFix1 locs tree) - -fltFix1 locs (StCondJump lbl tree) = - StCondJump lbl (fltFix1 locs tree) - -fltFix1 locs (StPrim op trees) = - StPrim op (map (fltFix1 locs) trees) - -fltFix1 locs (StCall f conv rep trees) = - StCall f conv rep (map (fltFix1 locs) trees) - -fltFix1 locs tree = tree -\end{code} diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 86d3c31984..7ba0869e08 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -247,7 +247,7 @@ getRegister (StCall fn cconv kind args) returnUs (Fixed kind reg call) where reg = if isFloatingRep kind - then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,))) + then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,))) else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,))) getRegister (StString s) @@ -505,42 +505,32 @@ getRegister leaf -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -getRegister (StDouble 0.0) - = let - code dst = mkSeqInstrs [FLDZ] - in - returnUs (Any DoubleRep code) - -getRegister (StDouble 1.0) - = let - code dst = mkSeqInstrs [FLD1] - in - returnUs (Any DoubleRep code) - getRegister (StDouble d) = getUniqLabelNCG `thenUs` \ lbl -> - --getNewRegNCG PtrRep `thenUs` \ tmp -> let code dst = mkSeqInstrs [ SEGMENT DataSegment, LABEL lbl, DATA DF [ImmDouble d], SEGMENT TextSegment, - FLD DF (OpImm (ImmCLbl lbl)) + GLD DF (ImmAddr (ImmCLbl lbl) 0) dst ] in returnUs (Any DoubleRep code) + getRegister (StPrim primop [x]) -- unary PrimOps = case primop of IntNegOp -> trivialUCode (NEGI L) x - NotOp -> trivialUCode (NOT L) x - FloatNegOp -> trivialUFCode FloatRep FCHS x - FloatSqrtOp -> trivialUFCode FloatRep FSQRT x - DoubleNegOp -> trivialUFCode DoubleRep FCHS x + FloatNegOp -> trivialUFCode FloatRep (GNEG F) x + DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x + + FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x + DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x - DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x + Double2FloatOp -> trivialUFCode FloatRep GDTOF x + Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x OrdOp -> coerceIntCode IntRep x ChrOp -> chrCode x @@ -550,14 +540,11 @@ getRegister (StPrim primop [x]) -- unary PrimOps Double2IntOp -> coerceFP2Int x Int2DoubleOp -> coerceInt2FP DoubleRep x - Double2FloatOp -> coerceFltCode x - Float2DoubleOp -> coerceFltCode 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]) where @@ -651,15 +638,15 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps IntRemOp -> quot_code L x y False{-remainder-} IntMulOp -> trivialCode (IMUL L) x y {-True-} - FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP x y - FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP x y - FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP x y - FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP x y + FloatAddOp -> trivialFCode FloatRep GADD x y + FloatSubOp -> trivialFCode FloatRep GSUB x y + FloatMulOp -> trivialFCode FloatRep GMUL x y + FloatDivOp -> trivialFCode FloatRep GDIV x y - DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP x y - DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y - DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP x y - DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y + DoubleAddOp -> trivialFCode DoubleRep GADD x y + DoubleSubOp -> trivialFCode DoubleRep GSUB x y + DoubleMulOp -> trivialFCode DoubleRep GMUL x y + DoubleDivOp -> trivialFCode DoubleRep GDIV x y AndOp -> trivialCode (AND L) x y {-True-} OrOp -> trivialCode (OR L) x y {-True-} @@ -673,18 +660,23 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps SllOp -> shift_code (SHL L) x y {-False-} SrlOp -> shift_code (SHR L) x y {-False-} - ISllOp -> shift_code (SHL L) x y {-False-} --was:panic "I386Gen:isll" - ISraOp -> shift_code (SAR L) x y {-False-} --was:panic "I386Gen:isra" - ISrlOp -> shift_code (SHR L) x y {-False-} --was:panic "I386Gen:isrl" + ISllOp -> shift_code (SHL L) x y {-False-} + ISraOp -> shift_code (SAR L) x y {-False-} + ISrlOp -> shift_code (SHR L) x y {-False-} - 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]) + DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep + [x, y]) where + + -------------------- shift_code :: (Operand -> Operand -> Instr) -> StixTree -> StixTree -> UniqSM Register + {- Case1: shift length as immediate -} -- Code is the same as the first eq. for trivialCode -- sigh. shift_code instr x y{-amount-} @@ -715,7 +707,6 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps shift_code instr x y{-amount-} = getRegister y `thenUs` \ register1 -> getRegister x `thenUs` \ register2 -> --- getNewRegNCG IntRep `thenUs` \ dst -> let -- Note: we force the shift length to be loaded -- into ECX, so that we can use CL when shifting. @@ -740,6 +731,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps in returnUs (Fixed IntRep eax code__2) + -------------------- add_code :: Size -> StixTree -> StixTree -> UniqSM Register add_code sz x (StInt y) @@ -749,51 +741,13 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (fromInteger y) - code__2 dst = code . - mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst)) - in - returnUs (Any IntRep code__2) -{- - add_code sz x (StInd _ mem) - = getRegister x `thenUs` \ register1 -> - --getNewRegNCG (registerRep register1) - -- `thenUs` \ tmp1 -> - getAmode mem `thenUs` \ amode -> - let - code2 = amodeCode amode - src2 = amodeAddr amode - - code__2 dst = let code1 = registerCode register1 dst - src1 = registerName register1 dst - in asmParThen [code2 asmVoid,code1 asmVoid] . - if isFixed register1 && src1 /= dst - then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), - ADD sz (OpAddr src2) (OpReg dst)] - else - mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)] + code__2 dst + = code . + mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) + (OpReg dst)) in returnUs (Any IntRep code__2) - add_code sz (StInd _ mem) y - = getRegister y `thenUs` \ register2 -> - --getNewRegNCG (registerRep register2) - -- `thenUs` \ tmp2 -> - getAmode mem `thenUs` \ amode -> - let - code1 = amodeCode amode - src1 = amodeAddr amode - - code__2 dst = let code2 = registerCode register2 dst - src2 = registerName register2 dst - in asmParThen [code1 asmVoid,code2 asmVoid] . - if isFixed register2 && src2 /= dst - then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst), - ADD sz (OpAddr src1) (OpReg dst)] - else - mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)] - in - returnUs (Any IntRep code__2) --} add_code sz x y = getRegister x `thenUs` \ register1 -> getRegister y `thenUs` \ register2 -> @@ -804,8 +758,11 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps src1 = registerName register1 tmp1 code2 = registerCode register2 tmp2 asmVoid src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1, code2] . - mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst)) + code__2 dst + = asmParThen [code1, code2] . + mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1)) + (ImmInt 0))) + (OpReg dst)) in returnUs (Any IntRep code__2) @@ -819,8 +776,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (-(fromInteger y)) - code__2 dst = code . - mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst)) + code__2 dst + = code . + mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) + (OpReg dst)) in returnUs (Any IntRep code__2) @@ -863,10 +822,14 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps src2 = ImmInt (fromInteger i) code__2 = asmParThen [code1] . mkSeqInstrs [-- we put src2 in (ebx) - MOV L (OpImm src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))), - MOV L (OpReg src1) (OpReg eax), - CLTD, - IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))] + MOV L (OpImm src2) + (OpAddr (AddrBaseIndex (Just ebx) Nothing + (ImmInt OFFSET_R1))), + MOV L (OpReg src1) (OpReg eax), + CLTD, + IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing + (ImmInt OFFSET_R1))) + ] in returnUs (Fixed IntRep (if is_division then eax else edx) code__2) @@ -882,14 +845,20 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps src2 = registerName register2 tmp2 code__2 = asmParThen [code1, code2] . if src2 == ecx || src2 == esi - then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax), - CLTD, - IDIV sz (OpReg src2)] + then mkSeqInstrs [ + MOV L (OpReg src1) (OpReg eax), + CLTD, + IDIV sz (OpReg src2) + ] else mkSeqInstrs [ -- we put src2 in (ebx) - MOV L (OpReg src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))), - MOV L (OpReg src1) (OpReg eax), - CLTD, - IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))] + MOV L (OpReg src2) + (OpAddr (AddrBaseIndex (Just ebx) Nothing + (ImmInt OFFSET_R1))), + MOV L (OpReg src1) (OpReg eax), + CLTD, + IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing + (ImmInt OFFSET_R1))) + ] in returnUs (Fixed IntRep (if is_division then eax else edx) code__2) ----------------------- @@ -898,16 +867,15 @@ getRegister (StInd pk mem) = getAmode mem `thenUs` \ amode -> let code = amodeCode amode - src = amodeAddr amode + src = amodeAddr amode size = primRepToSize pk code__2 dst = code . if pk == DoubleRep || pk == FloatRep - then mkSeqInstr (FLD {-DF-} size (OpAddr src)) + then mkSeqInstr (GLD size src dst) else mkSeqInstr (MOV size (OpAddr src) (OpReg dst)) in returnUs (Any pk code__2) - getRegister (StInt i) = let src = ImmInt (fromInteger i) @@ -1485,26 +1453,6 @@ condIntCode cond x y returnUs (CondCode False cond code__2) ----------- - -condFltCode cond x (StDouble 0.0) - = getRegister x `thenUs` \ register1 -> - getNewRegNCG (registerRep register1) - `thenUs` \ tmp1 -> - let - pk1 = registerRep register1 - code1 = registerCode register1 tmp1 - src1 = registerName register1 tmp1 - - code__2 = asmParThen [code1 asmVoid] . - mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ? - FNSTSW, - --AND HB (OpImm (ImmInt 68)) (OpReg eax), - --XOR HB (OpImm (ImmInt 64)) (OpReg eax) - SAHF - ] - in - returnUs (CondCode True (fix_FP_cond cond) code__2) - condFltCode cond x y = getRegister x `thenUs` \ register1 -> getRegister y `thenUs` \ register2 -> @@ -1512,35 +1460,33 @@ condFltCode cond x y `thenUs` \ tmp1 -> getNewRegNCG (registerRep register2) `thenUs` \ tmp2 -> + getNewRegNCG DoubleRep `thenUs` \ tmp -> let pk1 = registerRep register1 code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 + pk2 = registerRep register2 code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 = asmParThen [code2 asmVoid, code1 asmVoid] . - mkSeqInstrs [FUCOMPP, - FNSTSW, - --AND HB (OpImm (ImmInt 68)) (OpReg eax), - --XOR HB (OpImm (ImmInt 64)) (OpReg eax) - SAHF - ] + code__2 = asmParThen [code1 asmVoid, code2 asmVoid] . + mkSeqInstr (GCMP (primRepToSize pk1) src1 src2) + + {- On the 486, the flags set by FP compare are the unsigned ones! + (This looks like a HACK to me. WDP 96/03) + -} + fix_FP_cond :: Cond -> Cond + + fix_FP_cond GE = GEU + fix_FP_cond GTT = GU + fix_FP_cond LTT = LU + fix_FP_cond LE = LEU + fix_FP_cond any = any in returnUs (CondCode True (fix_FP_cond cond) code__2) -{- On the 486, the flags set by FP compare are the unsigned ones! - (This looks like a HACK to me. WDP 96/03) --} - -fix_FP_cond :: Cond -> Cond -fix_FP_cond GE = GEU -fix_FP_cond GTT = GU -fix_FP_cond LTT = LU -fix_FP_cond LE = LEU -fix_FP_cond any = any #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1798,7 +1744,6 @@ assignFltCode pk (StInd pk_dst dst) (StInd pk_src src) = getNewRegNCG IntRep `thenUs` \ tmp -> getAmode src `thenUs` \ amodesrc -> getAmode dst `thenUs` \ amodedst -> - --getRegister src `thenUs` \ register -> let codesrc1 = amodeCode amodesrc asmVoid addrsrc1 = amodeAddr amodesrc @@ -1819,38 +1764,38 @@ assignFltCode pk (StInd pk_dst dst) (StInd pk_src src) returnUs code__2 assignFltCode pk (StInd _ dst) src - = --getNewRegNCG pk `thenUs` \ tmp -> + = getNewRegNCG pk `thenUs` \ tmp -> getAmode dst `thenUs` \ amode -> - getRegister src `thenUs` \ register -> + getRegister src `thenUs` \ register -> let sz = primRepToSize pk dst__2 = amodeAddr amode code1 = amodeCode amode asmVoid - code2 = registerCode register {-tmp-}st0 asmVoid + code2 = registerCode register tmp asmVoid - --src__2= registerName register tmp - pk__2 = registerRep register - sz__2 = primRepToSize pk__2 + src__2 = registerName register tmp code__2 = asmParThen [code1, code2] . - mkSeqInstr (FSTP sz (OpAddr dst__2)) + mkSeqInstr (GST sz src__2 dst__2) in returnUs code__2 assignFltCode pk dst src = getRegister dst `thenUs` \ register1 -> getRegister src `thenUs` \ register2 -> - --getNewRegNCG (registerRep register2) - -- `thenUs` \ tmp -> + getNewRegNCG pk `thenUs` \ tmp -> let - sz = primRepToSize pk - dst__2 = registerName register1 st0 --tmp - - code = registerCode register2 dst__2 + -- the register which is dst + dst__2 = registerName register1 tmp + -- the register into which src is computed, preferably dst__2 src__2 = registerName register2 dst__2 + -- code to compute src into src__2 + code = registerCode register2 dst__2 - code__2 = code + code__2 = if isFixed register2 + then code . mkSeqInstr (GMOV src__2 dst__2) + else code in returnUs code__2 @@ -2345,22 +2290,23 @@ genCCall fn cconv kind args get_call_arg arg = get_op arg `thenUs` \ (code, op, sz) -> case sz of - DF -> returnUs (sz, + DF -> --getNewRegNCG DoubleRep `thenUs` \ tmp -> + returnUs (sz, code . - mkSeqInstr (FLD L op) . + --mkSeqInstr (GLD DF op tmp) . mkSeqInstr (SUB L (OpImm (ImmInt 8)) (OpReg esp)) . - mkSeqInstr (FSTP DF (OpAddr (AddrBaseIndex + mkSeqInstr (GST DF {-tmp-}op (AddrBaseIndex (Just esp) - Nothing (ImmInt 0)))) + Nothing (ImmInt 0))) ) _ -> returnUs (sz, - code . mkSeqInstr (PUSH sz op)) + code . mkSeqInstr (PUSH sz (OpReg op))) ------------ get_op :: StixTree - -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size - + -> UniqSM (InstrBlock, {-Operand-}Reg, Size) -- code, operator, size +{- get_op (StInt i) = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L) @@ -2372,7 +2318,7 @@ genCCall fn cconv kind args sz = primRepToSize pk in returnUs (code, OpAddr addr, sz) - +-} get_op op = getRegister op `thenUs` \ register -> getNewRegNCG (registerRep register) @@ -2383,7 +2329,7 @@ genCCall fn cconv kind args pk = registerRep register sz = primRepToSize pk in - returnUs (code, OpReg reg, sz) + returnUs (code, {-OpReg-} reg, sz) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2665,12 +2611,7 @@ trivialFCode :: PrimRep -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr) ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr) - ,IF_ARCH_i386 ( - {-this bizarre type for i386 seems a little too weird (WDP 96/03)-} - (Size -> Operand -> Instr) - -> (Size -> Operand -> Instr) {-reversed instr-} - -> Instr {-pop-} - -> Instr {-reversed instr: pop-} + ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr) ,))) -> StixTree -> StixTree -- the two arguments -> UniqSM Register @@ -2686,7 +2627,7 @@ trivialUCode trivialUFCode :: PrimRep -> IF_ARCH_alpha((Reg -> Reg -> Instr) - ,IF_ARCH_i386 (Instr + ,IF_ARCH_i386 ((Reg -> Reg -> Instr) ,IF_ARCH_sparc((Reg -> Reg -> Instr) ,))) -> StixTree -- the one argument @@ -2767,7 +2708,6 @@ trivialUFCode _ instr x trivialCode instr x y | maybeToBool imm = getRegister x `thenUs` \ register1 -> - --getNewRegNCG IntRep `thenUs` \ tmp1 -> let code__2 dst = let code1 = registerCode register1 dst src1 = registerName register1 dst @@ -2786,7 +2726,6 @@ trivialCode instr x y trivialCode instr x y | maybeToBool imm = getRegister y `thenUs` \ register1 -> - --getNewRegNCG IntRep `thenUs` \ tmp1 -> let code__2 dst = let code1 = registerCode register1 dst src1 = registerName register1 dst @@ -2801,48 +2740,10 @@ trivialCode instr x y where imm = maybeImm x imm__2 = case imm of Just x -> x -{- -trivialCode instr x (StInd pk mem) - = getRegister x `thenUs` \ register -> - --getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode mem `thenUs` \ amode -> - let - code2 = amodeCode amode asmVoid - src2 = amodeAddr amode - code__2 dst = let code1 = registerCode register dst asmVoid - src1 = registerName register dst - in asmParThen [code1, code2] . - if isFixed register && src1 /= dst - then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), - instr (OpAddr src2) (OpReg dst)] - else - mkSeqInstr (instr (OpAddr src2) (OpReg src1)) - in - returnUs (Any pk code__2) -trivialCode instr (StInd pk mem) y - = getRegister y `thenUs` \ register -> - --getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode mem `thenUs` \ amode -> - let - code2 = amodeCode amode asmVoid - src2 = amodeAddr amode - code__2 dst = let - code1 = registerCode register dst asmVoid - src1 = registerName register dst - in asmParThen [code1, code2] . - if isFixed register && src1 /= dst - then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), - instr (OpAddr src2) (OpReg dst)] - else - mkSeqInstr (instr (OpAddr src2) (OpReg src1)) - in - returnUs (Any pk code__2) --} trivialCode instr x y = getRegister x `thenUs` \ register1 -> getRegister y `thenUs` \ register2 -> - --getNewRegNCG IntRep `thenUs` \ tmp1 -> getNewRegNCG IntRep `thenUs` \ tmp2 -> let code2 = registerCode register2 tmp2 asmVoid @@ -2862,7 +2763,6 @@ trivialCode instr x y ----------- trivialUCode instr x = getRegister x `thenUs` \ register -> --- getNewRegNCG IntRep `thenUs` \ tmp -> let code__2 dst = let code = registerCode register dst @@ -2875,10 +2775,9 @@ trivialUCode instr x returnUs (Any IntRep code__2) ----------- +{- trivialFCode pk _ instrr _ _ (StInd pk' mem) y = getRegister y `thenUs` \ register2 -> - --getNewRegNCG (registerRep register2) - -- `thenUs` \ tmp2 -> getAmode mem `thenUs` \ amode -> let code1 = amodeCode amode @@ -2894,8 +2793,6 @@ trivialFCode pk _ instrr _ _ (StInd pk' mem) y trivialFCode pk instr _ _ _ x (StInd pk' mem) = getRegister x `thenUs` \ register1 -> - --getNewRegNCG (registerRep register1) - -- `thenUs` \ tmp1 -> getAmode mem `thenUs` \ amode -> let code2 = amodeCode amode @@ -2912,10 +2809,6 @@ trivialFCode pk instr _ _ _ x (StInd pk' mem) trivialFCode pk _ _ _ instrpr x y = getRegister x `thenUs` \ register1 -> getRegister y `thenUs` \ register2 -> - --getNewRegNCG (registerRep register1) - -- `thenUs` \ tmp1 -> - --getNewRegNCG (registerRep register2) - -- `thenUs` \ tmp2 -> getNewRegNCG DoubleRep `thenUs` \ tmp -> let pk1 = registerRep register1 @@ -2931,8 +2824,38 @@ trivialFCode pk _ _ _ instrpr x y mkSeqInstr instrpr in returnUs (Any pk1 code__2) +-} + +trivialFCode pk instr x y + = getRegister x `thenUs` \ register1 -> + getRegister y `thenUs` \ register2 -> + getNewRegNCG DoubleRep `thenUs` \ tmp1 -> + getNewRegNCG DoubleRep `thenUs` \ tmp2 -> + let + code1 = registerCode register1 tmp1 + src1 = registerName register1 tmp1 + + code2 = registerCode register2 tmp2 + src2 = registerName register2 tmp2 + + code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] . + mkSeqInstr (instr (primRepToSize pk) src1 src2 dst) + in + returnUs (Any DoubleRep code__2) + ------------- +trivialUFCode pk instr x + = getRegister x `thenUs` \ register -> + getNewRegNCG pk `thenUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + code__2 dst = code . mkSeqInstr (instr src dst) + in + returnUs (Any pk code__2) + +{- trivialUFCode pk instr (StInd pk' mem) = getAmode mem `thenUs` \ amode -> let @@ -2945,7 +2868,6 @@ trivialUFCode pk instr (StInd pk' mem) trivialUFCode pk instr x = getRegister x `thenUs` \ register -> - --getNewRegNCG pk `thenUs` \ tmp -> let code__2 dst = let code = registerCode register dst @@ -2953,7 +2875,7 @@ trivialUFCode pk instr x in code . mkSeqInstrs [instr] in returnUs (Any pk code__2) - +-} #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH @@ -3124,11 +3046,9 @@ coerceInt2FP pk x let code = registerCode register reg src = registerName register reg - - code__2 dst = code . mkSeqInstrs [ - -- to fix: should spill instead of using R1 - MOV L (OpReg src) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))), - FILD (primRepToSize pk) (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)) dst] + opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD + code__2 dst = code . + mkSeqInstr (opc src dst) in returnUs (Any pk code__2) @@ -3141,10 +3061,9 @@ coerceFP2Int x src = registerName register tmp pk = registerRep register - code__2 dst = code . mkSeqInstrs [ - FRNDINT, - FIST L (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)), - MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)] + opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI + code__2 dst = code . + mkSeqInstr (opc src dst) in returnUs (Any IntRep code__2) diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index 3c593e0567..d72de134ed 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -475,49 +475,34 @@ data RI -- Float Arithmetic. -- ToDo for 386 --- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single instructions +-- Note that we cheat by treating G{ABS,MOV,NEG} of doubles as single instructions -- right up until we spit them out. - | SAHF -- stores ah into flags - | FABS - | FADD Size Operand -- src - | FADDP - | FIADD Size MachRegsAddr -- src - | FCHS - | FCOM Size Operand -- src - | FCOS - | FDIV Size Operand -- src - | FDIVP - | FIDIV Size MachRegsAddr -- src - | FDIVR Size Operand -- src - | FDIVRP - | FIDIVR Size MachRegsAddr -- src - | FICOM Size MachRegsAddr -- src - | FILD Size MachRegsAddr Reg -- src, dst - | FIST Size MachRegsAddr -- dst - | FLD Size Operand -- src - | FLD1 - | FLDZ - | FMUL Size Operand -- src - | FMULP - | FIMUL Size MachRegsAddr -- src - | FRNDINT - | FSIN - | FSQRT - | FST Size Operand -- dst - | FSTP Size Operand -- dst - | FSUB Size Operand -- src - | FSUBP - | FISUB Size MachRegsAddr -- src - | FSUBR Size Operand -- src - | FSUBRP - | FISUBR Size MachRegsAddr -- src - | FTST - | FCOMP Size Operand -- src - | FUCOMPP - | FXCH - | FNSTSW - | FNOP + -- all the 3-operand fake fp insns are src1 src2 dst + -- and furthermore are constrained to be fp regs only. + | GMOV Reg Reg -- src(fpreg), dst(fpreg) + | GLD Size MachRegsAddr Reg -- src, dst(fpreg) + | GST Size Reg MachRegsAddr -- src(fpreg), dst + + | GFTOD Reg Reg -- src(fpreg), dst(fpreg) + | GFTOI Reg Reg -- src(fpreg), dst(intreg) + + | GDTOF Reg Reg -- src(fpreg), dst(fpreg) + | GDTOI Reg Reg -- src(fpreg), dst(intreg) + + | GITOF Reg Reg -- src(intreg), dst(fpreg) + | GITOD Reg Reg -- src(intreg), dst(fpreg) + + | GADD Size Reg Reg Reg -- src1, src2, dst + | GDIV Size Reg Reg Reg -- src1, src2, dst + | GSUB Size Reg Reg Reg -- src1, src2, dst + | GMUL Size Reg Reg Reg -- src1, src2, dst + + | GCMP Size Reg Reg -- src1, src2 + + | GABS Size Reg Reg -- src, dst + | GNEG Size Reg Reg -- src, dst + | GSQRT Size Reg Reg -- src, dst -- Comparison diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs index f5e02cb854..7bafa78a52 100644 --- a/ghc/compiler/nativeGen/MachRegs.lhs +++ b/ghc/compiler/nativeGen/MachRegs.lhs @@ -46,7 +46,7 @@ module MachRegs ( #endif #if i386_TARGET_ARCH , eax, ebx, ecx, edx, esi, esp - , st0, st1, st2, st3, st4, st5, st6, st7 + , fake0, fake1, fake2, fake3, fake4, fake5 #endif #if sparc_TARGET_ARCH , allArgRegs @@ -370,7 +370,10 @@ Intel x86 architecture: - Only ebx, esi, edi and esp are available across a C call (they are callee-saves). - Registers 0-7 have 16-bit counterparts (ax, bx etc.) - Registers 0-3 have 8 bit counterparts (ah, bh etc.) -- Registers 8-15 hold extended floating point values. +- Registers 8-13 are fakes; we pretend x86 has 6 conventionally-addressable + fp registers, and 3-operand insns for them, and we translate this into + real stack-based x86 fp code after register allocation. + \begin{code} #if i386_TARGET_ARCH @@ -378,7 +381,7 @@ gReg,fReg :: Int -> Int gReg x = x fReg x = (8 + x) -st0, st1, st2, st3, st4, st5, st6, st7, eax, ebx, ecx, edx, esp :: Reg +fake0, fake1, fake2, fake3, fake4, fake5, eax, ebx, ecx, edx, esp :: Reg eax = realReg (gReg 0) ebx = realReg (gReg 1) ecx = realReg (gReg 2) @@ -387,15 +390,12 @@ esi = realReg (gReg 4) edi = realReg (gReg 5) ebp = realReg (gReg 6) esp = realReg (gReg 7) -st0 = realReg (fReg 0) -st1 = realReg (fReg 1) -st2 = realReg (fReg 2) -st3 = realReg (fReg 3) -st4 = realReg (fReg 4) -st5 = realReg (fReg 5) -st6 = realReg (fReg 6) -st7 = realReg (fReg 7) - +fake0 = realReg (fReg 0) +fake1 = realReg (fReg 1) +fake2 = realReg (fReg 2) +fake3 = realReg (fReg 3) +fake4 = realReg (fReg 4) +fake5 = realReg (fReg 5) #endif \end{code} @@ -474,14 +474,12 @@ names in the header files. Gag me with a spoon, eh? #define edi 5 #define ebp 6 #define esp 7 -#define st0 8 -#define st1 9 -#define st2 10 -#define st3 11 -#define st4 12 -#define st5 13 -#define st6 14 -#define st7 15 +#define fake0 8 +#define fake1 9 +#define fake2 10 +#define fake3 11 +#define fake4 12 +#define fake5 13 #endif #if sparc_TARGET_ARCH #define g0 0 @@ -765,7 +763,7 @@ reservedRegs freeRegs :: [Reg] freeRegs = freeMappedRegs IF_ARCH_alpha( [0..63], - IF_ARCH_i386( [0..15], + IF_ARCH_i386( [0..13], IF_ARCH_sparc( [0..63],))) ------------------------------- diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 304a4a2de4..eddbe80d8f 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -94,14 +94,14 @@ pprReg IF_ARCH_i386(s,) r _ -> SLIT("very naughty I386 byte register") }) - {- UNUSED: +{- UNUSED: ppr_reg_no HB i = ptext (case i of { ILIT( 0) -> SLIT("%ah"); ILIT( 1) -> SLIT("%bh"); ILIT( 2) -> SLIT("%ch"); ILIT( 3) -> SLIT("%dh"); _ -> SLIT("very naughty I386 high byte register") }) - -} +-} {- UNUSED: ppr_reg_no S i = ptext @@ -125,21 +125,17 @@ pprReg IF_ARCH_i386(s,) r ppr_reg_no F i = ptext (case i of { - --ToDo: rm these (???) - ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)"); - ILIT(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)"); - ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)"); - ILIT(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)"); + ILIT( 8) -> SLIT("%fake0"); ILIT( 9) -> SLIT("%fake1"); + ILIT(10) -> SLIT("%fake2"); ILIT(11) -> SLIT("%fake3"); + ILIT(12) -> SLIT("%fake4"); ILIT(13) -> SLIT("%fake5"); _ -> SLIT("very naughty I386 float register") }) ppr_reg_no DF i = ptext (case i of { - --ToDo: rm these (???) - ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)"); - ILIT(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)"); - ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)"); - ILIT(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)"); + ILIT( 8) -> SLIT("%fake0"); ILIT( 9) -> SLIT("%fake1"); + ILIT(10) -> SLIT("%fake2"); ILIT(11) -> SLIT("%fake3"); + ILIT(12) -> SLIT("%fake4"); ILIT(13) -> SLIT("%fake5"); _ -> SLIT("very naughty I386 float register") }) #endif @@ -405,7 +401,7 @@ pprInstr (SEGMENT TextSegment) = ptext IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-} ,IF_ARCH_sparc(SLIT("\t.text\n\t.align 4") {-word boundary-} - ,IF_ARCH_i386(SLIT(".text\n\t.align 4") {-needs per-OS variation!-} + ,IF_ARCH_i386(SLIT(".text\n\t.align 4,0x90") {-needs per-OS variation!-} ,))) pprInstr (SEGMENT DataSegment) @@ -998,70 +994,111 @@ pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm) pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op) pprInstr (CALL imm) - = hcat [ ptext SLIT("\tcall "), pprImm imm ] - -pprInstr SAHF = ptext SLIT("\tsahf") -pprInstr FABS = ptext SLIT("\tfabs") - -pprInstr (FADD sz src@(OpAddr _)) - = hcat [ptext SLIT("\tfadd"), pprSize sz, space, pprOperand sz src] -pprInstr (FADD sz src) - = ptext SLIT("\tfadd") -pprInstr FADDP - = ptext SLIT("\tfaddp") -pprInstr (FMUL sz src) - = hcat [ptext SLIT("\tfmul"), pprSize sz, space, pprOperand sz src] -pprInstr FMULP - = ptext SLIT("\tfmulp") -pprInstr (FIADD size op) = pprSizeAddr SLIT("fiadd") size op -pprInstr FCHS = ptext SLIT("\tfchs") -pprInstr (FCOM size op) = pprSizeOp SLIT("fcom") size op -pprInstr FCOS = ptext SLIT("\tfcos") -pprInstr (FIDIV size op) = pprSizeAddr SLIT("fidiv") size op -pprInstr (FDIV sz src) - = hcat [ptext SLIT("\tfdiv"), pprSize sz, space, pprOperand sz src] -pprInstr FDIVP - = ptext SLIT("\tfdivp") -pprInstr (FDIVR sz src) - = hcat [ptext SLIT("\tfdivr"), pprSize sz, space, pprOperand sz src] -pprInstr FDIVRP - = ptext SLIT("\tfdivpr") -pprInstr (FIDIVR size op) = pprSizeAddr SLIT("fidivr") size op -pprInstr (FICOM size op) = pprSizeAddr SLIT("ficom") size op -pprInstr (FILD sz op reg) = pprSizeAddrReg SLIT("fild") sz op reg -pprInstr (FIST size op) = pprSizeAddr SLIT("fist") size op -pprInstr (FLD sz (OpImm (ImmCLbl src))) - = hcat [ptext SLIT("\tfld"),pprSize sz,space,pprCLabel_asm src] -pprInstr (FLD sz src) - = hcat [ptext SLIT("\tfld"),pprSize sz,space,pprOperand sz src] -pprInstr FLD1 = ptext SLIT("\tfld1") -pprInstr FLDZ = ptext SLIT("\tfldz") -pprInstr (FIMUL size op) = pprSizeAddr SLIT("fimul") size op -pprInstr FRNDINT = ptext SLIT("\tfrndint") -pprInstr FSIN = ptext SLIT("\tfsin") -pprInstr FSQRT = ptext SLIT("\tfsqrt") -pprInstr (FST sz dst) - = hcat [ptext SLIT("\tfst"), pprSize sz, space, pprOperand sz dst] -pprInstr (FSTP sz dst) - = hcat [ptext SLIT("\tfstp"), pprSize sz, space, pprOperand sz dst] -pprInstr (FISUB size op) = pprSizeAddr SLIT("fisub") size op -pprInstr (FSUB sz src) - = hcat [ptext SLIT("\tfsub"), pprSize sz, space, pprOperand sz src] -pprInstr FSUBP - = ptext SLIT("\tfsubp") -pprInstr (FSUBR size src) - = pprSizeOp SLIT("fsubr") size src -pprInstr FSUBRP - = ptext SLIT("\tfsubpr") -pprInstr (FISUBR size op) - = pprSizeAddr SLIT("fisubr") size op -pprInstr FTST = ptext SLIT("\tftst") -pprInstr (FCOMP sz op) - = hcat [ptext SLIT("\tfcomp"), pprSize sz, space, pprOperand sz op] -pprInstr FUCOMPP = ptext SLIT("\tfucompp") -pprInstr FXCH = ptext SLIT("\tfxch") -pprInstr FNSTSW = ptext SLIT("\tfnstsw %ax") -pprInstr FNOP = ptext SLIT("") + = hcat [ ptext SLIT("\tffree %st(0) ; call "), pprImm imm ] + + +-- Simulating a flat register set on the x86 FP stack is tricky. +-- you have to free %st(7) before pushing anything on the FP reg stack +-- so as to preclude the possibility of a FP stack overflow exception. +-- ToDo: make gpop into a single instruction, FST +pprInstr g@(GMOV src dst) + = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1]) + +-- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FXCH (dst+1) ; FINCSTP +pprInstr g@(GLD sz addr dst) + = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp, + pprAddr addr, gsemi, gpop dst 1]) + +-- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr +pprInstr g@(GST sz src addr) + = pprG g (hcat [gtab, gpush src 0, gsemi, + text "fstp", pprSize sz, gsp, pprAddr addr]) + +pprInstr g@(GFTOD src dst) + = pprG g bogus +pprInstr g@(GFTOI src dst) + = pprG g bogus + +pprInstr g@(GDTOF src dst) + = pprG g bogus +pprInstr g@(GDTOI src dst) + = pprG g bogus + +pprInstr g@(GITOF src dst) + = pprG g bogus +pprInstr g@(GITOD src dst) + = pprG g bogus + +pprInstr g@(GCMP sz src1 src2) + = pprG g (hcat [gtab, text "pushl %eax ; ", + gpush src2 0, gsemi, gpush src1 1] + $$ + hcat [gtab, text "fcompp ; fstsw %ax ; sahf ; popl %eax"]) + +pprInstr g@(GABS sz src dst) + = pprG g bogus +pprInstr g@(GNEG sz src dst) + = pprG g bogus +pprInstr g@(GSQRT sz src dst) + = pprG g bogus + +pprInstr g@(GADD sz src1 src2 dst) + = pprG g (hcat [gtab, gpush src1 0, + text " ; fadd ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) +pprInstr g@(GSUB sz src1 src2 dst) + = pprG g (hcat [gtab, gpush src1 0, + text " ; fsub ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) +pprInstr g@(GMUL sz src1 src2 dst) + = pprG g (hcat [gtab, gpush src1 0, + text " ; fmul ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) +pprInstr g@(GDIV sz src1 src2 dst) + = pprG g (hcat [gtab, gpush src1 0, + text " ; fdiv ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) + +-------------------------- +gpush reg offset + = hcat [text "ffree %st(7) ; fld ", greg reg offset] +gpop reg offset + = hcat [text "fxch ", greg reg offset, gsemi, text "fincstp"] + +bogus = text "\tbogus" +greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')' +gsemi = text " ; " +gtab = char '\t' +gsp = char ' ' +gregno (FixedReg i) = I# i +gregno (MappedReg i) = I# i + +pprG :: Instr -> SDoc -> SDoc +pprG fake actual + = (char '#' <> pprGInstr fake) $$ actual + +pprGInstr (GMOV src dst) = pprSizeRegReg SLIT("gmov") DF src dst +pprGInstr (GLD sz src dst) = pprSizeAddrReg SLIT("gld") sz src dst +pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst + +pprGInstr (GFTOD src dst) = pprSizeSizeRegReg SLIT("gftod") F DF src dst +pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F L src dst + +pprGInstr (GDTOF src dst) = pprSizeSizeRegReg SLIT("gdtof") DF F src dst +pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") DF L src dst + +pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") L F src dst +pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") L DF src dst + +pprGInstr (GCMP sz src dst) = pprSizeRegReg SLIT("gcmp") sz src dst +pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst +pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst +pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst + +pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg SLIT("gadd") sz src1 src2 dst +pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg SLIT("gsub") sz src1 src2 dst +pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg SLIT("gmul") sz src1 src2 dst +pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg SLIT("gdiv") sz src1 src2 dst \end{code} Continue with I386-only printing bits and bobs: @@ -1121,6 +1158,45 @@ pprSizeOpReg name size op1 reg pprReg size reg ] +pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> SDoc +pprSizeRegReg name size reg1 reg2 + = hcat [ + char '\t', + ptext name, + pprSize size, + space, + pprReg size reg1, + comma, + pprReg size reg2 + ] + +pprSizeSizeRegReg :: FAST_STRING -> Size -> Size -> Reg -> Reg -> SDoc +pprSizeSizeRegReg name size1 size2 reg1 reg2 + = hcat [ + char '\t', + ptext name, + pprSize size1, + pprSize size2, + space, + pprReg size1 reg1, + comma, + pprReg size2 reg2 + ] + +pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> SDoc +pprSizeRegRegReg name size reg1 reg2 reg3 + = hcat [ + char '\t', + ptext name, + pprSize size, + space, + pprReg size reg1, + comma, + pprReg size reg2, + comma, + pprReg size reg3 + ] + pprSizeAddr :: FAST_STRING -> Size -> MachRegsAddr -> SDoc pprSizeAddr name size op = hcat [ @@ -1143,6 +1219,18 @@ pprSizeAddrReg name size op dst pprReg size dst ] +pprSizeRegAddr :: FAST_STRING -> Size -> Reg -> MachRegsAddr -> SDoc +pprSizeRegAddr name size src op + = hcat [ + char '\t', + ptext name, + pprSize size, + space, + pprReg size src, + comma, + pprAddr op + ] + pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> SDoc pprOpOp name size op1 op2 = hcat [ diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs index 811a39a0ee..e3965e8af3 100644 --- a/ghc/compiler/nativeGen/RegAllocInfo.lhs +++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs @@ -64,6 +64,7 @@ import OrdList ( mkUnitList ) import PrimRep ( PrimRep(..) ) import UniqSet -- quite a bit of it import Outputable +import PprMach ( pprInstr ) \end{code} %************************************************************************ @@ -379,48 +380,36 @@ regUsage instr = case instr of CALL imm -> usage [] callClobberedRegs CLTD -> usage [eax] [edx] NOP -> usage [] [] - SAHF -> usage [eax] [] - FABS -> usage [st0] [st0] - FADD sz src -> usage (st0:opToReg src) [st0] -- allFPRegs - FADDP -> usage [st0,st1] [st0] -- allFPRegs - FIADD sz asrc -> usage (addrToRegs asrc) [st0] - FCHS -> usage [st0] [st0] - FCOM sz src -> usage (st0:opToReg src) [] - FCOS -> usage [st0] [st0] - FDIV sz src -> usage (st0:opToReg src) [st0] - FDIVP -> usage [st0,st1] [st0] - FDIVRP -> usage [st0,st1] [st0] - FIDIV sz asrc -> usage (addrToRegs asrc) [st0] - FDIVR sz src -> usage (st0:opToReg src) [st0] - FIDIVR sz asrc -> usage (addrToRegs asrc) [st0] - FICOM sz asrc -> usage (addrToRegs asrc) [] - FILD sz asrc dst -> usage (addrToRegs asrc) [dst] -- allFPRegs - FIST sz adst -> usage (st0:addrToRegs adst) [] - FLD sz src -> usage (opToReg src) [st0] -- allFPRegs - FLD1 -> usage [] [st0] -- allFPRegs - FLDZ -> usage [] [st0] -- allFPRegs - FMUL sz src -> usage (st0:opToReg src) [st0] - FMULP -> usage [st0,st1] [st0] - FIMUL sz asrc -> usage (addrToRegs asrc) [st0] - FRNDINT -> usage [st0] [st0] - FSIN -> usage [st0] [st0] - FSQRT -> usage [st0] [st0] - FST sz (OpReg r) -> usage [st0] [r] - FST sz dst -> usage (st0:opToReg dst) [] - FSTP sz (OpReg r) -> usage [st0] [r] -- allFPRegs - FSTP sz dst -> usage (st0:opToReg dst) [] -- allFPRegs - FSUB sz src -> usage (st0:opToReg src) [st0] -- allFPRegs - FSUBR sz src -> usage (st0:opToReg src) [st0] -- allFPRegs - FISUB sz asrc -> usage (addrToRegs asrc) [st0] - FSUBP -> usage [st0,st1] [st0] -- allFPRegs - FSUBRP -> usage [st0,st1] [st0] -- allFPRegs - FISUBR sz asrc -> usage (addrToRegs asrc) [st0] - FTST -> usage [st0] [] - FCOMP sz op -> usage (st0:opToReg op) [st0] -- allFPRegs - FUCOMPP -> usage [st0, st1] [st0, st1] -- allFPRegs - FXCH -> usage [st0, st1] [st0, st1] - FNSTSW -> usage [] [eax] - _ -> noUsage + + GMOV src dst -> usage [src] [dst] + GLD sz src dst -> usage (addrToRegs src) [dst] + GST sz src dst -> usage [src] (addrToRegs dst) + + GFTOD src dst -> usage [src] [dst] + GFTOI src dst -> usage [src] [dst] + + GDTOF src dst -> usage [src] [dst] + GDTOI src dst -> usage [src] [dst] + + GITOF src dst -> usage [src] [dst] + GITOD src dst -> usage [src] [dst] + + GADD sz s1 s2 dst -> usage [s1,s2] [dst] + GSUB sz s1 s2 dst -> usage [s1,s2] [dst] + GMUL sz s1 s2 dst -> usage [s1,s2] [dst] + GDIV sz s1 s2 dst -> usage [s1,s2] [dst] + + GCMP sz src1 src2 -> usage [src1,src2] [] + GABS sz src dst -> usage [src] [dst] + GNEG sz src dst -> usage [src] [dst] + GSQRT sz src dst -> usage [src] [dst] + + COMMENT _ -> noUsage + SEGMENT _ -> noUsage + LABEL _ -> noUsage + ASCII _ _ -> noUsage + DATA _ _ -> noUsage + _ -> error ("regUsage: " ++ showSDoc (pprInstr instr)) --noUsage where usage2 :: Operand -> Operand -> RegUsage usage2 op (OpReg reg) = usage (opToReg op) [reg] @@ -429,10 +418,10 @@ regUsage instr = case instr of usage1 :: Operand -> RegUsage usage1 (OpReg reg) = usage [reg] [reg] usage1 (OpAddr ea) = usage (addrToRegs ea) [] - allFPRegs = [st0,st1,st2,st3,st4,st5,st6,st7] + allFPRegs = [fake0,fake1,fake2,fake3,fake4,fake5] --callClobberedRegs = [ eax, ecx, edx ] -- according to gcc, anyway. - callClobberedRegs = [eax] + callClobberedRegs = [eax,fake0,fake1,fake2,fake3,fake4,fake5] -- General purpose register collecting functions. @@ -672,32 +661,39 @@ patchRegs instr env = case instr of POP sz op -> patch1 (POP sz) op SETCC cond op -> patch1 (SETCC cond) op JMP op -> patch1 JMP op - FADD sz src -> FADD sz (patchOp src) - FIADD sz asrc -> FIADD sz (lookupAddr asrc) - FCOM sz src -> patch1 (FCOM sz) src - FDIV sz src -> FDIV sz (patchOp src) - --FDIVP sz src -> FDIVP sz (patchOp src) - FIDIV sz asrc -> FIDIV sz (lookupAddr asrc) - FDIVR sz src -> FDIVR sz (patchOp src) - --FDIVRP sz src -> FDIVRP sz (patchOp src) - FIDIVR sz asrc -> FIDIVR sz (lookupAddr asrc) - FICOM sz asrc -> FICOM sz (lookupAddr asrc) - FILD sz asrc dst -> FILD sz (lookupAddr asrc) (env dst) - FIST sz adst -> FIST sz (lookupAddr adst) - FLD sz src -> patch1 (FLD sz) (patchOp src) - FMUL sz src -> FMUL sz (patchOp src) - --FMULP sz src -> FMULP sz (patchOp src) - FIMUL sz asrc -> FIMUL sz (lookupAddr asrc) - FST sz dst -> FST sz (patchOp dst) - FSTP sz dst -> FSTP sz (patchOp dst) - FSUB sz src -> FSUB sz (patchOp src) - --FSUBP sz src -> FSUBP sz (patchOp src) - FISUB sz asrc -> FISUB sz (lookupAddr asrc) - FSUBR sz src -> FSUBR sz (patchOp src) - --FSUBRP sz src -> FSUBRP sz (patchOp src) - FISUBR sz asrc -> FISUBR sz (lookupAddr asrc) - FCOMP sz src -> FCOMP sz (patchOp src) - _ -> instr + + GMOV src dst -> GMOV (env src) (env dst) + GLD sz src dst -> GLD sz (lookupAddr src) (env dst) + GST sz src dst -> GST sz (env src) (lookupAddr dst) + + GFTOD src dst -> GFTOD (env src) (env dst) + GFTOI src dst -> GFTOI (env src) (env dst) + + GDTOF src dst -> GDTOF (env src) (env dst) + GDTOI src dst -> GDTOI (env src) (env dst) + + GITOF src dst -> GITOF (env src) (env dst) + GITOD src dst -> GITOD (env src) (env dst) + + GADD sz s1 s2 dst -> GADD sz (env s1) (env s2) (env dst) + GSUB sz s1 s2 dst -> GSUB sz (env s1) (env s2) (env dst) + GMUL sz s1 s2 dst -> GMUL sz (env s1) (env s2) (env dst) + GDIV sz s1 s2 dst -> GDIV sz (env s1) (env s2) (env dst) + + GCMP sz src1 src2 -> GCMP sz (env src1) (env src2) + GABS sz src dst -> GABS sz (env src) (env dst) + GNEG sz src dst -> GNEG sz (env src) (env dst) + GSQRT sz src dst -> GSQRT sz (env src) (env dst) + + COMMENT _ -> instr + SEGMENT _ -> instr + LABEL _ -> instr + ASCII _ _ -> instr + DATA _ _ -> instr + JXX _ _ -> instr + CALL _ -> instr + CLTD -> instr + _ -> error ("patchInstr: " ++ showSDoc (pprInstr instr)) --instr where patch1 insn op = insn (patchOp op) patch2 insn src dst = insn (patchOp src) (patchOp dst) @@ -765,10 +761,15 @@ patchRegs instr env = case instr of Spill to memory, and load it back... +JRS, 000122: on x86, don't spill directly below the stack pointer, since +some insn sequences (int <-> conversions) use this as a temp location. +Leave 16 bytes of slop. + \begin{code} spillReg, loadReg :: Reg -> Reg -> InstrList spillReg dyn (MemoryReg i pk) + | i >= 0 -- JRS paranoia = let sz = primRepToSize pk in @@ -777,7 +778,9 @@ spillReg dyn (MemoryReg i pk) IF_ARCH_alpha( ST sz dyn (spRel i) {-I386: spill below stack pointer leaving 2 words/spill-} - ,IF_ARCH_i386 ( MOV sz (OpReg dyn) (OpAddr (spRel (-2 * i))) + ,IF_ARCH_i386 ( if pk == FloatRep || pk == DoubleRep + then GST sz dyn (spRel (-16 + (-2 * i))) + else MOV sz (OpReg dyn) (OpAddr (spRel (-16 + (-2 * i)))) {-SPARC: spill below frame pointer leaving 2 words/spill-} ,IF_ARCH_sparc( ST sz dyn (fpRel (-2 * i)) @@ -786,12 +789,15 @@ spillReg dyn (MemoryReg i pk) ---------------------------- loadReg (MemoryReg i pk) dyn + | i >= 0 -- JRS paranoia = let sz = primRepToSize pk in mkUnitList ( IF_ARCH_alpha( LD sz dyn (spRel i) - ,IF_ARCH_i386 ( MOV sz (OpAddr (spRel (-2 * i))) (OpReg dyn) + ,IF_ARCH_i386 ( if pk == FloatRep || pk == DoubleRep + then GLD sz (spRel (-16 + (-2 * i))) dyn + else MOV sz (OpAddr (spRel (-16 + (-2 * i)))) (OpReg dyn) ,IF_ARCH_sparc( LD sz (fpRel (-2 * i)) dyn ,))) ) diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index c9323ec415..ff5332df1a 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -159,7 +159,7 @@ primCode [] WriteArrayOp [obj, ix, v] obj' = amodeToStix obj ix' = amodeToStix ix v' = amodeToStix v - base = StIndex IntRep obj' arrHS + base = StIndex IntRep obj' arrHS --(StInt (toInteger 3)) assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v' in returnUs (\xs -> assign : xs) |