[project @ 2000-04-05 16:25:51 by simonpj]

* Add new flag -fddump-minimal-imports, which dumps a file
  M.imports that contains the (allegedly) minimal bunch of
  imports that make the system work.
  It's done by Rename.printMinimalImports

* Extend foreign import/export to handle
	* Booleans
	* newtypes
  as requested by the FFI team

* Tidy up DsCCall quite a bit
  Remove maybeBoxedPrimTy from TcHsSyn

diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index 3bcf942..7c869bf 100644 (file)
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -45,7 +45,8 @@ import TyCon          ( tyConDataCons )
 import Name            ( NamedThing(..) )
 import DataCon         ( DataCon{-instance NamedThing-}, dataConWrapId )
 import Maybes          ( maybeToBool, catMaybes )
 import Name            ( NamedThing(..) )
 import DataCon         ( DataCon{-instance NamedThing-}, dataConWrapId )
 import Maybes          ( maybeToBool, catMaybes )

-import PrimOp          ( primOpNeedsWrapper, pprPrimOp, PrimOp(..), CCall(..), CCallTarget(..) )
+import PrimOp          ( primOpNeedsWrapper, pprPrimOp, pprCCallOp, 
+                         PrimOp(..), CCall(..), CCallTarget(..) )

 import PrimRep         ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
 import SMRep           ( pprSMRep )
 import Unique          ( pprUnique, Unique{-instance NamedThing-} )
 import PrimRep         ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
 import SMRep           ( pprSMRep )
 import Unique          ( pprUnique, Unique{-instance NamedThing-} )

@@ -777,7 +778,7 @@ Amendment to the above: if we can GC, we have to:
   that the runtime check that PerformGC is being used sensibly will work.
 
 \begin{code}
   that the runtime check that PerformGC is being used sensibly will work.
 
 \begin{code}

-pprCCall (CCall op_str is_asm may_gc cconv) args results vol_regs
+pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs

   = vcat [
       char '{',
       declare_local_vars,   -- local var for *result*
   = vcat [
       char '{',
       declare_local_vars,   -- local var for *result*

@@ -797,10 +798,10 @@ pprCCall (CCall op_str is_asm may_gc cconv) args results vol_regs
        | otherwise = ( pp_basic_saves $$ pp_saves,
                        pp_basic_restores $$ pp_restores)
 
        | otherwise = ( pp_basic_saves $$ pp_saves,
                        pp_basic_restores $$ pp_restores)
 

-    non_void_args =
-       let nvas = tail args
-       in ASSERT (all non_void nvas) nvas
-    -- the first argument will be the "I/O world" token (a VoidRep)
+    non_void_args = let nvas = take (length args - 1) args
+                   in ASSERT2 ( all non_void nvas, pprCCallOp call <+> hsep (map pprAmode args) )
+                      nvas
+    -- the last argument will be the "I/O world" token (a VoidRep)

     -- all others should be non-void
 
     non_void_results =
     -- all others should be non-void
 
     non_void_results =

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index c06c67c..bcae7ed 100644 (file)
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -43,7 +43,7 @@ import Rules          ( addRule )
 import Type            ( Type, ClassContext, mkDictTy, mkTyConApp, mkTyVarTys,
                          mkFunTys, mkFunTy, mkSigmaTy, classesToPreds,
                          isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tyVarsOfTypes,
 import Type            ( Type, ClassContext, mkDictTy, mkTyConApp, mkTyVarTys,
                          mkFunTys, mkFunTy, mkSigmaTy, classesToPreds,
                          isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tyVarsOfTypes,

-                         splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
+                         splitSigmaTy, splitFunTy_maybe, 

                          splitFunTys, splitForAllTys, unUsgTy,
                          mkUsgTy, UsageAnn(..)
                        )
                          splitFunTys, splitForAllTys, unUsgTy,
                          mkUsgTy, UsageAnn(..)
                        )

diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index b5e120a..c8a382b 100644 (file)
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -23,8 +23,9 @@ module Name (
        tidyTopName, 
        nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule,
 
        tidyTopName, 
        nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule,
 

-       isUserExportedName, isUserImportedName, isUserImportedExplicitlyName, nameSrcLoc,
-       isLocallyDefinedName, isDynName,
+       isUserExportedName, isUserImportedName, isUserImportedExplicitlyName, 
+       maybeUserImportedFrom,
+       nameSrcLoc, isLocallyDefinedName, isDynName,

 
        isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
        
 
        isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
        

@@ -431,6 +432,9 @@ isUserImportedExplicitlyName other                                                   = False
 isUserImportedName (Name { n_prov = NonLocalDef (UserImport _ _ _) _ }) = True
 isUserImportedName other                                               = False
 
 isUserImportedName (Name { n_prov = NonLocalDef (UserImport _ _ _) _ }) = True
 isUserImportedName other                                               = False
 

+maybeUserImportedFrom (Name { n_prov = NonLocalDef (UserImport m _ _) _ }) = Just m
+maybeUserImportedFrom other                                               = Nothing
+

 isDynName :: Name -> Bool
        -- Does this name come from a DLL?
 isDynName nm = not (isLocallyDefinedName nm) && 
 isDynName :: Name -> Bool
        -- Does this name come from a DLL?
 isDynName nm = not (isLocallyDefinedName nm) && 

diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs
index a68a352..f02b4d6 100644 (file)
--- a/ghc/compiler/codeGen/CgRetConv.lhs
+++ b/ghc/compiler/codeGen/CgRetConv.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP Project, Glasgow University, 1992-1998
 %
 %
 % (c) The GRASP Project, Glasgow University, 1992-1998
 %

-% $Id: CgRetConv.lhs,v 1.20 2000/03/23 17:45:19 simonpj Exp $
+% $Id: CgRetConv.lhs,v 1.21 2000/04/05 16:25:51 simonpj Exp $

 %
 \section[CgRetConv]{Return conventions for the code generator}
 
 %
 \section[CgRetConv]{Return conventions for the code generator}
 

@@ -31,8 +31,7 @@ import DataCon                ( DataCon )
 import PrimOp          ( PrimOp{-instance Outputable-} )
 import PrimRep         ( isFloatingRep, PrimRep(..), is64BitRep )
 import TyCon           ( TyCon, tyConDataCons, tyConFamilySize )
 import PrimOp          ( PrimOp{-instance Outputable-} )
 import PrimRep         ( isFloatingRep, PrimRep(..), is64BitRep )
 import TyCon           ( TyCon, tyConDataCons, tyConFamilySize )

-import Type            ( Type, typePrimRep, isUnLiftedType, 
-                         splitAlgTyConApp_maybe )
+import Type            ( Type, typePrimRep, isUnLiftedType )

 import Util            ( isn'tIn )
 
 import Outputable
 import Util            ( isn'tIn )
 
 import Outputable

diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index 02d6e87..b1602d3 100644 (file)
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -36,7 +36,6 @@ import Type           ( Type, Kind, tyVarsOfType,
                          splitFunTy_maybe, mkPiType, mkTyVarTy, unUsgTy,
                          splitForAllTy_maybe, splitTyConApp_maybe,
                          isUnLiftedType, typeKind, 
                          splitFunTy_maybe, mkPiType, mkTyVarTy, unUsgTy,
                          splitForAllTy_maybe, splitTyConApp_maybe,
                          isUnLiftedType, typeKind, 

-                         splitAlgTyConApp_maybe,

                          isUnboxedTupleType,
                          hasMoreBoxityInfo
                        )
                          isUnboxedTupleType,
                          hasMoreBoxityInfo
                        )

diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 35491cd..4089f34 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -56,7 +56,7 @@ import Literal                ( isLitLitLit )
 import PrimOp          ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm )
 import IdInfo          ( ArityInfo(..), InlinePragInfo(..), OccInfo(..), IdFlavour(..), CprInfo(..), insideLam, workerExists )
 import TyCon           ( tyConFamilySize )
 import PrimOp          ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm )
 import IdInfo          ( ArityInfo(..), InlinePragInfo(..), OccInfo(..), IdFlavour(..), CprInfo(..), insideLam, workerExists )
 import TyCon           ( tyConFamilySize )

-import Type            ( splitAlgTyConApp_maybe, splitFunTy_maybe, isUnLiftedType )
+import Type            ( splitFunTy_maybe, isUnLiftedType )

 import Unique          ( Unique, buildIdKey, augmentIdKey )
 import Maybes          ( maybeToBool )
 import Bag
 import Unique          ( Unique, buildIdKey, augmentIdKey )
 import Maybes          ( maybeToBool )
 import Bag

diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 131bd47..583c32a 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -159,9 +159,7 @@ mkInlineMe e | exprIsTrivial e = e
 
 
 \begin{code}
 
 
 \begin{code}

-mkCoerce :: Type -> Type -> Expr b -> Expr b
--- In (mkCoerce to_ty from_ty e), we require that from_ty = exprType e
--- But exprType is defined in CoreUtils, so we don't check the assertion
+mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr

 
 mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
   = ASSERT( from_ty == to_ty2 )
 
 mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
   = ASSERT( from_ty == to_ty2 )

@@ -169,7 +167,8 @@ mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
 
 mkCoerce to_ty from_ty expr
   | to_ty == from_ty = expr
 
 mkCoerce to_ty from_ty expr
   | to_ty == from_ty = expr

-  | otherwise       = Note (Coerce to_ty from_ty) expr
+  | otherwise       = ASSERT( from_ty == exprType expr )
+                      Note (Coerce to_ty from_ty) expr

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index f5fa47f..ecab476 100644 (file)
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -9,9 +9,7 @@ module DsCCall
        , mkCCall
        , unboxArg
        , boxResult
        , mkCCall
        , unboxArg
        , boxResult

-       ,  wrapUnboxedValue
-       , can'tSeeDataConsPanic
-       
+       , resultWrapper

        ) where
 
 #include "HsVersions.h"
        ) where
 
 #include "HsVersions.h"

@@ -21,31 +19,31 @@ import CoreSyn
 import DsMonad
 import DsUtils
 
 import DsMonad
 import DsUtils
 

-import TcHsSyn         ( maybeBoxedPrimType )
-import CoreUtils       ( exprType )
+import CoreUtils       ( exprType, mkCoerce )

 import Id              ( Id, mkWildId )
 import Id              ( Id, mkWildId )

-import MkId            ( mkCCallOpId )
+import MkId            ( mkCCallOpId, realWorldPrimId )

 import Maybes          ( maybeToBool )
 import PrelInfo                ( packStringForCId )
 import PrimOp          ( PrimOp(..), CCall(..), CCallTarget(..) )
 import Maybes          ( maybeToBool )
 import PrelInfo                ( packStringForCId )
 import PrimOp          ( PrimOp(..), CCall(..), CCallTarget(..) )

