From f728b91a8a67f982bac536dea535e0c11e74b3ef Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Fri, 8 Dec 2023 09:37:20 -0700 Subject: [PATCH] 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 +--} +