diff --git a/app/Gyehoek/ANF.hs b/app/Gyehoek/ANF.hs index a6f0f23..298e5d4 100644 --- a/app/Gyehoek/ANF.hs +++ b/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) diff --git a/app/Gyehoek/Sexp.hs b/app/Gyehoek/Sexp.hs index be565b1..c5ea7a2 100644 --- a/app/Gyehoek/Sexp.hs +++ b/app/Gyehoek/Sexp.hs @@ -13,6 +13,8 @@ import Language.SexpGrammar.Generic import Data.InvertibleGrammar.Base qualified as IG import Data.InvertibleGrammar.Base ((:-)((:-))) import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List (List) +import GHC.Generics nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a) @@ -31,3 +33,20 @@ let_ name rhs e = list (el (sym "let") >>> el bindings >>> el e) bindings = nonempty binding binding :: Grammar Position (Sexp :- t) ((_, _) :- t) binding = list (el name >>> el rhs) >>> pair + +data DotList a = MkDotList (NonEmpty a) a + deriving (Show, Generic) + +dotlist :: Grammar Position _ _ -> _ +dotlist x = list $ rest $ coproduct + [ x >>> iso _ _ + ] + +lambda + :: (forall t. Grammar Position (Sexp :- t) (a :- t)) + -> Grammar Position (Sexp :- List a :- t1) t2 + -> Grammar Position (Sexp :- t1) t2 +lambda name e = list $ + el (sym "lambda") + >>> el (list $ rest name) + >>> el e diff --git a/app/Gyehoek/Syntax.hs b/app/Gyehoek/Syntax.hs index b1c48a0..ff43c1e 100644 --- a/app/Gyehoek/Syntax.hs +++ b/app/Gyehoek/Syntax.hs @@ -20,19 +20,20 @@ type Name = Text data Prim = PrimAdd | PrimSub | PrimMul | PrimDiv deriving (Show, Generic) -data Val - = ValInt Int - | ValNil - | ValPrim Prim - | ValLambda (List Name) Exp - | ValVar Name +data Lit + = LitInt Int + | LitNil + | LitBool Bool deriving (Show, Generic) data Exp = ExpLet (NonEmpty (Name, Exp)) Exp | ExpApply Exp (List Exp) | ExpBegin (List Exp) - | ExpVal Val + | ExpLit Lit + | ExpPrim Prim + | ExpLambda (List Name) Exp + | ExpVar Name deriving (Show, Generic) @@ -45,24 +46,26 @@ instance SexpIso Prim where $ With (. sym "/") $ End -instance SexpIso Val where +instance SexpIso Lit where sexpIso = match $ With (. sexpIso) $ With (. sym "nil") $ With (. sexpIso) - $ With lam - $ With (. symbol) $ End where - lam q = q . list - ( el (sym "lambda") - >>> el (sexpIso @(List Name)) - >>> el sexpIso ) instance SexpIso Exp where sexpIso = match $ With (. Gyehoek.Sexp.let_ symbol sexpIso sexpIso) $ With (\app -> app . list (el sexpIso >>> rest sexpIso)) $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso)) - $ With (<<< sexpIso) + $ With (. sexpIso) + $ With (. sexpIso) + $ With (. lam) + $ With (. symbol) $ End + where + lam = list + ( el (sym "lambda") + >>> el (sexpIso @(List Name)) + >>> el sexpIso )