96 lines
2.2 KiB
Haskell
96 lines
2.2 KiB
Haskell
{-# 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((:|)))
|
|
import Effectful
|
|
import Control.Monad.Cont qualified as Cont
|
|
import Effectful.Writer.Static.Local
|
|
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
|
|
import Data.IntMap.Strict (IntMap)
|
|
|
|
|
|
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)
|
|
|
|
|
|
|
|
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 e) =
|
|
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
|
|
|
|
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 = " ))"
|
|
|
|
lower :: Exp -> Eff es Text
|
|
lower = pure . makeFunc . lower' emptyEnv
|