91 lines
1.8 KiB
Haskell
91 lines
1.8 KiB
Haskell
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
module Main
|
|
(main)
|
|
where
|
|
|
|
import Data.Text (Text)
|
|
import Effectful
|
|
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 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
|