[project @ 2001-05-28 17:34:24 by qrczak]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsCCall.lhs

diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index ee5d7d5..3758d61 100644 (file)
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -6,7 +6,7 @@
 \begin{code}
 module DsCCall 
        ( dsCCall
-       , mkCCall
+       , mkFCall
        , unboxArg
        , boxResult
        , resultWrapper
@@ -20,13 +20,13 @@ import DsMonad
 
 import CoreUtils       ( exprType, mkCoerce )
 import Id              ( Id, mkWildId, idType )
-import MkId            ( mkCCallOpId, realWorldPrimId, mkPrimOpId )
+import MkId            ( mkFCallId, realWorldPrimId, mkPrimOpId )
 import Maybes          ( maybeToBool )
-import PrimOp          ( CCall(..), CCallTarget(..) )
+import ForeignCall     ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CCallConv(..) )
 import DataCon         ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
-import CallConv
+import ForeignCall     ( ForeignCall, CCallTarget(..) )
 import Type            ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
-                         splitTyConApp_maybe, tyVarsOfType, mkForAllTys, 
+                         splitTyConApp_maybe, tyVarsOfType, mkForAllTys, isPrimitiveType,
                          isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp,
                          Type
                        )
@@ -86,7 +86,7 @@ follows:
 \begin{code}
 dsCCall :: CLabelString        -- C routine to invoke
        -> [CoreExpr]   -- Arguments (desugared)
-       -> Bool         -- True <=> might cause Haskell GC
+       -> Safety       -- Safety of the call
        -> Bool         -- True <=> really a "_casm_"
        -> Type         -- Type of the result: IO t
        -> DsM CoreExpr
@@ -96,12 +96,14 @@ dsCCall lbl args may_gc is_asm result_ty
     boxResult [] result_ty     `thenDs` \ (ccall_result_ty, res_wrapper) ->
     getUniqueDs                        `thenDs` \ uniq ->
     let
-       the_ccall    = CCall (StaticTarget lbl) is_asm may_gc cCallConv
-       the_prim_app = mkCCall uniq the_ccall unboxed_args ccall_result_ty
+       target | is_asm    = CasmTarget lbl
+              | otherwise = StaticTarget lbl
+       the_fcall    = CCall (CCallSpec target CCallConv may_gc)
+       the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
     in
     returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
 
-mkCCall :: Unique -> CCall 
+mkFCall :: Unique -> ForeignCall 
        -> [CoreExpr]   -- Args
        -> Type         -- Result type
        -> CoreExpr
@@ -114,14 +116,14 @@ mkCCall :: Unique -> CCall
 -- Here we build a ccall thus
 --     (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
 --                     a b s x c
-mkCCall uniq the_ccall val_args res_ty
-  = mkApps (mkVarApps (Var the_ccall_id) tyvars) val_args
+mkFCall uniq the_fcall val_args res_ty
+  = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
   where
     arg_tys = map exprType val_args
     body_ty = (mkFunTys arg_tys res_ty)
     tyvars  = varSetElems (tyVarsOfType body_ty)
     ty             = mkForAllTys tyvars body_ty
-    the_ccall_id = mkCCallOpId uniq the_ccall ty
+    the_fcall_id = mkFCallId uniq the_fcall ty
 \end{code}
 
 \begin{code}
@@ -134,8 +136,8 @@ unboxArg :: CoreExpr                        -- The supplied argument
 -- where W is a CoreExpr that probably mentions x#
 
 unboxArg arg
-  -- Unlifted types: nothing to unbox
-  | isUnLiftedType arg_ty
+  -- Primtive types: nothing to unbox
+  | isPrimitiveType arg_ty
   = returnDs (arg, \body -> body)
 
   -- Newtypes
@@ -293,7 +295,7 @@ resultWrapper :: Type
                  CoreExpr -> CoreExpr) -- Wrapper for the result 
 resultWrapper result_ty
   -- Base case 1: primitive types
-  | isUnLiftedType result_ty
+  | isPrimitiveType result_ty
   = (Just result_ty, \e -> e)
 
   -- Base case 1: the unit type ()