From 51c86a12cc7575078e5765da21f77be6bcd32ff3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Sun, 5 Jul 2026 20:13:41 -0600 Subject: [PATCH] lowerslop --- .gitignore | 3 +- app/Gyehoek/CPS/Convert.hs | 3 -- app/Gyehoek/CPS/Lower.hs | 87 +++++++++++++++++++++++++++++++++++- app/Gyehoek/CPS/Syntax.hs | 17 +++++++ app/Gyehoek/Scheme/Syntax.hs | 5 ++- gyehoek.cabal | 1 + 6 files changed, 109 insertions(+), 7 deletions(-) diff --git a/.gitignore b/.gitignore index b154770..aa09459 100644 --- a/.gitignore +++ b/.gitignore @@ -7,4 +7,5 @@ dist-newstyle .ghc.environment.* *.tix .direnv -result \ No newline at end of file +result +play/ \ No newline at end of file diff --git a/app/Gyehoek/CPS/Convert.hs b/app/Gyehoek/CPS/Convert.hs index b13ad62..450ae61 100644 --- a/app/Gyehoek/CPS/Convert.hs +++ b/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 diff --git a/app/Gyehoek/CPS/Lower.hs b/app/Gyehoek/CPS/Lower.hs index 2639f89..ab444a1 100644 --- a/app/Gyehoek/CPS/Lower.hs +++ b/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 = " ))" diff --git a/app/Gyehoek/CPS/Syntax.hs b/app/Gyehoek/CPS/Syntax.hs index 19ebb3a..28704bd 100644 --- a/app/Gyehoek/CPS/Syntax.hs +++ b/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 diff --git a/app/Gyehoek/Scheme/Syntax.hs b/app/Gyehoek/Scheme/Syntax.hs index 625fc78..21cc9a7 100644 --- a/app/Gyehoek/Scheme/Syntax.hs +++ b/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 diff --git a/gyehoek.cabal b/gyehoek.cabal index c0beee3..854d62e 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -54,6 +54,7 @@ executable gyehoek , effectful-plugin , filepath , generic-lens + , hashable , invertible-grammar , lens , megaparsec