X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmLayout.hs;h=9e7263c0917c7eedb7dceed8de99cad6fb4241bb;hb=dd56e9ab4544e83d27532a8d9058140bfe81825c;hp=1269897f4e99b115fc500a86126f40da00e8ee3d;hpb=e6243a818496aad82b6f47511d3bd9bc800f747d;p=ghc-hetmet.git

diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 1269897..9e7263c 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -77,26 +77,30 @@ emitReturn :: [CmmExpr] -> FCode ()
 --	return (x,y)
 -- If the sequel is AssignTo [p,q]
 --	p=x; q=y; 
-emitReturn results 
-  = do  { adjustHpBackwards
-	; sequel    <- getSequel;
-	; updfr_off <- getUpdFrameOff
-	; case sequel of
-	    Return _        -> emit (mkReturnSimple results updfr_off)
-	    AssignTo regs _ -> emit (mkMultiAssign  regs results)
-    }
+emitReturn results
+  = do { sequel    <- getSequel;
+       ; updfr_off <- getUpdFrameOff
+       ; emit $ mkComment $ mkFastString ("emitReturn: " ++ show sequel)
+       ; case sequel of
+           Return _ ->
+             do { adjustHpBackwards
+                ; emit (mkReturnSimple results updfr_off) }
+           AssignTo regs adjust ->
+             do { if adjust then adjustHpBackwards else return ()
+                ; 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"
+        ; emit $ mkComment $ mkFastString ("emitCall: " ++ show sequel)
 	; case sequel of
-	    Return _              -> emit (mkForeignJump conv fun args updfr_off)
-	    AssignTo res_regs srt -> 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 ()
@@ -157,16 +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 (NativeDirectCall, NativeReturn) target args
 
   | otherwise		-- Over-saturated call
   = ASSERT( arity == length initial_reps )
     do	{ pap_id <- newTemp gcWord
-	; let srt = pprTrace "Urk! SRT for over-sat call" 
-			     (ppr lbl) NoC_SRT
-		-- XXX: what if rest_args contains static refs?
-	; withSequel (AssignTo [pap_id] srt)
-		     (emitCall Native target fast_args)
+	; withSequel (AssignTo [pap_id] True)
+		     (emitCall (NativeDirectCall, NativeReturn) target fast_args)
 	; slow_call (CmmReg (CmmLocal pap_id)) 
 		    rest_args rest_reps }
   where
@@ -349,7 +350,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
@@ -466,15 +467,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
-        ; arg_regs <-
-            pprTrace "bindArgsToRegs" (ppr args) $
-            bindArgsToRegs args
-        ; emitClosureAndInfoTable cl_info (node : arg_regs) $ body (node, arg_regs)
+        ; let node_points = nodeMustPointToIt lf_info
+        ; arg_regs <- bindArgsToRegs args
+        ; 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
@@ -483,7 +484,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