Skip to content

Commit 065789f

Browse files
csabahruskacsabahruska
committed
add wpc-plugin
1 parent 79a630f commit 065789f

File tree

13 files changed

+1628
-0
lines changed

13 files changed

+1628
-0
lines changed

‎wpc-plugin/CHANGELOG.md‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
# Revision history for wpc-plugin
2+
3+
## 0.1.0.0 -- YYYY-mm-dd
4+
5+
* First version. Released on an unsuspecting world.

‎wpc-plugin/external-stg-syntax‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
../external-stg-syntax

‎wpc-plugin/src/WPC/Foreign.hs‎

Lines changed: 118 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,118 @@
1+
{-# LANGUAGE RecordWildCards #-}
2+
{-# LANGUAGE LambdaCase #-}
3+
module WPC.Foreign where
4+
5+
import Control.Monad
6+
import GHC.Plugins
7+
8+
import GHC.Driver.Hooks
9+
import Language.Haskell.Syntax.Decls
10+
import GHC.HsToCore.Types
11+
import GHC.Types.ForeignStubs
12+
import GHC.Data.OrdList
13+
import GHC.Hs.Extension
14+
import GHC.Tc.Utils.Monad
15+
import GHC.HsToCore.Foreign.Decl
16+
import GHC.Types.ForeignCall
17+
import GHC.Types.RepType
18+
import GHC.Core.TyCo.Compare
19+
import GHC.Core.TyCo.Rep
20+
import GHC.Tc.Utils.TcType
21+
22+
import WPC.GlobalEnv
23+
import WPC.ForeignStubDecls
24+
import Data.IORef
25+
import Data.Maybe
26+
import Data.List
27+
28+
dsForeignsFun :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr))
29+
dsForeignsFun fos = do
30+
liftIO $ putStrLn " ###### dsForeignsFun"
31+
updTopEnv (\hscEnv -> hscEnv {hsc_hooks = (hsc_hooks hscEnv) {dsForeignsHook = Nothing}}) $ do
32+
33+
resultList <- forM fos $ \fo -> do
34+
(stubs, bindings) <- dsForeigns [fo]
35+
let stubDecl = mkStubDecl stubs bindings fo
36+
pure (stubs, bindings, stubDecl)
37+
38+
let (stubList, bindingList, stubDeclList) = unzip3 resultList
39+
liftIO $ modifyIORef globalEnvIORef $ \d -> d
40+
{ geStubDecls = Just stubDeclList
41+
}
42+
43+
pure (mergeForeignStubs stubList, mconcat bindingList)
44+
45+
mkStubDecl :: ForeignStubs -> OrdList (Id, CoreExpr) -> LForeignDecl GhcTc -> (ForeignStubs, StubDecl)
46+
mkStubDecl stub bindings (L loc decl) = case decl of
47+
ForeignImport{..} -> (stub, StubDeclImport fd_fi (mkStubImpl bindings decl))
48+
ForeignExport{..} -> (stub, StubDeclExport fd_fe (unLoc fd_name))
49+
50+
mkStubImpl :: OrdList (Id, CoreExpr) -> ForeignDecl GhcTc -> Maybe StubImpl
51+
mkStubImpl bindings decl = case decl of
52+
ForeignImport{..}
53+
| CImport _srcText _cconv _safety _mHeader CWrapper <- fd_fi
54+
, [wrapperCName] <- concat $ (map (getWrapperName . snd) $ fromOL bindings)
55+
, (isIOCall, retTy, argTys) <- getCWrapperDescriptor fd_i_ext
56+
-> Just $ StubImplImportCWrapper
57+
{ siCWrapperLabel = wrapperCName
58+
, siStdCallArgSize = Nothing
59+
, siIsIOCall = isIOCall
60+
, siReturnType = retTy
61+
, siArgTypes = argTys
62+
}
63+
64+
_ -> Nothing
65+
where
66+
goBind :: CoreBind -> [FastString]
67+
goBind = \case
68+
NonRec _ e -> getWrapperName e
69+
Rec l -> concatMap (getWrapperName . snd) l
70+
71+
goAlt :: CoreAlt -> [FastString]
72+
goAlt (Alt _ _ e) = getWrapperName e
73+
74+
getWrapperName :: CoreExpr -> [FastString]
75+
getWrapperName expr = case expr of
76+
App e a -> getWrapperName e ++ getWrapperName a
77+
Lam _ e -> getWrapperName e
78+
Let b e -> goBind b ++ getWrapperName e
79+
Case e _ _ l -> getWrapperName e ++ concatMap goAlt l
80+
Cast e _ -> getWrapperName e
81+
Tick _ e -> getWrapperName e
82+
83+
Var{} -> []
84+
Lit (LitLabel fe_nm _mb_sz_args IsFunction) -> [fe_nm]
85+
Lit{} -> []
86+
Type{} -> []
87+
Coercion{} -> []
88+
89+
getCWrapperDescriptor :: Coercion -> (Bool, String, [String]) -- is IO, result type, arg types
90+
getCWrapperDescriptor ffiCo = (is_IO_res_ty, showFFIType res_ty, map showFFIType fe_arg_tys)
91+
where
92+
-- example for ffiTy: (Int -> IO Int) -> IO (FunPtr (Int -> IO Int))
93+
ffiTy = coercionLKind ffiCo
94+
(_,sans_foralls) = tcSplitForAllInvisTyVars ffiTy
95+
-- example for arg_ty: Int -> IO Int
96+
([Scaled _ arg_ty], _) = tcSplitFunTys sans_foralls
97+
98+
(bndrs, orig_res_ty) = tcSplitPiTys arg_ty
99+
fe_arg_tys = mapMaybe anonPiTyBinderType_maybe bndrs
100+
101+
-- Look at the result type of the exported function, orig_res_ty
102+
-- If it's IO t, return (t, True)
103+
-- If it's plain t, return (t, False)
104+
(res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
105+
-- The function already returns IO t
106+
Just (_ioTyCon, res_ty) -> (res_ty, True)
107+
-- The function returns t
108+
Nothing -> (orig_res_ty, False)
109+
110+
showFFIType :: Type -> String
111+
showFFIType t = getOccString (getName (typeTyCon t))
112+
113+
typeTyCon :: Type -> TyCon
114+
typeTyCon ty
115+
| Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)
116+
= tc
117+
| otherwise
118+
= pprPanic "GHC.HsToCore.Foreign.C.typeTyCon" (ppr ty)

