From: Christiaan Baaij Date: Fri, 19 Jun 2009 10:17:44 +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=e230d86ae7135a268a72cdffba947a9011001ec2;hp=3fb6a3a819f85d89853660347b42f6085d20fb57;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: Use highordtest in main, since that can now be normalized. Add a (fairly complete) set of transforms. Add is_lam and is_fun predicates. Add a inlinebind helper function. Add a substitute helper function. Print the type in the transform debug output. Add infrastructure for running core to core transformations. Add a higher order testcase. Add is_wild function to check for wild binders. Generate VHDL from Core instead of flat functions. Conflicts: Translator.hs VHDL.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/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..be48aa3 --- /dev/null +++ b/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Translator + +main = do + makeVHDL "Adders.hs" "highordtest" True \ No newline at end of file diff --git a/Translator.hs b/Translator.hs index 3f60330..0f60277 100644 --- a/Translator.hs +++ b/Translator.hs @@ -52,8 +52,8 @@ import FlattenTypes import VHDLTypes import qualified VHDL -main = do - makeVHDL "Adders.hs" "highordtest" True +-- main = do +-- makeVHDL "Alu.hs" "exec" True makeVHDL :: String -> String -> Bool -> IO () makeVHDL filename name stateful = do @@ -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 561c279..d177a10 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -38,6 +38,9 @@ import TranslatorTypes import HsValueMap import Pretty import CoreTools +import Constants +import Generate +import GlobalNameTable createDesignFiles :: [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] @@ -48,7 +51,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) @@ -109,7 +112,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!") @@ -191,7 +194,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. @@ -220,7 +223,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 @@ -281,7 +284,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 @@ -361,9 +364,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) @@ -380,7 +383,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 @@ -392,7 +395,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 @@ -402,7 +405,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: