RTS tidyup sweep, first phase

[ghc-hetmet.git] / compiler / codeGen / StgCmmLayout.hs

diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index dbc97d4..11a3257 100644 (file)
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -59,7 +59,6 @@ import StaticFlags
 import Bitmap
 import Data.Bits
 
-import Maybes
 import Constants
 import Util
 import Data.List
@@ -90,17 +89,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 +160,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 (NativeDirectCall, NativeReturn) 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 (NativeDirectCall, NativeReturn) target fast_args)
        ; slow_call (CmmReg (CmmLocal pap_id)) 
                    rest_args rest_reps }
   where
@@ -314,7 +313,7 @@ mkVirtHeapOffsets is_thunk things
 -------------------------------------------------------------------------
 
 -- bring in ARG_P, ARG_N, etc.
-#include "../includes/StgFun.h"
+#include "../includes/rts/storage/FunTypes.h"
 
 -------------------------
 -- argDescrType :: ArgDescr -> StgHalfWord
@@ -350,7 +349,7 @@ stdPattern reps
   = case reps of
        []  -> Just ARG_NONE    -- just void args, probably
        [N] -> Just ARG_N
-       [P] -> Just ARG_N
+       [P] -> Just ARG_P
        [F] -> Just ARG_F
        [D] -> Just ARG_D
        [L] -> Just ARG_L
@@ -467,13 +466,15 @@ emitClosureProcAndInfoTable :: Bool                    -- top-level?
                             -> FCode ()
 emitClosureProcAndInfoTable top_lvl bndr cl_info args body
  = do  { let lf_info = closureLFInfo cl_info
-       -- Bind the binder itself, but only if it's not a top-level
+        -- Bind the binder itself, but only if it's not a top-level
         -- binding. We need non-top let-bindings to refer to the
         -- top-level binding, which this binding would incorrectly shadow.
         ; node <- if top_lvl then return $ idToReg (NonVoid bndr)
                   else bindToReg (NonVoid bndr) lf_info
+        ; let node_points = nodeMustPointToIt lf_info
         ; arg_regs <- bindArgsToRegs args
-        ; emitClosureAndInfoTable cl_info (node : arg_regs) $ body (node, arg_regs)
+        ; let args' = if node_points then (node : arg_regs) else arg_regs
+        ; emitClosureAndInfoTable cl_info args' $ body (node, arg_regs)
         }
 
 -- Data constructors need closures, but not with all the argument handling
@@ -482,7 +483,9 @@ emitClosureAndInfoTable :: ClosureInfo -> [LocalReg] -> FCode () -> FCode ()
 emitClosureAndInfoTable cl_info args body
   = do { info <- mkCmmInfo cl_info
        ; blks <- getCode body
-       ; emitProc info (infoLblToEntryLbl info_lbl) args blks
+       ; let conv = if nodeMustPointToIt (closureLFInfo cl_info) then NativeNodeCall
+                    else NativeDirectCall
+       ; emitProcWithConvention conv info (infoLblToEntryLbl info_lbl) args blks
        }
   where
     info_lbl = infoTableLabelFromCI cl_info