[project @ 2001-05-24 13:59:09 by simonpj]

------------------------------------------------------
	More stuff towards generalising 'foreign' declarations
	------------------------------------------------------

This is the second step towards generalising 'foreign' declarations to
handle langauges other than C.  Now I can handle

  foreign import dotnet type T
  foreign import dotnet "void Foo.Baz.f( T )" f :: T -> IO ()

			** WARNING **
	I believe that all the foreign stuff for C should
	work exactly as before, but I have not tested it
	thoroughly.  Sven, Manuel, Marcin: please give it a
	whirl and compare old with new output.

Lots of fiddling around with data types.  The main changes are

* HsDecls.lhs
	The ForeignDecl type and its friends
	Note also the ForeignType constructor to TyClDecl

* ForeignCall.lhs
	Here's where the stuff that survives right through
	compilation lives

* TcForeign.lhs DsForeign.lhs
	Substantial changes driven by the new data types

* Parser.y ParseIface.y RnSource
	Just what you'd expect

diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs
index c4b6684..8e83f7d 100644 (file)
--- a/ghc/compiler/absCSyn/AbsCUtils.lhs
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -28,7 +28,7 @@ import Unique         ( Unique{-instance Eq-} )
 import UniqSupply      ( uniqFromSupply, uniqsFromSupply, splitUniqSupply, 
                          UniqSupply )
 import CmdLineOpts      ( opt_EmitCExternDecls )
 import UniqSupply      ( uniqFromSupply, uniqsFromSupply, splitUniqSupply, 
                          UniqSupply )
 import CmdLineOpts      ( opt_EmitCExternDecls )

-import ForeignCall     ( ForeignCall(..), CCallSpec(..), isDynamicTarget )
+import ForeignCall     ( ForeignCall(..), CCallSpec(..), isDynamicTarget, isCasmTarget )

 import StgSyn          ( StgOp(..) )
 import Panic           ( panic )
 import FastTypes
 import StgSyn          ( StgOp(..) )
 import Panic           ( panic )
 import FastTypes

@@ -341,9 +341,9 @@ flatAbsC (CSwitch discrim alts deflt)
       = flatAbsC absC  `thenFlt` \ (alt_heres, alt_tops) ->
        returnFlt ( (tag, alt_heres), alt_tops )
 
       = flatAbsC absC  `thenFlt` \ (alt_heres, alt_tops) ->
        returnFlt ( (tag, alt_heres), alt_tops )
 

-flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _ is_asm)) uniq) args _)
-  |  is_dynamic                                        -- Emit a typedef if its a dynamic call
-  || (opt_EmitCExternDecls && not is_asm)      -- or we want extern decls
+flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
+  |  is_dynamic                                                 -- Emit a typedef if its a dynamic call
+  || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls

   = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
   where
     is_dynamic = isDynamicTarget target
   = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
   where
     is_dynamic = isDynamicTarget target

diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index cd9064b..82922d4 100644 (file)
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -46,7 +46,7 @@ import Name           ( NamedThing(..) )
 import DataCon         ( dataConWrapId )
 import Maybes          ( maybeToBool, catMaybes )
 import PrimOp          ( primOpNeedsWrapper )
 import DataCon         ( dataConWrapId )
 import Maybes          ( maybeToBool, catMaybes )
 import PrimOp          ( primOpNeedsWrapper )

-import ForeignCall     ( ForeignCall(..), isDynamicTarget )
+import ForeignCall     ( ForeignCall(..) )

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

@@ -284,7 +284,7 @@ pprAbsC (CCallProfCtrMacro op as) _
 pprAbsC (CCallProfCCMacro op as) _
   = hcat [ptext op, lparen,
        hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
 pprAbsC (CCallProfCCMacro op as) _
   = hcat [ptext op, lparen,
        hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]

-pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _ _) uniq results args) _
+pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _) uniq results args) _

   =  hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))
          , ccall_res_ty
          , fun_nm
   =  hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))
          , ccall_res_ty
          , fun_nm

@@ -775,13 +775,13 @@ 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}

-pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results vol_regs
+pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs

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

-        process_casm local_vars pp_non_void_args casm_str,
+        process_casm local_vars pp_non_void_args call_str,

       pp_restore_context,
       assign_results,
       char '}'
       pp_restore_context,
       assign_results,
       char '}'

@@ -814,16 +814,17 @@ pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results v
     (declare_local_vars, local_vars, assign_results)
       = ppr_casm_results non_void_results
 
     (declare_local_vars, local_vars, assign_results)
       = ppr_casm_results non_void_results
 

-    casm_str = if is_asm then _UNPK_ asm_str else ccall_str
-    StaticTarget asm_str = op_str      -- Must be static if it's a casm
+    call_str = case target of
+                 CasmTarget str  -> _UNPK_ str
+                 StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args
+                 DynamicTarget   -> mk_ccall_str dyn_fun              (tail ccall_args)

 
 

-    -- Remainder only used for ccall
-
-    fun_name = case op_str of
-                DynamicTarget   -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
-                StaticTarget st -> pprCLabelString st
+    ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
+    dyn_fun    = parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
+                                                

 
 

-    ccall_str = showSDoc
+    -- Remainder only used for ccall
+    mk_ccall_str fun_name ccall_fun_args = showSDoc

        (hcat [
                if null non_void_results
                  then empty
        (hcat [
                if null non_void_results
                  then empty

@@ -832,11 +833,6 @@ pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results v
                  hcat (punctuate comma ccall_fun_args),
                text "));"
        ])
                  hcat (punctuate comma ccall_fun_args),
                text "));"
        ])

-
-    ccall_fun_args | isDynamicTarget op_str = tail ccall_args
-                  | otherwise              = ccall_args
-
-    ccall_args    = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]

 \end{code}
 
 If the argument is a heap object, we need to reach inside and pull out
 \end{code}
 
 If the argument is a heap object, we need to reach inside and pull out

diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 9441a2a..6853b96 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -49,7 +49,7 @@ import Id             ( Id, idType, isId,
 import VarSet
 import Literal         ( isLitLitLit, litSize )
 import PrimOp          ( primOpIsDupable, primOpOutOfLine )
 import VarSet
 import Literal         ( isLitLitLit, litSize )
 import PrimOp          ( primOpIsDupable, primOpOutOfLine )

-import ForeignCall     ( ForeignCall(..), ccallIsCasm )
+import ForeignCall     ( okToExposeFCall )

 import IdInfo          ( InlinePragInfo(..), OccInfo(..), GlobalIdDetails(..),
                          isNeverInlinePrag
                        )
 import IdInfo          ( InlinePragInfo(..), OccInfo(..), GlobalIdDetails(..),
                          isNeverInlinePrag
                        )

@@ -490,10 +490,6 @@ okToUnfoldInHiFile e = opt_UnfoldCasms || go e
                                not (any isLitLitLit [ lit | (LitAlt lit, _, _) <- alts ])
     go (Note _ body)          = go body
     go (Type _)                      = True
                                not (any isLitLitLit [ lit | (LitAlt lit, _, _) <- alts ])
     go (Note _ body)          = go body
     go (Type _)                      = True

-
-    -- ok to unfold a PrimOp as long as it's not a _casm_
-    okToExposeFCall (CCall cc) = not (ccallIsCasm cc)
-    okToExposeFCall other      = True

 \end{code}
 
 
 \end{code}
 
 

diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index c03df9e..3758d61 100644 (file)
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -26,7 +26,7 @@ import ForeignCall    ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CC
 import DataCon         ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
 import ForeignCall     ( ForeignCall, CCallTarget(..) )
 import Type            ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
 import DataCon         ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
 import ForeignCall     ( ForeignCall, CCallTarget(..) )
 import Type            ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,

-                         splitTyConApp_maybe, tyVarsOfType, mkForAllTys, 
+                         splitTyConApp_maybe, tyVarsOfType, mkForAllTys, isPrimitiveType,

                          isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp,
                          Type
                        )
                          isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp,
                          Type
                        )

@@ -96,7 +96,9 @@ dsCCall lbl args may_gc is_asm result_ty
     boxResult [] result_ty     `thenDs` \ (ccall_result_ty, res_wrapper) ->
     getUniqueDs                        `thenDs` \ uniq ->
     let
     boxResult [] result_ty     `thenDs` \ (ccall_result_ty, res_wrapper) ->
     getUniqueDs                        `thenDs` \ uniq ->
     let

-       the_fcall    = CCall (CCallSpec (StaticTarget lbl) CCallConv may_gc is_asm)
+       target | is_asm    = CasmTarget lbl
+              | otherwise = StaticTarget lbl
+       the_fcall    = CCall (CCallSpec target CCallConv may_gc)

        the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
     in
     returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
        the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
     in
     returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)

@@ -134,8 +136,8 @@ unboxArg :: CoreExpr                        -- The supplied argument
 -- where W is a CoreExpr that probably mentions x#
 
 unboxArg arg
 -- where W is a CoreExpr that probably mentions x#
 
 unboxArg arg

-  -- Unlifted types: nothing to unbox
-  | isUnLiftedType arg_ty
+  -- Primtive types: nothing to unbox
+  | isPrimitiveType arg_ty

   = returnDs (arg, \body -> body)
 
   -- Newtypes
   = returnDs (arg, \body -> body)
 
   -- Newtypes

@@ -293,7 +295,7 @@ resultWrapper :: Type
                  CoreExpr -> CoreExpr) -- Wrapper for the result 
 resultWrapper result_ty
   -- Base case 1: primitive types
                  CoreExpr -> CoreExpr) -- Wrapper for the result 
 resultWrapper result_ty
   -- Base case 1: primitive types

-  | isUnLiftedType result_ty
+  | isPrimitiveType result_ty

   = (Just result_ty, \e -> e)
 
   -- Base case 1: the unit type ()
   = (Just result_ty, \e -> e)
 
   -- Base case 1: the unit type ()

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 06faf73..af2e270 100644 (file)
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -15,8 +15,7 @@ import CoreSyn
 import DsCCall         ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper )
 import DsMonad
 
 import DsCCall         ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper )
 import DsMonad
 

-import HsSyn           ( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) )
-import HsDecls         ( extNameStatic )
+import HsSyn           ( ForeignDecl(..), FoExport(..), FoImport(..)  )

 import TcHsSyn         ( TypecheckedForeignDecl )
 import CoreUtils       ( exprType, mkInlineMe )
 import Id              ( Id, idType, idName, mkVanillaGlobal, mkSysLocal,
 import TcHsSyn         ( TypecheckedForeignDecl )
 import CoreUtils       ( exprType, mkInlineMe )
 import Id              ( Id, idType, idName, mkVanillaGlobal, mkSysLocal,

@@ -35,9 +34,10 @@ import Type          ( repType, splitTyConApp_maybe,
                        )
 import ForeignCall     ( ForeignCall(..), CCallSpec(..), 
                          Safety(..), playSafe,
                        )
 import ForeignCall     ( ForeignCall(..), CCallSpec(..), 
                          Safety(..), playSafe,

-                         CCallTarget(..), dynamicTarget,
+                         CExportSpec(..),

                          CCallConv(..), ccallConvToInt
                        )
                          CCallConv(..), ccallConvToInt
                        )

+import CStrings                ( CLabelString )

 import TysWiredIn      ( unitTy, addrTy, stablePtrTyCon )
 import TysPrim         ( addrPrimTy )
 import PrelNames       ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName,
 import TysWiredIn      ( unitTy, addrTy, stablePtrTyCon )
 import TysPrim         ( addrPrimTy )
 import PrelNames       ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName,

@@ -75,36 +75,25 @@ dsForeigns :: Module
                  , SDoc              -- C stubs to use when calling
                                       -- "foreign exported" functions.
                  )
                  , SDoc              -- C stubs to use when calling
                                       -- "foreign exported" functions.
                  )

-dsForeigns mod_name fos = foldlDs combine ([], [], empty, empty) fos
+dsForeigns mod_name fos
+  = foldlDs combine ([], [], empty, empty) fos

  where
  where

-  combine (acc_feb, acc_f, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _) 
-    | isForeignImport =   -- foreign import (dynamic)?
-        dsFImport i (idType i) uns ext_nm cconv  `thenDs` \ bs -> 
-       returnDs (acc_feb, bs ++ acc_f, acc_h, acc_c)
-    | isForeignLabel = 
-        dsFLabel i (idType i) ext_nm `thenDs` \ b -> 
-       returnDs (acc_feb, b:acc_f, acc_h, acc_c)
-    | isDynamicExtName ext_nm =
-        dsFExportDynamic i (idType i) mod_name ext_nm cconv  `thenDs` \ (feb,bs,h,c) -> 
-       returnDs (feb:acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c)
-
-    | otherwise               =  -- foreign export
-        dsFExport i (idType i) mod_name ext_nm cconv False   `thenDs` \ (feb,fe,h,c) ->
-       returnDs (feb:acc_feb, fe:acc_f, h $$ acc_h, c $$ acc_c)
-   where
-    isForeignImport = 
-       case imp_exp of
-         FoImport _ -> True
-         _          -> False
-
-    isForeignLabel = 
-       case imp_exp of
-         FoLabel -> True
-         _       -> False
-
-    FoImport uns = imp_exp
+  combine (acc_feb, acc_f, acc_h, acc_c) (ForeignImport id _ spec _) 
+    = dsFImport mod_name id spec       `thenDs` \ (bs, h, c) -> 
+      returnDs (acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c)
+
+  combine (acc_feb, acc_f, acc_h, acc_c) (ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) _)
+    = dsFExport mod_name id (idType id) ext_nm cconv False     `thenDs` \ (feb, b, h, c) ->
+      returnDs (feb:acc_feb, b : acc_f, h $$ acc_h, c $$ acc_c)

 \end{code}
 
 \end{code}
 