-import DataCon         ( DataCon, splitProductType_maybe )
+import DataCon         ( DataCon, splitProductType_maybe, dataConSourceArity, dataConWrapId )

 import CallConv
 import Type            ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
 import CallConv
 import Type            ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,

-                         splitTyConApp_maybe, tyVarsOfType, mkForAllTys, Type
+                         splitTyConApp_maybe, tyVarsOfType, mkForAllTys, 
+                         isNewType, repType, isUnLiftedType, mkFunTy,
+                         Type

                        )
 import TysPrim         ( byteArrayPrimTy, realWorldStatePrimTy,
                        )
 import TysPrim         ( byteArrayPrimTy, realWorldStatePrimTy,

-                         byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
-                         intPrimTy
+                         byteArrayPrimTyCon, mutableByteArrayPrimTyCon, intPrimTy

                        )
                        )

-import TysWiredIn      ( unitDataConId, stringTy, boolTy,
-                         falseDataCon, falseDataConId,
-                         trueDataCon, trueDataConId,
+import TysWiredIn      ( unitDataConId, stringTy,

                          unboxedPairDataCon,
                          unboxedPairDataCon,

-                         mkUnboxedTupleTy, unboxedTupleCon
+                         mkUnboxedTupleTy, unboxedTupleCon,
+                         boolTy, trueDataCon, falseDataCon, trueDataConId, falseDataConId,
+                         unitTy

                        )
 import Literal         ( mkMachInt )
 import CStrings                ( CLabelString )
                        )
 import Literal         ( mkMachInt )
 import CStrings                ( CLabelString )

-import Unique          ( Unique )
+import Unique          ( Unique, Uniquable(..), ioTyConKey )

 import VarSet          ( varSetElems )
 import Outputable
 \end{code}
 import VarSet          ( varSetElems )
 import Outputable
 \end{code}

@@ -90,22 +88,18 @@ dsCCall :: CLabelString     -- C routine to invoke
        -> [CoreExpr]   -- Arguments (desugared)
        -> Bool         -- True <=> might cause Haskell GC
        -> Bool         -- True <=> really a "_casm_"
        -> [CoreExpr]   -- Arguments (desugared)
        -> Bool         -- True <=> might cause Haskell GC
        -> Bool         -- True <=> really a "_casm_"

-       -> Type         -- Type of the result (a boxed-prim IO type)
+       -> Type         -- Type of the result: IO t

        -> DsM CoreExpr
 
 dsCCall lbl args may_gc is_asm result_ty
        -> DsM CoreExpr
 
 dsCCall lbl args may_gc is_asm result_ty

-  = newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s ->
-
-    mapAndUnzipDs unboxArg args        `thenDs` \ (unboxed_args, arg_wrappers) ->
-    boxResult result_ty                `thenDs` \ (final_result_ty, res_wrapper) ->
+  = mapAndUnzipDs unboxArg args        `thenDs` \ (unboxed_args, arg_wrappers) ->
+    boxResult result_ty                `thenDs` \ (ccall_result_ty, res_wrapper) ->

     getUniqueDs                        `thenDs` \ uniq ->
     let
     getUniqueDs                        `thenDs` \ uniq ->
     let

-       val_args     = Var old_s : unboxed_args

        the_ccall    = CCall (StaticTarget lbl) is_asm may_gc cCallConv
        the_ccall    = CCall (StaticTarget lbl) is_asm may_gc cCallConv

-       the_prim_app = mkCCall uniq the_ccall val_args final_result_ty
-       the_body     = foldr ($) (res_wrapper the_prim_app) arg_wrappers
+       the_prim_app = mkCCall uniq the_ccall unboxed_args ccall_result_ty

     in
     in

-    returnDs (Lam old_s the_body)
+    returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)

 
 mkCCall :: Unique -> CCall 
        -> [CoreExpr]   -- Args
 
 mkCCall :: Unique -> CCall 
        -> [CoreExpr]   -- Args

@@ -135,32 +129,42 @@ unboxArg :: CoreExpr                      -- The supplied argument
         -> DsM (CoreExpr,              -- To pass as the actual argument
                 CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
                )
         -> DsM (CoreExpr,              -- To pass as the actual argument
                 CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
                )

-unboxArg arg
+-- Example: if the arg is e::Int, unboxArg will return
+--     (x#::Int#, \W. case x of I# x# -> W)
+-- where W is a CoreExpr that probably mentions x#

 
 

-  -- Primitive types
-  -- ADR Question: can this ever be used?  None of the PrimTypes are
-  -- instances of the CCallable class.
-  --
-  -- SOF response:
-  --    Oh yes they are, I've just added them :-) Having _ccall_ and _casm_
-  --  that accept unboxed arguments is a Good Thing if you have a stub generator
-  --  which generates the boiler-plate box-unbox code for you, i.e., it may help
-  --  us nuke this very module :-)
-  --
+unboxArg arg
+  -- Unlifted types: nothing to unbox

   | isUnLiftedType arg_ty
   = returnDs (arg, \body -> body)
 
   | isUnLiftedType arg_ty
   = returnDs (arg, \body -> body)
 

-  -- Strings
-  | arg_ty == stringTy
-  -- ToDo (ADR): - allow synonyms of Strings too?
-  = newSysLocalDs byteArrayPrimTy              `thenDs` \ prim_arg ->
+  -- Newtypes
+  | isNewType arg_ty
+  = unboxArg (mkCoerce (repType arg_ty) arg_ty arg)
+      
+  -- Booleans
+  | arg_ty == boolTy
+  = newSysLocalDs intPrimTy            `thenDs` \ prim_arg ->

     returnDs (Var prim_arg,
     returnDs (Var prim_arg,

-             \body -> Case (App (Var packStringForCId) arg) 
-                           prim_arg [(DEFAULT,[],body)])
+             \ body -> Case (Case arg (mkWildId arg_ty)
+                                      [(DataAlt falseDataCon,[],mkIntLit 0),
+                                       (DataAlt trueDataCon, [],mkIntLit 1)])
+                             prim_arg 
+                            [(DEFAULT,[],body)])
+
+  -- 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 
+  = ASSERT(isUnLiftedType data_con_arg_ty1 )   -- Typechecker ensures this
+    newSysLocalDs arg_ty               `thenDs` \ case_bndr ->
+    newSysLocalDs data_con_arg_ty1     `thenDs` \ prim_arg ->
+    returnDs (Var prim_arg,
+             \ body -> Case arg case_bndr [(DataAlt data_con,[prim_arg],body)]
+    )

 
   -- Byte-arrays, both mutable and otherwise; hack warning
   | is_product_type &&
 
   -- Byte-arrays, both mutable and otherwise; hack warning
   | is_product_type &&

-    length data_con_arg_tys == 3 &&
+    data_con_arity == 3 &&

     maybeToBool maybe_arg3_tycon &&
     (arg3_tycon ==  byteArrayPrimTyCon ||
      arg3_tycon ==  mutableByteArrayPrimTyCon)
     maybeToBool maybe_arg3_tycon &&
     (arg3_tycon ==  byteArrayPrimTyCon ||
      arg3_tycon ==  mutableByteArrayPrimTyCon)

@@ -171,141 +175,134 @@ unboxArg arg
              \ body -> Case arg case_bndr [(DataAlt data_con,vars,body)]
     )
 
              \ body -> Case arg case_bndr [(DataAlt data_con,vars,body)]
     )
 

-  -- Data types with a single constructor, which has a single, primitive-typed arg
-  | maybeToBool maybe_boxed_prim_arg_ty
-  = newSysLocalDs arg_ty               `thenDs` \ case_bndr ->
-    newSysLocalDs the_prim_arg_ty      `thenDs` \ prim_arg ->
-    returnDs (Var prim_arg,
-             \ body -> Case arg case_bndr [(DataAlt box_data_con,[prim_arg],body)]
-    )
-
-  -- Booleans
-  | arg_ty == boolTy
-  = newSysLocalDs intPrimTy            `thenDs` \ prim_arg ->
-    returnDs (Var prim_arg,
-             \ body -> Case (Case arg (mkWildId arg_ty) [
-                                (DataAlt falseDataCon,[],mkIntLit 0),
-                                (DataAlt trueDataCon, [],mkIntLit 1)])
-                             prim_arg [(DEFAULT,[],body)]
-    )
-

   | otherwise
   = getSrcLocDs `thenDs` \ l ->
     pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
   where
   | otherwise
   = getSrcLocDs `thenDs` \ l ->
     pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
   where

