Skip to content

GitLab

Commit ec269b12 authored by sewardj's avatar sewardj
Browse files

[project @ 2002-01-29 13:22:28 by sewardj] 

Teach the NCG how to do f-i-dynamic.  Nothing unexpected.
sparc-side now needs fixing.
parent 7f42c60a
Hide whitespace changes
Inline Side-by-side
ghc/compiler/nativeGen/MachCode.lhs
View file @ ec269b12
......@@ -63,6 +63,11 @@ order.
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.
......@@ -156,7 +161,8 @@ derefDLL tree
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
......@@ -878,8 +884,8 @@ getRegister (StMachOp mop [x]) -- unary MachOps
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
......@@ -991,11 +997,11 @@ getRegister (StMachOp mop [x, y]) -- dyadic MachOps
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]
......@@ -2617,7 +2623,7 @@ register allocator.
\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)
......@@ -2698,12 +2704,12 @@ genCCall fn cconv kind args
#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
......@@ -2711,32 +2717,41 @@ genCCall fn cconv ret_rep [StInt i]
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))
......
ghc/compiler/nativeGen/MachMisc.lhs
View file @ ec269b12
......@@ -572,7 +572,7 @@ but we don't care, since it doesn't get used much. We hope.
| JMP DestInfo Operand -- possible dests, target
| JXX Cond CLabel -- target
| CALL Imm
| CALL (Either Imm Reg)
-- Other things.
......
ghc/compiler/nativeGen/PprMach.lhs
View file @ ec269b12
......@@ -971,8 +971,8 @@ pprInstr (POP size op) = pprSizeOp SLIT("pop") size op
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)
......@@ -980,7 +980,8 @@ pprInstr (JXX cond lab) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
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
......
ghc/compiler/nativeGen/RegAllocInfo.lhs
View file @ ec269b12
......@@ -259,7 +259,8 @@ regUsage instr = case instr of
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 [] []
......@@ -679,6 +680,9 @@ patchRegs instr env = case instr of
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
......@@ -686,7 +690,6 @@ patchRegs instr env = case instr of
DATA _ _ -> instr
DELTA _ -> instr
JXX _ _ -> instr
CALL _ -> instr
CLTD -> instr
_ -> pprPanic "patchRegs(x86)" empty
......
ghc/compiler/nativeGen/Stix.lhs
View file @ ec269b12
......@@ -150,7 +150,8 @@ data StixExpr
| 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?
......@@ -206,10 +207,14 @@ pprStixExpr t
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
......@@ -341,7 +346,8 @@ stixExpr_CountTempUses u 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
......@@ -403,7 +409,8 @@ stixExpr_MapUniques f t
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
......
ghc/compiler/nativeGen/StixMacro.lhs
View file @ ec269b12
......@@ -72,7 +72,7 @@ adding an indirection.
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
......@@ -178,7 +178,8 @@ macroCode REGISTER_IMPORT [arg]
macroCode REGISTER_FOREIGN_EXPORT [arg]
= returnUs (
\xs -> StVoidable (
StCall SLIT("getStablePtr") CCallConv VoidRep [amodeToStix arg]
StCall (Left SLIT("getStablePtr")) CCallConv VoidRep
[amodeToStix arg]
)
: xs
)
......
ghc/compiler/nativeGen/StixPrim.lhs
View file @ ec269b12
......@@ -64,7 +64,7 @@ rather than inheriting the calling convention of the thing which we're really
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)
......@@ -77,16 +77,25 @@ foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety)) rhs
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
......@@ -94,11 +103,11 @@ foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety)) rhs
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
......@@ -107,9 +116,6 @@ foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety)) rhs
Int64Rep -> Int64Rep
Word64Rep -> Word64Rep
other -> IntRep
foreignCallCode lhs call rhs
= ncgPrimopMoan "Native code generator can't handle foreign call" (ppr call)
\end{code}
%************************************************************************
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment