import AbsCSyn ( MagicId )
import AbsCUtils ( magicIdPrimRep )
import CallConv ( CallConv )
-import CLabel ( isAsmTemp, CLabel, pprCLabel_asm )
+import CLabel ( isAsmTemp, CLabel, pprCLabel_asm, labelDynamic )
import Maybes ( maybeToBool, expectJust )
import PrimRep ( isFloatingRep, PrimRep(..) )
import PrimOp ( PrimOp(..) )
import CallConv ( cCallConv )
import Stix ( getNatLabelNCG, StixTree(..),
StixReg(..), CodeSegment(..),
- pprStixTrees, ppStixReg,
- NatM, thenNat, returnNat, mapNat, mapAndUnzipNat,
+ pprStixTree, ppStixReg,
+ NatM, thenNat, returnNat, mapNat,
+ mapAndUnzipNat, mapAccumLNat,
getDeltaNat, setDeltaNat
)
import Outputable
+import CmdLineOpts ( opt_Static )
+
+infixr 3 `bind`
\end{code}
type InstrBlock = OrdList Instr
-infixr 3 `bind`
x `bind` f = f x
\end{code}
LABEL lab)))
StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
returnNat nilOL)
+
StLabel lab -> returnNat (unitOL (LABEL lab))
- StJump arg -> genJump arg
- StCondJump lab arg -> genCondJump lab arg
- StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep args
+ StJump arg -> genJump (derefDLL arg)
+ StCondJump lab arg -> genCondJump lab (derefDLL arg)
+
+ -- A call returning void, ie one done for its side-effects
+ StCall fn cconv VoidRep args -> genCCall fn
+ cconv VoidRep (map derefDLL args)
StAssign pk dst src
- | isFloatingRep pk -> assignFltCode pk dst src
- | otherwise -> assignIntCode pk dst src
+ | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
+ | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
StFallThrough lbl
-- When falling through on the Alpha, we still have to load pv
where
getData :: StixTree -> NatM (InstrBlock, Imm)
- getData (StInt i) = returnNat (nilOL, ImmInteger i)
- getData (StDouble d) = returnNat (nilOL, ImmDouble d)
- getData (StLitLbl s) = returnNat (nilOL, ImmLab s)
- getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
- getData (StString s) =
+ getData (StInt i) = returnNat (nilOL, ImmInteger i)
+ getData (StDouble d) = returnNat (nilOL, ImmDouble d)
+ getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
+ getData (StString s) =
getNatLabelNCG `thenNat` \ lbl ->
returnNat (toOL [LABEL lbl,
ASCII True (_UNPK_ s)],
getData (StIndex rep (StCLbl lbl) (StInt off)) =
returnNat (nilOL,
ImmIndex lbl (fromInteger (off * sizeOf rep)))
+
+-- Walk a Stix tree, and insert dereferences to CLabels which are marked
+-- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
+-- not all such CLabel occurrences need this dereferencing -- SRTs don't
+-- for one.
+derefDLL :: StixTree -> StixTree
+derefDLL tree
+ | opt_Static -- short out the entire deal if not doing DLLs
+ = tree
+ | otherwise
+ = qq tree
+ where
+ qq t
+ = case t of
+ StCLbl lbl -> if labelDynamic lbl
+ then StInd PtrRep (StCLbl lbl)
+ else t
+ -- all the rest are boring
+ StIndex pk base offset -> StIndex pk (qq base) (qq offset)
+ StPrim pk args -> StPrim pk (map qq args)
+ StInd pk addr -> StInd pk (qq addr)
+ StCall who cc pk args -> StCall who cc pk (map qq args)
+ StInt _ -> t
+ StDouble _ -> t
+ StString _ -> t
+ StReg _ -> t
+ StScratchWord _ -> t
+ _ -> pprPanic "derefDLL: unhandled case"
+ (pprStixTree t)
\end{code}
%************************************************************************
\begin{code}
maybeImm :: StixTree -> Maybe Imm
-maybeImm (StLitLbl s) = Just (ImmLab s)
-maybeImm (StCLbl l) = Just (ImmCLbl l)
-
-maybeImm (StIndex rep (StCLbl l) (StInt off)) =
- Just (ImmIndex l (fromInteger (off * sizeOf rep)))
-
+maybeImm (StCLbl l)
+ = Just (ImmCLbl l)
+maybeImm (StIndex rep (StCLbl l) (StInt off))
+ = Just (ImmIndex l (fromInteger (off * sizeOf rep)))
maybeImm (StInt i)
| i >= toInteger minInt && i <= toInteger maxInt
= Just (ImmInt (fromInteger i))
-- cannae be Nothing
getRegister (StReg (StixTemp u pk))
- = returnNat (Fixed pk (UnmappedReg u pk) nilOL)
+ = returnNat (Fixed pk (mkVReg u pk) nilOL)
getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
| d == 0.0
= let code dst = unitOL (GLDZ dst)
- in trace "nativeGen: GLDZ"
- (returnNat (Any DoubleRep code))
+ in returnNat (Any DoubleRep code)
| d == 1.0
= let code dst = unitOL (GLD1 dst)
- in trace "nativeGen: GLD1"
- returnNat (Any DoubleRep code)
+ in returnNat (Any DoubleRep code)
| otherwise
= getNatLabelNCG `thenNat` \ lbl ->
other
-> pprPanic "getRegister(x86,unary primop)"
- (pprStixTrees [StPrim primop [x]])
+ (pprStixTree (StPrim primop [x]))
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
[x, y])
other
-> pprPanic "getRegister(x86,dyadic primop)"
- (pprStixTrees [StPrim primop [x, y]])
+ (pprStixTree (StPrim primop [x, y]))
where
--------------------
in
returnNat (Any PtrRep code)
| otherwise
- = pprPanic "getRegister(x86)" (pprStixTrees [leaf])
+ = pprPanic "getRegister(x86)" (pprStixTree leaf)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
getRegister (StDouble d)
= getNatLabelNCG `thenNat` \ lbl ->
getNewRegNCG PtrRep `thenNat` \ tmp ->
- let code dst = mkSeqInstrs [
+ let code dst = toOL [
SEGMENT DataSegment,
LABEL lbl,
DATA DF [ImmDouble d],
code = amodeCode amode
src = amodeAddr amode
size = primRepToSize pk
- code__2 dst = code . mkSeqInstr (LD size src dst)
+ code__2 dst = code `snocOL` LD size src dst
in
returnNat (Any pk code__2)
| fits13Bits i
= let
src = ImmInt (fromInteger i)
- code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
+ code dst = unitOL (OR False g0 (RIImm src) dst)
in
returnNat (Any IntRep code)
getRegister leaf
| maybeToBool imm
= let
- code dst = mkSeqInstrs [
+ code dst = toOL [
SETHI (HI imm__2) dst,
OR False dst (RIImm (LO imm__2)) dst]
in
getRegister x `thenNat` \ register1 ->
getRegister y `thenNat` \ register2 ->
let
- code1 = registerCode register1 tmp1 []
+ code1 = registerCode register1 tmp1
reg1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 []
+ code2 = registerCode register2 tmp2
reg2 = registerName register2 tmp2
- code__2 = asmSeqThen [code1, code2]
+ code__2 = code1 `appOL` code2
in
returnNat (Amode (AddrRegReg reg1 reg2) code__2)
| maybeToBool imm
= getNewRegNCG PtrRep `thenNat` \ tmp ->
let
- code = mkSeqInstr (SETHI (HI imm__2) tmp)
+ code = unitOL (SETHI (HI imm__2) tmp)
in
returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
where
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
- code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
+ code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
in
returnNat (CondCode False cond code__2)
getNewRegNCG IntRep `thenNat` \ tmp1 ->
getNewRegNCG IntRep `thenNat` \ tmp2 ->
let
- code1 = registerCode register1 tmp1 []
+ code1 = registerCode register1 tmp1
src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 []
+ code2 = registerCode register2 tmp2
src2 = registerName register2 tmp2
- code__2 = asmSeqThen [code1, code2] .
- mkSeqInstr (SUB False True src1 (RIReg src2) g0)
+ code__2 = code1 `appOL` code2 `snocOL`
+ SUB False True src1 (RIReg src2) g0
in
returnNat (CondCode False cond code__2)
`thenNat` \ tmp2 ->
getNewRegNCG DoubleRep `thenNat` \ tmp ->
let
- promote x = asmInstr (FxTOy F DF x tmp)
+ promote x = FxTOy F DF x tmp
pk1 = registerRep register1
code1 = registerCode register1 tmp1
code__2 =
if pk1 == pk2 then
- asmSeqThen [code1 [], code2 []] .
- mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
+ code1 `appOL` code2 `snocOL`
+ FCMP True (primRepToSize pk1) src1 src2
else if pk1 == FloatRep then
- asmSeqThen [code1 (promote src1), code2 []] .
- mkSeqInstr (FCMP True DF tmp src2)
+ code1 `snocOL` promote src1 `appOL` code2 `snocOL`
+ FCMP True DF tmp src2
else
- asmSeqThen [code1 [], code2 (promote src2)] .
- mkSeqInstr (FCMP True DF src1 tmp)
+ code1 `appOL` code2 `snocOL` promote src2 `snocOL`
+ FCMP True DF src1 tmp
in
returnNat (CondCode True cond code__2)
getAmode dst `thenNat` \ amode ->
getRegister src `thenNat` \ register ->
let
- code1 = amodeCode amode []
+ code1 = amodeCode amode
dst__2 = amodeAddr amode
- code2 = registerCode register tmp []
+ code2 = registerCode register tmp
src__2 = registerName register tmp
sz = primRepToSize pk
- code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
+ code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
in
returnNat code__2
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
code__2 = if isFixed register2
- then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
+ then code `snocOL` OR False g0 (RIReg src__2) dst__2
else code
in
returnNat code__2
sz = primRepToSize pk
dst__2 = amodeAddr amode
- code1 = amodeCode amode []
- code2 = registerCode register tmp1 []
+ code1 = amodeCode amode
+ code2 = registerCode register tmp1
src__2 = registerName register tmp1
pk__2 = registerRep register
sz__2 = primRepToSize pk__2
- code__2 = asmSeqThen [code1, code2] ++
- if pk == pk__2 then
- mkSeqInstr (ST sz src__2 dst__2)
- else
- mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
+ code__2 = code1 `appOL` code2 `appOL`
+ if pk == pk__2
+ then unitOL (ST sz src__2 dst__2)
+ else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
in
returnNat code__2
code__2 =
if pk /= pk__2 then
- code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
+ code `snocOL` FxTOy sz__2 sz src__2 dst__2
else if isFixed register2 then
- code . mkSeqInstr (FMOV sz src__2 dst__2)
+ code `snocOL` FMOV sz src__2 dst__2
else
code
in
#if sparc_TARGET_ARCH
genJump (StCLbl lbl)
- | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
- | otherwise = returnInstrs [CALL target 0 True, NOP]
+ | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
+ | otherwise = returnNat (toOL [CALL target 0 True, NOP])
where
target = ImmCLbl lbl
code = registerCode register tmp
target = registerName register tmp
in
- returnSeq code [JMP (AddrRegReg target g0), NOP]
+ returnNat (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP)
#endif {- sparc_TARGET_ARCH -}
\end{code}
cond = condName condition
target = ImmCLbl lbl
in
- returnSeq code (
- if condFloat condition then
- [NOP, BF cond False target, NOP]
- else
- [BI cond False target, NOP]
+ returnNat (
+ code `appOL`
+ toOL (
+ if condFloat condition
+ then [NOP, BF cond False target, NOP]
+ else [BI cond False target, NOP]
+ )
)
#endif {- sparc_TARGET_ARCH -}
-- ToDo:needed (WDP 96/03) ???
fn__2 = case (_HEAD_ fn) of
'.' -> ImmLit (ptext fn)
- _ -> ImmLab (ptext fn)
+ _ -> ImmLab False (ptext fn)
arg_size DF = 8
arg_size F = 8
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#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
- code = asmSeqThen (map ($ []) argCode)
+ code = concatOL argCode
in
- returnSeq code [call, NOP]
+ returnNat (code `snocOL` call `snocOL` NOP)
where
-- function names that begin with '.' are assumed to be special
-- internally generated names like '.mul,' which don't get an
-- ToDo:needed (WDP 96/03) ???
fn__2 = case (_HEAD_ fn) of
'.' -> ImmLit (ptext fn)
- _ -> ImmLab (ptext fn)
+ _ -> ImmLab False (ptext fn)
------------------------------------
{- Try to get a value into a specific register (or registers) for
src = registerName register reg
pk = registerRep register
in
- returnNat (case pk of
+ returnNat (
+ case pk of
DoubleRep ->
case dsts of
- [] -> (([], offset + 1), code . mkSeqInstrs [
+ [] -> ( ([], 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)),
- LD W (spRel (offset - 1)) dst])
- (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
- ST DF src (spRel (-2)),
- LD W (spRel (-2)) dst,
- LD W (spRel (-1)) dst__2])
- FloatRep -> ((dsts, offset), code . mkSeqInstrs [
- ST F src (spRel (-2)),
- LD W (spRel (-2)) dst])
- _ -> ((dsts, offset), if isFixed register then
- code . mkSeqInstr (OR False g0 (RIReg src) dst)
- else code))
-
+ ST DF src (spRel (offset - 1)) `snocOL`
+ LD W (spRel (offset - 1)) dst
+ )
+ (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
+ )
+ FloatRep
+ -> ( (dsts, offset),
+ code `snocOL`
+ ST F src (spRel (-2)) `snocOL`
+ LD W (spRel (-2)) dst
+ )
+ _ -> ( (dsts, offset),
+ if isFixed register
+ then code `snocOL` OR False g0 (RIReg src) dst
+ else code
+ )
+ )
-- Once we have run out of argument registers, we move to the
-- stack...
sz = primRepToSize pk
words = if pk == DoubleRep then 2 else 1
in
- returnNat (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
+ returnNat ( ([], offset + words),
+ code `snocOL` ST sz src (spRel offset) )
#endif {- sparc_TARGET_ARCH -}
\end{code}
let
code = registerCode register tmp
src = registerName register tmp
- code__2 dst = code . mkSeqInstrs [
+ code__2 dst = code `appOL` toOL [
SUB False True g0 (RIReg src) g0,
SUB True False g0 (RIImm (ImmInt (-1))) dst]
in
getNewRegNCG IntRep `thenNat` \ tmp1 ->
getNewRegNCG IntRep `thenNat` \ tmp2 ->
let
- code1 = registerCode register1 tmp1 []
+ code1 = registerCode register1 tmp1
src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 []
+ code2 = registerCode register2 tmp2
src2 = registerName register2 tmp2
- code__2 dst = asmSeqThen [code1, code2] . mkSeqInstrs [
+ code__2 dst = code1 `appOL` code2 `appOL` toOL [
XOR False src1 (RIReg src2) dst,
SUB False True g0 (RIReg dst) g0,
SUB True False g0 (RIImm (ImmInt (-1))) dst]
let
code = registerCode register tmp
src = registerName register tmp
- code__2 dst = code . mkSeqInstrs [
+ code__2 dst = code `appOL` toOL [
SUB False True g0 (RIReg src) g0,
ADD True False g0 (RIImm (ImmInt 0)) dst]
in
getNewRegNCG IntRep `thenNat` \ tmp1 ->
getNewRegNCG IntRep `thenNat` \ tmp2 ->
let
- code1 = registerCode register1 tmp1 []
+ code1 = registerCode register1 tmp1
src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 []
+ code2 = registerCode register2 tmp2
src2 = registerName register2 tmp2
- code__2 dst = asmSeqThen [code1, code2] . mkSeqInstrs [
+ code__2 dst = code1 `appOL` code2 `appOL` toOL [
XOR False src1 (RIReg src2) dst,
SUB False True g0 (RIReg dst) g0,
ADD True False g0 (RIImm (ImmInt 0)) dst]
let
code = condCode condition
cond = condName condition
- code__2 dst = code . mkSeqInstrs [
+ code__2 dst = code `appOL` toOL [
BI cond False (ImmCLbl lbl1), NOP,
OR False g0 (RIImm (ImmInt 0)) dst,
BI ALWAYS False (ImmCLbl lbl2), NOP,
let
code = condCode condition
cond = condName condition
- code__2 dst = code . mkSeqInstrs [
+ code__2 dst = code `appOL` toOL [
NOP,
BF cond False (ImmCLbl lbl1), NOP,
OR False g0 (RIImm (ImmInt 0)) dst,
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
- code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
+ code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
in
returnNat (Any IntRep code__2)
getNewRegNCG IntRep `thenNat` \ tmp1 ->
getNewRegNCG IntRep `thenNat` \ tmp2 ->
let
- code1 = registerCode register1 tmp1 []
+ code1 = registerCode register1 tmp1
src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 []
+ code2 = registerCode register2 tmp2
src2 = registerName register2 tmp2
- code__2 dst = asmSeqThen [code1, code2] .
- mkSeqInstr (instr src1 (RIReg src2) dst)
+ code__2 dst = code1 `appOL` code2 `snocOL`
+ instr src1 (RIReg src2) dst
in
returnNat (Any IntRep code__2)
`thenNat` \ tmp2 ->
getNewRegNCG DoubleRep `thenNat` \ tmp ->
let
- promote x = asmInstr (FxTOy F DF x tmp)
+ promote x = FxTOy F DF x tmp
pk1 = registerRep register1
code1 = registerCode register1 tmp1
code__2 dst =
if pk1 == pk2 then
- asmSeqThen [code1 [], code2 []] .
- mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
+ code1 `appOL` code2 `snocOL`
+ instr (primRepToSize pk) src1 src2 dst
else if pk1 == FloatRep then
- asmSeqThen [code1 (promote src1), code2 []] .
- mkSeqInstr (instr DF tmp src2 dst)
+ code1 `snocOL` promote src1 `appOL` code2 `snocOL`
+ instr DF tmp src2 dst
else
- asmSeqThen [code1 [], code2 (promote src2)] .
- mkSeqInstr (instr DF src1 tmp dst)
+ code1 `appOL` code2 `snocOL` promote src2 `snocOL`
+ instr DF src1 tmp dst
in
returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
let
code = registerCode register tmp
src = registerName register tmp
- code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
+ code__2 dst = code `snocOL` instr (RIReg src) dst
in
returnNat (Any IntRep code__2)
let
code = registerCode register tmp
src = registerName register tmp
- code__2 dst = code . mkSeqInstr (instr src dst)
+ code__2 dst = code `snocOL` instr src dst
in
returnNat (Any pk code__2)
code = registerCode register reg
src = registerName register reg
- code__2 dst = code . mkSeqInstrs [
+ code__2 dst = code `appOL` toOL [
ST W src (spRel (-2)),
LD W (spRel (-2)) dst,
FxTOy W (primRepToSize pk) dst dst]
src = registerName register reg
pk = registerRep register
- code__2 dst = code . mkSeqInstrs [
+ code__2 dst = code `appOL` toOL [
FxTOy (primRepToSize pk) W src tmp,
ST W tmp (spRel (-2)),
LD W (spRel (-2)) dst]
src_off = addrOffset src 3
src__2 = case src_off of Just x -> x
code__2 dst = if maybeToBool src_off then
- code . mkSeqInstr (LD BU src__2 dst)
+ code `snocOL` LD BU src__2 dst
else
- code . mkSeqInstrs [
- LD (primRepToSize pk) src dst,
- AND False dst (RIImm (ImmInt 255)) dst]
+ code `snocOL`
+ LD (primRepToSize pk) src dst `snocOL`
+ AND False dst (RIImm (ImmInt 255)) dst
in
returnNat (Any pk code__2)
let
code = registerCode register reg
src = registerName register reg
- code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
+ code__2 dst = code `snocOL` AND False src (RIImm (ImmInt 255)) dst
in
returnNat (Any IntRep code__2)
projects / ghc-hetmet.git / blobdiff