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:
parent
e0c6b9548f
commit
9f2574d9c2
@ -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
|
||||
|
@ -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 $
|
||||
|
@ -65,7 +65,6 @@ dependencies:
|
||||
- mtl
|
||||
- process
|
||||
- transformers
|
||||
- wasm-toolkit
|
||||
|
||||
internal-libraries:
|
||||
asterius-types:
|
||||
|
@ -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);
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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"
|
||||
|
@ -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
|
||||
|
@ -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,
|
||||
|
@ -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)
|
||||
|
@ -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
|
@ -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
|
||||
|
@ -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"
|
||||
|
@ -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()"
|
@ -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
|
||||
<> "}))"
|
||||
|
@ -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 ()
|
||||
|
@ -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
|
||||
]
|
||||
|
@ -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 = [],
|
||||
|
@ -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,
|
||||
|
@ -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
|
@ -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 = []
|
||||
}
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -1,4 +1,3 @@
|
||||
packages:
|
||||
asterius
|
||||
ghc-toolkit
|
||||
wasm-toolkit
|
||||
|
@ -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
|
||||
|
@ -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": {
|
||||
|
@ -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
|
||||
|
||||
|
@ -1 +0,0 @@
|
||||
# CHANGELOG for `wasm-toolkit`
|
@ -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.
|
@ -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`)
|
@ -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
@ -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
|
||||
]
|
@ -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.
@ -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.
@ -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
|
Loading…
Reference in New Issue
Block a user