diff --git a/app/Gyehoek/ANF.hs b/app/Gyehoek/ANF.hs new file mode 100644 index 0000000..6d05f84 --- /dev/null +++ b/app/Gyehoek/ANF.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-orphans -Wno-unused-matches -Wno-missing-signatures #-} +{- HLINT ignore "Avoid lambda using `infix`" -} +module Gyehoek.ANF + (toANF) + where + +import Data.Text (Text) +import Effectful +import Gyehoek.QBE qualified as QBE +import Data.List (List) +import Data.Text.IO qualified as TIO +import Control.Lens +import Data.Generics.Labels +import Data.Vector (Vector) +import Data.Function (fix) +import Effectful.Writer.Static.Local +import Gyehoek.Syntax qualified as Lam +import Gyehoek.Syntax (Name, Prim(..), Val(..)) +import Gyehoek.GenSym +import Control.Monad.Cont +import Data.Foldable +import Data.List.NonEmpty (NonEmpty((:|))) +import Gyehoek.QBE (FuncDef(FuncDef)) +import Data.Foldable1 + + +-- data Val +-- = ValInt Int +-- | ValNil +-- | ValPrim Prim +-- | ValLambda (List Name) Exp +-- | ValVar Name +-- deriving (Show) + +data Exp + = ExpLetApply Name Val (List Val) Exp + | ExpProgn (List Exp) + | ExpVal Val + deriving (Show) + + + +blah' :: List ((a -> r) -> r) -> (List a -> r) -> r +blah' = go [] where + go acc [] k = k (reverse acc) + go acc (f:fs) k = f \a -> go (a:acc) fs k + +-- 뻘짓이어라 +blah :: forall t a r. Foldable t => t ((a -> r) -> r) -> (List a -> r) -> r +blah xs k = + foldr (\i l acc -> i \x -> l (x:acc)) (k . reverse) xs [] + +toANF' + :: forall es. GenSym :> es + => Lam.Exp + -> (Val -> Eff es Exp) + -> Eff es Exp + +toANF' (Lam.ExpVal v) k = k v + +toANF' (Lam.ExpApply f xs) k = + blah (toANF' <$> (f:|xs)) \(f':xs') -> do + r <- gensym + ExpLetApply r f' xs' <$> k (ValVar r) + where + allToANF' es k = traverse (\e -> toANF' e k) es + -- blah = traverse g (f :| xs) + -- g :: Lam.Exp -> Eff es Val + -- g = ContT . toANF' + +toANF' e k = _ + +toANF e = toANF' e (pure . ExpVal) + +expr = + Lam.ExpApply (Lam.ExpVal (ValPrim PrimAdd)) + [ Lam.ExpVal (ValInt 1) + , Lam.ExpApply + (Lam.ExpVal (ValPrim PrimMul)) + [ Lam.ExpVal (ValInt 2) + , Lam.ExpVal (ValInt 4) + ] + ] + +expr2 = + Lam.ExpApply (Lam.ExpVal (ValPrim PrimAdd)) + [ Lam.ExpApply (Lam.ExpVal (ValPrim PrimMul)) [Lam.ExpVal (ValInt 1)] + , Lam.ExpApply (Lam.ExpVal (ValPrim PrimMul)) [Lam.ExpVal (ValInt 2)] + , Lam.ExpApply (Lam.ExpVal (ValPrim PrimMul)) [Lam.ExpVal (ValInt 3)] + ] + + + +type CodeGen = Writer (Vector QBE.Inst) + +emit :: CodeGen :> es => QBE.Inst -> Eff es () +emit = tell . pure + +instance Semigroup QBE.Program where + QBE.Program ts ds fs <> QBE.Program ts' ds' fs' = + QBE.Program (ts <> ts') (ds <> ds') (fs <> fs') + +instance Monoid QBE.Program where + mempty = QBE.Program mempty mempty mempty + +funcdef :: QBE.Ident QBE.Global -> [QBE.Param] -> NonEmpty QBE.Block -> FuncDef +funcdef name ps = QBE.FuncDef mempty Nothing name Nothing ps QBE.NoVariadic + +prims :: QBE.Program +prims = QBE.Program mempty mempty primfns where + primfns = [ mkArith "plus" QBE.Add + , mkArith "star" QBE.Mul + , mkArith "_" QBE.Sub + , mkArith "slash" (QBE.Div QBE.Signed) + ] + mkArith name bop = + funcdef name + [ QBE.Param (QBE.AbiBaseTy QBE.Long) "x" + , QBE.Param (QBE.AbiBaseTy QBE.Long) "y" + ] + [ QBE.Block "start" [] + [ QBE.BinaryOp ("r" QBE.:= QBE.Long) bop + (QBE.ValTemporary "x") (QBE.ValTemporary "y") + ] + (QBE.Ret (Just (QBE.ValTemporary "r"))) + ] + +lowerVal + :: forall es. (GenSym :> es, CodeGen :> es) + => Val + -> (QBE.Val -> Eff es QBE.Block) + -> Eff es QBE.Block + +lowerVal (ValInt n) k = k . QBE.ValConst . QBE.CInt . fromIntegral $ n +lowerVal _ k = _ + +lower' + :: forall es. (GenSym :> es, CodeGen :> es) + => Exp + -> (QBE.Val -> Eff es QBE.Block) + -> Eff es QBE.Block + +lower' (ExpVal v) k = lowerVal v k + +lower' (ExpLetApply r f xs e) k = + blah (lowerVal @es <$> (f:|xs)) \(f':xs') -> do + r <- gensym + emit $ QBE.Call + (Just (r, QBE.AbiBaseTy QBE.Long)) + f' + Nothing + (QBE.Arg (QBE.AbiBaseTy QBE.Long) <$> xs') + [] + lower' e k + +lower' _ k = _ + +lower e = do + _ <- runCodeGen (lower' e \r -> _) + _ diff --git a/app/Gyehoek/GenSym.hs b/app/Gyehoek/GenSym.hs new file mode 100644 index 0000000..95add42 --- /dev/null +++ b/app/Gyehoek/GenSym.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TypeFamilies #-} +module Gyehoek.GenSym where + +import Numeric.Natural +import Effectful.State.Dynamic +import Effectful.Dispatch.Dynamic +import Effectful +import Language.QBE as QBE +import Data.String (IsString(fromString)) +import Data.Text (Text) + + +class Gen a where + gen :: Natural -> a + +data GenSym :: Effect where + GenSym :: Gen a => GenSym m a + +type instance DispatchOf GenSym = Dynamic + +gensym :: forall a es. (Gen a, GenSym :> es) => Eff es a +gensym = send GenSym + +runGenSym :: Eff (GenSym : es) a -> Eff es a +runGenSym = reinterpret (evalStateLocal (0 :: Natural)) \_ GenSym -> + state \n -> (gen n, succ n) + -- state \n -> (Ident . fromString $ '.' : show n, succ n) + +instance Gen (QBE.Ident s) where + gen = Ident . fromString . ('.':) . show + +instance Gen Text where + gen = fromString . ('x':) . show diff --git a/app/Gyehoek/QBE.hs b/app/Gyehoek/QBE.hs index 6cae433..5a50b2b 100644 --- a/app/Gyehoek/QBE.hs +++ b/app/Gyehoek/QBE.hs @@ -6,10 +6,7 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE TemplateHaskellQuotes #-} module Gyehoek.QBE - ( GenSym - , runGenSym - , gensym - , module QBE + ( module QBE , render , fn ) @@ -17,10 +14,6 @@ module Gyehoek.QBE import Gyehoek.QBE.Parse import Language.QBE as QBE -import Effectful.State.Dynamic -import Effectful.Dispatch.Dynamic -import Effectful -import Numeric.Natural import Data.String (IsString(fromString)) import Prettyprinter (Pretty(pretty), layoutPretty, defaultLayoutOptions) import Data.Text (Text) @@ -36,18 +29,6 @@ import Data.Kind (Type) render :: Pretty a => a -> Text render = renderStrict . layoutPretty defaultLayoutOptions . pretty -data GenSym :: Effect where - GenSym :: GenSym m (Ident s) - -type instance DispatchOf GenSym = Dynamic - -gensym :: forall s es. GenSym :> es => Eff es (Ident s) -gensym = send GenSym - -runGenSym :: Eff (GenSym : es) a -> Eff es a -runGenSym = reinterpret (evalStateLocal (0 :: Natural)) \_ GenSym -> - state \n -> (Ident . fromString $ '.' : show n, succ n) - parseQuoteExp diff --git a/app/Gyehoek/Scratch.hs b/app/Gyehoek/Scratch.hs new file mode 100644 index 0000000..661f691 --- /dev/null +++ b/app/Gyehoek/Scratch.hs @@ -0,0 +1 @@ +module Gyehoek.Scratch where diff --git a/app/Gyehoek/Syntax.hs b/app/Gyehoek/Syntax.hs new file mode 100644 index 0000000..1b621d7 --- /dev/null +++ b/app/Gyehoek/Syntax.hs @@ -0,0 +1,25 @@ +module Gyehoek.Syntax where + +import Data.Text (Text) +import Data.List (List) + + +type Name = Text + +data Prim = PrimAdd | PrimSub | PrimMul | PrimDiv + deriving (Show) + +data Val + = ValInt Int + | ValNil + | ValPrim Prim + | ValLambda (List Name) Exp + | ValVar Name + deriving (Show) + +data Exp + = ExpLet (List (Name, Exp)) Exp + | ExpApply Exp (List Exp) + | ExpProgn (List Exp) + | ExpVal Val + deriving (Show) diff --git a/app/Main.hs b/app/Main.hs index fa0c5f7..aa8608d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -6,85 +6,10 @@ 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 +import qualified Gyehoek.ANF as ANF +import Gyehoek.QBE (render) +import qualified Data.Text.IO as TIO -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 +main = TIO.putStrLn . render $ ANF.expr diff --git a/gyehoek.cabal b/gyehoek.cabal index de9322b..788eb8a 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -29,8 +29,12 @@ executable gyehoek -- cabal-fmt: expand app -Main other-modules: + Gyehoek.ANF + Gyehoek.GenSym Gyehoek.QBE Gyehoek.QBE.Parse + Gyehoek.Scratch + Gyehoek.Syntax -- other-extensions: build-depends: @@ -40,12 +44,14 @@ executable gyehoek , effectful-plugin , lens , megaparsec + , mtl , prettyprinter , qbe , recursion-schemes , template-haskell , text , vector + , generic-lens hs-source-dirs: app default-language: GHC2024