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

2
src/Core/Parse.y
View File

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

36
src/Core/Syntax.hs
View File

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

34
src/GM.hs
View File

@@ -30,6 +30,8 @@ import Debug.Trace
import Core
----------------------------------------------------------------------------------
{-}
hdbgProg = undefined
evalProg = undefined
@@ -41,7 +43,7 @@ data Node = NNum Int
| NMarked Node
deriving (Show, Eq)
{-
--}
data GmState = GmState
{ _gmCode :: Code
@@ -116,7 +118,7 @@ pure []
----------------------------------------------------------------------------------
evalProg :: Program -> Maybe (Node, Stats)
evalProg :: CoreProgram -> Maybe (Node, Stats)
evalProg p = res <&> (,sts)
where
final = eval (compile p) & last
@@ -125,7 +127,7 @@ evalProg p = res <&> (,sts)
resAddr = final ^. gmStack ^? _head
res = resAddr >>= flip hLookup h
hdbgProg :: Program -> Handle -> IO (Node, Stats)
hdbgProg :: CoreProgram -> Handle -> IO (Node, Stats)
hdbgProg p hio = do
(renderOut . showState) `traverse_` states
-- 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
where
-- 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])
buildInitialHeap :: Program -> (GmHeap, Env)
buildInitialHeap :: CoreProgram -> (GmHeap, Env)
buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
where
compiledScs = fmap compileSc ss <> compiledPrims
@@ -586,20 +588,20 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
-- >> [ref/compileSc]
-- type CompiledSC = (Name, Int, Code)
compileSc :: ScDef -> CompiledSC
compileSc :: CoreScDef -> CompiledSC
compileSc (ScDef n as b) = (n, d, compileR env b)
where
env = (NameKey <$> as) `zip` [0..]
d = length as
-- << [ref/compileSc]
compileR :: Env -> Expr -> Code
compileR :: Env -> CoreExpr -> Code
compileR g e = compileE g e <> [Update d, Pop d, Unwind]
where
d = length g
-- compile an expression in a lazy context
compileC :: Env -> Expr -> Code
compileC :: Env -> CoreExpr -> Code
compileC g (Var k)
| k `elem` domain = [Push n]
| otherwise = [PushGlobal k]
@@ -625,7 +627,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
-- kinda gross. revisit this
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)
where
m' = (NameKey k, a) : m
@@ -643,7 +645,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
initialisers = mconcat $ compileBinder <$> addressed
body = compileC g' e
compileBinder :: (Binding, Int) -> Code
compileBinder :: (CoreBinding, Int) -> Code
compileBinder (_ := v, a) = compileC g' v <> [Update a]
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
-- expression is left on top of the stack in WHNF
compileE :: Env -> Expr -> Code
compileE :: Env -> CoreExpr -> Code
compileE _ (LitE l) = compileEL l
compileE g (Let NonRec bs e) =
-- we use compileE instead of compileC
@@ -672,7 +674,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
-- kinda gross. revisit this
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)
where
m' = (NameKey k, a) : m
@@ -693,7 +695,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
body = compileE g' e
-- we use compileE instead of compileC
compileBinder :: (Binding, Int) -> Code
compileBinder :: (CoreBinding, Int) -> Code
compileBinder (_ := v, a) = compileC g' v <> [Update a]
-- 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]
compileD :: Env -> [Alter] -> [(Tag, Code)]
compileD :: Env -> [CoreAlter] -> [(Tag, Code)]
compileD g as = fmap (compileA g) as
compileA :: Env -> Alter -> (Tag, Code)
compileA g (Alter t as e) = (t, [Split n] <> c <> [Slide n])
compileA :: Env -> CoreAlter -> (Tag, Code)
compileA g (Alter (AltData t) as e) = (t, [Split n] <> c <> [Slide n])
where
n = length as
binds = (NameKey <$> as) `zip` [0..]