tweag/asterius
1
1
Fork 0
mirror of https://github.com/tweag/asterius.git synced 2024-09-19 21:07:55 +03:00
Code Issues Projects Releases Wiki Activity

Remove redundant unit-id related logic & misc other ahc-boot fixes (#768)

Browse Source
This commit is contained in:
Cheng Shao 2020-09-01 00:40:06 +02:00 committed by GitHub
parent cd8cd8f665
commit ff2fdcc5b4
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
7 changed files with 111 additions and 203 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
asterius/app/ahc-cabal.hs
View File

@ -22,7 +22,7 @@ main = do
<> ahcAr
<> "\nwith-compiler: "
<> ahc
<> "\nwith-hc-pkg:"
<> "\nwith-hc-pkg: "
<> ahcPkg
<> "\n"
<> ahc_cabal_config

83
asterius/boot.sh
View File

@ -1,77 +1,92 @@
#!/bin/sh -e
#!/bin/bash
set -euo pipefail
cp -r $ASTERIUS_BOOT_LIBS_DIR .
cd boot-libs
pushd boot-libs
cd ghc-prim
$ASTERIUS_SETUP_GHC_PRIM configure --prefix=$ASTERIUS_LIB_DIR --global --builddir=$ASTERIUS_TMP_DIR/dist/ghc-prim --with-ghc=$ASTERIUS_AHC --with-ghc-pkg=$ASTERIUS_AHCPKG --with-ar=$ASTERIUS_AR $ASTERIUS_CONFIGURE_OPTIONS
pushd ghc-prim
$ASTERIUS_SETUP_GHC_PRIM configure --builddir=$ASTERIUS_TMP_DIR/dist/ghc-prim $ASTERIUS_CONFIGURE_OPTIONS
$ASTERIUS_SETUP_GHC_PRIM build -j --builddir=$ASTERIUS_TMP_DIR/dist/ghc-prim
$ASTERIUS_SETUP_GHC_PRIM install --builddir=$ASTERIUS_TMP_DIR/dist/ghc-prim
cd ..
popd
cd integer-simple
ahc-cabal act-as-setup --build-type=Simple -- configure --prefix=$ASTERIUS_LIB_DIR --global --builddir=$ASTERIUS_TMP_DIR/dist/integer-simple --with-ghc=$ASTERIUS_AHC --with-ghc-pkg=$ASTERIUS_AHCPKG --with-ar=$ASTERIUS_AR $ASTERIUS_CONFIGURE_OPTIONS
pushd integer-simple
ahc-cabal act-as-setup --build-type=Simple -- configure --builddir=$ASTERIUS_TMP_DIR/dist/integer-simple $ASTERIUS_CONFIGURE_OPTIONS
ahc-cabal act-as-setup --build-type=Simple -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/integer-simple
ahc-cabal act-as-setup --build-type=Simple -- install --builddir=$ASTERIUS_TMP_DIR/dist/integer-simple
cd ..
popd
cd base
pushd base
autoreconf -i
ahc-cabal act-as-setup --build-type=Configure -- configure --prefix=$ASTERIUS_LIB_DIR --global --builddir=$ASTERIUS_TMP_DIR/dist/base --with-ghc=$ASTERIUS_AHC --with-ghc-pkg=$ASTERIUS_AHCPKG --with-ar=$ASTERIUS_AR -finteger-simple $ASTERIUS_CONFIGURE_OPTIONS
ahc-cabal act-as-setup --build-type=Configure -- configure --builddir=$ASTERIUS_TMP_DIR/dist/base -finteger-simple $ASTERIUS_CONFIGURE_OPTIONS
ahc-cabal act-as-setup --build-type=Configure -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/base
ahc-cabal act-as-setup --build-type=Configure -- install --builddir=$ASTERIUS_TMP_DIR/dist/base
cd ..
popd
cd ghc-heap
ahc-cabal act-as-setup --build-type=Simple -- configure --prefix=$ASTERIUS_LIB_DIR --global --builddir=$ASTERIUS_TMP_DIR/dist/ghc-heap --with-ghc=$ASTERIUS_AHC --with-ghc-pkg=$ASTERIUS_AHCPKG --with-ar=$ASTERIUS_AR $ASTERIUS_CONFIGURE_OPTIONS
pushd ghc-heap
ahc-cabal act-as-setup --build-type=Simple -- configure --builddir=$ASTERIUS_TMP_DIR/dist/ghc-heap $ASTERIUS_CONFIGURE_OPTIONS
ahc-cabal act-as-setup --build-type=Simple -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/ghc-heap
ahc-cabal act-as-setup --build-type=Simple -- install --builddir=$ASTERIUS_TMP_DIR/dist/ghc-heap
cd ..
popd
cd ghc-boot-th
ahc-cabal act-as-setup --build-type=Simple -- configure --prefix=$ASTERIUS_LIB_DIR --global --builddir=$ASTERIUS_TMP_DIR/dist/ghc-boot-th --with-ghc=$ASTERIUS_AHC --with-ghc-pkg=$ASTERIUS_AHCPKG --with-ar=$ASTERIUS_AR $ASTERIUS_CONFIGURE_OPTIONS
pushd ghc-boot-th
ahc-cabal act-as-setup --build-type=Simple -- configure --builddir=$ASTERIUS_TMP_DIR/dist/ghc-boot-th $ASTERIUS_CONFIGURE_OPTIONS
ahc-cabal act-as-setup --build-type=Simple -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/ghc-boot-th
ahc-cabal act-as-setup --build-type=Simple -- install --builddir=$ASTERIUS_TMP_DIR/dist/ghc-boot-th
cd ..
popd
ahc-cabal v1-update || true
ahc-cabal v1-install --only-dependencies $ASTERIUS_CONFIGURE_OPTIONS \
unix
pushd $(mktemp -d)
ahc-cabal get unix-2.7.2.2
cd unix-2.7.2.2
ahc-cabal act-as-setup --build-type=Configure -- configure --builddir=$ASTERIUS_TMP_DIR/dist/unix --ghc-option=-this-unit-id=unix $ASTERIUS_CONFIGURE_OPTIONS
ahc-cabal act-as-setup --build-type=Configure -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/unix
ahc-cabal act-as-setup --build-type=Configure -- install --builddir=$ASTERIUS_TMP_DIR/dist/unix
popd
ahc-cabal v1-install $ASTERIUS_CONFIGURE_OPTIONS \
binary \
directory \
mtl \
pretty \
unix
pretty
cd ghc-boot
ahc-cabal act-as-setup --build-type=Simple -- configure --prefix=$ASTERIUS_LIB_DIR --global --builddir=$ASTERIUS_TMP_DIR/dist/ghc-boot --with-ghc=$ASTERIUS_AHC --with-ghc-pkg=$ASTERIUS_AHCPKG --with-ar=$ASTERIUS_AR $ASTERIUS_CONFIGURE_OPTIONS
pushd ghc-boot
ahc-cabal act-as-setup --build-type=Simple -- configure --builddir=$ASTERIUS_TMP_DIR/dist/ghc-boot $ASTERIUS_CONFIGURE_OPTIONS
ahc-cabal act-as-setup --build-type=Simple -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/ghc-boot
ahc-cabal act-as-setup --build-type=Simple -- install --builddir=$ASTERIUS_TMP_DIR/dist/ghc-boot
cd ..
popd
cd template-haskell
ahc-cabal act-as-setup --build-type=Simple -- configure --prefix=$ASTERIUS_LIB_DIR --global --builddir=$ASTERIUS_TMP_DIR/dist/template-haskell --with-ghc=$ASTERIUS_AHC --with-ghc-pkg=$ASTERIUS_AHCPKG --with-ar=$ASTERIUS_AR $ASTERIUS_CONFIGURE_OPTIONS
pushd template-haskell
ahc-cabal act-as-setup --build-type=Simple -- configure --builddir=$ASTERIUS_TMP_DIR/dist/template-haskell $ASTERIUS_CONFIGURE_OPTIONS
ahc-cabal act-as-setup --build-type=Simple -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/template-haskell
ahc-cabal act-as-setup --build-type=Simple -- install --builddir=$ASTERIUS_TMP_DIR/dist/template-haskell
cd ..
popd
cd ghci
ahc-cabal act-as-setup --build-type=Simple -- configure --prefix=$ASTERIUS_LIB_DIR --global --builddir=$ASTERIUS_TMP_DIR/dist/ghci --with-ghc=$ASTERIUS_AHC --with-ghc-pkg=$ASTERIUS_AHCPKG --with-ar=$ASTERIUS_AR -fghci $ASTERIUS_CONFIGURE_OPTIONS
pushd ghci
ahc-cabal act-as-setup --build-type=Simple -- configure --builddir=$ASTERIUS_TMP_DIR/dist/ghci -fghci --ghc-option=-this-unit-id=ghci $ASTERIUS_CONFIGURE_OPTIONS
ahc-cabal act-as-setup --build-type=Simple -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/ghci
ahc-cabal act-as-setup --build-type=Simple -- install --builddir=$ASTERIUS_TMP_DIR/dist/ghci
cd ..
popd
cd text
ahc-cabal act-as-setup --build-type=Simple -- configure --prefix=$ASTERIUS_LIB_DIR --global --builddir=$ASTERIUS_TMP_DIR/dist/text --with-ghc=$ASTERIUS_AHC --with-ghc-pkg=$ASTERIUS_AHCPKG --with-ar=$ASTERIUS_AR $ASTERIUS_CONFIGURE_OPTIONS
pushd text
ahc-cabal act-as-setup --build-type=Simple -- configure --builddir=$ASTERIUS_TMP_DIR/dist/text $ASTERIUS_CONFIGURE_OPTIONS
ahc-cabal act-as-setup --build-type=Simple -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/text
ahc-cabal act-as-setup --build-type=Simple -- install --builddir=$ASTERIUS_TMP_DIR/dist/text
cd ..
popd
ahc-cabal v1-install $ASTERIUS_CONFIGURE_OPTIONS \
aeson \
parsec
cd asterius-prelude
ahc-cabal act-as-setup --build-type=Simple -- configure --prefix=$ASTERIUS_LIB_DIR --global --builddir=$ASTERIUS_TMP_DIR/dist/asterius-prelude --with-ghc=$ASTERIUS_AHC --with-ghc-pkg=$ASTERIUS_AHCPKG --with-ar=$ASTERIUS_AR $ASTERIUS_CONFIGURE_OPTIONS
pushd asterius-prelude
ahc-cabal act-as-setup --build-type=Simple -- configure --builddir=$ASTERIUS_TMP_DIR/dist/asterius-prelude --ghc-option=-this-unit-id=asterius-prelude $ASTERIUS_CONFIGURE_OPTIONS
ahc-cabal act-as-setup --build-type=Simple -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/asterius-prelude
ahc-cabal act-as-setup --build-type=Simple -- install --builddir=$ASTERIUS_TMP_DIR/dist/asterius-prelude
cd ..
popd
popd

10
asterius/src/Asterius/Boot.hs
View File

@ -67,6 +67,12 @@ defaultBootArgs = BootArgs
"--disable-library-stripping",
"--enable-relocatable",
"-O2",
"--prefix=" <> (bootDir defaultBootArgs </> "asterius_lib"),
"--global",
"--ipid=$pkg",
"--with-ghc=" <> ahc,
"--with-ghc-pkg=" <> ahcPkg,
"--with-ar=" <> ahcAr,
"--ghc-option=-v1",
"--ghc-option=-dsuppress-ticks"
],
@ -80,7 +86,7 @@ bootCreateProcess :: BootArgs -> IO CreateProcess
bootCreateProcess args@BootArgs {..} = do
e <- getEnvironment
pure
(proc "sh" ["-e", "boot.sh"])
(proc "bash" ["-e", "boot.sh"])
{ cwd = Just dataDir,
env =
Just $
@ -89,9 +95,7 @@ bootCreateProcess args@BootArgs {..} = do
("ASTERIUS_SANDBOX_GHC_LIBDIR", sandboxGhcLibDir) :
("ASTERIUS_LIB_DIR", bootDir </> "asterius_lib") :
("ASTERIUS_TMP_DIR", bootTmpDir args) :
("ASTERIUS_AHC", ahc) :
("ASTERIUS_AHCPKG", ahcPkg) :
("ASTERIUS_AR", ahcAr) :
("ASTERIUS_SETUP_GHC_PRIM", setupGhcPrim) :
("ASTERIUS_CONFIGURE_OPTIONS", configureOptions) :
[(k, v) | (k, v) <- e, k /= "GHC_PACKAGE_PATH"],

42
asterius/src/Asterius/Builtins/Posix.hs
View File

@ -13,18 +13,11 @@ module Asterius.Builtins.Posix
where
import Asterius.EDSL
import Asterius.Internals.Session
import Asterius.Types
import qualified Asterius.Types.SymbolMap as SM
import Control.Exception
import Control.Monad.IO.Class
import qualified Data.ByteString as BS
import Data.Foldable
import qualified DynFlags as GHC
import qualified FastString as GHC
import Foreign
import qualified Module as GHC
import qualified Packages as GHC
import System.IO.Unsafe
import System.Posix.Internals
@ -315,15 +308,16 @@ offset_stat_mtime,
offset_stat_ino ::
Int
(offset_stat_mtime, offset_stat_size, offset_stat_mode, offset_stat_dev, offset_stat_ino) =
unsafePerformIO $ allocaBytes sizeof_stat $ \p -> do
forM_ [0 .. sizeof_stat - 1] $
\i -> pokeByteOff p i (fromIntegral i :: Word8)
_mtime <- (.&. 0xFF) . fromEnum <$> st_mtime p
_size <- (.&. 0xFF) . fromEnum <$> st_size p
_mode <- (.&. 0xFF) . fromEnum <$> st_mode p
_dev <- (.&. 0xFF) . fromEnum <$> st_dev p
_ino <- (.&. 0xFF) . fromEnum <$> st_ino p
pure (_mtime, _size, _mode, _dev, _ino)
unsafePerformIO $
allocaBytes sizeof_stat $ \p -> do
forM_ [0 .. sizeof_stat - 1] $
\i -> pokeByteOff p i (fromIntegral i :: Word8)
_mtime <- (.&. 0xFF) . fromEnum <$> st_mtime p
_size <- (.&. 0xFF) . fromEnum <$> st_size p
_mode <- (.&. 0xFF) . fromEnum <$> st_mode p
_dev <- (.&. 0xFF) . fromEnum <$> st_dev p
_ino <- (.&. 0xFF) . fromEnum <$> st_ino p
pure (_mtime, _size, _mode, _dev, _ino)
posixLockFile, posixUnlockFile :: AsteriusModule
posixLockFile = runEDSL "lockFile" $ do
@ -337,21 +331,15 @@ posixUnlockFile = runEDSL "unlockFile" $ do
{-# NOINLINE unixUnitId #-}
unixUnitId :: BS.ByteString
unixUnitId = unsafePerformIO $ fakeSession $ do
dflags <- GHC.getDynFlags
let Just comp_id = GHC.lookupPackageName dflags (GHC.PackageName "unix")
GHC.InstalledUnitId inst_unit_id =
GHC.componentIdToInstalledUnitId comp_id
liftIO $ evaluate $ GHC.fastZStringToByteString $
GHC.zEncodeFS
inst_unit_id
unixUnitId = "unix"
posixOpendir :: AsteriusModule
posixOpendir =
runEDSL
( mkEntitySymbol $ "ghczuwrapperZC0ZC"
<> unixUnitId
<> "ZCSystemziPosixziDirectoryZCopendir"
( mkEntitySymbol $
"ghczuwrapperZC0ZC"
<> unixUnitId
<> "ZCSystemziPosixziDirectoryZCopendir"
)
$ do
setReturnTypes [I64]

92
asterius/src/Asterius/GHCi/Internals.hs
View File

@ -18,7 +18,6 @@ import Asterius.Ar
import Asterius.Binary.File
import Asterius.Binary.NameCache
import Asterius.CodeGen
import Asterius.Internals.Name
import Asterius.Internals.Temp
import Asterius.JSRun.NonMain
import Asterius.Ld
@ -56,8 +55,8 @@ import qualified ErrUtils as GHC
import qualified FastString as GHC
import Foreign.Ptr
import GHC.IO.Handle.FD
import qualified GHCi.Message as GHC
import GHCi.Message
import qualified GHCi.Message as GHC
import qualified GHCi.RemoteTypes as GHC
import qualified HscMain as GHC
import qualified HscTypes as GHC
@ -261,28 +260,16 @@ asteriusWriteIServ hsc_env i a
)
}
modifyMVar_ globalGHCiState $ \s -> do
let run_q_exp_sym =
closureSymbol hsc_env "ghci" "Asterius.GHCi" "asteriusRunQExp"
run_q_pat_sym =
closureSymbol hsc_env "ghci" "Asterius.GHCi" "asteriusRunQPat"
run_q_type_sym =
closureSymbol hsc_env "ghci" "Asterius.GHCi" "asteriusRunQType"
run_q_dec_sym =
closureSymbol hsc_env "ghci" "Asterius.GHCi" "asteriusRunQDec"
let run_q_exp_sym = "ghci_AsteriusziGHCi_asteriusRunQExp_closure"
run_q_pat_sym = "ghci_AsteriusziGHCi_asteriusRunQPat_closure"
run_q_type_sym = "ghci_AsteriusziGHCi_asteriusRunQType_closure"
run_q_dec_sym = "ghci_AsteriusziGHCi_asteriusRunQDec_closure"
run_q_annwrapper_sym =
closureSymbol hsc_env "ghci" "Asterius.GHCi" "asteriusRunAnnWrapper"
"ghci_AsteriusziGHCi_asteriusRunAnnWrapper_closure"
run_mod_fin_sym =
closureSymbol
hsc_env
"ghci"
"Asterius.GHCi"
"asteriusRunModFinalizers"
"ghci_AsteriusziGHCi_asteriusRunModFinalizzers_closure"
buf_conv_sym =
closureSymbol
hsc_env
"asterius-prelude"
"Asterius.ByteString"
"byteStringFromJSUint8Array"
"asteriuszmprelude_AsteriusziByteString_byteStringFromJSUint8Array_closure"
this_id = remoteRefToInt q
(sym, m) = ghciCompiledCoreExprs s IM.! this_id
(js_s, p, _) = ghciSession s
@ -313,7 +300,6 @@ asteriusWriteIServ hsc_env i a
}
v <-
asteriusRunTH
hsc_env
i
st
(fromIntegral (staticsSymbolMap link_report ! sym))
@ -330,13 +316,12 @@ asteriusWriteIServ hsc_env i a
GHC.debugTraceMsg (GHC.hsc_dflags hsc_env) 3 $ GHC.text $ show m
withMVar globalGHCiState $ \s -> do
let (js_s, _, v) = ghciSession s
asteriusRunModFinalizers hsc_env js_s v
asteriusRunModFinalizers js_s v
GHC.Msg m -> fail $ "asteriusWriteIServ: unsupported message " <> show m
| otherwise = withMVar globalGHCiState $
\s -> let (_, p, _) = ghciSession s in writePipe p $ put a
asteriusRunTH ::
GHC.HscEnv ->
GHC.IServ ->
GHC.RemoteRef (IORef GHC.QState) ->
Word64 ->
@ -345,8 +330,8 @@ asteriusRunTH ::
Session ->
(Asterius.Types.Module, LinkReport) ->
IO JSVal
asteriusRunTH hsc_env _ _ q ty loc s ahc_dist_input =
withTempDir "asdf" $ \tmp_dir -> do
asteriusRunTH _ _ q ty loc s ahc_dist_input = withTempDir "asdf" $ \tmp_dir ->
do
let p = tmp_dir </> "asdf"
distNonMain p [runner_sym, run_mod_fin_sym, buf_conv_sym] ahc_dist_input
rts_val <- importMJS s $ p `replaceFileName` "rts.mjs"
@ -363,14 +348,14 @@ asteriusRunTH hsc_env _ _ q ty loc s ahc_dist_input =
<> toJS mod_val
<> "}))"
let runner_closure =
toJS i <> ".symbolTable.addressOf(\""
<> fromString
(CBS.unpack (entityName runner_sym))
toJS i
<> ".symbolTable.addressOf(\""
<> fromString (CBS.unpack (entityName runner_sym))
<> "\")"
buf_conv_closure =
toJS i <> ".symbolTable.addressOf(\""
<> fromString
(CBS.unpack (entityName buf_conv_sym))
toJS i
<> ".symbolTable.addressOf(\""
<> fromString (CBS.unpack (entityName buf_conv_sym))
<> "\")"
uint8_arr = "new Uint8Array(" <> toJS (encode loc) <> ")"
uint8_arr_sn =
@ -402,40 +387,32 @@ asteriusRunTH hsc_env _ _ q ty loc s ahc_dist_input =
<> ","
<> hv_closure
<> ")"
tid =
toJS i <> ".exports.rts_evalLazyIO(" <> applied_closure <> ")"
tid = toJS i <> ".exports.rts_evalLazyIO(" <> applied_closure <> ")"
eval @() s tid
evaluate i
where
runner_sym = closureSymbol hsc_env "ghci" "Asterius.GHCi" $ case ty of
GHC.THExp -> "asteriusRunQExp"
GHC.THPat -> "asteriusRunQPat"
GHC.THType -> "asteriusRunQType"
GHC.THDec -> "asteriusRunQDec"
GHC.THAnnWrapper -> "asteriusRunAnnWrapper"
run_mod_fin_sym =
closureSymbol hsc_env "ghci" "Asterius.GHCi" "asteriusRunModFinalizers"
runner_sym = case ty of
GHC.THExp -> "ghci_AsteriusziGHCi_asteriusRunQExp_closure"
GHC.THPat -> "ghci_AsteriusziGHCi_asteriusRunQPat_closure"
GHC.THType -> "ghci_AsteriusziGHCi_asteriusRunQType_closure"
GHC.THDec -> "ghci_AsteriusziGHCi_asteriusRunQDec_closure"
GHC.THAnnWrapper -> "ghci_AsteriusziGHCi_asteriusRunAnnWrapper_closure"
run_mod_fin_sym = "ghci_AsteriusziGHCi_asteriusRunModFinalizzers_closure"
buf_conv_sym =
closureSymbol
hsc_env
"asterius-prelude"
"Asterius.ByteString"
"byteStringFromJSUint8Array"
"asteriuszmprelude_AsteriusziByteString_byteStringFromJSUint8Array_closure"
asteriusRunModFinalizers :: GHC.HscEnv -> Session -> JSVal -> IO ()
asteriusRunModFinalizers hsc_env s i = do
asteriusRunModFinalizers :: Session -> JSVal -> IO ()
asteriusRunModFinalizers s i = do
let run_mod_fin_closure =
toJS i <> ".symbolTable.addressOf(\""
<> fromString
(CBS.unpack (entityName run_mod_fin_sym))
toJS i
<> ".symbolTable.addressOf(\""
<> fromString (CBS.unpack (entityName run_mod_fin_sym))
<> "\")"
tid =
toJS i <> ".exports.rts_evalLazyIO(" <> run_mod_fin_closure <> ")"
tid = toJS i <> ".exports.rts_evalLazyIO(" <> run_mod_fin_closure <> ")"
eval @() s tid
pure ()
where
run_mod_fin_sym =
closureSymbol hsc_env "ghci" "Asterius.GHCi" "asteriusRunModFinalizers"
run_mod_fin_sym = "ghci_AsteriusziGHCi_asteriusRunModFinalizzers_closure"
-- | Compiles the 'GHC.CoreExpr' of a 'Q' splice to Cmm, then unlinked Wasm, and
-- returns the associated id as a 'GHC.ForeignHValue'. This is invoked by GHC
@ -544,9 +521,6 @@ linkPkg hsc_env pkg_name =
Just comp_id =
GHC.lookupPackageName (GHC.hsc_dflags hsc_env) (GHC.PackageName pkg_name)
closureSymbol :: GHC.HscEnv -> String -> String -> String -> EntitySymbol
closureSymbol hsc_env = fakeClosureSymbol (GHC.hsc_dflags hsc_env)
intToRemoteRef :: Int -> GHC.RemoteRef a
intToRemoteRef = unsafeCoerce . GHC.toRemotePtr . intPtrToPtr . coerce

