X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsForeign.lhs;h=007edb9b3da67fa6cedb3dd4d8c63a514af26f16;hb=aedb94f5f220b5e442b23ecc445fd38c8d9b6ba0;hp=b0c82f85916739785c80eca4d8ee5722f54543a9;hpb=620531f5074b189bd04d10c88196493b1e2fa692;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index b0c82f8..007edb9 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -18,9 +18,8 @@ import DsMonad
 
 import HsSyn
 import DataCon
-import MachOp
-import SMRep
 import CoreUtils
+import CoreUnfold
 import Id
 import Literal
 import Module
@@ -31,6 +30,8 @@ import Coercion
 import TcType
 import Var
 
+import CmmExpr
+import CmmUtils
 import HscTypes
 import ForeignCall
 import TysWiredIn
@@ -165,8 +166,7 @@ fun_type_arg_stdcall_info StdCallConv ty
   = let
        (_tvs,sans_foralls)        = tcSplitForAllTys arg_ty
        (fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls
-    in 
-        Just $ sum (map (machRepByteWidth . typeMachRep . getPrimTyOf) fe_arg_tys)
+    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType . getPrimTyOf) fe_arg_tys)
 fun_type_arg_stdcall_info _other_conv _
   = Nothing
 \end{code}
@@ -231,9 +231,10 @@ dsFCall fn_id fcall = do
         -- Build the wrapper
         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
-        wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
+        wrap_rhs     = mkLams (tvs ++ args) wrapper_body
+        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineRule wrap_rhs (length args)
     
-    return ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
+    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty)
 \end{code}
 
 
@@ -425,19 +426,26 @@ mkFExportCBits :: FastString
 		  )
 mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc 
  = (header_bits, c_bits, type_string,
-    sum [ machRepByteWidth rep | (_,_,_,rep) <- aug_arg_info] -- all the args
+    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
+	 -- NB. the calculation here isn't strictly speaking correct.
+	 -- We have a primitive Haskell type (eg. Int#, Double#), and
+	 -- we want to know the size, when passed on the C stack, of
+	 -- the associated C type (eg. HsInt, HsDouble).  We don't have
+	 -- this information to hand, but we know what GHC's conventions
+	 -- are for passing around the primitive Haskell types, so we
+	 -- use that instead.  I hope the two coincide --SDM
     )
  where
   -- list the arguments to the C function
   arg_info :: [(SDoc, 		-- arg name
 		SDoc,		-- C type
 	        Type,		-- Haskell type
-		MachRep)]	-- the MachRep
+		CmmType)]	-- the CmmType
   arg_info  = [ let stg_type = showStgType ty in
                 (arg_cname n stg_type,
                  stg_type,
                  ty, 
-		 typeMachRep (getPrimTyOf ty))
+		 typeCmmType (getPrimTyOf ty))
 	      | (ty,n) <- zip arg_htys [1::Int ..] ]
 
   arg_cname n stg_ty
@@ -464,7 +472,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 
   stable_ptr_arg = 
 	(text "the_stableptr", text "StgStablePtr", undefined,
-	 typeMachRep (mkStablePtrPrimTy alphaTy))
+	 typeCmmType (mkStablePtrPrimTy alphaTy))
 
   -- stuff to do with the return type of the C function
   res_hty_is_unit = res_hty `coreEqType` unitTy	-- Look through any newtypes
@@ -582,16 +590,6 @@ foreignExportInitialiser hs_fn =
     ]
 
 
--- NB. the calculation here isn't strictly speaking correct.
--- We have a primitive Haskell type (eg. Int#, Double#), and
--- we want to know the size, when passed on the C stack, of
--- the associated C type (eg. HsInt, HsDouble).  We don't have
--- this information to hand, but we know what GHC's conventions
--- are for passing around the primitive Haskell types, so we
--- use that instead.  I hope the two coincide --SDM
-typeMachRep :: Type -> MachRep
-typeMachRep ty = argMachRep (typeCgRep ty)
-
 mkHObj :: Type -> SDoc
 mkHObj t = text "rts_mk" <> text (showFFIType t)
 
@@ -608,8 +606,8 @@ showFFIType t = getOccString (getName tc)
 	    Just (tc,_) -> tc
 	    Nothing	-> pprPanic "showFFIType" (ppr t)
 
-insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, MachRep)]
-                           -> [(SDoc, SDoc, Type, MachRep)]
+insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, CmmType)]
+                           -> [(SDoc, SDoc, Type, CmmType)]
 #if !defined(x86_64_TARGET_ARCH)
 insertRetAddr CCallConv args = ret_addr_arg : args
 insertRetAddr _ args = args
@@ -619,19 +617,19 @@ insertRetAddr _ args = args
 -- need to flush a register argument to the stack (See rts/Adjustor.c for
 -- details).
 insertRetAddr CCallConv args = go 0 args
-  where  go :: Int -> [(SDoc, SDoc, Type, MachRep)]
-                   -> [(SDoc, SDoc, Type, MachRep)]
+  where  go :: Int -> [(SDoc, SDoc, Type, CmmType)]
+                   -> [(SDoc, SDoc, Type, CmmType)]
          go 6 args = ret_addr_arg : args
 	 go n (arg@(_,_,_,rep):args)
-	  | I64 <- rep = arg : go (n+1) args
+	  | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
 	  | otherwise  = arg : go n     args
 	 go _ [] = []
 insertRetAddr _ args = args
 #endif
 
-ret_addr_arg :: (SDoc, SDoc, Type, MachRep)
+ret_addr_arg :: (SDoc, SDoc, Type, CmmType)
 ret_addr_arg = (text "original_return_addr", text "void*", undefined, 
-		typeMachRep addrPrimTy)
+		typeCmmType addrPrimTy)
 
 -- This function returns the primitive type associated with the boxed
 -- type argument to a foreign export (eg. Int ==> Int#).