Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
170 lines (155 sloc) 8.12 KB
module Hardware.StackMachine (
State(Initializing),
step1, step2, outputOf, terminal
) where
import CLaSH.Prelude hiding (Read)
import Hardware.Model (Ptr(Ptr), SKI(S,K,I,T,L), Output)
import Hardware.Defs (MemRequest(..),MemResponse(..),Some(Zero,One,Two),Write(..),Read(..))
import Text.Printf (printf)
-- Count is number of items in-memory
-- As many items as possible will be in the cache
-- We need to keep up to 3 items in the cache for fast S evaluation.
-- base is where the next write will go. The head of the stack is base - 1
data Stack = Stack {cache :: SKIs, base :: Ptr, count :: Unsigned 30}
instance Show Stack where
show (Stack cache (Ptr base) count) = printf "Stack@%08x [%d in memory] {%s}" (fromEnum base) (fromEnum count) (show cache)
data SKIs = NoSKIs | OneSKI SKI | TwoSKIs SKI SKI | ThreeSKIs SKI SKI SKI deriving (Show)
-- We're using a very wasteful non-freeing heap.
-- We could implement e.g. garbage collection (?) or reference counting,
-- but that's beyond this project.
-- tip is where the next write will go.
-- Heap grows down.
data Heap = Heap {tip :: Ptr} deriving (Show)
-- The current state of the evaluator.
-- For a clearer explanation of how the evaluator works,
-- see the (non-hardware-implementable) model evaluator.
data State = Initializing | State {stack :: Stack, heap :: Heap, current :: SKI} | Terminal deriving (Show)
-- The first step: Generate memory requests.
-- Behavior varies depending on how many things are in the stack cache.
-- Therefore, this function switches on the contents of the stack cache.
-- CLaSH and synthesis optimizers should lift reduntant expressions.
step1 :: State -> MemRequest
step1 Terminal = MemRequest Zero Zero -- We are done. Nothing to request.
step1 Initializing = MemRequest (One (Read (Ptr 0))) Zero -- Read the start of the program.
step1 (State (Stack NoSKIs _ 0) _ current) = case current of
S -> error "S on empty stack"
K -> error "K on empty stack"
I -> error "I on empty stack"
T ap bp -> MemRequest (Two (Read ap) (Read bp)) Zero
L o -> MemRequest Zero Zero
step1 (State (Stack (OneSKI x) _ 0) _ current) = case current of
S -> error "S on 1-elem stack"
K -> error "K on 1-elem stack"
I -> MemRequest Zero Zero
T ap bp -> MemRequest (Two (Read ap) (Read bp)) Zero
L o -> MemRequest Zero Zero
step1 (State (Stack (TwoSKIs x y) _ 0) _ current) = case current of
S -> error "S on 2-elem stack"
K -> MemRequest Zero Zero
I -> MemRequest Zero Zero
T ap bp -> MemRequest (Two (Read ap) (Read bp)) Zero
L o -> MemRequest Zero Zero
step1 (State (Stack (ThreeSKIs x y z) base 0) heap current) = case current of
S -> MemRequest Zero (Two (Write y (tip heap)) (Write z (pred $ tip heap)))
K -> MemRequest Zero Zero
I -> MemRequest Zero Zero
T ap bp -> MemRequest (Two (Read ap) (Read bp)) (One (Write z base))
L o -> MemRequest Zero Zero
step1 (State (Stack (ThreeSKIs x y z) base 1) heap current) = case current of
S -> MemRequest (One (Read stack_head)) (Two (Write y (tip heap)) (Write z (pred $ tip heap)))
K -> MemRequest (One (Read stack_head)) Zero
I -> MemRequest (One (Read stack_head)) Zero
T ap bp -> MemRequest (Two (Read ap) (Read bp)) (One (Write z base))
L o -> MemRequest (One (Read stack_head)) Zero
where
stack_head = pred base
step1 (State (Stack (ThreeSKIs x y z) base n) heap current) = case current of
S -> MemRequest (One (Read stack_head)) (Two (Write y (tip heap)) (Write z (pred $ tip heap)))
K -> MemRequest (Two (Read stack_head) (Read $ pred stack_head)) Zero
I -> MemRequest (One (Read stack_head)) Zero
T ap bp -> MemRequest (Two (Read ap) (Read bp)) (One (Write z base))
L o -> MemRequest (One (Read stack_head)) Zero
where
stack_head = pred base
default_stack :: Stack
default_stack = Stack NoSKIs (Ptr 0x100) 0
default_heap :: Heap
default_heap = Heap (Ptr 0x4FF)
-- Step 2: Take the memory response and generate the next state.
-- This may seem somewhat complicated, but there is a fair amount of
-- conceptual redundancy. It's just a pain to deal with all the different
-- possible stack configurations.
-- In particular, we have these possibilities: (# in cache, # in RAM)
-- (0,0),(1,0),(2,0)(3,0),(3,1),(3,_)
step2 :: State -> MemResponse -> State
step2 Terminal _ = Terminal
step2 Initializing (MemResponse (One ski)) = State default_stack default_heap ski
step2 (State (Stack NoSKIs base 0) heap current) (MemResponse response)
= case (current, response) of
(S,_) -> error "S on empty stack (step 2)"
(K,_) -> error "K on empty stack (step 2)"
(I,_) -> error "I on empty stack (step 2)"
(T _ _, Two a b) -> State (Stack (OneSKI b) base 0) heap a
(L _, _) -> Terminal
step2 (State (Stack (OneSKI x) base 0) heap current) (MemResponse response)
= case (current, response) of
(S,_) -> error "S on 1-elem stack (step 2)"
(K,_) -> error "K on 1-elem stack (step 2)"
(I,_) -> State (Stack NoSKIs base 0) heap x
(T _ _, Two a b) -> State (Stack (TwoSKIs b x) base 0) heap a
(L _,_) -> State (Stack NoSKIs base 0) heap x
step2 (State (Stack (TwoSKIs x y) base 0) heap current) (MemResponse response)
= case (current, response) of
(S,_) -> error "S on 2-elem stack (step 2)"
(K,_) -> State (Stack (NoSKIs) base 0) heap x
(I,_) -> State (Stack (OneSKI y) base 0) heap x
(T _ _, Two a b) -> State (Stack (ThreeSKIs b x y) base 0) heap a
(L o,_) -> State (Stack (OneSKI y) base 0) heap x
step2 (State (Stack (ThreeSKIs x y z) base 0) heap current) (MemResponse response)
= case (current, response) of
(S,_) -> State (Stack (TwoSKIs z (T y' z')) base 0) heap' x
(K,_) -> State (Stack (OneSKI z) base 0) heap x
(I,_) -> State (Stack (TwoSKIs y z) base 0) heap x
(T _ _, Two a b) -> State (Stack (ThreeSKIs b x y) pushBase 1) heap a
(L o,_) -> State (Stack (TwoSKIs y z) base 0) heap x
where
y' = tip heap
z' = pred y'
heap' = Heap (pred z')
pushBase = succ base
step2 (State (Stack (ThreeSKIs x y z) base 1) heap current) (MemResponse response)
= case (current, response) of
(S,One h) -> State (Stack (ThreeSKIs z (T y' z') h) popBase 0) heap' x
(K,One h) -> State (Stack (TwoSKIs z h) popBase 0) heap x
(I,One h) -> State (Stack (ThreeSKIs y z h) popBase 0) heap x
(T _ _, Two a b) -> State (Stack (ThreeSKIs b x y) pushBase 2) heap a
(L _,One h) -> State (Stack (ThreeSKIs y z h) popBase 0) heap x
where
y' = tip heap
z' = pred y'
heap' = Heap (pred z')
popBase = pred base
pushBase = succ base
step2 (State (Stack (ThreeSKIs x y z) base n) heap current) (MemResponse response)
= case (current, response) of
(S,One h) -> State (Stack (ThreeSKIs z (T y' z') h) popBase dec) heap' x
(K,Two h i) -> State (Stack (ThreeSKIs z h i) popPopBase decDec) heap x
(I,One h) -> State (Stack (ThreeSKIs y z h) popBase dec) heap x
(T _ _, Two a b) -> State (Stack (ThreeSKIs b x y) pushBase inc) heap a
(L _,One h) -> State (Stack (ThreeSKIs y z h) popBase dec) heap x
where
y' = tip heap
z' = pred y'
heap' = Heap (pred z')
popBase = pred base
popPopBase = pred popBase
pushBase = succ base
inc = succ n
dec = pred n
decDec = pred dec
outputOf :: State -> Maybe Output
outputOf (State _ _ (L o)) = Just o
outputOf _ = Nothing
terminal :: State -> Bool
terminal Terminal = True
terminal _ = False