+
+%************************************************************************
+%*                                                                     *
+\subsection{Foreign import}
+%*                                                                     *
+%************************************************************************
+

 Desugaring foreign imports is just the matter of creating a binding
 that on its RHS unboxes its arguments, performs the external call
 (using the @CCallOp@ primop), before boxing the result up and returning it.
 Desugaring foreign imports is just the matter of creating a binding
 that on its RHS unboxes its arguments, performs the external call
 (using the @CCallOp@ primop), before boxing the result up and returning it.

@@ -125,14 +114,33 @@ because it exposes the boxing to the call site.
                        
 
 \begin{code}
                        
 
 \begin{code}

-dsFImport :: Id
-         -> Type               -- Type of foreign import.
-         -> Safety             -- Whether can re-enter the Haskell RTS, do GC etc
-         -> ExtName
-         -> CCallConv
-         -> DsM [Binding]
-dsFImport fn_id ty safety ext_name cconv 
+dsFImport :: Module
+         -> Id
+         -> FoImport
+         -> DsM ([Binding], SDoc, SDoc)
+dsFImport mod_name lbl_id (LblImport ext_nm) 
+ = ASSERT(fromJust res_ty == addrPrimTy) -- typechecker ensures this
+   returnDs ([(lbl_id, rhs)], empty, empty)
+ where
+   (res_ty, fo_rhs) = resultWrapper (idType lbl_id)
+   rhs             = fo_rhs (mkLit (MachLabel ext_nm))
+
+dsFImport mod_name fn_id (CImport spec)     = dsFCall mod_name fn_id (CCall spec)
+dsFImport mod_name fn_id (DNImport spec)    = dsFCall mod_name fn_id (DNCall spec)
+dsFImport mod_name fn_id (CDynImport cconv) = dsFExportDynamic mod_name fn_id cconv
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{Foreign calls}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+dsFCall mod_Name fn_id fcall

   = let
   = let

+       ty                   = idType fn_id

        (tvs, fun_ty)        = splitForAllTys ty
        (arg_tys, io_res_ty) = splitFunTys fun_ty
     in
        (tvs, fun_ty)        = splitForAllTys ty
        (arg_tys, io_res_ty) = splitFunTys fun_ty
     in

@@ -145,22 +153,17 @@ dsFImport fn_id ty safety ext_name cconv
        -- These are the ids we pass to boxResult, which are used to decide
        -- whether to touch# an argument after the call (used to keep
        -- ForeignObj#s live across a 'safe' foreign import).
        -- These are the ids we pass to boxResult, which are used to decide
        -- whether to touch# an argument after the call (used to keep
        -- ForeignObj#s live across a 'safe' foreign import).

-       maybe_arg_ids | playSafe safety = work_arg_ids
-                     | otherwise       = []
+       maybe_arg_ids | unsafe_call fcall = work_arg_ids
+                     | otherwise         = []

     in
     boxResult maybe_arg_ids io_res_ty                  `thenDs` \ (ccall_result_ty, res_wrapper) ->
 
     getUniqueDs                                        `thenDs` \ ccall_uniq ->
     getUniqueDs                                        `thenDs` \ work_uniq ->
     let
     in
     boxResult maybe_arg_ids io_res_ty                  `thenDs` \ (ccall_result_ty, res_wrapper) ->
 
     getUniqueDs                                        `thenDs` \ ccall_uniq ->
     getUniqueDs                                        `thenDs` \ work_uniq ->
     let

-       lbl = case ext_name of
-               Dynamic      -> dynamicTarget
-               ExtName fs _ -> StaticTarget fs
-

        -- Build the worker
        worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
        -- Build the worker
        worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)

-       the_ccall     = CCall (CCallSpec lbl cconv safety False)
-       the_ccall_app = mkFCall ccall_uniq the_ccall val_args ccall_result_ty
+       the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty

        work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
        work_id       = mkSysLocal SLIT("$wccall") work_uniq worker_ty
 
        work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
        work_id       = mkSysLocal SLIT("$wccall") work_uniq worker_ty
 

@@ -169,20 +172,18 @@ dsFImport fn_id ty safety ext_name cconv
        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
         wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
     in
        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
         wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
     in

-    returnDs [(work_id, work_rhs), (fn_id, wrap_rhs)]
+    returnDs ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
+
+unsafe_call (CCall (CCallSpec _ _ safety)) = playSafe safety
+unsafe_call (DNCall _)                    = False

 \end{code}
 
 \end{code}
 

-Foreign labels 

 
 

-\begin{code}
-dsFLabel :: Id -> Type -> ExtName -> DsM Binding
-dsFLabel nm ty ext_name = 
-   ASSERT(fromJust res_ty == addrPrimTy) -- typechecker ensures this
-   returnDs (nm, fo_rhs (mkLit (MachLabel enm)))
-  where
-   (res_ty, fo_rhs) = resultWrapper ty
-   enm    = extNameStatic ext_name
-\end{code}
+%************************************************************************
+%*                                                                     *
+\subsection{Foreign export}
+%*                                                                     *
+%************************************************************************

 
 The function that does most of the work for `@foreign export@' declarations.
 (see below for the boilerplate code a `@foreign export@' declaration expands
 
 The function that does most of the work for `@foreign export@' declarations.
 (see below for the boilerplate code a `@foreign export@' declaration expands

