app/Main.hs

@@ -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)

rlp.cabal

@@ -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

src/Core/Examples.hs

@@ -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|

src/Core/Parse.y

@@ -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           :: { Alter Name }
-Alter           : litint ParList '->' Expr      { Alter $1 $2 $4 }
+Alter           : litint ParList '->' Expr      { Alter (AltData $1) $2 $4 }
 
-Expr1           :: { Expr }
+Expr1           :: { Expr Name }
-Expr1           : litint                        { IntE $1 }
+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
 
 }

src/Core/Rename.hs

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

src/Core/Syntax.hs

@@ -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
+    , Program'
-    , rhssOf
+    , Expr'
-    , isAtomic
+    , ScDef'
-    , insertModule
+    , Alter'
-    , extractProgram
+    , 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
+data Expr b = Var Name
             | Con Tag Int -- Con Tag Arity
-          | Let Rec [Binding] Expr
+            | Case (Expr b) [Alter b]
-          | Case Expr [Alter]
+            | Lam [b] (Expr b)
-          | Lam [Name] Expr
+            | Let Rec [Binding b] (Expr b)
-          | App Expr Expr
+            | App (Expr b) (Expr b)
-          | IntE Int
+            | LitE Literal
-          deriving (Show, Read, Lift, Eq)
+            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
+data Binding b = Binding b (Expr b)
-    deriving (Show, Read, Lift, Eq)
+    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
+data AltCon = AltData Tag
-    deriving (Show, Read, Lift, Eq)
+            | 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
+data ScDef b = ScDef b [b] (Expr b)
-    deriving (Show, Lift, Eq)
-
-data Module = Module (Maybe (Name, [Name])) Program
     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
+instance Monoid (Program b) 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
     mempty = Program []
 
 ----------------------------------------------------------------------------------
 
-bindersOf :: [(Name, b)] -> [Name]
+class HasRHS s z | s -> z where
-bindersOf = fmap fst
+    _rhs :: Lens' s (Expr z)
 
-rhssOf :: [(Name, b)] -> [b]
+instance HasRHS (Alter b) b where
-rhssOf = fmap snd
+    _rhs = lens
+        (\ (Alter _ _ e) -> e)
+        (\ (Alter t as _) e' -> Alter t as e')
 
-isAtomic :: Expr -> Bool
+instance HasRHS (ScDef b) b where
-isAtomic (Var _) = True
+    _rhs = lens
-isAtomic _       = False
+        (\ (ScDef _ _ e) -> e)
+        (\ (ScDef n as _) e' -> ScDef n as e')
 
-----------------------------------------------------------------------------------
+instance HasRHS (Binding b) b where
-
+    _rhs = lens
--- TODO: export list awareness
+        (\ (_ := e) -> e)
-insertModule :: Module -> Program -> Program
+        (\ (k := _) e' -> k := e')
-insertModule (Module _ m) p = p <> m
-
-extractProgram :: Module -> Program
-extractProgram (Module _ p) = p
 

src/Core/Utils.hs

@@ -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
+

src/Core2Core.hs

@@ -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)
+

src/GM.hs

@@ -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
+        -- compile an expression in a non-strict context
-        compileC :: Env -> Expr -> Code
+        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 :: Env -> Expr' -> Code
-        compileE _ (IntE n) = [PushInt n]
+        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 :: Env -> Alter' -> (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
                 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
+
+--}

src/TI.hs

@@ -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
 
+--}
+