-    arg_ty = exprType arg
-
-    maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
-    (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
+    arg_ty     = exprType arg
+    arg_rep_ty = repType arg_ty

 
     maybe_product_type                                   = splitProductType_maybe arg_ty
     is_product_type                              = maybeToBool maybe_product_type
     Just (tycon, _, data_con, data_con_arg_tys)   = maybe_product_type
 
     maybe_product_type                                   = splitProductType_maybe arg_ty
     is_product_type                              = maybeToBool maybe_product_type
     Just (tycon, _, data_con, data_con_arg_tys)   = maybe_product_type

-    (data_con_arg_ty1 : data_con_arg_ty2 : data_con_arg_ty3 :_)
-         = data_con_arg_tys
-
-    maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3
-    Just (arg3_tycon,_) = maybe_arg3_tycon
+    data_con_arity                               = dataConSourceArity data_con
+    (data_con_arg_ty1 : _)                       = data_con_arg_tys

 
 

-can'tSeeDataConsPanic thing ty
-  = pprPanic
-     "ERROR: Can't see the data constructor(s) for _ccall_/_casm_/foreign declaration"
-     (hcat [ text thing, text "; type: ", ppr ty
-           , text "(try compiling with -fno-prune-tydecls ..)\n"])
+    (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
+    maybe_arg3_tycon              = splitTyConApp_maybe data_con_arg_ty3
+    Just (arg3_tycon,_)                   = maybe_arg3_tycon

 \end{code}
 
 
 \begin{code}
 \end{code}
 
 
 \begin{code}

-boxResult :: Type                      -- Type of desired result
-         -> DsM (Type,                 -- Type of the result of the ccall itself
-                 CoreExpr -> CoreExpr) -- Wrapper for the ccall
-                                       -- to box the result
-boxResult result_ty
-  -- Data types with a single nullary constructor
-  | (maybeToBool maybe_product_type) &&                                -- Data type
-    (null data_con_arg_tys)
-  =
-    newSysLocalDs realWorldStatePrimTy         `thenDs` \ prim_state_id ->
-{-
-    wrapUnboxedValue result_ty                 `thenDs` \ (state_and_prim_datacon,
-                                                           state_and_prim_ty, prim_result_id, the_result) ->
-    mkConDs ioOkDataCon
-           [TyArg result_ty, VarArg (Var prim_state_id), VarArg the_result]
-                                                       `thenDs` \ the_pair ->
--}
-    let
-       the_pair = mkConApp unboxedPairDataCon
-                           [Type realWorldStatePrimTy, Type result_ty, 
-                            Var prim_state_id, 
-                            Var unitDataConId]
-       the_alt  = (DataAlt (unboxedTupleCon 1), [prim_state_id], the_pair)
-       scrut_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
-    in
-    returnDs (scrut_ty, \prim_app -> Case prim_app (mkWildId scrut_ty) [the_alt]
-    )
+boxResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
+
+-- Takes the result of the user-level ccall: 
+--     either (IO t), 
+--     or maybe just t for an side-effect-free call
+-- Returns a wrapper for the primitive ccall itself, along with the
+-- type of the result of the primitive ccall.  This result type
+-- will be of the form  
+--     State# RealWorld -> (# State# RealWorld, t' #)
+-- where t' is the unwrapped form of t.  If t is simply (), then
+-- the result type will be 
+--     State# RealWorld -> (# State# RealWorld #)

 
 

-  -- Data types with a single constructor, which has a single, primitive-typed arg
-  | (maybeToBool maybe_product_type) &&                                -- Data type
-    not (null data_con_arg_tys) && null other_args_tys &&      -- Just one arg
-    isUnLiftedType the_prim_result_ty                          -- of primitive type
-  =
-    newSysLocalDs realWorldStatePrimTy         `thenDs` \ prim_state_id ->
-    newSysLocalDs the_prim_result_ty           `thenDs` \ prim_result_id ->
-    newSysLocalDs ccall_res_type               `thenDs` \ case_bndr ->
-
-    let
-       the_result = mkConApp data_con (map Type tycon_arg_tys ++ [Var prim_result_id])
-       the_pair   = mkConApp unboxedPairDataCon
-                               [Type realWorldStatePrimTy, Type result_ty, 
-                                Var prim_state_id, the_result]
-       the_alt    = (DataAlt unboxedPairDataCon, [prim_state_id, prim_result_id], the_pair)
-    in
-    returnDs (ccall_res_type, \prim_app -> Case prim_app case_bndr [the_alt]
-    )
+boxResult result_ty
+  = case splitAlgTyConApp_maybe result_ty of
+
+       -- The result is IO t, so wrap the result in an IO constructor
+       Just (io_tycon, [io_res_ty], [io_data_con]) | getUnique io_tycon == ioTyConKey
+               -> mk_alt return_result 
+                         (resultWrapper io_res_ty)     `thenDs` \ (ccall_res_ty, the_alt) ->
+                  newSysLocalDs realWorldStatePrimTy    `thenDs` \ state_id ->
+                  let
+                       wrap = \ the_call -> mkApps (Var (dataConWrapId io_data_con))
+                                                   [Type io_res_ty, Lam state_id $
+                                                                    Case (App the_call (Var state_id))
+                                                                         (mkWildId ccall_res_ty)
+                                                                         [the_alt]]
+                  in
+                  returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+               where
+                  return_result state ans = mkConApp unboxedPairDataCon 
+                                                     [Type realWorldStatePrimTy, Type io_res_ty, 
+                                                      state, ans]
+
+       -- It isn't, so do unsafePerformIO
+       -- It's not conveniently available, so we inline it
+       other -> mk_alt return_result
+                       (resultWrapper result_ty)       `thenDs` \ (ccall_res_ty, the_alt) ->
+                let
+                   wrap = \ the_call -> Case (App the_call (Var realWorldPrimId)) 
+                                             (mkWildId ccall_res_ty)
+                                             [the_alt]
+                in
+                returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+             where
+                return_result state ans = ans
+  where
+    mk_alt return_result (Nothing, wrap_result)
+       =       -- The ccall returns ()
+         newSysLocalDs realWorldStatePrimTy    `thenDs` \ state_id ->
+         let
+               the_rhs      = return_result (Var state_id) (wrap_result (panic "boxResult"))
+               ccall_res_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
+               the_alt      = (DataAlt (unboxedTupleCon 1), [state_id], the_rhs)
+         in
+         returnDs (ccall_res_ty, the_alt)
+
+    mk_alt return_result (Just prim_res_ty, wrap_result)
+       =       -- The ccall returns a non-() value
+         newSysLocalDs realWorldStatePrimTy    `thenDs` \ state_id ->
+         newSysLocalDs prim_res_ty             `thenDs` \ result_id ->
+         let
+               the_rhs      = return_result (Var state_id) (wrap_result (Var result_id))
+               ccall_res_ty = mkUnboxedTupleTy 2 [realWorldStatePrimTy, prim_res_ty]
+               the_alt      = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
+         in
+         returnDs (ccall_res_ty, the_alt)
+
+
+resultWrapper :: Type
+             -> (Maybe Type,           -- Type of the expected result, if any
+                 CoreExpr -> CoreExpr) -- Wrapper for the result 
+resultWrapper result_ty
+  -- Base case 1: primitive types
+  | isUnLiftedType result_ty
+  = (Just result_ty, \e -> e)
+
+  -- Base case 1: the unit type ()
+  | result_ty == unitTy
+  = (Nothing, \e -> Var unitDataConId)

 
 

-  -- Booleans

   | result_ty == boolTy
   | result_ty == boolTy

-  = returnDs (mkUnboxedTupleTy 2 [realWorldStatePrimTy, intPrimTy],
-              \ prim_app -> Case prim_app (mkWildId intPrimTy) [
-                               (LitAlt (mkMachInt 0),[],Var falseDataConId),
-                               (DEFAULT             ,[],Var trueDataConId )])
+  = (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
+                                 [(LitAlt (mkMachInt 0),[],Var falseDataConId),
+                                  (DEFAULT             ,[],Var trueDataConId )])
+
+  -- Data types with a single constructor, which has a single arg
+  | is_product_type && data_con_arity == 1
+  = let
+        (maybe_ty, wrapper)    = resultWrapper unwrapped_res_ty
+       (unwrapped_res_ty : _) = data_con_arg_tys
+    in
+    (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) 
+                           (map Type tycon_arg_tys ++ [wrapper e]))
+
+  -- newtypes
+  | isNewType result_ty
+  = let
+       rep_ty              = repType result_ty
+        (maybe_ty, wrapper) = resultWrapper rep_ty
+    in
+    (maybe_ty, \e -> mkCoerce result_ty rep_ty (wrapper e))

 
   | otherwise
 
   | otherwise

-  = pprPanic "boxResult: " (ppr result_ty)
+  = pprPanic "resultWrapper" (ppr result_ty)

   where
     maybe_product_type                                             = splitProductType_maybe result_ty
   where
     maybe_product_type                                             = splitProductType_maybe result_ty

+    is_product_type                                        = maybeToBool maybe_product_type

     Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
     Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type

-    (the_prim_result_ty : other_args_tys)                  = data_con_arg_tys
-
-    ccall_res_type = mkUnboxedTupleTy 2 [realWorldStatePrimTy, the_prim_result_ty]
-
--- wrap up an unboxed value.
-wrapUnboxedValue :: Type -> DsM (Type, Id, CoreExpr)
-wrapUnboxedValue ty
-  | (maybeToBool maybe_product_type) &&                                -- Data type
-    not (null data_con_arg_tys) && null other_args_tys &&      -- Just one arg
-    isUnLiftedType the_prim_result_ty                          -- of primitive type
-  =
-    newSysLocalDs the_prim_result_ty                    `thenDs` \ prim_result_id ->
-    let
-       the_result = mkConApp data_con (map Type tycon_arg_tys ++ [Var prim_result_id])
-    in
-    returnDs (ccall_res_type, prim_result_id, the_result)
-
-  -- Data types with a single nullary constructor
-  | (maybeToBool maybe_product_type) &&                                -- Data type
-    (null data_con_arg_tys)
-  =
-    let 
-       scrut_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
-    in
-    returnDs (scrut_ty, unitDataConId, Var unitDataConId)
-
-  | otherwise
-  = pprPanic "boxResult: " (ppr ty)
- where
-   maybe_product_type                                     = splitProductType_maybe ty
-   Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
-   (the_prim_result_ty : other_args_tys)                  = data_con_arg_tys
-   ccall_res_type = mkUnboxedTupleTy 2 [realWorldStatePrimTy, the_prim_result_ty]
+    data_con_arity                                         = dataConSourceArity data_con

 \end{code}
 \end{code}

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index c812165..8ab7d4d 100644 (file)
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -15,9 +15,7 @@ import HsSyn          ( failureFreePat,
                          mkSimpleMatch
                        )
 import TcHsSyn         ( TypecheckedHsExpr, TypecheckedHsBinds,
                          mkSimpleMatch
                        )
 import TcHsSyn         ( TypecheckedHsExpr, TypecheckedHsBinds,

-                         TypecheckedStmt,
-                         maybeBoxedPrimType
-
+                         TypecheckedStmt

                        )
 import CoreSyn
 import CoreUtils       ( exprType, mkIfThenElse, bindNonRec )
                        )
 import CoreSyn
 import CoreUtils       ( exprType, mkIfThenElse, bindNonRec )

@@ -25,7 +23,7 @@ import CoreUtils      ( exprType, mkIfThenElse, bindNonRec )
 import DsMonad
 import DsBinds         ( dsMonoBinds, AutoScc(..) )
 import DsGRHSs         ( dsGuarded )
 import DsMonad
 import DsBinds         ( dsMonoBinds, AutoScc(..) )
 import DsGRHSs         ( dsGuarded )

-import DsCCall         ( dsCCall )
+import DsCCall         ( dsCCall, resultWrapper )

 import DsListComp      ( dsListComp )
 import DsUtils         ( mkErrorAppDs, mkDsLets, mkConsExpr, mkNilExpr )
 import Match           ( matchWrapper, matchSimply )
 import DsListComp      ( dsListComp )
 import DsUtils         ( mkErrorAppDs, mkDsLets, mkConsExpr, mkNilExpr )
 import Match           ( matchWrapper, matchSimply )

@@ -164,29 +162,11 @@ dsExpr (HsLitOut (HsString str) _)
   = returnDs (mkStringLitFS str)
 
 dsExpr (HsLitOut (HsLitLit str) ty)
   = returnDs (mkStringLitFS str)
 
 dsExpr (HsLitOut (HsLitLit str) ty)

-  | isUnLiftedType ty
-  = returnDs (mkLit (MachLitLit str ty))
-  | otherwise
-  = case (maybeBoxedPrimType ty) of
-      Just (boxing_data_con, prim_ty) ->
-           returnDs ( mkConApp boxing_data_con [mkLit (MachLitLit str prim_ty)] )
-      _ -> 
-       pprError "ERROR:"
-                (vcat
-                  [ hcat [ text "Cannot see data constructor of ``literal-literal''s type: "
-                        , text "value:", quotes (quotes (ptext str))
-                        , text "; type: ", ppr ty
-                        ]
-                  , text "Try compiling with -fno-prune-tydecls."
-                  ])
-                 
+  = ASSERT( maybeToBool maybe_ty )
+    returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))

   where
   where