@@ -196,19 +197,21 @@ For each `@foreign export foo@' in a module M we generate:
 the user-written Haskell function `@M.foo@'.
 
 \begin{code}
 the user-written Haskell function `@M.foo@'.
 
 \begin{code}

-dsFExport :: Id
-         -> Type               -- Type of foreign export.
-         -> Module
-         -> ExtName
+dsFExport :: Module
+         -> Id                 -- Either the exported Id, 
+                               -- or the foreign-export-dynamic constructor
+         -> Type               -- The type of the thing callable from C
+         -> CLabelString       -- The name to export to C land

          -> CCallConv
          -> CCallConv

-         -> Bool               -- True => invoke IO action that's hanging off 
-                               -- the first argument's stable pointer
+         -> Bool               -- True => foreign export dynamic
+                               --         so invoke IO action that's hanging off 
+                               --         the first argument's stable pointer

          -> DsM ( Id           -- The foreign-exported Id
                 , Binding
                 , SDoc
                 , SDoc
                 )
          -> DsM ( Id           -- The foreign-exported Id
                 , Binding
                 , SDoc
                 , SDoc
                 )

-dsFExport fn_id ty mod_name ext_name cconv isDyn
+dsFExport mod_name fn_id ty ext_name cconv isDyn

   =    -- BUILD THE returnIO WRAPPER, if necessary
        -- Look at the result type of the exported function, orig_res_ty
        -- If it's IO t, return         (\x.x,          IO t, t)
   =    -- BUILD THE returnIO WRAPPER, if necessary
        -- Look at the result type of the exported function, orig_res_ty
        -- If it's IO t, return         (\x.x,          IO t, t)

@@ -282,20 +285,19 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn
 
        the_app = getFun_wrapper (return_io_wrapper (mkVarApps (Var i) (tvs ++ fe_args)))
        the_body = mkLams (tvs ++ wrapper_args) the_app
 
        the_app = getFun_wrapper (return_io_wrapper (mkVarApps (Var i) (tvs ++ fe_args)))
        the_body = mkLams (tvs ++ wrapper_args) the_app

-       c_nm     = extNameStatic ext_name

   
        (h_stub, c_stub) = fexportEntry (moduleUserString mod)
   
        (h_stub, c_stub) = fexportEntry (moduleUserString mod)

-                                     c_nm f_helper_glob
-                                      wrapper_arg_tys res_ty cconv isDyn
+                                       ext_name f_helper_glob
+                                       wrapper_arg_tys res_ty cconv isDyn

      in
      returnDs (f_helper_glob, (f_helper_glob, the_body), h_stub, c_stub)
 
   where
      in
      returnDs (f_helper_glob, (f_helper_glob, the_body), h_stub, c_stub)
 
   where

-   (tvs,sans_foralls)                  = splitForAllTys ty
-   (fe_arg_tys', orig_res_ty)          = splitFunTys sans_foralls
+   (tvs,sans_foralls)          = splitForAllTys ty
+   (fe_arg_tys', orig_res_ty)  = splitFunTys sans_foralls

 
 

-   (_, stbl_ptr_ty')                   = splitForAllTys stbl_ptr_ty
-   (_, stbl_ptr_to_ty)                 = splitAppTy stbl_ptr_ty'
+   (_, stbl_ptr_ty')           = splitForAllTys stbl_ptr_ty
+   (_, stbl_ptr_to_ty)         = splitAppTy stbl_ptr_ty'

 
    fe_arg_tys | isDyn    = tail fe_arg_tys'
              | otherwise = fe_arg_tys'
 
    fe_arg_tys | isDyn    = tail fe_arg_tys'
              | otherwise = fe_arg_tys'

@@ -327,23 +329,19 @@ foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr
 \end{verbatim}
 
 \begin{code}
 \end{verbatim}
 
 \begin{code}

-dsFExportDynamic :: Id
-                -> Type                -- Type of foreign export.
-                -> Module
-                -> ExtName
+dsFExportDynamic :: Module
+                -> Id

                 -> CCallConv
                 -> CCallConv

-                -> DsM (Id, [Binding], SDoc, SDoc)
-dsFExportDynamic i ty mod_name ext_name cconv =
-     newSysLocalDs ty                                   `thenDs` \ fe_id ->
+                -> DsM ([Binding], SDoc, SDoc)
+dsFExportDynamic mod_name id cconv
+  =  newSysLocalDs ty                                   `thenDs` \ fe_id ->

      let 
         -- hack: need to get at the name of the C stub we're about to generate.
      let 
         -- hack: need to get at the name of the C stub we're about to generate.

-       fe_nm      = moduleUserString mod_name ++ "_" ++ toCName fe_id
-       fe_ext_name = ExtName (_PK_ fe_nm) Nothing
+       fe_nm      = _PK_ (moduleUserString mod_name ++ "_" ++ toCName fe_id)

      in
      in

-     dsFExport  i export_ty mod_name fe_ext_name cconv True
-       `thenDs` \ (feb, fe, h_code, c_code) ->
-     newSysLocalDs arg_ty                      `thenDs` \ cback ->
-     dsLookupGlobalValue newStablePtrName      `thenDs` \ newStablePtrId ->
+     dsFExport mod_name id export_ty fe_nm cconv True          `thenDs` \ (feb, fe, h_code, c_code) ->
+     newSysLocalDs arg_ty                              `thenDs` \ cback ->
+     dsLookupGlobalValue newStablePtrName              `thenDs` \ newStablePtrId ->

      let
        mk_stbl_ptr_app    = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
      in
      let
        mk_stbl_ptr_app    = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
      in

@@ -367,7 +365,7 @@ dsFExportDynamic i ty mod_name ext_name cconv =
        -}
       adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
                      , Var stbl_value
        -}
       adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
                      , Var stbl_value

-                     , mkLit (MachLabel (_PK_ fe_nm))
+                     , mkLit (MachLabel fe_nm)

                      ]
         -- name of external entry point providing these services.
        -- (probably in the RTS.) 
                      ]
         -- name of external entry point providing these services.
        -- (probably in the RTS.) 

@@ -382,13 +380,14 @@ dsFExportDynamic i ty mod_name ext_name cconv =
          io_app = mkLams tvs    $
                  mkLams [cback] $
                  stbl_app ccall_io_adj res_ty
          io_app = mkLams tvs    $
                  mkLams [cback] $
                  stbl_app ccall_io_adj res_ty

-        fed = (i `setInlinePragma` neverInlinePrag, io_app)
+        fed = (id `setInlinePragma` neverInlinePrag, io_app)

                -- Never inline the f.e.d. function, because the litlit
                -- might not be in scope in other modules.
      in
                -- Never inline the f.e.d. function, because the litlit
                -- might not be in scope in other modules.
      in

-     returnDs (feb, [fed, fe], h_code, c_code)
+     returnDs ([fed, fe], h_code, c_code)

 
  where
 
  where

+  ty                              = idType id

   (tvs,sans_foralls)              = splitForAllTys ty
   ([arg_ty], io_res_ty)                   = splitFunTys sans_foralls
   Just (ioTyCon, [res_ty])        = splitTyConApp_maybe io_res_ty
   (tvs,sans_foralls)              = splitForAllTys ty
   ([arg_ty], io_res_ty)                   = splitFunTys sans_foralls
   Just (ioTyCon, [res_ty])        = splitTyConApp_maybe io_res_ty

diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 3888db9..fc136d3 100644 (file)
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -9,12 +9,13 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
 \begin{code}
 module HsDecls (
        HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),
 \begin{code}
 module HsDecls (
        HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),

-       DefaultDecl(..), ForeignDecl(..), ForKind(..),
-       ExtName(..), isDynamicExtName, extNameStatic,
+       DefaultDecl(..), 
+       ForeignDecl(..), FoImport(..), FoExport(..), FoType(..),

        ConDecl(..), ConDetails(..), 
        BangType(..), getBangType, getBangStrictness, unbangedType,
        DeprecDecl(..), DeprecTxt,
        ConDecl(..), ConDetails(..), 
        BangType(..), getBangType, getBangStrictness, unbangedType,
        DeprecDecl(..), DeprecTxt,

-       hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, tyClDeclSysNames,
+       hsDeclName, instDeclName, 
+       tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars,

        isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
        mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName,
        getClassDeclSysNames, conDetailsTys
        isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
        mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName,
        getClassDeclSysNames, conDetailsTys

@@ -33,14 +34,13 @@ import HsCore               ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo,
 import CoreSyn         ( CoreRule(..) )
 import BasicTypes      ( NewOrData(..) )
 import Demand          ( StrictnessMark(..) )
 import CoreSyn         ( CoreRule(..) )
 import BasicTypes      ( NewOrData(..) )
 import Demand          ( StrictnessMark(..) )

-import ForeignCall     ( CCallConv )
+import ForeignCall     ( CExportSpec, CCallSpec, DNCallSpec, CCallConv )

 
 -- others:
 
 -- others:

-import ForeignCall     ( Safety )

 import Name            ( NamedThing )
 import FunDeps         ( pprFundeps )
 import Class           ( FunDep, DefMeth(..) )
 import Name            ( NamedThing )
 import FunDeps         ( pprFundeps )
 import Class           ( FunDep, DefMeth(..) )

-import CStrings                ( CLabelString, pprCLabelString )
+import CStrings                ( CLabelString )

 import Outputable      
 import SrcLoc          ( SrcLoc )
 \end{code}
 import Outputable      
 import SrcLoc          ( SrcLoc )
 \end{code}

@@ -82,10 +82,10 @@ data HsDecl name pat
 hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
           => HsDecl name pat -> name
 #endif
 hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
           => HsDecl name pat -> name
 #endif

-hsDeclName (TyClD decl)                                    = tyClDeclName decl
-hsDeclName (InstD   decl)                          = instDeclName decl
-hsDeclName (ForD    (ForeignDecl name _ _ _ _ _))   = name
-hsDeclName (FixD    (FixitySig name _ _))          = name
+hsDeclName (TyClD decl)                          = tyClDeclName decl
+hsDeclName (InstD   decl)                = instDeclName decl
+hsDeclName (ForD    decl)                = forDeclName decl
+hsDeclName (FixD    (FixitySig name _ _)) = name

 -- Others don't make sense
 #ifdef DEBUG
 hsDeclName x                                 = pprPanic "HsDecls.hsDeclName" (ppr x)
 -- Others don't make sense
 #ifdef DEBUG
 hsDeclName x                                 = pprPanic "HsDecls.hsDeclName" (ppr x)

@@ -249,13 +249,22 @@ Interface file code:
 
 
 \begin{code}
 
 
 \begin{code}

+-- TyClDecls are precisely the kind of declarations that can 
+-- appear in interface files; or (internally) in GHC's interface
+-- for a module.  That's why (despite the misnomer) IfaceSig and ForeignType
+-- are both in TyClDecl
+

 data TyClDecl name pat
   = IfaceSig { tcdName :: name,                -- It may seem odd to classify an interface-file signature
 data TyClDecl name pat
   = IfaceSig { tcdName :: name,                -- It may seem odd to classify an interface-file signature

-               tcdType :: HsType name,         -- as a 'TyClDecl', but it's very convenient.  These three
-               tcdIdInfo :: [HsIdInfo name],   -- are the kind that appear in interface files.
+               tcdType :: HsType name,         -- as a 'TyClDecl', but it's very convenient.  
+               tcdIdInfo :: [HsIdInfo name],

                tcdLoc :: SrcLoc
     }
 
                tcdLoc :: SrcLoc
     }
 

+  | ForeignType { tcdName   :: name,           -- See remarks about IfaceSig above
+                 tcdFoType :: FoType,
+                 tcdLoc    :: SrcLoc }
+

   | TyData {   tcdND     :: NewOrData,
                tcdCtxt   :: HsContext name,     -- context
                tcdName   :: name,               -- type constructor
   | TyData {   tcdND     :: NewOrData,
                tcdCtxt   :: HsContext name,     -- context
                tcdName   :: name,               -- type constructor

@@ -321,8 +330,9 @@ tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)]
 -- For record fields, the first one counts as the SrcLoc
 -- We use the equality to filter out duplicate field names
 
 -- For record fields, the first one counts as the SrcLoc
 -- We use the equality to filter out duplicate field names
 

-tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc})  = [(name,loc)]
-tyClDeclNames (IfaceSig  {tcdName = name, tcdLoc = loc})  = [(name,loc)]
+tyClDeclNames (TySynonym   {tcdName = name, tcdLoc = loc})  = [(name,loc)]
+tyClDeclNames (IfaceSig    {tcdName = name, tcdLoc = loc})  = [(name,loc)]
+tyClDeclNames (ForeignType {tcdName = name, tcdLoc = loc})  = [(name,loc)]

 
 tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc})
   = (cls_name,loc) : [(n,loc) | ClassOpSig n _ _ loc <- sigs]
 
 tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc})
   = (cls_name,loc) : [(n,loc) | ClassOpSig n _ _ loc <- sigs]

@@ -331,6 +341,13 @@ tyClDeclNames (TyData {tcdName = tc_name, tcdCons = cons, tcdLoc = loc})
   = (tc_name,loc) : conDeclsNames cons
 
 
   = (tc_name,loc) : conDeclsNames cons
 
 

+tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (TyData    {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (ForeignType {})                     = []
+tyClDeclTyVars (IfaceSig {})                = []
+
+

 --------------------------------
 -- The "system names" are extra implicit names *bound* by the decl.
 -- They are kept in a list rather than a tuple 
 --------------------------------
 -- The "system names" are extra implicit names *bound* by the decl.
 -- They are kept in a list rather than a tuple 

@@ -373,6 +390,10 @@ instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where
        tcdType d1 == tcdType d2 && 
        tcdIdInfo d1 == tcdIdInfo d2
 
        tcdType d1 == tcdType d2 && 
        tcdIdInfo d1 == tcdIdInfo d2
 

+  (==) d1@(ForeignType {}) d2@(ForeignType {})
+      = tcdName d1 == tcdName d2 && 
+       tcdFoType d1 == tcdFoType d2
+

   (==) d1@(TyData {}) d2@(TyData {})
       = tcdName d1 == tcdName d2 && 
        tcdND d1   == tcdND   d2 && 
   (==) d1@(TyData {}) d2@(TyData {})
       = tcdName d1 == tcdName d2 && 
        tcdND d1   == tcdND   d2 && 

@@ -433,6 +454,9 @@ instance (NamedThing name, Outputable name, Outputable pat)
     ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info})
        = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
 
     ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info})
        = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
 

+    ppr (ForeignType {tcdName = tycon})
+       = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
+

     ppr (TySynonym {tcdName = tycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty})
       = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
             4 (ppr mono_ty)
     ppr (TySynonym {tcdName = tycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty})
       = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
             4 (ppr mono_ty)

@@ -670,55 +694,46 @@ instance (Outputable name)
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-data ForeignDecl name = 
-   ForeignDecl 
-        name 
-       ForKind   
-       (HsType name)
-       ExtName
-       CCallConv
-       SrcLoc
-
-instance (Outputable name)
-             => Outputable (ForeignDecl name) where
-
-    ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc)
-      = ptext SLIT("foreign") <+> ppr_imp_exp <+> ppr cconv <+> 
-        ppr ext_name <+> ppr_unsafe <+> ppr nm <+> dcolon <+> ppr ty
-        where
-         (ppr_imp_exp, ppr_unsafe) =
-          case imp_exp of
-            FoLabel     -> (ptext SLIT("label"), empty)
-            FoExport    -> (ptext SLIT("export"), empty)
-            FoImport us -> (ptext SLIT("import"), ppr us)
-
-data ForKind
- = FoLabel
- | FoExport
- | FoImport Safety
-
-data ExtName
- = Dynamic 
- | ExtName CLabelString        -- The external name of the foreign thing,
-          (Maybe CLabelString) -- and optionally its DLL or module name
-                               -- Both of these are completely unencoded; 
-                               -- we just print them as they are
-
-isDynamicExtName :: ExtName -> Bool
-isDynamicExtName Dynamic = True
-isDynamicExtName _      = False
-
-extNameStatic :: ExtName -> CLabelString
-extNameStatic (ExtName f _) = f
-extNameStatic Dynamic      = panic "staticExtName: Dynamic - shouldn't ever happen."
-
-instance Outputable ExtName where
-  ppr Dynamic     = ptext SLIT("dynamic")
-  ppr (ExtName nm mb_mod) = 
-     case mb_mod of { Nothing -> empty; Just m -> doubleQuotes (ptext m) } <+> 
-     doubleQuotes (pprCLabelString nm)
+data ForeignDecl name
+  = ForeignImport name (HsType name) FoImport    SrcLoc
+  | ForeignExport name (HsType name) FoExport    SrcLoc
+
+forDeclName (ForeignImport n _ _ _) = n
+forDeclName (ForeignExport n _ _ _) = n
+
+data FoImport 
+  = LblImport  CLabelString    -- foreign label
+  | CImport    CCallSpec       -- foreign import 
+  | CDynImport CCallConv       -- foreign export dynamic
+  | DNImport   DNCallSpec      -- foreign import dotnet
+
+data FoExport = CExport CExportSpec
+
+data FoType = DNType           -- In due course we'll add subtype stuff
+           deriving( Eq )      -- Used for equality instance for TyClDecl
+
+instance Outputable name => Outputable (ForeignDecl name) where
+  ppr (ForeignImport nm ty (LblImport lbl) src_loc)
+    = ptext SLIT("foreign label") <+> ppr lbl <+> ppr nm <+> dcolon <+> ppr ty
+  ppr (ForeignImport nm ty decl src_loc)
+    = ptext SLIT("foreign import") <+> ppr decl <+> ppr nm <+> dcolon <+> ppr ty
+  ppr (ForeignExport nm ty decl src_loc)
+    = ptext SLIT("foreign export") <+> ppr decl <+> ppr nm <+> dcolon <+> ppr ty
+
+instance Outputable FoImport where
+   ppr (CImport  d)      = ppr d
+   ppr (CDynImport conv) = text "dynamic" <+> ppr conv
+   ppr (DNImport d)     = ptext SLIT("dotnet") <+> ppr d
+   ppr (LblImport l)    = ptext SLIT("label") <+> ppr l
+
+instance Outputable FoExport where
+   ppr (CExport d) = ppr d
+
+instance Outputable FoType where
+   ppr DNType = ptext SLIT("type dotnet")

 \end{code}
 
 \end{code}
 

+

 %************************************************************************
 %*                                                                     *
 \subsection{Transformation rules}
 %************************************************************************
 %*                                                                     *
 \subsection{Transformation rules}

diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 49c1cb1..992f086 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -46,7 +46,8 @@ import NameEnv
 import NameSet
 import OccName         ( pprOccName )
 import TyCon           ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConGenIds,
 import NameSet
 import OccName         ( pprOccName )
 import TyCon           ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConGenIds,

-                         tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, isClassTyCon
+                         tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, 
+                         isClassTyCon, isForeignTyCon

                        )
 import Class           ( classExtraBigSig, classTyCon, DefMeth(..) )
 import FieldLabel      ( fieldLabelType )
                        )
 import Class           ( classExtraBigSig, classTyCon, DefMeth(..) )
 import FieldLabel      ( fieldLabelType )

@@ -187,6 +188,11 @@ ifaceTyCls (ATyCon tycon) so_far
                        tcdSysNames  = map getName (tyConGenIds tycon),
                        tcdLoc       = noSrcLoc }
 
                        tcdSysNames  = map getName (tyConGenIds tycon),
                        tcdLoc       = noSrcLoc }
 

+           | isForeignTyCon tycon
+           = ForeignType { tcdName   = getName tycon,
+                           tcdFoType = DNType, -- The only case at present
+                           tcdLoc    = noSrcLoc }
+

            | otherwise = pprPanic "ifaceTyCls" (ppr tycon)
 
     tyvars      = tyConTyVars tycon
            | otherwise = pprPanic "ifaceTyCls" (ppr tycon)
 
     tyvars      = tyConTyVars tycon

diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index 2ccd9ec..a035b83 100644 (file)
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -70,7 +70,6 @@ calling.
 
 \begin{code}
 foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety is_asm)) rhs
 
 \begin{code}
 foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety is_asm)) rhs

-  | is_asm               = error "ERROR: Native code generator can't handle casm"

   | not (playSafe safety) = returnUs (\xs -> ccall : xs)
 
   | otherwise
   | not (playSafe safety) = returnUs (\xs -> ccall : xs)
 
   | otherwise

@@ -101,14 +100,13 @@ foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety is_asm)) rh
 
     ccall = case lhs of
       []    -> StCall fn cconv VoidRep args
 
     ccall = case lhs of
       []    -> StCall fn cconv VoidRep args

-      [lhs] ->
-         let lhs' = amodeToStix lhs
-             pk   = case getAmodeRep lhs of
+      [lhs] -> StAssign pk lhs' (StCall fn cconv pk args)
+           where
+              lhs' = amodeToStix lhs
+              pk   = case getAmodeRep lhs of

                         FloatRep  -> FloatRep
                         DoubleRep -> DoubleRep
                         other     -> IntRep
                         FloatRep  -> FloatRep
                         DoubleRep -> DoubleRep
                         other     -> IntRep

-         in
-             StAssign pk lhs' (StCall fn cconv pk args)

 
 foreignCallCode lhs call rhs
   = pprPanic "Native code generator can't handle foreign call" (ppr call)
 
 foreignCallCode lhs call rhs
   = pprPanic "Native code generator can't handle foreign call" (ppr call)

diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 353200f..daeabfb 100644 (file)
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -122,6 +122,7 @@ data Token
   | ITwith
   | ITstdcallconv
   | ITccallconv
   | ITwith
   | ITstdcallconv
   | ITccallconv

+  | ITdotnet

 
   | ITinterface                        -- interface keywords
   | IT__export
 
   | ITinterface                        -- interface keywords
   | IT__export

@@ -308,6 +309,7 @@ ghcExtensionKeywordsFM = listToUFM $
        ( "with",       ITwith ),
        ( "stdcall",    ITstdcallconv),
        ( "ccall",      ITccallconv),
        ( "with",       ITwith ),
        ( "stdcall",    ITstdcallconv),
        ( "ccall",      ITccallconv),

+       ( "dotnet",     ITdotnet),

         ("_ccall_",    ITccall (False, False, PlayRisky)),
         ("_ccall_GC_", ITccall (False, False, PlaySafe)),
         ("_casm_",     ITccall (False, True,  PlayRisky)),
         ("_ccall_",    ITccall (False, False, PlayRisky)),
         ("_ccall_GC_", ITccall (False, False, PlaySafe)),
         ("_casm_",     ITccall (False, True,  PlayRisky)),

diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index 51bc199..47381dc 100644 (file)
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -12,7 +12,7 @@ module ParseUtil (
        , mkRecConstrOrUpdate   -- HsExp -> [HsFieldUpdate] -> P HsExp
        , groupBindings
        
        , mkRecConstrOrUpdate   -- HsExp -> [HsFieldUpdate] -> P HsExp
        , groupBindings
        

-       , mkExtName             -- Maybe ExtName -> RdrName -> ExtName
+       , mkExtName             -- RdrName -> ExtName

 
        , checkPrec             -- String -> P String
        , checkContext          -- HsType -> P HsContext
 
        , checkPrec             -- String -> P String
        , checkContext          -- HsType -> P HsContext

@@ -41,6 +41,7 @@ import PrelNames      ( unitTyCon_RDR )
 import ForeignCall     ( CCallConv(..) )
 import OccName         ( dataName, varName, tcClsName,
                          occNameSpace, setOccNameSpace, occNameUserString )
 import ForeignCall     ( CCallConv(..) )
 import OccName         ( dataName, varName, tcClsName,
                          occNameSpace, setOccNameSpace, occNameUserString )

+import CStrings                ( CLabelString )

 import FastString      ( unpackFS )
 import UniqFM          ( UniqFM, listToUFM )
 import Outputable
 import FastString      ( unpackFS )
 import UniqFM          ( UniqFM, listToUFM )
 import Outputable

@@ -305,10 +306,8 @@ mkRecConstrOrUpdate _ _
 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 -- (This is why we use occNameUserString.)
 
 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 -- (This is why we use occNameUserString.)
 

-mkExtName :: Maybe ExtName -> RdrName -> ExtName
-mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm)))
-                                 Nothing
-mkExtName (Just x) _    = x
+mkExtName :: RdrName -> CLabelString
+mkExtName rdrNm = _PK_ (occNameUserString (rdrNameOcc rdrNm))

 
 -----------------------------------------------------------------------------
 -- group function bindings into equation groups
 
 -----------------------------------------------------------------------------
 -- group function bindings into equation groups

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index c8aa2ce..e747d2c 100644 (file)
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
 {-
 -----------------------------------------------------------------------------

-$Id: Parser.y,v 1.65 2001/05/22 13:43:17 simonpj Exp $
+$Id: Parser.y,v 1.66 2001/05/24 13:59:11 simonpj Exp $

 
 Haskell grammar.
 
 
 Haskell grammar.
 

@@ -21,7 +21,9 @@ import RdrName
 import PrelNames       ( mAIN_Name, unitTyCon_RDR, funTyCon_RDR, listTyCon_RDR,
                          tupleTyCon_RDR, unitCon_RDR, nilCon_RDR, tupleCon_RDR
                        )
 import PrelNames       ( mAIN_Name, unitTyCon_RDR, funTyCon_RDR, listTyCon_RDR,
                          tupleTyCon_RDR, unitCon_RDR, nilCon_RDR, tupleCon_RDR
                        )

-import ForeignCall     ( Safety(..), CCallConv(..), defaultCCallConv )
+import ForeignCall     ( Safety(..), CExportSpec(..), CCallSpec(..), 
+                         CCallConv(..), CCallTarget(..), defaultCCallConv,
+                         DNCallSpec(..) )

 import OccName         ( UserFS, varName, tcName, dataName, tcClsName, tvName )
 import SrcLoc          ( SrcLoc )
 import Module
 import OccName         ( UserFS, varName, tcName, dataName, tcClsName, tvName )
 import SrcLoc          ( SrcLoc )
 import Module

@@ -31,7 +33,9 @@ import BasicTypes     ( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..) )
 import Panic
 
 import GlaExts
 import Panic
 
 import GlaExts

+import CStrings                ( CLabelString )

 import FastString      ( tailFS )
 import FastString      ( tailFS )

+import Maybes          ( orElse )

 import Outputable
 
 #include "HsVersions.h"
 import Outputable
 
 #include "HsVersions.h"

@@ -102,6 +106,7 @@ Conflicts: 14 shift/reduce
  'with'        { ITwith }
  'stdcall'      { ITstdcallconv }
  'ccall'        { ITccallconv }
  'with'        { ITwith }
  'stdcall'      { ITstdcallconv }
  'ccall'        { ITccallconv }

+ 'dotnet'       { ITdotnet }

  '_ccall_'     { ITccall (False, False, PlayRisky) }
  '_ccall_GC_'  { ITccall (False, False, PlaySafe)  }
  '_casm_'      { ITccall (False, True,  PlayRisky) }
  '_ccall_'     { ITccall (False, False, PlayRisky) }
  '_ccall_GC_'  { ITccall (False, False, PlaySafe)  }
  '_casm_'      { ITccall (False, True,  PlayRisky) }

@@ -360,23 +365,45 @@ topdecl :: { RdrBinding }
                                (groupBindings $4)
                  in RdrHsDecl (InstD (InstDecl $3 binds sigs Nothing $1)) }
 
                                (groupBindings $4)
                  in RdrHsDecl (InstD (InstDecl $3 binds sigs Nothing $1)) }
 

-       | srcloc 'default' '(' types0 ')'
-               { RdrHsDecl (DefD (DefaultDecl $4 $1)) }
+       | srcloc 'default' '(' types0 ')'               { RdrHsDecl (DefD (DefaultDecl $4 $1)) }
+       | 'foreign' fordecl                             { RdrHsDecl $2 }
+       | '{-# DEPRECATED' deprecations '#-}'           { $2 }
+       | '{-# RULES' rules '#-}'                       { $2 }
+       | decl                                          { $1 }

 
 

-       | srcloc 'foreign' 'import' callconv ext_name 
-         unsafe_flag varid_no_unsafe '::' sigtype
-               { RdrHsDecl (ForD (ForeignDecl $7 (FoImport $6) $9 (mkExtName $5 $7) $4 $1)) }
+fordecl :: { RdrNameHsDecl }
+fordecl : srcloc 'label' ext_name varid '::' sigtype
+               { ForD (ForeignImport $4 $6 (LblImport ($3 `orElse` mkExtName $4)) $1) }

 
 

-       | srcloc 'foreign' 'export' callconv ext_name varid '::' sigtype
-               { RdrHsDecl (ForD (ForeignDecl $6 FoExport $8 (mkExtName $5 $6) $4 $1)) }

 
 

-       | srcloc 'foreign' 'label' ext_name varid '::' sigtype
-               { RdrHsDecl (ForD (ForeignDecl $5 FoLabel $7 (mkExtName $4 $5)
-                                       defaultCCallConv $1)) }
+       ----------- ccall/stdcall decls ------------
+       | srcloc 'import' ccallconv ext_name unsafe_flag varid_no_unsafe '::' sigtype
+               { let
+                   call_spec = CCallSpec (StaticTarget ($4 `orElse` mkExtName $6)) $3 $5
+                 in
+                 ForD (ForeignImport $6 $8 (CImport call_spec) $1)
+               }

 
 

-       | '{-# DEPRECATED' deprecations '#-}'           { $2 }
-       | '{-# RULES' rules '#-}'                       { $2 }
-       | decl                                          { $1 }
+       | srcloc 'import' ccallconv 'dynamic' unsafe_flag varid_no_unsafe '::' sigtype
+               { let
+                   call_spec = CCallSpec DynamicTarget $3 $5
+                 in
+                 ForD (ForeignImport $6 $8 (CImport call_spec) $1)
+               }
+
+       | srcloc 'export' ccallconv ext_name varid '::' sigtype
+               { ForD (ForeignExport $5 $7 (CExport (CExportStatic ($4 `orElse` mkExtName $5) $3)) $1) }
+
+       | srcloc 'export' ccallconv 'dynamic' varid '::' sigtype
+               { ForD (ForeignImport $5 $7 (CDynImport $3) $1) } 
+
+
+       ----------- .NET decls ------------
+       | srcloc 'import' 'dotnet' ext_name varid '::' sigtype
+               { ForD (ForeignImport $5 $7 (DNImport (DNCallSpec ($4 `orElse` mkExtName $5))) $1) }
+
+       | srcloc 'import' 'dotnet' 'type' tycon
+               { TyClD (ForeignType $5 DNType $1) }

 
 decls  :: { [RdrBinding] }
        : decls ';' decl                { $3 : $1 }
 
 decls  :: { [RdrBinding] }
        : decls ';' decl                { $3 : $1 }

@@ -462,7 +489,7 @@ deprecation :: { RdrBinding }
 -----------------------------------------------------------------------------
 -- Foreign import/export
 
 -----------------------------------------------------------------------------
 -- Foreign import/export
 

-callconv :: { CCallConv }
+ccallconv :: { CCallConv }

        : 'stdcall'             { StdCallConv }
        | 'ccall'               { CCallConv }
        | {- empty -}           { defaultCCallConv }
        : 'stdcall'             { StdCallConv }
        | 'ccall'               { CCallConv }
        | {- empty -}           { defaultCCallConv }

@@ -471,10 +498,8 @@ unsafe_flag :: { Safety }
        : 'unsafe'              { PlayRisky }
        | {- empty -}           { PlaySafe }
 
        : 'unsafe'              { PlayRisky }
        | {- empty -}           { PlaySafe }
 

-ext_name :: { Maybe ExtName }
-       : 'dynamic'             { Just Dynamic }
-       | STRING                { Just (ExtName $1 Nothing)   }
-       | STRING STRING         { Just (ExtName $2 (Just $1)) }
+ext_name :: { Maybe CLabelString }
+       : STRING                { Just $1 }

        | {- empty -}           { Nothing }
 
 
        | {- empty -}           { Nothing }
 
 

diff --git a/ghc/compiler/prelude/ForeignCall.lhs b/ghc/compiler/prelude/ForeignCall.lhs
index f469fa3..47eafed 100644 (file)
--- a/ghc/compiler/prelude/ForeignCall.lhs
+++ b/ghc/compiler/prelude/ForeignCall.lhs
@@ -8,16 +8,20 @@ module ForeignCall (
        ForeignCall(..),
        Safety(..), playSafe,
 
        ForeignCall(..),
        Safety(..), playSafe,
 

-       CCallSpec(..), ccallIsCasm,
-       CCallTarget(..), dynamicTarget, isDynamicTarget,
+       CExportSpec(..),
+       CCallSpec(..), 
+       CCallTarget(..), isDynamicTarget, isCasmTarget,

        CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
 
        CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
 

-       DotNetCallSpec(..)
+       DNCallSpec(..),
+
+       okToExposeFCall

     ) where
 
 #include "HsVersions.h"
 
 import CStrings                ( CLabelString, pprCLabelString )
     ) where
 
 #include "HsVersions.h"
 
 import CStrings                ( CLabelString, pprCLabelString )

+import FastString      ( FastString )

 import Outputable
 \end{code}
 
 import Outputable
 \end{code}
 

@@ -31,7 +35,7 @@ import Outputable
 \begin{code}
 data ForeignCall
   = CCall      CCallSpec
 \begin{code}
 data ForeignCall
   = CCall      CCallSpec

-  | DotNetCall DotNetCallSpec
+  | DNCall     DNCallSpec

   deriving( Eq )               -- We compare them when seeing if an interface
                                -- has changed (for versioning purposes)
 
   deriving( Eq )               -- We compare them when seeing if an interface
                                -- has changed (for versioning purposes)
 

@@ -39,7 +43,7 @@ data ForeignCall
 -- but this simple printer will do for now
 instance Outputable ForeignCall where
   ppr (CCall cc)      = ppr cc         
 -- but this simple printer will do for now
 instance Outputable ForeignCall where
   ppr (CCall cc)      = ppr cc         

-  ppr (DotNetCall dn) = ppr dn
+  ppr (DNCall dn) = ppr dn

 \end{code}
 
   
 \end{code}
 
   

@@ -70,16 +74,16 @@ playSafe PlayRisky = False
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

+data CExportSpec
+  = CExportStatic              -- foreign export ccall foo :: ty
+       CLabelString            -- C Name of exported function
+       CCallConv
+

 data CCallSpec
   =  CCallSpec CCallTarget     -- What to call
                CCallConv       -- Calling convention to use.
                Safety
 data CCallSpec
   =  CCallSpec CCallTarget     -- What to call
                CCallConv       -- Calling convention to use.
                Safety

-               Bool            -- True <=> really a "casm"

   deriving( Eq )
   deriving( Eq )

-
-
-ccallIsCasm :: CCallSpec -> Bool
-ccallIsCasm (CCallSpec _ _ _ c_asm) = c_asm

 \end{code}
 
 The call target:
 \end{code}
 
 The call target:

@@ -88,13 +92,15 @@ The call target:
 data CCallTarget
   = StaticTarget  CLabelString  -- An "unboxed" ccall# to `fn'.
   | DynamicTarget              -- First argument (an Addr#) is the function pointer
 data CCallTarget
   = StaticTarget  CLabelString  -- An "unboxed" ccall# to `fn'.
   | DynamicTarget              -- First argument (an Addr#) is the function pointer

+  | CasmTarget    CLabelString -- Inline C code (now seriously deprecated)

   deriving( Eq )
 
   deriving( Eq )
 

-isDynamicTarget DynamicTarget    = True
-isDynamicTarget (StaticTarget _) = False
+isDynamicTarget, isCasmTarget :: CCallTarget -> Bool
+isDynamicTarget DynamicTarget = True
+isDynamicTarget other        = False

 
 

-dynamicTarget :: CCallTarget
-dynamicTarget = DynamicTarget
+isCasmTarget (CasmTarget _) = True
+isCasmTarget other         = False

 \end{code}
 
 
 \end{code}
 
 

@@ -132,32 +138,21 @@ ccallConvAttribute CCallConv   = ""
 Printing into C files:
 
 \begin{code}
 Printing into C files:
 
 \begin{code}

+instance Outputable CExportSpec where
+  ppr (CExportStatic str _) = pprCLabelString str
+

 instance Outputable CCallSpec where
 instance Outputable CCallSpec where

-  ppr (CCallSpec fun cconv safety is_casm)
-    = hcat [ ifPprDebug callconv
-          , text "__", ppr_dyn
-           , text before , ppr_fun , after]
+  ppr (CCallSpec fun cconv safety)
+    = hcat [ ifPprDebug callconv, ppr_fun fun ]

     where
     where

-        callconv = text "{-" <> ppr cconv <> text "-}"
-       play_safe = playSafe safety
-
-       before
-         | is_casm && play_safe = "casm_GC ``"
-         | is_casm              = "casm ``"
-         | play_safe            = "ccall_GC "
-         | otherwise            = "ccall "
-
-       after
-         | is_casm   = text "''"
-         | otherwise = empty
-         
-       ppr_dyn = case fun of
-                   DynamicTarget -> text "dyn_"
-                   _             -> empty
-
-       ppr_fun = case fun of
-                    DynamicTarget   -> text "\"\""
-                    StaticTarget fn -> pprCLabelString fn
+      callconv = text "{-" <> ppr cconv <> text "-}"
+
+      gc_suf | playSafe safety = text "_GC"
+            | otherwise       = empty
+
+      ppr_fun DynamicTarget     = text "__dyn_ccall" <> gc_suf <+> text "\"\""
+      ppr_fun (StaticTarget fn) = text "__ccall"     <> gc_suf <+> pprCLabelString fn
+      ppr_fun (CasmTarget   fn) = text "__casm"      <> gc_suf <+> text "``" <> pprCLabelString fn <> text "''"

 \end{code}
 
 
 \end{code}
 
 

@@ -168,9 +163,25 @@ instance Outputable CCallSpec where
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-data DotNetCallSpec = DotNetCallSpec
+data DNCallSpec = DNCallSpec FastString

                    deriving( Eq )
 
                    deriving( Eq )
 

-instance Outputable DotNetCallSpec where
-  ppr DotNetCallSpec = text "DotNet!"
+instance Outputable DNCallSpec where
+  ppr (DNCallSpec s) = text "DotNet" <+> ptext s
+\end{code}
+
+
+
+%************************************************************************
+%*                                                                     *
+\subsubsection{Misc}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+okToExposeFCall :: ForeignCall -> Bool
+-- OK to unfold a Foreign Call in an interface file
+-- Yes, unless it's a _casm_
+okToExposeFCall (CCall (CCallSpec target _ _)) = not (isCasmTarget target)
+okToExposeFCall other                                 = True

 \end{code}
 \end{code}

diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs
index 395da7d..7c16614 100644 (file)
--- a/ghc/compiler/prelude/TysPrim.lhs
+++ b/ghc/compiler/prelude/TysPrim.lhs
@@ -41,9 +41,7 @@ module TysPrim(
        int64PrimTyCon,         int64PrimTy,
        word64PrimTyCon,        word64PrimTy,
 
        int64PrimTyCon,         int64PrimTy,
        word64PrimTyCon,        word64PrimTy,
 

-       primRepTyCon,
-
-       pcPrimTyCon
+       primRepTyCon

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

@@ -145,37 +143,43 @@ vrcsZP = [vrcZero,vrcPos]
 
 \begin{code}
 -- only used herein
 
 \begin{code}
 -- only used herein

-pcPrimTyCon :: Name -> Int -> ArgVrcs -> PrimRep -> TyCon
-pcPrimTyCon name arity arg_vrcs rep
-  = the_tycon
+pcPrimTyCon :: Name -> ArgVrcs -> PrimRep -> TyCon
+pcPrimTyCon name arg_vrcs rep
+  = mkPrimTyCon name kind arity arg_vrcs rep

   where
   where

-    the_tycon   = mkPrimTyCon name kind arity arg_vrcs rep
+    arity       = length arg_vrcs

     kind        = mkArrowKinds (take arity (repeat liftedTypeKind)) result_kind
     result_kind = unliftedTypeKind -- all primitive types are unlifted
 
     kind        = mkArrowKinds (take arity (repeat liftedTypeKind)) result_kind
     result_kind = unliftedTypeKind -- all primitive types are unlifted
 

+pcPrimTyCon0 :: Name -> PrimRep -> TyCon
+pcPrimTyCon0 name rep
+  = mkPrimTyCon name result_kind 0 [] rep
+  where
+    result_kind = unliftedTypeKind -- all primitive types are unlifted
+

 charPrimTy     = mkTyConTy charPrimTyCon
 charPrimTy     = mkTyConTy charPrimTyCon

-charPrimTyCon  = pcPrimTyCon charPrimTyConName 0 [] CharRep
+charPrimTyCon  = pcPrimTyCon0 charPrimTyConName CharRep

 
 intPrimTy      = mkTyConTy intPrimTyCon
 
 intPrimTy      = mkTyConTy intPrimTyCon

-intPrimTyCon   = pcPrimTyCon intPrimTyConName 0 [] IntRep
+intPrimTyCon   = pcPrimTyCon0 intPrimTyConName IntRep

 
 int64PrimTy    = mkTyConTy int64PrimTyCon
 
 int64PrimTy    = mkTyConTy int64PrimTyCon

-int64PrimTyCon = pcPrimTyCon int64PrimTyConName 0 [] Int64Rep
+int64PrimTyCon = pcPrimTyCon0 int64PrimTyConName Int64Rep

 
 wordPrimTy     = mkTyConTy wordPrimTyCon
 
 wordPrimTy     = mkTyConTy wordPrimTyCon

-wordPrimTyCon  = pcPrimTyCon wordPrimTyConName 0 [] WordRep
+wordPrimTyCon  = pcPrimTyCon0 wordPrimTyConName WordRep

 
 word64PrimTy   = mkTyConTy word64PrimTyCon
 
 word64PrimTy   = mkTyConTy word64PrimTyCon

-word64PrimTyCon        = pcPrimTyCon word64PrimTyConName 0 [] Word64Rep
+word64PrimTyCon        = pcPrimTyCon0 word64PrimTyConName Word64Rep

 
 addrPrimTy     = mkTyConTy addrPrimTyCon
 
 addrPrimTy     = mkTyConTy addrPrimTyCon

-addrPrimTyCon  = pcPrimTyCon addrPrimTyConName 0 [] AddrRep
+addrPrimTyCon  = pcPrimTyCon0 addrPrimTyConName AddrRep

 
 floatPrimTy    = mkTyConTy floatPrimTyCon
 
 floatPrimTy    = mkTyConTy floatPrimTyCon

-floatPrimTyCon = pcPrimTyCon floatPrimTyConName 0 [] FloatRep
+floatPrimTyCon = pcPrimTyCon0 floatPrimTyConName FloatRep

 
 doublePrimTy   = mkTyConTy doublePrimTyCon
 
 doublePrimTy   = mkTyConTy doublePrimTyCon

-doublePrimTyCon        = pcPrimTyCon doublePrimTyConName 0 [] DoubleRep
+doublePrimTyCon        = pcPrimTyCon0 doublePrimTyConName DoubleRep

 \end{code}
 
 
 \end{code}
 
 

@@ -196,7 +200,7 @@ keep different state threads separate.  It is represented by nothing at all.
 
 \begin{code}
 mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty]
 
 \begin{code}
 mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty]

-statePrimTyCon  = pcPrimTyCon statePrimTyConName 1 vrcsZ VoidRep
+statePrimTyCon  = pcPrimTyCon statePrimTyConName vrcsZ VoidRep

 \end{code}
 
 RealWorld is deeply magical.  It is *primitive*, but it is not
 \end{code}
 
 RealWorld is deeply magical.  It is *primitive*, but it is not

@@ -220,10 +224,10 @@ defined in \tr{TysWiredIn.lhs}, not here.
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-arrayPrimTyCon           = pcPrimTyCon arrayPrimTyConName            1 vrcsP  ArrayRep
-byteArrayPrimTyCon       = pcPrimTyCon byteArrayPrimTyConName        0 []     ByteArrayRep
-mutableArrayPrimTyCon    = pcPrimTyCon mutableArrayPrimTyConName     2 vrcsZP ArrayRep
-mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName 1 vrcsZ  ByteArrayRep
+arrayPrimTyCon           = pcPrimTyCon  arrayPrimTyConName            vrcsP  ArrayRep
+mutableArrayPrimTyCon    = pcPrimTyCon  mutableArrayPrimTyConName     vrcsZP ArrayRep
+mutableByteArrayPrimTyCon = pcPrimTyCon  mutableByteArrayPrimTyConName vrcsZ  ByteArrayRep
+byteArrayPrimTyCon       = pcPrimTyCon0 byteArrayPrimTyConName               ByteArrayRep

 
 mkArrayPrimTy elt          = mkTyConApp arrayPrimTyCon [elt]
 byteArrayPrimTy                    = mkTyConTy byteArrayPrimTyCon
 
 mkArrayPrimTy elt          = mkTyConApp arrayPrimTyCon [elt]
 byteArrayPrimTy                    = mkTyConTy byteArrayPrimTyCon

@@ -238,7 +242,7 @@ mkMutableByteArrayPrimTy s  = mkTyConApp mutableByteArrayPrimTyCon [s]
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName 2 vrcsZP PrimPtrRep
+mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName vrcsZP PrimPtrRep

 
 mkMutVarPrimTy s elt       = mkTyConApp mutVarPrimTyCon [s, elt]
 \end{code}
 
 mkMutVarPrimTy s elt       = mkTyConApp mutVarPrimTyCon [s, elt]
 \end{code}

@@ -250,7 +254,7 @@ mkMutVarPrimTy s elt            = mkTyConApp mutVarPrimTyCon [s, elt]
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName 2 vrcsZP PrimPtrRep
+mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName vrcsZP PrimPtrRep

 
 mkMVarPrimTy s elt         = mkTyConApp mVarPrimTyCon [s, elt]
 \end{code}
 
 mkMVarPrimTy s elt         = mkTyConApp mVarPrimTyCon [s, elt]
 \end{code}

@@ -262,7 +266,7 @@ mkMVarPrimTy s elt      = mkTyConApp mVarPrimTyCon [s, elt]
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName 1 vrcsP StablePtrRep
+stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName vrcsP StablePtrRep

 
 mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty]
 \end{code}
 
 mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty]
 \end{code}

