1
1
mirror of https://github.com/tweag/asterius.git synced 2024-10-05 13:17:19 +03:00

Misc simplifications (#870)

This commit is contained in:
Cheng Shao 2021-10-21 06:29:36 -07:00 committed by GitHub
parent e0c6b9548f
commit 9f2574d9c2
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
43 changed files with 44 additions and 3507 deletions

View File

@ -2,7 +2,6 @@
[![Docker Pulls](https://img.shields.io/docker/pulls/terrorjack/asterius.svg)](https://hub.docker.com/r/terrorjack/asterius)
![](https://github.com/tweag/asterius/workflows/pipeline/badge.svg?branch=master)
[![Gitter](https://img.shields.io/gitter/room/tweag/asterius)](https://gitter.im/tweag/asterius)
[![Netlify Status](https://api.netlify.com/api/v1/badges/e7cfe6ef-b0e6-4a17-bd74-8bce6063f147/deploy-status)](https://asterius.netlify.app)
Asterius is a Haskell to WebAssembly compiler based on GHC. It compiles

View File

@ -22,12 +22,7 @@ parseLinkTask args = do
linkModule = mempty,
hasMain = "--no-main" `notElem` args,
debug = "--debug" `elem` args,
gcSections = "--no-gc-sections" `notElem` args,
verboseErr = "--verbose-err" `elem` args,
pic = "--pic" `elem` args,
outputIR =
find ("--output-ir=" `isPrefixOf`) args
>>= stripPrefix "--output-ir=",
rootSymbols = map fromString $ str_args "--extra-root-symbol=",
exportFunctions =
("main" :) $ map fromString $

View File

@ -65,7 +65,6 @@ dependencies:
- mtl
- process
- transformers
- wasm-toolkit
internal-libraries:
asterius-types:

View File

@ -221,10 +221,6 @@ export async function newAsteriusInstance(req) {
);
return WebAssembly.instantiate(req.module, importObject).then(i => {
if (req.pic) {
i.exports.__wasm_apply_relocs();
}
__asterius_wasi.initialize(i);
Object.assign(__asterius_exports, i.exports);

View File

@ -34,7 +34,6 @@ module Asterius.Types.SymbolMap
insert,
-- * Filtering
filterWithKey,
filter,
restrictKeys,
@ -42,7 +41,6 @@ module Asterius.Types.SymbolMap
foldrWithKey',
mapWithKey,
mapAccum,
mapKeys,
-- * Conversion
elems,
@ -55,7 +53,6 @@ module Asterius.Types.SymbolMap
-- ** Maps
toMap,
fromMap,
)
where
@ -146,12 +143,6 @@ lookup k (SymbolMap m) = snd <$> IM.lookup (getKeyES k) m
infixl 9 !
-- | /O(n)/. Filter all keys/values that satisfy some predicate. NOTE: since we
-- use 'Key' for indexing and not 'EntitySymbol', the filtering happens on the
-- elements alone (which contain the corresponding 'EntitySymbol').
filterWithKey :: (EntitySymbol -> a -> Bool) -> SymbolMap a -> SymbolMap a
filterWithKey p (SymbolMap m) = SymbolMap $ IM.filter (uncurry p) m
-- | The restriction of a map to the keys in a set.
restrictKeys :: SymbolMap a -> SS.SymbolSet -> SymbolMap a
restrictKeys (SymbolMap m) s = SymbolMap $ IM.restrictKeys m (SS.toIntSet s)
@ -195,13 +186,6 @@ foldrWithKey' f z (SymbolMap m) = IM.foldrWithKey' (\_ (k, e) b -> f k e b) z m
filter :: (a -> Bool) -> SymbolMap a -> SymbolMap a
filter p (SymbolMap m) = SymbolMap $ IM.filter (p . snd) m
-- | /O(n*log n)/. Apply a function to each key in a map. The size of the
-- result may be smaller if two old 'EntitySymbol's are mapped to the same new
-- 'EntitySymbol'. In this case the value at the greates of the original keys
-- is retained.
mapKeys :: (EntitySymbol -> EntitySymbol) -> SymbolMap a -> SymbolMap a
mapKeys fn = fromListSM . (map (\(k, e) -> (fn k, e))) . toListSM
-- GEORGE: Given that EntitySymbol appears both in a co- and a contra- variant
-- position in the function, there is no direct way to utilize IM.mapKeys for
-- implementing mapKeys (getUnique is irreversible). TODO: reduce usage.
@ -235,8 +219,3 @@ toListSM (SymbolMap m) = IM.elems m
{-# INLINE toMap #-}
toMap :: SymbolMap a -> Map.Map EntitySymbol a
toMap = Map.fromList . toListSM
-- | /O(n*log n)/. Build a symbol map from a 'Map.Map'.
{-# INLINE fromMap #-}
fromMap :: Map.Map EntitySymbol a -> SymbolMap a
fromMap = fromListSM . Map.toList

View File

@ -18,13 +18,10 @@ module Asterius.Backends.Binaryen
( MarshalError (..),
marshalModule,
serializeModule,
serializeModuleSExpr,
setColorsEnabled,
)
where
import Asterius.Backends.Binaryen.CheckOverlapDataSegment
import Asterius.EDSL (mkDynamicDataAddress, mkDynamicFunctionAddress)
import qualified Asterius.Internals.Arena as A
import Asterius.Internals.Barf
import Asterius.Internals.MagicNumber
@ -254,12 +251,8 @@ data MarshalEnv = MarshalEnv
envLibCFuncNames :: Set.Set BS.ByteString,
-- | The 'A.Arena' for allocating temporary buffers.
envArena :: A.Arena,
-- | Whether the @pic@ extension is on.
envIsPicOn :: Bool,
-- | Whether the @verbose_err@ extension is on.
envIsVerboseErrOn :: Bool,
-- | Whether the tail call extension is on.
envAreTailCallsOn :: Bool,
-- | The offset map for the current module (statics).
envStaticsOffsetMap :: SM.SymbolMap Word32,
-- | The offset map for the current module (functions).
@ -275,18 +268,10 @@ type CodeGen a = ReaderT MarshalEnv IO a
askArena :: CodeGen A.Arena
askArena = reader envArena
-- | Check whether the @verbose_err@ extension is on.
isPicOn :: CodeGen Bool
isPicOn = reader envIsPicOn
-- | Check whether the @verbose_err@ extension is on.
isVerboseErrOn :: CodeGen Bool
isVerboseErrOn = reader envIsVerboseErrOn
-- | Check whether the tail call extension is on.
areTailCallsOn :: CodeGen Bool
areTailCallsOn = reader envAreTailCallsOn
-- | Retrieve the offset map from the local environment (statics).
askStaticsOffsetMap :: CodeGen (SM.SymbolMap Word32)
askStaticsOffsetMap = reader envStaticsOffsetMap
@ -458,28 +443,15 @@ marshalExpression e' = do
x <- marshalExpression dropValue
m <- askModuleRef
lift $ Binaryen.drop m x
ReturnCall {..} -> areTailCallsOn >>= \case
-- Case 1: Tail calls are on
True -> do
m <- askModuleRef
a <- askArena
lift $ do
dst <- marshalBS a (entityName returnCallTarget64)
Binaryen.returnCall m dst nullPtr 0 Binaryen.none
-- Case 2: Tail calls are off
False -> do
ReturnCall {..} -> do
fn_off_map <- askFunctionsOffsetMap
case SM.lookup returnCallTarget64 fn_off_map of
Just off -> do
pic_is_on <- isPicOn
s <-
marshalExpression
SetGlobal
{ globalSymbol = "__asterius_pc",
value =
if pic_is_on
then mkDynamicFunctionAddress off
else ConstI64 $ mkStaticFunctionAddress off
value = ConstI64 $ mkStaticFunctionAddress off
}
m <- askModuleRef
a <- askArena
@ -488,26 +460,7 @@ marshalExpression e' = do
(arr, _) <- marshalV a [s, r]
Binaryen.block m (coerce nullPtr) arr 2 Binaryen.none
Nothing -> marshalExpression $ barf (entityName returnCallTarget64) []
ReturnCallIndirect {..} -> areTailCallsOn >>= \case
-- Case 1: Tail calls are on
True -> do
t <-
marshalExpression
Unary
{ unaryOp = WrapInt64,
operand0 = returnCallIndirectTarget64
}
m <- askModuleRef
lift $
Binaryen.returnCallIndirect
m
t
nullPtr
0
Binaryen.none
Binaryen.none
-- Case 2: Tail calls are off
False -> do
ReturnCallIndirect {..} -> do
s <-
marshalExpression
SetGlobal
@ -528,7 +481,6 @@ marshalExpression e' = do
lift $ Binaryen.Expression.unreachable m
CFG {..} -> relooperRun graph
Symbol {..} -> do
pic_is_on <- isPicOn
verbose_err <- isVerboseErrOn
ss_off_map <- askStaticsOffsetMap
fn_off_map <- askFunctionsOffsetMap
@ -536,14 +488,10 @@ marshalExpression e' = do
m <- askModuleRef
if | Just off <- SM.lookup unresolvedSymbol ss_off_map ->
marshalExpression $
if pic_is_on
then mkDynamicDataAddress $ off + fromIntegral symbolOffset
else ConstI64 $ mkStaticDataAddress memory_base $ off + fromIntegral symbolOffset
ConstI64 $ mkStaticDataAddress memory_base $ off + fromIntegral symbolOffset
| Just off <- SM.lookup unresolvedSymbol fn_off_map ->
marshalExpression $
if pic_is_on
then mkDynamicFunctionAddress $ off + fromIntegral symbolOffset
else ConstI64 $ mkStaticFunctionAddress $ off + fromIntegral symbolOffset
ConstI64 $ mkStaticFunctionAddress $ off + fromIntegral symbolOffset
| verbose_err ->
marshalExpression $ barf (entityName unresolvedSymbol) [I64]
| otherwise ->
@ -694,26 +642,21 @@ marshalGlobal k Global {..} = do
Binaryen.addGlobal m ptr ty mut e
marshalModule ::
Bool ->
Bool ->
Bool ->
SM.SymbolMap Word32 ->
SM.SymbolMap Word32 ->
Word32 ->
Module ->
IO Binaryen.Module
marshalModule pic_on verbose_err tail_calls ss_off_map fn_off_map last_data_offset hs_mod@Module {..} = do
marshalModule verbose_err ss_off_map fn_off_map last_data_offset hs_mod@Module {..} = do
(m, memory_base) <- do
(bs, memory_base) <- wizer last_data_offset
BS.writeFile "wizer.output.wasm" bs
m <- BS.unsafeUseAsCStringLen bs $
\(p, l) -> Binaryen.Module.read p (fromIntegral l)
pure (m, memory_base)
checkOverlapDataSegment m
Binaryen.setFeatures m
$ foldl1' (.|.)
$ [Binaryen.tailCall | tail_calls]
<> [Binaryen.mvp]
$ foldl1' (.|.) [Binaryen.mvp]
A.with $ \a -> do
libc_func_names <- binaryenModuleExportNames m
for_ libc_func_names $
@ -727,9 +670,7 @@ marshalModule pic_on verbose_err tail_calls ss_off_map fn_off_map last_data_offs
{ envLibCFuncInfo = libc_func_info,
envLibCFuncNames = Set.fromList $ map fst libc_func_names,
envArena = a,
envIsPicOn = pic_on,
envIsVerboseErrOn = verbose_err,
envAreTailCallsOn = tail_calls,
envStaticsOffsetMap = ss_off_map,
envFunctionsOffsetMap = fn_off_map,
envMemoryBase = memory_base,
@ -754,7 +695,7 @@ marshalModule pic_on verbose_err tail_calls ss_off_map fn_off_map last_data_offs
Just tbl_import -> marshalTableImport m tbl_import
_ -> pure ()
marshalMemorySegments memorySegments
unless pic_on $ lift $ checkOverlapDataSegment m
lift $ checkOverlapDataSegment m
case memoryImport of
Just mem_import -> marshalMemoryImport m mem_import
_ -> pure ()
@ -812,13 +753,6 @@ serializeModule m = alloca $ \(buf_p :: Ptr (Ptr ())) ->
len <- peek len_p
BS.unsafePackMallocCStringLen (castPtr buf, fromIntegral len)
serializeModuleSExpr :: Binaryen.Module -> IO BS.ByteString
serializeModuleSExpr m =
Binaryen.allocateAndWriteText m >>= BS.unsafePackCString
setColorsEnabled :: Bool -> IO ()
setColorsEnabled b = Binaryen.setColorsEnabled . toEnum . fromEnum $ b
binaryenTypeToValueType :: Binaryen.Type -> ValueType
binaryenTypeToValueType ty =
case lookup

View File

@ -1,7 +1,6 @@
module Asterius.Binary.ByteString
( tryGetBS,
getBS,
putBS,
)
where
@ -32,9 +31,3 @@ tryGetBS ::
BS.ByteString ->
IO (Either SomeException a)
tryGetBS ncu = try . getBS ncu
putBS :: GHC.Binary a => a -> IO BS.ByteString
putBS a = do
bh <- GHC.openBinMem 1048576
GHC.putWithUserData (const (pure ())) bh a
GHC.withBinBuffer bh $ evaluate . BS.copy

View File

@ -11,7 +11,6 @@ module Asterius.Builtins
rtsGlobalImports,
rtsGlobalExports,
emitErrorMessage,
wasmPageSize,
generateWrapperFunction,
ShouldSext (..),
genWrap,
@ -44,9 +43,6 @@ import Data.String
import Data.Word
import Language.Haskell.GHC.Toolkit.Constants
wasmPageSize :: Int
wasmPageSize = 65536
data BuiltinsOptions
= BuiltinsOptions
{ progName :: String,
@ -549,8 +545,8 @@ rtsFunctionImports debug =
<> primitiveImports
<> barfImports
rtsFunctionExports :: Bool -> Bool -> [FunctionExport]
rtsFunctionExports pic debug =
rtsFunctionExports :: Bool -> [FunctionExport]
rtsFunctionExports debug =
[ FunctionExport {internalName = f <> "_wrapper", externalName = f}
| f <-
[ "loadI64",
@ -599,7 +595,6 @@ rtsFunctionExports pic debug =
else []
)
<> ["hs_init"]
<> ["__wasm_apply_relocs" | pic]
] <> [ FunctionExport
{ internalName = "stg_returnToSchedNotPaused",
externalName = "stg_returnToSchedNotPaused"

View File

@ -28,7 +28,6 @@ module Asterius.EDSL
params,
local,
i64Local,
i32Local,
i64MutLocal,
global,
newGlobal,
@ -38,52 +37,36 @@ module Asterius.EDSL
pointerI16,
pointerI8,
pointerF64,
pointerF32,
loadI64,
loadI32,
loadI16,
loadI8,
loadF64,
loadF32,
storeI64,
storeI32,
storeI16,
storeI8,
storeF64,
storeF32,
unTagClosure,
dynamicTableBase,
dynamicMemoryBase,
mkDynamicDataAddress,
mkDynamicFunctionAddress,
call,
call',
callImport,
callImport',
callIndirect,
Label,
block',
loop',
if',
break',
whileLoop,
switchI64,
module Asterius.EDSL.BinaryOp,
module Asterius.EDSL.UnaryOp,
module Asterius.EDSL.LibC,
notInt64,
nandInt64,
symbol,
symbol',
constI32,
constI64,
constF64,
baseReg,
r1,
currentNursery,
currentTSO,
currentTID,
hpAlloc,
mainCapability,
)
where
@ -101,7 +84,6 @@ import Control.Monad.State.Strict
import qualified Data.ByteString as BS
import Data.Traversable
import Data.Word
import Language.Haskell.GHC.Toolkit.Constants
-- | State maintained by the EDSL builder.
data EDSLState
@ -227,9 +209,6 @@ local vt v = do
putLVal lr v
pure $ getLVal lr
i32Local :: Expression -> EDSL Expression
i32Local = local I32
i64Local :: Expression -> EDSL Expression
i64Local = local I64
@ -284,27 +263,15 @@ pointerI8 = pointer I32 1
pointerF64 :: Expression -> Int -> LVal
pointerF64 = pointer F64 8
pointerF32 :: Expression -> Int -> LVal
pointerF32 = pointer F32 4
loadI64 :: Expression -> Int -> Expression
loadI64 bp o = getLVal $ pointerI64 bp o
loadI32 :: Expression -> Int -> Expression
loadI32 bp o = getLVal $ pointerI32 bp o
loadI16 :: Expression -> Int -> Expression
loadI16 bp o = getLVal $ pointerI16 bp o
loadI8 :: Expression -> Int -> Expression
loadI8 bp o = getLVal $ pointerI8 bp o
loadF64 :: Expression -> Int -> Expression
loadF64 bp o = getLVal $ pointerF64 bp o
loadF32 :: Expression -> Int -> Expression
loadF32 bp o = getLVal $ pointerF32 bp o
storeI64 :: Expression -> Int -> Expression -> EDSL ()
storeI64 bp o = putLVal $ pointerI64 bp o
@ -320,9 +287,6 @@ storeI8 bp o = putLVal $ pointerI8 bp o
storeF64 :: Expression -> Int -> Expression -> EDSL ()
storeF64 bp o = putLVal $ pointerF64 bp o
storeF32 :: Expression -> Int -> Expression -> EDSL ()
storeF32 bp o = putLVal $ pointerF32 bp o
-- | Encode not using xor.
notInt64 :: Expression -> Expression
notInt64 e = e `xorInt64` constI64 0xFFFFFFFFFFFFFFFF
@ -334,13 +298,6 @@ nandInt64 e1 e2 = notInt64 $ andInt64 e1 e2
unTagClosure :: Expression -> Expression
unTagClosure p = p `andInt64` constI64 0xFFFFFFFFFFFFFFF8
dynamicMemoryBase :: Expression
dynamicMemoryBase =
GetGlobal
{ globalSymbol = "__asterius_memory_base",
valueType = I32
}
dynamicTableBase :: Expression
dynamicTableBase =
GetGlobal
@ -348,14 +305,6 @@ dynamicTableBase =
valueType = I32
}
mkDynamicDataAddress :: Word32 -> Expression
mkDynamicDataAddress off =
extendUInt32 (dynamicMemoryBase `addInt32` ConstI32 (fromIntegral off))
mkDynamicFunctionAddress :: Word32 -> Expression
mkDynamicFunctionAddress off =
extendUInt32 (dynamicTableBase `addInt32` ConstI32 (fromIntegral off))
call :: EntitySymbol -> [Expression] -> EDSL ()
call f xs =
emit
@ -428,25 +377,6 @@ newScope m = do
m
EDSL $ state $ \s@EDSLState {..} -> (exprBuf, s {exprBuf = orig_buf})
block' :: [ValueType] -> (Label -> EDSL ()) -> EDSL ()
block' vts cont = do
lbl <- newLabel
es <- newScope $ cont lbl
emit Block
{ name = unLabel lbl,
bodys = bagToList es,
blockReturnTypes = vts
}
blockWithLabel :: [ValueType] -> Label -> EDSL () -> EDSL ()
blockWithLabel vts lbl m = do
es <- newScope m
emit Block
{ name = unLabel lbl,
bodys = bagToList es,
blockReturnTypes = vts
}
loop' :: [ValueType] -> (Label -> EDSL ()) -> EDSL ()
loop' vts cont = do
lbl <- newLabel
@ -470,59 +400,6 @@ whileLoop :: Expression -> EDSL () -> EDSL ()
whileLoop cond body =
loop' [] $ \lbl -> if' [] cond (body *> break' lbl Nothing) mempty
switchI64 :: Expression -> (EDSL () -> ([(Int, EDSL ())], EDSL ())) -> EDSL ()
switchI64 cond make_clauses = block' [] $ \switch_lbl ->
let exit_switch = break' switch_lbl Nothing
(clauses, def_clause) = make_clauses exit_switch
switch_block = do
switch_def_lbl <- newLabel
blockWithLabel [] switch_def_lbl $ do
clause_seq <- for (reverse clauses) $ \(clause_i, clause_m) -> do
clause_lbl <- newLabel
pure (clause_i, clause_lbl, clause_m)
foldr
( \(_, clause_lbl, clause_m) tot_m -> do
blockWithLabel [] clause_lbl tot_m
clause_m
)
( foldr
( \(clause_i, clause_lbl, _) br_m -> do
break' clause_lbl $ Just $ cond `eqInt64` constI64 clause_i
br_m
)
(break' switch_def_lbl Nothing)
clause_seq
)
clause_seq
def_clause
in switch_block
-- | Allocate a static region of bytes in the global section. Returns a
-- reference to the variable (symbol). Usage:
--
-- > runEDSL $ do
-- > x <- allocStaticBytes "x"
-- > (Serialized $ BS.pack $ replicate 8 1)
-- > loadi64 x 0
-- >
-- > y <- allocStaticBytes "y" (Uninitialized 8)
-- > storei64 x 0 (constI32 32)
allocStaticBytes ::
-- | Name of the static region
EntitySymbol ->
-- | Initializer
AsteriusStatic ->
-- | Expression to access the static, referenced by name.
EDSL Expression
allocStaticBytes n v = EDSL $ state $ \st ->
let st' =
st
{ staticsBuf =
(n, AsteriusStatics {staticsType = Bytes, asteriusStatics = [v]})
: staticsBuf st
}
in (symbol n, st')
symbol :: EntitySymbol -> Expression
symbol = flip symbol' 0
@ -538,23 +415,11 @@ constI64 = ConstI64 . fromIntegral
constF64 :: Int -> Expression
constF64 = ConstF64 . fromIntegral
baseReg :: LVal
baseReg = global BaseReg
r1 :: LVal
r1 = global $ VanillaReg 1
currentNursery :: LVal
currentNursery = global CurrentNursery
currentTSO :: LVal
currentTSO = global CurrentTSO
hpAlloc :: LVal
hpAlloc = global HpAlloc
mainCapability :: Expression
mainCapability = symbol "MainCapability"
currentTID :: Expression
currentTID = loadI32 (getLVal currentTSO) offset_StgTSO_id

View File

@ -134,7 +134,6 @@ newGHCiSession = do
{ nodeExtraArgs =
[ "--experimental-modules",
"--experimental-wasi-unstable-preview1",
"--experimental-wasm-return-call",
"--no-wasm-bounds-checks",
"--no-wasm-stack-checks",
"--unhandled-rejections=strict",
@ -291,7 +290,7 @@ asteriusWriteIServ hsc_env i a
this_id = remoteRefToInt q
(sym, m) = ghciCompiledCoreExprs s IM.! this_id
(js_s, p, _) = ghciSession s
(_, final_m, link_report) <-
(final_m, link_report) <-
linkExeInMemory
LinkTask
{ progName = "",
@ -301,10 +300,7 @@ asteriusWriteIServ hsc_env i a
linkModule = m <> M.foldr' (<>) (ghciLibs s) (ghciObjs s),
hasMain = False,
debug = False,
gcSections = True,
verboseErr = True,
pic = False,
outputIR = Nothing,
rootSymbols =
[ run_q_exp_sym,
run_q_pat_sym,

View File

@ -5,25 +5,15 @@
module Asterius.Internals
( encodeStorable,
reinterpretCast,
showBS,
c8BS,
kvDedup,
)
where
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Char8 as CBS
import qualified Data.Map.Strict as M
import Foreign
import GHC.Exts
import qualified GHC.Types
unI# :: Int -> Int#
unI# (I# x) = x
unIO :: GHC.Types.IO a -> (State# RealWorld -> (# State# RealWorld, a #))
unIO (GHC.Types.IO m) = m
{-# INLINE encodeStorable #-}
encodeStorable :: Storable a => a -> BS.ByteString
@ -31,18 +21,6 @@ encodeStorable a = BS.unsafeCreate len $ \p -> poke (castPtr p) a
where
len = sizeOf a
{-# INLINE reinterpretCast #-}
reinterpretCast :: (Storable a, Storable b) => a -> b
reinterpretCast a =
case runRW#
( \s0 -> case newPinnedByteArray# (unI# (sizeOf a)) s0 of
(# s1, mba #) -> case unsafeFreezeByteArray# mba s1 of
(# s2, ba #) -> case byteArrayContents# ba of
addr -> case unIO (poke (Ptr addr) a) s2 of
(# s3, _ #) -> unIO (peek (Ptr addr)) s3
) of
(# _, r #) -> r
{-# INLINE showBS #-}
showBS :: Show a => a -> BS.ByteString
showBS = fromString . show
@ -50,8 +28,3 @@ showBS = fromString . show
{-# INLINE c8BS #-}
c8BS :: BS.ByteString -> String
c8BS = CBS.unpack
-- | Deduplicate an association list in a left-biased manner; if the same key
-- appears more than once, the left-most key/value pair is preserved.
kvDedup :: Ord k => [(k, a)] -> [(k, a)]
kvDedup = M.toList . M.fromListWith (\_ a -> a)

View File

@ -1,13 +0,0 @@
module Asterius.Internals.Containers
( find,
)
where
import Control.Applicative
import qualified Data.Map.Internal as M
find :: (k -> a -> Maybe b) -> M.Map k a -> Maybe b
find f = w
where
w (M.Bin _ k a l r) = w l <|> f k a <|> w r
w M.Tip = Nothing

View File

@ -7,7 +7,6 @@
module Asterius.Internals.Temp
( temp,
withTempDir,
newTempFile,
)
where
@ -33,9 +32,3 @@ withTempDir :: String -> (FilePath -> IO r) -> IO r
withTempDir t c = do
tmpdir <- getTemporaryDirectory
withTempDirectory silent tmpdir t c
newTempFile :: FilePath -> String -> IO FilePath
newTempFile tmpdir p = do
(r, h) <- openBinaryTempFile tmpdir p
hClose h
pure $ tmpdir </> r

View File

@ -1,14 +1,12 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
module Asterius.JSGen.Bundle where
module Asterius.JSGen.Bundle
( BundleTask (..),
bundle,
)
where
import Asterius.Internals.Temp
import qualified Asterius.Sysroot as A
import qualified Data.ByteString as BS
import Data.Foldable
import System.Directory
import System.FilePath
import System.Process
data BundleTask = BundleTask
@ -35,21 +33,3 @@ bundle BundleTask {..} =
Just lib -> ["--output-library", lib]
_ -> []
)
bundleRTS :: IO BS.ByteString
bundleRTS = withTempDir "asterius" $ \tmpdir -> do
let rts_dir = A.srcDir </> "asterius" </> "rts"
rts_browser_dir = rts_dir </> "browser"
rts_mjs <- filter ((== ".mjs") . takeExtension) <$> listDirectory rts_dir
for_ rts_mjs $ \mjs -> copyFile (rts_dir </> mjs) (tmpdir </> mjs)
rts_browser_mjs <- listDirectory rts_browser_dir
for_ rts_browser_mjs $
\mjs -> copyFile (rts_browser_dir </> mjs) (tmpdir </> mjs)
bundle
BundleTask
{ entry = tmpdir </> "rts.mjs",
outputPath = tmpdir,
outputFileName = "rts.js",
outputLibrary = Just "Asterius"
}
BS.readFile $ tmpdir </> "rts.js"

View File

@ -1,49 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Asterius.JSRun.Main
( newAsteriusInstance,
hsMain,
hsStdOut,
hsStdErr,
)
where
import Control.Exception
import qualified Data.ByteString.Lazy as LBS
import Data.String
import Language.JavaScript.Inline.Core
import System.FilePath
newAsteriusInstance :: Session -> FilePath -> LBS.ByteString -> IO JSVal
newAsteriusInstance s req_path mod_buf = do
rts_val <- importMJS s $ req_path `replaceFileName` "rts.mjs"
req_mod_val <- importMJS s req_path
req_val <- eval @JSVal s $ toJS req_mod_val <> ".default"
mod_val <- eval @JSVal s $ "WebAssembly.compile(" <> toJS mod_buf <> ")"
eval s $
toJS rts_val
<> ".newAsteriusInstance(Object.assign("
<> toJS req_val
<> ",{module:"
<> toJS mod_val
<> "}))"
hsMain :: String -> Session -> JSVal -> IO ()
hsMain prog_name s i =
evaluate
=<< eval
s
( toJS i
<> ".exports.main().catch(err => { if (!(err.startsWith('ExitSuccess') || err.startsWith('ExitFailure '))) { "
<> toJS i
<> ".fs.writeNonMemory(2, `"
<> fromString prog_name
<> ": ${err}\n`);}})"
)
hsStdOut :: Session -> JSVal -> IO LBS.ByteString
hsStdOut s i = eval s $ toJS i <> ".stdio.stdout()"
hsStdErr :: Session -> JSVal -> IO LBS.ByteString
hsStdErr s i = eval s $ toJS i <> ".stdio.stderr()"

View File

@ -3,48 +3,18 @@
module Asterius.JSRun.NonMain
( distNonMain,
newAsteriusInstanceNonMain,
)
where
import Asterius.Ld
( LinkTask (..),
linkModules,
)
import Asterius.Main (ahcDistMain)
import Asterius.Main.Task
import Asterius.Resolve
import Asterius.Types
( EntitySymbol,
AsteriusCachedModule,
Module,
)
import Data.String
import Language.JavaScript.Inline.Core
import System.FilePath
linkNonMain :: AsteriusCachedModule -> [EntitySymbol] -> (Module, LinkReport)
linkNonMain store_m extra_syms = (m, link_report)
where
(_, m, link_report) =
linkModules
LinkTask
{ progName = "",
linkOutput = "",
linkObjs = [],
linkLibs = [],
linkModule = mempty,
Asterius.Ld.hasMain = False,
Asterius.Ld.debug = False,
Asterius.Ld.gcSections = True,
Asterius.Ld.verboseErr = True,
Asterius.Ld.pic = False,
Asterius.Ld.outputIR = Nothing,
rootSymbols = extra_syms,
Asterius.Ld.exportFunctions = []
}
store_m
distNonMain ::
FilePath -> [EntitySymbol] -> (Module, LinkReport) -> IO ()
distNonMain p extra_syms =
@ -56,38 +26,8 @@ distNonMain p extra_syms =
inputHS = p,
outputDirectory = takeDirectory p,
outputBaseName = takeBaseName p,
validate = False,
tailCalls = True,
yolo = True,
Asterius.Main.Task.hasMain = False,
Asterius.Main.Task.verboseErr = True,
Asterius.Main.Task.pic = False,
extraRootSymbols = extra_syms
}
newAsteriusInstanceNonMain ::
Session ->
FilePath ->
[EntitySymbol] ->
AsteriusCachedModule ->
IO JSVal
newAsteriusInstanceNonMain s p extra_syms m = do
distNonMain p extra_syms $ linkNonMain m extra_syms
let rts_path = p `replaceFileName` "rts.mjs"
req_path = p -<.> "req.mjs"
wasm_path = p -<.> "wasm"
rts_val <- importMJS s rts_path
req_mod_val <- importMJS s req_path
req_val <- eval @JSVal s $ toJS req_mod_val <> ".default"
mod_val <-
eval @JSVal s $
"import('fs').then(fs => fs.promises.readFile("
<> fromString (show wasm_path)
<> ")).then(buf => WebAssembly.compile(buf))"
eval s $
toJS rts_val
<> ".newAsteriusInstance(Object.assign("
<> toJS req_val
<> ",{module:"
<> toJS mod_val
<> "}))"

View File

@ -30,8 +30,7 @@ data LinkTask
{ progName, linkOutput :: FilePath,
linkObjs, linkLibs :: [FilePath],
linkModule :: AsteriusCachedModule,
hasMain, debug, gcSections, verboseErr, pic :: Bool,
outputIR :: Maybe FilePath,
hasMain, debug, verboseErr :: Bool,
rootSymbols, exportFunctions :: [EntitySymbol]
}
deriving (Show)
@ -74,12 +73,10 @@ rtsPrivateSymbols =
]
linkModules ::
LinkTask -> AsteriusCachedModule -> (AsteriusModule, Module, LinkReport)
LinkTask -> AsteriusCachedModule -> (Module, LinkReport)
linkModules LinkTask {..} m =
linkStart
pic
debug
gcSections
( toCachedModule
( (if hasMain then mainBuiltins else mempty)
<> rtsAsteriusModule
@ -96,21 +93,18 @@ linkModules LinkTask {..} m =
rtsPrivateSymbols,
SS.fromList
[ mkEntitySymbol internalName
| FunctionExport {..} <- rtsFunctionExports pic debug
| FunctionExport {..} <- rtsFunctionExports debug
]
]
)
exportFunctions
linkExeInMemory :: LinkTask -> IO (AsteriusModule, Module, LinkReport)
linkExeInMemory :: LinkTask -> IO (Module, LinkReport)
linkExeInMemory ld_task = do
final_store <- loadTheWorld ld_task
evaluate $ linkModules ld_task final_store
linkExe :: LinkTask -> IO ()
linkExe ld_task@LinkTask {..} = do
(pre_m, m, link_report) <- linkExeInMemory ld_task
(m, link_report) <- linkExeInMemory ld_task
putFile linkOutput (m, link_report)
case outputIR of
Just p -> putFile p $ toCachedModule pre_m
_ -> pure ()

View File

@ -46,7 +46,6 @@ import Data.Foldable
import Data.List
import Data.String
import Foreign
import qualified Language.WebAssembly.WireFormat as Wasm
import System.Console.GetOpt
import System.Directory
import System.Environment.Blank
@ -86,9 +85,6 @@ parseTask args = case err_msgs of
str_opt "output-directory" $ \s t -> t {outputDirectory = s},
str_opt "output-prefix" $ \s t -> t {outputBaseName = s},
bool_opt "no-main" $ \t -> t {hasMain = False},
bool_opt "no-validate" $ \t -> t {validate = False},
bool_opt "tail-calls" $ \t -> t {tailCalls = True},
bool_opt "no-gc-sections" $ \t -> t {gcSections = False},
bool_opt "bundle" $ \t -> t {bundle = True},
str_opt "optimize-level" $ \s t ->
let i = read s
@ -105,13 +101,10 @@ parseTask args = case err_msgs of
{ optimizeLevel = 0,
shrinkLevel = 0,
debug = True,
outputIR = True,
verboseErr = True
},
bool_opt "output-ir" $ \t -> t {outputIR = True},
bool_opt "run" $ \t -> t {run = True},
bool_opt "verbose-err" $ \t -> t {verboseErr = True},
bool_opt "pic" $ \t -> t {pic = True},
bool_opt "yolo" $ \t -> t {yolo = True},
bool_opt "console-history" $ \t -> t {consoleHistory = True},
str_opt "ghc-option" $
@ -184,8 +177,6 @@ genReq task LinkReport {..} =
intDec tableSlots,
", yolo: ",
if yolo task then "true" else "false",
", pic: ",
if pic task then "true" else "false",
", defaultTableBase: ",
intHex defaultTableBase,
", memoryBase: ",
@ -263,15 +254,8 @@ ahcLink task = do
<> [ "-optl--export-function=" <> c8BS (entityName export_func)
| export_func <- exportFunctions task
]
<> ["-optl--no-gc-sections" | not (gcSections task)]
<> ["-optl--pic" | pic task]
<> ["-optl--verbose-err" | verboseErr task]
<> extraGHCFlags task
<> [ "-optl--output-ir="
<> outputDirectory task
</> (outputBaseName task <.> "unlinked.bin")
| outputIR task
]
<> ["-optl--prog-name=" <> takeBaseName (inputHS task)]
<> ["-o", ld_output, inputHS task]
ncu <- newNameCacheUpdater
@ -289,14 +273,6 @@ ahcDistMain logger task (final_m, report) = do
out_entry = outputDirectory task </> outputBaseName task <.> "mjs"
out_js = outputDirectory task </> outputBaseName task <.> "js"
out_html = outputDirectory task </> outputBaseName task <.> "html"
out_link = outputDirectory task </> outputBaseName task <.> "link.txt"
when (outputIR task) $ do
logger $ "[INFO] Writing linking report to " <> show out_link
writeFile out_link $ show report
when (outputIR task) $ do
let p = out_wasm -<.> "linked.txt"
logger $ "[INFO] Printing linked IR to " <> show p
writeFile p $ show final_m
logger "[INFO] Converting linked IR to binaryen IR"
Binaryen.setDebugInfo $ if verboseErr task then 1 else 0
Binaryen.setOptimizeLevel $ fromIntegral $ optimizeLevel task
@ -304,9 +280,7 @@ ahcDistMain logger task (final_m, report) = do
Binaryen.setLowMemoryUnused 1
m_ref <-
Binaryen.marshalModule
(pic task)
(verboseErr task)
(tailCalls task)
(staticsOffsetMap report)
(functionOffsetMap report)
(lastDataOffset report)
@ -315,31 +289,9 @@ ahcDistMain logger task (final_m, report) = do
logger "[INFO] Running binaryen optimization"
Binaryen.optimize m_ref
Binaryen.runPass m_ref ["limit-segments"]
when (validate task) $ do
logger "[INFO] Validating binaryen IR"
pass_validation <- Binaryen.validate m_ref
when (pass_validation /= 1) $ fail "[ERROR] binaryen validation failed"
m_bin <- Binaryen.serializeModule m_ref
logger $ "[INFO] Writing WebAssembly binary to " <> show out_wasm
BS.writeFile out_wasm m_bin
when (outputIR task) $ do
let p = out_wasm -<.> "binaryen-show.txt"
logger $ "[info] writing re-parsed wasm-toolkit ir to " <> show p
case runGetOrFail Wasm.getModule (LBS.fromStrict m_bin) of
Right (rest, _, r)
| LBS.null rest -> writeFile p (show r)
| otherwise -> fail "[ERROR] Re-parsing produced residule"
_ -> fail "[ERROR] Re-parsing failed"
let out_wasm_binaryen_sexpr = out_wasm -<.> "binaryen-sexpr.txt"
logger $
"[info] writing re-parsed wasm-toolkit ir as s-expresions to "
<> show out_wasm_binaryen_sexpr
-- disable colors when writing out the binaryen module
-- to a file, so that we don't get ANSI escape sequences
-- for colors. Reset the state after
Asterius.Backends.Binaryen.setColorsEnabled False
m_sexpr <- Binaryen.serializeModuleSExpr m_ref
BS.writeFile out_wasm_binaryen_sexpr m_sexpr
Binaryen.dispose m_ref
logger $
"[INFO] Writing JavaScript runtime modules to "
@ -388,7 +340,6 @@ ahcDistMain logger task (final_m, report) = do
callProcess "node" $
[ "--experimental-modules",
"--experimental-wasi-unstable-preview1",
"--experimental-wasm-return-call",
"--unhandled-rejections=strict",
takeFileName script
]

View File

@ -11,15 +11,10 @@ module Asterius.Main.Task
outputDirectory,
outputBaseName,
hasMain,
validate,
tailCalls,
gcSections,
bundle,
debug,
outputIR,
run,
verboseErr,
pic,
yolo,
consoleHistory,
extraGHCFlags,
@ -45,7 +40,7 @@ data Task
inputEntryMJS :: Maybe FilePath,
outputDirectory :: FilePath,
outputBaseName :: String,
hasMain, validate, tailCalls, gcSections, bundle, debug, outputIR, run, verboseErr, pic, yolo, consoleHistory :: Bool,
hasMain, bundle, debug, run, verboseErr, yolo, consoleHistory :: Bool,
extraGHCFlags :: [String],
exportFunctions, extraRootSymbols :: [EntitySymbol],
gcThreshold :: Int
@ -61,15 +56,10 @@ defTask = Task
outputBaseName = error "Asterius.Main.parseTask: missing outputBaseName",
inputEntryMJS = Nothing,
hasMain = True,
validate = True,
tailCalls = False,
gcSections = True,
bundle = False,
debug = False,
outputIR = False,
run = False,
verboseErr = False,
pic = False,
yolo = False,
consoleHistory = False,
extraGHCFlags = [],

View File

@ -8,18 +8,14 @@ module Asterius.Passes.DataOffsetTable
)
where
import Asterius.EDSL
import Asterius.Internals
import Asterius.Internals.MagicNumber
import Asterius.Types
import qualified Asterius.Types.SymbolMap as SM
import Bag
import qualified Data.ByteString as BS
import Data.ByteString.Builder
import Data.ByteString.Lazy (toStrict)
import Data.List
import Data.Monoid
import qualified Data.Set as Set
import Data.Tuple
import Foreign
import Language.Haskell.GHC.Toolkit.Constants
@ -49,87 +45,6 @@ makeDataOffsetTable :: AsteriusModule -> (SM.SymbolMap Word32, Word32)
makeDataOffsetTable AsteriusModule {..} =
swap $ SM.mapAccum (\a ss -> (a + sizeofStaticsAligned ss, a)) 0 staticsMap
-- | Given the offset of a static and the static itself, compute the
-- corresponding data segment and the offset of the subsequent static.
-- Furthermore, gather the offsets of symbol statics, to be used by the
-- relocation function. NOTE: we do not generate data segments for
-- uninitialized statics; we do not have to specify each segment and the
-- linear memory is zero-initialized anyway.
{-# INLINEABLE makeDynamicSegment #-}
makeDynamicSegment ::
SM.SymbolMap Word32 ->
SM.SymbolMap Word32 ->
(Word32, Set.Set Word32, Set.Set Word32, Builder) ->
AsteriusStatic ->
(Word32, Set.Set Word32, Set.Set Word32, Builder)
makeDynamicSegment fn_off_map ss_off_map (current_off, fn_meta, ss_meta, acc) static = case static of
SymbolStatic sym o
| Just off <- SM.lookup sym fn_off_map ->
( next_off,
current_off `Set.insert` fn_meta,
ss_meta,
acc <> byteString (encodeStorable $ castOffsetToAddress $ fromIntegral $ off + fromIntegral o) -- To be fixed at runtime; see makeWasmApplyRelocs
)
| Just off <- SM.lookup sym ss_off_map ->
( next_off,
fn_meta,
current_off `Set.insert` ss_meta,
acc <> byteString (encodeStorable $ castOffsetToAddress $ fromIntegral $ off + fromIntegral o) -- To be fixed at runtime; see makeWasmApplyRelocs
)
| otherwise ->
( next_off,
fn_meta,
ss_meta,
acc <> byteString (encodeStorable invalidAddress)
)
Uninitialized len ->
( next_off,
fn_meta,
ss_meta,
acc <> byteString (BS.replicate len 0)
)
Serialized buf ->
( next_off,
fn_meta,
ss_meta,
acc <> byteString buf
)
where
next_off = current_off + sizeofStatic static
{-# INLINEABLE castOffsetToAddress #-}
castOffsetToAddress :: Word32 -> Int64
castOffsetToAddress = fromIntegral
-- The new relocation function; this should replace the placeholder no-op.
makeWasmApplyRelocs :: Int -> Int -> AsteriusModule
makeWasmApplyRelocs fn_statics_len ss_statics_len = runEDSL "__wasm_apply_relocs" $ do
-- Store the extended (64-bit) bases into local variables, to speed things up
-- and keep the size of the relocation function more manageable.
table_base <- i64Local $ extendUInt32 dynamicTableBase
memory_base <- i64Local $ extendUInt32 dynamicMemoryBase
i <- i64MutLocal
loc <- i64MutLocal -- for performance only
-- Fix the function offsets first
putLVal i (ConstI64 0)
whileLoop (getLVal i `neInt64` ConstI64 (fromIntegral fn_statics_len)) $ do
let off = loadI64 (symbol "__asterius_fn_segment" `addInt64` getLVal i) 0
putLVal loc $
(memory_base `addInt64` off)
storeI64 (getLVal loc) 0 $
(table_base `addInt64` loadI64 (getLVal loc) 0)
putLVal i (getLVal i `addInt64` ConstI64 8)
-- Fix the static offsets second
putLVal i (ConstI64 0)
whileLoop (getLVal i `neInt64` ConstI64 (fromIntegral ss_statics_len)) $ do
let off = loadI64 (symbol "__asterius_ss_segment" `addInt64` getLVal i) 0
putLVal loc $
(memory_base `addInt64` off)
storeI64 (getLVal loc) 0 $
(memory_base `addInt64` loadI64 (getLVal loc) 0)
putLVal i (getLVal i `addInt64` ConstI64 8)
-- | Given the offset of a static and the static itself, compute the
-- corresponding data segment and the offset of the subsequent static. NOTE: we
-- do not generate data segments for uninitialized statics; we do not have to
@ -193,119 +108,11 @@ makeStaticMemory AsteriusModule {..} fn_off_map ss_off_map _memory_base =
(ss_off_map SM.! statics_sym)
asteriusStatics
-- | Create the data segments, when @pic@ is on.
--
-- We collapse all the data segments into one, and at the end we include the
-- two newly created data segments: the one containing the function offsets
-- appears first and the one containing the static offsets appears second.
{-# INLINEABLE makeDynamicMemory #-}
makeDynamicMemory ::
AsteriusModule ->
SM.SymbolMap Word32 ->
SM.SymbolMap Word32 ->
(DataSegment, AsteriusModule, Word32, SM.SymbolMap Word32) -- relocation function implementation
makeDynamicMemory AsteriusModule {..} fn_off_map ss_off_map =
( complete_segment,
new_reloc <> new_statics,
fn_segment_len + ss_segment_len,
new_offsets
)
where
(_final_offset, all_fn_offs, all_ss_offs, _all_content) =
foldl
( \(real_current_offset, fn_offs, ss_offs, seg_contents) (sym, AsteriusStatics {..}) ->
let aligned_current_offset = ss_off_map SM.! sym
padding =
byteString $
BS.replicate
(fromIntegral $ aligned_current_offset - real_current_offset)
0
in foldl
(makeDynamicSegment fn_off_map ss_off_map)
(aligned_current_offset, fn_offs, ss_offs, seg_contents <> padding)
asteriusStatics
)
(0, Set.empty, Set.empty, mempty)
(SM.toList staticsMap)
-- Ensure that the last bit is also aligned
final_offset = fromIntegral $ fromIntegral _final_offset `roundup` segAlignment
all_content = _all_content <> byteString (BS.replicate (fromIntegral (final_offset - _final_offset)) 0)
-- The two new segments, containing the function offsets and the static
-- offsets that the relocation function needs to change.
(fn_segment, fn_segment_len, fn_statics, fn_statics_len) = mkOffsetSegment all_fn_offs
(ss_segment, ss_segment_len, ss_statics, ss_statics_len) = mkOffsetSegment all_ss_offs
-- All the data segments, collapsed into one. At the end we include the two
-- newly created data segments: the one containing the function offsets
-- should appear first, then the one containing the static offsets.
complete_segment :: DataSegment
complete_segment =
DataSegment
{ content =
toStrict -- NOTE: expensive
$ toLazyByteString
$ all_content <> fn_segment <> ss_segment,
offset = dynamicMemoryBase
}
-- The offsets of the two new data segments / statics that need to be added
-- to the offset map (@__asterius_fn_segment@ comes first,
-- @__asterius_ss_segment@ comes second).
new_offsets :: SM.SymbolMap Word32
new_offsets =
SM.fromList
[ ("__asterius_fn_segment", final_offset),
("__asterius_ss_segment", final_offset + fn_segment_len)
]
-- The two statics corresponding to the newly created data segments. Note
-- that there is no way to ensure that the new statics are placed _at the
-- end_ of the list (i.e. if we call @SM.toList@), because ordering in
-- @SymbolMap@ is not lexicographic (but it is deterministic). Since we've
-- already laid down the segments though, this is no problem; the
-- information is correctly set in the offset maps.
new_statics :: AsteriusModule
new_statics =
mempty
{ staticsMap =
SM.fromList
[ ("__asterius_fn_segment", fn_statics),
("__asterius_ss_segment", ss_statics)
]
}
-- The new relocation function; this should replace the placeholder no-op.
new_reloc :: AsteriusModule
new_reloc = makeWasmApplyRelocs fn_statics_len ss_statics_len
{-# INLINEABLE mkOffsetSegment #-}
mkOffsetSegment :: Set.Set Word32 -> (Builder, Word32, AsteriusStatics, Int)
mkOffsetSegment all_offs = (segment <> padding, fromIntegral aligned_len, statics, init_len)
where
init_len = 8 * Set.size all_offs
aligned_len = init_len `roundup` segAlignment
segment =
mconcat
$ map (byteString . encodeStorable . castOffsetToAddress)
$ Set.toAscList all_offs
padding = byteString (BS.replicate (aligned_len - init_len) 0)
statics =
AsteriusStatics
{ staticsType = ConstBytes,
asteriusStatics =
[Serialized $ toStrict $ toLazyByteString segment]
}
makeMemory ::
Bool ->
AsteriusModule ->
SM.SymbolMap Word32 ->
([DataSegment], SM.SymbolMap Word32, Word32, Word32, AsteriusModule) -- relocation function implementation
makeMemory pic_is_on m_globals_resolved fn_off_map
| pic_is_on =
let (seg, reloc, new_seg_len, new_seg_offs) = makeDynamicMemory m_globals_resolved fn_off_map _ss_off_map
in ( [seg],
_ss_off_map <> new_seg_offs,
_last_data_offset + new_seg_len, error "TODO",
reloc <> m_globals_resolved
)
| otherwise =
makeMemory m_globals_resolved fn_off_map =
( makeStaticMemory m_globals_resolved fn_off_map _ss_off_map _memory_base,
_ss_off_map,
_memory_base, _last_data_offset,

View File

@ -1,48 +0,0 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
module Asterius.Passes.MergeSymbolOffset
( mergeSymbolOffset,
)
where
import Asterius.EDSL
import Asterius.Internals.SYB
import Asterius.Types
import Data.Word
import Type.Reflection
noNeg :: Expression -> Int -> Word32
noNeg e n
| n >= 0 =
fromIntegral n
| otherwise =
error $
"Asterius.Passes.MergeSymbolOffset.noNeg: negative index "
<> show n
<> " when merging "
<> show e
{-# INLINEABLE mergeSymbolOffset #-}
mergeSymbolOffset :: Monad m => GenericM m
mergeSymbolOffset t =
pure $ case eqTypeRep (typeOf t) (typeRep :: TypeRep Expression) of
Just HRefl -> case t of
Load {ptr = Unary {unaryOp = WrapInt64, operand0 = sym@Symbol {..}}, ..} ->
Load
{ signed = signed,
bytes = bytes,
offset = noNeg t $ symbolOffset + fromIntegral offset,
valueType = valueType,
ptr = wrapInt64 $ sym {symbolOffset = 0}
}
Store {ptr = Unary {unaryOp = WrapInt64, operand0 = sym@Symbol {..}}, ..} ->
Store
{ bytes = bytes,
offset = noNeg t $ symbolOffset + fromIntegral offset,
ptr = wrapInt64 $ sym {symbolOffset = 0},
value = value,
valueType = valueType
}
_ -> t
_ -> t

View File

@ -1,111 +0,0 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Asterius.Passes.Relooper
( relooper,
)
where
import Asterius.Types
import Data.Foldable
import Data.List
import qualified Data.Map.Strict as M
{-# INLINE relooper #-}
relooper :: RelooperRun -> Expression
relooper cfg@RelooperRun {blockMap = oldMap} =
relooper' $
cfg
{ blockMap = M.insert "__asterius_unreachable" unreachableRelooperBlock oldMap
}
relooper' :: RelooperRun -> Expression
relooper' RelooperRun {..} = result_expr
where
lbls = M.keys blockMap
lbl_map = M.fromList $ zip lbls [0 ..]
lbl_to_idx = (lbl_map M.!)
set_block_lbl lbl = SetLocal {index = 0, value = ConstI32 $ lbl_to_idx lbl}
initial_expr = Switch
{ names = lbls,
defaultName = "__asterius_unreachable",
condition = GetLocal {index = 0, valueType = I32}
}
loop_lbl = "__asterius_loop"
exit_lbl = "__asterius_exit"
(blocks_expr, last_block_residule_exprs) =
M.foldlWithKey'
( \(tot_expr, residule_exprs) lbl RelooperBlock {..} ->
( Block
{ name = lbl,
bodys = tot_expr : residule_exprs,
blockReturnTypes = []
},
case addBlock of
AddBlock {..} ->
code
: ( case addBranches of
[] -> [Break {name = exit_lbl, breakCondition = Nothing}]
branches ->
foldr'
( \AddBranch {addBranchCondition = Just cond, to} e -> If
{ condition = cond,
ifTrue = set_block_lbl to,
ifFalse = Just e
}
)
(set_block_lbl $ to def_branch)
(init branches)
: [Break {name = loop_lbl, breakCondition = Nothing}]
where
def_branch@AddBranch {addBranchCondition = Nothing} =
last branches
)
AddBlockWithSwitch {..} ->
[code, SetLocal {index = 1, value = condition}]
<> ( foldr'
( \AddBranchForSwitch {to, indexes} e -> If
{ condition =
foldl1'
(Binary OrInt32)
[ Binary
{ binaryOp = EqInt32,
operand0 = GetLocal
{ index = 1,
valueType = I32
},
operand1 = ConstI32 $ fromIntegral tag
}
| tag <- indexes
],
ifTrue = set_block_lbl to,
ifFalse = Just e
}
)
(set_block_lbl $ to def_branch)
(init branches)
: [Break {name = loop_lbl, breakCondition = Nothing}]
)
where
branches = addBranches
def_branch@AddBranch {addBranchCondition = Nothing} = last branches
)
)
(initial_expr, [])
blockMap
result_expr = Block
{ name = exit_lbl,
bodys =
[ set_block_lbl entry,
Loop
{ name = loop_lbl,
body = Block
{ name = "",
bodys = blocks_expr : last_block_residule_exprs,
blockReturnTypes = []
}
}
],
blockReturnTypes = []
}

View File

@ -44,7 +44,6 @@ makeInfoTableOffsetSet AsteriusModule {..} ss_off_map =
staticsMap
resolveAsteriusModule ::
Bool ->
Bool ->
AsteriusModule ->
( Module,
@ -55,7 +54,7 @@ resolveAsteriusModule ::
Word32,
Int
)
resolveAsteriusModule pic_is_on debug m_globals_resolved =
resolveAsteriusModule debug m_globals_resolved =
(new_mod, final_m, ss_off_map, fn_off_map, memory_base, last_data_offset, table_slots)
where
-- Create the function offset table first. A dummy relocation function
@ -66,7 +65,7 @@ resolveAsteriusModule pic_is_on debug m_globals_resolved =
-- on), the relocation function must be replaced, and new data segments
-- (and corresponding statics) must be added, to hold the offsets needed by
-- the relocation function. All this is handled by @makeMemory@.
(segs, ss_off_map, memory_base, last_data_offset, final_m) = makeMemory pic_is_on m_globals_resolved fn_off_map
(segs, ss_off_map, memory_base, last_data_offset, final_m) = makeMemory m_globals_resolved fn_off_map
func_table = makeFunctionTable fn_off_map
table_slots = fromIntegral last_func_offset
func_imports =
@ -87,7 +86,7 @@ resolveAsteriusModule pic_is_on debug m_globals_resolved =
)
func_imports
)
$ rtsFunctionExports pic_is_on debug,
$ rtsFunctionExports debug,
functionTable = func_table,
tableImport = Nothing,
tableSlots = table_slots,
@ -99,16 +98,13 @@ resolveAsteriusModule pic_is_on debug m_globals_resolved =
}
linkStart ::
Bool ->
Bool ->
Bool ->
AsteriusCachedModule ->
SS.SymbolSet ->
[EntitySymbol] ->
(AsteriusModule, Module, LinkReport)
linkStart pic_on debug gc_sections store root_syms export_funcs =
( merged_m,
result_m,
(Module, LinkReport)
linkStart debug store root_syms export_funcs =
( result_m,
LinkReport
{ staticsOffsetMap = ss_off_map,
functionOffsetMap = fn_off_map,
@ -124,12 +120,10 @@ linkStart pic_on debug gc_sections store root_syms export_funcs =
}
)
where
merged_m0
| gc_sections = gcSections store root_syms export_funcs
| otherwise = fromCachedModule store
merged_m0 = gcSections store root_syms export_funcs
!merged_m0_evaluated = force merged_m0
!merged_m1
| debug = traceModule $ addMemoryTrap merged_m0_evaluated
| otherwise = merged_m0_evaluated
(!result_m, !merged_m, !ss_off_map, !fn_off_map, !memory_base, !last_data_offset, !tbl_slots) =
resolveAsteriusModule pic_on debug merged_m1
resolveAsteriusModule debug merged_m1

View File

@ -1,4 +1,7 @@
module Asterius.Sysroot where
module Asterius.Sysroot
( srcDir,
)
where
import System.Directory
import System.Environment.Blank
@ -11,11 +14,3 @@ srcDir = unsafePerformIO $ do
case mp of
Nothing -> fail "AHC_SRCDIR is not set"
Just s -> canonicalizePath s
{-# NOINLINE sysroot #-}
sysroot :: FilePath
sysroot = unsafePerformIO $ do
mp <- getEnv "AHC_LIBDIR"
case mp of
Nothing -> fail "AHC_LIBDIR is not set"
Just s -> canonicalizePath s

View File

@ -1,4 +1,3 @@
packages:
asterius
ghc-toolkit
wasm-toolkit

View File

@ -1,18 +1,17 @@
packages:
asterius
ghc-toolkit
wasm-toolkit
source-repository-package
type: git
location: https://github.com/tweag/inline-js.git
tag: 0fc7444c552820e44ea54ae82eb1f8542dd56f36
tag: 8512b09d2c0533a41d5d2aef182b11a58c420c10
subdir: inline-js-core
source-repository-package
type: git
location: https://github.com/tweag/ghc-asterius.git
tag: 6a375ebc374ed83ac568725de945bd751756a401
tag: bf758f1f98aab4f3267261bbeb91a18fa2e8de07
subdir:
ahc-bin
ahc-pkg

View File

@ -2,8 +2,8 @@
"ghc-asterius": {
"branch": "asterius-8.10",
"repo": "https://github.com/tweag/ghc-asterius.git",
"rev": "81450fe26da8de099c47ccaa9aa7d0f0f62921ab",
"sha256": "1gqjpmipfsk0xc2c9hsafa132a2qgya3bb8hxhwlh7wvs56wszz6",
"rev": "1388aa804ebb0f642d5ea86fe03a9ba1a3cb06c0",
"sha256": "0njav5q5bnl6jk9p6hy30hdb6bmp48fjq15m31ymvrvmfich850j",
"type": "git"
},
"haskell-nix": {
@ -12,10 +12,10 @@
"homepage": "https://input-output-hk.github.io/haskell.nix",
"owner": "input-output-hk",
"repo": "haskell.nix",
"rev": "8943d0960324a67f9b5ebfeee7d52d0209812751",
"sha256": "0k0d7f0yr4zwbs6fmj2miwv75f9c0xhp2k2ih1kki6gqq4gz3cb9",
"rev": "9a72ca634abc2b68d6a1a468130fd4503b3ad7ea",
"sha256": "1ivii52ldnj39y59rm68mj4nq3y5xasdv3hw3lib5r42pdyc0f8p",
"type": "tarball",
"url": "https://github.com/input-output-hk/haskell.nix/archive/8943d0960324a67f9b5ebfeee7d52d0209812751.tar.gz",
"url": "https://github.com/input-output-hk/haskell.nix/archive/9a72ca634abc2b68d6a1a468130fd4503b3ad7ea.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
},
"hs-nix-tools": {

View File

@ -11,7 +11,7 @@
, hsPkgs ? pkgs.callPackage ./nix/pkg-set.nix { inherit pkgs ghc; }
}:
(hsPkgs.shellFor rec {
packages = ps: with ps; [ asterius ghc-toolkit wasm-toolkit ];
packages = ps: with ps; [ asterius ghc-toolkit ];
withHoogle = true;
@ -50,7 +50,7 @@
pushd $(git rev-parse --show-toplevel)
for pkg in asterius ghc-toolkit wasm-toolkit; do
for pkg in asterius ghc-toolkit; do
hpack $pkg
done

View File

@ -1 +0,0 @@
# CHANGELOG for `wasm-toolkit`

View File

@ -1,13 +0,0 @@
Copyright (c) 2018 EURL Tweag
All rights reserved.
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
* Neither the name of Tweag I/O nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

View File

@ -1,9 +0,0 @@
# `wasm-toolkit`
A Haskell library to handle WebAssembly code. Currently contains:
* Complete definition of the AST, including support for custom sections.
* Binary encoder/decoder.
* Stochastic fuzzer which generates syntactically correct AST to test binary encoder/decoder.
This library models WebAssembly in a "speccy" manner; it only deals with lists of instructions, and does not implement expression syntax trees. The library doesn't have third party dependencies other than boot libs (the test suite does rely on `QuickCheck`)

View File

@ -1,36 +0,0 @@
name: wasm-toolkit
version: 0.0.1
category: Compiler
stability: alpha
maintainer: Shao Cheng <cheng.shao@tweag.io>
copyright: (c) 2018 Tweag I/O
license: BSD3
github: tweag/asterius
extra-source-files:
- CHANGELOG.md
- LICENSE
- README.md
- test/node-compile.js
ghc-options: -Wall
dependencies:
- base
- binary
- bytestring
- directory
- filepath
- process
library:
source-dirs: src
tests:
wasm-toolkit-codec:
source-dirs: test
main: wasm-toolkit-codec.hs
ghc-options: -threaded -rtsopts
dependencies:
- QuickCheck
- wasm-toolkit

File diff suppressed because it is too large Load Diff

View File

@ -1,584 +0,0 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Language.WebAssembly.WireFormat.Orphans
( genModule,
shrinkModule,
)
where
import qualified Data.ByteString.Short as SBS
import Data.Coerce
import Data.Word
import Language.WebAssembly.WireFormat
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Gen
genMaybe :: Gen a -> Gen (Maybe a)
genMaybe g = oneof [pure Nothing, Just <$> g]
genSBS :: Gen SBS.ShortByteString
genSBS = SBS.pack <$> listOf chooseAny
instance Arbitrary SBS.ShortByteString where
arbitrary = genSBS
shrink = map SBS.pack . shrink . SBS.unpack
genName :: Gen Name
genName = coerce genSBS
instance Arbitrary Name where
arbitrary = genName
shrink = genericShrink
genValueType :: Gen ValueType
genValueType = Test.QuickCheck.Gen.elements [I32, I64, F32, F64]
instance Arbitrary ValueType where
arbitrary = genValueType
shrink = genericShrink
genResultType :: Gen [ValueType]
genResultType = do
n <- choose (0, 1)
vectorOf n genValueType
genFunctionType :: Gen FunctionType
genFunctionType = FunctionType <$> listOf genValueType <*> genResultType
instance Arbitrary FunctionType where
arbitrary = genFunctionType
shrink = genericShrink
genLimits :: Gen Limits
genLimits = Limits <$> chooseAny <*> genMaybe chooseAny
instance Arbitrary Limits where
arbitrary = genLimits
shrink = genericShrink
genMemoryType :: Gen MemoryType
genMemoryType = coerce genLimits
instance Arbitrary MemoryType where
arbitrary = genMemoryType
shrink = genericShrink
genElementType :: Gen ElementType
genElementType = pure AnyFunc
instance Arbitrary ElementType where
arbitrary = genElementType
shrink = genericShrink
genTableType :: Gen TableType
genTableType = TableType <$> genElementType <*> genLimits
instance Arbitrary TableType where
arbitrary = genTableType
shrink = genericShrink
genMutability :: Gen Mutability
genMutability = Test.QuickCheck.Gen.elements [Const, Var]
instance Arbitrary Mutability where
arbitrary = genMutability
shrink = genericShrink
genGlobalType :: Gen GlobalType
genGlobalType = GlobalType <$> genValueType <*> genMutability
instance Arbitrary GlobalType where
arbitrary = genGlobalType
shrink = genericShrink
genMemoryArgument :: Gen MemoryArgument
genMemoryArgument = MemoryArgument <$> chooseAny <*> chooseAny
instance Arbitrary MemoryArgument where
arbitrary = genMemoryArgument
shrink = genericShrink
genInstructions :: Gen [Instruction]
genInstructions = listOf genInstruction
genInstruction :: Gen Instruction
genInstruction =
frequency
[ ( 64,
oneof
[ pure Unreachable,
pure Nop,
Branch <$> genLabelIndex,
BranchIf <$> genLabelIndex,
BranchTable <$> listOf genLabelIndex <*> genLabelIndex,
pure Return,
Call <$> genFunctionIndex,
CallIndirect <$> genFunctionTypeIndex,
pure Drop,
pure Select,
GetLocal <$> genLocalIndex,
SetLocal <$> genLocalIndex,
TeeLocal <$> genLocalIndex,
GetGlobal <$> genGlobalIndex,
SetGlobal <$> genGlobalIndex,
I32Load <$> genMemoryArgument,
I64Load <$> genMemoryArgument,
F32Load <$> genMemoryArgument,
F64Load <$> genMemoryArgument,
I32Load8Signed <$> genMemoryArgument,
I32Load8Unsigned <$> genMemoryArgument,
I32Load16Signed <$> genMemoryArgument,
I32Load16Unsigned <$> genMemoryArgument,
I64Load8Signed <$> genMemoryArgument,
I64Load8Unsigned <$> genMemoryArgument,
I64Load16Signed <$> genMemoryArgument,
I64Load16Unsigned <$> genMemoryArgument,
I64Load32Signed <$> genMemoryArgument,
I64Load32Unsigned <$> genMemoryArgument,
I32Store <$> genMemoryArgument,
I64Store <$> genMemoryArgument,
F32Store <$> genMemoryArgument,
F64Store <$> genMemoryArgument,
I32Store8 <$> genMemoryArgument,
I32Store16 <$> genMemoryArgument,
I64Store8 <$> genMemoryArgument,
I64Store16 <$> genMemoryArgument,
I64Store32 <$> genMemoryArgument,
pure MemorySize,
pure MemoryGrow,
pure I32Eqz,
pure I64Eqz,
pure I32Clz,
pure I32Ctz,
pure I32Popcnt,
pure I64Clz,
pure I64Ctz,
pure I64Popcnt,
pure F32Abs,
pure F32Neg,
pure F32Ceil,
pure F32Floor,
pure F32Trunc,
pure F32Nearest,
pure F32Sqrt,
pure F64Abs,
pure F64Neg,
pure F64Ceil,
pure F64Floor,
pure F64Trunc,
pure F64Nearest,
pure F64Sqrt,
pure I32WrapFromI64,
pure I32TruncSFromF32,
pure I32TruncUFromF32,
pure I32TruncSFromF64,
pure I32TruncUFromF64,
pure I64ExtendSFromI32,
pure I64ExtendUFromI32,
pure I64TruncSFromF32,
pure I64TruncUFromF32,
pure I64TruncSFromF64,
pure I64TruncUFromF64,
pure F32ConvertSFromI32,
pure F32ConvertUFromI32,
pure F32ConvertSFromI64,
pure F32ConvertUFromI64,
pure F32DemoteFromF64,
pure F64ConvertSFromI32,
pure F64ConvertUFromI32,
pure F64ConvertSFromI64,
pure F64ConvertUFromI64,
pure F64PromoteFromF32,
pure I32ReinterpretFromF32,
pure I64ReinterpretFromF64,
pure F32ReinterpretFromI32,
pure F64ReinterpretFromI64,
pure I32Eq,
pure I32Ne,
pure I32LtS,
pure I32LtU,
pure I32GtS,
pure I32GtU,
pure I32LeS,
pure I32LeU,
pure I32GeS,
pure I32GeU,
pure I64Eq,
pure I64Ne,
pure I64LtS,
pure I64LtU,
pure I64GtS,
pure I64GtU,
pure I64LeS,
pure I64LeU,
pure I64GeS,
pure I64GeU,
pure F32Eq,
pure F32Ne,
pure F32Lt,
pure F32Gt,
pure F32Le,
pure F32Ge,
pure F64Eq,
pure F64Ne,
pure F64Lt,
pure F64Gt,
pure F64Le,
pure F64Ge,
pure I32Add,
pure I32Sub,
pure I32Mul,
pure I32DivS,
pure I32DivU,
pure I32RemS,
pure I32RemU,
pure I32And,
pure I32Or,
pure I32Xor,
pure I32Shl,
pure I32ShrS,
pure I32ShrU,
pure I32RotL,
pure I32RotR,
pure I64Add,
pure I64Sub,
pure I64Mul,
pure I64DivS,
pure I64DivU,
pure I64RemS,
pure I64RemU,
pure I64And,
pure I64Or,
pure I64Xor,
pure I64Shl,
pure I64ShrS,
pure I64ShrU,
pure I64RotL,
pure I64RotR,
pure F32Add,
pure F32Sub,
pure F32Mul,
pure F32Div,
pure F32Min,
pure F32Max,
pure F32Copysign,
pure F64Add,
pure F64Sub,
pure F64Mul,
pure F64Div,
pure F64Min,
pure F64Max,
pure F64Copysign
]
),
( 1,
oneof
[ Block <$> genResultType <*> genInstructions,
Loop <$> genResultType <*> genInstructions,
If <$> genResultType <*> genInstructions <*> genMaybe genInstructions
]
)
]
instance Arbitrary Instruction where
arbitrary = genInstruction
shrink = genericShrink
genExpression :: Gen Expression
genExpression = Expression <$> listOf genInstruction
instance Arbitrary Expression where
arbitrary = genExpression
shrink = genericShrink
genCustom :: Gen Custom
genCustom = Custom <$> genName <*> genSBS
instance Arbitrary Custom where
arbitrary = genCustom
shrink = genericShrink
genFunctionTypeIndex :: Gen FunctionTypeIndex
genFunctionTypeIndex = coerce (chooseAny @Word32)
instance Arbitrary FunctionTypeIndex where
arbitrary = genFunctionTypeIndex
shrink = genericShrink
genFunctionIndex :: Gen FunctionIndex
genFunctionIndex = coerce (chooseAny @Word32)
instance Arbitrary FunctionIndex where
arbitrary = genFunctionIndex
shrink = genericShrink
genTableIndex :: Gen TableIndex
genTableIndex = coerce (chooseAny @Word32)
instance Arbitrary TableIndex where
arbitrary = genTableIndex
shrink = genericShrink
genMemoryIndex :: Gen MemoryIndex
genMemoryIndex = coerce (chooseAny @Word32)
instance Arbitrary MemoryIndex where
arbitrary = genMemoryIndex
shrink = genericShrink
genGlobalIndex :: Gen GlobalIndex
genGlobalIndex = coerce (chooseAny @Word32)
instance Arbitrary GlobalIndex where
arbitrary = genGlobalIndex
shrink = genericShrink
genLocalIndex :: Gen LocalIndex
genLocalIndex = coerce (chooseAny @Word32)
instance Arbitrary LocalIndex where
arbitrary = genLocalIndex
shrink = genericShrink
genLabelIndex :: Gen LabelIndex
genLabelIndex = coerce (chooseAny @Word32)
instance Arbitrary LabelIndex where
arbitrary = genLabelIndex
shrink = genericShrink
genImportDescription :: Gen ImportDescription
genImportDescription =
oneof
[ ImportFunction <$> genFunctionTypeIndex,
ImportTable <$> genTableType,
ImportMemory <$> genMemoryType,
ImportGlobal <$> genGlobalType
]
instance Arbitrary ImportDescription where
arbitrary = genImportDescription
shrink = genericShrink
genImport :: Gen Import
genImport = Import <$> genName <*> genName <*> genImportDescription
instance Arbitrary Import where
arbitrary = genImport
shrink = genericShrink
genTable :: Gen Table
genTable = coerce genTableType
instance Arbitrary Table where
arbitrary = genTable
shrink = genericShrink
genMemory :: Gen Memory
genMemory = coerce genMemoryType
instance Arbitrary Memory where
arbitrary = genMemory
shrink = genericShrink
genGlobal :: Gen Global
genGlobal = Global <$> genGlobalType <*> genExpression
instance Arbitrary Global where
arbitrary = genGlobal
shrink = genericShrink
genExportDescription :: Gen ExportDescription
genExportDescription =
oneof
[ ExportFunction <$> genFunctionIndex,
ExportTable <$> genTableIndex,
ExportMemory <$> genMemoryIndex,
ExportGlobal <$> genGlobalIndex
]
instance Arbitrary ExportDescription where
arbitrary = genExportDescription
shrink = genericShrink
genExport :: Gen Export
genExport = Export <$> genName <*> genExportDescription
instance Arbitrary Export where
arbitrary = genExport
shrink = genericShrink
genElement :: Gen Element
genElement =
Element <$> genTableIndex <*> genExpression <*> listOf genFunctionIndex
instance Arbitrary Element where
arbitrary = genElement
shrink = genericShrink
genLocals :: Gen Locals
genLocals = Locals <$> chooseAny <*> genValueType
instance Arbitrary Locals where
arbitrary = genLocals
shrink = genericShrink
genFunction :: Gen Function
genFunction = Function <$> listOf genLocals <*> genExpression
instance Arbitrary Function where
arbitrary = genFunction
shrink = genericShrink
genDataSegment :: Gen DataSegment
genDataSegment = DataSegment <$> genMemoryIndex <*> genExpression <*> genSBS
instance Arbitrary DataSegment where
arbitrary = genDataSegment
shrink = genericShrink
genSection :: Gen Section
genSection =
oneof
[ CustomSection <$> genCustom,
TypeSection <$> listOf genFunctionType,
ImportSection <$> listOf genImport,
FunctionSection <$> listOf genFunctionTypeIndex,
TableSection <$> listOf genTable,
MemorySection <$> listOf genMemory,
GlobalSection <$> listOf genGlobal,
ExportSection <$> listOf genExport,
StartSection <$> genFunctionIndex,
ElementSection <$> listOf genElement,
CodeSection <$> listOf genFunction,
DataSection <$> listOf genDataSegment
]
instance Arbitrary Section where
arbitrary = genSection
shrink = genericShrink
genModule :: Gen Module
genModule = Module <$> listOf genSection
isExportSection,
isElementSection,
isCodeSection,
isDataSection ::
Section -> Bool
isExportSection sec = case sec of
ExportSection {} -> True
_ -> False
isElementSection sec = case sec of
ElementSection {} -> True
_ -> False
isCodeSection sec = case sec of
CodeSection {} -> True
_ -> False
isDataSection sec = case sec of
DataSection {} -> True
_ -> False
shrinkedFunction :: Function
shrinkedFunction =
Function {functionLocals = [], functionBody = coerce [Unreachable]}
updateList :: Int -> a -> [a] -> [a]
updateList i a l = l0 <> (a : l1) where (l0, _ : l1) = splitAt i l
shrinkCodeSection :: [Function] -> [[Function]]
shrinkCodeSection _sec =
concat
[ if _sec !! i == shrinkedFunction
then []
else [updateList i shrinkedFunction _sec]
| i <- [0 .. length _sec - 1]
]
shrinkModule :: Module -> [Module]
shrinkModule m =
_drop_sec isExportSection
<> _drop_sec isElementSection
<> _results_by_code_sec
<> _drop_sec isDataSection
where
_drop_sec f = case break f (coerce m) of
(_, []) -> []
(_pre_secs, _ : _post_secs) -> [coerce $ _pre_secs <> _post_secs]
_results_by_code_sec = case break isCodeSection (coerce m) of
(_, []) -> []
(_pre_code_secs, _code_sec : _post_code_secs) ->
[ coerce $
_pre_code_secs
<> (CodeSection _shrinked_code_sec : _post_code_secs)
| _shrinked_code_sec <- shrinkCodeSection $ functions' _code_sec
]

View File

@ -1,55 +0,0 @@
module NodeCompile
( testNodeCompileWithShrink,
)
where
import Control.Exception
import Data.Binary.Put
import qualified Data.ByteString.Lazy as LBS
import Language.WebAssembly.WireFormat
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.Process
import Test.QuickCheck
import Test.QuickCheck.Monadic
testNodeCompile :: Module -> Property
testNodeCompile m = monadicIO $ do
_result <- run $ do
tmpdir <- getTemporaryDirectory
bracket
(openBinaryTempFile tmpdir "wasm-toolkit-test.wasm")
(\(p, _) -> removeFile p)
( \(p, h) -> do
LBS.hPut h $ runPut $ putModule m
hClose h
(_exit_code, _stdout, _stderr) <-
readProcessWithExitCode
"node"
["test" </> "node-compile.js", p]
""
case _exit_code of
ExitSuccess -> pure Nothing
_ -> do
(p_err, h_err) <- openTempFile tmpdir "wasm-toolkit-test-dump.txt"
hPutStr h_err $ show m
hClose h_err
pure $ Just (_exit_code, _stdout, _stderr, p_err)
)
case _result of
Just (_exit_code, _stdout, _stderr, p_err) ->
fail $
"Compiling serialized module via Node.js failed.\nExit code: "
<> show _exit_code
<> "\nStdout: "
<> _stdout
<> "\nStderr: "
<> _stderr
<> "\nModule dump path: "
<> p_err
_ -> pure ()
testNodeCompileWithShrink :: (Module -> [Module]) -> Module -> Property
testNodeCompileWithShrink s m = shrinking s m testNodeCompile

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

View File

@ -1,14 +0,0 @@
"use strict";
const fs = require("fs").promises;
async function compileWasmFromFilePath(p) {
const buf = await fs.readFile(p);
return WebAssembly.compile(buf);
}
process.on("unhandledRejection", err => {
throw err;
});
compileWasmFromFilePath(process.argv[2]);

Binary file not shown.

Binary file not shown.

View File

@ -1,116 +0,0 @@
{-# OPTIONS_GHC -Wno-overflowed-literals #-}
import Control.Monad
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString.Lazy as LBS
import Data.Foldable
import Language.WebAssembly.WireFormat
import Language.WebAssembly.WireFormat.Orphans
import Test.QuickCheck
import Test.QuickCheck.Gen
testCodecGen ::
(Eq a, Show a) => Gen a -> (a -> [a]) -> Get a -> (a -> Put) -> Property
testCodecGen gen s g p = forAllShrink gen s $ \x ->
let buf = runPut $ p x
in case runGetOrFail g buf of
Right (rest, _, r)
| r /= x || not (LBS.null rest) ->
counterexample
( "testCodeGen: failed to parse.\nBefore: "
<> show x
<> "\nBuffer: "
<> show buf
<> "\nAfter: "
<> show r
<> "\nResidule: "
<> show rest
)
False
| otherwise -> property True
_ ->
counterexample
( "testCodecGen: failed to parse.\nBefore: "
<> show x
<> "\nBuffer: "
<> show buf
)
False
testCodecFile ::
(Eq a, Show a) =>
LBS.ByteString ->
(a -> [a]) ->
Get a ->
(a -> Put) ->
Property
testCodecFile buf s g p = case runGetOrFail g buf of
Right (rest, _, x)
| LBS.null rest -> testCodecGen (pure x) s g p
| otherwise ->
counterexample
( "testCodecFile: failed to parse.\nBuffer: "
<> show buf
<> "\nResult: "
<> show x
<> "\nResidule: "
<> show rest
)
False
_ ->
counterexample
("testCodecFile: failed to parse.\nBuffer: " <> show buf)
False
testCodecModule :: FilePath -> IO Property
testCodecModule p = do
buf <- LBS.readFile p
pure $ testCodecFile buf genericShrink getModule putModule
testLEB128Static :: Property
testLEB128Static =
conjoin
[ testCodecGen (pure 0) (const []) getVU32 putVU32,
testCodecGen (pure maxBound) (const []) getVU32 putVU32,
testCodecGen (pure minBound) (const []) getVS32 putVS32,
testCodecGen (pure (-1)) (const []) getVS32 putVS32,
testCodecGen (pure 0) (const []) getVS32 putVS32,
testCodecGen (pure maxBound) (const []) getVS32 putVS32,
testCodecGen (pure minBound) (const []) getVS64 putVS64,
testCodecGen (pure (-1)) (const []) getVS64 putVS64,
testCodecGen (pure 0) (const []) getVS64 putVS64,
testCodecGen (pure maxBound) (const []) getVS64 putVS64,
testCodecGen (pure 0xFFFFFFFFFFFFFFF8) (const []) getVS64 putVS64
]
testLEB128Dynamic :: Property
testLEB128Dynamic =
conjoin
[ testCodecGen chooseAny (const []) getVU32 putVU32,
testCodecGen chooseAny (const []) getVS32 putVS32,
testCodecGen chooseAny (const []) getVS64 putVS64,
testCodecGen chooseAny (const []) getF32 putF32,
testCodecGen chooseAny (const []) getF64 putF64
]
main :: IO ()
main = do
quickCheck testLEB128Static
for_
[ "test/array.wasm",
"test/clang-fib.wasm",
"test/fib.wasm",
"test/jsffi.wasm",
"test/rtsapi.wasm",
"test/stableptr.wasm"
]
$ testCodecModule
>=> quickCheck
r <-
quickCheckResult $
conjoin
[ testLEB128Dynamic,
testCodecGen genModule genericShrink getModule putModule
]
writeFile "test/wasm-toolkit-codec.txt" $ show r