StCall now takes extra callconv arg; StixPrim.primCode doesn't flush stdout and stderr anymore (it's done in the .hc code)
\begin{code}
intTag :: Literal -> Integer
- intTag (MachChar c) = toInteger (ord c)
+ intTag (MachChar c) = fromInt (ord c)
intTag (MachInt i _) = i
intTag _ = panic "intTag"
mkJumpTable am alts lowTag highTag dflt
= getUniqLabelNCG `thenUs` \ utlbl ->
mapUs genLabel alts `thenUs` \ branches ->
- let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag])
- cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt highTag])
+ let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
+ cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
offset = StPrim IntSubOp [am, StInt lowTag]
genericOpt (StCondJump addr test)
= StCondJump addr (genericOpt test)
-genericOpt (StCall fn pk args)
- = StCall fn pk (map genericOpt args)
+genericOpt (StCall fn cconv pk args)
+ = StCall fn cconv pk (map genericOpt args)
\end{code}
Fold indices together when the types match:
OrOp -> x
XorOp -> x
SllOp -> x
- SraOp -> x
SrlOp -> x
ISllOp -> x
ISraOp -> x
= case op of
IntMulOp -> case exactLog2 n of
Nothing -> StPrim op args
- Just p -> StPrim SllOp [x, StInt p]
+ Just p -> StPrim ISllOp [x, StInt p]
IntQuotOp -> case exactLog2 n of
Nothing -> StPrim op args
- Just p -> StPrim SraOp [x, StInt p]
+ Just p -> StPrim ISrlOp [x, StInt p]
_ -> StPrim op args
\end{code}
)
import Stix ( StixTree )
import Unique ( mkBuiltinUnique )
-import Util ( mapAccumB, panic )
-import GlaExts ( trace )
+import Util ( mapAccumB, panic, trace )
import Outputable
\end{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 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
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
Double2FloatOp -> coerceFltCode x
Float2DoubleOp -> coerceFltCode x
- other_op -> getRegister (StCall fn DoubleRep [x])
+ other_op -> getRegister (StCall fn cconv 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"
+ ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
ISrlOp -> 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
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"
+ ISraOp -> shift_code (SAR L) x y {-False-} --panic "I386Gen:isra"
ISrlOp -> 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
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
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"
+ ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
ISrlOp -> 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
baseRegOffset (FloatReg ILIT(4)) = OFFSET_Flt4
baseRegOffset (DoubleReg ILIT(1)) = OFFSET_Dbl1
baseRegOffset (DoubleReg ILIT(2)) = OFFSET_Dbl2
+#ifdef OFFSET_Lng1
+baseRegOffset (LongReg _ ILIT(1)) = OFFSET_Lng1
+#endif
+#ifdef OFFSET_Lng2
+baseRegOffset (LongReg _ ILIT(2)) = OFFSET_Lng2
+#endif
baseRegOffset TagReg = OFFSET_Tag
baseRegOffset RetReg = OFFSET_Ret
baseRegOffset SpA = OFFSET_SpA
#ifdef CALLER_SAVES_DblReg2
callerSaves (DoubleReg ILIT(2)) = True
#endif
+#ifdef CALLER_SAVES_LngReg1
+callerSaves (LongReg _ ILIT(1)) = True
+#endif
+#ifdef CALLER_SAVES_LngReg2
+callerSaves (LongReg _ ILIT(2)) = True
+#endif
#ifdef CALLER_SAVES_Tag
callerSaves TagReg = True
#endif
#ifdef REG_Dbl2
magicIdRegMaybe (DoubleReg ILIT(2)) = Just (FixedReg ILIT(REG_Dbl2))
#endif
+#ifdef REG_Lng1
+magicIdRegMaybe (LongReg _ ILIT(1)) = Just (FixedReg ILIT(REG_Lng1))
+#endif
+#ifdef REG_Lng2
+magicIdRegMaybe (LongReg _ ILIT(2)) = Just (FixedReg ILIT(REG_Lng2))
+#endif
#ifdef REG_Tag
magicIdRegMaybe TagReg = Just (FixedReg ILIT(REG_TagReg))
#endif
import AbsCSyn ( node, infoptr, MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
+import CallConv ( CallConv )
import CLabel ( mkAsmTempLabel, CLabel )
import PrimRep ( PrimRep )
import PrimOp ( PrimOp )
-- Calls to C functions
- | StCall FAST_STRING PrimRep [StixTree]
+ | StCall FAST_STRING CallConv PrimRep [StixTree]
-- Assembly-language comments
import MachRegs
import AbsCSyn -- bits and bobs...
+import CallConv ( cCallConv )
import Constants ( mIN_MP_INT_SIZE )
import Literal ( Literal(..) )
import OrdList ( OrdList )
result2 = mpStruct 2
result3 = mpStruct 3
result4 = mpStruct 4
-init2 = StCall SLIT("mpz_init") VoidRep [result2]
-init3 = StCall SLIT("mpz_init") VoidRep [result3]
-init4 = StCall SLIT("mpz_init") VoidRep [result4]
+init2 = StCall SLIT("mpz_init") cCallConv VoidRep [result2]
+init3 = StCall SLIT("mpz_init") cCallConv VoidRep [result3]
+init4 = StCall SLIT("mpz_init") cCallConv VoidRep [result4]
gmpTake1Return1 res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda)
= let
safeHp = saveLoc Hp
save = StAssign PtrRep safeHp oldHp
(a1,a2,a3) = toStruct argument1 (aa,sa,da)
- mpz_op = StCall rtn VoidRep [result2, argument1]
+ mpz_op = StCall rtn cCallConv VoidRep [result2, argument1]
restore = StAssign PtrRep stgHp safeHp
(r1,r2,r3) = fromStruct result2 (ar,sr,dr)
in
save = StAssign PtrRep safeHp oldHp
(a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
(a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
- mpz_op = StCall rtn VoidRep [result3, argument1, argument2]
+ mpz_op = StCall rtn cCallConv VoidRep [result3, argument1, argument2]
restore = StAssign PtrRep stgHp safeHp
(r1,r2,r3) = fromStruct result3 (ar,sr,dr)
in
save = StAssign PtrRep safeHp oldHp
(a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
(a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
- mpz_op = StCall rtn VoidRep [result3, result4, argument1, argument2]
+ mpz_op = StCall rtn cCallConv VoidRep [result3, result4, argument1, argument2]
restore = StAssign PtrRep stgHp safeHp
(r1,r2,r3) = fromStruct result3 (ar1,sr1,dr1)
(r4,r5,r6) = fromStruct result4 (ar2,sr2,dr2)
argument2 = StIndex IntRep hp (StInt (toInteger mpIntSize))
(a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
(a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
- mpz_cmp = StCall SLIT("mpz_cmp") IntRep [argument1, argument2]
+ mpz_cmp = StCall SLIT("mpz_cmp") cCallConv IntRep [argument1, argument2]
r1 = StAssign IntRep result mpz_cmp
in
returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
da = amodeToStix cda
(a1,a2,a3) = toStruct hp (aa,sa,da)
- mpz_get_si = StCall SLIT("mpz_get_si") IntRep [hp]
+ mpz_get_si = StCall SLIT("mpz_get_si") cCallConv IntRep [hp]
r1 = StAssign IntRep result mpz_get_si
in
returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
da = amodeToStix cda
(a1,a2,a3) = toStruct hp (aa,sa,da)
- mpz_get_ui = StCall SLIT("mpz_get_ui") IntRep [hp]
+ mpz_get_ui = StCall SLIT("mpz_get_ui") cCallConv IntRep [hp]
r1 = StAssign WordRep result mpz_get_ui
in
returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
safeHp = saveLoc Hp
save = StAssign PtrRep safeHp oldHp
result = StIndex IntRep stgHpLim (StInt (toInteger (-mpIntSize)))
- set_str = StCall SLIT("mpz_init_set_str") IntRep
+ set_str = StCall SLIT("mpz_init_set_str") cCallConv IntRep
[result, amodeToStix str, StInt 10]
test = StPrim IntEqOp [set_str, StInt 0]
cjmp = StCondJump ulbl test
- abort = StCall SLIT("abort") VoidRep []
+ abort = StCall SLIT("abort") cCallConv VoidRep []
join = StLabel ulbl
restore = StAssign PtrRep stgHp safeHp
(a1,a2,a3) = fromStruct result (ar,sr,dr)
FloatRep -> SLIT("__encodeFloat")
DoubleRep -> SLIT("__encodeDouble")
_ -> panic "encodeFloatingKind"
- encode = StCall fn pk' [hp, expon]
+ encode = StCall fn cCallConv pk' [hp, expon]
r1 = StAssign pk' result encode
in
returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
FloatRep -> SLIT("__decodeFloat")
DoubleRep -> SLIT("__decodeDouble")
_ -> panic "decodeFloatingKind"
- decode = StCall fn VoidRep [mantissa, hp, arg]
+ decode = StCall fn cCallConv VoidRep [mantissa, hp, arg]
(a1,a2,a3) = fromStruct mantissa (ar,sr,dr)
a4 = StAssign IntRep exponr (StInd IntRep hp)
in
import MachMisc
import MachRegs
import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode )
+import CallConv ( cCallConv )
import Constants ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
sTD_UF_SIZE
)
cjmp = StCondJump ulbl test
arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness]
-- ToDo: Overflow? (JSM)
- gc = StCall SLIT("PerformGC_wrapper") VoidRep [arg]
+ gc = StCall SLIT("PerformGC_wrapper") cCallConv VoidRep [arg]
join = StLabel ulbl
in
returnUs (\xs -> assign : cjmp : gc : join : xs)
updatePAP, stackOverflow :: StixTree
updatePAP = StJump (sStLitLbl SLIT("UpdatePAP"))
-stackOverflow = StCall SLIT("StackOverflow") VoidRep []
+stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
\end{code}
import AbsCSyn
import AbsCUtils ( getAmodeRep, mixedTypeLocn )
+import CallConv ( cCallConv )
import Constants ( spARelToInt, spBRelToInt )
import CostCentre ( noCostCentreAttached )
import HeapOffs ( hpRelToInt, subOff )
\end{code}
The @ErrorIO@ primitive is actually a bit weird...assign a new value
-to the root closure, flush stdout and stderr, and jump to the
-@ErrorIO_innards@.
+to the root closure, and jump to the @ErrorIO_innards@.
\begin{code}
primCode [] ErrorIOPrimOp [rhs]
= let
changeTop = StAssign PtrRep topClosure (amodeToStix rhs)
in
- returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
+ returnUs (\xs -> changeTop : errorIO : xs)
\end{code}
@newArray#@ ops allocate heap space.
loc = StIndex PtrRep stgHp
(StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
assign = StAssign PtrRep result loc
- initialise = StCall SLIT("newArrZh_init") VoidRep [result, n, initial]
+ initialise = StCall SLIT("newArrZh_init") cCallConv VoidRep [result, n, initial]
in
heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
lhs' = amodeToStix lhs
pk = getAmodeRep lhs
sp' = amodeToStix sp
- call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
+ call = StCall SLIT("deRefStablePointer") cCallConv pk [sp', smStablePtrTable]
assign = StAssign pk lhs' call
in
returnUs (\xs -> assign : xs)
lhs' = amodeToStix lhs
a' = amodeToStix a
pk = getAmodeRep lhs -- an IntRep
- call = StCall SLIT("SeqZhCode") pk [a']
+ call = StCall SLIT("SeqZhCode") cCallConv pk [a']
assign = StAssign pk lhs' call
in
-- trace "SeqOp" $
returnUs (\xs -> assign : xs)
-primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
+primCode lhs (CCallOp (Just fn) is_asm may_gc cconv arg_tys result_ty) rhs
| is_asm = error "ERROR: Native code generator can't handle casm"
| otherwise
= case lhs of
- [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
+ [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs)
[lhs] ->
let lhs' = amodeToStix lhs
pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
- call = StAssign pk lhs' (StCall fn pk args)
+ call = StAssign pk lhs' (StCall fn cconv pk args)
in
returnUs (\xs -> call : xs)
where
amodeToStix (CIntLike (CLit (MachInt i _)))
= StPrim IntAddOp [intLikePtr, StInt off]
where
- off = toInteger intLikeSize * i
+ off = toInteger intLikeSize * toInteger i
amodeToStix (CIntLike x)
= StPrim IntAddOp [intLikePtr, off]
MachChar c -> StInt (toInteger (ord c))
MachStr s -> StString s
MachAddr a -> StInt a
- MachInt i _ -> StInt i
+ MachInt i _ -> StInt (toInteger i)
MachLitLit s _ -> StLitLit s
MachFloat d -> StDouble d
MachDouble d -> StDouble d
-- Trees for the ErrorIOPrimOp
-topClosure, flushStdout, flushStderr, errorIO :: StixTree
+topClosure, errorIO :: StixTree
topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
-flushStdout = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stdout")]
-flushStderr = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stderr")]
errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
\end{code}