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 -> _)
+  _

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

app/Gyehoek/QBE.hs

@@ -6,10 +6,7 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE TemplateHaskellQuotes #-}
 module Gyehoek.QBE
-  ( GenSym
+  ( module QBE
-  , runGenSym
-  , gensym
-  , 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

app/Gyehoek/Scratch.hs

@@ -0,0 +1 @@
+module Gyehoek.Scratch where

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)

app/Main.hs

@@ -6,85 +6,10 @@ module Main
   (main)
   where
 
-import Data.Text (Text)
+import qualified Gyehoek.ANF as ANF
-import Effectful
+import Gyehoek.QBE (render)
-import Gyehoek.QBE as QBE
+import qualified Data.Text.IO as TIO
-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!"
+main = TIO.putStrLn . render $ ANF.expr
-
-expr = UseVal (ValPrim PrimAdd)
-  :. UseVal (ValInt 1)
-  :. UseVal (ValInt 2)
-  -- :. UseVal (ValInt 3)
-  :. UseVal ValNil

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