From 5172c1b41ad073db666bf2a68d3629c858a00afd Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Mon, 5 Feb 2024 11:36:06 +0100 Subject: [PATCH 01/11] implement monadic evaluator for Juvix Tree --- src/Juvix/Compiler/Tree/SemEvaluator.hs | 398 ++++++++++++++++++++++++ 1 file changed, 398 insertions(+) create mode 100644 src/Juvix/Compiler/Tree/SemEvaluator.hs diff --git a/src/Juvix/Compiler/Tree/SemEvaluator.hs b/src/Juvix/Compiler/Tree/SemEvaluator.hs new file mode 100644 index 0000000000..674afe9606 --- /dev/null +++ b/src/Juvix/Compiler/Tree/SemEvaluator.hs @@ -0,0 +1,398 @@ +module Juvix.Compiler.Tree.SemEvaluator where + +import Control.Exception qualified as Exception +import GHC.Show qualified as S +import Juvix.Compiler.Core.Data.BinderList qualified as BL +import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Error +import Juvix.Compiler.Tree.Extra.Base +import Juvix.Compiler.Tree.Language +import Juvix.Compiler.Tree.Language.Value +import Juvix.Compiler.Tree.Pretty +import Text.Read qualified as T + +data EvalError = EvalError + { _evalErrorLocation :: Maybe Location, + _evalErrorMsg :: Text + } + +data EvalCtx = EvalCtx + { _evalCtxArgs :: [Value], + _evalCtxTemp :: BL.BinderList Value + } + +makeLenses ''EvalCtx +makeLenses ''EvalError + +instance Show EvalError where + show :: EvalError -> String + show EvalError {..} = + "evaluation error: " + ++ fromText _evalErrorMsg + +instance Exception.Exception EvalError + +emptyEvalCtx :: EvalCtx +emptyEvalCtx = + EvalCtx + { _evalCtxArgs = [], + _evalCtxTemp = mempty + } + +eval :: (Members '[Output Value, Error EvalError] r) => InfoTable -> Node -> Sem r Value +eval tab = runReader emptyEvalCtx . eval' + where + eval' :: forall r'. (Members '[Output Value, Reader EvalCtx, Error EvalError] r') => Node -> Sem r' Value + eval' node = case node of + Binop x -> goBinop x + Unop x -> goUnop x + Const c -> return (goConstant c) + MemRef x -> goMemRef x + AllocConstr x -> goAllocConstr x + AllocClosure x -> goAllocClosure x + ExtendClosure x -> goExtendClosure x + Call x -> goCall x + CallClosures x -> goCallClosures x + Branch x -> goBranch x + Case x -> goCase x + Save x -> goSave x + where + evalError :: Text -> Sem r' a + evalError msg = + Exception.throw (EvalError (getNodeLocation node) msg) + + goBinop :: NodeBinop -> Sem r' Value + goBinop NodeBinop {..} = do + arg1 <- eval' _nodeBinopArg1 + arg2 <- eval' _nodeBinopArg2 + case _nodeBinopOpcode of + IntAdd -> goIntBinop (+) arg1 arg2 + IntSub -> goIntBinop (-) arg1 arg2 + IntMul -> goIntBinop (*) arg1 arg2 + IntDiv + | arg2 == ValInteger 0 -> evalError "division by zero" + | otherwise -> goIntBinop quot arg1 arg2 + IntMod + | arg2 == ValInteger 0 -> evalError "division by zero" + | otherwise -> goIntBinop rem arg1 arg2 + IntLe -> goIntCmpBinop (<=) arg1 arg2 + IntLt -> goIntCmpBinop (<) arg1 arg2 + ValEq -> return (ValBool (arg1 == arg2)) + StrConcat -> goStrConcat arg1 arg2 + OpSeq -> return arg2 + + goIntBinop :: (Integer -> Integer -> Integer) -> Value -> Value -> Sem r' Value + goIntBinop f v1 v2 = case (v1, v2) of + (ValInteger i1, ValInteger i2) -> return (ValInteger (f i1 i2)) + _ -> evalError "expected two integer arguments" + + goIntCmpBinop :: (Integer -> Integer -> Bool) -> Value -> Value -> Sem r' Value + goIntCmpBinop f v1 v2 = case (v1, v2) of + (ValInteger i1, ValInteger i2) -> return (ValBool (f i1 i2)) + _ -> evalError "expected two integer arguments" + + goStrConcat :: Value -> Value -> Sem r' Value + goStrConcat v1 v2 = case (v1, v2) of + (ValString s1, ValString s2) -> return (ValString (s1 <> s2)) + _ -> evalError "expected two string arguments" + + goUnop :: NodeUnop -> Sem r' Value + goUnop NodeUnop {..} = do + v <- eval' _nodeUnopArg + case _nodeUnopOpcode of + OpShow -> return (ValString (printValue tab v)) + OpStrToInt -> goStringUnop strToInt v + OpTrace -> goTrace v + OpFail -> goFail v + OpArgsNum -> goArgsNum v + + strToInt :: Text -> Sem r' Value + strToInt s = case T.readMaybe (fromText s) of + Just i -> return (ValInteger i) + Nothing -> evalError "string to integer: not an integer" + + goStringUnop :: (Text -> Sem r' Value) -> Value -> Sem r' Value + goStringUnop f = \case + ValString s -> f s + _ -> evalError "expected a string argument" + + goFail :: Value -> Sem r' Value + goFail v = evalError ("failure: " <> printValue tab v) + + goArgsNum :: Value -> Sem r' Value + goArgsNum = \case + ValClosure Closure {..} -> return (ValInteger (fromIntegral argsNum)) + where + fi = lookupFunInfo tab _closureSymbol + argsNum = fi ^. functionArgsNum - length _closureArgs + _ -> + evalError "expected a closure" + + goTrace :: Value -> Sem r' Value + goTrace v = output v $> v + + goConstant :: NodeConstant -> Value + goConstant NodeConstant {..} = case _nodeConstant of + ConstInt i -> ValInteger i + ConstBool b -> ValBool b + ConstString s -> ValString s + ConstUnit -> ValUnit + ConstVoid -> ValVoid + + askTemp :: Sem r' (BL.BinderList Value) + askTemp = asks (^. evalCtxTemp) + + askArgs :: Sem r' [Value] + askArgs = asks (^. evalCtxArgs) + + goMemRef :: NodeMemRef -> Sem r' Value + goMemRef NodeMemRef {..} = case _nodeMemRef of + DRef r -> goDirectRef r + ConstrRef r -> goField r + + goDirectRef :: DirectRef -> Sem r' Value + goDirectRef = \case + ArgRef OffsetRef {..} -> + (!! _offsetRefOffset) <$> askArgs + TempRef RefTemp {_refTempOffsetRef = OffsetRef {..}} -> + BL.lookupLevel _offsetRefOffset <$> askTemp + + goField :: Field -> Sem r' Value + goField Field {..} = do + d <- goDirectRef _fieldRef + case d of + ValConstr Constr {..} -> return (_constrArgs !! _fieldOffset) + _ -> evalError "expected a constructor" + + goAllocConstr :: NodeAllocConstr -> Sem r' Value + goAllocConstr NodeAllocConstr {..} = do + vs <- mapM eval' _nodeAllocConstrArgs + return + ( ValConstr + Constr + { _constrTag = _nodeAllocConstrTag, + _constrArgs = vs + } + ) + + goAllocClosure :: NodeAllocClosure -> Sem r' Value + goAllocClosure NodeAllocClosure {..} = do + vs <- mapM eval' _nodeAllocClosureArgs + return + ( ValClosure + Closure + { _closureSymbol = _nodeAllocClosureFunSymbol, + _closureArgs = vs + } + ) + + goExtendClosure :: NodeExtendClosure -> Sem r' Value + goExtendClosure NodeExtendClosure {..} = do + fun <- eval' _nodeExtendClosureFun + case fun of + ValClosure Closure {..} -> do + vs <- mapM eval' (toList _nodeExtendClosureArgs) + return + ( ValClosure + Closure + { _closureSymbol, + _closureArgs = _closureArgs ++ vs + } + ) + _ -> evalError "expected a closure" + + goCall :: NodeCall -> Sem r' Value + goCall NodeCall {..} = case _nodeCallType of + CallFun sym -> doCall sym [] _nodeCallArgs + CallClosure cl -> doCallClosure cl _nodeCallArgs + + withCtx :: EvalCtx -> Sem r' a -> Sem r' a + withCtx = local . const + + doCall :: Symbol -> [Value] -> [Node] -> Sem r' Value + doCall sym clArgs as = do + vs <- mapM eval' as + let fi = lookupFunInfo tab sym + vs' = clArgs ++ vs + in if + | length vs' == fi ^. functionArgsNum -> do + let ctx' = + EvalCtx + { _evalCtxArgs = vs', + _evalCtxTemp = mempty + } + withCtx ctx' (eval' (fi ^. functionCode)) + | otherwise -> + evalError "wrong number of arguments" + + doCallClosure :: Node -> [Node] -> Sem r' Value + doCallClosure cl cargs = do + cl' <- eval' cl + case cl' of + ValClosure Closure {..} -> + doCall _closureSymbol _closureArgs cargs + _ -> + evalError "expected a closure" + + goCallClosures :: NodeCallClosures -> Sem r' Value + goCallClosures NodeCallClosures {..} = do + vs <- mapM eval' (toList _nodeCallClosuresArgs) + cl' <- eval' _nodeCallClosuresFun + go cl' vs + where + go :: Value -> [Value] -> Sem r' Value + go cl vs = case cl of + ValClosure Closure {..} + | argsNum == n -> do + let ctx' = + EvalCtx + { _evalCtxArgs = vs', + _evalCtxTemp = mempty + } + withCtx ctx' (eval' body) + | argsNum < n -> do + let ctx' = + EvalCtx + { _evalCtxArgs = take argsNum vs', + _evalCtxTemp = mempty + } + + body' <- withCtx ctx' (eval' body) + go body' (drop argsNum vs') + | otherwise -> + return + ( ValClosure + Closure + { _closureSymbol, + _closureArgs = vs' + } + ) + where + fi = lookupFunInfo tab _closureSymbol + argsNum = fi ^. functionArgsNum + vs' = _closureArgs ++ vs + n = length vs' + body = fi ^. functionCode + _ -> + evalError "expected a closure" + + goBranch :: NodeBranch -> Sem r' Value + goBranch NodeBranch {..} = do + arg' <- eval' _nodeBranchArg + br <- case arg' of + ValBool True -> return _nodeBranchTrue + ValBool False -> return _nodeBranchFalse + _ -> evalError "expected a boolean" + eval' br + + goCase :: NodeCase -> Sem r' Value + goCase NodeCase {..} = do + arg' <- eval' _nodeCaseArg + case arg' of + v@(ValConstr Constr {..}) -> + case find (\CaseBranch {..} -> _caseBranchTag == _constrTag) _nodeCaseBranches of + Just CaseBranch {..} -> goCaseBranch v _caseBranchSave _caseBranchBody + Nothing -> do + def <- maybe (evalError "no matching branch") return _nodeCaseDefault + goCaseBranch v False def + _ -> + evalError "expected a constructor" + + withExtendedTemp :: Value -> Sem r' a -> Sem r' a + withExtendedTemp v m = do + ctx <- ask + withCtx (over evalCtxTemp (BL.cons v) ctx) m + + goCaseBranch :: Value -> Bool -> Node -> Sem r' Value + goCaseBranch v bSave body + | bSave = withExtendedTemp v (eval' body) + | otherwise = eval' body + + goSave :: NodeSave -> Sem r' Value + goSave NodeSave {..} = do + v <- eval' _nodeSaveArg + withExtendedTemp v (eval' _nodeSaveBody) + +printValue :: InfoTable -> Value -> Text +printValue tab = \case + ValString s -> s + v -> ppPrint tab v + +valueToNode :: Value -> Node +valueToNode = \case + ValInteger i -> mkConst $ ConstInt i + ValBool b -> mkConst $ ConstBool b + ValString s -> mkConst $ ConstString s + ValUnit -> mkConst ConstUnit + ValVoid -> mkConst ConstVoid + ValConstr Constr {..} -> + AllocConstr + NodeAllocConstr + { _nodeAllocConstrInfo = mempty, + _nodeAllocConstrTag = _constrTag, + _nodeAllocConstrArgs = map valueToNode _constrArgs + } + ValClosure Closure {..} -> + AllocClosure + NodeAllocClosure + { _nodeAllocClosureInfo = mempty, + _nodeAllocClosureFunSymbol = _closureSymbol, + _nodeAllocClosureArgs = map valueToNode _closureArgs + } + +-- hEvalIO :: (MonadIO m) => Handle -> Handle -> InfoTable -> FunctionInfo -> m Value +-- hEvalIO hin hout infoTable funInfo = do +-- let !v = hEval hout infoTable (funInfo ^. functionCode) +-- hRunIO hin hout infoTable v + +-- | Interpret IO actions. +hRunIO :: forall m. (MonadIO m) => Handle -> Handle -> InfoTable -> Value -> m Value +hRunIO hin hout infoTable = \case + ValConstr (Constr (BuiltinTag TagReturn) [x]) -> return x + ValConstr (Constr (BuiltinTag TagBind) [x, f]) -> do + x' <- hRunIO hin hout infoTable x + let code = + CallClosures + NodeCallClosures + { _nodeCallClosuresInfo = mempty, + _nodeCallClosuresFun = valueToNode f, + _nodeCallClosuresArgs = valueToNode x' :| [] + } + let handleTrace = embed @m . liftIO . hPutStrLn hout . printValue infoTable + res <- + runM + . runError @EvalError + . runOutputSem handleTrace + $ eval infoTable code + let err :: EvalError -> m a + err e = do + liftIO (hPrint @Text stderr (show e)) + liftIO exitFailure + x'' <- either err return res + hRunIO hin hout infoTable x'' + ValConstr (Constr (BuiltinTag TagWrite) [ValString s]) -> do + liftIO $ hPutStr hout s + return ValVoid + ValConstr (Constr (BuiltinTag TagWrite) [arg]) -> do + liftIO $ hPutStr hout (ppPrint infoTable arg) + return ValVoid + ValConstr (Constr (BuiltinTag TagReadLn) []) -> do + liftIO $ hFlush hout + s <- liftIO $ hGetLine hin + return (ValString s) + val -> + return val + +-- | Catch EvalError and convert it to TreeError. +catchEvalErrorIO :: IO a -> IO (Either TreeError a) +catchEvalErrorIO ma = + Exception.catch + (Exception.evaluate ma >>= \ma' -> Right <$> ma') + (\(ex :: EvalError) -> return (Left (toTreeError ex))) + +toTreeError :: EvalError -> TreeError +toTreeError EvalError {..} = + TreeError + { _treeErrorMsg = "evaluation error: " <> _evalErrorMsg, + _treeErrorLoc = _evalErrorLocation + } From 6a7b1b75d4e66d9d9645a94c3d26e15e293e07ca Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Mon, 5 Feb 2024 12:38:45 +0100 Subject: [PATCH 02/11] add doEvalSem to app TreeEvaluator --- app/TreeEvaluator.hs | 10 ++++- src/Juvix/Compiler/Tree/SemEvaluator.hs | 55 +++++++++++-------------- 2 files changed, 32 insertions(+), 33 deletions(-) diff --git a/app/TreeEvaluator.hs b/app/TreeEvaluator.hs index 08d21dade9..f6bab31db9 100644 --- a/app/TreeEvaluator.hs +++ b/app/TreeEvaluator.hs @@ -7,12 +7,13 @@ import Juvix.Compiler.Tree.Error qualified as Tree import Juvix.Compiler.Tree.Evaluator qualified as Tree import Juvix.Compiler.Tree.Language.Value qualified as Tree import Juvix.Compiler.Tree.Pretty qualified as Tree +import Juvix.Compiler.Tree.SemEvaluator qualified as TreeSem evalTree :: forall r. (Members '[Embed IO, App] r) => Tree.InfoTable -> Sem r () evalTree tab = case tab ^. Tree.infoMainFunction of Just sym -> do - r <- liftIO $ doEval tab (Tree.lookupFunInfo tab sym) + r <- doEvalSem tab (Tree.lookupFunInfo tab sym) case r of Left err -> exitJuvixError (JuvixError err) @@ -31,3 +32,10 @@ doEval :: m (Either Tree.TreeError Tree.Value) doEval tab' funInfo = liftIO $ Tree.catchEvalErrorIO (liftIO $ Tree.hEvalIO stdin stdout tab' funInfo) + +doEvalSem :: + (MonadIO m) => + Tree.InfoTable -> + Tree.FunctionInfo -> + m (Either Tree.TreeError Tree.Value) +doEvalSem tab' funInfo = TreeSem.hEvalIOEither stdin stdout tab' funInfo diff --git a/src/Juvix/Compiler/Tree/SemEvaluator.hs b/src/Juvix/Compiler/Tree/SemEvaluator.hs index 674afe9606..6037fa8871 100644 --- a/src/Juvix/Compiler/Tree/SemEvaluator.hs +++ b/src/Juvix/Compiler/Tree/SemEvaluator.hs @@ -1,36 +1,22 @@ module Juvix.Compiler.Tree.SemEvaluator where import Control.Exception qualified as Exception -import GHC.Show qualified as S import Juvix.Compiler.Core.Data.BinderList qualified as BL import Juvix.Compiler.Tree.Data.InfoTable import Juvix.Compiler.Tree.Error +import Juvix.Compiler.Tree.Evaluator (EvalError (..)) import Juvix.Compiler.Tree.Extra.Base import Juvix.Compiler.Tree.Language import Juvix.Compiler.Tree.Language.Value import Juvix.Compiler.Tree.Pretty import Text.Read qualified as T -data EvalError = EvalError - { _evalErrorLocation :: Maybe Location, - _evalErrorMsg :: Text - } - data EvalCtx = EvalCtx { _evalCtxArgs :: [Value], _evalCtxTemp :: BL.BinderList Value } makeLenses ''EvalCtx -makeLenses ''EvalError - -instance Show EvalError where - show :: EvalError -> String - show EvalError {..} = - "evaluation error: " - ++ fromText _evalErrorMsg - -instance Exception.Exception EvalError emptyEvalCtx :: EvalCtx emptyEvalCtx = @@ -340,13 +326,28 @@ valueToNode = \case _nodeAllocClosureArgs = map valueToNode _closureArgs } --- hEvalIO :: (MonadIO m) => Handle -> Handle -> InfoTable -> FunctionInfo -> m Value --- hEvalIO hin hout infoTable funInfo = do --- let !v = hEval hout infoTable (funInfo ^. functionCode) --- hRunIO hin hout infoTable v +hEvalIOEither :: + forall m. + (MonadIO m) => + Handle -> + Handle -> + InfoTable -> + FunctionInfo -> + m (Either TreeError Value) +hEvalIOEither hin hout infoTable funInfo = do + let x = do + v <- eval infoTable (funInfo ^. functionCode) + hRunIO hin hout infoTable v + let handleTrace = liftIO . hPutStrLn hout . printValue infoTable + liftIO + . runM + . runError @TreeError + . mapError toTreeError + . runOutputSem handleTrace + $ x -- | Interpret IO actions. -hRunIO :: forall m. (MonadIO m) => Handle -> Handle -> InfoTable -> Value -> m Value +hRunIO :: forall r. (Members '[Embed IO, Error EvalError, Output Value] r) => Handle -> Handle -> InfoTable -> Value -> Sem r Value hRunIO hin hout infoTable = \case ValConstr (Constr (BuiltinTag TagReturn) [x]) -> return x ValConstr (Constr (BuiltinTag TagBind) [x, f]) -> do @@ -358,18 +359,8 @@ hRunIO hin hout infoTable = \case _nodeCallClosuresFun = valueToNode f, _nodeCallClosuresArgs = valueToNode x' :| [] } - let handleTrace = embed @m . liftIO . hPutStrLn hout . printValue infoTable - res <- - runM - . runError @EvalError - . runOutputSem handleTrace - $ eval infoTable code - let err :: EvalError -> m a - err e = do - liftIO (hPrint @Text stderr (show e)) - liftIO exitFailure - x'' <- either err return res - hRunIO hin hout infoTable x'' + res <- eval infoTable code + hRunIO hin hout infoTable res ValConstr (Constr (BuiltinTag TagWrite) [ValString s]) -> do liftIO $ hPutStr hout s return ValVoid From 52215b631a8a98e07b04aced65f37cb5ea832f19 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Tue, 6 Feb 2024 13:38:47 +0100 Subject: [PATCH 03/11] evaluator without bangs --- app/TreeEvaluator.hs | 9 + src/Juvix/Compiler/Tree/Evaluator.hs | 22 +- src/Juvix/Compiler/Tree/EvaluatorBangs.hs | 340 ++++++++++++++++++++++ 3 files changed, 360 insertions(+), 11 deletions(-) create mode 100644 src/Juvix/Compiler/Tree/EvaluatorBangs.hs diff --git a/app/TreeEvaluator.hs b/app/TreeEvaluator.hs index f6bab31db9..5f910ad223 100644 --- a/app/TreeEvaluator.hs +++ b/app/TreeEvaluator.hs @@ -5,6 +5,7 @@ import CommonOptions import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree import Juvix.Compiler.Tree.Error qualified as Tree import Juvix.Compiler.Tree.Evaluator qualified as Tree +import Juvix.Compiler.Tree.EvaluatorBangs qualified as TreeBang import Juvix.Compiler.Tree.Language.Value qualified as Tree import Juvix.Compiler.Tree.Pretty qualified as Tree import Juvix.Compiler.Tree.SemEvaluator qualified as TreeSem @@ -39,3 +40,11 @@ doEvalSem :: Tree.FunctionInfo -> m (Either Tree.TreeError Tree.Value) doEvalSem tab' funInfo = TreeSem.hEvalIOEither stdin stdout tab' funInfo + +doEvalBang :: + (MonadIO m) => + Tree.InfoTable -> + Tree.FunctionInfo -> + m (Either Tree.TreeError Tree.Value) +doEvalBang tab' funInfo = + liftIO $ TreeBang.catchEvalErrorIO (liftIO $ TreeBang.hEvalIO stdin stdout tab' funInfo) diff --git a/src/Juvix/Compiler/Tree/Evaluator.hs b/src/Juvix/Compiler/Tree/Evaluator.hs index 5d27c3ed6c..8b69ebd248 100644 --- a/src/Juvix/Compiler/Tree/Evaluator.hs +++ b/src/Juvix/Compiler/Tree/Evaluator.hs @@ -55,8 +55,8 @@ hEval hout tab = eval' [] mempty goBinop :: NodeBinop -> Value goBinop NodeBinop {..} = -- keeping the lets separate ensures that `arg1` is evaluated before `arg2` - let !arg1 = eval' args temps _nodeBinopArg1 - in let !arg2 = eval' args temps _nodeBinopArg2 + let arg1 = eval' args temps _nodeBinopArg1 + in let arg2 = eval' args temps _nodeBinopArg2 in case _nodeBinopOpcode of IntAdd -> goIntBinop (+) arg1 arg2 IntSub -> goIntBinop (-) arg1 arg2 @@ -92,7 +92,7 @@ hEval hout tab = eval' [] mempty goUnop :: NodeUnop -> Value goUnop NodeUnop {..} = - let !v = eval' args temps _nodeUnopArg + let v = eval' args temps _nodeUnopArg in case _nodeUnopOpcode of OpShow -> ValString (printValue v) OpStrToInt -> goStringUnop strToInt v @@ -155,7 +155,7 @@ hEval hout tab = eval' [] mempty goAllocConstr :: NodeAllocConstr -> Value goAllocConstr NodeAllocConstr {..} = - let !vs = map' (eval' args temps) _nodeAllocConstrArgs + let vs = map (eval' args temps) _nodeAllocConstrArgs in ValConstr Constr { _constrTag = _nodeAllocConstrTag, @@ -164,7 +164,7 @@ hEval hout tab = eval' [] mempty goAllocClosure :: NodeAllocClosure -> Value goAllocClosure NodeAllocClosure {..} = - let !vs = map' (eval' args temps) _nodeAllocClosureArgs + let vs = map (eval' args temps) _nodeAllocClosureArgs in ValClosure Closure { _closureSymbol = _nodeAllocClosureFunSymbol, @@ -175,7 +175,7 @@ hEval hout tab = eval' [] mempty goExtendClosure NodeExtendClosure {..} = case eval' args temps _nodeExtendClosureFun of ValClosure Closure {..} -> - let !vs = map' (eval' args temps) (toList _nodeExtendClosureArgs) + let vs = map (eval' args temps) (toList _nodeExtendClosureArgs) in ValClosure Closure { _closureSymbol, @@ -190,7 +190,7 @@ hEval hout tab = eval' [] mempty doCall :: Symbol -> [Value] -> [Node] -> Value doCall sym vs0 as = - let !vs = map' (eval' args temps) as + let vs = map (eval' args temps) as fi = lookupFunInfo tab sym vs' = vs0 ++ vs in if @@ -208,7 +208,7 @@ hEval hout tab = eval' [] mempty goCallClosures :: NodeCallClosures -> Value goCallClosures NodeCallClosures {..} = - let !vs = map' (eval' args temps) (toList _nodeCallClosuresArgs) + let vs = map (eval' args temps) (toList _nodeCallClosuresArgs) in go (eval' args temps _nodeCallClosuresFun) vs where go :: Value -> [Value] -> Value @@ -257,7 +257,7 @@ hEval hout tab = eval' [] mempty goSave :: NodeSave -> Value goSave NodeSave {..} = - let !v = eval' args temps _nodeSaveArg + let v = eval' args temps _nodeSaveArg in eval' args (BL.cons v temps) _nodeSaveBody printValue :: Value -> Text @@ -289,7 +289,7 @@ valueToNode = \case hEvalIO :: (MonadIO m) => Handle -> Handle -> InfoTable -> FunctionInfo -> m Value hEvalIO hin hout infoTable funInfo = do - let !v = hEval hout infoTable (funInfo ^. functionCode) + let v = hEval hout infoTable (funInfo ^. functionCode) hRunIO hin hout infoTable v -- | Interpret IO actions. @@ -305,7 +305,7 @@ hRunIO hin hout infoTable = \case _nodeCallClosuresFun = valueToNode f, _nodeCallClosuresArgs = valueToNode x' :| [] } - !x'' = hEval hout infoTable code + x'' = hEval hout infoTable code hRunIO hin hout infoTable x'' ValConstr (Constr (BuiltinTag TagWrite) [ValString s]) -> do liftIO $ hPutStr hout s diff --git a/src/Juvix/Compiler/Tree/EvaluatorBangs.hs b/src/Juvix/Compiler/Tree/EvaluatorBangs.hs new file mode 100644 index 0000000000..408d4a386b --- /dev/null +++ b/src/Juvix/Compiler/Tree/EvaluatorBangs.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Avoid restricted extensions" #-} +{-# HLINT ignore "Avoid restricted flags" #-} +module Juvix.Compiler.Tree.EvaluatorBangs where + +import Control.Exception qualified as Exception +import GHC.IO (unsafePerformIO) +import GHC.Show qualified as S +import Juvix.Compiler.Core.Data.BinderList qualified as BL +import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Error +import Juvix.Compiler.Tree.Extra.Base +import Juvix.Compiler.Tree.Language +import Juvix.Compiler.Tree.Language.Value +import Juvix.Compiler.Tree.Pretty +import Text.Read qualified as T + +data EvalError = EvalError + { _evalErrorLocation :: Maybe Location, + _evalErrorMsg :: Text + } + +makeLenses ''EvalError + +instance Show EvalError where + show :: EvalError -> String + show EvalError {..} = + "evaluation error: " + ++ fromText _evalErrorMsg + +instance Exception.Exception EvalError + +eval :: InfoTable -> Node -> Value +eval = hEval stdout + +hEval :: Handle -> InfoTable -> Node -> Value +hEval hout tab = eval' [] mempty + where + eval' :: [Value] -> BL.BinderList Value -> Node -> Value + eval' args temps node = case node of + Binop x -> goBinop x + Unop x -> goUnop x + Const c -> goConstant c + MemRef x -> goMemRef x + AllocConstr x -> goAllocConstr x + AllocClosure x -> goAllocClosure x + ExtendClosure x -> goExtendClosure x + Call x -> goCall x + CallClosures x -> goCallClosures x + Branch x -> goBranch x + Case x -> goCase x + Save x -> goSave x + where + evalError :: Text -> a + evalError msg = + Exception.throw (EvalError (getNodeLocation node) msg) + + goBinop :: NodeBinop -> Value + goBinop NodeBinop {..} = + -- keeping the lets separate ensures that `arg1` is evaluated before `arg2` + let !arg1 = eval' args temps _nodeBinopArg1 + in let !arg2 = eval' args temps _nodeBinopArg2 + in case _nodeBinopOpcode of + IntAdd -> goIntBinop (+) arg1 arg2 + IntSub -> goIntBinop (-) arg1 arg2 + IntMul -> goIntBinop (*) arg1 arg2 + IntDiv + | arg2 == ValInteger 0 -> evalError "division by zero" + | otherwise -> goIntBinop quot arg1 arg2 + IntMod + | arg2 == ValInteger 0 -> evalError "division by zero" + | otherwise -> goIntBinop rem arg1 arg2 + IntLe -> goIntCmpBinop (<=) arg1 arg2 + IntLt -> goIntCmpBinop (<) arg1 arg2 + ValEq + | arg1 == arg2 -> ValBool True + | otherwise -> ValBool False + StrConcat -> goStrConcat arg1 arg2 + OpSeq -> arg2 + + goIntBinop :: (Integer -> Integer -> Integer) -> Value -> Value -> Value + goIntBinop f v1 v2 = case (v1, v2) of + (ValInteger i1, ValInteger i2) -> ValInteger (f i1 i2) + _ -> evalError "expected two integer arguments" + + goIntCmpBinop :: (Integer -> Integer -> Bool) -> Value -> Value -> Value + goIntCmpBinop f v1 v2 = case (v1, v2) of + (ValInteger i1, ValInteger i2) -> ValBool (f i1 i2) + _ -> evalError "expected two integer arguments" + + goStrConcat :: Value -> Value -> Value + goStrConcat v1 v2 = case (v1, v2) of + (ValString s1, ValString s2) -> ValString (s1 <> s2) + _ -> evalError "expected two string arguments" + + goUnop :: NodeUnop -> Value + goUnop NodeUnop {..} = + let !v = eval' args temps _nodeUnopArg + in case _nodeUnopOpcode of + OpShow -> ValString (printValue v) + OpStrToInt -> goStringUnop strToInt v + OpTrace -> goTrace v + OpFail -> goFail v + OpArgsNum -> goArgsNum v + + strToInt :: Text -> Value + strToInt s = case T.readMaybe (fromText s) of + Just i -> + ValInteger i + Nothing -> + evalError "string to integer: not an integer" + + goStringUnop :: (Text -> Value) -> Value -> Value + goStringUnop f = \case + ValString s -> f s + _ -> evalError "expected a string argument" + + goFail :: Value -> Value + goFail v = evalError ("failure: " <> printValue v) + + goArgsNum :: Value -> Value + goArgsNum = \case + ValClosure Closure {..} -> + ValInteger (fromIntegral argsNum) + where + fi = lookupFunInfo tab _closureSymbol + argsNum = fi ^. functionArgsNum - length _closureArgs + _ -> + evalError "expected a closure" + + goTrace :: Value -> Value + goTrace v = unsafePerformIO (hPutStrLn hout (printValue v) >> return v) + + goConstant :: NodeConstant -> Value + goConstant NodeConstant {..} = case _nodeConstant of + ConstInt i -> ValInteger i + ConstBool b -> ValBool b + ConstString s -> ValString s + ConstUnit -> ValUnit + ConstVoid -> ValVoid + + goMemRef :: NodeMemRef -> Value + goMemRef NodeMemRef {..} = case _nodeMemRef of + DRef r -> goDirectRef r + ConstrRef r -> goField r + + goDirectRef :: DirectRef -> Value + goDirectRef = \case + ArgRef OffsetRef {..} -> + args !! _offsetRefOffset + TempRef RefTemp {_refTempOffsetRef = OffsetRef {..}} -> + BL.lookupLevel _offsetRefOffset temps + + goField :: Field -> Value + goField Field {..} = case goDirectRef _fieldRef of + ValConstr Constr {..} -> _constrArgs !! _fieldOffset + _ -> evalError "expected a constructor" + + goAllocConstr :: NodeAllocConstr -> Value + goAllocConstr NodeAllocConstr {..} = + let !vs = map' (eval' args temps) _nodeAllocConstrArgs + in ValConstr + Constr + { _constrTag = _nodeAllocConstrTag, + _constrArgs = vs + } + + goAllocClosure :: NodeAllocClosure -> Value + goAllocClosure NodeAllocClosure {..} = + let !vs = map' (eval' args temps) _nodeAllocClosureArgs + in ValClosure + Closure + { _closureSymbol = _nodeAllocClosureFunSymbol, + _closureArgs = vs + } + + goExtendClosure :: NodeExtendClosure -> Value + goExtendClosure NodeExtendClosure {..} = + case eval' args temps _nodeExtendClosureFun of + ValClosure Closure {..} -> + let !vs = map' (eval' args temps) (toList _nodeExtendClosureArgs) + in ValClosure + Closure + { _closureSymbol, + _closureArgs = _closureArgs ++ vs + } + _ -> evalError "expected a closure" + + goCall :: NodeCall -> Value + goCall NodeCall {..} = case _nodeCallType of + CallFun sym -> doCall sym [] _nodeCallArgs + CallClosure cl -> doCallClosure cl _nodeCallArgs + + doCall :: Symbol -> [Value] -> [Node] -> Value + doCall sym vs0 as = + let !vs = map' (eval' args temps) as + fi = lookupFunInfo tab sym + vs' = vs0 ++ vs + in if + | length vs' == fi ^. functionArgsNum -> + eval' vs' mempty (fi ^. functionCode) + | otherwise -> + evalError "wrong number of arguments" + + doCallClosure :: Node -> [Node] -> Value + doCallClosure cl cargs = case eval' args temps cl of + ValClosure Closure {..} -> + doCall _closureSymbol _closureArgs cargs + _ -> + evalError "expected a closure" + + goCallClosures :: NodeCallClosures -> Value + goCallClosures NodeCallClosures {..} = + let !vs = map' (eval' args temps) (toList _nodeCallClosuresArgs) + in go (eval' args temps _nodeCallClosuresFun) vs + where + go :: Value -> [Value] -> Value + go cl vs = case cl of + ValClosure Closure {..} + | argsNum == n -> + eval' vs' mempty body + | argsNum < n -> + go (eval' (take argsNum vs') mempty body) (drop argsNum vs') + | otherwise -> + ValClosure + Closure + { _closureSymbol, + _closureArgs = vs' + } + where + fi = lookupFunInfo tab _closureSymbol + argsNum = fi ^. functionArgsNum + vs' = _closureArgs ++ vs + n = length vs' + body = fi ^. functionCode + _ -> + evalError "expected a closure" + + goBranch :: NodeBranch -> Value + goBranch NodeBranch {..} = + case eval' args temps _nodeBranchArg of + ValBool True -> eval' args temps _nodeBranchTrue + ValBool False -> eval' args temps _nodeBranchFalse + _ -> evalError "expected a boolean" + + goCase :: NodeCase -> Value + goCase NodeCase {..} = + case eval' args temps _nodeCaseArg of + v@(ValConstr Constr {..}) -> + case find (\CaseBranch {..} -> _caseBranchTag == _constrTag) _nodeCaseBranches of + Just CaseBranch {..} -> goCaseBranch v _caseBranchSave _caseBranchBody + Nothing -> goCaseBranch v False (fromMaybe (evalError "no matching branch") _nodeCaseDefault) + _ -> + evalError "expected a constructor" + + goCaseBranch :: Value -> Bool -> Node -> Value + goCaseBranch v bSave body + | bSave = eval' args (BL.cons v temps) body + | otherwise = eval' args temps body + + goSave :: NodeSave -> Value + goSave NodeSave {..} = + let !v = eval' args temps _nodeSaveArg + in eval' args (BL.cons v temps) _nodeSaveBody + + printValue :: Value -> Text + printValue = \case + ValString s -> s + v -> ppPrint tab v + +valueToNode :: Value -> Node +valueToNode = \case + ValInteger i -> mkConst $ ConstInt i + ValBool b -> mkConst $ ConstBool b + ValString s -> mkConst $ ConstString s + ValUnit -> mkConst ConstUnit + ValVoid -> mkConst ConstVoid + ValConstr Constr {..} -> + AllocConstr + NodeAllocConstr + { _nodeAllocConstrInfo = mempty, + _nodeAllocConstrTag = _constrTag, + _nodeAllocConstrArgs = map valueToNode _constrArgs + } + ValClosure Closure {..} -> + AllocClosure + NodeAllocClosure + { _nodeAllocClosureInfo = mempty, + _nodeAllocClosureFunSymbol = _closureSymbol, + _nodeAllocClosureArgs = map valueToNode _closureArgs + } + +hEvalIO :: (MonadIO m) => Handle -> Handle -> InfoTable -> FunctionInfo -> m Value +hEvalIO hin hout infoTable funInfo = do + let !v = hEval hout infoTable (funInfo ^. functionCode) + hRunIO hin hout infoTable v + +-- | Interpret IO actions. +hRunIO :: (MonadIO m) => Handle -> Handle -> InfoTable -> Value -> m Value +hRunIO hin hout infoTable = \case + ValConstr (Constr (BuiltinTag TagReturn) [x]) -> return x + ValConstr (Constr (BuiltinTag TagBind) [x, f]) -> do + x' <- hRunIO hin hout infoTable x + let code = + CallClosures + NodeCallClosures + { _nodeCallClosuresInfo = mempty, + _nodeCallClosuresFun = valueToNode f, + _nodeCallClosuresArgs = valueToNode x' :| [] + } + !x'' = hEval hout infoTable code + hRunIO hin hout infoTable x'' + ValConstr (Constr (BuiltinTag TagWrite) [ValString s]) -> do + liftIO $ hPutStr hout s + return ValVoid + ValConstr (Constr (BuiltinTag TagWrite) [arg]) -> do + liftIO $ hPutStr hout (ppPrint infoTable arg) + return ValVoid + ValConstr (Constr (BuiltinTag TagReadLn) []) -> do + liftIO $ hFlush hout + s <- liftIO $ hGetLine hin + return (ValString s) + val -> + return val + +-- | Catch EvalError and convert it to TreeError. +catchEvalErrorIO :: IO a -> IO (Either TreeError a) +catchEvalErrorIO ma = + Exception.catch + (Exception.evaluate ma >>= \ma' -> Right <$> ma') + (\(ex :: EvalError) -> return (Left (toTreeError ex))) + +toTreeError :: EvalError -> TreeError +toTreeError EvalError {..} = + TreeError + { _treeErrorMsg = "evaluation error: " <> _evalErrorMsg, + _treeErrorLoc = _evalErrorLocation + } From b83e76786f6980837b2bf9d5444be4b6ebd3b348 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Tue, 6 Feb 2024 13:39:22 +0100 Subject: [PATCH 04/11] add effectful --- package.yaml | 3 + src/Juvix/Compiler/Tree/EvaluatorEff.hs | 390 ++++++++++++++++++++++++ 2 files changed, 393 insertions(+) create mode 100644 src/Juvix/Compiler/Tree/EvaluatorEff.hs diff --git a/package.yaml b/package.yaml index c8a08146aa..cac2792a86 100644 --- a/package.yaml +++ b/package.yaml @@ -54,6 +54,9 @@ dependencies: - directory == 1.3.* - dlist == 1.0.* - edit-distance == 0.2.* + - effectful == 2.3.* + - effectful-core == 2.3.* + - effectful-th == 1.0.* - exceptions == 0.10.* - extra == 1.7.* - file-embed == 0.0.* diff --git a/src/Juvix/Compiler/Tree/EvaluatorEff.hs b/src/Juvix/Compiler/Tree/EvaluatorEff.hs new file mode 100644 index 0000000000..8976ffed08 --- /dev/null +++ b/src/Juvix/Compiler/Tree/EvaluatorEff.hs @@ -0,0 +1,390 @@ +module Juvix.Compiler.Tree.EvaluatorEff where + +import Control.Exception qualified as Exception +import Juvix.Compiler.Core.Data.BinderList qualified as BL +import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Error +import Juvix.Compiler.Tree.Evaluator (EvalError (..)) +import Juvix.Compiler.Tree.Extra.Base +import Juvix.Compiler.Tree.Language +import Juvix.Compiler.Tree.Language.Value +import Juvix.Compiler.Tree.Pretty +import Text.Read qualified as T +import Effectful.Writer.Static.Loca + +data EvalCtx = EvalCtx + { _evalCtxArgs :: [Value], + _evalCtxTemp :: BL.BinderList Value + } + +makeLenses ''EvalCtx + +emptyEvalCtx :: EvalCtx +emptyEvalCtx = + EvalCtx + { _evalCtxArgs = [], + _evalCtxTemp = mempty + } + +eval :: (Members '[Output Value, Error EvalError] r) => InfoTable -> Node -> Sem r Value +eval tab = runReader emptyEvalCtx . eval' + where + eval' :: forall r'. (Members '[Output Value, Reader EvalCtx, Error EvalError] r') => Node -> Sem r' Value + eval' node = case node of + Binop x -> goBinop x + Unop x -> goUnop x + Const c -> return (goConstant c) + MemRef x -> goMemRef x + AllocConstr x -> goAllocConstr x + AllocClosure x -> goAllocClosure x + ExtendClosure x -> goExtendClosure x + Call x -> goCall x + CallClosures x -> goCallClosures x + Branch x -> goBranch x + Case x -> goCase x + Save x -> goSave x + where + evalError :: Text -> Sem r' a + evalError msg = + Exception.throw (EvalError (getNodeLocation node) msg) + + goBinop :: NodeBinop -> Sem r' Value + goBinop NodeBinop {..} = do + arg1 <- eval' _nodeBinopArg1 + arg2 <- eval' _nodeBinopArg2 + case _nodeBinopOpcode of + IntAdd -> goIntBinop (+) arg1 arg2 + IntSub -> goIntBinop (-) arg1 arg2 + IntMul -> goIntBinop (*) arg1 arg2 + IntDiv + | arg2 == ValInteger 0 -> evalError "division by zero" + | otherwise -> goIntBinop quot arg1 arg2 + IntMod + | arg2 == ValInteger 0 -> evalError "division by zero" + | otherwise -> goIntBinop rem arg1 arg2 + IntLe -> goIntCmpBinop (<=) arg1 arg2 + IntLt -> goIntCmpBinop (<) arg1 arg2 + ValEq -> return (ValBool (arg1 == arg2)) + StrConcat -> goStrConcat arg1 arg2 + OpSeq -> return arg2 + + goIntBinop :: (Integer -> Integer -> Integer) -> Value -> Value -> Sem r' Value + goIntBinop f v1 v2 = case (v1, v2) of + (ValInteger i1, ValInteger i2) -> return (ValInteger (f i1 i2)) + _ -> evalError "expected two integer arguments" + + goIntCmpBinop :: (Integer -> Integer -> Bool) -> Value -> Value -> Sem r' Value + goIntCmpBinop f v1 v2 = case (v1, v2) of + (ValInteger i1, ValInteger i2) -> return (ValBool (f i1 i2)) + _ -> evalError "expected two integer arguments" + + goStrConcat :: Value -> Value -> Sem r' Value + goStrConcat v1 v2 = case (v1, v2) of + (ValString s1, ValString s2) -> return (ValString (s1 <> s2)) + _ -> evalError "expected two string arguments" + + goUnop :: NodeUnop -> Sem r' Value + goUnop NodeUnop {..} = do + v <- eval' _nodeUnopArg + case _nodeUnopOpcode of + OpShow -> return (ValString (printValue tab v)) + OpStrToInt -> goStringUnop strToInt v + OpTrace -> goTrace v + OpFail -> goFail v + OpArgsNum -> goArgsNum v + + strToInt :: Text -> Sem r' Value + strToInt s = case T.readMaybe (fromText s) of + Just i -> return (ValInteger i) + Nothing -> evalError "string to integer: not an integer" + + goStringUnop :: (Text -> Sem r' Value) -> Value -> Sem r' Value + goStringUnop f = \case + ValString s -> f s + _ -> evalError "expected a string argument" + + goFail :: Value -> Sem r' Value + goFail v = evalError ("failure: " <> printValue tab v) + + goArgsNum :: Value -> Sem r' Value + goArgsNum = \case + ValClosure Closure {..} -> return (ValInteger (fromIntegral argsNum)) + where + fi = lookupFunInfo tab _closureSymbol + argsNum = fi ^. functionArgsNum - length _closureArgs + _ -> + evalError "expected a closure" + + goTrace :: Value -> Sem r' Value + goTrace v = output v $> v + + goConstant :: NodeConstant -> Value + goConstant NodeConstant {..} = case _nodeConstant of + ConstInt i -> ValInteger i + ConstBool b -> ValBool b + ConstString s -> ValString s + ConstUnit -> ValUnit + ConstVoid -> ValVoid + + askTemp :: Sem r' (BL.BinderList Value) + askTemp = asks (^. evalCtxTemp) + + askArgs :: Sem r' [Value] + askArgs = asks (^. evalCtxArgs) + + goMemRef :: NodeMemRef -> Sem r' Value + goMemRef NodeMemRef {..} = case _nodeMemRef of + DRef r -> goDirectRef r + ConstrRef r -> goField r + + goDirectRef :: DirectRef -> Sem r' Value + goDirectRef = \case + ArgRef OffsetRef {..} -> + (!! _offsetRefOffset) <$> askArgs + TempRef RefTemp {_refTempOffsetRef = OffsetRef {..}} -> + BL.lookupLevel _offsetRefOffset <$> askTemp + + goField :: Field -> Sem r' Value + goField Field {..} = do + d <- goDirectRef _fieldRef + case d of + ValConstr Constr {..} -> return (_constrArgs !! _fieldOffset) + _ -> evalError "expected a constructor" + + goAllocConstr :: NodeAllocConstr -> Sem r' Value + goAllocConstr NodeAllocConstr {..} = do + vs <- mapM eval' _nodeAllocConstrArgs + return + ( ValConstr + Constr + { _constrTag = _nodeAllocConstrTag, + _constrArgs = vs + } + ) + + goAllocClosure :: NodeAllocClosure -> Sem r' Value + goAllocClosure NodeAllocClosure {..} = do + vs <- mapM eval' _nodeAllocClosureArgs + return + ( ValClosure + Closure + { _closureSymbol = _nodeAllocClosureFunSymbol, + _closureArgs = vs + } + ) + + goExtendClosure :: NodeExtendClosure -> Sem r' Value + goExtendClosure NodeExtendClosure {..} = do + fun <- eval' _nodeExtendClosureFun + case fun of + ValClosure Closure {..} -> do + vs <- mapM eval' (toList _nodeExtendClosureArgs) + return + ( ValClosure + Closure + { _closureSymbol, + _closureArgs = _closureArgs ++ vs + } + ) + _ -> evalError "expected a closure" + + goCall :: NodeCall -> Sem r' Value + goCall NodeCall {..} = case _nodeCallType of + CallFun sym -> doCall sym [] _nodeCallArgs + CallClosure cl -> doCallClosure cl _nodeCallArgs + + withCtx :: EvalCtx -> Sem r' a -> Sem r' a + withCtx = local . const + + doCall :: Symbol -> [Value] -> [Node] -> Sem r' Value + doCall sym clArgs as = do + vs <- mapM eval' as + let fi = lookupFunInfo tab sym + vs' = clArgs ++ vs + in if + | length vs' == fi ^. functionArgsNum -> do + let ctx' = + EvalCtx + { _evalCtxArgs = vs', + _evalCtxTemp = mempty + } + withCtx ctx' (eval' (fi ^. functionCode)) + | otherwise -> + evalError "wrong number of arguments" + + doCallClosure :: Node -> [Node] -> Sem r' Value + doCallClosure cl cargs = do + cl' <- eval' cl + case cl' of + ValClosure Closure {..} -> + doCall _closureSymbol _closureArgs cargs + _ -> + evalError "expected a closure" + + goCallClosures :: NodeCallClosures -> Sem r' Value + goCallClosures NodeCallClosures {..} = do + vs <- mapM eval' (toList _nodeCallClosuresArgs) + cl' <- eval' _nodeCallClosuresFun + go cl' vs + where + go :: Value -> [Value] -> Sem r' Value + go cl vs = case cl of + ValClosure Closure {..} + | argsNum == n -> do + let ctx' = + EvalCtx + { _evalCtxArgs = vs', + _evalCtxTemp = mempty + } + withCtx ctx' (eval' body) + | argsNum < n -> do + let ctx' = + EvalCtx + { _evalCtxArgs = take argsNum vs', + _evalCtxTemp = mempty + } + + body' <- withCtx ctx' (eval' body) + go body' (drop argsNum vs') + | otherwise -> + return + ( ValClosure + Closure + { _closureSymbol, + _closureArgs = vs' + } + ) + where + fi = lookupFunInfo tab _closureSymbol + argsNum = fi ^. functionArgsNum + vs' = _closureArgs ++ vs + n = length vs' + body = fi ^. functionCode + _ -> + evalError "expected a closure" + + goBranch :: NodeBranch -> Sem r' Value + goBranch NodeBranch {..} = do + arg' <- eval' _nodeBranchArg + br <- case arg' of + ValBool True -> return _nodeBranchTrue + ValBool False -> return _nodeBranchFalse + _ -> evalError "expected a boolean" + eval' br + + goCase :: NodeCase -> Sem r' Value + goCase NodeCase {..} = do + arg' <- eval' _nodeCaseArg + case arg' of + v@(ValConstr Constr {..}) -> + case find (\CaseBranch {..} -> _caseBranchTag == _constrTag) _nodeCaseBranches of + Just CaseBranch {..} -> goCaseBranch v _caseBranchSave _caseBranchBody + Nothing -> do + def <- maybe (evalError "no matching branch") return _nodeCaseDefault + goCaseBranch v False def + _ -> + evalError "expected a constructor" + + withExtendedTemp :: Value -> Sem r' a -> Sem r' a + withExtendedTemp v m = do + ctx <- ask + withCtx (over evalCtxTemp (BL.cons v) ctx) m + + goCaseBranch :: Value -> Bool -> Node -> Sem r' Value + goCaseBranch v bSave body + | bSave = withExtendedTemp v (eval' body) + | otherwise = eval' body + + goSave :: NodeSave -> Sem r' Value + goSave NodeSave {..} = do + v <- eval' _nodeSaveArg + withExtendedTemp v (eval' _nodeSaveBody) + +printValue :: InfoTable -> Value -> Text +printValue tab = \case + ValString s -> s + v -> ppPrint tab v + +valueToNode :: Value -> Node +valueToNode = \case + ValInteger i -> mkConst $ ConstInt i + ValBool b -> mkConst $ ConstBool b + ValString s -> mkConst $ ConstString s + ValUnit -> mkConst ConstUnit + ValVoid -> mkConst ConstVoid + ValConstr Constr {..} -> + AllocConstr + NodeAllocConstr + { _nodeAllocConstrInfo = mempty, + _nodeAllocConstrTag = _constrTag, + _nodeAllocConstrArgs = map valueToNode _constrArgs + } + ValClosure Closure {..} -> + AllocClosure + NodeAllocClosure + { _nodeAllocClosureInfo = mempty, + _nodeAllocClosureFunSymbol = _closureSymbol, + _nodeAllocClosureArgs = map valueToNode _closureArgs + } + +hEvalIOEither :: + forall m. + (MonadIO m) => + Handle -> + Handle -> + InfoTable -> + FunctionInfo -> + m (Either TreeError Value) +hEvalIOEither hin hout infoTable funInfo = do + let x = do + v <- eval infoTable (funInfo ^. functionCode) + hRunIO hin hout infoTable v + let handleTrace = liftIO . hPutStrLn hout . printValue infoTable + liftIO + . runM + . runError @TreeError + . mapError toTreeError + . runOutputSem handleTrace + $ x + +-- | Interpret IO actions. +hRunIO :: forall r. (Members '[Embed IO, Error EvalError, Output Value] r) => Handle -> Handle -> InfoTable -> Value -> Sem r Value +hRunIO hin hout infoTable = \case + ValConstr (Constr (BuiltinTag TagReturn) [x]) -> return x + ValConstr (Constr (BuiltinTag TagBind) [x, f]) -> do + x' <- hRunIO hin hout infoTable x + let code = + CallClosures + NodeCallClosures + { _nodeCallClosuresInfo = mempty, + _nodeCallClosuresFun = valueToNode f, + _nodeCallClosuresArgs = valueToNode x' :| [] + } + res <- eval infoTable code + hRunIO hin hout infoTable res + ValConstr (Constr (BuiltinTag TagWrite) [ValString s]) -> do + liftIO $ hPutStr hout s + return ValVoid + ValConstr (Constr (BuiltinTag TagWrite) [arg]) -> do + liftIO $ hPutStr hout (ppPrint infoTable arg) + return ValVoid + ValConstr (Constr (BuiltinTag TagReadLn) []) -> do + liftIO $ hFlush hout + s <- liftIO $ hGetLine hin + return (ValString s) + val -> + return val + +-- | Catch EvalError and convert it to TreeError. +catchEvalErrorIO :: IO a -> IO (Either TreeError a) +catchEvalErrorIO ma = + Exception.catch + (Exception.evaluate ma >>= \ma' -> Right <$> ma') + (\(ex :: EvalError) -> return (Left (toTreeError ex))) + +toTreeError :: EvalError -> TreeError +toTreeError EvalError {..} = + TreeError + { _treeErrorMsg = "evaluation error: " <> _evalErrorMsg, + _treeErrorLoc = _evalErrorLocation + } From 657b87caf7b5067eef78920741741128220ea955 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Tue, 6 Feb 2024 16:58:15 +0100 Subject: [PATCH 05/11] implement the Juvix Tree evaluator using effectful --- app/TreeEvaluator.hs | 10 ++- src/Juvix/Compiler/Tree/EvaluatorEff.hs | 112 ++++++++++++++---------- 2 files changed, 77 insertions(+), 45 deletions(-) diff --git a/app/TreeEvaluator.hs b/app/TreeEvaluator.hs index 5f910ad223..556d0afef8 100644 --- a/app/TreeEvaluator.hs +++ b/app/TreeEvaluator.hs @@ -6,6 +6,7 @@ import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree import Juvix.Compiler.Tree.Error qualified as Tree import Juvix.Compiler.Tree.Evaluator qualified as Tree import Juvix.Compiler.Tree.EvaluatorBangs qualified as TreeBang +import Juvix.Compiler.Tree.EvaluatorEff qualified as Eff import Juvix.Compiler.Tree.Language.Value qualified as Tree import Juvix.Compiler.Tree.Pretty qualified as Tree import Juvix.Compiler.Tree.SemEvaluator qualified as TreeSem @@ -14,7 +15,7 @@ evalTree :: forall r. (Members '[Embed IO, App] r) => Tree.InfoTable -> Sem r () evalTree tab = case tab ^. Tree.infoMainFunction of Just sym -> do - r <- doEvalSem tab (Tree.lookupFunInfo tab sym) + r <- doEvalEff tab (Tree.lookupFunInfo tab sym) case r of Left err -> exitJuvixError (JuvixError err) @@ -34,6 +35,13 @@ doEval :: doEval tab' funInfo = liftIO $ Tree.catchEvalErrorIO (liftIO $ Tree.hEvalIO stdin stdout tab' funInfo) +doEvalEff :: + (MonadIO m) => + Tree.InfoTable -> + Tree.FunctionInfo -> + m (Either Tree.TreeError Tree.Value) +doEvalEff tab' funInfo = Eff.hEvalIOEither stdin stdout tab' funInfo + doEvalSem :: (MonadIO m) => Tree.InfoTable -> diff --git a/src/Juvix/Compiler/Tree/EvaluatorEff.hs b/src/Juvix/Compiler/Tree/EvaluatorEff.hs index 8976ffed08..fdc931c892 100644 --- a/src/Juvix/Compiler/Tree/EvaluatorEff.hs +++ b/src/Juvix/Compiler/Tree/EvaluatorEff.hs @@ -1,16 +1,19 @@ module Juvix.Compiler.Tree.EvaluatorEff where import Control.Exception qualified as Exception +import Effectful (Eff, IOE, runEff, (:>)) +import Effectful.Error.Static qualified as E +import Effectful.Reader.Static qualified as E +import Effectful.Writer.Static.Local qualified as E import Juvix.Compiler.Core.Data.BinderList qualified as BL import Juvix.Compiler.Tree.Data.InfoTable import Juvix.Compiler.Tree.Error import Juvix.Compiler.Tree.Evaluator (EvalError (..)) import Juvix.Compiler.Tree.Extra.Base -import Juvix.Compiler.Tree.Language +import Juvix.Compiler.Tree.Language hiding (Output, ask, asks, mapError, output, runError) import Juvix.Compiler.Tree.Language.Value import Juvix.Compiler.Tree.Pretty import Text.Read qualified as T -import Effectful.Writer.Static.Loca data EvalCtx = EvalCtx { _evalCtxArgs :: [Value], @@ -26,10 +29,23 @@ emptyEvalCtx = _evalCtxTemp = mempty } -eval :: (Members '[Output Value, Error EvalError] r) => InfoTable -> Node -> Sem r Value -eval tab = runReader emptyEvalCtx . eval' +type Output w = E.Writer [w] + +output :: (Output Value :> r) => Value -> Eff r () +output = E.tell . pure @[] + +runOutputEff :: (w -> Eff r ()) -> Eff (Output w ': r) a -> Eff r a +runOutputEff handle m = do + (a, l) <- E.runWriter m + mapM_ handle l + pure a + +-- eval :: (Members '[Output Value, Error EvalError] r) => InfoTable -> Node -> Sem r Value +eval :: (Output Value :> r, E.Error EvalError :> r) => InfoTable -> Node -> Eff r Value +eval tab = E.runReader emptyEvalCtx . eval' where - eval' :: forall r'. (Members '[Output Value, Reader EvalCtx, Error EvalError] r') => Node -> Sem r' Value + -- eval' :: forall r'. (Members '[Output Value, Reader EvalCtx, Error EvalError] r') => Node -> Sem r' Value + eval' :: forall r'. (Output Value :> r', E.Reader EvalCtx :> r', E.Error EvalError :> r') => Node -> Eff r' Value eval' node = case node of Binop x -> goBinop x Unop x -> goUnop x @@ -44,11 +60,11 @@ eval tab = runReader emptyEvalCtx . eval' Case x -> goCase x Save x -> goSave x where - evalError :: Text -> Sem r' a + evalError :: Text -> Eff r' a evalError msg = Exception.throw (EvalError (getNodeLocation node) msg) - goBinop :: NodeBinop -> Sem r' Value + goBinop :: NodeBinop -> Eff r' Value goBinop NodeBinop {..} = do arg1 <- eval' _nodeBinopArg1 arg2 <- eval' _nodeBinopArg2 @@ -68,22 +84,22 @@ eval tab = runReader emptyEvalCtx . eval' StrConcat -> goStrConcat arg1 arg2 OpSeq -> return arg2 - goIntBinop :: (Integer -> Integer -> Integer) -> Value -> Value -> Sem r' Value + goIntBinop :: (Integer -> Integer -> Integer) -> Value -> Value -> Eff r' Value goIntBinop f v1 v2 = case (v1, v2) of (ValInteger i1, ValInteger i2) -> return (ValInteger (f i1 i2)) _ -> evalError "expected two integer arguments" - goIntCmpBinop :: (Integer -> Integer -> Bool) -> Value -> Value -> Sem r' Value + goIntCmpBinop :: (Integer -> Integer -> Bool) -> Value -> Value -> Eff r' Value goIntCmpBinop f v1 v2 = case (v1, v2) of (ValInteger i1, ValInteger i2) -> return (ValBool (f i1 i2)) _ -> evalError "expected two integer arguments" - goStrConcat :: Value -> Value -> Sem r' Value + goStrConcat :: Value -> Value -> Eff r' Value goStrConcat v1 v2 = case (v1, v2) of (ValString s1, ValString s2) -> return (ValString (s1 <> s2)) _ -> evalError "expected two string arguments" - goUnop :: NodeUnop -> Sem r' Value + goUnop :: NodeUnop -> Eff r' Value goUnop NodeUnop {..} = do v <- eval' _nodeUnopArg case _nodeUnopOpcode of @@ -93,20 +109,20 @@ eval tab = runReader emptyEvalCtx . eval' OpFail -> goFail v OpArgsNum -> goArgsNum v - strToInt :: Text -> Sem r' Value + strToInt :: Text -> Eff r' Value strToInt s = case T.readMaybe (fromText s) of Just i -> return (ValInteger i) Nothing -> evalError "string to integer: not an integer" - goStringUnop :: (Text -> Sem r' Value) -> Value -> Sem r' Value + goStringUnop :: (Text -> Eff r' Value) -> Value -> Eff r' Value goStringUnop f = \case ValString s -> f s _ -> evalError "expected a string argument" - goFail :: Value -> Sem r' Value + goFail :: Value -> Eff r' Value goFail v = evalError ("failure: " <> printValue tab v) - goArgsNum :: Value -> Sem r' Value + goArgsNum :: Value -> Eff r' Value goArgsNum = \case ValClosure Closure {..} -> return (ValInteger (fromIntegral argsNum)) where @@ -115,7 +131,7 @@ eval tab = runReader emptyEvalCtx . eval' _ -> evalError "expected a closure" - goTrace :: Value -> Sem r' Value + goTrace :: Value -> Eff r' Value goTrace v = output v $> v goConstant :: NodeConstant -> Value @@ -126,32 +142,32 @@ eval tab = runReader emptyEvalCtx . eval' ConstUnit -> ValUnit ConstVoid -> ValVoid - askTemp :: Sem r' (BL.BinderList Value) - askTemp = asks (^. evalCtxTemp) + askTemp :: Eff r' (BL.BinderList Value) + askTemp = E.asks (^. evalCtxTemp) - askArgs :: Sem r' [Value] - askArgs = asks (^. evalCtxArgs) + askArgs :: Eff r' [Value] + askArgs = E.asks (^. evalCtxArgs) - goMemRef :: NodeMemRef -> Sem r' Value + goMemRef :: NodeMemRef -> Eff r' Value goMemRef NodeMemRef {..} = case _nodeMemRef of DRef r -> goDirectRef r ConstrRef r -> goField r - goDirectRef :: DirectRef -> Sem r' Value + goDirectRef :: DirectRef -> Eff r' Value goDirectRef = \case ArgRef OffsetRef {..} -> (!! _offsetRefOffset) <$> askArgs TempRef RefTemp {_refTempOffsetRef = OffsetRef {..}} -> BL.lookupLevel _offsetRefOffset <$> askTemp - goField :: Field -> Sem r' Value + goField :: Field -> Eff r' Value goField Field {..} = do d <- goDirectRef _fieldRef case d of ValConstr Constr {..} -> return (_constrArgs !! _fieldOffset) _ -> evalError "expected a constructor" - goAllocConstr :: NodeAllocConstr -> Sem r' Value + goAllocConstr :: NodeAllocConstr -> Eff r' Value goAllocConstr NodeAllocConstr {..} = do vs <- mapM eval' _nodeAllocConstrArgs return @@ -162,7 +178,7 @@ eval tab = runReader emptyEvalCtx . eval' } ) - goAllocClosure :: NodeAllocClosure -> Sem r' Value + goAllocClosure :: NodeAllocClosure -> Eff r' Value goAllocClosure NodeAllocClosure {..} = do vs <- mapM eval' _nodeAllocClosureArgs return @@ -173,7 +189,7 @@ eval tab = runReader emptyEvalCtx . eval' } ) - goExtendClosure :: NodeExtendClosure -> Sem r' Value + goExtendClosure :: NodeExtendClosure -> Eff r' Value goExtendClosure NodeExtendClosure {..} = do fun <- eval' _nodeExtendClosureFun case fun of @@ -188,15 +204,15 @@ eval tab = runReader emptyEvalCtx . eval' ) _ -> evalError "expected a closure" - goCall :: NodeCall -> Sem r' Value + goCall :: NodeCall -> Eff r' Value goCall NodeCall {..} = case _nodeCallType of CallFun sym -> doCall sym [] _nodeCallArgs CallClosure cl -> doCallClosure cl _nodeCallArgs - withCtx :: EvalCtx -> Sem r' a -> Sem r' a - withCtx = local . const + withCtx :: EvalCtx -> Eff r' a -> Eff r' a + withCtx = E.local . const - doCall :: Symbol -> [Value] -> [Node] -> Sem r' Value + doCall :: Symbol -> [Value] -> [Node] -> Eff r' Value doCall sym clArgs as = do vs <- mapM eval' as let fi = lookupFunInfo tab sym @@ -212,7 +228,7 @@ eval tab = runReader emptyEvalCtx . eval' | otherwise -> evalError "wrong number of arguments" - doCallClosure :: Node -> [Node] -> Sem r' Value + doCallClosure :: Node -> [Node] -> Eff r' Value doCallClosure cl cargs = do cl' <- eval' cl case cl' of @@ -221,13 +237,13 @@ eval tab = runReader emptyEvalCtx . eval' _ -> evalError "expected a closure" - goCallClosures :: NodeCallClosures -> Sem r' Value + goCallClosures :: NodeCallClosures -> Eff r' Value goCallClosures NodeCallClosures {..} = do vs <- mapM eval' (toList _nodeCallClosuresArgs) cl' <- eval' _nodeCallClosuresFun go cl' vs where - go :: Value -> [Value] -> Sem r' Value + go :: Value -> [Value] -> Eff r' Value go cl vs = case cl of ValClosure Closure {..} | argsNum == n -> do @@ -263,7 +279,7 @@ eval tab = runReader emptyEvalCtx . eval' _ -> evalError "expected a closure" - goBranch :: NodeBranch -> Sem r' Value + goBranch :: NodeBranch -> Eff r' Value goBranch NodeBranch {..} = do arg' <- eval' _nodeBranchArg br <- case arg' of @@ -272,7 +288,7 @@ eval tab = runReader emptyEvalCtx . eval' _ -> evalError "expected a boolean" eval' br - goCase :: NodeCase -> Sem r' Value + goCase :: NodeCase -> Eff r' Value goCase NodeCase {..} = do arg' <- eval' _nodeCaseArg case arg' of @@ -285,17 +301,17 @@ eval tab = runReader emptyEvalCtx . eval' _ -> evalError "expected a constructor" - withExtendedTemp :: Value -> Sem r' a -> Sem r' a + withExtendedTemp :: Value -> Eff r' a -> Eff r' a withExtendedTemp v m = do - ctx <- ask + ctx <- E.ask withCtx (over evalCtxTemp (BL.cons v) ctx) m - goCaseBranch :: Value -> Bool -> Node -> Sem r' Value + goCaseBranch :: Value -> Bool -> Node -> Eff r' Value goCaseBranch v bSave body | bSave = withExtendedTemp v (eval' body) | otherwise = eval' body - goSave :: NodeSave -> Sem r' Value + goSave :: NodeSave -> Eff r' Value goSave NodeSave {..} = do v <- eval' _nodeSaveArg withExtendedTemp v (eval' _nodeSaveBody) @@ -327,6 +343,12 @@ valueToNode = \case _nodeAllocClosureArgs = map valueToNode _closureArgs } +runError :: Eff (E.Error err ': r) x -> Eff r (Either err x) +runError = fmap (mapLeft snd) . E.runError + +mapError :: (E.Error b :> r) => (a -> b) -> Eff (E.Error a ': r) x -> Eff r x +mapError f = E.runErrorWith (\_ e -> E.throwError (f e)) + hEvalIOEither :: forall m. (MonadIO m) => @@ -336,19 +358,21 @@ hEvalIOEither :: FunctionInfo -> m (Either TreeError Value) hEvalIOEither hin hout infoTable funInfo = do - let x = do + let x :: Eff '[Output Value, E.Error EvalError, E.Error TreeError, IOE] Value + x = do v <- eval infoTable (funInfo ^. functionCode) hRunIO hin hout infoTable v - let handleTrace = liftIO . hPutStrLn hout . printValue infoTable + let handleTrace :: forall q. (MonadIO q) => Value -> q () + handleTrace = liftIO . hPutStrLn hout . printValue infoTable liftIO - . runM + . runEff . runError @TreeError . mapError toTreeError - . runOutputSem handleTrace + . runOutputEff handleTrace $ x -- | Interpret IO actions. -hRunIO :: forall r. (Members '[Embed IO, Error EvalError, Output Value] r) => Handle -> Handle -> InfoTable -> Value -> Sem r Value +hRunIO :: forall r. (IOE :> r, E.Error EvalError :> r, Output Value :> r) => Handle -> Handle -> InfoTable -> Value -> Eff r Value hRunIO hin hout infoTable = \case ValConstr (Constr (BuiltinTag TagReturn) [x]) -> return x ValConstr (Constr (BuiltinTag TagBind) [x, f]) -> do From f5777107dd79bde3a44ea95c56484dad133b1db3 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Wed, 7 Feb 2024 11:29:11 +0100 Subject: [PATCH 06/11] remove EvaluatorBangs --- app/TreeEvaluator.hs | 9 - src/Juvix/Compiler/Tree/Evaluator.hs | 22 +- src/Juvix/Compiler/Tree/EvaluatorBangs.hs | 340 ---------------------- 3 files changed, 11 insertions(+), 360 deletions(-) delete mode 100644 src/Juvix/Compiler/Tree/EvaluatorBangs.hs diff --git a/app/TreeEvaluator.hs b/app/TreeEvaluator.hs index 556d0afef8..c5ecfa7728 100644 --- a/app/TreeEvaluator.hs +++ b/app/TreeEvaluator.hs @@ -5,7 +5,6 @@ import CommonOptions import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree import Juvix.Compiler.Tree.Error qualified as Tree import Juvix.Compiler.Tree.Evaluator qualified as Tree -import Juvix.Compiler.Tree.EvaluatorBangs qualified as TreeBang import Juvix.Compiler.Tree.EvaluatorEff qualified as Eff import Juvix.Compiler.Tree.Language.Value qualified as Tree import Juvix.Compiler.Tree.Pretty qualified as Tree @@ -48,11 +47,3 @@ doEvalSem :: Tree.FunctionInfo -> m (Either Tree.TreeError Tree.Value) doEvalSem tab' funInfo = TreeSem.hEvalIOEither stdin stdout tab' funInfo - -doEvalBang :: - (MonadIO m) => - Tree.InfoTable -> - Tree.FunctionInfo -> - m (Either Tree.TreeError Tree.Value) -doEvalBang tab' funInfo = - liftIO $ TreeBang.catchEvalErrorIO (liftIO $ TreeBang.hEvalIO stdin stdout tab' funInfo) diff --git a/src/Juvix/Compiler/Tree/Evaluator.hs b/src/Juvix/Compiler/Tree/Evaluator.hs index 8b69ebd248..5d27c3ed6c 100644 --- a/src/Juvix/Compiler/Tree/Evaluator.hs +++ b/src/Juvix/Compiler/Tree/Evaluator.hs @@ -55,8 +55,8 @@ hEval hout tab = eval' [] mempty goBinop :: NodeBinop -> Value goBinop NodeBinop {..} = -- keeping the lets separate ensures that `arg1` is evaluated before `arg2` - let arg1 = eval' args temps _nodeBinopArg1 - in let arg2 = eval' args temps _nodeBinopArg2 + let !arg1 = eval' args temps _nodeBinopArg1 + in let !arg2 = eval' args temps _nodeBinopArg2 in case _nodeBinopOpcode of IntAdd -> goIntBinop (+) arg1 arg2 IntSub -> goIntBinop (-) arg1 arg2 @@ -92,7 +92,7 @@ hEval hout tab = eval' [] mempty goUnop :: NodeUnop -> Value goUnop NodeUnop {..} = - let v = eval' args temps _nodeUnopArg + let !v = eval' args temps _nodeUnopArg in case _nodeUnopOpcode of OpShow -> ValString (printValue v) OpStrToInt -> goStringUnop strToInt v @@ -155,7 +155,7 @@ hEval hout tab = eval' [] mempty goAllocConstr :: NodeAllocConstr -> Value goAllocConstr NodeAllocConstr {..} = - let vs = map (eval' args temps) _nodeAllocConstrArgs + let !vs = map' (eval' args temps) _nodeAllocConstrArgs in ValConstr Constr { _constrTag = _nodeAllocConstrTag, @@ -164,7 +164,7 @@ hEval hout tab = eval' [] mempty goAllocClosure :: NodeAllocClosure -> Value goAllocClosure NodeAllocClosure {..} = - let vs = map (eval' args temps) _nodeAllocClosureArgs + let !vs = map' (eval' args temps) _nodeAllocClosureArgs in ValClosure Closure { _closureSymbol = _nodeAllocClosureFunSymbol, @@ -175,7 +175,7 @@ hEval hout tab = eval' [] mempty goExtendClosure NodeExtendClosure {..} = case eval' args temps _nodeExtendClosureFun of ValClosure Closure {..} -> - let vs = map (eval' args temps) (toList _nodeExtendClosureArgs) + let !vs = map' (eval' args temps) (toList _nodeExtendClosureArgs) in ValClosure Closure { _closureSymbol, @@ -190,7 +190,7 @@ hEval hout tab = eval' [] mempty doCall :: Symbol -> [Value] -> [Node] -> Value doCall sym vs0 as = - let vs = map (eval' args temps) as + let !vs = map' (eval' args temps) as fi = lookupFunInfo tab sym vs' = vs0 ++ vs in if @@ -208,7 +208,7 @@ hEval hout tab = eval' [] mempty goCallClosures :: NodeCallClosures -> Value goCallClosures NodeCallClosures {..} = - let vs = map (eval' args temps) (toList _nodeCallClosuresArgs) + let !vs = map' (eval' args temps) (toList _nodeCallClosuresArgs) in go (eval' args temps _nodeCallClosuresFun) vs where go :: Value -> [Value] -> Value @@ -257,7 +257,7 @@ hEval hout tab = eval' [] mempty goSave :: NodeSave -> Value goSave NodeSave {..} = - let v = eval' args temps _nodeSaveArg + let !v = eval' args temps _nodeSaveArg in eval' args (BL.cons v temps) _nodeSaveBody printValue :: Value -> Text @@ -289,7 +289,7 @@ valueToNode = \case hEvalIO :: (MonadIO m) => Handle -> Handle -> InfoTable -> FunctionInfo -> m Value hEvalIO hin hout infoTable funInfo = do - let v = hEval hout infoTable (funInfo ^. functionCode) + let !v = hEval hout infoTable (funInfo ^. functionCode) hRunIO hin hout infoTable v -- | Interpret IO actions. @@ -305,7 +305,7 @@ hRunIO hin hout infoTable = \case _nodeCallClosuresFun = valueToNode f, _nodeCallClosuresArgs = valueToNode x' :| [] } - x'' = hEval hout infoTable code + !x'' = hEval hout infoTable code hRunIO hin hout infoTable x'' ValConstr (Constr (BuiltinTag TagWrite) [ValString s]) -> do liftIO $ hPutStr hout s diff --git a/src/Juvix/Compiler/Tree/EvaluatorBangs.hs b/src/Juvix/Compiler/Tree/EvaluatorBangs.hs deleted file mode 100644 index 408d4a386b..0000000000 --- a/src/Juvix/Compiler/Tree/EvaluatorBangs.hs +++ /dev/null @@ -1,340 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Avoid restricted extensions" #-} -{-# HLINT ignore "Avoid restricted flags" #-} -module Juvix.Compiler.Tree.EvaluatorBangs where - -import Control.Exception qualified as Exception -import GHC.IO (unsafePerformIO) -import GHC.Show qualified as S -import Juvix.Compiler.Core.Data.BinderList qualified as BL -import Juvix.Compiler.Tree.Data.InfoTable -import Juvix.Compiler.Tree.Error -import Juvix.Compiler.Tree.Extra.Base -import Juvix.Compiler.Tree.Language -import Juvix.Compiler.Tree.Language.Value -import Juvix.Compiler.Tree.Pretty -import Text.Read qualified as T - -data EvalError = EvalError - { _evalErrorLocation :: Maybe Location, - _evalErrorMsg :: Text - } - -makeLenses ''EvalError - -instance Show EvalError where - show :: EvalError -> String - show EvalError {..} = - "evaluation error: " - ++ fromText _evalErrorMsg - -instance Exception.Exception EvalError - -eval :: InfoTable -> Node -> Value -eval = hEval stdout - -hEval :: Handle -> InfoTable -> Node -> Value -hEval hout tab = eval' [] mempty - where - eval' :: [Value] -> BL.BinderList Value -> Node -> Value - eval' args temps node = case node of - Binop x -> goBinop x - Unop x -> goUnop x - Const c -> goConstant c - MemRef x -> goMemRef x - AllocConstr x -> goAllocConstr x - AllocClosure x -> goAllocClosure x - ExtendClosure x -> goExtendClosure x - Call x -> goCall x - CallClosures x -> goCallClosures x - Branch x -> goBranch x - Case x -> goCase x - Save x -> goSave x - where - evalError :: Text -> a - evalError msg = - Exception.throw (EvalError (getNodeLocation node) msg) - - goBinop :: NodeBinop -> Value - goBinop NodeBinop {..} = - -- keeping the lets separate ensures that `arg1` is evaluated before `arg2` - let !arg1 = eval' args temps _nodeBinopArg1 - in let !arg2 = eval' args temps _nodeBinopArg2 - in case _nodeBinopOpcode of - IntAdd -> goIntBinop (+) arg1 arg2 - IntSub -> goIntBinop (-) arg1 arg2 - IntMul -> goIntBinop (*) arg1 arg2 - IntDiv - | arg2 == ValInteger 0 -> evalError "division by zero" - | otherwise -> goIntBinop quot arg1 arg2 - IntMod - | arg2 == ValInteger 0 -> evalError "division by zero" - | otherwise -> goIntBinop rem arg1 arg2 - IntLe -> goIntCmpBinop (<=) arg1 arg2 - IntLt -> goIntCmpBinop (<) arg1 arg2 - ValEq - | arg1 == arg2 -> ValBool True - | otherwise -> ValBool False - StrConcat -> goStrConcat arg1 arg2 - OpSeq -> arg2 - - goIntBinop :: (Integer -> Integer -> Integer) -> Value -> Value -> Value - goIntBinop f v1 v2 = case (v1, v2) of - (ValInteger i1, ValInteger i2) -> ValInteger (f i1 i2) - _ -> evalError "expected two integer arguments" - - goIntCmpBinop :: (Integer -> Integer -> Bool) -> Value -> Value -> Value - goIntCmpBinop f v1 v2 = case (v1, v2) of - (ValInteger i1, ValInteger i2) -> ValBool (f i1 i2) - _ -> evalError "expected two integer arguments" - - goStrConcat :: Value -> Value -> Value - goStrConcat v1 v2 = case (v1, v2) of - (ValString s1, ValString s2) -> ValString (s1 <> s2) - _ -> evalError "expected two string arguments" - - goUnop :: NodeUnop -> Value - goUnop NodeUnop {..} = - let !v = eval' args temps _nodeUnopArg - in case _nodeUnopOpcode of - OpShow -> ValString (printValue v) - OpStrToInt -> goStringUnop strToInt v - OpTrace -> goTrace v - OpFail -> goFail v - OpArgsNum -> goArgsNum v - - strToInt :: Text -> Value - strToInt s = case T.readMaybe (fromText s) of - Just i -> - ValInteger i - Nothing -> - evalError "string to integer: not an integer" - - goStringUnop :: (Text -> Value) -> Value -> Value - goStringUnop f = \case - ValString s -> f s - _ -> evalError "expected a string argument" - - goFail :: Value -> Value - goFail v = evalError ("failure: " <> printValue v) - - goArgsNum :: Value -> Value - goArgsNum = \case - ValClosure Closure {..} -> - ValInteger (fromIntegral argsNum) - where - fi = lookupFunInfo tab _closureSymbol - argsNum = fi ^. functionArgsNum - length _closureArgs - _ -> - evalError "expected a closure" - - goTrace :: Value -> Value - goTrace v = unsafePerformIO (hPutStrLn hout (printValue v) >> return v) - - goConstant :: NodeConstant -> Value - goConstant NodeConstant {..} = case _nodeConstant of - ConstInt i -> ValInteger i - ConstBool b -> ValBool b - ConstString s -> ValString s - ConstUnit -> ValUnit - ConstVoid -> ValVoid - - goMemRef :: NodeMemRef -> Value - goMemRef NodeMemRef {..} = case _nodeMemRef of - DRef r -> goDirectRef r - ConstrRef r -> goField r - - goDirectRef :: DirectRef -> Value - goDirectRef = \case - ArgRef OffsetRef {..} -> - args !! _offsetRefOffset - TempRef RefTemp {_refTempOffsetRef = OffsetRef {..}} -> - BL.lookupLevel _offsetRefOffset temps - - goField :: Field -> Value - goField Field {..} = case goDirectRef _fieldRef of - ValConstr Constr {..} -> _constrArgs !! _fieldOffset - _ -> evalError "expected a constructor" - - goAllocConstr :: NodeAllocConstr -> Value - goAllocConstr NodeAllocConstr {..} = - let !vs = map' (eval' args temps) _nodeAllocConstrArgs - in ValConstr - Constr - { _constrTag = _nodeAllocConstrTag, - _constrArgs = vs - } - - goAllocClosure :: NodeAllocClosure -> Value - goAllocClosure NodeAllocClosure {..} = - let !vs = map' (eval' args temps) _nodeAllocClosureArgs - in ValClosure - Closure - { _closureSymbol = _nodeAllocClosureFunSymbol, - _closureArgs = vs - } - - goExtendClosure :: NodeExtendClosure -> Value - goExtendClosure NodeExtendClosure {..} = - case eval' args temps _nodeExtendClosureFun of - ValClosure Closure {..} -> - let !vs = map' (eval' args temps) (toList _nodeExtendClosureArgs) - in ValClosure - Closure - { _closureSymbol, - _closureArgs = _closureArgs ++ vs - } - _ -> evalError "expected a closure" - - goCall :: NodeCall -> Value - goCall NodeCall {..} = case _nodeCallType of - CallFun sym -> doCall sym [] _nodeCallArgs - CallClosure cl -> doCallClosure cl _nodeCallArgs - - doCall :: Symbol -> [Value] -> [Node] -> Value - doCall sym vs0 as = - let !vs = map' (eval' args temps) as - fi = lookupFunInfo tab sym - vs' = vs0 ++ vs - in if - | length vs' == fi ^. functionArgsNum -> - eval' vs' mempty (fi ^. functionCode) - | otherwise -> - evalError "wrong number of arguments" - - doCallClosure :: Node -> [Node] -> Value - doCallClosure cl cargs = case eval' args temps cl of - ValClosure Closure {..} -> - doCall _closureSymbol _closureArgs cargs - _ -> - evalError "expected a closure" - - goCallClosures :: NodeCallClosures -> Value - goCallClosures NodeCallClosures {..} = - let !vs = map' (eval' args temps) (toList _nodeCallClosuresArgs) - in go (eval' args temps _nodeCallClosuresFun) vs - where - go :: Value -> [Value] -> Value - go cl vs = case cl of - ValClosure Closure {..} - | argsNum == n -> - eval' vs' mempty body - | argsNum < n -> - go (eval' (take argsNum vs') mempty body) (drop argsNum vs') - | otherwise -> - ValClosure - Closure - { _closureSymbol, - _closureArgs = vs' - } - where - fi = lookupFunInfo tab _closureSymbol - argsNum = fi ^. functionArgsNum - vs' = _closureArgs ++ vs - n = length vs' - body = fi ^. functionCode - _ -> - evalError "expected a closure" - - goBranch :: NodeBranch -> Value - goBranch NodeBranch {..} = - case eval' args temps _nodeBranchArg of - ValBool True -> eval' args temps _nodeBranchTrue - ValBool False -> eval' args temps _nodeBranchFalse - _ -> evalError "expected a boolean" - - goCase :: NodeCase -> Value - goCase NodeCase {..} = - case eval' args temps _nodeCaseArg of - v@(ValConstr Constr {..}) -> - case find (\CaseBranch {..} -> _caseBranchTag == _constrTag) _nodeCaseBranches of - Just CaseBranch {..} -> goCaseBranch v _caseBranchSave _caseBranchBody - Nothing -> goCaseBranch v False (fromMaybe (evalError "no matching branch") _nodeCaseDefault) - _ -> - evalError "expected a constructor" - - goCaseBranch :: Value -> Bool -> Node -> Value - goCaseBranch v bSave body - | bSave = eval' args (BL.cons v temps) body - | otherwise = eval' args temps body - - goSave :: NodeSave -> Value - goSave NodeSave {..} = - let !v = eval' args temps _nodeSaveArg - in eval' args (BL.cons v temps) _nodeSaveBody - - printValue :: Value -> Text - printValue = \case - ValString s -> s - v -> ppPrint tab v - -valueToNode :: Value -> Node -valueToNode = \case - ValInteger i -> mkConst $ ConstInt i - ValBool b -> mkConst $ ConstBool b - ValString s -> mkConst $ ConstString s - ValUnit -> mkConst ConstUnit - ValVoid -> mkConst ConstVoid - ValConstr Constr {..} -> - AllocConstr - NodeAllocConstr - { _nodeAllocConstrInfo = mempty, - _nodeAllocConstrTag = _constrTag, - _nodeAllocConstrArgs = map valueToNode _constrArgs - } - ValClosure Closure {..} -> - AllocClosure - NodeAllocClosure - { _nodeAllocClosureInfo = mempty, - _nodeAllocClosureFunSymbol = _closureSymbol, - _nodeAllocClosureArgs = map valueToNode _closureArgs - } - -hEvalIO :: (MonadIO m) => Handle -> Handle -> InfoTable -> FunctionInfo -> m Value -hEvalIO hin hout infoTable funInfo = do - let !v = hEval hout infoTable (funInfo ^. functionCode) - hRunIO hin hout infoTable v - --- | Interpret IO actions. -hRunIO :: (MonadIO m) => Handle -> Handle -> InfoTable -> Value -> m Value -hRunIO hin hout infoTable = \case - ValConstr (Constr (BuiltinTag TagReturn) [x]) -> return x - ValConstr (Constr (BuiltinTag TagBind) [x, f]) -> do - x' <- hRunIO hin hout infoTable x - let code = - CallClosures - NodeCallClosures - { _nodeCallClosuresInfo = mempty, - _nodeCallClosuresFun = valueToNode f, - _nodeCallClosuresArgs = valueToNode x' :| [] - } - !x'' = hEval hout infoTable code - hRunIO hin hout infoTable x'' - ValConstr (Constr (BuiltinTag TagWrite) [ValString s]) -> do - liftIO $ hPutStr hout s - return ValVoid - ValConstr (Constr (BuiltinTag TagWrite) [arg]) -> do - liftIO $ hPutStr hout (ppPrint infoTable arg) - return ValVoid - ValConstr (Constr (BuiltinTag TagReadLn) []) -> do - liftIO $ hFlush hout - s <- liftIO $ hGetLine hin - return (ValString s) - val -> - return val - --- | Catch EvalError and convert it to TreeError. -catchEvalErrorIO :: IO a -> IO (Either TreeError a) -catchEvalErrorIO ma = - Exception.catch - (Exception.evaluate ma >>= \ma' -> Right <$> ma') - (\(ex :: EvalError) -> return (Left (toTreeError ex))) - -toTreeError :: EvalError -> TreeError -toTreeError EvalError {..} = - TreeError - { _treeErrorMsg = "evaluation error: " <> _evalErrorMsg, - _treeErrorLoc = _evalErrorLocation - } From a75541bfa3f63b867e12e4084a56c4158129993c Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Wed, 7 Feb 2024 09:56:37 +0100 Subject: [PATCH 07/11] add cli option to select evaluator --- app/Commands/Dev/Tree/Eval.hs | 2 +- app/Commands/Dev/Tree/Eval/Options.hs | 53 ++++++++++++++++++++++++++- app/Commands/Dev/Tree/Read.hs | 2 +- app/Commands/Dev/Tree/Repl.hs | 2 +- app/TreeEvaluator.hs | 34 ++++++++++++++--- 5 files changed, 82 insertions(+), 11 deletions(-) diff --git a/app/Commands/Dev/Tree/Eval.hs b/app/Commands/Dev/Tree/Eval.hs index dbe5269c66..bb86374dab 100644 --- a/app/Commands/Dev/Tree/Eval.hs +++ b/app/Commands/Dev/Tree/Eval.hs @@ -11,7 +11,7 @@ runCommand opts = do s <- readFile (toFilePath afile) case Tree.runParser (toFilePath afile) s of Left err -> exitJuvixError (JuvixError err) - Right tab -> evalTree tab + Right tab -> evalTree (opts ^. treeEvalEvaluator) tab where file :: AppPath File file = opts ^. treeEvalInputFile diff --git a/app/Commands/Dev/Tree/Eval/Options.hs b/app/Commands/Dev/Tree/Eval/Options.hs index 73a3965276..5fef943ada 100644 --- a/app/Commands/Dev/Tree/Eval/Options.hs +++ b/app/Commands/Dev/Tree/Eval/Options.hs @@ -1,9 +1,57 @@ module Commands.Dev.Tree.Eval.Options where import CommonOptions +import Juvix.Prelude.Pretty +import Prelude (show) -newtype TreeEvalOptions = TreeEvalOptions - { _treeEvalInputFile :: AppPath File +data Evaluator + = EvalEffectful + | EvalSem + | EvalRaw + deriving stock (Eq, Bounded, Enum, Data) + +defaultEvaluator :: Evaluator +defaultEvaluator = EvalEffectful + +instance Show Evaluator where + show = \case + EvalEffectful -> "effectful" + EvalSem -> "polysemy" + EvalRaw -> "raw" + +instance Pretty Evaluator where + pretty = CommonOptions.show + +optEvaluator :: Parser Evaluator +optEvaluator = + option + (eitherReader parseEvaluator) + ( long "evaluator" + <> value defaultEvaluator + <> metavar "EVALUATOR_NAME" + <> completer (mkCompleter (return . compl)) + <> help "hint: use autocomplete" + ) + where + compl :: String -> [String] + compl s = filter (isPrefixOf s) (map Prelude.show (allElements @Evaluator)) + + parseEvaluator :: String -> Either String Evaluator + parseEvaluator s = + maybe + (Left err) + Right + ( lookup + s + [(Prelude.show e, e) | e :: Evaluator <- allElements] + ) + where + err :: String + err = "Invalid evaluator name. The available names are: " <> Prelude.show (allElements @Evaluator) + +data TreeEvalOptions = TreeEvalOptions + { _treeEvalInputFile :: AppPath File, + _treeEvalEvaluator :: Evaluator } deriving stock (Data) @@ -12,4 +60,5 @@ makeLenses ''TreeEvalOptions parseTreeEvalOptions :: Parser TreeEvalOptions parseTreeEvalOptions = do _treeEvalInputFile <- parseInputFile FileExtJuvixTree + _treeEvalEvaluator <- optEvaluator pure TreeEvalOptions {..} diff --git a/app/Commands/Dev/Tree/Read.hs b/app/Commands/Dev/Tree/Read.hs index 1d47a13cba..8b5fb45a86 100644 --- a/app/Commands/Dev/Tree/Read.hs +++ b/app/Commands/Dev/Tree/Read.hs @@ -32,5 +32,5 @@ runCommand opts = do putStrLn "--------------------------------" putStrLn "| Eval |" putStrLn "--------------------------------" - Eval.evalTree tab' + Eval.evalTree Eval.defaultEvaluator tab' | otherwise = return () diff --git a/app/Commands/Dev/Tree/Repl.hs b/app/Commands/Dev/Tree/Repl.hs index 068fe31579..d6141fb582 100644 --- a/app/Commands/Dev/Tree/Repl.hs +++ b/app/Commands/Dev/Tree/Repl.hs @@ -102,7 +102,7 @@ evalNode node = do _functionArgNames = [], _functionType = TyDynamic } - et <- Eval.doEval tab fi + et <- Eval.doEvalDefault tab fi case et of Left e -> error (show e) Right v -> diff --git a/app/TreeEvaluator.hs b/app/TreeEvaluator.hs index c5ecfa7728..789bd983e2 100644 --- a/app/TreeEvaluator.hs +++ b/app/TreeEvaluator.hs @@ -1,6 +1,11 @@ -module TreeEvaluator where +module TreeEvaluator + ( module TreeEvaluator, + module Commands.Dev.Tree.Eval.Options, + ) +where import App +import Commands.Dev.Tree.Eval.Options import CommonOptions import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree import Juvix.Compiler.Tree.Error qualified as Tree @@ -10,11 +15,11 @@ import Juvix.Compiler.Tree.Language.Value qualified as Tree import Juvix.Compiler.Tree.Pretty qualified as Tree import Juvix.Compiler.Tree.SemEvaluator qualified as TreeSem -evalTree :: forall r. (Members '[Embed IO, App] r) => Tree.InfoTable -> Sem r () -evalTree tab = +evalTree :: forall r. (Members '[Embed IO, App] r) => Evaluator -> Tree.InfoTable -> Sem r () +evalTree ev tab = case tab ^. Tree.infoMainFunction of Just sym -> do - r <- doEvalEff tab (Tree.lookupFunInfo tab sym) + r <- doEval ev tab (Tree.lookupFunInfo tab sym) case r of Left err -> exitJuvixError (JuvixError err) @@ -26,13 +31,30 @@ evalTree tab = Nothing -> exitMsg (ExitFailure 1) "no 'main' function" +doEvalDefault :: + (MonadIO m) => + Tree.InfoTable -> + Tree.FunctionInfo -> + m (Either Tree.TreeError Tree.Value) +doEvalDefault = doEval defaultEvaluator + doEval :: + (MonadIO m) => + Evaluator -> + Tree.InfoTable -> + Tree.FunctionInfo -> + m (Either Tree.TreeError Tree.Value) +doEval = \case + EvalEffectful -> doEvalEff + EvalRaw -> doEvalRaw + EvalSem -> doEvalSem + +doEvalRaw :: (MonadIO m) => Tree.InfoTable -> Tree.FunctionInfo -> m (Either Tree.TreeError Tree.Value) -doEval tab' funInfo = - liftIO $ Tree.catchEvalErrorIO (liftIO $ Tree.hEvalIO stdin stdout tab' funInfo) +doEvalRaw tab' = liftIO . Tree.catchEvalErrorIO . liftIO . Tree.hEvalIO stdin stdout tab' doEvalEff :: (MonadIO m) => From a6b68e7c3ccfe9469be072007dfd72d826ac070d Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Wed, 7 Feb 2024 15:00:17 +0100 Subject: [PATCH 08/11] rename module --- app/TreeEvaluator.hs | 2 +- src/Juvix/Compiler/Tree/{SemEvaluator.hs => EvaluatorSem.hs} | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) rename src/Juvix/Compiler/Tree/{SemEvaluator.hs => EvaluatorSem.hs} (99%) diff --git a/app/TreeEvaluator.hs b/app/TreeEvaluator.hs index 789bd983e2..eaa1a9cd6a 100644 --- a/app/TreeEvaluator.hs +++ b/app/TreeEvaluator.hs @@ -11,9 +11,9 @@ import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree import Juvix.Compiler.Tree.Error qualified as Tree import Juvix.Compiler.Tree.Evaluator qualified as Tree import Juvix.Compiler.Tree.EvaluatorEff qualified as Eff +import Juvix.Compiler.Tree.EvaluatorSem qualified as TreeSem import Juvix.Compiler.Tree.Language.Value qualified as Tree import Juvix.Compiler.Tree.Pretty qualified as Tree -import Juvix.Compiler.Tree.SemEvaluator qualified as TreeSem evalTree :: forall r. (Members '[Embed IO, App] r) => Evaluator -> Tree.InfoTable -> Sem r () evalTree ev tab = diff --git a/src/Juvix/Compiler/Tree/SemEvaluator.hs b/src/Juvix/Compiler/Tree/EvaluatorSem.hs similarity index 99% rename from src/Juvix/Compiler/Tree/SemEvaluator.hs rename to src/Juvix/Compiler/Tree/EvaluatorSem.hs index 6037fa8871..f6b3f615f7 100644 --- a/src/Juvix/Compiler/Tree/SemEvaluator.hs +++ b/src/Juvix/Compiler/Tree/EvaluatorSem.hs @@ -1,4 +1,4 @@ -module Juvix.Compiler.Tree.SemEvaluator where +module Juvix.Compiler.Tree.EvaluatorSem where import Control.Exception qualified as Exception import Juvix.Compiler.Core.Data.BinderList qualified as BL From a5ea9fba71334ced9beaf96ae3b0c10f360b026f Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Wed, 7 Feb 2024 18:41:05 +0100 Subject: [PATCH 09/11] reduce code duplication --- src/Juvix/Compiler/Tree/Evaluator.hs | 14 ++++---- src/Juvix/Compiler/Tree/EvaluatorEff.hs | 45 ++----------------------- src/Juvix/Compiler/Tree/EvaluatorSem.hs | 45 ++----------------------- 3 files changed, 11 insertions(+), 93 deletions(-) diff --git a/src/Juvix/Compiler/Tree/Evaluator.hs b/src/Juvix/Compiler/Tree/Evaluator.hs index 5d27c3ed6c..3976147f10 100644 --- a/src/Juvix/Compiler/Tree/Evaluator.hs +++ b/src/Juvix/Compiler/Tree/Evaluator.hs @@ -94,7 +94,7 @@ hEval hout tab = eval' [] mempty goUnop NodeUnop {..} = let !v = eval' args temps _nodeUnopArg in case _nodeUnopOpcode of - OpShow -> ValString (printValue v) + OpShow -> ValString (printValue tab v) OpStrToInt -> goStringUnop strToInt v OpTrace -> goTrace v OpFail -> goFail v @@ -113,7 +113,7 @@ hEval hout tab = eval' [] mempty _ -> evalError "expected a string argument" goFail :: Value -> Value - goFail v = evalError ("failure: " <> printValue v) + goFail v = evalError ("failure: " <> printValue tab v) goArgsNum :: Value -> Value goArgsNum = \case @@ -126,7 +126,7 @@ hEval hout tab = eval' [] mempty evalError "expected a closure" goTrace :: Value -> Value - goTrace v = unsafePerformIO (hPutStrLn hout (printValue v) >> return v) + goTrace v = unsafePerformIO (hPutStrLn hout (printValue tab v) >> return v) goConstant :: NodeConstant -> Value goConstant NodeConstant {..} = case _nodeConstant of @@ -260,10 +260,10 @@ hEval hout tab = eval' [] mempty let !v = eval' args temps _nodeSaveArg in eval' args (BL.cons v temps) _nodeSaveBody - printValue :: Value -> Text - printValue = \case - ValString s -> s - v -> ppPrint tab v +printValue :: InfoTable -> Value -> Text +printValue tab = \case + ValString s -> s + v -> ppPrint tab v valueToNode :: Value -> Node valueToNode = \case diff --git a/src/Juvix/Compiler/Tree/EvaluatorEff.hs b/src/Juvix/Compiler/Tree/EvaluatorEff.hs index fdc931c892..515ae0dc48 100644 --- a/src/Juvix/Compiler/Tree/EvaluatorEff.hs +++ b/src/Juvix/Compiler/Tree/EvaluatorEff.hs @@ -1,4 +1,4 @@ -module Juvix.Compiler.Tree.EvaluatorEff where +module Juvix.Compiler.Tree.EvaluatorEff (eval, hEvalIOEither) where import Control.Exception qualified as Exception import Effectful (Eff, IOE, runEff, (:>)) @@ -8,7 +8,7 @@ import Effectful.Writer.Static.Local qualified as E import Juvix.Compiler.Core.Data.BinderList qualified as BL import Juvix.Compiler.Tree.Data.InfoTable import Juvix.Compiler.Tree.Error -import Juvix.Compiler.Tree.Evaluator (EvalError (..)) +import Juvix.Compiler.Tree.Evaluator (EvalError (..), printValue, valueToNode, toTreeError) import Juvix.Compiler.Tree.Extra.Base import Juvix.Compiler.Tree.Language hiding (Output, ask, asks, mapError, output, runError) import Juvix.Compiler.Tree.Language.Value @@ -316,33 +316,6 @@ eval tab = E.runReader emptyEvalCtx . eval' v <- eval' _nodeSaveArg withExtendedTemp v (eval' _nodeSaveBody) -printValue :: InfoTable -> Value -> Text -printValue tab = \case - ValString s -> s - v -> ppPrint tab v - -valueToNode :: Value -> Node -valueToNode = \case - ValInteger i -> mkConst $ ConstInt i - ValBool b -> mkConst $ ConstBool b - ValString s -> mkConst $ ConstString s - ValUnit -> mkConst ConstUnit - ValVoid -> mkConst ConstVoid - ValConstr Constr {..} -> - AllocConstr - NodeAllocConstr - { _nodeAllocConstrInfo = mempty, - _nodeAllocConstrTag = _constrTag, - _nodeAllocConstrArgs = map valueToNode _constrArgs - } - ValClosure Closure {..} -> - AllocClosure - NodeAllocClosure - { _nodeAllocClosureInfo = mempty, - _nodeAllocClosureFunSymbol = _closureSymbol, - _nodeAllocClosureArgs = map valueToNode _closureArgs - } - runError :: Eff (E.Error err ': r) x -> Eff r (Either err x) runError = fmap (mapLeft snd) . E.runError @@ -398,17 +371,3 @@ hRunIO hin hout infoTable = \case return (ValString s) val -> return val - --- | Catch EvalError and convert it to TreeError. -catchEvalErrorIO :: IO a -> IO (Either TreeError a) -catchEvalErrorIO ma = - Exception.catch - (Exception.evaluate ma >>= \ma' -> Right <$> ma') - (\(ex :: EvalError) -> return (Left (toTreeError ex))) - -toTreeError :: EvalError -> TreeError -toTreeError EvalError {..} = - TreeError - { _treeErrorMsg = "evaluation error: " <> _evalErrorMsg, - _treeErrorLoc = _evalErrorLocation - } diff --git a/src/Juvix/Compiler/Tree/EvaluatorSem.hs b/src/Juvix/Compiler/Tree/EvaluatorSem.hs index f6b3f615f7..4b6c358191 100644 --- a/src/Juvix/Compiler/Tree/EvaluatorSem.hs +++ b/src/Juvix/Compiler/Tree/EvaluatorSem.hs @@ -1,10 +1,10 @@ -module Juvix.Compiler.Tree.EvaluatorSem where +module Juvix.Compiler.Tree.EvaluatorSem (eval, hEvalIOEither) where import Control.Exception qualified as Exception import Juvix.Compiler.Core.Data.BinderList qualified as BL import Juvix.Compiler.Tree.Data.InfoTable import Juvix.Compiler.Tree.Error -import Juvix.Compiler.Tree.Evaluator (EvalError (..)) +import Juvix.Compiler.Tree.Evaluator (EvalError (..), printValue, valueToNode, toTreeError) import Juvix.Compiler.Tree.Extra.Base import Juvix.Compiler.Tree.Language import Juvix.Compiler.Tree.Language.Value @@ -299,33 +299,6 @@ eval tab = runReader emptyEvalCtx . eval' v <- eval' _nodeSaveArg withExtendedTemp v (eval' _nodeSaveBody) -printValue :: InfoTable -> Value -> Text -printValue tab = \case - ValString s -> s - v -> ppPrint tab v - -valueToNode :: Value -> Node -valueToNode = \case - ValInteger i -> mkConst $ ConstInt i - ValBool b -> mkConst $ ConstBool b - ValString s -> mkConst $ ConstString s - ValUnit -> mkConst ConstUnit - ValVoid -> mkConst ConstVoid - ValConstr Constr {..} -> - AllocConstr - NodeAllocConstr - { _nodeAllocConstrInfo = mempty, - _nodeAllocConstrTag = _constrTag, - _nodeAllocConstrArgs = map valueToNode _constrArgs - } - ValClosure Closure {..} -> - AllocClosure - NodeAllocClosure - { _nodeAllocClosureInfo = mempty, - _nodeAllocClosureFunSymbol = _closureSymbol, - _nodeAllocClosureArgs = map valueToNode _closureArgs - } - hEvalIOEither :: forall m. (MonadIO m) => @@ -373,17 +346,3 @@ hRunIO hin hout infoTable = \case return (ValString s) val -> return val - --- | Catch EvalError and convert it to TreeError. -catchEvalErrorIO :: IO a -> IO (Either TreeError a) -catchEvalErrorIO ma = - Exception.catch - (Exception.evaluate ma >>= \ma' -> Right <$> ma') - (\(ex :: EvalError) -> return (Left (toTreeError ex))) - -toTreeError :: EvalError -> TreeError -toTreeError EvalError {..} = - TreeError - { _treeErrorMsg = "evaluation error: " <> _evalErrorMsg, - _treeErrorLoc = _evalErrorLocation - } From e19befef4428d2e69e6a569c45f6c79e720133e4 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Wed, 7 Feb 2024 18:50:56 +0100 Subject: [PATCH 10/11] remove comments --- src/Juvix/Compiler/Tree/EvaluatorEff.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Juvix/Compiler/Tree/EvaluatorEff.hs b/src/Juvix/Compiler/Tree/EvaluatorEff.hs index 515ae0dc48..0cad323910 100644 --- a/src/Juvix/Compiler/Tree/EvaluatorEff.hs +++ b/src/Juvix/Compiler/Tree/EvaluatorEff.hs @@ -40,11 +40,9 @@ runOutputEff handle m = do mapM_ handle l pure a --- eval :: (Members '[Output Value, Error EvalError] r) => InfoTable -> Node -> Sem r Value eval :: (Output Value :> r, E.Error EvalError :> r) => InfoTable -> Node -> Eff r Value eval tab = E.runReader emptyEvalCtx . eval' where - -- eval' :: forall r'. (Members '[Output Value, Reader EvalCtx, Error EvalError] r') => Node -> Sem r' Value eval' :: forall r'. (Output Value :> r', E.Reader EvalCtx :> r', E.Error EvalError :> r') => Node -> Eff r' Value eval' node = case node of Binop x -> goBinop x From 37869e62c72e5a27715ab4533f68c5066fa0e096 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Wed, 7 Feb 2024 18:54:31 +0100 Subject: [PATCH 11/11] ormolu --- src/Juvix/Compiler/Tree/EvaluatorEff.hs | 2 +- src/Juvix/Compiler/Tree/EvaluatorSem.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Juvix/Compiler/Tree/EvaluatorEff.hs b/src/Juvix/Compiler/Tree/EvaluatorEff.hs index 0cad323910..719e70519e 100644 --- a/src/Juvix/Compiler/Tree/EvaluatorEff.hs +++ b/src/Juvix/Compiler/Tree/EvaluatorEff.hs @@ -8,7 +8,7 @@ import Effectful.Writer.Static.Local qualified as E import Juvix.Compiler.Core.Data.BinderList qualified as BL import Juvix.Compiler.Tree.Data.InfoTable import Juvix.Compiler.Tree.Error -import Juvix.Compiler.Tree.Evaluator (EvalError (..), printValue, valueToNode, toTreeError) +import Juvix.Compiler.Tree.Evaluator (EvalError (..), printValue, toTreeError, valueToNode) import Juvix.Compiler.Tree.Extra.Base import Juvix.Compiler.Tree.Language hiding (Output, ask, asks, mapError, output, runError) import Juvix.Compiler.Tree.Language.Value diff --git a/src/Juvix/Compiler/Tree/EvaluatorSem.hs b/src/Juvix/Compiler/Tree/EvaluatorSem.hs index 4b6c358191..91d28ab2fd 100644 --- a/src/Juvix/Compiler/Tree/EvaluatorSem.hs +++ b/src/Juvix/Compiler/Tree/EvaluatorSem.hs @@ -4,7 +4,7 @@ import Control.Exception qualified as Exception import Juvix.Compiler.Core.Data.BinderList qualified as BL import Juvix.Compiler.Tree.Data.InfoTable import Juvix.Compiler.Tree.Error -import Juvix.Compiler.Tree.Evaluator (EvalError (..), printValue, valueToNode, toTreeError) +import Juvix.Compiler.Tree.Evaluator (EvalError (..), printValue, toTreeError, valueToNode) import Juvix.Compiler.Tree.Extra.Base import Juvix.Compiler.Tree.Language import Juvix.Compiler.Tree.Language.Value