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

Merge pull request #4 from msydneyslaga/annotated-expr

Browse Source 
Annotated expr
This commit was merged in pull request #4.
This commit is contained in:
msydneyslaga
2023-12-11 14:20:00 -07:00
committed by GitHub
parent d50bce22be 238729cf1e
commit 427d9d2b29
10 changed files with 313 additions and 141 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
app/Main.hs
View File

@@ -133,7 +133,7 @@ ddumpEval = whenFlag flagDDumpEval do
parseProg :: RLPCOptions
-> String
-> Either SrcError (Program, [SrcError])
-> Either SrcError (CoreProgram, [SrcError])
parseProg o = evalRLPC o . (lexCore >=> parseCoreProg)
forFiles_ :: (Monad m)

5
rlp.cabal
View File

@@ -14,7 +14,7 @@ extra-doc-files: README.md
-- extra-source-files:
common warnings
ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds
-- ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds
library
import: warnings
@@ -23,6 +23,7 @@ library
, GM
, Compiler.RLPC
, Core.Syntax
, Core.Utils
other-modules: Data.Heap
, Data.Pretty
@@ -31,6 +32,7 @@ library
, Core.Examples
, Core.Lex
, Control.Monad.Errorful
, Core2Core
build-tool-depends: happy:happy, alex:alex
@@ -47,6 +49,7 @@ library
, unordered-containers
, hashable
, pretty
, recursion-schemes
hs-source-dirs: src
default-language: GHC2021

4
src/Core/Examples.hs
View File

