{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImplicitParams #-} module IExpandUtils( HPred, PExpr(..), pExprToHExpr, predToIExpr, pConj, pConjs, pAtom, pIf, pSel, normPConj, unsafeDerefHeap, HeapCell(..), uniqueStateName, newStateNo, getStateNo, HExpr, HeapData(..), HClock, HReset, HInout, HStateVar, HRules, HWireSet, HDef, HRule, HEFace, runG, G, GOutput(..), errG, errsG, deferErrors, eWarning, eWarnings, getElabProgressContext, eNoNF, addRules, pushTopModuleSchedNameScope, pushModuleSchedNameScope, popModuleSchedNameScope, pushRuleSchedNameScope, popRuleSchedNameScope, setRuleSchedNameScopeProgress, RuleElabProgress(..), pushIfcSchedNameScope, popIfcSchedNameScope, setIfcSchedNameScopeProgress, IfcElabProgress(..), addSubmodComments, {-getSubmodComments,-} addPort, getPortWires, savePortType, saveTopModPortType, saveRules, getSavedRules, clearSavedRules, replaceSavedRules, setBackendSpecific, cacheDef, addStateVar, step, updHeap, getHeap, {- filterHeapPtrs, -} getSymTab, getDefEnv, getFlags, getCross, getErrHandle, getModuleName, getNewRuleSuffix, updNewRuleSuffix, mapPExprPosition, chkClockDomain, chkResetDomain, fixupActionWireSet, chkModuleArgument, chkModuleArgumentClkRst, getMethodsByClockDomain, getMethodsByReset, extractWireSet, addHeapCell, addHeapUnev, newClock, newReset, addHeapPred, addInputClock, addOutputClock, addInputReset, addOutputReset, getClkGateUses, clearClkGateUses, setClkGateUses, assertNoClkGateUses, addClkGateUse, addInhighClkGate, addGateUsesToInhigh, addGateInhighAttributes, chkClkArgGateWires, chkClkAncestry, chkClkSiblings, getInputResetClockDomain, setInputResetClockDomain, chkInputClockPragmas, getBoundaryClock, getBoundaryClocks, boundaryClockToName, getBoundaryReset, getBoundaryResets, boundaryResetToName, getInputResets, makeInputClk, makeInputRstn, makeOutputClk, makeOutputRstn, makeArgInout, makeIfcInout, getInoutWires, makeDomainToBoundaryIdsMap, getDomainToBoundaryIdsMap, findBoundaryClock, isClockAncestor, isPrimType, isParamOnlyType, HeapPointer, unheap, unheapU, shallowUnheap, unheapAll, toHeap, toHeapCon, toHeapWHNFCon, toHeapInferName, toHeapConInferName, toHeapWHNFConInferName, toHeapWHNF, toHeapWHNFInferName, realPrimOp, integerPrim, realPrim, stringPrim, charPrim, handleBoolPrim, strictPrim, condPrim, NameInfo, legalizeNameInfo, newIStateLoc, newIStateLocForRule, isNoInlinedFunc, isAggressive, setAggressive, getPragmas, setPragmas, cleanupFinalRules, heapCellToHExpr, canLiftCond, newFFCallNo, makeArgPortId, makeArgParamId, showTopProgress, showModProgress, showRuleProgress ) where import Control.Monad.State import Data.IORef import System.IO.Unsafe import Data.List import Data.Maybe import Data.Char(isAlphaNum) import System.Time -- XXX: from old-time package import Debug.Trace(traceM) import qualified Data.Array as Array import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Generics as Generic import Eval import PPrint -- import PVPrint import PFPrint import Flags import Error(internalError, EMsg, ErrMsg(..), ErrorHandle, MsgContext, bsError, bsWarning, bsErrorWithContext, bsWarningWithContext, bsErrorWithContextNoExit, exitFail, closeOpenHandles) import Position import SymTab(SymTab, getIfcFlatMethodNames) import PreStrings(s_unnamed) import FStringCompat import Id import PreIds import CType(TISort(..), StructSubType(..)) import VModInfo import ISyntax import ISyntaxUtil import ISyntaxCheck(iGetKind) import Prim import Wires import IWireSet import Pragma(PProp(..), SPIdMap, substSchedPragmaIds, extractSchedPragmaIds, removeSchedPragmaIds) import Util import IOUtil(progArgs) import ISyntaxXRef(mapIExprPosition, mapIExprPosition2) import IStateLoc(IStateLoc, IStateLocPathComponent(..), StateLocMap, newIStateLocTop, hasIgnore, isAddRules, isLoop, extendStateLocMap, stateLocToPrefix, createSuffixedId, hasHide, hasHideAll, stateLocToHierName) {- DEBUGGING AIDS import Util(getEnvDef,traces) import System.IO.Unsafe(unsafePerformIO) dump_hcells = unsafePerformIO $ do env_bs_dump_hcells <- getEnvDef "BS_DUMP_HCELLS" "" return (read ("[" ++ env_bs_dump_hcells ++ "]")) trace_hcell cell expr | cell `elem` dump_hcells = traceM ("hcell " ++ show cell ++ ": " ++ show expr) | otherwise = return () -} ----------------------------------------------------------------------------- -- Trace Flags -- The comments for these flags are in IExpand doProfile :: Bool doProfile = elem "-trace-profile" progArgs doTraceHeap :: Bool doTraceHeap = elem "-trace-heap" progArgs doTraceHeap2 :: Bool doTraceHeap2 = length (filter (== "-trace-heap") progArgs) > 1 doTraceHeapAlloc :: Bool doTraceHeapAlloc = elem "-trace-heap-alloc" progArgs doTraceCache :: Bool doTraceCache = elem "-trace-def-cache" progArgs doTraceClock :: Bool doTraceClock = elem "-trace-clock" progArgs doDebugFreeVars :: Bool doDebugFreeVars = elem "-debug-eval-free-vars" progArgs doTracePortTypes :: Bool doTracePortTypes = elem "-trace-port-types" progArgs doTraceLoc :: Bool doTraceLoc = elem "-trace-state-loc" progArgs ----------------------------------------------------------------------------- type HPred = Pred HeapData pAtom :: IExpr a -> Pred a pAtom e = if isTrue e then PConj S.empty else PConj (S.singleton (PAtom e)) -- we're wrapping this in the G monad because pIf' should be in IO -- using unsafePeformIO inside of it is a performance hack pIf :: HExpr -> HPred -> HPred -> G HPred pIf c t e = return $ pIf' c t e -- expand heap references looking for PrimBNot to desugar pIf' :: HExpr -> HPred -> HPred -> HPred pIf' c@(IRefT _ _ (HeapData r)) t e = let (P p e') = heapCellToPExpr (unsafePerformIO (readIORef r)) in case e' of (IAps (ICon _ (ICPrim _ PrimBNot)) [] [c']) -> pConj p (pIf' c' e t) _ -> pIf'' c t e pIf' c t e = pIf'' c t e pIf'' :: HExpr -> HPred -> HPred -> HPred pIf'' (IAps (ICon _ (ICPrim _ PrimBNot)) [] [c]) t e = pIf' c e t pIf'' c t@(PConj ts) e@(PConj es) = let te = ts `S.intersection` es ts' = ts `S.difference` te es' = es `S.difference` te in if ts' == es' then t else PConj (S.insert (PIf c (PConj ts') (PConj es')) te) pSel :: HExpr -> Integer -> [HPred] -> HPred pSel idx idx_sz es = let getP (PConj p) = p common_ps = foldr1 S.intersection (map getP es) ps' = map (\ e -> (getP e) `S.difference` common_ps) es in if (all S.null ps') then PConj common_ps else PConj (S.insert (PSel idx idx_sz (map PConj ps')) common_ps) pConj :: Pred a -> Pred a -> Pred a pConj (PConj ts1) (PConj ts2) = PConj (ts1 `S.union` ts2) pConjs :: [Pred a] -> Pred a pConjs ps = PConj (S.unions [ ts | PConj ts <- ps ]) isPAtom :: PTerm a -> Bool isPAtom (PAtom _) = True isPAtom _ = False pairConj :: (Pred a, Pred b) -> (Pred a, Pred b) -> (Pred a, Pred b) pairConj (t1, f1) (t2, f2) = (t1 `pConj` t2, f1 `pConj` f2) -- like zipWith, but if one list is longer, keep those elements listConj :: [Pred a] -> [Pred a] -> [Pred a] listConj xs [] = xs listConj [] ys = ys listConj (x:xs) (y:ys) = (x `pConj` y) : listConj xs ys -- normPConj inherits the performance hack of pIf normPConj :: HPred -> G HPred normPConj p = return $ normPConj' p normPConj' :: HPred -> HPred normPConj' (PConj ps) = let un (PConj ps) = S.toList ps f p@(PAtom _) = if p `elem` as then [] else [p] f (PIf c (PConj ts) (PConj es)) = un (pIf' c ts_norm es_norm) where ts' = map f (S.toList ts) ts_norm = PConj (S.fromList (concat ts')) es' = map f (S.toList es) es_norm = PConj (S.fromList (concat es')) f (PSel idx idx_sz es) = un (pSel idx idx_sz es_norm) where es' = map (map f . un) es es_norm = map (PConj . S.fromList . concat) es' -- the atoms (as, if_or_sels) = partition isPAtom (S.toList ps) -- merge all the PIf with common conditions ifmap = M.fromListWith pairConj [(c, (t, e)) | PIf c t e <- if_or_sels ] mifs = [ PIf c t e | (c, (t, e)) <- M.toList ifmap ] -- remove the atoms that are already covered, and simplify mifs' = map f mifs -- merge all the PSel with common indices selmap = M.fromListWith listConj [((idx, idx_sz), es) | PSel idx idx_sz es <- if_or_sels ] msels = [ PSel idx idx_sz es | ((idx, idx_sz), es) <- M.toList selmap ] -- remove the atoms that are already covered, and simplify msels' = map f msels in PConj (S.fromList (as ++ concat mifs' ++ concat msels')) predToIExpr :: Pred a -> IExpr a predToIExpr (PConj es) = foldr (ieAnd . pTermToIExpr) iTrue (S.toList es) pTermToIExpr :: PTerm a -> IExpr a pTermToIExpr (PAtom e) = e pTermToIExpr (PIf c t e) = ieIfx itBit1 c (predToIExpr t) (predToIExpr e) pTermToIExpr (PSel idx idx_sz es) = -- the default for out of range selection is True ieCase itBit1 idx_sz idx (map predToIExpr es) iTrue -- An expression with an implicit condition. data PExpr = P HPred HExpr deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable) instance PPrint PExpr where pPrint d prec (P p e) = pPrint d prec (iePrimWhen (iGetType e) (predToIExpr p) e) pExprToHExpr :: PExpr -> HExpr pExprToHExpr (P (PConj s) e) | S.null s = e pExprToHExpr (P p e) = iePrimWhenPred (iGetType e) p e --------------------------------------------------------------------------- -- test whether an expression is a valid condition to be lifted to the -- predicate as part of aggressive implicit conditions -- (method arguments cannot be lited and the value result of ActionValue -- methods or foreign functions cannot be lifted) -- XXX In rev 13458, this function was changed from monadic to use -- XXX unsafePerformIO, as a workarounk for a mem leak (the same as is -- XXX done for pIf). Ravi suspected it might be a GHC bug? -- Avoid exponential expansion by memoizing results. -- XXX Perhaps better would be to generate this info along with the p-term. canLiftCond :: HExpr -> G Bool canLiftCond e = return $ fst $ canLiftCond' M.empty e canLiftCond' :: M.Map Int Bool -> HExpr -> (Bool, M.Map Int Bool) -- value portion of an ActionValue -- the select should only survive if it is surrounding a method call -- or foreign function call, so no check of "e" is needed canLiftCond' m (IAps (ICon i_sel ICSel { }) _ [e]) | i_sel == idAVValue_ = (False, m) -- dynamic selection from an array -- (we could not treat this prim specially and instead just consider an -- ICLazyArray liftable if all elements are liftable; but this is a more -- aggressive optimization that only considers the selectable elems) canLiftCond' m (IAps (ICon _ (ICPrim _ PrimArrayDynSelect)) [elem_ty, ITNum idx_sz] [arr_e, idx_e]) = case arr_e of ICon _ (ICLazyArray _ arr u) -> if (isJust u) then (False, m) else let cells = Array.elems arr reachable_cells = take (2 ^ idx_sz) cells cellToExpr (ArrayCell ptr ref) = IRefT elem_ty ptr ref -- check the index and the reachable cells es = (idx_e : map cellToExpr reachable_cells) in canLiftCond'_List m es _ -> internalError ("canLiftCond': array: " ++ ppReadable arr_e) canLiftCond' m (IAps f _ es) = canLiftCond'_List m (f:es) -- method argument canLiftCond' m (ICon _ (ICMethArg _)) = (False, m) -- other arrays are unexpected canLiftCond' m (ICon _ (ICLazyArray arr_ty arr u)) = internalError ("IExpandUtils.canLiftCond: unexpected array") canLiftCond' m (ICon _ _) = (True, m) canLiftCond' m ref@(IRefT t p r) = -- only follow references for which we haven't yet computed the answer case M.lookup p m of Nothing -> -- implicit conditions will have been dealt with previously, -- so we unheap with NoImp let (b, m') = canLiftCond' m (unheapNFNoImpEvil ref) in (b, M.insert p b m') Just b -> (b, m) canLiftCond' m e = internalError ("IExpandUtils.canLiftCond unexpected " ++ (ppReadable e)) canLiftCond'_List :: M.Map Int Bool -> [HExpr] -> (Bool, M.Map Int Bool) canLiftCond'_List m es = let fn e (b, accum_m) = if b then canLiftCond' accum_m e else (b, accum_m) in foldr fn (True, m) es ----------------------------------------------------------------------------- -- Test if a type is allowed in the residual program. isPrimType :: IType -> Bool -- Primitive interfaces isPrimType (ITCon _ _ (TIstruct SInterface{} _)) = True -- Primitive base types isPrimType (ITCon i _ _) = i == idPrimAction || -- types allowed as module parameters -- and foreign function arguments i == idString || i == idReal || -- we could support Integer in some contexts -- but choose not to -- i == idInteger i == idFmt || -- also not really a primitive i == idClock || i == idReset -- Primitive constructor applied to numeric type(s) isPrimType (ITAp a t) | iGetKind t == Just IKNum = isPrimTAp a -- Primitive arrays isPrimType (ITAp (ITCon i _ _) elem_ty) | i == idPrimArray = isPrimType elem_ty isPrimType _ = False -- Primitive type applications isPrimTAp :: IType -> Bool isPrimTAp (ITCon _ _ (TIstruct SInterface{} _)) = True isPrimTAp (ITCon i _ _) = i == idActionValue_ || i == idBit || i == idInout_ isPrimTAp (ITAp a t) | iGetKind t == Just IKNum = isPrimTAp a isPrimTAp _ = False isParamOnlyType :: IType -> Bool isParamOnlyType t = t == itString || t == itReal ----------------------------------------------------------------------------- type NameInfo = Maybe Id legalizeNameInfo :: NameInfo -> NameInfo legalizeNameInfo = liftM filterId where legalChar c = (isAlphaNum c) || (c == '_') filterId i = let b = filterFString legalChar (getIdBase i) q = filterFString legalChar (getIdQual i) in setIdBase (setIdQual i q) b type HeapPointer = Int -- type Heap s = STArray s HeapPointer (Maybe HeapCell) -- immutable heap used at the end of evaluation -- type IHeap = Array HeapPointer (Maybe HeapCell) data HeapCell = HUnev { hc_hexpr :: HExpr, hc_name :: NameInfo } | HWHNF { hc_pexpr :: PExpr, hc_name :: NameInfo } | HNF { hc_pexpr :: PExpr, hc_wire_set :: HWireSet, hc_name :: NameInfo } | HLoop { hc_name :: NameInfo } deriving (Show, Eq, Ord, Generic.Data, Generic.Typeable) -- should I drop the predicate for better printing of error messages? heapCellToHExpr :: HeapCell -> HExpr heapCellToHExpr (HUnev { hc_hexpr = e }) = e -- heapCellToHExpr (Harray { hc_hexpr = e }) = e heapCellToHExpr (HWHNF { hc_pexpr = p }) = (pExprToHExpr p) heapCellToHExpr (HNF { hc_pexpr = p }) = (pExprToHExpr p) heapCellToHExpr (HLoop mn) = internalError ("heapCellToHExpr.HLoop: " ++ ppReadable mn) heapCellToPExpr :: HeapCell -> PExpr heapCellToPExpr (HWHNF { hc_pexpr = p }) = p heapCellToPExpr (HNF { hc_pexpr = p }) = p heapCellToPExpr (HUnev { hc_hexpr = e }) = internalError("heapCellToPExpr.HUnev: " ++ ppReadable e) heapCellToPExpr (HLoop mn) = internalError ("heapCellToPExpr.HLoop: " ++ ppReadable mn) instance PPrint HeapCell where pPrint d p (HUnev { hc_hexpr = e, hc_name = name}) = text "HUnev" <+> pPrint d p e <+> pPrint d 0 name -- pPrint d p (Harray { hc_hexpr = e, hc_name = name}) = -- text "Harray" <+> pPrint d p e <+> pPrint d 0 name pPrint d p (HWHNF { hc_pexpr = e, hc_name = name}) = text "HWHNF" <+> pPrint d p e <+> pPrint d 0 name pPrint d p (HNF { hc_pexpr = e, hc_name = name, hc_wire_set = ws}) = text "HNF" <+> pPrint d p e <+> pPrint d 0 name <+> pPrint d 0 ws pPrint d p (HLoop name) = text "HLoop" <+> pPrint d 0 name newtype HeapData = HeapData (IORef (HeapCell)) deriving (Generic.Data, Generic.Typeable) {- instance Eq HeapData where (==) a b = True instance Ord HeapData where compare a b = EQ -} instance Show HeapData where show hd = "" {- instance PPrint HeapData where pPrint d p hd = text (show hd) -} instance Hyper HeapData where hyper (HeapData r) y = seq r y -- Heap expressions are IExprs with the real heap reference type filled in type HExpr = IExpr HeapData -- other useful synonyms type HClock = IClock HeapData type HReset = IReset HeapData type HInout = IInout HeapData type HStateVar = IStateVar HeapData type HRules = IRules HeapData type HWireSet = IWireSet HeapData type HRule = IRule HeapData type HDef = IDef HeapData type HEFace = IEFace HeapData type RulesBlobs = [(Bool, (HClock, HReset), IStateLoc, HPred, HExpr)] -- G is the main evaluator monad -- a writer monad for expanding rules lazily (for PrimModuleFix) -- it has a state monad (for result state) -- layered on top of IO for IORefs and errors/warnings/progress messages type G = StateT GState IO -- only used for post-evaluation heap traversals -- so unsafePerformIO is fine (the refs are no longer being modified) unsafeDerefHeap :: HeapData -> HeapCell unsafeDerefHeap (HeapData ref) = unsafePerformIO (readIORef ref) -- read-only evaluator state data GStateRO = GStateRO { errHandle :: !ErrorHandle, symtab :: !SymTab, -- lazy because computing the defenv may be expensive and (often) unnecessary defenv :: M.Map Id HExpr, checkMaxStep :: !Bool, maxStep :: !Integer, stepWarnInterval :: !Integer, flags :: !Flags } -- full evaluator state data GState = GState { stepNo :: !Integer, -- evaluation step nextWarnStep :: !Integer, -- next step to issue an evaluation warning at profilingMap :: !(M.Map Id (M.Map Position Int)), -- map from definitions to number of entries for profiling stateNo :: !Int, -- unique number for state variables -- Stores the pair "(x, next unique number to start with)". -- When "x" is instantiated a second time, to be named "x_1", -- we update the map to contain both "(x, 2)" and "(x_1, 1)". stateNameMap :: !(M.Map Id Int), -- Track names used within hierarchy for unquification of name of instances & loops stateLocMap :: !StateLocMap, -- comments on submodule instances -- mapping an instance name to its user-added comments -- XXX we use Id, just to have a position around; String would do commentsMap :: !(M.Map Id [String]), ffcallNo :: !Int, -- to generate unique names for ActionValue foreign function calls newClockId :: !ClockId, -- to generate unique ids for clocks newClockDomain :: !ClockDomain, -- to generate unique ids for clock families newResetId :: !ResetId, -- to generate unique ids for resets hp :: !HeapPointer, -- next unique id for a new heap reference -- This is a cache for "extractWires", so that it doesn't re-walk a -- a heap reference that we've already walked. -- XXX this could be stored in the heap cells? heapWires :: !(M.Map HeapPointer HWireSet), -- XXX what is the Id? flattened name? vars :: [(Id, HStateVar)], -- instantiated verilog modules portTypeMap :: PortTypeMap, -- map of state var -> port -> type rules :: HRules, -- accumulated rules newRuleSuffix :: Integer, -- store for creating unique names when ruleNameCheck is off -- scope for scheduling attribute names schedNameScope :: SchedNameScope, clock_domains :: !(M.Map ClockDomain [HClock]), -- all clock objects all_resets :: [HReset], -- all reset objects in_clock_info :: [(HClock, InputClockInf)], -- input clock information out_clock_info :: [(HClock, OutputClockInf)], -- output clock information in_reset_info :: [(HReset, ResetInf)], -- input reset information out_reset_info :: [(HReset, ResetInf)], -- output reset information ro :: !GStateRO, -- read-only state -- properties of the top-level def being compiled -- (these three fields could be in GStateRO, except that "pragmas" -- gets set when evaluating "primBuildModule" and we may eventually -- structure the evaluator to operate on multiple modules) mod_def_id :: Id, -- is the evaluation a no-lined function noinlined_func :: Bool, -- the pragmas for the top-level module pragmas :: [PProp], -- record when the gate of a clock is used used_clk_gates :: !(S.Set HClock), clk_gates_inhigh :: !(S.Set HClock), -- record when an input reset is used with a particular clock domain in_reset_clk_info :: !(M.Map HReset ClockDomain), -- map from clockdomain to the ids of boundary clocks in the domain -- (constructed after all input and output clocks are added) domain_to_boundary_id_map :: !(M.Map ClockDomain [Id]), -- map of clock ancestry relationships -- entries are parent -> list of children clk_ancestry_map :: !(M.Map HClock [HClock]), -- the clock/reset for input ports port_wires :: !(M.Map Id (HClock, HReset)), -- record whether the design is specific to a backend backend_specific :: !Bool, -- cache partially-evaluated top-level definitions defCache :: !(M.Map Id HExpr), -- used for moduleFix savedRules :: !RulesBlobs, -- whether a deferable error was reported badEvaluation :: !Bool, -- aggressive conditions aggressive_cond :: Bool } initGState :: ErrorHandle -> Flags -> SymTab -> M.Map Id HExpr -> Id -> Bool -> [PProp] -> GState initGState errh flags symt alldefs defId is_noinlined_func pps = let gsro = GStateRO { errHandle = errh, symtab = symt, checkMaxStep = redStepsMaxIntervals flags /= 0, maxStep = redSteps flags, stepWarnInterval = redStepsWarnInterval flags, flags = flags, defenv = alldefs } gs = GState { stepNo = 0, nextWarnStep = redStepsWarnInterval flags, stateNo = 0, stateNameMap = M.empty, stateLocMap = M.empty, commentsMap = M.empty, ffcallNo = 0, newClockId = initClockId, newClockDomain = initClockDomain, newResetId = initResetId, hp = 0, heapWires = M.empty, vars = [], portTypeMap = M.empty, rules = iREmpty, newRuleSuffix = 0, schedNameScope = emptySchedNameScope, profilingMap = M.empty, clock_domains = M.empty, all_resets = [], in_clock_info = [], out_clock_info = [], in_reset_info = [], out_reset_info = [], ro = gsro, mod_def_id = -- convert the raw defId to the user-recognizable Id setIdBaseString defId (init (getIdBaseString defId)), noinlined_func = is_noinlined_func, pragmas = pps, used_clk_gates = S.empty, clk_gates_inhigh = S.empty, in_reset_clk_info = M.empty, domain_to_boundary_id_map = M.empty, clk_ancestry_map = M.empty, port_wires = M.empty, backend_specific = False, defCache = M.empty, savedRules = [], badEvaluation = False, aggressive_cond = aggImpConds flags } in gs data GOutput a = GOutput { go_clock_domains :: [(ClockDomain, [HClock])], go_resets :: [HReset], go_state_vars :: [(Id, HStateVar)], go_port_types :: PortTypeMap, go_vclockinfo :: VClockInfo, go_vresetinfo :: VResetInfo, go_rules :: HRules, go_steps :: Integer, go_hp :: HeapPointer, go_profile :: M.Map Id (M.Map Position Int), go_comments_map :: [(Id,[String])], go_backend_specific :: Bool, go_ffcallNo :: Int, goutput :: a } runG :: ErrorHandle -> Flags -> SymTab -> M.Map Id HExpr -> Id -> Bool -> [PProp] -> G a -> IO (GOutput a) runG errh flags symt alldefs defId is_noinlined_func pps gFn = do let gs = initGState errh flags symt alldefs defId is_noinlined_func pps (retval, gs') <- runStateT gFn gs -- convert the relevant info in the final GState into the GOutput do -- if any file handles were not closed, close them now closeOpenHandles errh -- this can produce warnings vresetinfo <- make_vresetinfo errh (in_reset_info gs') (out_reset_info gs') (in_reset_clk_info gs') (domain_to_boundary_id_map gs') let vclockinfo = make_vclockinfo (clk_gates_inhigh gs') (in_clock_info gs') (out_clock_info gs') (domain_to_boundary_id_map gs') (clk_ancestry_map gs') -- check that any gates marked as unused are not in the inhigh -- list (which accumulates gate uses) let should_be_unused = concat [ is | PPgate_unused is <- pps ] getClk hclk = do c <- lookup hclk (in_clock_info gs') return (fst c) actually_used = mapMaybe getClk (S.toList (clk_gates_inhigh gs')) wrong_annotations = should_be_unused `intersect` actually_used mk_annotation_msg i = (getPosition i, EClkGateNotUnused (getIdBaseString i)) when (not (null wrong_annotations)) $ bsError errh (map mk_annotation_msg wrong_annotations) -- if there were deferred errors, they were reported to IO, so exit when (badEvaluation gs') $ exitFail errh -- check that there is no fixed-point state that was left unhandled let rblobs = savedRules gs' when (not (null rblobs)) $ internalError ("IExpandUtils.runG - unexpanded ruleblobs: " ++ ppReadable rblobs) return $ (GOutput { go_clock_domains = (M.toList (clock_domains gs')), go_resets = (all_resets gs'), go_state_vars = reverse (vars gs'), go_port_types = portTypeMap gs', go_vclockinfo = vclockinfo, go_vresetinfo = vresetinfo, go_rules = rules gs', go_steps = stepNo gs', go_hp = hp gs', go_profile = profilingMap gs', go_comments_map = M.toList (commentsMap gs'), go_backend_specific = backend_specific gs', go_ffcallNo = ffcallNo gs', goutput = retval }) errG :: EMsg -> G a errG emsg = errsG [emsg] errsG :: [EMsg] -> G a errsG emsgs = do errh <- getErrHandle ctx <- getElabProgressContext liftIO $ bsErrorWithContext errh ctx emsgs -- report evaluation problems -- defer exit until the end of evaluation -- if there are no errors, this is a no-op deferErrors :: [EMsg] -> G () deferErrors emsgs = when (not (null emsgs)) $ do s <- get put s { badEvaluation = True } let errh = errHandle (ro s) ctx <- getElabProgressContext liftIO $ bsErrorWithContextNoExit errh ctx emsgs eWarning :: EMsg -> G () eWarning emsg = eWarnings [emsg] eWarnings :: [EMsg] -> G () eWarnings emsgs = do errh <- getErrHandle ctx <- getElabProgressContext liftIO $ bsWarningWithContext errh ctx emsgs -- compile-time expression failed to evaluate error utility eNoNF :: HExpr -> G a eNoNF e = let ty = iGetType e pos = getIExprPosition e in errG (pos, ENoNF (ppString ty) (ppReadable e)) -- in errG (pos, ENoNF (ppString ty) (show e)) -- depends on the invariant that -- max steps is a multiple of stepWarnInterval (enforced by Flags) -- and that stepWarnInterval > 0 step :: Id -> G () step i = do s <- get -- do common update let c = stepNo s let s' = s { stepNo = c + 1 } if (doProfile) then do let prof = profilingMap s let pos_map = M.singleton (getPosition i) 1 let prof' = M.insertWith (M.unionWith (+)) i pos_map prof put (s' { profilingMap = prof' }) else put s' let w = nextWarnStep s when (c == w) $ do let check = checkMaxStep (ro s) let m = maxStep (ro s) -- can only hit the max step if we would issue a warning if (check && c == m) then errG (getIdPosition i, ETooManySteps (pfpString i) (itos m)) else do let w_i = stepWarnInterval (ro s) let w' = w + w_i when (badEvaluation s) $ errG (getIdPosition i, EStepsIntervalError (pfpString i) c w_i) eWarning (getIdPosition i, WTooManySteps (pfpString i) c w' m) s' <- get when doProfile $ liftIO (putStrLn (ppReadable (profilingMap s'))) put s' { nextWarnStep = w' } -- --------------- addRules :: HRules -> G () addRules rs = do s <- get --traceM("AddRules: " ++ ppReadable rs) let curScope = schedNameScope s (curFrame, frames) = case curScope of (f:fs) -> (f, fs) _ -> internalError ("addRules: curFrame") cur_ns = snf_istateloc curFrame cur_cnt = snf_ignoreCount curFrame cur_nameMap = snf_nameMap curFrame -- we should not be in a rule/interface scope when (isJust (snf_elabProgress curFrame)) $ internalError ("IExpandUtils.addRules: invalid elabProgress") flags <- getFlags suf <- getNewRuleSuffix -- this is like iRUnion, but with different attribute checking let cur_rules@(IRules sps1 rs1) = (rules s) (suf', rs') = uniquifyRules flags suf cur_rules rs updNewRuleSuffix suf' -- check the names in attributes of the new rules -- (any errors are deferred and it returns the rules without bad Ids) rs''@(IRules sps2 rs2) <- checkAddRulesAttributes cur_ns cur_nameMap rs' -- add the new rule names to the scope -- XXX The IRule should contain the right name to start with -- XXX rather than using remIStateLocPrefix (like popModuleSchedNameScope) let addFn (IRule { irule_name = rId } ) = (remIStateLocPrefix cur_ns rId, SNI_Rule rId) new_map_entries = map addFn rs2 -- there should be no conflicts, when using remIStateLocPrefix conflictFn v1 v2 = internalError ("addRules: conflict: " ++ ppReadable (v1,v2)) cur_nameMap' = map_insertManyWith conflictFn new_map_entries cur_nameMap curFrame' = SchedNameFrame cur_ns cur_cnt cur_nameMap' Nothing newScope = (curFrame' : frames) --traceM("ADD: rs2 = " ++ ppReadable rs2) --traceM("ADD: new_map_entries = " ++ ppReadable new_map_entries) --traceM("ADD: map = " ++ ppReadable cur_nameMap') s <- get put (s { schedNameScope = newScope }) -- add the rules themselves to the monad s <- get let new_rules = -- As the size of rs1 grows, it's more efficient to add to the front -- XXX We should consider a better data structure if (ruleNameCheck flags) then (IRules (sps1 ++ sps2) (rs1 ++ rs2)) else (IRules (sps2 ++ sps1) (rs2 ++ rs1)) put (s { rules = new_rules } ) checkAddRulesAttributes :: IStateLoc -> M.Map Id SchedNameInfo -> IRules a -> G (IRules a) checkAddRulesAttributes cur_ns idMap (IRules sps rs) = let mkErr i = (getIdPosition i, EUnknownRuleIdAttribute (pfpString i)) mkWarn i = (getIdPosition i, WInlinedMethodIdAttribute (pfpString i)) -- the rule Ids will be the global names (w/ hier and uniquified), -- the attributes on those rules will also have hierarchy prefixed -- to them, so we need to strip that off when checking for names -- in the scope. (For names in "rs", use the global name, because -- "sps" will have been adjusted for uniquifiers in sync with "rs".) -- names of the rules being added (global names) definedIds = S.fromList $ map getIRuleId rs -- this folds over the attr names checkFn i accum@(accum_warns, accum_errs, accum_badIds) = if (S.member i definedIds) then accum else -- remove the hierarchy prefix let i' = remIStateLocPrefix cur_ns i in case (M.lookup i' idMap) of Nothing -> (accum_warns, ((mkErr i'):accum_errs), (i:accum_badIds)) Just (SNI_Method False) -> (((mkWarn i'):accum_warns), accum_errs, (i:accum_badIds)) Just _ -> accum attrIds = extractSchedPragmaIds sps (warns, errs, badIds) = foldr checkFn ([], [], []) attrIds sps' = if (null badIds) then sps else removeSchedPragmaIds badIds sps in do --traceM("checkAddRules Attr: " ++ ppReadable (cur_ns, sps, rs)) when (not (null warns)) $ eWarnings warns deferErrors errs --traceM("definedIds: " ++ ppReadable definedIds) --traceM("attrIds: " ++ ppReadable attrIds) return (IRules sps' rs) -- --------------- -- XXX Consider unifying the IStateLoc stack with this stack -- XXX We also use this stack to keep track of elab progress, so -- XXX consider giving it a better name (it's not just the schedname scope) -- the lookup result for names in the current context data SchedNameInfo = -- Method Name -- The Bool indicates whether it is at a synthesized boundary -- (if False, it is inlined, and we don't support references to -- inlined boundaries yet, so warn and ignore). -- If a rule is later added with the same name, warn about the -- name clash and have the rule shadow the method. SNI_Method Bool | -- Rule Name -- The Id is the qualified, uniquified name for the rule -- (its global name). This is substituted into attributes in -- place of the name as it is visible in the attribute's scope. SNI_Rule Id deriving (Show, Eq, Ord) instance PPrint SchedNameInfo where pPrint d p sni = text (show sni) data SchedNameFrame = SchedNameFrame { -- hierarchy naming for this scope snf_istateloc :: IStateLoc, -- number of ignored levels that have been pushed -- (the number of pops remaining until this frame can be popped) -- (this is to avoid duplicating frames) snf_ignoreCount :: Integer, -- names available at this scope -- (populated by the parent, if any names remain visible, -- then with new names as they are added in the current scope) snf_nameMap :: M.Map Id SchedNameInfo, -- whether we are currently evaluating inside a rule/ifc; -- this should be Nothing when pushing/popping a frame snf_elabProgress :: Maybe ElabProgress } deriving (Show, Eq) instance PPrint SchedNameFrame where pPrint d p snf = (text "SchedNameFrame" <+> pPrint d p ig <+> pPrint d p ns <+> pPrint d p ep) $$ pPrint d p m where ig = snf_ignoreCount snf ns = snf_istateloc snf m = M.toList $ snf_nameMap snf ep = snf_elabProgress snf data ElabProgress = EPRule Id {- rule name/position -} Bool {- has the "hide" property -} (Maybe RuleElabProgress) {- progress inside the rule -} | -- This should only occur at the top-level EPInterface (Maybe IfcElabProgress) {- progress inside the ifc -} deriving (Show, Eq) instance PPrint ElabProgress where pPrint d p (EPRule i h rp) = pparen (p>0) $ text "Rule" <+> pPrint d 0 i <+> pPrint d 0 h <+> pPrint d 0 rp pPrint d p (EPInterface ip) = pparen (p>0) $ text "Interface" <+> pPrint d 0 ip data RuleElabProgress = REP_ExplicitCond | REP_Body | REP_ImplicitCond deriving (Show, Eq) instance PPrint RuleElabProgress where pPrint d p (REP_ExplicitCond) = text "ExplicitCond" pPrint d p (REP_Body) = text "Body" pPrint d p (REP_ImplicitCond) = text "ImplicitCond" data IfcElabProgress = IEP_OutputClock Id | IEP_OutputReset Id | IEP_OutputInout Id | IEP_Method Id Bool {- MethodElabProgress -} deriving (Show, Eq) instance PPrint IfcElabProgress where pPrint d p (IEP_OutputClock i) = pparen (p > 0) $ text "OutputClock" <+> pPrint d 0 i pPrint d p (IEP_OutputReset i) = pparen (p > 0) $ text "OutputReset" <+> pPrint d 0 i pPrint d p (IEP_OutputInout i) = pparen (p > 0) $ text "OutputInout" <+> pPrint d 0 i pPrint d p (IEP_Method i mp) = pparen (p > 0) $ text "Method" <+> pPrint d 0 i <+> pPrint d 0 mp type SchedNameScope = [SchedNameFrame] emptySchedNameScope :: SchedNameScope emptySchedNameScope = [] incrSNFIgnoreCount :: SchedNameScope -> SchedNameScope -- There should be a frame and it should not be in rule/ifc progress incrSNFIgnoreCount (SchedNameFrame ns cnt nameMap Nothing : frames) = (SchedNameFrame ns (cnt + 1) nameMap Nothing : frames) incrSNFIgnoreCount _ = internalError ("incrSNFIgnoreCount") -- create the initial scope, in which only the top methods are visible pushTopModuleSchedNameScope :: IType -> G () pushTopModuleSchedNameScope t = do symt <- getSymTab let ifcName = iGetIfcName $ iGetModIfcType t methNames = getIfcFlatMethodNames symt ifcName -- use True to indicate that these are top-level methods newNameMap = M.fromList [ (m, SNI_Method True) | m <- methNames ] newFrame = SchedNameFrame [] 0 newNameMap Nothing s <- get let -- the old scope should be empty, so ignore it newScope = [newFrame] put (s { schedNameScope = newScope }) -- When entering an inlined submodule, nothing from the parent is visible, -- only the methods in the submodule's interface. -- However, if this is an "ignore" level, then it's an internal BSC boundary -- that the user should not be aware of, so it retains the parent visibility -- (this handles the function "addRules" used internally by the compiler to -- add user rules). -- XXX If the user explicitly calls "addRules", we allow visibility to the -- XXX parent, for backwards compatibility. -- pushModuleSchedNameScope :: IStateLoc -> IType -> G () pushModuleSchedNameScope ns resTy = do symt <- getSymTab s <- get let oldScope = schedNameScope s let -- XXX For backwards compatibility, allow visibility in addRules. -- XXX For for-loops, we should create a new context and allow -- XXX indexing of iterations ign = (hasIgnore ns) || (isAddRules ns) || (isLoop ns) mIfcName = iMGetIfcName resTy methNames = case mIfcName of Nothing -> [] Just ifcName -> getIfcFlatMethodNames symt ifcName newNameMap = M.fromList [ (m, SNI_Method False) | m <- methNames ] newFrame = SchedNameFrame ns 0 newNameMap Nothing -- if this is an "ignore" level, just update the old scope newScope = if ign then incrSNFIgnoreCount oldScope else (newFrame:oldScope) --traceM("PUSH: " ++ (ppReadable ((toTF ign, toTF (hasIgnore ns)), head newScope))) --traceM("PUSH: " ++ ppReadable (M.toList (snf_nameMap (head newScope)))) put (s { schedNameScope = newScope }) pushRuleSchedNameScope :: Id -> Bool -> G () pushRuleSchedNameScope i hide = do s <- get let oldScope = schedNameScope s case oldScope of (curFrame@(SchedNameFrame { snf_elabProgress = Nothing }) : frames) -> do let newElabProgress = EPRule i hide Nothing newFrame = curFrame { snf_elabProgress = Just newElabProgress } newScope = (newFrame : frames) put (s { schedNameScope = newScope }) _ -> internalError ("pushRuleSchedNameScope: " ++ ppReadable oldScope) popRuleSchedNameScope :: G () popRuleSchedNameScope = do s <- get let oldScope = schedNameScope s case oldScope of (curFrame@(SchedNameFrame { snf_elabProgress = Just (EPRule {}) }) : frames) -> do let newFrame = curFrame { snf_elabProgress = Nothing } newScope = (newFrame : frames) put (s { schedNameScope = newScope }) _ -> internalError ("popRuleSchedNameScope: " ++ ppReadable oldScope) setRuleSchedNameScopeProgress :: Maybe RuleElabProgress -> G () setRuleSchedNameScopeProgress mp = do s <- get let oldScope = schedNameScope s case oldScope of (curFrame@(SchedNameFrame { snf_elabProgress = Just (EPRule i h _) }) : frames) -> do let newFrame = curFrame { snf_elabProgress = Just (EPRule i h mp) } newScope = (newFrame : frames) put (s { schedNameScope = newScope }) _ -> internalError ("setRuleSchedNameScopeProgress: " ++ ppReadable oldScope) pushIfcSchedNameScope :: G () pushIfcSchedNameScope = do s <- get let oldScope = schedNameScope s case oldScope of (curFrame@(SchedNameFrame { snf_elabProgress = Nothing }) : frames) -> do let newElabProgress = EPInterface Nothing newFrame = curFrame { snf_elabProgress = Just newElabProgress } newScope = (newFrame : frames) put (s { schedNameScope = newScope }) _ -> internalError ("pushIfcSchedNameScope: " ++ ppReadable oldScope) popIfcSchedNameScope :: G () popIfcSchedNameScope = do s <- get let oldScope = schedNameScope s case oldScope of (curFrame@(SchedNameFrame { snf_elabProgress = Just (EPInterface {}) }) : frames) -> do let newFrame = curFrame { snf_elabProgress = Nothing } newScope = (newFrame : frames) put (s { schedNameScope = newScope }) _ -> internalError ("popIfcSchedNameScope: " ++ ppReadable oldScope) setIfcSchedNameScopeProgress :: Maybe IfcElabProgress -> G () setIfcSchedNameScopeProgress mp = do s <- get let oldScope = schedNameScope s case oldScope of (curFrame@(SchedNameFrame { snf_elabProgress = Just (EPInterface _) }) : frames) -> do let newFrame = curFrame { snf_elabProgress = Just (EPInterface mp) } newScope = (newFrame : frames) put (s { schedNameScope = newScope }) _ -> internalError ("setIfcSchedNameScopeProgress: " ++ ppReadable oldScope) -- when exiting a submodule, put all the added rules from that scope -- into the parent scope (adding the submodule qualifier, but making -- sure that the names are still uniquified) -- -- For backwards compatibility, we want uniquification to give the same -- name at the top-level as it did before (uniquify in the order of eval). -- The way we should add child rules to a parent is by prefixing the child -- inst name to the child's rule names and then doing a new uniquify step -- as if we were adding those rules with only the parent rules visible -- (not with any rules above the parent). That's because a module should -- not have visibility into rules in the parent: a module should not have to -- mysteriously refer to a rule "r_1" because a parent had a rule with the -- same name. -- XXX For now, we have that visibility; we need to clean this up. -- popModuleSchedNameScope :: G () popModuleSchedNameScope = do s <- get let oldScope = schedNameScope s --traceM("POP: oldScope: " ++ ppReadable (head oldScope)) case oldScope of -- when there are ignored levels to pop -- (and assert that the frame is not in rule/ifc progress) (SchedNameFrame ns cnt nameMap Nothing : frames) | (cnt > 0) -> do let newScope = (SchedNameFrame ns (cnt - 1) nameMap Nothing : frames) put (s { schedNameScope = newScope }) -- otherwise, merge the current frame into its parent -- (and assert that neither frame is in rule/ifc progress) -- (actually, because of "primBuildModule", the parent could be in a rule) (curFrame : parentFrame : frames) | isNothing (snf_elabProgress curFrame) -- && isNothing (snf_elabProgress parentFrame) -> do let (SchedNameFrame _ _ cur_nameMap _) = curFrame -- preserve the parent's rule progress, b/c of "primBuildModule" (SchedNameFrame parent_ns parent_cnt parent_nameMap parent_ep) = parentFrame -- function to qualify cur names -- XXX This is what needs updating, to re-uniquify names rem_prefix = remIStateLocPrefix parent_ns -- remove method names while updating the rule names -- XXX the use of remIStateLocPrefix is what needs updating, -- XXX to re-uniquify names instead mkParentPair (i, SNI_Method {}) = Nothing mkParentPair (i, SNI_Rule ui) = Just (rem_prefix ui, SNI_Rule ui) -- update the parent frame new_map_entries = mapMaybe mkParentPair (M.toList cur_nameMap) -- there should not be conflicts -- XXX ignored levels can have conflicts when we try add to add -- XXX what was copied from the parent; this might argue for -- XXX keeping a separate list of just the new rules -- XXX (then we wouldn't do the filtering of methods, above) conflictFn v1 v2 | (v1 == v2) = v1 conflictFn v1 v2 = internalError ("popModuleSchedNameScope: conflict: " ++ ppReadable (v1,v2)) parent_nameMap' = map_insertManyWith conflictFn new_map_entries parent_nameMap parentFrame' = SchedNameFrame parent_ns parent_cnt parent_nameMap' parent_ep newScope = (parentFrame' : frames) --traceM("POP: add " ++ ppReadable (M.toList cur_nameMap)) --traceM("POP: new " ++ ppReadable (M.toList parent_nameMap')) put (s { schedNameScope = newScope }) _ -> internalError ("popModuleSchedNameScope: " ++ ppReadable oldScope) -- XXX Functions to push and pop scope for for-loops? remIStateLocPrefix :: IStateLoc -> Id -> Id remIStateLocPrefix ns i = let prefix = getIdBaseString $ stateLocToPrefix ns i_str = getIdBaseString i rem [] cs = cs rem (p:ps) (c:cs) | (p == c) = rem ps cs rem _ _ = internalError ("remIStateLocPrefix: " ++ ppReadable (ns, (stateLocToPrefix ns, i))) in setIdBaseString i (rem prefix i_str) -- --------------- addSubmodComments :: Id -> [String] -> G () addSubmodComments name [] = return () addSubmodComments name comments = do s <- get let oldmap = commentsMap s let newmap = M.insert name comments oldmap put (s { commentsMap = newmap }) {- -- This code would be used if we wanted to remove entries from the table, -- and attach comments directly to the IStateVar/AVInst. -- Instead, we keep the entire table around in IModule. getSubmodComments :: Id -> G (Maybe [String]) getSubmodComments name = do s <- get let cmap = commentsMap s case (M.lookup name cmap) of Nothing -> -- no comments for this submodule return Nothing Just comments -> do -- remove the comments from the map let newcmap = M.delete name cmap put (s { commentsMap = newcmap }) return (Just comments) -} -- --------------- addPort :: Id -> HClock -> HReset -> G () addPort port_id hclk hrst = do s <- get let cmap = port_wires s cmap' = M.insert port_id (hclk, hrst) cmap put s { port_wires = cmap' } getPortWires :: Id -> G HWireSet getPortWires port_id = do s <- get let cmap = port_wires s case (M.lookup port_id cmap) of Nothing -> return $ wsEmpty Just (hclk, hrst) -> return $ wsJoin (wsClock hclk) (wsReset hrst) savePortType :: Maybe Id -> VName -> IType -> G () savePortType minst port t = do when doTracePortTypes $ traceM ("savePortType " ++ ppString minst ++ "$" ++ ppString port ++ ": " ++ ppReadable t) s <- get let old_map = portTypeMap s let new_map = M.insertWith (flip M.union) minst (M.singleton port t) old_map put s { portTypeMap = new_map } saveTopModPortType :: VName -> IType -> G () saveTopModPortType port t = savePortType Nothing port t -- --------------- saveRules :: (HClock, HReset) -> IStateLoc -> HPred -> HExpr -> G () saveRules curClkRstn ns p rs = do s <- get let agg = aggressive_cond s put (s { savedRules = (agg, curClkRstn, ns, p, rs) : savedRules s }) getSavedRules :: G RulesBlobs getSavedRules = get >>= (return . savedRules) clearSavedRules :: G () clearSavedRules = do s <- get put (s { savedRules = [] }) replaceSavedRules :: RulesBlobs -> G () replaceSavedRules blobs = do s <- get put (s { savedRules = blobs }) -- XXX where does this belong? getInoutWires :: IInout a -> IWireSet a getInoutWires inout = let hclk = getInoutClock inout hrst = getInoutReset inout in wsAddReset hrst (wsClock hclk) -- --------------- setBackendSpecific :: G () setBackendSpecific = do s <- get put s { backend_specific = True } -- --------------- -- XXX check duplication of clock object -- add a clock to the clock domain map for tracking addClock :: HClock -> G () addClock c = do s <- get put s { clock_domains = M.insertWith (++) (getClockDomain c) [c] (clock_domains s) } assertNoClkGateUses :: G () assertNoClkGateUses = do s <- get let gs = used_clk_gates s when (not (S.null gs)) $ internalError ("unexpected unresolved clock gate uses") -- get,set, clear primitives to manage clock gate uses around primBuildModule getClkGateUses :: G (S.Set HClock) getClkGateUses = get >>= (return . used_clk_gates) clearClkGateUses :: G () clearClkGateUses = do s <- get put (s { used_clk_gates = S.empty }) setClkGateUses :: S.Set HClock -> G () setClkGateUses uses = do -- only reasonable to do if the use set is empty assertNoClkGateUses s <- get put (s { used_clk_gates = uses }) addClkGateUse :: HClock -> G () addClkGateUse c = do s <- get --traceM ("adding gate use = " ++ ppReadable c) put s { used_clk_gates = S.insert c (used_clk_gates s) } addInhighClkGate :: HClock -> G () addInhighClkGate c = -- try to only add clocks which are input clocks case (getClockWires c) of -- It's a clock tuple of a module port for the oscillator and gate == 1 IAps (ICon i (ICTuple {fieldIds = [i_osc, i_gate]})) [] [osc@(ICon _ (ICModPort _)), gate] | i == idClock && i_osc == idClockOsc && i_gate == idClockGate && isTrue gate -> do -- traceM ("is a boundary clock: " ++ ppReadable c) s <- get let old_set = clk_gates_inhigh s put s { clk_gates_inhigh = S.insert c old_set } _ -> do -- traceM ("not a boundary clock: " ++ ppReadable c) return () addGateUsesToInhigh :: G () addGateUsesToInhigh = do s <- get let gs = used_clk_gates s mapM_ addInhighClkGate (S.toList gs) s <- get put s { used_clk_gates = S.empty } addGateInhighAttributes :: G() addGateInhighAttributes = do s <- get pps <- getPragmas let inhigh_ids = concat [ is | PPgate_inhigh is <- pps ] inhigh_clocks = [ hc | (hc,(i,_)) <- in_clock_info s , i `elem` inhigh_ids ] mapM_ addInhighClkGate inhigh_clocks return () -- XXX check duplication of name / wires / clock object addInputClock :: HClock -> InputClockInf -> G () addInputClock clk ci = do s <- get let old_in_clock_info = in_clock_info s when doTraceClock $ traceM ("addInputClock: " ++ ppReadable (clk, getClockDomain clk, ci)) put (s { in_clock_info = (clk, ci):old_in_clock_info}) -- XXX check duplication of name / wires / clock object addOutputClock :: HClock -> OutputClockInf -> G () addOutputClock clk ci = do s <- get let old_out_clock_info = out_clock_info s when doTraceClock $ traceM ("addOutputClock: " ++ ppReadable (clk, getClockDomain clk, ci)) put (s { out_clock_info = (clk, ci):old_out_clock_info}) getClockIds :: [(HClock, (Id, a))] -> [(HClock, Id)] getClockIds = map (\ (c,(i,_)) -> (c, i)) getHClocks :: [(HClock, a)] -> [HClock] getHClocks = map fst -- returns Nothing if not found (could make that an internalError) getBoundaryClock :: Id -> G (Maybe HClock) getBoundaryClock i = do s <- get let clk_ids = getClockIds (out_clock_info s) ++ getClockIds (in_clock_info s) return (listToMaybe [c | (c, i') <- clk_ids, i' == i]) boundaryClockToName :: HClock -> G (Maybe Id) boundaryClockToName c = do s <- get let clk_ids = getClockIds (out_clock_info s) ++ getClockIds (in_clock_info s) return (listToMaybe [i | (c', i) <- clk_ids, c == c']) getBoundaryClocks :: G [HClock] getBoundaryClocks = do s <- get let hclocks = getHClocks (out_clock_info s) ++ getHClocks (in_clock_info s) return hclocks -- XXX check duplication of reset object -- add a reset to the list of resets for tracking addReset :: HReset -> G () addReset r = do s <- get put s { all_resets = r : (all_resets s) } -- XXX check duplication of name / wires / reset object addInputReset :: HReset -> ResetInf -> G () addInputReset rst ri = do s <- get let old_in_reset_info = in_reset_info s put (s { in_reset_info = (rst, ri):old_in_reset_info }) -- XXX check duplication of name / wires / reset object addOutputReset :: HReset -> ResetInf -> G () addOutputReset rst ri = do s <- get let old_out_reset_info = out_reset_info s put (s { out_reset_info = (rst, ri):old_out_reset_info }) getResetIds :: [(HReset, (Id, a))] -> [(HReset, Id)] getResetIds = map (\ (r,(i,_)) -> (r, i)) getHResets :: [(HReset, a)] -> [HReset] getHResets = map fst getBoundaryReset :: Id -> G (Maybe HReset) getBoundaryReset i = do s <- get let rst_ids = getResetIds (out_reset_info s) ++ getResetIds (in_reset_info s) return (listToMaybe [r | (r, i') <- rst_ids, i' == i]) getBoundaryResets :: G [HReset] getBoundaryResets = do s <- get let hresets = getHResets (out_reset_info s) ++ getHResets (in_reset_info s) return hresets getInputResets :: G [HReset] getInputResets = do s <- get return (getHResets (in_reset_info s)) boundaryResetToName :: HReset -> G (Maybe Id) boundaryResetToName r = do s <- get let rst_ids = getResetIds (out_reset_info s) ++ getResetIds (in_reset_info s) return (listToMaybe [i | (r', i) <- rst_ids, r == r']) setInputResetClockDomain :: HReset -> ClockDomain -> G () setInputResetClockDomain r clkdom = do s <- get let rc_map = in_reset_clk_info s let new_rc_map = M.insert r clkdom rc_map put (s { in_reset_clk_info = new_rc_map }) getInputResetClockDomain :: HReset -> G (Maybe ClockDomain) getInputResetClockDomain r = do s <- get let rc_map = in_reset_clk_info s return (M.lookup r rc_map) -- --------------- maybeToPrefix :: Id -> Maybe String -> Id maybeToPrefix def_prefix Nothing = def_prefix maybeToPrefix _ (Just str) = mkId noPosition (mkFString str) findClockOscPrefix :: [PProp] -> Id findClockOscPrefix pps = maybeToPrefix idCLK $ listToMaybe [ s | (PPCLK s) <- pps ] findClockGatePrefix :: [PProp] -> Id findClockGatePrefix pps = maybeToPrefix idCLK_GATE $ listToMaybe [ s | (PPGATE s) <- pps ] findResetPortPrefix :: String -> [PProp] -> Id findResetPortPrefix defRstName pps = let idrst = (mk_no . mkFString) defRstName in maybeToPrefix idrst $ listToMaybe [ s | (PPRSTN s) <- pps ] findArgClockOscName :: [PProp] -> Id -> Maybe String findArgClockOscName pps i = listToMaybe $ catMaybes [ lookup i ps | (PPclock_osc ps) <- pps ] findArgClockGateName :: [PProp] -> Id -> Maybe String findArgClockGateName pps i = listToMaybe $ catMaybes [ lookup i ps | (PPclock_gate ps) <- pps ] findArgResetPortName :: [PProp] -> Id -> Maybe String findArgResetPortName pps i = listToMaybe $ catMaybes [ lookup i ps | (PPreset_port ps) <- pps ] findArgPortName :: [PProp] -> Id -> Maybe String findArgPortName pps i = listToMaybe $ catMaybes [ lookup i ps | (PParg_port ps) <- pps ] findArgParamName :: [PProp] -> Id -> Maybe String findArgParamName pps i = listToMaybe $ catMaybes [ lookup i ps | (PParg_param ps) <- pps ] -- --------------- -- function to make clock/reset port Ids, for input clock/reset makePrefixArgId :: Id -> Maybe String -> Id -> Id -> Id makePrefixArgId id_base m_rename def_id prefix = let pos = getPosition id_base -- use this name if there's no explicit name name0 = if (id_base == def_id) then prefix else mkUSId prefix id_base in case (m_rename) of Nothing -> name0 Just rename_str -> mkId pos (mkFString rename_str) makeArgClockOscId :: [PProp] -> Id -> Id makeArgClockOscId pps clk_id = let prefix = findClockOscPrefix pps m_rename = findArgClockOscName pps clk_id in makePrefixArgId clk_id m_rename idDefaultClock prefix makeArgClockGateId :: [PProp] -> Id -> Id makeArgClockGateId pps clk_id = let prefix = findClockGatePrefix pps m_rename = findArgClockGateName pps clk_id in makePrefixArgId clk_id m_rename idDefaultClock prefix -- combine into one function makeArgClockIds :: [PProp] -> Bool -> Id -> (Id, Maybe Id) makeArgClockIds pps gated id_clk = (id_osc, toMaybe gated id_gate) where id_osc = makeArgClockOscId pps id_clk id_gate = makeArgClockGateId pps id_clk makeArgResetPortId :: String -> [PProp] -> Id -> Id makeArgResetPortId defRstName pps rst_id = let prefix = findResetPortPrefix defRstName pps m_rename = findArgResetPortName pps rst_id in makePrefixArgId rst_id m_rename idDefaultReset prefix makeArgPortId :: [PProp] -> Id -> Id makeArgPortId pps arg_id = let m_rename = findArgPortName pps arg_id pos = getPosition arg_id in case (m_rename) of Nothing -> arg_id Just str -> mkId pos (mkFString str) makeArgParamId :: [PProp] -> Id -> Id makeArgParamId pps param_id = let m_rename = findArgParamName pps param_id pos = getPosition param_id in case (m_rename) of Nothing -> param_id Just str -> mkId pos (mkFString str) -- --------------- makeIfcClockOscId :: [PProp] -> Id -> Id -> Id makeIfcClockOscId pps clk_id rename_id = let prefix = findClockOscPrefix pps in -- setPosition not needed because the rename id already has the pos mkUSId prefix rename_id makeIfcClockGateId :: [PProp] -> Id -> Id -> Id makeIfcClockGateId pps clk_id rename_id = let prefix = findClockGatePrefix pps in -- setPosition not needed because the rename id already has the pos mkUSId prefix rename_id -- combine into one function makeIfcClockIds :: [PProp] -> Bool -> Id -> Id -> (Id, Maybe Id) makeIfcClockIds pps gated id_clk rename_id = (id_osc, toMaybe gated id_gate) where id_osc = makeIfcClockOscId pps id_clk rename_id id_gate = makeIfcClockGateId pps id_clk rename_id makeIfcResetPortId :: String -> [PProp] -> Id -> Id -> Id makeIfcResetPortId defRstName pps rst_id rename_id = let prefix = findResetPortPrefix defRstName pps in -- setPosition not needed because the rename id already has the pos mkUSId prefix rename_id makeIfcInoutPortId :: Id -> Id -> Id makeIfcInoutPortId inout_id rename_id = -- setPosition not needed because the rename id already has the pos rename_id -- --------------- -- Given a clock Id, make a clock, the abstract input, and the VArgInfo. -- (the default clock is assumed to be idDefaultClock) makeInputClk :: Bool -> Id -> G (HClock, IAbstractInput, VArgInfo) makeInputClk gated id_clk = do when doTraceClock $ traceM "makeInputClk\n" pps <- getPragmas let (id_osc, mid_gate) = makeArgClockIds pps gated id_clk let topClkOsc = ICon id_osc (ICModPort itBit1) let topClkGate = case mid_gate of Just id_gate -> ICon id_gate (ICModPort itBit1) Nothing -> iTrue let abs_input = IAI_Clock id_osc mid_gate let varginfo = ClockArg id_clk -- consult clock_family and clock_ancestors pragmas to determine -- if this input clock belongs in an existing family same_family_as <- findFamilyMember id_clk -- consult clock_ancestors pragmas to identify any relationships -- involving this clock ancestor_edges <- findParentsAndChildren id_clk clk <- newClock (makeClockWires topClkOsc topClkGate) same_family_as ancestor_edges let vp_osc = id_to_vName id_osc let vp_gate = case (mid_gate) of Nothing -> -- we assume the gate is unused, and adjust -- it later if it needs to be inhigh Left False Just id_gate -> Right (id_to_vName id_gate) addInputClock clk (id_clk, Just (vp_osc, vp_gate)) return (clk, abs_input, varginfo) makeOutputClk :: Bool -> Id -> Id -> HClock -> G VFieldInfo makeOutputClk gated id_clk port_id clk = do let gate_high = isTrue (getClockGate clk) when ((not gated) && (not gate_high)) $ errG (getPosition id_clk, EUnexpectedOutputClkGate (getIdString (unQualId id_clk))) -- XXX unQualId VModInfo pps <- getPragmas let (id_osc, mid_gate) = makeIfcClockIds pps gated (unQualId id_clk) port_id let vp_osc = id_to_vName id_osc let vp_gate = case (mid_gate) of Nothing -> Nothing Just id_gate -> let portprops = if gate_high then [VPouthigh] else [] in Just (id_to_vName id_gate, portprops) -- XXX why use the qualified name here and not the others? -- XXX does the Id ever come qualified? addOutputClock clk (id_clk, Just (vp_osc, vp_gate)) -- XXX unQualId VModInfo return (Clock (unQualId id_clk)) -- Given a reset Id, make a reset, the abstract input, and the VArgInfo. -- (the default reset is assumed to be idDefaultReset) -- Also, an optional clock Id is given, if the reset is to be associated -- with a specific clock domain (the domain of that clock). makeInputRstn :: Id -> Maybe Id -> G (HReset, IAbstractInput, VArgInfo) makeInputRstn id_rst mclk = do when doTraceClock $ traceM "makeInputRstn\n" flags <- getFlags pps <- getPragmas let id_wire = makeArgResetPortId (resetName flags) pps id_rst topRstnClock <- case mclk of Nothing -> return noClock Just n -> do -- until we support recursive instantiation, -- this clock will only be an input clock c <- getBoundaryClock n let err = "IExpand.makeInputRstn: " ++ "unknown boundary clock" return (fromJustOrErr err c) let topRstnWire = ICon id_wire (ICModPort itBit1) let abs_input = IAI_Reset id_wire let varginfo = ResetArg id_rst rstn <- newReset topRstnClock topRstnWire addInputReset rstn (id_rst, (Just (id_to_vName id_wire), mclk)) return (rstn, abs_input, varginfo) -- This requires that the domain_to_boundary_ids_map has been made makeOutputRstn :: Position -> Id -> Id -> HReset -> G VFieldInfo makeOutputRstn mod_pos id_rst port_id rstn = do -- XXX unQualId VModInfo flags <- getFlags pps <- getPragmas let id_wire = makeIfcResetPortId (resetName flags) pps (unQualId id_rst) port_id -- is the value an input reset top_in_resets <- getInputResets let isInputReset r = r `elem` top_in_resets -- the clock written in the reset value let rst_clk :: HClock rst_clk = getResetClock rstn -- if the rst is an input reset and the clock is no_clock, -- then look to see if we've deduced an associated clock domain -- and, if so, use that domain instead -- XXX check for (rst_clkdom == noClockDomain)? clkdom <- if (isInputReset rstn) && (rst_clk == noClock) then do deduced_clkdom <- do mclkdom <- getInputResetClockDomain rstn -- consider no uses of the reset to be noClock return $ fromMaybe noClockDomain mclkdom if (deduced_clkdom /= noClockDomain) then return deduced_clkdom else return (getClockDomain rst_clk) else return (getClockDomain rst_clk) -- find a boundary clock in the same domain domainToIdsMap <- getDomainToBoundaryIdsMap let mClkName = findBoundaryClock domainToIdsMap clkdom when (isNothing mClkName && clkdom /= noClockDomain) $ eWarning (mod_pos, WOutputResetNoBoundaryClock (getIdString (unQualId id_rst))) -- XXX why use the qualified name here and not the others? -- XXX does the Id ever come qualified? addOutputReset rstn (id_rst, (Just (id_to_vName id_wire), mClkName)) -- XXX unQualId VModInfo return (Reset (unQualId id_rst)) -- Given an inout Id, make an inout, the abstract input, and the VArgInfo. -- (the default clock/reset is assumed to be idDefaultClock/idDefaultReset) -- Also, an optional clock Id and reset Id are given, if the inout is to be -- associated with a specific clock domain (the domain of that clock) or -- specific reset. makeArgInout :: Id -> Integer -> Maybe Id -> Maybe Id -> G (HInout, IAbstractInput, VArgInfo) makeArgInout id_iot sz mclk mrst = do when doTraceClock $ traceM "makeArgInout\n" -- to make a better Verilog name (based on user attributes) pps <- getPragmas let id_wire = makeArgPortId pps id_iot topIotClock <- case mclk of Nothing -> return noClock Just n -> do -- until we support recursive instantiation, -- this clock will only be an input clock c <- getBoundaryClock n let err = "IExpand.makeArgInout: " ++ "unknown boundary clock" return (fromJustOrErr err c) topIotReset <- case mrst of Nothing -> return noReset Just n -> do -- until we support recursive instantiation, -- this clock will only be an input clock r <- getBoundaryReset n let err = "IExpand.makeArgInout: " ++ "unknown boundary clock" return (fromJustOrErr err r) let topIotWire = ICon id_wire (ICModPort (itInout_N sz)) iinout = makeInout topIotClock topIotReset topIotWire let abs_arg = IAI_Inout id_wire sz let varginfo = InoutArg (id_to_vName id_wire) mclk mrst return (iinout, abs_arg, varginfo) makeIfcInout :: Position -> Id -> Id -> HInout -> G (WireProps, VFieldInfo) makeIfcInout mod_pos id_iot port_id inout = do let hclk = getInoutClock inout hrst = getInoutReset inout let id_wire = makeIfcInoutPortId id_iot port_id -- make the WireSet let clkdom = getClockDomain hclk rstid = getResetId hrst ws = WireProps (Just clkdom) [rstid] -- find the clock boundaryClocks <- getBoundaryClocks mclk <- if (hclk == noClock) then return Nothing else if hclk `elem` boundaryClocks then boundaryClockToName hclk else do eWarning (getPosition id_iot, WIfcInoutNoBoundaryClock (pfpString id_iot)) return Nothing -- find the reset boundaryResets <- getBoundaryResets mrst <- if (hrst == noReset) then return Nothing else if hrst `elem` boundaryResets then boundaryResetToName hrst else do eWarning (getPosition id_iot, WIfcInoutNoBoundaryReset (pfpString id_iot)) return Nothing -- make the VFieldInfo let fi = Inout { vf_name = id_iot, vf_inout = id_to_vName id_wire, vf_clock = mclk, vf_reset = mrst } return (ws, fi) -- For making the clock and reset parts of VModInfo, construct -- a map from clockdomain to the boundary clock ids in that domain makeDomainToBoundaryIdsMap :: G () makeDomainToBoundaryIdsMap = do s <- get let in_cinfos = in_clock_info s out_cinfos = out_clock_info s clk_ids = getClockIds out_cinfos ++ getClockIds in_cinfos new_map = M.fromListWith (++) [ (getClockDomain c, [n]) | (c, n) <- clk_ids ] put (s { domain_to_boundary_id_map = new_map }) getDomainToBoundaryIdsMap :: G (M.Map ClockDomain [Id]) getDomainToBoundaryIdsMap = do s <- get return (domain_to_boundary_id_map s) -- Given a clock, find a boundary clock in the same domain findBoundaryClock :: M.Map ClockDomain [Id] -> ClockDomain -> Maybe Id findBoundaryClock domainToIdsMap clkdom = case (M.lookup clkdom domainToIdsMap) of Just (clk:_) -> Just clk _ -> Nothing -- add a clock relationship to the clk_ancestry_map addClockChild :: (HClock, HClock) -> G () addClockChild (parent,child) = do s <- get let cam = clk_ancestry_map s cam' = M.insertWith (++) parent [child] cam put (s { clk_ancestry_map = cam' }) -- test if one clock is an ancestor of another isClockAncestor :: HClock -> HClock -> G Bool isClockAncestor ancestor child = do s <- get return $ canReach (clk_ancestry_map s) child ancestor where canReach cam to from = (from == to) || (any (canReach cam to) (M.findWithDefault [] from cam)) make_vclockinfo :: S.Set HClock -> [(HClock, InputClockInf)] -> [(HClock, OutputClockInf)] -> M.Map ClockDomain [Id] -> M.Map HClock [HClock] -> VClockInfo make_vclockinfo inhighs in_cinfos out_cinfos domainToIdsMap cam = ClockInfo (map snd in_cinfos') (map snd out_cinfos') ancestorPairs sameFamilyPairs where -- list of boundary clock names broken up by domain namesList = map snd (M.toList domainToIdsMap) namesToFamilyPairs [] = [] namesToFamilyPairs (a : rest) = map (pair a) rest sameFamilyPairs = concatMap namesToFamilyPairs namesList -- list of (ancestor,child) clock pairs in terms of boundary -- ids in the same family getHClock i = let in_matches = [ hc | (hc,(i',_)) <- in_cinfos , i == i' ] out_matches = [ hc | (hc,(i',_)) <- out_cinfos , i == i' ] in headOrErr ("make_vclockinfo: unknown clock" ++ (show i)) (in_matches ++ out_matches) all_pairs = [ (p,c) | same <- namesList , p <- same , c <- same , p /= c ] can_reach to from = (from == to) || (any (can_reach to) (M.findWithDefault [] from cam)) ancestorPairs = [ (p,c) | (p,c) <- all_pairs , let hc = getHClock c , let hp = getHClock p , hc /= hp , can_reach hc hp ] -- adjust the clockinfs of input clocks -- to indicate inhigh for appropriate gates adjustInhigh ci@(clk, clkinf) = let adjClkinf (i, Just (vp_osc, Left _)) = (i, Just (vp_osc, Left True)) adjClkinf x = internalError ("adjustInhigh: unexpected clockinf: " ++ ppReadable x) in if (S.member clk inhighs) then (clk, adjClkinf clkinf) else ci in_cinfos' = map adjustInhigh in_cinfos -- output clock gates already have VPouthigh in their Clockinf, -- and an error has already been triggered for output clocks -- with no gate port where the gate value is not 1 -- (this is done in makeOutputClock) out_cinfos' = out_cinfos -- this is in IO so that it can issue warnings make_vresetinfo :: ErrorHandle -> [(HReset, ResetInf)] -> [(HReset, ResetInf)] -> M.Map HReset ClockDomain -> M.Map ClockDomain [Id] -> IO VResetInfo make_vresetinfo errh in_rinfos out_rinfos rstClkDomMap domainToIdsMap = do let getInRstClkDom r = M.lookup r rstClkDomMap -- find the boundary clock to be associated with an input reset updateInputResetClock (r, (i, (mp, Nothing))) = let default_result = (r, (i, (mp, Nothing))) mk_result clk = (r, (i, (mp, Just clk))) do_warn = do bsWarning errh [(getPosition i, WInputResetNoBoundaryClock (getIdString i))] in case (getInRstClkDom r) of Just dom | (dom /= noClockDomain) -> case (findBoundaryClock domainToIdsMap dom) of Just clk -> return (mk_result clk) Nothing -> do do_warn return default_result _ -> return default_result updateInputResetClock ri = return ri -- update the input infos in_rinfos' <- mapM updateInputResetClock in_rinfos -- no change to output infos let out_rinfos' = out_rinfos return $ ResetInfo (map snd in_rinfos') (map snd out_rinfos') -- This is used by IExpand.newState to both -- (1) check that submodule gate ports are connected to True when required -- (2) record any boundary clocks connected to input clocks which have the -- requirement (for adding it to that clock at the end of evaluation) chkClkArgGateWires :: String -> String -> Position -> [InputClockInf] -> [(Id, HClock, Int)] -> G () chkClkArgGateWires modName instName pos clockinfs clockargnum_map = let -- whether a clock arg's gate is required to be 1 clockGateInhigh clk_id = case (lookup clk_id clockinfs) of Nothing -> internalError ("IExpand.newState: " ++ "clockarg not in clockinfo: " ++ ppReadable clk_id) Just (Just (_, Left b)) -> b Just _ -> False gates_which_need_inhigh = let f (clk_id, _, _) = clockGateInhigh clk_id in filter f clockargnum_map -- clock args to be reported as errors bad_gates = let gateNotHigh (_, clk_expr, _) = not (isTrue (getClockGate clk_expr)) in filter gateNotHigh gates_which_need_inhigh -- while we're at it, record which clocks were inhigh -- (addInhighClkGate will record only the ones which are -- boundary clocks with gate ports) gates_to_add = nub $ map snd3 gates_which_need_inhigh -- error for non-inhigh gates mkErr clkName = (pos, EClkGateNotInhigh modName instName clkName) in case (bad_gates) of [] -> mapM_ addInhighClkGate gates_to_add bs -> errsG $ map (mkErr . getIdString . fst3) bs chkInputClockPragmas :: [VArgInfo] -> G () chkInputClockPragmas vargs = do pps <- getPragmas let getClkIds (PPgate_input_clocks is) = is getClkIds (PPclock_family is) = is getClkIds (PPclock_ancestors ils) = nub (concat ils) getClkIds _ = [] -- Ids referenced in input clock pragmas pp_ids = concatMap getClkIds pps -- Ids of actual clock inputs clk_ids = [ i | ClockArg i <- vargs ] -- pragma Ids which don't match any clocks bad_pp_ids = filter (\i -> not (elem i clk_ids)) pp_ids mkErr i = (getPosition i, EAttributeIdNotAnInputClock (getIdString i)) in case (bad_pp_ids) of [] -> return () (b:_) -> -- XXX G only allows reporting one error? errG $ mkErr b -- This is used by IExpand.newState to check that clocks marked as -- siblings are in the same clock domain. chkClkSiblings :: String -> String -> Position -> [(Id,Id)] -> [(Id, HClock, Int)] -> G () chkClkSiblings modName instName pos siblings clockargnum_map = let -- list of clock pairs that should be siblings but aren't not_actually_siblings = [(getIdString i1, getIdString i2) | (i1, c1, n1) <- clockargnum_map , (i2, c2, n2) <- clockargnum_map , i1 /= i2 , not (sameClockDomain c1 c2) , (i1,i2) `elem` siblings ] in when (not (null (not_actually_siblings))) $ errG (pos, EClockArgSiblings modName instName not_actually_siblings) -- This is used by IExpand.newState to check that clocks marked as -- ancestors actually have the stated ancestry relationship. chkClkAncestry :: String -> String -> Position -> [(Id,Id)] -> [(Id, HClock, Int)] -> G () chkClkAncestry modName instName pos ancestors clockargnum_map = do let to_check = [ (c1,c2) | (i1, c1, n1) <- clockargnum_map , (i2, c2, n2) <- clockargnum_map , i1 /= i2 , (i1,i2) `elem` ancestors ] is_correct <- mapM (\(p,c) -> isClockAncestor p c) to_check cam <- gets clk_ancestry_map -- list of clock pairs that have incorrect ancestry let bad_relationships = [ x | (False,x) <- zip is_correct to_check ] clk_name c = case [ i | (i,c',_) <- clockargnum_map, c == c' ] of [i] -> getIdString i _ -> internalError $ "chkClkAncestry: could not find unique name for clock" err_pairs = [ (clk_name p, clk_name c) | (p,c) <- bad_relationships ] -- generate errors if any incorrect relationships were found when (not (null err_pairs)) $ errG (pos, EClockArgAncestors modName instName err_pairs) -- --------------- {-# INLINE newStateNo #-} newStateNo :: G Int newStateNo = do s <- get let n = stateNo s put (s { stateNo = n+1 }) return n -- disambiguates state names using stateNameMap uniqueStateName :: Id -> G Id uniqueStateName i = do s <- get let snmap = stateNameMap s case (M.lookup i snmap) of Nothing -> -- id is unused do let snmap' = M.insert i (1 :: Int) snmap put (s {stateNameMap = snmap'}) return i Just n -> let loop n = case M.lookup i' snmap of Nothing -> do let snmap' = M.insert i (n+1) snmap let snmap'' = M.insert i' (1 :: Int) snmap' put (s {stateNameMap = snmap''}) return i' -- already used i_n Just n' -> loop (n+1) where i' = (createSuffixedId i (toInteger n)) in loop n -- kick off with first candidate suffix -- create a new IStateLoc objct. newIStateLoc :: Id -> Id -> IType -> IStateLoc -> G IStateLoc newIStateLoc inst_id ifc_id ifc_type ns = do map <- gets stateLocMap let ns' = newIStateLocTop map inst_id ifc_id ifc_type ns when doTraceLoc $ traceM ("NewStateLoc: " ++ ppReadable ((inst_id, ifc_id), ns')) return ns' newIStateLocForRule :: Id -> Bool -> IStateLoc -> G IStateLoc newIStateLocForRule id hide ns@(islpc:_) = do let id' = if (hide) then setHideId id else id isl <- newIStateLoc id' id' (isl_ifc_type islpc) ns -- update the stateLocMap s <- get let newMap = extendStateLocMap (stateLocMap s) isl when doTraceLoc $ traceM ("NewRule: " ++ ppReadable isl) put (s {stateLocMap = newMap}) return isl newIStateLocForRule id hide [] = internalError "newIStateLocForRule: Empty loc" -- -------------- traceProgress :: String -> G () traceProgress str = liftIO $ do ct <- getClockTime now <- toCalendarTime ct traceM ("[" ++ calendarTimeToString now ++ "] elab progress: " ++ str) showTopProgress :: String -> G () showTopProgress str = do flags <- getFlags when (showElabProgress flags) $ traceProgress str showModProgress :: IStateLoc -> String -> G () showModProgress ns str = do flags <- getFlags let showHidden = tclShowHidden flags hide = if showHidden then False else (hasHide ns) || (hasHideAll ns) ign = (hasIgnore ns) when ((showElabProgress flags) && (not (hide || ign))) $ let mod = case (stateLocToHierName ns showHidden) of Nothing -> "" Just m -> "(" ++ m ++ ") " in traceProgress $ mod ++ str showRuleProgress :: IStateLoc -> Bool -> String -> String -> G () showRuleProgress ns rhide name str = do flags <- getFlags let showHidden = tclShowHidden flags hide = if showHidden then False else rhide || (hasHideAll ns) when ((showElabProgress flags) && (not hide)) $ let mod = case (stateLocToHierName ns showHidden) of Nothing -> "" Just m -> "(" ++ m ++ ") " in traceProgress $ mod ++ str ++ " (" ++ name ++ ")" -- -------------- -- When reporting an error message, construct the context from the stack getElabProgressContext :: G MsgContext getElabProgressContext = do let addPos pos | (pos == noPosition) = "" addPos pos = " at " ++ prPosition pos flags <- getFlags s <- get let showHidden = tclShowHidden flags scope = schedNameScope s case scope of (SchedNameFrame ns _ _ ep : _) -> do let modprog = case ep of Nothing -> empty Just (EPRule i rhide mrp) -> -- replicate the decision-making in "showRuleProgress" let hide = if showHidden then False else rhide || (hasHideAll ns) in case mrp of _ | hide -> empty Nothing -> s2par("During elaboration of rule " ++ quote (getIdBaseString i) ++ addPos (getPosition i) ++ ".") Just REP_ExplicitCond -> s2par("During elaboration of the explicit " ++ "condition of rule " ++ quote (getIdBaseString i) ++ addPos (getPosition i) ++ ".") Just REP_Body -> s2par("During elaboration of the body " ++ "of rule " ++ quote (getIdBaseString i) ++ addPos (getPosition i) ++ ".") Just REP_ImplicitCond -> s2par("During elaboration of the implicit " ++ "condition of rule " ++ quote (getIdBaseString i) ++ addPos (getPosition i) ++ ".") Just (EPInterface mip) -> case mip of Nothing -> s2par("During elaboration of the interface.") Just (IEP_OutputClock i) -> s2par("During elaboration of the interface " ++ "output clock " ++ quote (getIdBaseString i) ++ addPos (getPosition i) ++ ".") Just (IEP_OutputReset i) -> s2par("During elaboration of the interface " ++ "output reset " ++ quote (getIdBaseString i) ++ addPos (getPosition i) ++ ".") Just (IEP_OutputInout i) -> s2par("During elaboration of the interface " ++ "inout " ++ quote (getIdBaseString i) ++ addPos (getPosition i) ++ ".") Just (IEP_Method i False) -> s2par("During elaboration of the interface " ++ "method " ++ quote (getIdBaseString i) ++ addPos (getPosition i) ++ ".") Just (IEP_Method i True) -> s2par("During elaboration of the implicit " ++ "condition of the interface method " ++ quote (getIdBaseString i) ++ addPos (getPosition i) ++ ".") -- replicate the decision-making in "showModProgress" -- (could this be more efficient by not using abstracted funcs?) let convLocs [] = [] convLocs cur_ns@(cur_islpc:parent_ns) = let hide = if showHidden then False else (hasHide cur_ns) || (hasHideAll cur_ns) ign = hasIgnore cur_ns -- replicate how InstNodes names the hierarchy name = isl_inst_id cur_islpc pos = getPosition name finalName = maybe name (mkId pos) (getIdDisplayName name) in if (hide || ign) then convLocs parent_ns else (finalName : convLocs parent_ns) loc_ids = convLocs ns top_id = mod_def_id s ppLocId i = s2par("During elaboration of " ++ quote (getIdBaseString i) ++ addPos (getPosition i) ++ ".") return (vcat (modprog : map ppLocId (loc_ids ++ [top_id]))) _ -> internalError ("getElabProgressContext: " ++ ppReadable scope) -- ############################################################################# -- # -- ############################################################################# newFFCallNo :: G Int newFFCallNo = do s <- get let n = ffcallNo s put (s { ffcallNo = n + 1 }) return n -- create a clock given an expression for the wires -- and (maybe) a family to add it to -- and a list of parent (Left) and child (Right) clocks -- be careful about what to display because this is called from newState newClock :: HExpr -> Maybe (HClock) -> [Either HClock HClock] -> G HClock newClock wires mclock ancestors = do s <- get -- this trace sometimes leads to loops -- because state elements with output clocks point to themselves -- traceM ("new clock: " ++ ppReadable wires) let clockid = newClockId s let clockid' = nextClockId clockid domain <- case mclock of Just clock -> do when doTraceClock $ traceM ("existing domain: " ++ (show (getClockDomain clock))) put (s { newClockId = clockid'}) return (getClockDomain clock) Nothing -> do when doTraceClock $ traceM ("new domain") let domain = newClockDomain s let domain' = nextClockDomain domain put ( s {newClockId = clockid', newClockDomain = domain'}) return domain when doTraceClock $ traceM ("new clock id: " ++ (show clockid) ++ " domain: " ++ (show domain)) let clock = makeClock clockid domain wires addClock clock let addAncestor (Left p) = addClockChild (p,clock) addAncestor (Right c) = addClockChild (clock,c) mapM_ addAncestor ancestors return clock -- make a reset given an expression for the signal -- and its associated clock (possibly noClock) -- be careful about what to display because this is called from newState newReset :: HClock -> HExpr -> G HReset newReset clock wire = do s <- get let resetid = newResetId s let resetid' = nextResetId resetid put (s { newResetId = resetid'}) when doTraceClock $ traceM ("new reset id: " ++ (show resetid)) let reset = makeReset resetid clock wire addReset reset return reset -- Given an name for an input clock, attempt to find an existing -- clock in the same family based on the clock_family and clock_ancestors -- module pragmas. The name can be "" to indicate the default clock. findFamilyMember :: Id -> G (Maybe HClock) findFamilyMember clk_id = do pps <- getPragmas let fams = [ is | (PPclock_family is) <- pps ] ancs = [ is | (PPclock_ancestors ils) <- pps, is <- ils ] -- all families implied by clock_family and clock_ancestors all_families = transitive_union (fams ++ ancs) [] -- Maybe the family containing the desired clock the_family = find (elem clk_id) all_families -- if we found a clock family, search for an existing clock -- associated with any member of the family case the_family of Nothing -> return Nothing (Just f) -> do input_clk_info <- gets in_clock_info return (listToMaybe [ hc | (hc,(i,_)) <- input_clk_info , i `elem` f ]) where transitive_union [] disjoint = disjoint transitive_union (xs:rest) disjoint = let (no_overlap,overlap) = partition (null . (intersect xs)) disjoint in transitive_union rest (((concat overlap) `union` xs):no_overlap) -- Given an name for an input clock, attempt to find existing clocks -- which are parent or children of the clock, based on the clock_ancestors -- module pragmas. The name can be "" to indicate the default clock. -- Left is used for parent, Right for children. findParentsAndChildren :: Id -> G [Either HClock HClock] findParentsAndChildren clk_id = do pps <- getPragmas let ancs = [ is | (PPclock_ancestors ils) <- pps, is <- ils ] -- get all lists which mention the clock relevant = filter (clk_id `elem`) ancs -- turn the lists into a list of (parent,child) pairs pairs = concatMap to_pairs relevant -- extract lists of parent and child clocks parents = [ p | (p,c) <- pairs, c == clk_id ] children = [ c | (p,c) <- pairs, p == clk_id ] -- map the clock Ids to HClocks input_clk_info <- gets in_clock_info let get_hclk x = listToMaybe [ hc | (hc,(i,_)) <- input_clk_info, i == x ] parents' = map Left (mapMaybe get_hclk parents) children' = map Right (mapMaybe get_hclk children) return (parents' ++ children') where to_pairs [] = [] to_pairs [x] = [] to_pairs (a:b:rest) = (a,b):(to_pairs (b:rest)) addStateVar :: (Id, HStateVar) -> G () addStateVar v@(id,hsv) = do s <- get -- update the stateLocMap with this hierarchy path to avoid conflicts later let newMap = extendStateLocMap (stateLocMap s) (isv_isloc hsv) -- when doTraceLoc $ traceM $ ("New state var: " ++ ppReadable (id)) put (s { vars = v : vars s ,stateLocMap = newMap}) {- extendHeap :: G () extendHeap = do s <- get let oldtop = htop s let oldheap = heap s let newtop = 2 * oldtop newheap <- lift (lift (newArray (0, newtop - 1) Nothing)) put s { heap = newheap, htop = newtop } let copycell = \ (p :: HeapPointer) -> do c <- lift (lift (readArray oldheap p)) lift (lift (writeArray newheap p c)) mapM_ copycell ((uncurry enumFromTo) (bounds oldheap)) -} addHeapCell :: String -> HeapCell -> G (HeapPointer, HeapData) addHeapCell tag cell = do s <- get let p = hp s ref <- liftIO (newIORef (cell)) put (s { hp = p+1 }) when doTraceHeapAlloc $ traceM("addHeapCell(" ++ show p ++ "): " ++ tag ++ "\n") return (p, HeapData ref) addHeapUnev :: String -> IType -> HExpr -> Maybe Id -> G HExpr addHeapUnev tag t e cell_name = do let newcell = (HUnev { hc_hexpr = e, hc_name = cell_name }) cross <- getCross (p, r) <- addHeapCell tag newcell -- trace_hcell p e let result = IRefT t p r when doTraceHeap $ traceM ("addHeapUnev " ++ ppString cell_name ++ " [" ++ prPositionConcise (getPosition cell_name) ++ "] " ++ ppReadable (result,t,e)) return (mapIExprPosition cross (e, result)) -- add an expression to the heap, noting it is WHNF addHeapWHNF :: String -> IType -> PExpr -> Maybe Id -> G HExpr addHeapWHNF tag t pe cell_name = do let newcell = (HWHNF { hc_pexpr = pe, hc_name = cell_name }) (p, r) <- addHeapCell tag newcell let result = IRefT t p r when doTraceHeap $ traceM ("addHeapWHNF " ++ ppString cell_name ++ " [" ++ prPositionConcise (getPosition cell_name) ++ "] " ++ ppReadable (result,t,pe)) return result {- -- add an expression to the heap that is in NF addHeapNF :: String -> IType -> PExpr -> HWireSet -> G HExpr addHeapNF tag t pe ws = do let newcell = (HNF { hc_pexpr = pe, hc_wire_set = ws, hc_name = Nothing }) (p, r) <- addHeapCell tag newcell let result = IRefT t p r -- flags <- getFlags -- mapIExprPosition flags? when doTraceHeap $ traceM ("addHeapNF " ++ ppReadable (result,t,pe)) return result -} -- "evalPred" needs to create references for shared expressions. -- It doesn't need to create full-fledged heap refs, since evaluation -- is over at this point (the ref is NF, has no implicit condition and -- no wireset), but heap refs are all that are available. addHeapPred :: String -> HExpr -> G HExpr addHeapPred _ e@(IRefT {}) = return e addHeapPred tag e = do let t = itBit1 -- boolean condition pe = P pTrue e -- no implicit condition ws = wsEmpty -- no wire set let newcell = (HNF { hc_pexpr = pe, hc_wire_set = ws, hc_name = Nothing }) (p, r) <- addHeapCell tag newcell let result = IRefT t p r when doTraceHeap $ traceM ("addHeapPred " ++ ppReadable (result,e)) return result {-# INLINE getHeap #-} getHeap :: HeapData -> G HeapCell getHeap (HeapData ref) = liftIO (readIORef ref) {-# INLINE updHeap #-} updHeap :: String -> (HeapPointer, HeapData) -> HeapCell -> G () updHeap tag (p, HeapData ref) e = do o <- getHeap (HeapData ref) when doTraceHeap2 $ traceM ("old val [" ++ tag ++ "]: " ++ "(_" ++ show p ++ ", " ++ ppReadable o ++ ")") when doTraceHeap $ traceM ("updHeap [" ++ tag ++ "] " ++ "(_" ++ show p ++ ", " ++ ppReadable e ++ ")") let old_name = hc_name o let new_name = hc_name e let best_name = maybe old_name Just new_name let e' = e { hc_name = best_name } hyper best_name $ liftIO (writeIORef ref e') {- filterHeapPtrs :: (HeapCell -> Bool) -> G [HeapPointer] filterHeapPtrs accept = do state <- get let next_unused_addr = hp state filter_loop addr | addr == next_unused_addr = return [] | otherwise = do cell <- getHeap (HeapData addr) rest <- filter_loop (addr+1) return (if accept cell then addr:rest else rest) filter_loop 0 -} {-# INLINE getStateNo #-} getStateNo :: G Int getStateNo = do s <- get return (stateNo s) {-# INLINE getSymTab #-} getSymTab :: G SymTab getSymTab = do s <- get return (symtab (ro s)) {-# INLINE getDefEnv #-} getDefEnv :: G (M.Map Id HExpr) getDefEnv = do s <- get return (defenv (ro s)) {-# INLINE getFlags #-} getFlags :: G Flags getFlags = do s <- get return (flags (ro s)) {-# INLINE getCross #-} getCross :: G Bool getCross = do flags <- getFlags return (crossInfo flags) {-# INLINE getErrHandle #-} getErrHandle :: G ErrorHandle getErrHandle = do s <- get return (errHandle (ro s)) {-# INLINE getWireSetCache #-} getWireSetCache :: G (M.Map HeapPointer HWireSet) getWireSetCache = do s <- get return (heapWires s) {-# INLINE updWireSetCache #-} updWireSetCache :: HeapPointer -> HWireSet -> G () updWireSetCache p ws = do s <- get let cache' = M.insert p ws (heapWires s) put s { heapWires = cache' } {-# INLINE getModuleName #-} getModuleName :: G String getModuleName = do mid <- gets mod_def_id return (getIdBaseString mid) {-# INLINE getNewRuleSuffix #-} getNewRuleSuffix :: G Integer getNewRuleSuffix = do s <- get return (newRuleSuffix s) {-# INLINE updNewRuleSuffix #-} updNewRuleSuffix :: Integer -> G () updNewRuleSuffix suf = do s <- get put s { newRuleSuffix = suf } ----------------------------------------------------------------------------- {-# INLINE unheap #-} unheap :: PExpr -> G PExpr unheap (P p e_orig@(IRefT _ _ r)) = do e <- getHeap r cross <- getCross case e of (HUnev {}) -> internalError ("IExpandUtils.unheap: unevaluated") (HLoop name) -> internalError("IExpandUtils.unheap: HLoop " ++ ppReadable name) (HWHNF { hc_pexpr = P _ (IRefT _ _ _) }) -> internalError ("IExpandUtils.unheap: WHNF IRefT") (HWHNF { hc_pexpr = P p' e, hc_name = n } ) -> return (P (pConj p p') (mapIExprPosition cross (e_orig, e))) (HNF { hc_pexpr = P _ (IRefT _ _ _) }) -> internalError ("IExpandUtils.unheap: NF IRefT") (HNF { hc_pexpr = P p' e }) -> return (P (pConj p p') (mapIExprPosition cross (e_orig, e))) unheap pe = return pe {-# INLINE unheapU #-} unheapU :: HExpr -> G HExpr unheapU e_orig@(IRefT _ _ r) = do e <- getHeap r flgs <- getFlags let cross = (crossInfo flgs) case e of (HUnev { hc_hexpr = e }) -> return e (HLoop name) -> internalError ("unheapU: HLoop " ++ ppReadable name) (HWHNF { hc_pexpr = P _ (IRefT _ _ _) } ) -> internalError ("unheapU: IRefT") (HWHNF { hc_pexpr = e, hc_name = n }) -> return (mapIExprPosition cross (e_orig, (pExprToHExpr e))) (HNF { hc_pexpr = e }) -> return (mapIExprPosition cross (e_orig, (pExprToHExpr e))) unheapU e = return e -- unheap more than the first cell, but not much more than that {-# INLINE shallowUnheap #-} shallowUnheap :: HExpr -> G HExpr shallowUnheap e= do e' <- unheapU e case e' of IAps f ts es -> do es' <- mapM unheapU es; return (IAps f ts es') _ -> return e' {-# INLINE unheapNFNoImp #-} -- unheap dropping (inaccurate) implicit conditions -- since implicit conditions are not reduced to NF until evalPred unheapNFNoImp :: HExpr -> G HExpr unheapNFNoImp e_orig@(IRefT _ _ r) = do e <- getHeap r flgs <- getFlags let cross = (crossInfo flgs) case e of (HUnev { }) -> internalError ("unheapNFNoImp: HUnev " ++ ppReadable (e_orig, e)) (HLoop name) -> internalError ("unheapNFNoImp: HLoop " ++ ppReadable name) (HWHNF { }) -> internalError ("unheapNFNoImp: HWHNF " ++ ppReadable (e_orig, e)) (HNF { hc_pexpr = (P _ e) }) -> return (mapIExprPosition cross (e_orig, e)) unheapNFNoImp e = return e -- XXX use unsafePerformIO to work around an apparent monadic recursion bug unheapNFNoImpEvil :: HExpr -> HExpr unheapNFNoImpEvil (IRefT _ _ (HeapData c)) = case cell of HNF { hc_pexpr = (P _ e) } -> e _ -> internalError ("unheapNFNoImp - unexpected: " ++ ppReadable cell) where cell = unsafePerformIO (readIORef c) unheapNFNoImpEvil e = e {- unheapUH :: Heap -> HeapPointer -> HExpr unheapUH heap p = case I.lookup p heap of Nothing -> internalError "unheapUH: Nothing" Just (HUnev e) -> e Just (HWHNF (P _ (IRefT _ _ _))) -> internalError ("unheapUH: IRefT") Just (HWHNF e) -> (pExprToHExpr e) Just (HNF e) -> (pExprToHExpr e) -} unheapAll :: HExpr -> G HExpr unheapAll e = do e' <- unheapU e case e' of ILam i t e -> do e' <- unheapAll e; return (ILam i t e') IAps f ts es -> do f' <- unheapAll f; es' <- mapM unheapAll es; return (IAps f' ts es') ILAM i t e -> do e' <- unheapAll e; return (ILAM i t e') ICon i (ICLazyArray arr_t arr u) -> do let elem_ty = case arr_t of (ITAp c t) | (c == itPrimArray) -> t _ -> internalError ("unheapAll: array type") mapFn (ArrayCell ptr ref) = do unheapAll (IRefT elem_ty ptr ref) es <- mapM mapFn (Array.elems arr) let ic = case icPrimBuildArray (length es) of (ICon _ ci) -> ICon i ci _ -> internalError ("unheapAll: icPrimBuildArray") return (IAps ic [elem_ty] es) _ -> return e' -- unheapAll for NF with no implicit conditions -- used for error reporting (clock domains and multiple resets, etc.) unheapAllNFNoImp :: HExpr -> G HExpr unheapAllNFNoImp e = do e' <- unheapNFNoImp e case e' of ILam i t e -> do e' <- unheapAllNFNoImp e; return (ILam i t e') IAps f ts es -> do f' <- unheapAllNFNoImp f; es' <- mapM unheapAllNFNoImp es; return (IAps f' ts es') ILAM i t e -> do e' <- unheapAllNFNoImp e; return (ILAM i t e') _ -> return e' {-# INLINE toHeap #-} toHeap :: String -> HExpr -> Maybe Id -> G HExpr -- foreign function calls must be forced onto the heap for -- proper handling of actionvalues toHeap tag e@(ICon i (ICForeign {iConType = t})) cell_name = addHeapUnev tag t e cell_name -- definitions must be heaped for correct handling of actionvalues -- a top-level definition should have no free variables by construction toHeap tag (ICon i (ICDef t e)) cell_name = do e' <- cacheDef i t e toHeap tag e' cell_name toHeap tag e@(ICon _ _) cell_name = return e toHeap tag e@(IRefT _ _ _) cell_name = return e -- XXX name improvement? toHeap tag e cell_name = do -- these errors have never happened, disable checks for now. when (doDebugFreeVars && not (null (fVars e))) $ internalError ("toHeap: fv " ++ ppReadable (fVars e) ++ ppReadable e) when (doDebugFreeVars && not (null (ftVars e))) $ internalError ("toHeap: ftv " ++ ppReadable (ftVars e) ++ ppReadable e) -- do the real work of adding the cell addHeapUnev tag (iGetType e) e cell_name -- Used when you absolutely need to get an IRefT back -- for arrays {-# INLINE toHeapCon #-} toHeapCon :: String -> HExpr -> Maybe Id -> G HExpr -- expand out ICDef as in toHeap toHeapCon tag (ICon i (ICDef t e)) cell_name = do e' <- cacheDef i t e toHeapCon tag e' cell_name -- heap all other constants toHeapCon tag e@(ICon _ _) cell_name = addHeapUnev tag (iGetType e) e cell_name toHeapCon tag e cell_name = toHeap tag e cell_name {-# INLINE toHeapWHNF #-} toHeapWHNF :: String -> HExpr -> Maybe Id -> G HExpr toHeapWHNF tag e@(ICon _ _) cell_name = return e toHeapWHNF tag e@(IRefT _ _ _) cell_name = return e toHeapWHNF tag (IAps (ICon _ (ICPrim _ PrimWhenPred)) [t] [ICon _ (ICPred _ p), e]) cell_name = do let pe = P p e -- IRefT is not WHNF pe' <- unheap pe addHeapWHNF tag t pe' cell_name toHeapWHNF tag e cell_name = addHeapWHNF tag (iGetType e) (P pTrue e) cell_name {-# INLINE toHeapWHNFCon #-} toHeapWHNFCon :: String -> HExpr -> Maybe Id -> G HExpr toHeapWHNFCon tag e@(ICon _ _) cell_name = addHeapWHNF tag (iGetType e) (P pTrue e) cell_name toHeapWHNFCon tag e cell_name = toHeapWHNF tag e cell_name {-# INLINE toHeapWHNFInferName #-} toHeapWHNFInferName :: String -> HExpr -> G HExpr toHeapWHNFInferName tag e = inferName e >>= toHeapWHNF tag e {-# INLINE toHeapInferName #-} toHeapInferName :: String -> HExpr -> G HExpr toHeapInferName tag expr = inferName expr >>= toHeap tag expr {-# INLINE toHeapConInferName #-} toHeapConInferName :: String -> HExpr -> G HExpr toHeapConInferName tag expr = inferName expr >>= toHeapCon tag expr {-# INLINE toHeapWHNFConInferName #-} toHeapWHNFConInferName :: String -> HExpr -> G HExpr toHeapWHNFConInferName tag expr = inferName expr >>= toHeapWHNFCon tag expr -- inferName: given an expression, try to infer a reasonable name from it {-# INLINE inferName #-} inferName :: HExpr -> G (Maybe Id) inferName (IRefT _ _ heap_ref) = do heap_cell <- getHeap heap_ref return (hc_name heap_cell) -- bit selection inferName expr@(IAps (ICon _ (ICPrim { primOp = PrimSelect })) [ITNum bit_size, ITNum lowest_bit, _] [selected_object]) = do selected_object_name <- inferName selected_object let highest_bit = lowest_bit + bit_size - 1 suffix | highest_bit == lowest_bit = mkFString ("_BIT_" ++ show highest_bit ++ "_") | otherwise = mkFString ("_BITS_" ++ show highest_bit ++ "_TO_" ++ show lowest_bit ++ "_") case selected_object_name of Just name -> return (Just (mkIdPost name suffix)) Nothing -> return Nothing -- register read sugar inferName expr@(IAps (ICon con_name (ICSel {})) [_] [object]) | con_name == idPreludeRead = inferName object -- state instances inferName expr@(ICon inst_name (ICStateVar {})) = return (Just inst_name) inferName _ = return Nothing unCacheableType :: IType -> Bool unCacheableType (ITForAll _ _ _) = True -- top-level pure values of Clock and Reset involve no work -- and sometimes we want to play games (e.g. disabled clocks) unCacheableType (ITCon i _ _) = i == idClock || i == idReset unCacheableType t = isFunType t || isitActionValue t --- caching of previously evaluated definitions cacheDef :: Id -> IType -> HExpr -> G HExpr cacheDef i t e | unCacheableType t = return e cacheDef i t e@(ICon {}) = return e cacheDef i t e = do s <- get let m = defCache s case (M.lookup i m) of Just e' -> do when doTraceCache $ traceM ("cache hit: " ++ ppReadable (i, e')) return e' Nothing -> do e' <- toHeap "cache-def" e (Just i) s <- get let m' = M.insert i e' m put (s { defCache = m' }) when doTraceCache $ traceM ("cache miss: " ++ ppReadable (i, e)) return e' -- ############################################################################# -- # -- ############################################################################# -- XXX This is old code that should go away -- At the end of elaboration, this cleans up rule Ids by: -- * filtering out bad characters in the base name and uniquifying the result -- (the hierarchical prefixes have already been cleaned-up), -- * prepending "RL_" to the names -- * and adding the IdPRule property. -- Scheduling attributes are updated to account for changes in the names. cleanupFinalRules :: Flags -> IRules a -> IRules a cleanupFinalRules flags (IRules sps rs) = IRules sps' (reverse rs') where (_, id_rename_map, rs') = foldl foldFn (S.empty, M.empty, []) rs -- rename Ids in the attributes, but keep their original positions -- (we want the Ids to point to the user-written names in the source) sps' = substSchedPragmaIds id_rename_map sps uniqueFn seen = if (ruleNameCheck flags) then makeUniqueRuleString seen else id -- fold over the list, keep tracking of names that have been seen -- and renaming duplicates foldFn :: (S.Set String, SPIdMap, [IRule a]) -> IRule a -> (S.Set String, SPIdMap, [IRule a]) foldFn (seen, rename_map, rs) r@(IRule { irule_name = i } ) = let fs = getIdBaseString i -- clean up non-alphanum characters; -- uniquify the name, if this introduced a clash fs' = uniqueFn seen $ cleanupRuleName fs -- add this to the list of seen names seen' = S.insert fs' seen -- add the RL_ prefix and mark with property new_i = mkIdRule (setIdBaseString i fs') -- update the rename map -- (always necessary, because we always add RL_ rename_map' = M.insert i new_i rename_map rs' = (( r { irule_name = new_i } ):rs) in (seen', rename_map', rs') -- For Classic, replace spaces with underscore. -- All other non-alpha/num/underscore characters are filtered. cleanupRuleName :: String -> String cleanupRuleName i = filter legalChar $ map replace i where legalChar c = (isAlphaNum c) || c == '_' replace ' ' = '_' replace c = c makeUniqueRuleString :: S.Set String -> String -> String makeUniqueRuleString seen str = if (S.notMember base_str seen) then base_str else makeUniqueString 1 where -- XXX replacing with "unnamed" here may not be necessary base_str = if (str == "") then s_unnamed else str makeUniqueString :: Integer -> String makeUniqueString n = let str' = base_str ++ "_" ++ itos n in if (S.notMember str' seen) then str' else makeUniqueString (n+1) -- ############################################################################# -- # -- ############################################################################# -- check the clock set discovered during elaboration chkClockDomain :: String -> Id -> HWireSet -> HExpr -> G () chkClockDomain object id ws e = do when doTraceClock $ traceM ("check clock domain: " ++ (ppReadable id) ++ "\n " ++ (ppReadable ws) ++ (ppReadable e)) when (not (wsCheckClocks ws)) $ do when doTraceClock $ do e' <- unheapAllNFNoImp e traceM (ppReadable e') ms <- getMethodsByClockDomain e deferErrors [(getIdPosition id, EClockDomain object (pfpString id) ms)] chkResetDomain :: String -> Id -> HWireSet -> HExpr -> G () chkResetDomain object id ws e = do when doTraceClock $ traceM ("check reset domain: " ++ (ppReadable id) ++ "\n" ++ (ppReadable ws) ++ (ppReadable e)) when (not (wsCheckResets ws)) $ do when doTraceClock $ do e' <- unheapAllNFNoImp e traceM (ppReadable e') ms <- getMethodsByReset e eWarning (getPosition id, WMultipleResets object (pfpString id) ms) -- For the body of a rule or Action/ActionValue method that otherwise has no -- associated clock (or is associated with "noClock"), we (silently) associate -- it with the default clock. If the default is noClock or if there is no -- default clock, then something else needs to be done fixupActionWireSet :: HClock -> HWireSet -> Maybe HWireSet fixupActionWireSet dflt_clk ws = case (wsGetClockDomain ws) of Just d | (d == noClockDomain) -> if (isMissingDefaultClock dflt_clk) || (isNoClock dflt_clk) then Nothing else Just $ wsAddClock dflt_clk ws _ -> Just ws -- The Id argument is to provide more info for error messages. -- It is the name of the submodule instance whose arguments are being check, -- and its position is used for reporting errors (since a good position for -- the argument expression doesn't exist). chkModuleArgument :: Id -> (HExpr, HWireSet, VArgInfo) -> G (Maybe (Maybe Id, Maybe Id, HWireSet)) -- handle ports (which can be dynamic) chkModuleArgument inst_id (e, ws, varginfo) | isPort varginfo = do when doTraceClock $ traceM ("check Port module argument: " ++ (ppReadable e) ++ (ppReadable ws)) -- make an Id for error messages with the position of the instance -- but the name of the port let inst_pos = getIdPosition inst_id --inst_name = pfpString inst_id port_id = setIdPosition inst_pos (getVArgInfoName varginfo) -- check that the expression does not cross clock domains chkClockDomain "instance parameter" port_id ws e -- warn if the expression is associated with multiple resets chkResetDomain "instance parameter" port_id ws e -- find the clock name for the port -- (without the clockmap from "newState", -- we can't find the associated clock domain) let arg_clk = getVArgPortClock varginfo arg_rst = getVArgPortReset varginfo -- return the port info found return (Just (arg_clk, arg_rst, ws)) -- handle inouts (which have associated clock and reset that need checking) chkModuleArgument inst_id (e, ws, varginfo) | isInout varginfo = do when doTraceClock $ traceM ("check Inout module argument: " ++ (ppReadable e) ++ (ppReadable ws)) -- XXX sanity check that the "ws" doesn't have multiple domains -- XXX or multiple resets? -- find the clock name for the inout -- (without the clockmap from "newState", -- we can't find the associated clock domain) let arg_clk = getVArgInoutClock varginfo arg_rst = getVArgInoutReset varginfo -- return the port info found return (Just (arg_clk, arg_rst, ws)) -- handle the static arguments (clock, reset, parameter) chkModuleArgument inst_id (e, ws, varginfo) = do when doTraceClock $ traceM ("check other module argument: " ++ (ppReadable e) ++ (ppReadable ws)) let port_name = getIdString (getVArgInfoName varginfo) inst_name = getIdString inst_id inst_pos = getPosition inst_id when (not (wsIsEmpty ws)) $ do e' <- unheapAllNFNoImp e let errmsg = case varginfo of Param _ -> EModParameterDynamic inst_name port_name ClockArg _ -> EDynamicInputClock inst_name port_name ResetArg _ -> EDynamicInputReset inst_name port_name InoutArg {} -> EDynamicArgInout inst_name port_name Port _ _ _ -> internalError "chkModuleArgument: errmsg" -- This used to report (getIExprPosition e') which for mkReg is -- in the prelude! So we report the position of the instance name, -- which is known to be a better position: deferErrors [(inst_pos, errmsg)] -- XXX iParams could be inlined here -- these have no port info return Nothing -- After the clock map is available, we call this: chkModuleArgumentClkRst :: Id -> HStateVar -> (VArgInfo, HExpr, Maybe (Maybe Id, Maybe Id, HWireSet)) -> G () chkModuleArgumentClkRst inst_id isvar (varginfo, e, Just (mclk, mrst, ws)) | (isPort varginfo) = do let inst_pos = getPosition inst_id port_name = getIdString (getVArgInfoName varginfo) let expr_clkdom = case (wsGetClockDomain ws) of Just d -> d Nothing -> noClockDomain arg_clkdom = case (mclk) of Nothing -> noClockDomain Just clk -> getClockDomain (getNamedClock clk isvar) -- check that the expr clock matches the port clock -- (a noClock expr is OK in any clock domain, but if the port is -- expected to be noClock, then the expr better have no clock) when ( (expr_clkdom /= noClockDomain) && (arg_clkdom /= expr_clkdom) ) $ do let (port_clknames, port_hclks) = unzip $ [ (pfpString c, ic) | (c, ic) <- getClockMap isvar, getClockDomain ic == arg_clkdom ] expr_hclks = wsGetClocks ws let port_clks = nub $ map getClockOscString port_hclks expr_clks = nub $ map getClockOscString expr_hclks -- if the port is noClock, the clock info will be empty, -- so just tell the user "noClock"; otherwise, include -- some useful info let port_clkinfo = if (arg_clkdom == noClockDomain) then Nothing else Just (port_clknames, port_clks) -- XXX instead of just listing the expr_clks, should we list the -- XXX methods which contributed those clocks? deferErrors [(inst_pos, EPortExprClockDomain port_name port_clkinfo expr_clks)] -- warn if the reset of the expr doesn't match the reset of the port -- (note that we already warned if the expr has multiple resets) -- (a noReset value is OK for any port, but if the port is expected -- to be noReset, then the expr better have no reset, or we warn) let arg_rst = case (mrst) of Nothing -> noReset Just rst -> getNamedReset rst isvar case (wsGetResets ws) of [expr_rst] -> -- the expr has one reset; check if it matches the port -- (we could join the "arg_rst" to the wires -- and call wsCheckResets here, to not duplicate code) when ( (not (isNoReset expr_rst)) && (arg_rst /= expr_rst) ) $ do e' <- unheapAllNFNoImp e rms <- getMethodsByReset e' let ms = case rms of ((_, ms):_) -> ms _ -> [] -- internalError ? rst_name = case mrst of Just rst_id -> pfpString rst_id Nothing -> "no_reset" eWarning (inst_pos, WPortExprReset port_name rst_name ms) [] -> -- the expr has no reset, so it is OK to use anywhere return () rs -> -- the expr has multiple resets, so we've already reported a -- warning to the user return () chkModuleArgumentClkRst inst_id isvar (varginfo, e, Just (mclk, mrst, ws)) | (isInout varginfo) = do let inst_pos = getPosition inst_id port_name = getIdString (getVArgInfoName varginfo) let expr_clkdom = case (wsGetClockDomain ws) of Just d -> d Nothing -> noClockDomain arg_clkdom = case (mclk) of Nothing -> noClockDomain Just clk -> getClockDomain (getNamedClock clk isvar) -- check that the expr clock matches the port clock -- (there is no exception for noClock) when ( (arg_clkdom /= expr_clkdom) ) $ do let (port_clknames, port_hclks) = unzip $ [ (pfpString c, ic) | (c, ic) <- getClockMap isvar, getClockDomain ic == arg_clkdom ] expr_hclks = wsGetClocks ws let port_clks = nub $ map getClockOscString port_hclks expr_clks = nub $ map getClockOscString expr_hclks -- if the port is noClock, the clock info will be empty, -- so just tell the user "noClock"; otherwise, include -- some useful info let port_clkinfo = if (arg_clkdom == noClockDomain) then Nothing else Just (port_clknames, port_clks) expr_clkinfo = if (expr_clkdom == noClockDomain) then Nothing else Just expr_clks deferErrors [(inst_pos, EInoutExprClockDomain port_name port_clkinfo expr_clkinfo)] -- warn if the reset of the expr doesn't match the reset of the port -- (there is no exception for noReset) let arg_rst = case (mrst) of Nothing -> noReset Just rst -> getNamedReset rst isvar case (wsGetResets ws) of [expr_rst] -> -- the expr has one reset; check if it matches the port if (arg_rst /= expr_rst) then let rst_name = case mrst of Just rst_id -> pfpString rst_id Nothing -> "no_reset" in eWarning (inst_pos, WInoutExprReset port_name rst_name) else return () [] -> if (arg_rst /= noReset) then let rst_name = case mrst of Just rst_id -> pfpString rst_id Nothing -> "no_reset" in eWarning (inst_pos, WInoutExprReset port_name rst_name) else return () rs -> -- not possible for an Inout to have multiple resets? internalError ("chkModuleArgumentClkRst: " ++ "Inout with multiple resets: " ++ ppReadable rs) -- Other inputs should not have port info chkModuleArgumentClkRst inst_id isvar (varginfo, _, Nothing) | not ((isPort varginfo) || (isInout varginfo)) = return () -- Any other combination is unexpected chkModuleArgumentClkRst _ _ _ = internalError ("chkModuleArgumentClkRst") -- ----- -- drop methods clocked by noClock -- also remove duplicates and sort per clock (looking at string and position) -- required unheaped input in normal form (see unheapAllNFNoImp) getMethodsByClockDomain :: HExpr -> G [[(String, [(String, Position)])]] getMethodsByClockDomain e = do blobs <- getMethodsWithWires e let -- find all the method uses with clock domains -- (uses are a pair of a user-readable string and position, -- with the string first for sorting) meths = [(clk_dom, (clk, (str, getIdPosition i))) | (_, i, str, clk_dom, clk, _) <- blobs, clk_dom /= noClockDomain] -- sort and group by clock domain meths_by_domain = joinByFst meths -- turn each domain into a list of the clocks mkDomPair (_, d_ms) = do let -- sort and group by clock ms_by_clock = joinByFst d_ms -- turn each clock into a pair of the clock osc wire and the uses, -- removing duplicates and sorting the uses mkClkPair (c, c_ms) = do mcname <- boundaryClockToName c let cname = case mcname of Just i -> pfpString i Nothing -> getClockOscString c return (cname, nubSort c_ms) mapM mkClkPair ms_by_clock mapM mkDomPair meths_by_domain -- ----- -- drop methods reset by noReset -- also remove duplicates and sort per reset (looking at string and position) -- required unheaped input in normal form (see unheapAllNFNoImp) getMethodsByReset :: HExpr -> G [(String, [(String, Position)])] getMethodsByReset e = do blobs <- getMethodsWithWires e let -- find all the method uses with associated reset -- (uses are a pair of a user-readable string and position, -- with the string first for sorting) meths = [(rst, (str, getIdPosition i)) | (v, i, str, _, _, rst) <- blobs, not (isNoReset rst)] -- sort and group by reset meths_by_reset = joinByFst meths -- turn each reset into a pair of the reset wire and the uses, -- removing duplicates and sorting the uses mkRstPair (r, ms) = do mrname <- boundaryResetToName r let rname = case mrname of Just i -> pfpString i Nothing -> getResetString r return (rname, nubSort ms) mapM mkRstPair meths_by_reset -- ----- -- When we get the wires for an expression and it has more clocks or resets -- than expected, then we want a list of the method calls that contributed -- each clock and reset. This data type contains the info for that. -- -- * The object Id (or emptyId for input ports) -- * The method Id (or port Id) -- * User-readable string of the method application (or port name) -- * The clock domain -- * The clock -- * The reset -- type WireBlobTuple = (Id, Id, String, ClockDomain, HClock, HReset) getMethodsWithWires :: HExpr -> G [WireBlobTuple] getMethodsWithWires e = let ?mkvar = \ instId methId v -> let clk = getMethodClock methId v rst = getMethodReset methId v mstr = (getIdBaseString instId) ++ "." ++ (getIdBaseString methId) clk_dom = getClockDomain clk in return [(instId, methId, mstr, clk_dom, clk, rst)] ?mkport = \ i -> do port_wire_map <- lift get >>= return . port_wires let (clk, rst) = fromMaybe (noClock, noReset) (M.lookup i port_wire_map) clk_dom = getClockDomain clk mstr = getIdBaseString i return [(emptyId, i, mstr, clk_dom, clk, rst)] ?mkinout = \ i inout -> let clk = getInoutClock inout rst = getInoutReset inout clk_dom = getClockDomain clk str = getIdBaseString i in return [(emptyId, i, str, clk_dom, clk, rst)] ?mkws = \ _ -> Nothing ?z = [] ?jn = concat -- XXX why do include the position in the key? ?st = \ p pos ws -> do visited <- get put (S.insert (p, pos) visited) ?lk = \ p pos -> do visited <- get return $ if (p, pos) `S.member` visited then Just [] else Nothing ?upd = \ e_orig e -> do flgs <- lift getFlags return $ mapIExprPosition (crossInfo flgs) (e_orig, e) in evalStateT (extractWires e) S.empty -- ----- -- extract the dynamic wires (e.g. clocks, reset, etc.) from an elaboration-time object extractWireSet :: (Wireable a) => a -> G HWireSet extractWireSet x = let ?mkvar = \ _ methId v -> let clk = getMethodClock methId v rst = getMethodReset methId v in return $ wsAddReset rst (wsClock clk) ?mkport = \ i -> lift $ getPortWires i ?mkinout = \ _ inout -> return $ getInoutWires inout ?mkws = \ ws -> Just ws ?z = wsEmpty ?jn = wsJoinMany ?st = \ p _ ws -> lift $ updWireSetCache p ws ?lk = \ p _ -> do cache <- lift $ getWireSetCache return $ M.lookup p cache ?upd = \ e_orig e -> return e in evalStateT (extractWires x) S.empty -- ----- type W = StateT (S.Set (Int, Position)) G class Wireable a where extractWires :: (?mkvar :: Id -> Id -> HStateVar -> W b, ?mkport :: Id -> W b, ?mkinout :: Id -> HInout -> W b, ?mkws :: HWireSet -> Maybe b, ?z :: b, ?jn :: [b] -> b, ?st :: Int -> Position -> b -> W (), ?lk :: Int -> Position -> W (Maybe b), ?upd :: HExpr -> HExpr -> W HExpr) => a -> W b instance Wireable HExpr where extractWires (ILam i t e) = extractWires e -- method call extractWires (IAps (ICon methId (ICSel { })) _ ((ICon instId (ICStateVar { iVar = v })):es)) = do ws <- ?mkvar instId methId v wss <- mapM extractWires es return (?jn (ws:wss)) -- don't walk unnecessary parts of a struct or interface extractWires (IAps f@(ICon i_sel (ICSel { selNo = n })) _ (a@(IRefT _ p r):as)) = do -- we don't look for "p" in the WireSet cache, because we don't want to -- include the wires from the unused fields -- (presumably the fields will have their own refs, which can be cached) cell <- lift $ getHeap r let (P p e) = case cell of (HUnev { hc_hexpr = he }) -> P pTrue he (HWHNF { hc_pexpr = pe }) -> pe (HLoop name) -> internalError ("IExpand.extractWires HLoop: " ++ ppReadable name) (HNF { hc_pexpr = pe }) -> pe -- might "p" include wires from the other fields? p_ws <- extractWires p case e of (IAps (ICon i_tup (ICTuple {})) _ es) -> do let esel = if (length es > fromInteger n) then es!!(fromInteger n) else internalError("extractWires: ICSel: " ++ ppReadable (n, es)) a_wss <- mapM extractWires (esel:as) return (?jn (p_ws:a_wss)) (ICon instId (ICStateVar { iVar = v })) -> do ws <- ?mkvar instId i_sel v wss <- mapM extractWires as return (?jn (p_ws:ws:wss)) _ -> -- revert to the default handling of IAps -- (except no need to follow "f") do wss <- mapM extractWires (a:as) return (?jn wss) extractWires (IAps f _ es) = do ws <- mapM extractWires (f:es) return (?jn ws) extractWires (ILAM _ _ e) = extractWires e extractWires ref@(IRefT t p r) = do let pos = getIExprPosition ref cache_res <- ?lk p pos case cache_res of Just ws -> return ws Nothing -> do cell <- lift $ getHeap r ws <- case cell of -- XXX should be evaluated because clock ops are strict (HUnev { hc_hexpr = e }) -> ?upd ref e >>= extractWires (HWHNF { hc_pexpr = P p e }) -> ?upd ref e >>= \ e' -> extractWires (P p e') (HLoop name) -> internalError ("IExpand.extractWires HLoop: " ++ ppReadable name) (HNF { hc_pexpr = P p e, hc_wire_set = ws}) -> -- attempt to reuse the WireSet if possible case (?mkws ws) of Just v -> return v Nothing -> ?upd ref e >>= \ e' -> extractWires (P p e') ?st p pos ws return ws extractWires (ICon i (ICModPort {})) = ?mkport i extractWires (ICon i (ICInout { iInout = inout })) = ?mkinout i inout extractWires _ = return ?z instance Wireable (PTerm HeapData) where extractWires (PAtom e) = extractWires e extractWires (PIf c t e) = do ws1 <- extractWires c ws2 <- extractWires t ws3 <- extractWires e return (?jn [ws1,ws2,ws3]) extractWires (PSel idx _ es) = do ws1 <- extractWires idx wss <- mapM extractWires es return (?jn (ws1:wss)) instance Wireable HPred where extractWires (PConj ps) = do wss <- mapM extractWires (S.toList ps) return (?jn wss) instance Wireable PExpr where extractWires (P p e) = do ws1 <- extractWires p ws2 <- extractWires e return (?jn [ws1,ws2]) ----------------------------------------------------------------------------- realPrimOp :: PrimOp -> Bool realPrimOp PrimAdd = True realPrimOp PrimSub = True realPrimOp PrimAnd = True realPrimOp PrimOr = True realPrimOp PrimXor = True realPrimOp PrimMul = True realPrimOp PrimQuot = True realPrimOp PrimRem = True realPrimOp PrimSL = True realPrimOp PrimSRL = True realPrimOp PrimSRA = True realPrimOp PrimInv = True realPrimOp PrimNeg = True realPrimOp PrimEQ = True realPrimOp PrimEQ3 = True realPrimOp PrimULE = True realPrimOp PrimULT = True realPrimOp PrimSLE = True realPrimOp PrimSLT = True realPrimOp PrimSignExt = True --realPrimOp PrimZeroExt = True -- should not occur --realPrimOp PrimTrunc = True -- should not occur realPrimOp PrimExtract = True realPrimOp PrimConcat = True realPrimOp PrimSplit = True realPrimOp PrimBNot = True realPrimOp PrimBAnd = True realPrimOp PrimBOr = True realPrimOp PrimIf = True realPrimOp PrimSelect = True realPrimOp PrimArrayDynSelect = True realPrimOp PrimArrayDynUpdate = True -- realPrimOp PrimJoinActions = True realPrimOp PrimNoActions = True realPrimOp PrimExpIf = True realPrimOp PrimNoExpIf = True realPrimOp PrimNosplitDeep = True realPrimOp PrimSplitDeep = True realPrimOp PrimFmtConcat = True realPrimOp PrimSetSelPosition = True realPrimOp PrimStringConcat = True realPrimOp _ = False ----------------------------------------------------------------------------- integerPrim :: PrimOp -> Bool integerPrim PrimIntegerAdd = True integerPrim PrimIntegerSub = True integerPrim PrimIntegerNeg = True integerPrim PrimIntegerMul = True integerPrim PrimIntegerDiv = True integerPrim PrimIntegerMod = True integerPrim PrimIntegerQuot = True integerPrim PrimIntegerRem = True integerPrim PrimIntegerExp = True integerPrim PrimIntegerLog2 = True integerPrim PrimIntegerEQ = True integerPrim PrimIntegerLE = True integerPrim PrimIntegerLT = True integerPrim PrimIntegerToReal = True integerPrim PrimBitsToReal = True integerPrim _ = False ----------------------------------------------------------------------------- realPrim :: PrimOp -> Bool realPrim PrimRealEQ = True realPrim PrimRealLE = True realPrim PrimRealLT = True realPrim PrimRealToString = True realPrim PrimRealAdd = True realPrim PrimRealSub = True realPrim PrimRealNeg = True realPrim PrimRealMul = True realPrim PrimRealDiv = True realPrim PrimRealAbs = True realPrim PrimRealSignum = True realPrim PrimRealExpE = True realPrim PrimRealPow = True realPrim PrimRealLogE = True realPrim PrimRealLogBase = True realPrim PrimRealLog2 = True realPrim PrimRealLog10 = True realPrim PrimRealToBits = True realPrim PrimBitsToReal = True realPrim PrimRealSin = True realPrim PrimRealCos = True realPrim PrimRealTan = True realPrim PrimRealSinH = True realPrim PrimRealCosH = True realPrim PrimRealTanH = True realPrim PrimRealASin = True realPrim PrimRealACos = True realPrim PrimRealATan = True realPrim PrimRealASinH = True realPrim PrimRealACosH = True realPrim PrimRealATanH = True realPrim PrimRealATan2 = True realPrim PrimRealSqrt = True realPrim PrimRealTrunc = True realPrim PrimRealCeil = True realPrim PrimRealFloor = True realPrim PrimRealRound = True realPrim PrimSplitReal = True realPrim PrimDecodeReal = True realPrim PrimRealToDigits = True realPrim PrimRealIsInfinite = True realPrim PrimRealIsNegativeZero = True realPrim _ = False ----------------------------------------------------------------------------- -- ops that only take arguments (one or two) of type String -- (IExpand uses this to handle multiple ops in one arm of "conAp'") stringPrim :: PrimOp -> Bool stringPrim PrimStringConcat = True stringPrim PrimStringEQ = True stringPrim PrimStringToInteger = True stringPrim PrimStringLength = True stringPrim PrimStringSplit = True stringPrim PrimStringToChar = True stringPrim PrimGetStringPosition = True stringPrim _ = False -- ops that only take an argument of type Char -- (IExpand uses this to handle multiple ops in one arm of "conAp'") charPrim :: PrimOp -> Bool charPrim PrimCharToString = True charPrim PrimCharOrd = True charPrim _ = False ----------------------------------------------------------------------------- -- ops that are Boolean queries on one argument of type Handle -- (IExpand uses this to handle them all in one arm of "conAp'") handleBoolPrim :: PrimOp -> Bool handleBoolPrim PrimHandleIsEOF = True handleBoolPrim PrimHandleIsOpen = True handleBoolPrim PrimHandleIsClosed = True handleBoolPrim PrimHandleIsReadable = True handleBoolPrim PrimHandleIsWritable = True handleBoolPrim _ = False ----------------------------------------------------------------------------- strictPrim :: PrimOp -> Bool strictPrim PrimAdd = True strictPrim PrimSub = True strictPrim PrimAnd = True strictPrim PrimOr = True strictPrim PrimXor = True strictPrim PrimMul = True strictPrim PrimQuot = True strictPrim PrimRem = True strictPrim PrimSL = True strictPrim PrimSRL = True strictPrim PrimSRA = True strictPrim PrimInv = True strictPrim PrimNeg = True strictPrim PrimEQ = True strictPrim PrimEQ3 = True strictPrim PrimULE = True strictPrim PrimULT = True strictPrim PrimSLE = True strictPrim PrimSLT = True strictPrim PrimSignExt = True strictPrim PrimZeroExt = True strictPrim PrimTrunc = True strictPrim PrimExtract = True strictPrim PrimConcat = True strictPrim PrimSplit = True strictPrim PrimBNot = True strictPrim PrimSelect = True strictPrim PrimBitToInteger = True strictPrim PrimValueOf = True strictPrim PrimStringOf = True strictPrim PrimOrd = True strictPrim PrimChr = True strictPrim PrimSameFamilyClock = True strictPrim PrimIsAncestorClock = True strictPrim PrimClockEQ = True strictPrim PrimClockOf = True strictPrim PrimClocksOf = True strictPrim PrimResetOf = True strictPrim PrimResetsOf = True strictPrim PrimResetEQ = True strictPrim PrimGetStringPosition = True strictPrim PrimPrintPosition = True strictPrim PrimPrintType = True strictPrim PrimTypeEQ = True strictPrim PrimIsIfcType = True strictPrim PrimJoinNames = True strictPrim PrimExtendNameInteger = True strictPrim PrimGetNamePosition = True strictPrim PrimGetNameString = True strictPrim PrimMakeName = True strictPrim PrimFmtConcat = True strictPrim _ = False ----------------------------------------------------------------------------- -- When eval to NF returns one of these primitives, it is because the user -- wrote a dynamic expression; this is used to detect when to report a better -- error than nfError -- condPrim :: PrimOp -> Bool condPrim PrimIf = True condPrim PrimCase = True condPrim PrimArrayDynSelect = True condPrim _ = False -- ############################################################################# -- # Methods for carrying along Id Position info through IExpr -- # transformations. -- ############################################################################# mapPExprPosition :: Bool -> (PExpr,PExpr) -> G PExpr mapPExprPosition doit ((P pred_0 iexpr_0), (P pred_1 iexpr_1)) = do return (P pred_1 (mapIExprPosition2 doit (iexpr_0, iexpr_1))) ----------------------------------------------------------------------------- isNoInlinedFunc :: G Bool isNoInlinedFunc = gets noinlined_func isAggressive :: G Bool isAggressive = gets aggressive_cond setAggressive :: Bool -> G () setAggressive x = modify (\s -> s{aggressive_cond=x}) getPragmas :: G [PProp] getPragmas = gets pragmas setPragmas :: [PProp] -> G () setPragmas x = modify (\s -> s {pragmas=x}) -----------------------------------------------------------------------------