diff options
Diffstat (limited to 'hs/Interpreter.hs')
| -rw-r--r-- | hs/Interpreter.hs | 481 |
1 files changed, 481 insertions, 0 deletions
diff --git a/hs/Interpreter.hs b/hs/Interpreter.hs new file mode 100644 index 0000000..46c7d8e --- /dev/null +++ b/hs/Interpreter.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving, BangPatterns #-} +module Interpreter(interpret) where + +import Control.Monad.Except +import Control.Monad.State.Strict +import Control.Monad.Writer.Strict +import Data.List +import Data.Maybe +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +-- import Debug.Trace + +import AST +import qualified GCStore as GCS + + +interpret :: Program -> (Maybe String, String, VM) -- (Maybe error, output, vm) +interpret prog = + let res = evaluateProgram prog >> liftM show get >>= tellLine :: ExMonad () + m1 = unExMonad res :: ExceptT String (WriterT String (State VM)) () + m2 = runExceptT m1 :: WriterT String (State VM) (Either String ()) + m3 = runWriterT m2 :: State VM (Either String (), String) + m4 = runState m3 makeVM :: ((Either String (), String), VM) + vm = snd m4 :: VM + merr = either Just (const Nothing) (fst (fst m4)) + output = snd (fst m4) + in (merr, output, vm) + + +type Scope = Map.Map Name GCS.Id + +data Value + = VNum Double + | VStr String + | VBlock BlockType ArgList Block + | VNil + deriving (Show) + +type ObjectStore = GCS.Store Value + +data VM = VM {scopeStack :: [Scope], + objStore :: ObjectStore, + tempValue :: Int} + deriving (Show) + +newtype ExMonad a = ExContext {unExMonad :: ExceptT String (WriterT String (State VM)) a} + deriving (Functor, Applicative, Monad, MonadState VM, MonadWriter String, MonadError String) + +typeNameOf :: Value -> String +typeNameOf (VNum _) = "Number" +typeNameOf (VStr _) = "String" +typeNameOf (VBlock _ _ _) = "Block" +typeNameOf VNil = "Nil" + +niceThrowError :: String -> ExMonad a +niceThrowError s = tellLine s >> throwError s + +getTopScope :: String -> ExMonad Scope +getTopScope mname = get >>= \(VM stk _ _) -> case stk of + [] -> niceThrowError $ mname ++ " on empty scope stack" + (sc:_) -> return sc + +modifyScopeStack :: ([Scope] -> [Scope]) -> ExMonad () +modifyScopeStack f = modify $ \vm@(VM stk _ _) -> vm {scopeStack = f stk} + +putScopeStack :: [Scope] -> ExMonad () +putScopeStack = modifyScopeStack . const + +modifyObjStore :: (ObjectStore -> ObjectStore) -> ExMonad () +modifyObjStore f = modify $ \vm@(VM _ os _) -> vm {objStore = f os} + +putObjStore :: ObjectStore -> ExMonad () +putObjStore = modifyObjStore . const + +modifyTempValue :: (Int -> Int) -> ExMonad () +modifyTempValue func = modify $ \vm -> vm {tempValue = func (tempValue vm)} + +getTempValue :: ExMonad Int +getTempValue = liftM tempValue get + +getRefCount :: GCS.Id -> ExMonad Int +getRefCount gcsid = get >>= \vm -> return (GCS.refcount (objStore vm) gcsid) + +derefTell :: GCS.Id -> ExMonad () +derefTell gcsid = do + get >>= \vm -> return (GCS.deref (objStore vm) gcsid) + >>= putObjStore + rc <- getRefCount gcsid + tellLine $ "GCS deref " ++ show gcsid ++ " -> rc=" ++ show rc + +cleanupScope :: Scope -> ExMonad () +cleanupScope sc = do + tellLine $ "## cleanupScope: " ++ show sc + mapM_ cleanupGcsid (Map.elems sc) + +cleanupGcsid :: GCS.Id -> ExMonad () +cleanupGcsid gcsid = do + vm <- get + case GCS.retrieve (objStore vm) gcsid of + Nothing -> niceThrowError $ "cleanupScope: gcsid " ++ show gcsid ++ " doesn't exist" + Just (VBlock _ _ b) -> cleanupBlock b + _ -> return () + derefTell gcsid + +cleanupBlock :: Block -> ExMonad () +cleanupBlock block = do + let idset = collectBlock block + mapM_ derefTell idset + +collectBlock :: Block -> Set.Set GCS.Id +collectBlock (Block sts) = foldl Set.union $ map collectStatement sts + +collectStatement :: Statement -> Set.Set GCS.Id +collectStatement (Declaration _ e) = collectExpression e +collectStatement (Assignment _ e) = collectExpression e +collectStatement (Condition e b1 b2) = + foldl Set.union [collectExpression e, collectBlock b1, collectBlock b2] +collectStatement (Dive _ es b) = + Set.union (foldl Set.union (map collectExpression es)) (collectBlock b) +collectStatement (Expr e) = collectExpression e + +collectExpression :: Expression -> Set.Set GCS.Id +collectExpression (EBin _ e1 e2) = Set.union (collectExpression e1) (collectExpression e2) +collectExpression (EUn _ e) = collectExpression e +collectExpression (ELit li) = collectLiteral li + +collectLiteral :: Literal -> Set.Set GCS.Id +collectLiteral (LBlock _ _ b) = collectBlock b +collectLiteral (LGCSId gcsid') = cleanupGcsid gcsid' +collectLiteral _ = return () + +cleanupValue :: Value -> Set.Set GCS.Id +cleanupValue (VBlock _ _ b) = cleanupBlock b +cleanupValue _ = return () + +pushScope :: ExMonad () +pushScope = tellLine "pushScope" >> modifyScopeStack (Map.empty :) + +popScope :: ExMonad () +popScope = do + vm <- get + case scopeStack vm of + [] -> niceThrowError $ "popScope on empty scope stack" + (sc:rest) -> do + cleanupScope sc + putScopeStack rest + tellLine "popScope" + +findVar :: Name -> ExMonad (Maybe (Int, GCS.Id, Value)) +findVar n = do + (VM stk os _) <- get + let mbs = map (\sc -> Map.lookup n sc) stk + dr = dropWhile isNothing mbs + gcsid = fromJust (head dr) -- not evaluated if dr == [] + if null dr + then return Nothing + else maybe (niceThrowError $ "findVar: gcsid " ++ show gcsid ++ " doesn't exist") return + (GCS.retrieve os gcsid) + >>= \value -> return (Just (length mbs - length dr, gcsid, value)) + +createVarInScope :: Scope -> ObjectStore -> Name -> Value -> ExMonad (Scope, ObjectStore) +createVarInScope sc os n val = + let (gcsid, os') = GCS.store os val + sc' = Map.insert n gcsid sc + in tellLine ("GCS store in " ++ show gcsid ++ " value " ++ show val) >> + if isNothing (Map.lookup n sc) + then return (sc', os') + else error $ "Var " ++ n ++ " already exists in createVarInScope" + +updateVarInScope :: Scope -> ObjectStore -> Name -> Value -> ExMonad ObjectStore +updateVarInScope sc os n val = do + let gcsid = maybe (error $ "Var " ++ n ++ " not found in updateVarInScope") id (Map.lookup n sc) + prev = maybe (error "Retrieve=Nothing in updateVarInScope") id (GCS.retrieve os gcsid) + cleanupValue prev + tellLine ("GCS update " ++ show gcsid ++ " to value " ++ show val) + return (GCS.update os gcsid val) + +createVarLocal :: Name -> Value -> ExMonad () +createVarLocal n val = do + vm <- get + let (VM (sc:rest) os _) = vm + (sc', os') <- createVarInScope sc os n val + put $ vm {scopeStack = sc' : rest, objStore = os'} + +updateVarAt :: Int -> Name -> Value -> ExMonad () +updateVarAt idx n val = do + vm <- get + let (VM stk os _) = vm + updateVarInScope (stk !! idx) os n val >>= putObjStore + +tellLine :: String -> ExMonad () +tellLine s = get >>= \vm -> + let lvl = length (scopeStack vm) + ind = if lvl >= 1 then take (4 * (lvl - 1)) (cycle "| ") else error "ZERO LEVEL" + in tell $ ind ++ replace "\n" ('\n' : ind) s ++ "\n" + +tellLineStandout :: String -> ExMonad () +tellLineStandout s = tell $ "\x1B[1m" ++ s ++ "\x1B[0m\n" + +replace :: String -> String -> String -> String +replace _ _ "" = "" +replace a b subj = + if take (length a) subj == a + then b ++ replace a b (drop (length a) subj) + else head subj : replace a b (tail subj) + + +makeVM :: VM +makeVM = VM [Map.empty] GCS.empty 0 + +evaluateProgram :: Program -> ExMonad () +evaluateProgram (Program (Block sts)) = mapM_ evStatement sts + +evStatement :: Statement -> ExMonad () +-- evStatement a | traceShow a False = unreachable +evStatement a = tellLine ("-# evStatement: " ++ astPretty a) >> evStatement' a + +evStatement' :: Statement -> ExMonad () +evStatement' (Declaration n e) = + getTopScope "evStatement" >>= + maybe (evExpression e >>= createVarLocal n) + (const $ niceThrowError $ "Variable " ++ n ++ " already exists in scope") + . Map.lookup n +evStatement' (Assignment n e) = + findVar n >>= + maybe (niceThrowError $ "Variable " ++ n ++ " assigned to but not found") + (\(idx, _, _) -> evExpression e >>= updateVarAt idx n) +evStatement' (Condition cond b1 b2) = + evExpression cond >>= truthValue >>= \bool -> evBlock $ if bool then b1 else b2 +evStatement' (Dive "print" al b) = do + (show <$> mapM evExpression al) >>= tellLineStandout + evBlock b +evStatement' (Dive n al b) = + findVar n >>= + maybe (niceThrowError $ "Variable " ++ n ++ " dived into but not found") + (\(_, _, value) -> case value of + (VBlock BT2 val vb) + | length al == length val -> do + pushScope + evBlockNoScope $ Block [Declaration dn de | (dn, de) <- zip val al] + evBlockNoScope vb + evBlockNoScope b + popScope + | otherwise -> + niceThrowError $ "Invalid number of arguments to dived-in block " ++ n + _ -> niceThrowError $ "Cannot dive into " ++ n ++ " of invalid type " ++ typeNameOf value) +evStatement' (Expr e) = evExpression e >>= cleanupValue + +evExpression :: Expression -> ExMonad Value +-- evExpression a | traceShow a False = unreachable +evExpression a = tellLine ("-# evExpression: " ++ astPretty a) >> evExpression' a + +evExpression' :: Expression -> ExMonad Value +evExpression' (EBin bo e1 e2) = evBO bo e1 e2 +evExpression' (EUn uo e) = evExpression e >>= evUO uo +evExpression' (ELit li) = evLiteral li + +evBlock :: Block -> ExMonad () +-- evBlock a | traceShow a False = unreachable +evBlock bl = do + pushScope + evBlockNoScope bl + popScope + +evBlockNoScope :: Block -> ExMonad () +evBlockNoScope a = tellLine ("-# evBlockNoScope: " ++ astPretty a) >> evBlockNoScope' a + +evBlockNoScope' :: Block -> ExMonad () +evBlockNoScope' (Block sts) = mapM_ evStatement sts + +evLiteral :: Literal -> ExMonad Value +evLiteral (LNum m) = return $ VNum m +evLiteral (LStr s) = return $ VStr s +evLiteral (LVar n) = + findVar n >>= maybe (niceThrowError $ "Variable " ++ n ++ " referenced but not found") (return . thrd) +evLiteral (LBlock BT0 al bl) + | length al == 0 = evBlock bl >> return VNil + | otherwise = niceThrowError $ "Immediately invoked block literal cannot have parameters" +evLiteral (LBlock bt al bl) = liftM (VBlock bt al) $ processBlock bl +evLiteral (LGCSId gcsid) = get >>= \(VM _ os _) -> maybe (niceThrowError $ "evLiteral: gcsid " ++ show gcsid ++ " doesn't exist") return (GCS.retrieve os gcsid) +evLiteral LNil = return VNil + +evUO :: UnaryOp -> Value -> ExMonad Value +evUO UONeg (VNum m) = return $ VNum (-m) +evUO UONeg value = niceThrowError $ "Operator '(-)' does not take a value of type " ++ typeNameOf value +evUO UONot value = (bool2VNum . not) <$> truthValue value + +classifyBO :: BinaryOp -> (Bool, Bool, Bool) +classifyBO bo = case bo of + BOPlus -> (True, f, f) + BOMinus -> (True, f, f) + BOMul -> (True, f, f) + BODiv -> (True, f, f) + BOMod -> (True, f, f) + BOPow -> (True, f, f) + BOLess -> (f, True, f) + BOGreater -> (f, True, f) + BOEqual -> (f, True, f) + BOLEq -> (f, True, f) + BOGEq -> (f, True, f) + BOBoolAnd -> (f, f, True) + BOBoolOr -> (f, f, True) + where f = False + +isArithBO, isCompBO {-, isBoolBO-} :: BinaryOp -> Bool +isArithBO bo = let (r, _, _) = classifyBO bo in r +isCompBO bo = let (_, r, _) = classifyBO bo in r +-- isBoolBO bo = let (_, _, r) = classifyBO bo in r + +evArithBO :: BinaryOp -> Double -> Double -> Double +evArithBO BOPlus = (+) +evArithBO BOMinus = (-) +evArithBO BOMul = (*) +evArithBO BODiv = (/) +evArithBO BOMod = \a b -> a - fromIntegral (floor (a / b) :: Integer) * b +evArithBO BOPow = (**) +evArithBO _ = unreachable + +evOrderingBO :: Ord a => BinaryOp -> a -> a -> Value +evOrderingBO bo a b = + let c = compare a b + in bool2VNum $ case bo of + BOLess -> c == LT + BOGreater -> c == GT + BOEqual -> c == EQ + BOLEq -> c == LT || c == EQ + BOGEq -> c == GT || c == EQ + _ -> unreachable + +evBO :: BinaryOp -> Expression -> Expression -> ExMonad Value +evBO bo e1 e2 + | isArithBO bo = evExpression e1 >>= \v1 -> evExpression e2 >>= \v2 -> case (v1, v2) of + (VNum m1, VNum m2) -> return $ VNum $ evArithBO bo m1 m2 + (_, _) -> niceThrowError $ "Operator '" ++ astPretty bo ++ "' does not take types " ++ + typeNameOf v1 ++ " and " ++ typeNameOf v2 + | isCompBO bo = evExpression e1 >>= \v1 -> evExpression e2 >>= \v2 -> case (v1, v2) of + (VNum m1, VNum m2) -> return $ evOrderingBO bo m1 m2 + (VStr s1, VStr s2) -> return $ evOrderingBO bo s1 s2 + (_, _) -> niceThrowError $ "Operator '" ++ astPretty bo ++ "' does not take types " ++ + typeNameOf v1 ++ " and " ++ typeNameOf v2 + | bo == BOBoolAnd = + evExpression e1 >>= truthValue >>= \v1 -> + if not v1 then return (VNum 0) + else evExpression e2 >>= truthValue >>= return . bool2VNum + | bo == BOBoolOr = + evExpression e1 >>= truthValue >>= \v1 -> + if v1 then return (VNum 1) + else evExpression e2 >>= truthValue >>= return . bool2VNum + | otherwise = unreachable + + +truthValue :: Value -> ExMonad Bool +truthValue (VNum 0) = return False +truthValue (VNum _) = return True +truthValue (VStr "") = return False +truthValue (VStr _) = return True +truthValue (VBlock _ _ _) = niceThrowError "Block not valid as truth value" +truthValue VNil = return False + +bool2VNum :: Bool -> Value +bool2VNum True = VNum 1 +bool2VNum False = VNum 0 + + +data ProcessState = ProcessState {psStack :: [Set.Set Name], psSet :: Set.Set GCS.Id} + +newtype ProcessMonad a = ProcessMonad {unProcessMonad :: State ProcessState a} + deriving (Functor, Applicative, Monad, MonadState ProcessState) + +pmModifyStack :: ([Set.Set Name] -> [Set.Set Name]) -> ProcessMonad () +pmModifyStack f = modify $ \ps@(ProcessState s _) -> ps {psStack = f s} + +pmModifyStackTop :: (Set.Set Name -> Set.Set Name) -> ProcessMonad () +pmModifyStackTop f = modify $ \ps@(ProcessState (s:ss) _) -> ps {psStack = f s : ss} + +pmModifySet :: (Set.Set GCS.Id -> Set.Set GCS.Id) -> ProcessMonad () +pmModifySet f = modify $ \ps@(ProcessState _ s) -> ps {psSet = f s} + +processBlockCollect :: [Scope] -> Block -> ProcessMonad Block +processBlockCollect gStack = goBlock + where + goBlock :: Block -> ProcessMonad Block + goBlock (Block sts) = do + pmModifyStack (Set.empty :) + b <- Block <$> mapM goStatement sts + pmModifyStack tail + return b + + goStatement :: Statement -> ProcessMonad Statement + goStatement (Declaration n e) = do + d <- Declaration n <$> goExpression e + pmModifyStackTop (Set.insert n) + return d + goStatement (Assignment n e) = Assignment n <$> goExpression e + goStatement (Condition e b1 b2) = Condition <$> goExpression e <*> goBlock b1 <*> goBlock b2 + goStatement (Dive n al b) = Dive n <$> mapM goExpression al <*> goBlock b + goStatement (Expr e) = Expr <$> goExpression e + + goExpression :: Expression -> ProcessMonad Expression + goExpression (EBin bo e1 e2) = EBin bo <$> goExpression e1 <*> goExpression e2 + goExpression (EUn uo e) = EUn uo <$> goExpression e + goExpression (ELit l) = ELit <$> goLiteral l + + goLiteral :: Literal -> ProcessMonad Literal + goLiteral (LVar name) = do + (ProcessState st _) <- get + let midx1 = findIndex (Set.member name) st + midx2 = findIndex (Map.member name) gStack + case (midx1, midx2) of + (Nothing, Nothing) -> return (LVar name) + (Just _, _) -> return (LVar name) + (Nothing, Just idx) -> + let gcsid = fromJust $ Map.lookup name (gStack !! idx) + in pmModifySet (Set.insert gcsid) >> return (LGCSId gcsid) + goLiteral (LBlock bt al bl) = LBlock bt al <$> goBlock bl + goLiteral (LGCSId gcsid) = do + pmModifySet (Set.insert gcsid) + return (LGCSId gcsid) + goLiteral l = return l + +processBlock :: Block -> ExMonad Block +processBlock block = do + tellLine ("## processBlock: " ++ astPretty block) + (VM stk os _) <- get + let (block', ProcessState _ psset) = + runState (unProcessMonad $ processBlockCollect stk block) + (ProcessState [] Set.empty) + let refitems = Set.toList psset + os' = foldl GCS.ref os psset + mapM_ (\gcsid -> tellLine ("GCS ref " ++ show gcsid)) refitems + putObjStore os' + return block' + +-- processBlock :: Block -> ExMonad Block +-- processBlock b = tellLine ("## processBlock: " ++ show b) >> modifyTempValue (const 0) >> goBlock b +-- where +-- goStatement :: Statement -> ExMonad Statement +-- goStatement (Declaration n e) = do +-- d <- Declaration n <$> goExpression e +-- createVarLocal n VNil +-- return d +-- goStatement (Assignment n e) = Assignment n <$> goExpression e +-- goStatement (Condition e b1 b2) = Condition <$> goExpression e <*> goBlock b1 <*> goBlock b2 +-- goStatement (Dive n al b') = Dive n <$> mapM goExpression al <*> goBlock b' +-- goStatement (Expr e) = Expr <$> goExpression e + +-- goBlock :: Block -> ExMonad Block +-- goBlock (Block sts) = do +-- pushScope +-- modifyTempValue succ +-- b' <- Block <$> mapM goStatement sts +-- modifyTempValue pred +-- popScope +-- return b' + +-- goExpression :: Expression -> ExMonad Expression +-- goExpression (EBin bo e1 e2) = EBin bo <$> goExpression e1 <*> goExpression e2 +-- goExpression (EUn uo e) = EUn uo <$> goExpression e +-- goExpression (ELit l) = ELit <$> goLiteral l + +-- goLiteral :: Literal -> ExMonad Literal +-- goLiteral (LVar name) = do +-- tv <- getTempValue +-- findVar name >>= +-- maybe (niceThrowError $ "Unknown variable " ++ name ++ " while processing block") +-- (\(idx, gcsid, _) -> +-- if idx >= tv +-- then modifyObjStore (\os -> GCS.ref os gcsid) +-- >> tellLine ("GCS ref " ++ show gcsid) +-- >> return (LGCSId gcsid) +-- else return (LVar name)) +-- goLiteral (LBlock bt al bl) = LBlock bt al <$> goBlock bl +-- goLiteral l = return l + + +thrd :: (a, b, c) -> c +thrd (_, _, c) = c + +unreachable :: a +unreachable = error "Unreachable" |