-    (data_con, prim_ty)
-      = case (maybeBoxedPrimType ty) of
-         Just (boxing_data_con, prim_ty) -> (boxing_data_con, prim_ty)
-         Nothing
-           -> pprPanic "ERROR: ``literal-literal'' not a single-constructor type: "
-                       (hcat [ptext str, text "; type: ", ppr ty])
+    (maybe_ty, wrap_fn) = resultWrapper ty
+    Just rep_ty        = maybe_ty

 
 dsExpr (HsLitOut (HsInt i) ty)
   = returnDs (mkIntegerLit i)
 
 dsExpr (HsLitOut (HsInt i) ty)
   = returnDs (mkIntegerLit i)

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 8e4d0b7..c1fb6fe 100644 (file)
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -12,7 +12,7 @@ module DsForeign ( dsForeigns ) where
 
 import CoreSyn
 
 
 import CoreSyn
 

-import DsCCall         ( dsCCall, mkCCall, boxResult, unboxArg, wrapUnboxedValue )
+import DsCCall         ( dsCCall, mkCCall, boxResult, unboxArg )

 import DsMonad
 import DsUtils
 
 import DsMonad
 import DsUtils
 

@@ -23,15 +23,15 @@ import TcHsSyn              ( TypecheckedForeignDecl )
 import CoreUtils       ( exprType, mkInlineMe, bindNonRec )
 import DataCon         ( DataCon, dataConWrapId )
 import Id              ( Id, idType, idName, mkWildId, mkVanillaId )
 import CoreUtils       ( exprType, mkInlineMe, bindNonRec )
 import DataCon         ( DataCon, dataConWrapId )
 import Id              ( Id, idType, idName, mkWildId, mkVanillaId )

-import MkId            ( mkCCallOpId, mkWorkerId )
+import MkId            ( mkWorkerId )

 import Literal         ( Literal(..) )
 import Module          ( Module, moduleUserString )
 import Name            ( mkGlobalName, nameModule, nameOccName, getOccString, 
                          mkForeignExportOcc, isLocalName,
                          NamedThing(..), Provenance(..), ExportFlag(..)
                        )
 import Literal         ( Literal(..) )
 import Module          ( Module, moduleUserString )
 import Name            ( mkGlobalName, nameModule, nameOccName, getOccString, 
                          mkForeignExportOcc, isLocalName,
                          NamedThing(..), Provenance(..), ExportFlag(..)
                        )

