From d49dfd213e2cd384bceb38dc70eb122711d4f996 Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <m.kooijman@student.utwente.nl>
Date: Mon, 19 Jan 2009 16:45:52 +0100
Subject: [PATCH] Intial import of some haskell programs.

Contains the following files:
 * Adders.hs     - Some Haskell modelling of hardware adders.
 * Alu.hs        - A haskell model of an (extremely) simple cpu.
 * Bits.hs       - Stuff relating to a basic "Bit" datatype.
 * Inverter.hs   - A haskell model of an inverter.
 * Parser.hs     - A simple haskell parser using Language.Haskell libraries.
 * Shifter.hs    - A haskell model of an interactive xor-shifter.
 * Sim.hs        - Some utilities to run hardware models.
 * Translator.hs - A basic program that uses GHC to read Haskell code and
                   translates it into VHDL. This code is still very preliminary.
---
 Adders.hs     |  73 ++++++++++++++++++++
 Alu.hs        |  70 ++++++++++++++++++++
 Bits.hs       |  56 ++++++++++++++++
 Inverter.hs   |  12 ++++
 Parser.hs     |  73 ++++++++++++++++++++
 Shifter.hs    |  16 +++++
 Sim.hs        |  50 ++++++++++++++
 Translator.hs | 179 ++++++++++++++++++++++++++++++++++++++++++++++++++
 8 files changed, 529 insertions(+)
 create mode 100644 Adders.hs
 create mode 100644 Alu.hs
 create mode 100644 Bits.hs
 create mode 100644 Inverter.hs
 create mode 100644 Parser.hs
 create mode 100644 Shifter.hs
 create mode 100644 Sim.hs
 create mode 100644 Translator.hs

