import TargetReg
import BlockId
-import Cmm
+import OldCmm
import FastString
import FastBool
import Outputable
-}
{-
-MORE FLOATING POINT MUSINGS...
+Note [x86 Floating point precision]
Intel's internal floating point registers are by default 80 bit
extended precision. This means that all operations done on values in
128 bit slot (so we get alignment). We spill at 80-bits and ignore
the alignment problems.
-In the future, we'll use the SSE registers for floating point. This
-requires a CPU that supports SSE2 (ordinary SSE only supports 32 bit
-precision float ops), which means P4 or Xeon and above. Using SSE
-will solve all these problems, because the SSE registers use fixed 32
-bit or 64 bit precision.
+In the future [edit: now available in GHC 7.0.1, with the -msse2
+flag], we'll use the SSE registers for floating point. This requires
+a CPU that supports SSE2 (ordinary SSE only supports 32 bit precision
+float ops), which means P4 or Xeon and above. Using SSE will solve
+all these problems, because the SSE registers use fixed 32 bit or 64
+bit precision.
--SDM 1/2003
-}
| GITOF Reg Reg -- src(intreg), dst(fpreg)
| GITOD Reg Reg -- src(intreg), dst(fpreg)
+ | GDTOF Reg Reg -- src(fpreg), 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
| JMP Operand
| JXX Cond BlockId -- includes unconditional branches
| JXX_GBL Cond Imm -- non-local version of JXX
- | JMP_TBL Operand [BlockId] -- table jump
+ -- Table jump
+ | JMP_TBL Operand -- Address to jump to
+ [Maybe BlockId] -- Blocks in the jump table
+ Section -- Data section jump table should be put in
+ CLabel -- Label of jump table
| CALL (Either Imm Reg) [Reg]
-- Other things.
JXX _ _ -> mkRU [] []
JXX_GBL _ _ -> mkRU [] []
JMP op -> mkRUR (use_R op)
- JMP_TBL op _ -> mkRUR (use_R op)
+ JMP_TBL op _ _ _ -> mkRUR (use_R op)
CALL (Left _) params -> mkRU params callClobberedRegs
CALL (Right reg) params -> mkRU (reg:params) callClobberedRegs
CLTD _ -> mkRU [eax] [edx]
GITOF src dst -> mkRU [src] [dst]
GITOD src dst -> mkRU [src] [dst]
+ GDTOF src dst -> mkRU [src] [dst]
+
GADD _ s1 s2 dst -> mkRU [s1,s2] [dst]
GSUB _ s1 s2 dst -> mkRU [s1,s2] [dst]
GMUL _ s1 s2 dst -> mkRU [s1,s2] [dst]
POP sz op -> patch1 (POP sz) op
SETCC cond op -> patch1 (SETCC cond) op
JMP op -> patch1 JMP op
- JMP_TBL op ids -> patch1 JMP_TBL op $ ids
+ JMP_TBL op ids s lbl-> JMP_TBL (patchOp op) ids s lbl
GMOV src dst -> GMOV (env src) (env dst)
GLD sz src dst -> GLD sz (lookupAddr src) (env dst)
GITOF src dst -> GITOF (env src) (env dst)
GITOD src dst -> GITOD (env src) (env dst)
+ GDTOF src dst -> GDTOF (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)
_other -> panic "patchRegs: unrecognised instr"
where
+ patch1 :: (Operand -> a) -> Operand -> a
patch1 insn op = insn $! patchOp op
+ patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 insn src dst = (insn $! patchOp src) $! patchOp dst
patchOp (OpReg reg) = OpReg $! env reg
x86_jumpDestsOfInstr insn
= case insn of
JXX _ id -> [id]
- JMP_TBL _ ids -> ids
+ JMP_TBL _ ids _ _ -> [id | Just id <- ids]
_ -> []
x86_patchJumpInstr insn patchF
= case insn of
JXX cc id -> JXX cc (patchF id)
- JMP_TBL _ _ -> error "Cannot patch JMP_TBL"
+ JMP_TBL op ids section lbl
+ -> JMP_TBL op (map (fmap patchF) ids) section lbl
_ -> insn
where p insn r = case insn of
CALL _ _ -> GFREE : insn : r
JMP _ -> GFREE : insn : r
+ JXX_GBL _ _ -> panic "i386_insert_ffrees: cannot handle JXX_GBL"
_ -> insn : r
-- if you ever add a new FP insn to the fake x86 FP insn set,
GLD1{} -> True
GFTOI{} -> True
GDTOI{} -> True
- GITOF{} -> True
- GITOD{} -> True
+ GITOF{} -> True
+ GITOD{} -> True
+ GDTOF{} -> True
GADD{} -> True
GDIV{} -> True
GSUB{} -> True
data JumpDest = DestBlockId BlockId | DestImm Imm
+getJumpDestBlockId :: JumpDest -> Maybe BlockId
+getJumpDestBlockId (DestBlockId bid) = Just bid
+getJumpDestBlockId _ = Nothing
canShortcut :: Instr -> Maybe JumpDest
canShortcut (JXX ALWAYS id) = Just (DestBlockId id)
-- This helper shortcuts a sequence of branches.
-- The blockset helps avoid following cycles.
shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
-shortcutJump fn insn = shortcutJump' fn emptyBlockSet insn
+shortcutJump fn insn = shortcutJump' fn (setEmpty :: BlockSet) insn
where shortcutJump' fn seen insn@(JXX cc id) =
- if elemBlockSet id seen then insn
+ if setMember id seen then insn
else case fn id of
Nothing -> insn
Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id')
Just (DestImm imm) -> shortcutJump' fn seen' (JXX_GBL cc imm)
- where seen' = extendBlockSet seen id
+ where seen' = setInsert id seen
shortcutJump' _ _ other = other
-- Here because it knows about JumpDest
shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
shortcutStatic fn (CmmStaticLit (CmmLabel lab))
| Just uq <- maybeAsmTemp lab
- = CmmStaticLit (CmmLabel (shortBlockId fn emptyUniqSet (BlockId uq)))
+ = CmmStaticLit (CmmLabel (shortBlockId fn emptyUniqSet (mkBlockId uq)))
shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))
| Just uq <- maybeAsmTemp lbl1
- = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn emptyUniqSet (BlockId uq)) lbl2 off)
+ = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn emptyUniqSet (mkBlockId uq)) lbl2 off)
-- slightly dodgy, we're ignoring the second label, but this
-- works with the way we use CmmLabelDiffOff for jump tables now.
-> BlockId
-> CLabel
-shortBlockId fn seen blockid@(BlockId uq) =
+shortBlockId fn seen blockid =
case (elementOfUniqSet uq seen, fn blockid) of
(True, _) -> mkAsmTempLabel uq
(_, Nothing) -> mkAsmTempLabel uq
(_, Just (DestBlockId blockid')) -> shortBlockId fn (addOneToUniqSet seen uq) blockid'
(_, Just (DestImm (ImmCLbl lbl))) -> lbl
(_, _other) -> panic "shortBlockId"
+ where uq = getUnique blockid
projects / ghc-hetmet.git / blobdiff