Skip to content

Commit 80e408e

Browse files
csabahruskacsabahruska
committed
move the make fullpak functionality code to library
1 parent 2674e49 commit 80e408e

File tree

3 files changed

+120
-115
lines changed

3 files changed

+120
-115
lines changed

‎external-stg/app/mkfullpak.hs

Lines changed: 10 additions & 109 deletions
Original file line numberDiff line numberDiff line change
@@ -1,126 +1,27 @@
1-
{-# LANGUAGE RecordWildCards, LambdaCase #-}
2-
3-
import Control.Monad
4-
import Control.Monad.IO.Class
5-
import Control.Monad.Catch
1+
{-# LANGUAGE RecordWildCards #-}
2+
import System.FilePath
63
import Options.Applicative
74
import Data.Semigroup ((<>))
8-
import qualified Data.ByteString.Char8 as BS8
9-
import System.FilePath
10-
import System.Directory
11-
import Codec.Archive.Zip
12-
import Codec.Archive.Zip.Unix
13-
import Text.Printf
14-
15-
import qualified Data.Map as Map
165

17-
import Stg.Program
18-
import Stg.Foreign.Linker
19-
import qualified Stg.GHC.Symbols as GHCSymbols
6+
import Stg.Fullpak
207

21-
data Fullpak
22-
= Fullpak
8+
data FullpakOptions
9+
= FullpakOptions
2310
{ ghcstgappPath :: FilePath
2411
, stgbinsOnly :: Bool
2512
, includeAll :: Bool
2613
}
2714

28-
fullpak :: Parser Fullpak
29-
fullpak = Fullpak
15+
fullpak :: Parser FullpakOptions
16+
fullpak = FullpakOptions
3017
<$> argument str (metavar "FILE" <> help "The .ghc_stgapp file that will be packed")
3118
<*> switch (short 's' <> long "stgbins-only" <> help "Packs the module.stgbin files only")
3219
<*> switch (short 'a' <> long "include-all" <> help "Includes all progam and library modules (without dead module elimination)")
3320

34-
getModuleList :: [StgModuleInfo] -> IO [FilePath]
35-
getModuleList modinfoList = do
36-
putStrLn $ "all modules: " ++ show (length modinfoList)
37-
forM modinfoList $ \StgModuleInfo{..} -> do
38-
printf "%-60s %s\n" modPackageName modModuleName
39-
pure modModpakPath
40-
4121
main :: IO ()
4222
main = do
4323
let opts = info (fullpak <**> helper) mempty
44-
Fullpak{..} <- execParser opts
45-
46-
-- mk .fullpak
47-
modinfoList <- getAppModuleMapping ghcstgappPath
48-
appModpaks <- if includeAll
49-
then getModuleList modinfoList
50-
else collectProgramModules (map modModpakPath modinfoList) "main" "Main" GHCSymbols.liveSymbols
51-
52-
let modpakMap = Map.fromList [(modModpakPath m , m) | m <- modinfoList]
53-
fullpakModules = [modpakMap Map.! m | m <- appModpaks]
54-
fullpakName = ghcstgappPath -<.> ".fullpak"
55-
56-
-- collect license info
57-
StgAppLicenseInfo{..} <- getAppLicenseInfo ghcstgappPath
58-
59-
-- collect cbits sources
60-
cbitsSourceInfos <- getAppForeignFiles ghcstgappPath
61-
62-
-- link cbits.so
63-
workDir <- getExtStgWorkDirectory ghcstgappPath
64-
let soName = workDir </> "cbits.so"
65-
doesFileExist soName >>= \case
66-
True -> do
67-
putStrLn "using existing cbits.so"
68-
False -> do
69-
putStrLn "linking cbits.so"
70-
linkForeignCbitsSharedLib ghcstgappPath
71-
72-
putStrLn $ "creating " ++ fullpakName
73-
createArchive fullpakName $ do
74-
-- top level info
75-
let content = BS8.pack $ unlines
76-
[ "modules:", printSection $ map modModuleName fullpakModules
77-
]
78-
appinfo <- mkEntrySelector "app.info"
79-
addEntry Deflate content appinfo
80-
setExternalFileAttrs (fromFileMode 0o0644) appinfo
81-
82-
-- add .ghc_stgapp to .fullpak
83-
app_ghcstgapp <- mkEntrySelector "app.ghc_stgapp"
84-
loadEntry Deflate app_ghcstgapp ghcstgappPath
85-
setExternalFileAttrs (fromFileMode 0o0644) app_ghcstgapp
86-
87-
-- copy license info
88-
forM_ stgappUnitConfs $ \unitConf -> do
89-
add (".package-db-and-license-info" </> takeFileName unitConf) unitConf
90-
91-
-- copy cbits sources
92-
forM_ cbitsSourceInfos $ \StgAppForeignSourceInfo{..} -> do
93-
add ("cbits-source" </> stgForeignUnitId </> stgForeignSourceRelPath) stgForeignSourceAbsPath
94-
95-
-- copy cbits.so and related files
96-
add "cbits/cbits.so" soName
97-
add "cbits/cbits.so.sh" (soName ++ ".sh")
98-
add "cbits/stub.c" (workDir </> "stub.c")
99-
100-
-- copy module content
101-
forM_ fullpakModules $ \StgModuleInfo{..} -> do
102-
let files =
103-
[ "module.stgbin"
104-
] ++ if stgbinsOnly then [] else
105-
[ "module.ghcstg"
106-
, "module.fullcore-hi"
107-
, "module.ghccore"
108-
, "module.hs"
109-
, "module.cmm"
110-
, "module.s"
111-
, "module.info"
112-
, "module_stub.h"
113-
, "module_stub.c"
114-
, "module_capi_stub.o"
115-
]
116-
existingFiles <- withArchive modModpakPath $ mapM mkEntrySelector files >>= filterM doesEntryExist
117-
forM_ existingFiles $ \src -> do
118-
dst <- mkEntrySelector (modModuleName </> unEntrySelector src)
119-
copyEntry modModpakPath src dst
120-
setExternalFileAttrs (fromFileMode 0o0644) dst
24+
FullpakOptions{..} <- execParser opts
25+
let fullpakName = ghcstgappPath -<.> ".fullpak"
12126

122-
add :: FilePath -> FilePath -> ZipArchive ()
123-
add zipPath srcPath = do
124-
entry <- mkEntrySelector zipPath
125-
loadEntry Zstd entry srcPath
126-
setExternalFileAttrs (fromFileMode 0o0644) entry
27+
mkFullpak ghcstgappPath stgbinsOnly includeAll fullpakName

‎external-stg/external-stg.cabal

Lines changed: 2 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ library
1818
Stg.IRLocation
1919
Stg.Reconstruct
2020
Stg.Deconstruct
21+
Stg.Fullpak
2122
Stg.Program
2223
Stg.IO
2324
Stg.GHC.Symbols
@@ -83,12 +84,7 @@ executable mkfullpak
8384
hs-source-dirs: app
8485
main-is: mkfullpak.hs
8586
build-depends: base
86-
, containers
87-
, exceptions
88-
, optparse-applicative
8987
, filepath
90-
, directory
91-
, bytestring
92-
, zip
88+
, optparse-applicative
9389
, external-stg
9490
default-language: Haskell2010

‎external-stg/lib/Stg/Fullpak.hs

Lines changed: 108 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,108 @@
1+
{-# LANGUAGE RecordWildCards, LambdaCase #-}
2+
module Stg.Fullpak
3+
( mkFullpak
4+
) where
5+
6+
import Control.Monad
7+
import qualified Data.ByteString.Char8 as BS8
8+
import System.FilePath
9+
import System.Directory
10+
import Codec.Archive.Zip
11+
import Codec.Archive.Zip.Unix
12+
import Text.Printf
13+
14+
import qualified Data.Map as Map
15+
16+
import Stg.Program
17+
import Stg.Foreign.Linker
18+
import qualified Stg.GHC.Symbols as GHCSymbols
19+
20+
getModuleList :: [StgModuleInfo] -> IO [FilePath]
21+
getModuleList modinfoList = do
22+
putStrLn $ "all modules: " ++ show (length modinfoList)
23+
forM modinfoList $ \StgModuleInfo{..} -> do
24+
printf "%-60s %s\n" modPackageName modModuleName
25+
pure modModpakPath
26+
27+
add :: FilePath -> FilePath -> ZipArchive ()
28+
add zipPath srcPath = do
29+
entry <- mkEntrySelector zipPath
30+
loadEntry Zstd entry srcPath
31+
setExternalFileAttrs (fromFileMode 0o0644) entry
32+
33+
mkFullpak :: FilePath -> Bool -> Bool -> FilePath -> IO ()
34+
mkFullpak ghcstgappPath stgbinsOnly includeAll fullpakName = do
35+
-- mk .fullpak
36+
modinfoList <- getAppModuleMapping ghcstgappPath
37+
appModpaks <- if includeAll
38+
then getModuleList modinfoList
39+
else collectProgramModules (map modModpakPath modinfoList) "main" "Main" GHCSymbols.liveSymbols
40+
41+
let modpakMap = Map.fromList [(modModpakPath m , m) | m <- modinfoList]
42+
fullpakModules = [modpakMap Map.! m | m <- appModpaks]
43+
44+
-- collect license info
45+
StgAppLicenseInfo{..} <- getAppLicenseInfo ghcstgappPath
46+
47+
-- collect cbits sources
48+
cbitsSourceInfos <- getAppForeignFiles ghcstgappPath
49+
50+
-- link cbits.so
51+
workDir <- getExtStgWorkDirectory ghcstgappPath
52+
let soName = workDir </> "cbits.so"
53+
doesFileExist soName >>= \case
54+
True -> do
55+
putStrLn "using existing cbits.so"
56+
False -> do
57+
putStrLn "linking cbits.so"
58+
linkForeignCbitsSharedLib ghcstgappPath
59+
60+
putStrLn $ "creating " ++ fullpakName
61+
createArchive fullpakName $ do
62+
-- top level info
63+
let content = BS8.pack $ unlines
64+
[ "modules:", printSection $ map modModuleName fullpakModules
65+
]
66+
appinfo <- mkEntrySelector "app.info"
67+
addEntry Deflate content appinfo
68+
setExternalFileAttrs (fromFileMode 0o0644) appinfo
69+
70+
-- add .ghc_stgapp to .fullpak
71+
app_ghcstgapp <- mkEntrySelector "app.ghc_stgapp"
72+
loadEntry Deflate app_ghcstgapp ghcstgappPath
73+
setExternalFileAttrs (fromFileMode 0o0644) app_ghcstgapp
74+
75+
-- copy license info
76+
forM_ stgappUnitConfs $ \unitConf -> do
77+
add (".package-db-and-license-info" </> takeFileName unitConf) unitConf
78+
79+
-- copy cbits sources
80+
forM_ cbitsSourceInfos $ \StgAppForeignSourceInfo{..} -> do
81+
add ("cbits-source" </> stgForeignUnitId </> stgForeignSourceRelPath) stgForeignSourceAbsPath
82+
83+
-- copy cbits.so and related files
84+
add "cbits/cbits.so" soName
85+
add "cbits/cbits.so.sh" (soName ++ ".sh")
86+
add "cbits/stub.c" (workDir </> "stub.c")
87+
88+
-- copy module content
89+
forM_ fullpakModules $ \StgModuleInfo{..} -> do
90+
let files =
91+
[ "module.stgbin"
92+
] ++ if stgbinsOnly then [] else
93+
[ "module.ghcstg"
94+
, "module.fullcore-hi"
95+
, "module.ghccore"
96+
, "module.hs"
97+
, "module.cmm"
98+
, "module.s"
99+
, "module.info"
100+
, "module_stub.h"
101+
, "module_stub.c"
102+
, "module_capi_stub.o"
103+
]
104+
existingFiles <- withArchive modModpakPath $ mapM mkEntrySelector files >>= filterM doesEntryExist
105+
forM_ existingFiles $ \src -> do
106+
dst <- mkEntrySelector (modModuleName </> unEntrySelector src)
107+
copyEntry modModpakPath src dst
108+
setExternalFileAttrs (fromFileMode 0o0644) dst

0 commit comments

Comments
 (0)