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 = _
|
||||
|
||||
Binary file not shown.
@@ -1,4 +0,0 @@
|
||||
;;; -*- mode:scheme -*-
|
||||
|
||||
(let ((x0 (prim:write "wawa"))) x0)
|
||||
|
||||
@@ -1,23 +0,0 @@
|
||||
.data
|
||||
.balign 8
|
||||
.1:
|
||||
.ascii "wawa"
|
||||
/* end data */
|
||||
|
||||
.text
|
||||
.globl main
|
||||
main:
|
||||
pushq %rbp
|
||||
movq %rsp, %rbp
|
||||
movl $4, %esi
|
||||
leaq .1(%rip), %rdi
|
||||
callq scm_from_utf8_string
|
||||
movq %rax, %rdi
|
||||
callq scm_write
|
||||
leave
|
||||
ret
|
||||
.type main, @function
|
||||
.size main, .-main
|
||||
/* end function main */
|
||||
|
||||
.section .note.GNU-stack,"",@progbits
|
||||
@@ -1 +0,0 @@
|
||||
(prim:write "wawa")
|
||||
@@ -1,10 +0,0 @@
|
||||
|
||||
data $.1 =
|
||||
{b "wawa"}
|
||||
export
|
||||
function w $main () {
|
||||
@start
|
||||
%.2 =l call $scm_from_utf8_string (l $.1, l 4)
|
||||
%x0 =l call $scm_write (l %.2)
|
||||
ret %x0
|
||||
}
|
||||
Binary file not shown.
@@ -1,4 +0,0 @@
|
||||
;;; -*- mode:scheme -*-
|
||||
|
||||
(let ((x0 (prim:cons 4 5)) (x1 (prim:write x0))) x1)
|
||||
|
||||
@@ -1,18 +0,0 @@
|
||||
.text
|
||||
.globl main
|
||||
main:
|
||||
pushq %rbp
|
||||
movq %rsp, %rbp
|
||||
movl $16, %edi
|
||||
callq GC_malloc
|
||||
movq %rax, %rdi
|
||||
movq $18, (%rdi)
|
||||
movq $22, 8(%rdi)
|
||||
callq scm_write
|
||||
leave
|
||||
ret
|
||||
.type main, @function
|
||||
.size main, .-main
|
||||
/* end function main */
|
||||
|
||||
.section .note.GNU-stack,"",@progbits
|
||||
@@ -1 +0,0 @@
|
||||
(prim:write (prim:cons 4 5))
|
||||
@@ -1,10 +0,0 @@
|
||||
export
|
||||
function w $main () {
|
||||
@start
|
||||
%x0 =l call $GC_malloc (l 16)
|
||||
%.2 =l add %x0, 8
|
||||
storel 18, %x0
|
||||
storel 22, %.2
|
||||
%x1 =l call $scm_write (l %x0)
|
||||
ret %x1
|
||||
}
|
||||
@@ -1,15 +0,0 @@
|
||||
(define (adder x)
|
||||
(lambda (y)
|
||||
(+ x y)))
|
||||
|
||||
((adder 3) 4)
|
||||
|
||||
|
||||
|
||||
(define (adder x)
|
||||
(list (lambda (self y)
|
||||
(+ (nth self 1) y))
|
||||
x))
|
||||
|
||||
(let ((closure (adder 3)))
|
||||
((nth closure 0) closure 4))
|
||||
@@ -1,70 +0,0 @@
|
||||
.text
|
||||
zerop:
|
||||
pushq %rbp
|
||||
movq %rsp, %rbp
|
||||
cmpl $0, %edi
|
||||
jnz .Lbb2
|
||||
movl $1, %eax
|
||||
jmp .Lbb3
|
||||
.Lbb2:
|
||||
movl $0, %eax
|
||||
.Lbb3:
|
||||
leave
|
||||
ret
|
||||
.type zerop, @function
|
||||
.size zerop, .-zerop
|
||||
/* end function zerop */
|
||||
|
||||
.text
|
||||
factorial:
|
||||
pushq %rbp
|
||||
movq %rsp, %rbp
|
||||
subq $8, %rsp
|
||||
pushq %rbx
|
||||
movq %rdi, %rbx
|
||||
callq zerop
|
||||
movq %rbx, %rdi
|
||||
cmpl $0, %eax
|
||||
jnz .Lbb6
|
||||
movq %rdi, %rbx
|
||||
subq $1, %rdi
|
||||
callq factorial
|
||||
movq %rbx, %rdi
|
||||
imulq %rdi, %rax
|
||||
jmp .Lbb7
|
||||
.Lbb6:
|
||||
movl $1, %eax
|
||||
.Lbb7:
|
||||
popq %rbx
|
||||
leave
|
||||
ret
|
||||
.type factorial, @function
|
||||
.size factorial, .-factorial
|
||||
/* end function factorial */
|
||||
|
||||
.data
|
||||
.balign 8
|
||||
fstr:
|
||||
.ascii "fac 3 = %d\n"
|
||||
.byte 0
|
||||
/* end data */
|
||||
|
||||
.text
|
||||
.globl main
|
||||
main:
|
||||
pushq %rbp
|
||||
movq %rsp, %rbp
|
||||
movl $3, %edi
|
||||
callq factorial
|
||||
movq %rax, %rsi
|
||||
leaq fstr(%rip), %rdi
|
||||
movl $0, %eax
|
||||
callq printf
|
||||
movl $0, %eax
|
||||
leave
|
||||
ret
|
||||
.type main, @function
|
||||
.size main, .-main
|
||||
/* end function main */
|
||||
|
||||
.section .note.GNU-stack,"",@progbits
|
||||
@@ -1,16 +0,0 @@
|
||||
(define (factorial n)
|
||||
(if (zero? n)
|
||||
1
|
||||
(* n (factorial (- n 1)))))
|
||||
|
||||
|
||||
;;; ANF
|
||||
|
||||
(define (factorial n)
|
||||
(let ((r₁ (zero? n)))
|
||||
(if r₁
|
||||
1
|
||||
(let ((r₂ (- n 1))
|
||||
(r₃ (factorial r₂))
|
||||
(r₄ (* n r₃)))
|
||||
r₄))))
|
||||
@@ -1,30 +0,0 @@
|
||||
function l $zerop (l %n) {
|
||||
@start
|
||||
jnz %n, @b1, @b2
|
||||
@b1
|
||||
ret 0
|
||||
@b2
|
||||
ret 1
|
||||
}
|
||||
|
||||
function l $factorial (l %n) {
|
||||
@start
|
||||
%r1 =l call $zerop (l %n)
|
||||
jnz %r1, @b1, @b2
|
||||
@b1
|
||||
ret 1
|
||||
@b2
|
||||
%r2 =l sub %n, 1
|
||||
%r3 =l call $factorial (l %r2)
|
||||
%r4 =l mul %n, %r3
|
||||
ret %r4
|
||||
}
|
||||
|
||||
data $fstr = { b "fac 3 = %d\n", b 0 }
|
||||
|
||||
export function w $main () {
|
||||
@start
|
||||
%r =l call $factorial (l 3)
|
||||
call $printf (l $fstr, ..., l %r)
|
||||
ret 0
|
||||
}
|
||||
Binary file not shown.
@@ -1,4 +0,0 @@
|
||||
;;; -*- mode:scheme -*-
|
||||
|
||||
(let ((x0 (prim:write "안녕하세요"))) x0)
|
||||
|
||||
@@ -1,23 +0,0 @@
|
||||
.data
|
||||
.balign 8
|
||||
.1:
|
||||
.ascii "\354\225\210\353\205\225\355\225\230\354\204\270\354\232\224"
|
||||
/* end data */
|
||||
|
||||
.text
|
||||
.globl main
|
||||
main:
|
||||
pushq %rbp
|
||||
movq %rsp, %rbp
|
||||
movl $15, %esi
|
||||
leaq .1(%rip), %rdi
|
||||
callq scm_from_utf8_string
|
||||
movq %rax, %rdi
|
||||
callq scm_write
|
||||
leave
|
||||
ret
|
||||
.type main, @function
|
||||
.size main, .-main
|
||||
/* end function main */
|
||||
|
||||
.section .note.GNU-stack,"",@progbits
|
||||
@@ -1 +0,0 @@
|
||||
(prim:write "안녕하세요")
|
||||
@@ -1,10 +0,0 @@
|
||||
|
||||
data $.1 =
|
||||
{b "\354\225\210\353\205\225\355\225\230\354\204\270\354\232\224"}
|
||||
export
|
||||
function w $main () {
|
||||
@start
|
||||
%.2 =l call $scm_from_utf8_string (l $.1, l 15)
|
||||
%x0 =l call $scm_write (l %.2)
|
||||
ret %x0
|
||||
}
|
||||
@@ -18,19 +18,13 @@
|
||||
|
||||
overlays = [
|
||||
haskellNix.overlay
|
||||
(final: prev: {
|
||||
inherit (sydpkgs.packages.${final.stdenv.hostPlatform.system})
|
||||
bdwgc;
|
||||
})
|
||||
(final: prev: {
|
||||
gyehoek = final.haskell-nix.project' {
|
||||
src = ./.;
|
||||
compiler-nix-name = "ghc912";
|
||||
shell = {
|
||||
withHoogle = true;
|
||||
inputsFrom = [
|
||||
self.packages.${final.stdenv.hostPlatform.system}.runtime
|
||||
];
|
||||
inputsFrom = [];
|
||||
tools = {
|
||||
cabal = {};
|
||||
haskell-language-server = {};
|
||||
@@ -39,13 +33,13 @@
|
||||
gcc
|
||||
qbe
|
||||
haskellPackages.cabal-fmt
|
||||
bdwgc
|
||||
pkg-config
|
||||
guile
|
||||
clang-tools # clangd
|
||||
gdb
|
||||
gdbgui
|
||||
rust-analyzer
|
||||
self.packages.${final.stdenv.hostPlatform.system}.shake
|
||||
final.wabt
|
||||
final.nodejs
|
||||
final.wasmtime
|
||||
final.wasm-tools
|
||||
final.wac-cli
|
||||
final.guile
|
||||
];
|
||||
};
|
||||
};
|
||||
@@ -76,8 +70,7 @@
|
||||
packages = each-system ({ pkgs, system, ... }:
|
||||
hf.packages.${system} // {
|
||||
default = hf.packages.${system}."gyehoek:exe:gyehoek";
|
||||
runtime = pkgs.callPackage ./runtime {};
|
||||
inherit (pkgs) bdwgc;
|
||||
shake = pkgs.callPackage ./shake-wrapper.nix {};
|
||||
});
|
||||
|
||||
devShells = each-system
|
||||
|
||||
+5
-8
@@ -20,8 +20,7 @@ common ghcstuffs-dev
|
||||
common ghcstuffs
|
||||
ghc-options:
|
||||
-Wall -fdefer-type-errors -fno-show-valid-hole-fits
|
||||
-fdefer-out-of-scope-variables -fplugin=Effectful.Plugin
|
||||
-threaded
|
||||
-fdefer-out-of-scope-variables -fplugin=Effectful.Plugin -threaded
|
||||
|
||||
default-extensions:
|
||||
BlockArguments
|
||||
@@ -36,17 +35,17 @@ executable gyehoek
|
||||
|
||||
-- cabal-fmt: expand app -Main
|
||||
other-modules:
|
||||
Gyehoek.ANF.Syntax
|
||||
Gyehoek.CPS.Convert
|
||||
Gyehoek.CPS.Syntax
|
||||
Gyehoek.GenSym
|
||||
Gyehoek.Options
|
||||
Gyehoek.QBE
|
||||
Gyehoek.QBE.Parse
|
||||
Gyehoek.Scheme.Syntax
|
||||
Gyehoek.Sexp
|
||||
|
||||
build-depends:
|
||||
, base ^>=4.21.2.0
|
||||
, containers
|
||||
, cradle
|
||||
, effectful
|
||||
, effectful-core
|
||||
, effectful-plugin
|
||||
@@ -59,15 +58,13 @@ executable gyehoek
|
||||
, optparse-applicative
|
||||
, prettyprinter
|
||||
, process
|
||||
, qbe
|
||||
, recursion-schemes
|
||||
, sexp-grammar
|
||||
, template-haskell
|
||||
, text
|
||||
, text-short
|
||||
, unordered-containers
|
||||
, vector
|
||||
, text-short
|
||||
, cradle
|
||||
|
||||
hs-source-dirs: app
|
||||
default-language: GHC2024
|
||||
|
||||
@@ -1,4 +0,0 @@
|
||||
*.anf
|
||||
*.s
|
||||
*.ssa
|
||||
*.out
|
||||
@@ -1 +0,0 @@
|
||||
(prim:write (prim:car (prim:cons 123 456)))
|
||||
@@ -1 +0,0 @@
|
||||
(prim:write (prim:cdr (prim:cons 123 456)))
|
||||
@@ -1 +0,0 @@
|
||||
(prim:write "abc")
|
||||
@@ -1,3 +0,0 @@
|
||||
(begin (prim:write 'abc)
|
||||
(prim:newline)
|
||||
(prim:write 'abc))
|
||||
@@ -1 +0,0 @@
|
||||
(prim:write (prim:cons 4 2))
|
||||
@@ -0,0 +1,2 @@
|
||||
#!/usr/bin/env sh
|
||||
cabal repl --repl-options "-interactive-print=Text.Pretty.Simple.pPrint" --build-depends pretty-simple
|
||||
@@ -1 +0,0 @@
|
||||
target
|
||||
Generated
-112
@@ -1,112 +0,0 @@
|
||||
# This file is automatically @generated by Cargo.
|
||||
# It is not intended for manual editing.
|
||||
version = 4
|
||||
|
||||
[[package]]
|
||||
name = "allocator-api2"
|
||||
version = "0.2.21"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "683d7910e743518b0e34f1186f92494becacb047c7b6bf616c96772180fef923"
|
||||
|
||||
[[package]]
|
||||
name = "bdwgc-alloc"
|
||||
version = "0.6.13"
|
||||
source = "git+https://git.deertopia.net/msyds/bdwgc-rust.git#ccc273a168f3ddfee0a2ae170f561f19da8c274a"
|
||||
dependencies = [
|
||||
"cmake",
|
||||
"libc",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "cc"
|
||||
version = "1.2.62"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "a1dce859f0832a7d088c4f1119888ab94ef4b5d6795d1ce05afb7fe159d79f98"
|
||||
dependencies = [
|
||||
"find-msvc-tools",
|
||||
"shlex",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "cmake"
|
||||
version = "0.1.58"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "c0f78a02292a74a88ac736019ab962ece0bc380e3f977bf72e376c5d78ff0678"
|
||||
dependencies = [
|
||||
"cc",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "const_panic"
|
||||
version = "0.2.15"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "e262cdaac42494e3ae34c43969f9cdeb7da178bdb4b66fa6a1ea2edb4c8ae652"
|
||||
dependencies = [
|
||||
"typewit",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "equivalent"
|
||||
version = "1.0.2"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "877a4ace8713b0bcf2a4e7eec82529c029f1d0619886d18145fea96c3ffe5c0f"
|
||||
|
||||
[[package]]
|
||||
name = "find-msvc-tools"
|
||||
version = "0.1.9"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "5baebc0774151f905a1a2cc41989300b1e6fbb29aff0ceffa1064fdd3088d582"
|
||||
|
||||
[[package]]
|
||||
name = "foldhash"
|
||||
version = "0.1.5"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "d9c4f5dac5e15c24eb999c26181a6ca40b39fe946cbe4c263c7209467bc83af2"
|
||||
|
||||
[[package]]
|
||||
name = "gyehoek"
|
||||
version = "0.1.0"
|
||||
dependencies = [
|
||||
"bdwgc-alloc",
|
||||
"const_panic",
|
||||
"internment",
|
||||
"libc",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "hashbrown"
|
||||
version = "0.15.5"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "9229cfe53dfd69f0609a49f65461bd93001ea1ef889cd5529dd176593f5338a1"
|
||||
dependencies = [
|
||||
"allocator-api2",
|
||||
"equivalent",
|
||||
"foldhash",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "internment"
|
||||
version = "0.8.6"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "636d4b0f6a39fd684effe2a73f5310df16a3fa7954c26d36833e98f44d1977a2"
|
||||
dependencies = [
|
||||
"hashbrown",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "libc"
|
||||
version = "0.2.186"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "68ab91017fe16c622486840e4c83c9a37afeff978bd239b5293d61ece587de66"
|
||||
|
||||
[[package]]
|
||||
name = "shlex"
|
||||
version = "1.3.0"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "0fda2ff0d084019ba4d7c6f371c95d8fd75ce3524c3cb8fb653a3023f6323e64"
|
||||
|
||||
[[package]]
|
||||
name = "typewit"
|
||||
version = "1.15.2"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "214ca0b2191785cbc06209b9ca1861e048e39b5ba33574b3cedd58363d5bb5f6"
|
||||
@@ -1,20 +0,0 @@
|
||||
[package]
|
||||
name = "gyehoek"
|
||||
version = "0.1.0"
|
||||
edition = "2024"
|
||||
|
||||
[lib]
|
||||
name = "gyehoek"
|
||||
# crate-type = ["cdylib"]
|
||||
crate-type = ["staticlib"]
|
||||
|
||||
[dependencies]
|
||||
bdwgc-alloc = { version = "0.6.13"
|
||||
, default-features = false
|
||||
, features = ["cmake"] }
|
||||
const_panic = "0.2.15"
|
||||
internment = "0.8.6"
|
||||
libc = "0.2.186"
|
||||
|
||||
[patch.crates-io]
|
||||
bdwgc-alloc = { git = 'https://git.deertopia.net/msyds/bdwgc-rust.git' }
|
||||
@@ -1,24 +0,0 @@
|
||||
{ lib
|
||||
, rustPlatform
|
||||
, bdwgc
|
||||
, cmake
|
||||
, pkg-config
|
||||
}:
|
||||
|
||||
rustPlatform.buildRustPackage (finalAttrs: {
|
||||
pname = "gyehoek-runtime";
|
||||
version = "0.0.1";
|
||||
src = ./.;
|
||||
cargoLock = {
|
||||
lockFile = ./Cargo.lock;
|
||||
outputHashes."bdwgc-alloc-0.6.13" =
|
||||
"sha256-8/EZ9FThVVsdkwB+OIlNHQJxIr6DPf701Mlfq5U1j4E=";
|
||||
};
|
||||
nativeBuildInputs = [
|
||||
pkg-config
|
||||
cmake
|
||||
];
|
||||
buildInputs = [
|
||||
bdwgc
|
||||
];
|
||||
})
|
||||
@@ -1,24 +0,0 @@
|
||||
use std::slice;
|
||||
|
||||
use crate::scm::scm_bits;
|
||||
use crate::scm;
|
||||
|
||||
#[unsafe(no_mangle)]
|
||||
pub extern "C" fn scm_from_utf8_string (
|
||||
ptr : *const u8,
|
||||
len : usize
|
||||
) -> scm_bits {
|
||||
let bytes = unsafe { slice::from_raw_parts (ptr, len) };
|
||||
scm::make_string (str::from_utf8 (bytes).unwrap ())
|
||||
}
|
||||
|
||||
// #[unsafe(no_mangle)]
|
||||
// pub extern "C" fn scm_hash (ptr : *const u8, len : usize) -> u64 {
|
||||
// let bytes = unsafe { slice::from_raw_parts (ptr, len) };
|
||||
// crate::obarray::hash (str::from_utf8 (bytes).unwrap ())
|
||||
// }
|
||||
|
||||
#[unsafe(no_mangle)]
|
||||
pub extern "C" fn scm_string_to_symbol (str : scm_bits) -> scm_bits {
|
||||
crate::scm::string_to_symbol (str)
|
||||
}
|
||||
@@ -1,34 +0,0 @@
|
||||
use libc::{c_void, size_t};
|
||||
|
||||
#[link(name = "gc", kind = "static")]
|
||||
unsafe extern "C" {
|
||||
// fn GC_allow_register_threads ();
|
||||
// fn GC_alloc_lock ();
|
||||
// fn GC_alloc_unlock ();
|
||||
// fn GC_free (ptr: *mut c_void);
|
||||
// fn GC_get_stack_base (stack_base: *mut GcStackBase) -> c_int;
|
||||
// fn GC_init ();
|
||||
fn GC_malloc (size: size_t) -> *mut c_void;
|
||||
fn GC_realloc (ptr: *mut c_void, size: size_t) -> *mut c_void;
|
||||
// fn GC_register_my_thread
|
||||
// (stack_base: *const GcStackBase) -> c_int;
|
||||
// fn GC_set_stackbottom
|
||||
// (thread: *const c_void, stack_bottom: *const GcStackBase);
|
||||
// fn GC_unregister_my_thread ();
|
||||
// fn GC_gcollect ();
|
||||
// fn GC_register_finalizer (
|
||||
// ptr: *const c_void,
|
||||
// finalizer: extern "C" fn (*mut c_void, *mut c_void),
|
||||
// client_data: *const c_void,
|
||||
// opt_old_finalizer: *const c_void,
|
||||
// opt_old_client_data: *const c_void,
|
||||
// ) -> *mut c_void;
|
||||
}
|
||||
|
||||
pub unsafe fn malloc<T> (size: usize) -> *mut T {
|
||||
unsafe { GC_malloc (size) as *mut T }
|
||||
}
|
||||
|
||||
pub unsafe fn realloc<T> (ptr: *mut T, size: usize) -> *mut T {
|
||||
unsafe { GC_realloc (ptr as *mut c_void, size) as *mut T }
|
||||
}
|
||||
@@ -1,9 +0,0 @@
|
||||
#![allow(non_upper_case_globals)]
|
||||
#![allow(non_camel_case_types)]
|
||||
|
||||
mod gc;
|
||||
mod scm;
|
||||
mod primitives;
|
||||
// mod obarray;
|
||||
mod capi;
|
||||
mod var;
|
||||
@@ -1,31 +0,0 @@
|
||||
use crate::scm;
|
||||
use crate::scm::{scm_bits, SCM};
|
||||
use std::io::{stdout, Write};
|
||||
|
||||
#[unsafe(no_mangle)]
|
||||
pub extern "C" fn scm_write (x: scm_bits) -> scm_bits {
|
||||
match scm::unpack (x) {
|
||||
SCM::SmallInt (n) => print! ("{n}"),
|
||||
SCM::Cons (car, cdr) => {
|
||||
print! ("(");
|
||||
scm_write (car);
|
||||
print! (" . ");
|
||||
scm_write (cdr);
|
||||
print! (")");
|
||||
},
|
||||
SCM::String (s) => print! ("\"{s}\""),
|
||||
SCM::Nil => print! ("()"),
|
||||
SCM::False => print! ("#f"),
|
||||
SCM::True => print! ("#t"),
|
||||
SCM::Symbol (_s) => print! ("{x:#016x}"),
|
||||
// SCM::Symbol (s) => print! ("{s}"),
|
||||
};
|
||||
let _ = stdout ().flush ();
|
||||
return 0;
|
||||
}
|
||||
|
||||
#[unsafe(no_mangle)]
|
||||
pub extern "C" fn scm_newline () -> scm_bits {
|
||||
print! ("\n");
|
||||
0
|
||||
}
|
||||
@@ -1,203 +0,0 @@
|
||||
#![allow(non_upper_case_globals)]
|
||||
#![allow(non_camel_case_types)]
|
||||
|
||||
use std::slice;
|
||||
|
||||
use internment::Intern;
|
||||
|
||||
use crate::gc;
|
||||
|
||||
pub type scm_bits = u64;
|
||||
|
||||
pub const tc2_int : u64 = 2;
|
||||
pub const tc3_cons : u64 = 0;
|
||||
pub const tc7_obarray : u64 = 0x55;
|
||||
pub const tc7_symbol : u64 = 0x05;
|
||||
pub const tc7_string : u64 = 0x15;
|
||||
|
||||
// pub const scm_false : SCM = pack (0b00100);
|
||||
// pub const scm_true : SCM = pack (0b01100);
|
||||
// pub const scm_eol : SCM = pack (0b10100);
|
||||
|
||||
pub enum SCM {
|
||||
SmallInt (i64),
|
||||
Cons (scm_bits, scm_bits),
|
||||
String (String),
|
||||
Symbol (String),
|
||||
Nil,
|
||||
False,
|
||||
True,
|
||||
}
|
||||
|
||||
// #[inline(always)]
|
||||
// pub fn pack (x : SCM) -> scm_bits {
|
||||
// }
|
||||
|
||||
#[inline(always)]
|
||||
pub fn unpack_string (x : scm_bits) -> String {
|
||||
let len = unsafe { cell_word (x, 1) };
|
||||
let str_beginning = (x as *const scm_bits).wrapping_add (2) as *const u8;
|
||||
let slice = unsafe {
|
||||
str::from_utf8 (
|
||||
slice::from_raw_parts (
|
||||
str_beginning,
|
||||
len.try_into ().unwrap ()
|
||||
)
|
||||
).unwrap ()
|
||||
};
|
||||
String::from (slice)
|
||||
}
|
||||
|
||||
// super duper important for this to inline. we want to eliminate the
|
||||
// SCM type at runtime as much as possible. the hope is for inlining
|
||||
// to lead to a case-of-case–esque transformation.
|
||||
#[inline(always)]
|
||||
pub fn unpack (x : scm_bits) -> SCM {
|
||||
if is_small_int (x) {
|
||||
SCM::SmallInt ((x >> 2) as i64)
|
||||
} else if is_cons (x) {
|
||||
// `car` x and `cdr` x are safe iff `is_cons` x.
|
||||
unsafe { SCM::Cons (car (x), cdr (x)) }
|
||||
} else if is_string (x) {
|
||||
SCM::String (unpack_string (x))
|
||||
} else if is_symbol (x) {
|
||||
let s = unpack_string (unsafe { cell_word (x, 1) });
|
||||
SCM::Symbol (s)
|
||||
} else {
|
||||
// concat_panic! ("don't know how to unpack: ", x)
|
||||
panic! ("don't know how to unpack {x:#016x}")
|
||||
}
|
||||
}
|
||||
|
||||
const fn is_small_int (x: scm_bits) -> bool {
|
||||
3 & x == tc2_int
|
||||
}
|
||||
|
||||
const fn is_immediate (x: scm_bits) -> bool {
|
||||
6 & x != 0
|
||||
}
|
||||
|
||||
fn is_string (x: scm_bits) -> bool {
|
||||
has_tc7 (x, tc7_string)
|
||||
}
|
||||
|
||||
fn is_cons (x: scm_bits) -> bool {
|
||||
// safety of `cell_type` is mutually exclusive with
|
||||
// `is_immediate`, so this is okay.
|
||||
unsafe {
|
||||
! is_immediate (x) && (1 & cell_type (x)) == 0
|
||||
}
|
||||
}
|
||||
|
||||
fn is_symbol (x : scm_bits) -> bool {
|
||||
has_tc7 (x, tc7_symbol)
|
||||
}
|
||||
|
||||
fn has_tc7 (x: scm_bits, tc7: u64) -> bool {
|
||||
unsafe {
|
||||
! is_immediate (x) && (0x7f & cell_type (x)) == tc7
|
||||
}
|
||||
}
|
||||
|
||||
unsafe fn cell_type (x: scm_bits) -> scm_bits {
|
||||
unsafe { cell_word (x, 0) }
|
||||
}
|
||||
|
||||
unsafe fn cell_word (x: scm_bits, n: usize) -> scm_bits {
|
||||
let p = x as *mut scm_bits;
|
||||
unsafe {
|
||||
*(p.wrapping_add (n))
|
||||
}
|
||||
}
|
||||
|
||||
unsafe fn car (x: scm_bits) -> scm_bits {
|
||||
unsafe { cell_word (x, 0) }
|
||||
}
|
||||
|
||||
unsafe fn cdr (x: scm_bits) -> scm_bits {
|
||||
unsafe { cell_word (x, 1) }
|
||||
}
|
||||
|
||||
pub unsafe fn words (tag : scm_bits, n : usize) -> *mut scm_bits {
|
||||
let r = unsafe { gc::malloc (n * size_of::<scm_bits> ()) };
|
||||
unsafe { *r = tag };
|
||||
return r
|
||||
}
|
||||
|
||||
pub fn pack_ptr (obj : *const scm_bits) -> scm_bits {
|
||||
obj as scm_bits
|
||||
}
|
||||
|
||||
pub unsafe fn set_word (obj : *mut scm_bits, ix : usize, val : scm_bits) {
|
||||
let x = obj.wrapping_add (ix);
|
||||
unsafe { *x = val; }
|
||||
}
|
||||
|
||||
|
||||
|
||||
pub fn make_string_from_raw_parts (
|
||||
ptr : *const u8,
|
||||
len : usize
|
||||
) -> scm_bits {
|
||||
let bytes = unsafe { slice::from_raw_parts (ptr, len) };
|
||||
make_string (str::from_utf8 (bytes).unwrap ())
|
||||
}
|
||||
|
||||
pub fn make_string (s : &str) -> scm_bits {
|
||||
let len = s.len ();
|
||||
let size_of_tag_and_len = 2 * size_of::<scm_bits> ();
|
||||
let size_of_contents = len;
|
||||
let r = unsafe { gc::malloc (size_of_tag_and_len + size_of_contents) };
|
||||
unsafe {
|
||||
set_word (r, 0, tc7_string);
|
||||
set_word (r, 1, len as u64);
|
||||
}
|
||||
let str_beginning = r.wrapping_add (2) as *mut u8;
|
||||
for (i, b) in s.as_bytes ().iter ().enumerate () {
|
||||
unsafe { *(str_beginning.wrapping_add (i)) = *b };
|
||||
}
|
||||
return pack_ptr (r)
|
||||
}
|
||||
|
||||
|
||||
|
||||
// pub fn make_symbol (name : &str) -> scm_bits {
|
||||
// let r = unsafe { words (tc7_symbol, 2) };
|
||||
// let sym = obarray::symbols.intern (name).to_usize ();
|
||||
// unsafe { set_word (r, 1, sym.try_into ().unwrap ()) };
|
||||
// pack_ptr (r)
|
||||
// }
|
||||
|
||||
struct Symbol ([scm_bits; 2]);
|
||||
|
||||
impl PartialEq for Symbol {
|
||||
fn eq (&self, other: &Self) -> bool {
|
||||
if let (SCM::String (s1), SCM::String (s2))
|
||||
= (unpack (self.0[1]), unpack (other.0[1])) {
|
||||
s1 == s2
|
||||
} else {
|
||||
panic! ("not a symbol")
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
impl Eq for Symbol {}
|
||||
|
||||
impl std::hash::Hash for Symbol {
|
||||
fn hash <H: std::hash::Hasher> (&self, state: &mut H) {
|
||||
if let SCM::String (s) = unpack (self.0[1]) {
|
||||
s.hash (state)
|
||||
} else {
|
||||
panic! ("not a symbol")
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
fn make_symbol_off_heap (name : scm_bits) -> Symbol {
|
||||
Symbol ([ tc7_symbol, name ])
|
||||
}
|
||||
|
||||
pub fn string_to_symbol (str : scm_bits) -> scm_bits {
|
||||
let r = Intern::new (make_symbol_off_heap (str));
|
||||
pack_ptr (r.0.as_ptr ())
|
||||
}
|
||||
@@ -1,26 +0,0 @@
|
||||
use std::{collections::HashMap, ops::DerefMut as _, sync::{LazyLock, RwLock}};
|
||||
use crate::scm::scm_bits;
|
||||
|
||||
struct Vars (
|
||||
LazyLock <RwLock <HashMap <String, scm_bits>>>
|
||||
);
|
||||
|
||||
impl Vars {
|
||||
pub const fn new () -> Vars {
|
||||
Vars (LazyLock::new (|| RwLock::new (HashMap::new ())))
|
||||
}
|
||||
|
||||
pub fn lookup (&self, name : String) -> Option <scm_bits> {
|
||||
// let r = self.0.write ().unwrap ();
|
||||
// (*r).get (&name).map (|x| *x)
|
||||
todo! ()
|
||||
}
|
||||
|
||||
pub fn define (&self, name : String, value : scm_bits) {
|
||||
// let mut r = self.0.write ().unwrap ();
|
||||
// r.deref_mut ().insert (name, value);
|
||||
todo! ()
|
||||
}
|
||||
}
|
||||
|
||||
static vars : Vars = Vars::new ();
|
||||
@@ -0,0 +1,14 @@
|
||||
{ runCommandLocal, makeWrapper, lib, haskellPackages }:
|
||||
|
||||
let
|
||||
our-ghc = haskellPackages.ghc.withPackages (ps: [
|
||||
ps.shake
|
||||
]);
|
||||
in runCommandLocal
|
||||
"shake-wrapper"
|
||||
{ nativeBuildInputs = [ makeWrapper ]; }
|
||||
''
|
||||
mkdir -p $out/bin
|
||||
makeWrapper ${lib.getExe haskellPackages.shake} $out/bin/shake \
|
||||
--prefix PATH : ${lib.makeBinPath [our-ghc]}
|
||||
''
|
||||
Reference in New Issue
Block a user