diff --git a/app/Main.hs b/app/Main.hs index f18c03f..0842b59 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -44,7 +44,7 @@ options = RLPCOptions <> value EvaluatorGM <> help "the intermediate layer used to model evaluation" ) - <*> some (argument str (metavar "FILES...")) + <*> some (argument str $ metavar "FILES...") where infixr 9 # f # x = f x @@ -62,6 +62,7 @@ debugFlagReader :: ReadM DebugFlag debugFlagReader = maybeReader $ \case "dump-eval" -> Just DDumpEval "dump-opts" -> Just DDumpOpts + "dump-ast" -> Just DDumpAST _ -> Nothing ---------------------------------------------------------------------------------- @@ -79,13 +80,21 @@ main = do driver :: RLPCIO CompilerError () driver = sequence_ [ dshowFlags + , ddumpAST , ddumpEval ] dshowFlags :: RLPCIO CompilerError () dshowFlags = whenFlag flagDDumpOpts do ask >>= liftIO . print - liftIO $ exitSuccess + +ddumpAST :: RLPCIO CompilerError () +ddumpAST = whenFlag flagDDumpAST $ forFiles_ \o f -> do + liftIO $ withFile f ReadMode $ \h -> do + s <- hGetContents h + case parseProg o s of + Right (a,_) -> hPutStrLn stderr $ show a + Left e -> error "todo errors lol" ddumpEval :: RLPCIO CompilerError () ddumpEval = whenFlag flagDDumpEval do @@ -104,11 +113,6 @@ ddumpEval = whenFlag flagDDumpEval do Just f -> liftIO $ withFile f WriteMode $ dumpEval a Nothing -> liftIO $ dumpEval a stderr - parseProg :: RLPCOptions - -> String - -> Either SrcError (Program, [SrcError]) - parseProg o = evalRLPC o . (lexCore >=> parseCoreProg) - -- choose the appropriate model based on the compiler opts chooseEval = do ev <- view rlpcEvaluator @@ -117,3 +121,16 @@ ddumpEval = whenFlag flagDDumpEval do EvaluatorTI -> v TI.hdbgProg where v f p h = f p h *> pure () +parseProg :: RLPCOptions + -> String + -> Either SrcError (Program, [SrcError]) +parseProg o = evalRLPC o . (lexCore >=> parseCoreProg) + +forFiles_ :: (Monad m) + => (RLPCOptions -> FilePath -> RLPCT e m a) + -> RLPCT e m () +forFiles_ k = do + fs <- view rlpcInputFiles + o <- ask + forM_ fs (k o) + diff --git a/doc/src/references/gm-state-transitions.rst b/doc/src/references/gm-state-transitions.rst index 1c452f0..1b1e148 100644 --- a/doc/src/references/gm-state-transitions.rst +++ b/doc/src/references/gm-state-transitions.rst @@ -103,10 +103,9 @@ Core Transition Rules & m } -#. If the top of the stack is in WHNF (currently this just means a number) is on - top of the stack, :code:`Unwind` considers evaluation complete. In the case - where the dump is **not** empty, the instruction queue and stack is restored - from the top. +#. If the top of the stack is in WHNF is on top of the stack, :code:`Unwind` + considers evaluation complete. In the case where the dump is **not** empty, + the instruction queue and stack is restored from the top. .. math:: \gmrule @@ -126,6 +125,26 @@ Core Transition Rules & m } +#. Consider constructors to be in WHNF + + .. math:: + \gmrule + { \mathtt{Unwind} : \nillist + & a : s + & \langle i', s' \rangle : d + & h + \begin{bmatrix} + a : \mathtt{NConstr} \; t \; v + \end{bmatrix} + & m + } + { i' + & a : s' + & d + & h + & m + } + #. Bulding on the previous rule, in the case where the dump **is** empty, leave the machine in a halt state (i.e. with an empty instruction queue). @@ -402,7 +421,77 @@ Core Transition Rules & m } +#. Deconstruct a constructor + .. math:: + \gmrule + { \mathtt{Split} \; n : i + & a : s + & d + & h + \begin{bmatrix} + a : \mathtt{NConstr} \; t \; [a_1,\ldots,a_n] + \end{bmatrix} + & m + } + { i + & a_1 : \ldots a_n : s + & d + & h + & m + } + +#. Allow constructors to behave as functions: look a constructor up in the + environment, and if push the address if found + + .. math:: + \gmrule + { \mathtt{PushConstr} \; p_{t,n} : i + & s + & d + & h + & m + \begin{bmatrix} + p_{t,n} : a + \end{bmatrix} + } + { i + & a : s + & d + & h + & m + } + +#. Expanding upon the previous rule: in the case that no such address is found, + update the environment + + .. math:: + \gmrule + { \mathtt{PushConstr} \; p_{t,n} : i + & s + & d + & h + & m + } + { i + & a : s + & d + & h + \begin{bmatrix} + a : g_{t,n} + \end{bmatrix} + & m + \begin{bmatrix} + p_{t,n} : a + \end{bmatrix} + \\ + \SetCell[c=6]{c} + \text{where $p_{t,n}$ is a non-conflicting string rep. of + $\mathtt{Pack}\{t,n\}$,} \\ + \SetCell[c=6]{c} + \text{and $g_{t,n} = \mathtt{NGlobal} \; n \; + [\mathtt{Pack} \; t \; n, \mathtt{Update} \; 0, \mathtt{Unwind}]$} + } *************** Extension Rules @@ -436,7 +525,7 @@ Extension Rules n' : a \end{bmatrix} \\ - \SetCell[c=5]{c} + \SetCell[c=6]{c} \text{where $n'$ is the base-10 string rep. of $n$} } diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index a17b3fc..4961418 100644 --- a/src/Compiler/RLPC.hs +++ b/src/Compiler/RLPC.hs @@ -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 + diff --git a/src/Core/Lex.x b/src/Core/Lex.x index 89cbd31..d01034a 100644 --- a/src/Core/Lex.x +++ b/src/Core/Lex.x @@ -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 } } + +{ + "#-}" { 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) diff --git a/src/Core/Parse.y b/src/Core/Parse.y index ff36be7..4c04368 100644 --- a/src/Core/Parse.y +++ b/src/Core/Parse.y @@ -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 + } diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index aba8cdb..f68482b 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -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 diff --git a/src/GM.hs b/src/GM.hs index 3a2eae4..381d134 100644 --- a/src/GM.hs +++ b/src/GM.hs @@ -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 -> "" Nothing -> errTxtInvalidAddress where h = st ^. gmHeap