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

g-machine mark 1 hooray

Browse Source
This commit is contained in:
crumbtoo
2023-11-30 09:16:51 -07:00
parent 0c06550189
commit 2d62038d07
4 changed files with 73 additions and 19 deletions
Download Patch File Download Diff File Expand all files Collapse all files

38
app/Main.hs
View File

@@ -10,6 +10,7 @@ import System.IO
import System.Exit (exitSuccess)
import Core
import TIM
import GM
import Lens.Micro
import Lens.Micro.Mtl
----------------------------------------------------------------------------------
@@ -23,30 +24,46 @@ optParser = info (helper <*> options)
options :: Parser RLPCOptions
options = RLPCOptions
{- --log, -l -}
<$> optional # strOption
( long "log"
<> short 'l'
<> metavar "FILE"
<> help "output dumps to FILE. stderr is used by default"
)
-- temp. i want gcc/ghc style options
{- -d -}
<*> fmap S.fromList # many # option debugFlagReader
( short 'd'
<> help "dump evaluation logs"
<> metavar "DEBUG FLAG"
)
{- --evaluator, -e -}
<*> option evaluatorReader
( long "evaluator"
<> short 'e'
<> metavar "gm|tim"
<> value EvaluatorGM
<> help "the intermediate layer used to model evaluation"
)
<*> some (argument str (metavar "FILES..."))
where
infixr 9 #
f # x = f x
evaluatorReader :: ReadM Evaluator
evaluatorReader = maybeReader $ \case
"gm" -> Just EvaluatorGM
"tim" -> Just EvaluatorTIM
_ -> Nothing
mmany :: (Alternative f, Monoid m) => f m -> f m
mmany v = liftA2 (<>) v (mmany v)
debugFlagReader :: ReadM DebugFlag
debugFlagReader = maybeReader $ Just . \case
"dump-eval" -> DDumpEval
"dump-opts" -> DDumpOpts
debugFlagReader = maybeReader $ \case
"dump-eval" -> Just DDumpEval
"dump-opts" -> Just DDumpOpts
_ -> Nothing
----------------------------------------------------------------------------------
@@ -83,12 +100,21 @@ ddumpEval = whenFlag flagDDumpEval do
Left e -> addFatal . CompilerError $ show e
Right (a,_) -> do
log <- view rlpcLogFile
dumpEval <- chooseEval
case log of
Just f -> void . liftIO $ withFile f WriteMode $ hdbgProg a
Nothing -> void . liftIO $ hdbgProg a stderr
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
pure $ case ev of
EvaluatorGM -> v GM.hdbgProg
EvaluatorTIM -> v TIM.hdbgProg
where v f p h = f p h *> pure ()

7
src/Compiler/RLPC.hs
View File

@@ -17,11 +17,13 @@ module Compiler.RLPC
, addWound
, MonadErrorful
, Severity(..)
, Evaluator(..)
, evalRLPCT
, evalRLPCIO
, evalRLPC
, rlpcLogFile
, rlpcDebugOpts
, rlpcEvaluator
, rlpcInputFiles
, DebugFlag(..)
, whenFlag
@@ -80,10 +82,14 @@ evalRLPCIO o m = do
data RLPCOptions = RLPCOptions
{ _rlpcLogFile :: Maybe FilePath
, _rlpcDebugOpts :: DebugOpts
, _rlpcEvaluator :: Evaluator
, _rlpcInputFiles :: [FilePath]
}
deriving Show
data Evaluator = EvaluatorGM | EvaluatorTIM
deriving Show
data Severity = Error
| Warning
| Debug
@@ -105,6 +111,7 @@ instance Default RLPCOptions where
def = RLPCOptions
{ _rlpcLogFile = Nothing
, _rlpcDebugOpts = mempty
, _rlpcEvaluator = EvaluatorGM
, _rlpcInputFiles = []
}

7
src/Core/Examples.hs
View File

@@ -110,6 +110,13 @@ listExample3 = [coreProg|
main = foldr (+#) 0 list;
|]
simple1 = [coreProg|
k a b = a;
s f g x = f x (g x);
main = s k k 3;
|]
corePrelude :: Module
corePrelude = Module (Just ("Prelude", [])) $
-- non-primitive defs

40
src/GM.hs
View File

@@ -6,7 +6,7 @@ Description : The G-Machine
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module GM
(
( hdbgProg
)
where
----------------------------------------------------------------------------------
@@ -19,6 +19,8 @@ import Lens.Micro.TH
import Text.Printf
import Text.PrettyPrint hiding ((<>))
import Text.PrettyPrint.HughesPJ (maybeParens)
import Data.Foldable (traverse_)
import System.IO (Handle, hPutStrLn)
import Data.Heap
import Core
----------------------------------------------------------------------------------
@@ -72,6 +74,21 @@ pure []
----------------------------------------------------------------------------------
hdbgProg :: Program -> Handle -> IO (Node, Stats)
hdbgProg p hio = do
(renderOut . showState) `traverse_` p'
renderOut . showStats $ sts
pure (res, sts)
where
renderOut r = hPutStrLn hio $ render r ++ "\n"
p' = eval $ compile p
final = last p'
sts = final ^. gmStats
[resAddr] = final ^. gmStack
res = hLookupUnsafe resAddr h
h = final ^. gmHeap
eval :: GmState -> [GmState]
eval st = st : rest
where
@@ -139,20 +156,18 @@ step st = case head (st ^. gmCode) of
s = st ^. gmStack
h = st ^. gmHeap
s' = an : s
an = s !! (n+1)
an' = getArg an
getArg (hViewUnsafe h -> NAp _ a) = a
s' = arg : s
argAp = s !! (n+1)
arg = case hLookupUnsafe argAp h of
NAp _ a -> a
slide :: Int -> GmState -> GmState
slide n st = st
& gmCode %~ drop 1
& gmStack .~ s'
where
s = st ^. gmStack
a0 = head s
s' = a0 : drop n s
(a:s) = st ^. gmStack
s' = a : drop n s
unwind :: GmState -> GmState
unwind st = case hLookupUnsafe a h of
@@ -162,6 +177,7 @@ step st = case head (st ^. gmCode) of
NAp f x -> st
-- leave the Unwind instr; continue unwinding
& gmStack %~ (f:)
-- assumes length s < d (i.e. enough args have been supplied)
NGlobal d c -> st
-- 'jump' to global's code by replacing our current
-- code with `c`
@@ -235,9 +251,6 @@ pprTabstop = 4
qquotes :: Doc -> Doc
qquotes d = "`" <> d <> "'"
showResults :: [GmState] -> String
showResults st = undefined
showStats :: Stats -> Doc
showStats sts = "==== Stats ============" $$ stats
where
@@ -316,7 +329,8 @@ showNodeAtP p st a = case hLookup a h of
where
g = st ^. gmEnv
name = fromMaybe "<unknown>" $ lookup a (swap <$> g)
Just (NAp f x) -> showNodeAtP (p+1) st f <+> showNodeAtP (p+1) st x
Just (NAp f x) -> pprec $ showNodeAtP (p+1) st f <+> showNodeAtP (p+1) st x
where pprec = maybeParens (p > 0)
Nothing -> "<invalid address>"
where h = st ^. gmHeap