X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmLayout.hs;h=21e55ee074ded1985908b3a7b9db0dcab008f31c;hp=8c7c4342779278352af99246772d985f851b81c3;hb=9a82b1ffa35fa4c3927c66a1037a37d436cf6aac;hpb=a8e1e190ee5aa16f31bdde26daf3c897314e8994

diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 8c7c434..21e55ee 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -59,12 +59,11 @@ import StaticFlags
 import Bitmap
 import Data.Bits
 
-import Maybes
 import Constants
 import Util
 import Data.List
 import Outputable
-import FastString	( mkFastString, LitString, sLit )
+import FastString	( mkFastString, FastString, fsLit )
 
 ------------------------------------------------------------------------
 --		Call and return sequences
@@ -181,29 +180,29 @@ slow_call :: CmmExpr -> [CmmExpr] -> [LRep] -> FCode ()
 slow_call fun args reps
   = do call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps
        emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (ppr fun) ++
-                                        " with pat " ++ showSDoc (ptext rts_fun))
+                                        " with pat " ++ showSDoc (ftext rts_fun))
        emit (mkAssign nodeReg fun <*> call)
   where
     (rts_fun, arity) = slowCallPattern reps
 
 -- These cases were found to cover about 99% of all slow calls:
-slowCallPattern :: [LRep] -> (LitString, Arity)
+slowCallPattern :: [LRep] -> (FastString, Arity)
 -- Returns the generic apply function and arity
-slowCallPattern (P: P: P: P: P: P: _) = (sLit "stg_ap_pppppp", 6)
-slowCallPattern (P: P: P: P: P: _)    = (sLit "stg_ap_ppppp", 5)
-slowCallPattern (P: P: P: P: _)       = (sLit "stg_ap_pppp", 4)
-slowCallPattern (P: P: P: V: _)       = (sLit "stg_ap_pppv", 4)
-slowCallPattern (P: P: P: _)          = (sLit "stg_ap_ppp", 3)
-slowCallPattern (P: P: V: _)          = (sLit "stg_ap_ppv", 3)
-slowCallPattern (P: P: _)	      = (sLit "stg_ap_pp", 2)
-slowCallPattern (P: V: _)	      = (sLit "stg_ap_pv", 2)
-slowCallPattern (P: _)		      = (sLit "stg_ap_p", 1)
-slowCallPattern (V: _)		      = (sLit "stg_ap_v", 1)
-slowCallPattern (N: _)		      = (sLit "stg_ap_n", 1)
-slowCallPattern (F: _)		      = (sLit "stg_ap_f", 1)
-slowCallPattern (D: _)		      = (sLit "stg_ap_d", 1)
-slowCallPattern (L: _)		      = (sLit "stg_ap_l", 1)
-slowCallPattern []		      = (sLit "stg_ap_0", 0)
+slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)
+slowCallPattern (P: P: P: P: P: _)    = (fsLit "stg_ap_ppppp", 5)
+slowCallPattern (P: P: P: P: _)       = (fsLit "stg_ap_pppp", 4)
+slowCallPattern (P: P: P: V: _)       = (fsLit "stg_ap_pppv", 4)
+slowCallPattern (P: P: P: _)          = (fsLit "stg_ap_ppp", 3)
+slowCallPattern (P: P: V: _)          = (fsLit "stg_ap_ppv", 3)
+slowCallPattern (P: P: _)	      = (fsLit "stg_ap_pp", 2)
+slowCallPattern (P: V: _)	      = (fsLit "stg_ap_pv", 2)
+slowCallPattern (P: _)		      = (fsLit "stg_ap_p", 1)
+slowCallPattern (V: _)		      = (fsLit "stg_ap_v", 1)
+slowCallPattern (N: _)		      = (fsLit "stg_ap_n", 1)
+slowCallPattern (F: _)		      = (fsLit "stg_ap_f", 1)
+slowCallPattern (D: _)		      = (fsLit "stg_ap_d", 1)
+slowCallPattern (L: _)		      = (fsLit "stg_ap_l", 1)
+slowCallPattern []		      = (fsLit "stg_ap_0", 0)
 
 
 -------------------------------------------------------------------------
@@ -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
@@ -401,7 +400,7 @@ mkLiveness name size bits
   = let
         small_bits = case bits of 
 			[]  -> 0
-			[b] -> fromIntegral b
+                        [b] -> b
 			_   -> panic "livenessToAddrMode"
     in
     return (smallLiveness size small_bits)
@@ -475,17 +474,18 @@ emitClosureProcAndInfoTable top_lvl bndr cl_info args body
         ; 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)
+              conv = if nodeMustPointToIt lf_info
+                     then NativeNodeCall else NativeDirectCall
+        ; emitClosureAndInfoTable cl_info conv args' $ body (node, arg_regs)
         }
 
 -- Data constructors need closures, but not with all the argument handling
 -- needed for functions. The shared part goes here.
-emitClosureAndInfoTable :: ClosureInfo -> [LocalReg] -> FCode () -> FCode ()
-emitClosureAndInfoTable cl_info args body
+emitClosureAndInfoTable ::
+  ClosureInfo -> Convention -> [LocalReg] -> FCode () -> FCode ()
+emitClosureAndInfoTable cl_info conv args body
   = do { info <- mkCmmInfo cl_info
        ; blks <- getCode body
-       ; let conv = if nodeMustPointToIt (closureLFInfo cl_info) then NativeNodeCall
-                    else NativeDirectCall
        ; emitProcWithConvention conv info (infoLblToEntryLbl info_lbl) args blks
        }
   where