[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 (file)
--- 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 (file)
--- 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 (file)
--- 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}