Teach the NCG how to do f-i-dynamic. Nothing unexpected.
sparc-side now needs fixing.
type InstrBlock = OrdList Instr
x `bind` f = f x
+
+isLeft (Left _) = True
+isLeft (Right _) = False
+
+unLeft (Left x) = x
\end{code}
Code extractor for an entire stix tree---stix statement level.
StIndex pk base offset -> StIndex pk (qq base) (qq offset)
StMachOp mop args -> StMachOp mop (map qq args)
StInd pk addr -> StInd pk (qq addr)
- StCall who cc pk args -> StCall who cc pk (map qq args)
+ StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args)
+ StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args)
StInt _ -> t
StFloat _ -> t
StDouble _ -> t
other_op
-> getRegister (
(if is_float_op then demote else id)
- (StCall fn CCallConv DoubleRep
- [(if is_float_op then promote else id) x])
+ (StCall (Left fn) CCallConv DoubleRep
+ [(if is_float_op then promote else id) x])
)
where
integerExtend signed nBits x
MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
MO_Flt_Pwr -> getRegister (demote
- (StCall SLIT("pow") CCallConv DoubleRep
- [promote x, promote y])
+ (StCall (Left SLIT("pow")) CCallConv DoubleRep
+ [promote x, promote y])
)
- MO_Dbl_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
- [x, y])
+ MO_Dbl_Pwr -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep
+ [x, y])
other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
where
promote x = StMachOp MO_Flt_to_Dbl [x]
\begin{code}
genCCall
- :: FAST_STRING -- function to call
+ :: (Either FAST_STRING StixExpr) -- function to call
-> CCallConv
-> PrimRep -- type of the result
-> [StixExpr] -- arguments (of mixed type)
#if i386_TARGET_ARCH
genCCall fn cconv ret_rep [StInt i]
- | fn == SLIT ("PerformGC_wrapper")
+ | isLeft fn && unLeft fn == SLIT ("PerformGC_wrapper")
= let call = toOL [
MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
- CALL (ImmLit (ptext (if underscorePrefix
+ CALL (Left (ImmLit (ptext (if underscorePrefix
then (SLIT ("_PerformGC_wrapper"))
- else (SLIT ("PerformGC_wrapper")))))
+ else (SLIT ("PerformGC_wrapper"))))))
]
in
returnNat call
genCCall fn cconv ret_rep args
= mapNat push_arg
- (reverse args) `thenNat` \ sizes_n_codes ->
- getDeltaNat `thenNat` \ delta ->
- let (sizes, codes) = unzip sizes_n_codes
- tot_arg_size = sum sizes
- code2 = concatOL codes
- call = toOL (
- [CALL (fn__2 tot_arg_size)]
- ++
+ (reverse args) `thenNat` \ sizes_n_codes ->
+ getDeltaNat `thenNat` \ delta ->
+ let (sizes, push_codes) = unzip sizes_n_codes
+ tot_arg_size = sum sizes
+ in
+ -- deal with static vs dynamic call targets
+ (case fn of
+ Left t_static
+ -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
+ Right dyn
+ -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
+ ASSERT(dyn_rep == L)
+ returnNat (dyn_c `snocOL` CALL (Right dyn_r))
+ )
+ `thenNat` \ callinsns ->
+ let push_code = concatOL push_codes
+ call = callinsns `appOL`
+ toOL (
-- Deallocate parameters after call for ccall;
-- but not for stdcall (callee does it)
(if cconv == StdCallConv then [] else
[ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
++
-
[DELTA (delta + tot_arg_size)]
)
in
setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
- returnNat (code2 `appOL` call)
+ returnNat (push_code `appOL` call)
where
-- function names that begin with '.' are assumed to be special
-- internally generated names like '.mul,' which don't get an
-- underscore prefix
-- ToDo:needed (WDP 96/03) ???
- fn_u = _UNPK_ fn
+ fn_u = _UNPK_ (unLeft fn)
fn__2 tot_arg_size
| head fn_u == '.'
= ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
| JMP DestInfo Operand -- possible dests, target
| JXX Cond CLabel -- target
- | CALL Imm
+ | CALL (Either Imm Reg)
-- Other things.
pprInstr PUSHA = ptext SLIT("\tpushal")
pprInstr POPA = ptext SLIT("\tpopal")
-pprInstr (NOP) = ptext SLIT("\tnop")
-pprInstr (CLTD) = ptext SLIT("\tcltd")
+pprInstr NOP = ptext SLIT("\tnop")
+pprInstr CLTD = ptext SLIT("\tcltd")
pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op)
pprInstr (JMP dsts (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
pprInstr (JMP dsts op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
-pprInstr (CALL imm) = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
+pprInstr (CALL (Left imm)) = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
+pprInstr (CALL (Right reg)) = (<>) (ptext SLIT("\tcall *")) (pprReg L reg)
-- First bool indicates signedness; second whether quot or rem
pprInstr (IQUOT sz src dst) = pprInstr_quotRem True True sz src dst
SETCC cond op -> mkRU [] (def_W op)
JXX cond lbl -> mkRU [] []
JMP dsts op -> mkRU (use_R op) []
- CALL imm -> mkRU [] callClobberedRegs
+ CALL (Left imm) -> mkRU [] callClobberedRegs
+ CALL (Right reg) -> mkRU [reg] callClobberedRegs
CLTD -> mkRU [eax] [edx]
NOP -> mkRU [] []
GCOS sz src dst -> GCOS sz (env src) (env dst)
GTAN sz src dst -> GTAN sz (env src) (env dst)
+ CALL (Left imm) -> instr
+ CALL (Right reg) -> CALL (Right (env reg))
+
COMMENT _ -> instr
SEGMENT _ -> instr
LABEL _ -> instr
DATA _ _ -> instr
DELTA _ -> instr
JXX _ _ -> instr
- CALL _ -> instr
CLTD -> instr
_ -> pprPanic "patchRegs(x86)" empty
| StMachOp MachOp [StixExpr]
-- Calls to C functions
- | StCall FAST_STRING CCallConv PrimRep [StixExpr]
+ | StCall (Either FAST_STRING StixExpr) -- Left: static, Right: dynamic
+ CCallConv PrimRep [StixExpr]
-- What's the PrimRep of the value denoted by this StixExpr?
StReg reg -> pprStixReg reg
StMachOp op args -> pprMachOp op
<> parens (hsep (punctuate comma (map pprStixExpr args)))
- StCall nm cc k args
- -> parens (text "Call" <+> ptext nm <+>
+ StCall fn cc k args
+ -> parens (text "Call" <+> targ <+>
ppr cc <+> ppr k <+>
hsep (map pprStixExpr args))
+ where
+ targ = case fn of
+ Left t_static -> ptext t_static
+ Right t_dyn -> parens (pprStixExpr t_dyn)
pprStixStmt :: StixStmt -> SDoc
pprStixStmt t
StIndex pk t1 t2 -> qe t1 + qe t2
StInd pk t1 -> qe t1
StMachOp mop ts -> sum (map qe ts)
- StCall nm cconv pk ts -> sum (map qe ts)
+ StCall (Left nm) cconv pk ts -> sum (map qe ts)
+ StCall (Right f) cconv pk ts -> sum (map qe ts) + qe f
StInt _ -> 0
StFloat _ -> 0
StDouble _ -> 0
StIndex pk t1 t2 -> StIndex pk (qe t1) (qe t2)
StInd pk t1 -> StInd pk (qe t1)
StMachOp mop args -> StMachOp mop (map qe args)
- StCall nm cconv pk ts -> StCall nm cconv pk (map qe ts)
+ StCall (Left nm) cconv pk ts -> StCall (Left nm) cconv pk (map qe ts)
+ StCall (Right f) cconv pk ts -> StCall (Right (qe f)) cconv pk (map qe ts)
StInt _ -> t
StFloat _ -> t
StDouble _ -> t
macroCode UPD_CAF args
= let
[cafptr,bhptr] = map amodeToStix args
- new_caf = StVoidable (StCall SLIT("newCAF") CCallConv VoidRep [cafptr])
+ new_caf = StVoidable (StCall (Left SLIT("newCAF")) CCallConv VoidRep [cafptr])
a1 = StAssignMem PtrRep (StIndex PtrRep cafptr fixedHS) bhptr
a2 = StAssignMem PtrRep cafptr ind_static_info
in
macroCode REGISTER_FOREIGN_EXPORT [arg]
= returnUs (
\xs -> StVoidable (
- StCall SLIT("getStablePtr") CCallConv VoidRep [amodeToStix arg]
+ StCall (Left SLIT("getStablePtr")) CCallConv VoidRep
+ [amodeToStix arg]
)
: xs
)
calling.
\begin{code}
-foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety)) rhs
+foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs
| not (playSafe safety)
= returnUs (\xs -> ccall : xs)
id = StixTemp (StixVReg uniq IntRep)
suspend = StAssignReg IntRep id
- (StCall SLIT("suspendThread") {-no:cconv-} CCallConv
+ (StCall (Left SLIT("suspendThread")) {-no:cconv-} CCallConv
IntRep [StReg stgBaseReg])
resume = StVoidable
- (StCall SLIT("resumeThread") {-no:cconv-} CCallConv
+ (StCall (Left SLIT("resumeThread")) {-no:cconv-} CCallConv
VoidRep [StReg id])
in
returnUs (\xs -> save (suspend : ccall : resume : load xs))
where
- args = map amodeCodeForCCall rhs
+ (cargs, stix_target)
+ = case ctarget of
+ StaticTarget nm -> (rhs, Left nm)
+ DynamicTarget | not (null rhs) -- an assertion
+ -> (tail rhs, Right (amodeToStix (head rhs)))
+ CasmTarget _
+ -> ncgPrimopMoan "Native code generator can't handle foreign call"
+ (ppr call)
+
+ stix_args = map amodeCodeForCCall cargs
amodeCodeForCCall x =
let base = amodeToStix' x
in
ArrayRep -> StIndex PtrRep base arrPtrsHS
ByteArrayRep -> StIndex IntRep base arrWordsHS
ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
- _ -> base
+ other -> base
ccall = case lhs of
- [] -> StVoidable (StCall fn cconv VoidRep args)
- [lhs] -> mkStAssign pk lhs' (StCall fn cconv pk args)
+ [] -> StVoidable (StCall stix_target cconv VoidRep stix_args)
+ [lhs] -> mkStAssign pk lhs' (StCall stix_target cconv pk stix_args)
where
lhs' = amodeToStix lhs
pk = case getAmodeRep lhs of
Int64Rep -> Int64Rep
Word64Rep -> Word64Rep
other -> IntRep
-
-foreignCallCode lhs call rhs
- = ncgPrimopMoan "Native code generator can't handle foreign call" (ppr call)
\end{code}
%************************************************************************
projects / ghc-hetmet.git / commitdiff