diff options
| -rw-r--r-- | compiler/cmm/Cmm.hs | 121 | ||||
| -rw-r--r-- | compiler/cmm/CmmBrokenBlock.hs | 45 | ||||
| -rw-r--r-- | compiler/cmm/CmmCPS.hs | 86 | ||||
| -rw-r--r-- | compiler/cmm/CmmCPSGen.hs | 10 | ||||
| -rw-r--r-- | compiler/cmm/CmmLive.hs | 2 | ||||
| -rw-r--r-- | compiler/cmm/CmmOpt.hs | 4 | ||||
| -rw-r--r-- | compiler/cmm/CmmParse.y | 8 | ||||
| -rw-r--r-- | compiler/cmm/PprC.hs | 2 | ||||
| -rw-r--r-- | compiler/cmm/PprCmm.hs | 4 | ||||
| -rw-r--r-- | compiler/codeGen/CgForeignCall.hs | 10 | ||||
| -rw-r--r-- | compiler/codeGen/CgHpc.hs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/CgPrimOp.hs | 4 | ||||
| -rw-r--r-- | compiler/codeGen/CgUtils.hs | 2 | ||||
| -rw-r--r-- | compiler/nativeGen/AsmCodeGen.lhs | 4 | ||||
| -rw-r--r-- | compiler/nativeGen/MachCodeGen.hs | 18 |
15 files changed, 190 insertions, 132 deletions
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 27bf8d6bd6..5b3ad1668f 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -47,42 +47,49 @@ import Data.Word -- re-orderd during code generation. -- GenCmm is abstracted over --- (a) the type of static data elements --- (b) the contents of a basic block. +-- d, the type of static data elements in CmmData +-- h, the static info preceding the code of a CmmProc +-- i, the contents of a basic block within a CmmProc +-- -- We expect there to be two main instances of this type: --- (a) Plain C--, i.e. populated with CmmLit and CmmExpr respectively, --- (b) Native code, populated with instructions +-- (a) C--, i.e. populated with various C-- constructs +-- (Cmm and RawCmm below) +-- (b) Native code, populated with data/instructions -- newtype GenCmm d h i = Cmm [GenCmmTop d h i] --- | Cmm with the info table as a data type -type Cmm = GenCmm CmmStatic CmmInfo CmmStmt - --- | Cmm with the info tables converted to a list of 'CmmStatic' -type RawCmm = GenCmm CmmStatic [CmmStatic] CmmStmt - --- A top-level chunk, abstracted over the type of the contents of +-- | A top-level chunk, abstracted over the type of the contents of -- the basic blocks (Cmm or instructions are the likely instantiations). data GenCmmTop d h i - = CmmProc + = CmmProc -- A procedure h -- Extra header such as the info table CLabel -- Used to generate both info & entry labels CmmFormals -- Argument locals live on entry (C-- procedure params) [GenBasicBlock i] -- Code, may be empty. The first block is - -- the entry point. The order is otherwise initially + -- the entry point, and should be labelled by the code gen + -- with the CLabel. The order is otherwise initially -- unimportant, but at some point the code gen will -- fix the order. - -- the BlockId of the first block does not give rise + -- The BlockId of the first block does not give rise -- to a label. To jump to the first block in a Proc, -- use the appropriate CLabel. - -- some static data. - | CmmData Section [d] -- constant values only + -- BlockIds are only unique within a procedure + + | CmmData -- Static data + Section + [d] +-- | Cmm with the info table as a data type +type Cmm = GenCmm CmmStatic CmmInfo CmmStmt type CmmTop = GenCmmTop CmmStatic CmmInfo CmmStmt + +-- | Cmm with the info tables converted to a list of 'CmmStatic' +type RawCmm = GenCmm CmmStatic [CmmStatic] CmmStmt type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] CmmStmt + -- A basic block containing a single label, at the beginning. -- The list of basic blocks in a top-level code block may be re-ordered. -- Fall-through is not allowed: there must be an explicit jump at the @@ -90,12 +97,7 @@ type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] CmmStmt -- blocks in order to turn some jumps into fallthroughs. data GenBasicBlock i = BasicBlock BlockId [i] - -- ToDo: Julian suggests that we might need to annotate this type - -- with the out & in edges in the graph, i.e. two * [BlockId]. This - -- information can be derived from the contents, but it might be - -- helpful to cache it here. - -type CmmBasicBlock = GenBasicBlock CmmStmt +type CmmBasicBlock = GenBasicBlock CmmStmt blockId :: GenBasicBlock i -> BlockId -- The branch block id is that of the first block in @@ -113,9 +115,9 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs) data CmmInfo = CmmInfo - (Maybe BlockId) -- GC target. Nothing <=> CPS won't do stack check + (Maybe BlockId) -- GC target. Nothing <=> CPS won't do stack check (Maybe UpdateFrame) -- Update frame - CmmInfoTable -- Info table + CmmInfoTable -- Info table -- Info table as a haskell data type data CmmInfoTable @@ -174,7 +176,7 @@ data CmmStmt | CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is -- given by cmmExprRep of the rhs. - | CmmCall -- A foreign call, with + | CmmCall -- A call (forign, native or primitive), with CmmCallTarget CmmHintFormals -- zero or more results CmmActuals -- zero or more arguments @@ -190,18 +192,18 @@ data CmmStmt -- one -> second block etc -- Undefined outside range, and when there's a Nothing - | CmmJump CmmExpr -- Jump to another function, - CmmActuals -- with these parameters. + | CmmJump CmmExpr -- Jump to another C-- function, + CmmActuals -- with these parameters. - | CmmReturn -- Return from a function, - CmmActuals -- with these return values. + | CmmReturn -- Return from a native C-- function, + CmmActuals -- with these return values. -type CmmActual = CmmExpr -type CmmActuals = [(CmmActual,MachHint)] -type CmmFormal = LocalReg +type CmmActual = CmmExpr +type CmmActuals = [(CmmActual,MachHint)] +type CmmFormal = LocalReg type CmmHintFormals = [(CmmFormal,MachHint)] -type CmmFormals = [CmmFormal] -data CmmSafety = CmmUnsafe | CmmSafe C_SRT +type CmmFormals = [CmmFormal] +data CmmSafety = CmmUnsafe | CmmSafe C_SRT {- Discussion @@ -246,12 +248,12 @@ So we'll stick with the way it is, and add the optimisation to the NCG. ----------------------------------------------------------------------------- data CmmCallTarget - = CmmForeignCall -- Call to a foreign function + = CmmCallee -- Call a function (foreign or native) CmmExpr -- literal label <=> static call -- other expression <=> dynamic call CCallConv -- The calling convention - | CmmPrim -- Call to a "primitive" (eg. sin, cos) + | CmmPrim -- Call a "primitive" (eg. sin, cos) CallishMachOp -- These might be implemented as inline -- code by the backend. @@ -272,22 +274,11 @@ data CmmExpr -- where rep = cmmRegRep reg deriving Eq -cmmExprRep :: CmmExpr -> MachRep -cmmExprRep (CmmLit lit) = cmmLitRep lit -cmmExprRep (CmmLoad _ rep) = rep -cmmExprRep (CmmReg reg) = cmmRegRep reg -cmmExprRep (CmmMachOp op _) = resultRepOfMachOp op -cmmExprRep (CmmRegOff reg _) = cmmRegRep reg - data CmmReg = CmmLocal LocalReg | CmmGlobal GlobalReg deriving( Eq ) -cmmRegRep :: CmmReg -> MachRep -cmmRegRep (CmmLocal reg) = localRegRep reg -cmmRegRep (CmmGlobal reg) = globalRegRep reg - -- | Whether a 'LocalReg' is a GC followable pointer data Kind = KindPtr | KindNonPtr deriving (Eq) @@ -297,17 +288,6 @@ data LocalReg MachRep -- ^ Type Kind -- ^ Should the GC follow as a pointer -instance Eq LocalReg where - (LocalReg u1 _ _) == (LocalReg u2 _ _) = u1 == u2 - -instance Uniquable LocalReg where - getUnique (LocalReg uniq _ _) = uniq - -localRegRep :: LocalReg -> MachRep -localRegRep (LocalReg _ rep _) = rep - -localRegGCFollow (LocalReg _ _ p) = p - data CmmLit = CmmInt Integer MachRep -- Interpretation: the 2's complement representation of the value @@ -329,6 +309,31 @@ data CmmLit | CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset deriving Eq +instance Eq LocalReg where + (LocalReg u1 _ _) == (LocalReg u2 _ _) = u1 == u2 + +instance Uniquable LocalReg where + getUnique (LocalReg uniq _ _) = uniq + +----------------------------------------------------------------------------- +-- MachRep +----------------------------------------------------------------------------- +cmmExprRep :: CmmExpr -> MachRep +cmmExprRep (CmmLit lit) = cmmLitRep lit +cmmExprRep (CmmLoad _ rep) = rep +cmmExprRep (CmmReg reg) = cmmRegRep reg +cmmExprRep (CmmMachOp op _) = resultRepOfMachOp op +cmmExprRep (CmmRegOff reg _) = cmmRegRep reg + +cmmRegRep :: CmmReg -> MachRep +cmmRegRep (CmmLocal reg) = localRegRep reg +cmmRegRep (CmmGlobal reg) = globalRegRep reg + +localRegRep :: LocalReg -> MachRep +localRegRep (LocalReg _ rep _) = rep + +localRegGCFollow (LocalReg _ _ p) = p + cmmLitRep :: CmmLit -> MachRep cmmLitRep (CmmInt _ rep) = rep cmmLitRep (CmmFloat _ rep) = rep diff --git a/compiler/cmm/CmmBrokenBlock.hs b/compiler/cmm/CmmBrokenBlock.hs index 0f732d3a6a..cc968f1758 100644 --- a/compiler/cmm/CmmBrokenBlock.hs +++ b/compiler/cmm/CmmBrokenBlock.hs @@ -59,16 +59,20 @@ data BrokenBlock } -- | How a block could be entered +-- See Note [An example of CPS conversion] data BlockEntryInfo = FunctionEntry -- ^ Block is the beginning of a function CmmInfo -- ^ Function header info CLabel -- ^ The function name CmmFormals -- ^ Aguments to function + -- Only the formal parameters are live | ContinuationEntry -- ^ Return point of a function call CmmFormals -- ^ return values (argument to continuation) C_SRT -- ^ SRT for the continuation's info table Bool -- ^ True <=> GC block so ignore stack size + -- Live variables, other than + -- the return values, are on the stack | ControlEntry -- ^ Any other kind of block. -- Only entered due to control flow. @@ -77,6 +81,39 @@ data BlockEntryInfo -- no return values, but some live might end up as -- params or possibly in the frame +{- Note [An example of CPS conversion] + +This is NR's and SLPJ's guess about how things might work; +it may not be consistent with the actual code (particularly +in the matter of what's in parameters and what's on the stack). + +f(x,y) { + if x>2 then goto L + x = x+1 +L: if x>1 then y = g(y) + else x = x+1 ; + return( x+y ) +} + BECOMES + +f(x,y) { // FunctionEntry + if x>2 then goto L + x = x+1 +L: // ControlEntry + if x>1 then push x; push f1; jump g(y) + else x=x+1; jump f2(x, y) +} + +f1(y) { // ContinuationEntry + pop x; jump f2(x, y); +} + +f2(x, y) { // ProcPointEntry + return (z+y); +} + +-} + data ContFormat = ContFormat CmmHintFormals -- ^ return values (argument to continuation) C_SRT -- ^ SRT for the continuation's info table @@ -97,7 +134,7 @@ data FinalStmt CmmExpr -- ^ The function to call CmmActuals -- ^ Arguments of the call - | FinalCall -- ^ Same as 'CmmForeignCall' + | FinalCall -- ^ Same as 'CmmCallee' -- followed by 'CmmGoto' BlockId -- ^ Target of the 'CmmGoto' -- (must be a 'ContinuationEntry') @@ -238,9 +275,13 @@ breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry = next_id = BlockId $ head uniques block = do_call current_id entry accum_stmts exits next_id target results arguments srt - cont_info = (next_id, + + cont_info = (next_id, -- Entry convention for the + -- continuation of the call ContFormat results srt (ident `elem` gc_block_idents)) + + -- Break up the part after the call (cont_infos, blocks) = breakBlock' (tail uniques) next_id ControlEntry [] [] stmts diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index 3d14f190d3..e68216ac64 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -40,68 +40,63 @@ import Data.List -- |Top level driver for the CPS pass ----------------------------------------------------------------------------- cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm - -> [GenCmm CmmStatic CmmInfo CmmStmt] -- ^ Input C-- with Proceedures - -> IO [GenCmm CmmStatic CmmInfo CmmStmt] -- ^ Output CPS transformed C-- -cmmCPS dflags abstractC = do - when (dopt Opt_DoCmmLinting dflags) $ - do showPass dflags "CmmLint" - case firstJust $ map cmmLint abstractC of - Just err -> do printDump err - ghcExit dflags 1 - Nothing -> return () - showPass dflags "CPS" + -> [Cmm] -- ^ Input C-- with Proceedures + -> IO [Cmm] -- ^ Output CPS transformed C-- +cmmCPS dflags cmm_with_calls + = do { when (dopt Opt_DoCmmLinting dflags) $ + do showPass dflags "CmmLint" + case firstJust $ map cmmLint cmm_with_calls of + Just err -> do printDump err + ghcExit dflags 1 + Nothing -> return () + ; showPass dflags "CPS" -- TODO: more lint checking -- check for use of branches to non-existant blocks -- check for use of Sp, SpLim, R1, R2, etc. - uniqSupply <- mkSplitUniqSupply 'p' - let supplies = listSplitUniqSupply uniqSupply - let doCpsProc s (Cmm c) = - Cmm $ concat $ zipWith cpsProc (listSplitUniqSupply s) c - let continuationC = zipWith doCpsProc supplies abstractC + ; uniqSupply <- mkSplitUniqSupply 'p' + ; let supplies = listSplitUniqSupply uniqSupply + ; let cpsd_cmm = zipWith doCpsProc supplies cmm_with_calls - dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC) + ; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms cpsd_cmm) -- TODO: add option to dump Cmm to file - return continuationC + ; return cpsd_cmm } -make_stack_check stack_check_block_id info stack_use next_block_id = - BasicBlock stack_check_block_id $ - check_stmts ++ [CmmBranch next_block_id] - where - check_stmts = - case info of - -- If we are given a stack check handler, - -- then great, well check the stack. - CmmInfo (Just gc_block) _ _ - -> [CmmCondBranch - (CmmMachOp (MO_U_Lt $ cmmRegRep spReg) - [CmmReg stack_use, CmmReg spLimReg]) - gc_block] - -- If we aren't given a stack check handler, - -- then humph! we just won't check the stack for them. - CmmInfo Nothing _ _ - -> [] ----------------------------------------------------------------------------- -- |CPS a single CmmTop (proceedure) -- Only 'CmmProc' are transformed 'CmmData' will be left alone. ----------------------------------------------------------------------------- +doCpsProc :: UniqSupply -> Cmm -> Cmm +doCpsProc s (Cmm c) + = Cmm $ concat $ zipWith cpsProc (listSplitUniqSupply s) c + cpsProc :: UniqSupply - -> GenCmmTop CmmStatic CmmInfo CmmStmt -- ^Input proceedure - -> [GenCmmTop CmmStatic CmmInfo CmmStmt] -- ^Output proceedure and continuations + -> CmmTop -- ^Input procedure + -> [CmmTop] -- ^Output procedures; + -- a single input procedure is converted to + -- multiple output procedures -- Data blocks don't need to be CPS transformed cpsProc uniqSupply proc@(CmmData _ _) = [proc] -- Empty functions just don't work with the CPS algorithm, but -- they don't need the transformation anyway so just output them directly -cpsProc uniqSupply proc@(CmmProc _ _ _ []) = [proc] +cpsProc uniqSupply proc@(CmmProc _ _ _ []) + = pprTrace "cpsProc: unexpected empty proc" (ppr proc) [proc] -- CPS transform for those procs that actually need it +-- The plan is this: +-- +-- * Introduce a stack-check block as the first block +-- * The first blocks gets a FunctionEntry; the rest are ControlEntry +-- * Now break each block into a bunch of blocks (at call sites); +-- all but the first will be ContinuationEntry +-- cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs where -- We need to be generating uniques for several things. @@ -187,6 +182,23 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs cps_procs :: [CmmTop] cps_procs = zipWith (continuationToProc formats' stack_use) proc_uniques continuations' +make_stack_check stack_check_block_id info stack_use next_block_id = + BasicBlock stack_check_block_id $ + check_stmts ++ [CmmBranch next_block_id] + where + check_stmts = + case info of + -- If we are given a stack check handler, + -- then great, well check the stack. + CmmInfo (Just gc_block) _ _ + -> [CmmCondBranch + (CmmMachOp (MO_U_Lt $ cmmRegRep spReg) + [CmmReg stack_use, CmmReg spLimReg]) + gc_block] + -- If we aren't given a stack check handler, + -- then humph! we just won't check the stack for them. + CmmInfo Nothing _ _ + -> [] ----------------------------------------------------------------------------- collectNonProcPointTargets :: diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs index 87c8845cfb..732c962667 100644 --- a/compiler/cmm/CmmCPSGen.hs +++ b/compiler/cmm/CmmCPSGen.hs @@ -193,7 +193,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques tail_call curr_stack target arguments -- A regular Cmm function call - FinalCall next (CmmForeignCall target CmmCallConv) + FinalCall next (CmmCallee target CmmCallConv) results arguments _ _ -> pack_continuation curr_format cont_format ++ tail_call (curr_stack - cont_stack) @@ -204,10 +204,10 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques cont_stack = continuation_frame_size cont_format -- A safe foreign call - FinalCall next (CmmForeignCall target conv) + FinalCall next (CmmCallee target conv) results arguments _ _ -> target_stmts ++ - foreignCall call_uniques' (CmmForeignCall new_target conv) + foreignCall call_uniques' (CmmCallee new_target conv) results arguments where (call_uniques', target_stmts, new_target) = @@ -226,12 +226,12 @@ foreignCall uniques call results arguments = arg_stmts ++ saveThreadState ++ caller_save ++ - [CmmCall (CmmForeignCall suspendThread CCallConv) + [CmmCall (CmmCallee suspendThread CCallConv) [ (id,PtrHint) ] [ (CmmReg (CmmGlobal BaseReg), PtrHint) ] CmmUnsafe, CmmCall call results new_args CmmUnsafe, - CmmCall (CmmForeignCall resumeThread CCallConv) + CmmCall (CmmCallee resumeThread CCallConv) [ (new_base, PtrHint) ] [ (CmmReg (CmmLocal id), PtrHint) ] CmmUnsafe, diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs index bee3c65b07..958ba81821 100644 --- a/compiler/cmm/CmmLive.hs +++ b/compiler/cmm/CmmLive.hs @@ -176,7 +176,7 @@ cmmStmtLive _ (CmmCall target results arguments _) = addKilled (mkUniqSet $ cmmHintFormalsToLiveLocals results) where target_liveness = case target of - (CmmForeignCall target _) -> cmmExprLive target + (CmmCallee target _) -> cmmExprLive target (CmmPrim _) -> id cmmStmtLive other_live (CmmBranch target) = addLive (lookupWithDefaultUFM other_live emptyUniqSet target) diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 0a6c193546..b0ec5a1ad6 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -141,7 +141,7 @@ getStmtUses (CmmAssign _ e) = getExprUses e getStmtUses (CmmStore e1 e2) = plusUFM_C (+) (getExprUses e1) (getExprUses e2) getStmtUses (CmmCall target _ es _) = plusUFM_C (+) (uses target) (getExprsUses (map fst es)) - where uses (CmmForeignCall e _) = getExprUses e + where uses (CmmCallee e _) = getExprUses e uses _ = emptyUFM getStmtUses (CmmCondBranch e _) = getExprUses e getStmtUses (CmmSwitch e _) = getExprUses e @@ -162,7 +162,7 @@ inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e) inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2) inlineStmt u a (CmmCall target regs es srt) = CmmCall (infn target) regs es' srt - where infn (CmmForeignCall fn cconv) = CmmForeignCall fn cconv + where infn (CmmCallee fn cconv) = CmmCallee fn cconv infn (CmmPrim p) = CmmPrim p es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ] inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 579df5e8ab..c2dd22f8dc 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -877,17 +877,17 @@ foreignCall conv_string results_code expr_code args_code vols safety results <- sequence results_code expr <- expr_code args <- sequence args_code - --code (stmtC (CmmCall (CmmForeignCall expr convention) results args safety)) + --code (stmtC (CmmCall (CmmCallee expr convention) results args safety)) case convention of -- Temporary hack so at least some functions are CmmSafe - CmmCallConv -> code (stmtC (CmmCall (CmmForeignCall expr convention) results args safety)) + CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety)) _ -> case safety of CmmUnsafe -> code (emitForeignCall' PlayRisky results - (CmmForeignCall expr convention) args vols NoC_SRT) + (CmmCallee expr convention) args vols NoC_SRT) CmmSafe srt -> code (emitForeignCall' (PlaySafe unused) results - (CmmForeignCall expr convention) args vols NoC_SRT) where + (CmmCallee expr convention) args vols NoC_SRT) where unused = panic "not used by emitForeignCall'" primCall diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 77b8a8fd5d..238fd61248 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -199,7 +199,7 @@ pprStmt stmt = case stmt of where rep = cmmExprRep src - CmmCall (CmmForeignCall fn cconv) results args safety -> + CmmCall (CmmCallee fn cconv) results args safety -> -- Controversial: leave this out for now. -- pprUndef fn $$ diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 9221c086af..2d3fd6a746 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -212,7 +212,7 @@ pprStmt stmt = case stmt of -- call "ccall" foo(x, y)[r1, r2]; -- ToDo ppr volatile - CmmCall (CmmForeignCall fn cconv) results args safety -> + CmmCall (CmmCallee fn cconv) results args safety -> hcat [ if null results then empty else parens (commafy $ map ppr results) <> @@ -226,7 +226,7 @@ pprStmt stmt = case stmt of target fn' = parens (ppr fn') CmmCall (CmmPrim op) results args safety -> - pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv) + pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) results args safety) where lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False) diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index ce272e9a86..dd959943fb 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -73,7 +73,7 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live = do vols <- getVolatileRegs live srt <- getSRTInfo emitForeignCall' safety results - (CmmForeignCall cmm_target cconv) call_args (Just vols) srt + (CmmCallee cmm_target cconv) call_args (Just vols) srt where (call_args, cmm_target) = case target of @@ -128,12 +128,12 @@ emitForeignCall' safety results target args vols srt -- Once that happens, this function will just emit a (CmmSafe srt) call, -- and the CPS will will be the one to convert that -- to this sequence of three CmmUnsafe calls. - stmtC (CmmCall (CmmForeignCall suspendThread CCallConv) + stmtC (CmmCall (CmmCallee suspendThread CCallConv) [ (id,PtrHint) ] [ (CmmReg (CmmGlobal BaseReg), PtrHint) ] CmmUnsafe) stmtC (CmmCall temp_target results temp_args CmmUnsafe) - stmtC (CmmCall (CmmForeignCall resumeThread CCallConv) + stmtC (CmmCall (CmmCallee resumeThread CCallConv) [ (new_base, PtrHint) ] [ (CmmReg (CmmLocal id), PtrHint) ] CmmUnsafe) @@ -159,9 +159,9 @@ load_args_into_temps = mapM arg_assign_temp tmp <- maybe_assign_temp e return (tmp,hint) -load_target_into_temp (CmmForeignCall expr conv) = do +load_target_into_temp (CmmCallee expr conv) = do tmp <- maybe_assign_temp expr - return (CmmForeignCall tmp conv) + return (CmmCallee tmp conv) load_target_into_temp other_target = return other_target diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs index 811029bb18..e846f0e791 100644 --- a/compiler/codeGen/CgHpc.hs +++ b/compiler/codeGen/CgHpc.hs @@ -65,7 +65,7 @@ initHpc this_mod (HpcInfo tickCount hashNo) ; emitForeignCall' PlayRisky [(id,NoHint)] - (CmmForeignCall + (CmmCallee (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False) CCallConv ) diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index e489d73646..049e12a986 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -117,7 +117,7 @@ emitPrimOp [res] ParOp [arg] live vols <- getVolatileRegs live emitForeignCall' PlayRisky [(res,NoHint)] - (CmmForeignCall newspark CCallConv) + (CmmCallee newspark CCallConv) [(CmmReg (CmmGlobal BaseReg), PtrHint), (arg,PtrHint)] (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky @@ -133,7 +133,7 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmForeignCall (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) + (CmmCallee (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) CCallConv) [(CmmReg (CmmGlobal BaseReg), PtrHint), (mutv,PtrHint)] (Just vols) diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 19f5eabb2f..9ebcf90e30 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -358,7 +358,7 @@ emitRtsCall' res fun args vols safe = do stmtsC caller_load where (caller_save, caller_load) = callerSaveVolatileRegs vols - target = CmmForeignCall fun_expr CCallConv + target = CmmCallee fun_expr CCallConv fun_expr = mkLblExpr (mkRtsCodeLabel fun) ----------------------------------------------------------------------------- diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 3036a7ac6a..672ff6906e 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -519,9 +519,9 @@ cmmStmtConFold stmt CmmCall target regs args srt -> do target' <- case target of - CmmForeignCall e conv -> do + CmmCallee e conv -> do e' <- cmmExprConFold CallReference e - return $ CmmForeignCall e' conv + return $ CmmCallee e' conv other -> return other args' <- mapM (\(arg, hint) -> do arg' <- cmmExprConFold DataReference arg diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs index d07803de14..e6cb6fc05d 100644 --- a/compiler/nativeGen/MachCodeGen.hs +++ b/compiler/nativeGen/MachCodeGen.hs @@ -3089,11 +3089,11 @@ genCCall target dest_regs args = do (callinsns,cconv) <- case target of -- CmmPrim -> ... - CmmForeignCall (CmmLit (CmmLabel lbl)) conv + CmmCallee (CmmLit (CmmLabel lbl)) conv -> -- ToDo: stdcall arg sizes return (unitOL (CALL (Left fn_imm) []), conv) where fn_imm = ImmCLbl lbl - CmmForeignCall expr conv + CmmCallee expr conv -> do (dyn_c, dyn_r, dyn_rep) <- get_op expr ASSERT(dyn_rep == I32) return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) @@ -3202,7 +3202,7 @@ outOfLineFloatOp mop res args = do dflags <- getDynFlagsNat targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl - let target = CmmForeignCall targetExpr CCallConv + let target = CmmCallee targetExpr CCallConv if localRegRep res == F64 then @@ -3307,11 +3307,11 @@ genCCall target dest_regs args = do (callinsns,cconv) <- case target of -- CmmPrim -> ... - CmmForeignCall (CmmLit (CmmLabel lbl)) conv + CmmCallee (CmmLit (CmmLabel lbl)) conv -> -- ToDo: stdcall arg sizes return (unitOL (CALL (Left fn_imm) arg_regs), conv) where fn_imm = ImmCLbl lbl - CmmForeignCall expr conv + CmmCallee expr conv -> do (dyn_r, dyn_c) <- getSomeReg expr return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) @@ -3461,9 +3461,9 @@ genCCall target dest_regs argsAndHints = do vregs = concat vregss -- deal with static vs dynamic call targets callinsns <- (case target of - CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> do + CmmCallee (CmmLit (CmmLabel lbl)) conv -> do return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - CmmForeignCall expr conv -> do + CmmCallee expr conv -> do (dyn_c, [dyn_r]) <- arg_to_int_vregs expr return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) CmmPrim mop -> do @@ -3658,8 +3658,8 @@ genCCall target dest_regs argsAndHints (toOL []) [] (labelOrExpr, reduceToF32) <- case target of - CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False) - CmmForeignCall expr conv -> return (Right expr, False) + CmmCallee (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False) + CmmCallee expr conv -> return (Right expr, False) CmmPrim mop -> outOfLineFloatOp mop let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode |