msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

cleanup

Browse Source
This commit is contained in:
crumbtoo
2023-12-08 14:55:30 -07:00
parent f728b91a8a
commit e477891bc3
4 changed files with 49 additions and 24 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
rlp.cabal
View File

@@ -47,6 +47,7 @@ library
, unordered-containers , unordered-containers
, hashable , hashable
, pretty , pretty
, recursion-schemes
hs-source-dirs: src hs-source-dirs: src
default-language: GHC2021 default-language: GHC2021

2
src/Core/Parse.y
View File

@@ -124,7 +124,7 @@ Alter : litint ParList '->' Expr { Alter (AltData $1) $2 $4 }
Expr1 :: { Expr Name } Expr1 :: { Expr Name }
Expr1 : litint { LitE $ IntL $1 } Expr1 : litint { LitE $ IntL $1 }
| Id { Var (Name $1) } | Id { Var $1 }
| PackCon { $1 } | PackCon { $1 }
| ExprPragma { $1 } | ExprPragma { $1 }
| '(' Expr ')' { $2 } | '(' Expr ')' { $2 }

36
src/Core/Syntax.hs
View File

@@ -3,9 +3,13 @@ Module : Core.Syntax
Description : Core ASTs and the like Description : Core ASTs and the like
-} -}
{-# LANGUAGE PatternSynonyms, OverloadedStrings #-} {-# LANGUAGE PatternSynonyms, OverloadedStrings #-}
-- for recursion schemes
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
-- for recursion schemes
{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
module Core.Syntax module Core.Syntax
( Expr(..) ( Expr(..)
, Id(..)
, Literal(..) , Literal(..)
, pattern (:$) , pattern (:$)
, Binding(..) , Binding(..)
@@ -19,6 +23,10 @@ module Core.Syntax
, Module(..) , Module(..)
, Program(..) , Program(..)
, CoreProgram , CoreProgram
, CoreExpr
, CoreScDef
, CoreAlter
, CoreBinding
, bindersOf , bindersOf
, rhssOf , rhssOf
, isAtomic , isAtomic
@@ -32,10 +40,12 @@ import Data.Pretty
import Data.List (intersperse) import Data.List (intersperse)
import Data.Function ((&)) import Data.Function ((&))
import Data.String import Data.String
-- Lift instances for the Core quasiquoters
import Language.Haskell.TH.Syntax (Lift) import Language.Haskell.TH.Syntax (Lift)
import Data.Functor.Foldable.TH (makeBaseFunctor)
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
data Expr b = Var Id data Expr b = Var Name
| Con Tag Int -- Con Tag Arity | Con Tag Int -- Con Tag Arity
| Case (Expr b) [Alter b] | Case (Expr b) [Alter b]
| Lam [b] (Expr b) | Lam [b] (Expr b)
@@ -44,8 +54,7 @@ data Expr b = Var Id
| LitE Literal | LitE Literal
deriving (Show, Read, Lift) deriving (Show, Read, Lift)
data Id = Name Name deriving instance (Eq b) => Eq (Expr b)
deriving (Show, Read, Lift)
infixl 2 :$ infixl 2 :$
pattern (:$) :: Expr b -> Expr b -> Expr b pattern (:$) :: Expr b -> Expr b -> Expr b
@@ -56,12 +65,17 @@ pattern f :$ x = App f x
data Binding b = Binding b (Expr b) data Binding b = Binding b (Expr b)
deriving (Show, Read, Lift) deriving (Show, Read, Lift)
deriving instance (Eq b) => Eq (Binding b)
infixl 1 := infixl 1 :=
pattern (:=) :: b -> (Expr b) -> (Binding b) pattern (:=) :: b -> (Expr b) -> (Binding b)
pattern k := v = Binding k v pattern k := v = Binding k v
data Alter b = Alter AltCon [b] (Expr b) data Alter b = Alter AltCon [b] (Expr b)
deriving (Show, Read, Lift) deriving (Show, Read, Lift)
deriving instance (Eq b) => Eq (Alter b)
data Rec = Rec data Rec = Rec
| NonRec | NonRec
deriving (Show, Read, Eq, Lift) deriving (Show, Read, Eq, Lift)
@@ -69,10 +83,10 @@ data Rec = Rec
data AltCon = AltData Tag data AltCon = AltData Tag
| AltLiteral Literal | AltLiteral Literal
| Default | Default
deriving (Show, Read, Lift) deriving (Show, Read, Eq, Lift)
data Literal = IntL Int data Literal = IntL Int
deriving (Show, Read, Lift) deriving (Show, Read, Eq, Lift)
type Name = String type Name = String
type Tag = Int type Tag = Int
@@ -87,9 +101,13 @@ newtype Program b = Program [ScDef b]
deriving (Show, Lift) deriving (Show, Lift)
type CoreProgram = Program Name type CoreProgram = Program Name
type CoreExpr = Expr Name
type CoreScDef = ScDef Name
type CoreAlter = Alter Name
type CoreBinding = Binding Name
instance IsString (Expr b) where instance IsString (Expr b) where
fromString = Var . Name fromString = Var
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -121,3 +139,7 @@ insertModule (Module _ m) p = p <> m
extractProgram :: (Module b) -> (Program b) extractProgram :: (Module b) -> (Program b)
extractProgram (Module _ p) = p extractProgram (Module _ p) = p
----------------------------------------------------------------------------------
makeBaseFunctor ''Expr

34
src/GM.hs
View File

@@ -30,6 +30,8 @@ import Debug.Trace
import Core import Core
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
{-}
hdbgProg = undefined hdbgProg = undefined
evalProg = undefined evalProg = undefined
@@ -41,7 +43,7 @@ data Node = NNum Int
| NMarked Node | NMarked Node
deriving (Show, Eq) deriving (Show, Eq)
{- --}
data GmState = GmState data GmState = GmState
{ _gmCode :: Code { _gmCode :: Code
@@ -116,7 +118,7 @@ pure []
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
evalProg :: Program -> Maybe (Node, Stats) evalProg :: CoreProgram -> Maybe (Node, Stats)
evalProg p = res <&> (,sts) evalProg p = res <&> (,sts)
where where
final = eval (compile p) & last final = eval (compile p) & last
@@ -125,7 +127,7 @@ evalProg p = res <&> (,sts)
resAddr = final ^. gmStack ^? _head resAddr = final ^. gmStack ^? _head
res = resAddr >>= flip hLookup h res = resAddr >>= flip hLookup h
hdbgProg :: Program -> Handle -> IO (Node, Stats) hdbgProg :: CoreProgram -> Handle -> IO (Node, Stats)
hdbgProg p hio = do hdbgProg p hio = do
(renderOut . showState) `traverse_` states (renderOut . showState) `traverse_` states
-- TODO: i'd like the statistics to be at the top of the file, but `sts` -- TODO: i'd like the statistics to be at the top of the file, but `sts`
@@ -546,7 +548,7 @@ pop [] = []
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
compile :: Program -> GmState compile :: CoreProgram -> GmState
compile p = GmState c [] [] h g sts compile p = GmState c [] [] h g sts
where where
-- find the entry point and evaluate it -- find the entry point and evaluate it
@@ -573,7 +575,7 @@ compiledPrims =
binop k i = (k, 2, [Push 1, Eval, Push 1, Eval, i, Update 2, Pop 2, Unwind]) binop k i = (k, 2, [Push 1, Eval, Push 1, Eval, i, Update 2, Pop 2, Unwind])
buildInitialHeap :: Program -> (GmHeap, Env) buildInitialHeap :: CoreProgram -> (GmHeap, Env)
buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
where where
compiledScs = fmap compileSc ss <> compiledPrims compiledScs = fmap compileSc ss <> compiledPrims
@@ -586,20 +588,20 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
-- >> [ref/compileSc] -- >> [ref/compileSc]
-- type CompiledSC = (Name, Int, Code) -- type CompiledSC = (Name, Int, Code)
compileSc :: ScDef -> CompiledSC compileSc :: CoreScDef -> CompiledSC
compileSc (ScDef n as b) = (n, d, compileR env b) compileSc (ScDef n as b) = (n, d, compileR env b)
where where
env = (NameKey <$> as) `zip` [0..] env = (NameKey <$> as) `zip` [0..]
d = length as d = length as
-- << [ref/compileSc] -- << [ref/compileSc]
compileR :: Env -> Expr -> Code compileR :: Env -> CoreExpr -> Code
compileR g e = compileE g e <> [Update d, Pop d, Unwind] compileR g e = compileE g e <> [Update d, Pop d, Unwind]
where where
d = length g d = length g
-- compile an expression in a lazy context -- compile an expression in a lazy context
compileC :: Env -> Expr -> Code compileC :: Env -> CoreExpr -> Code
compileC g (Var k) compileC g (Var k)
| k `elem` domain = [Push n] | k `elem` domain = [Push n]
| otherwise = [PushGlobal k] | otherwise = [PushGlobal k]
@@ -625,7 +627,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
-- kinda gross. revisit this -- kinda gross. revisit this
addressed = bs `zip` reverse [0 .. d-1] addressed = bs `zip` reverse [0 .. d-1]
compileBinder :: Env -> (Binding, Int) -> (Env, Code) compileBinder :: Env -> (CoreBinding, Int) -> (Env, Code)
compileBinder m (k := v, a) = (m',c) compileBinder m (k := v, a) = (m',c)
where where
m' = (NameKey k, a) : m m' = (NameKey k, a) : m
@@ -643,7 +645,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
initialisers = mconcat $ compileBinder <$> addressed initialisers = mconcat $ compileBinder <$> addressed
body = compileC g' e body = compileC g' e
compileBinder :: (Binding, Int) -> Code compileBinder :: (CoreBinding, Int) -> Code
compileBinder (_ := v, a) = compileC g' v <> [Update a] compileBinder (_ := v, a) = compileC g' v <> [Update a]
compileC _ (Con t n) = [PushConstr t n] compileC _ (Con t n) = [PushConstr t n]
@@ -661,7 +663,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
-- compile an expression in a strict context such that a pointer to the -- compile an expression in a strict context such that a pointer to the
-- expression is left on top of the stack in WHNF -- expression is left on top of the stack in WHNF
compileE :: Env -> Expr -> Code compileE :: Env -> CoreExpr -> Code
compileE _ (LitE l) = compileEL l compileE _ (LitE l) = compileEL l
compileE g (Let NonRec bs e) = compileE g (Let NonRec bs e) =
-- we use compileE instead of compileC -- we use compileE instead of compileC
@@ -672,7 +674,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
-- kinda gross. revisit this -- kinda gross. revisit this
addressed = bs `zip` reverse [0 .. d-1] addressed = bs `zip` reverse [0 .. d-1]
compileBinder :: Env -> (Binding, Int) -> (Env, Code) compileBinder :: Env -> (CoreBinding, Int) -> (Env, Code)
compileBinder m (k := v, a) = (m',c) compileBinder m (k := v, a) = (m',c)
where where
m' = (NameKey k, a) : m m' = (NameKey k, a) : m
@@ -693,7 +695,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
body = compileE g' e body = compileE g' e
-- we use compileE instead of compileC -- we use compileE instead of compileC
compileBinder :: (Binding, Int) -> Code compileBinder :: (CoreBinding, Int) -> Code
compileBinder (_ := v, a) = compileC g' v <> [Update a] compileBinder (_ := v, a) = compileC g' v <> [Update a]
-- special cases for prim functions; essentially inlining -- special cases for prim functions; essentially inlining
@@ -708,11 +710,11 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
compileE g e = compileC g e ++ [Eval] compileE g e = compileC g e ++ [Eval]
compileD :: Env -> [Alter] -> [(Tag, Code)] compileD :: Env -> [CoreAlter] -> [(Tag, Code)]
compileD g as = fmap (compileA g) as compileD g as = fmap (compileA g) as
compileA :: Env -> Alter -> (Tag, Code) compileA :: Env -> CoreAlter -> (Tag, Code)
compileA g (Alter t as e) = (t, [Split n] <> c <> [Slide n]) compileA g (Alter (AltData t) as e) = (t, [Split n] <> c <> [Slide n])
where where
n = length as n = length as
binds = (NameKey <$> as) `zip` [0..] binds = (NameKey <$> as) `zip` [0..]