@@ -274,7 +278,7 @@ mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty]
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName 1 vrcsP StableNameRep
+stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName vrcsP StableNameRep

 
 mkStableNamePrimTy ty = mkTyConApp stableNamePrimTyCon [ty]
 \end{code}
 
 mkStableNamePrimTy ty = mkTyConApp stableNamePrimTyCon [ty]
 \end{code}

@@ -297,7 +301,7 @@ dead before it really was.
 
 \begin{code}
 foreignObjPrimTy    = mkTyConTy foreignObjPrimTyCon
 
 \begin{code}
 foreignObjPrimTy    = mkTyConTy foreignObjPrimTyCon

-foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConName 0 [] ForeignObjRep
+foreignObjPrimTyCon = pcPrimTyCon0 foreignObjPrimTyConName ForeignObjRep

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

@@ -308,7 +312,7 @@ foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConName 0 [] ForeignObjRep
 
 \begin{code}
 bcoPrimTy    = mkTyConTy bcoPrimTyCon
 
 \begin{code}
 bcoPrimTy    = mkTyConTy bcoPrimTyCon

-bcoPrimTyCon = pcPrimTyCon bcoPrimTyConName 0 [] BCORep
+bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName BCORep

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

@@ -318,7 +322,7 @@ bcoPrimTyCon = pcPrimTyCon bcoPrimTyConName 0 [] BCORep
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-weakPrimTyCon = pcPrimTyCon weakPrimTyConName 1 vrcsP WeakPtrRep
+weakPrimTyCon = pcPrimTyCon weakPrimTyConName vrcsP WeakPtrRep

 
 mkWeakPrimTy v = mkTyConApp weakPrimTyCon [v]
 \end{code}
 
 mkWeakPrimTy v = mkTyConApp weakPrimTyCon [v]
 \end{code}

