X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgCallConv.hs;h=752769f4e39e9ad841684176334a39223a4a633b;hb=9ca17cfcd9d1dc84bea3f19b60b9055f02ef7736;hp=ecf105f4d895adac331aeab2289001890a87769a;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4;p=ghc-hetmet.git

diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs
index ecf105f..752769f 100644
--- a/compiler/codeGen/CgCallConv.hs
+++ b/compiler/codeGen/CgCallConv.hs
@@ -1,3 +1,10 @@
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 -----------------------------------------------------------------------------
 --
 -- (c) The University of Glasgow 2004-2006
@@ -9,13 +16,6 @@
 --
 -----------------------------------------------------------------------------
 
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module CgCallConv (
 	-- Argument descriptors
 	mkArgDescr, argDescrType,
@@ -35,8 +35,6 @@ module CgCallConv (
 	getSequelAmode
     ) where
 
-#include "HsVersions.h"
-
 import CgUtils
 import CgMonad
 import SMRep
@@ -219,7 +217,7 @@ constructSlowCall
 
    -- don't forget the zero case
 constructSlowCall [] 
-  = (mkRtsApFastLabel SLIT("stg_ap_0"), [], [])
+  = (mkRtsApFastLabel (sLit "stg_ap_0"), [], [])
 
 constructSlowCall amodes
   = (stg_ap_pat, these, rest)
@@ -243,20 +241,20 @@ matchSlowPattern amodes = (arg_pat, these, rest)
 	(these, rest) = splitAt n amodes
 
 -- These cases were found to cover about 99% of all slow calls:
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_pppppp"), 6)
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) 	= (SLIT("stg_ap_ppppp"), 5)
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) 	= (SLIT("stg_ap_pppp"), 4)
-slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) 	= (SLIT("stg_ap_pppv"), 4)
-slowCallPattern (PtrArg: PtrArg: PtrArg: _)       	= (SLIT("stg_ap_ppp"), 3)
-slowCallPattern (PtrArg: PtrArg: VoidArg: _)       	= (SLIT("stg_ap_ppv"), 3)
-slowCallPattern (PtrArg: PtrArg: _)			= (SLIT("stg_ap_pp"), 2)
-slowCallPattern (PtrArg: VoidArg: _)			= (SLIT("stg_ap_pv"), 2)
-slowCallPattern (PtrArg: _)				= (SLIT("stg_ap_p"), 1)
-slowCallPattern (VoidArg: _)				= (SLIT("stg_ap_v"), 1)
-slowCallPattern (NonPtrArg: _)				= (SLIT("stg_ap_n"), 1)
-slowCallPattern (FloatArg: _)				= (SLIT("stg_ap_f"), 1)
-slowCallPattern (DoubleArg: _)				= (SLIT("stg_ap_d"), 1)
-slowCallPattern (LongArg: _)				= (SLIT("stg_ap_l"), 1)
+slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_pppppp", 6)
+slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) 	= (sLit "stg_ap_ppppp", 5)
+slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) 	= (sLit "stg_ap_pppp", 4)
+slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) 	= (sLit "stg_ap_pppv", 4)
+slowCallPattern (PtrArg: PtrArg: PtrArg: _)       	= (sLit "stg_ap_ppp", 3)
+slowCallPattern (PtrArg: PtrArg: VoidArg: _)       	= (sLit "stg_ap_ppv", 3)
+slowCallPattern (PtrArg: PtrArg: _)			= (sLit "stg_ap_pp", 2)
+slowCallPattern (PtrArg: VoidArg: _)			= (sLit "stg_ap_pv", 2)
+slowCallPattern (PtrArg: _)				= (sLit "stg_ap_p", 1)
+slowCallPattern (VoidArg: _)				= (sLit "stg_ap_v", 1)
+slowCallPattern (NonPtrArg: _)				= (sLit "stg_ap_n", 1)
+slowCallPattern (FloatArg: _)				= (sLit "stg_ap_f", 1)
+slowCallPattern (DoubleArg: _)				= (sLit "stg_ap_d", 1)
+slowCallPattern (LongArg: _)				= (sLit "stg_ap_l", 1)
 slowCallPattern _  = panic "CgStackery.slowCallPattern"
 
 -------------------------------------------------------------------------
@@ -338,9 +336,22 @@ assignPrimOpCallRegs args
 	-- For primops, *all* arguments must be passed in registers
 
 assignReturnRegs args
- = assign_regs args (mkRegTbl [])
+ -- when we have a single non-void component to return, use the normal
+ -- unpointed return convention.  This make various things simpler: it
+ -- means we can assume a consistent convention for IO, which is useful
+ -- when writing code that relies on knowing the IO return convention in 
+ -- the RTS (primops, especially exception-related primops).
+ -- Also, the bytecode compiler assumes this when compiling
+ -- case expressions and ccalls, so it only needs to know one set of
+ -- return conventions.
+ | [(rep,arg)] <- non_void_args, CmmGlobal r <- dataReturnConvPrim rep
+    = ([(arg, r)], [])
+ | otherwise
+    = assign_regs args (mkRegTbl [])
 	-- For returning unboxed tuples etc, 
 	-- we use all regs
+ where 
+       non_void_args = filter ((/= VoidArg).fst) args
 
 assign_regs :: [(CgRep,a)]     	-- Arg or result values to assign
 	    -> AvailRegs	-- Regs still avail: Vanilla, Float, Double, Longs