From: dias@eecs.tufts.edu Date: Mon, 23 Mar 2009 17:28:37 +0000 (+0000) Subject: Another small step: call and return conventions specified separately when making... X-Git-Tag: 2009-06-25~402 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=5d1c70a506f366eca47464f2a354de8cc0d9a795 Another small step: call and return conventions specified separately when making calls --- diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index 7c70736..d40edae 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -60,14 +60,13 @@ assignArgumentsPos conv isCall arg_ty reps = map cvt assignments (_, GC ) -> getRegsWithNode (_, PrimOpCall) -> allRegs (_, Slow ) -> noRegs - _ -> panic "Unknown calling convention" + _ -> pprPanic "Unknown calling convention" (ppr conv) else case (reps, conv) of ([_], _) -> allRegs (_, NativeCall) -> getRegsWithNode (_, NativeReturn) -> getRegsWithNode (_, GC ) -> getRegsWithNode - (_, PrimOpCall) -> getRegsWithNode (_, PrimOpReturn) -> getRegsWithNode (_, Slow ) -> noRegs _ -> pprPanic "Unknown calling convention" (ppr conv) diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 8869027..4eedd55 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -48,7 +48,7 @@ toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = mkStmts (CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss mkStmts (CmmStore l r : ss) = mkStore l r <*> mkStmts ss mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe _) CmmMayReturn : ss) = - mkCall f conv' (map hintlessCmm res) (map hintlessCmm args) updfr_sz + mkCall f (conv', conv') (map hintlessCmm res) (map hintlessCmm args) updfr_sz <*> mkStmts ss where conv' = Foreign (ForeignConvention conv [] []) -- JD: DUBIOUS mkStmts (CmmCall (CmmPrim {}) _ _ (CmmSafe _) _ : _) = diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index 29d8daf..9786029 100644 --- a/compiler/cmm/MkZipCfgCmm.hs +++ b/compiler/cmm/MkZipCfgCmm.hs @@ -60,7 +60,7 @@ mkAssign :: CmmReg -> CmmExpr -> CmmAGraph mkStore :: CmmExpr -> CmmExpr -> CmmAGraph ---------- Calls -mkCall :: CmmExpr -> Convention -> CmmFormals -> CmmActuals -> +mkCall :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph @@ -259,14 +259,15 @@ mkReturnSimple actuals updfr_off = mkFinalCall f _ actuals updfr_off = lastWithArgs Call old NativeCall actuals updfr_off $ toCall f Nothing updfr_off 0 -mkCmmCall f results actuals = mkCall f NativeCall results actuals +mkCmmCall f results actuals = mkCall f (NativeCall, NativeReturn) results actuals -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later. -mkCall f conv results actuals updfr_off = - pprTrace "mkCall" (ppr f <+> ppr actuals <+> ppr results <+> ppr conv) $ +mkCall f (callConv, retConv) results actuals updfr_off = + pprTrace "mkCall" (ppr f <+> ppr actuals <+> ppr results <+> ppr callConv <+> + ppr retConv) $ withFreshLabel "call successor" $ \k -> let area = CallArea $ Young k - (off, copyin) = copyInOflow conv False area results - copyout = lastWithArgs Call area conv actuals updfr_off + (off, copyin) = copyInOflow retConv False area results + copyout = lastWithArgs Call area callConv actuals updfr_off (toCall f (Just k) updfr_off off) in (copyout <*> mkLabel k <*> copyin) diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index 715fd09..43f57a0 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -114,16 +114,16 @@ data Convention | NativeReturn -- Native C-- return - | Slow -- Slow entry points: all args pushed on the stack + | Slow -- Slow entry points: all args pushed on the stack - | GC -- Entry to the garbage collector: uses the node reg! + | GC -- Entry to the garbage collector: uses the node reg! | PrimOpCall -- Calling prim ops | PrimOpReturn -- Returning from prim ops - | Foreign -- Foreign call/return - ForeignConvention + | Foreign -- Foreign call/return + ForeignConvention | Private -- Used for control transfers within a (pre-CPS) procedure All diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 462def3..f3687fc 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -465,7 +465,8 @@ cgTailCall fun_id fun_info args = do ; [ret,call] <- forkAlts [ getCode $ emitReturn [fun], -- Is tagged; no need to untag getCode $ do emit (mkAssign nodeReg fun) - emitCall NativeCall (entryCode fun') []] -- Not tagged + emitCall (NativeCall, NativeReturn) + (entryCode fun') []] -- Not tagged ; emit (mkCmmIfThenElse (cmmIsTagged fun) ret call) } SlowCall -> do -- A slow function call via the RTS apply routines diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 676aa4f..0e3501a 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -352,7 +352,7 @@ entryHeapCheck fun arity args code | otherwise = case gc_lbl (fun : args) of Just lbl -> mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl))) args' updfr_sz - Nothing -> mkCall generic_gc GC [] [] updfr_sz + Nothing -> mkCall generic_gc (GC, GC) [] [] updfr_sz gc_lbl :: [LocalReg] -> Maybe LitString {- @@ -386,13 +386,13 @@ altHeapCheck regs code heapCheck False (gc_call updfr_sz) code where gc_call updfr_sz - | null regs = mkCall generic_gc GC [] [] updfr_sz + | null regs = mkCall generic_gc (GC, GC) [] [] updfr_sz | Just gc_lbl <- rts_label regs -- Canned call - = mkCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) GC + = mkCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) (GC, GC) regs (map (CmmReg . CmmLocal) regs) updfr_sz | otherwise -- No canned call, and non-empty live vars - = mkCall generic_gc GC [] [] updfr_sz + = mkCall generic_gc (GC, GC) [] [] updfr_sz {- rts_label [reg] diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index c9f0324..47df621 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -90,17 +90,17 @@ emitReturn results ; emit (mkMultiAssign regs results) } } -emitCall :: Convention -> CmmExpr -> [CmmExpr] -> FCode () +emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode () -- (cgCall fun args) makes a call to the entry-code of 'fun', -- passing 'args', and returning the results to the current sequel -emitCall conv fun args +emitCall convs@(callConv, _) fun args = do { adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff ; emit $ mkComment $ mkFastString ("emitCall: " ++ show sequel) ; case sequel of - Return _ -> emit (mkForeignJump conv fun args updfr_off) - AssignTo res_regs _ -> emit (mkCall fun conv res_regs args updfr_off) + Return _ -> emit (mkForeignJump callConv fun args updfr_off) + AssignTo res_regs _ -> emit (mkCall fun convs res_regs args updfr_off) } adjustHpBackwards :: FCode () @@ -161,13 +161,13 @@ direct_call caller lbl arity args reps <+> ppr args <+> ppr reps ) | null rest_reps -- Precisely the right number of arguments - = emitCall NativeCall target args + = emitCall (NativeCall, NativeReturn) target args | otherwise -- Over-saturated call = ASSERT( arity == length initial_reps ) do { pap_id <- newTemp gcWord ; withSequel (AssignTo [pap_id] True) - (emitCall NativeCall target fast_args) + (emitCall (NativeCall, NativeReturn) target fast_args) ; slow_call (CmmReg (CmmLocal pap_id)) rest_args rest_reps } where diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 1d2f0db..7bc75de 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -82,7 +82,7 @@ cgOpApp (StgPrimOp primop) args res_ty | primOpOutOfLine primop = do { cmm_args <- getNonVoidArgAmodes args ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) - ; emitCall PrimOpCall fun cmm_args } + ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args } | ReturnsPrim VoidRep <- result_info = do cgPrimOp [] primop args diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 9ef5862..eb437a9 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -314,7 +314,7 @@ emitRtsCall' res fun args _vols safe where call updfr_off = if safe then - mkCall fun_expr NativeCall res' args' updfr_off + mkCmmCall fun_expr res' args' updfr_off else mkUnsafeCall (ForeignTarget fun_expr (ForeignConvention CCallConv arg_hints res_hints)) res' args'