@@ -340,7 +344,7 @@ to the thread id internally.
 
 \begin{code}
 threadIdPrimTy    = mkTyConTy threadIdPrimTyCon
 
 \begin{code}
 threadIdPrimTy    = mkTyConTy threadIdPrimTyCon

-threadIdPrimTyCon = pcPrimTyCon threadIdPrimTyConName 0 [] ThreadIdRep
+threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName ThreadIdRep

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

diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 78aa477..47fda3a 100644 (file)
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -351,6 +351,8 @@ decl    : src_loc qvar_name '::' type maybe_idinfo
                        { IfaceSig $2 $4 ($5 $2) $1 }
        | src_loc 'type' qtc_name tv_bndrs '=' type                    
                        { TySynonym $3 $4 $6 $1 }
                        { IfaceSig $2 $4 ($5 $2) $1 }
        | src_loc 'type' qtc_name tv_bndrs '=' type                    
                        { TySynonym $3 $4 $6 $1 }

+       | src_loc 'foreign' 'type' qtc_name                    
+                       { ForeignType $4 DNType $1 }

        | src_loc 'data' opt_decl_context qtc_name tv_bndrs constrs            
                        { mkTyData DataType $3 $4 $5 $6 (length $6) Nothing $1 }
        | src_loc 'newtype' opt_decl_context qtc_name tv_bndrs newtype_constr
        | src_loc 'data' opt_decl_context qtc_name tv_bndrs constrs            
                        { mkTyData DataType $3 $4 $5 $6 (length $6) Nothing $1 }
        | src_loc 'newtype' opt_decl_context qtc_name tv_bndrs newtype_constr

