%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[MachCode]{Generating machine code}
import AbsCSyn ( MagicId )
import AbsCUtils ( magicIdPrimRep )
+import CallConv ( CallConv )
import CLabel ( isAsmTemp, CLabel )
import Maybes ( maybeToBool, expectJust )
import OrdList -- quite a bit of it
import PrimRep ( isFloatingRep, PrimRep(..) )
-import PrimOp ( PrimOp(..), showPrimOp )
+import PrimOp ( PrimOp(..) )
+import CallConv ( cCallConv )
import Stix ( getUniqLabelNCG, StixTree(..),
StixReg(..), CodeSegment(..)
)
StJump arg -> genJump arg
StCondJump lab arg -> genCondJump lab arg
- StCall fn VoidRep args -> genCCall fn VoidRep args
+ StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep args
StAssign pk dst src
| isFloatingRep pk -> assignFltCode pk dst src
returnUs (mkSeqInstrs [LABEL lbl,
ASCII True (_UNPK_ s)],
ImmCLbl lbl)
+ -- the linker can handle simple arithmetic...
+ getData (StIndex rep (StCLbl lbl) (StInt off)) =
+ returnUs (id, ImmIndex lbl (fromInteger (off * sizeOf rep)))
\end{code}
%************************************************************************
maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
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))
getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
-getRegister (StCall fn kind args)
- = genCCall fn kind args `thenUs` \ call ->
+getRegister (StCall fn cconv kind args)
+ = genCCall fn cconv kind args `thenUs` \ call ->
returnUs (Fixed kind reg call)
where
reg = if isFloatingRep kind
getRegister (StPrim primop [x]) -- unary PrimOps
= case primop of
IntNegOp -> trivialUCode (NEG Q False) x
- IntAbsOp -> trivialUCode (ABS Q) x
NotOp -> trivialUCode NOT x
Double2FloatOp -> coerceFltCode x
Float2DoubleOp -> coerceFltCode x
- other_op -> getRegister (StCall fn DoubleRep [x])
+ other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
where
fn = case other_op of
FloatExpOp -> SLIT("exp")
OrOp -> trivialCode OR x y
XorOp -> trivialCode XOR x y
SllOp -> trivialCode SLL x y
- SraOp -> trivialCode SRA x y
SrlOp -> trivialCode SRL x y
- ISllOp -> panic "AlphaGen:isll"
- ISraOp -> panic "AlphaGen:isra"
- ISrlOp -> panic "AlphaGen:isrl"
+ ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
+ ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
+ ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
- FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
- DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
+ FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
+ DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
where
{- ------------------------------------------------------------
Some bizarre special code for getting condition codes into
getRegister (StPrim primop [x]) -- unary PrimOps
= case primop of
IntNegOp -> trivialUCode (NEGI L) x
- IntAbsOp -> absIntCode x
NotOp -> trivialUCode (NOT L) x
then StPrim Float2DoubleOp [x]
else x
in
- getRegister (StCall fn DoubleRep [x])
+ getRegister (StCall fn cCallConv DoubleRep [x])
where
(is_float_op, fn)
= case primop of
-}
SllOp -> shift_code (SHL L) x y {-False-}
- SraOp -> shift_code (SAR L) x y {-False-}
SrlOp -> shift_code (SHR L) x y {-False-}
- {- ToDo: nuke? -}
- ISllOp -> panic "I386Gen:isll"
- ISraOp -> panic "I386Gen:isra"
- ISrlOp -> panic "I386Gen:isrl"
+ 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"
- FloatPowerOp -> getRegister (StCall SLIT("pow") 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") DoubleRep [x, y])
+ DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
where
shift_code :: (Operand -> Operand -> Instr)
-> StixTree
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)
code2 = amodeCode amode
src2 = amodeAddr amode
--- fixedname = registerName register1 eax
code__2 dst = let code1 = registerCode register1 dst
src1 = registerName register1 dst
in asmParThen [code2 asmVoid,code1 asmVoid] .
code1 = amodeCode amode
src1 = amodeAddr amode
--- fixedname = registerName register2 eax
code__2 dst = let code2 = registerCode register2 dst
src2 = registerName register2 dst
in asmParThen [code1 asmVoid,code2 asmVoid] .
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 ->
then StPrim Float2DoubleOp [x]
else x
in
- getRegister (StCall fn DoubleRep [x])
+ getRegister (StCall fn cCallConv DoubleRep [x])
where
(is_float_op, fn)
= case primop of
DoubleSinhOp -> (False, SLIT("sinh"))
DoubleCoshOp -> (False, SLIT("cosh"))
DoubleTanhOp -> (False, SLIT("tanh"))
- _ -> panic ("Monadic PrimOp not handled: " ++ showPrimOp primop)
+ _ -> panic ("Monadic PrimOp not handled: " ++ show primop)
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
OrOp -> trivialCode (OR False) x y
XorOp -> trivialCode (XOR False) x y
SllOp -> trivialCode SLL x y
- SraOp -> trivialCode SRA x y
SrlOp -> trivialCode SRL x y
- ISllOp -> panic "SparcGen:isll"
- ISraOp -> panic "SparcGen:isra"
- ISrlOp -> panic "SparcGen:isrl"
+ ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
+ ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
+ ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
- FloatPowerOp -> getRegister (StCall SLIT("pow") 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") DoubleRep [x, y])
+ DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
-- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!"
where
- imul_div fn x y = getRegister (StCall fn IntRep [x, y])
+ imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
getRegister (StInd pk mem)
= getAmode mem `thenUs` \ amode ->
\begin{code}
genCCall
:: FAST_STRING -- function to call
+ -> CallConv
-> PrimRep -- type of the result
-> [StixTree] -- arguments (of mixed type)
-> UniqSM InstrBlock
#if alpha_TARGET_ARCH
-genCCall fn kind args
+genCCall fn cconv kind args
= mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
`thenUs` \ ((unused,_), argCode) ->
let
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
-genCCall fn kind [StInt i]
+genCCall fn cconv kind [StInt i]
| fn == SLIT ("PerformGC_wrapper")
= let
call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
returnInstrs call
-}
-genCCall fn kind args
+genCCall fn cconv kind args
= mapUs get_call_arg args `thenUs` \ argCode ->
let
nargs = length args
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
-genCCall fn kind args
+genCCall fn cconv kind args
= mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
`thenUs` \ ((unused,_), argCode) ->
let
= getRegister x `thenUs` \ register1 ->
--getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
--- fixedname = registerName register1 eax
code__2 dst = let code1 = registerCode register1 dst
src1 = registerName register1 dst
in code1 .
= getRegister y `thenUs` \ register1 ->
--getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
--- fixedname = registerName register1 eax
code__2 dst = let code1 = registerCode register1 dst
src1 = registerName register1 dst
in code1 .
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
--- fixedname = registerName register eax
code2 = amodeCode amode asmVoid
src2 = amodeAddr amode
code__2 dst = let code1 = registerCode register dst asmVoid
--getNewRegNCG IntRep `thenUs` \ tmp ->
getAmode mem `thenUs` \ amode ->
let
--- fixedname = registerName register eax
code2 = amodeCode amode asmVoid
src2 = amodeAddr amode
code__2 dst = let
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
--- fixedname = registerName register1 eax
code2 = registerCode register2 tmp2 asmVoid
src2 = registerName register2 tmp2
code__2 dst = let
= getRegister x `thenUs` \ register ->
-- getNewRegNCG IntRep `thenUs` \ tmp ->
let
--- fixedname = registerName register eax
code__2 dst = let
code = registerCode register dst
src = registerName register dst
= getRegister x `thenUs` \ register ->
--getNewRegNCG IntRep `thenUs` \ reg ->
let
--- fixedname = registerName register eax
code__2 dst = let
code = registerCode register dst
src = registerName register dst
projects / ghc-hetmet.git / blobdiff