@@ -12,7 +12,6 @@ import Core.TH
-- TODO: my shitty lexer isn't inserting semicolons
letrecExample :: Program
letrecExample = [coreProg|
pair x y f = f x y;
@@ -28,7 +27,6 @@ letrecExample = [coreProg|
main = f 3 4;
|]
idExample :: Program
idExample = [coreProg|
main = id 3;
|]
@@ -138,7 +136,7 @@ factorialGM = [coreProg|
main = fac 3;
|]
corePrelude :: Module
corePrelude :: Module Name
corePrelude = Module (Just ("Prelude", [])) $
-- non-primitive defs
[coreProg|

46
src/Core/Parse.y
View File

@@ -58,7 +58,7 @@ import Data.Default.Class (def)
%%
Module :: { Module }
Module :: { Module Name }
Module : module conname where Program Eof { Module (Just ($2, [])) $4 }
| Program Eof { Module Nothing $1 }
@@ -66,36 +66,36 @@ Eof :: { () }
Eof : eof { () }
| error { () }
StandaloneProgram :: { Program }
StandaloneProgram :: { Program Name }
StandaloneProgram : Program eof { $1 }
Program :: { Program }
Program :: { Program Name }
Program : ScDefs { Program $1 }
ScDefs :: { [ScDef] }
ScDefs :: { [ScDef Name] }
ScDefs : ScDef ';' ScDefs { $1 : $3 }
| ScDef ';' { [$1] }
| ScDef { [$1] }
| {- epsilon -} { [] }
ScDef :: { ScDef }
ScDef :: { ScDef Name }
ScDef : Var ParList '=' Expr { ScDef $1 $2 $4 }
ParList :: { [Name] }
ParList : Var ParList { $1 : $2 }
| {- epsilon -} { [] }
StandaloneExpr :: { Expr }
StandaloneExpr :: { Expr Name }
StandaloneExpr : Expr eof { $1 }
Expr :: { Expr }
Expr :: { Expr Name }
Expr : LetExpr { $1 }
| 'λ' Binders '->' Expr { Lam $2 $4 }
| Application { $1 }
| CaseExpr { $1 }
| Expr1 { $1 }
LetExpr :: { Expr }
LetExpr :: { Expr Name }
LetExpr : let '{' Bindings '}' in Expr { Let NonRec $3 $6 }
| letrec '{' Bindings '}' in Expr { Let Rec $3 $6 }
@@ -103,48 +103,48 @@ Binders :: { [Name] }
Binders : Var Binders { $1 : $2 }
| Var { [$1] }
Application :: { Expr }
Application :: { Expr Name }
Application : Expr1 AppArgs { foldl' App $1 $2 }
-- TODO: Application can probably be written as a single rule, without AppArgs
AppArgs :: { [Expr] }
AppArgs :: { [Expr Name] }
AppArgs : Expr1 AppArgs { $1 : $2 }
| Expr1 { [$1] }
CaseExpr :: { Expr }
CaseExpr :: { Expr Name }
CaseExpr : case Expr of '{' Alters '}' { Case $2 $5 }
Alters :: { [Alter] }
Alters :: { [Alter Name] }
Alters : Alter ';' Alters { $1 : $3 }
| Alter ';' { [$1] }
| Alter { [$1] }
Alter :: { Alter }
Alter : litint ParList '->' Expr { Alter $1 $2 $4 }
Alter :: { Alter Name }
Alter : litint ParList '->' Expr { Alter (AltData $1) $2 $4 }
Expr1 :: { Expr }
Expr1 : litint { IntE $1 }
Expr1 :: { Expr Name }
Expr1 : litint { LitE $ IntL $1 }
| Id { Var $1 }
| PackCon { $1 }
| ExprPragma { $1 }
| '(' Expr ')' { $2 }
ExprPragma :: { Expr }
ExprPragma :: { Expr Name }
ExprPragma : '{-#' Words '#-}' {% exprPragma $2 }
Words :: { [String] }
Words : word Words { $1 : $2 }
| word { [$1] }
PackCon :: { Expr }
PackCon :: { Expr Name }
PackCon : pack '{' litint litint '}' { Con $3 $4 }
Bindings :: { [Binding] }
Bindings :: { [Binding Name] }
Bindings : Binding ';' Bindings { $1 : $3 }
| Binding ';' { [$1] }
| Binding { [$1] }
Binding :: { Binding }
Binding :: { Binding Name }
Binding : Var '=' Expr { $1 := $3 }
Id :: { Name }
@@ -169,7 +169,7 @@ parseError (Located y x l _ : _) = addFatal err
, _errDiagnostic = SrcErrParse
}
parseTmp :: IO Module
parseTmp :: IO (Module Name)
parseTmp = do
s <- readFile "/tmp/t.hs"
case parse s of
@@ -178,7 +178,7 @@ parseTmp = do
where
parse = evalRLPC def . (lexCore >=> parseCore)
exprPragma :: [String] -> RLPC SrcError Expr
exprPragma :: [String] -> RLPC SrcError (Expr Name)
exprPragma ("AST" : e) = astPragma e
exprPragma _ = addFatal err
where err = SrcError
@@ -187,7 +187,7 @@ exprPragma _ = addFatal err
, _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma
}
astPragma :: [String] -> RLPC SrcError Expr
astPragma :: [String] -> RLPC SrcError (Expr Name)
astPragma = pure . read . unwords
}

11
src/Core/Rename.hs Normal file
View File

@@ -0,0 +1,11 @@
module Core.Rename
( renameCore
)
where
----------------------------------------------------------------------------------
import Core.Syntax
----------------------------------------------------------------------------------
renameCore :: Program Name -> Program Unique
renameCore = undefined

164
src/Core/Syntax.hs
View File

