lowerslop

.gitignore

@@ -7,4 +7,5 @@ dist-newstyle
 .ghc.environment.*
 *.tix
 .direnv
-result
+result
+play/

app/Gyehoek/CPS/Convert.hs

@@ -45,6 +45,3 @@ convert (Scm.ExpApply f xs) k =
     pure $ ExpFix [(r, MkKappa [x] m)] $ ExpApply f' (xs' ++ [ValVar r])
 
 convert _ k = _
-
-halt :: Applicative f => Val -> f Exp
-halt = pure . ExpApply (ValVar "halt") . pure

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 _ _
+data Env = MkEnv { vars :: Vector Name }
-lower = _
+  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 = "  ))"

app/Gyehoek/CPS/Syntax.hs

@@ -1,10 +1,17 @@
 {-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TemplateHaskell #-}
 module Gyehoek.CPS.Syntax
   ( Val(..)
   , Kappa(..)
   , Exp(..)
   , Name(..)
   , Prim(..)
+  , pattern Halt
+  , pattern Halt1
+  , _MkKappa
+  , _ExpPrim
+  , _ExpFix
+  , _ExpApply
   )
   where
 
@@ -16,6 +23,7 @@ import Data.List (List)
 import GHC.Generics (Generic)
 import Language.SexpGrammar.Generic
 import Control.Category
+import Control.Lens
 import Data.Text qualified as T
 import Data.Generics.Labels
 import Prelude hiding ((.), id)
@@ -38,6 +46,15 @@ data Exp
   | ExpApply Val (List Val)
   deriving (Show, Generic)
 
+pattern Halt :: List Val -> Exp
+pattern Halt xs = ExpApply (ValVar "halt") xs
+
+pattern Halt1 :: Val -> Exp
+pattern Halt1 x = ExpApply (ValVar "halt") [x]
+
+makePrisms ''Kappa
+makePrisms ''Exp
+
 
 -- SexpIso instances
 

app/Gyehoek/Scheme/Syntax.hs

@@ -3,6 +3,8 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OrPatterns #-}
+{-# LANGUAGE PatternSynonyms #-}
 module Gyehoek.Scheme.Syntax
   ( Name(..)
   , Prim(..)
@@ -28,10 +30,11 @@ import Gyehoek.Sexp qualified
 import Gyehoek.GenSym (Gen)
 import Control.Lens (Each)
 import Data.String (IsString)
+import Data.Hashable (Hashable)
 
 
 newtype Name = MkName { getName :: Text }
-  deriving newtype (Show, Eq, IsString, Gen)
+  deriving newtype (Show, Eq, IsString, Gen, Hashable)
   deriving stock (Generic)
 
 data Prim e

gyehoek.cabal

@@ -54,6 +54,7 @@ executable gyehoek
     , effectful-plugin
     , filepath
     , generic-lens
+    , hashable
     , invertible-grammar
     , lens
     , megaparsec