From f728b91a8a67f982bac536dea535e0c11e74b3ef Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Fri, 8 Dec 2023 09:37:20 -0700 Subject: [PATCH 1/3] add annotation param to Expr nightmare breaking changes. never listening to the "i'll do it later if i REALLY need it" part of my brain again. add annotation param to Expr --- app/Main.hs | 2 +- rlp.cabal | 2 +- src/Core/Examples.hs | 4 +- src/Core/Parse.y | 48 ++++++++--------- src/Core/Rename.hs | 11 ++++ src/Core/Syntax.hs | 125 ++++++++++++++++--------------------------- src/Core2Core.hs | 14 +++++ src/GM.hs | 25 ++++++++- src/TI.hs | 6 +++ 9 files changed, 127 insertions(+), 110 deletions(-) create mode 100644 src/Core/Rename.hs create mode 100644 src/Core2Core.hs diff --git a/app/Main.hs b/app/Main.hs index c071dbc..6c11ecd 100644 --- a/app/Main.hs +++ b/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) diff --git a/rlp.cabal b/rlp.cabal index f604254..de26f6b 100644 --- a/rlp.cabal +++ b/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 diff --git a/src/Core/Examples.hs b/src/Core/Examples.hs index d828554..b775a8f 100644 --- a/src/Core/Examples.hs +++ b/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| diff --git a/src/Core/Parse.y b/src/Core/Parse.y index 89a7035..1f1d64d 100644 --- a/src/Core/Parse.y +++ b/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 : 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 } - | Id { Var $1 } +Expr1 :: { Expr Name } +Expr1 : litint { LitE $ IntL $1 } + | Id { Var (Name $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 } diff --git a/src/Core/Rename.hs b/src/Core/Rename.hs new file mode 100644 index 0000000..bf28005 --- /dev/null +++ b/src/Core/Rename.hs @@ -0,0 +1,11 @@ +module Core.Rename + ( renameCore + ) + where +---------------------------------------------------------------------------------- +import Core.Syntax +---------------------------------------------------------------------------------- + +renameCore :: Program Name -> Program Unique +renameCore = undefined + diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index f68482b..da169f7 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -5,8 +5,11 @@ Description : Core ASTs and the like {-# LANGUAGE PatternSynonyms, OverloadedStrings #-} module Core.Syntax ( Expr(..) + , Id(..) + , Literal(..) , pattern (:$) , Binding(..) + , AltCon(..) , pattern (:=) , Rec(..) , Alter(..) @@ -15,6 +18,7 @@ module Core.Syntax , ScDef(..) , Module(..) , Program(..) + , CoreProgram , bindersOf , rhssOf , isAtomic @@ -31,106 +35,68 @@ import Data.String 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 Id + | 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) + +data Id = Name Name + deriving (Show, Read, Lift) 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) 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) 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, Lift) + +data Literal = IntL Int + deriving (Show, Read, 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 - fromString = Var +newtype Program b = Program [ScDef b] + deriving (Show, Lift) + +type CoreProgram = Program Name + +instance IsString (Expr b) where + fromString = Var . Name ---------------------------------------------------------------------------------- -instance Pretty Program where - -- TODO: module header - prettyPrec (Program ss) _ = mconcat $ intersperse "\n\n" $ fmap pretty ss +instance Semigroup (Program b) where + (<>) = coerce $ (<>) @[ScDef b] -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 [] ---------------------------------------------------------------------------------- @@ -141,16 +107,17 @@ bindersOf = fmap fst rhssOf :: [(Name, b)] -> [b] rhssOf = fmap snd -isAtomic :: Expr -> Bool -isAtomic (Var _) = True -isAtomic _ = False +isAtomic :: Expr b -> Bool +isAtomic (Var _) = True +isAtomic (LitE _) = True +isAtomic _ = False ---------------------------------------------------------------------------------- -- TODO: export list awareness -insertModule :: Module -> Program -> Program +insertModule :: (Module b) -> (Program b) -> (Program b) insertModule (Module _ m) p = p <> m -extractProgram :: Module -> Program +extractProgram :: (Module b) -> (Program b) extractProgram (Module _ p) = p diff --git a/src/Core2Core.hs b/src/Core2Core.hs new file mode 100644 index 0000000..0a37265 --- /dev/null +++ b/src/Core2Core.hs @@ -0,0 +1,14 @@ +module Core2Core + ( + ) + where +---------------------------------------------------------------------------------- +import Core.Syntax +---------------------------------------------------------------------------------- + +core2core :: Program -> Program +core2core = undefined + +floatNonStrictCase :: Expr -> Expr +floatNonStrictCase (Case e as) = Case e () + diff --git a/src/GM.hs b/src/GM.hs index c2eac80..1fbbf14 100644 --- a/src/GM.hs +++ b/src/GM.hs @@ -30,6 +30,19 @@ 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 @@ -596,7 +609,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 @@ -640,10 +653,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 _ (LitE l) = compileEL l compileE g (Let NonRec bs e) = -- we use compileE instead of compileC mconcat binders <> compileE g' e <> [Slide d] @@ -921,3 +940,5 @@ sweepNodes st = st & gmHeap %~ thread (f <$> addresses h) thread :: [a -> a] -> (a -> a) thread = appEndo . foldMap Endo + +--} diff --git a/src/TI.hs b/src/TI.hs index 347642b..e51bd0c 100644 --- a/src/TI.hs +++ b/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 +--} + From e477891bc31629393787e723c30c9a2ffb203a87 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Fri, 8 Dec 2023 14:55:30 -0700 Subject: [PATCH 2/3] cleanup --- rlp.cabal | 1 + src/Core/Parse.y | 2 +- src/Core/Syntax.hs | 36 +++++++++++++++++++++++++++++------- src/GM.hs | 34 ++++++++++++++++++---------------- 4 files changed, 49 insertions(+), 24 deletions(-) diff --git a/rlp.cabal b/rlp.cabal index de26f6b..187962d 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -47,6 +47,7 @@ library , unordered-containers , hashable , pretty + , recursion-schemes hs-source-dirs: src default-language: GHC2021 diff --git a/src/Core/Parse.y b/src/Core/Parse.y index 1f1d64d..1654038 100644 --- a/src/Core/Parse.y +++ b/src/Core/Parse.y @@ -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 } diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index da169f7..decc325 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -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 + diff --git a/src/GM.hs b/src/GM.hs index 1fbbf14..fa072d5 100644 --- a/src/GM.hs +++ b/src/GM.hs @@ -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..] From 238729cf1e43b0c870b5f59e6ddf9c347563d742 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Mon, 11 Dec 2023 14:18:48 -0700 Subject: [PATCH 3/3] core2core --- rlp.cabal | 2 ++ src/Core/Syntax.hs | 71 ++++++++++++++++------------------------ src/Core/Utils.hs | 72 +++++++++++++++++++++++++++++++++++++++++ src/Core2Core.hs | 81 +++++++++++++++++++++++++++++++++++++++++++--- src/GM.hs | 30 ++++++++--------- 5 files changed, 193 insertions(+), 63 deletions(-) create mode 100644 src/Core/Utils.hs diff --git a/rlp.cabal b/rlp.cabal index 187962d..c4249e6 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -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 diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index decc325..3d0a1ca 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -3,11 +3,7 @@ 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 #-} - +{-# LANGUAGE FunctionalDependencies #-} module Core.Syntax ( Expr(..) , Literal(..) @@ -22,27 +18,24 @@ module Core.Syntax , ScDef(..) , Module(..) , Program(..) - , CoreProgram - , CoreExpr - , CoreScDef - , CoreAlter - , CoreBinding - , 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) -import Data.Functor.Foldable.TH (makeBaseFunctor) ---------------------------------------------------------------------------------- data Expr b = Var Name @@ -100,17 +93,15 @@ data Module b = Module (Maybe (Name, [Name])) (Program b) 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 +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] @@ -119,27 +110,21 @@ instance Monoid (Program b) where ---------------------------------------------------------------------------------- -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 b -> Bool -isAtomic (Var _) = True -isAtomic (LitE _) = 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 b) -> (Program b) -> (Program b) -insertModule (Module _ m) p = p <> m - -extractProgram :: (Module b) -> (Program b) -extractProgram (Module _ p) = p - ----------------------------------------------------------------------------------- - -makeBaseFunctor ''Expr +instance HasRHS (Binding b) b where + _rhs = lens + (\ (_ := e) -> e) + (\ (k := _) e' -> k := e') diff --git a/src/Core/Utils.hs b/src/Core/Utils.hs new file mode 100644 index 0000000..dd9c6ed --- /dev/null +++ b/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 + diff --git a/src/Core2Core.hs b/src/Core2Core.hs index 0a37265..1211a22 100644 --- a/src/Core2Core.hs +++ b/src/Core2Core.hs @@ -1,14 +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 = undefined +core2core :: Program' -> Program' +core2core p = undefined -floatNonStrictCase :: Expr -> Expr -floatNonStrictCase (Case e as) = Case e () +-- 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) diff --git a/src/GM.hs b/src/GM.hs index fa072d5..38d6e75 100644 --- a/src/GM.hs +++ b/src/GM.hs @@ -118,7 +118,7 @@ pure [] ---------------------------------------------------------------------------------- -evalProg :: CoreProgram -> Maybe (Node, Stats) +evalProg :: Program' -> Maybe (Node, Stats) evalProg p = res <&> (,sts) where final = eval (compile p) & last @@ -127,7 +127,7 @@ evalProg p = res <&> (,sts) resAddr = final ^. gmStack ^? _head res = resAddr >>= flip hLookup h -hdbgProg :: CoreProgram -> 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` @@ -548,7 +548,7 @@ pop [] = [] ---------------------------------------------------------------------------------- -compile :: CoreProgram -> GmState +compile :: Program' -> GmState compile p = GmState c [] [] h g sts where -- find the entry point and evaluate it @@ -575,7 +575,7 @@ compiledPrims = binop k i = (k, 2, [Push 1, Eval, Push 1, Eval, i, Update 2, Pop 2, Unwind]) -buildInitialHeap :: CoreProgram -> (GmHeap, Env) +buildInitialHeap :: Program' -> (GmHeap, Env) buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs where compiledScs = fmap compileSc ss <> compiledPrims @@ -588,20 +588,20 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs -- >> [ref/compileSc] -- type CompiledSC = (Name, Int, Code) - compileSc :: CoreScDef -> 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 -> CoreExpr -> 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 -> CoreExpr -> 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] @@ -627,7 +627,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs -- kinda gross. revisit this addressed = bs `zip` reverse [0 .. d-1] - compileBinder :: Env -> (CoreBinding, Int) -> (Env, Code) + compileBinder :: Env -> (Binding', Int) -> (Env, Code) compileBinder m (k := v, a) = (m',c) where m' = (NameKey k, a) : m @@ -645,7 +645,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs initialisers = mconcat $ compileBinder <$> addressed body = compileC g' e - compileBinder :: (CoreBinding, Int) -> Code + compileBinder :: (Binding', Int) -> Code compileBinder (_ := v, a) = compileC g' v <> [Update a] compileC _ (Con t n) = [PushConstr t n] @@ -663,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 -> CoreExpr -> Code + compileE :: Env -> Expr' -> Code compileE _ (LitE l) = compileEL l compileE g (Let NonRec bs e) = -- we use compileE instead of compileC @@ -674,7 +674,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs -- kinda gross. revisit this addressed = bs `zip` reverse [0 .. d-1] - compileBinder :: Env -> (CoreBinding, Int) -> (Env, Code) + compileBinder :: Env -> (Binding', Int) -> (Env, Code) compileBinder m (k := v, a) = (m',c) where m' = (NameKey k, a) : m @@ -695,7 +695,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs body = compileE g' e -- we use compileE instead of compileC - compileBinder :: (CoreBinding, Int) -> Code + compileBinder :: (Binding', Int) -> Code compileBinder (_ := v, a) = compileC g' v <> [Update a] -- special cases for prim functions; essentially inlining @@ -710,10 +710,10 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs compileE g e = compileC g e ++ [Eval] - compileD :: Env -> [CoreAlter] -> [(Tag, Code)] + compileD :: Env -> [Alter'] -> [(Tag, Code)] compileD g as = fmap (compileA g) as - compileA :: Env -> CoreAlter -> (Tag, Code) + compileA :: Env -> Alter' -> (Tag, Code) compileA g (Alter (AltData t) as e) = (t, [Split n] <> c <> [Slide n]) where n = length as