module Adders where
import Bits
import qualified Sim
+
+import qualified Prelude as P
+import Prelude hiding (
+ null, length, head, tail, last, init, take, drop, (++), map, foldl, foldr,
+ zipWith, zip, unzip, concat, reverse, iterate )
+
import Language.Haskell.Syntax
-import qualified Data.TypeLevel as TypeLevel
-import qualified Data.Param.FSVec as FSVec
+import Types
+import Data.Param.TFVec
-mainIO f = Sim.simulateIO (Sim.stateless f) ()
+-- mainIO f = Sim.simulateIO (Sim.stateless f) ()
-- This function is from Sim.hs, but we redefine it here so it can get inlined
-- by default.
-stateless :: (i -> o) -> (i -> () -> ((), o))
-stateless f = \i s -> (s, f i)
-
-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)
-
-mux2 :: Bit -> (Bit, Bit) -> Bit
-mux2 Low (a, b) = a
-mux2 High (a, b) = b
+-- stateless :: (i -> o) -> (i -> () -> ((), o))
+-- stateless f = \i s -> (s, f i)
+--
+-- 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)
+--
+-- mux2 :: Bit -> (Bit, Bit) -> Bit
+-- mux2 Low (a, b) = a
+-- mux2 High (a, b) = b
-- Not really an adder, but this is nice minimal hardware description
-wire :: Bit -> Bit
-wire a = a
+-- wire :: Bit -> Bit
+-- wire a = a
-bus :: (TypeLevel.Pos len) => BitVec len -> BitVec len
-bus v = v
-
-bus_4 :: BitVec TypeLevel.D4 -> BitVec TypeLevel.D4
-bus_4 v = v
+-- bus :: (TypeLevel.Pos len) => BitVec len -> BitVec len
+-- bus v = v
+--
+-- bus_4 :: BitVec TypeLevel.D4 -> BitVec TypeLevel.D4
+-- bus_4 v = v
{-
inv_n :: (Pos len) => BitVec len -> BitVec len
inv_n_rec v = v
-}
-- Not really an adder either, but a slightly more complex example
-inv :: Bit -> Bit
-inv a = let r = hwnot a in r
+-- inv :: Bit -> Bit
+-- inv a = let r = hwnot a in r
-- Not really an adder either, but a slightly more complex example
-invinv :: Bit -> Bit
-invinv a = hwnot (hwnot a)
+-- invinv :: Bit -> Bit
+-- invinv a = hwnot (hwnot a)
-- Not really an adder either, but a slightly more complex example
-dup :: Bit -> (Bit, Bit)
-dup a = (a, a)
+-- dup :: Bit -> (Bit, Bit)
+-- dup a = (a, a)
-- Not really an adder either, but a simple stateful example (D-flipflop)
-dff :: Bit -> Bit -> (Bit, Bit)
-dff d s = (s', q)
- where
- q = s
- s' = d
-
-type ShifterState = (Bit, Bit, Bit, Bit)
-shifter :: Bit -> ShifterState -> (ShifterState, Bit)
-shifter i (a, b, c, d) =
- (s', d)
- where
- s' = (i, a, b, c)
-
-{-# NOINLINE shifter_en #-}
-shifter_en :: Bit -> Bit-> ShifterState -> (ShifterState, Bit)
-shifter_en High i (a, b, c, d) =
- (s', d)
- where
- s' = (i, a, b, c)
-
-shifter_en Low i s@(a, b, c, d) =
- (s, d)
+-- dff :: Bit -> Bit -> (Bit, Bit)
+-- dff d s = (s', q)
+-- where
+-- q = s
+-- s' = d
+--
+-- type ShifterState = (Bit, Bit, Bit, Bit)
+-- shifter :: Bit -> ShifterState -> (ShifterState, Bit)
+-- shifter i (a, b, c, d) =
+-- (s', d)
+-- where
+-- s' = (i, a, b, c)
+--
+-- {-# NOINLINE shifter_en #-}
+-- shifter_en :: Bit -> Bit-> ShifterState -> (ShifterState, Bit)
+-- shifter_en High i (a, b, c, d) =
+-- (s', d)
+-- where
+-- s' = (i, a, b, c)
+--
+-- shifter_en Low i s@(a, b, c, d) =
+-- (s, d)
-- Two multiplexed shifters
-type ShiftersState = (ShifterState, ShifterState)
-shifters :: Bit -> Bit -> ShiftersState -> (ShiftersState, Bit)
-shifters sel i (sa, sb) =
- (s', out)
- where
- (sa', outa) = shifter_en sel i sa
- (sb', outb) = shifter_en (hwnot sel) i sb
- s' = (sa', sb')
- out = if sel == High then outa else outb
+-- type ShiftersState = (ShifterState, ShifterState)
+-- shifters :: Bit -> Bit -> ShiftersState -> (ShiftersState, Bit)
+-- shifters sel i (sa, sb) =
+-- (s', out)
+-- where
+-- (sa', outa) = shifter_en sel i sa
+-- (sb', outb) = shifter_en (hwnot sel) i sb
+-- s' = (sa', sb')
+-- out = if sel == High then outa else outb
-- Combinatoric stateless no-carry adder
-- A -> B -> S
-no_carry_adder :: (Bit, Bit) -> Bit
-no_carry_adder (a, b) = a `hwxor` b
+-- no_carry_adder :: (Bit, Bit) -> Bit
+-- no_carry_adder (a, b) = a `hwxor` b
-- Combinatoric stateless half adder
-- A -> B -> (S, C)
-half_adder :: (Bit, Bit) -> (Bit, Bit)
-{-# NOINLINE half_adder #-}
-half_adder (a, b) =
- ( a `hwxor` b, a `hwand` b )
+-- half_adder :: (Bit, Bit) -> (Bit, Bit)
+-- {-# NOINLINE half_adder #-}
+-- half_adder (a, b) =
+-- ( a `hwxor` b, a `hwand` b )
-- Combinatoric stateless full adder
-- (A, B, C) -> (S, C)
-full_adder :: (Bit, Bit, Bit) -> (Bit, Bit)
-full_adder (a, b, cin) = (s, c)
- where
- (s1, c1) = half_adder(a, b)
- (s, c2) = half_adder(s1, cin)
- c = c1 `hwor` c2
-
-sfull_adder = stateless full_adder
+-- full_adder :: (Bit, Bit, Bit) -> (Bit, Bit)
+-- full_adder (a, b, cin) = (s, c)
+-- where
+-- (s1, c1) = half_adder(a, b)
+-- (s, c2) = half_adder(s1, cin)
+-- c = c1 `hwor` c2
+--
+-- sfull_adder = stateless full_adder
-- 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)
+-- 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)
-
-foo = id
-add, sub :: Int -> Int -> Int
-add a b = a + b
-sub a b = a - b
-
-highordtest = \x ->
- let s = foo x
- in
- case s of
- (a, b) ->
- case a of
- High -> add
- Low -> let
- op' = case b of
- High -> sub
- Low -> \c d -> c
- in
- \c d -> op' d c
+-- 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)
+--
+-- foo = id
+-- add, sub :: Int -> Int -> Int
+-- add a b = a + b
+-- sub a b = a - b
+--
+-- highordtest = \x ->
+-- let s = foo x
+-- in
+-- case s of
+-- (a, b) ->
+-- case a of
+-- High -> add
+-- Low -> let
+-- op' = case b of
+-- High -> sub
+-- Low -> \c d -> c
+-- in
+-- \c d -> op' d c
+
+functiontest :: TFVec D4 Bit -> Bit
+functiontest = \v -> let r = head v in r
+ highordtest2 = \a b ->
+ case a of
+ High -> \c d -> d
+ Low -> let
+ op' :: Bit -> Bit -> Bit
+ op' = case b of
+ High -> \c d -> d
+ Low -> \c d -> c
+ in
+ \c d -> op' d c
-- Four bit adder, using the continous adder below
-- [a] -> [b] -> ([s], cout)
--con_adder_4 as bs =
import qualified ForSyDe.Backend.VHDL.AST as AST
-- GHC API
+ import CoreSyn
import qualified Type
import qualified Name
import qualified OccName
import qualified Var
import qualified TyCon
- import qualified CoreSyn
+ import qualified DataCon
import Outputable ( showSDoc, ppr )
-- Local imports
import HsValueMap
import Pretty
import CoreTools
+import Constants
+import Generate
+import GlobalNameTable
createDesignFiles ::
[(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
map (Arrow.second $ AST.DesignFile full_context) units
where
- init_session = VHDLSession Map.empty builtin_funcs
+ init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
(units, final_session) =
State.runState (createLibraryUnits binds) init_session
ty_decls = Map.elems (final_session ^. vsTypes)
CoreSyn.CoreBndr
-> VHDLState VHDLSignalMapElement
-- We only need the vsTypes element from the state
- mkMap = MonadState.lift vsTypes . (\bndr ->
+ mkMap = (\bndr ->
let
--info = Maybe.fromMaybe
-- (error $ "Signal not found in the name map? This should not happen!")
procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
procs' = map AST.CSPSm procs
-- mkSigDec only uses vsTypes from the state
- mkSigDec' = MonadState.lift vsTypes . mkSigDec
+ mkSigDec' = mkSigDec
-- | Looks up all pairs of old state, new state signals, together with
-- the state id they represent.
rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
statement = AST.IfSm rising_edge_clk [assign] [] Nothing
-mkSigDec :: CoreSyn.CoreBndr -> TypeState (Maybe AST.SigDec)
+mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
mkSigDec bndr =
if True then do --isInternalSigUse use || isStateSigUse use then do
type_mark <- vhdl_ty $ Var.varType bndr
mkConcSm (bndr, app@(CoreSyn.App _ _))= do
signatures <- getA vsSignatures
- let
- (CoreSyn.Var f, args) = CoreSyn.collectArgs app
- signature = Maybe.fromMaybe
- (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
+ funSignatures <- getA vsNameTable
+ let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+ case (Map.lookup (bndrToString f) funSignatures) of
+ Just funSignature ->
+ let
+ sigs = map (bndrToString.varBndr) args
+ sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
+ func = (snd funSignature) sigsNames
+ src_wform = AST.Wform [AST.WformElem func Nothing]
+ dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
+ assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
+ in
+ return $ AST.CSSASm assign
+ Nothing ->
+ let
+ signature = Maybe.fromMaybe
+ (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
(Map.lookup (bndrToString f) signatures)
- entity_id = ent_id signature
- label = bndrToString bndr
+ entity_id = ent_id signature
+ label = bndrToString bndr
-- Add a clk port if we have state
--clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
--portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
- portmaps = mkAssocElems args bndr signature
- in
- return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
+ portmaps = mkAssocElems args bndr signature
+ in
+ return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
-- GHC generates some funny "r = r" bindings in let statements before
-- simplification. This outputs some dummy ConcSM for these, so things will at
-- least compile for now.
mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
+ -- A single alt case must be a selector
+ mkConcSm (bndr, (Case (Var scrut) b ty [alt])) = error "Single case alt not supported yet"
+
+ -- Multiple case alt are be conditional assignments and have only wild
+ -- binders in the alts and only variables in the case values and a variable
+ -- for a scrutinee. We check the constructor of the second alt, since the
+ -- first is the default case, if there is any.
+ mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
+ let
+ cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con)
+ true_expr = (varToVHDLExpr true)
+ false_expr = (varToVHDLExpr false)
+ false_wform = AST.Wform [AST.WformElem false_expr Nothing]
+ true_wform = AST.Wform [AST.WformElem true_expr Nothing]
+ whenelse = AST.WhenElse true_wform cond_expr
+ dst_name = AST.NSimple (bndrToVHDLId bndr)
+ assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
+ in
+ return $ AST.CSSASm assign
+ mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
+ mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
+
+ -- Turn a variable reference into a AST expression
+ varToVHDLExpr :: Var.Var -> AST.Expr
+ varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
+
+ -- Turn a constructor into an AST expression. For dataconstructors, this is
+ -- only the constructor itself, not any arguments it has. Should not be called
+ -- with a DEFAULT constructor.
+ conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
+ conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
+ where
+ tycon = DataCon.dataConTyCon dc
+ tyname = TyCon.tyConName tycon
+ dcname = DataCon.dataConName dc
+ lit = case Name.getOccString tyname of
+ -- TODO: Do something more robust than string matching
+ "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
+ "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
+ conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
+ conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
+
+
+
{-
mkConcSm sigs (UncondDef src dst) _ = do
src_expr <- vhdl_expr src
-- Create a cast expression, which is just a function call using the
-- type name as the function name.
let litexpr = AST.PrimLit lit
- ty_id <- MonadState.lift vsTypes (vhdl_ty ty)
+ ty_id <- vhdl_ty ty
let ty_name = AST.NSimple ty_id
let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
return $ AST.PrimFCall $ AST.FCall ty_name args
std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
-- Translate a Haskell type to a VHDL type
-vhdl_ty :: Type.Type -> TypeState AST.TypeMark
+vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
vhdl_ty ty = do
- typemap <- State.get
+ typemap <- getA vsTypes
let builtin_ty = do -- See if this is a tycon and lookup its name
(tycon, args) <- Type.splitTyConApp_maybe ty
let name = Name.getOccString (TyCon.tyConName tycon)
(tycon, args) <- Type.splitTyConApp_maybe ty
let name = Name.getOccString (TyCon.tyConName tycon)
case name of
- "FSVec" -> Just $ mk_vector_ty (fsvec_len ty) ty
+ "TFVec" -> Just $ mk_vector_ty (tfvec_len ty) ty
"SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
otherwise -> Nothing
-- Return new_ty when a new type was successfully created
mk_vector_ty ::
Int -- ^ The length of the vector
-> Type.Type -- ^ The Haskell type to create a VHDL type for
- -> TypeState AST.TypeMark -- The typemark created.
+ -> VHDLState AST.TypeMark -- The typemark created.
mk_vector_ty len ty = do
-- Assume there is a single type argument
let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
let ty_dec = AST.TypeDec ty_id ty_def
-- TODO: Check name uniqueness
- State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
+ --State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
+ modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_dec))
+ modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
return ty_id
projects / matthijs / master-project / cλash.git / commitdiff