From: Matthijs Kooijman <m.kooijman@student.utwente.nl>
Date: Mon, 19 Jan 2009 15:45:52 +0000 (+0100)
Subject: Intial import of some haskell programs.
X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fmaster-project%2Fc%CE%BBash.git;a=commitdiff_plain;h=d49dfd213e2cd384bceb38dc70eb122711d4f996

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.
---

d49dfd213e2cd384bceb38dc70eb122711d4f996
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