module PragmaCheck ( checkModuleArgPragmas, checkModulePortNames, ArgInfo(..), extractVTPairs, renamePProps ) where import qualified Data.Map as M import Control.Monad(msum) import Data.List(groupBy, sort, partition, nub, intersect) import Data.Maybe(listToMaybe, mapMaybe, catMaybes, fromMaybe) import Util(thd, fst3, headOrErr, fromJustOrErr) import Verilog(vKeywords, vIsValidIdent) import Error(internalError, EMsg, ErrMsg(..)) import ErrorMonad(ErrorMonad(..)) import PFPrint import Position import Id import PreIds(idDefaultClock, idDefaultReset, idCLK, idCLK_GATE, idPrimAction, idActionValue_, mk_no) import FStringCompat import PreStrings(fsUnderscore) import Flags(Flags(..)) import Pragma import CType import Type(tClock, tReset, tInout_) -- ============================== data ArgInfo = Simple Id CType -- Bool tracks Vector vs. ListN | Vector Bool Id CType [ArgInfo] extractVTPairs :: ArgInfo -> [(Id, CType)] extractVTPairs (Vector _ _ _ ais) = concatMap extractVTPairs ais extractVTPairs (Simple v t) = [(v,t)] -- adjust PProps to account for Vector arguments renamePProps :: [(Id, CType, ArgInfo)] -> [PProp] -> [PProp] renamePProps vtis pps = let renameMap = M.fromList [ (i_orig, new_is) | (i_orig, _, ai@(Vector {})) <- vtis, let new_is = map fst (extractVTPairs ai) ] fixPProp (PPclock_osc is) = (PPclock_osc (concatMap fixRenameProp is)) fixPProp (PPclock_gate is) = (PPclock_gate (concatMap fixRenameProp is)) fixPProp (PPreset_port is) = (PPreset_port (concatMap fixRenameProp is)) fixPProp (PParg_param is) = (PParg_param (concatMap fixRenameProp is)) fixPProp (PParg_port is) = (PParg_port (concatMap fixRenameProp is)) fixPProp (PParg_clocked_by is) = (PParg_clocked_by (concatMap fixClkRstProp is)) fixPProp (PParg_reset_by is) = (PParg_reset_by (concatMap fixClkRstProp is)) fixPProp (PPgate_inhigh is) = (PPgate_inhigh (concatMap fixSetProp is)) fixPProp (PPgate_unused is) = (PPgate_unused (concatMap fixSetProp is)) fixPProp (PPparam is) = (PPparam (concatMap fixSetProp is)) fixPProp (PPgate_input_clocks is) = (PPgate_input_clocks (concatMap fixSetProp is)) fixPProp p = p fixSetProp :: Id -> [Id] fixSetProp i1 = fromMaybe [i1] (M.lookup i1 renameMap) fixClkRstProp :: (Id, String) -> [(Id, String)] fixClkRstProp (i1,s) = case (M.lookup i1 renameMap) of Just new_is -> [ (new_i,s) | new_i <- new_is ] Nothing -> [(i1,s)] fixRenameProp :: (Id, String) -> [(Id, String)] fixRenameProp (i1,s) = let istr = getIdBaseString i1 rename i2 str = let i2str = getIdBaseString i2 suf = drop (length istr) i2str in str ++ suf in case (M.lookup i1 renameMap) of Just new_is -> [ (new_i,rename new_i s) | new_i <- new_is ] Nothing -> [(i1,s)] in map fixPProp pps -- ============================== -- Initial sanity check of module pragmas relating to module arguments modifies :: Id -> PProp -> Bool modifies n (PPclock_osc ps) = n `elem` (map fst ps) modifies n (PPclock_gate ps) = n `elem` (map fst ps) modifies n (PPreset_port ps) = n `elem` (map fst ps) modifies n (PParg_param ps) = n `elem` (map fst ps) modifies n (PParg_port ps) = n `elem` (map fst ps) modifies n (PParg_clocked_by ps) = n `elem` (map fst ps) modifies n (PParg_reset_by ps) = n `elem` (map fst ps) modifies n (PPgate_inhigh is) = n `elem` is modifies n (PPgate_unused is) = n `elem` is modifies n (PPparam is) = n `elem` is modifies _ _ = False isParam :: PProp -> Bool isParam (PPparam _) = True isParam (PParg_param _) = True isParam _ = False isOscOrGate :: PProp -> Bool isOscOrGate (PPclock_osc _) = True isOscOrGate (PPclock_gate _) = True isOscOrGate (PPgate_inhigh _) = True isOscOrGate (PPgate_unused _) = True isOscOrGate _ = False isReset :: PProp -> Bool isReset (PPreset_port _) = True isReset (PParg_clocked_by _) = True isReset _ = False isArg :: PProp -> Bool isArg (PParg_port _) = True isArg (PParg_clocked_by _) = True isArg (PParg_reset_by _) = True isArg _ = False checkArgType :: (PProp -> Bool) -> String -> (Id, [PProp]) -> Maybe EMsg checkArgType ok reason (arg, ps) = let bad = filter (not . ok) ps in case bad of [] -> Nothing (pp:_) -> Just (getPosition arg, EAttributeOnWrongArgType (getModulePragmaName pp) (getIdBaseString arg) reason) checkArgName :: [String] -> Position -> PProp -> Maybe EMsg checkArgName arg_names pos pp = let ns = getPragmaArgNames (sanitize pp) in listToMaybe [ (pos, EAttributeNoSuchArg (getModulePragmaName pp) n) | n <- ns , n `notElem` arg_names ] where ignored = [ idDefaultClock, idDefaultReset ] ignored2 = zip ignored (repeat "") fixed xs ign = [ x | x <- xs, x `notElem` ign ] sanitize (PPclock_osc ps) = PPclock_osc (fixed ps ignored2) sanitize (PPreset_port ps) = PPreset_port (fixed ps ignored2) sanitize (PPgate_inhigh is) = PPgate_inhigh (fixed is ignored) sanitize (PPgate_unused is) = PPgate_unused (fixed is ignored) sanitize pp = pp checkArgClockedBy :: [String] -> (Id, [PProp]) -> Maybe EMsg checkArgClockedBy clk_names (arg, ps) = let mclk = listToMaybe $ catMaybes $ [ lookup arg xs | PParg_clocked_by xs <- ps ] in case mclk of Just str | (str `notElem` clk_names) -> let arg_pos = getPosition arg in Just (arg_pos, EClockedByBadName str clk_names) _ -> Nothing checkArgResetBy :: [String] -> (Id, [PProp]) -> Maybe EMsg checkArgResetBy rst_names (arg, ps) = let mrst = listToMaybe $ catMaybes $ [ lookup arg xs | PParg_reset_by xs <- ps ] in case mrst of Just str | (str `notElem` rst_names) -> let arg_pos = getPosition arg in Just (arg_pos, EResetByBadName str rst_names) _ -> Nothing -- This is the entry point for sanity checking module argument pragmas -- (even when not synthesizing the module, these checks can be made) checkModuleArgPragmas :: Position -> [PProp] -> [PProp] -> [(Id, CType, ArgInfo)] -> ErrorMonad () checkModuleArgPragmas pos pps_orig pps vtis = let -- --------------- -- compute pragma info for each port -- ---------- -- implicit clock and reset arguments default_clk_arg = if (hasDefaultClk pps) then let id = setIdPosition pos idDefaultClock ty = tClock in [(id, ty, Simple id ty)] else [] default_rst_arg = if (hasDefaultRst pps) then let id = setIdPosition pos idDefaultReset ty = tReset in [(id, ty, Simple id ty)] else [] -- ---------- -- Functions to identify the type of arguments isVector (Vector {}) = True isVector (Simple {}) = False isCoreTypeOf t (Simple i it) = (it == t) isCoreTypeOf t (Vector _ _ it []) = (it == t) isCoreTypeOf t (Vector _ _ it is) = (it == t) || isCoreTypeOf t (headOrErr "isCoreTypeOf" is) -- we could check "t", but "i" also contains the type isClk (_,t,i) = isCoreTypeOf tClock i isRst (_,t,i) = isCoreTypeOf tReset i -- save effort by looking in the pre-expanded PProps isParamArg (i,_,_) = isParamModArg pps_orig i -- ---------- -- Separate the arguments by type (cs,others) = partition isClk vtis (rs,others') = partition isRst others (params,ports) = partition isParamArg others' clks = default_clk_arg ++ cs rsts = default_rst_arg ++ rs -- expand the arg names (for Vector) and pair the arg names -- with the PProp which modify them (using the PProps which -- have themselves been expanded) clk_info = [ (i, ps) | (i, _, Simple {}) <- clks, let ps = filter (modifies i) pps ] ++ [ (i, ps) | (_, _, Vector _ _ _ ais) <- clks, (i,_) <- concatMap extractVTPairs ais, let ps = filter (modifies i) pps ] rst_info = [ (i, ps) | (i, _, Simple {}) <- rsts, let ps = filter (modifies i) pps ] ++ [ (i, ps) | (_, _, Vector _ _ _ ais) <- rsts, (i,_) <- concatMap extractVTPairs ais, let ps = filter (modifies i) pps ] port_info = [ (i, ps) | (i, _, Simple {}) <- ports, let ps = filter (modifies i) pps ] ++ [ (i, ps) | (_, _, Vector _ _ _ ais) <- ports, (i,_) <- concatMap extractVTPairs ais, let ps = filter (modifies i) pps ] param_info = [ (i, ps) | (i, _, Simple {}) <- params, let ps = filter (modifies i) pps ] ++ [ (i, ps) | (_, _, Vector _ _ _ ais) <- params, (i,_) <- concatMap extractVTPairs ais, let ps = filter (modifies i) pps ] all_info = clk_info ++ rst_info ++ port_info ++ param_info -- --------------- -- it is an error if there is an empty clock/reset prefix and no name -- given for a default clock/reset emsg0 = let clk_prefix = listToMaybe [ s | PPCLK s <- pps ] ps = filter (modifies idDefaultClock) pps default_clock_osc = listToMaybe $ catMaybes $ [ lookup idDefaultClock xs | PPclock_osc xs <- ps ] in case (clk_prefix, default_clock_osc) of (Just "", Nothing) -> Just (pos, EEmptyPrefixNoPortName (getIdBaseString idDefaultClock)) _ -> Nothing emsg1 = let gate_prefix = listToMaybe [ s | PPGATE s <- pps ] ps = filter (modifies idDefaultClock) pps default_clock_gate = listToMaybe $ catMaybes $ [ lookup idDefaultClock xs | PPclock_gate xs <- ps ] in case (gate_prefix, default_clock_gate) of (Just "", Nothing) -> Just (pos, EEmptyPrefixNoPortName (getIdBaseString idDefaultClock)) _ -> Nothing emsg2 = let rst_prefix = listToMaybe [ s | PPRSTN s <- pps ] ps = filter (modifies idDefaultReset) pps default_reset_port = listToMaybe $ catMaybes $ [ lookup idDefaultReset xs | PPreset_port xs <- ps ] in case (rst_prefix, default_reset_port) of (Just "", Nothing) -> Just (pos, EEmptyPrefixNoPortName (getIdBaseString idDefaultReset)) _ -> Nothing -- --------------- -- it is an error if a clock is listed as both gated and ungated gated_clks = concat [ is | PPgate_input_clocks is <- pps ] ungated_clks = nub $ concat ([ is | PPgate_inhigh is <- pps ] ++ [ is | PPgate_unused is <- pps ]) conflicted_clks = gated_clks `intersect` ungated_clks emsg3 = case conflicted_clks of (i:_) -> Just (getPosition i, EConflictingGateAttr (getIdBaseString i)) [] -> Nothing -- --------------- -- it is an error to apply an attribute to a param or to an -- argument of the wrong type emsg4 = msum $ concat $ [ map (checkArgType isOscOrGate "a Clock") clk_info , map (checkArgType isReset "a Reset") rst_info , map (checkArgType isArg "a port argument") port_info , map (checkArgType isParam "a parameter, not a module port") param_info ] -- --------------- -- it is an error to apply an attribute to a non-existent argument all_args = [ getIdBaseString i | (i,_) <- all_info ] emsg5 = msum $ map (checkArgName all_args pos) pps -- --------------- -- it is an error if the associated clock is not one of the input clks -- XXX don't allow reference to vector clocks yet clks_nonvec = filter (not . isVector . thd) clks clk_names = ["no_clock"] ++ map (getIdBaseString . fst3) clks_nonvec emsg6 = msum $ map (checkArgClockedBy clk_names) -- only need to check resets and ports (rst_info ++ port_info) -- --------------- -- it is an error if the associated reset is not one of the input rsts -- XXX don't allow reference to vector resets yet rsts_nonvec = filter (not . isVector . thd) rsts rst_names = ["no_reset"] ++ map (getIdBaseString . fst3) rsts_nonvec emsg7 = msum $ map (checkArgResetBy rst_names) -- only need to check ports port_info -- --------------- -- report any errors or warnings in case (msum [ emsg0, emsg1, emsg2, emsg3 , emsg4, emsg5, emsg6, emsg7 ]) of (Just e) -> EMError [e] Nothing -> EMResult () -- ============================== -- Check port names (for clash, keyword clash, non-verilog Id) data ArgPortInfo = API { api_arg :: Id -- arg name , api_type :: CType -- arg type -- whether the arg is a Vector element -- and the original name of the argument , api_vector :: Maybe Id , api_prefix :: Maybe String -- user-given prefix , api_given_name :: Maybe String -- user-given name , api_port :: Maybe Id -- port Id, if exists } deriving (Show) -- get the name as the user knows it; for Vectors, this is different -- than "pi_arg" getAPIArgName :: ArgPortInfo -> Id getAPIArgName (API { api_vector = Just i }) = i getAPIArgName (API { api_arg = i }) = i mkPortName :: Id -> Maybe String -> Maybe String -> Id -> Id mkPortName _ _ (Just n) i = setIdBaseString i n mkPortName _ (Just pfx) Nothing i | pfx == "" = i | i == emptyId = setIdBaseString i pfx | otherwise = mkIdPre (concatFString [(mkFString pfx), fsUnderscore]) i mkPortName def_pfx Nothing Nothing i | def_pfx == emptyId = i | i == emptyId = setIdBase i (getIdBase def_pfx) | otherwise = mkIdPre (concatFString [(getIdBase def_pfx), fsUnderscore]) i -- This is the entry point for checking module port names (both arguments -- and interface ports). This is checkModulePortNames :: Flags -> Position -> [PProp] -> -- argument info [(Id, CType, ArgInfo)] -> -- interface info [(Id, CType, [IfcPragma])] -> -- return the mapping from argument port to type ErrorMonad [(Id, CType)] checkModulePortNames flgs pos pps vtis ftps = let idrstn = (mk_no . mkFString . resetName) flgs -- --------------- -- Get the prefixes osc_prefix = listToMaybe [ s | PPCLK s <- pps ] gate_prefix = listToMaybe [ s | PPGATE s <- pps ] rst_prefix = listToMaybe [ s | PPRSTN s <- pps ] -- --------------- -- compute naming info for each module argument -- ---------- -- implicit clock and reset arguments default_clk_arg = if (hasDefaultClk pps) then let id = setIdPosition pos idDefaultClock ty = tClock in [(id, ty, Simple id ty)] else [] default_rst_arg = if (hasDefaultRst pps) then let id = setIdPosition pos idDefaultReset ty = tReset in [(id, ty, Simple id ty)] else [] -- ---------- -- Functions to identify the type of arguments isCoreTypeOf t (Simple i it) = (it == t) isCoreTypeOf t (Vector _ _ it []) = (it == t) isCoreTypeOf t (Vector _ _ it is) = (it == t) || isCoreTypeOf t (headOrErr "isCoreTypeOf" is) -- we could check "t", but "i" also contains the type isClk (_,t,i) = isCoreTypeOf tClock i isRst (_,t,i) = isCoreTypeOf tReset i -- ---------- -- Separate the arguments by type (cs,others) = partition isClk vtis (rs,others') = partition isRst others (params,ports) = partition (\(i,_,_) -> isParamModArg pps i) others' clks = default_clk_arg ++ cs gates = filter (\(i,_,_) -> isGatedInputClk pps i) clks rsts = default_rst_arg ++ rs clk_arg_oscs = let mkOscPort (i,t,mv) = let ps = filter (modifies i) pps name = listToMaybe $ catMaybes $ [ lookup i xs | PPclock_osc xs <- ps ] -- default clock base name is "" i' = if (i == idDefaultClock) then setIdBaseString i "" else i port = Just (mkPortName idCLK osc_prefix name i') in (API i t mv osc_prefix name port) in [ mkOscPort (i,t,Nothing) | (i,t,Simple {}) <- clks ] ++ [ mkOscPort (i,t,Just i_orig) | (i_orig,_,Vector _ _ _ ais) <- clks, (i,t) <- concatMap extractVTPairs ais ] clk_arg_gates = let mkGatePort (i,t,mv) = let ps = filter (modifies i) pps n0 = catMaybes $ [ lookup i xs | PPclock_gate xs <- ps ] n1 = [ "" | PPgate_inhigh is <- ps, i `elem` is ] n2 = [ "" | PPgate_unused is <- ps, i `elem` is ] name = listToMaybe (n2 ++ n1 ++ n0) -- default clock base name is "" i' = if (i == idDefaultClock) then setIdBaseString i "" else i port = if (null n1 && null n2) then Just (mkPortName idCLK_GATE gate_prefix name i') else Nothing in (API i t mv gate_prefix name port) in [ mkGatePort (i,t,Nothing) | (i,t,Simple {}) <- gates ] ++ [ mkGatePort (i,t,Just i_orig) | (i_orig,_,Vector _ _ _ ais) <- gates, (i,t) <- concatMap extractVTPairs ais ] rst_arg_ports = let mkRstPort (i,t,mv) = let ps = filter (modifies i) pps name = listToMaybe $ catMaybes $ [ lookup i xs | PPreset_port xs <- ps ] -- default reset base name is "" i' = if (i == idDefaultReset) then setIdBaseString i "" else i port = Just (mkPortName idrstn rst_prefix name i') in (API i t mv rst_prefix name port) in [ mkRstPort (i,t,Nothing) | (i,t,Simple {}) <- rsts ] ++ [ mkRstPort (i,t,Just i_orig) | (i_orig,_,Vector _ _ _ ais) <- rsts, (i,t) <- concatMap extractVTPairs ais ] port_arg_ports = let mkPort (i,t,mv) = let ps = filter (modifies i) pps name = listToMaybe $ catMaybes $ [ lookup i xs | PParg_port xs <- ps ] port = Just (mkPortName emptyId Nothing name i) in (API i t mv Nothing name port) in [ mkPort (i,t,Nothing) | (i,t,Simple {}) <- ports ] ++ [ mkPort (i,t,Just i_orig) | (i_orig,_,Vector _ _ _ ais) <- ports, (i,t) <- concatMap extractVTPairs ais ] param_arg_params = let mkParam (i,t,mv) = let ps = filter (modifies i) pps name = listToMaybe $ catMaybes $ [ lookup i xs | PParg_param xs <- ps ] param = Just (mkPortName emptyId Nothing name i) in (API i t mv Nothing name param) in [ mkParam (i,t,Nothing) | (i,t,Simple {}) <- params ] ++ [ mkParam (i,t,Just i_orig) | (i_orig,_,Vector _ _ _ ais) <- params, (i,t) <- concatMap extractVTPairs ais ] all_arg_info = clk_arg_oscs ++ clk_arg_gates ++ rst_arg_ports ++ port_arg_ports ++ param_arg_params -- --------------- -- compute naming info for each the provided interface fields isClkField (_,t,_) = t == tClock isRstField (_,t,_) = t == tReset isInoutField (_,t,_) = case t of (TAp tt _) | (tt == tInout_) -> True _ -> False getMString :: Maybe String -> String getMString (Just str) = str getMString Nothing = internalError ("getMString: empty field") (clk_fs, other_fs) = partition isClkField ftps (rst_fs, other_fs') = partition isRstField other_fs (iot_fs, method_fs) = partition isInoutField other_fs' ifc_clock_ports = let mkClockPorts (i,_,ps) = let mpref = getClockPragmaInfo ps -- convert to Id and back, to reuse "mkPortName" pref_id = mk_homeless_id $ getMString $ mpref osc = mkPortName idCLK osc_prefix Nothing pref_id gate = mkPortName idCLK_GATE gate_prefix Nothing pref_id in [(getIdBaseString osc, i), (getIdBaseString gate, i)] in concatMap mkClockPorts clk_fs ifc_reset_ports = let mkResetPort (i,_,ps) = let mpref = getResetPragmaInfo ps -- convert to Id and back, to reuse "mkPortName" pref_id = mk_homeless_id $ getMString $ mpref p = mkPortName idrstn rst_prefix Nothing pref_id in (getIdBaseString p, i) in map mkResetPort rst_fs ifc_inout_ports = let mkInoutPort (i,t,ps) = let pref = getMString $ getInoutPragmaInfo ps in (pref, i) in map mkInoutPort iot_fs ifc_method_ports = let mkMethodPorts (i,t,ps) = let resType = getRes t resTypeId = fromJustOrErr ("ifc_method_ports: " ++ ppReadable t) (leftCon resType) -- XXX can PrimAction ever occur? -- XXX (Maybe if explicitly written?) -- The types Action and ActionValue (which should be the -- only types written by the user) become ActionValue_ -- in the flattened interface (with Action being size 0). -- So ActionValue_ should be only type seen. isPA = (qualEq resTypeId idPrimAction) isAV = (qualEq resTypeId idActionValue_) -- If the user wrote "Action" the flattened ifc is -- ActionValue_#(0). If the user wrote ActionValue#(t) -- then the flattened ifc is ActionValue#(sz), where -- "sz" is a variable reference in context Bits#(t,sz). -- If GenWrap did ctxReduce, then these variables would -- go away (if not, then we'd error, as iExpand does -- now). In the meantime, just look for explicit 0. isAV0 = case resType of (TAp (TCon (TyCon av _ _)) (TCon (TyNum n _))) | qualEq av idActionValue_ -> (n == 0) _ -> False (mpref, mres, mrdy, men, argids, ar, ae) = getMethodPragmaInfo ps res = if (isPA || isAV0) then [] else [getMString mres] rdy = if (ar) then [] else [getMString mrdy] en = if (not ae) && (isAV || isPA) then [getMString men] else [] argToName :: String -> Id -> String argToName pstr aid = joinStrings_ pstr (getIdString aid) args = map (argToName (getMString mpref)) argids in if (isRdyId i) then [] else zip (res ++ rdy ++ en ++ args) (repeat i) in concatMap mkMethodPorts method_fs all_ifc_info = ifc_clock_ports ++ ifc_reset_ports ++ ifc_inout_ports ++ ifc_method_ports -- --------------- -- check that no arg port name clashes with another port name and -- check that no arg port name clashes with a Verilog keyword and -- check that each arg port name is a valid Verilog identifier -- We also check that param arguments do not clash, but note that -- XXX parameters will be referred to as "ports" in the error message arg_names = sort [ (getIdBaseString n, getAPIArgName api) | api@(API { api_port = Just n }) <- all_arg_info ] arg_same_name = filter (\xs -> (length xs) > 1) $ groupBy (\(n1,_) (n2,_) -> n1 == n2) arg_names arg_kw_clash = filter (\(n,_) -> n `elem` vKeywords) arg_names arg_bad_ident = filter (\(n,_) -> not (vIsValidIdent n)) arg_names emsgs0 = let mkErr xs = let ns = [(n, getPosition i, getIdBaseString i) | (n,i) <- xs ] in (pos, EPortsSameName ns) in map mkErr arg_same_name emsgs1 = let mkErr (n,i) = (getPosition i, EPortKeywordClash n) in map mkErr arg_kw_clash emsgs2 = let mkErr (n,i) = (getPosition i, EPortNotValidIdent n) in map mkErr arg_bad_ident -- --------------- -- check that no ifc port name clashes with another port name and -- check that no ifc port name clashes with a Verilog keyword and -- check that each ifc port name is a valid Verilog identifier ifc_names = sort all_ifc_info ifc_same_name = filter (\xs -> (length xs) > 1) $ groupBy (\(n1,_) (n2,_) -> n1 == n2) ifc_names ifc_kw_clash = filter (\(n,_) -> n `elem` vKeywords) ifc_names ifc_bad_ident = filter (\(n,_) -> not (vIsValidIdent n)) ifc_names emsgs3 = let mkErr xs = let ns = [(n, getPosition i, getIdBaseString i) | (n,i) <- xs ] in case ns of ((v,p1,m1):(_,p2,m2):_) -> (p1, EPortNamesClashFromMethod m1 m2 v p2) _ -> internalError ("emsg3: impossible") in map mkErr ifc_same_name emsgs4 = let mkErr (n,i) = (getPosition i, EPortKeywordClashFromMethod (getIdBaseString i) n) in map mkErr ifc_kw_clash emsgs5 = let mkErr (n,i) = (getPosition i, EPortNotValidIdentFromMethod (getIdBaseString i) n) in map mkErr ifc_bad_ident -- --------------- -- check that no arg port clashes with an ifc port ifc_ports_map = M.fromList ifc_names findIfcPortName api@(API { api_port = Just p }) = case (M.lookup (getIdBaseString p) ifc_ports_map) of Nothing -> Nothing Just m -> Just (p, m, getAPIArgName api) findIfcPortName (API { api_port = Nothing }) = Nothing arg_ifc_dups = catMaybes $ map findIfcPortName all_arg_info emsgs6 = let mkErr (p,m,a) = (pos, EPortNamesClashArgAndIfc (pfpString p) (pfpString a) (pfpString m) (getPosition m)) in map mkErr arg_ifc_dups -- --------------- -- warn if a prefix is supplied but never used prefixes = [ osc_prefix, gate_prefix, rst_prefix ] uses_prefix (API _ _ _ (Just _) Nothing _) = True uses_prefix _ = False osc_prefix_used = (any uses_prefix clk_arg_oscs) || -- output clocks use the prefix (not (null clk_fs)) gate_prefix_used = (any uses_prefix clk_arg_gates) || -- output clocks always have a gate (for now) (not (null clk_fs)) reset_prefix_used = (any uses_prefix rst_arg_ports) || -- output resets use the prefix (not (null rst_fs)) prefix_used = [ osc_prefix_used, gate_prefix_used, reset_prefix_used ] pfx_tuples = zip3 ["clock", "gate", "reset"] prefixes prefix_used wmsgs0 = [ (pos, WUnusedPrefix k pfx) | (k,(Just pfx),False) <- pfx_tuples ] -- --------------- -- warn if gate_all_clocks is overridden on every clock -- output clocks are always gated (for now), so they are not -- included in this check all_gated = any null [ is | PPgate_input_clocks is <- pps ] no_ports = null (mapMaybe api_port clk_arg_gates) wmsgs1 = if (all_gated && no_ports) then [(pos, WGateAllClocksIgnored)] else [] -- --------------- -- compute the result: -- a mapping from module argument port names to the types -- for now, just args and inouts (no clock, reset, or param) porttypes = [ (n,t) |( API { api_port = Just n, api_type = t }) <- port_arg_ports ] result = porttypes -- --------------- -- report any errors or warnings -- report all errors, since none trump any others emsgs = emsgs0 ++ emsgs1 ++ emsgs2 ++ emsgs3 ++ emsgs4 ++ emsgs5 ++ emsgs6 wmsgs = wmsgs0 ++ wmsgs1 in if (null emsgs) then if (null wmsgs) then EMResult result else EMWarning wmsgs result else EMError emsgs -- ============================== -- XXX copied from GenWrap -- Join string together with an underscore if either is not empty. joinStrings_ :: String -> String -> String joinStrings_ "" s2 = s2 joinStrings_ s1 "" = s1 joinStrings_ s1 s2 = s1 ++ "_" ++ s2 -- ==============================