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

add annotation param to Expr

Browse Source 
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
This commit is contained in:
crumbtoo
2023-12-08 09:37:20 -07:00
parent a00405ebd4
commit f728b91a8a
9 changed files with 127 additions and 110 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)

2
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

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|

48
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 }
| 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
}

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

125
src/Core/Syntax.hs
View File

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

14
src/Core2Core.hs Normal file
View File

@@ -0,0 +1,14 @@
module Core2Core
(
)
where
----------------------------------------------------------------------------------
import Core.Syntax
----------------------------------------------------------------------------------
core2core :: Program -> Program
core2core = undefined
floatNonStrictCase :: Expr -> Expr
floatNonStrictCase (Case e as) = Case e ()

25
src/GM.hs
View File

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

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