48
asterius/src/Asterius/Internals/Name.hs
View File

@ -1,6 +1,5 @@
module Asterius.Internals.Name
( fakeClosureSymbol,
idClosureSymbol,
( idClosureSymbol,
)
where
@ -9,47 +8,12 @@ import Asterius.TypesConv
import qualified CLabel as GHC
import Data.String
import qualified DynFlags as GHC
import qualified FastString as GHC
import qualified Id as GHC
import qualified IdInfo as GHC
import qualified Module as GHC
import qualified Name as GHC
import qualified Packages as GHC
import qualified SrcLoc as GHC
import qualified Unique as GHC
fakeName ::
GHC.DynFlags ->
GHC.PackageName ->
GHC.ModuleName ->
GHC.OccName ->
GHC.Name
fakeName dflags pkg_name mod_name occ_name = name
where
dummy_uniq = GHC.mkUniqueGrimily 0
Just comp_id = GHC.lookupPackageName dflags pkg_name
inst_unit_id = GHC.componentIdToInstalledUnitId comp_id
Just pkg_conf = GHC.lookupInstalledPackage dflags inst_unit_id
unit_id = GHC.packageConfigId pkg_conf
m = GHC.mkModule unit_id mod_name
name = GHC.mkExternalName dummy_uniq m occ_name GHC.noSrcSpan
fakeClosureSymbol ::
GHC.DynFlags -> String -> String -> String -> EntitySymbol
fakeClosureSymbol dflags pkg_name mod_name occ_name = sym
where
name =
fakeName
dflags
(GHC.PackageName (GHC.mkFastString pkg_name))
(GHC.mkModuleName mod_name)
(GHC.mkVarOcc occ_name)
clbl = GHC.mkClosureLabel name GHC.MayHaveCafRefs
sym = fromString $ asmPpr dflags clbl
idClosureSymbol :: GHC.DynFlags -> GHC.Id -> EntitySymbol
idClosureSymbol dflags n =
fromString $ asmPpr dflags $
GHC.mkClosureLabel
(GHC.idName n)
(GHC.idCafInfo n)
fromString $
asmPpr dflags $
GHC.mkClosureLabel
(GHC.idName n)
(GHC.idCafInfo n)

37
asterius/src/Asterius/Internals/Session.hs
View File

@ -1,37 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Asterius.Internals.Session
( fakeSession,
)
where
import qualified Asterius.BuildInfo as A
import qualified Config as GHC
import Control.Monad
import Data.Foldable
import Data.List
import qualified DynFlags as GHC
import qualified GHC
import System.Environment.Blank
import System.FilePath
fakeSession :: GHC.Ghc r -> IO r
fakeSession m = do
ks <-
filter (\k -> ("GHC_" `isPrefixOf` k) || "HASKELL_" `isPrefixOf` k)
. map fst
<$> getEnvironment
for_ ks unsetEnv
GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut
$ GHC.runGhc (Just (A.dataDir </> ".boot" </> "asterius_lib"))
$ do
dflags0 <- GHC.getSessionDynFlags
void $
GHC.setSessionDynFlags
dflags0
{ GHC.ghcMode = GHC.CompManager,
GHC.hscTarget = GHC.HscAsm,
GHC.integerLibrary = GHC.IntegerSimple,
GHC.tablesNextToCode = False
}
m