X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmLayout.hs;h=84d4ef0362c1fa05ba3d9d1eab27fca1cfc07922;hb=1e50fd4185479a62e02d987bdfcb1c62712859ca;hp=47df62162200725101af8aa6b2aa2c49ca307cbd;hpb=5d1c70a506f366eca47464f2a354de8cc0d9a795;p=ghc-hetmet.git

diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 47df621..84d4ef0 100644
--- 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
@@ -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 (NativeCall, NativeReturn) 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 (NativeCall, NativeReturn) target fast_args)
+		     (emitCall (NativeDirectCall, NativeReturn) target fast_args)
 	; slow_call (CmmReg (CmmLocal pap_id)) 
 		    rest_args rest_reps }
   where
@@ -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