[project @ 2001-09-26 16:19:28 by simonpj]

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

diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index bdfa3c0..90f6318 100644 (file)
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -18,7 +18,7 @@ import CoreSyn
 
 import DsMonad
 
-import CoreUtils       ( exprType )
+import CoreUtils       ( exprType, mkCoerce )
 import Id              ( Id, mkWildId, idType )
 import MkId            ( mkFCallId, realWorldPrimId, mkPrimOpId )
 import Maybes          ( maybeToBool )
@@ -26,11 +26,13 @@ import ForeignCall  ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CC
 import DataCon         ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
 import ForeignCall     ( ForeignCall, CCallTarget(..) )
 
-import TcType          ( Type, isUnLiftedType, mkFunTys, mkFunTy,
+import TcType          ( tcSplitTyConApp_maybe )
+import Type            ( Type, isUnLiftedType, mkFunTys, mkFunTy,
                          tyVarsOfType, mkForAllTys, mkTyConApp, 
-                         isBoolTy, isUnitTy, isPrimitiveType
+                         isPrimitiveType, eqType,
+                         splitTyConApp_maybe, splitNewType_maybe
                        )
-import Type            ( splitTyConApp_maybe, repType, eqType )        -- Sees the representation type
+
 import PrimOp          ( PrimOp(TouchOp) )
 import TysPrim         ( realWorldStatePrimTy,
                          byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
@@ -45,7 +47,7 @@ import TysWiredIn     ( unitDataConId,
                        )
 import Literal         ( mkMachInt )
 import CStrings                ( CLabelString )
-import PrelNames       ( Unique, hasKey, ioTyConKey )
+import PrelNames       ( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey )
 import VarSet          ( varSetElems )
 import Outputable
 \end{code}
@@ -142,8 +144,13 @@ unboxArg arg
   | isPrimitiveType arg_ty
   = returnDs (arg, \body -> body)
 
+  -- Recursive newtypes
+  | Just rep_ty <- splitNewType_maybe arg_ty
+  = unboxArg (mkCoerce rep_ty arg_ty arg)
+      
   -- Booleans
-  | isBoolTy arg_ty
+  | Just (tc,_) <- splitTyConApp_maybe arg_ty, 
+    tc `hasKey` boolTyConKey
   = newSysLocalDs intPrimTy            `thenDs` \ prim_arg ->
     returnDs (Var prim_arg,
              \ body -> Case (Case arg (mkWildId arg_ty)
@@ -152,7 +159,6 @@ unboxArg arg
                              prim_arg 
                             [(DEFAULT,[],body)])
 
-  -- Newtypes 
   -- Data types with a single constructor, which has a single, primitive-typed arg
   -- This deals with Int, Float etc
   | is_product_type && data_con_arity == 1 
@@ -164,6 +170,9 @@ unboxArg arg
     )
 
   -- Byte-arrays, both mutable and otherwise; hack warning
+  -- We're looking for values of type ByteArray, MutableByteArray
+  --   data ByteArray          ix = ByteArray        ix ix ByteArray#
+  --   data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
   | is_product_type &&
     data_con_arity == 3 &&
     maybeToBool maybe_arg3_tycon &&
@@ -180,9 +189,7 @@ unboxArg arg
   = getSrcLocDs `thenDs` \ l ->
     pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
   where
-    arg_ty                                     = repType (exprType arg)
-       -- The repType looks through any newtype or 
-       -- implicit-parameter wrappings on the argument.  
+    arg_ty                                     = exprType arg
     maybe_product_type                                 = splitProductType_maybe arg_ty
     is_product_type                            = maybeToBool maybe_product_type
     Just (_, _, data_con, data_con_arg_tys)    = maybe_product_type
@@ -215,7 +222,9 @@ boxResult :: [Id] -> Type -> DsM (Type, CoreExpr -> CoreExpr)
 -- the call.  The arg_ids passed in are the Ids passed to the actual ccall.
 
 boxResult arg_ids result_ty
-  = case splitTyConApp_maybe result_ty of
+  = case tcSplitTyConApp_maybe result_ty of
+       -- This split absolutely has to be a tcSplit, because we must
+       -- see the IO type; and it's a newtype which is transparent to splitTyConApp.
 
        -- The result is IO t, so wrap the result in an IO constructor
        Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey
@@ -297,21 +306,28 @@ resultWrapper :: Type
                  CoreExpr -> CoreExpr) -- Wrapper for the result 
 resultWrapper result_ty
   -- Base case 1: primitive types
-  | isPrimitiveType result_ty_rep
+  | isPrimitiveType result_ty
   = (Just result_ty, \e -> e)
 
   -- Base case 2: the unit type ()
-  | isUnitTy result_ty_rep
+  | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
   = (Nothing, \e -> Var unitDataConId)
 
-  -- Base case 3: the boolean type ()
-  | isBoolTy result_ty_rep
+  -- Base case 3: the boolean type
+  | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
   = (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
                                  [(DEFAULT             ,[],Var trueDataConId ),
                                   (LitAlt (mkMachInt 0),[],Var falseDataConId)])
 
+  -- Recursive newtypes
+  | Just rep_ty <- splitNewType_maybe result_ty
+  = let
+        (maybe_ty, wrapper) = resultWrapper rep_ty
+    in
+    (maybe_ty, \e -> mkCoerce result_ty rep_ty (wrapper e))
+
   -- Data types with a single constructor, which has a single arg
-  | Just (_, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty_rep,
+  | Just (_, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
     dataConSourceArity data_con == 1
   = let
         (maybe_ty, wrapper)    = resultWrapper unwrapped_res_ty
@@ -323,5 +339,5 @@ resultWrapper result_ty
   | otherwise
   = pprPanic "resultWrapper" (ppr result_ty)
   where
-    result_ty_rep = repType result_ty
+    maybe_tc_app = splitTyConApp_maybe result_ty
 \end{code}