@@ -3,10 +3,13 @@ Module : Core.Syntax
Description : Core ASTs and the like
-}
{-# LANGUAGE PatternSynonyms, OverloadedStrings #-}
{-# LANGUAGE FunctionalDependencies #-}
module Core.Syntax
( Expr(..)
, Literal(..)
, pattern (:$)
, Binding(..)
, AltCon(..)
, pattern (:=)
, Rec(..)
, Alter(..)
@@ -15,142 +18,113 @@ module Core.Syntax
, ScDef(..)
, Module(..)
, Program(..)
, bindersOf
, rhssOf
, isAtomic
, insertModule
, extractProgram
, Program'
, Expr'
, ScDef'
, Alter'
, Binding'
, HasRHS(_rhs)
)
where
----------------------------------------------------------------------------------
import Data.Coerce
import Data.Pretty
import GHC.Generics
import Data.List (intersperse)
import Data.Function ((&))
import Data.String
-- Lift instances for the Core quasiquoters
import Lens.Micro
import Language.Haskell.TH.Syntax (Lift)
----------------------------------------------------------------------------------
data Expr = Var Name
| Con Tag Int -- Con Tag Arity
| Let Rec [Binding] Expr
| Case Expr [Alter]
| Lam [Name] Expr
| App Expr Expr
| IntE Int
deriving (Show, Read, Lift, Eq)
data Expr b = Var Name
| Con Tag Int -- Con Tag Arity
| Case (Expr b) [Alter b]
| Lam [b] (Expr b)
| Let Rec [Binding b] (Expr b)
| App (Expr b) (Expr b)
| LitE Literal
deriving (Show, Read, Lift)
deriving instance (Eq b) => Eq (Expr b)
infixl 2 :$
pattern (:$) :: Expr -> Expr -> Expr
pattern (:$) :: Expr b -> Expr b -> Expr b
pattern f :$ x = App f x
{-# COMPLETE Binding :: Binding #-}
{-# COMPLETE (:=) :: Binding #-}
data Binding = Binding Name Expr
deriving (Show, Read, Lift, Eq)
data Binding b = Binding b (Expr b)
deriving (Show, Read, Lift)
deriving instance (Eq b) => Eq (Binding b)
infixl 1 :=
pattern (:=) :: Name -> Expr -> Binding
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)
data Alter = Alter Tag [Name] Expr
deriving (Show, Read, Lift, Eq)
data AltCon = AltData Tag
| AltLiteral Literal
| Default
deriving (Show, Read, Eq, Lift)
data Literal = IntL Int
deriving (Show, Read, Eq, Lift)
type Name = String
type Tag = Int
data ScDef = ScDef Name [Name] Expr
deriving (Show, Lift, Eq)
data Module = Module (Maybe (Name, [Name])) Program
data ScDef b = ScDef b [b] (Expr b)
deriving (Show, Lift)
newtype Program = Program [ScDef]
data Module b = Module (Maybe (Name, [Name])) (Program b)
deriving (Show, Lift)
instance IsString Expr where
newtype Program b = Program [ScDef b]
deriving (Show, Lift)
type Program' = Program Name
type Expr' = Expr Name
type ScDef' = ScDef Name
type Alter' = Alter Name
type Binding' = Binding Name
instance IsString (Expr b) where
fromString = Var
----------------------------------------------------------------------------------
instance Semigroup (Program b) where
(<>) = coerce $ (<>) @[ScDef b]
instance Pretty Program where
-- TODO: module header
prettyPrec (Program ss) _ = mconcat $ intersperse "\n\n" $ fmap pretty ss
instance Pretty ScDef where
prettyPrec (ScDef n as e) _ =
mconcat (intersperse " " $ fmap IStr (n:as))
<> " = " <> pretty e <> IBreak
instance Pretty Expr where
prettyPrec (Var k) = withPrec maxBound $ IStr k
prettyPrec (IntE n) = withPrec maxBound $ iShow n
prettyPrec (Con t a) = withPrec maxBound $
"Pack{" <> iShow t <> " " <> iShow a <> "}"
prettyPrec (Let r bs e) = withPrec 0 $
IStr (if r == Rec then "letrec " else "let ")
<> binds <> IBreak
<> "in " <> pretty e
where
binds = mconcat (f <$> init bs)
<> IIndent (pretty $ last bs)
f b = IIndent $ pretty b <> IBreak
prettyPrec (Lam ns e) = withPrec 0 $
IStr "λ" <> binds <> " -> " <> pretty e
where
binds = fmap IStr ns & intersperse " " & mconcat
prettyPrec (Case e as) = withPrec 0 $
"case " <> IIndent (pretty e <> " of" <> IBreak <> alts)
where
-- TODO: don't break on last alt
alts = mconcat $ fmap palt as
palt x = IIndent $ pretty x <> IBreak
prettyPrec (App f x) = \p -> bracketPrec 0 p $
case f of
-- application is left-associative; don't increase prec if the
-- expression being applied is itself an application
(_:$_) -> precPretty p f <> " " <> precPretty (succ p) x
_ -> precPretty (succ p) f <> " " <> precPretty (succ p) x
instance Pretty Alter where
prettyPrec (Alter t bs e) = withPrec 0 $
"<" <> IStr (show t) <> "> " <> binds <> " -> " <> pretty e
where
binds = mconcat $ intersperse " " (fmap IStr bs)
instance Pretty Binding where
prettyPrec (k := v) = withPrec 0 $ IStr k <> " = " <> precPretty 0 v
----------------------------------------------------------------------------------
instance Semigroup Program where
(<>) = coerce $ (<>) @[ScDef]
instance Monoid Program where
instance Monoid (Program b) where
mempty = Program []
----------------------------------------------------------------------------------
bindersOf :: [(Name, b)] -> [Name]
bindersOf = fmap fst
class HasRHS s z | s -> z where
_rhs :: Lens' s (Expr z)
rhssOf :: [(Name, b)] -> [b]
rhssOf = fmap snd
instance HasRHS (Alter b) b where
_rhs = lens
(\ (Alter _ _ e) -> e)
(\ (Alter t as _) e' -> Alter t as e')
isAtomic :: Expr -> Bool
isAtomic (Var _) = True
isAtomic _ = False
instance HasRHS (ScDef b) b where
_rhs = lens
(\ (ScDef _ _ e) -> e)
(\ (ScDef n as _) e' -> ScDef n as e')
----------------------------------------------------------------------------------
-- TODO: export list awareness
insertModule :: Module -> Program -> Program
insertModule (Module _ m) p = p <> m
extractProgram :: Module -> Program
extractProgram (Module _ p) = p
instance HasRHS (Binding b) b where
_rhs = lens
(\ (_ := e) -> e)
(\ (k := _) e' -> k := e')

72
src/Core/Utils.hs Normal file
View File

@@ -0,0 +1,72 @@
-- for recursion schemes
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
-- for recursion schemes
{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
module Core.Utils
( bindersOf
, rhssOf
, isAtomic
, insertModule
, extractProgram
, freeVariables
, ExprF(..)
)
where
----------------------------------------------------------------------------------
import Data.Functor.Foldable.TH (makeBaseFunctor)
import Data.Functor.Foldable
import Data.Set (Set)
import Data.Set qualified as S
import Core.Syntax
import GHC.Exts (IsList(..))
----------------------------------------------------------------------------------
bindersOf :: (IsList l, Item l ~ b) => [Binding b] -> l
bindersOf bs = fromList $ fmap f bs
where f (k := _) = k
rhssOf :: (IsList l, Item l ~ Expr b) => [Binding b] -> l
rhssOf = fromList . fmap f
where f (_ := v) = v
isAtomic :: Expr b -> Bool
isAtomic (Var _) = True
isAtomic (LitE _) = True
isAtomic _ = False
----------------------------------------------------------------------------------
-- TODO: export list awareness
insertModule :: Module b -> Program b -> Program b
insertModule (Module _ m) p = p <> m
extractProgram :: Module b -> Program b
extractProgram (Module _ p) = p
----------------------------------------------------------------------------------
makeBaseFunctor ''Expr
freeVariables :: Expr' -> Set Name
freeVariables = cata go
where
go :: ExprF Name (Set Name) -> Set Name
go (VarF k) = S.singleton k
-- TODO: collect free vars in rhss of bs
go (LetF _ bs e) = (e `S.union` esFree) `S.difference` ns
where
es = rhssOf bs :: [Expr']
ns = bindersOf bs
-- TODO: this feels a little wrong. maybe a different scheme is
-- appropriate
esFree = foldMap id $ freeVariables <$> es
go (CaseF e as) = e `S.union` asFree
where
asFree = foldMap id $ freeVariables <$> (fmap altToLam as)
-- we map alts to lambdas to avoid writing a 'freeVariablesAlt'
altToLam (Alter _ ns e) = Lam ns e
go (LamF bs e) = e `S.difference` (S.fromList bs)
go e = foldMap id e

85
src/Core2Core.hs Normal file
View File

@@ -0,0 +1,85 @@
{-# LANGUAGE LambdaCase #-}
module Core2Core
( core2core
-- internal utilities for convenience
, floatCase
)
where
----------------------------------------------------------------------------------
import Data.Functor.Foldable
import Data.Maybe (fromJust)
import Data.Set qualified as S
import Data.List
import Control.Monad.Writer
import Control.Monad.State
import Lens.Micro
import Core.Syntax
import Core.Utils
----------------------------------------------------------------------------------
core2core :: Program' -> Program'
core2core p = undefined
-- assumes the provided expression is in a strict context
-- replaceNonStrictCases :: [Name] -> Expr' -> (Expr', [ScDef'])
-- replaceNonStrictCases names = runWriter . cata goE
-- where
-- goE :: ExprF Name (Writer [ScDef'] Expr')
-- -> Writer [ScDef'] Expr'
-- -- strict context
-- goE (VarF k) = pure (Var k)
-- goE (CaseF e as) = e *> ae'
-- where
-- ae = (\ (Alter _ _ b) -> b) <$> as
-- ae' = mconcat <$> traverse replaceNonStrictCases ae
type Replacer = StateT [Name] (Writer [ScDef'])
-- TODO: formally define a "strict context" and reference that here
replaceNonStrictCases :: [Name] -> Expr' -> (Expr', [ScDef'])
replaceNonStrictCases names = runWriter . flip evalStateT names . goE
where
goE :: Expr' -> Replacer Expr'
goE (Var k) = pure (Var k)
goE (LitE l) = pure (LitE l)
goE (Let Rec bs e) = Let Rec <$> bs' <*> goE e
where bs' = travBs goE bs
goE e = goC e
goC :: Expr' -> Replacer Expr'
-- the only truly non-trivial case: when a case expr is found in a
-- non-strict context, we float it into a supercombinator, give it a
-- name consumed from the state, record the newly created sc within the
-- Writer, and finally return an expression appropriately calling the sc
goC p@(Case e as) = do
n <- name
let (e',sc) = floatCase n p
altBodies = (\(Alter _ _ b) -> b) <$> as
tell [sc]
goE e
traverse goE altBodies
pure e'
goC (f :$ x) = (:$) <$> goC f <*> goC x
goC (Let r bs e) = Let r <$> bs' <*> goE e
where bs' = travBs goC bs
name = state (fromJust . uncons)
-- extract the right-hand sides of a list of bindings, traverse each
-- one, and return the original list of bindings
travBs :: (Expr' -> Replacer Expr') -> [Binding'] -> Replacer [Binding']
travBs c bs = bs ^.. each . _rhs
& traverse goC
& const (pure bs)
-- when provided with a case expr, floatCase will float the case into a
-- supercombinator of its free variables. the sc is returned along with an
-- expression that calls the sc with the necessary arguments
floatCase :: Name -> Expr' -> (Expr', ScDef')
floatCase n c@(Case e as) = (e', sc)
where
sc = ScDef n caseFrees c
caseFrees = S.toList $ freeVariables c
e' = foldl App (Var n) (Var <$> caseFrees)

59
src/GM.hs
View File

@@ -30,6 +30,21 @@ import Debug.Trace
import Core
----------------------------------------------------------------------------------
{-}
hdbgProg = undefined
evalProg = undefined
data Node = NNum Int
| NAp Addr Addr
| NInd Addr
| NUninitialised
| NConstr Tag [Addr] -- NConstr Tag Components
| NMarked Node
deriving (Show, Eq)
--}
data GmState = GmState
{ _gmCode :: Code
, _gmStack :: Stack
@@ -103,7 +118,7 @@ pure []
----------------------------------------------------------------------------------
evalProg :: Program -> Maybe (Node, Stats)
evalProg :: Program' -> Maybe (Node, Stats)
evalProg p = res <&> (,sts)
where
final = eval (compile p) & last
@@ -112,7 +127,7 @@ evalProg p = res <&> (,sts)
resAddr = final ^. gmStack ^? _head
res = resAddr >>= flip hLookup h
hdbgProg :: Program -> Handle -> IO (Node, Stats)
hdbgProg :: Program' -> 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`
@@ -533,7 +548,7 @@ pop [] = []
----------------------------------------------------------------------------------
compile :: Program -> GmState
compile :: Program' -> GmState
compile p = GmState c [] [] h g sts
where
-- find the entry point and evaluate it
@@ -560,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 :: Program' -> (GmHeap, Env)
buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
where
compiledScs = fmap compileSc ss <> compiledPrims
@@ -573,20 +588,20 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
-- >> [ref/compileSc]
-- type CompiledSC = (Name, Int, Code)
compileSc :: ScDef -> CompiledSC
compileSc :: ScDef' -> 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 -> Expr' -> 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
-- compile an expression in a non-strict context
compileC :: Env -> Expr' -> Code
compileC g (Var k)
| k `elem` domain = [Push n]
| otherwise = [PushGlobal k]
@@ -596,7 +611,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
f (NameKey n, _) = Just n
f _ = Nothing
compileC _ (IntE n) = [PushInt n]
compileC _ (LitE l) = compileCL l
-- >> [ref/compileC]
compileC g (App f x) = compileC g x
@@ -612,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 -> (Binding', Int) -> (Env, Code)
compileBinder m (k := v, a) = (m',c)
where
m' = (NameKey k, a) : m
@@ -630,7 +645,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
initialisers = mconcat $ compileBinder <$> addressed
body = compileC g' e
compileBinder :: (Binding, Int) -> Code
compileBinder :: (Binding', Int) -> Code
compileBinder (_ := v, a) = compileC g' v <> [Update a]
compileC _ (Con t n) = [PushConstr t n]
@@ -640,10 +655,16 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
compileC _ _ = error "yet to be implemented!"
compileCL :: Literal -> Code
compileCL (IntL n) = [PushInt n]
compileEL :: Literal -> Code
compileEL (IntL n) = [PushInt n]
-- 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 _ (IntE n) = [PushInt n]
compileE :: Env -> Expr' -> Code
compileE _ (LitE l) = compileEL l
compileE g (Let NonRec bs e) =
-- we use compileE instead of compileC
mconcat binders <> compileE g' e <> [Slide d]
@@ -653,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 -> (Binding', Int) -> (Env, Code)
compileBinder m (k := v, a) = (m',c)
where
m' = (NameKey k, a) : m
@@ -674,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 :: (Binding', Int) -> Code
compileBinder (_ := v, a) = compileC g' v <> [Update a]
-- special cases for prim functions; essentially inlining
@@ -689,11 +710,11 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
compileE g e = compileC g e ++ [Eval]
compileD :: Env -> [Alter] -> [(Tag, Code)]
compileD :: Env -> [Alter'] -> [(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 -> Alter' -> (Tag, Code)
compileA g (Alter (AltData t) as e) = (t, [Split n] <> c <> [Slide n])
where
n = length as
binds = (NameKey <$> as) `zip` [0..]
@@ -921,3 +942,5 @@ sweepNodes st = st & gmHeap %~ thread (f <$> addresses h)
thread :: [a -> a] -> (a -> a)
thread = appEndo . foldMap Endo
--}

6
src/TI.hs
View File

@@ -28,6 +28,10 @@ import Core.Examples
import Core
----------------------------------------------------------------------------------
hdbgProg = undefined
{-
data TiState = TiState Stack Dump TiHeap Env Stats
deriving Show
@@ -611,3 +615,5 @@ gc st@(TiState s d h g sts) = TiState s d h' g sts
marked = h & appEndo (foldMap Endo $ markFrom <$> as)
h' = scanHeap marked
--}