app/Main.hs

@@ -1,27 +1,90 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE OverloadedLists #-}
 module Main
   (main)
   where
 
 import Data.Text (Text)
 import Effectful
-import Gyehoek.QBE
+import Gyehoek.QBE as QBE
 import Data.List (List)
+import Data.Text.IO qualified as TIO
+import Control.Lens
+import Data.Vector (Vector)
+import Data.Function (fix)
+import Effectful.Writer.Static.Local
 
 
 type Name = Text
 
-data Expr
-  = Var Name
-  | App Expr (List Expr)
-  | Lam Name Expr
-  | Progn (List Expr)
-  | UsePrim Prim
+data Value
+  = ValInt Int
+  | ValNil
+  | ValPrim Prim
   deriving (Show)
 
+data Sexp
+  -- | Cons
+  = Sexp :. Sexp
+  | UseVal Value
+  deriving (Show)
+
+infixr 5 :.
+pattern Cons :: Sexp -> Sexp -> Sexp
+pattern Cons x y = x :. y
+
 data Prim = PrimAdd | PrimSub | PrimMul | PrimDiv
   deriving (Show)
 
+mapcar :: Traversal' Sexp Sexp
+mapcar k (Cons x xs) = Cons <$> k x <*> mapcar k xs
+mapcar k x           = pure x
+
+type CodeGen = Writer (Vector Inst)
+
+runCodeGen :: Eff (CodeGen : es) a -> Eff es (a, Vector Inst)
+runCodeGen = runWriter
+
+emit :: CodeGen :> es => Inst -> Eff es ()
+emit = tell . pure
+
+compile
+  :: (GenSym :> es, CodeGen :> es)
+  => Sexp
+  -> (QBE.Val -> Eff es Jump)
+  -> Eff es Jump
+
+compile (UseVal (ValInt n)) k =
+  k . ValConst . CInt . fromIntegral $ n
+
+compile (UseVal (ValPrim p) :. args) k = f (args ^.. mapcar)
+  where
+    f [x,y] =
+      compile x \x' ->
+        compile y \y' -> do
+          r <- gensym
+          emit $ BinaryOp (r := Long) bop x' y'
+          k (ValTemporary r)
+    f _ = _
+    bop = case p of
+      PrimAdd -> Add
+      PrimMul -> Mul
+      _ -> _
+
+compile _ _ = _
+
+compile' :: (GenSym :> es) => Ident Label -> Sexp -> Eff es Block
+compile' l e = do
+  (j,is) <- runCodeGen $ compile e (pure . Ret . Just)
+  pure $ Block l [] (is ^.. each) j
+
 main :: IO ()
 main = putStrLn "Hello, Haskell!"
 
+expr = UseVal (ValPrim PrimAdd)
+  :. UseVal (ValInt 1)
+  :. UseVal (ValInt 2)
+  -- :. UseVal (ValInt 3)
+  :. UseVal ValNil