X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsForeign.lhs;h=52956a09fff45264bc2f6f7b9782e0f339f0e290;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=a99b354017f668070c65c881ef06a9d9f49892d5;hpb=d0110d1962bfdee23152cbf64beea13d4b0f3846;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index a99b354..52956a0 100644 --- 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, @@ -80,11 +79,13 @@ dsForeigns [] dsForeigns fos = foldlDs combine (ForeignStubs empty empty [] [], []) fos where - combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) - (L loc (ForeignImport id _ spec depr)) + combine stubs (L loc decl) = putSrcSpanDs loc (combine1 stubs decl) + + combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) + (ForeignImport id _ spec depr) = traceIf (text "fi start" <+> ppr id) `thenDs` \ _ -> dsFImport (unLoc id) spec `thenDs` \ (bs, h, c, mbhd) -> - warnDepr depr loc `thenDs` \ _ -> + warnDepr depr `thenDs` \ _ -> traceIf (text "fi end" <+> ppr id) `thenDs` \ _ -> returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) @@ -92,11 +93,11 @@ dsForeigns fos acc_feb, bs ++ acc_f) - combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) - (L loc (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr)) + combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) + (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr) = dsFExport id (idType id) ext_nm cconv False `thenDs` \(h, c, _, _) -> - warnDepr depr loc `thenDs` \_ -> + warnDepr depr `thenDs` \_ -> returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb), acc_f) @@ -105,8 +106,8 @@ dsForeigns fos | e `elem` ls = ls | otherwise = e:ls - warnDepr False _ = returnDs () - warnDepr True loc = dsWarn (loc, msg) + warnDepr False = returnDs () + warnDepr True = dsWarn msg where msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax") \end{code} @@ -144,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 @@ -208,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 @@ -240,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 -> @@ -250,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 @@ -360,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 -> @@ -507,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;" @@ -540,21 +537,10 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc -- the program. -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL) - -- the only reason for making the mingw32 (anything targetting PE, really) stick - -- out here is that the GHCi linker isn't capable of handling .ctors sections - useStaticConstructors -#if defined(mingw32_HOST_OS) - = False -#else - = True -#endif - initialiser = case maybe_target of Nothing -> empty - Just hs_fn - | not useStaticConstructors -> empty - | otherwise -> + Just hs_fn -> vcat [ text "static void stginit_export_" <> ppr hs_fn <> text "() __attribute__((constructor));" @@ -571,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" @@ -588,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