cps
This commit is contained in:
@@ -1,574 +0,0 @@
|
||||
{-# 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.Syntax
|
||||
( Exp(..)
|
||||
, toANF
|
||||
, lower
|
||||
, wrapFunction
|
||||
, lowerProgram
|
||||
)
|
||||
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.Scheme.Syntax qualified as Lam
|
||||
import Gyehoek.Scheme.Syntax (Name, Prim(..), Lit(..))
|
||||
import Gyehoek.GenSym
|
||||
import Control.Monad.Cont
|
||||
import Data.Foldable
|
||||
import Data.List.NonEmpty (NonEmpty((:|)))
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
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, encode, decode, traversed)
|
||||
import Language.SexpGrammar.Generic
|
||||
import GHC.Generics (Generic)
|
||||
import Gyehoek.Sexp
|
||||
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
|
||||
import qualified Data.Bits
|
||||
import qualified GHC.IO.Encoding as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Effectful.State.Static.Local
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
|
||||
|
||||
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)
|
||||
|
||||
|
||||
|
||||
expandBindings
|
||||
-- | Match constructor. (an affine fold would be preferable to a
|
||||
-- prism here)
|
||||
:: Prism' e (lhs, rhs, e)
|
||||
-> e
|
||||
-> (List (lhs, rhs), e)
|
||||
expandBindings p = go [] where
|
||||
go acc e =
|
||||
case e ^? p of
|
||||
Just (l,r,e') -> go ((l,r):acc) e'
|
||||
Nothing -> (acc, e)
|
||||
|
||||
collapseBindings
|
||||
:: Foldable f => AReview e (lhs, rhs, e) -> f (lhs, rhs)
|
||||
-> e -> e
|
||||
collapseBindings p bs e = foldr (\(l,r) e' -> p # (l,r,e')) e bs
|
||||
|
||||
-- | Technically unlawful.
|
||||
bindingTelescope
|
||||
:: Prism' e (lhs, rhs, e)
|
||||
-> Iso' e (List (lhs, rhs), e)
|
||||
bindingTelescope p = iso
|
||||
(expandBindings p)
|
||||
(uncurry $ collapseBindings p)
|
||||
|
||||
foldLet
|
||||
:: Prism' Exp (lhs, rhs, Exp)
|
||||
-> Grammar
|
||||
Position
|
||||
(Exp :- NonEmpty (lhs, rhs) :- t)
|
||||
(Exp :- rhs :- lhs :- t)
|
||||
foldLet p =
|
||||
IG.Iso
|
||||
(\(e :- ((l1,r1):|bs) :- t) ->
|
||||
collapseBindings p bs e :- r1 :- l1 :- t)
|
||||
(\(e :- r :- l :- t) ->
|
||||
let (bs,e') = expandBindings p e
|
||||
in e' :- ((l,r) :| bs) :- t)
|
||||
|
||||
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 (:|))
|
||||
|
||||
-- nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
|
||||
-- nonEmptyGrammar = IG.Iso
|
||||
-- (\((x:|xs) :- t) -> xs :- x :- t)
|
||||
-- (\(xs :- x :- t) -> (x:|xs) :- t)
|
||||
|
||||
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
|
||||
letapp :: Grammar
|
||||
Position (Sexp :- t) (Exp :- List Val :- Val :- Text :- t)
|
||||
letapp =
|
||||
Gyehoek.Sexp.let_ symbol (sexpIso @(NonEmpty Val)) (sexpIso @Exp)
|
||||
>>> foldLet (#ExpLetApply
|
||||
. iso (\(rhs,f,xs,e) -> (rhs, f:|xs, e))
|
||||
(\(rhs,f:|xs,e) -> (rhs,f,xs,e)))
|
||||
>>> onTail nonEmptyGrammar
|
||||
|
||||
|
||||
|
||||
-- 뻘짓이어라
|
||||
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.ExpPrim p) k =
|
||||
telescope (toANF' <$> p) \p' -> do
|
||||
r <- gensym
|
||||
ExpLetPrim r p' <$> k (ValVar r)
|
||||
|
||||
toANF' (Lam.ExpApply f xs) k =
|
||||
telescope (toANF' <$> (f:|xs)) \(f':|xs') -> do
|
||||
r <- gensym
|
||||
ExpLetApply r f' xs' <$> k (ValVar r)
|
||||
|
||||
toANF' (Lam.ExpBegin xs) k = ExpBegin <$> traverse anf xs
|
||||
where
|
||||
anf x = toANF' x (pure . ExpVal)
|
||||
|
||||
toANF' (Lam.ExpLet xs e) k = _
|
||||
|
||||
toANF' e k = _
|
||||
|
||||
toANF e = toANF' e (pure . ExpVal)
|
||||
|
||||
|
||||
|
||||
expr =
|
||||
Lam.ExpPrim
|
||||
(PrimAdd
|
||||
(Lam.ExpPrim
|
||||
(PrimMul
|
||||
(Lam.ExpLit (LitInt 2))
|
||||
(Lam.ExpLit (LitInt 3))))
|
||||
(Lam.ExpLit (LitInt 4)))
|
||||
|
||||
expr2 =
|
||||
Lam.ExpBegin
|
||||
[ Lam.ExpPrim
|
||||
(PrimWrite
|
||||
(Lam.ExpPrim
|
||||
(PrimCons
|
||||
(Lam.ExpLit (LitInt 2))
|
||||
(Lam.ExpLit (LitInt 3)))))
|
||||
, Lam.ExpPrim
|
||||
(PrimWrite
|
||||
(Lam.ExpPrim
|
||||
(PrimMul
|
||||
(Lam.ExpLit (LitInt 5))
|
||||
(Lam.ExpLit (LitInt 4)))))
|
||||
]
|
||||
|
||||
|
||||
|
||||
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
|
||||
(Just (QBE.AbiBaseTy QBE.Long))
|
||||
name Nothing ps QBE.NoVariadic
|
||||
|
||||
prims :: QBE.Program
|
||||
prims = QBE.Program primtys mempty primfns where
|
||||
primtys =
|
||||
[ QBE.TypeDef "scm" Nothing
|
||||
[ (QBE.SubExtTy (QBE.BaseTy QBE.Long), Just 2) ]
|
||||
]
|
||||
primfns = [ -- write
|
||||
-- , 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 Semigroup BlockBuilder where
|
||||
Emit a as <> bs = Emit a (as <> bs)
|
||||
Exit _ <> bs = bs
|
||||
|
||||
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
|
||||
|
||||
lowerInt' = QBE.ValConst . QBE.CInt . fromIntegral
|
||||
|
||||
lowerInt = QBE.ValConst . QBE.CInt
|
||||
. (Data.Bits..|. 2)
|
||||
. (Data.Bits..<<. 2)
|
||||
. fromIntegral
|
||||
|
||||
lowerString
|
||||
:: forall es. (GenSym :> es, State StringLiterals :> es)
|
||||
=> Text -> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
|
||||
lowerString s k = do
|
||||
let len = lengthOf each $ T.encodeUtf8 s
|
||||
rawString <- getRawString
|
||||
r <- gensym
|
||||
Emit (alloc r rawString len) <$> k (QBE.ValTemporary r)
|
||||
where
|
||||
-- getRawString
|
||||
-- :: forall es. (GenSym :> es, State StringLiterals :> es)
|
||||
-- => Eff es _
|
||||
getRawString = do
|
||||
x <- get
|
||||
case x ^. at s of
|
||||
Just s' -> pure s'
|
||||
Nothing -> do r <- gensym
|
||||
state \lits -> (r, HM.insert s r lits)
|
||||
alloc r rs len =
|
||||
[ QBE.Call
|
||||
(Just (r, QBE.AbiBaseTy QBE.Long))
|
||||
(QBE.ValGlobal "scm_from_utf8_string")
|
||||
Nothing
|
||||
[ QBE.Arg (QBE.AbiBaseTy QBE.Long) (QBE.ValGlobal rs)
|
||||
-- N.b. The C function declares this argument as size_t, which
|
||||
-- /is/ long on my system.
|
||||
, QBE.Arg (QBE.AbiBaseTy QBE.Long) (lowerInt' len)
|
||||
]
|
||||
[]
|
||||
]
|
||||
|
||||
type StringLiterals = HashMap Text (QBE.Ident QBE.Global)
|
||||
|
||||
lowerVal
|
||||
:: forall es. (GenSym :> es, State StringLiterals :> es)
|
||||
=> Val
|
||||
-> (QBE.Val -> Eff es BlockBuilder)
|
||||
-> Eff es BlockBuilder
|
||||
|
||||
lowerVal (ValLit (LitInt n)) k = k . lowerInt $ n
|
||||
|
||||
lowerVal (ValLit (LitQuote (Lam.SexpSymbol s))) k =
|
||||
lowerString s \s' -> do
|
||||
r <- gensym
|
||||
Emit (intern r s') <$> k (QBE.ValTemporary r)
|
||||
where
|
||||
intern r s' =
|
||||
[ QBE.Call
|
||||
(Just (r, QBE.AbiBaseTy QBE.Long))
|
||||
(QBE.ValGlobal "scm_string_to_symbol")
|
||||
Nothing
|
||||
[ QBE.Arg (QBE.AbiBaseTy QBE.Long) s'
|
||||
]
|
||||
[]
|
||||
]
|
||||
|
||||
lowerVal (ValLit (LitString s)) k = lowerString s k
|
||||
|
||||
lowerVal (ValLit _) k = error "todo"
|
||||
lowerVal (ValVar x) k = k . QBE.ValTemporary . lowerName $ x
|
||||
|
||||
binaryPrim :: Prism' (Prim a) (QBE.BinaryOp, a, a)
|
||||
binaryPrim = prism' up down where
|
||||
up (bop,a,b) = case bop of
|
||||
QBE.Add -> _
|
||||
QBE.Mul -> _
|
||||
_ -> _
|
||||
down = \case
|
||||
PrimAdd a b -> Just (QBE.Add,a,b)
|
||||
PrimMul a b -> Just (QBE.Mul,a,b)
|
||||
_ -> Nothing
|
||||
|
||||
lowerArithmetic :: QBE.Assignment -> Prim QBE.Val -> QBE.Inst
|
||||
lowerArithmetic 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)
|
||||
_ -> _
|
||||
|
||||
sizeofScm :: Integral a => a
|
||||
sizeofScm = 8
|
||||
|
||||
lowerCons
|
||||
:: (GenSym :> es, State StringLiterals :> es)
|
||||
=> Name -> QBE.Val -> QBE.Val -> Exp
|
||||
-> (QBE.Val -> Eff es BlockBuilder)
|
||||
-> Eff es BlockBuilder
|
||||
lowerCons r car cdr e k = do
|
||||
r1 <- gensym
|
||||
Emit (alloc <> initialise r1) <$> lower' e k
|
||||
where
|
||||
alloc = [ QBE.Call
|
||||
(Just (lowerName r, QBE.AbiBaseTy QBE.Long))
|
||||
(QBE.ValGlobal "GC_malloc")
|
||||
Nothing
|
||||
[ QBE.Arg
|
||||
(QBE.AbiBaseTy QBE.Long)
|
||||
(QBE.ValConst (QBE.CInt (sizeofScm * 2))) ]
|
||||
[]
|
||||
]
|
||||
initialise r1 =
|
||||
[ QBE.BinaryOp (r1 QBE.:= QBE.Long) QBE.Add
|
||||
(QBE.ValTemporary (lowerName r)) (QBE.ValConst (QBE.CInt 8))
|
||||
, QBE.Store (QBE.BaseTy QBE.Long) car (QBE.ValTemporary (lowerName r))
|
||||
, QBE.Store (QBE.BaseTy QBE.Long) cdr (QBE.ValTemporary r1)
|
||||
]
|
||||
|
||||
smallIntHelper'
|
||||
:: GenSym :> es
|
||||
=> QBE.Ident 'QBE.Temporary
|
||||
-> QBE.BinaryOp
|
||||
-> QBE.Val -> QBE.Val
|
||||
-> (QBE.Val -> Eff es BlockBuilder)
|
||||
-> Eff es BlockBuilder
|
||||
smallIntHelper' r bop v1 v2 k = do
|
||||
Emit [ QBE.BinaryOp (r QBE.:= QBE.Long)
|
||||
bop v1 v2 ]
|
||||
<$> k (QBE.ValTemporary r)
|
||||
|
||||
smallIntHelper
|
||||
:: GenSym :> es
|
||||
=> QBE.BinaryOp
|
||||
-> QBE.Val -> QBE.Val
|
||||
-> (QBE.Val -> Eff es BlockBuilder)
|
||||
-> Eff es BlockBuilder
|
||||
smallIntHelper bop a b k = do
|
||||
r <- gensym
|
||||
smallIntHelper' r bop a b k
|
||||
|
||||
makeSmallInt'
|
||||
:: forall es. (GenSym :> es)
|
||||
=> QBE.Ident 'QBE.Temporary
|
||||
-> QBE.Val
|
||||
-> (QBE.Val -> Eff es BlockBuilder)
|
||||
-> Eff es BlockBuilder
|
||||
makeSmallInt' r n k =
|
||||
smallIntHelper QBE.Shl n (lowerInt' 2) \n' ->
|
||||
smallIntHelper' r QBE.Add n' (lowerInt' 2) k
|
||||
|
||||
makeSmallInt
|
||||
:: forall es. (GenSym :> es)
|
||||
=> QBE.Val
|
||||
-> (QBE.Val -> Eff es BlockBuilder)
|
||||
-> Eff es BlockBuilder
|
||||
makeSmallInt n k = do
|
||||
r <- gensym
|
||||
makeSmallInt' r n k
|
||||
|
||||
getSmallInt
|
||||
:: forall es. (GenSym :> es)
|
||||
=> QBE.Val
|
||||
-> (QBE.Val -> Eff es BlockBuilder)
|
||||
-> Eff es BlockBuilder
|
||||
getSmallInt n = smallIntHelper QBE.Shr n (lowerInt' 2)
|
||||
|
||||
lowerWrite
|
||||
:: forall es. (GenSym :> es)
|
||||
=> Name -> QBE.Val -> Exp
|
||||
-> (QBE.Val -> Eff es BlockBuilder)
|
||||
-> Eff es BlockBuilder
|
||||
lowerWrite r x e k =
|
||||
Emit [ QBE.Call (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
|
||||
(QBE.ValGlobal "scm_write") Nothing
|
||||
[QBE.Arg (QBE.AbiBaseTy QBE.Long) x]
|
||||
[]
|
||||
]
|
||||
<$> k (QBE.ValTemporary (lowerName r))
|
||||
|
||||
smallIntMask :: Integer
|
||||
smallIntMask = 2 ^ (sizeofScm * 8) - 2
|
||||
|
||||
lowerCar
|
||||
:: (GenSym :> es, State StringLiterals :> es)
|
||||
=> Name -> QBE.Val -> _
|
||||
-> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
|
||||
lowerCar r x e k = do
|
||||
Emit [ QBE.Load (lowerName r QBE.:= QBE.Long) QBE.Long x
|
||||
]
|
||||
<$> lower' e k
|
||||
|
||||
lowerCdr
|
||||
:: (GenSym :> es, State StringLiterals :> es)
|
||||
=> Name -> QBE.Val -> Exp
|
||||
-> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
|
||||
lowerCdr r x e k = do
|
||||
x1 <- gensym
|
||||
Emit [ QBE.BinaryOp (x1 QBE.:= QBE.Long)
|
||||
QBE.Add x (lowerInt' sizeofScm)
|
||||
, QBE.Load (lowerName r QBE.:= QBE.Long) QBE.Long
|
||||
(QBE.ValTemporary x1)
|
||||
]
|
||||
<$> lower' e k
|
||||
|
||||
lowerNewline r k =
|
||||
Emit [ QBE.Call (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
|
||||
(QBE.ValGlobal "scm_newline") Nothing
|
||||
[]
|
||||
[]
|
||||
]
|
||||
<$> k (QBE.ValTemporary (lowerName r))
|
||||
|
||||
lowerPrim
|
||||
:: forall es. (GenSym :> es, State StringLiterals :> es)
|
||||
=> Name -> Prim Val -> Exp
|
||||
-> (QBE.Val -> Eff es BlockBuilder)
|
||||
-> Eff es BlockBuilder
|
||||
lowerPrim r p e k =
|
||||
telescope (lowerVal <$> p) \case
|
||||
(preview binaryPrim -> Just (bop,a,b)) ->
|
||||
getSmallInt a \a' ->
|
||||
getSmallInt b \b' ->
|
||||
smallIntHelper bop a' b' \c ->
|
||||
makeSmallInt' (lowerName r) c \_ ->
|
||||
lower' e k
|
||||
PrimCons x y -> lowerCons r x y e k
|
||||
PrimCar x -> lowerCar r x e k
|
||||
PrimCdr x -> lowerCdr r x e k
|
||||
PrimWrite x -> lowerWrite r x e k
|
||||
PrimNewline -> lowerNewline r k
|
||||
|
||||
lower'
|
||||
:: forall es. (GenSym :> es, State StringLiterals :> es)
|
||||
=> Exp
|
||||
-> (QBE.Val -> Eff es BlockBuilder)
|
||||
-> Eff es BlockBuilder
|
||||
|
||||
lower' (ExpVal v) k = lowerVal v k
|
||||
|
||||
lower' (ExpLetPrim r p e) k = lowerPrim r p e k
|
||||
|
||||
lower' (ExpLetApply r f xs e) k =
|
||||
telescope (lowerVal @es <$> (f:|xs)) \(f':|xs') ->
|
||||
Emit [ QBE.Call
|
||||
(Just (lowerName r, QBE.AbiBaseTy QBE.Long))
|
||||
f'
|
||||
Nothing
|
||||
(QBE.Arg (QBE.AbiBaseTy QBE.Long) <$> xs')
|
||||
[]
|
||||
]
|
||||
<$> lower' e k
|
||||
|
||||
lower' (ExpBegin (x:xs)) k = fold1 <$> traverse low (x:|xs)
|
||||
where low e = lower' @es e (pure . Exit . QBE.Ret . Just)
|
||||
|
||||
lower' _ k = _
|
||||
|
||||
lower
|
||||
:: (GenSym :> es, State StringLiterals :> es)
|
||||
=> QBE.Ident QBE.Label
|
||||
-> Exp
|
||||
-> Eff es QBE.Block
|
||||
lower n e = buildBlock n <$> lower' e (pure . Exit . QBE.Ret . Just)
|
||||
|
||||
lowerStringLiterals =
|
||||
ifoldMapOf itraversed \s v ->
|
||||
[ QBE.DataDef [] v Nothing
|
||||
[QBE.FieldExtTy QBE.Byte [QBE.String (T.encodeUtf8 s)]]]
|
||||
|
||||
lowerProgram
|
||||
:: (GenSym :> es, Traversable t)
|
||||
=> t Exp -> Eff es QBE.Program
|
||||
lowerProgram anfs =
|
||||
case toList anfs of
|
||||
-- hack for dev convenience: if there's only one expression, let
|
||||
-- it be the entry point.
|
||||
[e] -> do
|
||||
(b,stringLits) <- runState mempty . lower "start" $ e
|
||||
let f = wrapFunction @NonEmpty "main" [b]
|
||||
dataDefs = lowerStringLiterals stringLits
|
||||
pure $ QBE.Program [] dataDefs [f]
|
||||
_ -> do
|
||||
let low e = do
|
||||
bl <- gensym' "b"
|
||||
fl <- gensym' "f"
|
||||
b <- lower bl e
|
||||
pure $ wrapFunction @NonEmpty fl [b]
|
||||
(fs,stringLits) <- runState mempty $ traverse low anfs
|
||||
pure $ QBE.Program [] (lowerStringLiterals stringLits) (fs ^.. traversed)
|
||||
|
||||
wrapFunction
|
||||
:: Foldable1 t
|
||||
=> QBE.Ident 'QBE.Global -> t QBE.Block -> QBE.FuncDef
|
||||
wrapFunction l bs =
|
||||
QBE.FuncDef [QBE.Export]
|
||||
(Just (QBE.AbiBaseTy QBE.Word))
|
||||
l Nothing [] QBE.NoVariadic (toNonEmpty bs)
|
||||
|
||||
wrapProgram :: Foldable1 t => t QBE.Block -> QBE.Program
|
||||
wrapProgram bs = prims <> QBE.Program [] [] [main] where
|
||||
main = QBE.FuncDef [QBE.Export]
|
||||
(Just (QBE.AbiBaseTy QBE.Word))
|
||||
"main" Nothing [] QBE.NoVariadic (toNonEmpty bs)
|
||||
@@ -0,0 +1,31 @@
|
||||
module Gyehoek.CPS.Convert
|
||||
( convert
|
||||
) where
|
||||
|
||||
import Gyehoek.CPS.Syntax
|
||||
import Gyehoek.Scheme.Syntax qualified as Scm
|
||||
import Gyehoek.GenSym
|
||||
import Effectful
|
||||
import Control.Monad.Cont qualified as Cont
|
||||
|
||||
|
||||
-- 뻘짓이어라
|
||||
telescope
|
||||
:: Traversable t
|
||||
=> (a -> (b -> r) -> r)
|
||||
-> t a -> (t b -> r) -> r
|
||||
telescope f = Cont.runCont . traverse (Cont.cont . f)
|
||||
|
||||
convert
|
||||
:: forall es. (GenSym :> es)
|
||||
=> Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
|
||||
|
||||
convert (Scm.ExpVar x) k = k $ ValVar x
|
||||
convert (Scm.ExpLit l) k = k $ ValLit l
|
||||
|
||||
convert (Scm.ExpPrim p) k =
|
||||
telescope (convert @es) p \p' -> do
|
||||
r <- gensym' "r"
|
||||
ExpPrim p' [r] . pure <$> k (ValVar r)
|
||||
|
||||
convert _ _ = _
|
||||
@@ -0,0 +1,77 @@
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
module Gyehoek.CPS.Syntax
|
||||
( Val(..)
|
||||
, Kappa(..)
|
||||
, Exp(..)
|
||||
, Name(..)
|
||||
, Prim(..)
|
||||
)
|
||||
where
|
||||
|
||||
import Language.SexpGrammar qualified as S
|
||||
import Gyehoek.Sexp qualified
|
||||
import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit)
|
||||
import Data.Text (Text)
|
||||
import Data.List (List)
|
||||
import GHC.Generics (Generic)
|
||||
import Language.SexpGrammar.Generic
|
||||
import Control.Category
|
||||
import Data.Text qualified as T
|
||||
import Data.Generics.Labels
|
||||
import Prelude hiding ((.), id)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
|
||||
-- Data types
|
||||
|
||||
data Val
|
||||
= ValLabel Name
|
||||
| ValVar Name
|
||||
| ValLit Lit
|
||||
deriving (Show, Generic)
|
||||
|
||||
data Kappa = MkKappa (List Name) Exp
|
||||
deriving (Show, Generic)
|
||||
|
||||
data Exp
|
||||
= ExpPrim (Prim Val) (List Name) (List Exp)
|
||||
| ExpFix (NonEmpty (Name, Kappa)) Exp
|
||||
| ExpApply Val (List Val)
|
||||
deriving (Show, Generic)
|
||||
|
||||
|
||||
-- SexpIso instances
|
||||
|
||||
instance S.SexpIso Val where
|
||||
sexpIso = match
|
||||
$ With (. label)
|
||||
$ With (. var)
|
||||
$ With (. S.sexpIso)
|
||||
$ End
|
||||
where
|
||||
label = S.keyword >>> S.iso MkName getName
|
||||
var = S.sexpIso
|
||||
|
||||
instance S.SexpIso Kappa where
|
||||
sexpIso = match
|
||||
$ With (. kappa)
|
||||
$ End
|
||||
where
|
||||
kappa = S.list $
|
||||
S.el Gyehoek.Sexp.kappaKeyword
|
||||
>>> S.el (S.list $ S.rest S.sexpIso)
|
||||
>>> S.el S.sexpIso
|
||||
|
||||
instance S.SexpIso Exp where
|
||||
sexpIso = match
|
||||
$ With (. prim)
|
||||
$ With (. let_)
|
||||
$ With (. app)
|
||||
$ End
|
||||
where
|
||||
let_ = Gyehoek.Sexp.let_ "fix" S.sexpIso S.sexpIso S.sexpIso
|
||||
app = S.list $ S.el S.sexpIso >>> S.rest S.sexpIso
|
||||
prim = S.list $
|
||||
S.el (S.sym "prim")
|
||||
>>> S.el (primSexpIso id (S.sexpIso @Val))
|
||||
>>> S.el S.sexpIso
|
||||
>>> S.rest S.sexpIso
|
||||
@@ -6,7 +6,6 @@ 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)
|
||||
import qualified Data.Text.Short as ST
|
||||
@@ -33,10 +32,6 @@ runGenSym = reinterpret (evalStateLocal (0 :: Natural)) \cases
|
||||
_ GenSym -> state \n -> (gen n, succ n)
|
||||
_ (GenSym' s) -> state \n -> (gen' s n, succ n)
|
||||
|
||||
instance Gen (QBE.Ident s) where
|
||||
gen = Ident . fromString . ('.':) . show
|
||||
gen' s = Ident . (ST.fromText s <>) . fromString . show
|
||||
|
||||
instance Gen Text where
|
||||
gen = fromString . ('x':) . show
|
||||
gen' s = (s <>) . fromString . show
|
||||
|
||||
@@ -1,61 +0,0 @@
|
||||
{-# LANGUAGE RequiredTypeArguments #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||
module Gyehoek.QBE
|
||||
( module QBE
|
||||
, render
|
||||
, fn
|
||||
, writeTo
|
||||
)
|
||||
where
|
||||
|
||||
import Gyehoek.QBE.Parse
|
||||
import Language.QBE as QBE
|
||||
import Data.String (IsString(fromString))
|
||||
import Prettyprinter (Pretty(pretty), layoutPretty, defaultLayoutOptions)
|
||||
import Data.Text (Text)
|
||||
import Data.Data
|
||||
import Prettyprinter.Render.Text (renderStrict)
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
import Language.Haskell.TH qualified as TH
|
||||
import Language.Haskell.TH.Quote
|
||||
import Data.Kind (Type)
|
||||
import qualified Data.Text.IO as TIO
|
||||
|
||||
|
||||
writeTo :: FilePath -> Text -> IO ()
|
||||
writeTo = TIO.writeFile
|
||||
|
||||
render :: Pretty a => a -> Text
|
||||
render = renderStrict . layoutPretty defaultLayoutOptions . pretty
|
||||
|
||||
|
||||
|
||||
parseQuoteExp
|
||||
:: (TH.Quote m, MonadFail m, Data a) => P a -> String -> m TH.Exp
|
||||
parseQuoteExp p s =
|
||||
case parse (space *> p <* space <* eof) "qq" (fromString s) of
|
||||
Left es -> fail . foldMap f . bundleErrors $ es
|
||||
where f e = parseErrorPretty e ++ "\n\n"
|
||||
Right x -> dataToExpQ (\_ -> Nothing) x
|
||||
|
||||
-- quoteExp :: TH.Quote m => forall (t :: Type) -> (Parser t) => String -> m TH.Exp
|
||||
-- quoteExp t s = case parse (parser @t) "qq" (fromString s) of
|
||||
-- Left es -> _
|
||||
-- Right x -> dataToExpQ (\_ -> Nothing) x
|
||||
|
||||
makeQQ :: forall (t :: Type) -> Parser t => QuasiQuoter
|
||||
makeQQ t = QuasiQuoter
|
||||
{ quoteExp = parseQuoteExp (parser @t)
|
||||
, quotePat = _
|
||||
, quoteType = undefined
|
||||
, quoteDec = undefined
|
||||
}
|
||||
|
||||
fn :: QuasiQuoter
|
||||
fn = makeQQ (type FuncDef)
|
||||
@@ -1,194 +0,0 @@
|
||||
{-# LANGUAGE RequiredTypeArguments #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
module Gyehoek.QBE.Parse where
|
||||
|
||||
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)
|
||||
import Data.Data
|
||||
import Prettyprinter.Render.Text (renderStrict)
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
import Text.Megaparsec.Char.Lexer qualified as L
|
||||
import Data.Void (Void)
|
||||
import Data.Char (isAlpha, isAlphaNum)
|
||||
import Control.Lens.Wrapped
|
||||
import Data.Functor.Contravariant (Predicate(Predicate))
|
||||
import qualified Data.Text as T
|
||||
import Data.Functor
|
||||
import Data.List (List)
|
||||
import Data.Foldable (fold)
|
||||
import Data.Maybe (isJust, fromMaybe)
|
||||
import Control.Monad.Fix (MonadFix(mfix))
|
||||
import Data.List.NonEmpty (fromList)
|
||||
import Language.Haskell.TH qualified as TH
|
||||
import Language.Haskell.TH.Quote
|
||||
import Data.Proxy
|
||||
import Data.Kind (Type)
|
||||
|
||||
|
||||
type P = Parsec Void Text
|
||||
|
||||
sc :: P ()
|
||||
sc = L.space hspace1 (L.skipLineComment "#") empty
|
||||
|
||||
lexeme :: P a -> P a
|
||||
lexeme = L.lexeme sc
|
||||
|
||||
symbol :: Text -> P Text
|
||||
symbol = L.symbol sc
|
||||
|
||||
infixr 8 .:
|
||||
(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
|
||||
(.:) f g x y = f (g x y)
|
||||
|
||||
rawIdent :: P QBE.RawIdent
|
||||
rawIdent = (fromString .: (:) <$> lead <*> trail) <?> "ident"
|
||||
where
|
||||
lead = satisfy \x -> isAlpha x || (x=='.') || (x=='_')
|
||||
trail = fmap T.unpack . takeWhileP Nothing $ \x ->
|
||||
isAlphaNum x || (x=='.') || (x=='_')
|
||||
|
||||
class ParseIdent (s :: Sigil) where
|
||||
ident :: P (QBE.Ident s)
|
||||
|
||||
rawIdentWithSigil :: Char -> P (Ident t)
|
||||
rawIdentWithSigil c = Ident <$> lexeme (char c *> rawIdent)
|
||||
|
||||
instance ParseIdent AggregateTy where ident = rawIdentWithSigil ':'
|
||||
instance ParseIdent Global where ident = rawIdentWithSigil '$'
|
||||
instance ParseIdent Temporary where ident = rawIdentWithSigil '%'
|
||||
instance ParseIdent QBE.Label where ident = rawIdentWithSigil '@'
|
||||
|
||||
const :: P QBE.Const
|
||||
const = cint <|> csingle <|> cdouble <|> cglobal <?> "const"
|
||||
where
|
||||
cint = CInt <$> lexeme (L.signed empty L.decimal) <?> "integer"
|
||||
csingle = empty <?> "single-precision float"
|
||||
cdouble = empty <?> "double-precision float"
|
||||
cglobal = CGlobal <$> ident <?> "global symbol"
|
||||
|
||||
val :: P QBE.Val
|
||||
val = vconst <|> vtemp <?> "val"
|
||||
where
|
||||
vconst = ValConst <$> Gyehoek.QBE.Parse.const
|
||||
vtemp = ValTemporary <$> ident <?> "temporary symbol"
|
||||
|
||||
assignment :: P QBE.Assignment
|
||||
assignment =
|
||||
Assignment <$> ident <*> (char '=' *> basety)
|
||||
|
||||
basety :: P QBE.BaseTy
|
||||
basety = lexeme $ char 'w' $> Word
|
||||
<|> char 'l' $> Long
|
||||
<|> char 's' $> Single
|
||||
<|> char 'd' $> Double
|
||||
|
||||
abity :: P AbiTy
|
||||
abity = AbiBaseTy <$> basety
|
||||
<|> AbiAggregateTy <$> ident
|
||||
|
||||
binaryOp :: P QBE.BinaryOp
|
||||
binaryOp = lexeme $ "add" $> Add
|
||||
<|> "sub" $> Sub
|
||||
<|> "mul" $> Mul
|
||||
<|> "div" $> Div Signed
|
||||
|
||||
comma :: P a -> P a
|
||||
comma p = symbol "," *> p
|
||||
|
||||
inst :: P QBE.Inst
|
||||
inst = try binaryOpInst <|> negInst <?> "inst"
|
||||
where
|
||||
binaryOpInst =
|
||||
BinaryOp
|
||||
<$> assignment
|
||||
<*> binaryOp
|
||||
<*> val <*> comma val
|
||||
negInst = Neg <$> assignment <*> (symbol "neg" *> val)
|
||||
|
||||
jump :: P QBE.Jump
|
||||
jump = jmp <|> jnz <|> ret <|> hlt <?> "jump"
|
||||
where
|
||||
jmp = symbol "jmp" *> (Jmp <$> ident)
|
||||
jnz = symbol "jnz" *> (Jnz <$> val <*> ident <*> comma ident)
|
||||
ret = symbol "ret" *> (Ret <$> optional val)
|
||||
hlt = empty
|
||||
|
||||
nl :: P ()
|
||||
nl = void (some (newline *> sc)) <?> "newline"
|
||||
|
||||
phi :: P QBE.Phi
|
||||
phi = empty
|
||||
|
||||
block :: P QBE.Block
|
||||
block = Block
|
||||
<$> (ident <* nl)
|
||||
<*> sepBy phi nl
|
||||
<*> sepBy inst nl
|
||||
<*> jump
|
||||
|
||||
sepByTry :: MonadParsec e s m => m a -> m sep -> m (List a)
|
||||
sepByTry p sep = do
|
||||
x <- p
|
||||
xs <- many (try $ sep *> p)
|
||||
pure (x:xs)
|
||||
|
||||
paramList :: P (Maybe (Ident Temporary), List Param, Variadic)
|
||||
paramList = label "parameter list" $ between (symbol "(") (symbol ")") do
|
||||
e <- optional env
|
||||
ps <- optional . try $ do
|
||||
commaIf (isJust e)
|
||||
sepByTry reg (symbol ",")
|
||||
v <- optional do
|
||||
commaIf (isJust e || isJust ps)
|
||||
variadic
|
||||
pure (e, fromMaybe [] ps, fromMaybe NoVariadic v)
|
||||
where
|
||||
commaIf True = void $ symbol ","
|
||||
commaIf False = pure ()
|
||||
env = symbol "env" *> ident @Temporary <?> "environment parameter"
|
||||
reg = Param <$> abity <*> ident <?> "regular parameter"
|
||||
variadic = symbol "..." $> Variadic <?> "variadic parameter"
|
||||
|
||||
funcdef :: P QBE.FuncDef
|
||||
funcdef = do
|
||||
linkages <- many linkage
|
||||
symbol "function"
|
||||
returnTy <- optional abity
|
||||
name <- ident @Global
|
||||
(env,params,variadic) <- paramList
|
||||
code <- fmap fromList . between (symbol "{" *> nl) (symbol "}") $
|
||||
sepEndBy1 block nl
|
||||
pure $ FuncDef linkages returnTy name env params variadic code
|
||||
|
||||
linkage :: P Linkage
|
||||
linkage = symbol "export" $> Export
|
||||
|
||||
-- stripped :: P a -> P a
|
||||
-- stripped p = optional nl *>
|
||||
|
||||
|
||||
|
||||
class Data a => Parser a where
|
||||
parser :: P a
|
||||
|
||||
instance Parser FuncDef where parser = funcdef
|
||||
|
||||
class ParseSeparator a where
|
||||
parseSeparator :: Proxy a -> P ()
|
||||
|
||||
instance (Parser a, ParseSeparator a) => Parser (List a) where
|
||||
parser = sepBy parser (parseSeparator @a Proxy)
|
||||
|
||||
instance ParseSeparator FuncDef where parseSeparator _ = nl
|
||||
instance ParseSeparator Block where parseSeparator _ = nl
|
||||
@@ -2,13 +2,15 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
module Gyehoek.Scheme.Syntax
|
||||
( Name
|
||||
( Name(..)
|
||||
, Prim(..)
|
||||
, Lit(..)
|
||||
, Define(..)
|
||||
, Exp(..)
|
||||
, Sexp(..)
|
||||
, primSexpIso
|
||||
)
|
||||
where
|
||||
|
||||
@@ -23,10 +25,14 @@ import Prelude hiding ((.), id)
|
||||
import Control.Category
|
||||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||
import Gyehoek.Sexp qualified
|
||||
import Gyehoek.GenSym (Gen)
|
||||
import Control.Lens (Each)
|
||||
import Data.String (IsString)
|
||||
|
||||
|
||||
type Name = Text
|
||||
newtype Name = MkName { getName :: Text }
|
||||
deriving newtype (Show, Eq, IsString, Gen)
|
||||
deriving stock (Generic)
|
||||
|
||||
data Prim e
|
||||
= PrimAdd e e
|
||||
@@ -40,6 +46,7 @@ data Prim e
|
||||
| PrimConsP e
|
||||
| PrimIntegerP e
|
||||
| PrimWrite e
|
||||
| PrimZeroP e
|
||||
| PrimNewline
|
||||
deriving (Show, Generic, Functor, Foldable, Traversable)
|
||||
|
||||
@@ -78,8 +85,14 @@ data Sexp
|
||||
|
||||
|
||||
|
||||
instance SexpIso a => SexpIso (Prim a) where
|
||||
sexpIso = match
|
||||
instance SexpIso Name where
|
||||
sexpIso = symbol >>> Sexp.partialOsi f g
|
||||
where
|
||||
f = Right . MkName
|
||||
g (MkName s) = s
|
||||
|
||||
primSexpIso :: (Text -> Text) -> Sexp.SexpGrammar a -> Sexp.SexpGrammar (Prim a)
|
||||
primSexpIso namefn a = match
|
||||
$ With (. binop "+")
|
||||
$ With (. binop "-")
|
||||
$ With (. binop "*")
|
||||
@@ -91,13 +104,16 @@ instance SexpIso a => SexpIso (Prim a) where
|
||||
$ With (. unop "cons?")
|
||||
$ With (. unop "integer?")
|
||||
$ With (. unop "write")
|
||||
$ With (. unop "zero?")
|
||||
$ With (. nullop "newline")
|
||||
$ End
|
||||
where
|
||||
primname = ("prim:" <>)
|
||||
nullop s = list $ el (sym (primname s))
|
||||
unop s = list $ el (sym (primname s)) >>> el sexpIso
|
||||
binop s = list $ el (sym (primname s)) >>> el sexpIso >>> el sexpIso
|
||||
nullop s = list $ el (sym (namefn s))
|
||||
unop s = list $ el (sym (namefn s)) >>> el a
|
||||
binop s = list $ el (sym (namefn s)) >>> el a >>> el a
|
||||
|
||||
instance SexpIso a => SexpIso (Prim a) where
|
||||
sexpIso = primSexpIso ("prim:"<>) sexpIso
|
||||
|
||||
instance SexpIso Lit where
|
||||
sexpIso = match
|
||||
@@ -121,20 +137,20 @@ instance SexpIso Define where
|
||||
$ With (. defun)
|
||||
$ End
|
||||
where
|
||||
defconst = list $ el (sym "define") >>> el symbol >>> el sexpIso
|
||||
defconst = list $ el (sym "define") >>> el sexpIso >>> el sexpIso
|
||||
defun = list $ el (sym "define") >>> el args >>> rest sexpIso
|
||||
args = list $ el symbol >>> rest symbol
|
||||
args = list $ el sexpIso >>> rest sexpIso
|
||||
|
||||
instance SexpIso Exp where
|
||||
sexpIso = match
|
||||
$ With (. Gyehoek.Sexp.let_ symbol sexpIso sexpIso)
|
||||
$ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso)
|
||||
$ With (. sexpIso)
|
||||
$ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
|
||||
$ With (. sexpIso)
|
||||
$ With (. if_)
|
||||
$ With (. sexpIso)
|
||||
$ With (. lam)
|
||||
$ With (. symbol)
|
||||
$ With (. sexpIso)
|
||||
$ With (\app -> app . list (el sexpIso >>> rest sexpIso))
|
||||
$ End
|
||||
where
|
||||
|
||||
+38
-6
@@ -12,11 +12,18 @@ module Gyehoek.Sexp
|
||||
, parseSexps
|
||||
, prefixSugar
|
||||
, todo
|
||||
, isoIso
|
||||
, encodeWith
|
||||
, decodeWith
|
||||
, kappa
|
||||
, lambda
|
||||
, kappaKeyword
|
||||
, lambdaKeyword
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Language.SexpGrammar as Sexp hiding (List, encode, decode, iso)
|
||||
import Language.SexpGrammar as Sexp hiding (List, encode, decode, encodeWith, decodeWith, iso)
|
||||
import Language.SexpGrammar qualified as Sexp
|
||||
import Language.Sexp qualified as S
|
||||
import Language.SexpGrammar.Generic
|
||||
@@ -44,10 +51,16 @@ sexp = iso
|
||||
(either error id . decode)
|
||||
|
||||
encode :: SexpIso a => a -> Either String Text
|
||||
encode = (_Right %~ decodeUtf8 . view strict) . Sexp.encode
|
||||
encode = encodeWith sexpIso
|
||||
|
||||
decode :: SexpIso a => Text -> Either String a
|
||||
decode = Sexp.decode . view lazy . encodeUtf8
|
||||
decode = decodeWith sexpIso
|
||||
|
||||
encodeWith :: SexpGrammar a -> a -> Either String Text
|
||||
encodeWith g = (_Right %~ decodeUtf8 . view strict) . Sexp.encodeWith g
|
||||
|
||||
decodeWith :: SexpGrammar a -> Text -> Either String a
|
||||
decodeWith g = Sexp.decodeWith g "FILE" . view lazy . encodeUtf8
|
||||
|
||||
parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
|
||||
parseSexps f = marshal . SexpLoc.parseSexps f . view lazy . encodeUtf8
|
||||
@@ -64,11 +77,12 @@ nonempty a =
|
||||
IG.flipped nonEmptyGrammar
|
||||
|
||||
let_
|
||||
:: (forall t. Grammar Position (Sexp :- t) (a :- t))
|
||||
:: Text
|
||||
-> (forall t. Grammar Position (Sexp :- t) (a :- t))
|
||||
-> (forall t. Grammar Position (Sexp :- t) (b :- t))
|
||||
-> Grammar Position (Sexp :- (NonEmpty (a, b) :- t1)) t2
|
||||
-> Grammar Position (Sexp :- t1) t2
|
||||
let_ name rhs e = list (el (sym "let") >>> el bindings >>> el e)
|
||||
let_ kw name rhs e = list (el (sym kw) >>> el bindings >>> el e)
|
||||
where
|
||||
-- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
|
||||
bindings = nonempty binding
|
||||
@@ -101,11 +115,29 @@ todo = (IGB.Flip $ IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g
|
||||
f _ = Left $ unexpected "todo"
|
||||
g _ = Left $ unexpected "todo"
|
||||
|
||||
kappa
|
||||
:: (forall t. Grammar Position (Sexp :- t) (a :- t))
|
||||
-> Grammar Position (Sexp :- List a :- t1) t2
|
||||
-> Grammar Position (Sexp :- t1) t2
|
||||
kappa name e = list $
|
||||
el kappaKeyword
|
||||
>>> el (list $ rest name)
|
||||
>>> el e
|
||||
|
||||
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 lambdaKeyword
|
||||
>>> el (list $ rest name)
|
||||
>>> el e
|
||||
|
||||
isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
|
||||
isoIso l = Sexp.iso (view l) (review l)
|
||||
|
||||
kappaKeyword :: Grammar Position (Sexp :- t) t
|
||||
kappaKeyword = coproduct [ sym "κ", sym "kappa" ]
|
||||
|
||||
lambdaKeyword :: Grammar Position (Sexp :- t) t
|
||||
lambdaKeyword = coproduct [ sym "λ", sym "lambda" ]
|
||||
|
||||
+1
-66
@@ -5,13 +5,10 @@ module Main
|
||||
(main)
|
||||
where
|
||||
|
||||
import qualified Gyehoek.ANF.Syntax as ANF
|
||||
import Gyehoek.QBE (render)
|
||||
import Gyehoek.Options
|
||||
import qualified Data.Text.IO as TIO
|
||||
import Data.Text (Text)
|
||||
import Prelude hiding (readFile, (.),id)
|
||||
import Control.Category
|
||||
import Options.Applicative
|
||||
import Control.Lens
|
||||
import Data.Generics.Labels
|
||||
@@ -27,7 +24,6 @@ import Data.Text.Lens
|
||||
import Data.List (List)
|
||||
import qualified Gyehoek.Scheme.Syntax as Scm
|
||||
import Effectful.Exception
|
||||
import qualified Gyehoek.QBE as QBE
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import System.IO (Handle)
|
||||
@@ -57,68 +53,7 @@ readFile f = FS.withFile f FS.ReadMode hGetContents
|
||||
readScm :: FileSystem :> es => FilePath -> Eff es (List Scm.Exp)
|
||||
readScm f = (Sexp.parseSexps f <$> readFile f) >>= either error pure
|
||||
|
||||
toANF
|
||||
:: (GenSym :> es, FileSystem :> es)
|
||||
=> FilePath -> List Scm.Exp -> Eff es (List ANF.Exp)
|
||||
toANF f exps = do
|
||||
anfs <- traverse ANF.toANF exps
|
||||
case traverse Sexp.encode anfs of
|
||||
Left e -> hPutStr FS.stderr (view packed e)
|
||||
Right ss -> do
|
||||
let anf_file = f -<.> "anf"
|
||||
FS.withFile anf_file FS.WriteMode \h_anf -> do
|
||||
hPutStr h_anf ";;; -*- mode:scheme -*-\n\n"
|
||||
hPutStr h_anf $ foldr (\x y -> x <> "\n\n" <> y) "" ss
|
||||
hPutStrLn FS.stderr $ "wrote " <> T.pack anf_file
|
||||
pure anfs
|
||||
|
||||
toQBE
|
||||
:: (GenSym :> es, FileSystem :> es, Traversable t)
|
||||
=> FilePath -> t ANF.Exp -> Eff es QBE.Program
|
||||
toQBE f anfs = do
|
||||
p <- ANF.lowerProgram anfs
|
||||
let qbe_file = f -<.> "ssa"
|
||||
FS.withFile qbe_file FS.WriteMode \h -> do
|
||||
hPutStr h . render $ p
|
||||
hPutStrLn FS.stderr $ "wrote " <> T.pack qbe_file
|
||||
pure p
|
||||
|
||||
callQBE
|
||||
:: (GenSym :> es, FileSystem :> es, IOE :> es)
|
||||
=> FilePath -> Eff es FilePath
|
||||
callQBE f = do
|
||||
let asm_file = f -<.> "s"
|
||||
qbe_file = f -<.> "ssa"
|
||||
C.StdoutUntrimmed stdout <-
|
||||
C.run $ C.cmd "qbe" & C.addArgs [qbe_file]
|
||||
FS.withFile asm_file FS.WriteMode \h -> do
|
||||
hPutStr h stdout
|
||||
hPutStrLn FS.stderr $ "wrote " <> T.pack asm_file
|
||||
pure asm_file
|
||||
|
||||
callGCC
|
||||
:: (GenSym :> es, FileSystem :> es, IOE :> es)
|
||||
=> FilePath -> List String -> Eff es FilePath
|
||||
callGCC f args = do
|
||||
let asm_file = f -<.> "s"
|
||||
exe = f -<.> "out"
|
||||
C.StdoutTrimmed (T.words -> flags) <-
|
||||
C.run $ C.cmd "pkg-config"
|
||||
& C.addArgs @String ["--cflags", "--libs", "bdw-gc"]
|
||||
C.run_ $ C.cmd "cc"
|
||||
& C.addArgs flags
|
||||
& C.addArgs ["-o", exe, asm_file]
|
||||
& C.addArgs args
|
||||
hPutStrLn FS.stderr $ "wrote " <> T.pack exe
|
||||
pure exe
|
||||
|
||||
driver
|
||||
:: (GenSym :> es, FileSystem :> es, IOE :> es)
|
||||
=> Options -> Eff es ()
|
||||
driver = runGenSym . traverseOf_ (#sourceFiles . folded) \f -> do
|
||||
exps <- readScm f
|
||||
anfs <- toANF f exps
|
||||
qbe <- toQBE f anfs
|
||||
callQBE f
|
||||
callGCC f ["../runtime/target/debug/libgyehoek.a"]
|
||||
pure ()
|
||||
driver = _
|
||||
|
||||
Reference in New Issue
Block a user