‎wpc-plugin/src/WPC/ForeignStubDecls.hs‎

Lines changed: 29 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,29 @@
1+
module WPC.ForeignStubDecls where
2+
3+
import GHC.Plugins
4+
import GHC.Types.ForeignStubs
5+
import GHC.Types.ForeignCall
6+
import GHC.Hs.Extension
7+
import Language.Haskell.Syntax.Decls
8+
9+
-- | Foreign export stub detailed declarations
10+
newtype ForeignStubDecls = ForeignStubDecls [(ForeignStubs, StubDecl)]
11+
12+
data StubImpl
13+
= StubImplImportCWrapper
14+
{ siCWrapperLabel :: FastString
15+
, siStdCallArgSize :: (Maybe Int) -- arg list size for std call mangling
16+
, siIsIOCall :: Bool
17+
, siReturnType :: String
18+
, siArgTypes :: [String]
19+
}
20+
21+
data StubDecl
22+
= StubDeclImport (ForeignImport GhcTc) (Maybe StubImpl)
23+
| StubDeclExport (ForeignExport GhcTc) Id -- HINT: exported HsId
24+
25+
mergeForeignStubs :: [ForeignStubs] -> ForeignStubs
26+
mergeForeignStubs stubs = case [(h, c) | ForeignStubs h c <- stubs] of
27+
[] -> NoStubs
28+
l -> ForeignStubs h c where (h, c) = mconcat l
29+

‎wpc-plugin/src/WPC/GhcStgApp.hs‎

Lines changed: 136 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,136 @@
1+
{-# LANGUAGE RecordWildCards #-}
2+
{-# LANGUAGE NamedFieldPuns #-}
3+
module WPC.GhcStgApp where
4+
5+
import GHC.Prelude
6+
7+
import GHC.Data.Maybe
8+
import GHC.Platform.ArchOS
9+
import GHC.Utils.Outputable
10+
import GHC.Unit.Info
11+
import GHC.Unit.Home.ModInfo
12+
import GHC.Unit.Module.Deps
13+
import GHC.Linker.Static.Utils
14+
import GHC.Linker.Types
15+
import GHC.Unit.Module.ModIface
16+
17+
import GHC.Driver.Ppr
18+
import GHC.Driver.Session
19+
20+
import qualified GHC.Data.ShortText as ST
21+
22+
import GHC.Utils.Json
23+
24+
import Data.List ( isPrefixOf )
25+
import Data.Containers.ListUtils ( nubOrd )
26+
import qualified Data.Set as Set
27+
import Data.Version
28+
import GHC.Unit.State
29+
import GHC.Unit.Env
30+
import GHC.Unit.Types
31+
import GHC.Platform
32+
33+
import System.FilePath
34+
import System.Directory
35+
36+
import WPC.Yaml
37+
38+
{-
39+
TODO:
40+
list app modules
41+
list app cbits
42+
-}
43+
44+
writeGhcStgApp :: DynFlags -> UnitEnv -> HomePackageTable -> IO ()
45+
writeGhcStgApp dflags unit_env hpt = do
46+
let home_mod_infos = eltsHpt hpt
47+
48+
-- the packages we depend on
49+
dep_units = Set.toList
50+
$ Set.unions
51+
$ fmap (dep_direct_pkgs . mi_deps . hm_iface)
52+
$ home_mod_infos
53+
54+
platform = targetPlatform dflags
55+
arch_os = platformArchOS platform
56+
staticLink = False
57+
output_fn = exeFileName arch_os staticLink (outputFile_ dflags)
58+
59+
root <- getCurrentDirectory
60+
dep_unit_infos <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units)
61+
let pp :: Outputable a => a -> String
62+
pp = showSDoc dflags . ppr
63+
toAbsPath p
64+
| isAbsolute p = p
65+
| otherwise = root </> p
66+
arrOfAbsPathST = arrOfAbsPath . map ST.unpack
67+
arrOfAbsPath = JSArray . map JSString . nubOrd . map toAbsPath
68+
app_deps = JSArray
69+
[ JSObject
70+
[ ("name", JSString $ pp unitPackageName)
71+
, ("version", JSString (showVersion unitPackageVersion))
72+
, ("id", JSString $ pp unitId)
73+
, ("unit-import-dirs", arrOfAbsPathST unitImportDirs)
74+
, ("unit-libraries", JSArray $ map (JSString . ST.unpack) unitLibraries)
75+
, ("library-dirs", arrOfAbsPathST unitLibraryDirs)
76+
, ("extra-libraries", JSArray $ map (JSString . ST.unpack) unitExtDepLibsSys)
77+
, ("framework-dirs", arrOfAbsPathST unitExtDepFrameworkDirs)
78+
, ("extra-frameworks", JSArray $ map (JSString . ST.unpack) unitExtDepFrameworks)
79+
, ("ld-options", JSArray $ map (JSString . ST.unpack) unitLinkerOptions)
80+
, ("exposed-modules", JSArray $ map (JSString . pp) [mod | (mod, Nothing) <- unitExposedModules])
81+
, ("hidden-modules", JSArray $ map (JSString . pp) unitHiddenModules)
82+
]
83+
| GenericUnitInfo{..} <- dep_unit_infos
84+
]
85+
86+
let arrOfStr = JSArray . map JSString . nubOrd
87+
appLdOptions = [ o
88+
| Option o <- ldInputs dflags
89+
, not $ isPrefixOf "-l" o
90+
]
91+
writeFile (output_fn ++ "." ++ objectSuf dflags ++ "_ghc_stgapp") $ showSDoc dflags $ renderYAML $ JSObject
92+
[ ("ghc-name", JSString . ghcNameVersion_programName $ ue_namever unit_env)
93+
, ("ghc-version", JSString . ghcNameVersion_projectVersion $ ue_namever unit_env)
94+
, ("platform-os", JSString . stringEncodeOS . platformOS $ targetPlatform dflags)
95+
, ("no-hs-main", JSBool $ gopt Opt_NoHsMain dflags)
96+
, ("o-suffix", JSString $ objectSuf dflags)
97+
, ("ways", arrOfStr $ map show . Set.toList $ ways dflags)
98+
, ("object-dir", JSString . toAbsPath $ fromMaybe root (objectDir dflags))
99+
, ("app-unit-id", JSString . pp $ ue_current_unit unit_env)
100+
, ("app-modules", JSArray $ map (JSString . pp) [moduleName . mi_module $ hm_iface | HomeModInfo{..} <- home_mod_infos])
101+
, ("extra-ld-inputs", arrOfAbsPath [f | FileOption _ f <- ldInputs dflags])
102+
, ("library-dirs", arrOfAbsPath $ libraryPaths dflags)
103+
, ("extra-libraries", arrOfStr [lib | Option ('-':'l':lib) <- ldInputs dflags])
104+
, ("framework-dirs", arrOfAbsPath $ frameworkPaths dflags)
105+
, ("extra-frameworks", JSArray $ map JSString $ cmdlineFrameworks dflags)
106+
, ("ld-options", arrOfStr appLdOptions)
107+
, ("unit-db-paths", arrOfAbsPath $ maybe [] (map unitDatabasePath) $ ue_unit_dbs unit_env)
108+
, ("app-deps", app_deps)
109+
]
110+
111+
{-
112+
eltsUDFM :: UniqDFM key elt -> [elt]
113+
eltsHpt :: HomePackageTable -> [HomeModInfo]
114+
type HomePackageTable = DModuleNameEnv HomeModInfo
115+
116+
data HomeModInfo = HomeModInfo
117+
{ hm_iface :: !ModIface
118+
, hm_details :: ModDetails
119+
, hm_linkable :: !HomeModLinkable
120+
}
121+
122+
type ModIface = ModIface_ 'ModIfaceFinal
123+
mi_module :: !Module, -- ^ Name of the module we are for
124+
125+
data GenModule unit = Module
126+
{ moduleUnit :: !unit -- ^ Unit the module belongs to
127+
, moduleName :: !ModuleName -- ^ Module name (e.g. A.B.C)
128+
}
129+
deriving (Eq,Ord,Data,Functor)
130+
131+
-- | A Module is a pair of a 'Unit' and a 'ModuleName'.
132+
type Module = GenModule Unit
133+
134+
moduleUnitId :: Module -> UnitId
135+
moduleUnitId = toUnitId . moduleUnit
136+
-}

‎wpc-plugin/src/WPC/GlobalEnv.hs‎

Lines changed: 33 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,33 @@
1+
module WPC.GlobalEnv where
2+
3+
import Data.IORef
4+
import System.IO.Unsafe
5+
6+
import GHC.Plugins
7+
import GHC.Stg.Syntax
8+
import GHC.Types.ForeignStubs
9+
10+
import WPC.ForeignStubDecls
11+
12+
data GlobalEnv
13+
= GlobalEnv
14+
{ geModSummary :: Maybe ModSummary
15+
, geModGuts :: Maybe ModGuts
16+
, geStgBinds :: Maybe [CgStgTopBinding]
17+
, geHscEnv :: Maybe HscEnv
18+
, geStubDecls :: Maybe [(ForeignStubs, StubDecl)]
19+
}
20+
21+
emptyGlobalEnv :: GlobalEnv
22+
emptyGlobalEnv
23+
= GlobalEnv
24+
{ geModSummary = Nothing
25+
, geModGuts = Nothing
26+
, geStgBinds = Nothing
27+
, geHscEnv = Nothing
28+
, geStubDecls = Nothing
29+
}
30+
31+
{-# NOINLINE globalEnvIORef #-}
32+
globalEnvIORef :: IORef GlobalEnv
33+
globalEnvIORef = unsafePerformIO $ newIORef emptyGlobalEnv

0 commit comments

Comments
 (0)