{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} module Pragma( -- Package and module pragmas Pragma(..), PProp(..), PPnm(..), getPragmaArgNames, getModulePragmaName, -- Rule pragmas RulePragma(..), getRulePragmaName, -- Schedule pragmas SchedulePragma(..), CSchedulePragma, ISchedulePragma, ASchedulePragma, longnameToId, mapSPIds, SPIdMap, substSchedPragmaIds, SPIdSplitMap, splitSchedPragmaIds, removeSchedPragmaIds, isRulePreempt, extractSchedPragmaIds, isAlwaysRdy, isAlwaysEn, isEnWhenRdy, isGatedInputClk, isGatedDefaultClk, hasDefaultClk, hasDefaultRst, hasInhighAttribute, hasUnusedAttribute, hasRuleHide, ppPProp, pvpPProp, -- Interface pragmas IfcPragma(..), noIfcPragmas,getIfcPName, filterIArgNames, filterPrintIfcArgs, getARAEPragmas, extractDuplicatePragmas, lookupPrefixIfcPragma, lookupResultIfcPragma, lookupReadyIfcPragma, lookupEnSignalIfcPragma, lookupRdySignalIfcPragma, isAlwaysReadyIfc, isAlwaysEnabledIfc, getMethodPragmaInfo, getClockPragmaInfo, getResetPragmaInfo, getInoutPragmaInfo, isParamModArg, filterPPparam, -- Def pragmas DefProp(..), defPropsHasNoCSE ) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804) import Prelude hiding ((<>)) #endif import qualified Data.Map as M import Data.Maybe(listToMaybe) import Data.List(sort) import qualified Data.Generics as Generic import Eval import PPrint import PVPrint import Id import PreIds(idDefaultClock, idDefaultReset) import ErrorUtil(internalError) import Util(itos, doubleQuote, findDup) import SchedInfo import Position import IdPrint --import Util(traces) -- ======================================================================== -- Pragma -- data Pragma = Pproperties Id [PProp]-- module Id and properties associate with | Pnoinline [Id] -- [Id] is a list of functions which should not be inlined deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable) instance PPrint Pragma where pPrint d p (Pproperties i pps) = (text "{-# properties" <+> ppId d i <+> text "= { ") <> sepList (map (pPrint d 0) pps) (text ",") <> text " } #-}" pPrint d p (Pnoinline is) = text "{-# noinline" <+> sep (map (ppId d) is) <+> text " #-}" instance PVPrint Pragma where pvPrint d p (Pproperties i pps) = foldr ($+$) empty (map (pvpPProp d) pps) pvPrint d p (Pnoinline is) = text "(* noinline" <+> sep (map (pvpId d) is) <+> text " *)" instance Hyper Pragma where hyper (Pproperties i pps) y = hyper2 i pps y hyper (Pnoinline is) y = hyper is y instance HasPosition Pragma where getPosition (Pproperties i _) = getPosition i getPosition (Pnoinline (i:_)) = getPosition i getPosition (Pnoinline []) = internalError "CSyntax:HasPosition(Pragma).getPosition: Pnoinline []" -- -------------------- -- Module definition properties: data PProp = PPverilog -- generate verilog | PPforeignImport Id -- wrapper for a foreign import -- (Id is link name, needed for dependency check, if we're -- generating the .ba file for the link name, not the src name) | PPalwaysReady [Longname] -- no ready signals for these methods ([] means all) | PPalwaysEnabled [Longname] -- execute on every cycle | PPenabledWhenReady [Longname] -- enable is equivalent to ready | PPscanInsert Integer -- insert scan chain ports | PPbitBlast -- do "bit blasting", -- e.g., split multibit ports | PPCLK String -- clock port prefix | PPGATE String -- gate port prefix | PPRSTN String -- reset port prefix | PPclock_osc [(Id,String)] -- port name for clock | PPclock_gate [(Id,String)] -- port name for gate | PPgate_inhigh [Id] -- clock args with inhigh gates | PPgate_unused [Id] -- clock args with unused gates | PPreset_port [(Id,String)] -- port name for reset | PParg_param [(Id,String)] -- name for parameter argument | PParg_port [(Id,String)] -- port name for other arguments | PParg_clocked_by [(Id,String)] -- clocks of module arguments | PParg_reset_by [(Id,String)] -- resets of module arguments | PPoptions [String] -- compiler options | PPgate_input_clocks [Id] -- list of clock args with gates | PPmethod_scheduling (MethodConflictInfo Longname) -- scheduling constraints for interface arg methods | PPdoc String -- comment to carry through to Verilog | PPperf_spec [[Id]] -- method composition order for performance specs | PPclock_family [Id] -- ids of input clocks in the same family | PPclock_ancestors [[Id]] -- input clock ancestry sequences -- module arguments which should generate to params instead of ports | PPparam [Id] | PPinst_name Id | PPinst_hide | PPinst_hide_all | PPdeprecate String deriving (Show, Eq, Ord, Generic.Data, Generic.Typeable) data PPnm = PPnmOne Id | PPnmArray Id Integer Integer deriving (Show, Eq, Ord) instance PPrint PProp where pPrint d _ (PPscanInsert i) = text "scanInsert = " <+> pPrint d 0 i pPrint d _ (PPCLK s) = text ("clock_prefix = " ++ s) pPrint d _ (PPGATE s) = text ("gate_prefix = " ++ s) pPrint d _ (PPRSTN s) = text ("reset_prefix = " ++ s) pPrint d _ (PPclock_osc xs) = text "clock_osc = {" <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")" | (i,s) <- xs ] (text ",") <> text "}" pPrint d _ (PPclock_gate xs) = text "clock_gate = {" <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")" | (i,s) <- xs ] (text ",") <> text "}" pPrint d _ (PPgate_inhigh is) = text "gate_inhigh = {" <> sepList (map (ppId d) is) (text ",") <> text "}" pPrint d _ (PPgate_unused is) = text "gate_unused = {" <> sepList (map (ppId d) is) (text ",") <> text "}" pPrint d _ (PPreset_port xs) = text "reset_port = {" <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")" | (i,s) <- xs ] (text ",") <> text "}" pPrint d _ (PParg_param xs) = text "arg_param = {" <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")" | (i,s) <- xs ] (text ",") <> text "}" pPrint d _ (PParg_port xs) = text "arg_port = {" <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")" | (i,s) <- xs ] (text ",") <> text "}" pPrint d _ (PParg_clocked_by xs) = text "clocked_by = {" <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")" | (i,s) <- xs ] (text ",") <> text "}" pPrint d _ (PParg_reset_by xs) = text "reset_by = {" <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")" | (i,s) <- xs ] (text ",") <> text "}" pPrint d _ (PPoptions os) = text "options = {" <> sepList (map (text . show) os) (text ",") <> text "}" pPrint d _ (PPdoc comment) = text ("doc = " ++ doubleQuote comment) pPrint d _ (PPdeprecate comment) = text ("deprecate = " ++ doubleQuote comment) pPrint d _ (PPinst_hide) = text "hide" pPrint d p v = text (drop 2 (show v)) instance PPrint PPnm where pPrint d _ (PPnmOne i) = ppId d i pPrint d _ (PPnmArray i h l) = ppId d i <> text ("[" ++ itos h ++ ":" ++ itos l ++ "]") instance PVPrint PProp where pvPrint d _ (PPscanInsert i) = text "scan_insert =" <+> pvPrint d 0 i pvPrint d _ (PPCLK s) = text ("clock_prefix = " ++ s) pvPrint d _ (PPGATE s) = text ("gate_prefix = " ++ s) pvPrint d _ (PPRSTN s) = text ("reset_prefix = " ++ s) pvPrint d _ (PPclock_osc xs) = text "clock_osc = {" <> sepList [ text "(" <> pvpId d i <> text "," <> (text s) <> text ")" | (i,s) <- xs ] (text ",") <> text "}" pvPrint d _ (PPclock_gate xs) = text "clock_gate = {" <> sepList [ text "(" <> pvpId d i <> text "," <> (text s) <> text ")" | (i,s) <- xs ] (text ",") <> text "}" pvPrint d _ (PPgate_inhigh is) = text "gate_inhigh = {" <> sepList (map (pvpId d) is) (text ",") <> text "}" pvPrint d _ (PPgate_unused is) = text "gate_unused = {" <> sepList (map (pvpId d) is) (text ",") <> text "}" pvPrint d _ (PPreset_port xs) = text "reset_port = {" <> sepList [ text "(" <> pvpId d i <> text "," <> (text s) <> text ")" | (i,s) <- xs ] (text ",") <> text "}" pvPrint d _ (PParg_param xs) = text "param_port = {" <> sepList [ text "(" <> pvpId d i <> text "," <> (text s) <> text ")" | (i,s) <- xs ] (text ",") <> text "}" pvPrint d _ (PParg_port xs) = text "arg_port = {" <> sepList [ text "(" <> pvpId d i <> text "," <> (text s) <> text ")" | (i,s) <- xs ] (text ",") <> text "}" pvPrint d _ (PParg_clocked_by xs) = text "clocked_by = {" <> sepList [ text "(" <> pvpId d i <> text "," <> (text s) <> text ")" | (i,s) <- xs ] (text ",") <> text "}" pvPrint d _ (PParg_reset_by xs) = text "reset_by = {" <> sepList [ text "(" <> pvpId d i <> text "," <> (text s) <> text ")" | (i,s) <- xs ] (text ",") <> text "}" pvPrint d _ (PPoptions os) = text "options = {" <> sepList (map (text . show) os) (text ",") <> text "}" pvPrint d _ (PPverilog) = text "synthesize" pvPrint d _ (PPalwaysReady ms) = text "always_ready" pvPrint d _ (PPalwaysEnabled ms) = text "always_enabled" pvPrint d _ (PPenabledWhenReady ms) = text "enabled_when_ready" pvPrint d _ (PPbitBlast) = text "bit_blast" pvPrint d _ (PPdoc comment) = text ("doc = " ++ doubleQuote comment) pvPrint d _ (PPdeprecate comment) = text ("deprecate = " ++ doubleQuote comment) pvPrint d _ (PPparam ids) = text "param = \"" <> sepList (map (pvpId d) ids) (text ",") <> text "\"" pvPrint d _ (PPinst_name i) = text "inst_name = \"" <> pvpId d i <> text "\"" pvPrint d _ (PPinst_hide) = text "inst_hide" pvPrint d p v = text (drop 2 (show v)) instance PVPrint PPnm where pvPrint d _ (PPnmOne i) = pvpId d i pvPrint d _ (PPnmArray i h l) = pvpId d i <> text ("[" ++ show h ++ ":" ++ show l ++ "]") pvpPProp :: PDetail -> PProp -> Doc pvpPProp d pprop = text "(*" <+> pvPrint d 0 pprop <+> text "*)" ppPProp :: PDetail -> PProp -> Doc ppPProp d pprop = text "{-#" <+> pPrint d 0 pprop <+> text "#-};" instance Hyper PProp where hyper (PPscanInsert i) y = seq i y hyper (PPCLK i) y = seq i y hyper (PPGATE i) y = seq i y hyper (PPRSTN i) y = seq i y hyper (PPclock_osc xs) y = hyper xs y hyper (PPclock_gate xs) y = hyper xs y hyper (PPgate_inhigh is) y = hyper is y hyper (PPgate_unused is) y = hyper is y hyper (PPreset_port xs) y = hyper xs y hyper (PParg_param xs) y = hyper xs y hyper (PParg_port xs) y = hyper xs y hyper (PParg_clocked_by xs) y = hyper xs y hyper (PParg_reset_by xs) y = hyper xs y hyper (PPoptions os) y = hyper os y hyper (PPclock_family is) y = hyper is y hyper (PPclock_ancestors ils) y = hyper ils y hyper x y = seq x y instance Hyper PPnm where hyper (PPnmOne i) y = hyper i y hyper (PPnmArray i h l) y = hyper3 i h l y getPragmaArgNames :: PProp -> [String] getPragmaArgNames (PPclock_osc ps) = [ getIdBaseString i | (i,_) <- ps ] getPragmaArgNames (PPclock_gate ps) = [ getIdBaseString i | (i,_) <- ps ] getPragmaArgNames (PPreset_port ps) = [ getIdBaseString i | (i,_) <- ps ] getPragmaArgNames (PParg_param ps) = [ getIdBaseString i | (i,_) <- ps ] getPragmaArgNames (PParg_port ps) = [ getIdBaseString i | (i,_) <- ps ] getPragmaArgNames (PParg_clocked_by ps) = map (getIdBaseString . fst) ps getPragmaArgNames (PParg_reset_by ps) = map (getIdBaseString . fst) ps getPragmaArgNames (PPgate_inhigh is) = map getIdBaseString is getPragmaArgNames (PPgate_unused is) = map getIdBaseString is getPragmaArgNames (PPgate_input_clocks is) = map getIdBaseString is getPragmaArgNames (PPclock_family is) = map getIdBaseString is getPragmaArgNames (PPclock_ancestors is) = map getIdBaseString (concat is) getPragmaArgNames (PPparam is) = map getIdBaseString is getPragmaArgNames _ = [] getModulePragmaName :: PProp -> String getModulePragmaName PPverilog = "synthesize" getModulePragmaName (PPforeignImport {}) = "foreign" getModulePragmaName (PPalwaysReady {}) = "always_ready" getModulePragmaName (PPalwaysEnabled {}) = "always_enabled" getModulePragmaName (PPenabledWhenReady {}) = "enabled_when_ready" getModulePragmaName (PPscanInsert {}) = "scan_insert" getModulePragmaName PPbitBlast = "bit_blast" getModulePragmaName (PPCLK {}) = "clock_prefix" getModulePragmaName (PPGATE {}) = "gate_prefix" getModulePragmaName (PPRSTN {}) = "reset_prefix" getModulePragmaName (PPclock_osc {}) = "osc" getModulePragmaName (PPclock_gate {}) = "gate" getModulePragmaName (PPgate_inhigh {}) = "inhigh" getModulePragmaName (PPgate_unused {}) = "unused" getModulePragmaName (PPreset_port {}) = "reset" getModulePragmaName (PParg_param {}) = "parameter" getModulePragmaName (PParg_port {}) = "port" getModulePragmaName (PParg_clocked_by {}) = "clocked_by" getModulePragmaName (PParg_reset_by {}) = "reset_by" getModulePragmaName (PPoptions {}) = "options" getModulePragmaName (PPgate_input_clocks {}) = "gate_input_clocks" getModulePragmaName (PPmethod_scheduling {}) = "method_scheduling" getModulePragmaName (PPdoc {}) = "doc" getModulePragmaName (PPperf_spec {}) = "perf_spec" getModulePragmaName (PPclock_family {}) = "clock_family" getModulePragmaName (PPclock_ancestors {}) = "clock_ancestors" getModulePragmaName (PPparam {}) = "param" getModulePragmaName (PPinst_name {}) = "inst_name" getModulePragmaName (PPinst_hide) = "inst_hide" getModulePragmaName (PPinst_hide_all) = "inst_hide_all" getModulePragmaName (PPdeprecate {}) = "deprecate" -- ======================================================================== -- RulePragma -- data RulePragma = RPfireWhenEnabled | RPnoImplicitConditions | RPaggressiveImplicitConditions | RPconservativeImplicitConditions | RPnoWarn -- suppress (on a per-rule basis) warnings G0023, G0036, and G0117 | RPwarnAllConflicts | RPcanScheduleFirst | RPclockCrossingRule | RPdoc String -- comment to carry through to Verilog | RPhide deriving (Show, Eq, Ord, Generic.Data, Generic.Typeable) -- used for classic printing of CSyntax -- and by various internal dumps of ISyntax/ASyntax instance PPrint RulePragma where pPrint d p RPfireWhenEnabled = text "{-# ASSERT fire when enabled #-}" pPrint d p RPnoImplicitConditions = text "{-# ASSERT no implicit conditions #-}" pPrint d p RPcanScheduleFirst = text "{-# ASSERT can schedule first #-}" pPrint d p RPaggressiveImplicitConditions = text "{-# aggressive_implicit_conditions #-}" pPrint d p RPconservativeImplicitConditions = text "{-# conservative_implicit_conditions #-}" pPrint d p RPnoWarn = text "{-# no_warn #-}" pPrint d p RPwarnAllConflicts = text "{-# warn_all_conflicts #-}" pPrint d p RPclockCrossingRule = text "{-# clock-crossing rule #-}" pPrint d p (RPdoc comment) = text ("{-# doc = " ++ doubleQuote comment ++ " #-}") pPrint d p RPhide = text ("{-# hide #-}") -- this is used for reporting a failure of a rule assertion -- (only the first two are assertions, perhaps the data structures -- should reflect this?) getRulePragmaName :: RulePragma -> String getRulePragmaName RPfireWhenEnabled = "fire_when_enabled" getRulePragmaName RPnoImplicitConditions = "no_implicit_conditions" getRulePragmaName RPaggressiveImplicitConditions = "aggressive_implicit_conditions" getRulePragmaName RPconservativeImplicitConditions = "conservative_implicit_conditions" getRulePragmaName RPnoWarn = "no_warn" getRulePragmaName RPwarnAllConflicts = "warn_all_conflicts" getRulePragmaName RPcanScheduleFirst = "can_schedule_first" getRulePragmaName RPclockCrossingRule = "clock_crossing_rule" getRulePragmaName (RPdoc {}) = "doc" getRulePragmaName RPhide = "hide" instance Hyper RulePragma where hyper x y = seq x y -- ======================================================================== -- SchedulePragma -- data SchedulePragma id_t = SPUrgency [id_t] | SPExecutionOrder [id_t] | SPMutuallyExclusive [[id_t]] | SPConflictFree [[id_t]] | SPPreempt [id_t] [id_t] | SPSchedule (MethodConflictInfo id_t) deriving (Show, Eq, Ord, Generic.Data, Generic.Typeable) type CSchedulePragma = SchedulePragma Longname type ISchedulePragma = SchedulePragma Id type ASchedulePragma = SchedulePragma Id instance (PPrint t, Ord t) => PPrint (SchedulePragma t) where pPrint d p (SPUrgency ids) = text "{-# ASSERT descending urgency: " <+> pPrint d p ids <+> text "#-}" pPrint d p (SPExecutionOrder ids) = text "{-# ASSERT execution order: " <+> pPrint d p ids <+> text "#-}" pPrint d p (SPMutuallyExclusive idss) = text "{-# ASSERT mutually exclusive: " <+> pPrint d p idss <+> text "#-}" pPrint d p (SPConflictFree idss) = text "{-# ASSERT conflict-free: " <+> pPrint d p idss <+> text "#-}" pPrint d p (SPPreempt ids1 ids2) = text "{-# ASSERT preempt: " <+> pPrint d p ids1 <+> pPrint d p ids2 <+> text "#-}" pPrint d p (SPSchedule s) = text "{-# ASSERT schedule: " <+> pPrint d p s <+> text "#-}" -- instance PVPrint ? instance (Hyper t) => Hyper (SchedulePragma t) where hyper (SPUrgency ids) y = hyper ids y hyper (SPExecutionOrder ids) y = hyper ids y hyper (SPMutuallyExclusive idss) y = hyper idss y hyper (SPConflictFree idss) y = hyper idss y hyper (SPPreempt ids1 ids2) y = hyper2 ids1 ids2 y hyper (SPSchedule s) y = hyper s y -- -------------------- longnameToId :: Longname -> Id longnameToId ln = foldr1 mkUSId ln -- Can be used to convert CSchedulePragma to ISchedulePragma, -- or to map a function over the Ids of a list of pragmas mapSPIds :: (t1 -> t2) -> [SchedulePragma t1] -> [SchedulePragma t2] mapSPIds f sps = let mapOneSP (SPUrgency ids) = SPUrgency (map f ids) mapOneSP (SPExecutionOrder ids) = SPExecutionOrder (map f ids) mapOneSP (SPMutuallyExclusive idss) = SPMutuallyExclusive (map (map f) idss) mapOneSP (SPConflictFree idss) = SPConflictFree (map (map f) idss) mapOneSP (SPPreempt ids1 ids2) = SPPreempt (map f ids1) (map f ids2) mapOneSP (SPSchedule s) = SPSchedule (mapMethodConflictInfo f s) in map mapOneSP sps -- -------------------- setpos :: Id -> Id -> Id setpos id1 id2 = setIdPosition (getIdPosition id1) id2 -- -------------------- type SPIdMap = M.Map Id Id substSchedPragmaIds :: SPIdMap -> [ISchedulePragma] -> [ISchedulePragma] substSchedPragmaIds idmap sps = let -- preserve the position of the original Id -- (still point to the name that the user wrote in the source) substId id1 = case (M.lookup id1 idmap) of Just id2 -> setpos id1 id2 Nothing -> id1 in mapSPIds substId sps -- -------------------- type SPIdSplitMap = [(Id,[Id])] splitSchedPragmaIds :: SPIdSplitMap -> [ASchedulePragma] -> [ASchedulePragma] splitSchedPragmaIds idsplitmap sps = let splitId :: Id -> [Id] splitId id1 = case (lookup id1 idsplitmap) of Just ids -> map (setpos id1) ids Nothing -> [id1] splitIdList ids = let joinFn :: [Id] -> [[Id]] -> [[Id]] joinFn xs ys = concatMap (\x -> map (\y -> (x:y)) ys) xs in foldr joinFn [[]] (map splitId ids) splitSP (SPUrgency ids) = map SPUrgency (splitIdList ids) splitSP (SPExecutionOrder ids) = map SPExecutionOrder (splitIdList ids) splitSP (SPMutuallyExclusive idss) = [SPMutuallyExclusive (map (concatMap splitId) idss)] splitSP (SPConflictFree idss) = [SPConflictFree (map (concatMap splitId) idss)] splitSP (SPPreempt ids1 ids2) = -- Split preempt rules retain the same preempt relationship -- individually. [SPPreempt (concatMap splitId ids1) (concatMap splitId ids2)] splitSP (SPSchedule s) = -- Split scheudle rules conservatively have the same relationship as -- individually. [SPSchedule (concatMapMethodConflictInfo splitId s)] in concatMap splitSP sps -- -------------------- removeSchedPragmaIds :: [Id] -> [ASchedulePragma] -> [ASchedulePragma] removeSchedPragmaIds [] sps = sps removeSchedPragmaIds ids sps = let f = (\x -> not (elem x ids)) filterIds = filter f removeSP (SPUrgency xids) = SPUrgency (filterIds xids) removeSP (SPExecutionOrder xids) = SPExecutionOrder (filterIds xids) removeSP (SPMutuallyExclusive xidss) = SPMutuallyExclusive ((map filterIds) xidss) removeSP (SPConflictFree xidss) = SPConflictFree ((map filterIds) xidss) removeSP (SPPreempt ids1 ids2) = SPPreempt (filterIds ids1) (filterIds ids2) removeSP (SPSchedule s) = SPSchedule (filterMethodConflictInfo f s) in map removeSP sps -- -------------------- isRulePreempt :: Id -> [ASchedulePragma] -> Bool isRulePreempt i sps = let handleOneSP (SPPreempt ids _) = elem i ids handleOneSP _ = False in any handleOneSP sps -- -------------------- extractSchedPragmaIds :: (Ord id_t) => [SchedulePragma id_t] -> [id_t] extractSchedPragmaIds sps = let extractSP (SPUrgency ids) = ids extractSP (SPExecutionOrder ids) = ids extractSP (SPMutuallyExclusive idss) = concat idss extractSP (SPConflictFree idss) = concat idss extractSP (SPPreempt ids1 ids2) = ids1 ++ ids2 extractSP (SPSchedule s) = (extractFromMethodConflictInfo s) in concatMap extractSP sps -- ======================================================================== isAlwaysEn :: [PProp] -> Id -> Bool isAlwaysEn [] i = False isAlwaysEn ((PPalwaysEnabled []):pps) i = True -- always_enabled for whole module (backwards compatible) isAlwaysEn ((PPalwaysEnabled is):pps) i = if i `elem` (map flattenUSId is) then True else isAlwaysEn pps i isAlwaysEn (pp:pps) i = isAlwaysEn pps i -- Given RDY_nm, return if nm is in the list for always_ready -- NOTE: always_enabled implies always_ready isAlwaysRdy :: [PProp] -> Id -> Bool isAlwaysRdy [] i = False isAlwaysRdy ((PPalwaysReady []):pps) i = isRdyId i -- always_ready for whole module (backwards compatible) isAlwaysRdy ((PPalwaysEnabled []):pps) i = isRdyId i -- always_enabled for module (backwards compatible) isAlwaysRdy ((PPalwaysReady is):pps) i = -- traces( "isar: " ++ ppReadable i ++ ":" ++ ppReadable (map (mkRdyId . flattenUSId) is)) $ if i `elem` (map (mkRdyId . flattenUSId) is) then True else isAlwaysRdy pps i isAlwaysRdy ((PPalwaysEnabled is):pps) i = if i `elem` (map (mkRdyId . flattenUSId) is) then True else isAlwaysRdy pps i isAlwaysRdy (pp:pps) i = isAlwaysRdy pps i -- NOTE: always_enabled implies enabled_when_ready isEnWhenRdy :: [PProp] -> Id -> Bool isEnWhenRdy [] i = False isEnWhenRdy ((PPenabledWhenReady []):pps) i = True -- enabled_when_ready for whole module isEnWhenRdy ((PPalwaysEnabled []):pps) i = True isEnWhenRdy ((PPenabledWhenReady is):pps) i = if i `elem` (map flattenUSId is) then True else isEnWhenRdy pps i isEnWhenRdy ((PPalwaysEnabled is):pps) i = if i `elem` (map flattenUSId is) then True else isEnWhenRdy pps i isEnWhenRdy (pp:pps) i = isEnWhenRdy pps i || isAlwaysEn pps i --always_enabled implies enabled_when_ready -- ======================================================================== -- the attribute "gate_all_clocks" is implemented by an empty list gateAllClocks :: [PProp] -> Bool gateAllClocks pps = elem (PPgate_input_clocks []) pps -- An input clock is gated if all input clocks are gated -- (gate_all_clocks with an empty list), or if it is explicitly -- named in gate_all_clocks, or if there is a non-empty -- clock_gate attribute for it. However, if it is gated -- using "gate_all_clocks", it can still be marked ungated -- by attribute for it. isGatedInputClk :: [PProp] -> Id -> Bool isGatedInputClk pps i = let in_list = or (map is_listed pps) on_port = or (map is_port pps) inhigh_or_unused = or (map is_no_port pps) in in_list || on_port || (gateAllClocks pps && (not inhigh_or_unused)) where is_listed (PPgate_input_clocks is) = i `elem` is is_listed _ = False is_port (PPclock_gate ps) = i `elem` (map fst ps) is_port _ = False is_no_port (PPgate_inhigh is) = i `elem` is is_no_port (PPgate_unused is) = i `elem` is is_no_port _ = False isGatedDefaultClk :: [PProp] -> Bool isGatedDefaultClk pps = isGatedInputClk pps idDefaultClock hasInhighAttribute :: [PProp] -> Id -> Bool hasInhighAttribute pps i | i == idDefaultClock = hasInhighAttribute pps emptyId | otherwise = or [ i `elem` is | PPgate_inhigh is <- pps ] hasUnusedAttribute :: [PProp] -> Id -> Bool hasUnusedAttribute pps i | i == idDefaultClock = hasUnusedAttribute pps emptyId | otherwise = or [ i `elem` is | PPgate_unused is <- pps ] hasDefaultClk :: [PProp] -> Bool hasDefaultClk pps = not (any removesDefClk pps) where removesDefClk (PPclock_osc ps) = (idDefaultClock,"") `elem` ps removesDefClk _ = False hasDefaultRst :: [PProp] -> Bool hasDefaultRst pps = not (any removesDefRst pps) where removesDefRst (PPreset_port ps) = (idDefaultReset,"") `elem` ps removesDefRst _ = False hasRuleHide :: [RulePragma] -> Bool hasRuleHide [] = False hasRuleHide (RPhide:_) = True hasRuleHide (_:rest) = hasRuleHide rest -- ========================================================================= -- Interface definition pragmas -- These pragma are associated with interfaces and/or the fields within the interface -- The first arg is the field name which the attribute is associated with data IfcPragma = PIArgNames [Id] -- arg names used as dummy names (XX this can be removed?) | PIPrefixStr String -- Method or interface | PIResultName String -- name for the result of the method AV or value methods | PIRdySignalName String -- name for the ready signal on this method | PIEnSignalName String -- name for the enable signal | PIAlwaysRdy -- ifc or methods tagged as always ready | PIAlwaysEnabled -- ifc or methods tagged as always enabled deriving (Show, Ord, Eq, Generic.Data, Generic.Typeable) -- type PragmaPair = (Id,String) instance PPrint IfcPragma where pPrint d _ (PIArgNames ids) = text "arg_names =" <+> brackets ( (sepList (map (ppVarId d) ids) comma) ) pPrint d _ (PIPrefixStr flds) = text "prefixs =" <+> doubleQuotes (text flds) pPrint d _ (PIRdySignalName flds) = text "ready =" <+> doubleQuotes (text flds) pPrint d _ (PIEnSignalName flds) = text "enable =" <+> doubleQuotes (text flds) pPrint d _ (PIResultName flds) = text "result =" <+> doubleQuotes (text flds) pPrint d _ (PIAlwaysRdy ) = text "always_ready " pPrint d _ (PIAlwaysEnabled ) = text "always_enabled " instance PVPrint IfcPragma where pvPrint d _ (PIArgNames ids) = text "ports =" <+> brackets ( (sepList (map (doubleQuotes . (ppVarId d)) ids) comma) ) pvPrint d _ (PIPrefixStr flds) = text "prefix =" <+> doubleQuotes (text flds) pvPrint d _ (PIRdySignalName flds) = text "ready =" <+> doubleQuotes (text flds) pvPrint d _ (PIEnSignalName flds) = text "enable =" <+> doubleQuotes (text flds) pvPrint d _ (PIResultName flds) = text "result =" <+> doubleQuotes (text flds) pvPrint d _ (PIAlwaysRdy ) = text "always_ready " pvPrint d _ (PIAlwaysEnabled ) = text "always_enabled " instance Hyper IfcPragma where hyper (PIArgNames ids) y = hyper ids y hyper (PIPrefixStr flds) y = hyper flds y hyper (PIRdySignalName flds) y = hyper flds y hyper (PIEnSignalName flds) y = hyper flds y hyper (PIResultName flds) y = hyper flds y hyper (PIAlwaysRdy ) y = y hyper (PIAlwaysEnabled ) y = y -- a means to get a print string from attribute getIfcPName :: IfcPragma -> String getIfcPName (PIArgNames fs) = "port" getIfcPName (PIPrefixStr pps) = "prefix" getIfcPName (PIRdySignalName pps) = "ready" getIfcPName (PIEnSignalName pps) = "enable" getIfcPName (PIResultName pps) = "result" getIfcPName (PIAlwaysRdy ) = "always_ready" getIfcPName (PIAlwaysEnabled ) = "always_enabled" -- an empty list to keep typing and searching happier noIfcPragmas :: [IfcPragma] noIfcPragmas = [] -- convenience function -- extract out PIArgNames ids. filterIArgNames :: [IfcPragma] -> [Id] filterIArgNames prags = concatMap getArgNames prags where getArgNames :: IfcPragma -> [Id] getArgNames (PIArgNames names) = names getArgNames _ = [] filterPrintIfcArgs :: [IfcPragma] -> [IfcPragma] filterPrintIfcArgs prags = filter isPrintArg prags where isPrintArg (PIArgNames names) = False isPrintArg x = True isAlwaysReadyIfc :: [IfcPragma] -> Bool isAlwaysReadyIfc prags = any isAR prags where isAR :: IfcPragma -> Bool isAR (PIAlwaysRdy ) = True isAR (PIAlwaysEnabled) = True -- AE implies AR isAR _ = False isAlwaysEnabledIfc :: [IfcPragma] -> Bool isAlwaysEnabledIfc prags = any isAR prags where isAR :: IfcPragma -> Bool isAR (PIAlwaysEnabled ) = True isAR _ = False getARAEPragmas :: [IfcPragma] -> [IfcPragma] getARAEPragmas prags = filter isARAE prags where isARAE (PIAlwaysRdy ) = True isARAE (PIAlwaysEnabled ) = True isARAE _ = False -- and may have different string -- return the names of any dupliplicate pragma extractDuplicatePragmas :: [IfcPragma] -> [String] extractDuplicatePragmas prags = findDup (sort names ) where names = map getIfcPName prags lookupReadyIfcPragma :: [IfcPragma] -> Maybe String lookupReadyIfcPragma iprags = listToMaybe allflds where allflds = [ flds | (PIRdySignalName flds) <- iprags] lookupPrefixIfcPragma :: [IfcPragma] -> Maybe String lookupPrefixIfcPragma iprags = listToMaybe allflds where allflds = [ flds | (PIPrefixStr flds) <- iprags] lookupRdySignalIfcPragma :: [IfcPragma] -> Maybe String lookupRdySignalIfcPragma iprags = listToMaybe allflds where allflds = [ flds | (PIRdySignalName flds) <- iprags] lookupEnSignalIfcPragma :: [IfcPragma] -> Maybe String lookupEnSignalIfcPragma iprags = listToMaybe allflds where allflds = [ flds | (PIEnSignalName flds) <- iprags] lookupResultIfcPragma :: [IfcPragma] -> Maybe String lookupResultIfcPragma iprags = listToMaybe allflds where allflds = [ flds | (PIResultName flds) <- iprags] -- prefix, Result, ready, enable, args, AR, AE -- XXX since these are all generated, we can add a new pragma to store these directly thus avoiding the lookup getMethodPragmaInfo :: [IfcPragma] -> (Maybe String, Maybe String, Maybe String, Maybe String, [Id], Bool, Bool) getMethodPragmaInfo prags = foldl getFields (Nothing,Nothing, Nothing,Nothing,[],False,False) prags where getFields :: (Maybe String, Maybe String, Maybe String, Maybe String, [Id], Bool, Bool) -> IfcPragma -> (Maybe String, Maybe String, Maybe String, Maybe String, [Id], Bool, Bool) getFields (mprefix,mres, mready, menable, [], ar, ae) (PIArgNames fis) = (mprefix,mres, mready, menable, fis, ar, ae) getFields (Nothing,mres, mready, menable, args, ar, ae) (PIPrefixStr s) = (Just s,mres, mready, menable, args, ar, ae) getFields (mprefix,Nothing, mready, menable, args, ar, ae) (PIResultName s ) = (mprefix,Just s, mready, menable, args, ar, ae) getFields (mprefix,mres, Nothing, menable, args, ar, ae) (PIRdySignalName s) = (mprefix,mres, Just s, menable, args, ar, ae) getFields (mprefix,mres, mready, Nothing, args, ar, ae) (PIEnSignalName s) = (mprefix,mres, mready, Just s, args, ar, ae) getFields (mprefix,mres, mready, menable, args, False, ae) (PIAlwaysRdy) = (mprefix,mres, mready, menable, args, True, ae) getFields (mprefix,mres, mready, menable, args, ar, False) (PIAlwaysEnabled) = (mprefix,mres, mready, menable, args, ar, True) getFields x@(mprefix,mres, mready, menable, args, ar, ae) y = internalError( "getMethodPragmaInfo: " ++ show (y)) -- From a set of ifc pragmas, determine: -- prefix getClockPragmaInfo :: [IfcPragma] -> (Maybe String) getClockPragmaInfo prags = foldl getFn (Nothing) prags where getFn (Nothing) (PIPrefixStr s) = (Just s) getFn x@(mprefix) y = internalError("getClockPragmaInfo: " ++ show (x, y)) -- From a set of ifc pragmas, determine: -- prefix getResetPragmaInfo :: [IfcPragma] -> (Maybe String) getResetPragmaInfo prags = foldl getFn (Nothing) prags where getFn (Nothing) (PIPrefixStr s) = (Just s) getFn x@(mprefix) y = internalError("getResetPragmaInfo: " ++ show (x, y)) -- From a set of ifc pragmas, determine: -- prefix getInoutPragmaInfo :: [IfcPragma] -> (Maybe String) getInoutPragmaInfo prags = foldl getFn (Nothing) prags where getFn (Nothing) (PIPrefixStr s) = (Just s) getFn x@(mprefix) y = internalError("getInoutPragmaInfo: " ++ show (x, y)) -- -------------------- isParamModArg :: [PProp] -> Id -> Bool isParamModArg [] i = False isParamModArg (PPparam ids:pps) i = if (i `elem` ids) then True else isParamModArg pps i isParamModArg (_:pps) i = isParamModArg pps i isPPparam :: PProp -> Bool isPPparam (PPparam {}) = True isPPparam _ = False filterPPparam :: Pragma -> Maybe Pragma filterPPparam (Pproperties i pprops) = let pprops' = filter (not . isPPparam) pprops in if (null pprops') then Nothing else Just (Pproperties i pprops') filterPPparam p@(Pnoinline {}) = Just p -- ======================================================================== -- DefProp (module def pragmas) data DefProp = DefP_Rule Id -- for method predicates | DefP_Method Id -- for method predicates | DefP_Instance Id -- for method predicates | DefP_NoCSE -- indicate this def should never be used for CSE deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable) instance PPrint DefProp where pPrint _d _i = text . show instance Hyper DefProp where hyper (DefP_Rule x) y = hyper x y hyper (DefP_Instance x) y = hyper x y hyper (DefP_Method x) y = hyper x y hyper DefP_NoCSE y = y -- -------------------- defPropsHasNoCSE :: [DefProp] -> Bool defPropsHasNoCSE = elem DefP_NoCSE -- ========================================================================