app/Gyehoek/ANF.hs

@@ -22,7 +22,7 @@ import Data.Vector.Strict (Vector)
 import Data.Function (fix)
 import Effectful.Writer.Static.Local
 import Gyehoek.Syntax qualified as Lam
-import Gyehoek.Syntax (Name, Prim(..), Val(..))
+import Gyehoek.Syntax (Name, Prim(..), Lit(..))
 import Gyehoek.GenSym
 import Control.Monad.Cont
 import Data.Foldable
@@ -41,13 +41,10 @@ import Data.InvertibleGrammar.Base ((:-)((:-)))
 import qualified Gyehoek.Sexp
 
 
--- data Val
---   = ValInt Int
---   | ValNil
---   | ValPrim Prim
---   | ValLambda (List Name) Exp
---   | ValVar Name
---   deriving (Show)
+data Val
+  = ValLit Lit
+  | ValVar Name
+  deriving (Show, Generic)
 
 data Exp
   = ExpLetApply Name Val (List Val) Exp
@@ -69,6 +66,12 @@ collapseBindings p l e =
     Just a -> collapseBindings p l (a ^. l) & _1 %~ (a:)
     Nothing -> ([], e)
 
+instance SexpIso Val where
+  sexpIso = match
+    $ With (. sexpIso)
+    $ With (. symbol)
+    $ End
+
 instance SexpIso Exp where
   sexpIso = match
     $ With (. letapp)
@@ -93,26 +96,17 @@ instance SexpIso Exp where
 
 
 
-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
-
+-- 뻘짓이어라
 telescope :: Traversable t => t ((a -> r) -> r) -> (t a -> r) -> r
 telescope = runCont . traverse cont
 
--- 뻘짓이어라
-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.ExpLit v) k = k . ValLit $ v
 
 toANF' (Lam.ExpApply f xs) k =
   telescope (toANF' <$> (f:|xs)) \(f':|xs') -> do
@@ -123,30 +117,25 @@ 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)
-      ]
-    ]
+-- 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)]
-    ]
+-- 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')
@@ -155,7 +144,9 @@ instance Monoid QBE.Program where
   mempty :: QBE.Program
   mempty = QBE.Program mempty mempty mempty
 
-funcdef :: QBE.Ident QBE.Global -> [QBE.Param] -> NonEmpty QBE.Block -> FuncDef
+funcdef
+  :: QBE.Ident QBE.Global
+  -> List QBE.Param -> NonEmpty QBE.Block -> FuncDef
 funcdef name ps = QBE.FuncDef mempty Nothing name Nothing ps QBE.NoVariadic
 
 prims :: QBE.Program
@@ -210,10 +201,10 @@ lowerVal
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
 
-lowerVal (ValInt n) k = k . QBE.ValConst . QBE.CInt . fromIntegral $ n
+lowerVal (ValLit (LitInt n)) k =
+  k . QBE.ValConst . QBE.CInt . fromIntegral $ n
+lowerVal (ValLit _) k = error "todo"
 lowerVal (ValVar x) k = k . QBE.ValTemporary . lowerName $ x
-lowerVal (ValPrim p) k = lowerPrim p k
-lowerVal _ k = _
 
 lower'
   :: forall es. (GenSym :> es)