Put code in colored boxes

[matthijs/master-project/haskell-symposium-talk.git] / PolyAlu.hs

diff --git a/PolyAlu.hs b/PolyAlu.hs
index afe9f5deaca3e649b4fb4c3e934bc2a698393132..23dfaa4fbe0fd47139e430f6ccfb1b2a47927efb 100644 (file)
--- a/PolyAlu.hs
+++ b/PolyAlu.hs
@@ -1,33 +1,34 @@
 {-# LINE 4 "PolyAlu.lhs" #-}
 {-#  LANGUAGE  TypeOperators, TypeFamilies, FlexibleContexts  #-}
-module PolyCPU where
+module Main where
 
 import qualified Prelude as P
-{-# LINE 27 "PolyAlu.lhs" #-}
+{-# LINE 29 "PolyAlu.lhs" #-}
 import CLasH.HardwareTypes
+{-# LINE 36 "PolyAlu.lhs" #-}
 import CLasH.Translator.Annotations
-{-# LINE 37 "PolyAlu.lhs" #-}
+{-# LINE 48 "PolyAlu.lhs" #-}
 type Op s a         =   a -> Vector s a -> a
 type Opcode         =   Bit
-{-# LINE 42 "PolyAlu.lhs" #-}
+{-# LINE 56 "PolyAlu.lhs" #-}
 type RegBank s a    =   Vector (s :+: D1) a
 type RegState s a   =   State (RegBank s a)
-{-# LINE 47 "PolyAlu.lhs" #-}
+{-# LINE 64 "PolyAlu.lhs" #-}
 type Word           =   SizedInt D12
-{-# LINE 55 "PolyAlu.lhs" #-}
+{-# LINE 76 "PolyAlu.lhs" #-}
 primOp :: (a -> a -> a) -> Op s a
 primOp f a b = a `f` a
-{-# LINE 60 "PolyAlu.lhs" #-}
+{-# LINE 84 "PolyAlu.lhs" #-}
 vectOp :: (a -> a -> a) -> Op s a
 vectOp f a b = foldl f a b
-{-# LINE 69 "PolyAlu.lhs" #-}
+{-# LINE 96 "PolyAlu.lhs" #-}
 alu :: 
   Op s a -> 
   Op s a -> 
   Opcode -> a -> Vector s a -> a
 alu op1 op2 Low    a b = op1 a b
 alu op1 op2 High   a b = op2 a b
-{-# LINE 82 "PolyAlu.lhs" #-}
+{-# LINE 112 "PolyAlu.lhs" #-}
 registerBank :: 
   ((NaturalT s ,PositiveT (s :+: D1),((s :+: D1) :>: s) ~ True )) =>
   (RegState s a) -> a -> RangedWord s ->
@@ -37,20 +38,42 @@ registerBank (State mem) data_in rdaddr wraddr wrenable =
   ((State mem'), data_out)
   where
     data_out  =   mem!rdaddr
-    mem'          | wrenable == Low  = mem
-                  | otherwise        = replace mem wraddr data_in
-{-# LINE 100 "PolyAlu.lhs" #-}
+    mem'  | wrenable == Low    = mem
+          | otherwise          = replace mem wraddr data_in
+{-# LINE 133 "PolyAlu.lhs" #-}
 {-# ANN actual_cpu TopEntity#-}
 actual_cpu :: 
-  (Opcode, Word, Vector D4 Word, 
-  RangedWord D9, 
-  RangedWord D9, Bit) -> 
-  RegState D9 Word ->
+  (Opcode, Word, Vector D4 Word, RangedWord D9, 
+  RangedWord D9, Bit) ->  RegState D9 Word ->
   (RegState D9 Word, Word)
 
 actual_cpu (opc, a ,b, rdaddr, wraddr, wren) ram = (ram', alu_out)
   where
-    alu_out = alu simpleOp vectorOp opc ram_out b
+    alu_out = alu (primOp (+)) (vectOp (+)) opc ram_out b
     (ram',ram_out)  = registerBank ram a rdaddr wraddr wren
-    simpleOp =  primOp  (+)
-    vectorOp =  vectOp  (+)
+{-# LINE 149 "PolyAlu.lhs" #-}
+{-# ANN initstate InitState#-}
+initstate :: RegState D9 Word
+initstate = State (copy (0 :: Word))  
+  
+{-# ANN program TestInput#-}
+program :: [(Opcode, Word, Vector D4 Word, RangedWord D9, RangedWord D9, Bit)]
+program =
+  [ (Low, 4, copy (0::Word), 0, 0, High) --  Write 4 to Reg0, out = 0
+  , (Low, 3, copy (0::Word), 0, 1, High) --  Write 3 to Reg1, out = Reg0 + Reg0 = 8
+  , (High,0, copy (3::Word), 1, 0, Low)  --  No Write       , out = 15
+  ]
+
+run func state [] = []
+run func state (i:input) = o:out
+  where
+    (state', o) = func i state
+    out         = run func state' input
+    
+main :: IO ()
+main = do
+  let input = program
+  let istate = initstate
+  let output = run actual_cpu istate input
+  mapM_ (\x -> putStr $ ("# (" P.++ (show x) P.++ ")\n")) output
+  return ()