256 lines
6.9 KiB
Haskell
256 lines
6.9 KiB
Haskell
{-# LANGUAGE OverloadedLabels #-}
|
|
{-# 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, lower)
|
|
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.Strict (Vector)
|
|
import Data.Function (fix)
|
|
import Effectful.Writer.Static.Local
|
|
import Gyehoek.Syntax qualified as Lam
|
|
import Gyehoek.Syntax (Name, Prim(..), Lit(..))
|
|
import Gyehoek.GenSym
|
|
import Control.Monad.Cont
|
|
import Data.Foldable
|
|
import Data.List.NonEmpty (NonEmpty((:|)), toList)
|
|
import Gyehoek.QBE (FuncDef(FuncDef))
|
|
import Data.Foldable1
|
|
import qualified Data.Text as T
|
|
import Data.String (fromString)
|
|
import Language.SexpGrammar as Sexp hiding (List, iso)
|
|
import Language.SexpGrammar.Generic
|
|
import GHC.Generics (Generic)
|
|
import Control.Category
|
|
import Prelude hiding ((.), id)
|
|
import Data.InvertibleGrammar.Base qualified as IG
|
|
import Data.InvertibleGrammar.Base ((:-)((:-)))
|
|
import qualified Gyehoek.Sexp
|
|
import Control.Lens.Unsound
|
|
|
|
|
|
data Val
|
|
= ValLit Lit
|
|
| ValVar Name
|
|
deriving (Show, Generic)
|
|
|
|
data Exp
|
|
= ExpLetApply Name Val (List Val) Exp
|
|
| ExpLetPrim Name (Prim Val) Exp
|
|
| ExpBegin (List Exp)
|
|
| ExpVal Val
|
|
deriving (Show, Generic)
|
|
|
|
|
|
|
|
collapseBindings
|
|
-- | Match constructor.
|
|
:: Prism' a b
|
|
-- | Extract subexpression from match.
|
|
-> Getter b a
|
|
-> a
|
|
-> (List b, a)
|
|
collapseBindings p l e =
|
|
case e ^? p of
|
|
Just a -> collapseBindings p l (a ^. l) & _1 %~ (a:)
|
|
Nothing -> ([], e)
|
|
|
|
foldLet
|
|
:: Prism' Exp a
|
|
-> Lens' a lhs
|
|
-> Lens' a rhs
|
|
-> Lens' a Exp
|
|
-> Grammar
|
|
Position
|
|
(Exp :- NonEmpty (lhs, rhs) :- t)
|
|
(Exp :- _)
|
|
foldLet p lhs rhs exp =
|
|
IG.Iso
|
|
_
|
|
_
|
|
|
|
instance SexpIso Val where
|
|
sexpIso = match
|
|
$ With (. sexpIso)
|
|
$ With (. symbol)
|
|
$ End
|
|
|
|
nonEmptyIso :: Iso (NonEmpty a) (NonEmpty b) (a, List a) (b, List b)
|
|
nonEmptyIso = iso (\(x:|xs) -> (x,xs)) (uncurry (:|))
|
|
|
|
instance SexpIso Exp where
|
|
sexpIso = match
|
|
$ With (. letapp)
|
|
$ With (. letprim)
|
|
$ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
|
|
$ With (. sexpIso)
|
|
$ End
|
|
where
|
|
letprim
|
|
:: Grammar Position (Sexp :- t) (Exp :- (Prim Val :- (Text :- t)))
|
|
letprim =
|
|
Gyehoek.Sexp.let_ symbol (sexpIso @(Prim Val)) (sexpIso @Exp)
|
|
>>> foldLet #ExpLetPrim _1 _2 _3
|
|
letapp :: Grammar
|
|
Position (Sexp :- t) (Exp :- List Val :- Val :- Text :- t)
|
|
letapp =
|
|
Gyehoek.Sexp.let_ symbol (sexpIso @(NonEmpty Val)) (sexpIso @Exp)
|
|
>>> foldLet #ExpLetApply _1 (lensProduct _2 _3 . from nonEmptyIso) _4
|
|
-- foldLet =
|
|
-- IG.Iso
|
|
-- (\(e :- ((r,f:|xs):|bs) :- t) ->
|
|
-- foldr (\(v,g:|ys) -> ExpLetApply v g ys) e bs
|
|
-- :- xs :- f :- r :- t)
|
|
-- (\(e :- xs :- f :- r :- t) ->
|
|
-- let (bs,e') = collapseBindings #ExpLetApply _4 e
|
|
-- & _1 . each %~ \(x,g,ys,_) -> (x,g:|ys)
|
|
-- in e' :- ((r,f:|xs):|bs) :- t)
|
|
|
|
|
|
|
|
-- 뻘짓이어라
|
|
telescope :: Traversable t => t ((a -> r) -> r) -> (t a -> r) -> r
|
|
telescope = runCont . traverse cont
|
|
|
|
toANF'
|
|
:: forall es. GenSym :> es
|
|
=> Lam.Exp
|
|
-> (Val -> Eff es Exp)
|
|
-> Eff es Exp
|
|
|
|
toANF' (Lam.ExpLit v) k = k . ValLit $ v
|
|
|
|
toANF' (Lam.ExpApply f xs) k =
|
|
telescope (toANF' <$> (f:|xs)) \(f':|xs') -> do
|
|
r <- gensym
|
|
ExpLetApply r f' xs' <$> k (ValVar r)
|
|
|
|
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)]
|
|
-- ]
|
|
|
|
|
|
|
|
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 = QBE.Program mempty mempty mempty
|
|
|
|
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
|
|
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")))
|
|
]
|
|
|
|
data BlockBuilder
|
|
= Emit (Vector QBE.Inst) !BlockBuilder
|
|
| Exit QBE.Jump
|
|
deriving (Show)
|
|
|
|
instance Each BlockBuilder BlockBuilder QBE.Inst QBE.Inst where
|
|
each k (Emit is bb) = Emit <$> traverse k is <*> each k bb
|
|
each k (Exit j) = pure (Exit j)
|
|
|
|
evalBlockBuilder :: BlockBuilder -> (Vector QBE.Inst, QBE.Jump)
|
|
evalBlockBuilder (Emit is bb) = evalBlockBuilder bb & _1 <>:~ is
|
|
evalBlockBuilder (Exit j) = ([],j)
|
|
|
|
buildBlock :: QBE.Ident QBE.Label -> BlockBuilder -> QBE.Block
|
|
buildBlock n bb = QBE.Block n [] (is ^.. each) j
|
|
where (is,j) = evalBlockBuilder bb
|
|
|
|
lowerName :: Name -> QBE.Ident t
|
|
lowerName = fromString . T.unpack
|
|
|
|
lowerVal
|
|
:: forall es. (GenSym :> es)
|
|
=> Val
|
|
-> (QBE.Val -> Eff es BlockBuilder)
|
|
-> Eff es BlockBuilder
|
|
|
|
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
|
|
|
|
lower'
|
|
:: forall es. (GenSym :> es)
|
|
=> Exp
|
|
-> (QBE.Val -> Eff es BlockBuilder)
|
|
-> Eff es BlockBuilder
|
|
|
|
lower' (ExpVal v) k = lowerVal v k
|
|
|
|
lower' (ExpLetApply r f xs e) k =
|
|
telescope (lowerVal @es <$> (f:|xs)) \(f':|xs') -> do
|
|
Emit [ QBE.Call
|
|
(Just (lowerName r, QBE.AbiBaseTy QBE.Long))
|
|
f'
|
|
Nothing
|
|
(QBE.Arg (QBE.AbiBaseTy QBE.Long) <$> xs')
|
|
[]
|
|
]
|
|
<$> lower' e k
|
|
|
|
lower' _ k = _
|
|
|
|
lower :: GenSym :> es => QBE.Ident QBE.Label -> Exp -> Eff es QBE.Block
|
|
lower n e = buildBlock n <$> lower' e (pure . Exit . QBE.Ret . Just)
|
|
|
|
wrapProgram :: Foldable1 t => t QBE.Block -> QBE.Program
|
|
wrapProgram bs = QBE.Program [] [] [main] where
|
|
main = QBE.FuncDef [QBE.Export]
|
|
(Just (QBE.AbiBaseTy QBE.Word))
|
|
"main" Nothing [] QBE.NoVariadic (toNonEmpty bs)
|