From: Christiaan Baaij Date: Fri, 19 Jun 2009 11:25:24 +0000 (+0200) Subject: Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=8a17f35807fb35ee4d2a4c35c75e1cf99066f94d;hp=eb3177ed5e53fd27bc64a45584ab646545c27e5f;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Merge branch 'cλash' of git.stderr.nl/matthijs/projects/master-project * 'cλash' of http://git.stderr.nl/matthijs/projects/master-project: Add another higher order testcase, highordtest2. Support VHDL generation for two-alternative cases. Conflicts: Translator.hs --- diff --git a/.gitignore b/.gitignore index 31ab9cc..a08978a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,5 @@ *.hi *.o *.swp +dist +vhdl diff --git a/Adders.hs b/Adders.hs index d4dbbf8..4b18e39 100644 --- a/Adders.hs +++ b/Adders.hs @@ -1,36 +1,42 @@ 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 @@ -52,118 +58,121 @@ instance Inv (BitVec D0) where 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 diff --git a/Alu.hs b/Alu.hs index 5403908..b3d5b22 100644 --- a/Alu.hs +++ b/Alu.hs @@ -2,7 +2,7 @@ module Alu where 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 diff --git a/Bits.hs b/Bits.hs index cea48cc..b50430a 100644 --- a/Bits.hs +++ b/Bits.hs @@ -2,8 +2,8 @@ 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 @@ -58,6 +58,6 @@ type Stream 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: diff --git a/Constants.hs b/Constants.hs new file mode 100644 index 0000000..3a0e088 --- /dev/null +++ b/Constants.hs @@ -0,0 +1,174 @@ +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 diff --git a/CoreTools.hs b/CoreTools.hs index 3dfaf50..a8dce3f 100644 --- a/CoreTools.hs +++ b/CoreTools.hs @@ -61,24 +61,24 @@ sized_word_len ty = -- | 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 diff --git a/Generate.hs b/Generate.hs new file mode 100644 index 0000000..97d9488 --- /dev/null +++ b/Generate.hs @@ -0,0 +1,157 @@ +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 diff --git a/GlobalNameTable.hs b/GlobalNameTable.hs new file mode 100644 index 0000000..ef4b25e --- /dev/null +++ b/GlobalNameTable.hs @@ -0,0 +1,22 @@ +{-# 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 diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..23ebcfd --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +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 diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000..078f46f --- /dev/null +++ b/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Translator + +main = do + makeVHDL "Adders.hs" "functiontest" True \ No newline at end of file diff --git a/Translator.hs b/Translator.hs index 7b548e7..1786332 100644 --- a/Translator.hs +++ b/Translator.hs @@ -62,7 +62,7 @@ makeVHDL filename name stateful = do -- 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 () diff --git a/VHDL.hs b/VHDL.hs index 7610231..8eb130f 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -39,6 +39,9 @@ import TranslatorTypes import HsValueMap import Pretty import CoreTools +import Constants +import Generate +import GlobalNameTable createDesignFiles :: [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] @@ -49,7 +52,7 @@ createDesignFiles binds = 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) @@ -110,7 +113,7 @@ createEntity (fname, expr) = do 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!") @@ -192,7 +195,7 @@ createArchitecture (fname, expr) = do 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. @@ -221,7 +224,7 @@ mkStateProcSm (num, old, new) = 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 @@ -244,19 +247,32 @@ mkConcSm :: 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 @@ -326,7 +342,7 @@ mkConcSm sigs (UncondDef src dst) _ = do -- 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 @@ -406,9 +422,9 @@ std_logic_ty :: AST.TypeMark 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) @@ -425,7 +441,7 @@ vhdl_ty ty = do (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 @@ -437,7 +453,7 @@ vhdl_ty ty = do 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 @@ -447,7 +463,9 @@ mk_vector_ty len ty = do 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 diff --git a/VHDLTypes.hs b/VHDLTypes.hs index 784b097..e517a8b 100644 --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@ -45,15 +45,25 @@ instance Ord OrdType where -- 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 diff --git "a/c\316\273ash.cabal" "b/c\316\273ash.cabal" new file mode 100644 index 0000000..798b281 --- /dev/null +++ "b/c\316\273ash.cabal" @@ -0,0 +1,21 @@ +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: