From: Matthijs Kooijman 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?a=commitdiff_plain;h=d49dfd213e2cd384bceb38dc70eb122711d4f996;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git 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