lowerslop

app/Gyehoek/CPS/Lower.hs

@@ -1,9 +1,15 @@
 {-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultilineStrings #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 module Gyehoek.CPS.Lower
   ( lower
   ) where
 
 import Gyehoek.CPS.Syntax
+import Data.Generics.Labels
 import Gyehoek.Scheme.Syntax qualified as Scm
 import Gyehoek.GenSym
 import Data.List.NonEmpty (NonEmpty((:|)))
@@ -14,6 +20,13 @@ import Data.Text (Text)
 import Data.Vector.Strict (Vector)
 import Control.Lens
 import Data.Foldable
+import Data.HashMap.Strict (HashMap)
+import Numeric.Natural
+import GHC.Generics (Generic)
+import Gyehoek.Scheme.Syntax (Lit(LitInt))
+import Text.Printf
+import qualified Data.Text as T
+import qualified Data.Vector.Strict as V
 
 
 type Emit = Writer (Vector Text)
@@ -21,5 +34,75 @@ type Emit = Writer (Vector Text)
 runEmit :: Eff (Emit : es) a -> Eff es (a, Text)
 runEmit = (mapped . _2 %~ fold) . runWriter
 
-lower :: Exp -> Eff _ _
-lower = _
+data Env = MkEnv { vars :: Vector Name }
+  deriving (Show, Generic)
+
+emptyEnv :: Env
+emptyEnv = MkEnv mempty
+
+type instance Index Env = Natural
+type instance IxValue Env = Name
+
+instance Ixed Env where
+  ix i = #vars . ix (fromIntegral i)
+
+
+
+-- countLocals :: Exp -> Int
+
+-- countLocals (ExpPrim p rs es) = length rs + sumOf (each . to countLocals) es
+
+-- countLocals (ExpFix bs e) =
+--   sumOf (each . _2 . _MkKappa . ((_1 . each . to (const 1))
+--                                  <> (_2 . to countLocals))) bs
+--   + countLocals e
+
+-- countLocals (ExpApply _ _) = 0
+
+tshow :: Show a => a -> Text
+tshow = T.pack . show
+
+
+
+lowerVal :: Env -> Val -> Vector Text
+
+lowerVal g (ValLit l) =
+  case l of
+    LitInt n -> [ "i32.const " <> tshow n ]
+    _ -> _
+
+lowerVal g (ValVar x) = [ "local.get " <> tshow i ]
+  where
+    i = V.elemIndex x g.vars ^?! _Just
+
+lower :: Env -> Exp -> Vector Text
+
+lower g (Halt [e]) = lowerVal g e
+
+lower g (ExpPrim p rs es) =
+  case p of
+    PrimAdd x y -> lowerBinOp "i32.add" g x y r e
+    PrimMul x y -> lowerBinOp "i32.mul" g x y r e
+  where
+    r = head rs
+    e = head es
+
+lowerBinOp op g x y r e =
+  lowerVal g x
+  <> lowerVal g y
+  <> [ op, "local.set " <> tshow n ]
+  <> lower g' e
+  where
+    g' = g & #vars <>~ [r]
+    n = length (g ^. #vars)
+
+
+
+makeFunc :: Vector Text -> Text
+makeFunc = (preamble<>) . (<>postamble) . T.unlines . toList . fmap indent
+  where
+    indent = ("    "<>)
+    preamble  = "(module\n\
+                \  (func (export \"main\") (result i32)\n\
+                \    (local i32 i32 i32 i32 i32 i32)\n"
+    postamble = "  ))"