*.hi
*.o
*.swp
+dist
+vhdl
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
import Bits
import qualified Sim
import Data.SizedWord
-import Types.Data.Num
+import Types
main = Sim.simulate exec program initial_state
mainIO = Sim.simulateIO exec initial_state
module Bits where
-import qualified Data.Param.FSVec as FSVec
-import qualified Data.TypeLevel as TypeLevel
+import qualified Data.Param.TFVec as TFVec
+import qualified Types
--class Signal a where
-- hwand :: a -> a -> a
lows = Low : lows
highs = High : highs
-type BitVec len = FSVec.FSVec len Bit
+type BitVec len = TFVec.TFVec len Bit
-- vim: set ts=8 sw=2 sts=2 expandtab:
--- /dev/null
+module Constants where
+
+import qualified ForSyDe.Backend.VHDL.AST as AST
+
+--------------
+-- Identifiers
+--------------
+
+-- | reset and clock signal identifiers in String form
+resetStr, clockStr :: String
+resetStr = "resetn"
+clockStr = "clock"
+
+-- | reset and clock signal identifiers in basic AST.VHDLId form
+resetId, clockId :: AST.VHDLId
+resetId = AST.unsafeVHDLBasicId resetStr
+clockId = AST.unsafeVHDLBasicId clockStr
+
+
+-- | \"types\" identifier
+typesId :: AST.VHDLId
+typesId = AST.unsafeVHDLBasicId "types"
+
+-- | work identifier
+workId :: AST.VHDLId
+workId = AST.unsafeVHDLBasicId "work"
+
+-- | std identifier
+stdId :: AST.VHDLId
+stdId = AST.unsafeVHDLBasicId "std"
+
+
+-- | textio identifier
+textioId :: AST.VHDLId
+textioId = AST.unsafeVHDLBasicId "textio"
+
+-- | range attribute identifier
+rangeId :: AST.VHDLId
+rangeId = AST.unsafeVHDLBasicId "range"
+
+
+-- | range attribute identifier
+imageId :: AST.VHDLId
+imageId = AST.unsafeVHDLBasicId "image"
+
+-- | event attribute identifie
+eventId :: AST.VHDLId
+eventId = AST.unsafeVHDLBasicId "event"
+
+
+-- | default function identifier
+defaultId :: AST.VHDLId
+defaultId = AST.unsafeVHDLBasicId "default"
+
+-- FSVec function identifiers
+
+-- | ex (operator ! in original Haskell source) function identifier
+exId :: AST.VHDLId
+exId = AST.unsafeVHDLBasicId "ex"
+
+-- | sel (function select in original Haskell source) function identifier
+selId :: AST.VHDLId
+selId = AST.unsafeVHDLBasicId "sel"
+
+
+-- | ltplus (function (<+) in original Haskell source) function identifier
+ltplusId :: AST.VHDLId
+ltplusId = AST.unsafeVHDLBasicId "ltplus"
+
+
+-- | plusplus (function (++) in original Haskell source) function identifier
+plusplusId :: AST.VHDLId
+plusplusId = AST.unsafeVHDLBasicId "plusplus"
+
+
+-- | empty function identifier
+emptyId :: AST.VHDLId
+emptyId = AST.unsafeVHDLBasicId "empty"
+
+-- | plusgt (function (+>) in original Haskell source) function identifier
+plusgtId :: AST.VHDLId
+plusgtId = AST.unsafeVHDLBasicId "plusgt"
+
+-- | singleton function identifier
+singletonId :: AST.VHDLId
+singletonId = AST.unsafeVHDLBasicId "singleton"
+
+-- | length function identifier
+lengthId :: AST.VHDLId
+lengthId = AST.unsafeVHDLBasicId "length"
+
+
+-- | isnull (function null in original Haskell source) function identifier
+isnullId :: AST.VHDLId
+isnullId = AST.unsafeVHDLBasicId "isnull"
+
+
+-- | replace function identifier
+replaceId :: AST.VHDLId
+replaceId = AST.unsafeVHDLBasicId "replace"
+
+
+-- | head function identifier
+headId :: AST.VHDLId
+headId = AST.unsafeVHDLBasicId "head"
+
+
+-- | last function identifier
+lastId :: AST.VHDLId
+lastId = AST.unsafeVHDLBasicId "last"
+
+
+-- | init function identifier
+initId :: AST.VHDLId
+initId = AST.unsafeVHDLBasicId "init"
+
+
+-- | tail function identifier
+tailId :: AST.VHDLId
+tailId = AST.unsafeVHDLBasicId "tail"
+
+
+-- | take function identifier
+takeId :: AST.VHDLId
+takeId = AST.unsafeVHDLBasicId "take"
+
+
+-- | drop function identifier
+dropId :: AST.VHDLId
+dropId = AST.unsafeVHDLBasicId "drop"
+
+-- | shiftl function identifier
+shiftlId :: AST.VHDLId
+shiftlId = AST.unsafeVHDLBasicId "shiftl"
+
+-- | shiftr function identifier
+shiftrId :: AST.VHDLId
+shiftrId = AST.unsafeVHDLBasicId "shiftr"
+
+-- | rotl function identifier
+rotlId :: AST.VHDLId
+rotlId = AST.unsafeVHDLBasicId "rotl"
+
+-- | reverse function identifier
+rotrId :: AST.VHDLId
+rotrId = AST.unsafeVHDLBasicId "rotr"
+
+-- | reverse function identifier
+reverseId :: AST.VHDLId
+reverseId = AST.unsafeVHDLBasicId "reverse"
+
+-- | copy function identifier
+copyId :: AST.VHDLId
+copyId = AST.unsafeVHDLBasicId "copy"
+
+------------------
+-- VHDL type marks
+------------------
+
+-- | Stardard logic type mark
+std_logicTM :: AST.TypeMark
+std_logicTM = AST.unsafeVHDLBasicId "std_logic"
+
+-- | boolean type mark
+booleanTM :: AST.TypeMark
+booleanTM = AST.unsafeVHDLBasicId "boolean"
+
+-- | fsvec_index AST. TypeMark
+tfvec_indexTM :: AST.TypeMark
+tfvec_indexTM = AST.unsafeVHDLBasicId "tfvec_index"
+
+-- | natural AST. TypeMark
+naturalTM :: AST.TypeMark
+naturalTM = AST.unsafeVHDLBasicId "natural"
\ No newline at end of file
-- | Evaluate a core Type representing type level int from the TypeLevel
-- library to a real int.
-eval_type_level_int :: Type.Type -> Int
-eval_type_level_int ty =
- unsafeRunGhc $ do
- -- Automatically import modules for any fully qualified identifiers
- setDynFlag DynFlags.Opt_ImplicitImportQualified
-
- let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
- let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
- let undef = hsTypedUndef $ coreToHsType ty
- let app = HsExpr.HsApp (to_int) (undef)
-
- core <- toCore [] app
- execCore core
+-- eval_type_level_int :: Type.Type -> Int
+-- eval_type_level_int ty =
+-- unsafeRunGhc $ do
+-- -- Automatically import modules for any fully qualified identifiers
+-- setDynFlag DynFlags.Opt_ImplicitImportQualified
+--
+-- let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
+-- let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
+-- let undef = hsTypedUndef $ coreToHsType ty
+-- let app = HsExpr.HsApp (to_int) (undef)
+--
+-- core <- toCore [] app
+-- execCore core
-- | Get the length of a FSVec type
-fsvec_len :: Type.Type -> Int
-fsvec_len ty =
- eval_type_level_int len
+tfvec_len :: Type.Type -> Int
+tfvec_len ty =
+ eval_tfp_int len
where
(tycon, args) = Type.splitTyConApp ty
[len, el_ty] = args
--- /dev/null
+module Generate where
+
+import qualified ForSyDe.Backend.VHDL.AST as AST
+import Constants
+
+-- | Generate a function call from the Function Name and a list of expressions
+-- (its arguments)
+genExprFCall :: AST.VHDLId -> [AST.Expr] -> AST.Expr
+genExprFCall fName args =
+ AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
+ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
+
+-- | List version of genExprFCall1
+genExprFCall1L :: AST.VHDLId -> [AST.Expr] -> AST.Expr
+genExprFCall1L fName [arg] = genExprFCall fName [arg]
+genExprFCall1L _ _ = error "Generate.genExprFCall1L incorrect length"
+
+-- | List version of genExprFCall2
+genExprFCall2L :: AST.VHDLId -> [AST.Expr] -> AST.Expr
+genExprFCall2L fName [arg1, arg2] = genExprFCall fName [arg1,arg2]
+genExprFCall2L _ _ = error "Generate.genExprFCall2L incorrect length"
+
+genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
+ -> AST.TypeMark -- ^ type of the vector
+ -> [AST.SubProgBody]
+genUnconsVectorFuns elemTM vectorTM =
+ [ AST.SubProgBody exSpec [] [exExpr]
+ , AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet]
+ , AST.SubProgBody headSpec [] [headExpr]
+ , AST.SubProgBody lastSpec [] [lastExpr]
+ , AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet]
+ , AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet]
+ , AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet]
+ , AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet]
+ ]
+ where
+ ixPar = AST.unsafeVHDLBasicId "ix"
+ vecPar = AST.unsafeVHDLBasicId "vec"
+ nPar = AST.unsafeVHDLBasicId "n"
+ iId = AST.unsafeVHDLBasicId "i"
+ iPar = iId
+ aPar = AST.unsafeVHDLBasicId "a"
+ resId = AST.unsafeVHDLBasicId "res"
+ exSpec = AST.Function exId [AST.IfaceVarDec vecPar vectorTM,
+ AST.IfaceVarDec ixPar naturalTM] elemTM
+ exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
+ (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
+ AST.NSimple ixPar]))
+ replaceSpec = AST.Function replaceId [ AST.IfaceVarDec vecPar vectorTM
+ , AST.IfaceVarDec iPar naturalTM
+ , AST.IfaceVarDec aPar elemTM
+ ] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-1);
+ replaceVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) lengthId Nothing) AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
+ replaceExpr = AST.NSimple resId AST.:=
+ (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
+ AST.PrimName (AST.NSimple aPar) AST.:&:
+ vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
+ ((AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) lengthId Nothing))
+ AST.:-: AST.PrimLit "1"))
+ replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ vecSlice init last = AST.PrimName (AST.NSlice
+ (AST.SliceName
+ (AST.NSimple vecPar)
+ (AST.ToRange init last)))
+ headSpec = AST.Function headId [AST.IfaceVarDec vecPar vectorTM] elemTM
+ -- return vec(0);
+ headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
+ (AST.NSimple vecPar) [AST.PrimLit "0"])))
+ lastSpec = AST.Function lastId [AST.IfaceVarDec vecPar vectorTM] elemTM
+ -- return vec(vec'length-1);
+ lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
+ (AST.NSimple vecPar)
+ [AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) lengthId Nothing)
+ AST.:-: AST.PrimLit "1"])))
+ initSpec = AST.Function initId [AST.IfaceVarDec vecPar vectorTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-2);
+ initVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) lengthId Nothing) AST.:-:
+ (AST.PrimLit "2")) ]))
+ Nothing
+ -- resAST.:= vec(0 to vec'length-2)
+ initExpr = AST.NSimple resId AST.:= (vecSlice
+ (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) lengthId Nothing)
+ AST.:-: AST.PrimLit "2"))
+ initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ tailSpec = AST.Function tailId [AST.IfaceVarDec vecPar vectorTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-2);
+ tailVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) lengthId Nothing) AST.:-:
+ (AST.PrimLit "2")) ]))
+ Nothing
+ -- res AST.:= vec(1 to vec'length-1)
+ tailExpr = AST.NSimple resId AST.:= (vecSlice
+ (AST.PrimLit "1")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) lengthId Nothing)
+ AST.:-: AST.PrimLit "1"))
+ tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ takeSpec = AST.Function takeId [AST.IfaceVarDec nPar naturalTM,
+ AST.IfaceVarDec vecPar vectorTM ] vectorTM
+ -- variable res : fsvec_x (0 to n-1);
+ takeVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ ((AST.PrimName (AST.NSimple nPar)) AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- res AST.:= vec(0 to n-1)
+ takeExpr = AST.NSimple resId AST.:=
+ (vecSlice (AST.PrimLit "1")
+ (AST.PrimName (AST.NSimple $ nPar) AST.:-: AST.PrimLit "1"))
+ takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ dropSpec = AST.Function dropId [AST.IfaceVarDec nPar naturalTM,
+ AST.IfaceVarDec vecPar vectorTM ] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-n-1);
+ dropVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) lengthId Nothing) AST.:-:
+ (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
+ Nothing
+ -- res AST.:= vec(n to vec'length-1)
+ dropExpr = AST.NSimple resId AST.:= (vecSlice
+ (AST.PrimName $ AST.NSimple nPar)
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) lengthId Nothing)
+ AST.:-: AST.PrimLit "1"))
+ dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE TemplateHaskell #-}
+
+module GlobalNameTable (globalNameTable) where
+
+import Language.Haskell.TH
+import qualified Data.Map as Map
+
+import qualified ForSyDe.Backend.VHDL.AST as AST
+import qualified Data.Param.TFVec as V
+
+import VHDLTypes
+import Constants
+import Generate
+
+mkGlobalNameTable :: [(String, (Int, [AST.Expr] -> AST.Expr ) )] -> NameTable
+mkGlobalNameTable = Map.fromList
+
+globalNameTable :: NameTable
+globalNameTable = mkGlobalNameTable
+ [ (show ('(V.!)) , (2, genExprFCall2L exId ) )
+ , ("head" , (1, genExprFCall1L headId ) )
+ ]
\ No newline at end of file
--- /dev/null
+Copyright (c) 2009 Christiaan Baaij & Matthijs Kooijman
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+ * Neither the name of the copyright holder nor the
+ names of its contributors may be used to endorse or promote products
+ derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER ``AS IS'' AND ANY
+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE
+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
\ No newline at end of file
--- /dev/null
+module Main where
+
+import Translator
+
+main = do
+ makeVHDL "Adders.hs" "functiontest" True
\ No newline at end of file
-- Translate to VHDL
vhdl <- moduleToVHDL core [(name, stateful)]
-- Write VHDL to file
- let dir = "../vhdl/vhdl/" ++ name ++ "/"
+ let dir = "./vhdl/" ++ name ++ "/"
mapM (writeVHDL dir) vhdl
return ()
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
-- 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
-- A map of a Core type to the corresponding type name
type TypeMap = Map.Map OrdType (AST.VHDLId, AST.TypeDec)
+-- A map of a vector Core type to the coressponding VHDL functions
+type TypeFunMap = Map.Map OrdType [AST.SubProgBody]
+
-- A map of a Haskell function to a hardware signature
type SignatureMap = Map.Map String Entity
+-- A map of a builtin function to VHDL function builder
+type NameTable = Map.Map String (Int, [AST.Expr] -> AST.Expr )
+
data VHDLSession = VHDLSession {
-- | A map of Core type -> VHDL Type
- vsTypes_ :: TypeMap,
+ vsTypes_ :: TypeMap,
+ -- | A map of vector Core type -> VHDL type function
+ vsTypeFuns_ :: TypeFunMap,
-- | A map of HsFunction -> hardware signature (entity name, port names,
-- etc.)
- vsSignatures_ :: SignatureMap
+ vsSignatures_ :: SignatureMap,
+ -- | A map of Vector HsFunctions -> VHDL function call
+ vsNameTable_ :: NameTable
}
-- Derive accessors
--- /dev/null
+name: clash
+version: 0.1
+build-type: Simple
+synopsis: CAES Languege for Hardware Descriptions (CλasH)
+description: CλasH is a toolchain/language to translate subsets of Haskell to synthesizable VHDL. It does this by translating the intermediate System Fc (GHC Core) representation to a VHDL AST, which is then written to file.
+category: Development
+license: BSD3
+license-file: LICENSE
+package-url: http://github.com/darchon/clash/tree/master
+copyright: Copyright (c) 2009 Christiaan Baaij & Matthijs Kooijman
+author: Christiaan Baaij & Matthijs Kooijman
+stability: alpha
+maintainer: christiaan.baaij@gmail.com & matthijs@stdin.nl
+build-depends: base > 4, syb, ghc, ghc-paths, transformers, haskell98,
+ ForSyDe, regex-posix ,data-accessor-template, pretty,
+ data-accessor, containers, prettyclass, tfp > 0.3,
+ tfvec, QuickCheck, template-haskell
+
+executable: clash
+main-is: Main.hs
+ghc-options:
projects / matthijs / master-project / cλash.git / commitdiff