[project @ 2006-01-06 16:30:17 by simonmar]

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

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 1523d83..52956a0 100644 (file)
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -28,9 +28,8 @@ import SMRep          ( argMachRep, typeCgRep )
 import CoreUtils       ( exprType, mkInlineMe )
 import Id              ( Id, idType, idName, mkSysLocal, setInlinePragma )
 import Literal         ( Literal(..), mkStringLit )
-import Module          ( moduleString )
+import Module          ( moduleFS )
 import Name            ( getOccString, NamedThing(..) )
-import OccName         ( encodeFS )
 import Type            ( repType, coreEqType )
 import TcType          ( Type, mkFunTys, mkForAllTys, mkTyConApp,
                          mkFunTy, tcSplitTyConApp_maybe, 
@@ -146,7 +145,7 @@ dsFImport id (CImport cconv safety header lib spec)
   = dsCImport id spec cconv safety no_hdrs       `thenDs` \(ids, h, c) ->
     returnDs (ids, h, c, if no_hdrs then Nothing else Just header)
   where
-    no_hdrs = nullFastString header
+    no_hdrs = nullFS header
 
   -- FIXME: the `lib' field is needed for .NET ILX generation when invoking
   --       routines that are external to the .NET runtime, but GHC doesn't
@@ -210,12 +209,6 @@ dsFCall fn_id fcall no_hdrs
     let
        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
 
-       -- 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 | unsafe_call fcall = work_arg_ids
-                     | otherwise         = []
-
        forDotnet = 
         case fcall of
           DNCall{} -> True
@@ -242,7 +235,7 @@ dsFCall fn_id fcall no_hdrs
     in
     augmentResultDs                                 `thenDs` \ augment -> 
     topConDs                                        `thenDs` \ topCon -> 
-    boxResult maybe_arg_ids augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
+    boxResult augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
 
     newUnique                                  `thenDs` \ ccall_uniq ->
     newUnique                                  `thenDs` \ work_uniq ->
@@ -252,7 +245,7 @@ dsFCall fn_id fcall no_hdrs
        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       = setImpInline no_hdrs $  -- See comments with setImpInline
-                       mkSysLocal (encodeFS FSLIT("$wccall")) work_uniq worker_ty
+                       mkSysLocal FSLIT("$wccall") work_uniq worker_ty
 
        -- Build the wrapper
        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
@@ -362,7 +355,7 @@ dsFExportDynamic id cconv
      getModuleDs                               `thenDs` \ mod_name -> 
      let 
         -- hack: need to get at the name of the C stub we're about to generate.
-       fe_nm      = mkFastString (moduleString mod_name ++ "_" ++ toCName fe_id)
+       fe_nm      = mkFastString (unpackFS (zEncodeFS (moduleFS mod_name)) ++ "_" ++ toCName fe_id)
      in
      newSysLocalDs arg_ty                      `thenDs` \ cback ->
      dsLookupGlobalId newStablePtrName         `thenDs` \ newStablePtrId ->
@@ -509,13 +502,15 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
           Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
           Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
 
+  cap = text "cap" <> comma
+
   -- the expression we give to rts_evalIO
   expr_to_run
      = foldl appArg the_cfun arg_info -- NOT aug_arg_info
        where
           appArg acc (arg_cname, _, arg_hty, _) 
              = text "rts_apply" 
-               <> parens (acc <> comma <> mkHObj arg_hty <> parens arg_cname)
+               <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
 
   -- various other bits for inside the fn
   declareResult = text "HaskellObj ret;"
@@ -562,13 +557,15 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
     fun_proto  $$
     vcat 
      [ lbrace
-     ,   text "SchedulerStatus rc;"
+     ,   text "Capability *cap;"
      ,   declareResult
      ,   declareCResult
-     ,   text "rts_lock();"
+     ,   text "cap = rts_lock();"
          -- create the application + perform it.
-     ,   text "rc=rts_evalIO" <> parens (
+     ,   text "cap=rts_evalIO" <> parens (
+               cap <>
                text "rts_apply" <> parens (
+                   cap <>
                    text "(HaskellObj)"
                 <> text (if is_IO_res_ty 
                                then "runIO_closure" 
@@ -579,9 +576,9 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
               <> text "&ret"
             ) <> semi
      ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
-                                               <> comma <> text "rc") <> semi
+                                               <> comma <> text "cap") <> semi
      ,   assignCResult
-     ,   text "rts_unlock();"
+     ,   text "rts_unlock(cap);"
      ,   if res_hty_is_unit then empty
             else text "return cret;"
      , rbrace