-import PrelInfo                ( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME, realWorldPrimId )
-import Type            ( splitAlgTyConApp_maybe,  unUsgTy,
+import PrelInfo                ( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME )
+import Type            ( unUsgTy,

                          splitTyConApp_maybe, splitFunTys, splitForAllTys,
                          Type, mkFunTys, mkForAllTys, mkTyConApp,
                          mkTyVarTy, mkFunTy, splitAppTy
                          splitTyConApp_maybe, splitFunTys, splitForAllTys,
                          Type, mkFunTys, mkForAllTys, mkTyConApp,
                          mkTyVarTy, mkFunTy, splitAppTy

@@ -45,10 +45,6 @@ import TysWiredIn    ( unitTyCon, addrTy, stablePtrTyCon,
 import Unique
 import Maybes          ( maybeToBool )
 import Outputable
 import Unique
 import Maybes          ( maybeToBool )
 import Outputable

-
-#if __GLASGOW_HASKELL__ >= 404
-import GlaExts         ( fromInt )
-#endif

 \end{code}
 
 Desugaring of @foreign@ declarations is naturally split up into
 \end{code}
 
 Desugaring of @foreign@ declarations is naturally split up into

@@ -133,21 +129,12 @@ dsFImport :: Id
          -> DsM [CoreBind]
 dsFImport fn_id ty may_not_gc ext_name cconv 
   = let
          -> DsM [CoreBind]
 dsFImport fn_id ty may_not_gc ext_name cconv 
   = let

-       (tvs, arg_tys, mbIoDataCon, io_res_ty) = splitForeignTyDs ty
-       is_io_action                           = maybeToBool mbIoDataCon
+       (tvs, fun_ty)        = splitForAllTys ty
+       (arg_tys, io_res_ty) = splitFunTys fun_ty

     in
     newSysLocalsDs arg_tys                     `thenDs` \ args ->
     in
     newSysLocalsDs arg_tys                     `thenDs` \ args ->

-    newSysLocalDs realWorldStatePrimTy         `thenDs` \ old_s ->
-    mapAndUnzipDs unboxArg (map Var args)      `thenDs` \ (unboxed_args, arg_wrappers) ->
-
-    (if not is_io_action then
-       newSysLocalDs realWorldStatePrimTy      `thenDs` \ state_tok ->
-       wrapUnboxedValue io_res_ty              `thenDs` \ (ccall_result_ty, v, res_v) ->
-       returnDs ( ccall_result_ty
-                , \ prim_app -> Case prim_app  (mkWildId ccall_result_ty)
-                                   [(DataAlt (unboxedTupleCon 2), [state_tok, v], res_v)])
-     else
-       boxResult io_res_ty)                    `thenDs` \ (ccall_result_ty, res_wrapper) ->
+    mapAndUnzipDs unboxArg (map Var args)      `thenDs` \ (val_args, arg_wrappers) ->
+    boxResult io_res_ty                                `thenDs` \ (ccall_result_ty, res_wrapper) ->

 
     (case ext_name of
        Dynamic       -> getUniqueDs `thenDs` \ u -> 
 
     (case ext_name of
        Dynamic       -> getUniqueDs `thenDs` \ u -> 

@@ -157,11 +144,7 @@ dsFImport fn_id ty may_not_gc ext_name cconv
     getUniqueDs                                                `thenDs` \ ccall_uniq ->
     getUniqueDs                                                `thenDs` \ work_uniq ->
     let
     getUniqueDs                                                `thenDs` \ ccall_uniq ->
     getUniqueDs                                                `thenDs` \ work_uniq ->
     let

-       the_state_arg | is_io_action = old_s
-                     | otherwise    = realWorldPrimId
-

        -- Build the worker
        -- Build the worker

-       val_args      = Var the_state_arg : unboxed_args

        work_arg_ids  = [v | Var v <- val_args]         -- All guaranteed to be vars
        worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
        the_ccall     = CCall lbl False (not may_not_gc) cconv
        work_arg_ids  = [v | Var v <- val_args]         -- All guaranteed to be vars
        worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
        the_ccall     = CCall lbl False (not may_not_gc) cconv

@@ -172,32 +155,12 @@ dsFImport fn_id ty may_not_gc ext_name cconv
        -- Build the wrapper
        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
        -- Build the wrapper
        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers

-        io_app              = case mbIoDataCon of
-                          Nothing        -> wrapper_body
-                          Just ioDataCon -> mkApps (Var (dataConWrapId ioDataCon)) 
-                                                   [Type io_res_ty, Lam old_s wrapper_body]
-        wrap_rhs = mkInlineMe (mkLams (tvs ++ args) io_app)
+        wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)

     in
     returnDs [NonRec fn_id wrap_rhs, NonRec work_id work_rhs]
 \end{code}
 
     in
     returnDs [NonRec fn_id wrap_rhs, NonRec work_id work_rhs]
 \end{code}
 

-Given the type of a foreign import declaration, split it up into
-its constituent parts.
-
-\begin{code}
-splitForeignTyDs :: Type -> ([TyVar], [Type], Maybe DataCon, Type)
-splitForeignTyDs ty
-  = case splitAlgTyConApp_maybe res_ty of
-       Just (_,(io_res_ty:_),(ioCon:_)) ->   -- .... -> IO t
-            (tvs, arg_tys, Just ioCon, io_res_ty)
-       _   ->                               -- .... -> t
-            (tvs, arg_tys, Nothing, res_ty)
-  where
-   (arg_tys, res_ty)   = splitFunTys sans_foralls
-   (tvs, sans_foralls) = splitForAllTys ty
-\end{code}
-
-foreign labels 
+Foreign labels 

 
 \begin{code}
 dsFLabel :: Id -> ExtName -> DsM CoreBind
 
 \begin{code}
 dsFLabel :: Id -> ExtName -> DsM CoreBind

diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 77cc791..3d2bf13 100644 (file)
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -44,6 +44,7 @@ module CmdLineOpts (
        opt_D_dump_rn_trace,
        opt_D_dump_rn_stats,
         opt_D_dump_stix,
        opt_D_dump_rn_trace,
        opt_D_dump_rn_stats,
         opt_D_dump_stix,

+       opt_D_dump_minimal_imports,

        opt_D_source_stats,
        opt_D_verbose_core2core,
        opt_D_verbose_stg2stg,
        opt_D_source_stats,
        opt_D_verbose_core2core,
        opt_D_verbose_stg2stg,

@@ -334,6 +335,7 @@ opt_D_dump_simpl_stats              = opt_D_dump_most || lookUp  SLIT("-ddump-simpl-stats")
 opt_D_source_stats             = opt_D_dump_most || lookUp  SLIT("-dsource-stats")
 opt_D_verbose_core2core                = opt_D_dump_all  || lookUp  SLIT("-dverbose-simpl")
 opt_D_verbose_stg2stg          = opt_D_dump_all  || lookUp  SLIT("-dverbose-stg")
 opt_D_source_stats             = opt_D_dump_most || lookUp  SLIT("-dsource-stats")
 opt_D_verbose_core2core                = opt_D_dump_all  || lookUp  SLIT("-dverbose-simpl")
 opt_D_verbose_stg2stg          = opt_D_dump_all  || lookUp  SLIT("-dverbose-stg")

+opt_D_dump_minimal_imports     = lookUp  SLIT("-ddump-minimal-imports")

 
 opt_DoCoreLinting              = lookUp  SLIT("-dcore-lint")
 opt_DoStgLinting               = lookUp  SLIT("-dstg-lint")
 
 opt_DoCoreLinting              = lookUp  SLIT("-dcore-lint")
 opt_DoStgLinting               = lookUp  SLIT("-dstg-lint")

diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index 565f66e..7a76a1a 100644 (file)
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -86,12 +86,14 @@ import Module               ( Module, mkPrelModule )
 import Name            ( mkWiredInTyConName, mkWiredInIdName, mkSrcOccFS, mkWorkerOcc, dataName )
 import DataCon         ( DataCon, StrictnessMark(..),  mkDataCon, dataConId )
 import Var             ( TyVar, tyVarKind )
 import Name            ( mkWiredInTyConName, mkWiredInIdName, mkSrcOccFS, mkWorkerOcc, dataName )
 import DataCon         ( DataCon, StrictnessMark(..),  mkDataCon, dataConId )
 import Var             ( TyVar, tyVarKind )

-import TyCon           ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkAlgTyCon, mkSynTyCon, mkTupleTyCon )
+import TyCon           ( TyCon, AlgTyConFlavour(..), ArgVrcs, tyConDataCons,
+                         mkAlgTyCon, mkSynTyCon, mkTupleTyCon, isUnLiftedTyCon
+                       )

 import BasicTypes      ( Arity, NewOrData(..), RecFlag(..) )
 import Type            ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys, 
                          mkArrowKinds, boxedTypeKind, unboxedTypeKind,
 import BasicTypes      ( Arity, NewOrData(..), RecFlag(..) )
 import Type            ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys, 
                          mkArrowKinds, boxedTypeKind, unboxedTypeKind,

-                         mkFunTy, mkFunTys, isUnLiftedType,
-                         splitTyConApp_maybe, splitAlgTyConApp_maybe,
+                         mkFunTy, mkFunTys,
+                         splitTyConApp_maybe, repType,

                          TauType, ClassContext )
 import PrimRep         ( PrimRep(..) )
 import Unique
                          TauType, ClassContext )
 import PrimRep         ( PrimRep(..) )
 import Unique

@@ -198,10 +200,10 @@ mk_tuple arity = (tycon, tuple_con)
        dc_uniq   = mkTupleDataConUnique arity
        mod       = mkPrelModule mod_name
 
        dc_uniq   = mkTupleDataConUnique arity
        mod       = mkPrelModule mod_name
 

-unitTyCon = tupleTyCon 0
-pairTyCon = tupleTyCon 2
+unitTyCon     = tupleTyCon 0
+unitDataConId = dataConId (head (tyConDataCons unitTyCon))

 
 

-unitDataConId = dataConId (tupleCon 0)
+pairTyCon = tupleTyCon 2

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -285,10 +287,7 @@ intTyCon = pcNonRecDataTyCon intTyConKey pREL_BASE SLIT("Int") [] [] [intDataCon
 intDataCon = pcDataCon intDataConKey pREL_BASE SLIT("I#") [] [] [intPrimTy] intTyCon
 
 isIntTy :: Type -> Bool
 intDataCon = pcDataCon intDataConKey pREL_BASE SLIT("I#") [] [] [intPrimTy] intTyCon
 
 isIntTy :: Type -> Bool

-isIntTy ty
-  = case (splitAlgTyConApp_maybe ty) of
-       Just (tycon, [], _) -> getUnique tycon == intTyConKey
-       _                   -> False
+isIntTy = isTyCon intTyConKey

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -306,11 +305,7 @@ addrTyCon = pcNonRecDataTyCon addrTyConKey   pREL_ADDR SLIT("Addr") [] [] [addrD
 addrDataCon = pcDataCon addrDataConKey pREL_ADDR SLIT("A#") [] [] [addrPrimTy] addrTyCon
 
 isAddrTy :: Type -> Bool
 addrDataCon = pcDataCon addrDataConKey pREL_ADDR SLIT("A#") [] [] [addrPrimTy] addrTyCon
 
 isAddrTy :: Type -> Bool

-isAddrTy ty
-  = case (splitAlgTyConApp_maybe ty) of
-       Just (tycon, [], _) -> getUnique tycon == addrTyConKey
-       _                   -> False
-
+isAddrTy = isTyCon addrTyConKey

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -320,21 +315,14 @@ floatTyCon = pcNonRecDataTyCon floatTyConKey pREL_FLOAT SLIT("Float") [] [] [flo
 floatDataCon = pcDataCon floatDataConKey pREL_FLOAT SLIT("F#") [] [] [floatPrimTy] floatTyCon
 
 isFloatTy :: Type -> Bool
 floatDataCon = pcDataCon floatDataConKey pREL_FLOAT SLIT("F#") [] [] [floatPrimTy] floatTyCon
 
 isFloatTy :: Type -> Bool

-isFloatTy ty
-  = case (splitAlgTyConApp_maybe ty) of
-       Just (tycon, [], _) -> getUnique tycon == floatTyConKey
-       _                   -> False
-
+isFloatTy = isTyCon floatTyConKey

 \end{code}
 
 \begin{code}
 doubleTy = mkTyConTy doubleTyCon
 
 isDoubleTy :: Type -> Bool
 \end{code}
 
 \begin{code}
 doubleTy = mkTyConTy doubleTyCon
 
 isDoubleTy :: Type -> Bool

-isDoubleTy ty
-  = case (splitAlgTyConApp_maybe ty) of
-       Just (tycon, [], _) -> getUnique tycon == doubleTyConKey
-       _                   -> False
+isDoubleTy = isTyCon doubleTyConKey

 
 doubleTyCon = pcNonRecDataTyCon doubleTyConKey pREL_FLOAT SLIT("Double") [] [] [doubleDataCon]
 doubleDataCon = pcDataCon doubleDataConKey pREL_FLOAT SLIT("D#") [] [] [doublePrimTy] doubleTyCon
 
 doubleTyCon = pcNonRecDataTyCon doubleTyConKey pREL_FLOAT SLIT("Double") [] [] [doubleDataCon]
 doubleDataCon = pcDataCon doubleDataConKey pREL_FLOAT SLIT("D#") [] [] [doublePrimTy] doubleTyCon

@@ -358,6 +346,9 @@ foreignObjTyCon
     foreignObjDataCon
       = pcDataCon foreignObjDataConKey pREL_IO_BASE SLIT("ForeignObj")
            [] [] [foreignObjPrimTy] foreignObjTyCon
     foreignObjDataCon
       = pcDataCon foreignObjDataConKey pREL_IO_BASE SLIT("ForeignObj")
            [] [] [foreignObjPrimTy] foreignObjTyCon

+
+isForeignObjTy :: Type -> Bool
+isForeignObjTy = isTyCon foreignObjTyConKey

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -381,10 +372,7 @@ largeIntegerDataCon = pcDataCon largeIntegerDataConKey pREL_NUM SLIT("J#")
 
 
 isIntegerTy :: Type -> Bool
 
 
 isIntegerTy :: Type -> Bool

-isIntegerTy ty
-  = case (splitAlgTyConApp_maybe ty) of
-       Just (tycon, [], _) -> getUnique tycon == integerTyConKey
-       _                   -> False
+isIntegerTy = isTyCon integerTyConKey

 \end{code}
 
 
 \end{code}
 
 

@@ -400,75 +388,67 @@ being the )
 
 \begin{code}
 isFFIArgumentTy :: Bool -> Type -> Bool
 
 \begin{code}
 isFFIArgumentTy :: Bool -> Type -> Bool

-isFFIArgumentTy forASafeCall ty =
-  (opt_GlasgowExts && isUnLiftedType ty) ||
-  case (splitAlgTyConApp_maybe ty) of
-    Just (tycon, _, _) -> 
-               let
-                u = getUnique tycon
-               in
-               u `elem` primArgTyConKeys &&   -- it has a suitable prim type, and
-               (not forASafeCall || not ( u `elem` notSafeExternalTyCons)) -- it is safe to pass out.
-    _                 -> False
-
--- types that can be passed as arguments to "foreign" functions
-primArgTyConKeys 
-  = [ intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey
-    , wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey
-    , floatTyConKey, doubleTyConKey
-    , addrTyConKey, charTyConKey, foreignObjTyConKey
-    , stablePtrTyConKey
-    , byteArrayTyConKey, mutableByteArrayTyConKey
-    ]
-
--- types that can be passed from the outside world into Haskell.
--- excludes (mutable) byteArrays.
-isFFIExternalTy :: Type -> Bool
-isFFIExternalTy ty = 
-  (opt_GlasgowExts && isUnLiftedType ty) || --leave out for now: maybeToBool (maybeBoxedPrimType ty))) ||
-  case (splitAlgTyConApp_maybe ty) of
-    Just (tycon, _, _) -> 
-       let 
-        u_tycon = getUnique tycon
-       in  
-       (u_tycon `elem` primArgTyConKeys) &&
-       not (u_tycon `elem` notLegalExternalTyCons)
-    _                 -> False
+-- Checks for valid argument type for a 'foreign import'
+isFFIArgumentTy is_safe ty = checkTyCon (legalOutgoingTyCon is_safe) ty

 
 

+isFFIExternalTy :: Type -> Bool
+-- Types that are allowed as arguments of a 'foreign export'
+isFFIExternalTy ty = checkTyCon legalIncomingTyCon ty

 
 isFFIResultTy :: Type -> Bool
 
 isFFIResultTy :: Type -> Bool

-isFFIResultTy ty =
-   not (isUnLiftedType ty) &&
-   case (splitAlgTyConApp_maybe ty) of
-    Just (tycon, _, _) -> 
-       let
-        u_tycon = getUnique tycon
-       in
-       (u_tycon == getUnique unitTyCon) ||
-        ((u_tycon `elem` primArgTyConKeys) && 
-        not (u_tycon `elem` notLegalExternalTyCons))
-    _                 -> False
-
--- it's illegal to return foreign objects and (mutable)
--- bytearrays from a _ccall_ / foreign declaration
--- (or be passed them as arguments in foreign exported functions).
-notLegalExternalTyCons =
-  [ foreignObjTyConKey, byteArrayTyConKey, mutableByteArrayTyConKey ]
-
--- it's really unsafe to pass out references to objects in the heap,
--- so for safe call-outs we simply disallow it.
-notSafeExternalTyCons =
-  [ byteArrayTyConKey, mutableByteArrayTyConKey ]
+-- Types that are allowed as a result of a 'foreign import' or of a 'foreign export'
+-- Maybe we should distinguish between import and export, but 
+-- here we just choose the more restrictive 'incoming' predicate
+-- But we allow () as well
+isFFIResultTy ty = checkTyCon (\tc -> tc == unitTyCon || legalIncomingTyCon tc) ty
+
+checkTyCon :: (TyCon -> Bool) -> Type -> Bool
+checkTyCon check_tc ty = case splitTyConApp_maybe (repType ty) of
+                               Just (tycon, _) -> check_tc tycon
+                               Nothing         -> False
+
+isTyCon :: Unique -> Type -> Bool
+isTyCon uniq ty = checkTyCon (\tc -> uniq == getUnique tc) ty
+\end{code}

 
 

+----------------------------------------------
+These chaps do the work; they are not exported
+----------------------------------------------

 
 

-isForeignObjTy :: Type -> Bool
-isForeignObjTy ty =
-  case (splitAlgTyConApp_maybe ty) of
-    Just (tycon, _, _) -> (getUnique tycon) == foreignObjTyConKey
-    _                 -> False
-    
+\begin{code}
+legalIncomingTyCon :: TyCon -> Bool
+-- It's illegal to return foreign objects and (mutable)
+-- bytearrays from a _ccall_ / foreign declaration
+-- (or be passed them as arguments in foreign exported functions).
+legalIncomingTyCon tc
+  | getUnique tc `elem` [ foreignObjTyConKey, byteArrayTyConKey, mutableByteArrayTyConKey ] 
+  = False
+  | otherwise
+  = marshalableTyCon tc
+
+legalOutgoingTyCon :: Bool -> TyCon -> Bool
+-- Checks validity of types going from Haskell -> external world
+-- The boolean is true for a 'safe' call (when we don't want to
+-- pass Haskell pointers to the world)
+legalOutgoingTyCon be_safe tc
+  | be_safe && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
+  = False
+  | otherwise
+  = marshalableTyCon tc
+
+marshalableTyCon tc
+  =  (opt_GlasgowExts && isUnLiftedTyCon tc)
+  || getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey
+                        , wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey
+                        , floatTyConKey, doubleTyConKey
+                        , addrTyConKey, charTyConKey, foreignObjTyConKey
+                        , stablePtrTyConKey
+                        , byteArrayTyConKey, mutableByteArrayTyConKey
+                        , boolTyConKey
+                        ]

 \end{code}
 
 \end{code}
 

+

 %************************************************************************
 %*                                                                     *
 \subsection[TysWiredIn-Bool]{The @Bool@ type}
 %************************************************************************
 %*                                                                     *
 \subsection[TysWiredIn-Bool]{The @Bool@ type}

diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 359f284..5a563a0 100644 (file)
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -14,22 +14,24 @@ import RnHsSyn              ( RenamedHsModule, RenamedHsDecl,
                          extractHsTyNames, extractHsCtxtTyNames
                        )
 
                          extractHsTyNames, extractHsCtxtTyNames
                        )
 

