Skip to content
GitLab
Commit 298e7a78 authored by sewardj's avatar sewardj
Browse files

[project @ 2000-01-31 18:11:50 by sewardj] 

Spilling and x86 shift-code cleanups.
parent 8db5c981
Hide whitespace changes
Inline Side-by-side
ghc/compiler/main/Constants.lhs
View file @ 298e7a78
......@@ -25,6 +25,7 @@ module Constants (
tICKY_HDR_SIZE,
aRR_WORDS_HDR_SIZE,
aRR_PTRS_HDR_SIZE,
rESERVED_C_STACK_BYTES,
sTD_ITBL_SIZE,
pROF_ITBL_SIZE,
......@@ -229,3 +230,10 @@ using:
interfaceFileFormatVersion :: Int
interfaceFileFormatVersion = HscIfaceFileVersion
\end{code}
This tells the native code generator the size of the spill
area is has available.
\begin{code}
rESERVED_C_STACK_BYTES = (RESERVED_C_STACK_BYTES :: Int)
\end{code}
ghc/compiler/nativeGen/MachCode.lhs
View file @ 298e7a78
......@@ -631,9 +631,8 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
=> trivialCode's is not restrictive enough (sigh.)
-}
SllOp -> shift_code (SHL L) x y {-False-}
SrlOp -> shift_code (SHR L) x y {-False-}
SllOp -> shift_code (SHL L) x y {-False-}
SrlOp -> shift_code (SHR L) x y {-False-}
ISllOp -> shift_code (SHL L) x y {-False-}
ISraOp -> shift_code (SAR L) x y {-False-}
ISrlOp -> shift_code (SHR L) x y {-False-}
......@@ -649,7 +648,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
where
--------------------
shift_code :: (Operand -> Operand -> Instr)
shift_code :: (Imm -> Operand -> Instr)
-> StixTree
-> StixTree
-> UniqSM Register
......@@ -659,21 +658,16 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
shift_code instr x y{-amount-}
| maybeToBool imm
= getRegister x `thenUs` \ register ->
let
op_imm = OpImm imm__2
let op_imm = OpImm imm__2
code__2 dst =
let
code = registerCode register dst
src = registerName register dst
let code = registerCode register dst
src = registerName register dst
in
mkSeqInstr (COMMENT SLIT("shift_code")) .
code .
if isFixed register && src /= dst
then
mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
instr op_imm (OpReg dst)]
else
mkSeqInstr (instr op_imm (OpReg src))
then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
instr imm__2 (OpReg dst)]
else mkSeqInstr (instr imm__2 (OpReg src))
in
returnUs (Any IntRep code__2)
where
......@@ -681,6 +675,12 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
imm__2 = case imm of Just x -> x
{- Case2: shift length is complex (non-immediate) -}
-- Since ECX is always used as a spill temporary, we can't
-- use it here to do non-immediate shifts. No big deal --
-- they are only very rare, and we can use an equivalent
-- test-and-jump sequence which doesn't use ECX.
-- DO NOT USE REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
-- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
shift_code instr x y{-amount-}
= getRegister x `thenUs` \ register1 ->
getRegister y `thenUs` \ register2 ->
......@@ -707,27 +707,27 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
BT L (ImmInt 4) r_tmp,
JXX GEU lbl_test3,
instr (OpImm (ImmInt 16)) r_dst,
instr (ImmInt 16) r_dst,
LABEL lbl_test3,
BT L (ImmInt 3) r_tmp,
JXX GEU lbl_test2,
instr (OpImm (ImmInt 8)) r_dst,
instr (ImmInt 8) r_dst,
LABEL lbl_test2,
BT L (ImmInt 2) r_tmp,
JXX GEU lbl_test1,
instr (OpImm (ImmInt 4)) r_dst,
instr (ImmInt 4) r_dst,
LABEL lbl_test1,
BT L (ImmInt 1) r_tmp,
JXX GEU lbl_test0,
instr (OpImm (ImmInt 2)) r_dst,
instr (ImmInt 2) r_dst,
LABEL lbl_test0,
BT L (ImmInt 0) r_tmp,
JXX GEU lbl_after,
instr (OpImm (ImmInt 1)) r_dst,
instr (ImmInt 1) r_dst,
LABEL lbl_after,
COMMENT (_PK_ "end shift sequence")
......@@ -735,39 +735,6 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
in
returnUs (Any IntRep code__2)
{-
-- since ECX is always used as a spill temporary, we can't
-- use it here to do non-immediate shifts. No big deal --
-- they are only very rare, and we can give an equivalent
-- insn sequence which doesn't use ECX.
-- DO NOT USE THIS CODE, SINCE IT IS INCOMPATIBLE WITH THE SPILLER
= getRegister y `thenUs` \ register1 ->
getRegister x `thenUs` \ register2 ->
let
-- Note: we force the shift length to be loaded
-- into ECX, so that we can use CL when shifting.
-- (only register location we are allowed
-- to put shift amounts.)
--
-- The shift instruction is fed ECX as src reg,
-- but we coerce this into CL when printing out.
src1 = registerName register1 ecx
code1 = if src1 /= ecx then -- if it is not in ecx already, force it!
registerCode register1 ecx .
mkSeqInstr (MOV L (OpReg src1) (OpReg ecx))
else
registerCode register1 ecx
code__2 =
let
code2 = registerCode register2 eax
src2 = registerName register2 eax
in
code1 . code2 .
mkSeqInstr (instr (OpReg ecx) (OpReg eax))
in
returnUs (Fixed IntRep eax code__2)
-}
--------------------
add_code :: Size -> StixTree -> StixTree -> UniqSM Register
......
ghc/compiler/nativeGen/MachMisc.lhs
View file @ 298e7a78
......@@ -503,11 +503,11 @@ current translation.
| XOR Size Operand Operand
| NOT Size Operand
| NEGI Size Operand -- NEG instruction (name clash with Cond)
| SHL Size Operand Operand -- 1st operand must be an Imm or CL
| SAR Size Operand Operand -- 1st operand must be an Imm or CL
| SHR Size Operand Operand -- 1st operand must be an Imm or CL
| NOP
| SHL Size Imm Operand -- Only immediate shifts allowed
| SAR Size Imm Operand -- Only immediate shifts allowed
| SHR Size Imm Operand -- Only immediate shifts allowed
| BT Size Imm Operand
| NOP
-- Float Arithmetic. -- ToDo for 386
......
ghc/compiler/nativeGen/PprMach.lhs
View file @ 298e7a78
......@@ -977,9 +977,10 @@ pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor") size src dst
pprInstr (NOT size op) = pprSizeOp SLIT("not") size op
pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op
pprInstr (SHL size imm dst) = {-pprSizeByteOpOp-} pprSizeOpOp SLIT("shl") size imm dst
pprInstr (SAR size imm dst) = {-pprSizeByteOpOp-} pprSizeOpOp SLIT("sar") size imm dst
pprInstr (SHR size imm dst) = {-pprSizeByteOpOp-} pprSizeOpOp SLIT("shr") size imm dst
pprInstr (SHL size imm dst) = pprSizeImmOp SLIT("shl") size imm dst
pprInstr (SAR size imm dst) = pprSizeImmOp SLIT("sar") size imm dst
pprInstr (SHR size imm dst) = pprSizeImmOp SLIT("shr") size imm dst
pprInstr (BT size imm src) = pprSizeImmOp SLIT("bt") size imm src
pprInstr (CMP size src dst) = pprSizeOpOp SLIT("cmp") size src dst
pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test") size src dst
......@@ -989,7 +990,6 @@ pprInstr PUSHA = ptext SLIT("\tpushal")
pprInstr POPA = ptext SLIT("\tpopal")
pprInstr (NOP) = ptext SLIT("\tnop")
pprInstr (BT size imm src) = pprSizeImmOp SLIT("bt") size imm src
pprInstr (CLTD) = ptext SLIT("\tcltd")
pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op)
......
ghc/compiler/nativeGen/RegAllocInfo.lhs
View file @ 298e7a78
......@@ -65,6 +65,7 @@ import OrdList ( mkUnitList )
import PrimRep ( PrimRep(..) )
import UniqSet -- quite a bit of it
import Outputable
import Constants ( rESERVED_C_STACK_BYTES )
\end{code}
%************************************************************************
......@@ -367,9 +368,9 @@ regUsage instr = case instr of
XOR sz src dst -> usage2s src dst
NOT sz op -> usage1 op
NEGI sz op -> usage1 op
SHL sz len dst -> usage2s len dst -- len is either an Imm or ecx.
SAR sz len dst -> usage2s len dst -- len is either an Imm or ecx.
SHR sz len dst -> usage2s len dst -- len is either an Imm or ecx.
SHL sz imm dst -> usage1 dst
SAR sz imm dst -> usage1 dst
SHR sz imm dst -> usage1 dst
BT sz imm src -> usage (opToReg src) []
PUSH sz op -> usage (opToReg op) []
......@@ -414,7 +415,7 @@ regUsage instr = case instr of
LABEL _ -> noUsage
ASCII _ _ -> noUsage
DATA _ _ -> noUsage
_ -> pprPanic "regUsage(x86) " empty
_ -> pprPanic "regUsage(x86)" empty
where
-- 2 operand form in which the second operand is purely a destination
......@@ -558,13 +559,15 @@ a singleton list which we know will satisfy all spill demands.
findReservedRegs :: [Instr] -> [[RegNo]]
findReservedRegs instrs
#if alpha_TARGET_ARCH
= [[NCG_Reserved_I1, NCG_Reserved_I2,
NCG_Reserved_F1, NCG_Reserved_F2]]
= --[[NCG_Reserved_I1, NCG_Reserved_I2,
-- NCG_Reserved_F1, NCG_Reserved_F2]]
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]]
= --[[NCG_Reserved_I1, NCG_Reserved_I2,
-- NCG_Reserved_F1, NCG_Reserved_F2,
-- NCG_Reserved_D1, NCG_Reserved_D2]]
error "findReservedRegs: sparc"
#endif
#if i386_TARGET_ARCH
-- Sigh. This is where it gets complicated.
......@@ -741,10 +744,10 @@ patchRegs instr env = case instr of
XOR sz src dst -> patch2 (XOR sz) src dst
NOT sz op -> patch1 (NOT sz) op
NEGI sz op -> patch1 (NEGI sz) op
SHL sz imm dst -> patch2 (SHL sz) imm dst
SAR sz imm dst -> patch2 (SAR sz) imm dst
SHR sz imm dst -> patch2 (SHR sz) imm dst
BT sz imm src -> patch1 (BT sz imm) src
SHL sz imm dst -> patch1 (SHL sz imm) dst
SAR sz imm dst -> patch1 (SAR sz imm) dst
SHR sz imm dst -> patch1 (SHR sz imm) dst
BT sz imm src -> patch1 (BT sz imm) src
TEST sz src dst -> patch2 (TEST sz) src dst
CMP sz src dst -> patch2 (CMP sz) src dst
PUSH sz op -> patch1 (PUSH sz) op
......@@ -855,52 +858,60 @@ patchRegs instr env = case instr of
Spill to memory, and load it back...
JRS, 000122: on x86, don't spill directly above the stack pointer, since
some insn sequences (int <-> conversions) use this as a temp location.
Leave 16 bytes of slop.
JRS, 000122: on x86, don't spill directly above the stack pointer,
since some insn sequences (int <-> conversions, and eventually
StixInteger) use this as a temp location. Leave 8 words (ie, 64 bytes
for a 64-bit arch) of slop.
\begin{code}
maxSpillSlots :: Int
maxSpillSlots = (rESERVED_C_STACK_BYTES - 64) `div` 8
-- 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
-- the C stack pointer.
spillSlotToOffset :: Int -> Int
spillSlotToOffset slot
| slot >= 0 && slot < maxSpillSlots
= 64 + 8 * slot
| otherwise
= pprPanic "spillSlotToOffset:"
(text "invalid spill location: " <> int slot)
spillReg, loadReg :: Reg -> Reg -> InstrList
spillReg dyn (MemoryReg i pk)
| i >= 0 -- JRS paranoia
= let sz = primRepToSize pk
= let sz = primRepToSize pk
off = spillSlotToOffset i
in
mkUnitList (
{-Alpha: spill below the stack pointer (?)-}
IF_ARCH_alpha( ST sz dyn (spRel i)
IF_ARCH_alpha( ST sz dyn (spRel (- (off `div` 8)))
{-I386: spill above stack pointer leaving 2 words/spill-}
,IF_ARCH_i386 ( let loc | i < 60 = 4 + 2 * i
| otherwise = -2000 - 2 * i
,IF_ARCH_i386 ( let off_w = off `div` 4
in
if pk == FloatRep || pk == DoubleRep
then GST DF dyn (spRel loc)
else MOV sz (OpReg dyn) (OpAddr (spRel loc))
then GST DF dyn (spRel off_w)
else MOV sz (OpReg dyn) (OpAddr (spRel off_w))
{-SPARC: spill below frame pointer leaving 2 words/spill-}
,IF_ARCH_sparc( ST sz dyn (fpRel (-2 * i))
,IF_ARCH_sparc( ST sz dyn (fpRel (- (off `div` 4)))
,)))
)
| otherwise
= pprPanic "spillReg:" (text "invalid spill location: " <> int i)
----------------------------
loadReg (MemoryReg i pk) dyn
| i >= 0 -- JRS paranoia
= let sz = primRepToSize pk
= let sz = primRepToSize pk
off = spillSlotToOffset i
in
mkUnitList (
IF_ARCH_alpha( LD sz dyn (spRel i)
,IF_ARCH_i386 ( let loc | i < 60 = 4 + 2 * i
| otherwise = -2000 - 2 * i
IF_ARCH_alpha( LD sz dyn (spRel (- (off `div` 8)))
,IF_ARCH_i386 ( let off_w = off `div` 4
in
if pk == FloatRep || pk == DoubleRep
then GLD DF (spRel loc) dyn
else MOV sz (OpAddr (spRel loc)) (OpReg dyn)
,IF_ARCH_sparc( LD sz (fpRel (-2 * i)) dyn
then GLD DF (spRel off_w) dyn
else MOV sz (OpAddr (spRel off_w)) (OpReg dyn)
,IF_ARCH_sparc( LD sz (fpRel (- (off `div` 4))) dyn
,)))
)
| otherwise
= pprPanic "loadReg:" (text "invalid spill location: " <> int i)
\end{code}
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment