--- /dev/null
+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:
--- /dev/null
+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:
--- /dev/null
+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:
--- /dev/null
+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:
--- /dev/null
+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 ()
--- /dev/null
+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:
--- /dev/null
+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:
--- /dev/null
+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
projects / matthijs / master-project / cλash.git / commitdiff