-import CmdLineOpts     ( opt_HiMap, opt_D_dump_rn_trace,
+import CmdLineOpts     ( opt_HiMap, opt_D_dump_rn_trace, opt_D_dump_minimal_imports,

                          opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnDeprecations
                        )
 import RnMonad
 import RnNames         ( getGlobalNames )
 import RnSource                ( rnSourceDecls, rnDecl )
                          opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnDeprecations
                        )
 import RnMonad
 import RnNames         ( getGlobalNames )
 import RnSource                ( rnSourceDecls, rnDecl )

-import RnIfaces                ( getImportedInstDecls, importDecl, getImportVersions,
+import RnIfaces                ( getImportedInstDecls, importDecl, getImportVersions, getInterfaceExports,

                          getImportedRules, loadHomeInterface, getSlurped, removeContext
                        )
                          getImportedRules, loadHomeInterface, getSlurped, removeContext
                        )

-import RnEnv           ( availName, availsToNameSet, 
-                         warnUnusedImports, warnUnusedLocalBinds, lookupImplicitOccRn,
+import RnEnv           ( availName, availsToNameSet, unitAvailEnv, availEnvElts, plusAvailEnv, 
+                         warnUnusedImports, warnUnusedLocalBinds, lookupImplicitOccRn, pprAvail,

                          FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs
                        )
                          FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs
                        )

-import Module           ( Module, ModuleName, mkSearchPath, mkThisModule )
+import Module           ( Module, ModuleName, WhereFrom(..),
+                         moduleNameUserString, mkSearchPath, moduleName, mkThisModule
+                       )

 import Name            ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
 import Name            ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,

-                         nameOccName, nameUnique, 
+                         nameOccName, nameUnique, nameModule, maybeUserImportedFrom,

                          isUserImportedExplicitlyName, isUserImportedName,
                          maybeWiredInTyConName, maybeWiredInIdName, isWiredInName
                        )
                          isUserImportedExplicitlyName, isUserImportedName,
                          maybeWiredInTyConName, maybeWiredInIdName, isWiredInName
                        )

@@ -37,18 +39,19 @@ import OccName              ( occNameFlavour, isValOcc )
 import Id              ( idType )
 import TyCon           ( isSynTyCon, getSynTyConDefn )
 import NameSet
 import Id              ( idType )
 import TyCon           ( isSynTyCon, getSynTyConDefn )
 import NameSet

-import PrelMods                ( mAIN_Name, pREL_MAIN_Name )
+import PrelMods                ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name )

 import TysWiredIn      ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
 import PrelInfo                ( ioTyCon_NAME, thinAirIdNames, fractionalClassKeys, derivingOccurrences )
 import Type            ( namesOfType, funTyCon )
 import ErrUtils                ( printErrorsAndWarnings, dumpIfSet, ghcExit )
 import BasicTypes      ( NewOrData(..) )
 import Bag             ( isEmptyBag, bagToList )
 import TysWiredIn      ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
 import PrelInfo                ( ioTyCon_NAME, thinAirIdNames, fractionalClassKeys, derivingOccurrences )
 import Type            ( namesOfType, funTyCon )
 import ErrUtils                ( printErrorsAndWarnings, dumpIfSet, ghcExit )
 import BasicTypes      ( NewOrData(..) )
 import Bag             ( isEmptyBag, bagToList )

-import FiniteMap       ( eltsFM )
+import FiniteMap       ( FiniteMap, eltsFM, fmToList, emptyFM, addToFM_C )

 import UniqSupply      ( UniqSupply )
 import UniqFM          ( lookupUFM )
 import Maybes          ( maybeToBool )
 import Outputable
 import UniqSupply      ( UniqSupply )
 import UniqFM          ( lookupUFM )
 import Maybes          ( maybeToBool )
 import Outputable

+import IO              ( openFile, IOMode(..) )

 \end{code}
 
 
 \end{code}
 
 

@@ -144,7 +147,7 @@ rename this_mod@(HsModule mod_name vers _ imports local_decls mod_deprec loc)
     getNameSupplyRn                            `thenRn` \ name_supply ->
 
        -- REPORT UNUSED NAMES
     getNameSupplyRn                            `thenRn` \ name_supply ->
 
        -- REPORT UNUSED NAMES

-    reportUnusedNames gbl_env global_avail_env
+    reportUnusedNames mod_name gbl_env global_avail_env

                      export_env
                      source_fvs                        `thenRn_`
 
                      export_env
                      source_fvs                        `thenRn_`
 

@@ -525,8 +528,8 @@ getInstDeclGates other                                  = emptyFVs
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}

-reportUnusedNames :: GlobalRdrEnv -> NameEnv AvailInfo -> ExportEnv -> NameSet -> RnM d ()
-reportUnusedNames gbl_env avail_env (ExportEnv export_avails _ _) mentioned_names
+reportUnusedNames :: ModuleName -> GlobalRdrEnv -> AvailEnv -> ExportEnv -> NameSet -> RnMG ()
+reportUnusedNames mod_name gbl_env avail_env (ExportEnv export_avails _ _) mentioned_names

   = let
        used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
 
   = let
        used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
 

@@ -569,14 +572,61 @@ reportUnusedNames gbl_env avail_env (ExportEnv export_avails _ _) mentioned_name
                                  | n <- nameSetToList mentioned_names,
                                    not (isLocallyDefined n),
                                    Just txt <- [lookupNameEnv deprec_env n] ]
                                  | n <- nameSetToList mentioned_names,
                                    not (isLocallyDefined n),
                                    Just txt <- [lookupNameEnv deprec_env n] ]

+
+       minimal_imports :: FiniteMap Module AvailEnv
+       minimal_imports = foldNameSet add emptyFM really_used_names
+       add n acc = case maybeUserImportedFrom n of
+                       Nothing -> acc
+                       Just m  -> addToFM_C plusAvailEnv acc m
+                                            (unitAvailEnv (mk_avail n))
+       mk_avail n = case lookupNameEnv avail_env n of
+                       Just (AvailTC m _) | n==m      -> AvailTC n [n]
+                                          | otherwise -> AvailTC m [n,m]
+                       Just avail         -> Avail n
+                       Nothing            -> pprPanic "mk_avail" (ppr n)

     in
     warnUnusedLocalBinds bad_locals                            `thenRn_`
     warnUnusedImports bad_imps                                 `thenRn_`
     in
     warnUnusedLocalBinds bad_locals                            `thenRn_`
     warnUnusedImports bad_imps                                 `thenRn_`

+    printMinimalImports mod_name minimal_imports               `thenRn_`

     getIfacesRn                                                        `thenRn` \ ifaces ->
     (if opt_WarnDeprecations
        then mapRn_ warnDeprec (deprec_used (iDeprecs ifaces))
        else returnRn ())
 
     getIfacesRn                                                        `thenRn` \ ifaces ->
     (if opt_WarnDeprecations
        then mapRn_ warnDeprec (deprec_used (iDeprecs ifaces))
        else returnRn ())
 

+-- ToDo: deal with original imports with 'qualified' and 'as M' clauses
+printMinimalImports mod_name imps
+  | not opt_D_dump_minimal_imports
+  = returnRn ()
+  | otherwise
+  = mapRn to_ies (fmToList imps)               `thenRn` \ mod_ies ->
+    ioToRnM (do { h <- openFile filename WriteMode ;
+                 printForUser h (vcat (map ppr_mod_ie mod_ies))
+       })                                      `thenRn_`
+    returnRn ()
+  where
+    filename = moduleNameUserString mod_name ++ ".imports"
+    ppr_mod_ie (mod_name, ies) 
+       | mod_name == pRELUDE_Name 
+       = empty
+       | otherwise
+       = ptext SLIT("import") <+> ppr mod_name <> 
+                           parens (fsep (punctuate comma (map ppr ies)))
+
+    to_ies (mod, avail_env) = mapRn to_ie (availEnvElts avail_env)     `thenRn` \ ies ->
+                             returnRn (moduleName mod, ies)
+
+    to_ie :: AvailInfo -> RnMG (IE Name)
+    to_ie (Avail n)       = returnRn (IEVar n)
+    to_ie (AvailTC n [m]) = ASSERT( n==m ) 
+                           returnRn (IEThingAbs n)
+    to_ie (AvailTC n ns)  = getInterfaceExports (moduleName (nameModule n)) 
+                                               ImportBySystem          `thenRn` \ (_, avails) ->
+                           case [ms | AvailTC m ms <- avails, m == n] of
+                             [ms] | all (`elem` ns) ms -> returnRn (IEThingAll n)
+                                  | otherwise          -> returnRn (IEThingWith n (filter (/= n) ns))
+                             other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $
+                                      returnRn (IEVar n)
+

 warnDeprec :: (Name, DeprecTxt) -> RnM d ()
 warnDeprec (name, txt)
   = pushSrcLocRn (getSrcLoc name)      $
 warnDeprec :: (Name, DeprecTxt) -> RnM d ()
 warnDeprec (name, txt)
   = pushSrcLocRn (getSrcLoc name)      $

diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index adc5a06..4bd6122 100644 (file)
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -590,7 +590,7 @@ mkExportAvails mod_name unqual_imp name_env avails
 
 plusExportAvails ::  ExportAvails ->  ExportAvails ->  ExportAvails
 plusExportAvails (m1, e1) (m2, e2)
 
 plusExportAvails ::  ExportAvails ->  ExportAvails ->  ExportAvails
 plusExportAvails (m1, e1) (m2, e2)

-  = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2)
+  = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2)

        -- ToDo: wasteful: we do this once for each constructor!
 \end{code}
 
        -- ToDo: wasteful: we do this once for each constructor!
 \end{code}
 

@@ -599,12 +599,24 @@ plusExportAvails (m1, e1) (m2, e2)
 
 \begin{code}
 plusAvail (Avail n1)      (Avail n2)       = Avail n1
 
 \begin{code}
 plusAvail (Avail n1)      (Avail n2)       = Avail n1

-plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2))
+plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))

 -- Added SOF 4/97
 #ifdef DEBUG
 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
 #endif
 
 -- Added SOF 4/97
 #ifdef DEBUG
 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
 #endif
 

+addAvail :: AvailEnv -> AvailInfo -> AvailEnv
+addAvail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail
+
+emptyAvailEnv = emptyNameEnv
+unitAvailEnv :: AvailInfo -> AvailEnv
+unitAvailEnv a = unitNameEnv (availName a) a
+
+plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
+plusAvailEnv = plusNameEnv_C plusAvail
+
+availEnvElts = nameEnvElts
+

 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
 
 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
 

@@ -658,20 +670,12 @@ filterAvail (IEThingAll _) avail@(AvailTC _ _)   = Just avail
 
 filterAvail ie avail = Nothing
 
 
 filterAvail ie avail = Nothing
 

+pprAvail :: AvailInfo -> SDoc
+pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of
+                                       []  -> empty
+                                       ns' -> parens (hsep (punctuate comma (map ppr ns')))

 
 

--- In interfaces, pprAvail gets given the OccName of the "host" thing
-pprAvail avail = getPprStyle $ \ sty ->
-                if ifaceStyle sty then
-                   ppr_avail (pprOccName . nameOccName) avail
-                else
-                   ppr_avail ppr avail
-
-ppr_avail pp_name (AvailTC n ns) = hsep [
-                                    pp_name n,
-                                    parens  $ hsep $ punctuate comma $
-                                    map pp_name ns
-                                  ]
-ppr_avail pp_name (Avail n) = pp_name n
+pprAvail (Avail n) = ppr n

 \end{code}
 
 
 \end{code}
 
 

diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index ac646e9..95a248e 100644 (file)
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -173,20 +173,24 @@ nameEnvElts    :: NameEnv a -> [a]
 addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
 addToNameEnv   :: NameEnv a -> Name -> a -> NameEnv a
 plusNameEnv    :: NameEnv a -> NameEnv a -> NameEnv a
 addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
 addToNameEnv   :: NameEnv a -> Name -> a -> NameEnv a
 plusNameEnv    :: NameEnv a -> NameEnv a -> NameEnv a

+plusNameEnv_C  :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a

 extendNameEnv  :: NameEnv a -> [(Name,a)] -> NameEnv a
 lookupNameEnv  :: NameEnv a -> Name -> Maybe a
 delFromNameEnv :: NameEnv a -> Name -> NameEnv a
 elemNameEnv    :: Name -> NameEnv a -> Bool
 extendNameEnv  :: NameEnv a -> [(Name,a)] -> NameEnv a
 lookupNameEnv  :: NameEnv a -> Name -> Maybe a
 delFromNameEnv :: NameEnv a -> Name -> NameEnv a
 elemNameEnv    :: Name -> NameEnv a -> Bool

+unitNameEnv    :: Name -> a -> NameEnv a

 
 emptyNameEnv   = emptyUFM
 nameEnvElts    = eltsUFM
 addToNameEnv_C = addToUFM_C
 addToNameEnv   = addToUFM
 plusNameEnv    = plusUFM
 
 emptyNameEnv   = emptyUFM
 nameEnvElts    = eltsUFM
 addToNameEnv_C = addToUFM_C
 addToNameEnv   = addToUFM
 plusNameEnv    = plusUFM

+plusNameEnv_C  = plusUFM_C

 extendNameEnv  = addListToUFM
 lookupNameEnv  = lookupUFM
 delFromNameEnv = delFromUFM
 elemNameEnv    = elemUFM
 extendNameEnv  = addListToUFM
 lookupNameEnv  = lookupUFM
 delFromNameEnv = delFromUFM
 elemNameEnv    = elemUFM

+unitNameEnv    = unitUFM

 
 --------------------------------
 type FixityEnv = NameEnv RenamedFixitySig
 
 --------------------------------
 type FixityEnv = NameEnv RenamedFixitySig

@@ -236,9 +240,8 @@ type ExportAvails = (FiniteMap ModuleName Avails,
        -- Includes avails only from *unqualified* imports
        -- (see 1.4 Report Section 5.1.1)
 
        -- Includes avails only from *unqualified* imports
        -- (see 1.4 Report Section 5.1.1)
 

-       NameEnv AvailInfo)      -- Used to figure out all other export specifiers.
-                               -- Maps a Name to the AvailInfo that contains it
-
+                    AvailEnv)  -- Used to figure out all other export specifiers.
+                       

 
 data GenAvailInfo name = Avail name     -- An ordinary identifier
                        | AvailTC name   -- The name of the type or class
 
 data GenAvailInfo name = Avail name     -- An ordinary identifier
                        | AvailTC name   -- The name of the type or class

@@ -247,6 +250,7 @@ data GenAvailInfo name      = Avail name     -- An ordinary identifier
                                         -- to be in scope, it must be in this list.
                                         -- Thus, typically: AvailTC Eq [Eq, ==, /=]
 
                                         -- to be in scope, it must be in this list.
                                         -- Thus, typically: AvailTC Eq [Eq, ==, /=]
 

+type AvailEnv    = NameEnv AvailInfo   -- Maps a Name to the AvailInfo that contains it

 type AvailInfo    = GenAvailInfo Name
 type RdrAvailInfo = GenAvailInfo OccName
 \end{code}
 type AvailInfo    = GenAvailInfo Name
 type RdrAvailInfo = GenAvailInfo OccName
 \end{code}

diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 4ef7c0a..788440b 100644 (file)
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -64,7 +64,7 @@ getGlobalNames :: RdrNameHsModule
               -> RnMG (Maybe (ExportEnv, 
                               GlobalRdrEnv,
                               FixityEnv,        -- Fixities for local decls only
               -> RnMG (Maybe (ExportEnv, 
                               GlobalRdrEnv,
                               FixityEnv,        -- Fixities for local decls only

-                              NameEnv AvailInfo -- Maps a name to its parent AvailInfo
+                              AvailEnv          -- Maps a name to its parent AvailInfo

                                                 -- Just for in-scope things only
                               ))
                        -- Nothing => no need to recompile
                                                 -- Just for in-scope things only
                               ))
                        -- Nothing => no need to recompile

@@ -547,7 +547,7 @@ type ExportAccum    -- The type of the accumulating parameter of
                        -- the main worker function in exportsFromAvail
      = ([ModuleName],          -- 'module M's seen so far
        ExportOccMap,           -- Tracks exported occurrence names
                        -- the main worker function in exportsFromAvail
      = ([ModuleName],          -- 'module M's seen so far
        ExportOccMap,           -- Tracks exported occurrence names

-       NameEnv AvailInfo)      -- The accumulated exported stuff, kept in an env
+       AvailEnv)               -- The accumulated exported stuff, kept in an env

                                --   so we can common-up related AvailInfos
 
 type ExportOccMap = FiniteMap OccName (Name, RdrNameIE)
                                --   so we can common-up related AvailInfos
 
 type ExportOccMap = FiniteMap OccName (Name, RdrNameIE)

@@ -578,7 +578,7 @@ exportsFromAvail this_mod (Just export_items)
                 (mod_avail_env, entity_avail_env)
                 global_name_env
   = foldlRn exports_from_item
                 (mod_avail_env, entity_avail_env)
                 global_name_env
   = foldlRn exports_from_item

-           ([], emptyFM, emptyNameEnv) export_items    `thenRn` \ (_, _, export_avail_map) ->
+           ([], emptyFM, emptyAvailEnv) export_items   `thenRn` \ (_, _, export_avail_map) ->

     let
        export_avails :: [AvailInfo]
        export_avails   = nameEnvElts export_avail_map
     let
        export_avails :: [AvailInfo]
        export_avails   = nameEnvElts export_avail_map

@@ -600,7 +600,7 @@ exportsFromAvail this_mod (Just export_items)
                Just mod_avails -> foldlRn (check_occs ie) occs mod_avails
                                   `thenRn` \ occs' ->
                                   let
                Just mod_avails -> foldlRn (check_occs ie) occs mod_avails
                                   `thenRn` \ occs' ->
                                   let

-                                       avails' = foldl add_avail avails mod_avails
+                                       avails' = foldl addAvail avails mod_avails

                                   in
                                   returnRn (mod:mods, occs', avails')
 
                                   in
                                   returnRn (mod:mods, occs', avails')
 

@@ -628,7 +628,7 @@ exportsFromAvail this_mod (Just export_items)
 
        = warnCheckRn (ok_item ie avail) (dodgyExportWarn ie)   `thenRn_`
           check_occs ie occs export_avail                      `thenRn` \ occs' ->
 
        = warnCheckRn (ok_item ie avail) (dodgyExportWarn ie)   `thenRn_`
           check_occs ie occs export_avail                      `thenRn` \ occs' ->