@@ -808,9 +810,10 @@ core_aexpr      : qvar_name                                        { UfVar $1 }
                                  (is_dyn, is_casm, may_gc) = $2
 
                                 target | is_dyn    = DynamicTarget
                                  (is_dyn, is_casm, may_gc) = $2
 
                                 target | is_dyn    = DynamicTarget

+                                       | is_casm   = CasmTarget $3

                                        | otherwise = StaticTarget $3
 
                                        | otherwise = StaticTarget $3
 

-                                ccall = CCallSpec target CCallConv may_gc is_casm
+                                ccall = CCallSpec target CCallConv may_gc

                             in
                             UfFCall (CCall ccall) $4
                           }
                             in
                             UfFCall (CCall ccall) $4
                           }

diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index 13c14bc..a1fbfeb 100644 (file)
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -119,6 +119,9 @@ In all cases this is set up for interface-file declarations:
 
 \begin{code}
 tyClDeclFVs :: RenamedTyClDecl -> NameSet
 
 \begin{code}
 tyClDeclFVs :: RenamedTyClDecl -> NameSet

+tyClDeclFVs (ForeignType {})
+  = emptyFVs
+

 tyClDeclFVs (IfaceSig {tcdType = ty, tcdIdInfo = id_infos})
   = extractHsTyNames ty                        `plusFV` 
     plusFVs (map hsIdInfoFVs id_infos)
 tyClDeclFVs (IfaceSig {tcdType = ty, tcdIdInfo = id_infos})
   = extractHsTyNames ty                        `plusFV` 
     plusFVs (map hsIdInfoFVs id_infos)

diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 7cab59c..f60ae46 100644 (file)
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -489,7 +489,8 @@ getGates :: FreeVars                -- Things mentioned in the source program
 getGates source_fvs decl 
   = get_gates (\n -> n `elemNameSet` source_fvs) decl
 
 getGates source_fvs decl 
   = get_gates (\n -> n `elemNameSet` source_fvs) decl
 

-get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty
+get_gates is_used (ForeignType {tcdName = tycon}) = unitNameSet tycon
+get_gates is_used (IfaceSig    {tcdType = ty})    = extractHsTyNames ty

 
 get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs})
   = (super_cls_and_sigs `addOneToNameSet` cls) `unionNameSets` 
 
 get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs})
   = (super_cls_and_sigs `addOneToNameSet` cls) `unionNameSets` 

diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index a54dbd8..2bfe8a5 100644 (file)
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -13,7 +13,7 @@ module RnNames (
 import CmdLineOpts     ( DynFlag(..) )
 
 import HsSyn           ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..),
 import CmdLineOpts     ( DynFlag(..) )
 
 import HsSyn           ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..),

-                         ForeignDecl(..), ForKind(..), isDynamicExtName,
+                         ForeignDecl(..), 

                          collectLocatedHsBinders
                        )
 import RdrHsSyn                ( RdrNameIE, RdrNameImportDecl,
                          collectLocatedHsBinders
                        )
 import RdrHsSyn                ( RdrNameIE, RdrNameImportDecl,

@@ -244,17 +244,11 @@ getLocalDeclBinders mod (ValD binds)
     new (rdr_name, loc) = newTopBinder mod rdr_name loc        `thenRn` \ name ->
                          returnRn (Avail name)
 
     new (rdr_name, loc) = newTopBinder mod rdr_name loc        `thenRn` \ name ->
                          returnRn (Avail name)
 

-getLocalDeclBinders mod (ForD (ForeignDecl nm kind _ ext_nm _ loc))
-  | binds_haskell_name kind
+getLocalDeclBinders mod (ForD (ForeignImport nm _ _ loc))

   = newTopBinder mod nm loc        `thenRn` \ name ->
     returnRn [Avail name]
   = newTopBinder mod nm loc        `thenRn` \ name ->
     returnRn [Avail name]

-
-  | otherwise          -- a foreign export
+getLocalDeclBinders mod (ForD _)

   = returnRn []
   = returnRn []

-  where
-    binds_haskell_name (FoImport _) = True
-    binds_haskell_name FoLabel      = True
-    binds_haskell_name FoExport     = isDynamicExtName ext_nm

 
 getLocalDeclBinders mod (FixD _)    = returnRn []
 getLocalDeclBinders mod (DeprecD _) = returnRn []
 
 getLocalDeclBinders mod (FixD _)    = returnRn []
 getLocalDeclBinders mod (DeprecD _) = returnRn []

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 781e67c..71fe8ff 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -49,8 +49,6 @@ import CmdLineOpts    ( DynFlag(..) )
                                -- Warn of unused for-all'd tyvars
 import Unique          ( Uniquable(..) )
 import Maybes          ( maybeToBool )
                                -- Warn of unused for-all'd tyvars
 import Unique          ( Uniquable(..) )
 import Maybes          ( maybeToBool )

-import ErrUtils                ( Message )
-import CStrings                ( isCLabelString )

 import ListSetOps      ( removeDupsEq )
 \end{code}
 
 import ListSetOps      ( removeDupsEq )
 \end{code}
 

@@ -112,39 +110,44 @@ rnSourceDecl (RuleD rule)
   = rnHsRuleDecl rule          `thenRn` \ (new_rule, fvs) ->
     returnRn (RuleD new_rule, fvs)
 
   = rnHsRuleDecl rule          `thenRn` \ (new_rule, fvs) ->
     returnRn (RuleD new_rule, fvs)
 

+rnSourceDecl (ForD ford)
+  = rnHsForeignDecl ford               `thenRn` \ (new_ford, fvs) ->
+    returnRn (ForD new_ford, fvs)
+

 rnSourceDecl (DefD (DefaultDecl tys src_loc))
   = pushSrcLocRn src_loc $
     mapFvRn (rnHsTypeFVs doc_str) tys          `thenRn` \ (tys', fvs) ->
     returnRn (DefD (DefaultDecl tys' src_loc), fvs)
   where
     doc_str = text "a `default' declaration"
 rnSourceDecl (DefD (DefaultDecl tys src_loc))
   = pushSrcLocRn src_loc $
     mapFvRn (rnHsTypeFVs doc_str) tys          `thenRn` \ (tys', fvs) ->
     returnRn (DefD (DefaultDecl tys' src_loc), fvs)
   where
     doc_str = text "a `default' declaration"

+\end{code}

 
 

-rnSourceDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
-  = pushSrcLocRn src_loc $
-    lookupOccRn name                   `thenRn` \ name' ->
-    let 
-       extra_fvs FoExport 
-         | isDyn = lookupOrigNames [newStablePtr_RDR, deRefStablePtr_RDR,
-                                    bindIO_RDR, returnIO_RDR]
-         | otherwise =
-               lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
-               returnRn (addOneFV fvs name')
-       extra_fvs other = returnRn emptyFVs
-    in
-    checkRn (ok_ext_nm ext_nm) (badExtName ext_nm)     `thenRn_`

 
 

-    extra_fvs imp_exp                                  `thenRn` \ fvs1 -> 
+%*********************************************************
+%*                                                     *
+\subsection{Foreign declarations}
+%*                                                     *
+%*********************************************************
+
+\begin{code}
+rnHsForeignDecl (ForeignImport name ty spec src_loc)
+  = pushSrcLocRn src_loc               $
+    lookupOccRn name                   `thenRn` \ name' ->
+    rnHsTypeFVs (fo_decl_msg name) ty  `thenRn` \ (ty', fvs1) ->
+    lookupOrigNames (extras spec)      `thenRn` \ fvs2 ->
+    returnRn (ForeignImport name' ty' spec src_loc, fvs1 `plusFV` fvs2)
+  where
+    extras (CDynImport _) = [newStablePtr_RDR, deRefStablePtr_RDR, bindIO_RDR, returnIO_RDR]
+    extras other         = []

 
 

-    rnHsTypeFVs fo_decl_msg ty                 `thenRn` \ (ty', fvs2) ->
-    returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), 
-             fvs1 `plusFV` fvs2)
- where
-  fo_decl_msg = ptext SLIT("The foreign declaration for") <+> ppr name
-  isDyn              = isDynamicExtName ext_nm
+rnHsForeignDecl (ForeignExport name ty spec src_loc)
+  = pushSrcLocRn src_loc                       $
+    lookupOccRn name                           `thenRn` \ name' ->
+    rnHsTypeFVs (fo_decl_msg name) ty                  `thenRn` \ (ty', fvs1) ->
+    lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs2 ->
+    returnRn (ForeignExport name' ty' spec src_loc, fvs1 `plusFV` fvs2)

 
 

-  ok_ext_nm Dynamic               = True
-  ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
-  ok_ext_nm (ExtName nm Nothing)   = isCLabelString nm
+fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name

 \end{code}
 
 
 \end{code}
 
 

@@ -284,6 +287,11 @@ rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc
   where
     doc_str = text "the interface signature for" <+> quotes (ppr name)
 
   where
     doc_str = text "the interface signature for" <+> quotes (ppr name)
 

+rnTyClDecl (ForeignType {tcdName = name, tcdFoType = spec, tcdLoc = loc})
+  = pushSrcLocRn loc                   $
+    lookupTopBndrRn name               `thenRn` \ name' ->
+    returnRn (ForeignType {tcdName = name', tcdFoType = spec, tcdLoc = loc})
+

 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
                    tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
                    tcdLoc = src_loc, tcdSysNames = sys_names})
 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
                    tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
                    tcdLoc = src_loc, tcdSysNames = sys_names})

@@ -428,7 +436,7 @@ finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- G
     meth_doc = text "the default-methods for class"    <+> ppr (tcdName rn_cls_decl)
 
 finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
     meth_doc = text "the default-methods for class"    <+> ppr (tcdName rn_cls_decl)
 
 finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)

-       -- Not a class declaration
+       -- Not a class or data type declaration

 \end{code}
 
 
 \end{code}
 
 

@@ -879,10 +887,6 @@ badRuleVar name var
         ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> 
                ptext SLIT("does not appear on left hand side")]
 
         ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> 
                ptext SLIT("does not appear on left hand side")]
 

-badExtName :: ExtName -> Message
-badExtName ext_nm
-  = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
-

 dupClassAssertWarn ctxt (assertion : dups)
   = sep [hsep [ptext SLIT("Duplicate class assertion"), 
               quotes (ppr assertion),
 dupClassAssertWarn ctxt (assertion : dups)
   = sep [hsep [ptext SLIT("Duplicate class assertion"), 
               quotes (ppr assertion),

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 1f83155..cbc20ff 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -178,6 +178,7 @@ tcInLocalScope env v = v `elemNameEnv` (tcLEnv env)
 data TyThingDetails = SynTyDetails Type
                    | DataTyDetails ThetaType [DataCon] [Id]
                    | ClassDetails ThetaType [Id] [ClassOpItem] DataCon
 data TyThingDetails = SynTyDetails Type
                    | DataTyDetails ThetaType [DataCon] [Id]
                    | ClassDetails ThetaType [Id] [ClassOpItem] DataCon

+                   | ForeignTyDetails  -- Nothing yet

 \end{code}
 
 
 \end{code}
 
 

diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index 3f133ff..615dea8 100644 (file)
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -20,8 +20,7 @@ module TcForeign
 #include "HsVersions.h"
 
 import HsSyn           ( HsDecl(..), ForeignDecl(..), HsExpr(..),
 #include "HsVersions.h"
 
 import HsSyn           ( HsDecl(..), ForeignDecl(..), HsExpr(..),

-                         ExtName(Dynamic), isDynamicExtName, MonoBinds(..),
-                         ForKind(..)
+                         MonoBinds(..), FoImport(..), FoExport(..)

                        )
 import RnHsSyn         ( RenamedHsDecl, RenamedForeignDecl )
 
                        )
 import RnHsSyn         ( RenamedHsDecl, RenamedForeignDecl )
 

@@ -46,17 +45,103 @@ import TysWiredIn  ( isFFIArgumentTy, isFFIImportResultTy,
                          isFFILabelTy
                        )
 import Type             ( Type )
                          isFFILabelTy
                        )
 import Type             ( Type )

-import ForeignCall     ( Safety )
+import ForeignCall     ( CCallSpec(..), CExportSpec(..), CCallTarget(..), isDynamicTarget )
+import CStrings                ( CLabelString, isCLabelString )

 import PrelNames       ( hasKey, ioTyConKey )
 import Outputable
 
 \end{code}
 
 \begin{code}
 import PrelNames       ( hasKey, ioTyConKey )
 import Outputable
 
 \end{code}
 
 \begin{code}

+-- Defines a binding
+isForeignImport :: ForeignDecl name -> Bool
+isForeignImport (ForeignImport _ _ _ _) = True
+isForeignImport _                      = False
+
+-- Exports a binding
+isForeignExport :: ForeignDecl name -> Bool
+isForeignExport (ForeignExport _ _ _ _) = True
+isForeignExport _                      = False
+\end{code}
+
+%************************************************************************
+%*                                                                     *
+\subsection{Imports}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}

 tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl])
 tcForeignImports decls = 
    mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
 
 tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl])
 tcForeignImports decls = 
    mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
 

+tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl)
+tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc)
+ = tcAddSrcLoc src_loc                 $
+   tcAddErrCtxt (foreignDeclCtxt fo)   $
+   tcHsLiftedSigType hs_ty             `thenTc`        \ sig_ty ->
+   let 
+      -- drop the foralls before inspecting the structure
+      -- of the foreign type.
+       (_, t_ty)         = splitForAllTys sig_ty
+       (arg_tys, res_ty) = splitFunTys t_ty
+       id                = mkLocalId nm sig_ty
+   in
+   tcCheckFIType sig_ty arg_tys res_ty imp_decl                `thenNF_Tc_` 
+   returnTc (id, ForeignImport id undefined imp_decl src_loc)
+\end{code}
+
+
+------------ Checking types for foreign import ----------------------
+\begin{code}
+tcCheckFIType _ _ _ (DNImport _)
+  = returnNF_Tc ()     -- No error checking yet
+
+tcCheckFIType sig_ty arg_tys res_ty (LblImport _)
+  = check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
+
+tcCheckFIType sig_ty arg_tys res_ty (CDynImport _)
+  =    -- Foreign export dynamic
+       -- The first (and only!) arg has got to be a function type
+       -- and it must return IO t; result type is IO Addr
+    case arg_tys of
+       [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys                  `thenNF_Tc_`
+                    checkForeignRes nonIOok  isFFIExportResultTy res1_ty       `thenNF_Tc_`
+                    checkForeignRes mustBeIO isFFIDynResultTy    res_ty
+                 where
+                    (arg1_tys, res1_ty) = splitFunTys arg1_ty
+        other -> addErrTc (illegalForeignTyErr empty sig_ty)
+
+tcCheckFIType sig_ty arg_tys res_ty (CImport (CCallSpec target _ safety))
+  | isDynamicTarget target     -- Foreign import dynamic
+  = case arg_tys of            -- The first arg must be Addr
+      []               -> check False (illegalForeignTyErr empty sig_ty)
+      (arg1_ty:arg_tys) -> getDOptsTc                                                  `thenNF_Tc` \ dflags ->
+                          check (isFFIDynArgumentTy arg1_ty)
+                                (illegalForeignTyErr argument arg1_ty)                 `thenNF_Tc_`
+                          checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys     `thenNF_Tc_`
+                          checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
+
+  | otherwise          -- Normal foreign import
+  = getDOptsTc                                                 `thenNF_Tc` \ dflags ->
+    checkCTarget target                                                `thenNF_Tc_`
+    checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys   `thenNF_Tc_`
+    checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
+
+-- This makes a convenient place to check
+-- that the C identifier is valid for C
+checkCTarget (StaticTarget str) | not (isCLabelString str) = addErrTc (badCName str)
+checkCTarget other                                        = returnNF_Tc ()
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{Exports}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}

 tcForeignExports :: [RenamedHsDecl] -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl])
 tcForeignExports decls = 
    foldlTc combine (emptyLIE, EmptyMonoBinds, [])
 tcForeignExports :: [RenamedHsDecl] -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl])
 tcForeignExports decls = 
    foldlTc combine (emptyLIE, EmptyMonoBinds, [])

