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:
-- | 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
+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
-- 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 ()
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)
-> 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!")
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 :: 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
-- 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 HsFunction Entity
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
projects / matthijs / master-project / cλash.git / commitdiff