diff --git a/asterius/package.yaml b/asterius/package.yaml index 92f6007c..022a0e05 100644 --- a/asterius/package.yaml +++ b/asterius/package.yaml @@ -37,6 +37,7 @@ dependencies: - containers - deepseq - directory + - dlist - filepath - ghc - ghc-prim diff --git a/asterius/src/Asterius/Builtins.hs b/asterius/src/Asterius/Builtins.hs index 8890eea5..d95f6d9f 100644 --- a/asterius/src/Asterius/Builtins.hs +++ b/asterius/src/Asterius/Builtins.hs @@ -29,9 +29,12 @@ module Asterius.Builtins ) where import Asterius.BuildInfo +import Asterius.EDSL import Asterius.Internals import Asterius.Types +import Asterius.TypesConv import qualified Data.ByteString.Short as SBS +import Data.Foldable import Data.List import Data.Maybe import qualified Data.Vector as V @@ -151,12 +154,6 @@ rtsAsteriusModule opts = ] } -generateWasmFunctionTypeName :: FunctionType -> SBS.ShortByteString -generateWasmFunctionTypeName FunctionType {..} = - showSBS returnType <> "(" <> - mconcat (intersperse "," [showSBS t | t <- V.toList paramTypes]) <> - ")" - rtsAsteriusFunctionImports :: Bool -> [AsteriusFunctionImport] rtsAsteriusFunctionImports debug = [ AsteriusFunctionImport @@ -347,328 +344,110 @@ errBrokenFunction = 11 mainFunction, initRtsAsteriusFunction, rtsEvalIOFunction, scheduleWaitThreadFunction, createThreadFunction, createGenThreadFunction, createIOThreadFunction, createStrictIOThreadFunction, allocateFunction, allocateMightFailFunction, allocatePinnedFunction, allocBlockFunction, allocBlockLockFunction, allocBlockOnNodeFunction, allocBlockOnNodeLockFunction, allocGroupFunction, allocGroupLockFunction, allocGroupOnNodeFunction, allocGroupOnNodeLockFunction, freeFunction, newCAFFunction, stgRunFunction, stgReturnFunction, printI64Function, printF32Function, printF64Function, memoryTrapFunction :: BuiltinsOptions -> AsteriusFunction mainFunction BuiltinsOptions {..} = - AsteriusFunction - { functionType = FunctionType {returnType = None, paramTypes = []} - , body = - Block - { name = "" - , bodys = - [ Call - { target = "init_rts_asterius" - , operands = [] - , valueType = None - } - , Call - { target = "rts_evalIO" - , operands = - [ mainCap - , Unresolved {unresolvedSymbol = "Main_main_closure"} - , constInt 0 - ] - , valueType = None - } - ] - , valueType = None - } - } + runEDSL $ do + call "init_rts_asterius" [] + call "rts_evalIO" [mainCapability, symbol "Main_main_closure", constI64 0] initRtsAsteriusFunction BuiltinsOptions {..} = - AsteriusFunction - { functionType = FunctionType {returnType = None, paramTypes = []} - , body = - Block - { name = "" - , bodys = - [ UnresolvedSetLocal - { unresolvedLocalReg = UniqueLocalReg 0 I64 - , value = - Call - { target = "allocGroup" - , operands = [constInt nurseryGroups] - , valueType = I64 - } - } - , UnresolvedSetGlobal - { unresolvedGlobalReg = Hp - , value = getFieldWord bd offset_bdescr_start - } - , UnresolvedSetGlobal - { unresolvedGlobalReg = HpLim - , value = - Binary - { binaryOp = AddInt64 - , operand0 = - UnresolvedGetGlobal {unresolvedGlobalReg = Hp} - , operand1 = - Binary - { binaryOp = MulInt64 - , operand0 = - Unary - { unaryOp = ExtendUInt32 - , operand0 = - getFieldWord32 bd offset_bdescr_blocks - } - , operand1 = constInt block_size - } - } - } - , setFieldWord baseReg offset_StgRegTable_rCCCS (ConstI64 0) - , setFieldWord baseReg offset_StgRegTable_rCurrentNursery bd - , setFieldWord baseReg offset_StgRegTable_rCurrentAlloc bd - , UnresolvedSetLocal - { unresolvedLocalReg = UniqueLocalReg 1 I64 - , value = - Call - { target = "allocate" - , operands = - [ mainCap - , constInt $ roundup_bytes_to_words sizeof_Task - ] - , valueType = I64 - } - } - , UnresolvedSetLocal - { unresolvedLocalReg = UniqueLocalReg 2 I64 - , value = - Call - { target = "allocate" - , operands = - [ mainCap - , constInt $ roundup_bytes_to_words sizeof_InCall - ] - , valueType = I64 - } - } - , setFieldWord mainCap offset_Capability_running_task task - , setFieldWord task offset_Task_cap mainCap - , setFieldWord task offset_Task_incall incall - , setFieldWord incall offset_InCall_task task - ] - , valueType = None - } - } - where - bd = getUnresolvedLocalWord 0 - task = getUnresolvedLocalWord 1 - incall = getUnresolvedLocalWord 2 + runEDSL $ do + bd <- call' "allocGroup" [constI64 nurseryGroups] I64 + putLVal hp $ loadI64 bd offset_bdescr_start + putLVal hpLim $ + getLVal hp `addInt64` + (extendUInt32 (loadI32 bd offset_bdescr_blocks) `mulInt64` + constI64 block_size) + putLVal cccs (constI64 0) + putLVal currentNursery bd + storeI64 (getLVal baseReg) offset_StgRegTable_rCurrentAlloc bd + task <- + call' + "allocate" + [mainCapability, constI64 $ roundup_bytes_to_words sizeof_Task] + I64 + incall <- + call' + "allocate" + [mainCapability, constI64 $ roundup_bytes_to_words sizeof_InCall] + I64 + storeI64 mainCapability offset_Capability_running_task task + storeI64 task offset_Task_cap mainCapability + storeI64 task offset_Task_incall incall + storeI64 incall offset_InCall_task task rtsEvalIOFunction BuiltinsOptions {..} = - AsteriusFunction - { functionType = - FunctionType {returnType = None, paramTypes = [I64, I64, I64]} - , body = - Block - { name = "" - , bodys = - [ UnresolvedSetLocal - { unresolvedLocalReg = UniqueLocalReg 3 I64 - , value = - Call - { target = "createStrictIOThread" - , operands = - [ cap - , constInt $ roundup_bytes_to_words threadStateSize - , p - ] - , valueType = I64 - } - } - , Call - { target = "scheduleWaitThread" - , operands = [tso, ret, cap] - , valueType = None - } - ] - , valueType = None - } - } - where - cap = mainCap - p = getLocalWord 1 - ret = getLocalWord 2 - tso = getUnresolvedLocalWord 3 + runEDSL $ do + [cap, p, ret] <- params [I64, I64, I64] + tso <- + call' + "createStrictIOThread" + [cap, constI64 $ roundup_bytes_to_words threadStateSize, p] + I64 + call "scheduleWaitThread" [tso, ret, cap] scheduleWaitThreadFunction _ = - AsteriusFunction - { functionType = - FunctionType {returnType = None, paramTypes = [I64, I64, I64]} - , body = - Block - { name = "" - , bodys = - [ UnresolvedSetLocal - { unresolvedLocalReg = UniqueLocalReg 3 I64 - , value = getFieldWord cap offset_Capability_running_task - } - , setFieldWord tso offset_StgTSO_bound $ - getFieldWord task offset_Task_incall - , setFieldWord tso offset_StgTSO_cap cap - , UnresolvedSetLocal - { unresolvedLocalReg = UniqueLocalReg 4 I64 - , value = getFieldWord task offset_Task_incall - } - , setFieldWord incall offset_InCall_tso tso - , setFieldWord incall offset_InCall_ret ret - , setFieldWord - cap - (offset_Capability_r + offset_StgRegTable_rCurrentTSO) - tso - , setFieldWord32 cap offset_Capability_interrupt (ConstI32 0) - , UnresolvedSetLocal - { unresolvedLocalReg = UniqueLocalReg 5 I64 - , value = - Call - { target = "StgRun" - , operands = - [ Unresolved - {unresolvedSymbol = "stg_returnToStackTop"} - , fieldOff cap offset_Capability_r - ] - , valueType = I64 - } - } - , setFieldWord incall offset_InCall_ret $ - getFieldWord - (getFieldWord tso $ - offset_StgTSO_StgStack + offset_StgStack_sp) - 8 - ] - , valueType = None - } - } - where - tso = getLocalWord 0 - ret = getLocalWord 1 - cap = mainCap - task = getUnresolvedLocalWord 3 - incall = getUnresolvedLocalWord 4 + runEDSL $ do + [tso, ret, cap] <- params [I64, I64, I64] + task <- i64Local $ loadI64 cap offset_Capability_running_task + storeI64 tso offset_StgTSO_bound $ loadI64 task offset_Task_incall + storeI64 tso offset_StgTSO_cap cap + incall <- i64Local $ loadI64 task offset_Task_incall + storeI64 incall offset_InCall_tso tso + storeI64 incall offset_InCall_ret ret + storeI64 cap (offset_Capability_r + offset_StgRegTable_rCurrentTSO) tso + storeI32 cap offset_Capability_interrupt (constI32 0) + _ <- + call' + "StgRun" + [ symbol "stg_returnToStackTop" + , cap `addInt64` constI64 offset_Capability_r + ] + I64 + storeI64 incall offset_InCall_ret $ + loadI64 (loadI64 tso $ offset_StgTSO_StgStack + offset_StgStack_sp) 8 createThreadFunction _ = - AsteriusFunction - { functionType = FunctionType {returnType = I64, paramTypes = [I64, I64]} - , body = - Block - { name = "" - , bodys = - [ UnresolvedSetLocal - { unresolvedLocalReg = UniqueLocalReg 2 I64 - , value = - Call - { target = "allocate" - , operands = [getLocalWord 0, alloc_words] - , valueType = I64 - } - } - , UnresolvedSetGlobal - {unresolvedGlobalReg = CurrentTSO, value = tso_p} - , saveUnresolvedSp 3 tso_p - , setFieldWord - stack_p - 0 - Unresolved {unresolvedSymbol = "stg_STACK_info"} - , UnresolvedSetLocal - { unresolvedLocalReg = UniqueLocalReg 4 I64 - , value = - Binary - { binaryOp = SubInt64 - , operand0 = alloc_words - , operand1 = - constInt $ - (offset_StgTSO_StgStack + offset_StgStack_stack) `div` - 8 - } - } - , setFieldWord32 - stack_p - offset_StgStack_stack_size - (wrapI64 stack_size_w) - , UnresolvedSetGlobal - { unresolvedGlobalReg = Sp - , value = - Binary - { binaryOp = AddInt64 - , operand0 = fieldOff stack_p offset_StgStack_stack - , operand1 = - words2Bytes - Binary - { binaryOp = SubInt64 - , operand0 = stack_size_w - , operand1 = - constInt $ - roundup_bytes_to_words sizeof_StgStopFrame - } - } - } - , setFieldWord stack_p offset_StgStack_sp sp - , setFieldWord tso_p offset_StgTSO_cap cap - , setFieldWord tso_p offset_StgTSO_stackobj stack_p - , setFieldWord tso_p offset_StgTSO_alloc_limit (ConstI64 0) - , setFieldWord - sp - 0 - Unresolved {unresolvedSymbol = "stg_stop_thread_info"} - , tso_p - ] - , valueType = I64 - } - } - where - cap = mainCap - alloc_words = getLocalWord 1 - tso_p = getUnresolvedLocalWord 2 - stack_p = getUnresolvedLocalWord 3 - stack_size_w = getUnresolvedLocalWord 4 - sp = UnresolvedGetGlobal {unresolvedGlobalReg = Sp} + runEDSL $ do + setReturnType I64 + [cap, alloc_words] <- params [I64, I64] + tso_p <- call' "allocate" [cap, alloc_words] I64 + putLVal currentTSO tso_p + stack_p <- i64Local $ tso_p `addInt64` constI64 offset_StgTSO_StgStack + storeI64 stack_p 0 $ symbol "stg_STACK_info" + stack_size_w <- + i64Local $ + alloc_words `subInt64` + constI64 ((offset_StgTSO_StgStack + offset_StgStack_stack) `div` 8) + storeI32 stack_p offset_StgStack_stack_size $ wrapInt64 stack_size_w + putLVal sp $ + (stack_p `addInt64` constI64 offset_StgStack_stack) `addInt64` + (stack_size_w `subInt64` + constI64 (roundup_bytes_to_words sizeof_StgStopFrame) `mulInt64` + constI64 8) + storeI64 stack_p offset_StgStack_sp (getLVal sp) + storeI64 tso_p offset_StgTSO_cap cap + storeI64 tso_p offset_StgTSO_stackobj stack_p + storeI64 tso_p offset_StgTSO_alloc_limit (constI64 0) + storeI64 (getLVal sp) 0 $ symbol "stg_stop_thread_info" + emit tso_p createThreadHelperFunction :: BuiltinsOptions -> [Maybe AsteriusEntitySymbol] -> AsteriusFunction createThreadHelperFunction _ closures = - AsteriusFunction - { functionType = - FunctionType {returnType = I64, paramTypes = [I64, I64, I64]} - , body = - Block - { name = "" - , bodys = - V.fromList $ - [ UnresolvedSetLocal - { unresolvedLocalReg = UniqueLocalReg 3 I64 - , value = - Call - { target = "createThread" - , operands = [cap, stack_size_w] - , valueType = I64 - } - } - , saveUnresolvedSp 4 tso_p - , UnresolvedSetGlobal - { unresolvedGlobalReg = Sp - , value = - fieldOff - (getFieldWord stack_p offset_StgStack_sp) - (-8 * length closures) - } - , setFieldWord stack_p offset_StgStack_sp sp - ] <> - [ setFieldWord - sp - (i * 8) - (case maybe_closure of - Just closure -> Unresolved {unresolvedSymbol = closure} - _ -> target_closure) - | (i, maybe_closure) <- zip [0 ..] (reverse closures) - ] <> - [tso_p] - , valueType = I64 - } - } - where - cap = mainCap - stack_size_w = getLocalWord 1 - target_closure = getLocalWord 2 - tso_p = getUnresolvedLocalWord 3 - stack_p = getUnresolvedLocalWord 4 - sp = UnresolvedGetGlobal {unresolvedGlobalReg = Sp} + runEDSL $ do + setReturnType I64 + [cap, stack_size_w, target_closure] <- params [I64, I64, I64] + tso_p <- call' "createThread" [cap, stack_size_w] I64 + stack_p <- i64Local $ tso_p `addInt64` constI64 offset_StgTSO_StgStack + putLVal sp $ + loadI64 stack_p offset_StgStack_sp `addInt64` + constI64 (-8 * length closures) + storeI64 stack_p offset_StgStack_sp $ getLVal sp + for_ (zip [0 ..] (reverse closures)) $ \(i, maybe_closure) -> + storeI64 (getLVal sp) (i * 8) $ + case maybe_closure of + Just closure -> symbol closure + _ -> target_closure + emit tso_p createGenThreadFunction opts = createThreadHelperFunction opts [Nothing, Just "stg_enter_info"] @@ -688,338 +467,163 @@ createStrictIOThreadFunction opts = ] allocateFunction _ = - AsteriusFunction - { functionType = FunctionType {returnType = I64, paramTypes = [I64, I64]} - , body = - Block - { name = "" - , bodys = - [ UnresolvedSetLocal - { unresolvedLocalReg = UniqueLocalReg 2 I64 - , value = - Binary - { binaryOp = AddInt64 - , operand0 = - UnresolvedGetGlobal {unresolvedGlobalReg = Hp} - , operand1 = words2Bytes n - } - } - , If - { condition = - Binary - { binaryOp = GtSInt64 - , operand0 = new_hp - , operand1 = - UnresolvedGetGlobal {unresolvedGlobalReg = HpLim} - } - , ifTrue = marshalErrorCode errHeapOverflow None - , ifFalse = Null - } - , UnresolvedSetLocal - { unresolvedLocalReg = UniqueLocalReg 3 I64 - , value = UnresolvedGetGlobal {unresolvedGlobalReg = Hp} - } - , UnresolvedSetGlobal {unresolvedGlobalReg = Hp, value = new_hp} - , setFieldWord - (getFieldWord baseReg offset_StgRegTable_rCurrentAlloc) - offset_bdescr_free - new_hp - , old_hp - ] - , valueType = I64 - } - } - where - n = getLocalWord 1 - new_hp = getUnresolvedLocalWord 2 - old_hp = getUnresolvedLocalWord 3 + runEDSL $ do + setReturnType I64 + [_, n] <- params [I64, I64] + new_hp <- i64Local $ getLVal hp `addInt64` (n `mulInt64` constI64 8) + if' + (new_hp `gtUInt64` getLVal hpLim) + (emit $ marshalErrorCode errHeapOverflow None) + mempty + old_hp <- i64Local $ getLVal hp + putLVal hp new_hp + storeI64 + (loadI64 (getLVal baseReg) offset_StgRegTable_rCurrentAlloc) + offset_bdescr_free + new_hp + emit old_hp allocateMightFailFunction _ = - AsteriusFunction - { functionType = FunctionType {returnType = I64, paramTypes = [I64, I64]} - , body = - Call - { target = "allocate" - , operands = [getLocalWord 0, getLocalWord 1] - , valueType = I64 - } - } + runEDSL $ do + setReturnType I64 + xs <- params [I64, I64] + r <- call' "allocate" xs I64 + emit r -allocatePinnedFunction _ = - AsteriusFunction - { functionType = FunctionType {returnType = I64, paramTypes = [I64, I64]} - , body = - Call - { target = "allocate" - , operands = [getLocalWord 0, getLocalWord 1] - , valueType = I64 - } - } +allocatePinnedFunction = allocateMightFailFunction allocBlockFunction _ = - AsteriusFunction - { functionType = FunctionType {returnType = I64, paramTypes = []} - , body = - Call {target = "allocGroup", operands = [ConstI64 1], valueType = I64} - } + runEDSL $ do + setReturnType I64 + r <- call' "allocGroup" [constI64 1] I64 + emit r allocBlockLockFunction _ = - AsteriusFunction - { functionType = FunctionType {returnType = I64, paramTypes = []} - , body = Call {target = "allocBlock", operands = [], valueType = I64} - } + runEDSL $ do + setReturnType I64 + r <- call' "allocBlock" [] I64 + emit r allocBlockOnNodeFunction _ = - AsteriusFunction - { functionType = FunctionType {returnType = I64, paramTypes = [I32]} - , body = Call {target = "allocBlock", operands = [], valueType = I64} - } + runEDSL $ do + setReturnType I64 + _ <- param I32 + r <- call' "allocBlock" [] I64 + emit r allocBlockOnNodeLockFunction _ = - AsteriusFunction - { functionType = FunctionType {returnType = I64, paramTypes = [I32]} - , body = - Call - { target = "allocBlockOnNode" - , operands = [GetLocal {index = 0, valueType = I32}] - , valueType = I64 - } - } + runEDSL $ do + setReturnType I64 + node <- param I32 + r <- call' "allocBlockOnNode" [node] I64 + emit r allocGroupFunction _ = - AsteriusFunction - { functionType = FunctionType {returnType = I64, paramTypes = [I64]} - , body = - Block - { name = "" - , bodys = - [ If - { condition = - Binary - { binaryOp = GtSInt64 - , operand0 = blocks_n - , operand1 = constInt $ 1024 * blocks_per_mblock - } - , ifTrue = marshalErrorCode errMegaBlockGroup None - , ifFalse = Null - } - , UnresolvedSetLocal - { unresolvedLocalReg = UniqueLocalReg 1 I64 - , value = - Binary - { binaryOp = MulInt64 - , operand0 = - Unary - { unaryOp = ExtendUInt32 - , operand0 = - Host - { hostOp = GrowMemory - , name = "" - , operands = - [ constInt32 $ - 1024 * - (mblock_size `div` wasmPageSize) - ] - } - } - , operand1 = constInt wasmPageSize - } - } - , setFieldWord - mblocks_p - (offset_first_bdescr + offset_bdescr_start) - first_block_p - , setFieldWord - mblocks_p - (offset_first_bdescr + offset_bdescr_free) - first_block_p - , setFieldWord32 - mblocks_p - (offset_first_bdescr + offset_bdescr_blocks) $ - constInt32 $ - blocks_per_mblock + ((1023 * mblock_size) `div` block_size) - , fieldOff mblocks_p offset_first_bdescr - ] - , valueType = I64 - } - } - where - first_block_p = fieldOff mblocks_p offset_first_block - blocks_n = getLocalWord 0 - mblocks_p = getUnresolvedLocalWord 1 + runEDSL $ do + setReturnType I64 + blocks_n <- param I64 + if' + (blocks_n `gtUInt64` constI64 (1024 * blocks_per_mblock)) + (emit $ marshalErrorCode errMegaBlockGroup None) + mempty + mblocks_p <- + i64Local $ + extendUInt32 + (growMemory (constI32 (1024 * (mblock_size `div` wasmPageSize)))) `mulInt64` + constI64 wasmPageSize + first_block_p <- i64Local $ mblocks_p `addInt64` constI64 offset_first_block + storeI64 mblocks_p (offset_first_bdescr + offset_bdescr_start) first_block_p + storeI64 mblocks_p (offset_first_bdescr + offset_bdescr_free) first_block_p + storeI32 mblocks_p (offset_first_bdescr + offset_bdescr_blocks) $ + constI32 $ blocks_per_mblock + ((1023 * mblock_size) `div` block_size) + emit $ mblocks_p `addInt64` constI64 offset_first_bdescr allocGroupLockFunction _ = - AsteriusFunction - { functionType = FunctionType {returnType = I64, paramTypes = [I64]} - , body = - Call - {target = "allocGroup", operands = [getLocalWord 0], valueType = I64} - } + runEDSL $ do + setReturnType I64 + x <- param I64 + r <- call' "allocGroup" [x] I64 + emit r allocGroupOnNodeFunction _ = - AsteriusFunction - { functionType = FunctionType {returnType = I64, paramTypes = [I32, I64]} - , body = - Call - {target = "allocGroup", operands = [getLocalWord 1], valueType = I64} - } + runEDSL $ do + setReturnType I64 + [_, x] <- params [I32, I64] + r <- call' "allocGroup" [x] I64 + emit r allocGroupOnNodeLockFunction _ = - AsteriusFunction - { functionType = FunctionType {returnType = I64, paramTypes = [I32, I64]} - , body = - Call - { target = "allocGroupOnNode" - , operands = [GetLocal {index = 0, valueType = I32}, getLocalWord 1] - , valueType = I64 - } - } + runEDSL $ do + setReturnType I64 + xs <- params [I32, I64] + r <- call' "allocGroupOnNode" xs I64 + emit r freeFunction _ = - AsteriusFunction - { functionType = FunctionType {returnType = None, paramTypes = [I64]} - , body = marshalErrorCode errUnimplemented None - } + runEDSL $ do + _ <- param I64 + emit $ marshalErrorCode errUnimplemented None newCAFFunction _ = - AsteriusFunction - { functionType = FunctionType {returnType = I64, paramTypes = [I64, I64]} - , body = - Block - { name = "" - , bodys = - [ setFieldWord caf offset_StgIndStatic_saved_info orig_info - , UnresolvedSetLocal - { unresolvedLocalReg = UniqueLocalReg 2 I64 - , value = - Call - { target = "allocate" - , operands = - [ cap - , constInt $ roundup_bytes_to_words sizeof_StgInd - ] - , valueType = I64 - } - } - , setFieldWord - bh - 0 - Unresolved {unresolvedSymbol = "stg_CAF_BLACKHOLE_info"} - , setFieldWord bh offset_StgInd_indirectee $ - getFieldWord reg offset_StgRegTable_rCurrentTSO - , setFieldWord caf offset_StgIndStatic_indirectee bh - , setFieldWord - caf - 0 - Unresolved {unresolvedSymbol = "stg_IND_STATIC_info"} - , bh - ] - , valueType = I64 - } - } - where - reg = getLocalWord 0 - caf = getLocalWord 1 - cap = mainCap - orig_info = getFieldWord caf 0 - bh = getUnresolvedLocalWord 2 + runEDSL $ do + setReturnType I64 + [reg, caf] <- params [I64, I64] + orig_info <- i64Local $ loadI64 caf 0 + storeI64 caf offset_StgIndStatic_saved_info orig_info + bh <- + call' + "allocate" + [mainCapability, constI64 $ roundup_bytes_to_words sizeof_StgInd] + I64 + storeI64 bh 0 $ symbol "stg_CAF_BLACKHOLE_info" + storeI64 bh offset_StgInd_indirectee $ + loadI64 reg offset_StgRegTable_rCurrentTSO + storeI64 caf offset_StgIndStatic_indirectee bh + storeI64 caf 0 $ symbol "stg_IND_STATIC_info" + emit bh stgRunFunction BuiltinsOptions {..} = - AsteriusFunction - { functionType = FunctionType {returnType = I64, paramTypes = [I64, I64]} - , body = - Block - { name = "" - , bodys = - [ Loop - { name = loop_lbl - , body = - If - { condition = Unary {unaryOp = EqZInt64, operand0 = f} - , ifTrue = Nop - , ifFalse = - Block - { name = "" - , bodys = - [ SetLocal - { index = 0 - , value = - CallIndirect - { indirectTarget = - Unary - { unaryOp = WrapInt64 - , operand0 = - Binary - { binaryOp = SubInt64 - , operand0 = - GetLocal - { index = 0 - , valueType = I64 - } - , operand1 = ConstI64 1 - } - } - , operands = [] - , typeName = "I64()" - } - } - , Break - { name = loop_lbl - , condition = Null - , value = Null - } - ] - , valueType = None - } - } - } - , UnresolvedGetGlobal {unresolvedGlobalReg = VanillaReg 1} - ] - , valueType = I64 - } - } - where - loop_lbl = "StgRun_loop" - f = getLocalWord 0 + runEDSL $ do + setReturnType I64 + f <- mutParam I64 + _ <- param I64 + loop $ \loop_lbl -> + if' (eqZInt64 (getLVal f)) mempty $ do + f' <- + callIndirect' + (getLVal f `subInt64` constI64 1) + [] + (FunctionType I64 []) + putLVal f f' + break' loop_lbl Null + emit $ getLVal r1 stgReturnFunction _ = - AsteriusFunction - { functionType = FunctionType {returnType = I64, paramTypes = []} - , body = ConstI64 0 - } + runEDSL $ do + setReturnType I64 + emit $ constI64 0 printI64Function _ = - AsteriusFunction - { functionType = FunctionType {returnType = None, paramTypes = [I64]} - , body = - CallImport {target' = "printI64", operands = cutI64 x, valueType = None} - } - where - x = getLocalWord 0 + runEDSL $ do + x <- param I64 + callImport "printI64" (V.toList (cutI64 x)) printF32Function _ = - AsteriusFunction - { functionType = FunctionType {returnType = None, paramTypes = [F32]} - , body = CallImport {target' = "printF32", operands = [x], valueType = None} - } - where - x = GetLocal {index = 0, valueType = F32} + runEDSL $ do + x <- param F32 + callImport "printF32" [x] printF64Function _ = - AsteriusFunction - { functionType = FunctionType {returnType = None, paramTypes = [F64]} - , body = CallImport {target' = "printF64", operands = [x], valueType = None} - } - where - x = GetLocal {index = 0, valueType = F64} + runEDSL $ do + x <- param F64 + callImport "printF64" [x] getI32GlobalRegFunction :: BuiltinsOptions -> UnresolvedGlobalReg -> AsteriusFunction getI32GlobalRegFunction _ gr = - AsteriusFunction - { functionType = FunctionType {returnType = I32, paramTypes = []} - , body = wrapI64 UnresolvedGetGlobal {unresolvedGlobalReg = gr} - } + runEDSL $ do + setReturnType I32 + emit $ wrapInt64 $ getLVal $ global gr memoryTrapFunction _ = AsteriusFunction @@ -1233,66 +837,23 @@ fieldOff p o getFieldWord :: Expression -> Int -> Expression getFieldWord p o = loadWord (wrapI64 $ fieldOff p o) -getFieldWord32 :: Expression -> Int -> Expression -getFieldWord32 p o = loadWord32 (wrapI64 $ fieldOff p o) - -setFieldWord :: Expression -> Int -> Expression -> Expression -setFieldWord p o = storeWord (wrapI64 $ fieldOff p o) - loadWord :: Expression -> Expression loadWord p = Load {signed = False, bytes = 8, offset = 0, align = 0, valueType = I64, ptr = p} -loadWord32 :: Expression -> Expression -loadWord32 p = - Load - {signed = False, bytes = 4, offset = 0, align = 0, valueType = I32, ptr = p} - -storeWord :: Expression -> Expression -> Expression -storeWord p w = - Store {bytes = 8, offset = 0, align = 0, ptr = p, value = w, valueType = I64} - -setFieldWord32 :: Expression -> Int -> Expression -> Expression -setFieldWord32 p o = storeWord32 (wrapI64 $ fieldOff p o) - -storeWord32 :: Expression -> Expression -> Expression -storeWord32 p w = - Store {bytes = 4, offset = 0, align = 0, ptr = p, value = w, valueType = I32} - wrapI64 :: Expression -> Expression wrapI64 w = Unary {unaryOp = WrapInt64, operand0 = w} -words2Bytes :: Expression -> Expression -words2Bytes w = - Binary {binaryOp = MulInt64, operand0 = w, operand1 = ConstI64 8} - constInt :: Int -> Expression constInt = ConstI64 . fromIntegral -constInt32 :: Int -> Expression -constInt32 = ConstI32 . fromIntegral - -getUnresolvedLocalWord :: Int -> Expression -getUnresolvedLocalWord i = - UnresolvedGetLocal {unresolvedLocalReg = UniqueLocalReg i I64} - getLocalWord :: BinaryenIndex -> Expression getLocalWord i = GetLocal {index = i, valueType = I64} -saveUnresolvedSp :: Int -> Expression -> Expression -saveUnresolvedSp sp_i tso_p = - UnresolvedSetLocal - { unresolvedLocalReg = UniqueLocalReg sp_i I64 - , value = fieldOff tso_p offset_StgTSO_StgStack - } - mainCap :: Expression mainCap = Unresolved {unresolvedSymbol = "MainCapability"} -baseReg :: Expression -baseReg = UnresolvedGetGlobal {unresolvedGlobalReg = BaseReg} - offset_StgTSO_StgStack :: Int offset_StgTSO_StgStack = 8 * roundup_bytes_to_words sizeof_StgTSO diff --git a/asterius/src/Asterius/EDSL.hs b/asterius/src/Asterius/EDSL.hs new file mode 100644 index 00000000..4c14ce7e --- /dev/null +++ b/asterius/src/Asterius/EDSL.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} + +module Asterius.EDSL + ( EDSL + , emit + , runEDSL + , LVal + , getLVal + , putLVal + , setReturnType + , mutParam + , mutLocal + , param + , params + , local + , i64Local + , global + , pointer + , pointerI64 + , pointerI32 + , loadI64 + , loadI32 + , storeI64 + , storeI32 + , call + , call' + , callImport + , callImport' + , callIndirect' + , Label + , block + , loop + , if' + , break' + , eqZInt64 + , extendUInt32 + , wrapInt64 + , growMemory + , addInt64 + , subInt64 + , mulInt64 + , gtUInt64 + , symbol + , constI32 + , constI64 + , baseReg + , r1 + , sp + , spLim + , hp + , hpLim + , cccs + , currentTSO + , currentNursery + , hpAlloc + , mainCapability + ) where + +import Asterius.Internals +import Asterius.Types +import Asterius.TypesConv +import Control.Monad.State.Strict +import qualified Data.ByteString.Short as SBS +import qualified Data.DList as DL +import Data.Traversable +import qualified Data.Vector as V + +data EDSLState = EDSLState + { retType :: ValueType + , paramBuf :: DL.DList ValueType + , paramNum, localNum, labelNum :: Int + , exprBuf :: DL.DList Expression + } + +initialEDSLState :: EDSLState +initialEDSLState = + EDSLState + { retType = None + , paramBuf = mempty + , paramNum = 0 + , localNum = 0 + , labelNum = 0 + , exprBuf = mempty + } + +newtype EDSL a = + EDSL (State EDSLState a) + deriving (Functor, Applicative, Monad) + +instance Semigroup a => Semigroup (EDSL a) where + p0 <> p1 = (<>) <$> p0 <*> p1 + +instance Monoid a => Monoid (EDSL a) where + mempty = pure mempty + +emit :: Expression -> EDSL () +emit e = EDSL $ modify' $ \s@EDSLState {..} -> s {exprBuf = exprBuf `DL.snoc` e} + +bundleExpressions :: DL.DList Expression -> Expression +bundleExpressions es = + case el of + [] -> Nop + [e] -> e + _ -> Block {name = mempty, bodys = V.fromList el, valueType = Auto} + where + el = DL.toList es + +runEDSL :: EDSL () -> AsteriusFunction +runEDSL (EDSL m) = + AsteriusFunction + { functionType = + FunctionType + {returnType = retType, paramTypes = V.fromList $ DL.toList paramBuf} + , body = bundleExpressions exprBuf + } + where + EDSLState {..} = execState m initialEDSLState + +data LVal = LVal + { getLVal :: Expression + , putLVal :: Expression -> EDSL () + } + +setReturnType :: ValueType -> EDSL () +setReturnType vt = EDSL $ modify' $ \s -> s {retType = vt} + +mutParam, mutLocal :: ValueType -> EDSL LVal +mutParam vt = + EDSL $ do + i <- + state $ \s@EDSLState {..} -> + ( fromIntegral paramNum + , s {paramBuf = paramBuf `DL.snoc` vt, paramNum = succ paramNum}) + pure + LVal + { getLVal = GetLocal {index = i, valueType = vt} + , putLVal = \v -> emit SetLocal {index = i, value = v} + } + +mutLocal vt = + EDSL $ do + i <- state $ \s@EDSLState {..} -> (localNum, s {localNum = succ localNum}) + let lr = UniqueLocalReg i vt + pure + LVal + { getLVal = UnresolvedGetLocal {unresolvedLocalReg = lr} + , putLVal = + \v -> emit UnresolvedSetLocal {unresolvedLocalReg = lr, value = v} + } + +param :: ValueType -> EDSL Expression +param vt = do + p <- mutParam vt + pure $ getLVal p + +params :: [ValueType] -> EDSL [Expression] +params vt = for vt param + +local :: ValueType -> Expression -> EDSL Expression +local vt v = do + lr <- mutLocal vt + putLVal lr v + pure $ getLVal lr + +i64Local :: Expression -> EDSL Expression +i64Local = local I64 + +global :: UnresolvedGlobalReg -> LVal +global gr = + LVal + { getLVal = UnresolvedGetGlobal {unresolvedGlobalReg = gr} + , putLVal = + \v -> emit $ UnresolvedSetGlobal {unresolvedGlobalReg = gr, value = v} + } + +pointer :: ValueType -> BinaryenIndex -> Expression -> Int -> LVal +pointer vt b bp o = + LVal + { getLVal = + Load + { signed = False + , bytes = b + , offset = 0 + , align = 0 + , valueType = vt + , ptr = p + } + , putLVal = + \v -> + emit $ + Store + { bytes = b + , offset = 0 + , align = 0 + , ptr = p + , value = v + , valueType = vt + } + } + where + p = + wrapInt64 $ + case o of + 0 -> bp + _ -> bp `addInt64` constI64 o + +pointerI64, pointerI32 :: Expression -> Int -> LVal +pointerI64 = pointer I64 8 + +pointerI32 = pointer I32 4 + +loadI64, loadI32 :: Expression -> Int -> Expression +loadI64 bp o = getLVal $ pointerI64 bp o + +loadI32 bp o = getLVal $ pointerI32 bp o + +storeI64, storeI32 :: Expression -> Int -> Expression -> EDSL () +storeI64 bp o = putLVal $ pointerI64 bp o + +storeI32 bp o = putLVal $ pointerI32 bp o + +call :: AsteriusEntitySymbol -> [Expression] -> EDSL () +call f xs = emit Call {target = f, operands = V.fromList xs, valueType = None} + +call' :: AsteriusEntitySymbol -> [Expression] -> ValueType -> EDSL Expression +call' f xs vt = do + lr <- mutLocal vt + putLVal lr Call {target = f, operands = V.fromList xs, valueType = vt} + pure $ getLVal lr + +callImport :: SBS.ShortByteString -> [Expression] -> EDSL () +callImport f xs = + emit CallImport {target' = f, operands = V.fromList xs, valueType = None} + +callImport' :: + SBS.ShortByteString -> [Expression] -> ValueType -> EDSL Expression +callImport' f xs vt = do + lr <- mutLocal vt + putLVal lr CallImport {target' = f, operands = V.fromList xs, valueType = vt} + pure $ getLVal lr + +callIndirect' :: Expression -> [Expression] -> FunctionType -> EDSL Expression +callIndirect' f xs ft = do + lr <- mutLocal (returnType ft) + putLVal + lr + CallIndirect + { indirectTarget = wrapInt64 f + , operands = V.fromList xs + , typeName = generateWasmFunctionTypeName ft + } + pure $ getLVal lr + +newtype Label = Label + { unLabel :: SBS.ShortByteString + } + +newLabel :: EDSL Label +newLabel = + EDSL $ + state $ \s@EDSLState {..} -> + (Label $ showSBS labelNum, s {labelNum = succ labelNum}) + +newScope :: EDSL () -> EDSL (DL.DList Expression) +newScope m = do + orig_buf <- + EDSL $ state $ \s@EDSLState {..} -> (exprBuf, s {exprBuf = mempty}) + m + EDSL $ state $ \s@EDSLState {..} -> (exprBuf, s {exprBuf = orig_buf}) + +block, loop :: (Label -> EDSL ()) -> EDSL () +block cont = do + lbl <- newLabel + es <- newScope $ cont lbl + emit + Block + {name = unLabel lbl, bodys = V.fromList $ DL.toList es, valueType = Auto} + +loop cont = do + lbl <- newLabel + es <- newScope $ cont lbl + emit Loop {name = unLabel lbl, body = bundleExpressions es} + +if' :: Expression -> EDSL () -> EDSL () -> EDSL () +if' cond t f = do + t_es <- newScope t + f_es <- newScope f + emit + If + { condition = cond + , ifTrue = bundleExpressions t_es + , ifFalse = bundleExpressions f_es + } + +break' :: Label -> Expression -> EDSL () +break' (Label lbl) cond = + emit Break {name = lbl, condition = cond, value = Null} + +eqZInt64, extendUInt32, wrapInt64, growMemory :: Expression -> Expression +eqZInt64 = Unary EqZInt64 + +extendUInt32 = Unary ExtendUInt32 + +wrapInt64 = Unary WrapInt64 + +growMemory x = Host {hostOp = GrowMemory, name = "", operands = [x]} + +addInt64, subInt64, mulInt64, gtUInt64 :: Expression -> Expression -> Expression +addInt64 = Binary AddInt64 + +subInt64 = Binary SubInt64 + +mulInt64 = Binary MulInt64 + +gtUInt64 = Binary GtUInt64 + +symbol :: AsteriusEntitySymbol -> Expression +symbol = Unresolved + +constI32, constI64 :: Int -> Expression +constI32 = ConstI32 . fromIntegral + +constI64 = ConstI64 . fromIntegral + +baseReg, r1, sp, spLim, hp, hpLim, cccs, currentTSO, currentNursery, hpAlloc :: + LVal +baseReg = global BaseReg + +r1 = global $ VanillaReg 1 + +sp = global Sp + +spLim = global SpLim + +hp = global Hp + +hpLim = global HpLim + +cccs = global CCCS + +currentTSO = global CurrentTSO + +currentNursery = global CurrentNursery + +hpAlloc = global HpAlloc + +mainCapability :: Expression +mainCapability = symbol "MainCapability" diff --git a/asterius/src/Asterius/JSFFI.hs b/asterius/src/Asterius/JSFFI.hs index 7a92261a..e0db1c03 100644 --- a/asterius/src/Asterius/JSFFI.hs +++ b/asterius/src/Asterius/JSFFI.hs @@ -7,8 +7,7 @@ {-# LANGUAGE StrictData #-} module Asterius.JSFFI - ( emptyFFIMarshalState - , addFFIProcessor + ( addFFIProcessor , generateFFIFunctionImports , generateFFIDict ) where @@ -71,9 +70,6 @@ combineChunks = parseFFIChunks :: Parser [Chunk Int] parseFFIChunks = combineChunks <$> parseChunks (parseChunk (parseField decimal)) -emptyFFIMarshalState :: FFIMarshalState -emptyFFIMarshalState = FFIMarshalState {ffiDecls = mempty} - marshalToFFIValueType :: GHC.Located GHC.RdrName -> Maybe FFIValueType marshalToFFIValueType loc_t = case GHC.occNameString $ GHC.rdrNameOcc $ GHC.unLoc loc_t of diff --git a/asterius/src/Asterius/TypesConv.hs b/asterius/src/Asterius/TypesConv.hs index 419a6bf3..732952dc 100644 --- a/asterius/src/Asterius/TypesConv.hs +++ b/asterius/src/Asterius/TypesConv.hs @@ -4,11 +4,14 @@ module Asterius.TypesConv ( marshalToModuleSymbol , zEncodeModuleSymbol + , generateWasmFunctionTypeName ) where +import Asterius.Internals import Asterius.Types import qualified Data.ByteString.Char8 as CBS import qualified Data.ByteString.Short as SBS +import Data.List import qualified Data.Vector as V import qualified GhcPlugins as GHC @@ -33,3 +36,10 @@ zEncodeModuleSymbol AsteriusModuleSymbol {..} = CBS.intercalate "." [SBS.fromShort mod_chunk | mod_chunk <- V.toList moduleName] + +{-# INLINEABLE generateWasmFunctionTypeName #-} +generateWasmFunctionTypeName :: FunctionType -> SBS.ShortByteString +generateWasmFunctionTypeName FunctionType {..} = + showSBS returnType <> "(" <> + mconcat (intersperse "," [showSBS t | t <- V.toList paramTypes]) <> + ")" diff --git a/docs/building.md b/docs/building.md index bda15f39..3deaba58 100644 --- a/docs/building.md +++ b/docs/building.md @@ -21,8 +21,8 @@ root@76bcb511663d:/mirror# ahc-link --help `asterius` requires a custom `ghc` which: -* Uses `ghc-head` instead of a release version. It forces us to keep an eye on upstream changes. The `master` branch of `ghc` may introduce breaking commits, so for safety you should choose the specific `ghc` commit as indicated in the `NIXPKGS_REV` revision of the CircleCI config file, details below. -* Disables [`TABLES_NEXT_TO_CODE`](https://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/HeapObjects#TABLES_NEXT_TO_CODE). It's impossible to attach executable code to an info table on the WebAssembly platform. +* Uses `ghc-head` instead of a release version. It forces us to keep an eye on upstream changes. The `master` branch of `ghc` may introduce breaking commits, so for safety you should choose the specific `ghc` version as indicated in the `stack.yaml` file. +* Disables [`TABLES_NEXT_TO_CODE`](https://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/HeapObjects#TABLES_NEXT_TO_CODE). It's hard to attach executable code to an info table on the WebAssembly platform. * Uses `integer-simple` instead of `integer-gmp`. Porting `integer-gmp` to WebAssembly requires extra work and is not currently scheduled. The building guide of `ghc` can be found [here](https://ghc.haskell.org/trac/ghc/wiki/Building). Add the following lines to `mk/build.mk`: @@ -42,11 +42,11 @@ Besides the custom `ghc`, these dependencies are also required: * `cmake`/`make`/`g++`: For building in-tree [`binaryen`](https://github.com/WebAssembly/binaryen) * `autoconf`: For booting `ghc-prim`/`base` -* `nodejs`: For running tests -* `stack` +* `nodejs`: For running tests. Ensure the latest version is used, since we rely on some recent V8 experimental features (e.g. BigInt support) +* `stack`: Someday `cabal` may also work, no specific obstacles anyway. ## Building `asterius` -`stack build asterius`. That's it. If you are using `nix`, make sure to add `--system-ghc` when invoking `stack`. +`stack build asterius`. That's it. Set `MAKEFLAGS=-j8` to pass flags to `make` for parallel building of `binaryen`. -Set `MAKEFLAGS=-j8` to pass flags to `make` for parallel building of `binaryen`. Run `stack exec ahc-boot` to test if booting works. +After the dust settles, run `stack exec ahc-boot` to perform booting. Set the `ASTERIUS_DEBUG` environment variable to make `ahc-boot` pretty-print IRs to text files which are useful when debugging compiled code of standard libraries. Be aware that this flag slows down the booting process significantly! diff --git a/docs/wasm-in-hs.md b/docs/wasm-in-hs.md new file mode 100644 index 00000000..bfd33474 --- /dev/null +++ b/docs/wasm-in-hs.md @@ -0,0 +1,16 @@ +## Writing WebAssembly code in Haskell + +In `Asterius.Builtins`, there are WebAssembly shims which serve as our runtime. We choose to write WebAssembly code in Haskell, using Haskell as our familiar meta-language. + +As of now, there are two ways of writing WebAssembly code in Haskell. The first way is directly manipulating AST types as specified in `Asterius.Types`. Those types are pretty bare-metal and maps closely to binaryen IR. Simply write some code to generate an `AsteriusFunction`, and ensure the function and its symbol is present in the store when linking starts. It will eventually be bundled into output WebAssembly binary file. + +Directly using `Asterius.Types` is not a pleasant experience, it's basically a DDoS on one's working memory, since the developer needs to keep a lot of things in mind: parameter/local ids, block/loop labels, etc. Also, the resulting Haskell code is pretty verbose, littered with syntactic noise (e.g. tons of list concats when constructing a block) + +We now provide an EDSL in `Asterius.EDSL` to construct an `AsteriusFunction`. Its core type is `EDSL a`, and can be composed with a `Monad` or `Monoid` interface. Most builtin functions in `Asterius.Builtins` are already refactored to use this EDSL. Typical usages: + +* "Allocate" a parameter/local. Use `param` or `local` to obtain an immutable `Expression` which corresponds to the value of a new parameter/local. There are also mutable variants. +* An opaque `LVal` type is provided to uniformly deal with local reads/assignments and memory loads/stores. Once an `LVal` is instantiated, it can be used to read an `Expression` in the pure world, or set an `Expression` in the `EDSL` monad. +* Several side-effecting instructions can simply be composed with the monadic/monoidal interface, without the need to explicitly construct an anonymous block. +* When we need named blocks/loops with branching instructions inside, use the `block`/`loop` combinators which has the type `(Label -> EDSL ()) -> EDSL ()`. Inside the passed in continuation, we can use `break'` to perform branching. The `Label` type is also opaque and cannot be inspected, the only thing we know is that it's scope-checked just like any ordinary Haskell value, so it's impossible to accidently branch to an "inner" label. + +The EDSL only checks for scope safety, so we don't mess up different locals or jump to non-existent labels. Type-safety is not guaranteed (binaryen validator checks for it anyway). Underneath it's just a shallow embedded DSL implemented with a plain old state monad. Some people call it the "remote monad design pattern". diff --git a/mkdocs.yml b/mkdocs.yml index dbb855ba..df0b4a2d 100644 --- a/mkdocs.yml +++ b/mkdocs.yml @@ -6,6 +6,7 @@ pages: - For users: - 'Building guide': 'building.md' - For developers: + - 'Writing WebAssembly code in Haskell': 'wasm-in-hs.md' - 'JavaScript FFI': 'jsffi.md' - 'The runtime debugging feature': 'debugging.md' - 'Project architecture': 'architecture.md' diff --git a/stack.yaml b/stack.yaml index ea8971f7..5c7adb00 100644 --- a/stack.yaml +++ b/stack.yaml @@ -14,6 +14,7 @@ extra-deps: - base-compat-0.10.4 - https://github.com/TerrorJack/cereal/archive/Serialize-instance-ShortByteString.zip - colour-2.3.4 + - dlist-0.8.0.4 - happy-1.19.9 - hashable-1.2.7.0 - haskell-lexer-1.0.1