import qualified Control.Monad.Trans.State as State
import qualified Data.Monoid as Monoid
import Data.Accessor
+import Debug.Trace
-- ForSyDe
import qualified ForSyDe.Backend.VHDL.AST as AST
import CoreTools
import Constants
import Generate
-import GlobalNameTable
createDesignFiles ::
[(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
map (Arrow.second $ AST.DesignFile full_context) units
where
- init_session = VHDLSession Map.empty Map.empty Map.empty Map.empty globalNameTable
+ init_session = VHDLState Map.empty Map.empty Map.empty Map.empty
(units, final_session) =
State.runState (createLibraryUnits binds) init_session
- tyfun_decls = Map.elems (final_session ^.vsTypeFuns)
+ tyfun_decls = map snd $ Map.elems (final_session ^.vsTypeFuns)
ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes))
tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
: (mkUseAll ["work"]
: ieee_context)
type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ vec_decls ++ ty_decls ++ subProgSpecs)
- type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls)
- subProgSpecs = concat (map subProgSpec tyfun_decls)
- subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec)
+ type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
+ subProgSpecs = map subProgSpec tyfun_decls
+ subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec
mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
createLibraryUnits ::
[(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
- -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
+ -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
createLibraryUnits binds = do
entities <- Monad.mapM createEntity binds
-- | Create an entity for a given function
createEntity ::
(CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
- -> VHDLState AST.EntityDec -- | The resulting entity
+ -> VHDLSession AST.EntityDec -- | The resulting entity
createEntity (fname, expr) = do
-- Strip off lambda's, these will be arguments
mkMap ::
--[(SignalId, SignalInfo)]
CoreSyn.CoreBndr
- -> VHDLState VHDLSignalMapElement
+ -> VHDLSession VHDLSignalMapElement
-- We only need the vsTypes element from the state
mkMap = (\bndr ->
let
-- | Create an architecture for a given function
createArchitecture ::
(CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
- -> VHDLState AST.ArchBody -- ^ The architecture for this function
+ -> VHDLSession AST.ArchBody -- ^ The architecture for this function
createArchitecture (fname, expr) = do
signaturemap <- getA vsSignatures
(sigName info)
-}
-mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
+mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
mkSigDec bndr =
if True then do --isInternalSigUse use || isStateSigUse use then do
type_mark <- vhdl_ty $ Var.varType bndr
-- | Transforms a core binding into a VHDL concurrent statement
mkConcSm ::
(CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
- -> VHDLState [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
+ -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
-- Ignore Cast expressions, they should not longer have any meaning as long as
let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
let valargs' = filter isValArg args
let valargs = filter (\(CoreSyn.Var bndr) -> not (Id.isDictId bndr)) valargs'
- case Var.globalIdVarDetails f of
- IdInfo.DataConWorkId dc ->
- -- It's a datacon. Create a record from its arguments.
- -- First, filter out type args. TODO: Is this the best way to do this?
- -- The types should already have been taken into acocunt when creating
- -- the signal, so this should probably work...
- --let valargs = filter isValArg args in
- if all is_var valargs then do
- labels <- getFieldLabels (CoreUtils.exprType app)
- return $ zipWith mkassign labels valargs
- else
- error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args
- where
- mkassign :: AST.VHDLId -> CoreExpr -> AST.ConcSm
- mkassign label (Var arg) =
- let sel_name = mkSelectedName bndr label in
- mkUncondAssign (Right sel_name) (varToVHDLExpr arg)
- IdInfo.VanillaGlobal -> do
- -- It's a global value imported from elsewhere. These can be builtin
- -- functions.
- funSignatures <- getA vsNameTable
- signatures <- getA vsSignatures
- case (Map.lookup (varToString f) funSignatures) of
- Just (arg_count, builder) ->
- if length valargs == arg_count then
- case builder of
- Left funBuilder ->
- let
- sigs = map (varToVHDLExpr.exprToVar) valargs
- func = funBuilder sigs
- src_wform = AST.Wform [AST.WformElem func Nothing]
- dst_name = AST.NSimple (mkVHDLExtId (varToString bndr))
- assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
- in
- return [AST.CSSASm assign]
- Right genBuilder ->
- let
- sigs = map exprToVar valargs
- signature = Maybe.fromMaybe
- (error $ "Using function '" ++ (varToString (head sigs)) ++ "' without signature? This should not happen!")
- (Map.lookup (head sigs) signatures)
- arg = tail sigs
- genSm = genBuilder signature (arg ++ [bndr])
- in return [AST.CSGSm genSm]
- else
- error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs
- Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
- IdInfo.NotGlobalId -> do
- signatures <- getA vsSignatures
- -- This is a local id, so it should be a function whose definition we
- -- have and which can be turned into a component instantiation.
- let
- signature = Maybe.fromMaybe
- (error $ "Using function '" ++ (varToString f) ++ "' without signature? This should not happen!")
- (Map.lookup f signatures)
- entity_id = ent_id signature
- label = "comp_ins_" ++ varToString bndr
- -- Add a clk port if we have state
- --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
- clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
- --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
- portmaps = clk_port : mkAssocElems args bndr signature
- in
- return [mkComponentInst label entity_id portmaps]
- details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
+ genApplication (Left bndr) f (map Left valargs)
-- A single alt case must be a selector. This means thee scrutinee is a simple
-- variable, the alternative is a dataalt with a single non-wild binder that
Just i -> do
labels <- getFieldLabels (Id.idType scrut)
let label = labels!!i
- let sel_name = mkSelectedName scrut label
+ let sel_name = mkSelectedName (varToVHDLName scrut) label
let sel_expr = AST.PrimName sel_name
return [mkUncondAssign (Left bndr) sel_expr]
Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
projects / matthijs / master-project / cλash.git / blobdiff