Small step toward call-conv improvement: separate out calls and returns

diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs
index b7e528b..7c70736 100644 (file)
--- a/compiler/cmm/CmmCallConv.hs
+++ b/compiler/cmm/CmmCallConv.hs
@@ -56,19 +56,21 @@ assignArgumentsPos conv isCall arg_ty reps = map cvt assignments
     where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
       regs = if isCall then
                case (reps, conv) of
-                 (_, Native) -> getRegsWithoutNode
+                 (_, NativeCall) -> getRegsWithoutNode
                  (_, GC    ) -> getRegsWithNode
-                 (_, PrimOp) -> allRegs
+                 (_, PrimOpCall) -> allRegs
                  (_, Slow  ) -> noRegs
-                 (_, _     ) -> getRegsWithoutNode
+                 _ -> panic "Unknown calling convention"
              else
                case (reps, conv) of
                  ([_], _)    -> allRegs
-                 (_, Native) -> getRegsWithNode
+                 (_, NativeCall)   -> getRegsWithNode
+                 (_, NativeReturn) -> getRegsWithNode
                  (_, GC    ) -> getRegsWithNode
-                 (_, PrimOp) -> getRegsWithNode
+                 (_, PrimOpCall) -> getRegsWithNode
+                 (_, PrimOpReturn) -> getRegsWithNode
                  (_, Slow  ) -> noRegs
-                 (_, _     ) -> getRegsWithNode
+                 _ -> pprPanic "Unknown calling convention" (ppr conv)
       (sizes, assignments) = unzip $ assignArguments' reps (sum sizes) regs
       assignArguments' [] _ _ = []
       assignArguments' (r:rs) offset avails =

diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs
index 09d5cd5..8869027 100644 (file)
--- a/compiler/cmm/CmmCvt.hs
+++ b/compiler/cmm/CmmCvt.hs
@@ -36,7 +36,7 @@ toZgraph _ _ (ListGraph []) =
   do g <- lgraphOfAGraph emptyAGraph
      return ((0, Nothing), g)
 toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = 
-           let (offset, entry) = mkEntry id Native args in
+           let (offset, entry) = mkEntry id NativeCall args in
            do g <- labelAGraph id $
                      entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
               return ((offset, Nothing), g)
@@ -94,7 +94,7 @@ get_hints (Foreign (ForeignConvention _ _ hints)) Results   = hints
 get_hints _other_conv                            _vd       = repeat NoHint
 
 get_conv :: MidCallTarget -> Convention
-get_conv (PrimTarget _)       = Native
+get_conv (PrimTarget _)       = NativeCall
 get_conv (ForeignTarget _ fc) = Foreign fc
 
 cmm_target :: MidCallTarget -> CmmCallTarget

diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs
index f28e327..29d8daf 100644 (file)
--- a/compiler/cmm/MkZipCfgCmm.hs
+++ b/compiler/cmm/MkZipCfgCmm.hs
@@ -244,22 +244,22 @@ toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> La
 toCall e cont updfr_off res_space arg_space =
   LastCall e cont arg_space res_space (Just updfr_off)
 mkJump e actuals updfr_off =
-  lastWithArgs Jump old Native actuals updfr_off $ toCall e Nothing updfr_off 0
+  lastWithArgs Jump old NativeCall actuals updfr_off $ toCall e Nothing updfr_off 0
 mkJumpGC e actuals updfr_off =
   lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
 mkForeignJump conv e actuals updfr_off =
   lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
 mkReturn e actuals updfr_off =
-  lastWithArgs Ret  old Native actuals updfr_off $ toCall e Nothing updfr_off 0
+  lastWithArgs Ret  old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
     -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
 mkReturnSimple actuals updfr_off =
-  lastWithArgs Ret  old Native actuals updfr_off $ toCall e Nothing updfr_off 0
+  lastWithArgs Ret  old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
     where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
 
 mkFinalCall f _ actuals updfr_off =
