[project @ 2003-01-13 14:12:31 by simonpj]

[ghc-hetmet.git] / ghc / compiler / codeGen / CgExpr.lhs

diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 2076a07..c5fa38a 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.48 2002/04/29 14:03:41 simonmar Exp $
+% $Id: CgExpr.lhs,v 1.52 2002/12/11 15:36:26 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 )
+import AbsCUtils       ( mkAbstractCs, getAmodeRep )
 import CLabel          ( mkClosureTblLabel )
 
 import SMRep           ( fixedHdrSize )
@@ -32,14 +32,18 @@ import CgLetNoEscape        ( cgLetNoEscapeClosure )
 import CgRetConv       ( dataReturnConvPrim )
 import CgTailCall      ( cgTailCall, performReturn, performPrimReturn,
                          mkDynamicAlgReturnCode, mkPrimReturnCode,
-                         tailCallPrimOp, returnUnboxedTuple
+                         tailCallPrimOp, ccallReturnUnboxedTuple
                        )
 import ClosureInfo     ( mkClosureLFInfo, mkSelectorLFInfo,
                          mkApLFInfo, layOutDynConstr )
 import CostCentre      ( sccAbleCostCentre, isSccCountCostCentre )
-import Id              ( idPrimRep, idType, Id )
+import Id              ( idPrimRep, Id )
 import VarSet
-import PrimOp          ( primOpOutOfLine, getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) )
+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 )
@@ -150,9 +154,7 @@ cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
   = tailCallPrimOp primop args
 
   | otherwise
-  = ASSERT(primop /= SeqOp) -- can't handle SeqOp
-
-    getArgAmodes args  `thenFC` \ arg_amodes ->
+  = getArgAmodes args  `thenFC` \ arg_amodes ->
 
     case (getPrimOpResultInfo primop) of
 
@@ -329,14 +331,12 @@ mkRhsClosure      bndr cc bi srt
     -- will evaluate to.
     cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
   where
-    lf_info              = mkSelectorLFInfo (idType bndr) offset_into_int 
-                                               (isUpdatable upd_flag)
-    (_, params_w_offsets) = layOutDynConstr bogus_name con idPrimRep params
+    lf_info              = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
+    (_, params_w_offsets) = layOutDynConstr con idPrimRep params
                                -- Just want the layout
     maybe_offset         = assocMaybe params_w_offsets selectee
     Just the_offset      = maybe_offset
     offset_into_int       = the_offset - fixedHdrSize
-    bogus_name           = panic "mkRhsClosure"
 \end{code}
 
 Ap thunks
@@ -371,7 +371,7 @@ mkRhsClosure        bndr cc bi srt
        = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
 
    where
-       lf_info = mkApLFInfo (idType bndr) upd_flag arity
+       lf_info = mkApLFInfo bndr upd_flag arity
        -- the payload has to be in the correct order, hence we can't
        -- just use the fvs.
        payload    = StgVarArg fun_id : args
@@ -453,7 +453,17 @@ Little helper for primitives that return unboxed tuples.
 \begin{code}
 primRetUnboxedTuple :: StgOp -> [StgArg] -> Type -> Code
 primRetUnboxedTuple op args res_ty
-  = getArgAmodes args      `thenFC` \ arg_amodes ->
+  = getArgAmodes args      `thenFC` \ arg_amodes1 ->
+    {-
+      For a foreign call, we might need to fiddle with some of the args:
+      for example, when passing a ByteArray#, we pass a ptr to the goods
+      rather than the heap object.
+    -}
+    let 
+       arg_amodes
+         | StgFCallOp{} <- op = zipWith shimFCallArg args arg_amodes1
+         | otherwise          = arg_amodes1
+    in
     {-
       put all the arguments in temporaries so they don't get stomped when
       we push the return address.
@@ -461,7 +471,7 @@ primRetUnboxedTuple op args res_ty
     let
       n_args             = length args
       arg_uniqs                  = map mkBuiltinUnique [0 .. n_args-1]
-      arg_reps           = map getArgPrimRep args
+      arg_reps           = map getAmodeRep arg_amodes
       arg_temps                  = zipWith CTemp arg_uniqs arg_reps
     in
     absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
@@ -474,5 +484,19 @@ primRetUnboxedTuple op args res_ty
       temp_uniqs  = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
       temp_amodes = zipWith CTemp temp_uniqs prim_reps
     in
-    returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
+    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}