[project @ 2000-06-30 13:11:07 by simonpj]

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

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index d2c20a3..3614d8d 100644 (file)
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -22,7 +22,9 @@ import CallConv
 import TcHsSyn         ( TypecheckedForeignDecl )
 import CoreUtils       ( exprType, mkInlineMe )
 import DataCon         ( DataCon, dataConWrapId )
-import Id              ( Id, idType, idName, mkWildId, mkVanillaId, mkSysLocal )
+import Id              ( Id, idType, idName, mkWildId, mkVanillaId, mkSysLocal,
+                         setInlinePragma )
+import IdInfo          ( neverInlinePrag )
 import MkId            ( mkWorkerId )
 import Literal         ( Literal(..) )
 import Module          ( Module, moduleUserString )
@@ -30,13 +32,13 @@ import Name         ( mkGlobalName, nameModule, nameOccName, getOccString,
                          mkForeignExportOcc, isLocalName,
                          NamedThing(..), Provenance(..), ExportFlag(..)
                        )
-import Type            ( unUsgTy,
+import Type            ( unUsgTy, repType,
                          splitTyConApp_maybe, splitFunTys, splitForAllTys,
                          Type, mkFunTys, mkForAllTys, mkTyConApp,
                          mkTyVarTy, mkFunTy, splitAppTy, applyTy, funResultTy
                        )
 import PprType         ( {- instance Outputable Type -} )
-import PrimOp          ( PrimOp(..), CCall(..), CCallTarget(..) )
+import PrimOp          ( PrimOp(..), CCall(..), CCallTarget(..), dynamicTarget )
 import Var             ( TyVar )
 import TysPrim         ( realWorldStatePrimTy, addrPrimTy )
 import TysWiredIn      ( unitTy, addrTy, stablePtrTyCon,
@@ -139,14 +141,13 @@ dsFImport fn_id ty may_not_gc ext_name cconv
     mapAndUnzipDs unboxArg (map Var args)      `thenDs` \ (val_args, arg_wrappers) ->
     boxResult io_res_ty                                `thenDs` \ (ccall_result_ty, res_wrapper) ->
 
-    (case ext_name of
-       Dynamic       -> getUniqueDs `thenDs` \ u -> 
-                       returnDs (DynamicTarget u)
-       ExtName fs _  -> returnDs (StaticTarget fs))    `thenDs` \ lbl ->
-
     getUniqueDs                                                `thenDs` \ ccall_uniq ->
     getUniqueDs                                                `thenDs` \ work_uniq ->
     let
+       lbl = case ext_name of
+               Dynamic      -> dynamicTarget
+               ExtName fs _ -> StaticTarget fs
+
        -- Build the worker
        work_arg_ids  = [v | Var v <- val_args]         -- All guaranteed to be vars
        worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
@@ -169,8 +170,9 @@ Foreign labels
 dsFLabel :: Id -> ExtName -> DsM CoreBind
 dsFLabel nm ext_name = returnDs (NonRec nm fo_rhs)
   where
-   fo_rhs = mkConApp addrDataCon [mkLit (MachLitLit enm addrPrimTy)]
+   fo_rhs = mkConApp addrDataCon [mkLit (MachLitLit addr addrPrimTy)]
    enm    = extNameStatic ext_name
+   addr   = SLIT("(&") _APPEND_ enm _APPEND_ SLIT(")")
 \end{code}
 
 The function that does most of the work for `@foreign export@' declarations.
@@ -298,24 +300,17 @@ of some fixed type behind an externally callable interface (i.e.,
 as a C function pointer). Useful for callbacks and stuff.
 
 \begin{verbatim}
-foreign export stdcall f :: (Addr -> Int -> IO Int) -> IO Addr
+foreign export dynamic f :: (Addr -> Int -> IO Int) -> IO Addr
 
--- Haskell-visible constructor, which is generated from the
--- above:
+-- Haskell-visible constructor, which is generated from the above:
+-- SUP: No check for NULL from createAdjustor anymore???
 
 f :: (Addr -> Int -> IO Int) -> IO Addr
-f cback = IO ( \ s1# ->
-  case makeStablePtr# cback s1# of { StateAndStablePtr# s2# sp# ->
-  case _ccall_ "mkAdjustor" sp# ``f_helper'' s2# of
-    StateAndAddr# s3# a# ->
-    case addr2Int# a# of
-      0# -> IOfail s# err
-      _  -> 
-        let
-         a :: Addr
-         a = A# a#
-        in
-         IOok s3# a)
+f cback =
+   bindIO (makeStablePtr cback)
+          (\StablePtr sp# -> IO (\s1# ->
+              case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of
+                 (# s2#, a# #) -> (# s2#, A# a# #)))
 
 foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr -> Int -> IO Int
 -- `special' foreign export that invokes the closure pointed to by the
@@ -379,7 +374,9 @@ dsFExportDynamic i ty mod_name ext_name cconv =
                  mkLams [cback] $
                  stbl_app ccall_io_adj addrTy
      in
-     returnDs (NonRec i io_app, fe, h_code, c_code)
+       -- Never inline the f.e.d. function, because the litlit might not be in scope
+       -- in other modules.
+     returnDs (NonRec (i `setInlinePragma` neverInlinePrag) io_app, fe, h_code, c_code)
 
  where
   (tvs,sans_foralls)              = splitForAllTys ty
@@ -493,7 +490,7 @@ showStgType t = text "Stg" <> text (showFFIType t)
 showFFIType :: Type -> String
 showFFIType t = getOccString (getName tc)
  where
-  tc = case splitTyConApp_maybe t of
+  tc = case splitTyConApp_maybe (repType t) of
            Just (tc,_) -> tc
            Nothing     -> pprPanic "showFFIType" (ppr t)
 \end{code}