From 1739ba3ce432e640139764596ca453e58aef3016 Mon Sep 17 00:00:00 2001 From: sof Date: Tue, 2 Mar 1999 15:40:11 +0000 Subject: [PATCH] [project @ 1999-03-02 15:40:08 by sof] Fix to allow local, non-exported actions to be 'foreign export'ed. --- ghc/compiler/deSugar/Desugar.lhs | 4 ++-- ghc/compiler/deSugar/DsBinds.lhs | 2 +- ghc/compiler/deSugar/DsForeign.lhs | 45 +++++++++++++++++++++--------------- ghc/compiler/deSugar/DsMonad.lhs | 3 ++- 4 files changed, 31 insertions(+), 23 deletions(-) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 8e43035..422dec0 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -18,7 +18,7 @@ import DsForeign ( dsForeigns ) import DsUtils import DsExpr () -- Forces DsExpr to be compiled; DsBinds only -- depends on DsExpr.hi-boot. -import Name ( Module, moduleString ) +import Module ( Module, moduleString ) import Bag ( isEmptyBag, unionBags ) import CmdLineOpts ( opt_SccGroup, opt_SccProfilingOn ) import CoreLint ( beginPass, endPass ) @@ -46,7 +46,7 @@ deSugar us global_val_env mod_name all_binds fo_decls = do ds_binds' = [Rec core_prs] ((fi_binds, fe_binds, h_code, c_code), ds_warns2) = - initDs us3 global_val_env module_and_group (dsForeigns fo_decls) + initDs us3 global_val_env module_and_group (dsForeigns mod_name fo_decls) ds_binds = fi_binds ++ ds_binds' ++ fe_binds diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 1a4046d..c0d1f77 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -31,7 +31,7 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, import CostCentre ( mkAutoCC, IsCafCC(..), mkAllDictsCC ) import Id ( idType, Id ) import VarEnv -import Name ( Module, isExported ) +import Name ( isExported ) import Type ( mkTyVarTy, isDictTy, substTy ) import TysWiredIn ( voidTy ) diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index bfe23c3..cc30527 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -24,8 +24,9 @@ import Const ( Con(..), mkMachInt ) import DataCon ( DataCon, dataConId ) import Id ( Id, idType, idName, mkWildId, mkUserId ) import Const ( Literal(..) ) +import Module ( Module ) import Name ( mkGlobalName, nameModule, nameOccName, getOccString, - mkForeignExportOcc, + mkForeignExportOcc, isLocalName, NamedThing(..), Provenance(..), ExportFlag(..) ) import PrelVals ( realWorldPrimId ) @@ -59,13 +60,14 @@ is the same as so we reuse the desugaring code in @DsCCall@ to deal with these. \begin{code} -dsForeigns :: [TypecheckedForeignDecl] +dsForeigns :: Module + -> [TypecheckedForeignDecl] -> DsM ( [CoreBind] -- desugared foreign imports , [CoreBind] -- helper functions for foreign exports , SDoc -- Header file prototypes for "foreign exported" functions. , SDoc -- C stubs to use when calling "foreign exported" funs. ) -dsForeigns fos = foldlDs combine ([],[],empty,empty) fos +dsForeigns mod_name fos = foldlDs combine ([],[],empty,empty) fos where combine (acc_fi, acc_fe, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _) | isForeignImport = -- foreign import (dynamic)? @@ -75,11 +77,11 @@ dsForeigns fos = foldlDs combine ([],[],empty,empty) fos dsFLabel i ext_nm `thenDs` \ b -> returnDs (b:acc_fi, acc_fe, acc_h, acc_c) | isDynamic ext_nm = - dsFExportDynamic i (idType i) ext_nm cconv `thenDs` \ (fi,fe,h,c) -> + dsFExportDynamic i (idType i) mod_name ext_nm cconv `thenDs` \ (fi,fe,h,c) -> returnDs (fi:acc_fi, fe:acc_fe, h $$ acc_h, c $$ acc_c) | otherwise = -- foreign export - dsFExport i (idType i) ext_nm cconv False `thenDs` \ (fe,h,c) -> + dsFExport i (idType i) mod_name ext_nm cconv False `thenDs` \ (fe,h,c) -> returnDs (acc_fi, fe:acc_fe, h $$ acc_h, c $$ acc_c) where isForeignImport = @@ -214,6 +216,7 @@ the user-written Haskell function 'M.foo'. \begin{code} dsFExport :: Id -> Type -- Type of foreign export. + -> Module -> ExtName -> CallConv -> Bool -- True => invoke IO action that's hanging off @@ -222,17 +225,20 @@ dsFExport :: Id , SDoc , SDoc ) -dsFExport i ty ext_name cconv isDyn = +dsFExport i ty mod_name ext_name cconv isDyn = getUniqueDs `thenDs` \ uniq -> getSrcLocDs `thenDs` \ src_loc -> let f_helper_glob = mkUserId helper_name helper_ty where - name = idName i - mod = nameModule name - occ = mkForeignExportOcc (nameOccName name) - prov = LocalDef src_loc Exported - helper_name = mkGlobalName uniq mod occ prov + name = idName i + mod + | isLocalName name = mod_name + | otherwise = nameModule name + + occ = mkForeignExportOcc (nameOccName name) + prov = LocalDef src_loc Exported + helper_name = mkGlobalName uniq mod occ prov in newSysLocalsDs fe_arg_tys `thenDs` \ fe_args -> (if isDyn then @@ -360,18 +366,19 @@ foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr \begin{code} dsFExportDynamic :: Id -> Type -- Type of foreign export. + -> Module -> ExtName -> CallConv -> DsM (CoreBind, CoreBind, SDoc, SDoc) -dsFExportDynamic i ty ext_name cconv = +dsFExportDynamic i ty mod_name ext_name cconv = newSysLocalDs ty `thenDs` \ fe_id -> let -- hack: need to get at the name of the C stub we're about to generate. fe_nm = toCName fe_id fe_ext_name = ExtName (_PK_ fe_nm) Nothing in - dsFExport i export_ty fe_ext_name cconv True `thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) -> - newSysLocalDs arg_ty `thenDs` \ cback -> + dsFExport i export_ty mod_name fe_ext_name cconv True `thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) -> + newSysLocalDs arg_ty `thenDs` \ cback -> dsLookupGlobalValue makeStablePtr_NAME `thenDs` \ makeStablePtrId -> let mk_stbl_ptr_app = mkApps (Var makeStablePtrId) [ Type arg_ty, Var cback ] @@ -528,16 +535,16 @@ mkCArgNames :: Int -> [a] -> [SDoc] mkCArgNames n as = zipWith (\ _ n -> text ('a':show n)) as [n..] mkHObj :: Type -> SDoc -mkHObj t = text "rts_mk" <> showFFIType t +mkHObj t = text "rts_mk" <> text (showFFIType t) unpackHObj :: Type -> SDoc -unpackHObj t = text "rts_get" <> showFFIType t +unpackHObj t = text "rts_get" <> text (showFFIType t) showStgType :: Type -> SDoc -showStgType t = text "Stg" <> showFFIType t +showStgType t = text "Stg" <> text (showFFIType t) -showFFIType :: Type -> SDoc -showFFIType t = text (getOccString (getName tc)) +showFFIType :: Type -> String +showFFIType t = getOccString (getName tc) where tc = case splitTyConApp_maybe t of Just (tc,_) -> tc diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index ea697b2..b5821b5 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -29,7 +29,8 @@ import Bag ( emptyBag, snocBag, bagToList, Bag ) import ErrUtils ( WarnMsg, pprBagOfErrors ) import HsSyn ( OutPat ) import Id ( mkSysLocal, setIdUnique, Id ) -import Name ( Module, Name, maybeWiredInIdName ) +import Module ( Module ) +import Name ( Name, maybeWiredInIdName ) import Var ( TyVar, setTyVarUnique ) import VarEnv import Outputable -- 1.7.10.4