import MachRegs
import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
snocOL, consOL, concatOL )
-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,
+ pprStixTree, ppStixReg,
NatM, thenNat, returnNat, mapNat,
mapAndUnzipNat, mapAccumLNat,
getDeltaNat, setDeltaNat
)
import Outputable
+import CmdLineOpts ( opt_Static )
infixr 3 `bind`
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 (StFloat d) = returnNat (nilOL, ImmFloat 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
+ StFloat _ -> 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)
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
+getRegister (StFloat f)
+ = getNatLabelNCG `thenNat` \ lbl ->
+ let code dst = toOL [
+ SEGMENT DataSegment,
+ LABEL lbl,
+ DATA F [ImmFloat f],
+ SEGMENT TextSegment,
+ GLD F (ImmAddr (ImmCLbl lbl) 0) dst
+ ]
+ in
+ returnNat (Any FloatRep code)
+
+
getRegister (StDouble d)
| 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
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#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 ->
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
+ IntNegOp -> trivialUCode (SUB False False g0) x
+ NotOp -> trivialUCode (XNOR False g0) x
- FloatNegOp -> trivialUFCode FloatRep (FNEG F) 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
DoubleExpOp -> (False, SLIT("exp"))
DoubleLogOp -> (False, SLIT("log"))
- DoubleSqrtOp -> (True, SLIT("sqrt"))
+ DoubleSqrtOp -> (False, SLIT("sqrt"))
DoubleSinOp -> (False, SLIT("sin"))
DoubleCosOp -> (False, SLIT("cos"))
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
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])
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
-- 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
+ arg_size F = 4
arg_size _ = 4
------------
if (case sz of DF -> True; F -> True; _ -> False)
then returnNat (size,
code `appOL`
- toOL [SUB L (OpImm (ImmInt 8)) (OpReg esp),
+ toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
DELTA (delta-size),
- GST DF reg (AddrBaseIndex (Just esp)
+ GST sz reg (AddrBaseIndex (Just esp)
Nothing
(ImmInt 0))]
)
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
-
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
-- 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
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)
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
code2 `snocOL`
instr (primRepToSize pk) tmp1 src2 dst
in
- returnNat (Any DoubleRep code__2)
+ returnNat (Any pk code__2)
-------------
projects / ghc-hetmet.git / blobdiff