handle Bool arg to foreign import "wrapper"

Fixes #746

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 725681e..e5cbbfb 100644 (file)
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -34,6 +34,7 @@ import Type           ( repType, coreEqType )
 import TcType          ( Type, mkFunTys, mkForAllTys, mkTyConApp,
                          mkFunTy, tcSplitTyConApp_maybe, tcSplitIOType_maybe,
                          tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
 import TcType          ( Type, mkFunTys, mkForAllTys, mkTyConApp,
                          mkFunTy, tcSplitTyConApp_maybe, tcSplitIOType_maybe,
                          tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,

+                         isBoolTy

                        )
 
 import BasicTypes       ( Boxity(..) )
                        )
 
 import BasicTypes       ( Boxity(..) )

@@ -45,7 +46,7 @@ import ForeignCall    ( ForeignCall(..), CCallSpec(..),
                          ccallConvAttribute
                        )
 import TysWiredIn      ( unitTy, tupleTyCon )
                          ccallConvAttribute
                        )
 import TysWiredIn      ( unitTy, tupleTyCon )

-import TysPrim         ( addrPrimTy, mkStablePtrPrimTy, alphaTy )
+import TysPrim         ( addrPrimTy, mkStablePtrPrimTy, alphaTy, intPrimTy )

 import PrelNames       ( stablePtrTyConName, newStablePtrName, bindIOName,
                          checkDotnetResName )
 import BasicTypes      ( Activation( NeverActive ) )
 import PrelNames       ( stablePtrTyConName, newStablePtrName, bindIOName,
                          checkDotnetResName )
 import BasicTypes      ( Activation( NeverActive ) )

@@ -629,16 +630,19 @@ ret_addr_arg = (text "original_return_addr", text "void*", undefined,
                typeMachRep addrPrimTy)
 
 -- This function returns the primitive type associated with the boxed
                typeMachRep addrPrimTy)
 
 -- This function returns the primitive type associated with the boxed

--- type argument to a foreign export (eg. Int ==> Int#).  It assumes
--- that all the types we are interested in have a single constructor
--- with a single primitive-typed argument, which is true for all of the legal
--- foreign export argument types (see TcType.legalFEArgTyCon).
+-- type argument to a foreign export (eg. Int ==> Int#).

 getPrimTyOf :: Type -> Type
 getPrimTyOf :: Type -> Type

-getPrimTyOf ty =
-  case splitProductType_maybe (repType ty) of
+getPrimTyOf ty
+  | isBoolTy rep_ty = intPrimTy
+  -- Except for Bool, the types we are interested in have a single constructor
+  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
+  | otherwise =
+  case splitProductType_maybe rep_ty of

      Just (_, _, data_con, [prim_ty]) ->
        ASSERT(dataConSourceArity data_con == 1)
        ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
        prim_ty
      _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
      Just (_, _, data_con, [prim_ty]) ->
        ASSERT(dataConSourceArity data_con == 1)
        ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
        prim_ty
      _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)

+  where
+       rep_ty = repType ty

 \end{code}
 \end{code}