Oh

wasm-calc6/src/Calc/Wasm/FromExpr.hs

@@ -94,6 +94,72 @@ scalarFromType (TVar _ _) =
 scalarFromType (TUnificationVar {}) =
   pure Pointer
 
+patternToPaths :: Pattern (Type ann) -> [Natural] -> M.Map Identifier (Type ann, [Natural])
+patternToPaths (PWildcard _) _ = mempty
+patternToPaths (PVar ty ident) offset = M.singleton ident (ty, offset)
+patternToPaths (PBox _ pat) offset = patternToPaths pat (offset <> [0])
+patternToPaths (PTuple ty p ps) offset =
+  let offsetList = getOffsetList ty
+   in patternToPaths p (offset <> [head offsetList])
+        <> mconcat
+          ( ( \(index, pat) ->
+                patternToPaths pat (offset <> [offsetList !! index])
+            )
+              <$> zip [1 ..] (NE.toList ps)
+          )
+
+fromLet ::
+  ( Show ann,
+    MonadError FromWasmError m,
+    MonadState FromExprState m
+  ) =>
+  Pattern (Type ann) ->
+  Expr (Type ann) ->
+  Expr (Type ann) ->
+  m WasmExpr
+fromLet pat expr rest = do
+  let paths = patternToPaths pat []
+  if null paths
+    then WSequence <$> fromExpr expr <*> fromExpr rest
+    else do
+      -- get type of the main expr
+      wasmType <- liftEither (scalarFromType (getOuterAnnotation expr))
+      -- first we make a nameless binding of the whole value
+      index <- addLocal Nothing wasmType
+      -- convert expr
+      wasmExpr <- fromExpr expr
+      -- turn patterns into indexes and expressions
+      indexes <-
+        traverse
+          ( \(ident, (ty, offset)) -> do
+              -- wasm type of var
+              bindingType <- liftEither (scalarFromType ty)
+              -- named binding
+              bindingIndex <- addLocal (Just ident) bindingType
+              -- get type we're going to be grabbing
+              let innerTy = I64 -- TODO: wrong
+              _ <- error "need to work out innerTy"
+              -- make expr for fetching value by folding through offsets
+              let fetchExpr =
+                    foldr (flip $ WTupleAccess innerTy) (WVar index) offset
+              -- return some stuff
+              pure (bindingIndex, fetchExpr)
+          )
+          (M.toList paths)
+
+      -- convert the rest
+      wasmRest <- fromExpr rest
+
+      -- `let i = <expr>; let a = i.1; let b = i.2; <rest>....`
+      pure $
+        WLet index wasmExpr $
+          foldr
+            ( \(bindingIndex, fetchExpr) thisExpr ->
+                WLet bindingIndex fetchExpr thisExpr
+            )
+            wasmRest
+            indexes
+
 fromExpr ::
   ( MonadError FromWasmError m,
     MonadState FromExprState m,
@@ -103,18 +169,8 @@ fromExpr ::
   m WasmExpr
 fromExpr (EPrim _ prim) = do
   pure (WPrim prim)
-fromExpr (ELet _ (PVar _ ident) expr rest) = do
-  -- get type of the let binding from `expr`
-  wasmType <- liftEither (scalarFromType (getOuterAnnotation expr))
-  -- record the type and get an unused identifier
-  index <- addLocal (Just ident) wasmType
-  -- convert expr
-  wasmExpr <- fromExpr expr
-  -- convert the rest
-  WLet index wasmExpr <$> fromExpr rest
-fromExpr (ELet _ (PWildcard _) expr rest) = do
-  WSequence <$> fromExpr expr <*> fromExpr rest
-fromExpr (ELet {}) = error "wasm fromExpr other pattern"
+fromExpr (ELet _ pat expr rest) =
+  fromLet pat expr rest
 fromExpr (EInfix _ op a b) = do
   -- we're assuming that the types of `a` and `b` are the same
   -- we want the type of the args, not the result

wasm-calc6/src/Calc/Wasm/ToWasm.hs

@@ -2,23 +2,24 @@
 
 module Calc.Wasm.ToWasm (moduleToWasm) where
 
-import           Calc.Types.Expr
-import           Calc.Types.FunctionName
-import           Calc.Types.Prim
-import           Calc.Wasm.Allocator
-import           Calc.Wasm.Types
-import           Data.Maybe              (catMaybes)
-import qualified Data.Text.Lazy          as TL
-import           GHC.Natural
+import Calc.Types.Expr
+import Calc.Types.FunctionName
+import Calc.Types.Prim
+import Calc.Utils
+import Calc.Wasm.Allocator
+import Calc.Wasm.Types
+import Data.Maybe (catMaybes)
+import qualified Data.Text.Lazy as TL
+import GHC.Natural
 import qualified Language.Wasm.Structure as Wasm
 
 mapWithIndex :: ((Int, a) -> b) -> [a] -> [b]
 mapWithIndex f = fmap f . zip [0 ..]
 
 fromType :: WasmType -> Wasm.ValueType
-fromType I32     = Wasm.I32
-fromType I64     = Wasm.I64
-fromType F64     = Wasm.F64
+fromType I32 = Wasm.I32
+fromType I64 = Wasm.I64
+fromType F64 = Wasm.F64
 fromType Pointer = Wasm.I32
 
 fromFunction :: Int -> WasmFunction -> Wasm.Function
@@ -28,7 +29,7 @@ fromFunction wfIndex (WasmFunction {wfExpr, wfArgs, wfLocals}) =
    in Wasm.Function
         (fromIntegral $ wfIndex + 1)
         (locals <> args)
-        (toWasm wfExpr)
+        (toWasm $ ltrace "wfExpr" wfExpr)
 
 typeFromFunction :: WasmFunction -> Wasm.FuncType
 typeFromFunction (WasmFunction {wfArgs, wfReturnType}) =
@@ -40,20 +41,20 @@ exportFromFunction wfIndex (WasmFunction {wfName = FunctionName fnName, wfPublic
 exportFromFunction _ _ = Nothing
 
 bitsizeFromType :: WasmType -> Wasm.BitSize
-bitsizeFromType I32     = Wasm.BS32
-bitsizeFromType I64     = Wasm.BS64
-bitsizeFromType F64     = Wasm.BS64
+bitsizeFromType I32 = Wasm.BS32
+bitsizeFromType I64 = Wasm.BS64
+bitsizeFromType F64 = Wasm.BS64
 bitsizeFromType Pointer = Wasm.BS32
 
 instructionFromOp :: WasmType -> Op -> Wasm.Instruction Natural
-instructionFromOp F64 OpAdd      = Wasm.FBinOp (bitsizeFromType F64) Wasm.FAdd
+instructionFromOp F64 OpAdd = Wasm.FBinOp (bitsizeFromType F64) Wasm.FAdd
 instructionFromOp F64 OpMultiply = Wasm.FBinOp (bitsizeFromType F64) Wasm.FMul
 instructionFromOp F64 OpSubtract = Wasm.FBinOp (bitsizeFromType F64) Wasm.FSub
-instructionFromOp F64 OpEquals   = Wasm.FRelOp (bitsizeFromType F64) Wasm.FEq
-instructionFromOp ty OpAdd       = Wasm.IBinOp (bitsizeFromType ty) Wasm.IAdd
-instructionFromOp ty OpMultiply  = Wasm.IBinOp (bitsizeFromType ty) Wasm.IMul
-instructionFromOp ty OpSubtract  = Wasm.IBinOp (bitsizeFromType ty) Wasm.ISub
-instructionFromOp ty OpEquals    = Wasm.IRelOp (bitsizeFromType ty) Wasm.IEq
+instructionFromOp F64 OpEquals = Wasm.FRelOp (bitsizeFromType F64) Wasm.FEq
+instructionFromOp ty OpAdd = Wasm.IBinOp (bitsizeFromType ty) Wasm.IAdd
+instructionFromOp ty OpMultiply = Wasm.IBinOp (bitsizeFromType ty) Wasm.IMul
+instructionFromOp ty OpSubtract = Wasm.IBinOp (bitsizeFromType ty) Wasm.ISub
+instructionFromOp ty OpEquals = Wasm.IRelOp (bitsizeFromType ty) Wasm.IEq
 
 toWasm :: WasmExpr -> [Wasm.Instruction Natural]
 toWasm (WPrim (PInt i)) =
@@ -81,9 +82,9 @@ toWasm (WAllocate i) =
 toWasm (WSet index container items) =
   let fromItem (offset, ty, value) =
         let storeInstruction = case ty of
-              F64     -> Wasm.F64Store (Wasm.MemArg offset 0)
-              I64     -> Wasm.I64Store (Wasm.MemArg offset 0)
-              I32     -> Wasm.I32Store (Wasm.MemArg offset 0)
+              F64 -> Wasm.F64Store (Wasm.MemArg offset 0)
+              I64 -> Wasm.I64Store (Wasm.MemArg offset 0)
+              I32 -> Wasm.I32Store (Wasm.MemArg offset 0)
               Pointer -> Wasm.I32Store (Wasm.MemArg offset 0)
          in [Wasm.GetLocal index] <> toWasm value <> [storeInstruction]
    in toWasm container
@@ -92,9 +93,9 @@ toWasm (WSet index container items) =
         <> [Wasm.GetLocal index]
 toWasm (WTupleAccess ty tup offset) =
   let loadInstruction = case ty of
-        F64     -> Wasm.F64Load (Wasm.MemArg offset 0)
-        I64     -> Wasm.I64Load (Wasm.MemArg offset 0)
-        I32     -> Wasm.I32Load (Wasm.MemArg offset 0)
+        F64 -> Wasm.F64Load (Wasm.MemArg offset 0)
+        I64 -> Wasm.I64Load (Wasm.MemArg offset 0)
+        I32 -> Wasm.I32Load (Wasm.MemArg offset 0)
         Pointer -> Wasm.I32Load (Wasm.MemArg offset 0)
    in toWasm tup <> [loadInstruction]
 

wasm-calc6/test/Test/Linearity/LinearitySpec.hs

@@ -2,15 +2,15 @@
 
 module Test.Linearity.LinearitySpec (spec) where
 
-import           Calc
-import           Calc.Linearity
-import           Calc.Typecheck
-import           Control.Monad   (void)
-import           Data.Either     (isRight)
-import           Data.Foldable   (traverse_)
+import Calc
+import Calc.Linearity
+import Calc.Typecheck
+import Control.Monad (void)
+import Data.Either (isRight)
+import Data.Foldable (traverse_)
 import qualified Data.Map.Strict as M
-import qualified Data.Text       as T
-import           Test.Hspec
+import qualified Data.Text as T
+import Test.Hspec
 
 runTC :: TypecheckM ann a -> Either (TypeError ann) a
 runTC = runTypecheckM (TypecheckEnv mempty mempty)
@@ -100,7 +100,7 @@ spec = do
                 ( "function dup<a>(a: a) { (a,a)}",
                   UsedMultipleTimes "a"
                 ),
-                  {-( "function twice(pair: (Integer, Integer)) { pair.1 + pair.2 }",
+                {-( "function twice(pair: (Integer, Integer)) { pair.1 + pair.2 }",
                   UsedMultipleTimes "pair"
                 ),-}
                 ( "function withPair<a,b>(pair: (a,b)) { let (a,b) = pair; (a, a, b) }",

wasm-calc6/test/Test/Wasm/WasmSpec.hs

@@ -29,14 +29,15 @@ testCompileExpr (input, result) = it (show input) $ do
                 resp <- runWasm (moduleToWasm wasmMod)
                 resp `shouldBe` Just [result]
 
-joinLines :: [Text] -> Text
-joinLines = foldr (\a b -> a <> "\n" <> b) ""
+_joinLines :: [Text] -> Text
+_joinLines = foldr (\a b -> a <> "\n" <> b) ""
 
 spec :: Spec
 spec = do
   describe "WasmSpec" $ do
     let testVals =
-          [ ("42", Wasm.VI64 42),
+          [ {-
+            ("42", Wasm.VI64 42),
             ("(1 + 1)", Wasm.VI64 2),
             ("1 + 2 + 3 + 4 + 5 + 6", Wasm.VI64 21),
             ("6 * 6", Wasm.VI64 36),
@@ -111,9 +112,13 @@ spec = do
                 ],
               Wasm.VI64 42
             ),
+            -}
             ("let _ = 1; 2", Wasm.VI64 2),
+            ("let Box(a) = Box(42); a", Wasm.VI64 42),
+            ("let Box(a) = Box(1.23); a", Wasm.VF64 1.23),
             ("let (a,b) = (1,2); a + b", Wasm.VI64 3),
-            ("let Box(a) = Box(42); a", Wasm.VI64 42)
+            ("let Box(Box(a)) = Box(Box(101)); a", Wasm.VI64 101),
+            ("let (a, (b,c)) = (1, (2,3)); a + b + c", Wasm.VI64 6)
           ]
 
     describe "From expressions" $ do