module Core.GMachine (eval) where
import Core.Grammar
import Core.G
import qualified Data.Map as M (Map, lookup, insert, fromList)
eval :: GmState -> [GmState]
eval state = state : restStates where
restStates | gmFinal state = []
| otherwise = eval nextState
nextState = doAdmin (step state)
gmFinal :: GmState -> Bool
gmFinal s = case (getCode s) of [] -> True
otherwise -> False
doAdmin :: GmState -> GmState
doAdmin s = putStats (statIncSteps (getStats s)) s
step :: GmState -> GmState
step state = dispatch i (putCode is state) where
(i:is) = getCode state
dispatch :: Instruction -> GmState -> GmState
dispatch (Pushglobal f) = pushglobal f
dispatch (Pushint n) = pushint n
dispatch (Pushbasic n) = pushbasic n
dispatch Mkap = mkap
dispatch Mkint = mkInt
dispatch Mkbool = mkBool
dispatch (Push n) = push n
dispatch (Pop n) = pop n
dispatch (Update n) = update n
dispatch Unwind = unwind
dispatch (Slide n) = slide n
dispatch (Alloc n) = alloc n
dispatch Eval = evalI
dispatch Add = add
dispatch Sub = sub
dispatch Mul = mul
dispatch Div = divide
dispatch Neg = neg
dispatch Eq = eq
dispatch Ne = ne
dispatch Lt = lt
dispatch Le = le
dispatch Gt = gt
dispatch Ge = ge
dispatch (Cond c1 c2) = cond c1 c2
dispatch (Pack t n) = pack t n
dispatch (Casejump cases) = casejump cases
dispatch (Split n) = split n
dispatch Print = printt
dispatch Get = get
pushglobal :: Name -> GmState -> GmState
pushglobal f state = let a = M.lookup f (getGlobals state) in
case a of Just add -> putStack (add: getStack state) state
Nothing -> error ("pushglobal: global " ++ f ++ " not found in globals")
pushint :: Int -> GmState -> GmState
pushint n state =
let maybeAddr = M.lookup (show n) (getGlobals state)
pushintHelper s = putHeap newHeap (putStack (a: getStack s) s)
(newHeap, a) = hAlloc (getHeap state) (NNum n) in
case maybeAddr of Just addr -> (putStack (addr: getStack state) state) where
Nothing -> pushintHelper $ putGlobals (show n) a state
pushbasic :: Int -> GmState -> GmState
pushbasic n state =
let vstack = getVStack state in putVStack (n:vstack) state
mkap :: GmState -> GmState
mkap state =
putHeap newHeap (putStack (newAddress:addresses) state) where
(newHeap, newAddress) = hAlloc (getHeap state) (NAp a1 a2)
(a1:a2:addresses) = getStack state
mkInt :: GmState -> GmState
mkInt state =
let stack = getStack state
heap = getHeap state
(n:v) = getVStack state
(newHeap, add) = hAlloc heap (NNum n)
in putVStack v $ putStack (add:stack) $ putHeap newHeap state
mkBool :: GmState -> GmState
mkBool state =
let stack = getStack state
heap = getHeap state
(t:v) = getVStack state
(newHeap, add) = hAlloc heap (NConstr t [])
in putVStack v $ putStack (add:stack) $ putHeap newHeap state
push :: Int -> GmState -> GmState
push n state =
let as = getStack state
a = (as !! n) in putStack (a:as) state
pop :: Int -> GmState -> GmState
pop n state = putStack (drop n stack) state where
stack = getStack state
update :: Int -> GmState -> GmState
update n state =
let (a:as) = getStack state
in putHeap (hUpdate (getHeap state) (as !! n) (NInd a)) (putStack as state)
unwind :: GmState -> GmState
unwind state =
let stack@(a:as) = getStack state
dump = getDump state
heap = getHeap state
replaceAddrs name = putStack (rearrange name heap stack)
n = (hLookup heap a)
newState (NNum num) = updateFromDump a dump state
newState (NConstr t s) = updateFromDump a dump state
newState (NAp a1 a2) = putCode [Unwind] (putStack (a1:a:as) state)
newState (NInd ia) = putCode [Unwind] (putStack (ia:as) state)
newState (NGlobal na c) | length as < na =
case dump of ((i,s):d) -> putCode i $
putStack ((last stack):s) $
putDump d state
[] -> error "unwind: dump should not be empty"
| otherwise =
replaceAddrs na $ putCode c state in
case n of Just node -> newState node
Nothing -> error "unwind: address not found in heap"
updateFromDump :: Addr -> GmDump -> GmState -> GmState
updateFromDump address dump state =
case dump of [] -> state
((i,s):d) -> putDump d $
putCode i $
putStack (address:s) state
rearrange :: Int -> GmHeap -> GmStack -> GmStack
rearrange n heap as =
let newAs = mapM ((getArg =<<) . hLookup heap) (tail as) in
case newAs of Just addrs -> take n addrs ++ drop n as
Nothing -> error "rearrange: address not found in heap"
getArg :: Node -> Maybe Addr
getArg (NAp a1 a2) = return a2
slide :: Int -> GmState -> GmState
slide n state = putStack (a : drop n as) state where
(a:as) = getStack state
alloc :: Int -> GmState -> GmState
alloc n state = let (newHeap, addrs) = allocNodes n (getHeap state)
stack = getStack state in
putHeap newHeap $ putStack (addrs ++ stack) state
allocNodes :: Int -> GmHeap -> (GmHeap, [Addr])
allocNodes 0 heap = (heap, [])
allocNodes n heap = (heap2, a:as) where
(heap1, as) = allocNodes (n1) heap
(heap2, a) = hAlloc heap1 (NInd hNull)
evalI :: GmState -> GmState
evalI state =
let code = getCode state
(a:as) = getStack state
dump = getDump state in
putCode [Unwind] $ putStack [a] $ putDump ((code, as):dump) state
add :: GmState -> GmState
add state = arithmetic2 (+) state
sub :: GmState -> GmState
sub state = arithmetic2 () state
divide :: GmState -> GmState
divide state = arithmetic2 (div) state
mul :: GmState -> GmState
mul state = arithmetic2 (*) state
neg :: GmState -> GmState
neg state = arithmetic1 (* (1)) state
eq :: GmState -> GmState
eq state = comparison (==) state
ne :: GmState -> GmState
ne state = comparison (/=) state
le :: GmState -> GmState
le state = comparison (<=) state
lt :: GmState -> GmState
lt state = comparison (<) state
gt :: GmState -> GmState
gt state = comparison (>) state
ge :: GmState -> GmState
ge state = comparison (>=) state
comparison :: (Int -> Int -> Bool) -> StateTran
comparison op state =
let (a0:a1:as) = getVStack state
bool = (a0 `op` a1)
vBool n = putVStack (n:as) state in
if bool then vBool 2 else vBool 1
arithmetic1 :: MOperator Int Int -> StateTran
arithmetic1 op state = putVStack (op a : v) state where
(a:v) = getVStack state
arithmetic2 :: DOperator Int Int -> StateTran
arithmetic2 op state = putVStack ((a0 `op` a1):as) state where
(a0:a1:as) = getVStack state
cond :: GmCode -> GmCode -> GmState -> GmState
cond t f state =
let (n:v) = getVStack state
i = getCode state in
case n of 2 -> putCode (t++i) $ putVStack v state
1 -> putCode (f++i) $ putVStack v state
_ -> error $ "cond: the number " ++ show n ++ " is not valid"
pack :: Int -> Int -> GmState -> GmState
pack t n state =
let stack = getStack state
heap = getHeap state
(newHeap, a) = hAlloc heap (NConstr t (take n stack)) in
putStack (a:(drop n stack)) $ putHeap newHeap state
casejump :: [(Int, GmCode)] -> GmState -> GmState
casejump cases state =
let (a:s) = getStack state
i = getCode state
heap = getHeap state
maybeNode = hLookup heap a
maybeCode typ = lookup typ cases
message t = "code for <" ++ show t ++ "> not found in cases"
typeCode t = case (maybeCode t) of Just code -> code
_ -> error (message t) in
case maybeNode of Just (NConstr t ss) -> putCode ((typeCode t)++i) state
_ -> error "casejump: node not found in heap"
split :: Int -> GmState -> GmState
split n state =
let (a:as) = getStack state
heap = getHeap state
maybeNC = hLookup heap a in
case maybeNC of Just (NConstr t s) -> putStack (s++as) state
_ -> error "split: node not found in heap"
printt :: GmState -> GmState
printt state =
let (a:as) = getStack state
heap = getHeap state
output = getOutput state
i = getCode state
appP xs = take (2 * (length xs)) $ cycle [Eval, Print]
maybeNode = hLookup heap a in
case maybeNode of
Just (NNum n) -> putStack as $ putOutput (output ++ " " ++ (show n)) state
Just (NConstr t s) -> putOutput ("<" ++ show t ++ ">") $ putCode ((appP s)++i) $ putStack (s++as) state
_ -> error $ "address " ++ show a ++ " not found in heap"
get :: GmState -> GmState
get state =
let (a:as) = getStack state
heap = getHeap state
maybeNode = hLookup heap a
v = getVStack state
getH val = putStack as $ putVStack (val:v) state
in case maybeNode of Just (NConstr t _) -> getH t
Just (NNum n) -> getH n
_ -> error "get: node not found in heap"