fix binary generation

src/Language/Wasm/Binary.hs

@@ -295,7 +295,7 @@ instance Serialize Index where
     get = Index <$> getULEB128 32
 
 instance Serialize MemArg where
-    put (MemArg align offset) = putULEB128 align >> putULEB128 offset
+    put MemArg { align, offset } = putULEB128 align >> putULEB128 offset
     get = MemArg <$> getULEB128 32 <*> getULEB128 32
 
 instance Serialize (Instruction Natural) where
@@ -309,13 +309,13 @@ instance Serialize (Instruction Natural) where
         putWord8 0x03
         putResultType result
         putExpression body
-    put If {result, true, false = []} = do
+    put If {resultType, true, false = []} = do
         putWord8 0x04
-        putResultType result
+        putResultType resultType
         putExpression true
-    put If {result, true, false} = do
+    put If {resultType, true, false} = do
         putWord8 0x04
-        putResultType result
+        putResultType resultType
         mapM_ put true
         putWord8 0x05 -- ELSE
         putExpression false

src/Language/Wasm/Builder.hs

@@ -23,8 +23,7 @@ module Language.Wasm.Builder (
     nextFuncIndex, setGlobalInitializer,
     GenFun,
     Glob, Loc,
-    param,
+    param, local, result,
-    local,
     ret,
     arg,
     i32, i64, f32, f64,
@@ -59,7 +58,7 @@ import Language.Wasm.Structure
 
 data FuncDef = FuncDef {
     args :: [ValueType],
-    results :: [ValueType],
+    returns :: [ValueType],
     locals :: [ValueType],
     instrs :: Expression
 } deriving (Show, Eq)
@@ -83,6 +82,11 @@ local t = do
     put $ f { locals = locals ++ [getValueType t]}
     return $ Loc $ fromIntegral $ length args + length locals
 
+result :: (ValueTypeable t) => Proxy t -> GenFun ()
+result t = do
+    f@FuncDef { returns } <- get
+    put $ f { returns = returns ++ [getValueType t] }
+
 appendExpr :: Expression -> GenFun ()
 appendExpr expr = do
     modify $ \def -> def { instrs = instrs def ++ expr }
@@ -131,8 +135,8 @@ arg e = produce e >> return ()
 
 getSize :: ValueType -> BitSize
 getSize I32 = BS32
-getSize I64 = BS32
+getSize I64 = BS64
-getSize F32 = BS64
+getSize F32 = BS32
 getSize F64 = BS64
 
 type family IsInt i :: Bool where
@@ -322,8 +326,8 @@ store :: (Producer addr, OutType addr ~ Proxy I32, Producer val, Integral offset
     -> align
     -> GenFun ()
 store addr val offset align = do
-    produce val
     produce addr
+    produce val
     case asValueType val of
         I32 -> appendExpr [I32Store $ MemArg (fromIntegral offset) (fromIntegral align)]
         I64 -> appendExpr [I64Store $ MemArg (fromIntegral offset) (fromIntegral align)]
@@ -337,8 +341,8 @@ store8 :: (Producer addr, OutType addr ~ Proxy I32, Producer val, IsInt (OutType
     -> align
     -> GenFun ()
 store8 addr val offset align = do
-    produce val
     produce addr
+    produce val
     case asValueType val of
         I32 -> appendExpr [I32Store8 $ MemArg (fromIntegral offset) (fromIntegral align)]
         I64 -> appendExpr [I64Store8 $ MemArg (fromIntegral offset) (fromIntegral align)]
@@ -351,8 +355,8 @@ store16 :: (Producer addr, OutType addr ~ Proxy I32, Producer val, IsInt (OutTyp
     -> align
     -> GenFun ()
 store16 addr val offset align = do
-    produce val
     produce addr
+    produce val
     case asValueType val of
         I32 -> appendExpr [I32Store16 $ MemArg (fromIntegral offset) (fromIntegral align)]
         I64 -> appendExpr [I64Store16 $ MemArg (fromIntegral offset) (fromIntegral align)]
@@ -365,8 +369,8 @@ store32 :: (Producer addr, OutType addr ~ Proxy I32, Producer val, OutType val ~
     -> align
     -> GenFun ()
 store32 addr val offset align = do
-    produce val
     produce addr
+    produce val
     appendExpr [I64Store32 $ MemArg (fromIntegral offset) (fromIntegral align)]
 
 invoke :: Natural -> [GenFun a] -> GenFun ()
@@ -448,8 +452,8 @@ typedef t = do
 funRec :: (Natural -> GenFun a) -> GenMod Natural
 funRec generator = do
     st@GenModState { target = m@Module { types, functions }, funcIdx } <- get
-    let FuncDef { args, results, locals, instrs } = execState (runReaderT (generator funcIdx) 0) $ FuncDef [] [] [] []
+    let FuncDef { args, returns, locals, instrs } = execState (runReaderT (generator funcIdx) 0) $ FuncDef [] [] [] []
-    let t = FuncType args results
+    let t = FuncType args returns
     let (idx, inserted) = Maybe.fromMaybe (length types, types ++ [t]) $ (\i -> (i, types)) <$> List.findIndex (== t) types
     put $ st {
         target = m { functions = functions ++ [Function (fromIntegral idx) locals instrs], types = inserted },

src/Language/Wasm/Structure.hs

@@ -106,9 +106,9 @@ data Instruction index =
     -- Control instructions
     Unreachable
     | Nop
-    | Block { result :: ResultType, body :: Expression }
+    | Block { resultType :: ResultType, body :: Expression }
-    | Loop { result :: ResultType, body :: Expression }
+    | Loop { resultType :: ResultType, body :: Expression }
-    | If { result :: ResultType, true :: Expression, false :: Expression }
+    | If { resultType :: ResultType, true :: Expression, false :: Expression }
     | Br index
     | BrIf index
     | BrTable [index] index

src/Language/Wasm/Validate.hs

@@ -180,24 +180,24 @@ checkMemoryInstr size memarg = do
 getInstrType :: Instruction Natural -> Checker Arrow
 getInstrType Unreachable = return $ Any ==> Any
 getInstrType Nop = return $ empty ==> empty
-getInstrType Block { result, body } = do
+getInstrType Block { resultType, body } = do
-    let blockType = empty ==> result
+    let blockType = empty ==> resultType
-    t <- withLabel result $ getExpressionType body
+    t <- withLabel resultType $ getExpressionType body
     if isArrowMatch t blockType
-    then return $ empty ==> result
+    then return $ empty ==> resultType
     else throwError $ TypeMismatch t blockType
-getInstrType Loop { result, body } = do
+getInstrType Loop { resultType, body } = do
-    let blockType = empty ==> result
+    let blockType = empty ==> resultType
     t <- withLabel [] $ getExpressionType body
     if isArrowMatch t blockType
-    then return $ empty ==> result
+    then return $ empty ==> resultType
     else throwError $ TypeMismatch t blockType
-getInstrType If { result, true, false } = do
+getInstrType If { resultType, true, false } = do
-    let blockType = empty ==> result
+    let blockType = empty ==> resultType
-    l <- withLabel result $ getExpressionType true
+    l <- withLabel resultType $ getExpressionType true
-    r <- withLabel result $ getExpressionType false
+    r <- withLabel resultType $ getExpressionType false
     if isArrowMatch l blockType
-    then (if isArrowMatch r blockType then (return $ I32 ==> result) else (throwError $ TypeMismatch r blockType))
+    then (if isArrowMatch r blockType then (return $ I32 ==> resultType) else (throwError $ TypeMismatch r blockType))
     else throwError $ TypeMismatch l blockType
 getInstrType (Br lbl) = do
     r <- map Val . maybeToList <$> getLabel lbl