diff options
Diffstat (limited to 'vm.hs')
| -rw-r--r-- | vm.hs | 78 |
1 files changed, 51 insertions, 27 deletions
@@ -21,7 +21,13 @@ type TempMap = Map.Map Int RunValue data State = State TempMap ([RunValue] {- current arguments -}, [RunValue] {- current closure -}) -data RunValue = RClosure Name [RunValue] | RValue Value +-- TODO: are more constructors from Value needed? +data RunValue + = RVClosure Name [RunValue] + | RVList [RunValue] + | RVNum Int + | RVString String + | RVQuoted RunValue deriving Show kErrorExit :: String @@ -47,20 +53,28 @@ vmRunInstr :: Info -> State -> Instruction -> IO State -- vmRunInstr _ _ ins | traceShow ins False = undefined vmRunInstr info@(Info bbmap gfds datas) state@(State tmap (args, closure)) (dest, instr) = case instr of IAssign ref -> return (assignRef state dest (findRef tmap ref)) - IParam i -> return (assignRef state dest (args !! i)) - IClosure i -> return (assignRef state dest (closure !! i)) - IData i -> return (assignRef state dest (RValue (datas !! i))) - ICallC cl as -> case findRef tmap cl of - RClosure clname clvals -> case Map.lookup clname gfds of - Just (GlobFuncDef b _ _) -> - let Just bb = Map.lookup b bbmap - in do - -- traceM ("call " ++ show cl ++ " with arguments " ++ show (map (findRef tmap) as)) - (rv, _) <- vmRunBB info (State tmap (map (findRef tmap) as, clvals)) bb - return (assignRef state dest rv) - Nothing -> liftM (assignRef state dest) (vmRunBuiltin clname (map (findRef tmap) as)) - _ -> error "VM: Cannot call non-closure object" - IAllocClo name clrefs -> return (assignRef state dest (RClosure name (map (findRef tmap) clrefs))) + IParam i -> + if i < length args then return (assignRef state dest (args !! i)) + else error $ show closure ++ ", " ++ show i ++ ", param-out-of-range" + IClosure i -> + if i < length closure then return (assignRef state dest (closure !! i)) + else error $ show closure ++ ", " ++ show i ++ ", closure-out-of-range" + IData i -> + if i < length datas then return (assignRef state dest (toRunValue (datas !! i))) + else error "data-out-of-range" + ICallC cl as -> + -- trace ("callc " ++ show (findRef tmap cl) ++ " " ++ show (map (findRef tmap) as)) $ + case findRef tmap cl of + RVClosure clname clvals -> case Map.lookup clname gfds of + Just (GlobFuncDef b _ _) -> + let Just bb = Map.lookup b bbmap + in do + -- traceM ("call " ++ show cl ++ " with arguments " ++ show (map (findRef tmap) as)) + (rv, _) <- vmRunBB info (State tmap (map (findRef tmap) as, clvals)) bb + return (assignRef state dest rv) + Nothing -> liftM (assignRef state dest) (vmRunBuiltin clname (map (findRef tmap) as)) + obj -> error $ "VM: Cannot call non-closure object: " ++ show obj + IAllocClo name clrefs -> return (assignRef state dest (RVClosure name (map (findRef tmap) clrefs))) IDiscard _ -> return state vmRunTerm :: Info -> State -> Terminator -> IO (RunValue, State) @@ -72,9 +86,9 @@ vmRunTerm info@(Info bbmap _ _) state@(State tmap _) term = case term of IUnknown -> undefined findRef :: TempMap -> Ref -> RunValue -findRef _ (RConst n) = RValue (VNum n) +findRef _ (RConst n) = RVNum n findRef tmap (RTemp i) = fromJust (Map.lookup i tmap) -findRef _ (RSClo name) = RClosure name [] +findRef _ (RSClo name) = RVClosure name [] findRef _ RNone = error "VM: None ref used" assignRef :: State -> Ref -> RunValue -> State @@ -83,19 +97,29 @@ assignRef _ ref _ = error $ "VM: Unexpected ref " ++ show ref ++ " assigned" vmRunBuiltin :: Name -> [RunValue] -> IO RunValue -- vmRunBuiltin name args | trace (name ++ " " ++ show args) False = undefined -vmRunBuiltin "print" as = putStrLn (intercalate ", " (map printshow as)) >> return (RValue (VList [])) -vmRunBuiltin "<=" [RValue (VNum a), RValue (VNum b)] = return (RValue (VNum (fromEnum (a <= b)))) -vmRunBuiltin "+" [RValue (VNum a), RValue (VNum b)] = return (RValue (VNum (a + b))) -vmRunBuiltin "-" [RValue (VNum a), RValue (VNum b)] = return (RValue (VNum (a - b))) -vmRunBuiltin "car" [RValue (VList (a:_))] = return (RValue a) -vmRunBuiltin "cdr" [RValue (VList (_:a))] = return (RValue (VList a)) +vmRunBuiltin "print" as = putStrLn (intercalate ", " (map printshow as)) >> return (RVList []) +vmRunBuiltin "<=" [RVNum a, RVNum b] = return (RVNum (fromEnum (a <= b))) +vmRunBuiltin "+" [RVNum a, RVNum b] = return (RVNum (a + b)) +vmRunBuiltin "-" [RVNum a, RVNum b] = return (RVNum (a - b)) +vmRunBuiltin "car" [RVList (a:_)] = return a +vmRunBuiltin "cdr" [RVList (_:a)] = return (RVList a) +vmRunBuiltin "list" values = return (RVList values) vmRunBuiltin name args = error (name ++ " " ++ show args) printshow :: RunValue -> String -printshow (RValue (VString str)) = str -printshow (RValue value) = show value -printshow (RClosure _ _) = "[closure]" +printshow (RVString str) = str +printshow (RVList values) = show values +printshow (RVNum i) = show i +printshow (RVQuoted value) = '\'' : show value +printshow (RVClosure _ _) = "[closure]" truthy :: RunValue -> Bool -truthy (RValue (VNum n)) = n /= 0 +truthy (RVNum n) = n /= 0 truthy _ = True + +toRunValue :: Value -> RunValue +toRunValue (VList values) = RVList (map toRunValue values) +toRunValue (VNum i) = RVNum i +toRunValue (VString s) = RVString s +toRunValue (VQuoted value) = RVQuoted (toRunValue value) +toRunValue _ = undefined |