@@ -66,170 +151,96 @@ tcForeignExports decls =
        tcFExport fe `thenTc ` \ (a_lie, b, f) ->
        returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs)
 
        tcFExport fe `thenTc ` \ (a_lie, b, f) ->
        returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs)
 

--- defines a binding
-isForeignImport :: ForeignDecl name -> Bool
-isForeignImport (ForeignDecl _ k _ dyn _ _) =
-  case k of
-    FoImport _ -> True
-    FoExport   -> case dyn of { Dynamic -> True ; _ -> False }
-    FoLabel    -> True
-
--- exports a binding
-isForeignExport :: ForeignDecl name -> Bool
-isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamicExtName ext_nm)
-isForeignExport _                                    = False
-
-\end{code}
-
-\begin{code}
-tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl)
-tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
-   tcAddSrcLoc src_loc              $
-   tcAddErrCtxt (foreignDeclCtxt fo) $
-   tcHsLiftedSigType hs_ty          `thenTc`   \ sig_ty ->
-   let
-      -- drop the foralls before inspecting the structure
-      -- of the foreign type.
-    (_, t_ty) = splitForAllTys sig_ty
-   in
-   case splitFunTys t_ty of
-     (arg_tys, res_ty) -> 
-       checkForeignExport True t_ty arg_tys res_ty `thenTc_`
-       let i = (mkLocalId nm sig_ty) in
-       returnTc (i, (ForeignDecl i FoExport undefined Dynamic cconv src_loc))
-
-tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
-   tcAddSrcLoc src_loc              $
-   tcAddErrCtxt (foreignDeclCtxt fo) $
-   tcHsLiftedSigType hs_ty         `thenTc`    \ sig_ty ->
-   let
-      -- drop the foralls before inspecting the structure
-      -- of the foreign type.
-    (_, t_ty) = splitForAllTys sig_ty
-   in
-   check (isFFILabelTy t_ty) 
-       (illegalForeignTyErr False{-result-} sig_ty)    `thenTc_`
-   let i = (mkLocalId nm sig_ty) in
-   returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc))
-
-tcFImport fo@(ForeignDecl nm imp_exp@(FoImport safety) hs_ty ext_nm cconv src_loc) =
-   tcAddSrcLoc src_loc              $
-   tcAddErrCtxt (foreignDeclCtxt fo) $
-
-   tcHsLiftedSigType hs_ty                  `thenTc` \ ty ->
-    -- Check that the type has the right shape
-    -- and that the argument and result types are acceptable.
-   let
-      -- drop the foralls before inspecting the structure
-      -- of the foreign type.
-    (_, t_ty) = splitForAllTys ty
-   in
-   case splitFunTys t_ty of
-     (arg_tys, res_ty) ->
-        checkForeignImport (isDynamicExtName ext_nm) safety ty arg_tys res_ty `thenTc_`
-       let i = (mkLocalId nm ty) in
-       returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
-

 tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl)
 tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl)

-tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
-   tcAddSrcLoc src_loc              $
-   tcAddErrCtxt (foreignDeclCtxt fo) $
+tcFExport fo@(ForeignExport nm hs_ty spec src_loc) =
+   tcAddSrcLoc src_loc                 $
+   tcAddErrCtxt (foreignDeclCtxt fo)   $

 
    tcHsLiftedSigType hs_ty            `thenTc` \ sig_ty ->
 
    tcHsLiftedSigType hs_ty            `thenTc` \ sig_ty ->

-   tcPolyExpr (HsVar nm) sig_ty     `thenTc`    \ (rhs, lie, _, _, _) ->
+   tcPolyExpr (HsVar nm) sig_ty                `thenTc`    \ (rhs, lie, _, _, _) ->
+
+   tcCheckFEType sig_ty spec           `thenTc_`

 
 

-   let
-      -- drop the foralls before inspecting the structure
-      -- of the foreign type.
-    (_, t_ty) = splitForAllTys sig_ty
-   in
-   case splitFunTys t_ty of
-     (arg_tys, res_ty) -> 
-       checkForeignExport False t_ty arg_tys res_ty `thenTc_`

          -- we're exporting a function, but at a type possibly more constrained
          -- than its declared/inferred type. Hence the need
          -- to create a local binding which will call the exported function
          -- at a particular type (and, maybe, overloading).
          -- we're exporting a function, but at a type possibly more constrained
          -- than its declared/inferred type. Hence the need
          -- to create a local binding which will call the exported function
          -- at a particular type (and, maybe, overloading).

-       newLocalId (nameOccName nm) sig_ty src_loc      `thenNF_Tc` \ i ->
-       let
-           bind  = VarMonoBind i rhs
-       in
-       returnTc (lie, bind, ForeignDecl i imp_exp undefined ext_nm cconv src_loc)
-        --                                         ^^^^^^^^^
-        -- ToDo: fill the type field in with something sensible.
+   newLocalId (nameOccName nm) sig_ty src_loc  `thenNF_Tc` \ id ->
+   let
+       bind  = VarMonoBind id rhs
+   in
+   returnTc (lie, bind, ForeignExport id undefined spec src_loc)
+\end{code}
+
+------------ Checking argument types for foreign export ----------------------

 
 

+\begin{code}
+tcCheckFEType sig_ty (CExport (CExportStatic str _))
+  = check (isCLabelString str) (badCName str)          `thenNF_Tc_`
+    checkForeignArgs isFFIExternalTy arg_tys           `thenNF_Tc_`
+    checkForeignRes nonIOok isFFIExportResultTy res_ty
+  where
+      -- Drop the foralls before inspecting n
+      -- the structure of the foreign type.
+    (_, t_ty) = splitForAllTys sig_ty
+    (arg_tys, res_ty) = splitFunTys t_ty

 \end{code}
 
 
 \end{code}
 
 

+
+%************************************************************************
+%*                                                                     *
+\subsection{Miscellaneous}
+%*                                                                     *
+%************************************************************************
+

 \begin{code}
 \begin{code}