-         returnRn (mods, occs', add_avail avails export_avail)
+         returnRn (mods, occs', addAvail avails export_avail)

 
        where
          rdr_name        = ieName ie
 
        where
          rdr_name        = ieName ie

@@ -646,8 +646,6 @@ exportsFromAvail this_mod (Just export_items)
                -- in the AvailTC is the type or class itself
     ok_item _ _ = True
 
                -- in the AvailTC is the type or class itself
     ok_item _ _ = True
 

-add_avail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail
-

 check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap
 check_occs ie occs avail 
   = foldlRn check occs (availNames avail)
 check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap
 check_occs ie occs avail 
   = foldlRn check occs (availNames avail)

diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index 5e11d81..f3a5d14 100644 (file)
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -45,7 +45,7 @@ import Name           ( mkLocalName, tidyOccName, tidyTopName,
 import TyCon           ( TyCon, isDataTyCon )
 import PrelInfo                ( unpackCStringId, unpackCString2Id, addr2IntegerId )
 import PrelRules       ( builtinRules )
 import TyCon           ( TyCon, isDataTyCon )
 import PrelInfo                ( unpackCStringId, unpackCString2Id, addr2IntegerId )
 import PrelRules       ( builtinRules )

-import Type            ( Type, splitAlgTyConApp_maybe, 
+import Type            ( Type, 

                          isUnLiftedType,
                          tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
                          Type
                          isUnLiftedType,
                          tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
                          Type

diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs
index 1215078..5fcb8d7 100644 (file)
--- a/ghc/compiler/stranal/WwLib.lhs
+++ b/ghc/compiler/stranal/WwLib.lhs
@@ -25,7 +25,7 @@ import TysPrim                ( realWorldStatePrimTy )
 import TysWiredIn      ( unboxedTupleCon, unboxedTupleTyCon )
 import Type            ( isUnLiftedType, 
                          splitForAllTys, splitFunTys,  isAlgType,
 import TysWiredIn      ( unboxedTupleCon, unboxedTupleTyCon )
 import Type            ( isUnLiftedType, 
                          splitForAllTys, splitFunTys,  isAlgType,

-                         splitAlgTyConApp_maybe, splitNewType_maybe,
+                         splitNewType_maybe,

                          mkTyConApp, mkFunTys,
                          Type
                        )
                          mkTyConApp, mkFunTys,
                          Type
                        )

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 7716100..8063961 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -14,7 +14,7 @@ import HsSyn          ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
                        )
 import RnHsSyn         ( RenamedHsExpr, RenamedRecordBinds )
 import TcHsSyn         ( TcExpr, TcRecordBinds, mkHsConApp,
                        )
 import RnHsSyn         ( RenamedHsExpr, RenamedRecordBinds )
 import TcHsSyn         ( TcExpr, TcRecordBinds, mkHsConApp,

-                         mkHsTyApp, mkHsLet, maybeBoxedPrimType
+                         mkHsTyApp, mkHsLet

                        )
 
 import TcMonad
                        )
 
 import TcMonad

@@ -390,8 +390,7 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
        -- constraints on the argument and result types.
     mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys)   `thenNF_Tc` \ ccarg_dicts_s ->
     newClassDicts result_origin [(cReturnableClass, [result_ty])]      `thenNF_Tc` \ (ccres_dict, _) ->
        -- constraints on the argument and result types.
     mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys)   `thenNF_Tc` \ ccarg_dicts_s ->
     newClassDicts result_origin [(cReturnableClass, [result_ty])]      `thenNF_Tc` \ (ccres_dict, _) ->

-    returnTc (mkHsConApp ioDataCon [result_ty] [HsCCall lbl args' may_gc is_asm result_ty],
-                     -- do the wrapping in the newtype constructor here
+    returnTc (HsCCall lbl args' may_gc is_asm io_result_ty,

              foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
 \end{code}
 
              foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
 \end{code}
 

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 37b7036..e99c01d 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -29,8 +29,6 @@ module TcHsSyn (
        -- re-exported from TcEnv
        TcId, tcInstId,
 
        -- re-exported from TcEnv
        TcId, tcInstId,
 

-       maybeBoxedPrimType,
-

        zonkTopBinds, zonkId, zonkIdOcc,
        zonkForeignExports, zonkRules
   ) where
        zonkTopBinds, zonkId, zonkIdOcc,
        zonkForeignExports, zonkRules
   ) where

@@ -51,7 +49,7 @@ import TcMonad
 import TcType  ( TcType, TcTyVar,
                  zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
                )
 import TcType  ( TcType, TcTyVar,
                  zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
                )

-import Type    ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
+import Type    ( mkTyVarTy, isUnLiftedType, Type )

 import Name    ( isLocallyDefined )
 import Var     ( TyVar )
 import VarEnv  ( TyVarEnv, emptyVarEnv, extendVarEnvList )
 import Name    ( isLocallyDefined )
 import Var     ( TyVar )
 import VarEnv  ( TyVarEnv, emptyVarEnv, extendVarEnvList )

@@ -140,27 +138,6 @@ idsToMonoBinds ids
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-Some gruesome hackery for desugaring ccalls. It's here because if we put it
-in Type.lhs we get irritating loops, and it's only used by TcInstDcls.lhs and
-DsCCall.lhs.
-
-\begin{code}
-maybeBoxedPrimType :: Type -> Maybe (DataCon, Type)
-maybeBoxedPrimType ty
-  = case splitProductType_maybe ty of                          -- Product data type
-      Just (tycon, tys_applied, data_con, [data_con_arg_ty])   -- constr has one arg
-         | isUnLiftedType data_con_arg_ty                      -- which is primitive
-        -> Just (data_con, data_con_arg_ty)
-
-      other_cases -> Nothing
-\end{code}
-
-%************************************************************************
-%*                                                                     *
-\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
-%*                                                                     *
-%************************************************************************
-

 This zonking pass runs over the bindings
 
  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 This zonking pass runs over the bindings
 
  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 0d9ffac..b50818d 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -14,9 +14,7 @@ import HsSyn          ( HsDecl(..), InstDecl(..),
                          andMonoBindList
                        )
 import RnHsSyn         ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )
                          andMonoBindList
                        )
 import RnHsSyn         ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )

-import TcHsSyn         ( TcMonoBinds, mkHsConApp,
-                         maybeBoxedPrimType
-                       )
+import TcHsSyn         ( TcMonoBinds, mkHsConApp )

 
 import TcBinds         ( tcSpecSigs )
 import TcClassDcl      ( tcMethodBind, checkFromThisClass )
 
 import TcBinds         ( tcSpecSigs )
 import TcClassDcl      ( tcMethodBind, checkFromThisClass )

@@ -60,7 +58,7 @@ import Type           ( Type, isUnLiftedType, mkTyVarTys,
 import Subst           ( mkTopTyVarSubst, substClasses )
 import VarSet          ( mkVarSet, varSetElems )
 import TysPrim         ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
 import Subst           ( mkTopTyVarSubst, substClasses )
 import VarSet          ( mkVarSet, varSetElems )
 import TysPrim         ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )

-import TysWiredIn      ( stringTy )
+import TysWiredIn      ( stringTy, isFFIArgumentTy, isFFIResultTy )

 import Unique          ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
 import Outputable
 \end{code}
 import Unique          ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
 import Outputable
 \end{code}

@@ -491,18 +489,7 @@ scrutiniseInstanceConstraint (clas, tys)
   | otherwise                     = addErrTc (instConstraintErr clas tys)
 
 scrutiniseInstanceHead clas inst_taus
   | otherwise                     = addErrTc (instConstraintErr clas tys)
 
 scrutiniseInstanceHead clas inst_taus

-  |    -- CCALL CHECK (a).... urgh!
-       -- To verify that a user declaration of a CCallable/CReturnable 
-       -- instance is OK, we must be able to see the constructor(s)
-       -- of the instance type (see next guard.)
-       --  
-        -- We flag this separately to give a more precise error msg.
-        --
-     (getUnique clas == cCallableClassKey || getUnique clas == cReturnableClassKey)
-  && is_alg_tycon_app && not constructors_visible
-  = addErrTc (invisibleDataConPrimCCallErr clas first_inst_tau)
-
-  |    -- CCALL CHECK (b) 
+  |    -- CCALL CHECK

        -- A user declaration of a CCallable/CReturnable instance
        -- must be for a "boxed primitive" type.
     (getUnique clas == cCallableClassKey   && not (ccallable_type   first_inst_tau)) ||
        -- A user declaration of a CCallable/CReturnable instance
        -- must be for a "boxed primitive" type.
     (getUnique clas == cCallableClassKey   && not (ccallable_type   first_inst_tau)) ||

@@ -558,32 +545,8 @@ scrutiniseInstanceHead clas inst_taus
 
     constructors_visible = not (null data_cons)
  
 
     constructors_visible = not (null data_cons)
  

-
--- These conditions come directly from what the DsCCall is capable of.
--- Totally grotesque.  Green card should solve this.
-
-ccallable_type   ty = isUnLiftedType ty ||                             -- Allow CCallable Int# etc
-                      maybeToBool (maybeBoxedPrimType ty) ||   -- Ditto Int etc
-                     ty == stringTy ||
-                     byte_arr_thing
-  where
-    byte_arr_thing = case splitProductType_maybe ty of
-                       Just (tycon, ty_args, data_con, [data_con_arg_ty1, data_con_arg_ty2, data_con_arg_ty3]) ->
-                               maybeToBool maybe_arg3_tycon &&
-                               (arg3_tycon == byteArrayPrimTyCon ||
-                                arg3_tycon == mutableByteArrayPrimTyCon)
-                            where
-                               maybe_arg3_tycon    = splitTyConApp_maybe data_con_arg_ty3
-                               Just (arg3_tycon,_) = maybe_arg3_tycon
-
-                       other -> False
-
-creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
-                       -- Or, a data type with a single nullary constructor
-                     case (splitAlgTyConApp_maybe ty) of
-                       Just (tycon, tys_applied, [data_con])
-                               -> isNullaryDataCon data_con
-                       other -> False
+ccallable_type   ty = isFFIArgumentTy False {- Not safe call -} ty
+creturnable_type ty = isFFIResultTy ty

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -609,19 +572,6 @@ nonBoxedPrimCCallErr clas inst_ty
         4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
                        ppr inst_ty])
 
         4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
                        ppr inst_ty])
 

-{-
-  Declaring CCallable & CReturnable instances in a module different
-  from where the type was defined. Caused by importing data type
-  abstractly (either programmatically or by the renamer being over-eager
-  in its pruning.)
--}
-invisibleDataConPrimCCallErr clas inst_ty
-  = hang (hsep [ptext SLIT("Constructors for"), quotes (ppr inst_ty),
-               ptext SLIT("not visible when checking"),
-                quotes (ppr clas), ptext SLIT("instance")])
-        4 (hsep [text "(Try either importing", ppr inst_ty, 
-                text "non-abstractly or compile using -fno-prune-tydecls ..)"])
-

 methodCtxt     = ptext SLIT("When checking the methods of an instance declaration")
 superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration")
 \end{code}
 methodCtxt     = ptext SLIT("When checking the methods of an instance declaration")
 superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration")
 \end{code}

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 4fdb337..1aaf17a 100644 (file)
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -316,7 +316,7 @@ splitTyConApp_maybe other         = Nothing
 
 splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
 splitAlgTyConApp_maybe (TyConApp tc tys) 
 
 splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
 splitAlgTyConApp_maybe (TyConApp tc tys) 

-  | isAlgTyCon tc &&
+  | isAlgTyCon tc && 

     tyConArity tc == length tys      = Just (tc, tys, tyConDataCons tc)
 splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
 splitAlgTyConApp_maybe other        = Nothing
     tyConArity tc == length tys      = Just (tc, tys, tyConDataCons tc)
 splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
 splitAlgTyConApp_maybe other        = Nothing