diff --git a/Adders.hs b/Adders.hs
new file mode 100644
index 0000000..c49ba81
--- /dev/null
+++ b/Adders.hs
@@ -0,0 +1,73 @@
+module Adders (main, no_carry_adder) where
+import Bits
+import Language.Haskell.Syntax
+
+main = do show_add exp_adder; show_add rec_adder;
+
+show_add f = do print ("Sum:   " ++ (displaysigs s)); print ("Carry: " ++ (displaysig c))
+  where
+    a = [High, High, High, High]
+    b = [Low, Low, Low, High]
+    (s, c) = f (a, b)
+
+-- Combinatoric no-carry adder
+-- A -> B -> S
+no_carry_adder :: (Bit, Bit) -> Bit
+no_carry_adder (a, b) = a `hwxor` b
+
+-- Combinatoric (one-bit) full adder
+-- (A, B, C) -> (S, C)
+full_adder :: (Bit, Bit, Bit) -> (Bit, Bit)
+full_adder (a, b, cin) = (s, c)
+  where
+    s = a `hwxor` b `hwxor` cin
+    c = a `hwand` b `hwor` (cin `hwand` (a `hwxor` b))
+
+-- Four bit adder
+-- Explicit version
+-- [a] -> [b] -> ([s], cout)
+exp_adder :: ([Bit], [Bit]) -> ([Bit], Bit)
+
+exp_adder ([a3,a2,a1,a0], [b3,b2,b1,b0]) =
+  ([s3, s2, s1, s0], c3)
+  where
+    (s0, c0) = full_adder (a0, b0, Low)
+    (s1, c1) = full_adder (a1, b1, c0)
+    (s2, c2) = full_adder (a2, b2, c1)
+    (s3, c3) = full_adder (a3, b3, c2)
+
+-- Any number of bits adder
+-- Recursive version
+-- [a] -> [b] -> ([s], cout)
+rec_adder :: ([Bit], [Bit]) -> ([Bit], Bit)
+
+rec_adder ([], []) = ([], Low)
+rec_adder ((a:as), (b:bs)) = 
+  (s : rest, cout)
+  where
+    (rest, cin) = rec_adder (as, bs)
+    (s, cout) = full_adder (a, b, cin)
+
+-- Four bit adder, using the continous adder below
+-- [a] -> [b] -> ([s], cout)
+--con_adder_4 as bs = 
+--  ([s3, s2, s1, s0], c)
+--  where
+--    ((s0, _):(s1, _):(s2, _):(s3, c):_) = con_adder (zip ((reverse as) ++ lows) ((reverse bs) ++ lows))
+
+-- Continuous sequential version
+-- Stream a -> Stream b -> Stream (sum, cout)
+--con_adder :: Stream (Bit, Bit) -> Stream (Bit, Bit)
+
+-- Forward to con_adder_int, but supply an initial state
+--con_adder pin =
+--  con_adder_int pin Low
+
+-- Stream a -> Stream b -> state -> Stream (s, c)
+--con_adder_int :: Stream (Bit, Bit) -> Bit -> Stream (Bit, Bit)
+--con_adder_int ((a,b):rest) cin =
+--  (s, cout) : con_adder_int rest cout
+--  where
+--    (s, cout) = full_adder a b cin
+
+-- vim: set ts=8 sw=2 sts=2 expandtab:
diff --git a/Alu.hs b/Alu.hs
new file mode 100644
index 0000000..2495df2
--- /dev/null
+++ b/Alu.hs
@@ -0,0 +1,70 @@
+module Alu (main) where
+import Bits
+import qualified Sim
+
+main = Sim.simulate exec program initial_state
+mainIO = Sim.simulateIO exec initial_state
+
+program = [
+            -- (addr, we, op)
+            (High, Low, High), -- z = r1 and t (0) ; t = r1 (1)
+            (Low, Low, Low), -- z = r0 or t (1); t = r0 (0)
+            (Low, High, DontCare), -- r0 = z (1)
+            (High, Low, High), -- z = r1 and t (0); t = r1 (1)
+            (High, High, DontCare) -- r1 = z (0)
+          ]
+
+initial_state = ((Low, High), (), Low, Low)
+
+--
+--
+
+type RegAddr = Bit
+type RegisterBankState = (Bit, Bit)
+register_bank :: 
+  (RegAddr, Bit, Bit) -> -- (addr, we, d)
+  RegisterBankState -> -- s
+  (RegisterBankState, Bit) -- (s', o)
+
+register_bank (Low, Low, _) s = -- Read r0
+  (s, fst s)
+
+register_bank (High, Low, _) s = -- Read r1
+  (s, snd s)
+
+register_bank (addr, High, d) s = -- Write
+  (s', DontCare)
+  where
+    (r0, r1) = s
+    r0' = if addr == Low then d else r0
+    r1' = if addr == High then d else r1
+    s' = (r0', r1')
+
+type AluState = ()
+type AluOp = Bit
+
+alu :: (AluOp, Bit, Bit) -> AluState -> (AluState, Bit)
+alu (High, a, b) s = ((), a `hwand` b)
+alu (Low, a, b) s = ((), a `hwor` b)
+
+type ExecState = (RegisterBankState, AluState, Bit, Bit)
+exec :: (RegAddr, Bit, AluOp) -> ExecState -> (ExecState, ())
+
+-- Read & Exec
+exec (addr, Low, op) s =
+  (s', ())
+  where
+    (reg_s, alu_s, t, z) = s
+    (reg_s', t') = register_bank (addr, Low, DontCare) reg_s
+    (alu_s', z') = alu (op, t', t) alu_s
+    s' = (reg_s', alu_s', t', z')
+
+-- Write
+exec (addr, High, op) s =
+  (s', ())
+  where
+    (reg_s, alu_s, t, z) = s
+    (reg_s', _) = register_bank (addr, High, z) reg_s
+    s' = (reg_s', alu_s, t, z)
+
+-- vim: set ts=8 sw=2 sts=2 expandtab:
diff --git a/Bits.hs b/Bits.hs
new file mode 100644
index 0000000..c0717bf
--- /dev/null
+++ b/Bits.hs
@@ -0,0 +1,56 @@
+module Bits where
+
+--class Signal a where
+--	hwand :: a -> a -> a
+--	hwor  :: a -> a -> a
+--	hwxor :: a -> a -> a
+--	hwnot :: a -> a
+--
+--	-- Prettyprint a signal. We're not extending Show here, since show must
+--	-- return a valid haskell syntax
+--	displaysig :: a -> String
+
+hwand :: Bit -> Bit -> Bit
+hwor  :: Bit -> Bit -> Bit
+hwxor :: Bit -> Bit -> Bit
+hwnot :: Bit -> Bit
+
+-- Prettyprint Bit signal. We're not extending Show here, since show must
+-- return Bit valid haskell syntax
+displaysig :: Bit -> String
+
+--instance Signal Bit where
+High `hwand` High = High
+_ `hwand` _ = Low
+
+High `hwor` _  = High
+_ `hwor` High  = High
+Low `hwor` Low = Low
+
+High `hwxor` Low = High
+Low `hwxor` High = High
+_ `hwxor` _      = Low
+
+hwnot High = Low
+hwnot Low  = High
+
+displaysig High = "1" 
+displaysig Low  = "0"
+
+-- The plain Bit type
+data Bit = High | Low | DontCare
+  deriving (Show, Eq, Read)
+
+-- A function to prettyprint a bitvector
+
+--displaysigs :: (Signal s) => [s] -> String
+displaysigs :: [Bit] -> String
+displaysigs = (foldl (++) "") . (map displaysig)
+
+type Stream a = [a]
+
+-- An infinite streams of highs or lows
+lows  = Low : lows
+highs = High : highs
+
+-- vim: set ts=8 sw=2 sts=2 expandtab:
diff --git a/Inverter.hs b/Inverter.hs
new file mode 100644
index 0000000..7d077e1
--- /dev/null
+++ b/Inverter.hs
@@ -0,0 +1,12 @@
+module Inverter (main) where
+import Bits
+import qualified Sim
+
+main = Sim.simulate inverter [High, Low, High, Low] ()
+mainIO = Sim.simulateIO inverter ()
+
+type InverterState = ()
+inverter :: Bit -> InverterState -> (InverterState, Bit)
+inverter a s = (s, hwnot a)
+
+-- vim: set ts=8 sw=2 sts=2 expandtab:
diff --git a/Parser.hs b/Parser.hs
new file mode 100644
index 0000000..d2bd651
--- /dev/null
+++ b/Parser.hs
@@ -0,0 +1,73 @@
+module Main (main) where
+import Language.Haskell.Syntax
+import Language.Haskell.Pretty
+import Language.Haskell.Parser
+import GHC
+
+main =
+	do 
+		let filename = "adder.hs"
+		-- Read the file
+		file <- readFile filename
+		-- Parse the file
+		let mode = ParseMode {parseFilename = filename}
+		    ParseOk mod = parseModuleWithMode mode file
+		-- Print funky stuff
+		--putStr $ foldl (\s d -> s ++ (show d) ++ "\n\n") "" (decls mod)
+		putList (findfunc "exp_adder" (decls mod))
+
+decls (HsModule _ _ _ _ decls) =
+	decls
+
+name (HsModule _ n _ _ _) =
+	n
+
+findfunc :: 
+            String        -- Function name to find
+         -> [HsDecl]      -- Decls to search
+				 -> [HsMatch]
+
+findfunc name decls = foldl (findmatches name) [] decls
+
+-- Look at a HsDecl and add all HsMatches in it with the sought name to res
+findmatches name res (HsFunBind matches) = res ++ filter (filtermatch name) matches
+findmatches name res _ = res
+
+-- Look at a single match and see if it has the sought name
+filtermatch name (HsMatch _ (HsIdent n) _ _ _) =
+	n == name
+
+-- Print a list of showable things, separated by newlines instead of ,
+-- Also pretty prints them
+putList :: (Show a, Pretty a) => [a] -> IO ()
+putList (x:xs) =
+	do
+		indent 0 (show x)
+		putStr "\n"
+		putStr $ prettyPrint x
+		putStr "\n\n"
+		putList xs
+
+putList [] =
+	do return ()
+
+-- Add indentations to the given string
+indent :: Int -> String -> IO ()
+indent n (x:xs) = do 
+	if x `elem` "[(" 
+		then do
+			putChar x
+			putStr "\n"
+			putStr (replicate (n + 1) ' ')
+			indent (n + 1) xs
+		else if x `elem` "])" 
+			then do
+				putStr "\n"
+				putStr (replicate (n - 1) ' ')
+				putChar x
+				indent (n - 1) xs
+			else do 
+				putChar x
+				indent n xs
+
+indent n [] = do return ()
diff --git a/Shifter.hs b/Shifter.hs
new file mode 100644
index 0000000..15f6790
--- /dev/null
+++ b/Shifter.hs
@@ -0,0 +1,16 @@
+module Shifter (main, mainIO) where
+import Bits
+import qualified Sim
+
+main = Sim.simulate shifter [High, Low, Low, Low] [High, Low, High, Low]
+mainIO = Sim.simulateIO shifter [High, Low, High, Low]
+
+type ShifterState = [Bit]
+shifter :: Bit -> ShifterState -> (ShifterState, Bit)
+shifter i s =
+  (s', o)
+  where
+    s' = (o `hwxor` i) : (init s)
+    o  = last s
+
+-- vim: set ts=8 sw=2 sts=2 expandtab:
diff --git a/Sim.hs b/Sim.hs
new file mode 100644
index 0000000..0820d13
--- /dev/null
+++ b/Sim.hs
@@ -0,0 +1,50 @@
+module Sim (simulate, Circuit, simulateIO) where
+import Data.Typeable
+
+simulate f input s = do
+  putStr "Input: "
+  putStr $ show input
+  putStr "\nInitial State: "
+  putStr $ show s
+  putStr "\n\n"
+  foldl1 (>>) (map (printOutput) output)
+  where
+    output = run f input s
+
+-- A circuit with input of type a, state of type s and output of type b
+type Circuit a s b = a -> s -> (s, b)
+
+run :: Circuit a s b -> [a] -> s -> [(s, b)]
+run f (i:input) s =
+  (s', o): (run f input s')
+  where
+    (s', o) = f i s
+run _ [] _ = []
+
+simulateIO :: (Read a, Show b, Show s) => Sim.Circuit a s b -> s -> IO()
+simulateIO c s = do
+  putStr "Initial State: "
+  putStr $ show s
+  putStr "\n\n"
+  runIO c s
+
+runIO :: (Read a, Show b, Show s) => Sim.Circuit a s b -> s -> IO()
+runIO f s = do
+  putStr "\nInput: "
+  line <- getLine
+  if (line == "") then
+      return ()
+    else
+      let i = (read line) in do
+      let (s', o) = f i s in do
+      printOutput (s', o)
+      simulateIO f s'
+
+printOutput :: (Show s, Show o) => (s, o) -> IO ()
+printOutput (s, o) = do
+  putStr "Output: "
+  putStr $ show o
+  putStr "\nNew State: "
+  putStr $ show s
+  putStr "\n\n"
+-- vim: set ts=8 sw=2 sts=2 expandtab:
diff --git a/Translator.hs b/Translator.hs
new file mode 100644
index 0000000..64cdb51
--- /dev/null
+++ b/Translator.hs
@@ -0,0 +1,179 @@
+module Main(main) where
+import GHC
+import CoreSyn
+import qualified CoreUtils
+import qualified Var
+import qualified Type
+import qualified TyCon
+import qualified DataCon
+import qualified Maybe
+import Name
+import Data.Generics
+import NameEnv ( lookupNameEnv )
+import HscTypes ( cm_binds, cm_types )
+import MonadUtils ( liftIO )
+import Outputable ( showSDoc, ppr )
+import GHC.Paths ( libdir )
+import DynFlags ( defaultDynFlags )
+import List ( find )
+
+main = 
+		do
+			defaultErrorHandler defaultDynFlags $ do
+				runGhc (Just libdir) $ do
+					dflags <- getSessionDynFlags
+					setSessionDynFlags dflags
+					--target <- guessTarget "adder.hs" Nothing
+					--liftIO (print (showSDoc (ppr (target))))
+					--liftIO $ printTarget target
+					--setTargets [target]
+					--load LoadAllTargets
+					--core <- GHC.compileToCoreSimplified "Adders.hs"
+					core <- GHC.compileToCoreSimplified "Adders.hs"
+					liftIO $ printBinds (cm_binds core)
+					let bind = findBind "no_carry_adder" (cm_binds core)
+					let NonRec var expr = bind
+					liftIO $ putStr $ showSDoc $ ppr expr
+					liftIO $ putStr "\n\n"
+					liftIO $ putStr $ getEntity bind
+					liftIO $ putStr $ getArchitecture bind
+					return expr
+
+printTarget (Target (TargetFile file (Just x)) obj Nothing) =
+	print $ show file
+
+printBinds [] = putStr "done\n\n"
+printBinds (b:bs) = do
+	printBind b
+	putStr "\n"
+	printBinds bs
+
+printBind (NonRec b expr) = do
+	putStr "NonRec: "
+	printBind' (b, expr)
+
+printBind (Rec binds) = do
+	putStr "Rec: \n"	
+	foldl1 (>>) (map printBind' binds)
+
+printBind' (b, expr) = do
+	putStr $ getOccString b
+	--putStr $ showSDoc $ ppr expr
+	putStr "\n"
+
+findBind :: String -> [CoreBind] -> CoreBind
+findBind lookfor =
+	-- This ignores Recs and compares the name of the bind with lookfor,
+	-- disregarding any namespaces in OccName and extra attributes in Name and
+	-- Var.
+	Maybe.fromJust . find (\b -> case b of 
+		Rec l -> False
+		NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
+	)
+
+-- Generate a port (or multiple for tuple types) in the given direction for
+-- each type given.
+getPortsForTys :: String -> String -> Int -> [Type] -> String
+getPortsForTys dir prefix num [] = ""
+getPortsForTys dir prefix num (t:ts) = 
+	(getPortsForTy dir (prefix ++ show num) t) ++ getPortsForTys dir prefix (num + 1) ts
+
+getPortsForFunTy ty =
+		-- All of a function's arguments become IN ports, the result becomes on
+		-- (or more) OUT ports.
+		-- Drop the first ;\n
+		drop 2 (getPortsForTys "in" "portin" 0 args) ++ (getPortsForTy "out" "portout" res) ++ "\n"
+	where
+		(args, res) = Type.splitFunTys ty
+
+getPortsForTy	:: String -> String -> Type -> String
+getPortsForTy dir name ty =
+	if (TyCon.isTupleTyCon tycon) then
+		-- Expand tuples we find
+		getPortsForTys dir name 0 args
+	else -- Assume it's a type constructor application, ie simple data type
+		let 
+			vhdlTy = showSDoc $ ppr $ TyCon.tyConName tycon;
+		in
+			";\n\t" ++ name ++ " : " ++ dir ++ " " ++ vhdlTy
+	where
+		(tycon, args) = Type.splitTyConApp ty 
+
+getEntity (NonRec var expr) =
+		"entity " ++ name ++ " is\n"
+		++ "port (\n"
+		++ getPortsForFunTy ty
+	  ++ ");\n"
+		++ "end " ++ name ++ ";\n\n"
+	where
+		name = (getOccString var)
+		ty = CoreUtils.exprType expr
+
+-- Accepts a port name and an argument to map to it.
+-- Returns the appropriate line for in the port map
+getPortMapEntry binds portname (Var id) = 
+	"\t" ++ portname ++ " => " ++ signalname ++ "\n"
+	where
+		Port signalname = Maybe.fromMaybe
+			(error $ "Argument " ++ getOccString id ++ "is unknown")
+			(lookup id binds)
+
+getPortMapEntry binds _ a = error $ "Unsupported argument: " ++ (showSDoc $ ppr a)
+
+getInstantiations ::
+	PortNameMap                  -- The arguments that need to be applied to the
+															 -- expression. Should always be the Args
+															 -- constructor.
+	-> [(CoreBndr, PortNameMap)] -- A list of bindings in effect
+	-> CoreSyn.CoreExpr          -- The expression to generate an architecture for
+	-> String                    -- The resulting VHDL code
+
+-- A lambda expression binds the first argument (a) to the binder b.
+getInstantiations (Args (a:as)) binds (Lam b expr) =
+	getInstantiations (Args as) ((b, a):binds) expr
+
+-- A case expression that checks a single variable and has a single
+-- alternative, can be used to take tuples apart
+getInstantiations args binds (Case (Var v) b _ [res]) =
+	case altcon of
+		DataAlt datacon ->
+			if (DataCon.isTupleCon datacon) then
+				getInstantiations args binds' expr
+			else
+				error "Data constructors other than tuples not supported"
+		otherwise ->
+			error "Case binders other than tuples not supported"
+	where
+		binds' = (zip bind_vars tuple_ports) ++ binds
+		(altcon, bind_vars, expr) = res
+		-- Find the portnamemaps for each of the tuple's elements
+		Tuple tuple_ports = Maybe.fromMaybe 
+			(error $ "Case expression uses unknown scrutinee " ++ getOccString v)
+			(lookup v binds)
+
+-- An application is an instantiation of a component
+getInstantiations args binds app@(App expr arg) =
+	--indent ++ "F:\n" ++ (getInstantiations (' ':indent) expr) ++ "\n" ++ indent ++ "A:\n" ++ (getInstantiations (' ':indent) arg) ++ "\n"
+	"app : " ++ (getOccString f) ++ "\n"
+	++ "port map (\n"
+	++ concat (zipWith (getPortMapEntry binds) ["portin0", "portin1"] args)
+	++ ");\n"
+	where
+		((Var f), args) = collectArgs app
+
+getInstantiations args binds expr = showSDoc $ ppr $ expr
+
+getArchitecture (NonRec var expr) =
+	"architecture structural of " ++ name ++ " is\n"
+	++ "begin\n"
+	++ getInstantiations (Args [Tuple [Port "portin0", Port "portin1"]]) [] expr
+	++ "end structural\n"
+	where
+		name = (getOccString var)
+		ty = CoreUtils.exprType expr
+
+data PortNameMap =
+	Args [PortNameMap] -- Each of the submaps represent an argument to the
+	                   -- function. Should only occur at top level.
+	| Tuple [PortNameMap]
+	| Port  String
-- 
2.30.2