Another small step: call and return conventions specified separately when making...

diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs
index 7c70736..d40edae 100644 (file)
--- 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
                  (_, 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
              else
                case (reps, conv) of
                  ([_], _)    -> allRegs
                  (_, NativeCall)   -> getRegsWithNode
                  (_, NativeReturn) -> getRegsWithNode
                  (_, GC    ) -> getRegsWithNode

-                 (_, PrimOpCall) -> getRegsWithNode

                  (_, PrimOpReturn) -> getRegsWithNode
                  (_, Slow  ) -> noRegs
                  _ -> pprPanic "Unknown calling convention" (ppr conv)
                  (_, 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 (file)
--- 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) =
         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 _) _ : _) =
             <*> 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 (file)
--- a/compiler/cmm/MkZipCfgCmm.hs
+++ b/compiler/cmm/MkZipCfgCmm.hs
@@ -60,7 +60,7 @@ mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
 
 ---------- Calls
 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
 
 ---------- Calls

-mkCall       :: CmmExpr -> Convention -> CmmFormals -> CmmActuals ->
+mkCall       :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals ->

                   UpdFrameOffset -> CmmAGraph
 mkCmmCall    :: CmmExpr ->              CmmFormals -> CmmActuals ->
                   UpdFrameOffset -> CmmAGraph
                   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
 
 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.
 
 -- 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
   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)
                                (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 (file)
--- a/compiler/cmm/ZipCfgCmmRep.hs
+++ b/compiler/cmm/ZipCfgCmmRep.hs
@@ -114,16 +114,16 @@ data Convention
 
   | NativeReturn -- Native C-- return
 
 
   | 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
 
 
   | 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
 
   | 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 (file)
--- 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)
                    ; [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
                   ; 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 (file)
--- 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
        | 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
 {-
 
     gc_lbl :: [LocalReg] -> Maybe LitString
 {-

@@ -386,13 +386,13 @@ altHeapCheck regs code
        heapCheck False (gc_call updfr_sz) code
   where
     gc_call updfr_sz
        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
 
        | 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
                    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] 
 
 {-
     rts_label [reg] 

diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index c9f0324..47df621 100644 (file)
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -90,17 +90,17 @@ emitReturn results
                 ; emit (mkMultiAssign  regs 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
 -- (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
   = 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 ()
     }
 
 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
                            <+> 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)
 
   | 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
        ; 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 (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))
   | 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 
 
   | ReturnsPrim VoidRep <- result_info
   = do cgPrimOp [] primop args 

diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 9ef5862..eb437a9 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
   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'
       else
         mkUnsafeCall (ForeignTarget fun_expr
                          (ForeignConvention CCallConv arg_hints res_hints)) res' args'