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

oh boy (pack)

Browse Source
This commit is contained in:
crumbtoo
2023-12-06 15:29:03 -07:00
parent 87d3aac1fb
commit 07c3064a72
7 changed files with 231 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files

18
src/Compiler/RLPC.hs
View File

@@ -6,7 +6,10 @@ This module implements the toolset common to the entire compiler, most notably
errors and the family of RLPC monads.
-}
{-# LANGUAGE GeneralisedNewtypeDeriving, StandaloneDeriving #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
-- only used for mtl instances
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
module Compiler.RLPC
( RLPC
@@ -29,12 +32,15 @@ module Compiler.RLPC
, whenFlag
, flagDDumpEval
, flagDDumpOpts
, flagDDumpAST
, def
)
where
----------------------------------------------------------------------------------
import Control.Arrow ((>>>))
import Control.Monad.Reader
import Control.Monad.State (MonadState(state))
import Control.Monad.Errorful
import Data.Functor.Identity
import Data.Default.Class
@@ -51,10 +57,18 @@ import Lens.Micro.TH
newtype RLPCT e m a = RLPCT {
runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a
}
-- TODO: incorrect ussage of MonadReader. RLPC should have its own
-- environment access functions
deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
deriving instance (MonadIO m) => MonadIO (RLPCT e m)
instance MonadTrans (RLPCT e) where
lift = RLPCT . lift . lift
instance (MonadState s m) => MonadState s (RLPCT e m) where
state = lift . state
type RLPC e = RLPCT e Identity
type RLPCIO e = RLPCT e IO
@@ -119,6 +133,7 @@ type DebugOpts = HashSet DebugFlag
data DebugFlag = DDumpEval
| DDumpOpts
| DDumpAST
deriving (Show, Eq, Generic)
-- deriving (Hashable)
@@ -143,3 +158,6 @@ flagDDumpEval = flagGetter DDumpEval
flagDDumpOpts :: SimpleGetter RLPCOptions Bool
flagDDumpOpts = flagGetter DDumpOpts
flagDDumpAST :: SimpleGetter RLPCOptions Bool
flagDDumpAST = flagGetter DDumpAST

19
src/Core/Lex.x
View File

@@ -42,6 +42,7 @@ $octit = 0-7
$hexit = [0-9 A-F a-f]
$namechar = [$alpha $digit \' \#]
$symchar = [$symbol \:]
$nonwhite = $printable # $white
$nl = [\n\r]
$white_no_nl = $white # $nl
@@ -68,6 +69,7 @@ rlp :-
"}" { constTok TokenRBrace }
";" { constTok TokenSemicolon }
"," { constTok TokenComma }
"{-#" { constTok TokenLPragma `andBegin` pragma }
"let" { constTok TokenLet }
"letrec" { constTok TokenLetrec }
@@ -94,6 +96,19 @@ rlp :-
\n { skip }
}
<pragma>
{
"#-}" { constTok TokenRPragma `andBegin` 0 }
"{" { constTok TokenLBrace }
"}" { constTok TokenRBrace }
";" { constTok TokenSemicolon }
$white { skip }
\n { skip }
$nonwhite+ { lexWith TokenWord }
}
{
data Located a = Located Int Int Int a
deriving Show
@@ -123,6 +138,9 @@ data CoreToken = TokenLet
| TokenLBrace
| TokenRBrace
| TokenSemicolon
| TokenLPragma
| TokenRPragma
| TokenWord String
| TokenEOF
deriving Show
@@ -135,6 +153,7 @@ data SrcError = SrcError
data SrcErrorType = SrcErrLexical String
| SrcErrParse
| SrcErrUnknownPragma Name
deriving Show
type Lexer = AlexInput -> Int -> Alex (Located CoreToken)

24
src/Core/Parse.y
View File

@@ -44,6 +44,7 @@ import Data.Default.Class (def)
varsym { Located _ _ _ (TokenVarSym $$) }
conname { Located _ _ _ (TokenConName $$) }
consym { Located _ _ _ (TokenConSym $$) }
word { Located _ _ _ (TokenWord $$) }
'λ' { Located _ _ _ TokenLambda }
'->' { Located _ _ _ TokenArrow }
'=' { Located _ _ _ TokenEquals }
@@ -51,6 +52,8 @@ import Data.Default.Class (def)
')' { Located _ _ _ TokenRParen }
'{' { Located _ _ _ TokenLBrace }
'}' { Located _ _ _ TokenRBrace }
'{-#' { Located _ _ _ TokenLPragma }
'#-}' { Located _ _ _ TokenRPragma }
';' { Located _ _ _ TokenSemicolon }
eof { Located _ _ _ TokenEOF }
@@ -122,8 +125,16 @@ Expr1 :: { Expr }
Expr1 : litint { IntE $1 }
| Id { Var $1 }
| PackCon { $1 }
| ExprPragma { $1 }
| '(' Expr ')' { $2 }
ExprPragma :: { Expr }
ExprPragma : '{-#' Words '#-}' {% exprPragma $2 }
Words :: { [String] }
Words : word Words { $1 : $2 }
| word { [$1] }
PackCon :: { Expr }
PackCon : pack '{' litint ',' litint '}' { Con $3 $5 }
@@ -148,6 +159,7 @@ Con : '(' consym ')' { $2 }
| conname { $1 }
{
parseError :: [Located CoreToken] -> RLPC SrcError a
parseError (Located y x l _ : _) = addFatal err
where err = SrcError
@@ -165,5 +177,17 @@ parseTmp = do
where
parse = evalRLPC def . (lexCore >=> parseCore)
exprPragma :: [String] -> RLPC SrcError Expr
exprPragma ("AST" : e) = astPragma e
exprPragma _ = addFatal err
where err = SrcError
{ _errSpan = (0,0,0) -- TODO: span
, _errSeverity = Warning
, _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma
}
astPragma :: [String] -> RLPC SrcError Expr
astPragma = pure . read . unwords
}

8
src/Core/Syntax.hs
View File

@@ -38,7 +38,7 @@ data Expr = Var Name
| Lam [Name] Expr
| App Expr Expr
| IntE Int
deriving (Show, Lift, Eq)
deriving (Show, Read, Lift, Eq)
infixl 2 :$
pattern (:$) :: Expr -> Expr -> Expr
@@ -47,7 +47,7 @@ pattern f :$ x = App f x
{-# COMPLETE Binding :: Binding #-}
{-# COMPLETE (:=) :: Binding #-}
data Binding = Binding Name Expr
deriving (Show, Lift, Eq)
deriving (Show, Read, Lift, Eq)
infixl 1 :=
pattern (:=) :: Name -> Expr -> Binding
@@ -55,10 +55,10 @@ pattern k := v = Binding k v
data Rec = Rec
| NonRec
deriving (Show, Eq, Lift)
deriving (Show, Read, Eq, Lift)
data Alter = Alter Tag [Name] Expr
deriving (Show, Lift, Eq)
deriving (Show, Read, Lift, Eq)
type Name = String
type Tag = Int

55
src/GM.hs
View File

@@ -163,8 +163,18 @@ step st = case head (st ^. gmCode) of
Mul -> mulI
Div -> divI
Split n -> splitI n
Pack t n -> packI t n
where
packI :: Tag -> Int -> GmState
packI t n = st
& advanceCode
& gmStack %~ (a:)
& gmHeap .~ h'
where
(as,s) = splitAt n (st ^. gmStack)
(h',a) = alloc (st ^. gmHeap) $ NConstr t as
pushGlobalI :: Name -> GmState
pushGlobalI k = st
& advanceCode
@@ -178,7 +188,23 @@ step st = case head (st ^. gmCode) of
& fromMaybe (error $ "undefined var: " <> show k)
pushConstrI :: Tag -> Int -> GmState
pushConstrI = undefined
pushConstrI t n = st
& advanceCode
& gmStack %~ (a:)
& gmEnv .~ m'
& gmHeap .~ h'
where
s = st ^. gmStack
m = st ^. gmEnv
h = st ^. gmHeap
(a,m',h') = case lookupC t n m of
-- address found in env; no need to update env or heap
Just aa -> (aa,m,h)
Nothing -> (aa,mm,hh)
where
(hh,aa) = alloc h (NGlobal n c)
c = [Pack t n, Update 0, Unwind]
mm = (ConstrKey t n, aa) : m
-- Extension Rules 1,2 (sharing)
pushIntI :: Int -> GmState
@@ -339,6 +365,19 @@ step st = case head (st ^. gmCode) of
-- leave the stack as is
[] -> ([], s, [])
NConstr t n -> st
& gmCode .~ i'
& gmStack .~ s'
& gmDump .~ d'
where
(i',s',d') = case st ^. gmDump of
-- if the dump is non-empty, restore the instruction
-- queue and stack, and pop the dump
((ii,ss):d) -> (ii,a:ss,d)
-- if the dump is empty, clear the instruction queue and
-- leave the stack as is
[] -> ([], s, [])
NAp f _ -> st
-- leave the Unwind instr; continue unwinding
& gmStack %~ (f:)
@@ -537,8 +576,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
compileBinder (_ := v, a) = compileC g' v <> [Update a]
-- kinda evil; better system eventually
compileC g (Con t n) = [PushGlobal p]
where p = idPack t n
compileC g (Con t n) = [PushConstr t n]
compileC _ _ = error "yet to be implemented!"
@@ -607,8 +645,8 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
argOffset :: Int -> Env -> Env
argOffset n = each . _2 %~ (+n)
idPack :: Tag -> Int -> String
idPack t n = printf "Pack{%d,%d}" t n
idPack :: Tag -> Int -> String
idPack t n = printf "Pack{%d,%d}" t n
----------------------------------------------------------------------------------
@@ -728,12 +766,15 @@ showNodeAtP p st a = case hLookup a h of
where
g = st ^. gmEnv
name = case lookup a (swap <$> g) of
Just (NameKey n) -> n
_ -> errTxtInvalidAddress
Just (NameKey n) -> n
Just (ConstrKey t n) -> idPack t n
_ -> errTxtInvalidAddress
Just (NAp f x) -> pprec $ showNodeAtP (p+1) st f <+> showNodeAtP (p+1) st x
where pprec = maybeParens (p > 0)
Just (NInd a') -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a'
where pprec = maybeParens (p > 0)
Just (NConstr t as) -> pprec $ "NConstr" <+> int t <+> text (show as)
where pprec = maybeParens (p > 0)
Just NUninitialised -> "<uninitialised>"
Nothing -> errTxtInvalidAddress
where h = st ^. gmHeap