From c5bde4d7862c7df2b4bad183088f77a43d8b5a2c Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Fri, 19 Jun 2009 12:11:49 +0200 Subject: [PATCH] Started adding builtin functions --- .gitignore | 1 + Alu.hs | 2 +- Bits.hs | 6 +++--- CoreTools.hs | 32 ++++++++++++++++---------------- LICENSE | 25 +++++++++++++++++++++++++ Translator.hs | 2 +- VHDL.hs | 22 ++++++++++++---------- VHDLTypes.hs | 11 +++++++++-- 8 files changed, 68 insertions(+), 33 deletions(-) create mode 100644 LICENSE diff --git a/.gitignore b/.gitignore index eefec2f..a08978a 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,4 @@ *.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/CoreTools.hs b/CoreTools.hs index 3d3828b..5fbe871 100644 --- a/CoreTools.hs +++ b/CoreTools.hs @@ -56,24 +56,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/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/Translator.hs b/Translator.hs index 550b4f0..f377152 100644 --- a/Translator.hs +++ b/Translator.hs @@ -58,7 +58,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 c563504..846cd81 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -47,7 +47,7 @@ createDesignFiles flatfuncmap = 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 flatfuncmap) init_session ty_decls = Map.elems (final_session ^. vsTypes) @@ -110,7 +110,7 @@ createEntity hsfunc flatfunc = do -> SignalId -> VHDLState VHDLSignalMapElement -- We only need the vsTypes element from the state - mkMap sigmap = MonadState.lift vsTypes . (\id -> + mkMap sigmap = (\id -> let info = Maybe.fromMaybe (error $ "Signal not found in the name map? This should not happen!") @@ -194,7 +194,7 @@ createArchitecture hsfunc flatfunc = 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. @@ -223,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 :: SignalInfo -> TypeState (Maybe AST.SigDec) +mkSigDec :: SignalInfo -> VHDLState (Maybe AST.SigDec) mkSigDec info = let use = sigUse info in if isInternalSigUse use || isStateSigUse use then do @@ -282,7 +282,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 @@ -360,9 +360,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) @@ -379,7 +379,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 @@ -391,7 +391,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 @@ -401,7 +401,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 a5d1569..f317167 100644 --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@ -44,6 +44,9 @@ 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 HsFunction Entity @@ -52,10 +55,14 @@ 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 -- 2.30.2