Use "ReturnedTo" when generating safe foreign calls

4 files changed, 33 insertions, 34 deletions

diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index d82b4bc3b1..d8127ab737 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -52,7 +52,7 @@ import OrdList
 import MkGraph
 
 import Data.IORef
-import Control.Monad (when)
+import Control.Monad (when,void)
 import Util
 
 codeGen :: DynFlags
@@ -244,9 +244,9 @@ cgDataCon data_con
  	        do { _ <- ticky_code
 		   ; ldvEnter (CmmReg nodeReg)
 		   ; tickyReturnOldCon (length arg_things)
-                   ; _ <- emitReturn [cmmOffsetB (CmmReg nodeReg)
+                   ; void $ emitReturn [cmmOffsetB (CmmReg nodeReg)
                                             (tagForCon data_con)]
-                   ; return () }
+                   }
                         -- The case continuation code expects a tagged pointer
 
 	    arg_reps :: [(PrimRep, UnaryType)]
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 148d53a4e3..861c4e33e1 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -436,8 +436,8 @@ closureCodeBody top_lvl bndr cl_info _cc args arity body fv_details
                 -- heap check, to reduce live vars over check
                 ; if node_points then load_fvs node lf_info fv_bindings
                                  else return ()
-                ; _ <- cgExpr body
-                ; return () }}
+                ; void $ cgExpr body
+                }}
   }
 
 -- A function closure pointer may be tagged, so we
@@ -503,8 +503,7 @@ thunkCode cl_info fv_details _cc node arity body
                ; let lf_info = closureLFInfo cl_info
                ; fv_bindings <- mapM bind_fv fv_details
                ; load_fvs node lf_info fv_bindings
-               ; _ <- cgExpr body
-               ; return () }}}
+               ; void $ cgExpr body }}}
 
 
 ------------------------------------------------------------------------
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index a6274662ad..8fec067288 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -41,6 +41,7 @@ import Outputable
 import BasicTypes
 
 import Control.Monad
+import Prelude hiding( succ )
 
 -----------------------------------------------------------------------------
 -- Code generation for Foreign Calls
@@ -88,13 +89,11 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
         ; sequel <- getSequel
         ; case sequel of
             AssignTo assign_to_these _ ->
-                do { emitForeignCall safety assign_to_these call_target
+                emitForeignCall safety assign_to_these call_target
                                      call_args CmmMayReturn
-                   ; return AssignedDirectly
-                   }
 
             _something_else ->
-                do { emitForeignCall safety res_regs call_target
+                do { _ <- emitForeignCall safety res_regs call_target
                                      call_args CmmMayReturn
                    ; emitReturn (map (CmmReg . CmmLocal) res_regs)
                    }
@@ -185,7 +184,7 @@ emitCCall :: [(CmmFormal,ForeignHint)]
           -> [(CmmActual,ForeignHint)]
           -> FCode ()
 emitCCall hinted_results fn hinted_args
-  = emitForeignCall PlayRisky results target args CmmMayReturn
+  = void $ emitForeignCall PlayRisky results target args CmmMayReturn
   where
     (args, arg_hints) = unzip hinted_args
     (results, result_hints) = unzip hinted_results
@@ -195,7 +194,7 @@ emitCCall hinted_results fn hinted_args
 
 emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
 emitPrimCall res op args
-  = emitForeignCall PlayRisky res (PrimTarget op) args CmmMayReturn
+  = void $ emitForeignCall PlayRisky res (PrimTarget op) args CmmMayReturn
 
 -- alternative entry point, used by CmmParse
 emitForeignCall
@@ -205,20 +204,34 @@ emitForeignCall
         -> [CmmActual]          -- arguments
         -> CmmReturnInfo        -- This can say "never returns"
                                 --   only RTS procedures do this
-        -> FCode ()
+        -> FCode ReturnKind
 emitForeignCall safety results target args _ret
   | not (playSafe safety) = do
     let (caller_save, caller_load) = callerSaveVolatileRegs
     emit caller_save
     emit $ mkUnsafeCall target results args
     emit caller_load
+    return AssignedDirectly
 
   | otherwise = do
     updfr_off <- getUpdFrameOff
     temp_target <- load_target_into_temp target
-    emit =<< mkSafeCall temp_target results args updfr_off
-                (playInterruptible safety)
-
+    k <- newLabelC
+    let (off, copyout) = copyInOflow NativeReturn (Young k) results
+       -- see Note [safe foreign call convention]
+    emit $
+           (    mkStore (CmmStackSlot (Young k) (widthInBytes wordWidth))
+                        (CmmLit (CmmBlock k))
+            <*> mkLast (CmmForeignCall { tgt  = temp_target
+                                       , res  = results
+                                       , args = args
+                                       , succ = k
+                                       , updfr = updfr_off
+                                       , intrbl = playInterruptible safety })
+            <*> mkLabel k
+            <*> copyout
+           )
+    return (ReturnedTo k off)
 
 
 {-
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index eb6b9a988f..3d34cb9bdd 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -30,7 +30,7 @@ module StgCmmMonad (
 	getCodeR, getCode, getHeapUsage,
 
         mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
-        mkCall, mkCmmCall, mkSafeCall,
+        mkCall, mkCmmCall,
 
         forkClosureBody, forkStatics, forkAlts, forkProc, codeOnly,
 
@@ -95,6 +95,9 @@ infixr 9 `thenFC`
 
 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
 
+instance Functor FCode where
+  fmap f (FCode g) = FCode $ \i s -> let (a,s') = g i s in (f a, s')
+
 instance Monad FCode where
 	(>>=) = thenFC
 	return = returnFC
@@ -792,22 +795,6 @@ mkCmmCall f results actuals updfr_off
    = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off (0,[])
 
 
-mkSafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]
-           -> UpdFrameOffset -> Bool
-           -> FCode CmmAGraph
-mkSafeCall   t fs as upd i = do
-  k <- newLabelC
-  let (_off, copyout) = copyInOflow NativeReturn (Young k) fs
-    -- see Note [safe foreign call convention]
-  return
-     (    mkStore (CmmStackSlot (Young k) (widthInBytes wordWidth))
-                  (CmmLit (CmmBlock k))
-      <*> mkLast (CmmForeignCall { tgt=t, res=fs, args=as, succ=k
-                                 , updfr=upd, intrbl=i })
-      <*> mkLabel k
-      <*> copyout
-     )
-
 -- ----------------------------------------------------------------------------
 -- CgStmts