From ec269b1201dd73f6173d7d66ddbe2bbbc2244bf2 Mon Sep 17 00:00:00 2001 From: sewardj Date: Tue, 29 Jan 2002 13:22:29 +0000 Subject: [PATCH] [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. --- ghc/compiler/nativeGen/MachCode.lhs | 59 +++++++++++++++++++------------ ghc/compiler/nativeGen/MachMisc.lhs | 2 +- ghc/compiler/nativeGen/PprMach.lhs | 7 ++-- ghc/compiler/nativeGen/RegAllocInfo.lhs | 7 ++-- ghc/compiler/nativeGen/Stix.lhs | 17 ++++++--- ghc/compiler/nativeGen/StixMacro.lhs | 5 +-- ghc/compiler/nativeGen/StixPrim.lhs | 26 ++++++++------ 7 files changed, 78 insertions(+), 45 deletions(-) diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index e120d80..ac2944c 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -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)) diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index ad71188..c29aee4 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -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. diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index e65a6a3..ae2aa96 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -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 diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs index f1149ac..0791d5d 100644 --- a/ghc/compiler/nativeGen/RegAllocInfo.lhs +++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs @@ -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 diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index 573496c..199087d 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -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 diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 141cf98..a57c951 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -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 ) diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index c70a237..6d6db58 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -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} %************************************************************************ -- 1.7.10.4