[project @ 2001-07-16 09:41:26 by simonpj]

Tidy up Type/TcType stuff in DsCCall/DsForeign

diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index eca07f7..a103864 100644 (file)
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -31,7 +31,7 @@ import TcType         ( Type, isUnLiftedType, mkFunTys, mkFunTy,
                          isBoolTy, isUnitTy, isPrimitiveType,
                          tcSplitTyConApp_maybe
                        )
-import Type            ( splitTyConApp_maybe, repType, eqType )        -- Sees the representation type
+import Type            ( repType, eqType )     -- Sees the representation type
 import PrimOp          ( PrimOp(TouchOp) )
 import TysPrim         ( realWorldStatePrimTy,
                          byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
@@ -153,7 +153,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 
@@ -165,6 +164,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 &&
@@ -183,7 +185,9 @@ unboxArg arg
   where
     arg_ty                                     = repType (exprType arg)
        -- The repType looks through any newtype or 
-       -- implicit-parameter wrappings on the argument.  
+       -- implicit-parameter wrappings on the argument;
+       -- this is necessary, because isBoolTy (in particular) does not.
+
     maybe_product_type                                 = splitProductType_maybe arg_ty
     is_product_type                            = maybeToBool maybe_product_type
     Just (_, _, data_con, data_con_arg_tys)    = maybe_product_type
@@ -217,6 +221,8 @@ boxResult :: [Id] -> Type -> DsM (Type, CoreExpr -> CoreExpr)
 
 boxResult arg_ids result_ty
   = 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
@@ -324,6 +330,5 @@ resultWrapper result_ty
   | otherwise
   = pprPanic "resultWrapper" (ppr result_ty)
   where
-    result_ty_rep = repType result_ty
-
+    result_ty_rep = repType result_ty  -- Look through any newtypes/implicit parameters
 \end{code}

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 9c979a3..133e1d6 100644 (file)
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -28,14 +28,10 @@ import Name         ( mkGlobalName, nameModule, nameOccName, getOccString,
                          NamedThing(..),
                        )
 
-       -- Import Type not TcType; in this module we are generating code
-       -- to marshal representation types across to C
-import Type            ( splitTyConApp_maybe, funResultTy,
-                         splitFunTys, splitForAllTys, splitAppTy, 
-                         Type, mkFunTys, mkForAllTys, mkTyConApp,
-                         mkFunTy, applyTy, eqType, repType
-                       )
-import TcType          ( tcSplitForAllTys, tcSplitFunTys,
+import Type            ( repType, eqType )
+import TcType          ( Type, mkFunTys, mkForAllTys, mkTyConApp,
+                         mkFunTy, applyTy, 
+                         tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
                          tcSplitTyConApp_maybe, tcSplitAppTy,
                          tcFunResultTy
                        )
@@ -151,6 +147,8 @@ dsFCall mod_Name fn_id fcall
        ty                   = idType fn_id
        (tvs, fun_ty)        = tcSplitForAllTys ty
        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
+               -- Must use tcSplit* functions because we want to 
+               -- see that (IO t) in the corner
     in
     newSysLocalsDs arg_tys                     `thenDs` \ args ->
     mapAndUnzipDs unboxArg (map Var args)      `thenDs` \ (val_args, arg_wrappers) ->
@@ -225,6 +223,9 @@ dsFExport mod_name fn_id ty ext_name cconv isDyn
        -- If it's IO t, return         (\x.x,          IO t, t)
        -- If it's plain t, return      (\x.returnIO x, IO t, t)
      (case tcSplitTyConApp_maybe orig_res_ty of
+       -- We must use tcSplit here so that we see the (IO t) in
+       -- the type.  [IO t is transparent to plain splitTyConApp.]
+
        Just (ioTyCon, [res_ty])
              -> ASSERT( ioTyCon `hasKey` ioTyConKey )
                        -- The function already returns IO t
@@ -303,15 +304,19 @@ dsFExport mod_name fn_id ty ext_name cconv isDyn
   where
    (tvs,sans_foralls)          = tcSplitForAllTys ty
    (fe_arg_tys', orig_res_ty)  = tcSplitFunTys sans_foralls
-
-   (_, stbl_ptr_ty')           = tcSplitForAllTys stbl_ptr_ty
-   (_, stbl_ptr_to_ty)         = tcSplitAppTy stbl_ptr_ty'
+       -- We must use tcSplits here, because we want to see 
+       -- the (IO t) in the corner of the type!
 
    fe_arg_tys | isDyn    = tail fe_arg_tys'
              | otherwise = fe_arg_tys'
 
    stbl_ptr_ty | isDyn     = head fe_arg_tys'
               | otherwise = error "stbl_ptr_ty"
+
+   (_, stbl_ptr_ty')           = tcSplitForAllTys stbl_ptr_ty
+   (_, stbl_ptr_to_ty)         = tcSplitAppTy stbl_ptr_ty'
+       -- Again, stable pointers are just newtypes, 
+       -- so we must see them!  Hence tcSplit*
 \end{code}
 
 @foreign export dynamic@ lets you dress up Haskell IO actions
@@ -395,11 +400,12 @@ dsFExportDynamic mod_name id cconv
      returnDs ([fed, fe], h_code, c_code)
 
  where
-  ty                              = idType id
-  (tvs,sans_foralls)              = tcSplitForAllTys ty
-  ([arg_ty], io_res_ty)                   = tcSplitFunTys sans_foralls
-  Just (ioTyCon, [res_ty])        = tcSplitTyConApp_maybe io_res_ty
-  export_ty                       = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty
+  ty                   = idType id
+  (tvs,sans_foralls)   = tcSplitForAllTys ty
+  ([arg_ty], io_res_ty)        = tcSplitFunTys sans_foralls
+  [res_ty]             = tcTyConAppArgs io_res_ty
+       -- Must use tcSplit* to see the (IO t), which is a newtype
+  export_ty            = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty
 
 toCName :: Id -> String
 toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
@@ -455,7 +461,7 @@ fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits)
 
   cParamTypes  = map showStgType real_args
 
-  res_ty_is_unit = res_ty `eqType` unitTy
+  res_ty_is_unit = res_ty `eqType` unitTy      -- Look through any newtypes
 
   cResType | res_ty_is_unit = text "void"
           | otherwise      = showStgType res_ty
@@ -503,7 +509,7 @@ showStgType t = text "Hs" <> text (showFFIType t)
 showFFIType :: Type -> String
 showFFIType t = getOccString (getName tc)
  where
-  tc = case splitTyConApp_maybe (repType t) of
+  tc = case tcSplitTyConApp_maybe (repType t) of
            Just (tc,_) -> tc
            Nothing     -> pprPanic "showFFIType" (ppr t)
 \end{code}