From: simonmar <unknown>
Date: Tue, 10 Aug 2004 09:02:41 +0000 (+0000)
Subject: [project @ 2004-08-10 09:02:36 by simonmar]
X-Git-Tag: Initial_conversion_from_CVS_complete~1759
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=c9a32c38c1d80b5df0f816f57a2d11555b7eadb4

[project @ 2004-08-10 09:02:36 by simonmar]
Fix problem with inline foreign-call changes yesterday.  Foreign call
args sometimes have to be modified using shimFCallArg - nowadays this
is done at code generation time, whereas it used to be done at
pretty-printing time.
---

diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs
index 24067c0..fef7bf5 100644
--- a/ghc/compiler/absCSyn/AbsCUtils.lhs
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -12,7 +12,8 @@ module AbsCUtils (
 	getAmodeRep,
 	mixedTypeLocn, mixedPtrLocn,
 	flattenAbsC,
-	mkAbsCStmtList
+	mkAbsCStmtList,
+	shimFCallArg
 	-- printing/forcing stuff comes from PprAbsC
     ) where
 
@@ -20,6 +21,10 @@ module AbsCUtils (
 #include "../includes/config.h"
 
 import AbsCSyn
+import Type		( tyConAppTyCon, repType )
+import TysPrim		( foreignObjPrimTyCon, arrayPrimTyCon, 
+			  byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
+			  mutableArrayPrimTyCon )
 import CLabel		( mkMAP_FROZEN_infoLabel )
 import Digraph		( stronglyConnComp, SCC(..) )
 import DataCon		( fIRST_TAG, dataConTag )
@@ -32,7 +37,7 @@ import UniqSupply	( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
 			  UniqSupply )
 import CmdLineOpts      ( opt_EmitCExternDecls, opt_Unregisterised )
 import ForeignCall	( ForeignCall(..), CCallSpec(..), isDynamicTarget )
-import StgSyn		( StgOp(..) )
+import StgSyn		( StgOp(..), stgArgType )
 import CoreSyn		( AltCon(..) )
 import SMRep		( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize )
 import Outputable
@@ -1292,5 +1297,19 @@ translateOp [r] EqForeignObj [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
 translateOp [r] EqStablePtrOp [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
 
 translateOp _ _ _ = Nothing
+\end{code}
+
 
+\begin{code}
+shimFCallArg arg amode
+  | tycon == foreignObjPrimTyCon
+	= CMacroExpr AddrRep ForeignObj_CLOSURE_DATA [amode]
+  | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
+	= CMacroExpr PtrRep PTRS_ARR_CTS [amode]
+  | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
+	= CMacroExpr AddrRep BYTE_ARR_CTS [amode]
+  | otherwise = amode
+  where	
+	-- should be a tycon app, since this is a foreign call
+	tycon = tyConAppTyCon (repType (stgArgType arg))
 \end{code}
diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index d313839..c805aaa 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgCase.lhs,v 1.67 2004/08/09 13:19:29 simonmar Exp $
+% $Id: CgCase.lhs,v 1.68 2004/08/10 09:02:38 simonmar Exp $
 %
 %********************************************************
 %*							*
@@ -22,7 +22,8 @@ import CgMonad
 import StgSyn
 import AbsCSyn
 
-import AbsCUtils	( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, getAmodeRep )
+import AbsCUtils	( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
+			  getAmodeRep, shimFCallArg )
 import CgBindery	( getVolatileRegs, getArgAmodes,
 			  bindNewToReg, bindNewToTemp,
 			  getCAddrModeAndInfo,
@@ -155,7 +156,12 @@ cgCase (StgOpApp op args _)
        live_in_whole_case live_in_alts bndr srt alt_type alts
   | inline_primop
   =	-- Get amodes for the arguments and results
-    getArgAmodes args			`thenFC` \ arg_amodes ->
+    getArgAmodes args			`thenFC` \ arg_amodes1 ->
+    let 
+	arg_amodes
+	  | StgFCallOp{} <- op = zipWith shimFCallArg args arg_amodes1
+	  | otherwise          = arg_amodes1
+    in
     getVolatileRegs live_in_alts        `thenFC` \ vol_regs ->
 
     case alt_type of 
@@ -223,7 +229,7 @@ cgCase (StgOpApp op args _)
   where
    inline_primop = case op of
 	StgPrimOp primop  -> not (primOpOutOfLine primop)
-	StgFCallOp (CCall (CCallSpec _ _ PlayRisky)) _ -> True
+	--StgFCallOp (CCall (CCallSpec _ _ PlayRisky)) _ -> True
 		 -- unsafe foreign calls are "inline"
 	_otherwise -> False
 
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 903db7e..88771b9 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgExpr.lhs,v 1.57 2004/03/31 15:23:16 simonmar Exp $
+% $Id: CgExpr.lhs,v 1.58 2004/08/10 09:02:41 simonmar Exp $
 %
 %********************************************************
 %*							*
@@ -18,7 +18,7 @@ import Constants	( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE )
 import StgSyn
 import CgMonad
 import AbsCSyn
-import AbsCUtils	( mkAbstractCs, getAmodeRep )
+import AbsCUtils	( mkAbstractCs, getAmodeRep, shimFCallArg )
 import CLabel		( mkClosureTblLabel )
 
 import SMRep		( fixedHdrSize )
@@ -41,12 +41,10 @@ import Id		( idPrimRep, Id )
 import VarSet
 import PrimOp		( primOpOutOfLine, getPrimOpResultInfo, 
 			  PrimOp(..), PrimOpResultInfo(..) )
-import TysPrim		( foreignObjPrimTyCon, arrayPrimTyCon, 
-			  byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
-			  mutableArrayPrimTyCon )
 import PrimRep		( PrimRep(..), isFollowableRep )
 import TyCon		( isUnboxedTupleTyCon, isEnumerationTyCon )
-import Type		( Type, typePrimRep, tyConAppArgs, tyConAppTyCon, repType )
+import Type		( Type, typePrimRep, tyConAppArgs, 
+			  tyConAppTyCon, repType )
 import Maybes		( maybeToBool )
 import ListSetOps	( assocMaybe )
 import Unique		( mkBuiltinUnique )
@@ -482,17 +480,4 @@ primRetUnboxedTuple op args res_ty
     in
     ccallReturnUnboxedTuple temp_amodes
 	(absC (COpStmt temp_amodes op arg_temps []))
-
-
-shimFCallArg arg amode
-  | tycon == foreignObjPrimTyCon
-	= CMacroExpr AddrRep ForeignObj_CLOSURE_DATA [amode]
-  | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
-	= CMacroExpr PtrRep PTRS_ARR_CTS [amode]
-  | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
-	= CMacroExpr AddrRep BYTE_ARR_CTS [amode]
-  | otherwise = amode
-  where	
-	-- should be a tycon app, since this is a foreign call
-	tycon = tyConAppTyCon (repType (stgArgType arg))
 \end{code}