-  lastWithArgs Call old Native actuals updfr_off $ toCall f Nothing updfr_off 0
+  lastWithArgs Call old NativeCall actuals updfr_off $ toCall f Nothing updfr_off 0
 
-mkCmmCall f results actuals = mkCall f Native results actuals
+mkCmmCall f results actuals = mkCall f NativeCall 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 =

diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs
index a64a81d..715fd09 100644 (file)
--- a/compiler/cmm/ZipCfgCmmRep.hs
+++ b/compiler/cmm/ZipCfgCmmRep.hs
@@ -110,13 +110,17 @@ data MidCallTarget        -- The target of a MidUnsafeCall
   deriving Eq
 
 data Convention
-  = Native             -- Native C-- call/return
+  = NativeCall   -- Native C-- call
+
+  | NativeReturn -- Native C-- return
 
   | Slow               -- Slow entry points: all args pushed on the stack
 
   | GC                         -- Entry to the garbage collector: uses the node reg!
 
-  | PrimOp             -- Calling prim ops
+  | PrimOpCall   -- Calling prim ops
+
+  | PrimOpReturn -- Returning from prim ops
 
   | Foreign            -- Foreign call/return
        ForeignConvention
@@ -516,12 +520,14 @@ genFullCondBranch expr t f =
          ]
 
 pprConvention :: Convention -> SDoc
-pprConvention (Native {})  = text "<native-convention>"
-pprConvention  Slow        = text "<slow-convention>"
-pprConvention  GC          = text "<gc-convention>"
-pprConvention  PrimOp      = text "<primop-convention>"
-pprConvention (Foreign c)  = ppr c
-pprConvention (Private {}) = text "<private-convention>"
+pprConvention (NativeCall   {}) = text "<native-call-convention>"
+pprConvention (NativeReturn {}) = text "<native-ret-convention>"
+pprConvention  Slow             = text "<slow-convention>"
+pprConvention  GC               = text "<gc-convention>"
+pprConvention  PrimOpCall       = text "<primop-call-convention>"
+pprConvention  PrimOpReturn     = text "<primop-ret-convention>"
+pprConvention (Foreign c)       = ppr c
+pprConvention (Private {})      = text "<private-convention>"
 
 pprForeignConvention :: ForeignConvention -> SDoc
 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs

diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 32e43a7..462def3 100644 (file)
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -465,7 +465,7 @@ 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 Native (entryCode fun') []]  -- Not tagged
+                                     emitCall NativeCall (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/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index dbc97d4..c9f0324 100644 (file)
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -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 Native target args
+  = emitCall NativeCall target args
 
   | otherwise          -- Over-saturated call
   = ASSERT( arity == length initial_reps )
     do { pap_id <- newTemp gcWord
        ; withSequel (AssignTo [pap_id] True)
-                    (emitCall Native target fast_args)
+                    (emitCall NativeCall target fast_args)
        ; slow_call (CmmReg (CmmLocal pap_id)) 
                    rest_args rest_reps }
   where

diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 1419773..fdaba95 100644 (file)
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -607,7 +607,7 @@ emitProcWithConvention conv info lbl args blocks
         ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
 
 emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
-emitProc = emitProcWithConvention Native
+emitProc = emitProcWithConvention NativeCall
 
 emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
 emitSimpleProc lbl code = 

diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 8298b68..1d2f0db 100644 (file)
--- 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 PrimOp fun cmm_args }
+        ; emitCall PrimOpCall fun cmm_args }
 
   | ReturnsPrim VoidRep <- result_info
   = do cgPrimOp [] primop args 

diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index f49c266..9ef5862 100644 (file)
--- 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 Native res' args' updfr_off
+        mkCall fun_expr NativeCall res' args' updfr_off
       else
         mkUnsafeCall (ForeignTarget fun_expr
                          (ForeignConvention CCallConv arg_hints res_hints)) res' args'