- return (core, env)
-
--- | Extracts the named binds from the given module.
-findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
-findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
-
--- | Extract a named bind from the given list of binds
-findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
-findBind binds lookfor =
- -- This ignores Recs and compares the name of the bind with lookfor,
- -- disregarding any namespaces in OccName and extra attributes in Name and
- -- Var.
- find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
-
--- | Flattens the given bind into the given signature and adds it to the
--- session. Then (recursively) finds any functions it uses and does the same
--- with them.
--- flattenBind ::
--- HsFunction -- The signature to flatten into
--- -> (CoreBndr, CoreExpr) -- The bind to flatten
--- -> TranslatorState ()
---
--- flattenBind hsfunc bind@(var, expr) = do
--- -- Flatten the function
--- let flatfunc = flattenFunction hsfunc bind
--- -- Propagate state variables
--- let flatfunc' = propagateState hsfunc flatfunc
--- -- Store the flat function in the session
--- modA tsFlatFuncs (Map.insert hsfunc flatfunc')
--- -- Flatten any functions used
--- let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
--- mapM_ resolvFunc used_hsfuncs
-
--- | Decide which incoming state variables will become state in the
--- given function, and which will be propagate to other applied
--- functions.
--- propagateState ::
--- HsFunction
--- -> FlatFunction
--- -> FlatFunction
---
--- propagateState hsfunc flatfunc =
--- flatfunc {flat_defs = apps', flat_sigs = sigs'}
--- where
--- (olds, news) = unzip $ getStateSignals hsfunc flatfunc
--- states' = zip olds news
--- -- Find all signals used by all sigdefs
--- uses = concatMap sigDefUses (flat_defs flatfunc)
--- -- Find all signals that are used more than once (is there a
--- -- prettier way to do this?)
--- multiple_uses = uses List.\\ (List.nub uses)
--- -- Find the states whose "old state" signal is used only once
--- single_use_states = filter ((`notElem` multiple_uses) . fst) states'
--- -- See if these single use states can be propagated
--- (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
--- substate_sigs = concat substate_sigss
--- -- Mark any propagated state signals as SigSubState
--- sigs' = map
--- (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
--- (flat_sigs flatfunc)
-
--- | Propagate the state into a single function application.
--- propagateState' ::
--- [(SignalId, SignalId)]
--- -- ^ TODO
--- -> SigDef -- ^ The SigDef to process.
--- -> ([SignalId], SigDef)
--- -- ^ Any signal ids that should become substates,
--- -- and the resulting application.
---
--- propagateState' states def =
--- if (is_FApp def) then
--- (our_old ++ our_new, def {appFunc = hsfunc'})
--- else
--- ([], def)
--- where
--- hsfunc = appFunc def
--- args = appArgs def
--- res = appRes def
--- our_states = filter our_state states
--- -- A state signal belongs in this function if the old state is
--- -- passed in, and the new state returned
--- our_state (old, new) =
--- any (old `Foldable.elem`) args
--- && new `Foldable.elem` res
--- (our_old, our_new) = unzip our_states
--- -- Mark the result
--- zipped_res = zipValueMaps res (hsFuncRes hsfunc)
--- res' = fmap (mark_state (zip our_new [0..])) zipped_res
--- -- Mark the args
--- zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
--- args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
--- hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
---
--- mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
--- mark_state states (id, use) =
--- case lookup id states of
--- Nothing -> use
--- Just state_id -> State state_id
-
--- | Returns pairs of signals that should be mapped to state in this function.
--- getStateSignals ::
--- HsFunction -- | The function to look at
--- -> FlatFunction -- | The function to look at
--- -> [(SignalId, SignalId)]
--- -- | TODO The state signals. The first is the state number, the second the
--- -- signal to assign the current state to, the last is the signal
--- -- that holds the new state.
---
--- getStateSignals hsfunc flatfunc =
--- [(old_id, new_id)
--- | (old_num, old_id) <- args
--- , (new_num, new_id) <- res
--- , old_num == new_num]
--- where
--- sigs = flat_sigs flatfunc
--- -- Translate args and res to lists of (statenum, sigid)
--- args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
--- res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
-
--- | Find the given function, flatten it and add it to the session. Then
--- (recursively) do the same for any functions used.
--- resolvFunc ::
--- HsFunction -- | The function to look for
--- -> TranslatorState ()
---
--- resolvFunc hsfunc = do
--- flatfuncmap <- getA tsFlatFuncs
--- -- Don't do anything if there is already a flat function for this hsfunc or
--- -- when it is a builtin function.
--- Monad.unless (Map.member hsfunc flatfuncmap) $ do
--- -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
--- -- New function, resolve it
--- core <- getA tsCoreModule
--- -- Find the named function
--- let name = (hsFuncName hsfunc)
--- let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name
--- case bind of
--- Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
--- Just b -> flattenBind hsfunc b
-
--- | Translate a top level function declaration to a HsFunction. i.e., which
--- interface will be provided by this function. This function essentially
--- defines the "calling convention" for hardware models.
--- mkHsFunction ::
--- Var.Var -- ^ The function defined
--- -> Type -- ^ The function type (including arguments!)
--- -> Bool -- ^ Is this a stateful function?
--- -> HsFunction -- ^ The resulting HsFunction
---
--- mkHsFunction f ty stateful=
--- HsFunction hsname hsargs hsres
--- where
--- hsname = getOccString f
--- (arg_tys, res_ty) = Type.splitFunTys ty
--- (hsargs, hsres) =
--- if stateful
--- then
--- let
--- -- The last argument must be state
--- state_ty = last arg_tys
--- state = useAsState (mkHsValueMap state_ty)
--- -- All but the last argument are inports
--- inports = map (useAsPort . mkHsValueMap)(init arg_tys)
--- hsargs = inports ++ [state]
--- hsres = case splitTupleType res_ty of
--- -- Result type must be a two tuple (state, ports)
--- Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
--- then
--- Tuple [state, useAsPort (mkHsValueMap outport_ty)]
--- else
--- error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
--- otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
--- in
--- (hsargs, hsres)
--- else
--- -- Just use everything as a port
--- (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
-
--- | Adds signal names to the given FlatFunction
--- nameFlatFunction ::
--- FlatFunction
--- -> FlatFunction
---
--- nameFlatFunction flatfunc =
--- -- Name the signals
--- let
--- s = flat_sigs flatfunc
--- s' = map nameSignal s in
--- flatfunc { flat_sigs = s' }
--- where
--- nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
--- nameSignal (id, info) =
--- let hints = nameHints info in
--- let parts = ("sig" : hints) ++ [show id] in
--- let name = concat $ List.intersperse "_" parts in
--- (id, info {sigName = Just name})
---
--- -- | Splits a tuple type into a list of element types, or Nothing if the type
--- -- is not a tuple type.
--- splitTupleType ::
--- Type -- ^ The type to split
--- -> Maybe [Type] -- ^ The tuples element types
---
--- splitTupleType ty =
--- case Type.splitTyConApp_maybe ty of
--- Just (tycon, args) -> if TyCon.isTupleTyCon tycon
--- then
--- Just args
--- else
--- Nothing
--- Nothing -> Nothing
+ top_entity <- mapM topEntLoc cores
+ init_state <- mapM initSLoc cores
+ test_input <- mapM testLoc cores
+ return (cores, top_entity, init_state, test_input, env)
+
+-- | Find a binder in module according to a certain criteria
+findBind ::
+ GhcMonad m =>
+ (Var.Var -> m Bool) -- ^ The criteria to filter the binds on
+ -> HscTypes.CoreModule -- ^ The module to be inspected
+ -> m (Maybe CoreBndr) -- ^ The (first) bind to meet the criteria
+findBind annotation core = do
+ let binds = CoreSyn.flattenBinds $ cm_binds core
+ annbinds <- Monad.filterM (annotation . fst) binds
+ let bndr = case annbinds of [] -> Nothing ; xs -> Just $ head $ fst (unzip annbinds)
+ return bndr
+
+-- | Find an expresion in module according to a certain criteria
+findExpr ::
+ GhcMonad m =>
+ (Var.Var -> m Bool) -- ^ The criteria to filter the binds on
+ -> HscTypes.CoreModule -- ^ The module to be inspected
+ -> m (Maybe CoreExpr) -- ^ The (first) expr to meet the criteria
+findExpr annotation core = do
+ let binds = CoreSyn.flattenBinds $ cm_binds core
+ annbinds <- Monad.filterM (annotation . fst) binds
+ let exprs = case annbinds of [] -> Nothing ; xs -> Just $ head $ snd (unzip annbinds)
+ return exprs
+
+-- | Determine if a binder has an Annotation meeting a certain criteria
+hasCLasHAnnotation ::
+ GhcMonad m =>
+ (CLasHAnn -> Bool) -- ^ The criteria the Annotation has to meet
+ -> Var.Var -- ^ The Binder
+ -> m Bool -- ^ Indicates if binder has the Annotation
+hasCLasHAnnotation clashAnn var = do
+ let deserializer = Serialized.deserializeWithData
+ let target = Annotations.NamedTarget (Var.varName var)
+ (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
+ let annEnts = filter clashAnn anns
+ case annEnts of
+ [] -> return False
+ xs -> return True
+
+-- | Determine if a binder has a certain name
+hasVarName ::
+ GhcMonad m =>
+ String -- ^ The name the binder has to have
+ -> Var.Var -- ^ The Binder
+ -> m Bool -- ^ Indicate if the binder has the name
+hasVarName lookfor bind = return $ lookfor == (occNameString $ nameOccName $ getName bind)