import HsValueMap
import Pretty
import CoreTools
+import Constants
+import Generate
+import GlobalNameTable
createDesignFiles ::
[(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
-> [(AST.VHDLId, AST.DesignFile)]
createDesignFiles binds =
- (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
+ (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
map (Arrow.second $ AST.DesignFile full_context) units
where
- init_session = VHDLSession Map.empty builtin_funcs
+ init_session = VHDLSession Map.empty Map.empty Map.empty builtin_funcs globalNameTable
(units, final_session) =
State.runState (createLibraryUnits binds) init_session
ty_decls = Map.elems (final_session ^. vsTypes)
+ subty_decls = Map.elems (final_session ^. vsSubTypes)
+ tyfun_decls = Map.elems (final_session ^.vsTypeFuns)
ieee_context = [
AST.Library $ mkVHDLBasicId "IEEE",
mkUseAll ["IEEE", "std_logic_1164"],
full_context =
mkUseAll ["work", "types"]
: ieee_context
- type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls)
+ type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (packageTypeDecs ++ packageSubtypeDecs ++ subProgSpecs)
+ type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls)
+ packageTypeDecs = map (AST.PDITD . snd) ty_decls
+ packageSubtypeDecs = map (AST.PDISD . snd) subty_decls
+ subProgSpecs = concat (map subProgSpec tyfun_decls)
+ subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec)
-- Create a use foo.bar.all statement. Takes a list of components in the used
-- name. Must contain at least two components
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
+ "RangedWord" -> Just $ mk_natural_ty 0 (ranged_word_bound ty) ty
otherwise -> Nothing
-- Return new_ty when a new type was successfully created
Maybe.fromMaybe
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
+
+mk_natural_ty ::
+ Int -- ^ The minimum bound (> 0)
+ -> Int -- ^ The maximum bound (> minimum bound)
+ -> Type.Type -- ^ The Haskell type to create a VHDL type for
+ -> VHDLState AST.TypeMark -- The typemark created.
+mk_natural_ty min_bound max_bound ty = do
+ let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
+ let ty_def = AST.SubtypeIn naturalTM (Nothing)
+ let ty_dec = AST.SubtypeDec ty_id ty_def
+ modA vsSubTypes (Map.insert (OrdType ty) (ty_id, ty_dec))
return ty_id
projects / matthijs / master-project / cλash.git / blobdiff