-checkForeignImport :: Bool -> Safety -> Type -> [Type] -> Type -> TcM ()
-checkForeignImport is_dynamic safety ty args res
- | is_dynamic =
-    -- * first arg has got to be an Addr
-   case args of
-     []     -> check False (illegalForeignTyErr True{-Arg-} ty)
-     (x:xs) ->
-       getDOptsTc                                              `thenTc` \ dflags ->
-        check (isFFIDynArgumentTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
-        mapTc (checkForeignArg (isFFIArgumentTy dflags safety)) xs     `thenTc_`
-       checkForeignRes True {-NonIO ok-} (isFFIImportResultTy dflags) res
- | otherwise =
-     getDOptsTc                                                           `thenTc` \ dflags ->
-     mapTc (checkForeignArg (isFFIArgumentTy dflags safety)) args `thenTc_`
-     checkForeignRes True {-NonIO ok-} (isFFIImportResultTy dflags) res
-
-checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM ()
-checkForeignExport is_dynamic ty args res
- | is_dynamic = 
-    -- * the first (and only!) arg has got to be a function type
-    --   and it must return IO t
-    -- * result type is IO Addr
-   case args of
-     [arg]  ->
-       case splitFunTys arg of
-          (arg_tys, res_ty) -> 
-               mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_`
-               checkForeignRes True {-NonIO ok-} isFFIExportResultTy res_ty
-                                                                `thenTc_`
-               checkForeignRes False {-Must be IO-} isFFIDynResultTy res
-     _      -> check False (illegalForeignTyErr True{-Arg-} ty)
- | otherwise =
-     mapTc (checkForeignArg isFFIExternalTy) args              `thenTc_`
-     checkForeignRes True {-NonIO ok-} isFFIExportResultTy res
- 
-checkForeignArg :: (Type -> Bool) -> Type -> TcM ()
-checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty)
+------------ Checking argument types for foreign import ----------------------
+checkForeignArgs :: (Type -> Bool) -> [Type] -> NF_TcM ()
+checkForeignArgs pred tys
+  = mapNF_Tc go tys    `thenNF_Tc_` returnNF_Tc ()
+  where
+    go ty = check (pred ty) (illegalForeignTyErr argument ty)

 
 

+
+------------ Checking result types for foreign calls ----------------------

 -- Check that the type has the form 
 --    (IO t) or (t) , and that t satisfies the given predicate.
 --
 -- Check that the type has the form 
 --    (IO t) or (t) , and that t satisfies the given predicate.
 --

-checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
+checkForeignRes :: Bool -> (Type -> Bool) -> Type -> NF_TcM ()
+
+nonIOok  = True
+mustBeIO = False
+

 checkForeignRes non_io_result_ok pred_res_ty ty =
  case (splitTyConApp_maybe ty) of
     Just (io, [res_ty]) 
         | io `hasKey` ioTyConKey && pred_res_ty res_ty 
 checkForeignRes non_io_result_ok pred_res_ty ty =
  case (splitTyConApp_maybe ty) of
     Just (io, [res_ty]) 
         | io `hasKey` ioTyConKey && pred_res_ty res_ty 

-       -> returnTc ()
+       -> returnNF_Tc ()

     _   
         -> check (non_io_result_ok && pred_res_ty ty) 
     _   
         -> check (non_io_result_ok && pred_res_ty ty) 

-                (illegalForeignTyErr False{-Res-} ty)
+                (illegalForeignTyErr result ty)

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

-check :: Bool -> Message -> TcM ()
+check :: Bool -> Message -> NF_TcM ()

 check True _      = returnTc ()
 check True _      = returnTc ()

-check _    the_err = addErrTc the_err `thenNF_Tc_` returnTc ()
+check _    the_err = addErrTc the_err

 
 

-illegalForeignTyErr isArg ty
+illegalForeignTyErr arg_or_res ty

   = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration:")])
         4 (hsep [ppr ty])
   = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration:")])
         4 (hsep [ppr ty])

-  where
-   arg_or_res
-    | isArg     = ptext SLIT("argument")
-    | otherwise = ptext SLIT("result")

 
 

-foreignDeclCtxt fo = 
- hang (ptext SLIT("When checking declaration:"))
-  4   (ppr fo)
+-- Used for 'arg_or_res' argument to illegalForeignTyErr
+argument = text "argument"
+result   = text "result"
+
+badCName :: CLabelString -> Message
+badCName target = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
+
+foreignDeclCtxt fo
+  = hang (ptext SLIT("When checking declaration:"))
+     4   (ppr fo)

 \end{code}
 \end{code}

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 755c68b..78a6676 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -650,9 +650,9 @@ zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
 
 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
 
 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)

-zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
+zonkForeignExport (ForeignExport i hs_ty spec src_loc) =

    zonkIdOcc i `thenNF_Tc` \ i' ->
    zonkIdOcc i `thenNF_Tc` \ i' ->

-   returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
+   returnNF_Tc (ForeignExport i' undefined spec src_loc)

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

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 59d04eb..d2132a5 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -32,7 +32,7 @@ import TcEnv          ( TcEnv, tcExtendGlobalValEnv,
                          tcExtendTyVarEnvForMeths, 
                          tcAddImportedIdInfo, tcLookupClass,
                          InstInfo(..), pprInstInfo, simpleInstInfoTyCon, 
                          tcExtendTyVarEnvForMeths, 
                          tcAddImportedIdInfo, tcLookupClass,
                          InstInfo(..), pprInstInfo, simpleInstInfoTyCon, 

-                         simpleInstInfoTy, newDFunName, tcExtendTyVarEnv,
+                         simpleInstInfoTy, newDFunName,

                          isLocalThing,
                        )
 import InstEnv         ( InstEnv, extendInstEnv )
                          isLocalThing,
                        )
 import InstEnv         ( InstEnv, extendInstEnv )

diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index a68b51a..8842be5 100644 (file)
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -340,7 +340,7 @@ tcModule :: PersistentCompilerState
 
 tcModule pcs hst get_fixity this_mod decls
   = fixTc (\ ~(unf_env, _, _) ->
 
 tcModule pcs hst get_fixity this_mod decls
   = fixTc (\ ~(unf_env, _, _) ->

-               -- Loop back the final environment, including the fully zonkec
+               -- Loop back the final environment, including the fully zonked

                -- versions of bindings from this module.  In the presence of mutual
                -- recursion, interface type signatures may mention variables defined
                -- in this module, which is why the knot is so big
                -- versions of bindings from this module.  In the presence of mutual
                -- recursion, interface type signatures may mention variables defined
                -- in this module, which is why the knot is so big

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index ae8da7e..9fa3806 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -13,7 +13,7 @@ module TcTyClsDecls (
 import CmdLineOpts     ( DynFlags, DynFlag(..), dopt )
 import HsSyn           ( TyClDecl(..),  
                          ConDecl(..),   Sig(..), HsPred(..), 
 import CmdLineOpts     ( DynFlags, DynFlag(..), dopt )
 import HsSyn           ( TyClDecl(..),  
                          ConDecl(..),   Sig(..), HsPred(..), 

-                         tyClDeclName, hsTyVarNames, 
+                         tyClDeclName, hsTyVarNames, tyClDeclTyVars,

                          isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
                        )
 import RnHsSyn         ( RenamedTyClDecl, tyClDeclFVs )
                          isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
                        )
 import RnHsSyn         ( RenamedTyClDecl, tyClDeclFVs )

@@ -30,11 +30,11 @@ import TcType               ( TcKind, newKindVar, zonkKindEnv )
 
 import TcUnify         ( unifyKind )
 import TcInstDcls      ( tcAddDeclCtxt )
 
 import TcUnify         ( unifyKind )
 import TcInstDcls      ( tcAddDeclCtxt )

-import Type            ( Kind, mkArrowKind, zipFunTys )
+import Type            ( Kind, mkArrowKind, liftedTypeKind, zipFunTys )

 import Variance         ( calcTyConArgVrcs )
 import Class           ( Class, mkClass, classTyCon )
 import TyCon           ( TyCon, tyConKind, ArgVrcs, AlgTyConFlavour(..), 
 import Variance         ( calcTyConArgVrcs )
 import Class           ( Class, mkClass, classTyCon )
 import TyCon           ( TyCon, tyConKind, ArgVrcs, AlgTyConFlavour(..), 

-                         mkSynTyCon, mkAlgTyCon, mkClassTyCon )
+                         mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon )

 import DataCon         ( isNullaryDataCon )
 import Var             ( varName )
 import FiniteMap
 import DataCon         ( isNullaryDataCon )
 import Var             ( varName )
 import FiniteMap

@@ -207,8 +207,8 @@ tcTyClDecl1 is_rec unf_env decl
 \begin{code}
 getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
 getInitialKind decl
 \begin{code}
 getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
 getInitialKind decl

- = kcHsTyVars (tcdTyVars decl) `thenNF_Tc` \ arg_kinds ->
-   newKindVar                  `thenNF_Tc` \ result_kind  ->
+ = kcHsTyVars (tyClDeclTyVars decl)    `thenNF_Tc` \ arg_kinds ->
+   newKindVar                          `thenNF_Tc` \ result_kind  ->

    returnNF_Tc (tcdName decl, mk_kind arg_kinds result_kind)
 
 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
    returnNF_Tc (tcdName decl, mk_kind arg_kinds result_kind)
 
 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds

@@ -242,6 +242,8 @@ kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
     kcHsType rhs               `thenTc` \ rhs_kind ->
     unifyKind result_kind rhs_kind
 
     kcHsType rhs               `thenTc` \ rhs_kind ->
     unifyKind result_kind rhs_kind
 

+kcTyClDecl (ForeignType {}) = returnTc ()
+

 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
   = kcTyClDeclBody decl                        $ \ result_kind ->
     kcHsContext context                        `thenTc_` 
 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
   = kcTyClDeclBody decl                        $ \ result_kind ->
     kcHsContext context                        `thenTc_` 

@@ -273,7 +275,7 @@ kcTyClDeclBody decl thing_inside
                  AThing kind         -> kind
                -- For some odd reason, a class doesn't include its kind
 
                  AThing kind         -> kind
                -- For some odd reason, a class doesn't include its kind
 

-       (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tcdTyVars decl)) kind
+       (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tyClDeclTyVars decl)) kind

     in
     tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
 \end{code}
     in
     tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
 \end{code}

@@ -327,6 +329,10 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
                                 | otherwise                      -> DataTyCon
 
 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
                                 | otherwise                      -> DataTyCon
 
 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details

+                  (ForeignType {tcdName = tycon_name})
+  = ATyCon (mkForeignTyCon tycon_name liftedTypeKind 0 [])
+
+buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details

                   (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
                              tcdFDs = fundeps, tcdSysNames = name_list} )
   = AClass clas
                   (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
                              tcdFDs = fundeps, tcdSysNames = name_list} )
   = AClass clas

diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index afbd15e..ebfa3a8 100644 (file)
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -81,6 +81,9 @@ tcTyDecl1 is_rec unf_env (TyData {tcdND = new_or_data, tcdCtxt = context,
     mapTc (tcConDecl is_rec new_or_data tycon tyvars ctxt) con_decls   `thenTc` \ data_cons ->
     tcRecordSelectors is_rec unf_env tycon data_cons                   `thenTc` \ sel_ids -> 
     returnTc (tycon_name, DataTyDetails ctxt data_cons sel_ids)
     mapTc (tcConDecl is_rec new_or_data tycon tyvars ctxt) con_decls   `thenTc` \ data_cons ->
     tcRecordSelectors is_rec unf_env tycon data_cons                   `thenTc` \ sel_ids -> 
     returnTc (tycon_name, DataTyDetails ctxt data_cons sel_ids)

+
+tcTyDecl1 is_rec unf_env (ForeignType {tcdName = tycon_name})
+  = returnTc (tycon_name, ForeignTyDetails)

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

diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index 273a067..36ebf46 100644 (file)
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -312,7 +312,7 @@ showTypeCategory ty
                || utc == addrPrimTyConKey)                then 'i'
          else if utc  == floatPrimTyConKey                then 'f'
          else if utc  == doublePrimTyConKey               then 'd'
                || utc == addrPrimTyConKey)                then 'i'
          else if utc  == floatPrimTyConKey                then 'f'
          else if utc  == doublePrimTyConKey               then 'd'

-         else if isPrimTyCon tycon {- array, we hope -}   then 'A'
+         else if isPrimTyCon tycon {- array, we hope -}   then 'A'     -- Bogus

          else if isEnumerationTyCon tycon                 then 'E'
          else if isTupleTyCon tycon                       then 'T'
          else if maybeToBool (maybeTyConSingleCon tycon)  then 'S'
          else if isEnumerationTyCon tycon                 then 'E'
          else if isTupleTyCon tycon                       then 'T'
          else if maybeToBool (maybeTyConSingleCon tycon)  then 'S'

diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index 857d0ab..b8a139b 100644 (file)
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -13,6 +13,8 @@ module TyCon(
        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
        isRecursiveTyCon, newTyConRep,
 
        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
        isRecursiveTyCon, newTyConRep,
 

+       mkForeignTyCon, isForeignTyCon,
+

        mkAlgTyCon, --mkAlgTyCon, 
        mkClassTyCon,
        mkFunTyCon,
        mkAlgTyCon, --mkAlgTyCon, 
        mkClassTyCon,
        mkFunTyCon,

@@ -123,14 +125,18 @@ data TyCon
        algTyConClass :: Maybe Class    -- Just cl if this tycon came from a class declaration
     }
 
        algTyConClass :: Maybe Class    -- Just cl if this tycon came from a class declaration
     }
 

-  | PrimTyCon {                -- Primitive types; cannot be defined in Haskell
-                       -- NB: All of these guys are *unlifted*, but not all are *unboxed*
+  | PrimTyCon {                        -- Primitive types; cannot be defined in Haskell
+                               -- Now includes foreign-imported types

        tyConUnique  :: Unique,
        tyConName    :: Name,
        tyConKind    :: Kind,
        tyConArity   :: Arity,
        tyConArgVrcs :: ArgVrcs,
        tyConUnique  :: Unique,
        tyConName    :: Name,
        tyConKind    :: Kind,
        tyConArity   :: Arity,
        tyConArgVrcs :: ArgVrcs,

-       primTyConRep :: PrimRep
+       primTyConRep :: PrimRep,        -- Many primitive tycons are unboxed, but some are
+                                       -- boxed (represented by pointers). The PrimRep tells.
+
+       isUnLifted   :: Bool    -- Most primitive tycons are unlifted, 
+                               -- but foreign-imported ones may not be

     }
 
   | TupleTyCon {
     }
 
   | TupleTyCon {

@@ -290,14 +296,30 @@ mkTupleTyCon name kind arity tyvars con boxed gen_info
        genInfo = gen_info
     }
 
        genInfo = gen_info
     }
 

-mkPrimTyCon name kind arity arg_vrcs rep 
+-- Foreign-imported (.NET) type constructors are represented
+-- as primitive, but *lifted*, TyCons for now.  
+-- They  have PtrRep
+mkForeignTyCon name kind arity arg_vrcs

   = PrimTyCon {
   = PrimTyCon {

-       tyConName = name,
-       tyConUnique = nameUnique name,
-       tyConKind = kind,
-       tyConArity = arity,
+       tyConName    = name,
+       tyConUnique  = nameUnique name,
+       tyConKind    = kind,
+       tyConArity   = arity,

         tyConArgVrcs = arg_vrcs,
         tyConArgVrcs = arg_vrcs,

-       primTyConRep = rep
+       primTyConRep = PtrRep,
+       isUnLifted   = False
+    }
+
+
+mkPrimTyCon name kind arity arg_vrcs rep
+  = PrimTyCon {
+       tyConName    = name,
+       tyConUnique  = nameUnique name,
+       tyConKind    = kind,
+       tyConArity   = arity,
+        tyConArgVrcs = arg_vrcs,
+       primTyConRep = rep,
+       isUnLifted   = True

     }
 
 mkSynTyCon name kind arity tyvars rhs argvrcs
     }
 
 mkSynTyCon name kind arity tyvars rhs argvrcs

@@ -322,9 +344,9 @@ isFunTyCon _             = False
 isPrimTyCon (PrimTyCon {}) = True
 isPrimTyCon _              = False
 
 isPrimTyCon (PrimTyCon {}) = True
 isPrimTyCon _              = False
 

-isUnLiftedTyCon (PrimTyCon {}) = True
-isUnLiftedTyCon (TupleTyCon { tyConBoxed = boxity}) = not (isBoxed boxity)
-isUnLiftedTyCon _              = False
+isUnLiftedTyCon (PrimTyCon  {isUnLifted = is_unlifted}) = is_unlifted
+isUnLiftedTyCon (TupleTyCon {tyConBoxed = boxity})      = not (isBoxed boxity)
+isUnLiftedTyCon _                                      = False

 
 -- isBoxedTyCon should not be applied to SynTyCon, nor KindCon
 isBoxedTyCon (AlgTyCon {}) = True
 
 -- isBoxedTyCon should not be applied to SynTyCon, nor KindCon
 isBoxedTyCon (AlgTyCon {}) = True

@@ -383,6 +405,11 @@ tupleTyConBoxity tc = tyConBoxed tc
 
 isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True
 isRecursiveTyCon other                               = False
 
 isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True
 isRecursiveTyCon other                               = False

+
+-- isForeignTyCon identifies foreign-imported type constructors
+-- For the moment, they are primitive but lifted, but that may change
+isForeignTyCon (PrimTyCon {isUnLifted = is_unlifted}) = not is_unlifted
+isForeignTyCon other                                 = False

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

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 2bf99f5..2b1a149 100644 (file)
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -63,7 +63,8 @@ module Type (
        getDFunTyKey,
 
        -- Lifting and boxity
        getDFunTyKey,
 
        -- Lifting and boxity

-       isUnLiftedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
+       isUnLiftedType, isUnboxedTupleType, isAlgType, 
+       isDataType, isNewType, isPrimitiveType,

 
        -- Free variables
        tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
 
        -- Free variables
        tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,

@@ -108,7 +109,7 @@ import TyCon        ( TyCon,
                  isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
                  isAlgTyCon, isSynTyCon, tyConArity,
                  tyConKind, tyConDataCons, getSynTyConDefn,
                  isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
                  isAlgTyCon, isSynTyCon, tyConArity,
                  tyConKind, tyConDataCons, getSynTyConDefn,

-                 tyConPrimRep
+                 tyConPrimRep, isPrimTyCon

                )
 
 -- others
                )
 
 -- others

@@ -1126,6 +1127,15 @@ isNewType ty = case splitTyConApp_maybe ty of
                        Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
                                              isNewTyCon tc
                        other              -> False
                        Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
                                              isNewTyCon tc
                        other              -> False

+
+isPrimitiveType :: Type -> Bool
+-- Returns types that are opaque to Haskell.
+-- Most of these are unlifted, but now that we interact with .NET, we
+-- may have primtive (foreign-imported) types that are lifted
+isPrimitiveType ty = case splitTyConApp_maybe ty of
+                       Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
+                                             isPrimTyCon tc
+                       other              -> False

 \end{code}
 
 
 \end{code}