diff --git a/app/Gyehoek/ANF.hs b/app/Gyehoek/ANF.hs index 4949ff2..0bae57c 100644 --- a/app/Gyehoek/ANF.hs +++ b/app/Gyehoek/ANF.hs @@ -146,10 +146,11 @@ toANF' -> Eff es Exp toANF' (Lam.ExpLit v) k = k . ValLit $ v + toANF' (Lam.ExpPrim p) k = - telescope (toANF' <$> p) \p -> do + telescope (toANF' <$> p) \p' -> do r <- gensym - ExpLetPrim r p <$> k (ValVar r) + ExpLetPrim r p' <$> k (ValVar r) toANF' (Lam.ExpApply f xs) k = telescope (toANF' <$> (f:|xs)) \(f':|xs') -> do @@ -236,6 +237,23 @@ lowerVal (ValLit (LitInt n)) k = lowerVal (ValLit _) k = error "todo" lowerVal (ValVar x) k = k . QBE.ValTemporary . lowerName $ x +lowerBinaryOp :: QBE.Assignment -> Prim QBE.Val -> QBE.Inst +lowerBinaryOp r p = QBE.BinaryOp r bop x y + where + (bop,x,y) = case p of + PrimAdd a b -> (QBE.Add,a,b) + PrimMul a b -> (QBE.Mul,a,b) + _ -> _ + +-- lowerPrim +-- :: forall es. (GenSym :> es) +-- => Prim Val +-- -> (QBE.Val -> Eff es BlockBuilder) +-- -> Eff es BlockBuilder +-- lowerPrim p k = telescope (lowerVal <$> p) \p' -> do +-- Emit [ lowerBinaryOp (r QBE.:= QBE.Long) p' ] +-- <$> k (QBE.ValTemporary r) + lower' :: forall es. (GenSym :> es) => Exp @@ -244,6 +262,11 @@ lower' lower' (ExpVal v) k = lowerVal v k +lower' (ExpLetPrim r p e) k = + telescope (lowerVal <$> p) \p' -> do + Emit [ lowerBinaryOp (lowerName r QBE.:= QBE.Long) p' ] + <$> lower' e k + lower' (ExpLetApply r f xs e) k = telescope (lowerVal @es <$> (f:|xs)) \(f':|xs') -> do Emit [ QBE.Call diff --git a/app/Gyehoek/Syntax.hs b/app/Gyehoek/Syntax.hs index 49b9a2b..1539eae 100644 --- a/app/Gyehoek/Syntax.hs +++ b/app/Gyehoek/Syntax.hs @@ -13,6 +13,7 @@ import Prelude hiding ((.), id) import Control.Category import Data.List.NonEmpty (NonEmpty ((:|))) import Gyehoek.Sexp qualified +import Control.Lens (Each) type Name = Text @@ -24,6 +25,8 @@ data Prim e | PrimDiv e e deriving (Show, Generic, Functor, Foldable, Traversable) +instance Each (Prim e) (Prim e') e e' + data Lit = LitInt Int | LitNil