diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index b7c6ffac0..a9f975325 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -18,9 +18,9 @@ jobs: auth_header="$(git config --local --get http.https://github.com/.extraheader)" git submodule sync --recursive git -c "http.extraheader=$auth_header" -c protocol.version=2 submodule update --init --force --recursive --depth=1 - - name: Check trailing whitespace + - name: Check tabs and whitespace shell: bash - run: ".github/workflows/check_trailing_whitespace.sh" + run: ".github/workflows/check_whitespace.sh" - name: Install dependencies shell: bash run: ".github/workflows/install_dependencies_ubuntu.sh" diff --git a/.github/workflows/check_trailing_whitespace.sh b/.github/workflows/check_whitespace.sh similarity index 71% rename from .github/workflows/check_trailing_whitespace.sh rename to .github/workflows/check_whitespace.sh index e36b9b0f4..e252ca716 100755 --- a/.github/workflows/check_trailing_whitespace.sh +++ b/.github/workflows/check_whitespace.sh @@ -7,6 +7,11 @@ set -e if git ls-files | egrep '\.(lhs|hs|hsc)$' | xargs grep -n ' $'; then echo "Trailing whitespace found!" exit 1 -else - exit 0 fi + +if git ls-files | egrep '\.(lhs|hs|hsc)$' | xargs grep -n $'\t'; then + echo "Tabs found!" + exit 1 +fi + +exit 0 diff --git a/src/Parsec/ParsecLanguage.hs b/src/Parsec/ParsecLanguage.hs index 0dca50e05..073cfe8e3 100644 --- a/src/Parsec/ParsecLanguage.hs +++ b/src/Parsec/ParsecLanguage.hs @@ -36,9 +36,9 @@ haskellStyle= emptyDef , commentLine = "--" , nestedComments = True , identStart = letter - , identLetter = alphaNum <|> oneOf "_'" - , opStart = opLetter haskellStyle - , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" + , identLetter = alphaNum <|> oneOf "_'" + , opStart = opLetter haskellStyle + , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" , reservedOpNames= [] , reservedNames = [] , caseSensitive = True @@ -46,16 +46,16 @@ haskellStyle= emptyDef javaStyle :: LanguageDef st javaStyle = emptyDef - { commentStart = "/*" - , commentEnd = "*/" - , commentLine = "//" - , nestedComments = True - , identStart = letter - , identLetter = alphaNum <|> oneOf "_'" - , reservedNames = [] - , reservedOpNames= [] - , caseSensitive = False - } + { commentStart = "/*" + , commentEnd = "*/" + , commentLine = "//" + , nestedComments = True + , identStart = letter + , identLetter = alphaNum <|> oneOf "_'" + , reservedNames = [] + , reservedOpNames= [] + , caseSensitive = False + } ----------------------------------------------------------- -- minimal language definition @@ -85,14 +85,14 @@ haskell = makeTokenParser haskellDef haskellDef :: LanguageDef st haskellDef = haskell98Def - { identLetter = identLetter haskell98Def <|> char '#' - , reservedNames = reservedNames haskell98Def ++ - ["foreign","import","export","primitive" - ,"_ccall_","_casm_" - ,"forall" - ] + { identLetter = identLetter haskell98Def <|> char '#' + , reservedNames = reservedNames haskell98Def ++ + ["foreign","import","export","primitive" + ,"_ccall_","_casm_" + ,"forall" + ] } - + haskell98Def :: LanguageDef st haskell98Def = haskellStyle { reservedOpNames= ["::","..","=","\\","|","<-","->","@","~","=>"] @@ -115,10 +115,10 @@ mondrian = makeTokenParser mondrianDef mondrianDef :: LanguageDef st mondrianDef = javaStyle - { reservedNames = [ "case", "class", "default", "extends" - , "import", "in", "let", "new", "of", "package" - ] - , caseSensitive = True - } + { reservedNames = [ "case", "class", "default", "extends" + , "import", "in", "let", "new", "of", "package" + ] + , caseSensitive = True + } + - diff --git a/src/comp/AAddSchedAssumps.hs b/src/comp/AAddSchedAssumps.hs index 8d89bb479..3bbf71799 100644 --- a/src/comp/AAddSchedAssumps.hs +++ b/src/comp/AAddSchedAssumps.hs @@ -74,7 +74,7 @@ aAddSchedAssumps apkg schedule schedinfo = (apkg'', schedinfo') instSchedMap :: OSchedMap instSchedMap = M.fromList [(n, methodConflictInfo (vSched vmi)) - | AVInst { avi_vname = n, avi_vmi = vmi } <- insts ] + | AVInst { avi_vname = n, avi_vmi = vmi } <- insts ] insts = apkg_state_instances apkg apkg' = apkg doCFAssumps = addCFAssumps pragmas ruleMethodMap instSchedMap cmpRule diff --git a/src/comp/AAddScheduleDefs.hs b/src/comp/AAddScheduleDefs.hs index 99aff0ee1..aa39bcd69 100644 --- a/src/comp/AAddScheduleDefs.hs +++ b/src/comp/AAddScheduleDefs.hs @@ -98,8 +98,8 @@ aAddScheduleDefs flags pps pkg aschedinfo = asched = asi_schedule aschedinfo conflicts = concatMap getConflictList (asch_scheduler asched) mumap = asi_method_uses_map aschedinfo - -- for error messages - pkgpos = getPosition (apkg_name pkg) + -- for error messages + pkgpos = getPosition (apkg_name pkg) -- Build maps for ready and enable values and collect -- proof obligations associated with always_ready, always_en, etc. diff --git a/src/comp/ABin.hs b/src/comp/ABin.hs index 26cd28a5b..1dc6ce2b8 100644 --- a/src/comp/ABin.hs +++ b/src/comp/ABin.hs @@ -48,21 +48,21 @@ data ABinModInfo = abmi_path :: String, -- the name of the BSV package which defined this module abmi_src_name :: String, - -- time when BSC was called to compile the .ba - --abmi_time :: ClockTime, - abmi_apkg :: APackage, - abmi_aschedinfo :: AScheduleInfo, - -- if this can be used prior to generating abin, - -- or put into APackage, then it's not needed here: - abmi_pps :: [PProp], - -- original type of the module - -- (this could go in APackage; - -- like pps, this is taken from GenWrap's WrapInfo) - -- (for now, the list of preds is empty, so CType would do) - abmi_oqt :: CQType, - abmi_method_dump :: MethodDumpInfo, - abmi_pathinfo :: VPathInfo, - abmi_flags :: Flags, + -- time when BSC was called to compile the .ba + --abmi_time :: ClockTime, + abmi_apkg :: APackage, + abmi_aschedinfo :: AScheduleInfo, + -- if this can be used prior to generating abin, + -- or put into APackage, then it's not needed here: + abmi_pps :: [PProp], + -- original type of the module + -- (this could go in APackage; + -- like pps, this is taken from GenWrap's WrapInfo) + -- (for now, the list of preds is empty, so CType would do) + abmi_oqt :: CQType, + abmi_method_dump :: MethodDumpInfo, + abmi_pathinfo :: VPathInfo, + abmi_flags :: Flags, -- the generated Verilog abmi_vprogram :: Maybe VProgram } @@ -81,47 +81,47 @@ data ABinModSchedErrInfo = -- the name of the BSV package which defined this module abmsei_src_name :: String, -- the package prior to scheduling - abmsei_apkg :: APackage, + abmsei_apkg :: APackage, -- the available schedule info - abmsei_aschederrinfo :: AScheduleErrInfo, + abmsei_aschederrinfo :: AScheduleErrInfo, -- pragmas - abmsei_pps :: [PProp], + abmsei_pps :: [PProp], -- original type of the module - abmsei_oqt :: CQType, + abmsei_oqt :: CQType, -- flags - abmsei_flags :: Flags + abmsei_flags :: Flags } -- --------------- instance PPrint ABin where pPrint d p (ABinMod abmi ver) = - text "ABin Module" $+$ - nest 2 (text "version:" <+> text ver $+$ - pPrint d 0 abmi) + text "ABin Module" $+$ + nest 2 (text "version:" <+> text ver $+$ + pPrint d 0 abmi) pPrint d p (ABinForeignFunc abffi ver) = - text "ABin Foreign Function" $+$ - nest 2 (text "version:" <+> text ver $+$ - pPrint d 0 abffi) + text "ABin Foreign Function" $+$ + nest 2 (text "version:" <+> text ver $+$ + pPrint d 0 abffi) pPrint d p (ABinModSchedErr abmsei ver) = - text "ABin Module (Schedule Error)" $+$ - nest 2 (text "version:" <+> text ver $+$ - pPrint d 0 abmsei) + text "ABin Module (Schedule Error)" $+$ + nest 2 (text "version:" <+> text ver $+$ + pPrint d 0 abmsei) instance PPrint ABinModInfo where pPrint d p (ABinModInfo path srcName apkg aschedinfo pps oqt mi pathinfo flags vprog) = - text "path:" <+> text path $+$ - text "package:" <+> text srcName $+$ - pPrint d 0 apkg $+$ - pPrint d 0 aschedinfo $+$ + text "path:" <+> text path $+$ + text "package:" <+> text srcName $+$ + pPrint d 0 apkg $+$ + pPrint d 0 aschedinfo $+$ text "pprop:" <+> pPrint d 0 pps $+$ text "oqt:" <+> pPrint d 0 oqt $+$ - -- no dump of method info - text "pathinfo:" <+> pPrint d 0 pathinfo $+$ + -- no dump of method info + text "pathinfo:" <+> pPrint d 0 pathinfo $+$ -- no dump of flags text "vprog:" <+> (if (isNothing vprog) then text "Nothing" @@ -130,16 +130,16 @@ instance PPrint ABinModInfo where instance PPrint ABinForeignFuncInfo where pPrint d p (ABinForeignFuncInfo fid ff) = - text "src name:" <+> pPrint d 0 fid $+$ - pPrint d 0 ff + text "src name:" <+> pPrint d 0 fid $+$ + pPrint d 0 ff instance PPrint ABinModSchedErrInfo where pPrint d p (ABinModSchedErrInfo path srcName apkg aschederrinfo pps oqt flags) = - text "path:" <+> text path $+$ - text "package:" <+> text srcName $+$ - pPrint d 0 apkg $+$ - pPrint d 0 aschederrinfo $+$ + text "path:" <+> text path $+$ + text "package:" <+> text srcName $+$ + pPrint d 0 apkg $+$ + pPrint d 0 aschederrinfo $+$ text "pprop:" <+> pPrint d 0 pps $+$ text "oqt:" <+> pPrint d 0 oqt -- no dump of flags diff --git a/src/comp/ACheck.hs b/src/comp/ACheck.hs index b7daa1223..e150fadac 100644 --- a/src/comp/ACheck.hs +++ b/src/comp/ACheck.hs @@ -17,30 +17,30 @@ import Trace -- type check the the state elements, definitions, rules and interface aMCheck :: APackage -> Bool aMCheck apkg = - all chkAVInst (apkg_state_instances apkg) - && all chkADef (apkg_local_defs apkg) - && all chkARule (apkg_rules apkg) - && all chkAIface (apkg_interface apkg) + all chkAVInst (apkg_state_instances apkg) + && all chkADef (apkg_local_defs apkg) + && all chkARule (apkg_rules apkg) + && all chkAIface (apkg_interface apkg) - -- XXX when module parameters carry an expr for default value, - -- XXX check that here + -- XXX when module parameters carry an expr for default value, + -- XXX check that here - -- XXX if we wanted, we could check that the port list and - -- XXX the VArgInfo at the top-level agree on types - -- XXX (e.g., clock to clock, reset to reset) + -- XXX if we wanted, we could check that the port list and + -- XXX the VArgInfo at the top-level agree on types + -- XXX (e.g., clock to clock, reset to reset) -- type check the state elements, definitions and foreign function calls -- scheduled package aSMCheck :: ASPackage -> Bool aSMCheck asp = - all chkAVInst (aspkg_state_instances asp) - && all chkADef (aspkg_values asp) - && all chkADef (aspkg_inout_values asp) - && all chkAForeignBlock (aspkg_foreign_calls asp) + all chkAVInst (aspkg_state_instances asp) + && all chkADef (aspkg_values asp) + && all chkADef (aspkg_inout_values asp) + && all chkAForeignBlock (aspkg_foreign_calls asp) && chkDupWires asp - -- XXX when module parameters carry an expr for default value, - -- XXX check that here + -- XXX when module parameters carry an expr for default value, + -- XXX check that here -- make sure a wire is never defined twice in an ASPackage chkDupWires :: ASPackage -> Bool @@ -61,7 +61,7 @@ chkAVInst :: AVInst -> Bool chkAVInst aa = let chkParam e = let t = chkAExpr e - in isConstAExpr [] e && (isBit t || isString t || isReal t) + in isConstAExpr [] e && (isBit t || isString t || isReal t) in (tracePP "chkAVInst Params" aa $ all chkParam (getParams aa)) && (tracePP "chkAVInst Ports" aa $ all (isBitOrInout_ . chkAExpr) (getPorts aa)) && @@ -74,11 +74,11 @@ chkADef :: ADef -> Bool chkADef aa@(ADef _ t e _) = let et = chkAExpr e in if t == et - then True - else internalError ("chkADef " - ++ ppReadable aa - ++ ": (" ++ show aa ++ ") " - ++ ppReadable t ++ " /= " ++ ppReadable et) + then True + else internalError ("chkADef " + ++ ppReadable aa + ++ ": (" ++ show aa ++ ") " + ++ ppReadable t ++ " /= " ++ ppReadable et) chkARule :: ARule -> Bool chkARule aa@(ARule _ _ _ _ p as asmps _) = @@ -114,10 +114,10 @@ chkCond t = isBit t && (let (ATBit sz) = t in (sz == 1)) chkAAction :: AAction -> Bool chkAAction aa@(ACall i m (c:es)) = tracePP "chkAAction ACall" aa $ - all (isBit . chkAExpr) es && chkCond (chkAExpr c) + all (isBit . chkAExpr) es && chkCond (chkAExpr c) chkAAction afc@(AFCall { aact_objid = i, aact_args = (c:es) }) = tracePP "chkAAction AFCall" afc $ - chkCond (chkAExpr c) && all (isForeignArg . chkAExpr) es + chkCond (chkAExpr c) && all (isForeignArg . chkAExpr) es chkAAction ata@(ATaskAction { aact_args = (c:es) }) = tracePP "chkAAction ATaskAction" ata $ chkCond (chkAExpr c) && all (isForeignArg . chkAExpr) es @@ -133,83 +133,83 @@ chkAForeignCall afc = False chkAExpr :: AExpr -> AType chkAExpr e@(APrim _ t PrimMul es) = - let ts = map chkAExpr es - -- getBit (ATBit n) = n + let ts = map chkAExpr es + -- getBit (ATBit n) = n -- getBit _ = internalError("ACheck checkAExpr.getBit" ++ (show e)) -- multiplication can widen or narrow the result - in if all isBit ts && isBit t -- && sum (map getBit ts) == getBit t - then - t - else - internalError ("chkAExpr * : " ++ ppReadable e) + in if all isBit ts && isBit t -- && sum (map getBit ts) == getBit t + then + t + else + internalError ("chkAExpr * : " ++ ppReadable e) chkAExpr e@(APrim _ t PrimQuot es) = - let ts = map chkAExpr es - getBit (ATBit n) = n + let ts = map chkAExpr es + getBit (ATBit n) = n getBit _ = internalError("ACheck checkAExpr.getBit" ++ (show e)) - in if all isBit ts && isBit t && (getBit t == getBit (ts!!0)) - then - t - else - internalError ("chkAExpr * : " ++ ppReadable e) + in if all isBit ts && isBit t && (getBit t == getBit (ts!!0)) + then + t + else + internalError ("chkAExpr * : " ++ ppReadable e) chkAExpr e@(APrim _ t PrimRem es) = - let ts = map chkAExpr es - getBit (ATBit n) = n + let ts = map chkAExpr es + getBit (ATBit n) = n getBit _ = internalError("ACheck checkAExpr.getBit" ++ (show e)) - in if all isBit ts && isBit t && (getBit t == getBit (ts!!1)) - then - t - else - internalError ("chkAExpr * : " ++ ppReadable e) + in if all isBit ts && isBit t && (getBit t == getBit (ts!!1)) + then + t + else + internalError ("chkAExpr * : " ++ ppReadable e) chkAExpr e@(APrim _ t PrimConcat es) = - let ts = map chkAExpr es - getBit (ATBit n) = n + let ts = map chkAExpr es + getBit (ATBit n) = n getBit _ = internalError("ACheck checkAExpr.getBit" ++ (show e)) - in if all isBit ts && isBit t && sum (map getBit ts) == getBit t - then - t - else + in if all isBit ts && isBit t && sum (map getBit ts) == getBit t + then + t + else if not (isBit t) then internalError ("chkAExpr ++: result not bit type (" ++ ppString t ++ "): " ++ ppReadable e) else if not (all isBit ts) then internalError ("chkAExpr ++: some args not bit type (" ++ ppString ts ++ "): " ++ ppReadable e) else internalError ("chkAExpr ++: expression bitsize (" ++ ppString (getBit t) ++ ") does not match sum of args bitsizes (" ++ ppString (sum (map getBit ts)) ++ ") from (" ++ ppString ts ++ "): " ++ ppReadable e) chkAExpr e@(APrim _ t op es) | isRelOp op = - let ts = map chkAExpr es - in if t == aTBool && all isBit ts && allSame ts - then t - else internalError ("chkAExpr: relop " ++ ppReadable (e, t, ts)) + let ts = map chkAExpr es + in if t == aTBool && all isBit ts && allSame ts + then t + else internalError ("chkAExpr: relop " ++ ppReadable (e, t, ts)) chkAExpr e@(APrim _ t op [v]) | op == PrimSignExt || op == PrimZeroExt = - case (chkAExpr v, t) of - (ATBit n, ATBit m) | n <= m -> t - _ -> internalError ("chkAExpr: " ++ ppReadable (e, chkAExpr v, t)) + case (chkAExpr v, t) of + (ATBit n, ATBit m) | n <= m -> t + _ -> internalError ("chkAExpr: " ++ ppReadable (e, chkAExpr v, t)) chkAExpr e@(APrim _ t PrimIf (c:es)) = if all ((compatTypesWthStr t) . chkAExpr) es && chkAExpr c == aTBool then t else internalError ("chkAExpr: if " ++ ppReadable (e, t)) chkAExpr e@(APrim _ t op es) | op == PrimPriMux || op == PrimMux = - if f es - then t - else internalError ("chkAExpr: mux " ++ ppReadable t ++ ppReadable e) + if f es + then t + else internalError ("chkAExpr: mux " ++ ppReadable t ++ ppReadable e) where f [] = True - f (c:x:xs) = chkAExpr c == aTBool && compatTypesWthStr (chkAExpr x) t && f xs - f _ = internalError "chkAExpr mux" + f (c:x:xs) = chkAExpr c == aTBool && compatTypesWthStr (chkAExpr x) t && f xs + f _ = internalError "chkAExpr mux" -- XXX could check a little more chkAExpr e@(APrim _ t PrimCase (x:v:ces)) = - if compatTypesWthStr (chkAExpr v) t && chk ces - then t - else internalError ("chkAExpr: case " ++ ppReadable e) + if compatTypesWthStr (chkAExpr v) t && chk ces + then t + else internalError ("chkAExpr: case " ++ ppReadable e) where chk [] = True - chk (c:e:ces) = chkAExpr c == te && compatTypesWthStr (chkAExpr e) t && chk ces + chk (c:e:ces) = chkAExpr c == te && compatTypesWthStr (chkAExpr e) t && chk ces chk _ = False - te = chkAExpr x + te = chkAExpr x chkAExpr e@(APrim _ t PrimExtract es) = - if all (isBit . chkAExpr) es - then t - else internalError ("chkAExpr: extract " ++ ppReadable e) + if all (isBit . chkAExpr) es + then t + else internalError ("chkAExpr: extract " ++ ppReadable e) chkAExpr e@(APrim _ t op [e1, e2]) | isShift op = - if chkAExpr e1 == t {- XXX && chkAExpr e2 == aTNat-} - then t - else internalError ("chkAExpr: shift " ++ ppReadable e) + if chkAExpr e1 == t {- XXX && chkAExpr e2 == aTNat-} + then t + else internalError ("chkAExpr: shift " ++ ppReadable e) chkAExpr e@(APrim _ arr_ty PrimBuildArray elem_es) = case arr_ty of @@ -258,30 +258,30 @@ chkAExpr e@(APrim _ t PrimStringConcat es) -- all other primitives chkAExpr e@(APrim _ t op es) = - if all ((== t) . chkAExpr) es - then t - else internalError ("chkAExpr: other " ++ ppReadable (e, t, map chkAExpr es)) + if all ((== t) . chkAExpr) es + then t + else internalError ("chkAExpr: other " ++ ppReadable (e, t, map chkAExpr es)) chkAExpr e@(AMethCall t _ _ es) = - if all (isBit . chkAExpr) es - then t - else internalError ("chkAExpr: methcall " ++ ppReadable e) + if all (isBit . chkAExpr) es + then t + else internalError ("chkAExpr: methcall " ++ ppReadable e) chkAExpr e@(AFunCall { ae_type = t, ae_args = es }) = - if all (isForeignArg . chkAExpr) es - then t - else internalError ("chkAExpr: funcall " ++ ppReadable e) + if all (isForeignArg . chkAExpr) es + then t + else internalError ("chkAExpr: funcall " ++ ppReadable e) chkAExpr (ASInt _ _ (IntLit _ _ i)) | i < 0 = - internalError ("chkAExpr: negative constant: " ++ show i) + internalError ("chkAExpr: negative constant: " ++ show i) chkAExpr (ASInt _ t@(ATBit sz) (IntLit _ _ i)) = -- check that "log2(i+1) <= sz" -- or, in otherwords, "2^sz > i" if (2^sz > i) - then t - else internalError ("chkAExpr: integer does not fit in size: " ++ - ppReadable (i,sz)) + then t + else internalError ("chkAExpr: integer does not fit in size: " ++ + ppReadable (i,sz)) chkAExpr (ASInt _ t (IntLit _ _ i)) = - internalError ("chkAExpr: non-bit integer: " ++ ppReadable (t,i)) + internalError ("chkAExpr: non-bit integer: " ++ ppReadable (t,i)) chkAExpr e@(ASClock t c) = if chkAClock c @@ -299,9 +299,9 @@ chkAExpr e@(ASInout t r) = else internalError ("chkAExpr: invalid inout: " ++ show e) chkAExpr e@(AMGate t _ _) = - if isBit1 t - then t - else internalError ("chkAExpr: invalid clock gate: " ++ ppReadable e) + if isBit1 t + then t + else internalError ("chkAExpr: invalid clock gate: " ++ ppReadable e) chkAExpr e = aType e @@ -369,35 +369,35 @@ aSignalCheck :: ASPackage -> [AId] aSignalCheck (ASPackage _ fmod ps _ is ios insts souts ds iods fs _ _ _) = let pnames = [ i | (i,_) <- ps ] - inames = [ i | (i,_) <- is ] - ionames= [ i | (i,_) <- ios ] - dnames = [ i | ADef i _ _ _ <- ds ] - snames = [ i | (i,_) <- souts ] - - -- used in ASDef - defs = dnames - -- used in ASPort - ports = inames ++ snames ++ ionames + inames = [ i | (i,_) <- is ] + ionames= [ i | (i,_) <- ios ] + dnames = [ i | ADef i _ _ _ <- ds ] + snames = [ i | (i,_) <- souts ] + + -- used in ASDef + defs = dnames + -- used in ASPort + ports = inames ++ snames ++ ionames -- used in ASParam params = pnames -- XXX if parameters carried expressions for their default values, -- XXX we would check those uses here - iexprs = concatMap avi_iargs insts - dexprs = [ e | ADef i _ e _ <- ds ] + iexprs = concatMap avi_iargs insts + dexprs = [ e | ADef i _ e _ <- ds ] iodexprs = [ e | ADef i _ e _ <- iods ] - fexprs = concat [ clks ++ es ++ rsts | (clks, fcalls) <- fs, + fexprs = concat [ clks ++ es ++ rsts | (clks, fcalls) <- fs, AForeignCall _ _ es _ rsts <- fcalls ] - exprs = fexprs ++ iexprs ++ dexprs ++ iodexprs + exprs = fexprs ++ iexprs ++ dexprs ++ iodexprs -- build set from the list defSet = S.fromList defs portSet = S.fromList ports paramSet = S.fromList params in - checkUses defSet portSet paramSet exprs + checkUses defSet portSet paramSet exprs -- return The list of all names not referenced in the given environments diff --git a/src/comp/ACleanup.hs b/src/comp/ACleanup.hs index 1a1a72ee4..9918e8f68 100644 --- a/src/comp/ACleanup.hs +++ b/src/comp/ACleanup.hs @@ -117,53 +117,53 @@ cleanupActions flags pred as = -- Found an action method loop merged (first@(ACall id methodid (cond:args)):rest) = - -- Internal loop to scan for matching actions that might be ME - let loopR :: [AAction] -> [AAction] -> CMonad [AAction] - loopR scanned [] = - return ((reverse merged) ++ [first] ++ (reverse scanned)) - - -- not necessary - rest has been cleaned already - -- loopR scanned [] = loop (first:merged) (reverse scanned) - loopR scanned (firstR@(ACall id' methodid' (cond':args')):restR) - | (id == id') && - (methodid == methodid') && + -- Internal loop to scan for matching actions that might be ME + let loopR :: [AAction] -> [AAction] -> CMonad [AAction] + loopR scanned [] = + return ((reverse merged) ++ [first] ++ (reverse scanned)) + + -- not necessary - rest has been cleaned already + -- loopR scanned [] = loop (first:merged) (reverse scanned) + loopR scanned (firstR@(ACall id' methodid' (cond':args')):restR) + | (id == id') && + (methodid == methodid') && ((length args) == (length args')) = - do - dtState <- getDisjointTestState - (isDisjoint,newstate) <- - liftIO $ checkDisjointCond dtState pred cond cond' - updateDisjointTestState newstate - - if (isDisjoint) then - do - newid <- newName - addDef (ADef newid aTBool - (APrim newid aTBool PrimBOr [cond, cond']) []) - newargs <- - (mapM (\ (arg, arg') -> - do - argid <- newName - let argtyp = (aType arg) - addDef (ADef argid argtyp - (APrim argid argtyp PrimIf [cond, arg, arg']) []) - return (ASDef argtyp argid)) - (zip args args')) - let newcall = (ACall id methodid - ((ASDef aTBool newid):newargs)) - - -- restR is guaranteed merged amongst itself (see below) - -- so no more work need be done... - return ((reverse merged) - ++ [newcall] - ++ (reverse scanned) - ++ restR) - else loopR (firstR:scanned) restR - loopR scanned (firstR:restR) = loopR (firstR:scanned) restR + do + dtState <- getDisjointTestState + (isDisjoint,newstate) <- + liftIO $ checkDisjointCond dtState pred cond cond' + updateDisjointTestState newstate + + if (isDisjoint) then + do + newid <- newName + addDef (ADef newid aTBool + (APrim newid aTBool PrimBOr [cond, cond']) []) + newargs <- + (mapM (\ (arg, arg') -> + do + argid <- newName + let argtyp = (aType arg) + addDef (ADef argid argtyp + (APrim argid argtyp PrimIf [cond, arg, arg']) []) + return (ASDef argtyp argid)) + (zip args args')) + let newcall = (ACall id methodid + ((ASDef aTBool newid):newargs)) + + -- restR is guaranteed merged amongst itself (see below) + -- so no more work need be done... + return ((reverse merged) + ++ [newcall] + ++ (reverse scanned) + ++ restR) + else loopR (firstR:scanned) restR + loopR scanned (firstR:restR) = loopR (firstR:scanned) restR -- aggressively merge the rest -- which allows the shortcuts in loopR above - in do rest' <- (loop [] rest) - (loopR [] rest') + in do rest' <- (loop [] rest) + (loopR [] rest') -- don't try to merge foreign function calls since -- those shouldn't get muxed anyway diff --git a/src/comp/AConv.hs b/src/comp/AConv.hs index 4a891f4b0..187aa6caa 100644 --- a/src/comp/AConv.hs +++ b/src/comp/AConv.hs @@ -67,13 +67,13 @@ type CSEMap = M.Map AExpr (AId, AType, AExpr) type IEDefMap = M.Map Id (AExpr, [DefProp]) data AState = AState { errHandle :: ErrorHandle, - varNo :: !Int, -- for new variable names - cseMap :: CSEMap, -- for CSE - stVarMap :: IdMap, -- I-expr names to A-expr names - ieDefMap :: IEDefMap, -- accumulated definitions + varNo :: !Int, -- for new variable names + cseMap :: CSEMap, -- for CSE + stVarMap :: IdMap, -- I-expr names to A-expr names + ieDefMap :: IEDefMap, -- accumulated definitions flags :: Flags, -- to hold the flags on the Monad wmsgs :: [WMsg] -- to hold accumulated warnings - } + } type IdMap = M.Map Id Id @@ -99,13 +99,13 @@ getMap = liftM cseMap (get) newAIdFromAExpr :: Position -> AExpr -> M AId newAIdFromAExpr p expr = do s <- get - let n = varNo s + let n = varNo s new_name = signalNameFromAExpr expr ++ "_" ++ aconvPref ++ itos n new_id = setFromRHSId $ mkId p (mkFString new_name) new_id' = if (isSignCast expr) then setSignedId new_id else new_id - put (s { varNo = n+1 }) + put (s { varNo = n+1 }) return new_id' where isSignCast (AFunCall { ae_funname = name }) = name == sSigned isSignCast _ = False @@ -113,7 +113,7 @@ newAIdFromAExpr p expr = do addMap :: AExpr -> AId -> AType -> M () addMap e i t = do s <- get - put (s { cseMap = M.insert e (i, t, e) (cseMap s) }) + put (s { cseMap = M.insert e (i, t, e) (cseMap s) }) transId :: Id -> M Id transId i = do s <- get @@ -148,11 +148,11 @@ aConv errh pps flags imod = state = aInitState errh itr flags in case runStateT (runReaderT (aDo imod) False) state of Left emsg -> bsError errh [emsg] - Right (apkg, s) -> + Right (apkg, s) -> do let wmessages = wmsgs s when ((not . null) wmessages) $ bsWarning errh wmessages - return apkg + return apkg -- This checks for methods which are calling tasks or foreign functions. @@ -172,15 +172,15 @@ checkForeign a@(AIActionValue { }) = checkForeignInRules :: AId -> [ARule] -> M [(AId, [Position])] checkForeignInRules method rs = let foreign_poss = - [getPosition i | (ARule { arule_actions = as }) <- rs, - (AFCall { aact_objid = i }) <- as] ++ + [getPosition i | (ARule { arule_actions = as }) <- rs, + (AFCall { aact_objid = i }) <- as] ++ -- task actions are foreign function calls too [getPosition i | (ARule { arule_actions = as }) <- rs, - (ATaskAction { aact_objid = i }) <- as] + (ATaskAction { aact_objid = i }) <- as] filtered_poss = nub $ filter isUsefulPosition foreign_poss in if (not (null foreign_poss)) - then return [(method, filtered_poss)] - else return [] + then return [(method, filtered_poss)] + else return [] aDo :: IModule a -> M APackage @@ -190,31 +190,31 @@ aDo imod@(IModule mi fmod be wi ps iks its clks rsts itvs pts idefs rs ifc ffcal -- AVInst keeps the types of method ports let tsConv :: Id -> [IType] -> ([AType], Maybe AType, Maybe AType) tsConv i ts = - let inputs = initOrErr "tsConv" ts - res = lastOrErr "tsConv" ts - in_types = map (aTypeConv i) inputs - (en_type, val_type) = - if (isitActionValue_ res) && (getAV_Size res > 0) - then (Just (ATBit 1), - Just (ATBit (getAV_Size res))) - else if (isActionType res) - then (Just (ATBit 1), Nothing) - else (Nothing, Just (aTypeConv i res)) + let inputs = initOrErr "tsConv" ts + res = lastOrErr "tsConv" ts + in_types = map (aTypeConv i) inputs + (en_type, val_type) = + if (isitActionValue_ res) && (getAV_Size res > 0) + then (Just (ATBit 1), + Just (ATBit (getAV_Size res))) + else if (isActionType res) + then (Just (ATBit 1), Nothing) + else (Nothing, Just (aTypeConv i res)) in (in_types, en_type, val_type) - let (IRules sps irule_list) = rs - arule_list <- mapM aRule irule_list - --trace ("aDo rules extracted") $ return () + let (IRules sps irule_list) = rs + arule_list <- mapM aRule irule_list + --trace ("aDo rules extracted") $ return () let lookupInstPorts i = fromMaybe (M.empty) (M.lookup i pts) - aitvs <- mapM (\ (i0, IStateVar b ui _ v es t tss _ _ hnames) -> - do i <- transId i0 + aitvs <- mapM (\ (i0, IStateVar b ui _ v es t tss _ _ hnames) -> + do i <- transId i0 let portTypes = lookupInstPorts (Just i0) - es' <- zipWithM aExprArg (vArgs v) es - -- XXX Lennart put a comment here to say "add ifc args in the AVInst list" - -- XXX because I think AVerilog filters out fake entries in the AVInst list as ifc args: - -- XXX patch in args here - return (AVInst (addIdProp i IdPProbe) + es' <- zipWithM aExprArg (vArgs v) es + -- XXX Lennart put a comment here to say "add ifc args in the AVInst list" + -- XXX because I think AVerilog filters out fake entries in the AVInst list as ifc args: + -- XXX patch in args here + return (AVInst (addIdProp i IdPProbe) (aTypeConv i t) ui (map (tsConv i) tss) @@ -224,17 +224,17 @@ aDo imod@(IModule mi fmod be wi ps iks its clks rsts itvs pts idefs rs ifc ffcal [])) itvs - aifc <- mapM (aIface flags) ifc + aifc <- mapM (aIface flags) ifc - -- Check whether there are any methods calling tasks or foreign funcs, - -- which need to be warned about + -- Check whether there are any methods calling tasks or foreign funcs, + -- which need to be warned about methodss_to_warn <- mapM checkForeign aifc - let methods_to_warn = concat methodss_to_warn - meth_info_digested = - map (\(i,poss) -> (pfpString i, getPosition i, poss)) - methods_to_warn - when (not (null methods_to_warn)) $ - addWarning (getPosition mi, WFCall meth_info_digested) + let methods_to_warn = concat methodss_to_warn + meth_info_digested = + map (\(i,poss) -> (pfpString i, getPosition i, poss)) + methods_to_warn + when (not (null methods_to_warn)) $ + addWarning (getPosition mi, WFCall meth_info_digested) -- any defs that have the keepEvenUnused property should be forced -- to be kept by calling aEDef to add them to maps in the monad @@ -311,21 +311,21 @@ aDo imod@(IModule mi fmod be wi ps iks its clks rsts itvs pts idefs rs ifc ffcal return (d, acs)) clks - return (APackage { apkg_name = unQualId (dropGenSuffixId mi), - apkg_is_wrapped = fmod, - apkg_backend = be, - apkg_size_params = [ i | (i, k) <- iks ], - apkg_inputs = map aAbstractInput its, + return (APackage { apkg_name = unQualId (dropGenSuffixId mi), + apkg_is_wrapped = fmod, + apkg_backend = be, + apkg_size_params = [ i | (i, k) <- iks ], + apkg_inputs = map aAbstractInput its, apkg_external_wires = wi, apkg_external_wire_types = lookupInstPorts Nothing, apkg_clock_domains = clock_domains, apkg_reset_list = reset_list, - apkg_state_instances = aSubst subst_map aitvs, - apkg_local_defs = local_defs, - apkg_rules = aSubst subst_map arule_list, - apkg_schedule_pragmas = sps, - apkg_interface = aSubst subst_map aifc, - apkg_inst_comments = cmap, + apkg_state_instances = aSubst subst_map aitvs, + apkg_local_defs = local_defs, + apkg_rules = aSubst subst_map arule_list, + apkg_schedule_pragmas = sps, + apkg_interface = aSubst subst_map aifc, + apkg_inst_comments = cmap, apkg_inst_tree = mkInstTree imod, apkg_proof_obligations = [] }) @@ -337,9 +337,9 @@ aAbstractInput (IAI_Inout r n) = (AAI_Inout r n) aIface :: Flags -> IEFace a -> M AIFace aIface flags iface@(IEFace i its maybe_e maybe_rs wp fi) = do - --trace ("enter " ++ ppReadable i) $ return () - let its' = [ (arg_i, aTypeConv arg_i arg_t) | (arg_i, arg_t) <- its] - g = if isRdyId i then aSBool True else ASDef aTBool (mkRdyId i) + --trace ("enter " ++ ppReadable i) $ return () + let its' = [ (arg_i, aTypeConv arg_i arg_t) | (arg_i, arg_t) <- its] + g = if isRdyId i then aSBool True else ASDef aTBool (mkRdyId i) case (maybe_e, maybe_rs) of (Nothing, Nothing) -> internalError ("AConv.aIface nothing in it " ++ ppReadable iface) @@ -373,9 +373,9 @@ aIface flags iface@(IEFace i its maybe_e maybe_rs wp fi) = do return (AIDef i its' wp g (ADef i (aTypeConv i t) ae []) fi []) (Nothing, Just rs) -> do - arule_list <- mapM aRule (extractRules rs) - --trace ("exit " ++ ppReadable i) $ return () - return $ AIAction its' wp g i arule_list fi + arule_list <- mapM aRule (extractRules rs) + --trace ("exit " ++ ppReadable i) $ return () + return $ AIAction its' wp g i arule_list fi (Just (val_, t), Just rs) -> do @@ -383,16 +383,16 @@ aIface flags iface@(IEFace i its maybe_e maybe_rs wp fi) = do ae <- aExpr val_ --trace ("exit av " ++ ppReadable i) $ return () return (AIActionValue its' wp g i arule_list - (ADef i (aTypeConv i t) ae []) fi ) + (ADef i (aTypeConv i t) ae []) fi ) -- should internalError if size(val_)==0 XXX aRule :: IRule a -> M ARule aRule (IRule i rps s wp p a orig isl) = do - --trace ("enter rule " ++ ppReadable i) $ return () - p' <- aSExpr p - as' <- aAction i a + --trace ("enter rule " ++ ppReadable i) $ return () + p' <- aSExpr p + as' <- aAction i a -- traceM $ "exit rule " ++ ppReadable i - return (ARule i rps s wp p' as' [] orig) + return (ARule i rps s wp p' as' [] orig) aReset :: IReset a -> M AReset aReset r = do @@ -400,7 +400,7 @@ aReset r = do r' <- case (getResetWire r) of IAps (ICon i (ICSel { iConType = itReset })) _ [(ICon vid (ICStateVar {iVar = sv}))] -> let i_rstn = lookupOutputResetWire i (getVModInfo sv) - in return (mkOutputWire vid i_rstn) + in return (mkOutputWire vid i_rstn) ICon idNoReset (ICPrim itBit1 PrimResetUnassertedVal) -> do return (APrim idNoReset aTBool PrimResetUnassertedVal []) wire_exp -> aSExpr wire_exp @@ -413,7 +413,7 @@ aInout r = do e@(IAps (ICon i (ICSel {})) _ [(ICon vid (ICStateVar {iVar = sv}))]) -> let t = iGetType e i_iot = lookupIfcInoutWire i (getVModInfo sv) - in if (isitInout_ t) + in if (isitInout_ t) then return (mkIfcInoutN (getInout_Size t) vid i_iot) else internalError ("aInout: sel not Inout_ type: " ++ ppReadable e) @@ -435,34 +435,34 @@ aClock c = do return (AClock { aclock_osc = a_osc, aclock_gate = a_gate }) -- output clock fields IAps (ICon i (ICSel { iConType = itClock })) _ [(ICon vid (ICStateVar {iVar = sv}))] -> - let (i_osc, mi_gate) = lookupOutputClockWires i (getVModInfo sv) - osc_aexpr = mkOutputWire vid i_osc - gate_aexpr = case (mi_gate) of - Nothing -> aTrue - Just i_gate -> -- mkOutputWire vid i_gate - AMGate aTBool vid i - in return (AClock { aclock_osc = osc_aexpr, - aclock_gate = gate_aexpr }) + let (i_osc, mi_gate) = lookupOutputClockWires i (getVModInfo sv) + osc_aexpr = mkOutputWire vid i_osc + gate_aexpr = case (mi_gate) of + Nothing -> aTrue + Just i_gate -> -- mkOutputWire vid i_gate + AMGate aTBool vid i + in return (AClock { aclock_osc = osc_aexpr, + aclock_gate = gate_aexpr }) _ -> internalError ("AConv.ASClock: " ++ (show c)) aSExpr :: IExpr a -> M AExpr aSExpr e = do - e' <- aExpr e + e' <- aExpr e noCSE <- ask - case e' of - (ASInt _ _ _) -> return e' - (ASDef _ _) -> return e' - (ASPort _ _) -> return e' - (ASParam _ _) -> return e' - (ASStr _ _ _) -> return e' - (ASAny _ _) -> return e' + case e' of + (ASInt _ _ _) -> return e' + (ASDef _ _) -> return e' + (ASPort _ _) -> return e' + (ASParam _ _) -> return e' + (ASStr _ _ _) -> return e' + (ASAny _ _) -> return e' (ASClock _ _) -> return e' (ASReset _ _) -> return e' (ASInout _ _) -> return e' _ | noCSE -> return e' - _ -> do - (i, t, e'') <- find e' (aType e') (getIExprPosition e) - return (ASDef t i) + _ -> do + (i, t, e'') <- find e' (aType e') (getIExprPosition e) + return (ASDef t i) aExprArg :: VArgInfo -> IExpr a -> M AExpr aExprArg (Param _) = aExprNoCSE @@ -473,71 +473,71 @@ aExprNoCSE e = withReaderT (const True) (aExpr e) aExpr :: IExpr a -> M AExpr aExpr exp@(IAps (ICon isel (ICPrim _ PrimSelect)) [ITNum i1, ITNum i2, ITNum i3] [e]) = do - e' <- aSExpr e - if i2 < i3 && i3-i2 >= i1 - then - return $ APrim isel (ATBit i1) PrimExtract [e', aNat (i1+i2-1), aNat i2] - else + e' <- aSExpr e + if i2 < i3 && i3-i2 >= i1 + then + return $ APrim isel (ATBit i1) PrimExtract [e', aNat (i1+i2-1), aNat i2] + else internalError ("aExpr select: bad bit selection\n" ++ - ppReadable (getIdPosition isel) ++ ppReadable exp) + ppReadable (getIdPosition isel) ++ ppReadable exp) aExpr (IAps (ICon i (ICPrim _ PrimExtract)) [ITNum i1, _, ITNum i2] [e,h,l]) = do - let n = log2 i1 + let n = log2 i1 errh <- gets errHandle - es' <- mapM aSExpr [e, eTrunc errh n h, eTrunc errh n l] - return $ APrim i (ATBit i2) PrimExtract es' + es' <- mapM aSExpr [e, eTrunc errh n h, eTrunc errh n l] + return $ APrim i (ATBit i2) PrimExtract es' -- XXX we can remove PrimRange here, or keep it aExpr (IAps (ICon i (ICPrim _ PrimRange)) _ [_,_,e]) = aSExpr e -- XXX hack to get strings into the compiler (masquerade as integers or bits) aExpr (IAps (ICon i1 (ICPrim _ PrimIntegerToBit)) _ [IAps (ICon i2 (ICPrim _ PrimStringToInteger)) _ [s]]) = - aExpr s + aExpr s -- special cases for sign and zero extensions, since they depend on the type information aExpr e@(IAps (ICon i (ICPrim _ PrimSignExt)) [_,_,ITNum ii] es) = do - es' <- mapM aSExpr es - return $ APrim i (ATBit ii) PrimSignExt es' + es' <- mapM aSExpr es + return $ APrim i (ATBit ii) PrimSignExt es' aExpr e@(IAps (ICon i (ICPrim _ p)) ts es) | realPrim p = do - es' <- mapM aSExpr (if p `elem` assocPrims then concatMap (joinOp p) es else es) - --traceM (ppReadable (es, es')) - return $ APrim i (primType p ts es') p es' + es' <- mapM aSExpr (if p `elem` assocPrims then concatMap (joinOp p) es else es) + --traceM (ppReadable (es, es')) + return $ APrim i (primType p ts es') p es' -- error if "avValue_" is applied to too many arguments -- (so that the following other case arms can assume this check) aExpr (IAps (ICon i (ICSel { })) ts (e:es)) | (i == idAVValue_) && (not (null es)) = internalError ("aExpr: too many arguments to avValue_: " ++ - ppReadable es) + ppReadable es) -- value part of ActionValue task without arguments aExpr e@(IAps (ICon m (ICSel { })) _ [(ICon i (ICForeign {fName = name, - isC = isC, - foports = Nothing, - fcallNo = mn}))]) + isC = isC, + foports = Nothing, + fcallNo = mn}))]) | m == idAVValue_ = let n = case (mn) of - Nothing -> internalError - ("aExpr: avValue_ on ICForeign without fcallNo") - Just val -> val - t@(ATBit _) = aTypeConvE e (iGetType e) + Nothing -> internalError + ("aExpr: avValue_ on ICForeign without fcallNo") + Just val -> val + t@(ATBit _) = aTypeConvE e (iGetType e) in return (ATaskValue t i name isC n) -- value part of ActionValue task with arguments aExpr e@(IAps (ICon m (ICSel { })) _ - [(IAps (ICon i (ICForeign {fName = name, - isC = isC, - foports = Nothing, - fcallNo = mn})) fts fes)]) + [(IAps (ICon i (ICForeign {fName = name, + isC = isC, + foports = Nothing, + fcallNo = mn})) fts fes)]) | m == idAVValue_ = let n = case (mn) of - Nothing -> internalError - ("aExpr: avValue_ on ICForeign without fcallNo") - Just val -> val - t@(ATBit _) = aTypeConvE e (iGetType e) + Nothing -> internalError + ("aExpr: avValue_ on ICForeign without fcallNo") + Just val -> val + t@(ATBit _) = aTypeConvE e (iGetType e) in -- the value side carries no arguments - -- the cookie "n" will connect it back up to the action side + -- the cookie "n" will connect it back up to the action side return (ATaskValue t i name isC n) -- value part of ActionValue method @@ -572,7 +572,7 @@ aExpr e@(IAps (ICon m (ICSel { })) _ [(ICon i (ICClock { iClock = c }))]) | m == ac <- aClock c return (aclock_osc ac) aExpr (IAps (ICon _ (ICCon { iConType = ITAp _ t, conNo = n })) _ _) | t == itBit1 = - return $ aSBool (n /= 0) + return $ aSBool (n /= 0) aExpr e@(IAps (ICon i (ICForeign { fName = name, isC = isC, foports = Nothing})) ts es) = do es' <- mapM aSExpr es -- XXX should this ever happen? @@ -582,8 +582,8 @@ aExpr e@(IAps (ICon i (ICForeign { fName = name, isC = isC, foports = Nothing})) --traceM("AFunCall1: " ++ name) return $ AFunCall (aTypeConvE e (iGetType e)) i name isC es' aExpr e@(IAps (ICon i (ICForeign { fName = name, isC = False, foports = (Just ops)})) ts es) = do - es' <- mapM aSExpr es - let ns = [ n | ITNum n <- ts ] + es' <- mapM aSExpr es + let ns = [ n | ITNum n <- ts ] let t = aTypeConvE e (iGetType e) -- because Classic allows foreign functions to be declared, -- we need to check if this is a genwrap generated function @@ -591,7 +591,7 @@ aExpr e@(IAps (ICon i (ICForeign { fName = name, isC = False, foports = (Just op then dropGenSuffixId i else i --traceM("AFunCall2: " ++ name) - return $ ANoInlineFunCall t i' + return $ ANoInlineFunCall t i' (ANoInlineFun name ns ops Nothing) es' aExpr e@(ICon v (ICModPort { iConType = t })) = return (ASPort (aTypeConvE e t) v) @@ -618,7 +618,7 @@ aExpr e@(ICon i (ICForeign { iConType = t, fName = name, isC = False, foports = then dropGenSuffixId i else i --traceM("AFunCall4: " ++ name) - return $ ANoInlineFunCall (aTypeConvE e t) i' + return $ ANoInlineFunCall (aTypeConvE e t) i' (ANoInlineFun name [] ops Nothing) [] aExpr e@(IAps (ICon _ (ICUndet { })) _ _) = internalError ("AConv.ICUndet application " ++ ppReadable e) @@ -640,22 +640,22 @@ aExpr e@(ICon _ (ICInout { iConType = it, iInout = i})) | (isitInout_ it) = do return (ASInout at ai) aExpr e = internalError - ("AConv.aExpr at " ++ ppString p ++ ":" ++ ppReadable e ++ "\n" ++ - (show p) ++ ":" ++ (showTypeless e)) + ("AConv.aExpr at " ++ ppString p ++ ":" ++ ppReadable e ++ "\n" ++ + (show p) ++ ":" ++ (showTypeless e)) where p = getIExprPosition e aEDef :: Id -> IExpr a -> [DefProp] -> M AExpr aEDef i e ps = do - da <- getDA + da <- getDA -- traceM $ "aEDef " ++ ppReadable (i,e,ps) - case M.lookup i da of - Just (a, _) -> do + case M.lookup i da of + Just (a, _) -> do return a - Nothing -> do + Nothing -> do -- traceM $ "not found" - a <- aSExpr e - addDA i a ps - return a + a <- aSExpr e + addDA i a ps + return a aTypeConv :: Id -> IType -> AType aTypeConv _ (ITAp (ITCon b _ _) (ITNum n)) | b == idBit = ATBit n @@ -671,9 +671,9 @@ aTypeConv _ (ITAp (ITCon i t (TIstruct SStruct fs@(val:_))) (ITNum n)) = -- internalError ("Yes\n\n" ++ (show a) ++"\n\n" ++ (show n)) aTypeConv _ t = abs t [] where abs (ITCon i _ _) ns = ATAbstract i (reverse ns) - abs (ITAp t _) ns = abs t ns - abs _ _ = -- ATAbstract idBit [] -- XXX what's this - internalError ("aTypeConv|" ++ show t) + abs (ITAp t _) ns = abs t ns + abs _ _ = -- ATAbstract idBit [] -- XXX what's this + internalError ("aTypeConv|" ++ show t) -- This is a variation of "aTypeConv" that is only used by "aExpr". -- A String expression can be used to determine the size of the ATString type. @@ -692,27 +692,27 @@ aTypeConvE a t | t == itString = otherwise -> ATString Nothing aTypeConvE a t = abs t [] where abs (ITCon i _ _) ns = ATAbstract i (reverse ns) - abs (ITAp t _) ns = abs t ns - abs _ _ = -- ATAbstract idBit [] -- XXX what's this - internalError ("aTypeConvE|" ++ show t) + abs (ITAp t _) ns = abs t ns + abs _ _ = -- ATAbstract idBit [] -- XXX what's this + internalError ("aTypeConvE|" ++ show t) realPrim p = p `elem` - [ - PrimSignExt, PrimZeroExt, PrimTrunc, - PrimExtract, PrimConcat, - PrimIf, PrimCase, + [ + PrimSignExt, PrimZeroExt, PrimTrunc, + PrimExtract, PrimConcat, + PrimIf, PrimCase, PrimBuildArray, PrimArrayDynSelect, - PrimRange, + PrimRange, -- not primArith because not Bit n -> Bit n -> Bit n PrimMul, PrimQuot, PrimRem - ] ++ primAriths ++ primCmps ++ primBools ++ primStrings + ] ++ primAriths ++ primCmps ++ primBools ++ primStrings primAriths = [ PrimAdd, PrimSub, PrimAnd, PrimOr, PrimXor, - PrimSL, PrimSRL, PrimSRA, - PrimInv, PrimNeg ] + PrimSL, PrimSRL, PrimSRA, + PrimInv, PrimNeg ] primBools = [ PrimBAnd, PrimBOr, PrimBNot ] primCmps = [ PrimEQ, PrimEQ3, - PrimULE, PrimULT, - PrimSLE, PrimSLT ] + PrimULE, PrimULT, + PrimSLE, PrimSLT ] primStrings = [ PrimStringConcat ] -- Many primops are associative, but if we reassociate we might rebalance a carefully @@ -735,7 +735,7 @@ sumStrSizes (e:es) = do n <- case (aType e) of aPrim :: AType -> PrimOp -> AExpr -> AExpr aPrim t p es | p `elem` assocPrims = APrim _ t p (concatMap join es) where join (APrim _ t' p' es) | t == t' && p == p' = es - join e = [e] + join e = [e] aPrim t p es = APrim _ t p es -} @@ -758,16 +758,16 @@ primType PrimCase _ (_:d:ps) = else dflt_t primType PrimConcat _ es = ATBit (sum (map (unbit . aType) es)) where unbit (ATBit width) = width - unbit _ = internalError "concatenation of abstract types in AConv.primType" + unbit _ = internalError "concatenation of abstract types in AConv.primType" primType PrimMul ts _ = ATBit (getNum (last ts)) where getNum (ITNum n) = n - getNum _ = internalError "multiplication of abstract types in AConv.primType" + getNum _ = internalError "multiplication of abstract types in AConv.primType" primType PrimQuot ts _ = ATBit (getNum (head ts)) where getNum (ITNum n) = n - getNum _ = internalError "quotient of abstract types in AConv.primType" + getNum _ = internalError "quotient of abstract types in AConv.primType" primType PrimRem ts _ = ATBit (getNum (last ts)) where getNum (ITNum n) = n - getNum _ = internalError "remainder of abstract types in AConv.primType" + getNum _ = internalError "remainder of abstract types in AConv.primType" primType p _ _ | p `elem` (primBools ++ primCmps) = ATBit 1 primType p _ (e:_) | p `elem` primAriths || p == PrimRange = aType e primType (PrimStringConcat) _ es@(_:_) = ATString (sumStrSizes es) @@ -799,41 +799,41 @@ aAction1 r cond (IAps (IAps f _ es1) _ es2) = aAction1 r cond (IAps f [] (es1++e -- action part of ActionValue task without arguments aAction1 _ cond a@(IAps (ICon avAction_ (ICSel { })) _ - ((ICon i (ICForeign {iConType = ity, + ((ICon i (ICForeign {iConType = ity, fName = name, - isC = isC, - foports = Nothing, - fcallNo = mn})) : es)) + isC = isC, + foports = Nothing, + fcallNo = mn})) : es)) | avAction_ == idAVAction_ = do let n = case (mn) of - Nothing -> internalError - ("aAction1: avAction_ on ICForeign without fcallNo") - Just val -> val + Nothing -> internalError + ("aAction1: avAction_ on ICForeign without fcallNo") + Just val -> val value_type = aTypeConv i (snd (itGetArrows ity)) when (not (null es)) $ internalError ("aAction1: too many arguments to avAction_: " ++ - ppReadable es) + ppReadable es) cond' <- aSExpr cond return [(ATaskAction i name isC n [cond'] Nothing value_type False)] -- action part of ActionValue task with arguments aAction1 _ cond a@(IAps (ICon avAction_ (ICSel { })) _ - ((IAps (ICon i (ICForeign {iConType = ity0, + ((IAps (ICon i (ICForeign {iConType = ity0, fName = name, - isC = isC, - foports = Nothing, - fcallNo = mn})) fts fes) : es)) + isC = isC, + foports = Nothing, + fcallNo = mn})) fts fes) : es)) | avAction_ == idAVAction_ = do let n = case (mn) of - Nothing -> internalError - ("aAction1: avAction_ on ICForeign without fcallNo") - Just val -> val + Nothing -> internalError + ("aAction1: avAction_ on ICForeign without fcallNo") + Just val -> val -- allow for polymorphic foreign functions ity = itInst ity0 fts value_type = aTypeConv i (snd (itGetArrows ity)) when (not (null es)) $ internalError ("aAction1: too many arguments to avAction_: " ++ - ppReadable es) + ppReadable es) cond' <- aSExpr cond fes' <- mapM aSExpr fes return [(ATaskAction i name isC n (cond' : fes') Nothing value_type False)] @@ -846,23 +846,23 @@ aAction1 r cond a@(IAps (ICon avAction_ (ICSel { })) _ es) | avAction_ == idAVAc -- anything else is invalid [e] -> internalError ("aAction1: avAction_ called on non-primitive actionvalue\n" ++ - "e = " ++ show e) + "e = " ++ show e) _ -> internalError "aAction1: avAction_ with wrong number of arguments" aAction1 _ cond (IAps (ICon m (ICSel { })) _ (ICon i (ICStateVar { }) : es)) = do - cond' <- aSExpr cond - es' <- mapM aSExpr es - i' <- transId i - return [ACall i' m (cond' : es')] + cond' <- aSExpr cond + es' <- mapM aSExpr es + i' <- transId i + return [ACall i' m (cond' : es')] aAction1 _ cond (IAps (ICon i (ICForeign { fName = name, isC = isC, foports = Nothing })) ts es) = do - cond' <- aSExpr cond - es' <- mapM aSExpr es + cond' <- aSExpr cond + es' <- mapM aSExpr es -- XXX should this ever happen? -- assume we do not need applied types, -- the foreign function is truly polymorphic - --let ns = [ n | ITNum n <- ts ] - return [AFCall i name isC (cond' : es') False] + --let ns = [ n | ITNum n <- ts ] + return [AFCall i name isC (cond' : es') False] -- noinline functions returning Action are not synthesizable, so this -- branch is not needed @@ -875,9 +875,9 @@ aAction1 _ cond (ICon i (ICForeign { fName = name, isC = isC, foports = Nothing aAction1 s cond (IAps (ICon _ (ICPrim { primOp = PrimIf })) _ [c, t, e]) = do flags <- getFlags - t' <- aAction' s (iTransBoolExpr flags (c `ieAnd` cond)) t - e' <- aAction' s (iTransBoolExpr flags ((ieNot c) `ieAnd` cond)) e - return (t' ++ e') + t' <- aAction' s (iTransBoolExpr flags (c `ieAnd` cond)) t + e' <- aAction' s (iTransBoolExpr flags ((ieNot c) `ieAnd` cond)) e + return (t' ++ e') {- aAction1 s cond (ICon _ (ICPrim { primOp = PrimNoActions })) = @@ -912,13 +912,13 @@ aAction1 r cond e = internalError ("aAction1 end: " ++ ppReadable (r, cond, e) + find :: AExpr -> AType -> Position -> M (AId, AType, AExpr) find e t pos = do - m <- getMap - case M.lookup e m of - Just ite -> return ite - Nothing -> do - i <- newAIdFromAExpr pos e - addMap e i t - return (i, t, e) + m <- getMap + case M.lookup e m of + Just ite -> return ite + Nothing -> do + i <- newAIdFromAExpr pos e + addMap e i t + return (i, t, e) ----- @@ -939,10 +939,10 @@ makeIdMap ids = M.fromList (zip ids ids) -- makeIdMap :: [Id] -> IdMap -- makeIdMap = M.fromList . concatMap numGroup . sortGroup le -- where le i1 i2 = nonum (getIdString i1) <= nonum (getIdString i2) --- nonum = reverse . tail . dropWhile isDigit . reverse --- numGroup [i] = [(i, noNumId i)] --- numGroup is = zipWith (\ i n -> (i, mkIdPost (noNumId i) (concatFString [fsUnderscore, mkNumFString n]))) is [0..] --- noNumId i = mkId (getIdPosition i) (mkFString (nonum (getIdString i))) +-- nonum = reverse . tail . dropWhile isDigit . reverse +-- numGroup [i] = [(i, noNumId i)] +-- numGroup is = zipWith (\ i n -> (i, mkIdPost (noNumId i) (concatFString [fsUnderscore, mkNumFString n]))) is [0..] +-- noNumId i = mkId (getIdPosition i) (mkFString (nonum (getIdString i))) trId :: IdMap -> Id -> Id trId m i = diff --git a/src/comp/ADropUndet.hs b/src/comp/ADropUndet.hs index f915a8742..ebfca42a3 100644 --- a/src/comp/ADropUndet.hs +++ b/src/comp/ADropUndet.hs @@ -66,16 +66,16 @@ fixUndet errh flags defmap = g -- if it doesn't, and the backends are not allowed to diverge, -- then replace it with a constant f (ASAny t Nothing) | (not b) = Just (mkUnspec errh tgt t) - -- XXX This is a fixup for ITransform not picking the best value. - -- XXX The long-term solution is to not pick values in ITransform, - -- XXX but to wait until the Path Graph is available. - f (APrim i t PrimIf [_, tt, ff]) = - let tt' = g tt - ff' = g ff - in case (tt,ff) of - ((ASAny _ _), _) | canFixUndet flags avmap ff' -> Just ff' - (_, (ASAny _ _)) | canFixUndet flags avmap tt' -> Just tt' - _ -> Nothing + -- XXX This is a fixup for ITransform not picking the best value. + -- XXX The long-term solution is to not pick values in ITransform, + -- XXX but to wait until the Path Graph is available. + f (APrim i t PrimIf [_, tt, ff]) = + let tt' = g tt + ff' = g ff + in case (tt,ff) of + ((ASAny _ _), _) | canFixUndet flags avmap ff' -> Just ff' + (_, (ASAny _ _)) | canFixUndet flags avmap tt' -> Just tt' + _ -> Nothing -- otherwise, don't change it f _ = Nothing diff --git a/src/comp/ADumpScheduleInfo.hs b/src/comp/ADumpScheduleInfo.hs index 94f129e39..b982ab9a5 100644 --- a/src/comp/ADumpScheduleInfo.hs +++ b/src/comp/ADumpScheduleInfo.hs @@ -4,8 +4,8 @@ -- (which imports DisjointTest and requires linking with the SAT libraries) -- module ADumpScheduleInfo( - MethodDumpInfo, - RuleConflictType(..) + MethodDumpInfo, + RuleConflictType(..) ) where import ASyntax(AId, AExpr) diff --git a/src/comp/ANoInline.hs b/src/comp/ANoInline.hs index 68dda510e..01988d1fc 100644 --- a/src/comp/ANoInline.hs +++ b/src/comp/ANoInline.hs @@ -58,8 +58,8 @@ genIdFromAExpr expr = do put (state { nis_uniqueId = uniqueNum + 1 }) let newIdStr = signalNameFromAExpr expr ++ aNoInlinePref ++ itos uniqueNum return $ mkId - noPosition -- XXX aexpr should have an instance of HasPosition - (mkFString newIdStr) + noPosition -- XXX aexpr should have an instance of HasPosition + (mkFString newIdStr) -- Add the expression -- realy the definition to the monad addExpr :: AType -> AExpr -> NIStateMonad AId @@ -67,13 +67,13 @@ addExpr t e = do ds <- gets nis_defs rlm <- gets nis_rlookup case ( M.lookup (e,t) rlm ) of - Nothing -> - do - nid <- genIdFromAExpr e + Nothing -> + do + nid <- genIdFromAExpr e addDef (ADef nid t e []) return nid - -- don't create a new id for an expression that already has an id - Just fid -> return fid + -- don't create a new id for an expression that already has an id + Just fid -> return fid -- =============== @@ -86,52 +86,52 @@ addExpr t e = do aNoInline :: Flags -> APackage -> APackage aNoInline flags apkg = let - -- initial state - initState = NIState { - nis_uniqueId = 1, - nis_defs = [], - nis_rlookup = M.empty - } + -- initial state + initState = NIState { + nis_uniqueId = 1, + nis_defs = [], + nis_rlookup = M.empty + } -- fields of the package - ifc = apkg_interface apkg - rs = apkg_rules apkg - insts = apkg_state_instances apkg - defs = apkg_local_defs apkg - - -- monadic action - action = do - -- we can't use mapAExprs in one go over the whole package - -- because we don't want to lift exprs at the top level of defs. - -- instead, by parts: - - -- map over the defs - -- (this doesn't return defs, it adds them all to the state, - -- to be retrieved at the end) - mapM_ liftADef defs + ifc = apkg_interface apkg + rs = apkg_rules apkg + insts = apkg_state_instances apkg + defs = apkg_local_defs apkg + + -- monadic action + action = do + -- we can't use mapAExprs in one go over the whole package + -- because we don't want to lift exprs at the top level of defs. + -- instead, by parts: + + -- map over the defs + -- (this doesn't return defs, it adds them all to the state, + -- to be retrieved at the end) + mapM_ liftADef defs -- map over ifcs - ifc' <- mapMAExprs (liftAExpr False) ifc - -- map over rules - rs' <- mapMAExprs (liftAExpr False) rs - -- map over state - insts' <- mapMAExprs (liftAExpr False) insts - - -- get back the final list of defs - -- (original defs with lifting, plus any new defs) - defs' <- gets nis_defs - - -- now that all ANoInlineFunCall are top-level defs, - -- assign instance names to each one - let defs'' = updateNoInlineDefs defs' - - -- return the new package - return (apkg { apkg_interface = ifc', - apkg_rules = rs', - apkg_state_instances = insts', - apkg_local_defs = defs'' }) + ifc' <- mapMAExprs (liftAExpr False) ifc + -- map over rules + rs' <- mapMAExprs (liftAExpr False) rs + -- map over state + insts' <- mapMAExprs (liftAExpr False) insts + + -- get back the final list of defs + -- (original defs with lifting, plus any new defs) + defs' <- gets nis_defs + + -- now that all ANoInlineFunCall are top-level defs, + -- assign instance names to each one + let defs'' = updateNoInlineDefs defs' + + -- return the new package + return (apkg { apkg_interface = ifc', + apkg_rules = rs', + apkg_state_instances = insts', + apkg_local_defs = defs'' }) in - evalState action initState + evalState action initState -- =============== @@ -170,16 +170,16 @@ liftAExpr _ expr = return expr updateNoInlineDefs :: [ADef] -> [ADef] updateNoInlineDefs defs = let - updateDef :: ADef -> (Integer, [ADef]) -> (Integer, [ADef]) - updateDef (ADef di dt (ANoInlineFunCall ft fi f es) props) (n, ds) = - let (ANoInlineFun m ts ps _) = f - inst_name = instPrefix ++ getIdBaseString fi ++ "_" ++ itos n - f' = (ANoInlineFun m ts ps (Just inst_name)) - d' = (ADef di dt (ANoInlineFunCall ft fi f' es) props) - in (n+1, d':ds) - updateDef d (n, ds) = (n, d:ds) + updateDef :: ADef -> (Integer, [ADef]) -> (Integer, [ADef]) + updateDef (ADef di dt (ANoInlineFunCall ft fi f es) props) (n, ds) = + let (ANoInlineFun m ts ps _) = f + inst_name = instPrefix ++ getIdBaseString fi ++ "_" ++ itos n + f' = (ANoInlineFun m ts ps (Just inst_name)) + d' = (ADef di dt (ANoInlineFunCall ft fi f' es) props) + in (n+1, d':ds) + updateDef d (n, ds) = (n, d:ds) in - snd $ foldr updateDef (0,[]) defs + snd $ foldr updateDef (0,[]) defs -- =============== diff --git a/src/comp/AOpt.hs b/src/comp/AOpt.hs index 0e73da5de..a6775d23c 100644 --- a/src/comp/AOpt.hs +++ b/src/comp/AOpt.hs @@ -1,14 +1,14 @@ {-# OPTIONS_GHC -fwarn-name-shadowing -fwarn-missing-signatures #-} module AOpt(aOpt, - aOptBoolExpr, - -- this is needed only because aOptBoolExpr only applies to Bit1 - aBoolSimp, + aOptBoolExpr, + -- this is needed only because aOptBoolExpr only applies to Bit1 + aBoolSimp, -- used by Bluesim backend aExpandDynSel, aInsertCaseDef -- Used by SERI dump ,aOptAPackageLite - ) where + ) where import Control.Monad.State @@ -92,9 +92,9 @@ aOpt errh flags pkg0 = do let bflags = flagsToBFlags flags - keepF = keepFires flags -- F - optsch = optSched flags -- T - optjoin = optJoinDefs flags -- F see comments on b1072 + keepF = keepFires flags -- F + optsch = optSched flags -- T + optjoin = optJoinDefs flags -- F see comments on b1072 inlineB = inlineBool flags -- T when debug $ @@ -123,14 +123,14 @@ aOpt errh flags pkg0 = do traceM ("trace defs, post insert-case: " ++ ppReadable (aspkg_values pkg1B)) let - -- There are several pass thru aExpand in this function to + -- There are several pass thru aExpand in this function to -- give better cleanup and inlining. This is especially true -- after case generation since many signal disappear -- -- expcheap needed as True here to get aInsertCase to work. -- aExpand is needed here after scheduling tsort defs -- - pkg2 = aExpand errh keepF False inlineB pkg1B + pkg2 = aExpand errh keepF False inlineB pkg1B ds = aspkg_values pkg2 fb = aspkg_foreign_calls pkg2 @@ -167,7 +167,7 @@ aOpt errh flags pkg0 = do let ds3 = joinDefs optjoin ds2 when debug $ traceM ("trace defs, post joinDefs (ds3): " ++ ppReadable ds3) - let pkg6 = pkg5 { aspkg_values = ds3 } + let pkg6 = pkg5 { aspkg_values = ds3 } -- -- We may want to turn off optsch here, since this undoes the effect of joinDefs @@ -197,10 +197,10 @@ flagsToBFlags flags = BFlags { -- double to account for select + argument -- in our mux representation ao_ifmuxsize = 2 * (optIfMuxSize flags), - ao_mux = optMux flags, -- T + ao_mux = optMux flags, -- T ao_muxExpand = optMuxExpand flags, -- F - ao_muxconst = optMuxConst flags, -- T - ao_bitConst = optBitConst flags, -- F + ao_muxconst = optMuxConst flags, -- T + ao_bitConst = optBitConst flags, -- F -- ao_aggInline = optAggInline flags, -- T ao_keepfires = keepFires flags, -- False @@ -273,7 +273,7 @@ addDef d@(ADef aid t e _) = do let uses = (aid,0) : map (\i -> (i,1)) (aVars e) put s { o_defs = d:o_defs s, o_defmap = M.insert aid e (o_defmap s), - o_usemap = map_insertManyWith (+) uses (o_usemap s) + o_usemap = map_insertManyWith (+) uses (o_usemap s) } -- retrieve the defs (in order they were added) @@ -361,8 +361,8 @@ expandVarRef _ e = e -- use map accompanying the pre-optimization defs. expandUniqueVarRef :: (AId -> Bool) -> (AId -> AExpr) -> AExpr -> AExpr expandUniqueVarRef isUnique findf e@(ASDef { ae_objid = aid }) - | (isUnique aid) = expandUniqueVarRef isUnique findf (findf aid) --- | otherwise = trace ("choosing not to expand " ++ ppReadable aid) $ e + | (isUnique aid) = expandUniqueVarRef isUnique findf (findf aid) +-- | otherwise = trace ("choosing not to expand " ++ ppReadable aid) $ e expandUniqueVarRef _ _ e = e ----- @@ -374,19 +374,19 @@ aOptDefs bflgs ds fblocks ss = (evalState optf initOState) where optf :: O ( [ADef], [AForeignBlock], [AVInst] ) optf = do --traceM ("FF " ++ ppReadable ds) - setNonDefUses ss fblocks + setNonDefUses ss fblocks -- and various prim opt aPrim (incld some flattening / joining of nested muxes - mapM_ (aOptDef bflgs) ds + mapM_ (aOptDef bflgs) ds fb1 <- mapM (aOptForeignBlock bflgs) fblocks - ds' <- getDefs + ds' <- getDefs when debug2 $ traceM ("trace post aoptdef in aoptDefs : " ++ ppReadable ds' ) clearDefs - setNonDefUses ss fb1 + setNonDefUses ss fb1 -- Do the mux optimization - mapM_ (aMuxOptDef bflgs) ds' + mapM_ (aMuxOptDef bflgs) ds' fb2 <- mapM (aMuxOptForeign bflgs) fb1 ss1 <- mapM (aOptInstDefs bflgs) ss - newdefs <- getDefs + newdefs <- getDefs return (newdefs,fb2,ss1) aOptInstDefs :: BFlags -> AVInst -> O AVInst @@ -414,18 +414,18 @@ joinDefs False ds = ds joinDefs True dsx = reverse (snd (foldl add (M.empty, []) dsx)) where add :: (M.Map AExpr ADef, [ADef]) -> ADef -> (M.Map AExpr ADef,[ADef]) add (m, ds) d@(ADef _ _ (ASInt _ _ _) _) = (m, d:ds) - add (m, ds) d@(ADef _ _ (ASDef _ _) _) = (m, d:ds) - add (m, ds) d@(ADef _ _ (ASStr _ _ _) _) = (m, d:ds) - add (m, ds) d@(ADef _ _ (ASPort _ _) _) = (m, d:ds) - add (m, ds) d@(ADef _ _ (ASParam _ _) _) = (m, d:ds) - add (m, ds) d@(ADef _ _ (ASAny _ _) _) = (m, d:ds) - add (m, ds) d@(ADef ie _ e props) = - case M.lookup e m of - Nothing + add (m, ds) d@(ADef _ _ (ASDef _ _) _) = (m, d:ds) + add (m, ds) d@(ADef _ _ (ASStr _ _ _) _) = (m, d:ds) + add (m, ds) d@(ADef _ _ (ASPort _ _) _) = (m, d:ds) + add (m, ds) d@(ADef _ _ (ASParam _ _) _) = (m, d:ds) + add (m, ds) d@(ADef _ _ (ASAny _ _) _) = (m, d:ds) + add (m, ds) d@(ADef ie _ e props) = + case M.lookup e m of + Nothing | hasIdProp ie IdP_enable -> (m, d:ds) | defPropsHasNoCSE props -> (m, d:ds) - | otherwise -> (M.insert e d m, d:ds) - Just (ADef i t _ p) -> -- traces ("adding simple assignment: " ++ ppReadable (ie,i)) $ + | otherwise -> (M.insert e d m, d:ds) + Just (ADef i t _ p) -> -- traces ("adding simple assignment: " ++ ppReadable (ie,i)) $ (m, (ADef ie t (ASDef t i) p) : ds) -- if the expression is a primitive with 1-bit type, optimize it as @@ -450,11 +450,11 @@ aOptDef bflgs def@(ADef i t rdef@(ASDef rt aid) ps) = do mredirect <- lookupDef aid -- traceM( "aoptdef redirect: " ++ ppReadable rdef) case (mredirect) of - Nothing -> - internalError ("Aopt::aOptDef lookup failed: " ++ ppReadable def) - Just (ATaskValue {}) -> aOptDef_dflt bflgs def -- don't redirect - Just (AFunCall { ae_isC = True }) -> aOptDef_dflt bflgs def -- don't redirect - Just rdef_expr -> addDef (ADef i t rdef_expr ps) + Nothing -> + internalError ("Aopt::aOptDef lookup failed: " ++ ppReadable def) + Just (ATaskValue {}) -> aOptDef_dflt bflgs def -- don't redirect + Just (AFunCall { ae_isC = True }) -> aOptDef_dflt bflgs def -- don't redirect + Just rdef_expr -> addDef (ADef i t rdef_expr ps) aOptDef bflgs def = aOptDef_dflt bflgs def -- the default case for aOptDef (shared between the two branches above) @@ -464,7 +464,7 @@ aOptDef_dflt bflgs def@(ADef i t e p) = do --when debug2 $ traceM( "aOptDef: IC: " ++ ppReadable e' ) e'' <- aExp bflgs e when debug2 $ traceM( "aOptDef: " ++ ppReadable def ++ - "result : " ++ ppReadable e'' ) + "result : " ++ ppReadable e'' ) addDef (ADef i t e'' p) aOptForeignBlock :: BFlags -> AForeignBlock -> O AForeignBlock @@ -632,18 +632,18 @@ aPrimInsertCase stringOK findFn aid t PrimIf es@[cond, _, _] -- then this will be Just [(v,c), (v2,c2), ...] let mcs = getConsts findFn (const True) cond res = case mcs of - -- if all the v's are the same - Just cs@((v,_):_) | allSame (map fst cs) -> - -- collect the ifs, + -- if all the v's are the same + Just cs@((v,_):_) | allSame (map fst cs) -> + -- collect the ifs, -- if there are any nested, convert to case - let (ces, d) = collIf findFn v [] (APrim aid t PrimIf es) + let (ces, d) = collIf findFn v [] (APrim aid t PrimIf es) -- aPrim will check this again -- but we do it here for the Bluesim backend ces' = rmDupsInCasePairs ces - in if length ces > 1 + in if length ces > 1 then APrim aid t PrimCase (v:d:flattenPairs ces') - else APrim aid t PrimIf es - _ -> APrim aid t PrimIf es + else APrim aid t PrimIf es + _ -> APrim aid t PrimIf es in tracep debug2 ("aPrimInsertCase: " ++ ppReadable es) $ tracep debug2 ("aPrimInsertCase: result: " ++ ppReadable res) $ res @@ -670,18 +670,18 @@ aExp bflags etop@(ASDef t aid) = let e = fromMaybe (internalError("AOpt::aExp ADef lookup failed " ++ ppReadable aid)) mexpr aggInline = ao_aggInline bflags return $ - case (aggInline, e ) of - (True, el@(APrim _ _ PrimExtract [ _, (ASInt {} ), (ASInt {} ) ])) - -> el - (True, el@(AMethValue {} )) -> el - (True, el@(ASPort {} )) -> el - (True, el@(ASParam {} )) -> el - (True, el@(ASDef {} )) -> el - (_, el@(ASInt {} )) -> el - (_, el@(ASStr {} )) -> el - -- Do not inline in other cases. - -- In particular, ATaskValue must stay toplevel, - -- with the same def name. + case (aggInline, e ) of + (True, el@(APrim _ _ PrimExtract [ _, (ASInt {} ), (ASInt {} ) ])) + -> el + (True, el@(AMethValue {} )) -> el + (True, el@(ASPort {} )) -> el + (True, el@(ASParam {} )) -> el + (True, el@(ASDef {} )) -> el + (_, el@(ASInt {} )) -> el + (_, el@(ASStr {} )) -> el + -- Do not inline in other cases. + -- In particular, ATaskValue must stay toplevel, + -- with the same def name. _ -> etop aExp bflags etop@(ASPort t aid) = -- port can be constant, check here @@ -755,28 +755,28 @@ aPrim bflags aid t PrimIf [cnd, x, y] | ao_ifmux bflags && not (isStringType t) findD <- findDef findU <- findUse let -- if inlining reveals an expression that's a mux return it, else - -- returns the original expression + -- returns the original expression usePrimPri = ao_ifsToPrimPri bflags op = if (usePrimPri) then PrimPriMux else PrimMux -- inlineMux :: AExpr -> O AExpr - inlineMux e@(ASDef { }) = do + inlineMux e@(ASDef { }) = do let e' = (expandUniqueVarRef findU findD e) - case (e') of - (APrim _ _ opx es) | opx == op && + case (e') of + (APrim _ _ opx es) | opx == op && genericLength es < muxSize -> return e' - _ -> return e - inlineMux e = return e + _ -> return e + inlineMux e = return e -- x' <- inlineMux x y' <- inlineMux y let notc' = aNot c' otherCond = if ( usePrimPri) then aTrue else notc' - -- if the underlying expression is a mux, join them + -- if the underlying expression is a mux, join them addToMux :: AExpr -> AExpr -> [AExpr] - addToMux c (APrim _ _ opx es) | opx == op = - flattenPairs $ nubByFst (mapFst (aAnd c) (makePairs es)) - addToMux c e = [c, e] + addToMux c (APrim _ _ opx es) | opx == op = + flattenPairs $ nubByFst (mapFst (aAnd c) (makePairs es)) + addToMux c e = [c, e] let es' = addToMux c' x' ++ addToMux otherCond y' when debug2 $ traceM("optIfMux size: " ++ show (length es')) aPrim bflags aid t op es' @@ -827,14 +827,14 @@ aPrim bflags aid t@(ATBit n) p exs | ao_bitConst bflags && bitwise p && any isInt exs = do -- trace (ppReadable (APrim _ t p es)) $ return () let mkBit (ASInt _ _ (IntLit { ilValue = i })) = - return (integerToAExprs n i) -- fast special case - mkBit e = do - e' <- mkDefS e - getf <- findDef - let err = internalError "AOpt.aPrim.mkBit" + return (integerToAExprs n i) -- fast special case + mkBit e = do + e' <- mkDefS e + getf <- findDef + let err = internalError "AOpt.aPrim.mkBit" e'' = APrim aid err PrimConcat (aFlattenConc True getf e') - return [ aSelect e'' i 1 | i <- [n-1,n-2..0] ] - mkCol es = aPrimBool aid aTBool (boolOp p) es + return [ aSelect e'' i 1 | i <- [n-1,n-2..0] ] + mkCol es = aPrimBool aid aTBool (boolOp p) es ess <- mapM mkBit exs aPrim bflags aid t PrimConcat (map mkCol (transpose ess)) @@ -973,26 +973,26 @@ aBool b = aSBool b -- before mapping aOptDef. -- collIf :: (AId -> AExpr) -> AExpr -> [(AExpr, AExpr)] -> AExpr -> - ([(AExpr, AExpr)], AExpr) + ([(AExpr, AExpr)], AExpr) collIf findf v ces d = let -- this is either the original expr or an expanded variable ref - d' = expandVarRef findf d + d' = expandVarRef findf d in - case (collIfPrim findf v ces d') of - Just res -> res - Nothing -> (reverse ces, d) + case (collIfPrim findf v ces d') of + Just res -> res + Nothing -> (reverse ces, d) -- This does the real work. -- It returns (Just result) if optimization was possible collIfPrim :: (AId -> AExpr) -> AExpr -> [(AExpr, AExpr)] -> AExpr -> Maybe ([(AExpr, AExpr)], AExpr) collIfPrim findf v ces (APrim _ _ PrimIf [_, t, e]) | t == e = - Just $ collIf findf v ces t + Just $ collIf findf v ces t collIfPrim findf v ces (APrim _ _ PrimIf [cond, t, e]) | me /= Nothing = - Just $ collIf findf v (zip (map snd cs) (repeat t) ++ ces) e + Just $ collIf findf v (zip (map snd cs) (repeat t) ++ ces) e where me = getConsts findf (== v) cond - Just cs = me + Just cs = me collIfPrim findf v ces (APrim _ _ PrimCase (v':d:ces')) | v == v' = - Just (reverse ces ++ makePairs ces', d) + Just (reverse ces ++ makePairs ces', d) collIfPrim _ _ ces d = Nothing @@ -1021,13 +1021,13 @@ integerToAExprs n i = map (aSBool . (== 1)) (integerToBits n i) -- (cmuxo is the optMuxConst flag) aFlattenConc :: Bool -> (AId -> AExpr) -> AExpr -> [AExpr] aFlattenConc cmuxo getf ex = flatConc ex - where flatConc e@(ASDef _ i) = - case getf i of - APrim _ _ PrimConcat es -> concatMap flatConc es - _ -> [e] - flatConc (APrim _ _ PrimConcat es) = concatMap flatConc es - flatConc (ASInt _ (ATBit n) (IntLit { ilValue = i })) | cmuxo = integerToAExprs n i - flatConc e = [e] + where flatConc e@(ASDef _ i) = + case getf i of + APrim _ _ PrimConcat es -> concatMap flatConc es + _ -> [e] + flatConc (APrim _ _ PrimConcat es) = concatMap flatConc es + flatConc (ASInt _ (ATBit n) (IntLit { ilValue = i })) | cmuxo = integerToAExprs n i + flatConc e = [e] --- @@ -1072,32 +1072,32 @@ complete t@(ATBit nx) d cepairs = step :: Integer -> [(AExpr, AExpr)] -> [(AExpr, AExpr)] step n [] | n >= maxlen = [] step n _ | n >= maxlen = internalError ("AOpt::complete::step: " ++ - "arm out of range: " ++ + "arm out of range: " ++ ppReadable (n, maxlen)); step n (ce@(ASInt _ _ (IntLit { ilValue = i }), e) : ces) - | (n == i) = ce : step (n+1) ces - | (n > i) = internalError ("AOpt::complete::step: " ++ - "duplicate arms: " ++ - ppReadable (n,i) ++ + | (n == i) = ce : step (n+1) ces + | (n > i) = internalError ("AOpt::complete::step: " ++ + "duplicate arms: " ++ + ppReadable (n,i) ++ ppReadable cepairs) step n ces = - let new_c = (ASInt defaultAId t (ilDec n)) -- XXX size the literal? - in (new_c, d) : step (n+1) ces + let new_c = (ASInt defaultAId t (ilDec n)) -- XXX size the literal? + in (new_c, d) : step (n+1) ces in if -- there's only one arm missing (len == maxlen - 1) || - -- or there's less than a third missing, - ( (maxlen - len <= maxlen `div` 3) && - -- and it's an inlineable expression - (isASimple d) && - -- and the case isn't too large - (maxlen < 8) ) + -- or there's less than a third missing, + ( (maxlen - len <= maxlen `div` 3) && + -- and it's an inlineable expression + (isASimple d) && + -- and the case isn't too large + (maxlen < 8) ) then - -- then fill in the missing arm(s) - step 0 sortedPairs + -- then fill in the missing arm(s) + step 0 sortedPairs else - sortedPairs + sortedPairs complete _ _ _ = internalError( "AOpt::complete" ) @@ -1240,74 +1240,74 @@ muxOpt bflgs aidx dty op esIn | ao_muxExpand bflgs = do -- ess <- mapM (mapM mkDefS) (map (aFlattenConc cmuxo getf) asIn) let - -- Concatenations are broken apart to mux the separate pieces? + -- Concatenations are broken apart to mux the separate pieces? -- For Strings, the aSize function returns string size *8 which is bad in this case -- szs represents all the break points for the various c exprs which are concats. - -- for each "es" in "ess" (corresponding to the pieces concatenated - -- to form the value for one branch), - -- * get the size of each piece - -- * produce the list of indices for the start of each piece: - -- given the lengths [1,2,3] produces [6,5,3,0] - -- from these lengths, one ordered list of all indices is made - -- (indicating each location where a concat on some branch starts) + -- for each "es" in "ess" (corresponding to the pieces concatenated + -- to form the value for one branch), + -- * get the size of each piece + -- * produce the list of indices for the start of each piece: + -- given the lengths [1,2,3] produces [6,5,3,0] + -- from these lengths, one ordered list of all indices is made + -- (indicating each location where a concat on some branch starts) -- szs = (remOrdDup . sort . concatMap (scanr (+) 0 . map aSize)) ess - -- XXX need to CSE expressions that are split + -- XXX need to CSE expressions that are split let - -- lists of the concatenated pieces for each branch of the mux - ess' = map (reverse . splitEs 0 szs . reverse) ess - -- to turn mux of concats into a concat of muxes, transpose the - -- list into lists for each mux containing the same segment from - -- each value - tess = transpose ess' + -- lists of the concatenated pieces for each branch of the mux + ess' = map (reverse . splitEs 0 szs . reverse) ess + -- to turn mux of concats into a concat of muxes, transpose the + -- list into lists for each mux containing the same segment from + -- each value + tess = transpose ess' let - mxs = map (mux psIn) tess - mux :: [AExpr] -> [AExpr] -> AExpr - mux pxs exs@(ex:_) = mux' [] pxs exs - where mux' :: [(AExpr,AExpr)] -> [AExpr] -> [AExpr] -> AExpr + mxs = map (mux psIn) tess + mux :: [AExpr] -> [AExpr] -> AExpr + mux pxs exs@(ex:_) = mux' [] pxs exs + where mux' :: [(AExpr,AExpr)] -> [AExpr] -> [AExpr] -> AExpr mux' xs [] [] = aMakeMux aidx t op (reverse xs) - mux' xs (_:ps) ((ASAny _ _) : es) = mux' xs ps es - mux' xs (p:ps) (e:es) = mux' ((p,e):xs) ps es + mux' xs (_:ps) ((ASAny _ _) : es) = mux' xs ps es + mux' xs (p:ps) (e:es) = mux' ((p,e):xs) ps es mux' xs ps es = internalError( "AOpt::mux' " ++ ppReadable (xs,ps,es) ) -- list ps and es must be same size - t = aType ex + t = aType ex mux _ _ = internalError( "AOpt::mux" ) let - jms = joinMuxes mxs + jms = joinMuxes mxs joinMuxes :: [AExpr] -> [AExpr] - joinMuxes (m:m':ms) = - case join2 m m' of - Nothing -> m : joinMuxes (m':ms) - Just m'' -> joinMuxes (m'':ms) - joinMuxes ms = ms - join2 (APrim aid ty p pes) (APrim _ _ p' pes') | length pes == length pes' - && p == p' && (p == PrimMux || p == PrimPriMux) = do - pes'' <- joinpes pes pes' - return (APrim aid (aType (pes''!!1)) p pes'') + joinMuxes (m:m':ms) = + case join2 m m' of + Nothing -> m : joinMuxes (m':ms) + Just m'' -> joinMuxes (m'':ms) + joinMuxes ms = ms + join2 (APrim aid ty p pes) (APrim _ _ p' pes') | length pes == length pes' + && p == p' && (p == PrimMux || p == PrimPriMux) = do + pes'' <- joinpes pes pes' + return (APrim aid (aType (pes''!!1)) p pes'') {- -- XXX why is this commented out? it looks like a good optimization! - join2 (APrim _ ty PrimIf [c,t,e]) (APrim _ _ PrimIf [c',t',e']) | c == c' = do - let t'' = aConcat [t, t'] - e'' = aConcat [e, e'] - return (APrim _ (aType t'') PrimIf [c,t'',e'']) + join2 (APrim _ ty PrimIf [c,t,e]) (APrim _ _ PrimIf [c',t',e']) | c == c' = do + let t'' = aConcat [t, t'] + e'' = aConcat [e, e'] + return (APrim _ (aType t'') PrimIf [c,t'',e'']) -} - join2 _ _ = Nothing - joinpes (p:e:pes) (p':e':pes') = - if p == p' then do - pes'' <- joinpes pes pes' - return (p:(aConcat [e, e']):pes'') - else - Nothing - joinpes [] [] = return [] - joinpes xs ys = internalError ("joinpes " ++ ppReadable (xs, ys)) + join2 _ _ = Nothing + joinpes (p:e:pes) (p':e':pes') = + if p == p' then do + pes'' <- joinpes pes pes' + return (p:(aConcat [e, e']):pes'') + else + Nothing + joinpes [] [] = return [] + joinpes xs ys = internalError ("joinpes " ++ ppReadable (xs, ys)) -- trace (ppReadable d ++ ppReadable ess -- ++ ppReadable (concatMap concat dsss) -- ++ ppReadable szs ++ ppReadable ess' -- ++ ppReadable tess ++ ppReadable ps ++ ppReadable ms ++ ppReadable d') - aOptMuxSel :: AExpr -> AExpr - aOptMuxSel (APrim aid t p pes) | p == PrimMux || p == PrimPriMux = - APrim aid t p (flattenPairs (mapFst aBoolSimp (makePairs pes))) - aOptMuxSel _ = internalError "aOptMuxSel" + aOptMuxSel :: AExpr -> AExpr + aOptMuxSel (APrim aid t p pes) | p == PrimMux || p == PrimPriMux = + APrim aid t p (flattenPairs (mapFst aBoolSimp (makePairs pes))) + aOptMuxSel _ = internalError "aOptMuxSel" result = aConcat (map (aTransAndOrMux . aTransMux . aOptMuxSel) jms) -- when debug2 $ traceM ("muxOpt result:" ++ ppReadable result) @@ -1328,33 +1328,33 @@ muxOpt _ aid _ _ _ = internalError ("AOpt::muxOpt unexpected" ++ ppReadable aid) -- "e" is the piece to start chewing on splitEs :: Integer -> [Integer] -> [AExpr] -> [AExpr] splitEs offs (l:ss@(h:_)) (e:es) = - let - -- the size of the next piece - s = aSize e - -- the distance from the current index to the next index - d = h - l - in - -- if the amount chewed from "e" so far plus the distance - -- to go is exactly the size of the "e" ... - if offs + d == s then - -- then if the amount chewed is 0, just output "e". - -- otherwise, select the portion remaining from "e". - -- in either case, continue chewing on "es" starting - -- with the next index ("ss") and reset offset back to 0 - if offs == 0 then - e : splitEs 0 ss es - else - aSelect e offs d : splitEs 0 ss es - else - -- otherwise, it must be less than "s", because we - -- know that the sizes list contains an index for - -- end of every "e". so... - -- select the next distance from "e" and - -- continue with the next index, incrementing the - -- offset by "d", and still chewing on "e" - aSelect e offs d : splitEs (offs+d) ss (e : es) - -- if "es" is empty, or if the index list is 1 elem or less, - -- return nothing + let + -- the size of the next piece + s = aSize e + -- the distance from the current index to the next index + d = h - l + in + -- if the amount chewed from "e" so far plus the distance + -- to go is exactly the size of the "e" ... + if offs + d == s then + -- then if the amount chewed is 0, just output "e". + -- otherwise, select the portion remaining from "e". + -- in either case, continue chewing on "es" starting + -- with the next index ("ss") and reset offset back to 0 + if offs == 0 then + e : splitEs 0 ss es + else + aSelect e offs d : splitEs 0 ss es + else + -- otherwise, it must be less than "s", because we + -- know that the sizes list contains an index for + -- end of every "e". so... + -- select the next distance from "e" and + -- continue with the next index, incrementing the + -- offset by "d", and still chewing on "e" + aSelect e offs d : splitEs (offs+d) ss (e : es) + -- if "es" is empty, or if the index list is 1 elem or less, + -- return nothing splitEs _ _ _ = [] -- Given a list of expressions to be concatenated (args to PrimConcat), @@ -1369,70 +1369,70 @@ splitEs _ _ _ = [] aConcat :: [AExpr] -> AExpr aConcat exs = let joinPairs :: [AExpr] -> [AExpr] - joinPairs ((APrim aid _ PrimExtract - [e, ASInt _ _ (IntLit _ _ hi), ASInt _ _ (IntLit _ _ lo) ]) : - (APrim aid' _ PrimExtract - [e', ASInt _ _ (IntLit _ _ hi'), ASInt _ _ (IntLit _ _ lo')]) : - as) | e == e' && lo == hi' + 1 = - joinPairs (aExtract e hi lo' : as) - joinPairs ((ASInt aid (ATBit s) (IntLit _ b i)) : (ASInt aid' (ATBit s') (IntLit _ _ i')) : as) = + joinPairs ((APrim aid _ PrimExtract + [e, ASInt _ _ (IntLit _ _ hi), ASInt _ _ (IntLit _ _ lo) ]) : + (APrim aid' _ PrimExtract + [e', ASInt _ _ (IntLit _ _ hi'), ASInt _ _ (IntLit _ _ lo')]) : + as) | e == e' && lo == hi' + 1 = + joinPairs (aExtract e hi lo' : as) + joinPairs ((ASInt aid (ATBit s) (IntLit _ b i)) : (ASInt aid' (ATBit s') (IntLit _ _ i')) : as) = -- XXX the literal has no width - joinPairs ((ASInt aid (ATBit (s+s')) (IntLit Nothing b (i*2^s' + i'))) : as) - joinPairs (a:as) = a : joinPairs as - joinPairs [] = [] - flat (APrim _ _ PrimConcat es) = concatMap flat es - flat e = [e] + joinPairs ((ASInt aid (ATBit (s+s')) (IntLit Nothing b (i*2^s' + i'))) : as) + joinPairs (a:as) = a : joinPairs as + joinPairs [] = [] + flat (APrim _ _ PrimConcat es) = concatMap flat es + flat e = [e] in case joinPairs (concatMap flat exs) of - [e] -> e - es -> APrim defaultAId (ATBit (sum (map aSize es))) PrimConcat es + [e] -> e + es -> APrim defaultAId (ATBit (sum (map aSize es))) PrimConcat es aSelect :: AExpr -> Integer -> Integer -> AExpr aSelect (ASAny _ _) _ d = ASAny (ATBit d) Nothing aSelect (ASInt aid _ (IntLit w b i)) offs d = - ASInt aid (ATBit d) (IntLit Nothing b (integerSelect d offs i)) + ASInt aid (ATBit d) (IntLit Nothing b (integerSelect d offs i)) aSelect (APrim aid _ PrimExtract [e, (ASInt _ _ _), ASInt _ _ (IntLit _ _ lo)]) offs d = - APrim aid (ATBit d) PrimExtract [e, aNat (offs+d-1+lo), aNat (offs+lo)] + APrim aid (ATBit d) PrimExtract [e, aNat (offs+d-1+lo), aNat (offs+lo)] aSelect e0@(APrim aid _ PrimConcat exs) offs dx = let (es', offs') = chopL (reverse exs) offs - where chopL (e:es) o | s <= o = chopL es (o-s) where s = aSize e - chopL es o = (es, o) - es'' = chopH es' (dx+offs') - where chopH (e:es) d | d > 0 = e : chopH es (d - aSize e) - chopH _ _ = [] + where chopL (e:es) o | s <= o = chopL es (o-s) where s = aSize e + chopL es o = (es, o) + es'' = chopH es' (dx+offs') + where chopH (e:es) d | d > 0 = e : chopH es (d - aSize e) + chopH _ _ = [] in case reverse es'' of - [] -> internalError ("aSelect PrimConcat " ++ ppReadable (e0, offs, dx)) - [e] -> aSelect e offs' dx - ses -> let ce = APrim aid (ATBit (sum (map aSize ses))) PrimConcat ses - in APrim aid (ATBit dx) PrimExtract [ce, aNat (offs'+dx-1), aNat offs'] + [] -> internalError ("aSelect PrimConcat " ++ ppReadable (e0, offs, dx)) + [e] -> aSelect e offs' dx + ses -> let ce = APrim aid (ATBit (sum (map aSize ses))) PrimConcat ses + in APrim aid (ATBit dx) PrimExtract [ce, aNat (offs'+dx-1), aNat offs'] aSelect e offs d = APrim defaultAId (ATBit d) PrimExtract [e, aNat (offs+d-1), aNat offs] aExtract :: AExpr -> Integer -> Integer -> AExpr aExtract e hi 0 | hi+1 == aSize e = e aExtract e hi lo = - APrim - defaultAId - (ATBit (hi-lo+1)) - PrimExtract [e, aNat hi, aNat lo] + APrim + defaultAId + (ATBit (hi-lo+1)) + PrimExtract [e, aNat hi, aNat lo] ------------ aMakeMux :: AId -> AType -> PrimOp -> [(AExpr, AExpr)] -> AExpr aMakeMux aid t op pexs = let pexs' = joinEq (if op == PrimMux then partition else span) pexs - joinEq f [] = [] - joinEq f ((p,e):pes) = - let (xs, pes') = f (aEqual e . snd) pes - in (aOrs (p : map fst xs), e) : joinEq f pes' + joinEq f [] = [] + joinEq f ((p,e):pes) = + let (xs, pes') = f (aEqual e . snd) pes + in (aOrs (p : map fst xs), e) : joinEq f pes' aEqual :: AExpr -> AExpr -> Bool - aEqual (ASInt _ _ (IntLit _ _ i)) (ASInt _ _ (IntLit _ _ i')) = i == i' - aEqual e e' = e == e' + aEqual (ASInt _ _ (IntLit _ _ i)) (ASInt _ _ (IntLit _ _ i')) = i == i' + aEqual e e' = e == e' in APrim aid t op (flattenPairs pexs') aIf :: AType -> AExpr -> AExpr -> AExpr -> AExpr aIf ty c (ASInt _ _ (IntLit _ _ 1)) (ASInt _ _ (IntLit _ _ 0)) = aZeroExt ty c aIf ty c (ASInt _ _ (IntLit _ _ 0)) (ASInt _ _ (IntLit _ _ 1)) = - aZeroExt ty (aBoolSimp (APrim dummy_id aTBool PrimBNot [c])) + aZeroExt ty (aBoolSimp (APrim dummy_id aTBool PrimBNot [c])) aIf ty@(ATBit 1) c t e = aBoolSimp (APrim dummy_id ty PrimIf [c, t, e]) aIf ty c t e = APrim dummy_id ty PrimIf [c, t, e] @@ -1440,8 +1440,8 @@ aIf ty c t e = APrim dummy_id ty PrimIf [c, t, e] aZeroExt :: AType -> AExpr -> AExpr aZeroExt (ATBit 1) e = e aZeroExt ty@(ATBit sz) e = APrim dummy_id ty PrimConcat - [ASInt defaultAId - (ATBit (sz-1)) (ilDec 0), e] + [ASInt defaultAId + (ATBit (sz-1)) (ilDec 0), e] aZeroExt _ _ = internalError( "AOpt::aZeroExt" ) -- This is only called by muxOpt, which only optimizes PrimMux and PrimPriMux @@ -1449,9 +1449,9 @@ aTransMux :: AExpr -> AExpr aTransMux (APrim _ t _ []) = ASAny t Nothing -- ok for both types aTransMux (APrim _ _ _ [_, e]) = e -- ok for both types aTransMux (APrim aid t PrimMux [p1, e1, p2, e2]) = - if isASimple p2 && not (isASimple p1) - then aIf t p2 e2 e1 - else aIf t p1 e1 e2 + if isASimple p2 && not (isASimple p1) + then aIf t p2 e2 e1 + else aIf t p1 e1 e2 aTransMux (APrim aid t PrimPriMux [p1, e1, p2, e2]) = aIf t p1 e1 e2 aTransMux e@(APrim {}) = e aTransMux _ = internalError( "AOpt::aTransMux" ) @@ -1460,13 +1460,13 @@ aTransAndOrMux :: AExpr -> AExpr aTransAndOrMux (APrim aid t PrimMux pes) = -- all inputs that are 0 can be removed from an AND/OR mux let pes' = filter (isNonZero . snd) (makePairs pes) - isNonZero (ASInt _ _ (IntLit _ _ 0)) = False - isNonZero _ = True + isNonZero (ASInt _ _ (IntLit _ _ 0)) = False + isNonZero _ = True in if t == aTBool then - -- turn a boolean mux into the corresponding expression. - aBoolSimp (APrim aid t PrimBOr [ APrim aid t PrimBAnd [p, e] | (p, e) <- pes' ]) - else - APrim aid t PrimMux (flattenPairs pes') + -- turn a boolean mux into the corresponding expression. + aBoolSimp (APrim aid t PrimBOr [ APrim aid t PrimBAnd [p, e] | (p, e) <- pes' ]) + else + APrim aid t PrimMux (flattenPairs pes') aTransAndOrMux e = e ------------ @@ -1484,17 +1484,17 @@ aBoolSimp e = -- a quick and dirty optimization of or-and expressions that are generated for the scheduler aOrAnd :: AExpr -> AExpr aOrAnd e@(APrim _ t PrimOr es@(_:_)) = - let es' = map (S.fromList . getOp PrimBAnd) es - common = foldr1 S.intersect es' - es'' = map (mkAnd . S.toList . (`S.minus` common)) es' - mkAnd :: [AExpr] -> AExpr - mkAnd [] = aBool True - mkAnd [e] = e - mkAnd es = APrim _ aTBool PrimBAnd es - in if S.null common then - e - else - APrim _ aTBool PrimBAnd (APrim _ aTBool PrimBOr es'') : S.toList common + let es' = map (S.fromList . getOp PrimBAnd) es + common = foldr1 S.intersect es' + es'' = map (mkAnd . S.toList . (`S.minus` common)) es' + mkAnd :: [AExpr] -> AExpr + mkAnd [] = aBool True + mkAnd [e] = e + mkAnd es = APrim _ aTBool PrimBAnd es + in if S.null common then + e + else + APrim _ aTBool PrimBAnd (APrim _ aTBool PrimBOr es'') : S.toList common aOrAnd e = e aOrAndS e = e @@ -1502,7 +1502,7 @@ aOrAndS e = e optXor :: AExpr -> AExpr optXor (APrim _ t PrimXor [ASInt aid _ (IntLit _ _ x), ASInt _ _ (IntLit _ _ y)]) = - ASInt aid t (ilSizedBin 1 ((x+y)`mod`2)) + ASInt aid t (ilSizedBin 1 ((x+y)`mod`2)) optXor (APrim _ t PrimXor [ASInt _ _ (IntLit _ _ 0), y]) = y optXor (APrim aid t PrimXor [ASInt _ _ (IntLit _ _ 1), y]) = aNotLabel aid y optXor (APrim _ t PrimXor [x, ASInt _ _ (IntLit _ _ 0)]) = x @@ -1523,10 +1523,10 @@ toBE e = Var e fromBE :: BoolExp AExpr -> AExpr fromBE (And b1 b2) = APrim defaultAId aTBool PrimBAnd (getOp PrimBAnd (fromBE b1) ++ - getOp PrimBAnd (fromBE b2)) + getOp PrimBAnd (fromBE b2)) fromBE (Or b1 b2) = APrim defaultAId aTBool PrimBOr (getOp PrimBOr (fromBE b1) ++ - getOp PrimBOr (fromBE b2)) + getOp PrimBOr (fromBE b2)) fromBE (Not b) = APrim defaultAId aTBool PrimBNot [fromBE b] fromBE (If c t e) = APrim defaultAId aTBool PrimIf [fromBE c, fromBE t, fromBE e] fromBE (Var e) = e diff --git a/src/comp/APaths.hs b/src/comp/APaths.hs index 5ae1bf698..5f3358905 100644 --- a/src/comp/APaths.hs +++ b/src/comp/APaths.hs @@ -1,8 +1,8 @@ module APaths( - PathGraphInfo, - PathUrgencyPairs, PathNode, - aPathsPreSched, aPathsPostSched - ) where + PathGraphInfo, + PathUrgencyPairs, PathNode, + aPathsPreSched, aPathsPostSched + ) where -- ======================================================================== -- APaths @@ -143,20 +143,20 @@ type PathEnv = M.Map AId PathNode -- The information that is passed between the pre and post scheduler stages data PathGraphInfo = PathGraphInfo - { pgi_graph :: Graph PathNode, - pgi_inputs :: [PathNode], - pgi_outputs :: [PathNode] } + { pgi_graph :: Graph PathNode, + pgi_inputs :: [PathNode], + pgi_outputs :: [PathNode] } instance PPrint PathGraphInfo where pPrint d p pgi = - text "PathGraphInfo" <+> text "{" $+$ - nest 2 (text "graph" <+> text "=" <+> - pPrint d p (pgi_graph pgi) <+> text "," $+$ - text "inputs" <+> text "=" <+> - pPrint d p (pgi_inputs pgi) <+> text "," $+$ - text "outputs" <+> text "=" <+> - pPrint d p (pgi_outputs pgi)) $+$ - text "}" + text "PathGraphInfo" <+> text "{" $+$ + nest 2 (text "graph" <+> text "=" <+> + pPrint d p (pgi_graph pgi) <+> text "," $+$ + text "inputs" <+> text "=" <+> + pPrint d p (pgi_inputs pgi) <+> text "," $+$ + text "outputs" <+> text "=" <+> + pPrint d p (pgi_outputs pgi)) $+$ + text "}" instance Hyper PathGraphInfo where hyper x y = hyper3 (pgi_graph x) (pgi_inputs x) (pgi_outputs x) y @@ -216,68 +216,68 @@ data PathNode = printPathNode :: Bool -> PDetail -> Int -> PathNode -> Doc printPathNode use_pvprint d p node = let pp :: (PVPrint a, PPrint a) => a -> Doc - pp = if (use_pvprint) - then pvPrint d p - else pPrint d p + pp = if (use_pvprint) + then pvPrint d p + else pPrint d p in case (node) of - (PNDef def_id) -> - fsep [text "Definition", quotes (pp def_id)] - (PNStateMethodArg inst_id meth_id port_id) -> - fsep [text "Argument", pp port_id, - s2par "of method", quotes (pp meth_id), - s2par "of submodule", quotes (pp inst_id)] - (PNStateMethodRes inst_id meth_id) -> - fsep [s2par "Return value", - s2par "of method", quotes (pp meth_id), - s2par "of submodule", quotes (pp inst_id)] - (PNStateMethodEnable inst_id meth_id) -> - fsep [s2par "Enable signal", - s2par "of method", quotes (pp meth_id), - s2par "of submodule", quotes (pp inst_id)] + (PNDef def_id) -> + fsep [text "Definition", quotes (pp def_id)] + (PNStateMethodArg inst_id meth_id port_id) -> + fsep [text "Argument", pp port_id, + s2par "of method", quotes (pp meth_id), + s2par "of submodule", quotes (pp inst_id)] + (PNStateMethodRes inst_id meth_id) -> + fsep [s2par "Return value", + s2par "of method", quotes (pp meth_id), + s2par "of submodule", quotes (pp inst_id)] + (PNStateMethodEnable inst_id meth_id) -> + fsep [s2par "Enable signal", + s2par "of method", quotes (pp meth_id), + s2par "of submodule", quotes (pp inst_id)] -- (PNStateMethodReady inst_id meth_id) -> ... - (PNStateArgument inst_id arg_id arg_num) -> --- fsep [s2par "Instantiation argument", pp arg_id] + (PNStateArgument inst_id arg_id arg_num) -> +-- fsep [s2par "Instantiation argument", pp arg_id] -- Report the position of the argument, not its mangled name - fsep [s2par "Instantiation argument", pp arg_num, - s2par "of submodule", quotes (pp inst_id)] - (PNStateMethodArgMux inst_id meth_id) -> - fsep [s2par "Control mux for arguments ", - s2par "of method", quotes (pp meth_id), - s2par "of submodule", quotes (pp inst_id)] - (PNCanFire rule_or_meth_id) -> - fsep [s2par "CanFire signal of rule/method", - quotes (pp rule_or_meth_id)] - (PNWillFire rule_or_meth_id) -> - fsep [s2par "WillFire signal of rule/method", - quotes (pp rule_or_meth_id)] - (PNTopMethodArg meth_id arg_id) -> - fsep [text "Argument", pp arg_id, - s2par "of top-level method", quotes (pp meth_id)] - (PNTopMethodRes meth_id) -> - fsep [text "Output", - s2par "of top-level method", quotes (pp meth_id)] - (PNTopMethodReady meth_id) -> - fsep [s2par "Ready condition", - s2par "of top-level method", quotes (pp meth_id)] - (PNTopMethodEnable meth_id) -> - fsep [s2par "Enable signal", - s2par "of top-level method", quotes (pp meth_id)] - (PNTopArgument arg_id arg_num) -> - fsep [s2par "Top-level module argument", --- quotes (pp arg_id)] + fsep [s2par "Instantiation argument", pp arg_num, + s2par "of submodule", quotes (pp inst_id)] + (PNStateMethodArgMux inst_id meth_id) -> + fsep [s2par "Control mux for arguments ", + s2par "of method", quotes (pp meth_id), + s2par "of submodule", quotes (pp inst_id)] + (PNCanFire rule_or_meth_id) -> + fsep [s2par "CanFire signal of rule/method", + quotes (pp rule_or_meth_id)] + (PNWillFire rule_or_meth_id) -> + fsep [s2par "WillFire signal of rule/method", + quotes (pp rule_or_meth_id)] + (PNTopMethodArg meth_id arg_id) -> + fsep [text "Argument", pp arg_id, + s2par "of top-level method", quotes (pp meth_id)] + (PNTopMethodRes meth_id) -> + fsep [text "Output", + s2par "of top-level method", quotes (pp meth_id)] + (PNTopMethodReady meth_id) -> + fsep [s2par "Ready condition", + s2par "of top-level method", quotes (pp meth_id)] + (PNTopMethodEnable meth_id) -> + fsep [s2par "Enable signal", + s2par "of top-level method", quotes (pp meth_id)] + (PNTopArgument arg_id arg_num) -> + fsep [s2par "Top-level module argument", +-- quotes (pp arg_id)] -- Report the position of the argument, not its mangled name - quotes (pp arg_num)] + quotes (pp arg_num)] (PNClk clk_id) -> - s2par ("Clock: " ++ (pfpReadable clk_id)) + s2par ("Clock: " ++ (pfpReadable clk_id)) (PNRstN rstn_id) -> - s2par ("Reset: " ++ (pfpReadable rstn_id)) + s2par ("Reset: " ++ (pfpReadable rstn_id)) (PNTopClkGate gate_id) -> s2par ("Top-level module clock-gating input: " ++ - pfpReadable gate_id) + pfpReadable gate_id) (PNStateClkGate inst_id clk_id) -> - fsep [s2par "Clock-gating output", - s2par "of clock", quotes (pp clk_id), - s2par "of submodule", quotes (pp inst_id)] + fsep [s2par "Clock-gating output", + s2par "of clock", quotes (pp clk_id), + s2par "of submodule", quotes (pp inst_id)] instance PPrint PathNode where pPrint d p = printPathNode False d p @@ -293,7 +293,7 @@ instance Hyper PathNode where filterPNDefs :: [PathNode] -> [PathNode] filterPNDefs pns = filter (not . isPNDef) pns where isPNDef (PNDef _) = True - isPNDef _ = False + isPNDef _ = False alwaysRdyNode pps (PNTopMethodRes m) = isAlwaysRdy pps m alwaysRdyNode pps _ = False @@ -379,7 +379,7 @@ aPathsPreSched errh flags apkg = do -- XXX needed now, right? let numbered_inputs = let pair_to_triple x (y,z) = (x,y,z) - in zipWith pair_to_triple [1..] inputs_with_arginfo + in zipWith pair_to_triple [1..] inputs_with_arginfo -- the Verilog names of the clocks/resets according to the VWireInfo let clk_ports = getInputClockPorts (wClk wi) @@ -399,18 +399,18 @@ aPathsPreSched errh flags apkg = do getRstPort (AAI_Reset r) = r getRstPort ai = internalError ("APaths: unexpected rst input: " ++ - ppReadable ai) + ppReadable ai) getSimplePort (AAI_Port p) = p getSimplePort ai = internalError ("APaths: unexpected port input: " ++ - ppReadable ai) + ppReadable ai) -- drop the type info on clocks/resets, and the numbering clk_inputs = concatMap getClkPorts - [ ai | (n, ai, arginfo) <- numbered_inputs, + [ ai | (n, ai, arginfo) <- numbered_inputs, isClock arginfo ] rst_inputs = map getRstPort - [ ai | (n, ai, arginfo) <- numbered_inputs, + [ ai | (n, ai, arginfo) <- numbered_inputs, isReset arginfo ] -- keep the numbering and type for ports/params port_inputs = [ (n,p) | (n, ai, arginfo) <- numbered_inputs, @@ -461,38 +461,38 @@ aPathsPreSched errh flags apkg = do -- Note: the VPort's are stripped of VeriPortProp to be just VName -- XXX is the VeriPortProp info worth keeping? state_instances :: - [ ( AId, [(VName, VName)], [(VName, Integer, AExpr)], - [(AId, [(VName,Integer)], Maybe VName, Maybe VName, Maybe AId)] ) ] + [ ( AId, [(VName, VName)], [(VName, Integer, AExpr)], + [(AId, [(VName,Integer)], Maybe VName, Maybe VName, Maybe AId)] ) ] state_instances = - [(inst_id, nns, args, meth_info) | + [(inst_id, nns, args, meth_info) | avi <- vs, - let vmi = avi_vmi avi, + let vmi = avi_vmi avi, -- instance name - let inst_id = avi_vname avi, - let args = getVModInfoArgs avi, - -- path info pairs - let (VPathInfo nns) = vPath vmi, - - -- instantiation arguments - -- (for now, we don't track paths through clk and rst) - -- let (_,_,_,args) = getVModInfoArgs avi, - - -- method info - let meth_info = - [(meth_id, numbered_args, maybe_EN, maybe_res, maybe_clk) | - vfieldinfo@(Method { vf_name = meth_id }) <- vFields vmi, - let args = map fst (vf_inputs vfieldinfo), - let numbered_args = zip args [1..], - let maybe_EN = (vf_enable vfieldinfo) >>= return . fst, - let maybe_res = (vf_output vfieldinfo) >>= return . fst, + let inst_id = avi_vname avi, + let args = getVModInfoArgs avi, + -- path info pairs + let (VPathInfo nns) = vPath vmi, + + -- instantiation arguments + -- (for now, we don't track paths through clk and rst) + -- let (_,_,_,args) = getVModInfoArgs avi, + + -- method info + let meth_info = + [(meth_id, numbered_args, maybe_EN, maybe_res, maybe_clk) | + vfieldinfo@(Method { vf_name = meth_id }) <- vFields vmi, + let args = map fst (vf_inputs vfieldinfo), + let numbered_args = zip args [1..], + let maybe_EN = (vf_enable vfieldinfo) >>= return . fst, + let maybe_res = (vf_output vfieldinfo) >>= return . fst, let maybe_clk = vf_clock vfieldinfo ] ] state_input_nodes = - [ PNStateMethodArg inst_id meth_id arg_num | + [ PNStateMethodArg inst_id meth_id arg_num | (inst_id, _, _, methods) <- state_instances, - (meth_id, numbered_args, maybe_EN, maybe_res, _) <- methods, + (meth_id, numbered_args, maybe_EN, maybe_res, _) <- methods, arg_num <- map snd numbered_args ] state_output_nodes = @@ -507,14 +507,14 @@ aPathsPreSched errh flags apkg = do ] state_arg_nodes = - [ PNStateArgument inst_id arg_id arg_num | - (inst_id, _, arg_pairs, _) <- state_instances, + [ PNStateArgument inst_id arg_id arg_num | + (inst_id, _, arg_pairs, _) <- state_instances, (arg_id, arg_num, _) <- arg_pairs ] state_mux_nodes = - [ PNStateMethodArgMux inst_id meth_id | - (inst_id, _, _, methods) <- state_instances, + [ PNStateMethodArgMux inst_id meth_id | + (inst_id, _, _, methods) <- state_instances, (meth_id, args, _, _, _) <- methods, length args > 0 ] @@ -525,12 +525,12 @@ aPathsPreSched errh flags apkg = do -- noAction rules). let rule_ids = -- methods - [ r_id | (AIAction { aif_body = rs }) <- ifc, + [ r_id | (AIAction { aif_body = rs }) <- ifc, (ARule { arule_id = r_id }) <- rs ] ++ - [ r_id | (AIActionValue { aif_body = rs }) <- ifc, + [ r_id | (AIActionValue { aif_body = rs }) <- ifc, (ARule { arule_id = r_id }) <- rs ] ++ -- rules - [ r_id | (ARule { arule_id = r_id }) <- ors ] + [ r_id | (ARule { arule_id = r_id }) <- ors ] let can_fire_nodes = [ PNCanFire r_id | r_id <- rule_ids ] let will_fire_nodes = [ PNWillFire r_id | r_id <- rule_ids ] @@ -538,51 +538,51 @@ aPathsPreSched errh flags apkg = do -- ---------- let method_inputs = - [(arg, PNTopMethodArg m arg) | (AIDef { aif_inputs = args, + [(arg, PNTopMethodArg m arg) | (AIDef { aif_inputs = args, aif_value = (ADef m _ _ _) }) <- ifc, - (arg,_) <- args] ++ - [(arg, PNTopMethodArg m arg) | (AIAction { aif_inputs = args, + (arg,_) <- args] ++ + [(arg, PNTopMethodArg m arg) | (AIAction { aif_inputs = args, aif_name = m }) <- ifc, - (arg,_) <- args] ++ + (arg,_) <- args] ++ [(arg, PNTopMethodArg m arg) | (AIActionValue { aif_inputs = args, aif_name = m }) <- ifc, (arg,_) <- args] method_outputs = - [(m, PNTopMethodRes m) | (AIDef { aif_value = (ADef m _ _ _) }) <- ifc] ++ - [(m, PNTopMethodRes m) | (AIActionValue { aif_name = m, aif_value = (ADef m' _ _ _) }) <- ifc] + [(m, PNTopMethodRes m) | (AIDef { aif_value = (ADef m _ _ _) }) <- ifc] ++ + [(m, PNTopMethodRes m) | (AIActionValue { aif_name = m, aif_value = (ADef m' _ _ _) }) <- ifc] method_enables = - -- Name creation is safe, since it is based on VFieldInfo - [(mkNamedEnable afi, PNTopMethodEnable m) | + -- Name creation is safe, since it is based on VFieldInfo + [(mkNamedEnable afi, PNTopMethodEnable m) | (AIAction { aif_name = m, aif_fieldinfo = afi }) <- ifc ] ++ - [(mkNamedEnable afi, PNTopMethodEnable m) | + [(mkNamedEnable afi, PNTopMethodEnable m) | (AIActionValue { aif_name = m, aif_fieldinfo = afi }) <- ifc ] -- port and parameter module args which are not clocks or resets module_arg_ports = - [ (arg_id, PNTopArgument arg_id arg_num) | - (arg_num, (arg_id,_)) <- port_inputs ] + [ (arg_id, PNTopArgument arg_id arg_num) | + (arg_num, (arg_id,_)) <- port_inputs ] module_arg_params = - [ (arg_id, PNTopArgument arg_id arg_num) | - (arg_num, (arg_id,_)) <- param_inputs ] + [ (arg_id, PNTopArgument arg_id arg_num) | + (arg_num, (arg_id,_)) <- param_inputs ] clk_wires = [ (i, PNClk i) - | AClock { aclock_osc = ASPort _ i } <- clks ] + | AClock { aclock_osc = ASPort _ i } <- clks ] input_clk_wires = filter (\(i,n) -> i `elem` clk_inputs) clk_wires gate_wires = [ (i, PNTopClkGate i) - | AClock { aclock_gate = ASPort _ i } <- clks ] + | AClock { aclock_gate = ASPort _ i } <- clks ] input_clk_gate_wires = - let -- should not be any which is not an elem of clk_inputs - isInputClk i = elem i clk_inputs - non_input_clk_gates = - filter (not . isInputClk) (map fst gate_wires) - in if (null non_input_clk_gates) - then gate_wires - else internalError - ("Found non-input clock gates referenced as ASPort: " ++ - ppReadable non_input_clk_gates) + let -- should not be any which is not an elem of clk_inputs + isInputClk i = elem i clk_inputs + non_input_clk_gates = + filter (not . isInputClk) (map fst gate_wires) + in if (null non_input_clk_gates) + then gate_wires + else internalError + ("Found non-input clock gates referenced as ASPort: " ++ + ppReadable non_input_clk_gates) rstn_wires = [ (i, PNRstN i) | AReset { areset_wire = ASPort _ i } <- rsts ] input_rstn_wires = filter (\(i,n) -> i `elem` rst_inputs) rstn_wires @@ -606,8 +606,8 @@ aPathsPreSched errh flags apkg = do -- ---------- submod_clk_gate_nodes = - [ (PNStateClkGate i c) - | AClock { aclock_gate = AMGate _ i c } <- clks ] + [ (PNStateClkGate i c) + | AClock { aclock_gate = AMGate _ i c } <- clks ] -- ---------- @@ -617,14 +617,14 @@ aPathsPreSched errh flags apkg = do let pathnodes = def_nodes ++ state_input_nodes ++ state_output_nodes ++ - state_enable_nodes ++ state_arg_nodes ++ - state_mux_nodes ++ - can_fire_nodes ++ will_fire_nodes ++ - method_input_nodes ++ method_output_nodes ++ - method_enable_nodes ++ method_ready_nodes ++ - module_arg_port_nodes ++ module_arg_param_nodes ++ + state_enable_nodes ++ state_arg_nodes ++ + state_mux_nodes ++ + can_fire_nodes ++ will_fire_nodes ++ + method_input_nodes ++ method_output_nodes ++ + method_enable_nodes ++ method_ready_nodes ++ + module_arg_port_nodes ++ module_arg_param_nodes ++ clk_nodes ++ gate_nodes ++ rstn_nodes ++ - submod_clk_gate_nodes + submod_clk_gate_nodes -- ==================== -- Determine the edges of the graph @@ -640,7 +640,7 @@ aPathsPreSched errh flags apkg = do -- (laziness ensures it will not be computed unless necessary) let overlap_error a b = internalError ("APaths.aPaths': ifc or def overlap: " ++ - ppReadable a ++ ppReadable b) + ppReadable a ++ ppReadable b) -- add ifc_env elements one-by-one, -- bailing with an error if we ever need to combine @@ -665,82 +665,82 @@ aPathsPreSched errh flags apkg = do let mkMethodEdges :: AIFace -> [(PathNode,PathNode)] mkMethodEdges (AIDef mid inputs wp rdy (ADef m _ e _) _ _) = - -- connect the rdy expression (likely just an ASDef reference) - -- to the internal graph node for the method ready - (mkEdges (PNTopMethodReady m) rdy env) ++ - -- make faux connections from the rdy to the arguments, so that - -- dependencies in the other direction are caught as loops - [(PNTopMethodReady m, PNTopMethodArg m arg) | (arg,_) <- inputs] ++ + -- connect the rdy expression (likely just an ASDef reference) + -- to the internal graph node for the method ready + (mkEdges (PNTopMethodReady m) rdy env) ++ + -- make faux connections from the rdy to the arguments, so that + -- dependencies in the other direction are caught as loops + [(PNTopMethodReady m, PNTopMethodArg m arg) | (arg,_) <- inputs] ++ -- connect the definition to the method result - -- (this method has no enable, so it cannot contribute to any - -- methcall argument muxes, so just use "mkEdges") - (mkEdges (PNTopMethodRes m) e env) + -- (this method has no enable, so it cannot contribute to any + -- methcall argument muxes, so just use "mkEdges") + (mkEdges (PNTopMethodRes m) e env) mkMethodEdges (AIAction inputs wp rdy m rs fi) = - let rdy_node = PNTopMethodReady m - en_node = PNTopMethodEnable m - mkMRuleEdges (ARule ri _ _ _ rpred actions _ _) = - -- Note: rule predicate -> CanFire + let rdy_node = PNTopMethodReady m + en_node = PNTopMethodEnable m + mkMRuleEdges (ARule ri _ _ _ rpred actions _ _) = + -- Note: rule predicate -> CanFire -- method predicate -> CanFire -- CanFire -> method RDY -- method EN -> WillFire -- WillFire -> rule action enables - -- Connection from CanFire to WillFire added in sched_edges. - let cf_node = PNCanFire ri - wf_node = PNWillFire ri - in -- add edges from rule predicate to the CanFire - (mkEdges cf_node rpred env) ++ + -- Connection from CanFire to WillFire added in sched_edges. + let cf_node = PNCanFire ri + wf_node = PNWillFire ri + in -- add edges from rule predicate to the CanFire + (mkEdges cf_node rpred env) ++ -- add edges from method predicate to CanFire (mkEdges cf_node rdy env) ++ -- add edge from the CanFire to method RDY [(cf_node, rdy_node)] ++ - -- add edge from the method EN to the WillFire + -- add edge from the method EN to the WillFire [(en_node, wf_node)] ++ - -- add edges from rule WillFire to ENs in each action - (concatMap (mkActionEdges env wf_node) actions) - in - -- make faux connections from the rdy to the arguments and the - -- enable, so that dependencies in the other direction are caught - -- as loops - [(rdy_node, en_node)] ++ - [(rdy_node, PNTopMethodArg m arg) - | (arg,_) <- inputs] ++ - -- connect the rules - concatMap mkMRuleEdges rs + -- add edges from rule WillFire to ENs in each action + (concatMap (mkActionEdges env wf_node) actions) + in + -- make faux connections from the rdy to the arguments and the + -- enable, so that dependencies in the other direction are caught + -- as loops + [(rdy_node, en_node)] ++ + [(rdy_node, PNTopMethodArg m arg) + | (arg,_) <- inputs] ++ + -- connect the rules + concatMap mkMRuleEdges rs mkMethodEdges (AIActionValue inputs wp rdy m rs (ADef m' _ e _) fi) = - let rdy_node = PNTopMethodReady m - en_node = PNTopMethodEnable m - mkMRuleEdges (ARule ri _ _ _ rpred actions _ _) = - -- Note: rule predicate -> CanFire + let rdy_node = PNTopMethodReady m + en_node = PNTopMethodEnable m + mkMRuleEdges (ARule ri _ _ _ rpred actions _ _) = + -- Note: rule predicate -> CanFire -- method predicate -> CanFire -- CanFire -> method RDY -- method EN -> WillFire -- WillFire -> rule action enables - -- Connection from CanFire to WillFire added in sched_edges. - let cf_node = PNCanFire ri - wf_node = PNWillFire ri - in -- add edges from rule predicate to the CanFire - (mkEdges cf_node rpred env) ++ + -- Connection from CanFire to WillFire added in sched_edges. + let cf_node = PNCanFire ri + wf_node = PNWillFire ri + in -- add edges from rule predicate to the CanFire + (mkEdges cf_node rpred env) ++ -- add edges from method predicate to CanFire (mkEdges cf_node rdy env) ++ -- add edge from the CanFire to method RDY [(cf_node, rdy_node)] ++ - -- add edge from the method EN to the WillFire + -- add edge from the method EN to the WillFire [(en_node, wf_node)] ++ - -- add edges from rule WillFire to ENs in each action - (concatMap (mkActionEdges env wf_node) actions) - in - -- make faux connections from the rdy to the arguments and the - -- enable, so that dependencies in the other direction are caught - -- as loops - [(rdy_node, en_node)] ++ - [(rdy_node, PNTopMethodArg m arg) - | (arg,_) <- inputs] ++ + -- add edges from rule WillFire to ENs in each action + (concatMap (mkActionEdges env wf_node) actions) + in + -- make faux connections from the rdy to the arguments and the + -- enable, so that dependencies in the other direction are caught + -- as loops + [(rdy_node, en_node)] ++ + [(rdy_node, PNTopMethodArg m arg) + | (arg,_) <- inputs] ++ -- connect the definition to the method result - -- (this method's Enable could contribute to methcall argument - -- muxes, so use "mkEdgesWithMux") + -- (this method's Enable could contribute to methcall argument + -- muxes, so use "mkEdgesWithMux") (mkEdgesWithMux en_node (PNTopMethodRes m) e env) ++ - -- connect the rules + -- connect the rules concatMap mkMRuleEdges rs mkMethodEdges (AIClock {}) = [] @@ -753,10 +753,10 @@ aPathsPreSched errh flags apkg = do -- rules (rt) let mkRuleEdges (ARule ri _ _ _ rpred actions _ _) = - -- Note: Connection from canfire to willfire added in sched_edges. - -- add edge from pred to can_fire + -- Note: Connection from canfire to willfire added in sched_edges. + -- add edge from pred to can_fire (mkEdges (PNCanFire ri) rpred env) ++ - -- add edges from will_fire to ENs of actions + -- add edges from will_fire to ENs of actions (concatMap (mkActionEdges env (PNWillFire ri)) actions) rule_edges = concatMap mkRuleEdges ors @@ -774,48 +774,48 @@ aPathsPreSched errh flags apkg = do res == vname ] findInputPathNodes inst_id vname methods argpairs = - [ (Nothing, PNStateArgument inst_id arg_id arg_num) | - (arg_id, arg_num, _) <- argpairs + [ (Nothing, PNStateArgument inst_id arg_id arg_num) | + (arg_id, arg_num, _) <- argpairs ] ++ [ (clk, PNStateMethodEnable inst_id meth_id) | (meth_id, _, Just enable, _, clk) <- methods, enable == vname ] ++ - [ (clk, PNStateMethodArg inst_id meth_id arg_num) | - (meth_id, args, _, _, clk) <- methods, + [ (clk, PNStateMethodArg inst_id meth_id arg_num) | + (meth_id, args, _, _, clk) <- methods, (arg, arg_num) <- args, arg == vname ] -- Connect module inputs and outputs based on the path annotations let state_internal_edges = - [ (pn1, pn2) | - (inst_id, pathpairs, argpairs, methods) <- state_instances, - (vname1, vname2) <- pathpairs, - (clk1,pn1) <- findInputPathNodes inst_id vname1 methods argpairs, - (clk2,pn2) <- findOutputPathNodes inst_id vname2 methods, + [ (pn1, pn2) | + (inst_id, pathpairs, argpairs, methods) <- state_instances, + (vname1, vname2) <- pathpairs, + (clk1,pn1) <- findInputPathNodes inst_id vname1 methods argpairs, + (clk2,pn2) <- findOutputPathNodes inst_id vname2 methods, (clk1 == clk2) || (isNothing clk1) || (isNothing clk2) - ] + ] -- Connect module instantiation arguments to the expressions provided -- at instantiation time for their values. let mkStateArgEdge inst_id (arg_id, arg_num, arg_expr) = let arg_node = PNStateArgument inst_id arg_id arg_num - in mkEdges arg_node arg_expr env + in mkEdges arg_node arg_expr env state_arg_edges = - [ e | (inst_id, _, arg_pairs, _) <- state_instances, - arg_pair <- arg_pairs, - e <- mkStateArgEdge inst_id arg_pair + [ e | (inst_id, _, arg_pairs, _) <- state_instances, + arg_pair <- arg_pairs, + e <- mkStateArgEdge inst_id arg_pair ] -- Connect the control mux for a method to the arguments of that method let state_mux_edges = - [ (PNStateMethodArgMux inst_id meth_id, + [ (PNStateMethodArgMux inst_id meth_id, PNStateMethodArg inst_id meth_id arg_num) | - (inst_id, _, _, methods) <- state_instances, - (meth_id, args, _, _, _) <- methods, - (_, arg_num) <- args ] + (inst_id, _, _, methods) <- state_instances, + (meth_id, args, _, _, _) <- methods, + (_, arg_num) <- args ] -- Combine all the submodule edges let state_edges = @@ -837,13 +837,13 @@ aPathsPreSched errh flags apkg = do -- for rules [ (PNCanFire ri, PNWillFire ri) | (ARule { arule_id = ri }) <- ors ] ++ - -- for methods - [ (PNCanFire ri, PNWillFire ri) | - (AIAction { aif_body = rs }) <- ifc, - (ARule { arule_id = ri }) <- rs ] ++ - [ (PNCanFire ri, PNWillFire ri) | - (AIActionValue { aif_body = rs }) <- ifc, - (ARule { arule_id = ri }) <- rs ] + -- for methods + [ (PNCanFire ri, PNWillFire ri) | + (AIAction { aif_body = rs }) <- ifc, + (ARule { arule_id = ri }) <- rs ] ++ + [ (PNCanFire ri, PNWillFire ri) | + (AIActionValue { aif_body = rs }) <- ifc, + (ARule { arule_id = ri }) <- rs ] -- -------------------- @@ -866,7 +866,7 @@ aPathsPreSched errh flags apkg = do n <- filter (\x -> not (S.member x pathnodeset)) [n1,n2] ] when (length unknown_nodes > 0) $ internalError ("APath.aPaths': nodes not in graph: " ++ - show unknown_nodes) + show unknown_nodes) -- ==================== -- Construct the graph @@ -889,7 +889,7 @@ aPathsPreSched errh flags apkg = do let rdy_to_en_edges = [(PNTopMethodRes rdy_id, PNTopMethodEnable m_id) | (AIAction { aif_pred = (ASDef _ rdy_id), aif_name = m_id, aif_fieldinfo = m_fi }) <- ifc ] ++ - [(PNTopMethodRes rdy_id, PNTopMethodEnable m_id) | + [(PNTopMethodRes rdy_id, PNTopMethodEnable m_id) | (AIActionValue { aif_pred = (ASDef _ rdy_id), aif_name = m_id, aif_fieldinfo = m_fi }) <- ifc ] @@ -903,17 +903,17 @@ aPathsPreSched errh flags apkg = do (PNWillFire wf_rule_id, rs) <- zip will_fire_nodes reachables, cf_node@(PNCanFire cf_rule_id) <- can_fire_nodes, let mpath = lookup cf_node rs, - isJust mpath, - let filtered_path = reverse (filterPNDefs (fromJust mpath)) ] - ++ - -- edges from WF to RDY of value method - [ (wf_rule_id, meth_id, filtered_path) | - (PNWillFire wf_rule_id, rs) <- zip will_fire_nodes reachables, + isJust mpath, + let filtered_path = reverse (filterPNDefs (fromJust mpath)) ] + ++ + -- edges from WF to RDY of value method + [ (wf_rule_id, meth_id, filtered_path) | + (PNWillFire wf_rule_id, rs) <- zip will_fire_nodes reachables, (AIDef { aif_value = (ADef meth_id _ _ _) }) <- ifc, let meth_node = (PNTopMethodReady meth_id), let mpath = lookup meth_node rs, - isJust mpath, - let filtered_path = reverse (filterPNDefs (fromJust mpath)) ] + isJust mpath, + let filtered_path = reverse (filterPNDefs (fromJust mpath)) ] when trace_apaths $ do @@ -934,8 +934,8 @@ aPathsPreSched errh flags apkg = do mod_outputs = method_output_nodes let pathGraphInfo = PathGraphInfo { pgi_graph = pathgraph, - pgi_inputs = mod_inputs, - pgi_outputs = mod_outputs } + pgi_inputs = mod_inputs, + pgi_outputs = mod_outputs } return (pathGraphInfo, urgency_pairs) @@ -956,7 +956,7 @@ aPathsPreSched errh flags apkg = do -- ruleOrd = list of rule IDs in reverse order of execution -- aPathsPostSched :: Flags -> [PProp] -> APackage -> - PathGraphInfo -> ASchedule -> IO (VPathInfo) + PathGraphInfo -> ASchedule -> IO (VPathInfo) aPathsPostSched flags pps apkg pathGraphInfo (ASchedule scheds _) = do -- ==================== @@ -988,17 +988,17 @@ aPathsPostSched flags pps apkg pathGraphInfo (ASchedule scheds _) = do ss' = [(i, partition isRule cs) | (i,cs) <- ss ] (rule_sched, meth_sched) = partition (isUserRule . fst) ss' rr_edges = -- WF of conflicting rule -> WF of user-rule - [ (PNWillFire r2, PNWillFire r1) + [ (PNWillFire r2, PNWillFire r1) | (r1,(rcs,_)) <- rule_sched , r2 <- rcs ] mr_edges = -- RDY of conflicting value method -> WF of user-rule - [ (PNTopMethodReady vm, PNWillFire r) + [ (PNTopMethodReady vm, PNWillFire r) | (r,(_,vmcs)) <- rule_sched , vm <- vmcs ] rm_edges = -- WF of conflicting rule -> RDY of a method - [ (PNWillFire r, PNTopMethodReady m) + [ (PNWillFire r, PNTopMethodReady m) | (m,(rcs,_)) <- meth_sched , r <- rcs ] @@ -1034,7 +1034,7 @@ aPathsPostSched flags pps apkg pathGraphInfo (ASchedule scheds _) = do -- pairs of PathNode let pathpairs = [ (input, output) | -- we don't need to know the path - (input, rs) <- zip mod_inputs reachables, + (input, rs) <- zip mod_inputs reachables, output <- mod_outputs, isJust (lookup output rs) ] @@ -1050,30 +1050,30 @@ aPathsPostSched flags pps apkg pathGraphInfo (ASchedule scheds _) = do [ (meth_id, ({-numbered_args,-} maybe_EN, maybe_res)) | meth <- apkg_interface apkg, let vfieldinfo = aif_fieldinfo meth, - let meth_id = vf_name vfieldinfo, - --let args = map fst (vf_inputs vfieldinfo), - --let numbered_args = zip args [1..], - let maybe_EN = (vf_enable vfieldinfo) >>= return . fst, - let maybe_res = (vf_output vfieldinfo) >>= return . fst - ] + let meth_id = vf_name vfieldinfo, + --let args = map fst (vf_inputs vfieldinfo), + --let numbered_args = zip args [1..], + let maybe_EN = (vf_enable vfieldinfo) >>= return . fst, + let maybe_res = (vf_output vfieldinfo) >>= return . fst + ] let findMethod m = case (M.lookup m meth_info_map) of - Just info -> info - Nothing -> internalError ("APaths findMethod: " ++ ppReadable m) + Just info -> info + Nothing -> internalError ("APaths findMethod: " ++ ppReadable m) -- the "arg" is already the VName and not a number let convertArg m arg = aidToVName arg let convertRes m = case (findMethod m) of - (_, Just res) -> res - _ -> internalError ("APaths convertRes: " ++ ppReadable m) + (_, Just res) -> res + _ -> internalError ("APaths convertRes: " ++ ppReadable m) let convertEnable m = case (findMethod m) of - (Just enable, _) -> enable - _ -> internalError ("APaths convertEnable: " ++ ppReadable m) + (Just enable, _) -> enable + _ -> internalError ("APaths convertEnable: " ++ ppReadable m) -- convert PathNode back to VName let pnToVName (PNTopMethodArg m arg) = convertArg m arg @@ -1127,7 +1127,7 @@ mkEdges pn e env = -- * expression -- * environment mkEdgesWithMux :: PathNode -> PathNode -> AExpr -> PathEnv -> - [(PathNode, PathNode)] + [(PathNode, PathNode)] mkEdgesWithMux en pn e env = let (is, edges, mux_nodes) = findEdges env e in edges ++ (connectEdge pn is) ++ (connectEdgeR en mux_nodes) @@ -1142,13 +1142,13 @@ connectEdgeR pn pns = map (\x -> (pn, x)) pns mkActionEdges :: PathEnv -> PathNode -> AAction -> - [(PathNode, PathNode)] + [(PathNode, PathNode)] mkActionEdges env en (ACall state_id qual_meth_id (cond:exprs)) = let meth_id = unQualId qual_meth_id - meth_en = PNStateMethodEnable state_id meth_id - meth_arg_mux = PNStateMethodArgMux state_id meth_id - meth_args = - map (\arg_num -> PNStateMethodArg state_id meth_id arg_num) [1..] + meth_en = PNStateMethodEnable state_id meth_id + meth_arg_mux = PNStateMethodArgMux state_id meth_id + meth_args = + map (\arg_num -> PNStateMethodArg state_id meth_id arg_num) [1..] in -- if the method has arguments, connect the enable signal of the -- action to the control mux for the arguments @@ -1184,7 +1184,7 @@ mkActionEdges env en action = -- * expression to be analyzed -- findEdges :: PathEnv -> AExpr -> - ([PathNode], [(PathNode, PathNode)], [PathNode]) + ([PathNode], [(PathNode, PathNode)], [PathNode]) findEdges env (APrim i t op es) = -- make edge between inputs and output concatUnzip3 (map (findEdges env) es) @@ -1192,14 +1192,14 @@ findEdges env (AMethCall t i qmi exprs) = -- make edges between exprs and meth input -- return the output connection let mi = unQualId qmi - -- like mkEdgesWithMux, but want to return the muxes, not connect them - f (n,exp) = let (is, edges, muxes) = findEdges env exp - pn = PNStateMethodArg i mi n - es = edges ++ (connectEdge pn is) - in (es, muxes) + -- like mkEdgesWithMux, but want to return the muxes, not connect them + f (n,exp) = let (is, edges, muxes) = findEdges env exp + pn = PNStateMethodArg i mi n + es = edges ++ (connectEdge pn is) + in (es, muxes) (edges, ms) = concatUnzip (map f (zip [1..] exprs)) - meth_arg_mux = PNStateMethodArgMux i mi - muxes = if (length exprs > 0) then (meth_arg_mux:ms) else ms + meth_arg_mux = PNStateMethodArgMux i mi + muxes = if (length exprs > 0) then (meth_arg_mux:ms) else ms in ([PNStateMethodRes i mi], edges, muxes) findEdges env (AMethValue t i qmi) = ([PNStateMethodRes i (unQualId qmi)], [], []) @@ -1215,18 +1215,18 @@ findEdges env (ATaskValue { }) = ([],[],[]) -- module port reference findEdges env (ASPort t i) = case (M.lookup i env) of - Nothing -> internalError ("findEdges: unknown ASPort: " ++ ppReadable i) - Just pn -> ([pn],[],[]) + Nothing -> internalError ("findEdges: unknown ASPort: " ++ ppReadable i) + Just pn -> ([pn],[],[]) -- module parameter reference findEdges env (ASParam t i) = case (M.lookup i env) of - Nothing -> internalError ("findEdges: unknown ASParam: " ++ ppReadable i) - Just pn -> ([pn],[],[]) + Nothing -> internalError ("findEdges: unknown ASParam: " ++ ppReadable i) + Just pn -> ([pn],[],[]) -- ref to local def findEdges env (ASDef t i) = case (M.lookup i env) of - Nothing -> internalError ("findEdges: unknown ASDef: " ++ ppReadable i) - Just pn -> ([pn],[],[]) + Nothing -> internalError ("findEdges: unknown ASDef: " ++ ppReadable i) + Just pn -> ([pn],[],[]) findEdges env (ASInt _ _ _) = ([],[],[]) findEdges env (ASReal _ _ _) = ([],[],[]) findEdges env (ASStr _ _ _) = ([],[],[]) @@ -1259,62 +1259,62 @@ errPathCycle moduleId graph cycle = -- (notice that PNDefs are omitted) printPath path = pPrint PDReadable 0 (filterPNDefs path) - -- --------------- - -- Functions for reporting the different types of errors + -- --------------- + -- Functions for reporting the different types of errors - -- function to make the default error message - default_err = - (getPosition moduleId, EPreSchedCycle (printPath cycle)) + -- function to make the default error message + default_err = + (getPosition moduleId, EPreSchedCycle (printPath cycle)) - -- function to make WF-to-CF error message - mkWfToCfErr (ruleId, Just path) = - (getPosition ruleId, - ESelfUrgency (pfpString ruleId) (printPath path)) - mkWfToCfErr x = internalError - ("APaths.errPathCycle: WfToCf: " ++ show x) + -- function to make WF-to-CF error message + mkWfToCfErr (ruleId, Just path) = + (getPosition ruleId, + ESelfUrgency (pfpString ruleId) (printPath path)) + mkWfToCfErr x = internalError + ("APaths.errPathCycle: WfToCf: " ++ show x) mkArgToRdyErr (methodId, argId, Just path) = - (getPosition moduleId, - EPathMethodArgToRdy - (pfpString methodId) (pfpString argId) (printPath path)) - mkArgToRdyErr x = internalError - ("APaths.errPathCycle: ArgToRdy: " ++ show x) - - mkEnToRdyErr (methodId, Just path) = - (getPosition moduleId, - EPathMethodEnToRdy (pfpString methodId) (printPath path)) - mkEnToRdyErr x = internalError - ("APaths.errPathCycle: EnToRdy: " ++ show x) - - -- --------------- - - method_arg_errs = - [ mkArgToRdyErr (m1, argId, findPath graph arg rdy) | + (getPosition moduleId, + EPathMethodArgToRdy + (pfpString methodId) (pfpString argId) (printPath path)) + mkArgToRdyErr x = internalError + ("APaths.errPathCycle: ArgToRdy: " ++ show x) + + mkEnToRdyErr (methodId, Just path) = + (getPosition moduleId, + EPathMethodEnToRdy (pfpString methodId) (printPath path)) + mkEnToRdyErr x = internalError + ("APaths.errPathCycle: EnToRdy: " ++ show x) + + -- --------------- + + method_arg_errs = + [ mkArgToRdyErr (m1, argId, findPath graph arg rdy) | arg@(PNTopMethodArg m1 argId) <- cycle, - rdy@(PNTopMethodReady m2) <- cycle, - m1 == m2 ] + rdy@(PNTopMethodReady m2) <- cycle, + m1 == m2 ] - method_en_errs = - [ mkEnToRdyErr (m1, findPath graph en rdy) | + method_en_errs = + [ mkEnToRdyErr (m1, findPath graph en rdy) | en@(PNTopMethodEnable m1) <- cycle, - rdy@(PNTopMethodReady m2) <- cycle, + rdy@(PNTopMethodReady m2) <- cycle, m1 == m2 ] - method_errs = method_arg_errs ++ method_en_errs + method_errs = method_arg_errs ++ method_en_errs - rule_errs = - [ mkWfToCfErr (r1, findPath graph wf cf) | + rule_errs = + [ mkWfToCfErr (r1, findPath graph wf cf) | wf@(PNWillFire r1) <- cycle, cf@(PNCanFire r2) <- cycle, - r1 == r2 ] + r1 == r2 ] - -- --------------- + -- --------------- in - if (length method_errs > 0) - then method_errs - else if (length rule_errs > 0) - then rule_errs - else [default_err] + if (length method_errs > 0) + then method_errs + else if (length rule_errs > 0) + then rule_errs + else [default_err] -- ==================================== @@ -1345,47 +1345,47 @@ getVModInfoArgs avi = [(port, arg_num, e) | (Port (port,_) _ _, arg_num, e) <- z -- {- getVModInfoArgs :: AVInst -> ([(VName, AExpr)], - [(VName, VName, AExpr)], - [(VName, AExpr)], - [(VName, Integer, AExpr)]) + [(VName, VName, AExpr)], + [(VName, AExpr)], + [(VName, Integer, AExpr)]) getVModInfoArgs avi = let -- VModInfo - vmi = avi_vmi avi - -- number of parameters (to be dropped from the AExpr list) - num_params = vNParam vmi - -- AExpr inputs to just the arguments (not the parameters) - input_exprs = genericDrop num_params (avi_iargs avi) - -- all port arguments (not parameters) - input_names = vArgs vmi - - input_pairs = zip input_names input_exprs - - -- figure out which ports are clocks, clock gates, and resets - clks = map fst (vClk vmi) - clkgates = [ (gate_name, clk_name) | + vmi = avi_vmi avi + -- number of parameters (to be dropped from the AExpr list) + num_params = vNParam vmi + -- AExpr inputs to just the arguments (not the parameters) + input_exprs = genericDrop num_params (avi_iargs avi) + -- all port arguments (not parameters) + input_names = vArgs vmi + + input_pairs = zip input_names input_exprs + + -- figure out which ports are clocks, clock gates, and resets + clks = map fst (vClk vmi) + clkgates = [ (gate_name, clk_name) | (clk_name, Just gate_name) <- vClk vmi ] - rsts = vRst vmi - isClk i = elem i clks - isGate i = lookup i clkgates - isRst i = elem i rsts - - -- filter out clocks and resets - foldfunc p@(i,e) (cs, gs, rs, as) = - if (isClk i) - then ((p:cs), gs, rs, as) - else case (isGate i) of - Just clk_id -> let t = (i, clk_id, e) - in (cs, (t:gs), rs, as) - Nothing -> if (isRst i) - then (cs, gs, (p:rs), as) - else (cs, gs, rs, (p:as)) - - (clk_pairs, gate_triples, rst_pairs, arg_pairs) = - foldr foldfunc ([],[],[],[]) input_pairs - - mkArgTriple (arg_id, arg_expr) arg_num = (arg_id, arg_num, arg_expr) - arg_triples = zipWith mkArgTriple arg_pairs [1..] + rsts = vRst vmi + isClk i = elem i clks + isGate i = lookup i clkgates + isRst i = elem i rsts + + -- filter out clocks and resets + foldfunc p@(i,e) (cs, gs, rs, as) = + if (isClk i) + then ((p:cs), gs, rs, as) + else case (isGate i) of + Just clk_id -> let t = (i, clk_id, e) + in (cs, (t:gs), rs, as) + Nothing -> if (isRst i) + then (cs, gs, (p:rs), as) + else (cs, gs, rs, (p:as)) + + (clk_pairs, gate_triples, rst_pairs, arg_pairs) = + foldr foldfunc ([],[],[],[]) input_pairs + + mkArgTriple (arg_id, arg_expr) arg_num = (arg_id, arg_num, arg_expr) + arg_triples = zipWith mkArgTriple arg_pairs [1..] in - (clk_pairs, gate_triples, rst_pairs, arg_triples) + (clk_pairs, gate_triples, rst_pairs, arg_triples) -} diff --git a/src/comp/ARenameIO.hs b/src/comp/ARenameIO.hs index c36282348..163e3985c 100644 --- a/src/comp/ARenameIO.hs +++ b/src/comp/ARenameIO.hs @@ -1,6 +1,6 @@ module ARenameIO( - aRenameIO - ) where + aRenameIO + ) where import qualified Data.Map as M @@ -10,7 +10,7 @@ import FStringCompat(FString) import Flags(Flags) import ASyntax import BackendNamingConventions(createVerilogNameMap, - xLateIdUsingFStringMap) + xLateIdUsingFStringMap) import Util(fastNub) import Pragma(DefProp) @@ -30,7 +30,7 @@ import Pragma(DefProp) aRenameIO :: Flags -> ASPackage -> ASPackage aRenameIO flags pkg = - let mi = aspkg_name pkg + let mi = aspkg_name pkg fmod = aspkg_is_wrapped pkg ps = aspkg_parameters pkg exps = aspkg_outputs pkg @@ -45,17 +45,17 @@ aRenameIO flags pkg = si = aspkg_signal_info pkg cmap = aspkg_comment_info pkg - -- This is the submodule connection map - -- (see comment on "createVerilogNameMap" for examples) - vmap = createVerilogNameMap flags pkg + -- This is the submodule connection map + -- (see comment on "createVerilogNameMap" for examples) + vmap = createVerilogNameMap flags pkg new_pkg = - ASPackage mi - fmod + ASPackage mi + fmod ps exps imps - iomps + iomps (map (trI vmap) vs) -- names in state arg exprs -- remove duplicates because output wires may be hooked up -- to more than one method (e.g. FIFOF_.notFull, FIFOF_.i_notFull) @@ -63,12 +63,12 @@ aRenameIO flags pkg = (map (trD vmap) defs) -- names of defs & in def exprs (map (trIOD vmap) iods) -- names in iodef exprs (map (trFB vmap) fs) -- names in foreign block exprs - (map (tr vmap) ws) -- inlined port names + (map (tr vmap) ws) -- inlined port names (trSI vmap si) -- names in signal info - cmap -- instance names should not have changed + cmap -- instance names should not have changed in - new_pkg + new_pkg type FSMap = M.Map FString FString @@ -139,11 +139,11 @@ trSI mp si = aspsi_output_rsts = map (tr mp) (aspsi_output_rsts si), aspsi_ifc_iots = map (tr mp) (aspsi_ifc_iots si), aspsi_methods = map trMeth (aspsi_methods si), - -- inlined rwire names are not renamed, - -- as the signal exists in the defs with the original name - aspsi_inlined_ports = aspsi_inlined_ports si, - -- rule scheduling ports are not renamed - aspsi_rule_sched = aspsi_rule_sched si, + -- inlined rwire names are not renamed, + -- as the signal exists in the defs with the original name + aspsi_inlined_ports = aspsi_inlined_ports si, + -- rule scheduling ports are not renamed + aspsi_rule_sched = aspsi_rule_sched si, -- mux signals are not renamed aspsi_mux_selectors = aspsi_mux_selectors si, aspsi_mux_values = aspsi_mux_values si, @@ -152,4 +152,3 @@ trSI mp si = -- ============================== - diff --git a/src/comp/ASchedule.hs b/src/comp/ASchedule.hs index 5d0fc5604..c33ae3764 100644 --- a/src/comp/ASchedule.hs +++ b/src/comp/ASchedule.hs @@ -2232,7 +2232,7 @@ mkCombinedGraph ruleNames urgencyMap scGraphFinal scConflictMap sched_id_order u in M.toList $ map_insertManyWith (++) edges' graph0 csmap = mkCSMap nodes edges - in --trace ("s_to_e_edges: " ++ ppReadable s_to_e_edges) $ + in --trace ("s_to_e_edges: " ++ ppReadable s_to_e_edges) $ --trace ("path_edges: " ++ ppReadable path_edges) $ --trace ("urg_edges: " ++ ppReadable urg_edges) $ --trace ("early_edges: " ++ ppReadable early_edges) $ diff --git a/src/comp/AScheduleInfo.hs b/src/comp/AScheduleInfo.hs index 3766b3173..de6946d63 100644 --- a/src/comp/AScheduleInfo.hs +++ b/src/comp/AScheduleInfo.hs @@ -77,23 +77,23 @@ data AScheduleInfo = AScheduleInfo instance PPrint AScheduleInfo where pPrint d p asi = - text "AScheduleInfo" $+$ - nest 2 ( - text "-- schedule" $+$ - pPrint d 0 (asi_schedule asi) $+$ - text "-- vschedinfo" $+$ - pPrint d 0 (asi_v_sched_info asi) $+$ - text "-- warnings" $+$ - (let ppWarn = vcat . map text . lines - in vcat (map (ppWarn . thd) (asi_warnings asi))) $+$ + text "AScheduleInfo" $+$ + nest 2 ( + text "-- schedule" $+$ + pPrint d 0 (asi_schedule asi) $+$ + text "-- vschedinfo" $+$ + pPrint d 0 (asi_v_sched_info asi) $+$ + text "-- warnings" $+$ + (let ppWarn = vcat . map text . lines + in vcat (map (ppWarn . thd) (asi_warnings asi))) $+$ text "-- method uses map" $+$ pPrint d 0 (asi_method_uses_map asi) $+$ text "-- rule uses map" $+$ pPrint d 0 (asi_rule_uses_map asi) $+$ text "-- resource allocation table" $+$ pPrint d 0 (asi_resource_alloc_table asi) - -- no dump of DBs, sched graph and order - ) + -- no dump of DBs, sched graph and order + ) -- --------------- @@ -141,26 +141,26 @@ data AScheduleErrInfo = AScheduleErrInfo instance PPrint AScheduleErrInfo where pPrint d p asei = - text "AScheduleErrInfo" $+$ - nest 2 ( - text "-- schedule" $+$ - pPrint d 0 (asei_schedule asei) $+$ - text "-- vschedinfo" $+$ - pPrint d 0 (asei_v_sched_info asei) $+$ - text "-- warnings" $+$ - (let ppWarn = vcat . map text . lines - in vcat (map (ppWarn . thd) (asei_warnings asei))) $+$ - text "-- errors" $+$ - (let ppErr = vcat . map text . lines - in vcat (map (ppErr . thd) (asei_errors asei))) $+$ + text "AScheduleErrInfo" $+$ + nest 2 ( + text "-- schedule" $+$ + pPrint d 0 (asei_schedule asei) $+$ + text "-- vschedinfo" $+$ + pPrint d 0 (asei_v_sched_info asei) $+$ + text "-- warnings" $+$ + (let ppWarn = vcat . map text . lines + in vcat (map (ppWarn . thd) (asei_warnings asei))) $+$ + text "-- errors" $+$ + (let ppErr = vcat . map text . lines + in vcat (map (ppErr . thd) (asei_errors asei))) $+$ text "-- method uses map" $+$ pPrint d 0 (asei_method_uses_map asei) $+$ text "-- rule uses map" $+$ pPrint d 0 (asei_rule_uses_map asei) $+$ text "-- resource allocation table" $+$ pPrint d 0 (asei_resource_alloc_table asei) - -- no dump of DBs, sched graph and order - ) + -- no dump of DBs, sched graph and order + ) -- --------------- @@ -256,13 +256,13 @@ data RuleRelationDB = (M.Map (ARuleId,ARuleId) RuleRelationInfo) -- conflicts data RuleRelationInfo = RuleRelationInfo { mCF :: Maybe Conflicts - , mSC :: Maybe Conflicts - , mRes :: Maybe Conflicts - , mCycle :: Maybe Conflicts - , mPragma :: Maybe Conflicts + , mSC :: Maybe Conflicts + , mRes :: Maybe Conflicts + , mCycle :: Maybe Conflicts + , mPragma :: Maybe Conflicts , mArb :: Maybe Conflicts - -- XXX path and urgency info? - } deriving (Eq,Show) + -- XXX path and urgency info? + } deriving (Eq,Show) defaultRuleRelationship :: RuleRelationInfo defaultRuleRelationship = RuleRelationInfo { mCF = Nothing @@ -313,31 +313,31 @@ data Conflicts = printConflicts :: Bool -> PDetail -> Conflicts -> Doc printConflicts use_pvprint d edge = let pfp :: (PVPrint a, PPrint a) => a -> Doc - pfp = if (use_pvprint) - then pvPrint d 0 - else pPrint d 0 + pfp = if (use_pvprint) + then pvPrint d 0 + else pPrint d 0 in case (edge) of - (CUse uses) -> - let meths = vcat [pfp m1 <+> text "vs." <+> pfp m2 - | (m1, m2) <- uses] - in fsep [s2par "calls to", nest 2 meths] - (CCycle cycle_rules) -> - let cycle = fsep (intersperse (text "->") - [pfp r | r <- cycle_rules]) - in fsep [s2par "dropped cycle", nest 2 $ parens cycle] + (CUse uses) -> + let meths = vcat [pfp m1 <+> text "vs." <+> pfp m2 + | (m1, m2) <- uses] + in fsep [s2par "calls to", nest 2 meths] + (CCycle cycle_rules) -> + let cycle = fsep (intersperse (text "->") + [pfp r | r <- cycle_rules]) + in fsep [s2par "dropped cycle", nest 2 $ parens cycle] (CMethodsBeforeRules) -> - s2par "methods fire before rules" + s2par "methods fire before rules" (CUserEarliness pos) -> - fsep [s2par "earliness attribute at", pfp pos] + fsep [s2par "earliness attribute at", pfp pos] (CUserAttribute pos) -> - fsep [s2par "scheduling attribute at", pfp pos] - (CUserPreempt pos) -> - fsep [s2par "preempt attribute at", pfp pos] - (CResource m) -> fsep [s2par "resource limit on", pfp m] - (CArbitraryChoice) -> - s2par "earliness order chosen by the compiler" - (CFFuncArbitraryChoice) -> - s2par ("earliness order chosen by the compiler" ++ + fsep [s2par "scheduling attribute at", pfp pos] + (CUserPreempt pos) -> + fsep [s2par "preempt attribute at", pfp pos] + (CResource m) -> fsep [s2par "resource limit on", pfp m] + (CArbitraryChoice) -> + s2par "earliness order chosen by the compiler" + (CFFuncArbitraryChoice) -> + s2par ("earliness order chosen by the compiler" ++ " (due to system task or foreign function use)") instance PPrint Conflicts where @@ -363,26 +363,26 @@ printRuleRelationInfo :: ARuleId -> ARuleId -> Bool -> RuleRelationInfo -> Doc printRuleRelationInfo rule1 rule2 isDisjoint (RuleRelationInfo mCF mSC mRes mCycle mPragma mArb) = let - -- print a single conflict of a given type - pp_conflict ctype Nothing = - sep [text "no", text ctype, text "conflict"] - pp_conflict ctype (Just c) = - sep [text ctype, text "conflict:", pPrint PDReadable 0 c] + -- print a single conflict of a given type + pp_conflict ctype Nothing = + sep [text "no", text ctype, text "conflict"] + pp_conflict ctype (Just c) = + sep [text ctype, text "conflict:", pPrint PDReadable 0 c] in - (text "Scheduling info for rules \"" <> - pPrint PDReadable 0 rule1 <> text "\" and \"" <> - pPrint PDReadable 0 rule2 <> text "\":") - $+$ - sep [text "predicates", - (if isDisjoint - then text "are" else text "are not"), - text "disjoint"] - $+$ - nest 4 (pp_conflict "<>" mCF $+$ - pp_conflict "<" mSC $+$ - pp_conflict "resource" mRes $+$ - pp_conflict "cycle" mCycle $+$ - pp_conflict "attribute" mPragma) + (text "Scheduling info for rules \"" <> + pPrint PDReadable 0 rule1 <> text "\" and \"" <> + pPrint PDReadable 0 rule2 <> text "\":") + $+$ + sep [text "predicates", + (if isDisjoint + then text "are" else text "are not"), + text "disjoint"] + $+$ + nest 4 (pp_conflict "<>" mCF $+$ + pp_conflict "<" mSC $+$ + pp_conflict "resource" mRes $+$ + pp_conflict "cycle" mCycle $+$ + pp_conflict "attribute" mPragma) -- XXX mArb -- ----- diff --git a/src/comp/AState.hs b/src/comp/AState.hs index 6c1c10d40..68b65cce7 100644 --- a/src/comp/AState.hs +++ b/src/comp/AState.hs @@ -2,14 +2,14 @@ --XXX {-# OPTIONS_GHC -fwarn-name-shadowing -fwarn-missing-signatures #-} module AState( - aState, - ) where + aState, + ) where import qualified Data.Map as M import qualified Data.Set as S import Data.List(transpose, sortBy, partition, - unzip4, groupBy, intersect, + unzip4, groupBy, intersect, genericLength) import ListUtil(mapFst) @@ -23,7 +23,7 @@ import Flags(Flags) import Position(noPosition) import PreStrings( fsUnderUnder, - fsMux, fsMuxPreSel, fsMuxSel, fsMuxVal) + fsMux, fsMuxPreSel, fsMuxSel, fsMuxVal) import Id import Pragma import Prim @@ -33,7 +33,7 @@ import VModInfo import ASyntax import ASyntaxUtil import ASchedule(AScheduleInfo(..), ExclusiveRulesDB(..), areRulesExclusive, - RAT, MethodUsesMap, MethodUsers, MethodId(..), UniqueUse(..)) + RAT, MethodUsesMap, MethodUsers, MethodId(..), UniqueUse(..)) import AUses(useDropCond) import AVerilogUtil(vNameToTask) import Wires(WireProps(..)) @@ -160,50 +160,50 @@ aState' :: Flags -> [PProp] -> AScheduleInfo -> APackage -> ErrorMonad (ASPackag aState' flags pps schedule_info apkg = do --traceM( "In AState: " ++ ppReadable pps ) ; let - mi = apkg_name apkg - fmod = apkg_is_wrapped apkg - size_ps = apkg_size_params apkg - vs = apkg_state_instances apkg - ds = apkg_local_defs apkg - ors = apkg_rules apkg - ifc = apkg_interface apkg - wi = apkg_external_wires apkg - submod_cmap = apkg_inst_comments apkg - - clockPortTable = getOutputClockPortTable (wClk wi) - resetPortTable = getOutputResetPortTable (wRst wi) - clockdomain_map = M.fromList (apkg_clock_domains apkg) - reset_map = M.fromList (apkg_reset_list apkg) - - rerr = internalError "AState.reset_lookup unknown reset" - reset_lookup k = M.findWithDefault rerr k reset_map - - domainerr = internalError "AState.domain_osc_lookup unknown domain" - domain_osc_lookup k = map aclock_osc - (M.findWithDefault domainerr k clockdomain_map) - - vmi_map :: VModInfoMap + mi = apkg_name apkg + fmod = apkg_is_wrapped apkg + size_ps = apkg_size_params apkg + vs = apkg_state_instances apkg + ds = apkg_local_defs apkg + ors = apkg_rules apkg + ifc = apkg_interface apkg + wi = apkg_external_wires apkg + submod_cmap = apkg_inst_comments apkg + + clockPortTable = getOutputClockPortTable (wClk wi) + resetPortTable = getOutputResetPortTable (wRst wi) + clockdomain_map = M.fromList (apkg_clock_domains apkg) + reset_map = M.fromList (apkg_reset_list apkg) + + rerr = internalError "AState.reset_lookup unknown reset" + reset_lookup k = M.findWithDefault rerr k reset_map + + domainerr = internalError "AState.domain_osc_lookup unknown domain" + domain_osc_lookup k = map aclock_osc + (M.findWithDefault domainerr k clockdomain_map) + + vmi_map :: VModInfoMap vmi_map = - let mkVMIPair avi = (avi_vname avi, avi_vmi avi) - in M.fromList (map mkVMIPair vs) + let mkVMIPair avi = (avi_vname avi, avi_vmi avi) + in M.fromList (map mkVMIPair vs) let - (ASchedule _ earliness_order_unfiltered) = asi_schedule schedule_info - -- alwaysEnabled = (PPalwaysEnabled []) `elem` pps + (ASchedule _ earliness_order_unfiltered) = asi_schedule schedule_info + -- alwaysEnabled = (PPalwaysEnabled []) `elem` pps - -- interface rules + -- interface rules irs :: [ARule] -- the body of the Action methods into ARule - irs = concatMap aIfaceRules ifc - -- all rules (including action methods) - rs_unsorted = irs ++ ors + irs = concatMap aIfaceRules ifc + -- all rules (including action methods) + rs_unsorted = irs ++ ors - -- all rule names (including action methods) - rs_ids = map aRuleName rs_unsorted - -- earliness order minus value methods - earliness_order = - filter (`elem` rs_ids) earliness_order_unfiltered + -- all rule names (including action methods) + rs_ids = map aRuleName rs_unsorted + -- earliness order minus value methods + earliness_order = + filter (`elem` rs_ids) earliness_order_unfiltered - -- interface outputs + -- interface outputs -- these are the output port names and their assignments -- We separate out the RDY defs for always_ready methods from others, -- because we want the defs (they feed into enables) but do want the @@ -219,31 +219,31 @@ aState' flags pps schedule_info apkg = do --traceM( "outs are: " ++ ppReadable outs ) ; --traceM( "rdys are: " ++ ppReadable rdysToRemove ) let - -- rule ordering map - om = M.fromList (zip earliness_order [0..]) - -- ruleid to rule map - rmap = M.fromList [(aRuleName r, r) | r <- rs_unsorted] - - -- lookup utility function - ridToRule :: ARuleId -> ARule - ridToRule rid = - M.findWithDefault - (internalError("AState: rule maps do not match\n" ++ - (ppReadable (reverse earliness_order)) ++ - (ppReadable (M.keys rmap)))) - rid rmap - -- sorted rules - rs = if (not . null) earliness_order then - -- lookup with earliness_order to sort the rules - map ridToRule (reverse earliness_order) + -- rule ordering map + om = M.fromList (zip earliness_order [0..]) + -- ruleid to rule map + rmap = M.fromList [(aRuleName r, r) | r <- rs_unsorted] + + -- lookup utility function + ridToRule :: ARuleId -> ARule + ridToRule rid = + M.findWithDefault + (internalError("AState: rule maps do not match\n" ++ + (ppReadable (reverse earliness_order)) ++ + (ppReadable (M.keys rmap)))) + rid rmap + -- sorted rules + rs = if (not . null) earliness_order then + -- lookup with earliness_order to sort the rules + map ridToRule (reverse earliness_order) else - -- order doesn't matter for -schedule-sequential - -- and -schedule-disjoint - rs_unsorted + -- order doesn't matter for -schedule-sequential + -- and -schedule-disjoint + rs_unsorted -- from the module arguments, separate out the param inputs (param_args, port_args, inout_args) = - getAPackageParamsPortsAndInouts apkg + getAPackageParamsPortsAndInouts apkg -- aspkg input parameters (other than size parameters) param_inputs = @@ -252,82 +252,82 @@ aState' flags pps schedule_info apkg = do -- module arguments declared as parameters param_args - -- input wires + -- input wires inputIds :: [AInput] - inputIds = + inputIds = port_args ++ concatMap aIfaceArgs ifc ++ - [ (mkNamedEnable fi, aTBool) | + [ (mkNamedEnable fi, aTBool) | (AIAction { aif_name = i, - aif_fieldinfo = fi }) <- ifc, - not (isAlwaysEn pps i)] ++ + aif_fieldinfo = fi }) <- ifc, + not (isAlwaysEn pps i)] ++ [ (mkNamedEnable fi, aTBool) | (AIActionValue {aif_name = i, - aif_fieldinfo = fi }) <- ifc, - not (isAlwaysEn pps i)] + aif_fieldinfo = fi }) <- ifc, + not (isAlwaysEn pps i)] - -- inout wires + -- inout wires inoutIds :: [AInput] - inoutIds = - inout_args ++ - [ (mkNamedInout fi, aType e) | (AIInout _ (AInout e) fi) <- ifc ] + inoutIds = + inout_args ++ + [ (mkNamedInout fi, aType e) | (AIInout _ (AInout e) fi) <- ifc ] - -- output wires and types + -- output wires and types outputIds :: [AOutput] outputIds = map (\def -> ((adef_objid def),(adef_type def))) - (outs ++ clk_defs ++ rstn_defs) + (outs ++ clk_defs ++ rstn_defs) -- list of tuples of lists (exported identifiers, definitions) - clk_blob = - [(clk_id:gate_id, clk_def:gate_def) | + clk_blob = + [(clk_id:gate_id, clk_def:gate_def) | (AIClock { aif_name = n, - aif_clock = AClock { aclock_osc = osc, - aclock_gate = gate } }) <- ifc, + aif_clock = AClock { aclock_osc = osc, + aclock_gate = gate } }) <- ifc, let (clk_vname, mgate_vname) = - fromJustOrErr ("AState.unknown output clock " - ++ ppReadable n) - (M.lookup n clockPortTable), + fromJustOrErr ("AState.unknown output clock " + ++ ppReadable n) + (M.lookup n clockPortTable), let clk_id = vName_to_id clk_vname, - let clk_def :: ADef + let clk_def :: ADef clk_def = (ADef clk_id (ATBit 1) osc []), - let gate_id = + let gate_id = case mgate_vname of - Nothing -> [] - Just (gate_vname, _) -> [vName_to_id gate_vname], - let gate_def :: [ADef] + Nothing -> [] + Just (gate_vname, _) -> [vName_to_id gate_vname], + let gate_def :: [ADef] gate_def = map (\i -> ADef i (ATBit 1) gate []) gate_id - ] + ] - clk_defs = concatMap snd clk_blob + clk_defs = concatMap snd clk_blob - (rstn_exps, rstn_defs) = unzip - [(rstn_id, rstn_def) | + (rstn_exps, rstn_defs) = unzip + [(rstn_id, rstn_def) | (AIReset { aif_name = n, - aif_reset = AReset { areset_wire = wire } }) <- ifc, - let rstn_vname = - fromJustOrErr ("AState.unknown output reset " - ++ ppReadable n) - (M.lookup n resetPortTable), - let rstn_id = vName_to_id rstn_vname, - let rstn_def :: ADef + aif_reset = AReset { areset_wire = wire } }) <- ifc, + let rstn_vname = + fromJustOrErr ("AState.unknown output reset " + ++ ppReadable n) + (M.lookup n resetPortTable), + let rstn_id = vName_to_id rstn_vname, + let rstn_def :: ADef rstn_def = (ADef rstn_id (ATBit 1) wire []) - ] + ] - (iot_exps, iot_defs) = unzip - [(iot_id, iot_def) | + (iot_exps, iot_defs) = unzip + [(iot_id, iot_def) | (AIInout { aif_name = n, - aif_inout = AInout { ainout_wire = wire }, + aif_inout = AInout { ainout_wire = wire }, aif_fieldinfo = Inout {vf_inout = iot_vname} }) <- ifc, - let t = aType wire, - let iot_id = vName_to_id iot_vname, - let iot_def = (ADef iot_id t wire []) - ] + let t = aType wire, + let iot_id = vName_to_id iot_vname, + let iot_def = (ADef iot_id t wire []) + ] - -- definitions - defs = ds ++ outs ++ always_ready_defs ++ - mux_defs ++ enas ++ - clk_defs ++ rstn_defs + -- definitions + defs = ds ++ outs ++ always_ready_defs ++ + mux_defs ++ enas ++ + clk_defs ++ rstn_defs -- create dummy defs for ATaskActions which ignore their returns processActions new_defs new_as n [] = (new_defs, reverse new_as, n) @@ -353,7 +353,7 @@ aState' flags pps schedule_info apkg = do in forceReturns (ds ++ new_defs) (r':new_rs) n' rest (dummy_defs, rs') = forceReturns [] [] 1 rs - -- when "isC", translate from the call name to the + -- when "isC", translate from the call name to the -- system task wrapper name cvtName False f = f cvtName True f= vNameToTask f @@ -365,86 +365,86 @@ aState' flags pps schedule_info apkg = do in (c':es) addWF rid es = internalError("addWF: " ++ ppReadable (rid, es)) - cvtForeign rid resets (AFCall id f isC es _) = - AForeignCall id (cvtName isC f) (addWF rid es) [] resets - cvtForeign rid resets a@(ATaskAction id f isC _ es Nothing _ _) = - AForeignCall id (cvtName isC f) (addWF rid es) [] resets + cvtForeign rid resets (AFCall id f isC es _) = + AForeignCall id (cvtName isC f) (addWF rid es) [] resets + cvtForeign rid resets a@(ATaskAction id f isC _ es Nothing _ _) = + AForeignCall id (cvtName isC f) (addWF rid es) [] resets cvtForeign rid resets (ATaskAction id f isC _ es (Just aid) ty _) = - AForeignCall id (cvtName isC f) (addWF rid es) [aid] resets + AForeignCall id (cvtName isC f) (addWF rid es) [aid] resets cvtForeign rid resets a@(ACall { }) = - internalError("AState.cvtForeign - not foreign:" ++ ppReadable a) + internalError("AState.cvtForeign - not foreign:" ++ ppReadable a) - -- (domain, rule foreign actions) - -- singleton list for the convenience of fblocks below - domain_rfas = - [ (domain, [cvtForeign rid resets a]) | + -- (domain, rule foreign actions) + -- singleton list for the convenience of fblocks below + domain_rfas = + [ (domain, [cvtForeign rid resets a]) | ARule rid _ _ wp _ as _ _ <- rs', let domain = fromJustOrErr "AState.domain_rfas no clock domain" - (wpClockDomain wp), + (wpClockDomain wp), let resets = map (areset_wire . reset_lookup) (wpResets wp), - a <- as, isForeign a ] + a <- as, isForeign a ] -- foreign function actions by clock domain -- (use "flip" to preserve the order) - fdomain_map = M.toList (M.fromListWith (flip (++)) domain_rfas) + fdomain_map = M.toList (M.fromListWith (flip (++)) domain_rfas) -- the foreign blocks - fblocks = mapFst domain_osc_lookup fdomain_map + fblocks = mapFst domain_osc_lookup fdomain_map - -- New improved resource allocation - blobs = ratToBlobs (asi_method_uses_map schedule_info) + -- New improved resource allocation + blobs = ratToBlobs (asi_method_uses_map schedule_info) omMultMap (asi_resource_alloc_table schedule_info) - (ers, ars) = blobs + (ers, ars) = blobs - -- Old resource allocation - --(ers, ars) = getMethCalls sch ds outs rs' + -- Old resource allocation + --(ers, ars) = getMethCalls sch ds outs rs' - exclusive_rules_db = asi_exclusive_rules_db schedule_info + exclusive_rules_db = asi_exclusive_rules_db schedule_info - -- XXX redo construction of muxes for args, enables, and outputs: - -- XXX use the fieldinfo to create the right names (and ARenameIO goes away) - -- XXX can construct the enables and outputs separately from the args - -- XXX the fieldinfo will also identify which are value, action, and AV methods + -- XXX redo construction of muxes for args, enables, and outputs: + -- XXX use the fieldinfo to create the right names (and ARenameIO goes away) + -- XXX can construct the enables and outputs separately from the args + -- XXX the fieldinfo will also identify which are value, action, and AV methods - -- mkEmuxxs needs to know which are the value methods, because - -- selectors for muxes are RDY for value methods (instead of WILLFIRE) - value_method_ids = [ i | (AIDef { aif_value = (ADef i _ _ _) }) <- ifc ] + -- mkEmuxxs needs to know which are the value methods, because + -- selectors for muxes are RDY for value methods (instead of WILLFIRE) + value_method_ids = [ i | (AIDef { aif_value = (ADef i _ _ _) }) <- ifc ] - -- muxes for values (definitions) - (emux_selss, emux_valss, emux_outss, esss) = - unzip4 (map (mkEmuxssExpr exclusive_rules_db value_method_ids om) ers) + -- muxes for values (definitions) + (emux_selss, emux_valss, emux_outss, esss) = + unzip4 (map (mkEmuxssExpr exclusive_rules_db value_method_ids om) ers) - -- muxes for actions - -- (we don't need a substitution for actionvalue value calls, - -- because there is no multiplicity for action/actionvalue methods, + -- muxes for actions + -- (we don't need a substitution for actionvalue value calls, + -- because there is no multiplicity for action/actionvalue methods, -- so any value calls can be converted to use of the one port) - (amux_selss, amux_valss, amux_outss, _) = - unzip4 (map (mkEmuxssAction exclusive_rules_db value_method_ids om) ars) + (amux_selss, amux_valss, amux_outss, _) = + unzip4 (map (mkEmuxssAction exclusive_rules_db value_method_ids om) ars) - mux_sel_defs = concat emux_selss ++ concat amux_selss - mux_val_defs = concat emux_valss ++ concat amux_valss - mux_out_defs = concat emux_outss ++ concat amux_outss - mux_defsRed = mux_sel_defs ++ mux_val_defs ++ mux_out_defs + mux_sel_defs = concat emux_selss ++ concat amux_selss + mux_val_defs = concat emux_valss ++ concat amux_valss + mux_out_defs = concat emux_outss ++ concat amux_outss + mux_defsRed = mux_sel_defs ++ mux_val_defs ++ mux_out_defs -- -- filter out the redundant def from the new defintions -- leave the mux_val_defs since these may not have good names. esubmap = M.fromList $ genAliases (mux_sel_defs) mux_defs = map (aSubst esubmap) mux_defsRed - enas = concatMap mkEnabless ars + enas = concatMap mkEnabless ars - -- substitution of value method calls to instance outputs - substs = M.fromList (concat esss) + -- substitution of value method calls to instance outputs + substs = M.fromList (concat esss) - -- actionvalue method value references can be unconditionally converted + -- actionvalue method value references can be unconditionally converted subst :: AExpr -> Maybe AExpr - subst (AMethValue vt modId methId) = - Just (ASPort vt (mkMethId modId methId Nothing MethodResult)) - -- substitute AMOsc, AMGate, AMReset references with their port - subst (AMGate gt modId clkId) = - Just (mkOutputGatePort vmi_map modId clkId) - -- substitute any value method calls, according to the substitution + subst (AMethValue vt modId methId) = + Just (ASPort vt (mkMethId modId methId Nothing MethodResult)) + -- substitute AMOsc, AMGate, AMReset references with their port + subst (AMGate gt modId clkId) = + Just (mkOutputGatePort vmi_map modId clkId) + -- substitute any value method calls, according to the substitution subst e@(AMethCall vt modId methId es) = case (M.lookup e substs) of Nothing -> @@ -454,39 +454,39 @@ aState' flags pps schedule_info apkg = do in Just (ASPort vt (mkMethId modId methId ino MethodResult)) me' -> me' -- AMethValue, AMGate and AMethCall should cover it - subst e = Nothing + subst e = Nothing - getMult o m = let avi = getVInst o vs + getMult o m = let avi = getVInst o vs vmi = avi_vmi avi - in getMethMult vmi m - - -- instances with the number of used port copies - -- (up to the max multiplicity) - vs' = map addMult vs - - -- to ensure correlation, make it a pair of the name to its mult - addMult avi@(AVInst { avi_vname = i, avi_vmi = vi }) = - let port_mults = [ (m, getMultUse (i, m)) | - (Method { vf_name = m }) <- vFields vi ] - in avi { avi_iarray = port_mults } - getMultUse om = M.findWithDefault 0 om omnsMap - - -- convert the clock and reset args to Verilog wire port connections - -- (also convert AMGate etc to the Verilog wire names) - -- XXX is it more efficient to only subst inside rewireClockResetInout - -- XXX since we only apply it when we actually introduce a gate? + in getMethMult vmi m + + -- instances with the number of used port copies + -- (up to the max multiplicity) + vs' = map addMult vs + + -- to ensure correlation, make it a pair of the name to its mult + addMult avi@(AVInst { avi_vname = i, avi_vmi = vi }) = + let port_mults = [ (m, getMultUse (i, m)) | + (Method { vf_name = m }) <- vFields vi ] + in avi { avi_iarray = port_mults } + getMultUse om = M.findWithDefault 0 om omnsMap + + -- convert the clock and reset args to Verilog wire port connections + -- (also convert AMGate etc to the Verilog wire names) + -- XXX is it more efficient to only subst inside rewireClockResetInout + -- XXX since we only apply it when we actually introduce a gate? vs'' :: [AVInst] - vs'' = mapAExprs (exprMap subst) $ - map rewireClockResetInout vs' + vs'' = mapAExprs (exprMap subst) $ + map rewireClockResetInout vs' fblocks' = mapAExprs (exprMap subst) fblocks - -- output methods with their number of uses (OutputMethodNumberS) + -- output methods with their number of uses (OutputMethodNumberS) -- ers and ars omns list the number of methods used (not the total) -- for the total see omMultMap omns :: [ ( (AId,AId) ,Integer) ] - omns = [ (om, genericLength is) | ((om, f), is) <- ers ++ ars ] + omns = [ (om, genericLength is) | ((om, f), is) <- ers ++ ars ] omnsMap = M.fromList omns -- map from object-method pairs to method multiplicity @@ -494,31 +494,31 @@ aState' flags pps schedule_info apkg = do -- (for use in making allmvars) omMultMap = M.fromList (concatMap genMethodMult vs) - -- defined variables - dvars = S.fromList [ i | ADef i _ _ _ <- defs' ] + -- defined variables + dvars = S.fromList [ i | ADef i _ _ _ <- defs' ] - -- all possible method inputs & outputs - allmvars :: [(AId, AType, Bool)] + -- all possible method inputs & outputs + allmvars :: [(AId, AType, Bool)] allmvars = genModVars vs omMultMap -- all undefined method inputs and outputs - mvars :: [(AId, AType, Bool)] - mvars = [ (ui, t, a) | (ui, t, a) <- allmvars, + mvars :: [(AId, AType, Bool)] + mvars = [ (ui, t, a) | (ui, t, a) <- allmvars, not (ui `S.member` dvars)] - -- undefined state outputs - svars = [ (i, t) | (i, t, False) <- mvars ] + -- undefined state outputs + svars = [ (i, t) | (i, t, False) <- mvars ] - wvars = map fst2of3 (concatMap getSpecialOutputs vs) + wvars = map fst2of3 (concatMap getSpecialOutputs vs) - -- unconnected signals - edefs = concatMap tieToZero mvars + -- unconnected signals + edefs = concatMap tieToZero mvars -- [ ADef i t aFalse | (i, t, True) <- mvars ] -- XXX need to tie unconnected state inputs to 0 will stop verilog warns. defs' :: [ADef] - defs' = [ d {adef_expr = (exprMap subst) e} | d@(ADef _ _ e _) <- defs ] + defs' = [ d {adef_expr = (exprMap subst) e} | d@(ADef _ _ e _) <- defs ] defs'' :: [ADef] - defs'' = defs' ++ edefs ++ dummy_defs + defs'' = defs' ++ edefs ++ dummy_defs --rdysToRemove = filter (isRdyToRemove pps) defs'' -- traceM("Astate omns : " ++ ppReadable omns ) @@ -529,26 +529,26 @@ aState' flags pps schedule_info apkg = do --traceM( "alwaysEnas are: " ++ ppReadable alwaysEnas ) -- create the signal Id info for the ASPackage let signal_info = - ASPSignalInfo { - aspsi_inputs = map fst (param_args ++ port_args ++ inout_args), + ASPSignalInfo { + aspsi_inputs = map fst (param_args ++ port_args ++ inout_args), - aspsi_output_clks = map mkSIClockTuple clk_blob, - aspsi_output_rsts = rstn_exps, - aspsi_ifc_iots = iot_exps, - aspsi_methods = mkSignalInfoMethod ifc, + aspsi_output_clks = map mkSIClockTuple clk_blob, + aspsi_output_rsts = rstn_exps, + aspsi_ifc_iots = iot_exps, + aspsi_methods = mkSignalInfoMethod ifc, - aspsi_inlined_ports = [], + aspsi_inlined_ports = [], - aspsi_rule_sched = - [(i,[mkIdCanFire i, mkIdWillFire i]) - | (ARule { arule_id=i }) <- rs' ], + aspsi_rule_sched = + [(i,[mkIdCanFire i, mkIdWillFire i]) + | (ARule { arule_id=i }) <- rs' ], - -- mux output Ids are just submodule inputs, - -- so no need to include them here again - aspsi_mux_selectors = map adef_objid mux_sel_defs, - aspsi_mux_values = map adef_objid mux_val_defs, - aspsi_submod_enables = map adef_objid enas - } + -- mux output Ids are just submodule inputs, + -- so no need to include them here again + aspsi_mux_selectors = map adef_objid mux_sel_defs, + aspsi_mux_values = map adef_objid mux_val_defs, + aspsi_submod_enables = map adef_objid enas + } -- create the comment info for the ASPackage let rule_cmap = [(i,cs) | r <- ors, @@ -556,8 +556,8 @@ aState' flags pps schedule_info apkg = do let rps = arule_pragmas r, let cs = [ c | (RPdoc c) <- rps ] ] comment_info = - ASPCommentInfo { - aspci_submod_insts = submod_cmap, + ASPCommentInfo { + aspci_submod_insts = submod_cmap, aspci_rules = rule_cmap } @@ -575,19 +575,19 @@ aState' flags pps schedule_info apkg = do aspkg_inout_values = iot_defs, aspkg_foreign_calls = fblocks' , aspkg_inlined_ports = [], - aspkg_signal_info = signal_info, - aspkg_comment_info = comment_info } + aspkg_signal_info = signal_info, + aspkg_comment_info = comment_info } -- does the number of uses (n) exceed the number of available ports (p)? let overused_ports = [ (o,m,k,n) | ((o,m),n) <- omns, - let k = getMult o m, - k/=0 && n>k ] + let k = getMult o m, + k/=0 && n>k ] {- traceM ("aState\n" ++ ppReadable ({-(ds, outs),-} ers, ars, substs)) traceM ("aState\n" ++ ppReadable ers ++ "--\n" ++ ppReadable ars ++ "--\n" - ++ ppReadable blobs) + ++ ppReadable blobs) traceM (ppReadable (zip earliness_order [0..])) traceM (ppReadable (S.toList dvars)) traceM (ppReadable mvars) @@ -602,15 +602,15 @@ aState' flags pps schedule_info apkg = do -- check for name clashes let port_ids = map fst outputIds ++ - map fst inputIds ++ - map fst param_inputs + map fst inputIds ++ + map fst param_inputs --orig_def_ids = map adef_objid ds - state_inst_ids = map avi_vname vs + state_inst_ids = map avi_vname vs -- instance names vs port/parameter names (user error) let state_port_clashes = intersect port_ids state_inst_ids - state_port_emsgs = [ (noPosition, ENetInstConflict (getIdString inst)) - | inst <- state_port_clashes ] + state_port_emsgs = [ (noPosition, ENetInstConflict (getIdString inst)) + | inst <- state_port_clashes ] -- port names vs defs (internal error?) --let port_def_clashes = intersect port_ids orig_def_ids @@ -623,28 +623,28 @@ aState' flags pps schedule_info apkg = do -- do any always_ready methods have a RDY which is not constant 1? case (overused_ports) of - [] -> if (null state_port_emsgs) - then EMResult res - else EMError state_port_emsgs - ((o,m,k,n):_) -> EMError [(getIdPosition o, - EFewPorts (pfpString o) (pfpString m) k n)] + [] -> if (null state_port_emsgs) + then EMResult res + else EMError state_port_emsgs + ((o,m,k,n):_) -> EMError [(getIdPosition o, + EFewPorts (pfpString o) (pfpString m) k n)] ------------------------- genModVars :: [AVInst] -> M.Map (AId, AId) Integer -> [(AId, AType, Bool)] genModVars vs omMultMap = allmvars where - getMultUse om = M.findWithDefault 0 om omMultMap - -- For all ports to submodules, make a 3-tuple: - -- * port signal name uniquified for multiplicity - -- * the type of the signal - -- * whether the signal is an input to module. + getMultUse om = M.findWithDefault 0 om omMultMap + -- For all ports to submodules, make a 3-tuple: + -- * port signal name uniquified for multiplicity + -- * the type of the signal + -- * whether the signal is an input to module. -- - -- XXX This is WRONG since the uniquifier for multiple methods - -- XXX is added to the instance name rather than the method name. - allmvars = - [(uniqueId, portType, isEnable) | - -- for all submodules (get the module Id, + -- XXX This is WRONG since the uniquifier for multiple methods + -- XXX is added to the instance name rather than the method name. + allmvars = + [(uniqueId, portType, isEnable) | + -- for all submodules (get the module Id, -- the method arg types, and the Verilog port names) (AVInst { avi_vname = modId, avi_meth_types = methType, @@ -653,15 +653,15 @@ genModVars vs omMultMap = allmvars -- for each method (get the method Id, the arg types, -- and whether it's an action method) -- - ( m@(Method { vf_name = methId, vf_inputs = argIds, vf_mult = mult }), - (argTypes, en_type, val_type) ) - <- zip (vFields vmodinfo) methType, + ( m@(Method { vf_name = methId, vf_inputs = argIds, vf_mult = mult }), + (argTypes, en_type, val_type) ) + <- zip (vFields vmodinfo) methType, -- - -- for each part of the method, produce a triple of - -- the method part, the type of the associated port, - -- and a boolean if it is the enable part (of an action meth) + -- for each part of the method, produce a triple of + -- the method part, the type of the associated port, + -- and a boolean if it is the enable part (of an action meth) -- - (meth_part, portType, isEnable) <- + (meth_part, portType, isEnable) <- -- argument triples [ (MethodArg n, argType, True) -- EWC mark at true for input | (n, argType) <- zip [1..] argTypes ] ++ @@ -673,9 +673,9 @@ genModVars vs omMultMap = allmvars (case (val_type) of Nothing -> [] (Just t) -> [(MethodResult, t, False)]), - -- uniquifiers for multiple ports - -- (if only one copy, then the list just contains 0) - ino <- map (toMaybe (mult > 1)) [ 0 .. (getMultUse (modId, methId) - 1) `max` 0 ], + -- uniquifiers for multiple ports + -- (if only one copy, then the list just contains 0) + ino <- map (toMaybe (mult > 1)) [ 0 .. (getMultUse (modId, methId) - 1) `max` 0 ], let uniqueId = (mkMethId modId methId ino meth_part)] tieToZero :: (AId,AType,Bool) -> [ADef] @@ -731,9 +731,9 @@ getVInst i as = head ( [ a | a <- as, i == (avi_vname a) ] ++ getMethMult :: VModInfo -> AId -> Integer getMethMult vi m = head ( - [ k | (Method { vf_name = m', vf_mult = k}) <- vFields vi, - m == m' ] ++ - internalError ("getMethMult " ++ ppString (vi,m))) + [ k | (Method { vf_name = m', vf_mult = k}) <- vFields vi, + m == m' ] ++ + internalError ("getMethMult " ++ ppString (vi,m))) -- --------------- @@ -753,7 +753,7 @@ mkSIMethodTuple (AIDef name args _ pred _ vfi _) = aspm_menableid = Nothing, aspm_mresultid = Just res, aspm_inputs = map fst args, - aspm_assocrules = [] } + aspm_assocrules = [] } ] mkSIMethodTuple (AIAction args _ pred name rs vfi) = let (_, rdy, ena) = extractNames vfi @@ -764,7 +764,7 @@ mkSIMethodTuple (AIAction args _ pred name rs vfi) = aspm_menableid = Just ena, aspm_mresultid = Nothing, aspm_inputs = map fst args, - aspm_assocrules = map aRuleName rs } + aspm_assocrules = map aRuleName rs } ] mkSIMethodTuple (AIActionValue args _ pred name rs _ vfi) = let (res, rdy, ena) = extractNames vfi @@ -775,7 +775,7 @@ mkSIMethodTuple (AIActionValue args _ pred name rs _ vfi) = aspm_menableid = Just ena, aspm_mresultid = Just res, aspm_inputs = map fst args, - aspm_assocrules = map aRuleName rs } + aspm_assocrules = map aRuleName rs } ] mkSIMethodTuple (AIClock {}) = [] mkSIMethodTuple (AIReset {}) = [] @@ -839,7 +839,7 @@ ratToBlobs mMap omMultMap rat = -- pair (Bool,MethBlob) where the Bool is True if the method use is an -- expression and False if it is an action mkBlob :: MethodUsesMap -> M.Map (AId, AId) Integer -> (MethodId, [(UniqueUse, Integer)]) -> - (Bool, MethBlob) + (Bool, MethBlob) mkBlob mMap omMultMap (method@(MethodId obj met), usedPorts) = let -- We will use information for this method from both the @@ -879,8 +879,8 @@ mkBlob mMap omMultMap (method@(MethodId obj met), usedPorts) = -- so the RAT has uses without their conditions (see RSchedule.hs) methodUses :: [(UniqueUse, MethodUsers)] methodUses = case (M.lookup method mMap) of - Just mUse -> mapFst useDropCond mUse - Nothing -> lookupErr method + Just mUse -> mapFst useDropCond mUse + Nothing -> lookupErr method -- --------------- -- Convert a UniqueUse into an element of MethPortBlob @@ -894,11 +894,11 @@ mkBlob mMap omMultMap (method@(MethodId obj met), usedPorts) = -- to determine the expr/action boolean with "uExp".) cvt :: UniqueUse -> (UniqueUse, Maybe [ARuleId]) cvt use = case (lookup use methodUses) of - Just ([],rs,[]) -> (use, Just rs) - -- pred uses and inst uses must always be available - -- (no muxing) - Just (ps,_,is) -> (use, Nothing) - Nothing -> lookupErr use + Just ([],rs,[]) -> (use, Just rs) + -- pred uses and inst uses must always be available + -- (no muxing) + Just (ps,_,is) -> (use, Nothing) + Nothing -> lookupErr use -- Convert a UniqueUse into an AExpr for use in MethPortBlob -- (For actions, the first argument is the condition, so remove it) @@ -908,7 +908,7 @@ mkBlob mMap omMultMap (method@(MethodId obj met), usedPorts) = exp (UUAction (AFCall i f isC es isA)) = AFunCall aTAction i f isC es -- XXX think this is just used for expression muxing exp (UUAction (ATaskAction i f isC n es tid tty isA)) = - AFunCall aTAction i f isC es + AFunCall aTAction i f isC es -- --------------- -- Make the MethodBlob @@ -978,11 +978,11 @@ mkBlob mMap omMultMap (method@(MethodId obj met), usedPorts) = -- of the new definitions mkEmuxss :: ([AExpr] -> [AExpr]) -> ([AExpr] -> AExpr) -> - ExclusiveRulesDB -> [AId] -> OrderMap -> MethBlob -> - ([ADef], [ADef], [ADef], AExprSubst) + ExclusiveRulesDB -> [AId] -> OrderMap -> MethBlob -> + ([ADef], [ADef], [ADef], AExprSubst) mkEmuxss tl cnd rdb value_method_ids om (((o, m), f), emrss) = let genfunct = mkEmuxs tl cnd rdb value_method_ids om o m - (sel_dss, val_dss, out_dss, sss) = unzip4 (zipWith genfunct (map (toMaybe f) [0..]) emrss) + (sel_dss, val_dss, out_dss, sss) = unzip4 (zipWith genfunct (map (toMaybe f) [0..]) emrss) in (concat sel_dss, concat val_dss, concat out_dss, concat sss) -- XXX The "const aTrue" suggests that the use is unconditional. @@ -992,8 +992,8 @@ mkEmuxssExpr :: ExclusiveRulesDB -> [AId] -> OrderMap -> MethBlob -> ([ADef], [ mkEmuxssExpr = mkEmuxss id (const aTrue) --mkEmuxssAction :: ExclusiveRulesDB -> [AId] -> OrderMap -> --- AId -> MethBlob -> --- ([ADef], [ADef], [ADef], AExprSubst) +-- AId -> MethBlob -> +-- ([ADef], [ADef], [ADef], AExprSubst) mkEmuxssAction = mkEmuxss tail head -- --------------- @@ -1002,32 +1002,32 @@ mkEmuxssAction = mkEmuxss tail head -- (that is, per copy of the method on a single state instance) mkEmuxs :: ([AExpr] -> [AExpr]) -> ([AExpr] -> AExpr) -> - ExclusiveRulesDB -> [AId] -> OrderMap -> - AId -> AId -> Maybe Integer -> MethPortBlob -> - ([ADef], [ADef], [ADef], AExprSubst) + ExclusiveRulesDB -> [AId] -> OrderMap -> + AId -> AId -> Maybe Integer -> MethPortBlob -> + ([ADef], [ADef], [ADef], AExprSubst) mkEmuxs tl cnd rdb value_method_ids om o m ino emrs = let meth_id = mkMethId o m ino MethodResult - -- Break each MethPortBlob into a list of the expressions for + -- Break each MethPortBlob into a list of the expressions for -- each argument, and then transpose the entire structure to - -- make a list of, for each argument, a list of the different - -- expressions used by the different uses for that argument - arg_blobs = transpose [ [ (e, (cnd es), rs) | e <- tl es ] | - (AMethCall _ _ _ es, rs) <- emrs] + -- make a list of, for each argument, a list of the different + -- expressions used by the different uses for that argument + arg_blobs = transpose [ [ (e, (cnd es), rs) | e <- tl es ] | + (AMethCall _ _ _ es, rs) <- emrs] -- Call mkEmux once for each argument of the method, giving it -- the list of different expressions for that argument, to -- separately mux the values for each argument. -- The result is new defs for the connections to the mux. def_tuples = zipWith (mkEmux rdb value_method_ids om ino o m) - [1..] arg_blobs - (sel_defs, val_defs, out_defs) = concatUnzip3 def_tuples + [1..] arg_blobs + (sel_defs, val_defs, out_defs) = concatUnzip3 def_tuples - -- Replace the method call with the output port of the method - subst = [(e, ASPort (aType e) meth_id) | (e, _) <- emrs] + -- Replace the method call with the output port of the method + subst = [(e, ASPort (aType e) meth_id) | (e, _) <- emrs] in -- traces ("mkEmuxs " ++ ppReadable emrs ++ ppReadable xs) $ - (sel_defs, val_defs, out_defs, subst) + (sel_defs, val_defs, out_defs, subst) -- --------------- @@ -1051,106 +1051,106 @@ mkEmuxs tl cnd rdb value_method_ids om o m ino emrs = -- * The definition for the output of the mux -- mkEmux :: ExclusiveRulesDB -> [AId] -> OrderMap -> - Maybe Integer -> AId -> AId -> Integer -> - [(AExpr, AExpr, Maybe [ARuleId])] -> ([ADef], [ADef], [ADef]) + Maybe Integer -> AId -> AId -> Integer -> + [(AExpr, AExpr, Maybe [ARuleId])] -> ([ADef], [ADef], [ADef]) mkEmux exclusive_rules_db value_method_ids om ino o m ano [(e, _, _)] = -- Only one input to the mux ([], [], [ ADef (argId ino o m ano) (aType e) e [] ]) mkEmux exclusive_rules_db value_method_ids om ino o m ano ers@((e,_,_):_) = -- Multiple inputs let - -- --------------- - -- Determine if we need a PrimMux or PrimPriMux - - -- should we use a PrimPriMux? - -- Old decision: If any rule Id is not in the order map, then it - -- must be a read method, and we can assume that the scheduler - -- has taken care to only enable one unique use at a time, so - -- PrimMux is sufficient. For all other cases (rules and - -- action methods), use PrimPriMux. - -- New decision: We can do better for rules and action methods by - -- only using PrimPriMux when some of the rules are not disjoint. - -- (If exclusive_rules_db says all the rules are disjoint, no pri - -- mux is needed.) Note that we even do this check for read - -- methods (to be safe), even though we could have continued to - -- use the same assumption as in the "old decision". - -- In both cases: We assume that predicate uses can be ignored, - -- by matching "(_,_,Just rs)". If we ever support multiple - -- predicate uses (due to urgency) we will need to fix this. - usePri :: Bool - --usePri = and [ M.lookup r om /= Nothing | + -- --------------- + -- Determine if we need a PrimMux or PrimPriMux + + -- should we use a PrimPriMux? + -- Old decision: If any rule Id is not in the order map, then it + -- must be a read method, and we can assume that the scheduler + -- has taken care to only enable one unique use at a time, so + -- PrimMux is sufficient. For all other cases (rules and + -- action methods), use PrimPriMux. + -- New decision: We can do better for rules and action methods by + -- only using PrimPriMux when some of the rules are not disjoint. + -- (If exclusive_rules_db says all the rules are disjoint, no pri + -- mux is needed.) Note that we even do this check for read + -- methods (to be safe), even though we could have continued to + -- use the same assumption as in the "old decision". + -- In both cases: We assume that predicate uses can be ignored, + -- by matching "(_,_,Just rs)". If we ever support multiple + -- predicate uses (due to urgency) we will need to fix this. + usePri :: Bool + --usePri = and [ M.lookup r om /= Nothing | -- (_, _, Just rs) <- ers, r <- rs ] - usePri = let rs = concat [rs | (_, _, Just rs) <- ers] - val = not (and - [areRulesExclusive exclusive_rules_db r r' - | r <- rs, r' <- rs , r /= r']) - in val + usePri = let rs = concat [rs | (_, _, Just rs) <- ers] + val = not (and + [areRulesExclusive exclusive_rules_db r r' + | r <- rs, r' <- rs , r /= r']) + in val - -- --------------- - -- Functions to make selector Ids + -- --------------- + -- Functions to make selector Ids - selId s = - mkIdPre fsMux - (mkIdPost i (concatFString [fsUnderUnder, fsMuxSel, s])) + selId s = + mkIdPre fsMux + (mkIdPost i (concatFString [fsUnderUnder, fsMuxSel, s])) - preSelId s = - mkIdPre fsMux - (mkIdPost i (concatFString [fsUnderUnder, fsMuxPreSel, s])) + preSelId s = + mkIdPre fsMux + (mkIdPost i (concatFString [fsUnderUnder, fsMuxPreSel, s])) - -- --------------- - -- Functions to make value Ids + -- --------------- + -- Functions to make value Ids - valId s = - mkIdPre fsMux - (mkIdPost i (concatFString [fsUnderUnder, fsMuxVal, s])) + valId s = + mkIdPre fsMux + (mkIdPost i (concatFString [fsUnderUnder, fsMuxVal, s])) - -- --------------- - -- Function to make control signal Id - -- (WILL_FIRE for rule or action method, RDY for read method) + -- --------------- + -- Function to make control signal Id + -- (WILL_FIRE for rule or action method, RDY for read method) - isReadMethod rId = elem rId value_method_ids + isReadMethod rId = elem rId value_method_ids - willfireId rId = if (isReadMethod rId) - then aRdyId rId - else aWillFireId rId + willfireId rId = if (isReadMethod rId) + then aRdyId rId + else aWillFireId rId -- produce the uniquifier for mux selector Ids - -- Here we just add _#, but we could include the rules for - -- the selector in its name, or even just include one name - -- when it's only one rule. for brevity, we just use _# - use2suffix :: Integer -> Maybe [Id] -> FString + -- Here we just add _#, but we could include the rules for + -- the selector in its name, or even just include one name + -- when it's only one rule. for brevity, we just use _# + use2suffix :: Integer -> Maybe [Id] -> FString use2suffix n _ = mkFString ("_" ++ itos n) - -- --------------- - -- Function to make the arguments to the selector primitive + -- --------------- + -- Function to make the arguments to the selector primitive -- For each arg blob, two AExprs are created: One of type Bool - -- which refers to the control signal for the arg, and one - -- which is the expression for the argument (here, "e"). - -- The control signal is just a references to a definition, - -- which will be created by mkSel (see below). - - -- return a list of the selector expr and the return expr, and - -- any new defs (because we want to give the return expr a name) - - mkArg :: (Integer, (AExpr, AExpr, Maybe [ARuleId])) -> - ([AExpr], [ADef]) - mkArg (n, (e, _, mrs)) = - let suffix = use2suffix n mrs - val_type = ae_type e - val_id = valId suffix + -- which refers to the control signal for the arg, and one + -- which is the expression for the argument (here, "e"). + -- The control signal is just a references to a definition, + -- which will be created by mkSel (see below). + + -- return a list of the selector expr and the return expr, and + -- any new defs (because we want to give the return expr a name) + + mkArg :: (Integer, (AExpr, AExpr, Maybe [ARuleId])) -> + ([AExpr], [ADef]) + mkArg (n, (e, _, mrs)) = + let suffix = use2suffix n mrs + val_type = ae_type e + val_id = valId suffix props = case mrs of Nothing -> [] Just rs -> map DefP_Rule rs - in - ([ASDef aTBool (selId suffix), - ASDef val_type val_id], - [ADef val_id val_type e props]) - - -- --------------- - -- Function to make the definitions for the control signals - mkSel :: (Integer, (AExpr, AExpr, Maybe [ARuleId])) -> [ADef] - mkSel (n, (_, c, Just rs)) = + in + ([ASDef aTBool (selId suffix), + ASDef val_type val_id], + [ADef val_id val_type e props]) + + -- --------------- + -- Function to make the definitions for the control signals + mkSel :: (Integer, (AExpr, AExpr, Maybe [ARuleId])) -> [ADef] + mkSel (n, (_, c, Just rs)) = let suffix = use2suffix n (Just rs) props :: [DefProp] props = map DefP_Rule rs -- record the source rule @@ -1161,71 +1161,71 @@ mkEmux exclusive_rules_db value_method_ids om ino o m ano ers@((e,_,_):_) = ] else - -- if there is a non-split condition, create a - -- pre-selector signal which is the OR of the WFs, - -- and the selector will be the presel AND the cond + -- if there is a non-split condition, create a + -- pre-selector signal which is the OR of the WFs, + -- and the selector will be the presel AND the cond [ADef (preSelId suffix) aTBool (aOrs (map willfireId rs)) props, ADef (selId suffix) aTBool (aAnd (ASDef aTBool (preSelId suffix)) c) props] - -- only one input to the mux was handled by the first case of mkEmux - mkSel x = internalError ("mkSel, match failed: " ++ ppReadable x) + -- only one input to the mux was handled by the first case of mkEmux + mkSel x = internalError ("mkSel, match failed: " ++ ppReadable x) - -- --------------- - -- Function to put the muxed arguments in priority order - -- (if we make a PrimPriMux, it will expect arguments in pri order) + -- --------------- + -- Function to put the muxed arguments in priority order + -- (if we make a PrimPriMux, it will expect arguments in pri order) - -- If an arm is found to be used by multiple rules, then we need - -- to separate it into different arms, so that each rule's arm - -- can be put at the appropriate place in the priority. + -- If an arm is found to be used by multiple rules, then we need + -- to separate it into different arms, so that each rule's arm + -- can be put at the appropriate place in the priority. - order uses = let sep_numbered_uses = - [ (num, (val, cond, Just [r])) - | (val, cond, Just rs) <- uses, - r <- rs, - let num = mlookup r om ] - in map snd $ - sortBy (\ (x, _) (y, _) -> compare x y) - sep_numbered_uses + order uses = let sep_numbered_uses = + [ (num, (val, cond, Just [r])) + | (val, cond, Just rs) <- uses, + r <- rs, + let num = mlookup r om ] + in map snd $ + sortBy (\ (x, _) (y, _) -> compare x y) + sep_numbered_uses - -- --------------- - -- Put it all together + -- --------------- + -- Put it all together - -- The type of the muxed value, for use in creating the new Defs - t = aType e + -- The type of the muxed value, for use in creating the new Defs + t = aType e - -- The arg blobs, numbered, and in priority order if necessary - ers' = zip [1..] $ if usePri - then order ers - else ers + -- The arg blobs, numbered, and in priority order if necessary + ers' = zip [1..] $ if usePri + then order ers + else ers -- PrimMux takes a list of pairs of the selector ASDef and the - -- expr that should result + -- expr that should result -- mux_pairs = the pairs, val_defs = the new Id defs for the vals - (mux_pairs, val_defs) = concatUnzipMap mkArg ers' + (mux_pairs, val_defs) = concatUnzipMap mkArg ers' default_pair = mkDefaultPair t mux_pairs - -- The new Id defs for the mux selector control signals - sel_defs = concatMap mkSel ers' + -- The new Id defs for the mux selector control signals + sel_defs = concatMap mkSel ers' - -- The Id of this argument - i = argId ino o m ano + -- The Id of this argument + i = argId ino o m ano - -- The new def for the result of the mux + -- The new def for the result of the mux -- default_pair is an explicit default conditions for the mux ASAny out_def :: ADef - out_def = ADef i t (APrim i t - (if usePri then PrimPriMux else PrimMux) - (mux_pairs ++ default_pair) ) [] + out_def = ADef i t (APrim i t + (if usePri then PrimPriMux else PrimMux) + (mux_pairs ++ default_pair) ) [] - -- The uses used in predicates (should not be > 1) - pred_uses = [ v | (v, _, Nothing) <- ers ] + -- The uses used in predicates (should not be > 1) + pred_uses = [ v | (v, _, Nothing) <- ers ] in --traces ("mkEmux(1) " ++ ppReadable (ers, ers', t)) $ - --traces ("mkEmux(2) " ++ ppReadable (ers)) $ - --traces ("mkEmux(new_defs) " ++ ppReadable (new_defs)) $ - if (length pred_uses > 1) - then internalError ("Multiple port use " ++ + --traces ("mkEmux(2) " ++ ppReadable (ers)) $ + --traces ("mkEmux(new_defs) " ++ ppReadable (new_defs)) $ + if (length pred_uses > 1) + then internalError ("Multiple port use " ++ ppReadable (o, m, map fst3 ers)) - else (sel_defs, val_defs, [out_def]) + else (sel_defs, val_defs, [out_def]) mkEmux _ _ _ _ _ _ _ _ = internalError "mkEMux" @@ -1244,31 +1244,31 @@ mkEnabless (((o, m), f), emrss) = concat (zipWith (mkEnables o m) (map (toMaybe mkEnables :: AId -> AId -> Maybe Integer -> MethPortBlob -> [ADef] mkEnables o m ino emrs = - let mi = mkMethId o m ino MethodEnable - (dss, ess) = unzip (zipWith mkE emrs [1..]) + let mi = mkMethId o m ino MethodEnable + (dss, ess) = unzip (zipWith mkE emrs [1..]) mkE :: (AExpr, Maybe [ARuleId]) -> Integer -> ([ADef], [AExpr]) - mkE (AMethCall _ _ _ (ASInt _ _ (IntLit _ _ 1) : _), Just is) _ = + mkE (AMethCall _ _ _ (ASInt _ _ (IntLit _ _ 1) : _), Just is) _ = ([], [ aWillFireId i | i <- is ]) - mkE (AMethCall _ _ _ (c : _), Just is) k = + mkE (AMethCall _ _ _ (c : _), Just is) k = let ior = mkIdPre (concatFString [mkFString astOrPref, mkNumFString k]) mi - iand = mkIdPre (concatFString [mkFString astAndPref, + iand = mkIdPre (concatFString [mkFString astAndPref, mkNumFString k]) mi dor :: [ADef] - (dor, aor) = - case is of - [i] -> ([], aWillFireId i) - _ -> ([ADef ior aTBool + (dor, aor) = + case is of + [i] -> ([], aWillFireId i) + _ -> ([ADef ior aTBool (aOrs [ aWillFireId i | i <- is ]) []], ASDef aTBool ior) dand :: ADef - dand = ADef iand aTBool (aAnd aor c) [] + dand = ADef iand aTBool (aAnd aor c) [] in (dor ++ [dand], [ASDef aTBool iand]) - mkE _ _ = ([], []) - in case (concat dss, concat ess) of - ([ADef i _ e p], [ASDef _ i']) | i == i' -> [ADef mi aTBool e p] -- pass on props? - (ds, es) -> ds ++ [ADef mi aTBool (aOrs es) []] + mkE _ _ = ([], []) + in case (concat dss, concat ess) of + ([ADef i _ e p], [ASDef _ i']) | i == i' -> [ADef mi aTBool e p] -- pass on props? + (ds, es) -> ds ++ [ADef mi aTBool (aOrs es) []] -- ============================== @@ -1352,7 +1352,7 @@ realClockPorts vmi clk = Nothing -> [] Just (osc, Nothing) -> [Port (osc, [VPclock]) Nothing Nothing] Just (osc, Just gate_vname) -> [Port (osc, [VPclock]) Nothing Nothing, - Port (gate_vname, [VPclockgate]) + Port (gate_vname, [VPclockgate]) Nothing Nothing] -- ClockInfo lookup matches realClockPorts @@ -1398,13 +1398,13 @@ type VModInfoMap = M.Map AId VModInfo mkOutputGatePort :: VModInfoMap -> AId -> AId -> AExpr mkOutputGatePort vmi_map modId clkId = let lookupErr = internalError ("mkOutputGatePort: vmi not found: " ++ - ppReadable modId) - vmi = M.findWithDefault lookupErr modId vmi_map + ppReadable modId) + vmi = M.findWithDefault lookupErr modId vmi_map in - case (lookupOutputClockWires clkId vmi) of - (i_osc, Nothing) -> - internalError ("mkOutputGatePort: no gating signal " ++ - ppReadable (modId, clkId)) - (i_osc, Just i_gate) -> mkOutputWire modId i_gate + case (lookupOutputClockWires clkId vmi) of + (i_osc, Nothing) -> + internalError ("mkOutputGatePort: no gating signal " ++ + ppReadable (modId, clkId)) + (i_osc, Just i_gate) -> mkOutputWire modId i_gate -- ============================== diff --git a/src/comp/ASyntax.hs b/src/comp/ASyntax.hs index c79d8ee3b..4e7966989 100644 --- a/src/comp/ASyntax.hs +++ b/src/comp/ASyntax.hs @@ -1,57 +1,57 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module ASyntax( - APackage(..), + APackage(..), getAPackageFieldInfos, getAPackageClocks, - getAPackageInputs, - getAPackageParamsPortsAndInouts, - apkgIsMCD, - apkgExposesClkOrRst, - AId, - AMethodId, - AType(..), - ASize, - ARule(..), + getAPackageInputs, + getAPackageParamsPortsAndInouts, + apkgIsMCD, + apkgExposesClkOrRst, + AId, + AMethodId, + AType(..), + ASize, + ARule(..), AAssumption(..), - ARuleId, - APred, - AIFace(..), - AInput, - AAbstractInput(..), + ARuleId, + APred, + AIFace(..), + AInput, + AAbstractInput(..), AOutput, AClock(..), AReset(..), AInout(..), - AClockDomain, + AClockDomain, mkOutputWire, mkIfcInoutN, - AExpr(..), - ADef(..), - ASPackage(..), - ASPSignalInfo(..), + AExpr(..), + ADef(..), + ASPackage(..), + ASPSignalInfo(..), ASPMethodInfo(..), ASPCommentInfo(..), AStateOut, - AVInst(..), + AVInst(..), getSpecialOutputs, - getOutputClockWires, + getOutputClockWires, getOutputClockPorts, - getOutputResetPorts, - getIfcInoutPorts, - ASchedule(..), - AScheduler(..), - AAction(..), - ANoInlineFun(..), - ARuleDescr, - aTZero, - aTBool, - aSBool, - aXSBool, - aRuleName, - aRulePred, - aTNat, - aTAction, + getOutputResetPorts, + getIfcInoutPorts, + ASchedule(..), + AScheduler(..), + AAction(..), + ANoInlineFun(..), + ARuleDescr, + aTZero, + aTBool, + aSBool, + aXSBool, + aRuleName, + aRulePred, + aTNat, + aTAction, aTClock, aTReset, aTInout, @@ -63,53 +63,53 @@ module ASyntax( unifyStringTypes, getArrayElemType, getArraySize, - aIfaceName, - aIfaceNameString, + aIfaceName, + aIfaceNameString, aIfaceProps, - aIfaceResSize, - aIfaceResType, - aIfaceResId, - aIfaceArgs, - aIfaceArgSize, - aIfaceRules, - aIfaceRulesImpl, - aIfaceSchedNames, - aIfacePred, - aiface_vname, - aiface_argnames_width, - aIfaceMethods, + aIfaceResSize, + aIfaceResType, + aIfaceResId, + aIfaceArgs, + aIfaceArgSize, + aIfaceRules, + aIfaceRulesImpl, + aIfaceSchedNames, + aIfacePred, + aiface_vname, + aiface_argnames_width, + aIfaceMethods, aIfaceHasAction, - aTrue, - aFalse, - isTrue, - isFalse, + aTrue, + aFalse, + isTrue, + isFalse, aNoReset, cmpASInt, getSchedulerIds, dropScheduleIds, dropSchedulerIds, - aNat, - AForeignCall(..), + aNat, + AForeignCall(..), AForeignBlock, PPrintExpand(..), pPrintExpandFlags, - ppeString, - ppeAPackage, - mkMethId, - mkMethStr, - isMethId, - MethodPart(..), + ppeString, + ppeAPackage, + mkMethId, + mkMethStr, + isMethId, + MethodPart(..), getParams, getPorts, getClocks, getResets, getInouts, - getInstArgs, - defaultAId, + getInstArgs, + defaultAId, binOp, mkCFCondWireInstId, PExpandContext, defContext, bContext, pContext - ) where + ) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804) import Prelude hiding ((<>)) @@ -144,36 +144,36 @@ import InstNodes(InstTree) -- packages converted from ISyntax data APackage = APackage { - -- package name + -- package name apkg_name :: AId, - -- module wrapped around a non-inlined function + -- module wrapped around a non-inlined function apkg_is_wrapped :: Bool, -- whether module compilation was specific to the chosen backend apkg_backend :: Maybe Backend, - -- size parameters (names in verilog) + -- size parameters (names in verilog) apkg_size_params :: [AId], - -- package inputs (ports and parameters) + -- package inputs (ports and parameters) -- in the order described by wireinfo - -- (i.e. clock, reset, inouts, provided method arguments, + -- (i.e. clock, reset, inouts, provided method arguments, -- module arg ports, module arg parameters) apkg_inputs :: [AAbstractInput], - -- table of different clock domains + -- table of different clock domains apkg_clock_domains :: [AClockDomain], - -- description of external wires (e.g. clock and reset) + -- description of external wires (e.g. clock and reset) apkg_external_wires :: VWireInfo, -- table of port names to source types apkg_external_wire_types :: M.Map VName IType, - -- table of resets + -- table of resets apkg_reset_list :: [(ResetId, AReset)], - -- state elements (Verilog instances) + -- state elements (Verilog instances) apkg_state_instances :: [AVInst], - -- local defs, in dependency-sorted order? + -- local defs, in dependency-sorted order? apkg_local_defs :: [ADef], - -- rules, in unspecified order + -- rules, in unspecified order apkg_rules :: [ARule], - -- relationships among rule names + -- relationships among rule names apkg_schedule_pragmas :: [ASchedulePragma], - -- interface methods + -- interface methods apkg_interface :: [AIFace], -- comments on submodule instantiations apkg_inst_comments :: [(Id, [String])], @@ -195,51 +195,51 @@ getAPackageClocks APackage { apkg_clock_domains = acds } = concatMap snd acds getAPackageInputs :: APackage -> [(AAbstractInput, VArgInfo)] getAPackageInputs apkg = let - -- get the two fields - inputs = apkg_inputs apkg - arginfos = wArgs (apkg_external_wires apkg) + -- get the two fields + inputs = apkg_inputs apkg + arginfos = wArgs (apkg_external_wires apkg) - -- check that they are the same length - inputs_length = length (apkg_inputs apkg) - arginfos_length = length arginfos + -- check that they are the same length + inputs_length = length (apkg_inputs apkg) + arginfos_length = length arginfos - args_with_info = zip inputs arginfos + args_with_info = zip inputs arginfos in - if (inputs_length /= arginfos_length) - then internalError ("getAPackageInputs: " ++ - "length inputs != length arginfos: " ++ - ppReadable (inputs, arginfos)) - else args_with_info + if (inputs_length /= arginfos_length) + then internalError ("getAPackageInputs: " ++ + "length inputs != length arginfos: " ++ + ppReadable (inputs, arginfos)) + else args_with_info -- returns the input ports, separated into params, ports and inouts -- (note that this converts abstract inputs to port inputs) getAPackageParamsPortsAndInouts :: APackage -> ([AInput], [AInput], [AInput]) getAPackageParamsPortsAndInouts apkg = let args_with_info = getAPackageInputs apkg - drop_info (xs, ys, zs) = (map fst xs, map fst ys, map fst zs) - cvtToPorts (xs, ys, zs) = - (concatMap absInputToPorts xs, - concatMap absInputToPorts ys, - concatMap absInputToPorts zs) - (params, rest) = partition (isParam . snd) args_with_info - (inouts,ports) = partition (isInout . snd) rest + drop_info (xs, ys, zs) = (map fst xs, map fst ys, map fst zs) + cvtToPorts (xs, ys, zs) = + (concatMap absInputToPorts xs, + concatMap absInputToPorts ys, + concatMap absInputToPorts zs) + (params, rest) = partition (isParam . snd) args_with_info + (inouts,ports) = partition (isInout . snd) rest in cvtToPorts $ drop_info $ (params, ports, inouts) apkgIsMCD :: APackage -> Bool apkgIsMCD apkg = let domains = apkg_clock_domains apkg - clocks = concatMap snd domains - resets = apkg_reset_list apkg + clocks = concatMap snd domains + resets = apkg_reset_list apkg in (length domains /= 1) || - (length clocks /= 1) || - (length resets > 1) + (length clocks /= 1) || + (length resets > 1) apkgExposesClkOrRst :: APackage -> Bool apkgExposesClkOrRst apkg = let isClkOrRst (AIClock {}) = True - isClkOrRst (AIReset {}) = True - isClkOrRst _ = False + isClkOrRst (AIReset {}) = True + isClkOrRst _ = False in any isClkOrRst (apkg_interface apkg) @@ -247,65 +247,65 @@ apkgExposesClkOrRst apkg = -- rules and interface methods have turned into logic connected to state instances data ASPackage = ASPackage { -- package name - aspkg_name :: AId, - -- module wrapped around a pure function with pragma no-inline - aspkg_is_wrapped :: Bool, - -- parameters (names in Verilog) + aspkg_name :: AId, + -- module wrapped around a pure function with pragma no-inline + aspkg_is_wrapped :: Bool, + -- parameters (names in Verilog) -- (i.e. module args generated as params, size parameters) - -- XXX there are no size parameters because we don't support + -- XXX there are no size parameters because we don't support -- XXX synthesis of size-polymorphic modules - aspkg_parameters :: [AInput], - -- package outputs (output clocks/resets, method results/RDY) - aspkg_outputs :: [AOutput], - -- package inputs (input clocks/resets, method args/EN, module args) - -- (i.e. clock, reset, method arguments, module args as ports) - aspkg_inputs :: [AInput], - -- package inouts (module args and provided interface) - aspkg_inouts :: [AInput], - -- state elements (Verilog instances) - aspkg_state_instances :: [AVInst], - -- state element outputs (wires coming out of state elements) - aspkg_state_outputs :: [AStateOut], - -- defs (all sorts) - aspkg_values :: [ADef], + aspkg_parameters :: [AInput], + -- package outputs (output clocks/resets, method results/RDY) + aspkg_outputs :: [AOutput], + -- package inputs (input clocks/resets, method args/EN, module args) + -- (i.e. clock, reset, method arguments, module args as ports) + aspkg_inputs :: [AInput], + -- package inouts (module args and provided interface) + aspkg_inouts :: [AInput], + -- state elements (Verilog instances) + aspkg_state_instances :: [AVInst], + -- state element outputs (wires coming out of state elements) + aspkg_state_outputs :: [AStateOut], + -- defs (all sorts) + aspkg_values :: [ADef], -- inout defs aspkg_inout_values :: [ADef], - -- foreign function calls (grouped by clock domain) - aspkg_foreign_calls :: [AForeignBlock], - -- wire ports from inlined submodules (RWire and CReg) - -- which shouldn't be unecessarily inlined away - aspkg_inlined_ports :: [AId], + -- foreign function calls (grouped by clock domain) + aspkg_foreign_calls :: [AForeignBlock], + -- wire ports from inlined submodules (RWire and CReg) + -- which shouldn't be unecessarily inlined away + aspkg_inlined_ports :: [AId], -- info about which Ids are for what purpose aspkg_signal_info :: ASPSignalInfo, -- user comments to be included in the output RTL aspkg_comment_info :: ASPCommentInfo } - deriving (Eq, Show) + deriving (Eq, Show) instance Hyper ASPackage where hyper x y = (x==x) `seq` y data ASPSignalInfo = ASPSignalInfo { - -- input params, ports, clocks, and resets are all in one list - -- (can use isParam etc to filter it out) + -- input params, ports, clocks, and resets are all in one list + -- (can use isParam etc to filter it out) aspsi_inputs :: [AId], -- the interface output clocks (and possibly empty list of gates) aspsi_output_clks :: [(AId,[AId])], - aspsi_output_rsts :: [AId], - aspsi_ifc_iots :: [AId], + aspsi_output_rsts :: [AId], + aspsi_ifc_iots :: [AId], -- the ifc methods - aspsi_methods :: [ASPMethodInfo], + aspsi_methods :: [ASPMethodInfo], - -- inline submodule info (RWire and CReg) + -- inline submodule info (RWire and CReg) -- XXX this somewhat duplicates the aspkg_inlined_ports field - -- * instance name + -- * instance name -- * module name as String - -- * list of ports that became signals - aspsi_inlined_ports :: [(AId, String, [AId])], + -- * list of ports that became signals + aspsi_inlined_ports :: [(AId, String, [AId])], - -- rule scheduling signals + -- rule scheduling signals -- relation from rule name to its CAN_FIRE and WILL_FIRE signals - aspsi_rule_sched :: [(AId, [AId])], + aspsi_rule_sched :: [(AId, [AId])], -- mux selectors -- ids of defs created in AState for the selectors to submod muxes @@ -317,7 +317,7 @@ data ASPSignalInfo = ASPSignalInfo { -- ids of defs created in AState for the enables to submod methods aspsi_submod_enables :: [AId] } - deriving (Eq, Show) + deriving (Eq, Show) instance PPrint ASPSignalInfo where @@ -332,10 +332,10 @@ instance PPrint ASPSignalInfo where -- relation from method name to -- type of method (value, action, actionvalue) as string - -- ports for RDY, EN, val, args - -- names of the associated rules (for methods with actions) + -- ports for RDY, EN, val, args + -- names of the associated rules (for methods with actions) data ASPMethodInfo = ASPMethodInfo { - aspm_name :: AId, + aspm_name :: AId, aspm_type :: String, aspm_mrdyid :: Maybe AId, aspm_menableid :: Maybe AId, @@ -361,13 +361,13 @@ instance Hyper ASPSignalInfo where data ASPCommentInfo = ASPCommentInfo { -- comments on submodule instantiations - aspci_submod_insts :: [(Id, [String])], + aspci_submod_insts :: [(Id, [String])], -- comments on rules - aspci_rules :: [(AId, [String])] + aspci_rules :: [(AId, [String])] -- comments on methods -- aspsi_methods :: ... } - deriving (Eq, Show) + deriving (Eq, Show) instance Hyper ASPCommentInfo where hyper x y = (x==x) `seq` y @@ -375,27 +375,27 @@ instance Hyper ASPCommentInfo where -- parallel rule groups; total order on state -- (first rule in the list writes, present only if there are state conflicts) data ASchedule = ASchedule { - asch_scheduler :: [AScheduler], - -- list of ruleids is REVERSE ordering for execution - asch_rev_exec_order :: [ARuleId] + asch_scheduler :: [AScheduler], + -- list of ruleids is REVERSE ordering for execution + asch_rev_exec_order :: [ARuleId] } - deriving (Eq, Show) + deriving (Eq, Show) instance Hyper ASchedule where hyper x y = (x==x) `seq` y newtype AScheduler = - -- esposito: (r,f) s.t. - -- f is the list of conditions for which - -- rule r should not fire when enabled - -- f is expressed as a - -- list of rules that conflict with the rule r. - -- In the future, f should be a list of list of rules, - -- where the sublists are a list of rules which when - -- enabled should disable the firing of r. - -- So [[a,b],[c],[d,e,f]] = !(ab) && !c && !(def) + -- esposito: (r,f) s.t. + -- f is the list of conditions for which + -- rule r should not fire when enabled + -- f is expressed as a + -- list of rules that conflict with the rule r. + -- In the future, f should be a list of list of rules, + -- where the sublists are a list of rules which when + -- enabled should disable the firing of r. + -- So [[a,b],[c],[d,e,f]] = !(ab) && !c && !(def) ASchedEsposito [(ARuleId, [ARuleId])] - deriving (Eq, Show) + deriving (Eq, Show) getSchedulerIds :: AScheduler -> [ARuleId] getSchedulerIds (ASchedEsposito fs) = map fst fs @@ -425,13 +425,13 @@ type AMethodId = AId data AType = -- Bit k - ATBit { + ATBit { atb_size :: ASize } - -- sized or unsized string + -- sized or unsized string | ATString { ats_maybe_size :: Maybe ASize - } + } -- Verilog real number | ATReal -- PrimArray @@ -440,12 +440,12 @@ data AType = atr_elem_type :: AType } -- abstract type, PrimAction, Interface, Clock, .. - -- (can take size parameters as arguments) + -- (can take size parameters as arguments) | ATAbstract { - ata_id :: AId, - ata_sizes :: [ASize] - } - deriving (Eq, Ord, Show) + ata_id :: AId, + ata_sizes :: [ASize] + } + deriving (Eq, Ord, Show) instance Hyper AType where hyper x y = (x==x) `seq` y @@ -522,13 +522,13 @@ type AInput = (AId, AType) data AAbstractInput = -- simple input using one port AAI_Port AInput | - -- clock osc and maybe gate + -- clock osc and maybe gate AAI_Clock AId (Maybe AId) | - AAI_Reset AId | - AAI_Inout AId Integer - -- room to add other types here, like: - -- AAI_Struct [(AId, AType)] - -- ... + AAI_Reset AId | + AAI_Inout AId Integer + -- room to add other types here, like: + -- AAI_Struct [(AId, AType)] + -- ... deriving (Eq, Show) absInputToPorts :: AAbstractInput -> [AInput] @@ -577,24 +577,24 @@ data AVInst = AVInst { getSpecialOutputs :: AVInst -> [(AId, AType, VPort)] getSpecialOutputs avi = let - extractClkPorts (_, osc_port, Nothing) = [osc_port] - extractClkPorts (_, osc_port, Just gate_port) = [osc_port, gate_port] + extractClkPorts (_, osc_port, Nothing) = [osc_port] + extractClkPorts (_, osc_port, Just gate_port) = [osc_port, gate_port] - -- throw away the association with the clock/reset name - clk_ports = concatMap extractClkPorts (getOutputClockPorts avi) - rst_ports = map snd (getOutputResetPorts avi) - iot_ports = map snd (getIfcInoutPorts avi) + -- throw away the association with the clock/reset name + clk_ports = concatMap extractClkPorts (getOutputClockPorts avi) + rst_ports = map snd (getOutputResetPorts avi) + iot_ports = map snd (getIfcInoutPorts avi) in - -- nub because special wires (e.g. an oscillator) - -- can theoretically be reused - nub (clk_ports ++ rst_ports ++ iot_ports) + -- nub because special wires (e.g. an oscillator) + -- can theoretically be reused + nub (clk_ports ++ rst_ports ++ iot_ports) -- Does not return clock gates ports which are "outhigh" getOutputClockWires :: AVInst -> - [(AId, -- Clock Id - AId, -- Osc - Maybe AId)] -- Gate + [(AId, -- Clock Id + AId, -- Osc + Maybe AId)] -- Gate getOutputClockWires avi = let vmi = avi_vmi avi @@ -602,37 +602,37 @@ getOutputClockWires avi = mkOscWire osc_name = mkOutputWireId (avi_vname avi) osc_name mkGateWire gate_name = mkOutputWireId (avi_vname avi) gate_name clock_wires clk_id = - case (lookupOutputClockWires clk_id vmi) of + case (lookupOutputClockWires clk_id vmi) of (osc_name, Nothing) -> - (clk_id, mkOscWire osc_name, Nothing) - (osc_name, Just gate_name) -> - (clk_id, mkOscWire osc_name, Just (mkGateWire gate_name)) + (clk_id, mkOscWire osc_name, Nothing) + (osc_name, Just gate_name) -> + (clk_id, mkOscWire osc_name, Just (mkGateWire gate_name)) in map clock_wires out_clocks getOutputClockPorts :: AVInst -> - [(AId, -- Clock Id - (AId, AType, VPort), -- Osc - Maybe (AId, AType, VPort))] -- Gate + [(AId, -- Clock Id + (AId, AType, VPort), -- Osc + Maybe (AId, AType, VPort))] -- Gate getOutputClockPorts avi = let vmi = avi_vmi avi out_clocks = [id | (Clock id) <- vFields vmi] mkOscPort clk_name = - (mkOutputWireId (avi_vname avi) clk_name, - ATBit 1, - (clk_name, [VPclock])) + (mkOutputWireId (avi_vname avi) clk_name, + ATBit 1, + (clk_name, [VPclock])) mkGatePort (clk_gate_name, portprops) = - (mkOutputWireId (avi_vname avi) clk_gate_name, - ATBit 1, - (clk_gate_name, (VPclockgate:portprops))) + (mkOutputWireId (avi_vname avi) clk_gate_name, + ATBit 1, + (clk_gate_name, (VPclockgate:portprops))) clock_ports id = - case (lookupOutputClockPorts id vmi) of + case (lookupOutputClockPorts id vmi) of (clk_name, Nothing) -> - (id, mkOscPort clk_name, Nothing) - (clk_name, Just clk_gate_vport) -> - (id, mkOscPort clk_name, Just (mkGatePort clk_gate_vport)) + (id, mkOscPort clk_name, Nothing) + (clk_name, Just clk_gate_vport) -> + (id, mkOscPort clk_name, Just (mkGatePort clk_gate_vport)) in map clock_ports out_clocks @@ -643,11 +643,11 @@ getOutputResetPorts avi = vmi = avi_vmi avi output_resets = [id | (Reset id) <- vFields vmi] mkResetPort rst_name = (mkOutputWireId (avi_vname avi) rst_name, - ATBit 1, - (rst_name, [VPreset])) + ATBit 1, + (rst_name, [VPreset])) reset_ports id = - let rst_name = lookupOutputResetPort id vmi - in (id, mkResetPort rst_name) + let rst_name = lookupOutputResetPort id vmi + in (id, mkResetPort rst_name) in map reset_ports output_resets @@ -659,12 +659,12 @@ getIfcInoutPorts avi = ifc_inouts = [(id,vn,ty) | (Inout id vn _ _, mr) <- zip (vFields vmi) res_types, let ty = fromJustOrErr ("ASyntax.unknown inout " ++ - ppReadable id) mr] + ppReadable id) mr] mkInoutPort ty vname = (mkOutputWireId (avi_vname avi) vname, - ty, - (vname, [VPinout])) + ty, + (vname, [VPinout])) inout_ports (id,vn,ty) = (id, mkInoutPort ty vn) in map inout_ports ifc_inouts @@ -684,7 +684,7 @@ getPorts avi = [e | (i, e) <- getInstArgs avi, isPort i] getInstArgs :: AVInst -> [(VArgInfo, AExpr)] getInstArgs avi = zip (vArgs vi) es where vi = avi_vmi avi - es = avi_iargs avi + es = avi_iargs avi getClocks :: AVInst -> [AExpr] getClocks avi = [e | (i,e) <- getInstArgs avi, isClock i] @@ -702,7 +702,7 @@ data ADef = ADef { adef_expr :: AExpr, adef_props :: [DefProp] } - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show) instance HasPosition ADef where getPosition adef = getPosition (adef_objid adef ) @@ -714,18 +714,18 @@ instance Hyper ADef where -- it's only used as an optimization; it's safe to put Nothing there data ARule = ARule { - arule_id :: ARuleId, -- rule name with a suffix + arule_id :: ARuleId, -- rule name with a suffix arule_pragmas :: [RulePragma], -- rule pragmas, - -- e.g., no-implicit-conditions + -- e.g., no-implicit-conditions arule_descr :: ARuleDescr, -- string that describes the rule arule_wprops :: WireProps, -- clock domain and reset information arule_pred :: APred, -- rule predicate (CAN_FIRE) arule_actions :: [AAction], -- rule body (actions) arule_assumps :: [AAssumption], -- assumptions that should hold after this rule executes arule_parent :: (Maybe ARuleId) -- if this rule came from a split, - -- Just parent rule name + -- Just parent rule name } - deriving (Eq, Show) + deriving (Eq, Show) type ARuleDescr = String @@ -764,12 +764,12 @@ data AIFace = AIDef { aif_name :: AId, aif_body :: [ARule], aif_fieldinfo :: VFieldInfo } | AIActionValue { aif_inputs :: [AInput], - aif_props :: WireProps, - aif_pred :: APred, - aif_name :: AId, - aif_body :: [ARule], - aif_value :: ADef, - aif_fieldinfo :: VFieldInfo } + aif_props :: WireProps, + aif_pred :: APred, + aif_name :: AId, + aif_body :: [ARule], + aif_value :: ADef, + aif_fieldinfo :: VFieldInfo } -- trivial aif_inputs, props, pred? | AIClock { aif_name :: AId, aif_clock :: AClock, @@ -836,8 +836,8 @@ aiface_argnames_width (AIClock {}) = [] aiface_argnames_width (AIReset {}) = [] aiface_argnames_width aif = zip3 (map fst (aif_inputs aif)) - (map (getVNameString . fst) (vf_inputs (aif_fieldinfo aif))) - (map aIfaceArgSize (aif_inputs aif)) + (map (getVNameString . fst) (vf_inputs (aif_fieldinfo aif))) + (map aIfaceArgSize (aif_inputs aif)) aIfaceArgSize :: AInput -> Integer @@ -854,7 +854,7 @@ aIfaceRulesImpl (AIAction { aif_name = i, aif_body = rs }) = map (addRdyToARule rdyId) rs where rdyId = mkRdyId i aIfaceRulesImpl (AIActionValue { aif_name = i, - aif_body = rs }) = map (addRdyToARule rdyId) rs + aif_body = rs }) = map (addRdyToARule rdyId) rs where rdyId = mkRdyId i aIfaceRulesImpl _ = [] @@ -886,9 +886,9 @@ aIfacePred ifc@(AIInout {}) = aIfaceMethods :: [AIFace] -> [AIFace] aIfaceMethods is = let getMethod (AIClock {}) = Nothing - getMethod (AIReset {}) = Nothing - getMethod (AIInout {}) = Nothing - getMethod i = Just i + getMethod (AIReset {}) = Nothing + getMethod (AIInout {}) = Nothing + getMethod i = Just i in mapMaybe getMethod is @@ -899,35 +899,35 @@ aIfaceHasAction _ = False -- note no types because they are implicitly action data AAction - = ACall { -- state method call - aact_objid :: AId, - acall_methid :: AMethodId, - aact_args :: [AExpr] -- first element of the list is the condition - } - | AFCall { - aact_objid :: AId, -- foreign function call - afcall_fun :: String, - afcall_isC :: Bool, - aact_args :: [AExpr], -- first element of the list is the condition + = ACall { -- state method call + aact_objid :: AId, + acall_methid :: AMethodId, + aact_args :: [AExpr] -- first element of the list is the condition + } + | AFCall { + aact_objid :: AId, -- foreign function call + afcall_fun :: String, + afcall_isC :: Bool, + aact_args :: [AExpr], -- first element of the list is the condition -- is it an action inserted by BSC to check an assumption aact_assump :: Bool - } + } -- action part of a foreign ActionValue function | ATaskAction { - aact_objid :: AId, - ataskact_fun :: String, - ataskact_isC :: Bool, - ataskact_cookie :: Integer, -- correlation cookie - aact_args :: [AExpr], -- first element is the condition + aact_objid :: AId, + ataskact_fun :: String, + ataskact_isC :: Bool, + ataskact_cookie :: Integer, -- correlation cookie + aact_args :: [AExpr], -- first element is the condition -- the temporary to set, spliced in later - ataskact_temp :: (Maybe Id), + ataskact_temp :: (Maybe Id), -- include the return value type for easy reference, -- and to support foreign functions with ignored values - ataskact_value_type :: AType, + ataskact_value_type :: AType, -- is it an action inserted by BSC to check an assumption aact_assump :: Bool - } - deriving (Eq, Ord, Show) + } + deriving (Eq, Ord, Show) instance Hyper AAction where hyper x y = (x==x) `seq` y @@ -945,18 +945,18 @@ data AClock = AClock { instance PPrint AClock where pPrint d p (AClock osc gate) = (text "{ osc: ") <+> - (pPrint d p osc) <+> - (text "gate: ") <+> - (pPrint d p gate) <+> - (text "}") + (pPrint d p osc) <+> + (text "gate: ") <+> + (pPrint d p gate) <+> + (text "}") mkOutputWireId :: AId -> VName -> AId mkOutputWireId var_id (VName wire_str) = let var_fstr = getIdFString (unQualId var_id) wire_fstr = mkFString wire_str in mkId - noPosition - (concatFString [var_fstr, fsDollar, wire_fstr]) + noPosition + (concatFString [var_fstr, fsDollar, wire_fstr]) mkOutputWire :: AId -> VName -> AExpr mkOutputWire var_id wire_name = ASPort (ATBit 1) (mkOutputWireId var_id wire_name) @@ -983,166 +983,166 @@ instance PPrint AInout where pPrint d p (AInout { ainout_wire = wire }) = (text "{ wire: ") <+> (pPrint d p wire) <+> (text "}") -- Every expression is annotated with its (result) type - -- all types should be ae_type - -- all ids should be ae_objid + -- all types should be ae_type + -- all ids should be ae_objid data AExpr - = APrim { -- Verilog primitive (e.g., +) - ae_objid :: AId, - ae_type :: AType, - aprim_prim :: PrimOp, - ae_args :: [AExpr] - } - | AMethCall { - ae_type :: AType, - ae_objid :: AId, - ameth_id :: AMethodId, - ae_args :: [AExpr] -- external state method call - } - -- like AMethCall, but for the return value of actionvalue methods, - -- where the return value no longer has to care about the arguments, - -- because the action (AAction) will handle the muxing and arbitration - -- of arguments and there is no multiplicity for actionvalue methods - | AMethValue { - ae_type :: AType, - ae_objid :: AId, - ameth_id :: AMethodId - } + = APrim { -- Verilog primitive (e.g., +) + ae_objid :: AId, + ae_type :: AType, + aprim_prim :: PrimOp, + ae_args :: [AExpr] + } + | AMethCall { + ae_type :: AType, + ae_objid :: AId, + ameth_id :: AMethodId, + ae_args :: [AExpr] -- external state method call + } + -- like AMethCall, but for the return value of actionvalue methods, + -- where the return value no longer has to care about the arguments, + -- because the action (AAction) will handle the muxing and arbitration + -- of arguments and there is no multiplicity for actionvalue methods + | AMethValue { + ae_type :: AType, + ae_objid :: AId, + ameth_id :: AMethodId + } -- calls a combinatorial function expressed via module instantiation - -- XXX this can be created not only via "noinline" in BSV, - -- XXX but also "foreign" in Classic syntax; consider renaming? - | ANoInlineFunCall { - ae_type :: AType, - ae_objid :: AId, - ae_fun :: ANoInlineFun, - ae_args :: [AExpr] - } - -- foreign function / task call - | AFunCall { - ae_type :: AType, - ae_objid :: AId, - ae_funname :: String, - ae_isC :: Bool, - ae_args :: [AExpr] -- external function call - } + -- XXX this can be created not only via "noinline" in BSV, + -- XXX but also "foreign" in Classic syntax; consider renaming? + | ANoInlineFunCall { + ae_type :: AType, + ae_objid :: AId, + ae_fun :: ANoInlineFun, + ae_args :: [AExpr] + } + -- foreign function / task call + | AFunCall { + ae_type :: AType, + ae_objid :: AId, + ae_funname :: String, + ae_isC :: Bool, + ae_args :: [AExpr] -- external function call + } | ATaskValue { -- value returned by an ActionValue foreign task call - ae_type :: AType, - ae_objid :: AId, - ae_funname :: String, - ae_isC :: Bool, - ae_cookie :: Integer -- "cookie" identifying the call for later fixup + ae_type :: AType, + ae_objid :: AId, + ae_funname :: String, + ae_isC :: Bool, + ae_cookie :: Integer -- "cookie" identifying the call for later fixup -- arguments, etc. handled by the action side of the call - } - | ASPort { -- module ports - ae_type :: AType, - ae_objid :: AId - } - | ASParam { -- module parameters - ae_type :: AType, - ae_objid :: AId - } - | ASDef { -- reference to local definition or input to module - ae_type :: AType, - ae_objid :: AId - } - | ASInt { -- constant - ae_objid :: AId, - ae_type :: AType, - ae_ival :: IntLit - } + } + | ASPort { -- module ports + ae_type :: AType, + ae_objid :: AId + } + | ASParam { -- module parameters + ae_type :: AType, + ae_objid :: AId + } + | ASDef { -- reference to local definition or input to module + ae_type :: AType, + ae_objid :: AId + } + | ASInt { -- constant + ae_objid :: AId, + ae_type :: AType, + ae_ival :: IntLit + } | ASReal { -- real-valued constant ae_objid :: AId, ae_type :: AType, ae_rval :: Double } - | ASStr { -- string literal - ae_objid :: AId, - ae_type :: AType, - ae_strval :: String - } - | ASAny { -- don't care expression - ae_type :: AType, + | ASStr { -- string literal + ae_objid :: AId, + ae_type :: AType, + ae_strval :: String + } + | ASAny { -- don't care expression + ae_type :: AType, ae_val :: Maybe (AExpr) - } + } | ASClock { -- abstract clock - ae_type :: AType, -- (will vanish after AState) - ae_clock :: AClock - } + ae_type :: AType, -- (will vanish after AState) + ae_clock :: AClock + } | ASReset { -- abstract reset - ae_type :: AType, -- (will vanish after AState), - ae_expr :: AReset - } + ae_type :: AType, -- (will vanish after AState), + ae_expr :: AReset + } | ASInout { -- abstract inout - ae_type :: AType, -- (will vanish after AState), - ae_expi :: AInout - } + ae_type :: AType, -- (will vanish after AState), + ae_expi :: AInout + } {- -- instead of using ASPort, ASPackage should create these: | AWire { - ae_type :: AType, - ae_objid :: AId - } - -- reset access on a submodule - | AMReset { - ae_type :: AType, -- always ATBit 1 - ae_objid :: AId, - ae_rstid :: AId - } - -- oscillator access on a submodule - | AMOsc { - ae_type :: AType, -- always ATBit 1 - ae_objid :: AId, - ae_clkid :: AId - } + ae_type :: AType, + ae_objid :: AId + } + -- reset access on a submodule + | AMReset { + ae_type :: AType, -- always ATBit 1 + ae_objid :: AId, + ae_rstid :: AId + } + -- oscillator access on a submodule + | AMOsc { + ae_type :: AType, -- always ATBit 1 + ae_objid :: AId, + ae_clkid :: AId + } -} - -- oscillator access on a submodule - | AMGate { - ae_type :: AType, -- always ATBit 1 - ae_objid :: AId, - ae_clkid :: AId - } - deriving (Ord, Show) + -- oscillator access on a submodule + | AMGate { + ae_type :: AType, -- always ATBit 1 + ae_objid :: AId, + ae_clkid :: AId + } + deriving (Ord, Show) instance Hyper AExpr where hyper x y = (x==x) `seq` y instance Eq AExpr where APrim _ t op aexprs == APrim _ t' op' aexprs' = - (t == t') && (op == op') && (aexprs == aexprs') + (t == t') && (op == op') && (aexprs == aexprs') AMethCall t aid mid aexprs == AMethCall t' aid' mid' aexprs' = - (t == t') && (mid == mid') && (aexprs == aexprs') && (aid == aid') + (t == t') && (mid == mid') && (aexprs == aexprs') && (aid == aid') AMethValue t aid mid == AMethValue t' aid' mid' = - (t == t') && (mid == mid') && (aid == aid') + (t == t') && (mid == mid') && (aid == aid') ANoInlineFunCall t aid af aexprs == ANoInlineFunCall t' aid' af' aexprs' = - (t == t') && (af == af') && (aexprs == aexprs') && (aid == aid') + (t == t') && (af == af') && (aexprs == aexprs') && (aid == aid') AFunCall t aid af isC aexprs == AFunCall t' aid' af' isC' aexprs' = - (t == t') && (af == af') && (isC == isC') && (aexprs == aexprs') && (aid == aid') + (t == t') && (af == af') && (isC == isC') && (aexprs == aexprs') && (aid == aid') ATaskValue t aid af isC n == ATaskValue t' aid' af' isC' n' = - (t == t') && (aid == aid') && (af == af') && (isC == isC') && (n == n') + (t == t') && (aid == aid') && (af == af') && (isC == isC') && (n == n') ASPort t aid == ASPort t' aid' = - (t == t') && (aid == aid') + (t == t') && (aid == aid') ASParam t aid == ASParam t' aid' = - (t == t') && (aid == aid') + (t == t') && (aid == aid') ASDef t aid == ASDef t' aid' = - (t == t') && (aid == aid') + (t == t') && (aid == aid') ASInt _ t il == ASInt _ t' il' = - (t == t') && (il == il') + (t == t') && (il == il') ASReal _ t r == ASReal _ t' r' = (t == t') && (r == r') ASStr _ t str == ASStr _ t' str' = - (t == t') && (str == str') + (t == t') && (str == str') ASAny t me == ASAny t' me' = - ((t, me) == (t', me')) + ((t, me) == (t', me')) ASClock t c == ASClock t' c' = c == c' -- t and t' should be aTClock @@ -1151,7 +1151,7 @@ instance Eq AExpr where ASInout t e == ASInout t' e' = e == e' -- t and t' should be aTInout AMGate t oid cid == AMGate t' oid' cid' = - (t == t') && (oid == oid') && (cid == cid') + (t == t') && (oid == oid') && (cid == cid') aexpr == aexpr' = False @@ -1182,11 +1182,11 @@ data ANoInlineFun = String -- numeric types [Integer] - -- port list (inputs,outputs), each is port name and size + -- port list (inputs,outputs), each is port name and size -- XXX sizes all seem to be generated as 0. ([(String, Integer)], [(String, Integer)]) - -- when an instance name is assigned to the call, it is stored here - (Maybe String) + -- when an instance name is assigned to the call, it is stored here + (Maybe String) deriving (Eq, Ord, Show) @@ -1196,14 +1196,14 @@ type AForeignBlock = ([AExpr], [AForeignCall]) -- type not required because it is implicitly Action data AForeignCall = - AForeignCall { + AForeignCall { afc_name :: AId, afc_fun :: String, afc_args :: [AExpr], -- first element of the list is the condition -- (including the WILL_FIRE of the calling rule) afc_writes :: [AId], -- identifiers set by this foreign function call afc_resets :: [AExpr] -- reset wires connected to this foreign function call - -- inouts not connected to foreign function calls at present + -- inouts not connected to foreign function calls at present } deriving (Eq, Show) @@ -1247,34 +1247,34 @@ cmpASInt x y = internalError("cmpASInt: " ++ show x ++ " == " ++ show y) instance PPrint APackage where pPrint d _ apkg = - (text "APackage" <+> ppId d (apkg_name apkg) <> + (text "APackage" <+> ppId d (apkg_name apkg) <> if (apkg_is_wrapped apkg) then text " -- function" else empty) $+$ (case (apkg_backend apkg) of - Nothing -> empty - Just be -> text " -- backend:" <+> pPrint d 0 be) $+$ - text "-- APackage parameters" $+$ - pPrint d 0 (apkg_size_params apkg) $+$ - text "-- APackage arguments" $+$ - foldr ($+$) empty (map (pPrint d 0) (apkg_inputs apkg)) $+$ + Nothing -> empty + Just be -> text " -- backend:" <+> pPrint d 0 be) $+$ + text "-- APackage parameters" $+$ + pPrint d 0 (apkg_size_params apkg) $+$ + text "-- APackage arguments" $+$ + foldr ($+$) empty (map (pPrint d 0) (apkg_inputs apkg)) $+$ text "-- APackage wire info" $+$ pPrint d 0 (apkg_external_wires apkg) $+$ text "-- APackage clock domains" $+$ pPrint d 0 (apkg_clock_domains apkg) $+$ text "-- APackage resets" $+$ pPrint d 0 (apkg_reset_list apkg) $+$ - text "-- AP state elements" $+$ - foldr ($+$) empty (map (pPrint d 0) (apkg_state_instances apkg)) $+$ - text "-- AP local definitions" $+$ - foldr ($+$) empty (map (pPrint d 0) (apkg_local_defs apkg)) $+$ - text "-- AP rules" $+$ - foldr ($+$) empty (map (pPrint d 0) (apkg_rules apkg)) $+$ - text "-- AP scheduling pragmas" $+$ - pPrint d 0 (apkg_schedule_pragmas apkg) $+$ - text "-- AP interface" $+$ - foldr ($+$) empty [(text "-- AP apkg_interface def" <+> pPrint d 0 (apkg_name apkg)) $+$ + text "-- AP state elements" $+$ + foldr ($+$) empty (map (pPrint d 0) (apkg_state_instances apkg)) $+$ + text "-- AP local definitions" $+$ + foldr ($+$) empty (map (pPrint d 0) (apkg_local_defs apkg)) $+$ + text "-- AP rules" $+$ + foldr ($+$) empty (map (pPrint d 0) (apkg_rules apkg)) $+$ + text "-- AP scheduling pragmas" $+$ + pPrint d 0 (apkg_schedule_pragmas apkg) $+$ + text "-- AP interface" $+$ + foldr ($+$) empty [(text "-- AP apkg_interface def" <+> pPrint d 0 (apkg_name apkg)) $+$ pPrint d 0 i | i <- apkg_interface apkg] $+$ - text "-- AP instance comments" $+$ - foldr ($+$) empty (map (ppInstComment d) (apkg_inst_comments apkg)) $+$ + text "-- AP instance comments" $+$ + foldr ($+$) empty (map (ppInstComment d) (apkg_inst_comments apkg)) $+$ text "-- AP remaining proof obligations" $+$ pPrint d 0 (apkg_proof_obligations apkg) @@ -1287,18 +1287,18 @@ ppV d (i, t) = pPrint d 0 i <+> text "::" <+> pPrint d 0 t <> text ";" instance PPrint AAbstractInput where pPrint d p (AAI_Port v) = ppV d v pPrint d p (AAI_Clock osc Nothing) = - text "clock {" <+> - (text "osc =" <+> pPrint d 0 osc) <+> - text "}" + text "clock {" <+> + (text "osc =" <+> pPrint d 0 osc) <+> + text "}" pPrint d p (AAI_Clock osc (Just gate)) = - text "clock {" <+> - (text "osc =" <+> pPrint d 0 osc <> text "," <+> - text "gate =" <+> pPrint d 0 gate) <+> - text "}" + text "clock {" <+> + (text "osc =" <+> pPrint d 0 osc <> text "," <+> + text "gate =" <+> pPrint d 0 gate) <+> + text "}" pPrint d p (AAI_Reset r) = - text "reset {" <+> pPrint d 0 r <+> text "}" + text "reset {" <+> pPrint d 0 r <+> text "}" pPrint d p (AAI_Inout r n) = - text "inout {" <+> pPrint d 0 r <> text"[" <> pPrint d 0 n <> text"]" <+> text "}" + text "inout {" <+> pPrint d 0 r <> text"[" <> pPrint d 0 n <> text"]" <+> text "}" instance PPrint AVInst where pPrint d _ (AVInst i t ui mts pts vi es ns) = @@ -1314,43 +1314,43 @@ ppVTI d (vi, es, ns) = sep [pPrint d 0 (vName vi), pPrint d 0 vi, pPrint d 0 es, instance PPrint ASPackage where pPrint d p pack@(ASPackage mi fmod ps exps is ios ss sos ds iods fs ws ids cmap) = - (text "ASPackage" <+> ppId d mi <> if fmod then text " -- function" else text "") $+$ - text "-- ASPackage parameters" $+$ - (text "" <+> sep (map (pPrint d 0) ps) <> text ";") $+$ - text "-- ASPackage outputs" $+$ - (text "" <+> sep (map (pPrint d 0) exps) <> text ";") $+$ - text "-- ASPackage inputs" $+$ - foldr ($+$) (text "") (map (ppV d) is) $+$ - text "-- ASPackage inouts" $+$ - foldr ($+$) (text "") (map (ppV d) ios) $+$ - text "-- ASP state elements" $+$ - foldr ($+$) (text "") (map (pPrint d 0) ss) $+$ - text "-- ASP state elements outputs" $+$ - foldr ($+$) (text "") (map (ppV d) sos) $+$ + (text "ASPackage" <+> ppId d mi <> if fmod then text " -- function" else text "") $+$ + text "-- ASPackage parameters" $+$ + (text "" <+> sep (map (pPrint d 0) ps) <> text ";") $+$ + text "-- ASPackage outputs" $+$ + (text "" <+> sep (map (pPrint d 0) exps) <> text ";") $+$ + text "-- ASPackage inputs" $+$ + foldr ($+$) (text "") (map (ppV d) is) $+$ + text "-- ASPackage inouts" $+$ + foldr ($+$) (text "") (map (ppV d) ios) $+$ + text "-- ASP state elements" $+$ + foldr ($+$) (text "") (map (pPrint d 0) ss) $+$ + text "-- ASP state elements outputs" $+$ + foldr ($+$) (text "") (map (ppV d) sos) $+$ text "-- ASP inlined rwire ports" $+$ foldr ($+$) (text "") (map (pPrint d 0) ws) $+$ - text "-- ASP definitions" $+$ - foldr ($+$) (text "") (map (pPrint d 0) ds) $+$ - text "-- ASP inout definitions" $+$ - foldr ($+$) (text "") (map (pPrint d 0) iods) $+$ + text "-- ASP definitions" $+$ + foldr ($+$) (text "") (map (pPrint d 0) ds) $+$ + text "-- ASP inout definitions" $+$ + foldr ($+$) (text "") (map (pPrint d 0) iods) $+$ text "-- ASP foreign function calls" $+$ foldr ($+$) (text "") (map (pPrint d 0) fs) $+$ text "--ASP Signal Info" $+$ pPrint d 0 (aspkg_signal_info pack) instance PPrint ASchedule where pPrint d p (ASchedule groups order) = (text "parallel:" <+> pPrint d 0 groups) - $+$ (text "order:" <+> pPrint d 0 (reverse order)) + $+$ (text "order:" <+> pPrint d 0 (reverse order)) instance PPrint AScheduler where pPrint d p (ASchedEsposito fs) = - let ppDep (r,cfs) = pPrint d 0 r <+> text "->" <+> pPrint d 0 cfs - in text "esposito:" <+> text "[" <> sep (punctuate (text ",") (map ppDep fs)) <> text "]" + let ppDep (r,cfs) = pPrint d 0 r <+> text "->" <+> pPrint d 0 cfs + in text "esposito:" <+> text "[" <> sep (punctuate (text ",") (map ppDep fs)) <> text "]" instance PPrint ADef where pPrint d _ (ADef i t e props) = - (pPrint d 0 i <+> text "::" <+> pPrint d 0 t <> text ";") $+$ - (pPrint d 0 i <> text " =" <+> pPrint d 0 e <> text ";") $+$ + (pPrint d 0 i <+> text "::" <+> pPrint d 0 t <> text ";") $+$ + (pPrint d 0 i <> text " =" <+> pPrint d 0 e <> text ";") $+$ (if (null $ getIdProps i) then empty else text "-- IdProp" <+> text (show i) ) $+$ (if (null props) then empty else @@ -1362,42 +1362,42 @@ pPred d p pred = text "pred: " <+> pPrint d p pred instance PPrint AIFace where -- XXX print assumptions pPrint d p ai@(AIDef {} ) = - (text "--AIDef" <+> pPrint d p (aif_name ai)) $+$ + (text "--AIDef" <+> pPrint d p (aif_name ai)) $+$ foldr ($+$) empty (map (ppV d) (aif_inputs ai)) $+$ - pPrint d 0 (aif_value ai) $+$ - pPred d p (aif_pred ai) $+$ + pPrint d 0 (aif_value ai) $+$ + pPred d p (aif_pred ai) $+$ pPrint d 0 (aif_props ai) $+$ pPrint d 0 (aif_fieldinfo ai) $+$ - text "" + text "" pPrint d p ai@(AIAction {} ) = - (text "--AIAction" <+> pPrint d p (aif_name ai)) $+$ - foldr ($+$) empty (map (ppV d) (aif_inputs ai)) $+$ - pPrint d p (aif_body ai) $+$ - pPred d p (aif_pred ai) $+$ + (text "--AIAction" <+> pPrint d p (aif_name ai)) $+$ + foldr ($+$) empty (map (ppV d) (aif_inputs ai)) $+$ + pPrint d p (aif_body ai) $+$ + pPred d p (aif_pred ai) $+$ pPrint d 0 (aif_props ai) $+$ pPrint d 0 (aif_fieldinfo ai) $+$ - text "" + text "" pPrint d p ai@(AIActionValue {}) = -- XXX this should be done better - (text "--AIActionValue" <+> pPrint d p (aif_name ai)) $+$ - foldr ($+$) empty (map (ppV d) (aif_inputs ai) ) $+$ - pPrint d p (aif_value ai) $+$ + (text "--AIActionValue" <+> pPrint d p (aif_name ai)) $+$ + foldr ($+$) empty (map (ppV d) (aif_inputs ai) ) $+$ + pPrint d p (aif_value ai) $+$ pPrint d p (aif_body ai) $+$ - pPred d p (aif_pred ai) $+$ + pPred d p (aif_pred ai) $+$ pPrint d 0 (aif_props ai) $+$ pPrint d 0 (aif_fieldinfo ai) $+$ - text "" + text "" pPrint d p (AIClock i c _) = pPrint d 0 c pPrint d p (AIReset i r _) = pPrint d 0 r pPrint d p (AIInout i r _) = pPrint d 0 r instance PPrint ARule where pPrint d@PDDebug _ (ARule s _ _ _ p as _ _) = - (text "rule" <+> pPrint d 0 s) + (text "rule" <+> pPrint d 0 s) pPrint d _ (ARule s rps sd wp p as asmps _) = - vcat (map (pPrint d 0) rps) $+$ - (text "rule" <+> pPrint d 0 s <> text (" " ++ show sd) <> text ":") $+$ - (text " when" <+> pPrint d 0 p) $+$ - (text " ==>" <+> ppActions d as) $+$ + vcat (map (pPrint d 0) rps) $+$ + (text "rule" <+> pPrint d 0 s <> text (" " ++ show sd) <> text ":") $+$ + (text " when" <+> pPrint d 0 p) $+$ + (text " ==>" <+> ppActions d as) $+$ pPrint d 0 asmps $+$ pPrint d 0 wp @@ -1407,21 +1407,21 @@ instance PPrint AAssumption where text "else " <+> pPrint d p as ppActions d as = text "{" <+> sep (map ppA as) <+> text "}" - where ppA a = pPrint d 0 a <> text ";" + where ppA a = pPrint d 0 a <> text ";" -- AFCall/ATaskAction prints i instead of the string name -- to print the Bluespec function being called, not the foreign one instance PPrint AAction where pPrint d _ (ACall i m (c : es)) | isOne c = pPrint d 0 i <> text "." <> ppMethId d m <+> sep (map (pPrint d 1) es) pPrint d _ (ACall i m (c : es)) = sep [ - text "if" <+> pPrint d 0 c <+> text "then", - nest 2 (pPrint d 0 i <> text "." <> ppMethId d m <+> sep (map (pPrint d 1) es)) - ] + text "if" <+> pPrint d 0 c <+> text "then", + nest 2 (pPrint d 0 i <> text "." <> ppMethId d m <+> sep (map (pPrint d 1) es)) + ] pPrint d _ (AFCall i _ _ (c : es) _) | isOne c = pPrint d 0 i <+> sep (map (pPrint d 1) es) pPrint d _ (AFCall i _ _ (c : es) _) = sep [ - text "if" <+> pPrint d 0 c <+> text "then", - nest 2 (pPrint d 0 i <+> sep (map (pPrint d 1) es)) - ] + text "if" <+> pPrint d 0 c <+> text "then", + nest 2 (pPrint d 0 i <+> sep (map (pPrint d 1) es)) + ] pPrint d _ (ATaskAction i _ _ n (c : es) _ _ _) | isOne c = pPrint d 0 i <> text ("#" ++ itos(n)) <+> sep (map (pPrint d 1) es) pPrint d _ (ATaskAction i _ _ n (c : es) _ _ _) = sep [ text "if" <+> pPrint d 0 c <+> text "then", @@ -1467,30 +1467,30 @@ instance PPrint AExpr where pPrint d p (APrim _ _ o es@(_:_:_)) | binOp o = pparen (p>0) $ sepList (map (pPrint d 1) es) (text "" <+> pPrint d 1 o) pPrint d p (APrim _ _ PrimCase (e:dd:ces)) = - (text "case" <+> pPrint d 0 e <+> text "of") $+$ - foldr ($+$) (text "_ ->" <+> pPrint d 0 dd) (f ces) - where f [] = [] - f (x:y:xs) = (pPrint d 0 x <+> text "->" <+> pPrint d 0 y) : f xs - f x = internalError ("pPrint AExpr Aprim binOp: " ++ show x) + (text "case" <+> pPrint d 0 e <+> text "of") $+$ + foldr ($+$) (text "_ ->" <+> pPrint d 0 dd) (f ces) + where f [] = [] + f (x:y:xs) = (pPrint d 0 x <+> text "->" <+> pPrint d 0 y) : f xs + f x = internalError ("pPrint AExpr Aprim binOp: " ++ show x) pPrint d p (APrim _ _ PrimPriMux es) = pparen (p>0) $ - text "primux" <+> sep (f es) - where f [] = [] - f (x:y:xs) = pparen True (sep [pPrint d 0 x <> text ",", pPrint d 0 y]) : f xs - f x = internalError ("pPrint AExpr Aprim PriMux 1: " ++ show x) + text "primux" <+> sep (f es) + where f [] = [] + f (x:y:xs) = pparen True (sep [pPrint d 0 x <> text ",", pPrint d 0 y]) : f xs + f x = internalError ("pPrint AExpr Aprim PriMux 1: " ++ show x) pPrint d p (APrim _ _ PrimMux es) = pparen (p>0) $ - text "mux" <+> sep (f es) - where f [] = [] - f (x:y:xs) = pparen True (sep [pPrint d 0 x <> text ",", pPrint d 0 y]) : f xs - f x = internalError ("pPrint AExpr Aprim PriMux 2: " ++ show x) + text "mux" <+> sep (f es) + where f [] = [] + f (x:y:xs) = pparen True (sep [pPrint d 0 x <> text ",", pPrint d 0 y]) : f xs + f x = internalError ("pPrint AExpr Aprim PriMux 2: " ++ show x) pPrint d p (APrim _ _ o es) = pparen (p>0) $ pPrint d 1 o <+> sep (map (pPrint d 1) es) pPrint d p (ANoInlineFunCall _ i _ es) = pparen (p>0) $ pPrint d 1 i <+> sep (map (pPrint d 1) es) pPrint d p (AFunCall _ i _ _ es) = pparen (p>0) $ pPrint d 1 i <+> sep (map (pPrint d 1) es) pPrint d p (ATaskValue _ i _ _ n) = pparen (p>0) $ pPrint d 1 i <> text ("#" ++ itos(n)) pPrint d p (AMethCall _ i m es) = - pparen (p>0 && not (null es)) $ - pPrint d 1 i <> sep (text "." <> ppMethId d m : map (pPrint d 1) es) + pparen (p>0 && not (null es)) $ + pPrint d 1 i <> sep (text "." <> ppMethId d m : map (pPrint d 1) es) pPrint d p (AMethValue _ i m) = - pparen (p>0) $ pPrint d 1 i <> text "." <> ppMethId d m + pparen (p>0) $ pPrint d 1 i <> text "." <> ppMethId d m pPrint d p (ASPort _ i) = pPrint d p i pPrint d p (ASParam _ i) = pPrint d p i pPrint d p (ASDef _ i) = pPrint d p i @@ -1504,7 +1504,7 @@ instance PPrint AExpr where pPrint d p (ASReset _ r) = text "reset" <+> pPrint d p r pPrint d p (ASInout _ r) = text "inout" <+> pPrint d p r pPrint d p (AMGate _ o c) = - pPrint d 1 o <> text "." <> pPrint d 1 c <> text ".gate" + pPrint d 1 o <> text "." <> pPrint d 1 c <> text ".gate" ppMethId d@PDReadable m = ppId d (unQualId m) ppMethId d m = ppId d m @@ -1522,15 +1522,15 @@ instance PPrint AType where binOp :: PrimOp -> Bool binOp p = p `elem` - [PrimAdd, PrimSub, PrimAnd, PrimOr, PrimXor, + [PrimAdd, PrimSub, PrimAnd, PrimOr, PrimXor, PrimMul, PrimQuot, PrimRem, - PrimSL, PrimSRL, PrimSRA, - PrimEQ, PrimEQ3, - PrimULE, PrimULT, - PrimSLE, PrimSLT, - PrimBAnd, PrimBOr, + PrimSL, PrimSRL, PrimSRA, + PrimEQ, PrimEQ3, + PrimULE, PrimULT, + PrimSLE, PrimSLT, + PrimBAnd, PrimBOr, PrimConcat - ] + ] -- PRETTY PRINTING WITH DEFINITION EXPANSION -- @@ -1592,9 +1592,9 @@ ppeString ds ec = instance (PPrintExpand a) => PPrintExpand [a] where pPrintExpand _ d _ [] = text "[]" pPrintExpand m d _ xs = let (y:ys) = reverse (map (pPrintExpand m d defContext) xs) - ys' = map (<> text ",") ys - xs' = reverse (y:ys') - in text "[" <> sep xs' <> text "]" + ys' = map (<> text ",") ys + xs' = reverse (y:ys') + in text "[" <> sep xs' <> text "]" ppeAPackage :: Int -> PDetail -> APackage -> Doc ppeAPackage lim d apkg@(APackage { apkg_local_defs = ds }) = @@ -1602,34 +1602,34 @@ ppeAPackage lim d apkg@(APackage { apkg_local_defs = ds }) = ,lookupLimit = lim ,lookupLevel = 0 } in - (text "APackage" <+> ppId d (apkg_name apkg) <> + (text "APackage" <+> ppId d (apkg_name apkg) <> if apkg_is_wrapped apkg then text " -- function" else text "") $+$ (case (apkg_backend apkg) of - Nothing -> empty - Just be -> text " -- backend:" <+> pPrint d 0 be) $+$ - text "-- APackage parameters" $+$ - pPrint d 0 (apkg_size_params apkg) $+$ - text "-- APackage arguments" $+$ - foldr ($+$) empty (map (pPrint d 0) (apkg_inputs apkg)) $+$ + Nothing -> empty + Just be -> text " -- backend:" <+> pPrint d 0 be) $+$ + text "-- APackage parameters" $+$ + pPrint d 0 (apkg_size_params apkg) $+$ + text "-- APackage arguments" $+$ + foldr ($+$) empty (map (pPrint d 0) (apkg_inputs apkg)) $+$ text "-- APackage wire info" $+$ pPrint d 0 (apkg_external_wires apkg) $+$ text "-- APackage clock domains" $+$ pPrint d 0 (apkg_clock_domains apkg) $+$ text "-- APackage resets" $+$ pPrint d 0 (apkg_reset_list apkg) $+$ - text "-- AP state elements" $+$ - foldr ($+$) empty (map (ppeVI edef d) (apkg_state_instances apkg)) $+$ --- text "-- AP local definitions" $+$ --- foldr ($+$) empty (map (pPrintExpand edef d 0) (apkg_local_defs apkg)) $+$ - text "-- AP rules" $+$ - foldr ($+$) empty (map (pPrintExpand edef d defContext) (apkg_rules apkg)) $+$ - text "-- AP scheduling pragmas" $+$ - pPrint d 0 (apkg_schedule_pragmas apkg) $+$ - text "-- AP interface" $+$ - foldr ($+$) empty [(text "-- AP apkg_interface def" <+> pPrint d 0 (apkg_name apkg)) $+$ + text "-- AP state elements" $+$ + foldr ($+$) empty (map (ppeVI edef d) (apkg_state_instances apkg)) $+$ +-- text "-- AP local definitions" $+$ +-- foldr ($+$) empty (map (pPrintExpand edef d 0) (apkg_local_defs apkg)) $+$ + text "-- AP rules" $+$ + foldr ($+$) empty (map (pPrintExpand edef d defContext) (apkg_rules apkg)) $+$ + text "-- AP scheduling pragmas" $+$ + pPrint d 0 (apkg_schedule_pragmas apkg) $+$ + text "-- AP interface" $+$ + foldr ($+$) empty [(text "-- AP apkg_interface def" <+> pPrint d 0 (apkg_name apkg)) $+$ pPrintExpand edef d defContext i | i <- apkg_interface apkg] $+$ - text "-- AP instance comments" $+$ - foldr ($+$) empty (map (ppInstComment d) (apkg_inst_comments apkg)) $+$ + text "-- AP instance comments" $+$ + foldr ($+$) empty (map (ppInstComment d) (apkg_inst_comments apkg)) $+$ text "-- AP remaining proof obligations" $+$ pPrint d 0 (apkg_proof_obligations apkg) @@ -1648,18 +1648,18 @@ ppeVTI m d (vi, es, ns) = instance PPrintExpand AIFace where -- XXX print assumptions pPrintExpand m d ec (AIDef id is wp g b _ _) = - (text "--" <+> pPrint d (getP ec) g) $+$ - foldr ($+$) (pPrint d (getP ec) b) (map (ppV d) is) $+$ - text "" + (text "--" <+> pPrint d (getP ec) g) $+$ + foldr ($+$) (pPrint d (getP ec) b) (map (ppV d) is) $+$ + text "" pPrintExpand m d ec (AIAction is wp g _ rs _) = - (text "--" <+> pPrint d (getP ec) g) $+$ - foldr ($+$) (pPrintExpand m d ec rs) (map (ppV d) is) $+$ - text "" + (text "--" <+> pPrint d (getP ec) g) $+$ + foldr ($+$) (pPrintExpand m d ec rs) (map (ppV d) is) $+$ + text "" pPrintExpand m d ec (AIActionValue is wp g _ rs b _) = - (text "--" <+> pPrint d (getP ec) g) $+$ - foldr ($+$) (pPrintExpand m d ec rs) (map (ppV d) is) $+$ + (text "--" <+> pPrint d (getP ec) g) $+$ + foldr ($+$) (pPrintExpand m d ec rs) (map (ppV d) is) $+$ foldr ($+$) (pPrint d (getP ec) b) (map (ppV d) is) $+$ - text "" + text "" pPrintExpand m d ec (AIClock i c _) = pPrint d (getP ec) c pPrintExpand m d ec (AIReset i r _) = pPrint d (getP ec) r pPrintExpand m d ec (AIInout i r _) = pPrint d (getP ec) r @@ -1667,35 +1667,35 @@ instance PPrintExpand AIFace where instance PPrintExpand ARule where -- XXX print assumptions pPrintExpand m d@PDDebug _ (ARule s _ _ _ p as _ _) = - (text "rule" <+> pPrint d 0 s) + (text "rule" <+> pPrint d 0 s) pPrintExpand m d _ (ARule s rps sd wp p as _ _) = - vcat (map (pPrint d 0) rps) $+$ - (text "rule" <+> pPrint d 0 s <> text (" " ++ show sd) <> text ":") $+$ - (text " when" <+> pPrintExpand m d bContext p) $+$ - (text " ==>" <+> ppeActions m d as) + vcat (map (pPrint d 0) rps) $+$ + (text "rule" <+> pPrint d 0 s <> text (" " ++ show sd) <> text ":") $+$ + (text " when" <+> pPrintExpand m d bContext p) $+$ + (text " ==>" <+> ppeActions m d as) ppeActions m d as = text "{" <+> sep (map ppeA as) <+> text "}" - where ppeA a = pPrintExpand m d defContext a <> text ";" + where ppeA a = pPrintExpand m d defContext a <> text ";" instance PPrintExpand AAction where pPrintExpand m d _ (ACall i meth (c : es)) | isOne c = - pPrint d 0 i <> text "." <> ppMethId d meth <+> sep (map (pPrintExpand m d pContext) es) + pPrint d 0 i <> text "." <> ppMethId d meth <+> sep (map (pPrintExpand m d pContext) es) pPrintExpand m d _ (ACall i meth (c : es)) = sep [ - text "if" <+> pPrintExpand m d bContext c <+> text "then", - nest 2 (pPrint d 0 i <> text "." <> ppMethId d meth <+> sep (map (pPrintExpand m d pContext) es)) - ] + text "if" <+> pPrintExpand m d bContext c <+> text "then", + nest 2 (pPrint d 0 i <> text "." <> ppMethId d meth <+> sep (map (pPrintExpand m d pContext) es)) + ] pPrintExpand m d _ (AFCall i _ _ (c : es) _) | isOne c = pPrint d 0 i <+> sep (map (pPrintExpand m d pContext) es) pPrintExpand m d _ (AFCall i _ _ (c : es) _) = sep [ - text "if" <+> pPrintExpand m d bContext c <+> text "then", - nest 2 (pPrint d 0 i <+> sep (map (pPrintExpand m d pContext) es)) + text "if" <+> pPrintExpand m d bContext c <+> text "then", + nest 2 (pPrint d 0 i <+> sep (map (pPrintExpand m d pContext) es)) - ] + ] pPrintExpand m d _ (ATaskAction i _ _ n (c : es) _ _ _) | isOne c = pPrint d 0 i <> text ("#" ++ itos(n)) <+> sep (map (pPrintExpand m d pContext) es) pPrintExpand m d _ (ATaskAction i _ _ n (c : es) _ _ _) = sep [ - text "if" <+> pPrintExpand m d defContext c <+> text "then", - nest 2 (pPrint d 0 i <> text ("#" ++ itos(n)) <+> sep (map (pPrintExpand m d pContext) es)) + text "if" <+> pPrintExpand m d defContext c <+> text "then", + nest 2 (pPrint d 0 i <> text ("#" ++ itos(n)) <+> sep (map (pPrintExpand m d pContext) es)) - ] + ] pPrintExpand _ _ _ x = internalError ("pPrintExpand AAction: " ++ show x) @@ -1726,28 +1726,28 @@ instance PPrintExpand AExpr where p = useParen ec pPrintExpand m d ec (APrim _ _ PrimCase (e:dd:ces)) = - (text "case" <+> pPrintExpand m d ec' e <+> text "of") $+$ - foldr ($+$) (text "_ ->" <+> pPrintExpand m d ec' dd) (f ces) - where ec' = defContext + (text "case" <+> pPrintExpand m d ec' e <+> text "of") $+$ + foldr ($+$) (text "_ ->" <+> pPrintExpand m d ec' dd) (f ces) + where ec' = defContext f [] = [] - f (x:y:xs) = (pPrintExpand m d ec' x <+> text "->" <+> pPrintExpand m d ec' y) : f xs - f x = internalError ("pPrintExpand APrim _ PrimCase: " ++ show x) + f (x:y:xs) = (pPrintExpand m d ec' x <+> text "->" <+> pPrintExpand m d ec' y) : f xs + f x = internalError ("pPrintExpand APrim _ PrimCase: " ++ show x) pPrintExpand m d ec (APrim _ _ PrimPriMux es) = pparen (p) $ - text "primux" <+> sep (f es) - where p = useParen ec + text "primux" <+> sep (f es) + where p = useParen ec ec' = defContext { literal= literal ec} ecb = defContext { literal=Boolean } f [] = [] - f (x:y:xs) = parens (sep [pPrintExpand m d ecb x <> comma, pPrintExpand m d ec' y]) : f xs - f x = internalError ("pPrintExpand APrim _ PrimPriMux: " ++ show x) + f (x:y:xs) = parens (sep [pPrintExpand m d ecb x <> comma, pPrintExpand m d ec' y]) : f xs + f x = internalError ("pPrintExpand APrim _ PrimPriMux: " ++ show x) pPrintExpand m d ec (APrim _ _ PrimMux es) = pparen (p) $ - text "mux" <+> sep (f es) - where p = useParen ec + text "mux" <+> sep (f es) + where p = useParen ec ec' = defContext { literal= literal ec} ecb = defContext { literal=Boolean } f [] = [] - f (x:y:xs) = parens (sep [pPrintExpand m d ecb x <> comma , pPrintExpand m d ec' y]) : f xs - f x = internalError ("pPrintExpand APrim: " ++ show x) + f (x:y:xs) = parens (sep [pPrintExpand m d ecb x <> comma , pPrintExpand m d ec' y]) : f xs + f x = internalError ("pPrintExpand APrim: " ++ show x) pPrintExpand m d ec (APrim _ _ PrimExtract (var:hi:lo:[])) = pPrintExpand m d pContext var <> lbrack <> (if ( dhi == dlo ) @@ -1825,13 +1825,13 @@ data MethodPart = -- and infinite number of ports (like a register) mkMethId :: Id -> Id -> Maybe Integer -> MethodPart -> Id mkMethId o m ino mp = - -- trace ("POS O: " ++ (show (getIdPosition o)) ++ " " ++ + -- trace ("POS O: " ++ (show (getIdPosition o)) ++ " " ++ -- "POS M: " ++ (show (getIdPosition m))) $ - addIdProps - (mkId (getIdPosition o) idstring) - (IdPMeth : (enprops ++ getIdProps o)) - where - idstring = (mkMethStr o m ino mp) + addIdProps + (mkId (getIdPosition o) idstring) + (IdPMeth : (enprops ++ getIdProps o)) + where + idstring = (mkMethStr o m ino mp) enprops = if mp == MethodEnable then [IdP_enable] else [] isMethId :: Id -> Bool @@ -1846,21 +1846,21 @@ mkMethStr obj m m_port mp = [meth_base, fsUnderscore, mkNumFString port] - base = case mp of - MethodArg n -> - if (n == 0) - then internalError "mkMethStr" - else concatFString [meth_port, - fsUnderscore, - mkNumFString n] - MethodResult -> meth_port - MethodEnable -> - -- XXX are we overloading fsEnable? - concatFString [fsEnable, meth_port] - inst = getIdFString obj + base = case mp of + MethodArg n -> + if (n == 0) + then internalError "mkMethStr" + else concatFString [meth_port, + fsUnderscore, + mkNumFString n] + MethodResult -> meth_port + MethodEnable -> + -- XXX are we overloading fsEnable? + concatFString [fsEnable, meth_port] + inst = getIdFString obj in concatFString [inst, - fsDollar, - base] + fsDollar, + base] -- ############################################################################# -- # diff --git a/src/comp/ASyntaxUtil.hs b/src/comp/ASyntaxUtil.hs index c4aa1e2ac..9449beb2d 100644 --- a/src/comp/ASyntaxUtil.hs +++ b/src/comp/ASyntaxUtil.hs @@ -84,7 +84,7 @@ instance AVars AAction where instance AVars AForeignCall where aVars afc = concatMap aVars (afc_args afc) - ++ concatMap aVars (afc_resets afc) + ++ concatMap aVars (afc_resets afc) instance AVars AIFace where aVars (AIDef _ _ _ p d _ asmps) = aVars p ++ aVars d ++ aVars asmps @@ -225,13 +225,13 @@ class ATypeC a where instance ATypeC AType where aSize e = - case aType e of - ATBit s -> s + case aType e of + ATBit s -> s ATString (Just s) -> 8*s -- 8 bits per character - ATAbstract i [n] | i==idInout_ -> n + ATAbstract i [n] | i==idInout_ -> n ATArray sz t -> sz * (aSize t) - ATReal -> 64 - t -> internalError ("aSize: " ++ (ppReadable t)) + ATReal -> 64 + t -> internalError ("aSize: " ++ (ppReadable t)) aType t = t instance ATypeC AExpr where @@ -279,7 +279,7 @@ instance AExprs AAction where mapAExprs f (AFCall id fun isC es isA) = (AFCall id fun isC (mapAExprs f es) isA) mapAExprs f (ATaskAction id fun isC n es tid tty isA) = - (ATaskAction id fun isC n (mapAExprs f es) tid tty isA) + (ATaskAction id fun isC n (mapAExprs f es) tid tty isA) -- monadic mapMAExprs f (ACall id mid es) = do es' <- mapMAExprs f es @@ -288,8 +288,8 @@ instance AExprs AAction where do es' <- mapMAExprs f es return (AFCall id fun isC es' isA) mapMAExprs f (ATaskAction id fun isC n es tid tty isA) = - do es' <- mapMAExprs f es - return (ATaskAction id fun isC n es' tid tty isA) + do es' <- mapMAExprs f es + return (ATaskAction id fun isC n es' tid tty isA) -- find findAExprs f (ACall id mid es) = findAExprs f es findAExprs f (AFCall id fun isC es isA) = findAExprs f es @@ -306,25 +306,25 @@ instance AExprs ADef where instance AExprs AForeignCall where -- XXX resets? mapAExprs f (AForeignCall id fun es ids resets) = - (AForeignCall id fun (mapAExprs f es) ids (mapAExprs f resets)) + (AForeignCall id fun (mapAExprs f es) ids (mapAExprs f resets)) -- monadic mapMAExprs f (AForeignCall id fun es ids resets) = - do es' <- mapMAExprs f es - resets' <- mapMAExprs f resets - return (AForeignCall id fun es' ids resets') + do es' <- mapMAExprs f es + resets' <- mapMAExprs f resets + return (AForeignCall id fun es' ids resets') -- find findAExprs f (AForeignCall _ _ es _ resets) = findAExprs f es ++ findAExprs f resets instance AExprs ARule where mapAExprs f (ARule rid rps d wp p as asmps splitorig) = - ARule rid rps d wp (mapAExprs f p) (mapAExprs f as) (mapAExprs f asmps) splitorig + ARule rid rps d wp (mapAExprs f p) (mapAExprs f as) (mapAExprs f asmps) splitorig -- monadic mapMAExprs f (ARule rid rps d wp p as asmps splitorig) = - do p' <- mapMAExprs f p - as' <- mapMAExprs f as + do p' <- mapMAExprs f p + as' <- mapMAExprs f as asmps' <- mapMAExprs f asmps - return (ARule rid rps d wp p' as' asmps' splitorig) + return (ARule rid rps d wp p' as' asmps' splitorig) -- find findAExprs f (ARule _ _ _ _ p as asmps _) = findAExprs f p ++ findAExprs f as ++ findAExprs f asmps @@ -338,29 +338,29 @@ instance AExprs AAssumption where instance AExprs AIFace where mapAExprs f (AIDef mid is wp p def fi asmps) = - AIDef mid is wp (mapAExprs f p) (mapAExprs f def) fi (mapAExprs f asmps) + AIDef mid is wp (mapAExprs f p) (mapAExprs f def) fi (mapAExprs f asmps) mapAExprs f (AIAction is wp p id rs fi) = - AIAction is wp (mapAExprs f p) id (mapAExprs f rs) fi + AIAction is wp (mapAExprs f p) id (mapAExprs f rs) fi mapAExprs f (AIActionValue is wp p id rs def fi) = - AIActionValue is wp (mapAExprs f p) id (mapAExprs f rs) (mapAExprs f def) fi + AIActionValue is wp (mapAExprs f p) id (mapAExprs f rs) (mapAExprs f def) fi mapAExprs f c@(AIClock { }) = c mapAExprs f r@(AIReset { }) = r mapAExprs f r@(AIInout { }) = r -- monadic mapMAExprs f (AIDef mid is wp p def fi asmps) = - do p' <- mapMAExprs f p - def' <- mapMAExprs f def + do p' <- mapMAExprs f p + def' <- mapMAExprs f def asmps' <- mapMAExprs f asmps - return (AIDef mid is wp p' def' fi asmps') + return (AIDef mid is wp p' def' fi asmps') mapMAExprs f (AIAction is wp p id rs fi) = - do p' <- mapMAExprs f p - rs' <- mapMAExprs f rs - return (AIAction is wp p' id rs' fi) + do p' <- mapMAExprs f p + rs' <- mapMAExprs f rs + return (AIAction is wp p' id rs' fi) mapMAExprs f (AIActionValue is wp p id rs def fi) = - do p' <- mapMAExprs f p - rs' <- mapMAExprs f rs - def' <- mapMAExprs f def - return (AIActionValue is wp p' id rs' def' fi) + do p' <- mapMAExprs f p + rs' <- mapMAExprs f rs + def' <- mapMAExprs f def + return (AIActionValue is wp p' id rs' def' fi) mapMAExprs f c@(AIClock { }) = return c mapMAExprs f r@(AIReset { }) = return r mapMAExprs f r@(AIInout { }) = return r @@ -387,51 +387,51 @@ instance AExprs ASPackage where mapAExprs f pkg@(ASPackage { aspkg_state_instances = vs, aspkg_values = defs, aspkg_inout_values = iodefs, - aspkg_foreign_calls = fs }) + aspkg_foreign_calls = fs }) = pkg { aspkg_state_instances = (mapAExprs f vs), - aspkg_values = (mapAExprs f defs), - aspkg_inout_values = (mapAExprs f iodefs), - aspkg_foreign_calls = (mapAExprs f fs) } + aspkg_values = (mapAExprs f defs), + aspkg_inout_values = (mapAExprs f iodefs), + aspkg_foreign_calls = (mapAExprs f fs) } -- monadic mapMAExprs f pkg@(ASPackage { aspkg_state_instances = vs, aspkg_values = defs, aspkg_inout_values = iodefs, - aspkg_foreign_calls = fs }) + aspkg_foreign_calls = fs }) = do vs' <- mapMAExprs f vs - defs' <- mapMAExprs f defs - iodefs' <- mapMAExprs f iodefs - fs' <- mapMAExprs f fs - return (pkg { aspkg_state_instances = vs', - aspkg_values = defs', - aspkg_inout_values = iodefs', - aspkg_foreign_calls = fs' }) + defs' <- mapMAExprs f defs + iodefs' <- mapMAExprs f iodefs + fs' <- mapMAExprs f fs + return (pkg { aspkg_state_instances = vs', + aspkg_values = defs', + aspkg_inout_values = iodefs', + aspkg_foreign_calls = fs' }) -- find findAExprs f pkg@(ASPackage { aspkg_state_instances = vs, aspkg_values = defs, aspkg_inout_values = iodefs, - aspkg_foreign_calls = fs }) + aspkg_foreign_calls = fs }) = findAExprs f vs ++ findAExprs f defs ++ findAExprs f iodefs ++ findAExprs f fs instance AExprs APackage where mapAExprs f pack = pack { - apkg_interface = mapAExprs f (apkg_interface pack), - apkg_rules = mapAExprs f (apkg_rules pack), - apkg_state_instances = mapAExprs f (apkg_state_instances pack), - apkg_local_defs = mapAExprs f (apkg_local_defs pack) } + apkg_interface = mapAExprs f (apkg_interface pack), + apkg_rules = mapAExprs f (apkg_rules pack), + apkg_state_instances = mapAExprs f (apkg_state_instances pack), + apkg_local_defs = mapAExprs f (apkg_local_defs pack) } -- monadic mapMAExprs f pack@(APackage { apkg_interface = ifc, - apkg_rules = rs, - apkg_state_instances = insts, - apkg_local_defs = defs }) + apkg_rules = rs, + apkg_state_instances = insts, + apkg_local_defs = defs }) = do ifc' <- mapMAExprs f ifc - rs' <- mapMAExprs f rs - insts' <- mapMAExprs f insts - defs' <- mapMAExprs f defs - return (pack { apkg_interface = ifc', - apkg_rules = rs', - apkg_state_instances = insts', - apkg_local_defs = defs' }) + rs' <- mapMAExprs f rs + insts' <- mapMAExprs f insts + defs' <- mapMAExprs f defs + return (pack { apkg_interface = ifc', + apkg_rules = rs', + apkg_state_instances = insts', + apkg_local_defs = defs' }) -- find findAExprs f pack = findAExprs f (apkg_interface pack) ++ @@ -450,15 +450,15 @@ type EMap a = M.Map AId a aSubst :: (AExprs a) => EMap AExpr -> a -> a aSubst m = mapAExprs xsub where xsub :: AExpr -> AExpr - xsub x@(ASPort _ i) = - case M.lookup i m of + xsub x@(ASPort _ i) = + case M.lookup i m of Just e -> e Nothing -> x - xsub x@(ASParam _ i) = + xsub x@(ASParam _ i) = case M.lookup i m of Just e -> e Nothing -> x - xsub x@(ASDef _ i) = + xsub x@(ASDef _ i) = case M.lookup i m of Just e -> e Nothing -> x @@ -575,8 +575,8 @@ instance AActions AIFace where instance AActions APackage where mapAActions f pack = pack { - apkg_interface = mapAActions f (apkg_interface pack), - apkg_rules = mapAActions f (apkg_rules pack) + apkg_interface = mapAActions f (apkg_interface pack), + apkg_rules = mapAActions f (apkg_rules pack) } @@ -605,8 +605,8 @@ instance ARules AIFace where instance ARules APackage where mapARules f pack = pack { - apkg_interface = mapARules f (apkg_interface pack), - apkg_rules = mapARules f (apkg_rules pack) + apkg_interface = mapARules f (apkg_interface pack), + apkg_rules = mapARules f (apkg_rules pack) } @@ -657,22 +657,22 @@ tsortADefs ds = -- ds_ids are the AIds from the input ADefs -- s is a OrdSet of AId from the input ADefs let - ds_ids = (map adef_objid ds) - s = S.fromList ds_ids + ds_ids = (map adef_objid ds) + s = S.fromList ds_ids -- g is a list of (AId, [AIds used by that ADef which are in 's' -- drop all other AIds (mostly AVars) --- g = [(i, filter (`S.member` s) (aVars e)) | ADef i _ e <- ds ] - g = zip ds_ids (map ((filter (`S.member` s)) . aVars . adef_expr) ds) +-- g = [(i, filter (`S.member` s) (aVars e)) | ADef i _ e <- ds ] + g = zip ds_ids (map ((filter (`S.member` s)) . aVars . adef_expr) ds) -- tsort returns Left if there is a loop, Right if sorted in case tsort g of - Left is -> internalError ("tsortADefs: cyclic " ++ ppReadable is ++ ppReadable ds) - Right is -> --trace ("tsortADefs exit " ++ show (length is)) $ + Left is -> internalError ("tsortADefs: cyclic " ++ ppReadable is ++ ppReadable ds) + Right is -> --trace ("tsortADefs exit " ++ show (length is)) $ -- m is OrdMap of (AId of ADef, ADef) from input ADefs - let m = M.fromList (zip ds_ids ds) + let m = M.fromList (zip ds_ids ds) -- get i is OrdMap lookup giving ADef in m from AId - get i = case M.lookup i m of Just d -> d; Nothing -> internalError "tsortADefs: get" + get i = case M.lookup i m of Just d -> d; Nothing -> internalError "tsortADefs: get" -- return ADefs in tsort-ed order removing AIds. - in map get is + in map get is -- --------------- @@ -716,8 +716,8 @@ aAndsLabel _ [] = internalError "ASyntaxUtil::aAnds null list" aAndsLabel _ [e] = e aAndsLabel aid es = if any isFalse es then aFalse else aAnds' (nub (filter (not . isTrue) es)) where aAnds' [] = aTrue - aAnds' [e] = e - aAnds' es = APrim aid aTBool PrimBAnd es + aAnds' [e] = e + aAnds' es = APrim aid aTBool PrimBAnd es aOrLabel :: AId -> AExpr -> AExpr -> AExpr @@ -740,5 +740,5 @@ aOrsLabel _ [] = internalError "ASyntaxUtil::aOrs null list" aOrsLabel _ [e] = e aOrsLabel aid es = if any isTrue es then aTrue else aOrs' (nub (filter (not . isFalse) es)) where aOrs' [] = aFalse - aOrs' [e] = e - aOrs' es = APrim aid aTBool PrimBOr es + aOrs' [e] = e + aOrs' es = APrim aid aTBool PrimBOr es diff --git a/src/comp/AUses.hs b/src/comp/AUses.hs index 87ac95ee6..28ec04d71 100644 --- a/src/comp/AUses.hs +++ b/src/comp/AUses.hs @@ -47,7 +47,7 @@ module AUses( MethodUsesList, getUUPos, hasSideEffects, extractCondition, differentArgs, useDropCond, - MethodUsers, -- requires RuleId + MethodUsers, -- requires RuleId RuleId, -- create the ruleUsesMap and methodUsesMap together @@ -55,7 +55,7 @@ module AUses( -- used by ASchedule and AAddSchedAssumps RuleUsesMap, - RuleUses(..), + RuleUses(..), Rule(..), ruleName, rulePred, ruleAncestor, rumToObjectMap, rumToMethodUseMap, rumGetMethodIds, rumRuleUsesFF, @@ -88,16 +88,16 @@ import Control.Monad.State.Strict -- RULE: internal rule/interface method rep for scheduler -- type RuleId = ARuleId data Rule = Rule RuleId (Maybe RuleId) [APred] [AExpr] [AAction] - -- name, source if split, predicates, non-predicate reads, writes + -- name, source if split, predicates, non-predicate reads, writes instance Eq Rule where (Rule rId _ _ _ _) == (Rule rId' _ _ _ _) = rId == rId' -- we can assume unique ids instance PPrint Rule where pPrint d i (Rule rId _ rPred rReads rWrites) = - sep $ map sep - [[text "rule:", pPrint d i rId], [text "pred:", pPrint d i rPred], - [text "reads:", pPrint d i rReads], [text "writes:", pPrint d i rWrites]] + sep $ map sep + [[text "rule:", pPrint d i rId], [text "pred:", pPrint d i rPred], + [text "reads:", pPrint d i rReads], [text "writes:", pPrint d i rWrites]] ruleName :: Rule -> RuleId ruleName (Rule rId _ _ _ _) = rId @@ -383,19 +383,19 @@ data RuleUses = RuleUses ExprUses ExprUses ActionUses instance PPrint RuleUses where pPrint d i (RuleUses pus rus wus) = let pmus = toListMethodExprUses $ getMethodExprUses pus - rmus = toListMethodExprUses $ getMethodExprUses rus - wmus = toListMethodActionUses $ getMethodActionUses wus - pfus = toListFFExprUses $ getFFuncExprUses pus - rfus = toListFFExprUses $ getFFuncExprUses rus - wfus = toListFFActionUses $ getFFuncActionUses wus + rmus = toListMethodExprUses $ getMethodExprUses rus + wmus = toListMethodActionUses $ getMethodActionUses wus + pfus = toListFFExprUses $ getFFuncExprUses pus + rfus = toListFFExprUses $ getFFuncExprUses rus + wfus = toListFFActionUses $ getFFuncActionUses wus in sep [ - sep [text "predicate reads (methods):", pPrint d i pmus], - sep [text "action reads (methods):", pPrint d i rmus], - sep [text "action writes (methods):", pPrint d i wmus], - sep [text "predicate reads (funcs):", pPrint d i pfus], - sep [text "action reads: (funcs)", pPrint d i rfus], - sep [text "action writes: (funcs)", pPrint d i wfus] - ] + sep [text "predicate reads (methods):", pPrint d i pmus], + sep [text "action reads (methods):", pPrint d i rmus], + sep [text "action writes (methods):", pPrint d i wmus], + sep [text "predicate reads (funcs):", pPrint d i pfus], + sep [text "action reads: (funcs)", pPrint d i rfus], + sep [text "action writes: (funcs)", pPrint d i wfus] + ] instance Show RuleUses where show ruses = ppReadable ruses @@ -425,8 +425,8 @@ type RuleUsesMap = M.Map RuleId (AExpr, RuleUses) -- XXX A more abstract entry point might be good? rumGetActionUses :: RuleUsesMap -> ARuleId -> ActionUses rumGetActionUses m r = case M.lookup r m of - Just (_, RuleUses _ _ range) -> range - _ -> errNotInUseMap r + Just (_, RuleUses _ _ range) -> range + _ -> errNotInUseMap r -- The following are intended as more abstract entry points for ASchedule: @@ -435,7 +435,7 @@ rumRuleUsesFF :: RuleUsesMap -> ARuleId -> Bool rumRuleUsesFF m r = case M.lookup r m of Just (_, RuleUses preds domain range) -> - let eUsesFF = not . M.null . getFFuncExprUses + let eUsesFF = not . M.null . getFFuncExprUses aUsesFF = not . M.null . getFFuncActionUses in eUsesFF preds || eUsesFF domain || aUsesFF range _ -> errNotInUseMap r @@ -445,7 +445,7 @@ rumRuleUsesFF m r = rumToObjectMap :: RuleUsesMap -> M.Map ARuleId (S.Set Id) rumToObjectMap m = let usesToObjIds (_, RuleUses preds domain range) = - let eObjIds = M.keysSet . getMethodExprUses + let eObjIds = M.keysSet . getMethodExprUses aObjIds = M.keysSet . getMethodActionUses in S.unions [eObjIds preds, eObjIds domain, aObjIds range] in M.map usesToObjIds m @@ -456,7 +456,7 @@ rumToMethodUseMap :: RuleUsesMap -> M.Map ARuleId (AExpr, M.Map Id (M.Map Id [UniqueUse])) rumToMethodUseMap m = let usesToMethMap (pred, RuleUses preds domain range) = - let toE (e, c) = UUExpr e c + let toE (e, c) = UUExpr e c toA a = UUAction a convE = M.map (M.map (map toE . M.toList)) . getMethodExprUses convA = M.map (M.map (map toA)) . getMethodActionUses @@ -469,7 +469,7 @@ rumGetMethodIdMap :: RuleUsesMap -> ARuleId -> M.Map Id (S.Set Id) rumGetMethodIdMap m r = case M.lookup r m of Just (_, RuleUses preds domain range) -> - let convE us = M.map (M.keysSet) (getMethodExprUses us) + let convE us = M.map (M.keysSet) (getMethodExprUses us) convA us = M.map (M.keysSet) (getMethodActionUses us) in M.unionsWith (S.union) [convE preds, convE domain, convA range] _ -> errNotInUseMap r @@ -958,17 +958,17 @@ invertRuleUsesMap :: RuleUsesMap -> MethodUsesMap invertRuleUsesMap rMap = foldr (uncurry (M.insertWith mergeUseMapData)) M.empty $ [cvt rId uses | (rId, (_, RuleUses pUses rUses wUses)) <- M.toList rMap, - let pMUses = getMethodUUExprs pUses, - let rMUses = getMethodUUExprs rUses, - let wMUses = getMethodUUActions wUses, - uses <- map Left pMUses ++ map Right (wMUses ++ rMUses)] + let pMUses = getMethodUUExprs pUses, + let rMUses = getMethodUUExprs rUses, + let wMUses = getMethodUUActions wUses, + uses <- map Left pMUses ++ map Right (wMUses ++ rMUses)] where - -- convert a Left/Right use into the proper triple form, for merging - -- (Left for predicate uses, Right for action reads/writes) - cvt rId (Left (mId, us)) = - (mId, [(uUse, ([rId], [], [])) | uUse <- us]) - cvt rId (Right (mId, us)) = - (mId, [(uUse, ([], [rId], [])) | uUse <- us]) + -- convert a Left/Right use into the proper triple form, for merging + -- (Left for predicate uses, Right for action reads/writes) + cvt rId (Left (mId, us)) = + (mId, [(uUse, ([rId], [], [])) | uUse <- us]) + cvt rId (Right (mId, us)) = + (mId, [(uUse, ([], [rId], [])) | uUse <- us]) -- create a mapping from an instance Id to the list of method call uses -- in the instantiation of that submodule diff --git a/src/comp/AVeriQuirks.hs b/src/comp/AVeriQuirks.hs index 4246c8ed9..cfbbfa1d1 100644 --- a/src/comp/AVeriQuirks.hs +++ b/src/comp/AVeriQuirks.hs @@ -80,8 +80,8 @@ genIdFromAExpr expr = do oldId <- gets uniqueId put state{ uniqueId = oldId + 1 } return $ mkId - noPosition -- XXX aexpr should have an instance of HasPosition - (mkFString (signalNameFromAExpr expr ++ + noPosition -- XXX aexpr should have an instance of HasPosition + (mkFString (signalNameFromAExpr expr ++ aVeriQuirksPref ++ itos oldId)) -- Add the expression -- realy the definition to the monad @@ -89,41 +89,41 @@ addExpr :: AType -> AExpr -> QQState AId addExpr t e = do rlm <- gets rlookup case ( M.lookup (e,t) rlm ) of - Nothing -> - do - nid <- genIdFromAExpr e + Nothing -> + do + nid <- genIdFromAExpr e addDef (ADef nid t e []) return nid - -- don't create a new id for an expression that already has an id - Just fid -> return fid + -- don't create a new id for an expression that already has an id + Just fid -> return fid -- Top Level operations -- Deal with various quirks in the Verilog syntax & semantics. aVeriQuirks :: Flags -> ASPackage -> ASPackage aVeriQuirks flags pkg = - evalState action initState + evalState action initState where - initState = - QState { - qs_keepAddSize = keepAddSize flags, - qs_rmPrimModules = removePrimModules flags, - qs_useNegate = useNegate flags, - qs_readableMux = readableMux flags, - uniqueId = 1, - defs = [], + initState = + QState { + qs_keepAddSize = keepAddSize flags, + qs_rmPrimModules = removePrimModules flags, + qs_useNegate = useNegate flags, + qs_readableMux = readableMux flags, + uniqueId = 1, + defs = [], rlookup = M.empty } - action = - do - mapM_ aQDef (aspkg_values pkg) + action = + do + mapM_ aQDef (aspkg_values pkg) is' <- mapM aQInst (aspkg_state_instances pkg) - fs' <- mapM aQForeignBlock (aspkg_foreign_calls pkg) - ds' <- gets defs - return (pkg { aspkg_values = (reverse ds'), + fs' <- mapM aQForeignBlock (aspkg_foreign_calls pkg) + ds' <- gets defs + return (pkg { aspkg_values = (reverse ds'), aspkg_state_instances = is', - aspkg_foreign_calls = fs' }) + aspkg_foreign_calls = fs' }) aQDef :: ADef -> QQState () @@ -175,9 +175,9 @@ aQForeignCallAV x = return x aQExp :: Bool -> AExpr -> QQState AExpr -- non-constant bit extraction turns into shift and mask aQExp top (APrim aid t@(ATBit n) PrimExtract [e, h, l]) - | h /= l && not (isConst h && isConst l) = + | h /= l && not (isConst h && isConst l) = let te@(ATBit m) = aType e - ht = aType h + ht = aType h -- (e & ~(('1 << 1) << h)) e1 = APrim aid te PrimAnd [e, mask] mask = APrim aid te PrimInv [(APrim aid te PrimSL [maskbase, h])] @@ -185,7 +185,7 @@ aQExp top (APrim aid t@(ATBit n) PrimExtract [e, h, l]) -- e1 >> l e2 = APrim aid te PrimSRL [e1, l] -- extend/truncate e2 - e3 = case (compare m n) of + e3 = case (compare m n) of GT -> APrim aid t PrimExtract [e2, aSInt ht (n-1), aSInt ht 0] LT -> APrim aid t PrimZeroExt [e2] EQ -> e2 @@ -210,13 +210,13 @@ aQExp top eee@(APrim aid t@(ATBit n) PrimSRA [e1, ASInt _ _ (IntLit _ _ k)]) = -- arithmetic right shift replicates MSB Need do some shifting and masking aQExp top (APrim aid t@(ATBit n) PrimSRA [e1,e2]) = do - let sl = APrim aid (ATBit n) PrimSRL [e1, e2] + let sl = APrim aid (ATBit n) PrimSRL [e1, e2] mask = ASInt aid (ATBit n) (ilHex (2^n - 1)) maskshift = APrim aid (ATBit n) PrimInv [(APrim aid (ATBit n) PrimSRL [mask, e2])] msb = APrim aid (ATBit 1) PrimExtract [e1, aSNat (n-1), aSNat (n-1)] msbs = APrim aid (ATBit n) PrimSignExt [msb] - msbmask = APrim aid (ATBit n) PrimAnd [maskshift, msbs] - sel = APrim aid t PrimOr [sl, msbmask] + msbmask = APrim aid (ATBit n) PrimAnd [maskshift, msbs] + sel = APrim aid t PrimOr [sl, msbmask] aQExp top sel -- PrimExtract needs first argument in a variable @@ -271,13 +271,13 @@ aQExp top (APrim aid t p es) | p == PrimAdd || p == PrimSub = do es' <- mapM (aQExp False) es keepAddSize <- gets qs_keepAddSize let es'' = if keepAddSize then - let dropzext (APrim aid _ PrimZeroExt [e]) = e - dropzext (APrim aid _ PrimConcat [ASInt _ _ (IntLit _ _ 0), e]) = e - dropzext e = e - in --(if (map dropzext es' /= es') then trace (ppReadable es') else id) $ - map dropzext es' - else - es' + let dropzext (APrim aid _ PrimZeroExt [e]) = e + dropzext (APrim aid _ PrimConcat [ASInt _ _ (IntLit _ _ 0), e]) = e + dropzext e = e + in --(if (map dropzext es' /= es') then trace (ppReadable es') else id) $ + map dropzext es' + else + es' return (APrim aid t p es'') -- All multipliers should already be assigned directly to a @@ -298,7 +298,7 @@ aQExp top x@(APrim aid t p es) | p == PrimMux || p == PrimPriMux = do rmPrimModules <- gets qs_rmPrimModules readableMux <- gets qs_readableMux case ( rmPrimModules, readableMux ) of - (True, False) -> aQMux aid t p es' -- build AndOr Muxes + (True, False) -> aQMux aid t p es' -- build AndOr Muxes (_, _ ) -> return (APrim aid t p es') aQExp top (APrim aid t p es) = mapM (aQExp False) es >>= return . APrim aid t p @@ -335,18 +335,18 @@ aQMux aid t@(ATBit n) p as = do let (ps, es) = if ( isASAny $ last as) then unzip (makePairs $ init as) else unzip (makePairs as) - priEnc = map pri . tail . reverse . tails . reverse + priEnc = map pri . tail . reverse . tails . reverse -- pri :: [AExpr] -> AExpr - pri [x] = x - pri (x:xs) = APrim aid aTBool PrimBAnd (x : map aNot xs) + pri [x] = x + pri (x:xs) = APrim aid aTBool PrimBAnd (x : map aNot xs) pri [] = internalError ("AVerilog::aQMux::pri") -- - -- bnot x = APrim aid aTBool PrimBNot [x] + -- bnot x = APrim aid aTBool PrimBNot [x] ps' <- mapM mkDefS ps ps'' <- if p == PrimMux then return ps' else {- mapM mkDefS -} return (priEnc ps') - let sext e = if n == 1 then e else APrim aid t PrimSignExt [e] - e = aBitOr aid t [ aBitAnd aid t [sext p, e] | (p, e) <- zip ps'' es ] + let sext e = if n == 1 then e else APrim aid t PrimSignExt [e] + e = aBitOr aid t [ aBitAnd aid t [sext p, e] | (p, e) <- zip ps'' es ] return e aQMux _ _ _ _ = internalError ("AVerilog::aQMux") @@ -354,33 +354,33 @@ aQMux _ _ _ _ = internalError ("AVerilog::aQMux") aBitOr :: AId -> AType -> [AExpr] -> AExpr aBitOr aid t@(ATBit n) es = let (cs, xs) = partition isConst es - one = 2^n-1 - c = foldr integerOr 0 (map (getConst one) cs) - aOr' [] = aInt t 0 - aOr' [e] = e - aOr' es = APrim aid t PrimOr es + one = 2^n-1 + c = foldr integerOr 0 (map (getConst one) cs) + aOr' [] = aInt t 0 + aOr' [e] = e + aOr' es = APrim aid t PrimOr es in if c == one then - aInt t one - else if c == 0 then - aOr' xs - else - aOr' (xs ++ [aSInt t c]) + aInt t one + else if c == 0 then + aOr' xs + else + aOr' (xs ++ [aSInt t c]) aBitOr _ _ _ = internalError ("AVerilog::aOr") aBitAnd :: AId -> AType -> [AExpr] -> AExpr aBitAnd aid t@(ATBit n) es = let (cs, xs) = partition isConst es - one = 2^n-1 - c = foldr integerAnd one (map (getConst 0) cs) - aAnd' [] = aInt t one - aAnd' [e] = e - aAnd' es = APrim aid t PrimAnd es + one = 2^n-1 + c = foldr integerAnd one (map (getConst 0) cs) + aAnd' [] = aInt t one + aAnd' [e] = e + aAnd' es = APrim aid t PrimAnd es in if c == 0 then - aInt t 0 - else if c == one then - aAnd' xs - else - aAnd' (xs ++ [aSInt t c]) + aInt t 0 + else if c == one then + aAnd' xs + else + aAnd' (xs ++ [aSInt t c]) aBitAnd _ _ _ = internalError ("AVerilog::aAnd") aInt t i = aSInt t i diff --git a/src/comp/AVerilog.hs b/src/comp/AVerilog.hs index e1e4ace70..abf4b8162 100644 --- a/src/comp/AVerilog.hs +++ b/src/comp/AVerilog.hs @@ -318,7 +318,7 @@ aVerilog errh flags pps aspack ffmap = -- XXX might be good to allow the user to specify a default args :: [VArg] - args = [ VAParameter (vId i) r v + args = [ VAParameter (vId i) r v | (i, t) <- ps, let (r, v) = case t of ATBit sz -> (Just (VEConst (sz-1), diff --git a/src/comp/AVerilogUtil.hs b/src/comp/AVerilogUtil.hs index 597782ea6..647ee851a 100644 --- a/src/comp/AVerilogUtil.hs +++ b/src/comp/AVerilogUtil.hs @@ -3,33 +3,33 @@ module AVerilogUtil ( - -- basic conversion functions - vId, - vExpr, - vMethId, + -- basic conversion functions + vId, + vExpr, + vMethId, vNameToTask, - -- less basic (might belong in AVerilog?) - vDefMpd, + -- less basic (might belong in AVerilog?) + vDefMpd, - -- higher level conversion functions + -- higher level conversion functions -- XXX these might belong in AVerilog? - vState, InstInfo, wiredInstance, - vForeignBlock, vForeignCall, + vState, InstInfo, wiredInstance, + vForeignBlock, vForeignCall, - -- separate decls and defs - -- (could go in AVerilog, but needed by vForeignBlock - expVVDWire, + -- separate decls and defs + -- (could go in AVerilog, but needed by vForeignBlock + expVVDWire, - -- Id routines - suff, pref, + -- Id routines + suff, pref, - -- size routine - vSize, + -- size routine + vSize, isNotZeroSized, flagsToVco, VConvtOpts(..) - ) where + ) where import Data.List(nub, partition, genericLength, union, intersect, (\\)) import Data.Maybe @@ -44,14 +44,14 @@ import PreIds( idInout_, idSVA ) import Position( Position ) import VModInfo(vArgs, vName, vFields, VName(..), VeriPortProp(..), - getIfcIdPosition, VArgInfo(..), VFieldInfo(..)) + getIfcIdPosition, VArgInfo(..), VFieldInfo(..)) import Prim import ASyntax import ASyntaxUtil import Verilog import VPrims(verilogInstancePrefix, viWidth) import BackendNamingConventions(createVerilogNameMapForAVInst, - xLateFStringUsingFStringMap) + xLateFStringUsingFStringMap) import ForeignFunctions(ForeignFunction(..), ForeignFuncMap, isPoly, isMappedAVId) import Util @@ -98,7 +98,7 @@ expVVDWire :: [VMItem] -> ([VMItem], [VMItem]) expVVDWire defs = let explode (VMDecl (VVDWire r v@(VVar i) e)) = ([VMDecl (VVDecl VDWire r [v])], - [VMAssign (VLId i) e]) + [VMAssign (VLId i) e]) explode vm@(VMDecl _) = ([vm], []) explode vm = ([], [vm]) @@ -123,15 +123,15 @@ polyReturnType _ _ = Nothing -- always-block for it, and a list of IDs which need to be declared -- as reg because their assignments were inlined into the block. vForeignBlock :: VConvtOpts -> ForeignFuncMap -> - [ADef] -> AForeignBlock -> Maybe ([VMItem], [AId]) + [ADef] -> AForeignBlock -> Maybe ([VMItem], [AId]) vForeignBlock vco ffmap ds (_, []) = Nothing vForeignBlock vco ffmap ds (clks, fcalls) = let -- make a def map def_map = M.fromList [(i, d) | d@(ADef i _ _ _) <- ds] findDef i = let err = internalError ("vForeignBlock findDef: " ++ - ppReadable i) - in M.findWithDefault err i def_map + ppReadable i) + in M.findWithDefault err i def_map -- make a def dependency map dep_map = M.fromList [(i, aVars d) | d@(ADef i _ _ _) <- ds] @@ -155,16 +155,16 @@ vForeignBlock vco ffmap ds (clks, fcalls) = convert :: Either ADef AForeignCall -> [VStmt] convert (Right fcall) = [vForeignCall vco fcall ffmap] convert (Left adef) = - let -- some of the defs that we inline might not be simple - -- assignments, so use vDefMpd instead of vExpr, but drop - -- the declaration part, and convert the VMItems to VStmts - vdef_items = snd $ expVVDWire $ vDefMpd vco adef ffmap - itemToStmt :: VMItem -> VStmt - itemToStmt (VMAssign i e) = VAssign i e - itemToStmt (VMStmt { vi_body = Valways (VAt _ body) }) = body - itemToStmt item = internalError ("vForeignBlock convert: " ++ - ppReadable item) - in map itemToStmt vdef_items + let -- some of the defs that we inline might not be simple + -- assignments, so use vDefMpd instead of vExpr, but drop + -- the declaration part, and convert the VMItems to VStmts + vdef_items = snd $ expVVDWire $ vDefMpd vco adef ffmap + itemToStmt :: VMItem -> VStmt + itemToStmt (VMAssign i e) = VAssign i e + itemToStmt (VMStmt { vi_body = Valways (VAt _ body) }) = body + itemToStmt item = internalError ("vForeignBlock convert: " ++ + ppReadable item) + in map itemToStmt vdef_items -- the always block statements fcall_stmts0 = concatMap convert fcalls_and_defs @@ -176,31 +176,31 @@ vForeignBlock vco ffmap ds (clks, fcalls) = -- the always block sensitivity list sensitivity_list = -- foreign function calls trigger at the negative clock edge so - -- values are ready (at the positive edge) from input system tasks + -- values are ready (at the positive edge) from input system tasks foldr1 VEEOr (map (VEEnegedge . (vExpr vco)) clks) -- the always block -- (starting the block with "#0" is a hack to pacify VCS and NC) always_stmt = Valways (VAt sensitivity_list - (VSeq (VZeroDelay : fcall_stmts))) + (VSeq (VZeroDelay : fcall_stmts))) -- the assertions' sensitivity list ass_sensitivity_list = -- foreign function calls trigger at the negative clock edge so - -- values are ready (at the positive edge) from input system tasks + -- values are ready (at the positive edge) from input system tasks foldr1 VEEOr (map (VEEposedge . (vExpr vco)) clks) mkVAssert :: VStmt -> VMItem mkVAssert (VTask _ es) = - VMStmt { vi_translate_off = True, + VMStmt { vi_translate_off = True, vi_body = VAssert ass_sensitivity_list es } mkVAssert x = internalError("mkVAssert: " ++ (show x)) ass_stmts = map mkVAssert asses in -- put it together, with translate_off, since it is for sim only Just ((if null fcall_stmts then [] else - [VMStmt { vi_translate_off = True, + [VMStmt { vi_translate_off = True, vi_body = always_stmt }])++ - (if null asses then [] else ass_stmts), + (if null asses then [] else ass_stmts), - inline_def_ids) + inline_def_ids) vForeignCall :: VConvtOpts -> AForeignCall -> ForeignFuncMap -> VStmt vForeignCall vco f@(AForeignCall aid taskid (c:es) ids resets) ffmap = @@ -218,10 +218,10 @@ vForeignCall vco f@(AForeignCall aid taskid (c:es) ids resets) ffmap = fcall exprs | Just (cnd, es_T, es_F) <- splitString exprs = Vifelse (vExpr vco cnd) (fcall es_T) (fcall es_F) fcall exprs = case ids' of - [] -> (buildVerilogTask vco vtaskid (map (vExpr vco) exprs)) - [i] -> (VSeq [(VAssign (VLId (vId i)) - (VEFctCall vtaskid (map (vExpr vco) exprs))), - VZeroDelay]) + [] -> (buildVerilogTask vco vtaskid (map (vExpr vco) exprs)) + [i] -> (VSeq [(VAssign (VLId (vId i)) + (VEFctCall vtaskid (map (vExpr vco) exprs))), + VZeroDelay]) _ -> internalError("AVerilog.vForeignCall" ++ (show f)) -- if c is trivial (i.e. 0 or 1), verilog pretty printing will optimize it: fcall_body = Vif (vExpr vco c) (fcall es') @@ -270,150 +270,150 @@ buildVerilogTask vco taskid es | isMappedAVId (vidToId taskid) = VSeq [VTask tas buildVerilogTask vco taskid es = VTask taskid es tsortForeignCallsAndDefs :: [ADef] -> [AForeignCall] -> - [Either ADef AForeignCall] + [Either ADef AForeignCall] -- if there are no defs, just return the fcalls tsortForeignCallsAndDefs [] fcalls = map Right fcalls tsortForeignCallsAndDefs ds fcalls = let - -- we will create a graph where the edges are: - -- * "Left AId" to represent a def (by it's name) - -- * "Right Integer" to represent an fcall (by it's position) - - -- The use of Left and Right was chosen to make Defs lower in - -- the Ord order than ForeignCalls. This way, tsort puts them first. - - -- ---------- - -- Defs - - -- the Ids of the defs - -- (we only want to make edges for variable uses from this list) - ds_ids = map adef_objid ds - -- for efficiency, make it a set - s = S.fromList ds_ids - - -- make edges for def-to-def dependencies - def_edges = [ (Left i, map Left uses) - | ADef i _ e _ <- ds, - let uses = filter (`S.member` s) (aVars e) ] - - -- map def ids back to their defs - defmap = M.fromList [ (i,d) | d@(ADef i _ _ _) <- ds ] - getDef i = - case (M.lookup i defmap) of - Just d -> d - Nothing -> internalError "tsortForeignCallsAndDefs: getDef" - - -- ---------- - -- ForeignCalls - - -- give the fcalls a unique number and make a mapping - -- (numbering in order sets the Ord order for tsort) - - numbered_fcalls :: [(Integer, AForeignCall)] - numbered_fcalls = zip [1..] fcalls - - fcall_map = M.fromList numbered_fcalls - getFCall n = - case (M.lookup n fcall_map) of - Just d -> d - Nothing -> internalError "tsortForeignCallsAndDefs: getFCall" - - -- ---------- - -- ForeignCall-to-ForeignCall edges - -- (to maintain the user-specified order of the ForeignCalls) - - -- (are these still needed now that we use Ord to bias tsort?) - fcall_edges = - if (length fcalls > 1) - then let mkEdge (n1,_) (n2,_) = (Right n2, [Right n1]) - in zipWith mkEdge - (init numbered_fcalls) (tail numbered_fcalls) - else [] - - -- ---------- - -- ForeignCall to Def edges - - -- any defs used by an fcall have to be computed before the - -- fcall is called - fcall_def_edges = [ (Right n, map Left uses) - | (n,f) <- numbered_fcalls, + -- we will create a graph where the edges are: + -- * "Left AId" to represent a def (by it's name) + -- * "Right Integer" to represent an fcall (by it's position) + + -- The use of Left and Right was chosen to make Defs lower in + -- the Ord order than ForeignCalls. This way, tsort puts them first. + + -- ---------- + -- Defs + + -- the Ids of the defs + -- (we only want to make edges for variable uses from this list) + ds_ids = map adef_objid ds + -- for efficiency, make it a set + s = S.fromList ds_ids + + -- make edges for def-to-def dependencies + def_edges = [ (Left i, map Left uses) + | ADef i _ e _ <- ds, + let uses = filter (`S.member` s) (aVars e) ] + + -- map def ids back to their defs + defmap = M.fromList [ (i,d) | d@(ADef i _ _ _) <- ds ] + getDef i = + case (M.lookup i defmap) of + Just d -> d + Nothing -> internalError "tsortForeignCallsAndDefs: getDef" + + -- ---------- + -- ForeignCalls + + -- give the fcalls a unique number and make a mapping + -- (numbering in order sets the Ord order for tsort) + + numbered_fcalls :: [(Integer, AForeignCall)] + numbered_fcalls = zip [1..] fcalls + + fcall_map = M.fromList numbered_fcalls + getFCall n = + case (M.lookup n fcall_map) of + Just d -> d + Nothing -> internalError "tsortForeignCallsAndDefs: getFCall" + + -- ---------- + -- ForeignCall-to-ForeignCall edges + -- (to maintain the user-specified order of the ForeignCalls) + + -- (are these still needed now that we use Ord to bias tsort?) + fcall_edges = + if (length fcalls > 1) + then let mkEdge (n1,_) (n2,_) = (Right n2, [Right n1]) + in zipWith mkEdge + (init numbered_fcalls) (tail numbered_fcalls) + else [] + + -- ---------- + -- ForeignCall to Def edges + + -- any defs used by an fcall have to be computed before the + -- fcall is called + fcall_def_edges = [ (Right n, map Left uses) + | (n,f) <- numbered_fcalls, let uses = filter (`S.member` s) (aVars f) ] - -- any def which uses a value set by an fcall must be computed - -- after the fcall is called - def_fcall_edges = - let - -- find the values set by the fcalls - avalue_pairs = [ (val, n) | (n,f) <- numbered_fcalls, - val <- afc_writes f ] - avalue_map = M.fromList avalue_pairs - findNum i = - let err = internalError - ("tsortForeignCallsAndDefs def_fcall_edges") - in M.findWithDefault err i avalue_map - -- and just the set of ids, for testing membership - avalue_set = M.keysSet avalue_map - isAV i = S.member i avalue_set - -- find the defs that depend on the avalues - aval_refs = [ (i, refs) - | (ADef i _ e _) <- ds, + -- any def which uses a value set by an fcall must be computed + -- after the fcall is called + def_fcall_edges = + let + -- find the values set by the fcalls + avalue_pairs = [ (val, n) | (n,f) <- numbered_fcalls, + val <- afc_writes f ] + avalue_map = M.fromList avalue_pairs + findNum i = + let err = internalError + ("tsortForeignCallsAndDefs def_fcall_edges") + in M.findWithDefault err i avalue_map + -- and just the set of ids, for testing membership + avalue_set = M.keysSet avalue_map + isAV i = S.member i avalue_set + -- find the defs that depend on the avalues + aval_refs = [ (i, refs) + | (ADef i _ e _) <- ds, let refs = filter isAV (aVars e), - not (null refs) ] - in -- make the edges - [ (Left i, map (Right . findNum) refs) - | (i, refs) <- aval_refs ] + not (null refs) ] + in -- make the edges + [ (Left i, map (Right . findNum) refs) + | (i, refs) <- aval_refs ] - -- ---------- - -- put it together into one graph + -- ---------- + -- put it together into one graph - g = + g = {- - trace ("fcalls = " ++ ppReadable numbered_fcalls) $ - trace ("def_edges = " ++ ppReadable def_edges) $ - trace ("fcall_edges = " ++ ppReadable fcall_edges) $ - trace ("fcall_def_edges = " ++ ppReadable fcall_def_edges) $ - trace ("def_fcall_edges = " ++ ppReadable def_fcall_edges) $ + trace ("fcalls = " ++ ppReadable numbered_fcalls) $ + trace ("def_edges = " ++ ppReadable def_edges) $ + trace ("fcall_edges = " ++ ppReadable fcall_edges) $ + trace ("fcall_def_edges = " ++ ppReadable fcall_def_edges) $ + trace ("def_fcall_edges = " ++ ppReadable def_fcall_edges) $ -} - map_insertManyWith union (fcall_edges) $ - map_insertManyWith union (fcall_def_edges) $ - map_insertManyWith union (def_fcall_edges) $ - M.fromList def_edges + map_insertManyWith union (fcall_edges) $ + map_insertManyWith union (fcall_def_edges) $ + map_insertManyWith union (def_fcall_edges) $ + M.fromList def_edges -- Convert the graph to the format expected by tsort. - g_edges = M.toList g + g_edges = M.toList g - -- ---------- - -- convert a graph node back into a def/action - -- and then to a SimCCFnStmt + -- ---------- + -- convert a graph node back into a def/action + -- and then to a SimCCFnStmt - convertNode (Left i) = Left (getDef i) - convertNode (Right n) = Right (getFCall n) + convertNode (Left i) = Left (getDef i) + convertNode (Right n) = Right (getFCall n) in - -- tsort returns Left if there is a loop, Right if sorted. - case (tsort g_edges) of - Right is -> map convertNode is - Left (scc:_) -> - let path = extractOneCycle_map g scc - in internalError ("tsortForeignCallsAndDefs: cyclic " ++ - ppReadable (map convertNode path)) - Left [] -> internalError ("tsortForeignCallsAndDefs: cyclic []") + -- tsort returns Left if there is a loop, Right if sorted. + case (tsort g_edges) of + Right is -> map convertNode is + Left (scc:_) -> + let path = extractOneCycle_map g scc + in internalError ("tsortForeignCallsAndDefs: cyclic " ++ + ppReadable (map convertNode path)) + Left [] -> internalError ("tsortForeignCallsAndDefs: cyclic []") getAVDependDefs :: (M.Map AId [AId]) -> [AForeignCall] -> [AId] getAVDependDefs rev_dep_map fcalls = let avalues = concatMap afc_writes fcalls - all_ids = closeOverMap rev_dep_map avalues + all_ids = closeOverMap rev_dep_map avalues in -- don't include the avalues themselves - all_ids \\ avalues - -- for efficiency, we could exploit knowledge that the avalues - -- are at the end of the list and do this: - --rDrop (length avalues) all_ids + all_ids \\ avalues + -- for efficiency, we could exploit knowledge that the avalues + -- are at the end of the list and do this: + --rDrop (length avalues) all_ids getFCallDependDefs :: (M.Map AId [AId]) -> [AForeignCall] -> [AId] getFCallDependDefs dep_map fcalls = let -- XXX we presumably don't need to include the reset exprs? - is = aVars (concatMap afc_args fcalls) + is = aVars (concatMap afc_args fcalls) in closeOverMap dep_map is closeOverMap :: (M.Map AId [AId]) -> [AId] -> [AId] @@ -424,13 +424,13 @@ closeOverMap' dmap considered consider_next [] = if (S.null consider_next) then considered else let consider_next' = S.difference consider_next considered - considered' = S.union considered consider_next' - in closeOverMap' dmap considered' S.empty (S.toList consider_next') + considered' = S.union considered consider_next' + in closeOverMap' dmap considered' S.empty (S.toList consider_next') closeOverMap' dmap considered consider_next (i:is) = case (M.lookup i dmap) of - (Just dep_is) -> let consider_next' = set_insertMany dep_is consider_next - in closeOverMap' dmap considered consider_next' is - Nothing -> closeOverMap' dmap considered consider_next is + (Just dep_is) -> let consider_next' = set_insertMany dep_is consider_next + in closeOverMap' dmap considered consider_next' is + Nothing -> closeOverMap' dmap considered consider_next is -- ============================== @@ -446,8 +446,8 @@ vDefMpd :: VConvtOpts -> ADef -> ForeignFuncMap -- special case for two input mux, for readability {- vDefMpd _ (ADef i t (APrim _ _ PrimPriMux [ce,te,_,ee])) = - [ VMDecl $ VVDecl VDWire (vSize t) [VVar (vId i)], - VMAssign (VLId (vId i)) (VEIf (vExpr vco ce) (vExpr vco te) (vExpr vco ee)) ] + [ VMDecl $ VVDecl VDWire (vSize t) [VVar (vId i)], + VMAssign (VLId (vId i)) (VEIf (vExpr vco ce) (vExpr vco te) (vExpr vco ee)) ] -} vDefMpd vco (ADef i t (APrim _ _ PrimPriMux []) _) _ = internalError("vDefMpd 11" ) @@ -455,11 +455,11 @@ vDefMpd vco (ADef i t (APrim _ _ PrimPriMux [e]) _) _ = internalError("vDefMpd 1 vDefMpd vco def@(ADef i t (APrim _ _ PrimPriMux es) _) _ = if (not (vco_readableMux vco)) then - [ VMDecl $ VVDecl VDWire (vSize t) [VVar (vId i)], - muxInst vco True (aSize t) (vPrimInstId "priorityMux_" i) (VEVar (vId i) : map (vExpr vco) es) ] + [ VMDecl $ VVDecl VDWire (vSize t) [VVar (vId i)], + muxInst vco True (aSize t) (vPrimInstId "priorityMux_" i) (VEVar (vId i) : map (vExpr vco) es) ] else - [ VMDecl $ VVDecl VDReg (vSize t) [VVar vi], - VMStmt { vi_translate_off = False, + [ VMDecl $ VVDecl VDReg (vSize t) [VVar vi], + VMStmt { vi_translate_off = False, vi_body = Valways $ VAt ev $ Vcase { vs_case_expr = one, @@ -476,17 +476,17 @@ vDefMpd vco def@(ADef i t (APrim _ _ PrimPriMux es) _) _ = arms ((c,e) : ces) = (VCaseArm [vExpr vco c] (VAssign (VLId vi) (vExpr vco e)) : arms ces) sensitivityList = nub (concatMap aIds es) - ev = if (null sensitivityList) + ev = if (null sensitivityList) then (internalError("AVerilogUtil:: null sensitivity list for PrimPriMux" ++ ppReadable def)) else foldr1 VEEOr (map (VEE . VEVar) sensitivityList) vDefMpd vco def@(ADef i t (APrim _ _ PrimMux es) _) _ = if (not (vco_readableMux vco)) then - [ VMDecl $ VVDecl VDWire (vSize t) [VVar (vId i)], - muxInst vco False (aSize t) (vPrimInstId "mux_" i) (VEVar (vId i) : map (vExpr vco) es) ] + [ VMDecl $ VVDecl VDWire (vSize t) [VVar (vId i)], + muxInst vco False (aSize t) (vPrimInstId "mux_" i) (VEVar (vId i) : map (vExpr vco) es) ] else - [ VMDecl $ VVDecl VDReg (vSize t) [VVar vi], - VMStmt { vi_translate_off = False, + [ VMDecl $ VVDecl VDReg (vSize t) [VVar vi], + VMStmt { vi_translate_off = False, vi_body = Valways $ VAt ev $ VSeq [ -- VAssign (VLId vi) (VEConst 0), -- no need to put default assignment @@ -504,45 +504,45 @@ vDefMpd vco def@(ADef i t (APrim _ _ PrimMux es) _) _ = arm (c,e) = VCaseArm [vExpr vco c] (VAssign (VLId vi) (vExpr vco e)) defaultArm (c,e) = [VDefault (VAssign (VLId vi) (vExpr vco e))] sensitivityList = nub (concatMap aIds es) - ev = if (null sensitivityList) + ev = if (null sensitivityList) then (internalError("AVerilogUtil:: null sensitivity list for PrimMux" ++ ppReadable def)) else foldr1 VEEOr (map (VEE . VEVar) sensitivityList) vDefMpd vco (ADef i t - (ANoInlineFunCall _ _ - (ANoInlineFun n is (ips, ops) (Just inst_name)) es) _) _ = - let ops' = ops -- filter (\(x,y) -> y >= 0 ) $ traces ("ops " ++ show ops) ops + (ANoInlineFunCall _ _ + (ANoInlineFun n is (ips, ops) (Just inst_name)) es) _) _ = + let ops' = ops -- filter (\(x,y) -> y >= 0 ) $ traces ("ops " ++ show ops) ops -- Size information all appears to be 0 (ips',es') = unzip $ filter (isNotZeroSized . ae_type . snd) (zip ips es) oname = VEVar (vId i) -- a concat of the outputs - oports = case ops' of - [(o, _)] -> [(mkVId o, Just oname)] - ons -> let ns = tail (scanr (+) 0 (map snd ons)) - in zipWith (\ (o, s) l -> - (mkVId o, - Just (veSelect - oname - (VEConst (l+s-1)) - (VEConst l)))) - ons - ns - in - [ VMDecl $ VVDecl VDWire (vSize t) [VVar (vId i)], - VMInst { + oports = case ops' of + [(o, _)] -> [(mkVId o, Just oname)] + ons -> let ns = tail (scanr (+) 0 (map snd ons)) + in zipWith (\ (o, s) l -> + (mkVId o, + Just (veSelect + oname + (VEConst (l+s-1)) + (VEConst l)))) + ons + ns + in + [ VMDecl $ VVDecl VDWire (vSize t) [VVar (vId i)], + VMInst { vi_module_name = mkVId n, vi_inst_name = VId inst_name i Nothing, -- these are size params, so default width of 32 is fine vi_inst_params = Left (map (\x -> (Nothing,VEConst x)) is), vi_inst_ports = (zip (map (\ x -> mkVId (fst x)) ips') - (map (Just . (vExpr vco)) es') + (map (Just . (vExpr vco)) es') ++ oports) } - ] + ] vDefMpd vco defin@(ADef i t (APrim _ _ PrimCase es@(x:defarm:ces_t)) _) _ = - [ VMDecl $ VVDecl VDReg (vSize t) [VVar vi], - VMStmt { vi_translate_off = False, + [ VMDecl $ VVDecl VDReg (vSize t) [VVar vi], + VMStmt { vi_translate_off = False, vi_body = Valways $ VAt ev $ VSeq [Vcase { vs_case_expr = vExpr vco x, @@ -551,19 +551,19 @@ vDefMpd vco defin@(ADef i t (APrim _ _ PrimCase es@(x:defarm:ces_t)) _) _ = vs_full = False }] } - ] + ] where vi = vId i - arms [] = [] - arms ((c,e) : ces) = - let (cs, ces') = partition ((== e) . snd) ces - in VCaseArm (map (vExpr vco) (c:map fst cs)) (VAssign (VLId vi) (vExpr vco e)) : arms ces' + arms [] = [] + arms ((c,e) : ces) = + let (cs, ces') = partition ((== e) . snd) ces + in VCaseArm (map (vExpr vco) (c:map fst cs)) (VAssign (VLId vi) (vExpr vco e)) : arms ces' sensitivityList = nub (concatMap aIds es) - ev = if (null sensitivityList) + ev = if (null sensitivityList) then (internalError("AVerilogUtil:: null sensitivity list for case" ++ ppReadable defin)) else foldr1 VEEOr (map (VEE . VEVar) sensitivityList) - n = aSize x - fullcase = (2^n * 2) == (length ces_t) - def = if fullcase then [] else [VDefault (VAssign (VLId vi) (vExpr vco defarm))] + n = aSize x + fullcase = (2^n * 2) == (length ces_t) + def = if fullcase then [] else [VDefault (VAssign (VLId vi) (vExpr vco defarm))] vDefMpd vco (ADef i_t t_t@(ATBit _) (ATaskValue {}) _) _ = [VMDecl $ VVDecl VDReg (vSize t_t) [VVar (vId i_t)]] @@ -579,19 +579,19 @@ vDefMpd vco (ADef i_t t_t@(ATBit _) fn@(AFunCall {}) _) ffmap ev = foldr1 VEEOr (map (VEE . VEVar) sensitivityList) arg_list = [ ASDef t_t i_t ] ++ (ae_args fn) args = map (vExpr vco) arg_list - body = if (null sensitivityList) + body = if (null sensitivityList) then Vinitial $ VSeq [VTask vtaskid args] else Valways $ VAt ev $ VSeq [VTask vtaskid args] vDefMpd vco (ADef i_t t_t@(ATBit _) e_t _) _ = let - -- XXX AMethCall/AMethValue shouldn't exist - -- vExprMpd (AMethCall t i m []) = VEVar (vMethId i m 1 MethodResult) - -- vExprMpd (AMethCall t i m _) = internalError "AVerilog.vExprMpd: AMethCall with args" - -- vExprMpd (AMethValue t i m) = VEVar (vMethId i m 1 MethodResult) - vExprMpd e = vExpr vco e + -- XXX AMethCall/AMethValue shouldn't exist + -- vExprMpd (AMethCall t i m []) = VEVar (vMethId i m 1 MethodResult) + -- vExprMpd (AMethCall t i m _) = internalError "AVerilog.vExprMpd: AMethCall with args" + -- vExprMpd (AMethValue t i m) = VEVar (vMethId i m 1 MethodResult) + vExprMpd e = vExpr vco e in - [VMDecl $ VVDWire (vSize t_t) (VVar (vId i_t)) (vExprMpd e_t)] + [VMDecl $ VVDWire (vSize t_t) (VVar (vId i_t)) (vExprMpd e_t)] vDefMpd vco adef@(ADef i_t t_t@(ATAbstract aid _) e_t _) _ | aid==idInout_ = [VMDecl $ VVDWire (vSize t_t) (VVar (vId i_t)) (vExpr vco e_t)] vDefMpd vco adef@(ADef i_t t_t@(ATString _) e_t _) _ = @@ -647,26 +647,26 @@ vExpr vco (APrim _ _ PrimIf [e1, e2, e3]) = VEIf (vExpr vco e1) (vExpr vco e2) ( vExpr vco (APrim _ _ PrimBNot [e]) = vNot (vExpr vco e) vExpr vco (APrim _ _ PrimRange [_,_,e]) = vExpr vco e vExpr vco (APrim _ t PrimZeroExt [e]) = - VEConcat [VEWConst - (mkVId "0") - (aSize t - aSize e) - 10 - 0, - vExpr vco e] + VEConcat [VEWConst + (mkVId "0") + (aSize t - aSize e) + 10 + 0, + vExpr vco e] vExpr vco (APrim _ t PrimSignExt [e]) | aSize e == 1 && aSize t > 0 = VERepeat (VEConst (aSize t)) (vExpr vco e) vExpr vco e0@(APrim _ t PrimSignExt [e]) = VEConcat [vERepeat fill (VESelect1 vexp vhi), vexp] where fill = if (j >= i) then internalError("AVerilogUtil.broken SignExtend: " ++ ppReadable e0) else i-j - vhi = VEConst (j-1) - vexp = vExpr vco e - i = aSize t - j = aSize e - vERepeat 1 x = x - vERepeat n x = VERepeat (VEConst n) x + vhi = VEConst (j-1) + vexp = vExpr vco e + i = aSize t + j = aSize e + vERepeat 1 x = x + vERepeat n x = VERepeat (VEConst n) x vExpr vco (APrim aid t p [e1, e2]) | isSignedCmp p = VEOp (idToVId aid) (flip_t (vExpr vco e1)) (unsOp p) (flip_t (vExpr vco e2)) where flip_t e = vXor e (VEWConst (mkVId (show ((2 :: Integer)^(s-1)))) s 16 (2^(s-1))) - s = aSize (aType e1) + s = aSize (aType e1) vExpr vco (APrim aid _ p [e]) = VEUnOp (idToVId aid) (toVOp p) (vExpr vco e) vExpr vco (APrim aid _ p [e1,e2]) | p == PrimSL || p == PrimSRL = VEOp (idToVId aid) (vExpr vco e1) (toVOp p) (vExprC vco e2) vExpr vco (APrim aid _ p [e1,e2]) = VEOp (idToVId aid) (vExpr vco e1) (toVOp p) (vExpr vco e2) @@ -779,10 +779,10 @@ muxInputs = mkVId "out" : fxx 0 -- connected to it in the VMInst (expressions for params and port args, -- but Ids in all other cases, because wires are declared) type InstInfo = ([(VId, VExpr)], -- parameter exprs - [(VId, VExpr)], -- non-method port exprs (clocks, resets, inouts) - [(VId, VId)], -- special ifc outputs (clocks, resets, inouts) - [(VId, VId)], -- method input port signals - [(VId, VId)]) -- method output port signals + [(VId, VExpr)], -- non-method port exprs (clocks, resets, inouts) + [(VId, VId)], -- special ifc outputs (clocks, resets, inouts) + [(VId, VId)], -- method input port signals + [(VId, VId)]) -- method output port signals -- an instance is "wired" to the outside world -- if it connects *any* sort of port @@ -807,29 +807,29 @@ wiredInstance item = internalError ("wiredInstance - not instance: " ++ ppReadab -- XXX this function is too big vState :: Flags -> M.Map AId AId -> AVInst -> (AId, VMItem, InstInfo) vState flags rewire_map avinst = - let vco = flagsToVco flags + let vco = flagsToVco flags v_inst_name = avi_vname avinst mts = avi_meth_types avinst vi = avi_vmi avinst es = avi_iargs avinst -- - -- the port multiplicity usage (how many copies are used) + -- the port multiplicity usage (how many copies are used) -- ns = avi_iarray avinst - -- get the number of copies of a method which are used - -- getMethodMultUse m = - -- case (lookup m ns) of - -- Just mult -> mult - -- Nothing -> internalError ("vState getMethodMultUse: " ++ - -- - -- "ns list not consistent with vfi") + -- get the number of copies of a method which are used + -- getMethodMultUse m = + -- case (lookup m ns) of + -- Just mult -> mult + -- Nothing -> internalError ("vState getMethodMultUse: " ++ + -- + -- "ns list not consistent with vfi") -- -- a map from ATS names for method names and args -- to the corresponding signals in verilog -- e.g., "r$write" -> "r$EN", "r$write_1" -> "r->$D_IN" port_rename_table = - M.fromList (createVerilogNameMapForAVInst flags avinst) + M.fromList (createVerilogNameMapForAVInst flags avinst) rewire_inout (ASPort t i) | isInoutType t, Just i' <- M.lookup i rewire_map = ASPort t i' @@ -841,40 +841,40 @@ vState flags rewire_map avinst = -- make sure to filter-out 0-width ports and parameters -- we also rewire inout ports that might have been renamed -- because of a connection - arges = [(vai, vExpr vco e') | (vai, e) <- zip (vArgs vi) es, + arges = [(vai, vExpr vco e') | (vai, e) <- zip (vArgs vi) es, let e' = rewire_inout e, isNotZeroSized (aType e) ] - -- Below, we construct info on the method: - -- arguments, return values, and enables + -- Below, we construct info on the method: + -- arguments, return values, and enables mkArgId :: Id -> Integer -> Maybe Integer -> VId - mkArgId m k m_port = vMethId v_inst_name m m_port (MethodArg k) port_rename_table + mkArgId m k m_port = vMethId v_inst_name m m_port (MethodArg k) port_rename_table - mkEnId m m_port = vMethId v_inst_name m m_port MethodEnable port_rename_table + mkEnId m m_port = vMethId v_inst_name m m_port MethodEnable port_rename_table - mkResId m m_port = vMethId v_inst_name m m_port MethodResult port_rename_table + mkResId m m_port = vMethId v_inst_name m m_port MethodResult port_rename_table - -- add the multiplicity to Verilog port names - -- (if there are not multiple ports, no uniquifier is added) - portid :: String -> Maybe Integer -> String - portid s Nothing = s - portid s (Just n) = s ++ "_" ++ itos (n+1) -- ports start numbering at 1 not 0 + -- add the multiplicity to Verilog port names + -- (if there are not multiple ports, no uniquifier is added) + portid :: String -> Maybe Integer -> String + portid s Nothing = s + portid s (Just n) = s ++ "_" ++ itos (n+1) -- ports start numbering at 1 not 0 - -- check that an instantiated module doesn't reuse an input port - check_inps [i] = i + -- check that an instantiated module doesn't reuse an input port + check_inps [i] = i check_inps ((port, _, _):_) = - -- XXX should this be a user error? + -- XXX should this be a user error? internalError("attempt to instantiate module " ++ (ppReadable v_inst_name) ++ " with duplicated port " ++ (ppReadable port)) check_inps [] = internalError( "AVerilog::mkinput" ) - -- for each method argument: the Verilog port name with muliplicity, - -- the Id in method syntax ($_[_]), and possibly - -- the size if it is not 1-bit + -- for each method argument: the Verilog port name with muliplicity, + -- the Id in method syntax ($_[_]), and possibly + -- the size if it is not 1-bit inps :: [(VId, VId, Maybe VRange)] - inps = [ (mkVId (portid s ino), + inps = [ (mkVId (portid s ino), mkArgId m k ino, vSize argType) | (meth@(Method m _ _ mult ps mo me), @@ -884,53 +884,53 @@ vState flags rewire_map avinst = ino <- if mult > 1 then map Just [0..mult-1] else [Nothing], (VName s, argType, k) <- zip3 (map fst ps) argTypes [1..], isNotZeroSized argType - ] + ] - -- check for duplicates + -- check for duplicates inputs :: [(VId, VId, Maybe VRange)] - inputs = map check_inps - (sortGroup (\ (x,_,_) (y,_,_) -> x <= y) inps) + inputs = map check_inps + (sortGroup (\ (x,_,_) (y,_,_) -> x <= y) inps) - -- for each method with an action: the method name, the enable - -- Verilog port name, the enable name in method syntax - -- ($EN_), whether the method must be always enabled + -- for each method with an action: the method name, the enable + -- Verilog port name, the enable name in method syntax + -- ($EN_), whether the method must be always enabled meth_enables = - [ (m, - mkVId (portid s ino), - mkEnId m ino, + [ (m, + mkVId (portid s ino), + mkEnId m ino, inhigh ) - | (Method m _ _ mult ss mo me@(Just (VName s,vps))) + | (Method m _ _ mult ss mo me@(Just (VName s,vps))) <- vFields vi, - let inhigh = VPinhigh `elem` vps, + let inhigh = VPinhigh `elem` vps, -- let multu = getMethodMultUse m, - ino <- if mult > 1 then map Just [0..mult-1] else [Nothing] + ino <- if mult > 1 then map Just [0..mult-1] else [Nothing] ] - -- for each method with a result: the result Verilog port name, - -- the result name in method syntax ($) - -- (nub, because several methods might have their return value - -- come from the same output port) - meth_return_vals = - nub - [ (mkVId (portid s ino), - mkResId m ino) - | ((Method m _ _ mult ss mo@(Just (VName s, vps)) me), (_,_,Just retType)) + -- for each method with a result: the result Verilog port name, + -- the result name in method syntax ($) + -- (nub, because several methods might have their return value + -- come from the same output port) + meth_return_vals = + nub + [ (mkVId (portid s ino), + mkResId m ino) + | ((Method m _ _ mult ss mo@(Just (VName s, vps)) me), (_,_,Just retType)) <- zip (vFields vi) mts, isNotZeroSized retType, -- let multu = getMethodMultUse m, ino <- if mult > 1 then map Just [0..mult-1] else [Nothing] - ] + ] -- clock and reset outputs -- no nub because getSpecialPorts takes care of it -- include a flag that tells us if the wire needs to be declared or not special_wire_blobs = - [ (vIdV wvname, vId wid', wid' == wid) - | (wid, wtype, (wvname, wvprops)) <- getSpecialOutputs avinst, + [ (vIdV wvname, vId wid', wid' == wid) + | (wid, wtype, (wvname, wvprops)) <- getSpecialOutputs avinst, -- redirect wires that need special wiring (currently inouts) let wid' = fromMaybe wid (M.lookup wid rewire_map), isNotZeroSized wtype - ] + ] -- the only special wires that are true outputs are the ones -- that need to be declared @@ -946,8 +946,8 @@ vState flags rewire_map avinst = -- XXX or varying names after rewiring output_wire_connections = nubByFst (meth_return_vals ++ special_wire_connections) - -- instantiation parameters - paramExprs = + -- instantiation parameters + paramExprs = -- Lennart added the dropping of sizes in r364, but this leads -- to bugs if the uses of the param in the submod rely on the -- size of the parameter. All our parameters are sized @@ -957,20 +957,20 @@ vState flags rewire_map avinst = -- want to display it in hex). [ (vIdV vn, {-vDropSize-} ve) | (Param vn, ve) <- arges ] - -- dynamic module arguments - port_ps = [ (vIdV vn, ve) | (Port (vn,_) _ _, ve) <- arges ] + -- dynamic module arguments + port_ps = [ (vIdV vn, ve) | (Port (vn,_) _ _, ve) <- arges ] - -- the wires (ins, outs and inouts) to connect to the module ports + -- the wires (ins, outs and inouts) to connect to the module ports args :: [(VId, Maybe VExpr)] - args = - -- dynamic arguments - [ (p, Just e) | (p, e) <- port_ps ] ++ - -- method inputs - [ (p, Just (VEVar w)) | (p, w, rng) <- inputs, nonZero rng ] ++ - -- method enables (those which are not always enabled) - [ (p, Just (VEVar w)) | (_, p, w, False) <- meth_enables ] ++ - -- wire outputs - method return values and "special" (e.g. clock and reset) - [ (p, Just (VEVar w)) | (p, w) <- output_wire_connections ] + args = + -- dynamic arguments + [ (p, Just e) | (p, e) <- port_ps ] ++ + -- method inputs + [ (p, Just (VEVar w)) | (p, w, rng) <- inputs, nonZero rng ] ++ + -- method enables (those which are not always enabled) + [ (p, Just (VEVar w)) | (_, p, w, False) <- meth_enables ] ++ + -- wire outputs - method return values and "special" (e.g. clock and reset) + [ (p, Just (VEVar w)) | (p, w) <- output_wire_connections ] ifc_position = (getIfcIdPosition vi) @@ -983,19 +983,19 @@ vState flags rewire_map avinst = vi_inst_ports = map (updateArgPosition ifc_position) (map tildeHack args) } - inst_info = - (-- param exprs - paramExprs, - -- non-meth input port exprs - port_ps, - -- special wire output names - special_wire_outputs, - -- method input names - [ (p, w) | (p, w, rng) <- inputs, nonZero rng ] ++ - [ (p, w) | (_, p, w, False) <- meth_enables], - -- method output names - meth_return_vals - ) + inst_info = + (-- param exprs + paramExprs, + -- non-meth input port exprs + port_ps, + -- special wire output names + special_wire_outputs, + -- method input names + [ (p, w) | (p, w, rng) <- inputs, nonZero rng ] ++ + [ (p, w) | (_, p, w, False) <- meth_enables], + -- method output names + meth_return_vals + ) -- debug_inputs = traces ("\n\nDBG vState:\n" ++ ppReadable avinst ++ "\n\n") @@ -1004,12 +1004,12 @@ vState flags rewire_map avinst = -- debug_vminst = traces ("\n\nDBG vState vminst=\n" ++ ppReadable vminst ++ "\n\n") in - -- debug_inputs $ debug_arges $ debug_vminst $ - if (length (vArgs vi)) /= (length es) - then internalError "AVerilog.vState: # args differs from expected" + -- debug_inputs $ debug_arges $ debug_vminst $ + if (length (vArgs vi)) /= (length es) + then internalError "AVerilog.vState: # args differs from expected" else (v_inst_name, - vminst, - inst_info) + vminst, + inst_info) -- ------------------------------ updateArgPosition :: Position -> (VId,Maybe VExpr) -> (VId,Maybe VExpr) @@ -1051,7 +1051,7 @@ vIdV (VName s) = mkVId s vMethId :: Id -> Id -> Maybe Integer -> MethodPart -> M.Map FString FString -> VId vMethId i m m_port mp fsmap = let fstring = - xLateFStringUsingFStringMap fsmap (mkMethStr i m m_port mp) + xLateFStringUsingFStringMap fsmap (mkMethStr i m m_port mp) in VId (getFString fstring) (setIdBase ( unQualId i) fstring ) Nothing {- diff --git a/src/comp/Assump.hs b/src/comp/Assump.hs index c59111c90..5c93f1eb4 100644 --- a/src/comp/Assump.hs +++ b/src/comp/Assump.hs @@ -6,8 +6,8 @@ import PPrint import Eval data Assump - = Id :>: Scheme - deriving (Show, Eq) + = Id :>: Scheme + deriving (Show, Eq) instance PPrint Assump where pPrint d p (i :>: s) = pparen (p > 0) $ pPrint d 0 i <+> text ":>:" <+> pPrint d 0 s diff --git a/src/comp/BDD.hs b/src/comp/BDD.hs index 78c542098..6d61768bf 100644 --- a/src/comp/BDD.hs +++ b/src/comp/BDD.hs @@ -34,7 +34,7 @@ bddAnd a b = apply (&&) a b bddOr a b = apply (||) a b bddNot :: BDD a -> BDD a ---bddNot e = bddOp (\ x y -> not x) e bddFalse -- inefficient +--bddNot e = bddOp (\ x y -> not x) e bddFalse -- inefficient bddNot e = fst (flip I.empty e) where flip m (L b) = (L (not b), m) flip m (N u x t f) = diff --git a/src/comp/BExpr.hs b/src/comp/BExpr.hs index aa675159d..faca23d87 100644 --- a/src/comp/BExpr.hs +++ b/src/comp/BExpr.hs @@ -78,8 +78,8 @@ bNothing = A [iTrue] bAdd e (A es) = A $ mergeOrdNoDup (get e) es bImplies (A es) e = --- if length es > 1 then trace (ppReadable (e, es, isOrdSubset (get e) es)) $ isOrdSubset (get e) es - isOrdSubset (get e) es +-- if length es > 1 then trace (ppReadable (e, es, isOrdSubset (get e) es)) $ isOrdSubset (get e) es + isOrdSubset (get e) es bImpliesB b (A es) = all (bImplies b) es diff --git a/src/comp/Backend.hs b/src/comp/Backend.hs index 95a4b6510..dd231f953 100644 --- a/src/comp/Backend.hs +++ b/src/comp/Backend.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} module Backend ( - Backend(..), - backendMatches - ) where + Backend(..), + backendMatches + ) where import qualified Data.Generics as Generic import PPrint @@ -11,7 +11,7 @@ import Eval -- =============== data Backend = Bluesim | Verilog - deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable) + deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable) instance PPrint Backend where pPrint _ _ Bluesim = text "Bluesim" diff --git a/src/comp/BackendNamingConventions.hs b/src/comp/BackendNamingConventions.hs index 61032f46f..d5e71fb97 100644 --- a/src/comp/BackendNamingConventions.hs +++ b/src/comp/BackendNamingConventions.hs @@ -155,18 +155,18 @@ regaligned = VName "RegAligned" isRegN :: AVInst -> Bool isRegN avi = (getAVDefName avi == regn) || - (getAVDefName avi == configregn) || - (getAVDefName avi == crossregn) + (getAVDefName avi == configregn) || + (getAVDefName avi == crossregn) isRegUN :: AVInst -> Bool isRegUN avi = (getAVDefName avi == regun) || - (getAVDefName avi == configregun) || - (getAVDefName avi == crossregun) + (getAVDefName avi == configregun) || + (getAVDefName avi == crossregun) isRegA :: AVInst -> Bool isRegA avi = (getAVDefName avi == rega) || - (getAVDefName avi == configrega) || - (getAVDefName avi == crossrega) || + (getAVDefName avi == configrega) || + (getAVDefName avi == crossrega) || (getAVDefName avi == regaligned) isRegAligned :: AVInst -> Bool @@ -202,12 +202,12 @@ widthParamStr = "width" findPort :: ErrorHandle -> VName -> AVInst -> AExpr findPort errh lookupname avi@(AVInst { avi_vmi = vi, avi_iargs = es }) = let pairs :: [(VArgInfo, AExpr)] - pairs = zip (vArgs vi) es - exprs = [ e | (Port (name,props) mclk mrst, e) <- pairs, - name == lookupname ] + pairs = zip (vArgs vi) es + exprs = [ e | (Port (name,props) mclk mrst, e) <- pairs, + name == lookupname ] in case (exprs) of - [e] -> e - x ->let msg = (getPosition $ avi_type avi, + [e] -> e + x ->let msg = (getPosition $ avi_type avi, (EPortNameErrorOnImport (getVNameString $ vName vi) (getVNameString lookupname))) @@ -217,12 +217,12 @@ findPort errh lookupname avi@(AVInst { avi_vmi = vi, avi_iargs = es }) = findParam :: VName -> AVInst -> AExpr findParam lookupname (AVInst { avi_vmi = vi, avi_iargs = es }) = let pairs :: [(VArgInfo, AExpr)] - pairs = zip (vArgs vi) es - exprs = [ e | (Param name, e) <- pairs, - name == lookupname ] + pairs = zip (vArgs vi) es + exprs = [ e | (Param name, e) <- pairs, + name == lookupname ] in case (exprs) of - [e] -> e - x -> internalError ("findParam: " ++ ppReadable (lookupname, pairs)) + [e] -> e + x -> internalError ("findParam: " ++ ppReadable (lookupname, pairs)) -- ---------- -- clock and reset @@ -272,8 +272,8 @@ mkQOUT avi = mkPortNameFromFStr (getIdFString (avi_vname avi)) (promoteAVI avi) -- XXX need better comment promoteAVI avi = (setIdPosition - (getIfcIdPosition (avi_vmi avi)) - (avi_vname avi)) + (getIfcIdPosition (avi_vmi avi)) + (avi_vname avi)) -- This makes the AId, use vId (or idToVId) to make a VId mkPortName :: String -> AId -> AId @@ -286,29 +286,29 @@ mkPortNameFromFStr portname_fstr v_inst_name = let -- the following was copied from vMethId -- (is this done in order to carry along properties?) - portname_id = setIdBase (unQualId v_inst_name) portname_fstr - --portname_id = mkId noPosition portname_fstr + portname_id = setIdBase (unQualId v_inst_name) portname_fstr + --portname_id = mkId noPosition portname_fstr in - portname_id + portname_id mkPortNameFStr :: String -> AId -> FString mkPortNameFStr v_port_name v_inst_name = concatFString [getIdFString v_inst_name, - fsDollar, - mkFString v_port_name] + fsDollar, + mkFString v_port_name] -- --------------- -- Given a port name mapping (produced in ARenameIO), -- update it so that "r$Q_OUT" is shortened to just "r" updateVerilogNameMapForReg :: AVInst -> - [(FString,FString)] -> [(FString,FString)] + [(FString,FString)] -> [(FString,FString)] updateVerilogNameMapForReg avi ps = let oldname = mkPortNameFStr qoutPortStr (avi_vname avi) - newname = getIdFString (avi_vname avi) - updPair (a,b) = (a, if (b == oldname) then newname else b) + newname = getIdFString (avi_vname avi) + updPair (a,b) = (a, if (b == oldname) then newname else b) in - map updPair ps + map updPair ps -- --------------- @@ -434,13 +434,13 @@ createVerilogNameMapForAVInst :: Flags -> AVInst -> [(FString, FString)] createVerilogNameMapForAVInst flags avi@(AVInst { avi_vname = inst_id, avi_vmi = vminfo }) = let -- the default map - default_map = concatMap (createMapForVMod inst_id) (vFields vminfo) - -- create a special map for register instance (without $Q_OUT) - reg_map = updateVerilogNameMapForReg avi default_map - -- choose which to return - result = if ((removeReg flags) && (isRegInst avi) && ((not (isClockCrossingRegInst avi)) || (removeCross flags))) - then reg_map - else default_map + default_map = concatMap (createMapForVMod inst_id) (vFields vminfo) + -- create a special map for register instance (without $Q_OUT) + reg_map = updateVerilogNameMapForReg avi default_map + -- choose which to return + result = if ((removeReg flags) && (isRegInst avi) && ((not (isClockCrossingRegInst avi)) || (removeCross flags))) + then reg_map + else default_map in -- trace("result =" ++ (ppReadable result)) $ result @@ -534,8 +534,8 @@ createMapForVMod inst_id (Method meth_id _ _ mult ins mo me) = -- trace (ppReada -- mkMethId in ASyntax -- the two lists should be the same length (this is checked) createMapForOneMeth :: Id -> Integer -> - [VPort] -> Maybe VPort -> Maybe VPort -> - ([FString],[FString]) + [VPort] -> Maybe VPort -> Maybe VPort -> + ([FString],[FString]) createMapForOneMeth meth_id mult ins me mo = if check then -- trace (ppReadable (method_names, verilog_names)) $ (method_names, verilog_names) @@ -555,23 +555,23 @@ createMapForOneMeth meth_id mult ins me mo = if check then method_input_names = [ addNum meth_n arg_n | meth_n <- meth_mult, arg_n <- [1 .. length ins]] addNum fs n = - concatFString [fs, fsUnderscore, (mkNumFString (toInteger n))] + concatFString [fs, fsUnderscore, (mkNumFString (toInteger n))] -- the Verilog port names for the above verilog_input_names = map getFStringForVerilogPair ins -- names for the output port (method_output_names, verilog_output_name) = - case (mo) of - Nothing -> ([], []) - Just p -> (meth_mult, [getFStringForVerilogPair p]) + case (mo) of + Nothing -> ([], []) + Just p -> (meth_mult, [getFStringForVerilogPair p]) -- names for the enable (method_enable_names, verilog_enable_name) = - case (me) of - Nothing -> ([], []) - Just p -> (map mkEnableName meth_mult, - [getFStringForVerilogPair p]) + case (me) of + Nothing -> ([], []) + Just p -> (map mkEnableName meth_mult, + [getFStringForVerilogPair p]) mkEnableName fs = concatFString [fsEnable, fs] @@ -581,16 +581,16 @@ createMapForOneMeth meth_id mult ins me mo = if check then method_output_names verilog_names_pre_mult = - verilog_input_names ++ - verilog_enable_name ++ - verilog_output_name + verilog_input_names ++ + verilog_enable_name ++ + verilog_output_name -- handle the multiplicity for verilog names here -- note how we go from 1..mult instead of 0..mult-1 -- as the method side does verilog_names = if (mult <= 1) - then verilog_names_pre_mult - else [addNum fs n | -- PORT_N + then verilog_names_pre_mult + else [addNum fs n | -- PORT_N fs <- verilog_names_pre_mult, n <- [1..mult]] @@ -598,11 +598,11 @@ createMapForOneMeth meth_id mult ins me mo = if check then getFStringForVerilogPair :: (VName, [VeriPortProp]) -> FString getFStringForVerilogPair (vname, proplist) = let getvns vs = (verilog_cleanup $ getVNameString vs) ++ suffix - verilog_cleanup = filter isAlphaNum_ . map replace - isAlphaNum_ c = ((isAlphaNum c) || c == '_') - replace ' ' = '_' - replace '?' = 'X' - replace c = c + verilog_cleanup = filter isAlphaNum_ . map replace + isAlphaNum_ c = ((isAlphaNum c) || c == '_') + replace ' ' = '_' + replace '?' = 'X' + replace c = c -- XXX inhigh ports don't exist, so we mark them with this string, -- XXX which AVerilog looks for suffix = if (VPinhigh `elem` proplist) then "_AlwaysEnabled" else "" diff --git a/src/comp/Balanced.lhs b/src/comp/Balanced.lhs index 39d82bee2..dce1bf928 100644 --- a/src/comp/Balanced.lhs +++ b/src/comp/Balanced.lhs @@ -69,11 +69,11 @@ trees). > > left, right :: LTree a b -> LTree a b > left Start = internalError "left: empty loser tree" -> left (LLoser _ _ _ tl _ _tr) = tl -> left (RLoser _ _ _ tl _ _tr) = tl +> left (LLoser _ _ _ tl _ _tr) = tl +> left (RLoser _ _ _ tl _ _tr) = tl > right Start = internalError "right: empty loser tree" -> right (LLoser _ _ _ _tl _ tr) = tr -> right (RLoser _ _ _ _tl _ tr) = tr +> right (LLoser _ _ _ _tl _ tr) = tr +> right (RLoser _ _ _ _tl _ tr) = tr > maxKey :: PSQ k p -> k > maxKey Void = internalError "maxKey: empty queue" @@ -82,11 +82,11 @@ trees). Smart constructors. > start :: LTree k p -> start = Start +> start = Start > > lloser, rloser :: k -> p -> LTree k p -> k -> LTree k p -> LTree k p -> lloser k p tl m tr = LLoser (1 + size tl + size tr) k p tl m tr -> rloser k p tl m tr = RLoser (1 + size tl + size tr) k p tl m tr +> lloser k p tl m tr = LLoser (1 + size tl + size tr) k p tl m tr +> rloser k p tl m tr = RLoser (1 + size tl + size tr) k p tl m tr > > size :: LTree k p -> Size > size Start = 0 @@ -97,8 +97,8 @@ Smart constructors. Balance factor. -> omega :: Int -> omega = 2 +> omega :: Int +> omega = 2 > lbalance, rbalance :: Ord p => k -> p -> LTree k p -> k -> LTree k p -> LTree k p > lbalance k p l m r @@ -114,43 +114,43 @@ Balance factor. > | otherwise = rloser k p l m r > lbalanceLeft k p l m r -> | size (left r) < size (right r) = lsingleLeft k p l m r +> | size (left r) < size (right r) = lsingleLeft k p l m r > | otherwise = ldoubleLeft k p l m r > lbalanceRight k p l m r -> | size (right l) < size (left l) = lsingleRight k p l m r +> | size (right l) < size (left l) = lsingleRight k p l m r > | otherwise = ldoubleRight k p l m r > > rbalanceLeft k p l m r -> | size (left r) < size (right r) = rsingleLeft k p l m r +> | size (left r) < size (right r) = rsingleLeft k p l m r > | otherwise = rdoubleLeft k p l m r > rbalanceRight k p l m r > | size (right l) < size (left l) = rsingleRight k p l m r > | otherwise = rdoubleRight k p l m r > lsingleLeft k1 p1 t1 m1 (LLoser _ k2 p2 t2 m2 t3) -> | p1 <= p2 = lloser k1 p1 (rloser k2 p2 t1 m1 t2) m2 t3 -> | otherwise = lloser k2 p2 (lloser k1 p1 t1 m1 t2) m2 t3 +> | p1 <= p2 = lloser k1 p1 (rloser k2 p2 t1 m1 t2) m2 t3 +> | otherwise = lloser k2 p2 (lloser k1 p1 t1 m1 t2) m2 t3 > lsingleLeft k1 p1 t1 m1 (RLoser _ k2 p2 t2 m2 t3) -> = rloser k2 p2 (lloser k1 p1 t1 m1 t2) m2 t3 +> = rloser k2 p2 (lloser k1 p1 t1 m1 t2) m2 t3 > lsingleLeft _ _ _ _ Start = internalError "lsingleLeft" > > rsingleLeft k1 p1 t1 m1 (LLoser _ k2 p2 t2 m2 t3) -> = rloser k1 p1 (rloser k2 p2 t1 m1 t2) m2 t3 +> = rloser k1 p1 (rloser k2 p2 t1 m1 t2) m2 t3 > rsingleLeft k1 p1 t1 m1 (RLoser _ k2 p2 t2 m2 t3) -> = rloser k2 p2 (rloser k1 p1 t1 m1 t2) m2 t3 +> = rloser k2 p2 (rloser k1 p1 t1 m1 t2) m2 t3 > rsingleLeft _ _ _ _ Start = internalError "rsingleLeft" > > lsingleRight k1 p1 (LLoser _ k2 p2 t1 m1 t2) m2 t3 -> = lloser k2 p2 t1 m1 (lloser k1 p1 t2 m2 t3) +> = lloser k2 p2 t1 m1 (lloser k1 p1 t2 m2 t3) > lsingleRight k1 p1 (RLoser _ k2 p2 t1 m1 t2) m2 t3 -> = lloser k1 p1 t1 m1 (lloser k2 p2 t2 m2 t3) +> = lloser k1 p1 t1 m1 (lloser k2 p2 t2 m2 t3) > lsingleRight _ _ Start _ _ = internalError "lsingleRight" > > rsingleRight k1 p1 (LLoser _ k2 p2 t1 m1 t2) m2 t3 -> = lloser k2 p2 t1 m1 (rloser k1 p1 t2 m2 t3) +> = lloser k2 p2 t1 m1 (rloser k1 p1 t2 m2 t3) > rsingleRight k1 p1 (RLoser _ k2 p2 t1 m1 t2) m2 t3 -> | p1 <= p2 = rloser k1 p1 t1 m1 (lloser k2 p2 t2 m2 t3) -> | otherwise = rloser k2 p2 t1 m1 (rloser k1 p1 t2 m2 t3) +> | p1 <= p2 = rloser k1 p1 t1 m1 (lloser k2 p2 t2 m2 t3) +> | otherwise = rloser k2 p2 t1 m1 (rloser k1 p1 t2 m2 t3) > rsingleRight _ _ Start _ _ = internalError "rsingleRight" > ldoubleLeft k1 p1 t1 m1 (LLoser _ k2 p2 t2 m2 t3) @@ -222,8 +222,8 @@ Tournament view. > > single (k :-> p) = single' k p > -> single' :: k -> p -> PSQ k p -> single' k p = Winner k p start k +> single' :: k -> p -> PSQ k p +> single' k p = Winner k p start k > > insert b q = case tourView q of > Null -> single b @@ -256,9 +256,9 @@ Determining the second-best player. > secondBest :: (Ord k, Ord p) => LTree k p -> k -> PSQ k p > secondBest Start _m = Void > secondBest (LLoser _ k p tl m tr) m' -> = Winner k p tl m `play` secondBest tr m' +> = Winner k p tl m `play` secondBest tr m' > secondBest (RLoser _ k p tl m tr) m' -> = secondBest tl m `play` Winner k p tr m' +> = secondBest tl m `play` Winner k p tr m' \paragraph{Observers} @@ -279,23 +279,23 @@ Determining the second-best player. > Single k p -> s_single (k :-> p) > tl `Play` tr -> toOrdLists tl <> toOrdLists tr > -> atMost pt q = toList (atMosts pt q) +> atMost pt q = toList (atMosts pt q) > > atMosts :: Ord p => p -> PSQ k p -> Sequ (Binding k p) > atMosts _pt Void = s_empty > atMosts pt (Winner k p t _) = prune k p t > where > prune k p t -> | p > pt = s_empty +> | p > pt = s_empty > | otherwise = traverse k p t > traverse k p Start = s_single (k :-> p) > traverse k p (LLoser _ k' p' tl _m tr) -> = prune k' p' tl <> traverse k p tr +> = prune k' p' tl <> traverse k p tr > traverse k p (RLoser _ k' p' tl _m tr) > = traverse k p tl <> prune k' p' tr > > -> atMostRange pt (kl, kr) q = toList (atMostRanges pt (kl, kr) q) +> atMostRange pt (kl, kr) q = toList (atMostRanges pt (kl, kr) q) > atMostRanges :: (Ord k, Ord p) => p -> (k, k) -> PSQ k p -> Sequ (Binding k p) > atMostRanges _pt _range Void = s_empty @@ -303,16 +303,16 @@ Determining the second-best player. > = prune k p t > where > prune k p t -> | p > pt = s_empty +> | p > pt = s_empty > | otherwise = traverse k p t > traverse k p Start -> | k `inrange` range = s_single (k :-> p) +> | k `inrange` range = s_single (k :-> p) > | otherwise = s_empty > traverse k p (LLoser _ k' p' tl m tr) > = guard (kl <= m) (prune k' p' tl) > <> guard (m <= kr) (traverse k p tr) > traverse k p (RLoser _ k' p' tl m tr) -> = guard (kl <= m) (traverse k p tl) +> = guard (kl <= m) (traverse k p tl) > <> guard (m <= kr) (prune k' p' tr) \paragraph{Modifier} @@ -349,8 +349,8 @@ Folding a list in a binary-subdivision scheme. > (a1, as1) = rec (n - m) as > (a2, as2) = rec m as1 -> inrange :: (Ord a) => a -> (a, a) -> Bool -> a `inrange` (l, r) = l <= a && a <= r +> inrange :: (Ord a) => a -> (a, a) -> Bool +> a `inrange` (l, r) = l <= a && a <= r --------------- Sequ --------------- @@ -371,7 +371,7 @@ Folding a list in a binary-subdivision scheme. % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - > {- -> newtype Sequ a = Sequ ([a] -> [a]) +> newtype Sequ a = Sequ ([a] -> [a]) > > s_empty = Sequ (\as -> as) > @@ -386,13 +386,13 @@ Folding a list in a binary-subdivision scheme. > toList (Sequ x) = x [] > -} > -> data Sequ a = SEmpty | SUnit a | SFork (Sequ a) (Sequ a) +> data Sequ a = SEmpty | SUnit a | SFork (Sequ a) (Sequ a) > > s_empty = SEmpty > > s_single a = SUnit a > -> x1 <> x2 = SFork x1 x2 +> x1 <> x2 = SFork x1 x2 > > -- fromList xs = foldr (<>) SEmpty (map s_single xs) > diff --git a/src/comp/BinParse.hs b/src/comp/BinParse.hs index c32b57815..7158d77c9 100644 --- a/src/comp/BinParse.hs +++ b/src/comp/BinParse.hs @@ -20,18 +20,18 @@ binop fix bin op atom = (atom >>- (:[])) `into` opsO [] end _ _ = internalError "binop parse: bad operand stack" newop [] as iop = opsA [iop] as newop oos@(sop:os) as@(~(a:b:as')) iop = - let (iprec,iass) = prec iop - (sprec,sass) = prec sop - in if iprec==sprec && (iass/=sass || iass==FInfix iprec) then - failure "proper operator combination" - else if iprec>sprec || iprec==sprec && iass==FInfixr iprec then - opsA (iop:oos) as - else - newop os (bin b sop a : as') iop + let (iprec,iass) = prec iop + (sprec,sass) = prec sop + in if iprec==sprec && (iass/=sass || iass==FInfix iprec) then + failure "proper operator combination" + else if iprec>sprec || iprec==sprec && iass==FInfixr iprec then + opsA (iop:oos) as + else + newop os (bin b sop a : as') iop prec o = - case fix o of - f@(FInfixl i) -> (i, f) - f@(FInfixr i) -> (i, f) - f@(FInfix i) -> (i, f) + case fix o of + f@(FInfixl i) -> (i, f) + f@(FInfixr i) -> (i, f) + f@(FInfix i) -> (i, f) f -> internalError("BinParse :: prec unexpected pattern") diff --git a/src/comp/BoolExp.hs b/src/comp/BoolExp.hs index 5f499a8db..1731764c4 100644 --- a/src/comp/BoolExp.hs +++ b/src/comp/BoolExp.hs @@ -15,14 +15,14 @@ import qualified Data.Set as S data BoolExp a - = And (BoolExp a) (BoolExp a) - | Or (BoolExp a) (BoolExp a) - | Not (BoolExp a) - | If (BoolExp a) (BoolExp a) (BoolExp a) - | Var a - | TT - | FF - deriving (Eq, Ord) + = And (BoolExp a) (BoolExp a) + | Or (BoolExp a) (BoolExp a) + | Not (BoolExp a) + | If (BoolExp a) (BoolExp a) (BoolExp a) + | Var a + | TT + | FF + deriving (Eq, Ord) --iF :: BoolExp a -> BoolExp a -> BoolExp a -> BoolExp a --iF c t e = (c `And` t) `Or` (Not c `And` e) @@ -46,20 +46,20 @@ substBE v n e = e -} instance (Show a) => Show (BoolExp a) where - show e = pp e + show e = pp e pp :: (Show a) => BoolExp a -> String pp e = pp' (0::Integer) e where pp' p (e1 `And` e2) = paren (p>3) (pp' 3 e1 ++ " & " ++ pp' 3 e2) - pp' p (e1 `Or` e2) = paren (p>2) (pp' 2 e1 ++ " | " ++ pp' 2 e2) - pp' p (If e1 e2 e3) = paren (p>1) (pp' 1 e1 ++ " ? " ++ pp' 1 e2 ++ " : " ++ pp' 1 e3) - pp' _ (Not e) = "~" ++ pp' 10 e - pp' _ (Var v) = show v - pp' _ TT = "T" - pp' _ FF = "F" + pp' p (e1 `Or` e2) = paren (p>2) (pp' 2 e1 ++ " | " ++ pp' 2 e2) + pp' p (If e1 e2 e3) = paren (p>1) (pp' 1 e1 ++ " ? " ++ pp' 1 e2 ++ " : " ++ pp' 1 e3) + pp' _ (Not e) = "~" ++ pp' 10 e + pp' _ (Var v) = show v + pp' _ TT = "T" + pp' _ FF = "F" - paren True s = "("++s++")" - paren False s = s + paren True s = "("++s++")" + paren False s = s instance (PPrint a) => PPrint (BoolExp a) where pPrint d p (e1 `And` e2) = pparen (p>3) (pPrint d 3 e1 <+> text "&" <+> pPrint d 3 e2) @@ -84,7 +84,7 @@ reduce (And e1 e2) | e1 == e2 = Just e1 reduce (And e1 e2) | e1 == bNot e2 = Just FF reduce e@(And _ _) = me' where me' = fmap (rrAnds . reverse) (redAnd False S.empty [] es) - es = collAnd e + es = collAnd e reduce (Or TT e) = Just TT reduce (Or FF e) = Just e @@ -100,7 +100,7 @@ reduce (Or e1 e2) | e1 == e2 = Just e1 reduce (Or e1 e2) | e1 == bNot e2 = Just TT reduce e@(Or _ _) = me' where me' = fmap (rrOrs . reverse) (redOr False S.empty [] es) - es = collOr e + es = collOr e reduce (Not (And e1 e2)) = Just (Or (rNot e1) (rNot e2)) reduce (Not (Or e1 e2)) = Just (And (rNot e1) (rNot e2)) @@ -125,12 +125,12 @@ reduce _ = Nothing redAnd change s rs [] = toMaybe change rs redAnd change s rs (e:es) = if e `S.member` s then redAnd True s rs es else if Not e `S.member` s then Just [FF] - else redAnd change (S.insert e s) (e:rs) es + else redAnd change (S.insert e s) (e:rs) es redOr change s rs [] = toMaybe change rs redOr change s rs (e:es) = if e `S.member` s then redOr True s rs es else if Not e `S.member` s then Just [TT] - else redOr change (S.insert e s) (e:rs) es + else redOr change (S.insert e s) (e:rs) es foldrx f z [] = z foldrx f z [x] = x @@ -170,25 +170,25 @@ rrNot e = Not e -- simple simplify sSimplify :: (Ord a) => BoolExp a -> BoolExp a sSimplify (And e1 e2) = - let e' = And (sSimplify e1) (sSimplify e2) in - case reduce e' of - Just e -> sSimplify e - Nothing -> e' + let e' = And (sSimplify e1) (sSimplify e2) in + case reduce e' of + Just e -> sSimplify e + Nothing -> e' sSimplify (Or e1 e2) = - let e' = Or (sSimplify e1) (sSimplify e2) in - case reduce e' of - Just e -> sSimplify e - Nothing -> e' + let e' = Or (sSimplify e1) (sSimplify e2) in + case reduce e' of + Just e -> sSimplify e + Nothing -> e' sSimplify (If e1 e2 e3) = - let e' = If (sSimplify e1) (sSimplify e2) (sSimplify e3) in - case reduce e' of - Just e -> sSimplify e - Nothing -> e' + let e' = If (sSimplify e1) (sSimplify e2) (sSimplify e3) in + case reduce e' of + Just e -> sSimplify e + Nothing -> e' sSimplify (Not e) = - let e' = Not (sSimplify e) in - case reduce e' of - Just e -> sSimplify e - Nothing -> e' + let e' = Not (sSimplify e) in + case reduce e' of + Just e -> sSimplify e + Nothing -> e' sSimplify e@(Var _) = e sSimplify TT = TT sSimplify FF = FF @@ -197,23 +197,23 @@ sSimplify FF = FF nSimplify :: (Ord a) => BoolExp a -> BoolExp a nSimplify = sSimplify . nSimp . sSimplify where nSimp (And e1 e2) = - -- (x || y || z) && !y --> (x || z) && !y - simpAO collAnd collOr rrAnds rrOrs e1 e2 - nSimp (Or e1 e2) = - -- (x && y && z) || !y --> (x && z) || !y - simpAO collOr collAnd rrOrs rrAnds e1 e2 - nSimp (Not e) = Not (nSimp e) - nSimp (If c t e) = If (nSimp c) (nSimp t) (nSimp e) - nSimp e = e - simpAO cA cO rA rO e1 e2 = - let es = cA (nSimp e1) ++ cA (nSimp e2) - ess = map cO es - ess' = red S.empty [] ess - red remSet rss [] = reverse (map (rem remSet) rss) - red remSet rss ([e]:ess) = let e' = rrNot e in red (S.insert e' remSet) ([e]:rss) ess - red remSet rss (es:ess) = red remSet (es:rss) ess - rem remSet es = filter (\e -> not (S.member e remSet)) es - in rA (map rO ess') + -- (x || y || z) && !y --> (x || z) && !y + simpAO collAnd collOr rrAnds rrOrs e1 e2 + nSimp (Or e1 e2) = + -- (x && y && z) || !y --> (x && z) || !y + simpAO collOr collAnd rrOrs rrAnds e1 e2 + nSimp (Not e) = Not (nSimp e) + nSimp (If c t e) = If (nSimp c) (nSimp t) (nSimp e) + nSimp e = e + simpAO cA cO rA rO e1 e2 = + let es = cA (nSimp e1) ++ cA (nSimp e2) + ess = map cO es + ess' = red S.empty [] ess + red remSet rss [] = reverse (map (rem remSet) rss) + red remSet rss ([e]:ess) = let e' = rrNot e in red (S.insert e' remSet) ([e]:rss) ess + red remSet rss (es:ess) = red remSet (es:rss) ess + rem remSet es = filter (\e -> not (S.member e remSet)) es + in rA (map rO ess') -- "Advanced" simplify aSimplify :: (Ord a) => BoolExp a -> BoolExp a @@ -234,29 +234,29 @@ simp bdd e = -- r= let e' = boolExpToBDD e in if bddIsTrue (bddImplies bdd e') then - TT - else if bddIsTrue (bddImplies bdd (bddNot e')) then - FF - else - red $ - case e of - And e1 e2 -> - let e1' = boolExpToBDD e1 - e2' = boolExpToBDD e2 - in if implies bdd e1' e2' then simp bdd e1 - else if implies bdd e2' e1' then simp bdd e2 - else And (simp (bddAnd bdd e2') e1) (simp (bddAnd bdd e1') e2) - Or e1 e2 -> - let e1' = bddNot (boolExpToBDD e1) - e2' = bddNot (boolExpToBDD e2) - in if implies bdd e1' e2' then simp bdd e1 - else if implies bdd e2' e1' then simp bdd e2 - else Or (simp (bddAnd bdd e2') e1) (simp (bddAnd bdd e1') e2) - Not e -> Not (simp bdd e) - If e1 e2 e3 -> - let e1' = boolExpToBDD e1 - in If (simp bdd e1) (simp (bddAnd bdd e1') e2) (simp (bddAnd bdd (bddNot e1')) e3) - e -> e + TT + else if bddIsTrue (bddImplies bdd (bddNot e')) then + FF + else + red $ + case e of + And e1 e2 -> + let e1' = boolExpToBDD e1 + e2' = boolExpToBDD e2 + in if implies bdd e1' e2' then simp bdd e1 + else if implies bdd e2' e1' then simp bdd e2 + else And (simp (bddAnd bdd e2') e1) (simp (bddAnd bdd e1') e2) + Or e1 e2 -> + let e1' = bddNot (boolExpToBDD e1) + e2' = bddNot (boolExpToBDD e2) + in if implies bdd e1' e2' then simp bdd e1 + else if implies bdd e2' e1' then simp bdd e2 + else Or (simp (bddAnd bdd e2') e1) (simp (bddAnd bdd e1') e2) + Not e -> Not (simp bdd e) + If e1 e2 e3 -> + let e1' = boolExpToBDD e1 + in If (simp bdd e1) (simp (bddAnd bdd e1') e2) (simp (bddAnd bdd (bddNot e1')) e3) + e -> e -- in traces (ppReadable e ++ "====>\n" ++ ppReadable r) r ------------ @@ -276,10 +276,10 @@ boolExpToBDD :: (Ord a) => BoolExp a -> BDD a boolExpToBDD (And e1 e2) = bddAnd (boolExpToBDD e1) (boolExpToBDD e2) boolExpToBDD (Or e1 e2) = bddOr (boolExpToBDD e1) (boolExpToBDD e2) boolExpToBDD (If e1 e2 e3) = - let e1' = boolExpToBDD e1 - e2' = boolExpToBDD e2 - e3' = boolExpToBDD e3 - in (e1' `bddAnd` e2') `bddOr` (bddNot e1' `bddAnd` e3') + let e1' = boolExpToBDD e1 + e2' = boolExpToBDD e2 + e3' = boolExpToBDD e3 + in (e1' `bddAnd` e2') `bddOr` (bddNot e1' `bddAnd` e3') boolExpToBDD (Not e) = bddNot (boolExpToBDD e) boolExpToBDD (Var v) = bddVar v boolExpToBDD TT = bddTrue diff --git a/src/comp/BoolOpt.hs b/src/comp/BoolOpt.hs index 5dc8a5b83..e8d0155c1 100644 --- a/src/comp/BoolOpt.hs +++ b/src/comp/BoolOpt.hs @@ -76,7 +76,7 @@ optBoolExprQM n e = let (grps', us) = unzip (sweep step grps) in loop (concat grps' ++ all) (nub (concat us) ++ marked) (filter (not . null) grps') - prime = loop (concat grps) [] grps -- prime implicants + prime = loop (concat grps) [] grps -- prime implicants selPrimes sel cprime [] = sel selPrimes sel [] _ = internalError "selPrimes" diff --git a/src/comp/CFreeVars.hs b/src/comp/CFreeVars.hs index 0ca224e85..78e399256 100644 --- a/src/comp/CFreeVars.hs +++ b/src/comp/CFreeVars.hs @@ -413,10 +413,10 @@ getFVDl (CLValueSign def qs) = -- the "qs" are implicit condition for methods, -- so there is no binding there that can affect "def", -- thus we don't remove the variables bound there - getFVQuals qs `unionFVS` getFVD def + getFVQuals qs `unionFVS` getFVD def getFVDl (CLValue _ cs qs) = -- as above, we don't subtract the vars bound in "qs" - unionManyFVS (getFVQuals qs : map getFVC cs) + unionManyFVS (getFVQuals qs : map getFVC cs) getFVDl (CLMatch p e) = -- here, we do want to remove any vars bound in the pattern getFVE e `minusVS` getPV p @@ -429,16 +429,16 @@ getFVD (CDefT _ _ _ cs) = unionManyFVS (map getFVC cs) getFVC :: CClause -> FVSet getFVC (CClause ps qs e) = - let bvs = getVQuals qs `S.union` getPVs ps - in ((getFVQuals qs `unionFVS` getFVE e) `minusVS` bvs) `plusCS` getPCs ps + let bvs = getVQuals qs `S.union` getPVs ps + in ((getFVQuals qs `unionFVS` getFVE e) `minusVS` bvs) `plusCS` getPCs ps getFVR :: CRule -> FVSet getFVR (CRule _ n qs e) = - let bvs = getVQuals qs - in getMFVE n `unionFVS` ((getFVQuals qs `unionFVS` getFVE e) `minusVS` bvs) + let bvs = getVQuals qs + in getMFVE n `unionFVS` ((getFVQuals qs `unionFVS` getFVE e) `minusVS` bvs) getFVR (CRuleNest _ n qs rs) = - let bvs = getVQuals qs - in getMFVE n `unionFVS` ((getFVQuals qs `unionFVS` unionManyFVS (map getFVR rs)) `minusVS` bvs) + let bvs = getVQuals qs + in getMFVE n `unionFVS` ((getFVQuals qs `unionFVS` unionManyFVS (map getFVR rs)) `minusVS` bvs) getMFVE :: Maybe CExpr -> FVSet getMFVE Nothing = emptyFVS @@ -460,9 +460,9 @@ getFTCC (CClause ps qs e) = getFTCR :: CRule -> S.Set Id getFTCR (CRule _ n qs e) = - getMFTC n `S.union` (getFTCQuals qs `S.union` getFTCE e) + getMFTC n `S.union` (getFTCQuals qs `S.union` getFTCE e) getFTCR (CRuleNest _ n qs rs) = - getMFTC n `S.union` (getFTCQuals qs `S.union` S.unions (map getFTCR rs)) + getMFTC n `S.union` (getFTCQuals qs `S.union` S.unions (map getFTCR rs)) getMFTC Nothing = S.empty getMFTC (Just e) = getFTCE e diff --git a/src/comp/CSyntax.hs b/src/comp/CSyntax.hs index 350759b12..a7b7b25a6 100644 --- a/src/comp/CSyntax.hs +++ b/src/comp/CSyntax.hs @@ -1,70 +1,70 @@ {-# LANGUAGE CPP #-} module CSyntax( - CPackage(..), - CSignature(..), - CExpr(..), - CCaseArm(..), - CCaseArms, - CType, - TyVar(..), - TyCon(..), - Kind(..), - PartialKind(..), - CImport(..), - CInclude(..), - CQual(..), - CClause(..), - CPat(..), - Literal(..), - Type(..), - TISort(..), - CQType(..), - CDef(..), - CExport(..), - CRule(..), - CDefn(..), - CDefl(..), - CFunDeps, - CPred(..), + CPackage(..), + CSignature(..), + CExpr(..), + CCaseArm(..), + CCaseArms, + CType, + TyVar(..), + TyCon(..), + Kind(..), + PartialKind(..), + CImport(..), + CInclude(..), + CQual(..), + CClause(..), + CPat(..), + Literal(..), + Type(..), + TISort(..), + CQType(..), + CDef(..), + CExport(..), + CRule(..), + CDefn(..), + CDefl(..), + CFunDeps, + CPred(..), CTypeclass(..), - CField(..), - CFields, - CStmt(..), + CField(..), + CFields, + CStmt(..), CStmts, - IdK(..), - CLiteral(..), - CMStmt(..), - COp(..), - CPOp(..), - CFixity(..), - RulePragma(..), - xWrapperModuleVerilog, + IdK(..), + CLiteral(..), + CMStmt(..), + COp(..), + CPOp(..), + CFixity(..), + RulePragma(..), + xWrapperModuleVerilog, xClassicModuleVerilog, CInternalSummand(..), CSummands, getCISName, COriginalSummand(..), COSummands, getCOSName, - cApply, - cmtApply, - cTApplys, - cTCon, - cTVar, - leftCon, - anyExpr, - anyExprAt, - anyTExpr, - noType, - cTApply, - iKName, - impName, + cApply, + cmtApply, + cTApplys, + cTCon, + cTVar, + leftCon, + anyExpr, + anyExprAt, + anyTExpr, + noType, + cTApply, + iKName, + impName, cVar, - cVApply, - getName, - getLName, - getDName, - isTDef, - getNK, + cVApply, + getName, + getLName, + getDName, + isTDef, + getNK, isCQFilter, - HasPosition(..), - StructSubType(..)) where + HasPosition(..), + StructSubType(..)) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804) import Prelude hiding ((<>)) @@ -102,92 +102,92 @@ data CPackage = CPackage -- Right exps = export everything but exps [CImport] -- imported identifiers [CFixity] -- fixity declarations for infix operators - [CDefn] -- top level definitions + [CDefn] -- top level definitions [CInclude] -- any `include files - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show) data CExport - = CExpVar Id -- export a variable identifier + = CExpVar Id -- export a variable identifier | CExpCon Id -- export a constructor - | CExpConAll Id -- export an identifier and constructors + | CExpConAll Id -- export an identifier and constructors -- (datatypes, interfaces, etc.) - | CExpPkg Id -- export an entire package - deriving (Eq, Ord, Show) + | CExpPkg Id -- export an entire package + deriving (Eq, Ord, Show) data CImport - = CImpId Bool Id -- Bool indicates qualified - | CImpSign String Bool CSignature - deriving (Eq, Ord, Show) + = CImpId Bool Id -- Bool indicates qualified + | CImpSign String Bool CSignature + deriving (Eq, Ord, Show) -- Package signature from import data CSignature - = CSignature Id [Id] [CFixity] [CDefn] -- package name, imported packages, definitions - deriving (Eq, Ord, Show) + = CSignature Id [Id] [CFixity] [CDefn] -- package name, imported packages, definitions + deriving (Eq, Ord, Show) data CFixity - = CInfix Integer Id - | CInfixl Integer Id - | CInfixr Integer Id - deriving (Eq, Ord, Show) + = CInfix Integer Id + | CInfixl Integer Id + | CInfixr Integer Id + deriving (Eq, Ord, Show) -- Top level definition data CDefn - = Ctype IdK [Id] CType + = Ctype IdK [Id] CType | Cdata { cd_visible :: Bool, cd_name :: IdK, cd_type_vars :: [Id], cd_original_summands :: COSummands, cd_internal_summands :: CSummands, cd_derivings :: [CTypeclass] } - | Cstruct Bool StructSubType IdK [Id] CFields - [CTypeclass] + | Cstruct Bool StructSubType IdK [Id] CFields + [CTypeclass] -- Bool indicates the constrs are visible -- first [Id] are the names of this definition's argument type variables -- last [CTypeclass] are derived classes -- incoherent_matches superclasses name_with_kind variables fundeps default_methods - | Cclass (Maybe Bool) [CPred] IdK [Id] CFunDeps CFields - | Cinstance CQType [CDefl] - | CValue Id [CClause] - | CValueSign CDef - | Cforeign { cforg_name :: Id, - cforg_type :: CQType, - cforg_foreign_name :: Maybe String, - cforg_ports :: Maybe ([String], [String]) } - | Cprimitive Id CQType - | CprimType IdK - | CPragma Pragma - -- only in package signatures - | CIinstance Id CQType + | Cclass (Maybe Bool) [CPred] IdK [Id] CFunDeps CFields + | Cinstance CQType [CDefl] + | CValue Id [CClause] + | CValueSign CDef + | Cforeign { cforg_name :: Id, + cforg_type :: CQType, + cforg_foreign_name :: Maybe String, + cforg_ports :: Maybe ([String], [String]) } + | Cprimitive Id CQType + | CprimType IdK + | CPragma Pragma + -- only in package signatures + | CIinstance Id CQType -- CItype is imported abstractly - | CItype IdK [Id] [Position] -- positions of use that caused export - | CIclass (Maybe Bool) [CPred] IdK [Id] CFunDeps [Position] -- positions of use that caused export - | CIValueSign Id CQType + | CItype IdK [Id] [Position] -- positions of use that caused export + | CIclass (Maybe Bool) [CPred] IdK [Id] CFunDeps [Position] -- positions of use that caused export + | CIValueSign Id CQType deriving (Eq, Ord, Show) -- Since IdPKind is only expected in some disjuncts of CDefn, we could -- create a separate IdPK for those cases, but that seems like overkill. -- IdPKind in other locations will just be treated like IdK (no kind info). data IdK - = IdK Id - | IdKind Id Kind - -- this should not exist after typecheck - | IdPKind Id PartialKind + = IdK Id + | IdKind Id Kind + -- this should not exist after typecheck + | IdPKind Id PartialKind deriving (Eq, Ord, Show) type CFunDeps = [([Id],[Id])] -- Expressions data CExpr - = CLam (Either Position Id) CExpr - | CLamT (Either Position Id) CQType CExpr + = CLam (Either Position Id) CExpr + | CLamT (Either Position Id) CQType CExpr | Cletseq [CDefl] CExpr -- rhs of "let x = x" refers to previous def -- before current let or in earlier arm | Cletrec [CDefl] CExpr -- rhs of "let x = x" refers to self - | CSelect CExpr Id -- expr, field id - | CCon Id [CExpr] -- constructor id, arguments + | CSelect CExpr Id -- expr, field id + | CCon Id [CExpr] -- constructor id, arguments | Ccase Position CExpr CCaseArms - | CStruct Id [(Id, CExpr)] - | CStructUpd CExpr [(Id, CExpr)] + | CStruct Id [(Id, CExpr)] + | CStructUpd CExpr [(Id, CExpr)] -- for hardware writes -- lhs <= rhs @@ -199,61 +199,61 @@ data CExpr | CTaskApply CExpr [CExpr] -- system task calls | CTaskApplyT CExpr CType [CExpr] -- type-checked $task (only $display) calls (the type is the inferred function type for the varargs task) | CLit CLiteral - | CBinOp CExpr Id CExpr - | CHasType CExpr CQType + | CBinOp CExpr Id CExpr + | CHasType CExpr CQType | Cif Position CExpr CExpr CExpr -- x[a] - | CSub Position CExpr CExpr + | CSub Position CExpr CExpr -- x[a:b] - | CSub2 CExpr CExpr CExpr + | CSub2 CExpr CExpr CExpr -- x[a:b] = y | CSubUpdate Position CExpr (CExpr, CExpr) CExpr - | Cmodule Position [CMStmt] - | Cinterface Position (Maybe Id) [CDefl] - | CmoduleVerilog + | Cmodule Position [CMStmt] + | Cinterface Position (Maybe Id) [CDefl] + | CmoduleVerilog CExpr -- expr for the module name (type String) Bool -- whether it is a user-imported module - VClockInfo -- clocks - VResetInfo -- resets - [(VArgInfo,CExpr)] -- input arguments - [VFieldInfo] -- output interface fields - VSchedInfo -- scheduling annotations - VPathInfo -- path annotations - | CForeignFuncC Id CQType -- link name, wrapped type - | Cdo Bool CStmts -- Bool indicates recursive binding - | Caction Position CStmts - | Crules [CSchedulePragma] [CRule] - | CADump [CExpr] - -- used before operator parsing - | COper [COp] - -- from deriving - | CCon1 Id Id CExpr -- type id, con id, expr - | CSelectTT Id CExpr Id -- type id, expr, field id - -- INTERNAL in type checker - | CCon0 (Maybe Id) Id -- type id, constructor id - -- Not part of the surface syntax, used after type checking - | CConT Id Id [CExpr] -- type id, constructor id, arguments - | CStructT CType [(Id, CExpr)] - | CSelectT Id Id -- type id, field id + VClockInfo -- clocks + VResetInfo -- resets + [(VArgInfo,CExpr)] -- input arguments + [VFieldInfo] -- output interface fields + VSchedInfo -- scheduling annotations + VPathInfo -- path annotations + | CForeignFuncC Id CQType -- link name, wrapped type + | Cdo Bool CStmts -- Bool indicates recursive binding + | Caction Position CStmts + | Crules [CSchedulePragma] [CRule] + | CADump [CExpr] + -- used before operator parsing + | COper [COp] + -- from deriving + | CCon1 Id Id CExpr -- type id, con id, expr + | CSelectTT Id CExpr Id -- type id, expr, field id + -- INTERNAL in type checker + | CCon0 (Maybe Id) Id -- type id, constructor id + -- Not part of the surface syntax, used after type checking + | CConT Id Id [CExpr] -- type id, constructor id, arguments + | CStructT CType [(Id, CExpr)] + | CSelectT Id Id -- type id, field id | CLitT CType CLiteral | CAnyT Position UndefKind CType - | CmoduleVerilogT CType + | CmoduleVerilogT CType CExpr -- expr for the module name (type String) Bool -- whether it is a user-imported module - VClockInfo -- clocks - VResetInfo -- resets - [(VArgInfo,CExpr)] -- input arguments - [VFieldInfo] -- output interface fields - VSchedInfo -- scheduling annotations - VPathInfo -- path annotations - | CForeignFuncCT Id CType -- link name, primitive type - | CTApply CExpr [CType] + VClockInfo -- clocks + VResetInfo -- resets + [(VArgInfo,CExpr)] -- input arguments + [VFieldInfo] -- output interface fields + VSchedInfo -- scheduling annotations + VPathInfo -- path annotations + | CForeignFuncCT Id CType -- link name, primitive type + | CTApply CExpr [CType] -- for passing pprops as values | Cattributes [(Position,PProp)] deriving (Ord, Show) instance Hyper CExpr where - hyper x y = (x==x) `seq` y -- XXX + hyper x y = (x==x) `seq` y -- XXX -- ignore positions when testing equality instance Eq CExpr where @@ -359,19 +359,19 @@ instance Eq CExpr where -- function called by the Classic parser to create a CmoduleVerilog -- from a Classic "module verilog" (imported Verilog module) xClassicModuleVerilog :: CExpr -> [(String, CExpr)] -> - [String] -> [String] -> - [(String, ([VeriPortProp], CExpr))] -> - [VFieldInfo] -> VSchedInfo -> VPathInfo -> - CExpr + [String] -> [String] -> + [(String, ([VeriPortProp], CExpr))] -> + [VFieldInfo] -> VSchedInfo -> VPathInfo -> + CExpr xClassicModuleVerilog m params clocks resets ports methodinfo schedinfo pathinfo = -- get the current clock and reset and connect them to the imported module Cmodule (getPosition m) (clock_stmt ++ reset_stmt ++ [CMStmt (CSExpr Nothing - (xCmoduleVerilog m True -- it's a user import - (WireInfo clock_info reset_info arg_info) - args methodinfo' schedinfo pathinfo))]) + (xCmoduleVerilog m True -- it's a user import + (WireInfo clock_info reset_info arg_info) + args methodinfo' schedinfo pathinfo))]) where param_ais = map (Param . VName . fst) params param_args = map snd params port_clock = case clock_names of @@ -395,12 +395,12 @@ xClassicModuleVerilog m params clocks resets ports methodinfo schedinfo pathinfo clock_names = map (addIdSuffix idClk) [1..(genericLength clocks)] clock_ais = map ClockArg clock_names default_clk = listToMaybe clock_names -- Nothing if no clocks - -- a single actual clock - no gating ancestors or siblings - -- (The clock gate property is False, just to make life easier, - -- because all module-verilog in the libs don't care about the gate) + -- a single actual clock - no gating ancestors or siblings + -- (The clock gate property is False, just to make life easier, + -- because all module-verilog in the libs don't care about the gate) clock_info = - let mkInputClockInf i s = (i, Just (VName s, Left False)) - in ClockInfo (zipWith mkInputClockInf clock_names clocks) [] [] [] + let mkInputClockInf i s = (i, Just (VName s, Left False)) + in ClockInfo (zipWith mkInputClockInf clock_names clocks) [] [] [] reset_stmt = if (null resets) @@ -413,8 +413,8 @@ xClassicModuleVerilog m params clocks resets ports methodinfo schedinfo pathinfo reset_ais = map ResetArg reset_names -- Classic modules should have resets synchronized with their clock (if any) reset_info = - let mkInputResetInf i s = (i, (Just (VName s), default_clk)) - in ResetInfo (zipWith mkInputResetInf reset_names resets) [] + let mkInputResetInf i s = (i, (Just (VName s), default_clk)) + in ResetInfo (zipWith mkInputResetInf reset_names resets) [] default_rst = listToMaybe reset_names -- Nothing if no resets arg_info = clock_ais ++ reset_ais ++ param_ais ++ port_ais @@ -434,35 +434,35 @@ xClassicModuleVerilog m params clocks resets ports methodinfo schedinfo pathinfo -- The wrapped CmoduleVerilog is marked as not being a user import -- (since it's a synthesized module from Bluespec source). xWrapperModuleVerilog :: Bool -> [PProp] -> CExpr -> VWireInfo -> [CExpr] -> - [VFieldInfo] -> VSchedInfo -> VPathInfo -> - CExpr + [VFieldInfo] -> VSchedInfo -> VPathInfo -> + CExpr xWrapperModuleVerilog True pps m wireinfo args fields schedinfo pathinfo = -- it's a foreign function, which needs to clock or reset xCmoduleVerilog m False wireinfo args fields schedinfo pathinfo xWrapperModuleVerilog False pps m wireinfo args fields schedinfo pathinfo = let (args1,stmts1) = if (hasDefaultClk pps) - then ([CVar idClk], - [CMStmt (bindVarT idClk tClock (CVar idExposeCurrentClock))]) - else ([],[]) + then ([CVar idClk], + [CMStmt (bindVarT idClk tClock (CVar idExposeCurrentClock))]) + else ([],[]) (args2,stmts2) = - if (hasDefaultRst pps) - then ([CVar idRst], - [CMStmt (bindVarT idRst tReset (CVar idExposeCurrentReset))]) - else ([],[]) + if (hasDefaultRst pps) + then ([CVar idRst], + [CMStmt (bindVarT idRst tReset (CVar idExposeCurrentReset))]) + else ([],[]) args' = args ++ args1 ++ args2 stmts' = stmts1 ++ stmts2 ++ [CMStmt (CSExpr Nothing - (xCmoduleVerilog m False -- it's not a user import - wireinfo args' fields schedinfo pathinfo))] + (xCmoduleVerilog m False -- it's not a user import + wireinfo args' fields schedinfo pathinfo))] in Cmodule (getPosition m) stmts' -- --------------- -- The core of the above functions xCmoduleVerilog :: CExpr -> Bool -> VWireInfo -> [CExpr] -> - [VFieldInfo] -> VSchedInfo -> VPathInfo -> - CExpr + [VFieldInfo] -> VSchedInfo -> VPathInfo -> + CExpr xCmoduleVerilog m is_user_import wireinfo args fields schedinfo pathinfo = let arginfo = wArgs wireinfo in if (length args) == (length arginfo) then @@ -470,28 +470,28 @@ xCmoduleVerilog m is_user_import wireinfo args fields schedinfo pathinfo = is_user_import (wClk wireinfo) (wRst wireinfo) - (zip arginfo args) - fields -- methods or clocks + (zip arginfo args) + fields -- methods or clocks schedinfo pathinfo -- VPathInfo else internalError - ("CSyntax.xCmoduleVerilog: args and arginfo do not match: " ++ - (ppReadable args) ++ (ppReadable arginfo)) + ("CSyntax.xCmoduleVerilog: args and arginfo do not match: " ++ + (ppReadable args) ++ (ppReadable arginfo)) -- =============== data CLiteral = CLiteral Position Literal deriving (Show) instance Eq CLiteral where - CLiteral _ l == CLiteral _ l' = l == l' + CLiteral _ l == CLiteral _ l' = l == l' instance Ord CLiteral where - CLiteral _ l `compare` CLiteral _ l' = l `compare` l' + CLiteral _ l `compare` CLiteral _ l' = l `compare` l' data COp - = CRand CExpr -- operand - | CRator Int Id -- infix operator Id, Int is the number of arguments? - deriving (Eq, Ord, Show) + = CRand CExpr -- operand + | CRator Int Id -- infix operator Id, Int is the number of arguments? + deriving (Eq, Ord, Show) type CSummands = [CInternalSummand] @@ -509,8 +509,8 @@ data CInternalSummand = -- return only the primary name getCISName :: CInternalSummand -> Id getCISName cis = case (cis_names cis) of - [] -> internalError "getCISName: empty cis_names" - (cn:_) -> cn + [] -> internalError "getCISName: empty cis_names" + (cn:_) -> cn -- original summands (taking a list of arguments, each of whose types -- is given by CQType); the Int is a hack to support Enums with @@ -529,8 +529,8 @@ data COriginalSummand = -- return only the primary name getCOSName :: COriginalSummand -> Id getCOSName cos = case (cos_names cos) of - [] -> internalError "getCOSName: empty cos_names" - (cn:_) -> cn + [] -> internalError "getCOSName: empty cos_names" + (cn:_) -> cn -- if CQType is a function, [IfcPragmas] (if present) lists argument names -- (used by the backend to generate pretty names for module ports) @@ -555,13 +555,13 @@ type CCaseArms = [CCaseArm] -- [(CPat, [CQual], CExpr)] data CStmt -- bind cexpr of type cqtype to cpat; id, if present, is instance name - = CSBindT CPat (Maybe CExpr) [(Position,PProp)] CQType CExpr + = CSBindT CPat (Maybe CExpr) [(Position,PProp)] CQType CExpr -- bind cexpr to cpat; id, if present, is instance name - | CSBind CPat (Maybe CExpr) [(Position,PProp)] CExpr - | CSletseq [CDefl] -- rhs of "let x = x" refers to previous def + | CSBind CPat (Maybe CExpr) [(Position,PProp)] CExpr + | CSletseq [CDefl] -- rhs of "let x = x" refers to previous def -- before current let or in earlier arm - | CSletrec [CDefl] -- rhs of "let x = x" refers to self - | CSExpr (Maybe CExpr) CExpr + | CSletrec [CDefl] -- rhs of "let x = x" refers to self + | CSExpr (Maybe CExpr) CExpr deriving (Eq, Ord, Show) bindVarT :: Id -> CType -> CExpr -> CStmt @@ -570,42 +570,42 @@ bindVarT i t e = CSBindT (CPVar i) Nothing [] (CQType [] t) e type CStmts = [CStmt] data CMStmt - = CMStmt CStmt - | CMrules CExpr - | CMinterface CExpr - | CMTupleInterface Position [CExpr] + = CMStmt CStmt + | CMrules CExpr + | CMinterface CExpr + | CMTupleInterface Position [CExpr] deriving (Eq, Ord, Show) data CRule - = CRule [RulePragma] (Maybe CExpr) [CQual] CExpr - | CRuleNest [RulePragma] (Maybe CExpr) [CQual] [CRule] + = CRule [RulePragma] (Maybe CExpr) [CQual] CExpr + | CRuleNest [RulePragma] (Maybe CExpr) [CQual] [CRule] deriving (Eq, Ord, Show) -- "let" binding -data CDefl -- [CQual] part is when clause used in interfaces - = CLValueSign CDef [CQual] - | CLValue Id [CClause] [CQual] - | CLMatch CPat CExpr +data CDefl -- [CQual] part is when clause used in interfaces + = CLValueSign CDef [CQual] + | CLValue Id [CClause] [CQual] + | CLMatch CPat CExpr deriving (Eq, Ord, Show) -- Definition, local or global data CDef - = CDef Id CQType [CClause] -- before type checking - | CDefT Id [TyVar] CQType [CClause] -- after type checking, with type variables from the CQType + = CDef Id CQType [CClause] -- before type checking + | CDefT Id [TyVar] CQType [CClause] -- after type checking, with type variables from the CQType deriving (Eq, Ord, Show) -- Definition clause -- each interface's definitions (within the module) correspond to one of these data CClause - = CClause [CPat] -- arguments (including patterns) + = CClause [CPat] -- arguments (including patterns) [CQual] -- qualifier on the args CExpr -- the body deriving (Eq, Ord, Show) -- Pattern matching data CQual - = CQGen CType CPat CExpr - | CQFilter CExpr + = CQGen CType CPat CExpr + | CQFilter CExpr deriving (Eq, Ord, Show) isCQFilter :: CQual -> Bool @@ -613,27 +613,27 @@ isCQFilter (CQFilter _) = True isCQFilter _ = False data CPat - = CPCon Id [CPat] - | CPstruct Id [(Id, CPat)] + = CPCon Id [CPat] + | CPstruct Id [(Id, CPat)] | CPVar Id | CPAs Id CPat | CPAny Position | CPLit CLiteral - -- position, base, [(length, value or don't-care)] starting from MSB + -- position, base, [(length, value or don't-care)] starting from MSB -- note that length is length in digits, not bits! - | CPMixedLit Position Integer [(Integer, Maybe Integer)] - -- used before operator parsing - | CPOper [CPOp] - -- generated by deriving code - | CPCon1 Id Id CPat -- first Id is type of constructor - -- After type checking - | CPConTs Id Id [CType] [CPat] + | CPMixedLit Position Integer [(Integer, Maybe Integer)] + -- used before operator parsing + | CPOper [CPOp] + -- generated by deriving code + | CPCon1 Id Id CPat -- first Id is type of constructor + -- After type checking + | CPConTs Id Id [CType] [CPat] deriving (Eq, Ord, Show) data CPOp - = CPRand CPat - | CPRator Int Id - deriving (Eq, Ord, Show) + = CPRand CPat + | CPRator Int Id + deriving (Eq, Ord, Show) data CInclude = CInclude String @@ -798,9 +798,9 @@ instance HasPosition CExpr where getPosition (Cmodule pos _) = pos getPosition (Cinterface pos i ds) = pos getPosition (CmoduleVerilog e _ _ _ ses fs _ _) = - getPosition (e, map snd ses, fs) + getPosition (e, map snd ses, fs) getPosition (CmoduleVerilogT _ e _ _ _ ses fs _ _) = - getPosition (e, map snd ses, fs) + getPosition (e, map snd ses, fs) getPosition (CForeignFuncC i _) = getPosition i getPosition (CForeignFuncCT i _) = getPosition i getPosition (Cdo _ ss) = getPosition ss @@ -877,8 +877,8 @@ ppExports d (Left exports) = t "(" <> sepList (map (pp d) exports) (t",") <> t") instance PPrint CPackage where pPrint d _ (CPackage i exps imps fixs def includes) = - (t"package" <+> ppConId d i <> ppExports d exps <+> t "where {") $+$ - pBlock d 0 True (map (pp d) imps ++ map (pp d) fixs ++ map (pp d) def ++ map (pp d) includes) + (t"package" <+> ppConId d i <> ppExports d exps <+> t "where {") $+$ + pBlock d 0 True (map (pp d) imps ++ map (pp d) fixs ++ map (pp d) def ++ map (pp d) includes) instance PPrint CExport where pPrint d p (CExpVar i) = ppVarId d i @@ -895,8 +895,8 @@ ppQualified False = empty instance PPrint CSignature where pPrint d _ (CSignature i imps fixs def) = - (t"signature" <+> ppConId d i <+> t "where" <+> t "{") $+$ - pBlock d 0 True (map pi imps ++ map (pp d) fixs ++ map (pp d) def) + (t"signature" <+> ppConId d i <+> t "where" <+> t "{") $+$ + pBlock d 0 True (map pi imps ++ map (pp d) fixs ++ map (pp d) def) where pi i = t"import" <+> ppConId d i instance PPrint CFixity where @@ -906,63 +906,63 @@ instance PPrint CFixity where instance PPrint CDefn where pPrint d p (Ctype i as ty) = - sep [sep ((t"type" <+> ppConIdK d i) : map (nest 2 . ppVarId d) as) <+> t "=", - nest 2 (pp d ty)] + sep [sep ((t"type" <+> ppConIdK d i) : map (nest 2 . ppVarId d) as) <+> t "=", + nest 2 (pp d ty)] pPrint d p (Cdata { cd_visible = vis, cd_name = i, cd_type_vars = as, cd_original_summands = cs@(_:_), cd_internal_summands = [], - cd_derivings = ds }) = -- a hack to print original constructors - sep [sep ((t"data" <+> ppConIdK d i) : map (nest 2 . ppVarId d) as) <> t(if vis then " =" else " =="), - nest 2 (ppOSummands d cs)] + cd_derivings = ds }) = -- a hack to print original constructors + sep [sep ((t"data" <+> ppConIdK d i) : map (nest 2 . ppVarId d) as) <> t(if vis then " =" else " =="), + nest 2 (ppOSummands d cs)] pPrint d p (Cdata { cd_visible = vis, cd_name = i, cd_type_vars = as, cd_internal_summands = cs, cd_derivings = ds }) = - sep [sep ((t"data" <+> ppConIdK d i) : map (nest 2 . ppVarId d) as) <> t(if vis then " =" else " =="), - nest 2 (ppSummands d cs)] - <> ppDer d ds + sep [sep ((t"data" <+> ppConIdK d i) : map (nest 2 . ppVarId d) as) <> t(if vis then " =" else " =="), + nest 2 (ppSummands d cs)] + <> ppDer d ds pPrint d p (Cstruct vis (SInterface prags) i as fs ds) = - (t("interface ") <> sep (ppConIdK d i : map (nest 2 . ppVarId d) as) <+> ppIfcPragma d prags <+> t(if vis then "= {" else "== {")) $+$ + (t("interface ") <> sep (ppConIdK d i : map (nest 2 . ppVarId d) as) <+> ppIfcPragma d prags <+> t(if vis then "= {" else "== {")) $+$ pBlock d 4 False (map (ppField d) fs) <> ppDer d ds pPrint d p (Cstruct vis ss i as fs ds) = - (t("struct ") <> sep (ppConIdK d i : map (nest 2 . ppVarId d) as) <+> t(if vis then "= {" else "== {")) $+$ + (t("struct ") <> sep (ppConIdK d i : map (nest 2 . ppVarId d) as) <+> t(if vis then "= {" else "== {")) $+$ pBlock d 4 False (map (ppField d) fs) <> ppDer d ds pPrint d p (Cclass incoh ps ik is fd ss) = - (t_cls <+> ppPreds d ps (sep (ppConIdK d ik : map (ppVarId d) is)) <> ppFDs d fd <+> t "where {") $+$ + (t_cls <+> ppPreds d ps (sep (ppConIdK d ik : map (ppVarId d) is)) <> ppFDs d fd <+> t "where {") $+$ pBlock d 4 False (map (ppField d) ss) where t_cls = case incoh of Just False -> t"class coherent" Just True -> t"class incoherent" Nothing -> t"class" pPrint d p (Cinstance qt ds) = - (t"instance" <+> pPrint d 0 qt <+> t "where {") $+$ + (t"instance" <+> pPrint d 0 qt <+> t "where {") $+$ pBlock d 4 False (map (pPrint d 0) ds) pPrint d p (CValueSign def) = pPrint d p def pPrint d p (CValue i cs) = - vcat (map (\ cl -> ppClause d p [ppVarId d i] cl <> t";") cs) + vcat (map (\ cl -> ppClause d p [ppVarId d i] cl <> t";") cs) pPrint d p (Cprimitive i ty) = - text "primitive" <+> ppVarId d i <+> t "::" <+> pp d ty + text "primitive" <+> ppVarId d i <+> t "::" <+> pp d ty pPrint d p (CPragma pr) = pPrint d p pr pPrint d p (CprimType ik) = - t"primitive type" <+> - -- don't use ppConIdK because this syntax has no parentheses - case (ik) of - (IdK i) -> ppConId d i - (IdKind i k) -> ppConId d i <+> t "::" <+> pp d k - (IdPKind i pk) -> ppConId d i <+> t "::" <+> pp d pk + t"primitive type" <+> + -- don't use ppConIdK because this syntax has no parentheses + case (ik) of + (IdK i) -> ppConId d i + (IdKind i k) -> ppConId d i <+> t "::" <+> pp d k + (IdPKind i pk) -> ppConId d i <+> t "::" <+> pp d pk pPrint d p (Cforeign i ty oname opnames) = - text "foreign" <+> ppVarId d i <+> t "::" <+> pp d ty <> (case oname of Nothing -> text ""; Just s -> text (" = " ++ show s)) <> (case opnames of Nothing -> text ""; Just (is, os) -> t"," <> pparen True (sep (map (text . show) is ++ po os))) + text "foreign" <+> ppVarId d i <+> t "::" <+> pp d ty <> (case oname of Nothing -> text ""; Just s -> text (" = " ++ show s)) <> (case opnames of Nothing -> text ""; Just (is, os) -> t"," <> pparen True (sep (map (text . show) is ++ po os))) where po [o] = [text ",", text (show o)] - po os = [t"(" <> sepList (map (text . show) os) (t",") <> t ")"] + po os = [t"(" <> sepList (map (text . show) os) (t",") <> t ")"] pPrint d p (CIinstance i qt) = - t"instance" <+> ppConId d i <+> pPrint d 0 qt + t"instance" <+> ppConId d i <+> pPrint d 0 qt pPrint d p (CItype i as positions) = - sep (t"type" <+> ppConIdK d i : map (nest 2 . ppVarId d) as) + sep (t"type" <+> ppConIdK d i : map (nest 2 . ppVarId d) as) pPrint d p (CIclass incoh ps ik is fd positions) = - t_cls <+> ppPreds d ps (sep (ppConIdK d ik : map (nest 2 . ppVarId d) is)) <> ppFDs d fd + t_cls <+> ppPreds d ps (sep (ppConIdK d ik : map (nest 2 . ppVarId d) is)) <> ppFDs d fd where t_cls = case incoh of Just False -> t"class coherent" Just True -> t"class incoherent" @@ -1012,9 +1012,9 @@ instance PPrint IdK where pBlock d n _ [] = t"}" pBlock d n nl xs = - (t (replicate n ' ') <> - foldr1 ($+$) (map (\ x -> x <> if nl then t";" $+$ t"" else t";") (init xs) ++ [last xs])) $+$ - t"}" + (t (replicate n ' ') <> + foldr1 ($+$) (map (\ x -> x <> if nl then t";" $+$ t"" else t";") (init xs) ++ [last xs])) $+$ + t"}" ppDer d [] = text "" ppDer d is = text " deriving (" <> sepList (map (pPrint d 0) is) (text ",") <> text ")" @@ -1024,14 +1024,14 @@ instance PPrint CExpr where pPrint d p (CLam ei e) = ppQuant "\\ " d p ei e pPrint d p (CLamT ei ty e) = ppQuant "\\ " d p ei e pPrint d p (Cletseq [] e) = pparen (p > 0) $ - (t"letseq in" <+> pp d e) + (t"letseq in" <+> pp d e) pPrint d p (Cletseq ds e) = pparen (p > 0) $ - (t"letseq" <+> foldr1 ($+$) (map (pp d) ds)) $+$ + (t"letseq" <+> foldr1 ($+$) (map (pp d) ds)) $+$ (t"in " <> pp d e) pPrint d p (Cletrec [] e) = pparen (p > 0) $ - (t"let in" <+> pp d e) + (t"let in" <+> pp d e) pPrint d p (Cletrec ds e) = pparen (p > 0) $ - (t"let" <+> foldr1 ($+$) (map (pp d) ds)) $+$ + (t"let" <+> foldr1 ($+$) (map (pp d) ds)) $+$ (t"in " <> pp d e) pPrint d p (CSelect e i) = pparen (p > (maxPrec+2)) $ pPrint d (maxPrec+2) e <> t"." <> ppVarId d i pPrint d p (CCon i []) = ppConId d i @@ -1041,16 +1041,16 @@ instance PPrint CExpr where pPrint d p (CVar i) = ppVarId d i pPrint d p (CStruct tyc []) | tyc == idPrimUnit = text "()" pPrint d p (CStruct tyc ies) = pparen (p > 0) $ pPrint d (maxPrec+1) tyc <+> t "{" <+> sepList (map f ies ++ [t"}"]) (t";") - where f (i, e) = ppVarId d i <+> t "=" <+> pp d e + where f (i, e) = ppVarId d i <+> t "=" <+> pp d e pPrint d p (CStructUpd e ies) = pparen (p > 0) $ pPrint d (maxPrec+1) e <+> t "{" <+> sepList (map f ies ++ [t"}"]) (t";") - where f (i, e) = ppVarId d i <+> t "=" <+> pp d e + where f (i, e) = ppVarId d i <+> t "=" <+> pp d e pPrint d p (Cwrite _ e v) = pparen (p > 0) $ pPrint d (maxPrec+1) e <+> t ":=" <+> pPrint d p v pPrint PDReadable p (CApply e []) = pPrint PDReadable p e pPrint d p (CApply e es) = pparen (p>(maxPrec-1)) $ - sep (pPrint d (maxPrec-1) e : map (nest 2 . ppApArg) es) + sep (pPrint d (maxPrec-1) e : map (nest 2 . ppApArg) es) where ppApArg e = pPrint d maxPrec e pPrint d p (CTaskApply e es) = pparen (p>(maxPrec-1)) $ - sep (pPrint d (maxPrec-1) e : map (nest 2 . ppApArg) es) + sep (pPrint d (maxPrec-1) e : map (nest 2 . ppApArg) es) where ppApArg e = pPrint d maxPrec e -- XXX: should include t? pPrint d p (CTaskApplyT e t es) = pparen (p>(maxPrec-1)) $ @@ -1067,39 +1067,39 @@ instance PPrint CExpr where pPrint d p (Cinterface pos Nothing ds) = pparen (p>0) (t"interface {" $+$ pBlock d 2 False (map (pp d) ds)) pPrint d p (Cinterface pos (Just i) ds) = - pparen (p>0) (t"interface" <+> pp d i <+> t "{" $+$ pBlock d 2 False (map (pp d) ds)) + pparen (p>0) (t"interface" <+> pp d i <+> t "{" $+$ pBlock d 2 False (map (pp d) ds)) pPrint d p (CmoduleVerilog m ui c r ses fs sch ps) = - sep [ - t"module verilog" <+> pp d m <+> - pp d c <> t"" <+> pp d r <+> t"", - nest 4 (if null ses then t"" else pparen True (sepList (map ppA ses) (t","))), - nest 4 (t"{" $+$ pBlock d 2 False (map f fs)), - nest 4 (pp d sch) ] - where mfi s Nothing = empty - mfi s (Just i) = t s <+> ppVarId d i - mfp s Nothing = empty - mfp s (Just (VName s', _)) = t s <+> t s' - f (Clock i) = t "clock_field " <> ppVarId d i - f (Reset i) = t "reset_field " <> ppVarId d i - f (Inout i (VName p) mc mr) = - t "inout_field " <> ppVarId d i <+> t p <+> - mfi "clocked_by" mc <+> mfi "reset_by" mr - f (Method i mc mr n ps mo me) = - ppVarId d i <> g n <+> t "=" <+> t (unwords (map h ps)) <+> - mfi "clocked_by" mc <+> mfi "reset_by" mr <+> mfp "output" mo <+> mfp "enable" me - g 1 = t"" - g n = t("[" ++ itos n ++ "]") - h (s,[]) = show s - h (s,ps) = show s ++ "{" ++ concat (intersperse "," (map (drop 2 . show) ps)) ++ "}" - ppA (ai, e) = text "(" <> text (ppReadable ai) <> text "," <+> pp d e <> text ")" + sep [ + t"module verilog" <+> pp d m <+> + pp d c <> t"" <+> pp d r <+> t"", + nest 4 (if null ses then t"" else pparen True (sepList (map ppA ses) (t","))), + nest 4 (t"{" $+$ pBlock d 2 False (map f fs)), + nest 4 (pp d sch) ] + where mfi s Nothing = empty + mfi s (Just i) = t s <+> ppVarId d i + mfp s Nothing = empty + mfp s (Just (VName s', _)) = t s <+> t s' + f (Clock i) = t "clock_field " <> ppVarId d i + f (Reset i) = t "reset_field " <> ppVarId d i + f (Inout i (VName p) mc mr) = + t "inout_field " <> ppVarId d i <+> t p <+> + mfi "clocked_by" mc <+> mfi "reset_by" mr + f (Method i mc mr n ps mo me) = + ppVarId d i <> g n <+> t "=" <+> t (unwords (map h ps)) <+> + mfi "clocked_by" mc <+> mfi "reset_by" mr <+> mfp "output" mo <+> mfp "enable" me + g 1 = t"" + g n = t("[" ++ itos n ++ "]") + h (s,[]) = show s + h (s,ps) = show s ++ "{" ++ concat (intersperse "," (map (drop 2 . show) ps)) ++ "}" + ppA (ai, e) = text "(" <> text (ppReadable ai) <> text "," <+> pp d e <> text ")" pPrint d p (CForeignFuncC i wrap_ty) = - -- There's no real Classic syntax for this: - t"ForeignFuncC" <+> pp d i + -- There's no real Classic syntax for this: + t"ForeignFuncC" <+> pp d i pPrint d p (Cdo _ ss) = pparen (p>0) $ t "do" <+> t "{" <+> sepList (map (pPrint d 0) ss ++ [t"}"]) (t";") pPrint d p (Caction _ ss) = pparen (p>0) $ t "action" <+> t "{" <+> sepList (map (pPrint d 0) ss ++ [t"}"]) (t";") pPrint d p (Crules [] rs) = pparen (p>0) $ t"rules {" $+$ pBlock d 2 False (map (pp d) rs) pPrint d p (Crules ps rs) = pPrint d p ps $+$ - (pparen (p>0) $ t"rules {" $+$ pBlock d 2 False (map (pp d) rs)) + (pparen (p>0) $ t"rules {" $+$ pBlock d 2 False (map (pp d) rs)) pPrint d p (CADump es) = prDump d es <+> text "" pPrint d p (COper ops) = pparen (p > maxPrec-1) (sep (map (pPrint d (maxPrec-1)) ops)) ---- @@ -1110,14 +1110,14 @@ instance PPrint CExpr where ---- pPrint d p (CConT _ i es) = pPrint d p (CCon i es) pPrint d p (CStructT ty ies) = pPrint d p (CStruct tyc ies) - where (Just tyc) = leftCon ty + where (Just tyc) = leftCon ty pPrint d p (CSelectT _ i) = text "." <> ppVarId d i pPrint d p (CLitT _ l) = pPrint d p l pPrint d p (CAnyT pos uk t) = text "_" pPrint d p (CmoduleVerilogT _ m ui c mr ses fs sch ps) = pPrint d p (CmoduleVerilog m ui c mr ses fs sch ps) pPrint d p (CForeignFuncCT i prim_ty) = t"ForeignFuncC" <+> pp d i pPrint d p (CTApply e ts) = pparen (p>(maxPrec-1)) $ - sep (pPrint d (maxPrec-1) e : map (nest 2 . ppApArg) ts) + sep (pPrint d (maxPrec-1) e : map (nest 2 . ppApArg) ts) where ppApArg ty = t"\183" <> pPrint d maxPrec ty pPrint d p (Cattributes pps) = pparen True $ text "Attributes" <+> pPrint d 0 (map snd pps) @@ -1165,14 +1165,14 @@ ppCase detail scrutinee arms = nest 2 (pp detail (cca_consequent arm))] ppOp d pd i p1 p2 = - pparen (pd > 0) (sep [pPrint d 1 p1 <> t"" <+> ppInfix d i, pPrint d 1 p2]) + pparen (pd > 0) (sep [pPrint d 1 p1 <> t"" <+> ppInfix d i, pPrint d 1 p2]) {- - let (p, lp, rp) = - case getFixity i of - FInfixl p -> (p, p, p+1) - FInfixr p -> (p, p+1, p) - FInfix p -> (p, p+1, p+1) - in pparen (d > PDReadable || pd>p) + let (p, lp, rp) = + case getFixity i of + FInfixl p -> (p, p, p+1) + FInfixr p -> (p, p+1, p) + FInfix p -> (p, p+1, p+1) + in pparen (d > PDReadable || pd>p) (sep [pPrint d lp p1 <> t"" <+> ppInfix d i, pPrint d rp p2]) -} @@ -1182,10 +1182,10 @@ ppQuals d qs = t" when" <+> sepList (map (pp d) qs) (t",") ppOSummands d cs = sepList (map (nest 2 . ppOCon) cs) (t" |") where ppOCon summand = let pp_name = case (cos_names summand) of - [cn] -> ppConId d cn - cns -> text "(" <> - sepList (map (ppConId d) cns) (text ",") <> - text ")" + [cn] -> ppConId d cn + cns -> text "(" <> + sepList (map (ppConId d) cns) (text ",") <> + text ")" pp_args = map (pPrint d maxPrec) (cos_arg_types summand) pp_encoding = case cos_tag_encoding summand of @@ -1196,27 +1196,27 @@ ppOSummands d cs = sepList (map (nest 2 . ppOCon) cs) (t" |") ppSummands d cs = sepList (map (nest 2 . ppCon) cs) (t" |") where ppCon summand = - let pp_name = case (cis_names summand) of - [cn] -> ppConId d cn - cns -> text "(" <> - sepList (map (ppConId d) cns) (text ",") <> - text ")" + let pp_name = case (cis_names summand) of + [cn] -> ppConId d cn + cns -> text "(" <> + sepList (map (ppConId d) cns) (text ",") <> + text ")" pp_arg = pPrint d maxPrec (cis_arg_type summand) - in sep [pp_name, pp_arg] + in sep [pp_name, pp_arg] instance PPrint CDef where pPrint d p (CDef i ty cs) = ppValueSign d i [] ty cs pPrint d p (CDefT i vs ty cs) = ppValueSign d i vs ty cs instance PPrint CRule where - pPrint d p (CRule rps mlbl mqs e) = - ppRPS d rps $+$ - (case mlbl of Nothing -> t""; Just i -> pp d i <> t": ") <> sep [ppQuals d mqs, t " ==>", - nest 4 (pp d e)] - pPrint d p (CRuleNest rps mlbl mqs rs) = - ppRPS d rps $+$ - (case mlbl of Nothing -> t""; Just i -> pp d i <> t": ") <> - (ppQuals d mqs $+$ pBlock d 2 False (map (pp d) rs)) + pPrint d p (CRule rps mlbl mqs e) = + ppRPS d rps $+$ + (case mlbl of Nothing -> t""; Just i -> pp d i <> t": ") <> sep [ppQuals d mqs, t " ==>", + nest 4 (pp d e)] + pPrint d p (CRuleNest rps mlbl mqs rs) = + ppRPS d rps $+$ + (case mlbl of Nothing -> t""; Just i -> pp d i <> t": ") <> + (ppQuals d mqs $+$ pBlock d 2 False (map (pp d) rs)) ppRPS d [] = text "" ppRPS d rps = vcat (map (pPrint d 0) rps) @@ -1224,7 +1224,7 @@ ppRPS d rps = vcat (map (pPrint d 0) rps) instance PPrint CDefl where pPrint d p (CLValueSign def me) = optWhen d me $ pPrint d p def pPrint d p (CLValue i cs me) = optWhen d me $ - foldr1 ($+$) (map (\ cl -> ppClause d p [ppVarId d i] cl <> t";") cs) + foldr1 ($+$) (map (\ cl -> ppClause d p [ppVarId d i] cl <> t";") cs) pPrint d p (CLMatch pat e) = ppClause d p [] (CClause [pat] [] e) optWhen d [] s = s @@ -1232,45 +1232,45 @@ optWhen d qs s = s $+$ (t" " <> ppQuals d qs) ppValueSign :: PDetail -> Id -> [TyVar] -> CQType -> [CClause] -> Doc ppValueSign d i [] ty cs = - (ppVarId d i <+> t "::" <+> pp d ty <> t";") $+$ - foldr1 ($+$) (map (\ cl -> ppClause d (0::Integer) [ppVarId d i] cl <> t";") cs) + (ppVarId d i <+> t "::" <+> pp d ty <> t";") $+$ + foldr1 ($+$) (map (\ cl -> ppClause d (0::Integer) [ppVarId d i] cl <> t";") cs) ppValueSign d i vs ty cs = - (ppVarId d i <+> t ":: /\\" <> sep (map (pPrint d maxPrec) vs) <> t"." <> pp d ty <> t";") $+$ - foldr1 ($+$) (map (\ cl -> ppClause d (0::Integer) [ppVarId d i] cl <> t";") cs) + (ppVarId d i <+> t ":: /\\" <> sep (map (pPrint d maxPrec) vs) <> t"." <> pp d ty <> t";") $+$ + foldr1 ($+$) (map (\ cl -> ppClause d (0::Integer) [ppVarId d i] cl <> t";") cs) instance PPrint CClause where pPrint d p cl = ppClause d p [] cl ppClause d p xs (CClause ps mqs e) = - sep [sep (xs ++ map (pPrint d maxPrec) ps) <> ppQuals d mqs <+> t "= ", - nest 4 (pp d e)] + sep [sep (xs ++ map (pPrint d maxPrec) ps) <> ppQuals d mqs <+> t "= ", + nest 4 (pp d e)] instance PPrint CQual where - pPrint d p (CQGen _ pa e) = pp d pa <+> t "<-" <+> pp d e - pPrint d p (CQFilter e) = pp d e + pPrint d p (CQGen _ pa e) = pp d pa <+> t "<-" <+> pp d e + pPrint d p (CQFilter e) = pp d e instance PPrint CPat where pPrint d p (CPVar a) = pPrint d p a pPrint d p (CPCon i as) = pparen (p>(maxPrec-1)) $ sep (ppConId d i : map (pPrint d maxPrec) as) pPrint d p (CPstruct tyc []) | tyc == idPrimUnit = text "()" pPrint d p (CPstruct tyc [(_, fst), (_, snd)]) | tyc == idPrimPair = - pparen True (pPrint d 0 fst <> t"," <+> pPrint d 0 snd) + pparen True (pPrint d 0 fst <> t"," <+> pPrint d 0 snd) pPrint d p (CPstruct i fs) = pparen (p>(maxPrec-1)) $ ppConId d i <+> t "{" <+> sep (map ppField fs ++ [t"}"]) - where ppField (i, CPVar i') | i == i' = ppVarId d i <> t";" - ppField (i, p) = ppVarId d i <+> t "=" <+> pp d p <> t";" + where ppField (i, CPVar i') | i == i' = ppVarId d i <> t";" + ppField (i, p) = ppVarId d i <+> t "=" <+> pp d p <> t";" pPrint d p (CPAs a pp) = pPrint d maxPrec a <> t"@" <> pPrint d maxPrec pp pPrint d p (CPAny _) = text "_" pPrint d p (CPLit l) = pPrint d p l pPrint d p (CPMixedLit _ base ps) = - let digitBits = log2 base + let digitBits = log2 base f (len, Just val) = integerFormat (len `div` digitBits) base val - f (len, Nothing) = genericReplicate (len `div` digitBits) '?' - pref 2 = "0b" - pref 8 = "0o" - pref 10 = "" - pref 16 = "0x" - pref x = internalError ("bad radix to CPMixedLit: " ++ show x) - in text (pref base ++ concatMap f ps) + f (len, Nothing) = genericReplicate (len `div` digitBits) '?' + pref 2 = "0b" + pref 8 = "0o" + pref 10 = "" + pref 16 = "0x" + pref x = internalError ("bad radix to CPMixedLit: " ++ show x) + in text (pref base ++ concatMap f ps) pPrint d p (CPOper ops) = pparen (p > maxPrec-1) (sep (map (pPrint d (maxPrec-1)) ops)) pPrint d p (CPCon1 _ i a) = pPrint d p (CPCon i [a]) ---- @@ -1287,15 +1287,15 @@ ppInfix d i = --s@(c:_) | isIdChar c -> t"`" <> t s <> t"`" --s -> t s let p = getIdQual i - b = getIdBase i + b = getIdBase i in if (p==fsEmpty) then - (case getFString b of - s@(c:_) | isIdChar c -> t"`" <> t s <> t"`" - s -> t s) + (case getFString b of + s@(c:_) | isIdChar c -> t"`" <> t s <> t"`" + s -> t s) else (t"`" <> t (getFString p) <> t "." <> - (case getFString b of - s@(c:_) | isIdChar c -> t s - s -> t "(" <> t s <> t")") <> t"`") + (case getFString b of + s@(c:_) | isIdChar c -> t s + s -> t "(" <> t s <> t")") <> t"`") instance PPrint CInclude where pPrint d p (CInclude s) = pPrint d p s diff --git a/src/comp/CSyntaxTypes.hs b/src/comp/CSyntaxTypes.hs index ef4af9a7f..99e0677fe 100644 --- a/src/comp/CSyntaxTypes.hs +++ b/src/comp/CSyntaxTypes.hs @@ -1,6 +1,6 @@ module CSyntaxTypes( - Types(..) - ) where + Types(..) + ) where import Data.List(union, (\\), nub) import ListUtil(mapSnd) @@ -29,30 +29,30 @@ instance Types CDef where -- This fixes bug 675, but is it fixing the problem or just masking it? -- More thought/investigation is needed. apSub s (CDefT i vs qt cs) = - let s' = if null vs then s else trimSubstByVars vs s - in CDefT i vs (apSub s' qt) (apSub s' cs) + let s' = if null vs then s else trimSubstByVars vs s + in CDefT i vs (apSub s' qt) (apSub s' cs) {- -- For investigating, use this code to assert an internalError or trace -- on bad substitutions. - let (s',removed_vs) = removeFromSubst vs s - r = getSubstRange s' - in - --if (any (\v -> elem v r) removed_vs) - if (any (\v -> elem v r) vs) - then internalError ("apSub CDefT:\n" ++ - " i = " ++ ppReadable i ++ - " vs = " ++ ppReadable vs ++ - " removed_vs = " ++ ppReadable removed_vs ++ - " s' = " ++ ppReadable s') - else - if (length removed_vs > 0) - then trace ("apSub CDefT, removing from Subst:\n" ++ - " i = " ++ ppReadable i ++ - " vs = " ++ ppReadable vs ++ - " removed_vs = " ++ ppReadable removed_vs ++ - " s = " ++ ppReadable s) $ - CDefT i vs (apSub s' qt) (apSub s' cs) - else CDefT i vs (apSub s' qt) (apSub s' cs) + let (s',removed_vs) = removeFromSubst vs s + r = getSubstRange s' + in + --if (any (\v -> elem v r) removed_vs) + if (any (\v -> elem v r) vs) + then internalError ("apSub CDefT:\n" ++ + " i = " ++ ppReadable i ++ + " vs = " ++ ppReadable vs ++ + " removed_vs = " ++ ppReadable removed_vs ++ + " s' = " ++ ppReadable s') + else + if (length removed_vs > 0) + then trace ("apSub CDefT, removing from Subst:\n" ++ + " i = " ++ ppReadable i ++ + " vs = " ++ ppReadable vs ++ + " removed_vs = " ++ ppReadable removed_vs ++ + " s = " ++ ppReadable s) $ + CDefT i vs (apSub s' qt) (apSub s' cs) + else CDefT i vs (apSub s' qt) (apSub s' cs) -} tv (CDef i qt cs) = tv (qt, cs) tv (CDefT i vs qt cs) = (nub (tv (qt, cs))) \\ vs @@ -114,7 +114,7 @@ instance Types CExpr where apSub s (CLitT t l) = CLitT (apSub s t) l apSub s (CAnyT pos uk t) = CAnyT pos uk (apSub s t) apSub s (CmoduleVerilogT t m ui c r ses fs sch ps) = - CmoduleVerilogT (apSub s t) (apSub s m) ui c r (mapSnd (apSub s) ses) fs sch ps + CmoduleVerilogT (apSub s t) (apSub s m) ui c r (mapSnd (apSub s) ses) fs sch ps apSub s (CForeignFuncCT i pty) = CForeignFuncCT i (apSub s pty) apSub s (COper os) = internalError ("CSyntaxTypes.Types(CExpr).apSub: COper " ++ ppReadable os) apSub s e@(Cattributes pps) = e diff --git a/src/comp/CVPrint.hs b/src/comp/CVPrint.hs index f603d95af..850a1d471 100644 --- a/src/comp/CVPrint.hs +++ b/src/comp/CVPrint.hs @@ -1,50 +1,50 @@ {-# LANGUAGE CPP #-} module CVPrint ( - CPackage(..), - CSignature(..), - CExpr(..), - CType, - TyVar(..), - TyCon(..), - Kind(..), - CImport(..), + CPackage(..), + CSignature(..), + CExpr(..), + CType, + TyVar(..), + TyCon(..), + Kind(..), + CImport(..), CQual(..), - CClause(..), - CPat(..), - Literal(..), - Type(..), - TISort(..), - CQType(..), - CDef(..), - CExport(..), - CRule(..), - CDefn(..), - CDefl(..), - CFunDeps, - CPred(..), - CFields, - CStmt(..), - IdK(..), - CLiteral(..), - CMStmt(..), - COp(..), - CPOp(..), - CFixity(..), - leftCon, - anyExpr, - noType, - iKName, - impName, - tMkTuple, - mkTuple, pMkTuple, - pvPreds, - getName, - getLName, - isTDef, - getNK, - HasPosition(..), - StructSubType(..), - pvpId, pvParameterTypes) where + CClause(..), + CPat(..), + Literal(..), + Type(..), + TISort(..), + CQType(..), + CDef(..), + CExport(..), + CRule(..), + CDefn(..), + CDefl(..), + CFunDeps, + CPred(..), + CFields, + CStmt(..), + IdK(..), + CLiteral(..), + CMStmt(..), + COp(..), + CPOp(..), + CFixity(..), + leftCon, + anyExpr, + noType, + iKName, + impName, + tMkTuple, + mkTuple, pMkTuple, + pvPreds, + getName, + getLName, + isTDef, + getNK, + HasPosition(..), + StructSubType(..), + pvpId, pvParameterTypes) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804) import Prelude hiding ((<>)) @@ -91,8 +91,8 @@ pvpExports d (Left exports) = map (pp d) exports instance PVPrint CPackage where pvPrint d _ (CPackage i exps imps fixs def includes) = - (t"package" <+> pp d i <> t";") $+$ empty $+$ - pBlockNT d 0 True (pvpExports d exps ++ map (pp d) imps ++ map (pp d) fixs ++ pdefs d def ++ map (pp d) includes) (t"\n") $+$ + (t"package" <+> pp d i <> t";") $+$ empty $+$ + pBlockNT d 0 True (pvpExports d exps ++ map (pp d) imps ++ map (pp d) fixs ++ pdefs d def ++ map (pp d) includes) (t"\n") $+$ (t"endpackage:" <+> pp d i) pdefs _ [] = [] @@ -122,8 +122,8 @@ ppQualified False = empty instance PVPrint CSignature where pvPrint d _ (CSignature i imps fixs def) = - (t"signature" <+> pp d i <+> t "where {") $+$ - pBlock d 0 True (map pi imps ++ map (pp d) fixs ++ map (pp d) def) (t";") (t"}") + (t"signature" <+> pp d i <+> t "where {") $+$ + pBlock d 0 True (map pi imps ++ map (pp d) fixs ++ map (pp d) def) (t";") (t"}") where pi i = t"include" <+> pvpId d i instance PVPrint CFixity where @@ -145,32 +145,32 @@ pvParameterTypes d ts = t"#(" <> sepList (map (\ y -> pvPrint d 0 y) ts) (t ",") <> t ")" p2defs d (CPragma (Pproperties _ props)) - (CValueSign df2@(CDef i qt@(CQType ps ty) cs@[CClause cps [] cexp])) | all isVar cps = + (CValueSign df2@(CDef i qt@(CQType ps ty) cs@[CClause cps [] cexp])) | all isVar cps = let (ys, x) = getArrows ty - ity = case x of (TAp (TCon _) y) -> y; - (TAp (TVar _) y) -> y; - z -> z + ity = case x of (TAp (TCon _) y) -> y; + (TAp (TVar _) y) -> y; + z -> z f [] = empty f xs = t"#(" <> - sepList (zipWith (\ x c -> -- t"parameter" <+> - pvPrint d 0 x <> t"" <+> pvPrint d 10 c) - xs cps) - (t",") <> t")" - (mId,ps') = findModId ps - line1 = t"module" <+> pvpId d i <> f ys <> t"(" <> pvPrint d 0 ity <> t")" + sepList (zipWith (\ x c -> -- t"parameter" <+> + pvPrint d 0 x <> t"" <+> pvPrint d 10 c) + xs cps) + (t",") <> t")" + (mId,ps') = findModId ps + line1 = t"module" <+> pvpId d i <> f ys <> t"(" <> pvPrint d 0 ity <> t")" in - if isModule mId x then + if isModule mId x then (pProps d props $+$ - (case cexp of - (Cmodule _ sts) -> - (pBlockNT d 0 False + (case cexp of + (Cmodule _ sts) -> + (pBlockNT d 0 False [line1, if ps'==[] then empty - else t " provisos (" <> sepList (map (pvPrint d 0) ps') (t ",") <> t")"] empty) + else t " provisos (" <> sepList (map (pvPrint d 0) ps') (t ",") <> t")"] empty) <> (t";") $+$ - (pBlock d 2 False (map (pp d) (reorderStmts sts)) empty (t"endmodule:" <+> pp d i)) - e -> (ppValueSignRest d (pvpId d i) ps' True True line1 e "module"))) + (pBlock d 2 False (map (pp d) (reorderStmts sts)) empty (t"endmodule:" <+> pp d i)) + e -> (ppValueSignRest d (pvpId d i) ps' True True line1 e "module"))) else (pProps d props $+$ ppValueSign d i [] qt cs) p2defs d (CPragma (Pproperties i1 props)) (CValueSign df2@(CDef i2 _ _)) | i1==i2 = @@ -183,12 +183,12 @@ pProps d ps = t"(*" <+> sepList (map (pvPrint d 0) ps) (text ",") <+> text "*)" instance PVPrint CDefn where pvPrint d p (Ctype i [] ty) = - sep [t"typedef", - nest 2 (pp d ty), - pp d i <> t";"] + sep [t"typedef", + nest 2 (pp d ty), + pp d i <> t";"] pvPrint d p (Ctype i as ty) = - sep [t"typedef", - nest 2 (pp d ty) <+> pp d i <+> + sep [t"typedef", + nest 2 (pp d ty) <+> pp d i <+> pvParameterTypeVars d as <> t ";"] pvPrint d p (Cdata { cd_visible = vis, @@ -197,9 +197,9 @@ instance PVPrint CDefn where cd_original_summands = cs@(_:_), cd_internal_summands = [], cd_derivings = ds }) = -- a hack to print original constructors - sep [sep ((t"data1" <+> pp d i) : map (nest 2 . pvPrint d maxPrec) as) <+> - t(if vis then "=" else "=="), - nest 2 (ppOSummands d cs)] + sep [sep ((t"data1" <+> pp d i) : map (nest 2 . pvPrint d maxPrec) as) <+> + t(if vis then "=" else "=="), + nest 2 (ppOSummands d cs)] pvPrint d p (Cdata { cd_visible = vis, cd_name = i, @@ -210,30 +210,30 @@ instance PVPrint CDefn where ppCon summand = pvPrint d 0 (cis_arg_type summand) <+> pvpId d (getCISName summand) -- XXX print all the names? ppIde summand = pvpId d (getCISName summand) -- XXX print all the names? - isVoid (CInternalSummand { cis_arg_type = TCon (TyCon unit _ _) }) = + isVoid (CInternalSummand { cis_arg_type = TCon (TyCon unit _ _) }) = (unit == idPrimUnit) - isVoid _ = False - isEnum = all isVoid + isVoid _ = False + isEnum = all isVoid in (if isEnum cs - then - t"typedef enum {" $+$ + then + t"typedef enum {" $+$ sepList (map (nest 2 . ppIde) cs) (t",") <> (t"}") else - t"typedef union tagged {" $+$ + t"typedef union tagged {" $+$ pBlock d 4 False (map ppCon cs) (t";") (t"}")) <+> pp d i <+> typarams <+> ppDer d ds <> t";" pvPrint d p (Cstruct vis (SInterface ps) i [] fs ds) = ppIfcPrags d (Just ps) $$ - (t"interface" <+> - pp d i <> t";" <+> if vis then empty else t"/*") $+$ + (t"interface" <+> + pp d i <> t";" <+> if vis then empty else t"/*") $+$ pBlock d 4 False (map (ppField d (t"method") True) fs) (t";") (t"endinterface:" <+> pp d i) <+> ppDer d ds pvPrint d p (Cstruct vis (SInterface ps) i as fs ds) = ppIfcPrags d (Just ps) $$ - (t"interface" <+> + (t"interface" <+> pvPrint d 9 i <+> pvParameterTypeVars d as - <> t";" <+> (if vis then empty else t"/*")) $+$ + <> t";" <+> (if vis then empty else t"/*")) $+$ pBlock d 4 False (map (ppField d (t"method") True) fs)(t";") (t"endinterface:" <+> pp d i) <+> (if vis then empty else t"*/") <+> ppDer d ds @@ -241,12 +241,12 @@ instance PVPrint CDefn where let typarams = pvParameterTypeVars d as -- ppCon (i, ty) = pvPrint d 0 ty <+> pvpId d i in - t"typedef struct" <+> t "{" $+$ + t"typedef struct" <+> t "{" $+$ pBlock d 4 False (map (ppField d empty False) fs)(t";") (t"} ") <> - pp d i <+> typarams <+> ppDer d ds <> t";" + pp d i <+> typarams <+> ppDer d ds <> t";" -{- (t"typedef struct" <+> - pp d i <> t(if vis then ";" else "; /*")) $+$ +{- (t"typedef struct" <+> + pp d i <> t(if vis then ";" else "; /*")) $+$ pBlock d 4 False (map (ppField d "" False) fs) (t";") (t"}") <+> ppDer d ds -} @@ -255,10 +255,10 @@ instance PVPrint CDefn where pvPrint d p (Cclass Nothing ps ik is fd ss) = ((pBlockNT d 0 False [t"typeclass" <+> pp d ik <+> pvParameterTypeVars d is, - pvpFDs d fd, + pvpFDs d fd, if ps==[] then empty - else t " provisos (" <> sepList (map (pvPrint d 0) ps) (t",") <> t")"] empty)<> (t";")) $+$ + else t " provisos (" <> sepList (map (pvPrint d 0) ps) (t",") <> t")"] empty)<> (t";")) $+$ pBlockNT d 4 False (map (\s -> ppField d (t"function") True s <> t";") ss) empty $+$ t"endtypeclass" @@ -269,46 +269,46 @@ instance PVPrint CDefn where [t"instance" <+> pvPrint d 9 x <> pvParameterTypes d ys, if ps==[] then empty - else t " provisos (" <> sepList (map (pvPrint d 0) ps) (t",") <> t")"] empty)<> (t";")) $+$ + else t " provisos (" <> sepList (map (pvPrint d 0) ps) (t",") <> t")"] empty)<> (t";")) $+$ pBlockNT d 4 False (map (pvPrint d 0) ds) empty $+$ t"endinstance" pvPrint d p (Cprimitive i ty) = - text "primitive" <+> pvpId d i <+> t "::" <+> pp d ty + text "primitive" <+> pvpId d i <+> t "::" <+> pp d ty pvPrint d p (CPragma pr) = pvPrint d p pr pvPrint d p (CprimType (IdKind i k)) = - t"primitive type" <+> pp d i <+> t "::" <+> pp d k + t"primitive type" <+> pp d i <+> t "::" <+> pp d k pvPrint d p (Cforeign i ty oname opnames) = - text "foreign" <+> pvpId d i <+> t "::" - <+> pp d ty - <> (case oname of Nothing -> empty; Just s -> text (" = " ++ show s)) - <> (case opnames of - Nothing -> empty; - Just (is, os) -> - t"," <> pparen True (sep (map (text . show) is ++ po os))) + text "foreign" <+> pvpId d i <+> t "::" + <+> pp d ty + <> (case oname of Nothing -> empty; Just s -> text (" = " ++ show s)) + <> (case opnames of + Nothing -> empty; + Just (is, os) -> + t"," <> pparen True (sep (map (text . show) is ++ po os))) where po [o] = [text ",", text (show o)] - po os = [t"(" <> sepList (map (text . show) os) (t",") <> t ")"] + po os = [t"(" <> sepList (map (text . show) os) (t",") <> t ")"] {- -- XXX These are not in BSV pvPrint d p (CIinstance i qt) = - t"instance" <+> pvpId d i <> t"" <+> pvPrint d 0 qt + t"instance" <+> pvpId d i <> t"" <+> pvPrint d 0 qt pvPrint d p (CItype i as usePositions) = - sep (t"type" <+> pp d i : map (nest 2 . pvPrint d maxPrec) as) + sep (t"type" <+> pp d i : map (nest 2 . pvPrint d maxPrec) as) pvPrint d p (Cclass (Just _) ps ik is fd ss) = pvPrint d p (CIclass incoh ps ik is fds usePositions) = let pdoc = if ps==[] then empty - else t " provisos (" <> + else t " provisos (" <> sepList (map (pvPrint d 0) ps) (t",") <> t")" - in (pBlockNT d 0 False + in (pBlockNT d 0 False [t"class" <+> pp d ik <+> pvParameterTypeVars d is, - pvpFDs d fd, pdoc] empty) + pvpFDs d fd, pdoc] empty) <> (t";") pvPrint d p (CIValueSign i ty) = pvpId d i <+> t "::" <+> pp d ty -} @@ -348,13 +348,13 @@ ppTypedId d mi i y = ppLabelledTypedId d (if isFn y then t"function" else empty) ppLabelledTypedId d intro modId isFnlike i ty ids = let (ys, x) = getArrows ty ity = case x of (TAp (TCon _) y) -> y; - z -> z + z -> z g [] = empty g xs = t"#(" <> sepList xs (t",") <> t")" f [] = intro <+> pp d x <+> i <> (if isFnlike then t"()" else empty) f xs = if isModule modId x - then t"module" <+> i <> g xs <> t"(" <> pvPrint d 0 ity <> t")" - else intro <+> pvPrint d 9 x <+> i <> t"(" <> sepList xs (text ",") <> t")" + then t"module" <+> i <> g xs <> t"(" <> pvPrint d 0 ity <> t")" + else intro <+> pvPrint d 9 x <+> i <> t"(" <> sepList xs (text ",") <> t")" zs = zipWith (\ y i -> ppTypedId d Nothing i y newIds) ys ids in f zs @@ -403,14 +403,14 @@ instance PVPrint IdK where pBlock d n _ [] _ ket = ket pBlock d n nl xs sep ket = - (t (replicate n ' ') <> - foldr1 ($+$) (map (\ x -> x <> if nl then sep $+$ empty else sep) xs)) $+$ - ket + (t (replicate n ' ') <> + foldr1 ($+$) (map (\ x -> x <> if nl then sep $+$ empty else sep) xs)) $+$ + ket pBlockNT d n _ [] _ = empty pBlockNT d n nl xs sep = - (t (replicate n ' ') <> - foldr1 ($+$) (map (\ x -> x <> if nl then sep $+$ empty else sep) xs)) + (t (replicate n ' ') <> + foldr1 ($+$) (map (\ x -> x <> if nl then sep $+$ empty else sep) xs)) ppDer d [] = empty ppDer d is = text "deriving (" <> sepList (map (pvPrint d 0) is) (text ",") <> text ")" @@ -429,20 +429,20 @@ ppMClause d [x] (CClause ps [] e) mIf | all isVar ps = sepList (map (pvPrint d maxPrec) ps) (t",") <> t")" <+> mIf <+> t";", nest 2 (ppMBody d e)] ppMClause d xs (CClause ps mqs e) mIf = - sep [t"// APPROXIMATELY:", - t"method" <+> sep (xs ++ map (pvPrint d maxPrec) ps) <+> ppQuals d mqs <+> mIf <+> t "=", - nest 4 (pp d e)] + sep [t"// APPROXIMATELY:", + t"method" <+> sep (xs ++ map (pvPrint d maxPrec) ps) <+> ppQuals d mqs <+> mIf <+> t "=", + nest 4 (pp d e)] ppM d (CLValue i [CClause _ _ (Cinterface _ (Just i1) subIfc)] []) = sep ((t"interface"<+>pvpId d i1 <+> pvpId d i <>t";"): (map (\ si -> nest 2 (ppM d si)) subIfc) ++ - [t"endinterface:"<+> pvpId d i]) + [t"endinterface:"<+> pvpId d i]) ppM d (CLValue i [cl] me) = - (ppMClause d [pvpId d i] cl (optIf d me)) - $+$ t"endmethod:" <+> pvpId d i + (ppMClause d [pvpId d i] cl (optIf d me)) + $+$ t"endmethod:" <+> pvpId d i ppM d (CLValueSign (CDef i _ [cl]) me) = - (ppMClause d [pvpId d i] cl (optIf d me)) - $+$ t"endmethod:" <+> pvpId d i + (ppMClause d [pvpId d i] cl (optIf d me)) + $+$ t"endmethod:" <+> pvpId d i ppM d def = pvPrint d 0 def optIf d [] = empty @@ -470,7 +470,7 @@ findSpecialOps [] = ([],[],undefined) findSpecialOps [x] = ([x],[],undefined) findSpecialOps [x,y] = internalError "bad list of operators and operands" findSpecialOps ((CRand e1):(CRator _ i):(CRand e2):xs) | - (isIdChar (head (getBSVIdString i)) || (getBSVIdString i =="++")) = + (isIdChar (head (getBSVIdString i)) || (getBSVIdString i =="++")) = let w = CBinOp e1 i e2 in findSpecialOps ((CRand w):xs) findSpecialOps (x:(y@(CRator _ i)):xs) | (getBSVIdString i) == "$" = @@ -488,25 +488,25 @@ instance PVPrint CExpr where pvPrint d p (CLam i e) = ppQuant "\\ " d p i e pvPrint d p (CLamT i ty e) = ppQuant "\\ " d p i e pvPrint d p (Cletrec [] e) = pparen (p > 0) $ - (t"/* empty letseq */" $+$ pp d e) + (t"/* empty letseq */" $+$ pp d e) --pvPrint d p (Cletrec ds e) = pparen (p > 0) $ - -- (t"let" <+> foldr1 ($+$) (map (pp d) ds)) $+$ + -- (t"let" <+> foldr1 ($+$) (map (pp d) ds)) $+$ -- (t"in " <> pp d e) pvPrint d p (Cletrec ds e) = t "/* letrec */" $+$ - if (p>1) then t"(begin" <+> ppLet <>t";"$+$ t"end)" - else if (p==1) then t"begin" <+> ppLet <>t";"$+$ t"end" - else ppLet + if (p>1) then t"(begin" <+> ppLet <>t";"$+$ t"end)" + else if (p==1) then t"begin" <+> ppLet <>t";"$+$ t"end" + else ppLet where ppLet = ((foldr1 ($+$) (map (pp d) ds)) $+$ pparen True (pp d e)) pvPrint d p (Cletseq [] e) = pparen (p > 0) $ - (t"let in" <+> pp d e) + (t"let in" <+> pp d e) --pvPrint d p (Cletrec ds e) = pparen (p > 0) $ - -- (t"let" <+> foldr1 ($+$) (map (pp d) ds)) $+$ + -- (t"let" <+> foldr1 ($+$) (map (pp d) ds)) $+$ -- (t"in " <> pp d e) pvPrint d p (Cletseq ds e) = - if (p>1) then t"(begin" <+> ppLet <>t";"$+$ t"end)" - else if (p==1) then t"begin" <+> ppLet <>t";"$+$ t"end" - else ppLet + if (p>1) then t"(begin" <+> ppLet <>t";"$+$ t"end)" + else if (p==1) then t"begin" <+> ppLet <>t";"$+$ t"end" + else ppLet where ppLet = ((foldr1 ($+$) (map (pp d) ds)) $+$ pparen True (pp d e)) -- undo ._read desugaring pvPrint d p (CSelect e i) | i `qualEq` id_read noPosition = pvPrint d p e @@ -528,17 +528,17 @@ instance PVPrint CExpr where (pvpId d i) <+> pparen True (sepList(map (pvPrint d 1) as) (t",")) pvPrint d p (Ccase pos e arms) = - if (p>1) then t"(begin" <+> ppCase d e arms $+$ t"end)" - else if (p==1) then t"begin" <+> ppCase d e arms $+$ t"end" - else ppCase d e arms + if (p>1) then t"(begin" <+> ppCase d e arms $+$ t"end)" + else if (p==1) then t"begin" <+> ppCase d e arms $+$ t"end" + else ppCase d e arms pvPrint d p (CAny {}) = text "?" pvPrint d p (CVar i) = pvpId d i pvPrint d p (CStruct tyc []) | tyc == idPrimUnit = text "()" pvPrint d p (CStruct tyc ies) = pparen (p > 0) $ pvPrint d (maxPrec+1) tyc <+> t "{" <+> sepList (map f ies ) (t",") <> t"}" - where f (i, e) = pvpId d i <+> t ":" <+> pp d e + where f (i, e) = pvpId d i <+> t ":" <+> pp d e pvPrint d p (CStructUpd e ies) = ppStrUpd d e ies --- sep (pvPrint d (maxPrec-1) e : map (nest 2 . ppApArg) es) +-- sep (pvPrint d (maxPrec-1) e : map (nest 2 . ppApArg) es) -- where ppApArg e = pvPrint d maxPrec e pvPrint d p (Cwrite pos e v) = pparen (p > 0) $ pvPrint d (maxPrec+1) e <+> t "<=" <+> pvPrint d p v pvPrint d p (CApply (CVar i) [pos, v, idx]) | i == idPrimSelectFn noPosition = @@ -548,9 +548,9 @@ instance PVPrint CExpr where = pparen (p>(maxPrec-1)) $ t"valueOf" <> pparen True (pp d ty) pvPrint d p (CApply (CVar i) - [CHasType the_lit@(CLit (CLiteral _ - ( LInt (IntLit w b v)))) - (CQType [] (TAp (TCon (TyCon i2 _ _)) (TCon (TyNum nTy _))))]) + [CHasType the_lit@(CLit (CLiteral _ + ( LInt (IntLit w b v)))) + (CQType [] (TAp (TCon (TyCon i2 _ _)) (TCon (TyNum nTy _))))]) | getIdBaseString i == "unpack" && getIdBaseString i2 == "Bit" = (t $ show nTy) <> (pp d the_lit) @@ -574,23 +574,23 @@ instance PVPrint CExpr where pvPrint d p (Cmodule _ is) = t"module " $+$ pBlock d 2 False (map (pp d) (reorderStmts is)) empty (t"endmodule") -- pvPrint d p (Cinterface Nothing ds) = --- (t"interface {" $+$ pBlock d 2 False (map (pp d) ds) (t";") (t"}")) +-- (t"interface {" $+$ pBlock d 2 False (map (pp d) ds) (t";") (t"}")) pvPrint d p (Cinterface pos Nothing ds) = - (pBlockNT d 0 False (map (ppM d) ds) empty) + (pBlockNT d 0 False (map (ppM d) ds) empty) -- pvPrint d p (CLValueSign def me) = optWhen d me $ pvPrint d p def pvPrint d p (Cinterface pos (Just i) ds) = - (t"interface" <+> pp d i) $+$ - (pBlock d 2 False (map (ppM d) ds) empty (t"endinterface:" <+> pp d i)) + (t"interface" <+> pp d i) $+$ + (pBlock d 2 False (map (ppM d) ds) empty (t"endinterface:" <+> pp d i)) pvPrint d p (CmoduleVerilog m ui c r ses fs sch ps) = - sep [ - t"(unexpected) module verilog" <+> pp d m <> t";", - (if c==(ClockInfo [][][][]) then empty else pPrint d p c), + sep [ + t"(unexpected) module verilog" <+> pp d m <> t";", + (if c==(ClockInfo [][][][]) then empty else pPrint d p c), (if r==(ResetInfo [][]) then empty else pPrint d p r), - nest 4 (if null ses then empty else pparen True (sepList (map ppA ses) (t","))), - nest 4 (t"{" $+$ pBlock d 2 False (map (ppVeriMethod d Nothing) fs) (t";") (t"}")), - nest 4 (pp d sch), - nest 4 (pp d ps) ] - where ppA (s, e) = text "(" <> text (show s) <> text "," <+> pp d e <> text ")" + nest 4 (if null ses then empty else pparen True (sepList (map ppA ses) (t","))), + nest 4 (t"{" $+$ pBlock d 2 False (map (ppVeriMethod d Nothing) fs) (t";") (t"}")), + nest 4 (pp d sch), + nest 4 (pp d ps) ] + where ppA (s, e) = text "(" <> text (show s) <> text "," <+> pp d e <> text ")" pvPrint d p (CForeignFuncC i wrap_ty) = t"(unexpected) ForeignFuncC" <+> pp d i pvPrint d p (Cdo _ ss) = pparen (p>0) $ t "actionvalue" $+$ nest 2 (ppActions d ss True) $+$ t "endactionvalue" @@ -605,7 +605,7 @@ instance PVPrint CExpr where pvPrint d p (COper ops) = let (ys,zs,i) = findSpecialOps ops in if (null zs) then pparen (p > maxPrec-1) (sep (map (pvPrint d (maxPrec-1)) ys)) - else ppOp d p i (COper ys) (COper zs) + else ppOp d p i (COper ys) (COper zs) ---- pvPrint d p (CCon1 _ i e) = pvPrint d p (CCon i [e]) pvPrint d p (CSelectTT _ e i) = pvPrint d p (CSelect e i) @@ -614,16 +614,16 @@ instance PVPrint CExpr where ---- pvPrint d p (CConT _ i es) = pvPrint d p (CCon i es) pvPrint d p (CStructT ty ies) = pvPrint d p (CStruct tyc ies) - where (Just tyc) = leftCon ty + where (Just tyc) = leftCon ty pvPrint d p (CSelectT _ i) = text "." <> pvpId d i pvPrint d p (CLitT _ l) = pvPrint d p l pvPrint d p (CAnyT pos uk t) = text "?" pvPrint d p (CmoduleVerilogT _ m ui c r ses fs sch ps) = - pvPrint d p (CmoduleVerilog m ui c r ses fs sch ps) + pvPrint d p (CmoduleVerilog m ui c r ses fs sch ps) pvPrint d p (CForeignFuncCT i prim_ty) = t"(unexpected) ForeignFuncC" <+> pp d i pvPrint d p (CTApply e ts) = pparen (p>(maxPrec-1)) $ - sep (pvPrint d (maxPrec-1) e : map (nest 2 . ppApArg) ts) + sep (pvPrint d (maxPrec-1) e : map (nest 2 . ppApArg) ts) where ppApArg ty = t"\183" <> pvPrint d maxPrec ty pvPrint d p (Cattributes pps) = text "Attributes" <> pparen True (pvPrint d 0 (map snd pps)) @@ -644,17 +644,17 @@ separgs d e = (pp d e, empty) instance PVPrint CStmt where pvPrint d p (CSBindT (CPVar i) maybeInstName pprops (CQType _ ty) e) = let -- (tx, tys) = unravel ty - (ep, argsp) = separgs d e + (ep, argsp) = separgs d e instName = case maybeInstName of Just name -> pp d name Nothing -> text "the_" <> pp d i - isInst = isInstantiating e + isInst = isInstantiating e in foldr ($+$) empty (map (pvpPProp d . snd) pprops) $+$ - (pp d ty <> t"" <+> pp d i <> t(if isInst then "();" else ";")) $+$ - (if isInst - then ep <> {- f tys <> -} argsp <+> instName <> t"(" <> pp d i <> t");" - else pp d i <+> t "<-" <+> pp d e <> t";") + (pp d ty <> t"" <+> pp d i <> t(if isInst then "();" else ";")) $+$ + (if isInst + then ep <> {- f tys <> -} argsp <+> instName <> t"(" <> pp d i <> t");" + else pp d i <+> t "<-" <+> pp d e <> t";") pvPrint d p (CSBindT pat _ pprops ty e) = foldr ($+$) empty $ @@ -688,9 +688,9 @@ instance PVPrint CMStmt where pvPrint d p (CMinterface (Cinterface pos (Just _) e )) = pvPrint d p (Cinterface pos Nothing e) pvPrint d p (CMinterface e) = pvPrint d p e pvPrint d p (CMTupleInterface _ es) = - let n = length es + let n = length es in t ("return(tuple"++show n++"(") <> - sepList (map (pvPrint d p) es) (text ",") <> text "));" + sepList (map (pvPrint d p) es) (text ",") <> text "));" prDump d es = text "{-# dump" <+> sepList (map (pp d) es) (text ",") <+> text "#-}" @@ -713,7 +713,7 @@ ppCase detail scrutinee arms = sep [ppPat (cca_pattern arm) <+> ppQuals detail (cca_filters arm) <+> t ": ", nest 2 (ppCaseBody detail (cca_consequent arm))] <> t";" - ppPat pt = pp detail pt + ppPat pt = pp detail pt findPs (CBinOp e1 i e2) | getBSVIdString i == "," = e1:(findPs e2) findPs e = [e] @@ -731,10 +731,10 @@ ppOp d pd i p1 p2 = "," -> let ps = p1:(findPs p2) in ppTuple d ps "$" -> ppr (case p1 of - (CApply e es) -> pvPrint d 0 (CApply e (es++[p2])) - (CCon i es) -> pvPrint d 0 (CCon i (es++[p2])) - _ -> rand1 <> pparen True rand2 - ) + (CApply e es) -> pvPrint d 0 (CApply e (es++[p2])) + (CCon i es) -> pvPrint d 0 (CCon i (es++[p2])) + _ -> rand1 <> pparen True rand2 + ) "++" -> t"{" <> sepList (map (pvPrint d 0) [p1,p2]) (t",") <> t"}" "<+" -> ppr(t "preempts" <> pparen True (sep [ rand1 <> t",", rand2])) "+>" -> ppr(t "preempted" <> pparen True (sep [ rand1 <> t",", rand2])) @@ -807,8 +807,8 @@ ppVeriMethod d mr (Method i mc mreset n pts mo me) = let f _ _ Nothing = empty f before after (Just (VName vn, prs)) = (case prs of - [] -> empty - xs -> t"(*" <+> sepList (map (pvPrint d 0) xs) (t ",") <> t" *) ") <> + [] -> empty + xs -> t"(*" <+> sepList (map (pvPrint d 0) xs) (t ",") <> t" *) ") <> (t (before ++ vn ++ after)) in t"method " <> @@ -837,28 +837,28 @@ instance PVPrint CDef where pvPrint d p (CDef i (CQType ps ty) [CClause cps [] (CmoduleVerilog m ui c r args meths sch pts)]) | all isVar cps = let (ys, x) = getArrows ty - ity = case x of (TAp (TCon _) y) -> y; - z -> z - s (CLit (CLiteral _ (LString x))) = x - s x = internalError ("pvPrint CDef not lit: " ++ show x) + ity = case x of (TAp (TCon _) y) -> y; + z -> z + s (CLit (CLiteral _ (LString x))) = x + s x = internalError ("pvPrint CDef not lit: " ++ show x) f [] = empty f xs = t"#(" <> - sepList (zipWith (\ x c -> -- t"parameter" <+> - pvPrint d 0 x <> t"" <+> pvPrint d 10 c) - xs cps) - (t",") <> t")" - pOutMClk Nothing = empty - pOutMClk (Just ((VName s), mg)) = t s <> pOutMGate mg - pOutMGate Nothing = empty - pOutMGate (Just (VName s, vpps)) = t", " <> ppPortProps d vpps <> t s - pInMClk Nothing = empty - pInMClk (Just ((VName s), mg)) = t s <> pInMGate mg - -- these technically need a placeholder gate name (CLK_GATE?) - pInMGate (Left True) = empty -- text ", (* inhigh *)" + sepList (zipWith (\ x c -> -- t"parameter" <+> + pvPrint d 0 x <> t"" <+> pvPrint d 10 c) + xs cps) + (t",") <> t")" + pOutMClk Nothing = empty + pOutMClk (Just ((VName s), mg)) = t s <> pOutMGate mg + pOutMGate Nothing = empty + pOutMGate (Just (VName s, vpps)) = t", " <> ppPortProps d vpps <> t s + pInMClk Nothing = empty + pInMClk (Just ((VName s), mg)) = t s <> pInMGate mg + -- these technically need a placeholder gate name (CLK_GATE?) + pInMGate (Left True) = empty -- text ", (* inhigh *)" pInMGate (Left False) = text ", (* unused *)" - pInMGate (Right (VName s)) = t", " <> t s + pInMGate (Right (VName s)) = t", " <> t s noInputResets = null (input_resets r) - (mId,ps') = findModId ps + (mId,ps') = findModId ps in (if isModule mId x -- xxx readies xxx then (((pBlockNT d 0 False @@ -866,29 +866,29 @@ instance PVPrint CDef where t" = module" <+> pvpId d i <> f ys <> t"(" <> pvPrint d 0 ity <> t")", if ps'==[] then empty - else t " provisos (" <> sepList (map (pvPrint d 0) ps') (t ",") <> t")"] empty) + else t " provisos (" <> sepList (map (pvPrint d 0) ps') (t ",") <> t")"] empty) <> (t";")) $+$ - (pBlock d 2 False - ((let ClockInfo in_cs out_cs as ss = c - in ((map (\ (i, mc) -> - -- we could print this as "input_clock" if we want - t"clock" <+> pp d i <+> t"(" <> pOutMClk mc <> t")") out_cs) ++ - (map (\ (i, mc) -> - -- we could print this as "output_clock" if we want - t"clock" <+> pp d i <+> t"(" <> pInMClk mc <> t")") in_cs) ++ - (map (\ (i1, i2) -> t"ancestor" <+> pp d i1 <>t","<+> pp d i2) as) ++ - (map (\ (i1, i2) -> t"sibling" <+> pp d i1 <>t","<+> pp d i2) ss))) ++ - (if noInputResets then [t"no_reset"] else []) ++ - (map (pPrint d p) (input_resets r)) ++ -- XXX is this right? - (map (pPrint d p) (output_resets r)) ++ -- XXX is this right? - (map (ppVeriArg d) args) ++ - (map (ppVeriMethod d Nothing) meths) ++ - (ppSchedInfo d p sch) ++ - [ppPathInfo d p pts]) - (t";") - (t"endmodule:" <+> pp d i))) + (pBlock d 2 False + ((let ClockInfo in_cs out_cs as ss = c + in ((map (\ (i, mc) -> + -- we could print this as "input_clock" if we want + t"clock" <+> pp d i <+> t"(" <> pOutMClk mc <> t")") out_cs) ++ + (map (\ (i, mc) -> + -- we could print this as "output_clock" if we want + t"clock" <+> pp d i <+> t"(" <> pInMClk mc <> t")") in_cs) ++ + (map (\ (i1, i2) -> t"ancestor" <+> pp d i1 <>t","<+> pp d i2) as) ++ + (map (\ (i1, i2) -> t"sibling" <+> pp d i1 <>t","<+> pp d i2) ss))) ++ + (if noInputResets then [t"no_reset"] else []) ++ + (map (pPrint d p) (input_resets r)) ++ -- XXX is this right? + (map (pPrint d p) (output_resets r)) ++ -- XXX is this right? + (map (ppVeriArg d) args) ++ + (map (ppVeriMethod d Nothing) meths) ++ + (ppSchedInfo d p sch) ++ + [ppPathInfo d p pts]) + (t";") + (t"endmodule:" <+> pp d i))) else t "ERROR (for verilog module): module not of module type" - ) + ) -- for bsc2bsv, if CForeignFuncC is ever supported in Classic pvPrint d p (CDef bsv_id cqt [CClause [] [] (CForeignFuncC c_id _)]) = @@ -912,9 +912,9 @@ instance PVPrint VPathInfo where ppSchedInfo d p (SchedInfo mci rms rbm ccm) = let ds = makeMethodConflictDocs (pvPrint d p) pvpReadable "(" ")" mci - mci_docs = map (\x -> text "schedule" <+> x) ds - rms_docs = map (\p -> text "rule_between" <+> pvPrint d 0 p) rms - rbm_docs = map (\p -> text "rule_before" <+> pvPrint d 0 p) rbm + mci_docs = map (\x -> text "schedule" <+> x) ds + rms_docs = map (\p -> text "rule_between" <+> pvPrint d 0 p) rms + rbm_docs = map (\p -> text "rule_before" <+> pvPrint d 0 p) rbm ccm_docs = map (\p -> text "cross-domain" <+> pvPrint d 0 p) ccm in mci_docs ++ rms_docs ++ rbm_docs ++ ccm_docs @@ -924,7 +924,7 @@ ppBodyLets d (d1:ds) = ppBody :: PDetail -> Bool -> CExpr -> Doc ppBody d isMod (Cletrec [CLValueSign (CDef i1 t1 c1) q1] - (Cletrec [CLValueSign (CDef i2 _ _) _] e)) + (Cletrec [CLValueSign (CDef i2 _ _) _] e)) | i1 == mkIdPost i2 fsAcute = ppBodyLets d [CLValueSign (CDef i2 t1 c1) q1] $+$ (ppBody d isMod e) @@ -947,10 +947,10 @@ ppValueSignRest d i ps isFnT isMod line1 cexp ender = [line1, if ps==[] then empty - else t " provisos (" <> sepList (map (pvPrint d 0) ps) (t",") <> t")"] empty)<> (t";")) $+$ + else t " provisos (" <> sepList (map (pvPrint d 0) ps) (t",") <> t")"] empty)<> (t";")) $+$ (if isFnT then (ppBody d isMod cexp $+$ t ("end"++ender++":") <+> i) - else (i <+> t "=" <+> pvPrint d 2 cexp <> t ";")) + else (i <+> t "=" <+> pvPrint d 2 cexp <> t ";")) ppValueSign :: PDetail -> Id -> [TyVar] -> CQType -> [CClause] -> Doc @@ -961,14 +961,14 @@ ppValueSign d i [] (CQType ps ty) [CClause cs [] cexp] | all isVar cs = in ppValueSignRest d id ps' (isFn ty) False line1 cexp "function" ppValueSign d i [] ty cs = - (pvpId d i <+> t "::" <+> pp d ty <> t";") $+$ - foldr1 ($+$) (map (\ cl -> ppClause d [pvpId d i] cl) cs) + (pvpId d i <+> t "::" <+> pp d ty <> t";") $+$ + foldr1 ($+$) (map (\ cl -> ppClause d [pvpId d i] cl) cs) ppValueSign d i vs ty cs = - (pvpId d i <+> t ":: /\\" <> sep (map (pvPrint d maxPrec) vs) <> t"." <> pp d ty <> t";") $+$ - foldr1 ($+$) (map (\ cl -> ppClause d [pvpId d i] cl) cs) + (pvpId d i <+> t ":: /\\" <> sep (map (pvPrint d maxPrec) vs) <> t"." <> pp d ty <> t";") $+$ + foldr1 ($+$) (map (\ cl -> ppClause d [pvpId d i] cl) cs) ppRuleBody d (Cletrec ds (Caction _ ss)) = - (foldr1 ($+$) (map (pp d) ds)) $+$ ppActions d ss True + (foldr1 ($+$) (map (pp d) ds)) $+$ ppActions d ss True ppRuleBody d (Caction _ ss) = ppActions d ss True ppRuleBody d e = pp d e <> t";" @@ -979,21 +979,21 @@ ppRuleName d (Just i) = pp d i instance PVPrint CRule where pvPrint d p (CRule [] mlbl mqs e) = - (t"rule" <+> ppRuleName d mlbl) <+> ppRQuals d mqs $+$ - nest 3 (ppRuleBody d e) $+$ - (case mlbl of Just _ -> t "endrule:" <+> ppRuleName d mlbl; - _ -> t"endrule") + (t"rule" <+> ppRuleName d mlbl) <+> ppRQuals d mqs $+$ + nest 3 (ppRuleBody d e) $+$ + (case mlbl of Just _ -> t "endrule:" <+> ppRuleName d mlbl; + _ -> t"endrule") pvPrint d p (CRule rps mlbl mqs e) = - ppRPS d rps $+$ - (t"rule" <+> ppRuleName d mlbl) <+> ppRQuals d mqs $+$ - nest 3 (ppRuleBody d e) $+$ - (case mlbl of Just _ -> t "endrule:" <+> ppRuleName d mlbl; - _ -> t"endrule") + ppRPS d rps $+$ + (t"rule" <+> ppRuleName d mlbl) <+> ppRQuals d mqs $+$ + nest 3 (ppRuleBody d e) $+$ + (case mlbl of Just _ -> t "endrule:" <+> ppRuleName d mlbl; + _ -> t"endrule") pvPrint d p (CRuleNest rps mlbl mqs rs) = - ppRPS d rps $+$ t"rule" <+> ppRuleName d mlbl <+> - (ppQuals d mqs $+$ pBlock d 2 False (map (pp d) rs) (t";") (t"endrule")) + ppRPS d rps $+$ t"rule" <+> ppRuleName d mlbl <+> + (ppQuals d mqs $+$ pBlock d 2 False (map (pp d) rs) (t";") (t"endrule")) ppRPS d [] = empty ppRPS d rps = t"(*" <+> sepList (map ppRP rps) (t",") <+> t "*)" @@ -1024,13 +1024,13 @@ pUnmkTuple x = [x] instance PVPrint CDefl where pvPrint d p (CLValueSign def me) = optWhen d me $ pvPrint d p def pvPrint d p (CLValue i cs me) = optWhen d me $ - foldr1 ($+$) (map (\ cl -> ppClause d [pvpId d i] cl) cs) + foldr1 ($+$) (map (\ cl -> ppClause d [pvpId d i] cl) cs) -- pvPrint d p (CLMatch ps@(CPCon i _) e) | getIdBaseString i == "," = -- t "match {" <> (catList(map (pvPrint d maxPrec) (pUnmkTuple ps)) (t","))<>t"} =" $+$ --- nest 4 (pp d e) <> t";" +-- nest 4 (pp d e) <> t";" pvPrint d p (CLMatch pat e) = - t"match"<+> pp d pat <+> t"=" $+$ - nest 4 (pp d e) <> t";" + t"match"<+> pp d pat <+> t"=" $+$ + nest 4 (pp d e) <> t";" optWhen d [] s = s optWhen d qs s = s $+$ (t" " <> ppQuals d qs) @@ -1040,13 +1040,13 @@ instance PVPrint CClause where ppClause :: PDetail -> [Doc] -> CClause -> Doc ppClause d xs (CClause [] mqs e) = - sep [t"let" <+> sep xs <> ppQuals d mqs <+> t "= ", - nest 4 (pp d e)] + sep [t"let" <+> sep xs <> ppQuals d mqs <+> t "= ", + nest 4 (pp d e)] <> t";" ppClause d xs (CClause ps [] e) = let ids' = xs ++ map (ppCP d) ps (i:ids) = if null ids' then internalError "CVPrint.ppClause" else ids' - line1 = ppUntypedId d i ids + line1 = ppUntypedId d i ids in ppValueSignRest d i [] True False line1 e "function" ppClause d xs (CClause ps mqs e) = @@ -1058,9 +1058,9 @@ ppCP d p = xs -> t"{"<>(catList(map (pp d) xs) (t","))<>t"}" instance PVPrint CQual where - pvPrint d p (CQGen _ pattern expr) = + pvPrint d p (CQGen _ pattern expr) = pp d expr <+> t "matches" <+> pp d expr - pvPrint d p (CQFilter e) = pp d e + pvPrint d p (CQFilter e) = pp d e instance PVPrint CPat where @@ -1076,30 +1076,30 @@ instance PVPrint CPat where pvPrint d p pat@(CPCon i as) = let notTpl = getIdString i /= "," - bs = if notTpl then as else pUnmkTuple pat + bs = if notTpl then as else pUnmkTuple pat in pparen (notTpl && p>(maxPrec-1)) $ (if notTpl then t"tagged" <+> pvpId d i else empty )<+> t "{" <> (catList(map (pvPrint d maxPrec) bs) (t","))<>t"}" pvPrint d p (CPstruct tyc []) | tyc == idPrimUnit = text "()" pvPrint d p (CPstruct tyc [(_, fst), (_, snd)]) | tyc == idPrimPair = - pparen True (pvPrint d 0 fst <> t"," <+> pvPrint d 0 snd) + pparen True (pvPrint d 0 fst <> t"," <+> pvPrint d 0 snd) pvPrint d p (CPstruct i fs) = pparen (p>(maxPrec-1)) $ pvpId d i <+> t "{" <+> sep (map ppFld fs ++ [t"}"]) - where ppFld (i, CPVar i') | i == i' = pvpId d i <> t";" - ppFld (i, p) = pvpId d i <+> t "=" <+> pp d p <> t";" + where ppFld (i, CPVar i') | i == i' = pvpId d i <> t";" + ppFld (i, p) = pvpId d i <+> t "=" <+> pp d p <> t";" pvPrint d p (CPAs a pp) = pvPrint d maxPrec a <> t"@" <> pvPrint d maxPrec pp pvPrint d p (CPAny _) = text ".*" pvPrint d p (CPLit l) = pvPrint d p l pvPrint d p (CPMixedLit _ base ps) = - let digitBits = log2 base + let digitBits = log2 base f (len, Just val) = integerFormat (len `div` digitBits) base val - f (len, Nothing) = genericReplicate (len `div` digitBits) '?' - pref 2 = "'b" - pref 8 = "'o" - pref 10 = "'d" - pref 16 = "'h" - pref x = internalError ("bad radix to CPMixedLit: " ++ show x) - in text (pref base ++ concatMap f ps) + f (len, Nothing) = genericReplicate (len `div` digitBits) '?' + pref 2 = "'b" + pref 8 = "'o" + pref 10 = "'d" + pref 16 = "'h" + pref x = internalError ("bad radix to CPMixedLit: " ++ show x) + in text (pref base ++ concatMap f ps) pvPrint d p (CPOper ops) = pparen (p > maxPrec-1) (sep (map (pvPrint d (maxPrec-1)) ops)) pvPrint d p (CPCon1 _ i a) = pvPrint d p (CPCon i [a]) ---- @@ -1138,13 +1138,13 @@ tUnmkTuple x = [x] instance PVPrint Type where pvPrint d p (TCon (TyCon special _ _)) | special == idPrimUnit = text "void" - -- These are needed when printing a function/method, - -- because Action/ActionValue are keywords which introduce implicit - -- action..endaction or actionvalue..endactionvalue blocks. - -- It used to be that displaying "Prelude::Action" would print - -- broken code, because then it's no longer using the keyword. - -- So this code is to ensure that those places print the keyword, - -- but it affects all other printing of the type, too. + -- These are needed when printing a function/method, + -- because Action/ActionValue are keywords which introduce implicit + -- action..endaction or actionvalue..endactionvalue blocks. + -- It used to be that displaying "Prelude::Action" would print + -- broken code, because then it's no longer using the keyword. + -- So this code is to ensure that those places print the keyword, + -- but it affects all other printing of the type, too. | special == idAction = text "Action" | special == idActionValue = text "ActionValue" pvPrint d p (TCon c) = pvPrint d 0 c @@ -1156,11 +1156,11 @@ instance PVPrint Type where pvPrint d p ty@(TAp (TAp (TCon special) a) b) | isTConPair special = let ts = tUnmkTuple ty - n = length ts + n = length ts in t"Tuple" <> t(show n) <> pvParameterTypes d ts | isTConArrow special = pparen (p > 8) (ppTypedId d Nothing (t"f") ty newIds) --- pparen (p > 8) (sep [pvPrint d 9 a <+> text "->", pvPrint d 8 r]) +-- pparen (p > 8) (sep [pvPrint d 9 a <+> text "->", pvPrint d 8 r]) pvPrint d p (TAp e e') = pparen (p>9) $ let (x, ys) = unravel (TAp e e') in pvPrint d 9 x <> t"#(" <> sepList (map (pvPrint d 0) ys) (text ",") <> t")" diff --git a/src/comp/Classic.hs b/src/comp/Classic.hs index 51bce5427..81cb9e5a1 100644 --- a/src/comp/Classic.hs +++ b/src/comp/Classic.hs @@ -7,7 +7,7 @@ import IOMutVar(MutableVar, newVar, readVar, writeVar) import System.IO.Unsafe(unsafePerformIO) data SyntaxMode = BSV | CLASSIC | ESE - deriving Eq + deriving Eq syntax :: MutableVar SyntaxMode syntax = unsafePerformIO $ (newVar CLASSIC) diff --git a/src/comp/CtxRed.hs b/src/comp/CtxRed.hs index b8dba293c..a3b5b39fd 100644 --- a/src/comp/CtxRed.hs +++ b/src/comp/CtxRed.hs @@ -56,28 +56,28 @@ instance CtxRed CField where instance CtxRed CDefn where ctxRed (CValueSign d) = do - d' <- ctxRed d - return (CValueSign d') + d' <- ctxRed d + return (CValueSign d') -- primitives should be defined so they don't need ctxRed {- ctxRed (Cprimitive i cqt) = do - (_, cqt') <- ctxRedCQType cqt + (_, cqt') <- ctxRedCQType cqt popBoundTVs -- necessary after call to ctxRedCQType - return (Cprimitive i cqt') + return (Cprimitive i cqt') -} -- XXX do data&class? ctxRed (Cstruct vis ss idk vs fs ds) = do - fs' <- mapM ctxRed fs - return (Cstruct vis ss idk vs fs' ds) + fs' <- mapM ctxRed fs + return (Cstruct vis ss idk vs fs' ds) ctxRed (Cinstance cqt ds) = do - (s, cqt') <- ctxRedInstHead cqt - ds' <- ctxRed (apSub s ds) + (s, cqt') <- ctxRedInstHead cqt + ds' <- ctxRed (apSub s ds) popBoundTVs -- necessary after call to ctxRedCQType -- but only after we've recursed into the defs - return (Cinstance cqt' ds') + return (Cinstance cqt' ds') ctxRed f@(Cforeign {}) = do (_, cqt') <- ctxRedCQType (cforg_type f) @@ -114,72 +114,72 @@ instance CtxRed CDefn where instance CtxRed CDefl where ctxRed (CLValueSign d me) = do - d' <- ctxRed d - me' <- ctxRed me - return (CLValueSign d' me') + d' <- ctxRed d + me' <- ctxRed me + return (CLValueSign d' me') ctxRed (CLValue i cs me) = do - cs' <- ctxRed cs - me' <- ctxRed me - return (CLValue i cs' me') + cs' <- ctxRed cs + me' <- ctxRed me + return (CLValue i cs' me') ctxRed (CLMatch p e) = do - p' <- ctxRed p - e' <- ctxRed e - return (CLMatch p' e') + p' <- ctxRed p + e' <- ctxRed e + return (CLMatch p' e') instance CtxRed CDef where ctxRed (CDef i cqt cs) = do - (s, cqt') <- ctxRedCQType cqt - cs' <- ctxRed (apSub s cs) + (s, cqt') <- ctxRedCQType cqt + cs' <- ctxRed (apSub s cs) popBoundTVs -- necessary after call to ctxRedCQType -- but only after we've recursed into the defs - return (CDef i cqt' cs') + return (CDef i cqt' cs') ctxRed _ = internalError "TypeCheck instance CtxRed CDef" instance CtxRed CClause where ctxRed (CClause ps qs e) = do - qs' <- ctxRed qs - e' <- ctxRed e - return (CClause ps qs' e') + qs' <- ctxRed qs + e' <- ctxRed e + return (CClause ps qs' e') instance CtxRed CExpr where ctxRed (CLam i e) = do - e' <- ctxRed e - return (CLam i e') + e' <- ctxRed e + return (CLam i e') ctxRed (CLamT i qt e) = do -- CLamT does not bind type variable names, so we don't need to -- reduce "e" between "ctxRedCQType" and popping the bound tvs - e' <- ctxRed e - (_, qt') <- ctxRedCQType qt + e' <- ctxRed e + (_, qt') <- ctxRedCQType qt popBoundTVs -- necessary after call to ctxRedCQType - return (CLamT i qt' e') + return (CLamT i qt' e') ctxRed (Cletseq ds e) = do - ds' <- ctxRed ds - e' <- ctxRed e - return (Cletseq ds' e') + ds' <- ctxRed ds + e' <- ctxRed e + return (Cletseq ds' e') ctxRed (Cletrec ds e) = do - ds' <- ctxRed ds - e' <- ctxRed e - return (Cletrec ds' e') + ds' <- ctxRed ds + e' <- ctxRed e + return (Cletrec ds' e') ctxRed (CSelect e i) = do - e' <- ctxRed e - return (CSelect e' i) + e' <- ctxRed e + return (CSelect e' i) ctxRed (CSelectTT ti e i) = do - e' <- ctxRed e - return (CSelectTT ti e' i) + e' <- ctxRed e + return (CSelectTT ti e' i) ctxRed (CCon i es) = do - es' <- ctxRed es - return (CCon i es') + es' <- ctxRed es + return (CCon i es') ctxRed (Ccase pos e as) = do - e' <- ctxRed e - as' <- ctxRed as - return (Ccase pos e' as') + e' <- ctxRed e + as' <- ctxRed as + return (Ccase pos e' as') ctxRed (CStruct i ies) = do - ies' <- ctxRed ies - return (CStruct i ies') + ies' <- ctxRed ies + return (CStruct i ies') ctxRed (CStructUpd e ies) = do - e' <- ctxRed e - ies' <- ctxRed ies - return (CStructUpd e' ies') + e' <- ctxRed e + ies' <- ctxRed ies + return (CStructUpd e' ies') ctxRed (Cwrite pos e v) = do e' <- ctxRed e v' <- ctxRed v @@ -187,39 +187,39 @@ instance CtxRed CExpr where ctxRed e@(CAny {}) = return e ctxRed e@(CVar _) = return e ctxRed (CApply e es) = do - e' <- ctxRed e - es' <- ctxRed es - return (CApply e' es') + e' <- ctxRed e + es' <- ctxRed es + return (CApply e' es') ctxRed (CTaskApply e es) = do - e' <- ctxRed e - es' <- ctxRed es - return (CTaskApply e' es') + e' <- ctxRed e + es' <- ctxRed es + return (CTaskApply e' es') ctxRed e@(CLit _) = return e ctxRed (CBinOp e1 o e2) = do - e1' <- ctxRed e1 - e2' <- ctxRed e2 - return (CBinOp e1' o e2') + e1' <- ctxRed e1 + e2' <- ctxRed e2 + return (CBinOp e1' o e2') ctxRed (CHasType e cqt) = do -- CHasType does not bind type variable names, so we don't need to -- reduce "e" between "ctxRedCQType" and popping the bound tvs - e' <- ctxRed e - (_, cqt') <- ctxRedCQType cqt + e' <- ctxRed e + (_, cqt') <- ctxRedCQType cqt popBoundTVs -- necessary after call to ctxRedCQType - return (CHasType e' cqt') + return (CHasType e' cqt') ctxRed (Cif pos e1 e2 e3) = do - e1' <- ctxRed e1 - e2' <- ctxRed e2 - e3' <- ctxRed e3 - return (Cif pos e1' e2' e3') + e1' <- ctxRed e1 + e2' <- ctxRed e2 + e3' <- ctxRed e3 + return (Cif pos e1' e2' e3') ctxRed (CSub pos e1 e2) = do - e1' <- ctxRed e1 - e2' <- ctxRed e2 - return (CSub pos e1' e2') + e1' <- ctxRed e1 + e2' <- ctxRed e2 + return (CSub pos e1' e2') ctxRed (CSub2 e1 e2 e3) = do - e1' <- ctxRed e1 - e2' <- ctxRed e2 - e3' <- ctxRed e3 - return (CSub2 e1' e2' e3') + e1' <- ctxRed e1 + e2' <- ctxRed e2 + e3' <- ctxRed e3 + return (CSub2 e1' e2' e3') ctxRed (CSubUpdate pos e_vec (e_h, e_l) e_rhs) = do e_vec' <- ctxRed e_vec e_h' <- ctxRed e_h @@ -227,36 +227,36 @@ instance CtxRed CExpr where e_rhs' <- ctxRed e_rhs return (CSubUpdate pos e_vec' (e_h', e_l') e_rhs') ctxRed (CCon1 ti i e) = do - e' <- ctxRed e - return (CCon1 ti i e') + e' <- ctxRed e + return (CCon1 ti i e') ctxRed (Cmodule pos is) = do - is' <- ctxRed is - return (Cmodule pos is') + is' <- ctxRed is + return (Cmodule pos is') ctxRed (Cinterface pos mi ds) = do - ds' <- ctxRed ds - return (Cinterface pos mi ds') + ds' <- ctxRed ds + return (Cinterface pos mi ds') ctxRed (CmoduleVerilog m ui c r ses fs sch ps) = do - m' <- ctxRed m - ses' <- ctxRed ses - return (CmoduleVerilog m' ui c r ses' fs sch ps) + m' <- ctxRed m + ses' <- ctxRed ses + return (CmoduleVerilog m' ui c r ses' fs sch ps) -- the contexts on the cqt here are not a real type, -- but are extra info for better error reporting in tiExpr ctxRed e@(CForeignFuncC i cqt) = return e ctxRed (Cdo rec ss) = do - ss' <- ctxRed ss - return (Cdo rec ss') + ss' <- ctxRed ss + return (Cdo rec ss') ctxRed (Caction pos ss) = do - ss' <- ctxRed ss - return (Caction pos ss') + ss' <- ctxRed ss + return (Caction pos ss') ctxRed (Crules ps rs) = do - rs' <- ctxRed rs - return (Crules ps rs') + rs' <- ctxRed rs + return (Crules ps rs') ctxRed (CADump es) = do - es' <- ctxRed es - return (CADump es') + es' <- ctxRed es + return (CADump es') ctxRed (CConT ti i es) = do - es' <- ctxRed es - return (CConT ti i es') + es' <- ctxRed es + return (CConT ti i es') ctxRed e@(Cattributes _) = return e ctxRed e = internalError ("ctxRed: " ++ ppReadable e) @@ -267,74 +267,74 @@ instance CtxRed CStmt where ctxRed (CSBindT p name pprops qt e) = do -- CSBindT does not bind type variable names, so we don't need to -- reduce "e" between "ctxRedCQType" and popping the bound tvs - p' <- ctxRed p - e' <- ctxRed e - (_, qt') <- ctxRedCQType qt + p' <- ctxRed p + e' <- ctxRed e + (_, qt') <- ctxRedCQType qt popBoundTVs -- necessary after call to ctxRedCQType - return (CSBindT p name pprops qt' e') + return (CSBindT p name pprops qt' e') ctxRed (CSBind p name pprops e) = do - p' <- ctxRed p - e' <- ctxRed e - return (CSBind p name pprops e') + p' <- ctxRed p + e' <- ctxRed e + return (CSBind p name pprops e') ctxRed (CSletseq ds) = do - ds' <- ctxRed ds - return (CSletseq ds') + ds' <- ctxRed ds + return (CSletseq ds') ctxRed (CSletrec ds) = do - ds' <- ctxRed ds - return (CSletrec ds') + ds' <- ctxRed ds + return (CSletrec ds') ctxRed (CSExpr name e) = do - e' <- ctxRed e - return (CSExpr name e') + e' <- ctxRed e + return (CSExpr name e') instance CtxRed CMStmt where ctxRed (CMStmt s) = do - s' <- ctxRed s - return (CMStmt s') + s' <- ctxRed s + return (CMStmt s') ctxRed (CMrules e) = do - e' <- ctxRed e - return (CMrules e') + e' <- ctxRed e + return (CMrules e') ctxRed (CMinterface e) = do - e' <- ctxRed e - return (CMinterface e') + e' <- ctxRed e + return (CMinterface e') ctxRed (CMTupleInterface pos es) = do - es' <- mapM ctxRed es - return (CMTupleInterface pos es') + es' <- mapM ctxRed es + return (CMTupleInterface pos es') instance CtxRed CQual where ctxRed (CQGen t p e) = do - e' <- ctxRed e - return (CQGen t p e') + e' <- ctxRed e + return (CQGen t p e') ctxRed (CQFilter e) = do - e' <- ctxRed e - return (CQFilter e') + e' <- ctxRed e + return (CQFilter e') instance CtxRed CRule where ctxRed (CRule rps mi qs e) = do - mi' <- ctxRed mi - qs' <- ctxRed qs - e' <- ctxRed e - return (CRule rps mi' qs' e') + mi' <- ctxRed mi + qs' <- ctxRed qs + e' <- ctxRed e + return (CRule rps mi' qs' e') ctxRed (CRuleNest rps mi qs rs) = do - mi' <- ctxRed mi - qs' <- ctxRed qs - rs' <- ctxRed rs - return (CRuleNest rps mi' qs' rs') + mi' <- ctxRed mi + qs' <- ctxRed qs + rs' <- ctxRed rs + return (CRuleNest rps mi' qs' rs') instance (CtxRed a) => CtxRed [a] where ctxRed xs = mapM ctxRed xs instance (CtxRed a, CtxRed b) => CtxRed (a, b) where ctxRed (a, b) = do - a' <- ctxRed a - b' <- ctxRed b - return (a', b') + a' <- ctxRed a + b' <- ctxRed b + return (a', b') instance (CtxRed a, CtxRed b, CtxRed c) => CtxRed (a, b, c) where ctxRed (a, b, c) = do - a' <- ctxRed a - b' <- ctxRed b - c' <- ctxRed c - return (a', b', c') + a' <- ctxRed a + b' <- ctxRed b + c' <- ctxRed c + return (a', b', c') instance (CtxRed a) => CtxRed (Maybe a) where ctxRed Nothing = return Nothing @@ -375,8 +375,8 @@ ctxRedCQType' isInstHead cqt = do -- convert the CQType (using the assumptions we know) sy <- getSymTab (qs0 :=> t0) <- case convCQTypeWithAssumps sy btks cqt of - Left emsg -> err emsg - Right qt -> return qt + Left emsg -> err emsg + Right qt -> return qt -- do extra reduction on instance heads to avoid synonym-expansion -- and SizeOf issues, without unduly disturbing non-instance types diff --git a/src/comp/Deriving.hs b/src/comp/Deriving.hs index d2ef5ee03..50b268ce4 100644 --- a/src/comp/Deriving.hs +++ b/src/comp/Deriving.hs @@ -76,35 +76,35 @@ doDer :: Flags -> SymTab -> Id -> [(Id, CDefn)] -> CDefn -> [Either EMsg [CDefn]] doDer flags r packageid xs data_decl@(Cdata {}) = let unqual_name = iKName (cd_name data_decl) - qual_name = qualId packageid unqual_name + qual_name = qualId packageid unqual_name Just (TypeInfo _ kind _ _) = findType r qual_name - ty_var_names = cd_type_vars data_decl + ty_var_names = cd_type_vars data_decl ty_var_kinds = getArgKinds kind ty_vars = zipWith cTVarKind ty_var_names ty_var_kinds - orig_sums = cd_original_summands data_decl - int_sums = cd_internal_summands data_decl - derivs = cd_derivings data_decl + orig_sums = cd_original_summands data_decl + int_sums = cd_internal_summands data_decl + derivs = cd_derivings data_decl derivs' = addRequiredDerivs flags r qual_name ty_vars derivs -- XXX ignore derivs' to sneak in recursive data decls bad_rec_derivs = filter forbidsRecursiveInstance derivs in if (not (null bad_rec_derivs)) && (isRecursiveData unqual_name orig_sums) - then [Left (getPosition data_decl, - EDeriveRecursive (map (getIdString . typeclassId) bad_rec_derivs) (getIdString unqual_name))] - else Right [data_decl] : + then [Left (getPosition data_decl, + EDeriveRecursive (map (getIdString . typeclassId) bad_rec_derivs) (getIdString unqual_name))] + else Right [data_decl] : map (doDataDer xs qual_name ty_vars orig_sums int_sums) derivs' doDer flags r packageid xs struct_decl@(Cstruct _ s i ty_var_names fields derivs) = let unqual_name = iKName i - qual_name = qualId packageid unqual_name + qual_name = qualId packageid unqual_name Just (TypeInfo _ kind _ _) = findType r qual_name ty_var_kinds = getArgKinds kind ty_vars = zipWith cTVarKind ty_var_names ty_var_kinds derivs' = addRequiredDerivs flags r qual_name ty_vars derivs bad_rec_derivs = filter forbidsRecursiveInstance derivs' in if (not (null bad_rec_derivs)) && (isRecursiveStruct unqual_name fields) - then [Left (getPosition struct_decl, - EDeriveRecursive (map (getIdString . typeclassId) bad_rec_derivs) (getIdString unqual_name))] - else Right [struct_decl] : - map (doStructDer xs qual_name ty_vars fields) derivs' + then [Left (getPosition struct_decl, + EDeriveRecursive (map (getIdString . typeclassId) bad_rec_derivs) (getIdString unqual_name))] + else Right [struct_decl] : + map (doStructDer xs qual_name ty_vars fields) derivs' doDer flags r packageid xs prim_decl@(CprimType (IdKind i kind)) -- "special" typeclasses only need to be derived for ordinary types | res_kind /= KStar = [Right [prim_decl]] @@ -169,14 +169,14 @@ forbidsRecursiveInstance i = False isRecursiveData :: Id -> COSummands -> Bool isRecursiveData i ocs = let allCQTyCons (CQType _ ty) = allTConNames ty - types = unions (map (cos_arg_types) ocs) - cons = unions (map allCQTyCons types) + types = unions (map (cos_arg_types) ocs) + cons = unions (map allCQTyCons types) in i `elem` cons isRecursiveStruct :: Id -> CFields -> Bool isRecursiveStruct i fs = let allCQTyCons (CQType _ ty) = allTConNames ty - cons = unions (map (allCQTyCons . cf_type) fs) + cons = unions (map (allCQTyCons . cf_type) fs) in i `elem` cons -- my guesses at the arguments: @@ -189,7 +189,7 @@ isRecursiveStruct i fs = -- (an id and one type -- the list became a struct) -- di = the class to be derived doDataDer :: [(Id, CDefn)] -> Id -> [Type] -> COSummands -> CSummands -> - CTypeclass -> Either EMsg [CDefn] + CTypeclass -> Either EMsg [CDefn] doDataDer xs i vs ocs cs (CTypeclass di) | qualEq di idEq = Right [doDEq (getPosition di) i vs ocs cs] doDataDer xs i vs ocs cs (CTypeclass di) | qualEq di idBits = @@ -214,21 +214,21 @@ doDataDer xs i vs [cos@(COriginalSummand { cos_arg_types = [CQType _ ty]})] cs d fieldType = cos_arg_types cos fieldSet = S.fromList (tv fieldType) Just (Cclass _ _ _ [v] _ fs) = lookup (typeclassId di) xs - ity = foldl TAp (cTCon i) vs - inst = Cinstance (CQType [CPred di [ty]] (TAp (cTCon $ typeclassId di) ity)) (map conv fs) - conv (CField { cf_name = f, cf_type = CQType _ t }) = - CLValue (unQualId f) + ity = foldl TAp (cTCon i) vs + inst = Cinstance (CQType [CPred di [ty]] (TAp (cTCon $ typeclassId di) ity)) (map conv fs) + conv (CField { cf_name = f, cf_type = CQType _ t }) = + CLValue (unQualId f) [CClause [] [] (mkConv con coCon tmpVarXIds tv t (CVar f))] [] where (Just kind) = getTypeKind t tv = cTVarKind v kind - cn = getCOSName cos - con e = CCon cn [e] - coCon e = Ccase (getPosition di) - e - [CCaseArm { cca_pattern = CPCon cn [CPVar id_y], + cn = getCOSName cos + con e = CCon cn [e] + coCon e = Ccase (getPosition di) + e + [CCaseArm { cca_pattern = CPCon cn [CPVar id_y], cca_filters = [], - cca_consequent = CVar id_y }] + cca_consequent = CVar id_y }] doDataDer xs i vs ocs cs (CTypeclass di) = Left (getPosition di, ECannotDerive (pfpString di)) @@ -259,14 +259,14 @@ doStructDer xs i vs [field] di Just (Cclass _ _ _ [v] _ fs) = lookup (typeclassId di) xs ity = foldl TAp (cTCon i) vs CQType _ type_no_qual = fieldType - inst = Cinstance (CQType [CPred di [type_no_qual]] + inst = Cinstance (CQType [CPred di [type_no_qual]] (TAp (cTCon $ typeclassId di) ity)) (map conv fs) - conv (CField { cf_name = f, cf_type = CQType _ t }) = - CLValue (unQualId f) [CClause [] [] (mkConv con coCon tmpVarXIds tv t (CVar f))] [] + conv (CField { cf_name = f, cf_type = CQType _ t }) = + CLValue (unQualId f) [CClause [] [] (mkConv con coCon tmpVarXIds tv t (CVar f))] [] where (Just kind) = getTypeKind t tv = cTVarKind v kind - con e = CStruct i [(cf_name field, e)] - coCon e = CSelectTT i e (cf_name field) + con e = CStruct i [(cf_name field, e)] + coCon e = CSelectTT i e (cf_name field) doStructDer _ i vs cs (CTypeclass di) | isTCId i = -- ignore bad deriving, it should be handled in the data case Right [] @@ -279,18 +279,18 @@ doStructDer _ i vs cs (CTypeclass di) = doSEq :: Position -> Id -> [Type] -> CFields -> CDefn doSEq dpos ti vs fs = Cinstance (CQType ctx (TAp (cTCon idEq) ty)) [eq, ne] where ctx = map (\ (CField { cf_type = CQType _ t }) -> CPred (CTypeclass idEq) [t]) fs - ty = cTApplys (cTCon ti) vs - qt = CQType [] (ty `fn` ty `fn` tBool) - eq = CLValueSign (CDef (idEqualNQ dpos) qt [eqc]) [] - ne = CLValueSign (CDef (idNotEqualNQ dpos) qt [nec]) [] - eqc = CClause [CPVar id_x, CPVar id_y] [] eqb - nec = CClause [CPVar id_x, CPVar id_y] [] (eNot (cVApply idEqual [vx, vy])) - vx = CVar id_x - vy = CVar id_y - eqb = - case fs of - [] -> eTrue - fs -> foldr1 eAnd + ty = cTApplys (cTCon ti) vs + qt = CQType [] (ty `fn` ty `fn` tBool) + eq = CLValueSign (CDef (idEqualNQ dpos) qt [eqc]) [] + ne = CLValueSign (CDef (idNotEqualNQ dpos) qt [nec]) [] + eqc = CClause [CPVar id_x, CPVar id_y] [] eqb + nec = CClause [CPVar id_x, CPVar id_y] [] (eNot (cVApply idEqual [vx, vy])) + vx = CVar id_x + vy = CVar id_y + eqb = + case fs of + [] -> eTrue + fs -> foldr1 eAnd [cVApply idEqual [CSelectTT ti vx (cf_name field), CSelectTT ti vy (cf_name field)] | field <- fs ] @@ -299,38 +299,38 @@ doDEq :: Position -> Id -> [Type] -> COSummands -> CSummands -> CDefn doDEq dpos i vs ocs cs = Cinstance (CQType ctx (TAp (cTCon idEq) ty)) [eq, ne] where ctx | isEnum ocs = [] | otherwise = concat [(CPred (CTypeclass idEq) [t] : ps) | oc <- ocs, CQType ps t <- cos_arg_types oc ] - ty = cTApplys (cTCon i) vs - qt = CQType [] (ty `fn` ty `fn` tBool) - eq = CLValueSign (CDef (idEqualNQ dpos) qt [eqc]) [] - ne = CLValueSign (CDef (idNotEqualNQ dpos) qt [nec]) [] - eqc = CClause [CPVar id_x, CPVar id_y] [] eqb - nec = CClause [CPVar id_x, CPVar id_y] [] (eNot (cVApply idEqual [vx, vy])) - vx = CVar id_x - vy = CVar id_y - eqb | isEnum ocs = cVApply idEqual [hasSz (cVApply idPrimOrd [vx]) sz, + ty = cTApplys (cTCon i) vs + qt = CQType [] (ty `fn` ty `fn` tBool) + eq = CLValueSign (CDef (idEqualNQ dpos) qt [eqc]) [] + ne = CLValueSign (CDef (idNotEqualNQ dpos) qt [nec]) [] + eqc = CClause [CPVar id_x, CPVar id_y] [] eqb + nec = CClause [CPVar id_x, CPVar id_y] [] (eNot (cVApply idEqual [vx, vy])) + vx = CVar id_x + vy = CVar id_y + eqb | isEnum ocs = cVApply idEqual [hasSz (cVApply idPrimOrd [vx]) sz, cVApply idPrimOrd [vy]] - | otherwise = + | otherwise = Ccase dpos - vx - (map gen ocs ++ - [CCaseArm { cca_pattern = CPAny noPosition, - cca_filters = [], - cca_consequent = eFalse }]) - sz = cTNum (log2 (length ocs)) tpos - gen :: COriginalSummand -> CCaseArm - gen cos = + vx + (map gen ocs ++ + [CCaseArm { cca_pattern = CPAny noPosition, + cca_filters = [], + cca_consequent = eFalse }]) + sz = cTNum (log2 (length ocs)) tpos + gen :: COriginalSummand -> CCaseArm + gen cos = CCaseArm { cca_pattern = CPCon1 i cn (CPVar id_x1), cca_filters = [CQGen noType (CPCon1 i cn (CPVar id_y1)) vy], cca_consequent = cmp } - where ts = cos_arg_types cos - cn = getCOSName cos - n = length ts - id_x1 = head tmpVarXIds - id_y1 = head tmpVarYIds - cmp = if n == 0 then eTrue else cVApply idEqual [CVar id_x1, CVar id_y1] - tpos = getIdPosition i - + where ts = cos_arg_types cos + cn = getCOSName cos + n = length ts + id_x1 = head tmpVarXIds + id_y1 = head tmpVarYIds + cmp = if n == 0 then eTrue else cVApply idEqual [CVar id_x1, CVar id_y1] + tpos = getIdPosition i + -- ------------------------- @@ -338,66 +338,66 @@ doSBits :: Position -> Id -> [Type] -> CFields -> CDefn doSBits dpos ti vs fields = Cinstance (CQType ctx (cTApplys (cTCon idBits) [aty, sz])) [pk, un] where tiPos = getPosition ti ctx = bCtx ++ aCtx ++ cCtx - cCtx = concatMap (\ (CField { cf_type = CQType q _}) -> q) fields - bCtx = zipWith (\ (CField { cf_type = cqt@(CQType _ t) }) sv -> + cCtx = concatMap (\ (CField { cf_type = CQType q _}) -> q) fields + bCtx = zipWith (\ (CField { cf_type = cqt@(CQType _ t) }) sv -> CPred (CTypeclass idBits) [t, cTVarKind (setIdPosition (getPosition cqt) sv) KNum]) fields bvs - aCtx = let f _ [] _ = [] - f a (s:ss) (n:nn) = - CPred (CTypeclass idAdd) - [cTVarKind s KNum, cTVarKind a KNum, - cTVarKind n KNum] : f n ss nn - f _ _ _ = internalError "Deriving.doSBits.f: _ (_:_) []" - b:bs = reverse bvs - in if null fields then [] else f b bs avs - avs = take (n-1) (everyThird tmpTyVarIds) - bvs = take n (everyThird (tail tmpTyVarIds)) - sz = case fields of - [] -> cTNum 0 tiPos - [_] -> cTVarKind (setIdPosition tiPos (headOrErr "doSBits" bvs)) KNum - _ -> cTVarKind (setIdPosition tiPos (lastOrErr "doSBits" avs)) KNum - aty = cTApplys (cTCon ti) vs - bty = TAp (cTCon idBit) sz - n = length fields - - pk = CLValueSign (CDef (idPackNQ dpos) (CQType [] (aty `fn` bty)) [pkc]) [] - pkc = CClause [CPVar id_x] [] pkb - vx = CVar id_x - pkb = case fields of - [] -> anyExprAt tiPos - _ -> foldr1 eConcat + aCtx = let f _ [] _ = [] + f a (s:ss) (n:nn) = + CPred (CTypeclass idAdd) + [cTVarKind s KNum, cTVarKind a KNum, + cTVarKind n KNum] : f n ss nn + f _ _ _ = internalError "Deriving.doSBits.f: _ (_:_) []" + b:bs = reverse bvs + in if null fields then [] else f b bs avs + avs = take (n-1) (everyThird tmpTyVarIds) + bvs = take n (everyThird (tail tmpTyVarIds)) + sz = case fields of + [] -> cTNum 0 tiPos + [_] -> cTVarKind (setIdPosition tiPos (headOrErr "doSBits" bvs)) KNum + _ -> cTVarKind (setIdPosition tiPos (lastOrErr "doSBits" avs)) KNum + aty = cTApplys (cTCon ti) vs + bty = TAp (cTCon idBit) sz + n = length fields + + pk = CLValueSign (CDef (idPackNQ dpos) (CQType [] (aty `fn` bty)) [pkc]) [] + pkc = CClause [CPVar id_x] [] pkb + vx = CVar id_x + pkb = case fields of + [] -> anyExprAt tiPos + _ -> foldr1 eConcat [cVApply idPack [CSelectTT ti vx (cf_name field)] | field <- fields] - un = CLValueSign (CDef (idUnpackNQ dpos) (CQType [] (bty `fn` aty)) [unc]) [] - unc = CClause [CPVar id_x] [] ukb - ukb = case fields of - [] -> CStruct ti [] - [field] -> CStruct ti [(cf_name field, cVApply idUnpack [vx])] - _ -> let xs = take (n-1) tmpVarXIds - bind = mkBind vx xs - mkBind o [] = id - mkBind o (x:xs) = - monoDef x (cVApply idPrimSplit [o]) . - mkBind (CSelectTT idPrimPair (CVar x) idPrimSnd) xs - mkExp [field] y _ = + un = CLValueSign (CDef (idUnpackNQ dpos) (CQType [] (bty `fn` aty)) [unc]) [] + unc = CClause [CPVar id_x] [] ukb + ukb = case fields of + [] -> CStruct ti [] + [field] -> CStruct ti [(cf_name field, cVApply idUnpack [vx])] + _ -> let xs = take (n-1) tmpVarXIds + bind = mkBind vx xs + mkBind o [] = id + mkBind o (x:xs) = + monoDef x (cVApply idPrimSplit [o]) . + mkBind (CSelectTT idPrimPair (CVar x) idPrimSnd) xs + mkExp [field] y _ = [(cf_name field, cVApply idUnpack [CSelectTT idPrimPair (CVar y) idPrimSnd])] - mkExp (field:fields) y (x:xs) = + mkExp (field:fields) y (x:xs) = (cf_name field, cVApply idUnpack [CSelectTT idPrimPair (CVar x) idPrimFst]) : mkExp fields x xs mkExp _ _ _ = internalError "Deriving.doSBits.ukb.mkExp: [] _ _ or _ _ []" err = internalError "Deriving.doSBits.ukb.mkExp: no var" - in bind (CStruct ti (mkExp fields err xs)) + in bind (CStruct ti (mkExp fields err xs)) -- doDBits: derive Bits instance, with the pack and unpack functions, -- for a enum or tagged union declaration doDBits :: Position -> Id -> [Type] -> COSummands -> CSummands -> - Either EMsg [CDefn] + Either EMsg [CDefn] doDBits dpos type_name type_vars original_tags tags | not (null (duplicate_tag_encoding_errors type_name tags)) = Left (head (duplicate_tag_encoding_errors type_name tags)) @@ -430,7 +430,7 @@ doDBits dpos enum_name type_vars original_tags tags hasSz (CLit (num_to_cliteral_at (getPosition tag) (cis_tag_encoding tag))) num_bits_ctype in CClause unpacked_pattern [] packed_expr - unpack_function = + unpack_function = CDef (idUnpackNQ dpos) (CQType [] (packed_ctype `fn` unpacked_ctype)) unpack_body -- unpack optimized for [0, 1, ..] (better hardware) @@ -458,9 +458,9 @@ doDBits dpos type_name type_vars original_tags tags = -- fix their position and mark them as KNum make_num_vars n l = map (cTVarNum . fix_position) $ take n l -- type_ctype: the csyntax type for which we're deriving - unpacked_ctype = cTApplys (cTCon type_name) type_vars + unpacked_ctype = cTApplys (cTCon type_name) type_vars -- num_tags: number of tags in the tagged union - num_tags = length tags + num_tags = length tags -- max tag: the highest tag encoding max_tag | null tags = 0 | otherwise = foldr1 max [cis_tag_encoding tag | tag <- tags] @@ -471,12 +471,12 @@ doDBits dpos type_name type_vars original_tags tags = max_field_size_max_provisos ++ final_bit_size_provisos -- make sure all subfields can be turned into bits fields_provisos_bits = - zipWith (\ field sv -> CPred (CTypeclass idBits) [cis_arg_type field, sv]) + zipWith (\ field sv -> CPred (CTypeclass idBits) [cis_arg_type field, sv]) tags field_bit_sizes -- max_field_size_provisos constrain max_num_field_bits to an -- upper bound of all subfield sizes by context: -- add freshvar sizeof(field) max_num_field_bits - max_field_size_add_provisos + max_field_size_add_provisos | num_tags <= 1 = [] | otherwise = zipWith ( \ x sv -> @@ -486,77 +486,77 @@ doDBits dpos type_name type_vars original_tags tags = -- max_field_size_max_provisos constrain max_num_field_bits to -- the least upper bound of all subfield sizes by constraining -- lastvar to be the largest - max_field_size_max_provisos + max_field_size_max_provisos | null tags = [] | otherwise = let f _ [] _ = [] - f a (s:ss) (n:nn) = + f a (s:ss) (n:nn) = CPred (CTypeclass idMax) [s, a, n] : f n ss nn f _ _ _ = internalError "Deriving.doDBits.f: _ (_:_) []" - b:bs = reverse field_bit_sizes - in f b bs max_field_size_sofar_vars - num_rep_bits_var:max_field_size_sofar_vars = + b:bs = reverse field_bit_sizes + in f b bs max_field_size_sofar_vars + num_rep_bits_var:max_field_size_sofar_vars = make_num_vars num_tags (everyThird tmpTyVarIds) -- max_num_field_bits: # bits required to represent all fields w/o tags - max_num_field_bits = last max_field_size_sofar_vars + max_num_field_bits = last max_field_size_sofar_vars -- field_bit_sizes: the bit sizes of the fields (as CTypes) - field_bit_sizes = make_num_vars num_tags (everyThird (tail tmpTyVarIds)) + field_bit_sizes = make_num_vars num_tags (everyThird (tail tmpTyVarIds)) -- field_bit_size_paddings: padding between individual field size -- and the maximum field size; used only once, as dummy variables - field_bit_size_paddings = make_num_vars num_tags (everyThird (tail (tail tmpTyVarIds))) + field_bit_size_paddings = make_num_vars num_tags (everyThird (tail (tail tmpTyVarIds))) -- final_bit_size_provisos constrain the final bit size of the -- tagged union: tag size + max(field sizes) = final size -- num_rep_bits_ctype: the final bit size of the tagged union - (final_bit_size_provisos, num_rep_bits_ctype) = - case original_tags of - [] -> ([], cTNum 0 decl_position) - [_] -> ([], headOrErr "doDBits" field_bit_sizes) - _ -> ([CPred (CTypeclass idAdd) + (final_bit_size_provisos, num_rep_bits_ctype) = + case original_tags of + [] -> ([], cTNum 0 decl_position) + [_] -> ([], headOrErr "doDBits" field_bit_sizes) + _ -> ([CPred (CTypeclass idAdd) [num_tag_bits_ctype, max_num_field_bits, num_rep_bits_var]], num_rep_bits_var) - packed_ctype = TAp (cTCon idBit) num_rep_bits_ctype - pack_function = + packed_ctype = TAp (cTCon idBit) num_rep_bits_ctype + pack_function = CDef (idPackNQ dpos) (CQType [] (unpacked_ctype `fn` packed_ctype)) pack_clauses - pack_clauses + pack_clauses | num_tags == 1 = [CClause [CPCon1 type_name (getCISName (headOrErr "doDBits" tags)) (CPVar id_x)] [] (cVApply idPack [vx])] | otherwise = zipWith mkPk tags field_bit_sizes - mkPk tag field_sz = + mkPk tag field_sz = CClause [CPCon1 type_name (getCISName tag) (CPVar id_x)] [] - (cVApply idPrimConcat + (cVApply idPrimConcat [litSz (cis_tag_encoding tag), pkBody field_sz]) - pkBody sz = cVApply idPrimConcat [anyExprAt decl_position, + pkBody sz = cVApply idPrimConcat [anyExprAt decl_position, hasSz (cVApply idPack [vx]) sz ] - litSz k = hasSz (CLit $ num_to_cliteral_at decl_position k) + litSz k = hasSz (CLit $ num_to_cliteral_at decl_position k) num_tag_bits_ctype - unpack_function = CDef (idUnpackNQ dpos) unpack_type unpack_clauses + unpack_function = CDef (idUnpackNQ dpos) unpack_type unpack_clauses unpack_type = CQType [] (packed_ctype `fn` unpacked_ctype) - unpack_clauses + unpack_clauses -- if there's only one, unpack the contents - | num_tags == 1 = [CClause [CPVar id_x] [] (CCon1 type_name (getCISName (headOrErr "doDBits" tags)) + | num_tags == 1 = [CClause [CPVar id_x] [] (CCon1 type_name (getCISName (headOrErr "doDBits" tags)) (cVApply idUnpack [vx]))] | otherwise = [CClause [CPVar id_x] [] (monoDef id_y (cVApply idPrimSplit [vx]) $ - Ccase dpos - (hasSz (CSelectTT idPrimPair vy idPrimFst) + Ccase dpos + (hasSz (CSelectTT idPrimPair vy idPrimFst) num_tag_bits_ctype) - (map mkUn tags))] - mkUn tag = + (map mkUn tags))] + mkUn tag = CCaseArm { cca_pattern = CPLit (num_to_cliteral_at decl_position (cis_tag_encoding tag)), cca_filters = [], cca_consequent = (CCon1 type_name (getCISName tag) unBody) } - unBody = cVApply idUnpack [cVApply idPrimTrunc + unBody = cVApply idUnpack [cVApply idPrimTrunc [CSelectTT idPrimPair vy idPrimSnd]] - vx = CVar id_x - vy = CVar id_y + vx = CVar id_x + vy = CVar id_y in Right $ [Cinstance (CQType provisos (cTApplys (cTCon idBits) [unpacked_ctype, @@ -573,23 +573,23 @@ doSFShow dpos ti vs fields = Cinstance (CQType ctx (cTApplys (cTCon idFShow) [aty])) [fshow_function] where ctx = bCtx ++ cCtx - cCtx = concatMap (\ (CField { cf_type = CQType q _}) -> q) fields - bCtx = map (\ (CField { cf_type = cqt@(CQType _ t) }) -> + cCtx = concatMap (\ (CField { cf_type = CQType q _}) -> q) fields + bCtx = map (\ (CField { cf_type = cqt@(CQType _ t) }) -> CPred (CTypeclass idFShow) [t]) fields - aty = cTApplys (cTCon ti) vs - fty = cTCon idFmt + aty = cTApplys (cTCon ti) vs + fty = cTCon idFmt - fshow_function = + fshow_function = CLValueSign (CDef (idfshowNQ dpos) (CQType [] (aty `fn` fty)) [fshow_clause]) [] - fshow_clause = CClause [CPVar id_x] [] fshow_body + fshow_clause = CClause [CPVar id_x] [] fshow_body - vx = CVar id_x + vx = CVar id_x fshow_body = let sid = getIdBaseString ti in CTaskApply (CVar idFormat) $ @@ -641,7 +641,7 @@ doDFShow dpos enum_name type_vars original_tags tags [fshow_function] doDFShow dpos union_name type_vars original_tags tags = let - union_ctype = cTApplys (cTCon union_name) type_vars + union_ctype = cTApplys (cTCon union_name) type_vars fmt_ctype = cTCon idFmt provisos = @@ -681,7 +681,7 @@ doDBounded dpos i vs ocs cs = --then compileError ("Cannot derive Bounded for " ++ show i) --else Cinstance (CQType ctx (TAp (cTCon idBounded) aty)) [maxB, minB] - where -- this is more restrictive than it needs to be (insisting on Bounded for each term, not just the first and last + where -- this is more restrictive than it needs to be (insisting on Bounded for each term, not just the first and last -- this is motivated by what Bounded "should" mean rather than the current requirements of the Bounded class ctx | isEnum ocs = [] | otherwise = [CPred (CTypeclass idBounded) [cis_arg_type field] | field <- cs] @@ -696,8 +696,8 @@ doDBounded dpos i vs ocs cs = maxBVal = if lastEmpty then (CCon (getCISName (lastOrErr "doDBounded" cs)) []) else (CCon1 i (getCISName (lastOrErr "doDBounded" cs)) (CVar idMaxBound)) - minB = CLValueSign (CDef (idMinBoundNQ dpos) (CQType [] aty) [CClause [] [] minBVal]) [] - maxB = CLValueSign (CDef (idMaxBoundNQ dpos) (CQType [] aty) [CClause [] [] maxBVal]) [] + minB = CLValueSign (CDef (idMinBoundNQ dpos) (CQType [] aty) [CClause [] [] minBVal]) [] + maxB = CLValueSign (CDef (idMaxBoundNQ dpos) (CQType [] aty) [CClause [] [] maxBVal]) [] doDUndefined :: Id -> [Type] -> COSummands -> CSummands -> CDefn -- the single-summand case is not already derived for data declarations with no internal type @@ -758,14 +758,14 @@ doDDeepSeqCond i vs ocs cs = Cinstance instance_cqt $ doSBounded :: Position -> Id -> [Type] -> CFields -> CDefn doSBounded dpos i vs fs = Cinstance (CQType ctx (TAp (cTCon idBounded) aty)) [maxB, minB] - where aty = cTApplys (cTCon i) vs - ctx = map (\ (CField {cf_type = CQType _ t}) -> CPred (CTypeclass idBounded) [t]) fs - minB = mmDef (idMinBoundNQ dpos) idMinBound - maxB = mmDef (idMaxBoundNQ dpos) idMaxBound - mmDef md mv = - let mfs = [ (cf_name f, CVar mv) | f <- fs ] - str = CStruct i mfs - in CLValueSign (CDef md (CQType [] aty) [CClause [] [] str]) [] + where aty = cTApplys (cTCon i) vs + ctx = map (\ (CField {cf_type = CQType _ t}) -> CPred (CTypeclass idBounded) [t]) fs + minB = mmDef (idMinBoundNQ dpos) idMinBound + maxB = mmDef (idMaxBoundNQ dpos) idMaxBound + mmDef md mv = + let mfs = [ (cf_name f, CVar mv) | f <- fs ] + str = CStruct i mfs + in CLValueSign (CDef md (CQType [] aty) [CClause [] [] str]) [] doSUndefined :: Id -> [Type] -> CFields -> CDefn doSUndefined i vs fs = Cinstance (CQType ctx (TAp (cTCon idUndefined) ty)) [undef] @@ -889,7 +889,7 @@ idPrimDeepSeqCondNQ = unQualId idPrimDeepSeqCond mkConv :: (CExpr -> CExpr) -> (CExpr -> CExpr) -> [Id] -> CType -> CType -> (CExpr -> CExpr) mkConv con coCon _ v v' | v == v' = con mkConv con coCon (x:xs) v (TAp (TAp (TCon (TyCon arr _ _)) a) r) | arr == idArrow noPosition = - \ e -> CLam (Right x) + \ e -> CLam (Right x) (mkConv con coCon xs v r (CApply e [mkConv coCon con xs v a (CVar x)])) mkConv _ _ _ v t = \ e -> e @@ -917,8 +917,8 @@ addRequiredDeriv flags r i tvs clsId derivs | Right True <- fst (runTI flags False r check) = derivs where check = do let Just (TypeInfo _ kind _ sort) = - {- trace ("check undef: " ++ ppReadable i) $ -} - findType r i + {- trace ("check undef: " ++ ppReadable i) $ -} + findType r i let t = cTApplys (TCon (TyCon i (Just kind) sort)) tvs cls <- findCls (CTypeclass clsId) vp <- mkVPredFromPred [] (IsIn cls [t]) @@ -940,4 +940,3 @@ addRequiredDerivs flags r i tvs derivs = -- ------------------------- - diff --git a/src/comp/Error.hs b/src/comp/Error.hs index c6978eb07..ba0af9f96 100644 --- a/src/comp/Error.hs +++ b/src/comp/Error.hs @@ -478,7 +478,7 @@ data ErrMsg | EBadStringEscapeChar Char -- bad character follows \ in string | EStringNewline -- newline in string | EStringEOF -- end of file inside string - | ESyntax !String ![String] -- found token, expected tokens + | ESyntax !String ![String] -- found token, expected tokens -- | ESyntaxUnknown -- dummy parse error | EUnsupportedBitVector -- bit vectors [N:0] only | EUnsupportedNumReal String -- real numbers not supported @@ -979,7 +979,7 @@ data ErrMsg | EUnexpectedOutputClkGate String --- | WInterfaceArg String +-- | WInterfaceArg String | EInterfaceArg String | ECrossDomainPragma [String] @@ -1116,7 +1116,7 @@ data ErrMsg | EFlagAfterSrc String | ENotVerSrcFile String | ENotCSrcFile String --- | ENeedUpdCheckFlag +-- | ENeedUpdCheckFlag | EMultipleSrcFiles | EMissingUserFile String [String] | EUnrecognizedCmdLineText String diff --git a/src/comp/ErrorMonad.hs b/src/comp/ErrorMonad.hs index a5d02ea80..15d0a7147 100644 --- a/src/comp/ErrorMonad.hs +++ b/src/comp/ErrorMonad.hs @@ -14,15 +14,15 @@ import Error(EMsg, WMsg, ErrMsg(..), ErrorHandle, bsError, bsWarning) import Position(noPosition) data ErrorMonad v = EMError [EMsg] - | EMWarning [WMsg] v - | EMResult v + | EMWarning [WMsg] v + | EMResult v instance Monad ErrorMonad where (EMError es) >>= _ = EMError es -- XXX could merge errors (EMWarning ws v) >>= f = case f v of EMError es -> EMError es -- XXX ws - EMWarning ws' v' -> EMWarning (ws ++ ws') v' - EMResult v' -> EMWarning ws v' + EMWarning ws' v' -> EMWarning (ws ++ ws') v' + EMResult v' -> EMWarning ws v' (EMResult v) >>= f = (f v) return v = EMResult v #if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 808) diff --git a/src/comp/ErrorUtil.hs b/src/comp/ErrorUtil.hs index 8f9be178e..63d28a72f 100644 --- a/src/comp/ErrorUtil.hs +++ b/src/comp/ErrorUtil.hs @@ -1,6 +1,6 @@ module ErrorUtil (internalError) where --- import Pretty -- causes loops +-- import Pretty -- causes loops import System.IO(hPutStr, stderr) import System.IO.Unsafe(unsafePerformIO) import System.Exit(exitWith, ExitCode(..)) diff --git a/src/comp/FStringCompat.hs b/src/comp/FStringCompat.hs index 2899ead56..9948d2137 100644 --- a/src/comp/FStringCompat.hs +++ b/src/comp/FStringCompat.hs @@ -34,8 +34,8 @@ mkFString s = fromString s cloneFString :: [FString] -> FString -> FString cloneFString fs f = head [f' | n <- [1..] :: [Integer], - let f' = f ++ fromString ('_':'_':'_':itos n), - f' `notElem` fs] + let f' = f ++ fromString ('_':'_':'_':itos n), + f' `notElem` fs] tmpFString :: Int -> String -> FString tmpFString _ = fromString diff --git a/src/comp/Fixity.hs b/src/comp/Fixity.hs index 6e37f92f2..fbff11647 100644 --- a/src/comp/Fixity.hs +++ b/src/comp/Fixity.hs @@ -1,9 +1,9 @@ module Fixity(Fixity(..), defaultFixity) where data Fixity - = FInfixl Int | FInfixr Int | FInfix Int - | FPrefix - | FInfixa Int -- used only in printing to indicate assoc oper + = FInfixl Int | FInfixr Int | FInfix Int + | FPrefix + | FInfixa Int -- used only in printing to indicate assoc oper deriving (Eq, Ord, Show) defaultFixity :: Fixity diff --git a/src/comp/FixupDefs.hs b/src/comp/FixupDefs.hs index 3f5f8c9f3..4e085bcd3 100644 --- a/src/comp/FixupDefs.hs +++ b/src/comp/FixupDefs.hs @@ -35,15 +35,15 @@ fixupDefs (IPackage mi _ ps ds) ipkgs = -- Create a recursive data structure by populating the map "m" -- with defs created using the map itself - m = M.fromList [ (i, e) | (IDef i _ e _) <- ads' ] - ads' = iDefsMap (fixUp m) ads + m = M.fromList [ (i, e) | (IDef i _ e _) <- ads' ] + ads' = iDefsMap (fixUp m) ads -- The new package contents ipkg_sigs = [ (mi, s) | (m@(IPackage mi _ _ _), s) <- ipkgs ] ds' = iDefsMap (fixUp m) ds in --trace ("fixup " ++ ppReadable (map fst (M.toList m))) $ - (IPackage mi ipkg_sigs ps' ds', ads') + (IPackage mi ipkg_sigs ps' ds', ads') -- =============== @@ -85,19 +85,19 @@ fixUp m e = e get :: M.Map Id (IExpr a) -> Id -> IExpr a get m i = let value = get2 m i pos = (getIdPosition i) - in -- trace("LookupX " - -- ++ (ppReadable i) ++ " => " - -- ++ (ppReadable (updateIExprPosition pos value))) $ - (updateIExprPosition pos value) + in -- trace("LookupX " + -- ++ (ppReadable i) ++ " => " + -- ++ (ppReadable (updateIExprPosition pos value))) $ + (updateIExprPosition pos value) get2 :: M.Map Id (IExpr a) -> Id -> IExpr a get2 m i = case M.lookup i m of Just e -> e Nothing -> internalError ( - "fixupDefs.get: " - ++ pfpString i ++ "\n" - ++ ppReadable (map fst (M.toList m))) + "fixupDefs.get: " + ++ pfpString i ++ "\n" + ++ ppReadable (map fst (M.toList m))) -- =============== diff --git a/src/comp/Flags.hs b/src/comp/Flags.hs index 03388e25f..b3f699a32 100644 --- a/src/comp/Flags.hs +++ b/src/comp/Flags.hs @@ -161,7 +161,7 @@ data Flags = Flags { warnUndetPred :: Bool } -- don't derive Show -- it causes an optimized ghc build to take a long time --- deriving (Show) +-- deriving (Show) data Verbosity = Quiet | Normal | Verbose | ExtraVerbose deriving(Eq, Show, Ord, Enum) diff --git a/src/comp/FlagsDecode.hs b/src/comp/FlagsDecode.hs index 4bc0c7bbc..71edc2356 100644 --- a/src/comp/FlagsDecode.hs +++ b/src/comp/FlagsDecode.hs @@ -534,7 +534,7 @@ defaultFlags bluespecdir = Flags { -- The ifcPath value will be produced from the raw value, -- by replacing the default-path token with the appropriate value -- once all the flag values are known, and adding bdir to the front, - -- in adjustFinalFlags. + -- in adjustFinalFlags. ifcPathRaw = [ defaultPathToken ], -- ifcPath = [], -- XXX this value is for properly constructing the help message @@ -633,7 +633,7 @@ defaultFlags bluespecdir = Flags { -- The vPath value will be produced from the raw value, -- by replacing the default-path token with the appropriate value -- once the full ifcPath is known, and adding vdir to the front, - -- in adjustFinalFlags. + -- in adjustFinalFlags. vPathRaw = [ defaultPathToken ], vPath = [], vpp = True, @@ -901,7 +901,7 @@ adjustFinalFlags warns0 errs0 flags0 = -- -p / -bdir checks -- add bdir to the head of the import path. - -- replace the default path with the Prelude and Libraries locations + -- replace the default path with the Prelude and Libraries locations -- XXX make sure this is in sync with the default value (ifcPath) -- XXX displayed in the help message @@ -1999,7 +1999,7 @@ splitPath bspecdir old_path s = let -- break on colons paths0 = makePath s -- expand symbols, and remove empty dirs - paths = let expandPercent c = if (c == '%') then bspecdir else [c] + paths = let expandPercent c = if (c == '%') then bspecdir else [c] expandDir d = if (d == "+") then old_path else if (d == "") diff --git a/src/comp/ForeignFunctions.hs b/src/comp/ForeignFunctions.hs index 71d909f91..8e8856122 100644 --- a/src/comp/ForeignFunctions.hs +++ b/src/comp/ForeignFunctions.hs @@ -294,7 +294,7 @@ ignoreRet fc = -- into 32-bit storage and written back after the call. forReturn :: (AExpr, ForeignType) -> (ReturnStyle,Argument) forReturn (e,rt) | aSize e > 64 = (Pointer, noCopy (e,rt)) - | isPoly rt = (Buffered, Alloc (aSize e) True) + | isPoly rt = (Buffered, Alloc (aSize e) True) | aSize e > 32 = (Buffered, Alloc (aSize e) True) | aSize e > 8 = (Direct, noCopy (e,rt)) | otherwise = (Buffered, Alloc (aSize e) True) @@ -518,24 +518,24 @@ mkImportDeclarations ff_map = toAVId :: Id -> Id toAVId id = case (LM.lookupBy qualEq toAVIdMap id) of - Just x -> x + Just x -> x _ -> internalError $ "ForeignFunctions: (toAVId) No AVId exists for " ++ (ppReadable id) fromAVId :: Id -> Id fromAVId id = case (LM.lookupBy qualEq fromAVIdMap id) of - Just x -> x - _ -> internalError $ "ForeignFunctions: (fromAVId) " ++ (ppReadable id) ++ "is not an AVId" + Just x -> x + _ -> internalError $ "ForeignFunctions: (fromAVId) " ++ (ppReadable id) ++ "is not an AVId" isAVId :: Id -> Bool isAVId id = case (LM.lookupBy qualEq fromAVIdMap id) of - Nothing -> False - _ -> True + Nothing -> False + _ -> True isMappedAVId :: Id -> Bool isMappedAVId id = case (LM.lookupBy qualEq toAVIdMap id) of - Nothing -> False - _ -> True + Nothing -> False + _ -> True toAVIdMap :: [(Id, Id)] toAVIdMap = [ (idSWrite, idSWriteAV) @@ -556,19 +556,19 @@ fromAVIdMap = toDisplayId :: Id -> Id toDisplayId id = case (LM.lookupBy qualEq toDisplayIdMap id) of - Just x -> x + Just x -> x _ -> internalError $ "ForeignFunctions: (toDisplayId) No DisplayId exists for " ++ (ppReadable id) fromDisplayId :: Id -> Id fromDisplayId id = case (LM.lookupBy qualEq fromDisplayIdMap id) of - Just x -> x - _ -> internalError $ "ForeignFunctions: (fromDisplayId) " ++ (ppReadable id) ++ "is not an DisplayId" + Just x -> x + _ -> internalError $ "ForeignFunctions: (fromDisplayId) " ++ (ppReadable id) ++ "is not an DisplayId" isDisplayId :: Id -> Bool isDisplayId id = case (LM.lookupBy qualEq fromDisplayIdMap id) of - Nothing -> False - _ -> True + Nothing -> False + _ -> True toDisplayIdMap :: [(Id, Id)] toDisplayIdMap = [ (idWrite, idDisplay) @@ -592,19 +592,19 @@ fromDisplayIdMap = toFileId :: Id -> Id toFileId id = case (LM.lookupBy qualEq toFileIdMap id) of - Just x -> x + Just x -> x _ -> internalError $ "ForeignFunctions: (toFileId) No FileId exists for " ++ (ppReadable id) fromFileId :: Id -> Id fromFileId id = case (LM.lookupBy qualEq fromFileIdMap id) of - Just x -> x - _ -> internalError $ "ForeignFunctions: (fromFileId) " ++ (ppReadable id) ++ "is not an FileId" + Just x -> x + _ -> internalError $ "ForeignFunctions: (fromFileId) " ++ (ppReadable id) ++ "is not an FileId" isFileId :: Id -> Bool isFileId id = case (LM.lookupBy qualEq fromFileIdMap id) of - Nothing -> False - _ -> True + Nothing -> False + _ -> True toFileIdMap :: [(Id, Id)] toFileIdMap = [ (idWrite, idFWrite) diff --git a/src/comp/GHCPretty.lhs b/src/comp/GHCPretty.lhs index ddf1c6ca0..3e585d3de 100644 --- a/src/comp/GHCPretty.lhs +++ b/src/comp/GHCPretty.lhs @@ -900,7 +900,7 @@ display mode page_width ribbon_width txt end doc (lay1 $! k + shift) s sl p ))) other -> lay1 k s sl p - lay _ _ = internalError "bad case in lay" + lay _ _ = internalError "bad case in lay" lay1 k s sl p = Str (indent k) `txt` (s `txt` (lay2 $! k + sl) p) @@ -908,7 +908,7 @@ display mode page_width ribbon_width txt end doc lay2 k (TextBeside s sl p) = s `txt` ((lay2 $! k + sl) p) lay2 k (Nest _ p) = lay2 k p lay2 k Empty = end - lay2 _ _ = internalError "bad case in lay2" + lay2 _ _ = internalError "bad case in lay2" in lay 0 doc }} diff --git a/src/comp/GenABin.hs b/src/comp/GenABin.hs index dd4d0cc25..588d3e2a6 100644 --- a/src/comp/GenABin.hs +++ b/src/comp/GenABin.hs @@ -55,38 +55,38 @@ instance Bin ABin where putI 0 toBin version -- output the foreign function info - toBin (abffi_src_name ffinfo) - toBin (abffi_foreign_func ffinfo) + toBin (abffi_src_name ffinfo) + toBin (abffi_foreign_func ffinfo) writeBytes (ABinMod modinfo version) = section "ABinMod" $ do -- tag which kind of module - putI 1 - toBin version + putI 1 + toBin version -- output module info - toBin (abmi_path modinfo) - toBin (abmi_src_name modinfo) - --toBin (abmi_time modinfo) - toBin (abmi_apkg modinfo) - toBin (abmi_aschedinfo modinfo) - toBin (abmi_pps modinfo) - toBin (abmi_oqt modinfo) - toBin (abmi_method_dump modinfo) - toBin (abmi_pathinfo modinfo) - toBin (abmi_flags modinfo) + toBin (abmi_path modinfo) + toBin (abmi_src_name modinfo) + --toBin (abmi_time modinfo) + toBin (abmi_apkg modinfo) + toBin (abmi_aschedinfo modinfo) + toBin (abmi_pps modinfo) + toBin (abmi_oqt modinfo) + toBin (abmi_method_dump modinfo) + toBin (abmi_pathinfo modinfo) + toBin (abmi_flags modinfo) toBin (abmi_vprogram modinfo) writeBytes (ABinModSchedErr modinfo version) = section "ABinModSchedErr" $ do -- tag which kind of module - putI 2 - toBin version + putI 2 + toBin version -- output module info - toBin (abmsei_path modinfo) - toBin (abmsei_src_name modinfo) - toBin (abmsei_apkg modinfo) - toBin (abmsei_aschederrinfo modinfo) - toBin (abmsei_pps modinfo) - toBin (abmsei_oqt modinfo) - toBin (abmsei_flags modinfo) + toBin (abmsei_path modinfo) + toBin (abmsei_src_name modinfo) + toBin (abmsei_apkg modinfo) + toBin (abmsei_aschederrinfo modinfo) + toBin (abmsei_pps modinfo) + toBin (abmsei_oqt modinfo) + toBin (abmsei_flags modinfo) readBytes = do tag <- getI version <- fromBin case (tag) of @@ -97,29 +97,29 @@ instance Bin ABin where 1 -> do path <- fromBin srcName <- fromBin --time <- fromBin - apkg <- fromBin - asched <- fromBin - pps <- fromBin - oqt <- fromBin - mi <- fromBin - pathinfo <- fromBin - flags <- fromBin + apkg <- fromBin + asched <- fromBin + pps <- fromBin + oqt <- fromBin + mi <- fromBin + pathinfo <- fromBin + flags <- fromBin vprog <- fromBin - let modinfo = + let modinfo = ABinModInfo path srcName apkg asched pps - oqt mi pathinfo flags vprog - return (ABinMod modinfo version) + oqt mi pathinfo flags vprog + return (ABinMod modinfo version) 2 -> do path <- fromBin srcName <- fromBin - apkg <- fromBin - aschederr <- fromBin - pps <- fromBin - oqt <- fromBin - flags <- fromBin - let modinfo = + apkg <- fromBin + aschederr <- fromBin + pps <- fromBin + oqt <- fromBin + flags <- fromBin + let modinfo = ABinModSchedErrInfo path srcName apkg aschederr pps oqt flags - return (ABinModSchedErr modinfo version) + return (ABinModSchedErr modinfo version) n -> internalError ("GenABin.Bin(ABin): tag = " ++ show n) -- ---------- @@ -128,40 +128,40 @@ instance Bin ABin where instance Bin APackage where writeBytes (APackage { apkg_name = mi, - apkg_is_wrapped = is_wrap, - apkg_backend = be, - apkg_size_params = ps, - apkg_inputs = inps, - apkg_clock_domains = clks, - apkg_external_wires = wi, + apkg_is_wrapped = is_wrap, + apkg_backend = be, + apkg_size_params = ps, + apkg_inputs = inps, + apkg_clock_domains = clks, + apkg_external_wires = wi, apkg_external_wire_types = wpt, - apkg_reset_list = rsts, - apkg_state_instances = avis, - apkg_local_defs = ds, - apkg_rules = rs, - apkg_schedule_pragmas = asps, - apkg_interface = aifcs, - apkg_inst_comments = ics, + apkg_reset_list = rsts, + apkg_state_instances = avis, + apkg_local_defs = ds, + apkg_rules = rs, + apkg_schedule_pragmas = asps, + apkg_interface = aifcs, + apkg_inst_comments = ics, apkg_inst_tree = inst_tree, apkg_proof_obligations = pos - }) = if (null pos) + }) = if (null pos) then section "APackage" $ do toBin mi - toBin is_wrap - toBin be - toBin ps - toBin inps - toBin clks - toBin wi + toBin is_wrap + toBin be + toBin ps + toBin inps + toBin clks + toBin wi toBin wpt - toBin rsts - toBin avis - toBin ds - toBin rs - toBin asps - toBin aifcs + toBin rsts + toBin avis + toBin ds + toBin rs + toBin asps + toBin aifcs toBin inst_tree - toBin ics + toBin ics -- proof obligations not written else internalError $ "GenABin.Bin(APackage).readBytes: non-empty proof obligations" readBytes = do mi <- fromBin @@ -182,23 +182,23 @@ instance Bin APackage where ics <- fromBin return (APackage { apkg_name = mi, - apkg_is_wrapped = is_wrap, - apkg_backend = be, - apkg_size_params = ps, - apkg_inputs = inps, - apkg_clock_domains = clks, - apkg_external_wires = wi, + apkg_is_wrapped = is_wrap, + apkg_backend = be, + apkg_size_params = ps, + apkg_inputs = inps, + apkg_clock_domains = clks, + apkg_external_wires = wi, apkg_external_wire_types = wpt, - apkg_reset_list = rsts, - apkg_state_instances = avis, - apkg_local_defs = ds, - apkg_rules = rs, - apkg_schedule_pragmas = asps, - apkg_interface = aifcs, - apkg_inst_comments = ics, + apkg_reset_list = rsts, + apkg_state_instances = avis, + apkg_local_defs = ds, + apkg_rules = rs, + apkg_schedule_pragmas = asps, + apkg_interface = aifcs, + apkg_inst_comments = ics, apkg_inst_tree = inst_tree, apkg_proof_obligations = [] - }) + }) -- ---------- -- Bin Backend @@ -209,9 +209,9 @@ instance Bin Backend where readBytes = do i <- getI case i of - 0 -> return Bluesim - 1 -> return Verilog - n -> internalError $ "GenABin.Bin(Backend).readBytes: " ++ show n + 0 -> return Bluesim + 1 -> return Verilog + n -> internalError $ "GenABin.Bin(Backend).readBytes: " ++ show n -- ---------- -- Bin AAbstractInput @@ -224,11 +224,11 @@ instance Bin AAbstractInput where readBytes = do i <- getI case i of - 0 -> do p <- fromBin; return (AAI_Port p) - 1 -> do osc <- fromBin; mgate <- fromBin; return (AAI_Clock osc mgate) - 2 -> do r <- fromBin; return (AAI_Reset r) - 3 -> do r <- fromBin; n <- fromBin; return (AAI_Inout r n) - n -> internalError $ "GenABin.Bin(AAbstractInfo).readBytes: " ++ show n + 0 -> do p <- fromBin; return (AAI_Port p) + 1 -> do osc <- fromBin; mgate <- fromBin; return (AAI_Clock osc mgate) + 2 -> do r <- fromBin; return (AAI_Reset r) + 3 -> do r <- fromBin; n <- fromBin; return (AAI_Inout r n) + n -> internalError $ "GenABin.Bin(AAbstractInfo).readBytes: " ++ show n -- ---------- -- Bin ForeignFunction @@ -261,7 +261,7 @@ instance Bin ForeignFunction where instance Bin AVInst where writeBytes (AVInst i t ui ms pts vmi ias iarr) = section "AVInst" $ - do toBin i; toBin t; toBin ui; toBin ms; toBin pts; + do toBin i; toBin t; toBin ui; toBin ms; toBin pts; toBin vmi; toBin ias; toBin iarr readBytes = do i <- fromBin; t <- fromBin; ui <- fromBin; ms <- fromBin; pts <- fromBin; vmi <- fromBin; ias <- fromBin; iarr <- fromBin; @@ -273,12 +273,12 @@ instance Bin AVInst where instance Bin ARule where writeBytes (ARule i ps d wps pred act asmps mp) = section "ARule" $ - do toBin i; toBin ps; toBin d; toBin wps; toBin pred; toBin act; - toBin asmps; toBin mp + do toBin i; toBin ps; toBin d; toBin wps; toBin pred; toBin act; + toBin asmps; toBin mp readBytes = - do i <- fromBin; ps <- fromBin; d <- fromBin; wps <- fromBin; - pred <- fromBin; act <- fromBin; asmps <- fromBin; mp <- fromBin; - return (ARule i ps d wps pred act asmps mp) + do i <- fromBin; ps <- fromBin; d <- fromBin; wps <- fromBin; + pred <- fromBin; act <- fromBin; asmps <- fromBin; mp <- fromBin; + return (ARule i ps d wps pred act asmps mp) instance Bin AAssumption where writeBytes (AAssumption p as) = do toBin p; toBin as @@ -290,20 +290,20 @@ instance Bin AAction where writeBytes (AFCall i f isC as isA) = do putI 1; toBin i; toBin f; toBin isC; toBin as; toBin isA writeBytes (ATaskAction i f isC c as tmp ty isA) = - do putI 2; toBin i; toBin f; toBin isC; toBin c; toBin as; + do putI 2; toBin i; toBin f; toBin isC; toBin c; toBin as; toBin tmp; toBin ty; toBin isA readBytes = - do i <- getI - case i of - 0 -> do i <- fromBin; m <- fromBin; as <- fromBin; - return (ACall i m as) - 1 -> do i <- fromBin; f <- fromBin; isC <- fromBin; as <- fromBin; - isA <- fromBin; return (AFCall i f isC as isA) - 2 -> do i <- fromBin; f <- fromBin; isC <- fromBin; c <- fromBin; - as <- fromBin; tmp <- fromBin; ty <- fromBin; + do i <- getI + case i of + 0 -> do i <- fromBin; m <- fromBin; as <- fromBin; + return (ACall i m as) + 1 -> do i <- fromBin; f <- fromBin; isC <- fromBin; as <- fromBin; + isA <- fromBin; return (AFCall i f isC as isA) + 2 -> do i <- fromBin; f <- fromBin; isC <- fromBin; c <- fromBin; + as <- fromBin; tmp <- fromBin; ty <- fromBin; isA <- fromBin; - return (ATaskAction i f isC c as tmp ty isA) - n -> internalError $ "GenABin.Bin(AAction).readBytes: " ++ show n + return (ATaskAction i f isC c as tmp ty isA) + n -> internalError $ "GenABin.Bin(AAction).readBytes: " ++ show n instance Bin WireProps where writeBytes (WireProps cd rs) = do toBin cd; toBin rs @@ -314,41 +314,41 @@ instance Bin WireProps where instance Bin AIFace where writeBytes (AIDef name is ps pred val vfi asmps) = - do putI 0; toBin name; toBin is; toBin ps; toBin pred; toBin val; - toBin vfi; toBin asmps + do putI 0; toBin name; toBin is; toBin ps; toBin pred; toBin val; + toBin vfi; toBin asmps writeBytes (AIAction is ps pred name body vfi) = - do putI 1; toBin is; toBin ps; toBin pred; toBin name; toBin body; - toBin vfi + do putI 1; toBin is; toBin ps; toBin pred; toBin name; toBin body; + toBin vfi writeBytes (AIActionValue is ps pred name body val vfi) = - do putI 2; toBin is; toBin ps; toBin pred; toBin name; toBin body; - toBin val; toBin vfi + do putI 2; toBin is; toBin ps; toBin pred; toBin name; toBin body; + toBin val; toBin vfi writeBytes (AIClock name clk vfi) = - do putI 3; toBin name; toBin clk; toBin vfi + do putI 3; toBin name; toBin clk; toBin vfi writeBytes (AIReset name rst vfi) = - do putI 4; toBin name; toBin rst; toBin vfi + do putI 4; toBin name; toBin rst; toBin vfi writeBytes (AIInout name iot vfi) = - do putI 5; toBin name; toBin iot; toBin vfi + do putI 5; toBin name; toBin iot; toBin vfi readBytes = - do i <- getI - case i of - 0 -> do name <- fromBin; is <- fromBin; ps <- fromBin; - pred <- fromBin; val <- fromBin; vfi <- fromBin; + do i <- getI + case i of + 0 -> do name <- fromBin; is <- fromBin; ps <- fromBin; + pred <- fromBin; val <- fromBin; vfi <- fromBin; asmps <- fromBin; - return (AIDef name is ps pred val vfi asmps) - 1 -> do is <- fromBin; ps <- fromBin; pred <- fromBin; - name <- fromBin; body <- fromBin; vfi <- fromBin; - return (AIAction is ps pred name body vfi) - 2 -> do is <- fromBin; ps <- fromBin; pred <- fromBin; - name <- fromBin; body <- fromBin; val <- fromBin; - vfi <- fromBin; - return (AIActionValue is ps pred name body val vfi) - 3 -> do name <- fromBin; clk <- fromBin; vfi <- fromBin; - return (AIClock name clk vfi) - 4 -> do name <- fromBin; rst <- fromBin; vfi <- fromBin; - return (AIReset name rst vfi) - 5 -> do name <- fromBin; iot <- fromBin; vfi <- fromBin; - return (AIInout name iot vfi) - n -> internalError $ "GenABin.Bin(AIFace).readBytes: " ++ show n + return (AIDef name is ps pred val vfi asmps) + 1 -> do is <- fromBin; ps <- fromBin; pred <- fromBin; + name <- fromBin; body <- fromBin; vfi <- fromBin; + return (AIAction is ps pred name body vfi) + 2 -> do is <- fromBin; ps <- fromBin; pred <- fromBin; + name <- fromBin; body <- fromBin; val <- fromBin; + vfi <- fromBin; + return (AIActionValue is ps pred name body val vfi) + 3 -> do name <- fromBin; clk <- fromBin; vfi <- fromBin; + return (AIClock name clk vfi) + 4 -> do name <- fromBin; rst <- fromBin; vfi <- fromBin; + return (AIReset name rst vfi) + 5 -> do name <- fromBin; iot <- fromBin; vfi <- fromBin; + return (AIInout name iot vfi) + n -> internalError $ "GenABin.Bin(AIFace).readBytes: " ++ show n -- ---------- -- Bin AScheduleInfo @@ -356,24 +356,24 @@ instance Bin AIFace where instance Bin AScheduleInfo where writeBytes (AScheduleInfo ws mumap rumap rat erdb sorder sch sgraph rrdb vsi) = section "AScheduleInfo" $ - do toBin ws; toBin mumap; toBin rumap; toBin rat; toBin erdb; - toBin sorder; toBin sch; toBin sgraph; toBin rrdb; toBin vsi + do toBin ws; toBin mumap; toBin rumap; toBin rat; toBin erdb; + toBin sorder; toBin sch; toBin sgraph; toBin rrdb; toBin vsi readBytes = - do ws <- fromBin; mumap <- fromBin; rumap <- fromBin; rat <- fromBin; + do ws <- fromBin; mumap <- fromBin; rumap <- fromBin; rat <- fromBin; erdb <- fromBin; sorder <- fromBin; sch <- fromBin; sgraph <- fromBin; rrdb <- fromBin; vsi <- fromBin; - return (AScheduleInfo ws mumap rumap rat erdb sorder sch sgraph rrdb vsi) + return (AScheduleInfo ws mumap rumap rat erdb sorder sch sgraph rrdb vsi) instance Bin AScheduleErrInfo where writeBytes (AScheduleErrInfo ws es mumap rumap rat erdb sorder sch sgraph rrdb vsi) = section "AScheduleErrInfo" $ - do toBin ws; toBin es; toBin mumap; toBin rumap; toBin rat; toBin erdb; - toBin sorder; toBin sch; toBin sgraph; toBin rrdb; toBin vsi + do toBin ws; toBin es; toBin mumap; toBin rumap; toBin rat; toBin erdb; + toBin sorder; toBin sch; toBin sgraph; toBin rrdb; toBin vsi readBytes = - do ws <- fromBin; es <- fromBin; mumap <- fromBin; rumap <- fromBin; + do ws <- fromBin; es <- fromBin; mumap <- fromBin; rumap <- fromBin; rat <- fromBin; erdb <- fromBin; sorder <- fromBin; sch <- fromBin; sgraph <- fromBin; rrdb <- fromBin; vsi <- fromBin; - return (AScheduleErrInfo ws es mumap rumap rat erdb sorder sch sgraph rrdb vsi) + return (AScheduleErrInfo ws es mumap rumap rat erdb sorder sch sgraph rrdb vsi) instance Bin ASchedule where writeBytes (ASchedule ss order) = section "ASchedule" $ do toBin ss; toBin order @@ -393,11 +393,11 @@ instance Bin UniqueUse where writeBytes (UUAction a) = section "UUAction" $ do putI 0; toBin a writeBytes (UUExpr e c) = section "UUExpr" $ do putI 1; toBin e; toBin c readBytes = - do i <- getI - case i of - 0 -> do a <- fromBin; return (UUAction a) - 1 -> do e <- fromBin; c <- fromBin; return (UUExpr e c) - n -> internalError $ "GenABin.Bin(UniqueUse).readBytes: " ++ show n + do i <- getI + case i of + 0 -> do a <- fromBin; return (UUAction a) + 1 -> do e <- fromBin; c <- fromBin; return (UUExpr e c) + n -> internalError $ "GenABin.Bin(UniqueUse).readBytes: " ++ show n -- XXX drop use conditions because of sharing issues -- .ba file size explodes (may be better now with CSE of UseCond) @@ -427,12 +427,12 @@ instance Bin RuleRelationDB where instance Bin RuleRelationInfo where writeBytes (RuleRelationInfo mCF mSC mRes mCycle mPragma mArb) = - do toBin mCF; toBin mSC; toBin mRes; toBin mCycle; toBin mPragma; + do toBin mCF; toBin mSC; toBin mRes; toBin mCycle; toBin mPragma; toBin mArb readBytes = - do mCF <- fromBin; mSC <- fromBin; mRes <- fromBin; - mCycle <- fromBin; mPragma <- fromBin; mArb <- fromBin; - return (RuleRelationInfo mCF mSC mRes mCycle mPragma mArb) + do mCF <- fromBin; mSC <- fromBin; mRes <- fromBin; + mCycle <- fromBin; mPragma <- fromBin; mArb <- fromBin; + return (RuleRelationInfo mCF mSC mRes mCycle mPragma mArb) instance Bin Conflicts where writeBytes (CUse mms) = do putI 0; toBin mms @@ -445,28 +445,28 @@ instance Bin Conflicts where writeBytes (CArbitraryChoice) = do putI 7 writeBytes (CFFuncArbitraryChoice) = do putI 8 readBytes = - do i <- getI - case i of - 0 -> do mms <- fromBin; return (CUse mms) - 1 -> do rs <- fromBin; return (CCycle rs) - 2 -> return CMethodsBeforeRules - 3 -> do pos <- fromBin; return (CUserEarliness pos) - 4 -> do pos <- fromBin; return (CUserAttribute pos) - 5 -> do pos <- fromBin; return (CUserPreempt pos) - 6 -> do m <- fromBin; return (CResource m) - 7 -> return CArbitraryChoice - 8 -> return CFFuncArbitraryChoice - n -> internalError $ "GenABin.Bin(Conflicts).readBytes: " ++ show n + do i <- getI + case i of + 0 -> do mms <- fromBin; return (CUse mms) + 1 -> do rs <- fromBin; return (CCycle rs) + 2 -> return CMethodsBeforeRules + 3 -> do pos <- fromBin; return (CUserEarliness pos) + 4 -> do pos <- fromBin; return (CUserAttribute pos) + 5 -> do pos <- fromBin; return (CUserPreempt pos) + 6 -> do m <- fromBin; return (CResource m) + 7 -> return CArbitraryChoice + 8 -> return CFFuncArbitraryChoice + n -> internalError $ "GenABin.Bin(Conflicts).readBytes: " ++ show n instance Bin SchedNode where writeBytes (Sched i) = section "SchedNode" $ do putI 0; toBin i writeBytes (Exec i) = section "SchedNode" $ do putI 1; toBin i readBytes = - do i <- getI - case i of - 0 -> do i <- fromBin; return (Sched i) - 1 -> do i <- fromBin; return (Exec i) - n -> internalError $ "GenABin.Bin(SchedNode).readBytes: " ++ show n + do i <- getI + case i of + 0 -> do i <- fromBin; return (Sched i) + 1 -> do i <- fromBin; return (Exec i) + n -> internalError $ "GenABin.Bin(SchedNode).readBytes: " ++ show n instance Bin RuleConflictType where writeBytes rct = toBin (fromEnum rct) @@ -501,7 +501,7 @@ instance Bin ResourceFlag where writeBytes RFsimple = do putI 1 readBytes = do i <- getI - case i of + case i of 0 -> return RFoff 1 -> return RFsimple n -> internalError $ "GenABin.Bin(ResourceFlag).readBytes: " ++ show n @@ -550,18 +550,18 @@ instance Bin MsgListFlag where -- should automatically verify no typoes at compile-time XXX instance Bin Flags where writeBytes (Flags - a_000 a_001 a_002 a_003 a_004 a_005 a_006 a_007 a_008 a_009 - a_010 a_011 a_012 a_013 a_014 a_015 a_016 a_017 a_018 a_019 - a_020 a_021 a_022 a_023 a_024 a_025 a_026 a_027 a_028 a_029 - a_030 a_031 a_032 a_033 a_034 a_035 a_036 a_037 a_038 a_039 - a_040 a_041 a_042 a_043 a_044 a_045 a_046 a_047 a_048 a_049 - a_050 a_051 a_052 a_053 a_054 a_055 a_056 a_057 a_058 a_059 - a_060 a_061 a_062 a_063 a_064 a_065 a_066 a_067 a_068 a_069 - a_070 a_071 a_072 a_073 a_074 a_075 a_076 a_077 a_078 a_079 - a_080 a_081 a_082 a_083 a_084 a_085 a_086 a_087 a_088 a_089 - a_090 a_091 a_092 a_093 a_094 a_095 a_096 a_097 a_098 a_099 - a_100 a_101 a_102 a_103 a_104 a_105 a_106 a_107 a_108 a_109 - a_110 a_111 a_112 a_113 a_114 a_115 a_116 a_117 a_118 a_119 + a_000 a_001 a_002 a_003 a_004 a_005 a_006 a_007 a_008 a_009 + a_010 a_011 a_012 a_013 a_014 a_015 a_016 a_017 a_018 a_019 + a_020 a_021 a_022 a_023 a_024 a_025 a_026 a_027 a_028 a_029 + a_030 a_031 a_032 a_033 a_034 a_035 a_036 a_037 a_038 a_039 + a_040 a_041 a_042 a_043 a_044 a_045 a_046 a_047 a_048 a_049 + a_050 a_051 a_052 a_053 a_054 a_055 a_056 a_057 a_058 a_059 + a_060 a_061 a_062 a_063 a_064 a_065 a_066 a_067 a_068 a_069 + a_070 a_071 a_072 a_073 a_074 a_075 a_076 a_077 a_078 a_079 + a_080 a_081 a_082 a_083 a_084 a_085 a_086 a_087 a_088 a_089 + a_090 a_091 a_092 a_093 a_094 a_095 a_096 a_097 a_098 a_099 + a_100 a_101 a_102 a_103 a_104 a_105 a_106 a_107 a_108 a_109 + a_110 a_111 a_112 a_113 a_114 a_115 a_116 a_117 a_118 a_119 a_120 a_121 a_122 a_123 a_124 a_125 a_126 a_127 a_128 a_129 a_130 a_131 a_132 a_133 a_134 a_135 a_136 a_137 a_138) = do toBin a_000; toBin a_001; toBin a_002; toBin a_003; toBin a_004; @@ -588,7 +588,7 @@ instance Bin Flags where toBin a_105; toBin a_106; toBin a_107; toBin a_108; toBin a_109; toBin a_110; toBin a_111; toBin a_112; toBin a_113; toBin a_114; toBin a_115; toBin a_116; toBin a_117; toBin a_118; toBin a_119; - toBin a_120; toBin a_121; toBin a_122; toBin a_123; toBin a_124; + toBin a_120; toBin a_121; toBin a_122; toBin a_123; toBin a_124; toBin a_125; toBin a_126; toBin a_127; toBin a_128; toBin a_129; toBin a_130; toBin a_131; toBin a_132; toBin a_133; toBin a_134; toBin a_135; toBin a_136; toBin a_137; toBin a_138 @@ -617,24 +617,24 @@ instance Bin Flags where a_105 <- fromBin; a_106 <- fromBin; a_107 <- fromBin; a_108 <- fromBin; a_109 <- fromBin; a_110 <- fromBin; a_111 <- fromBin; a_112 <- fromBin; a_113 <- fromBin; a_114 <- fromBin; a_115 <- fromBin; a_116 <- fromBin; a_117 <- fromBin; a_118 <- fromBin; a_119 <- fromBin; - a_120 <- fromBin; a_121 <- fromBin; a_122 <- fromBin; a_123 <- fromBin; a_124 <- fromBin; + a_120 <- fromBin; a_121 <- fromBin; a_122 <- fromBin; a_123 <- fromBin; a_124 <- fromBin; a_125 <- fromBin; a_126 <- fromBin; a_127 <- fromBin; a_128 <- fromBin; a_129 <- fromBin; a_130 <- fromBin; a_131 <- fromBin; a_132 <- fromBin; a_133 <- fromBin; a_134 <- fromBin; a_135 <- fromBin; a_136 <- fromBin; a_137 <- fromBin; a_138 <- fromBin return (Flags - a_000 a_001 a_002 a_003 a_004 a_005 a_006 a_007 a_008 a_009 - a_010 a_011 a_012 a_013 a_014 a_015 a_016 a_017 a_018 a_019 - a_020 a_021 a_022 a_023 a_024 a_025 a_026 a_027 a_028 a_029 - a_030 a_031 a_032 a_033 a_034 a_035 a_036 a_037 a_038 a_039 - a_040 a_041 a_042 a_043 a_044 a_045 a_046 a_047 a_048 a_049 - a_050 a_051 a_052 a_053 a_054 a_055 a_056 a_057 a_058 a_059 - a_060 a_061 a_062 a_063 a_064 a_065 a_066 a_067 a_068 a_069 - a_070 a_071 a_072 a_073 a_074 a_075 a_076 a_077 a_078 a_079 - a_080 a_081 a_082 a_083 a_084 a_085 a_086 a_087 a_088 a_089 - a_090 a_091 a_092 a_093 a_094 a_095 a_096 a_097 a_098 a_099 - a_100 a_101 a_102 a_103 a_104 a_105 a_106 a_107 a_108 a_109 - a_110 a_111 a_112 a_113 a_114 a_115 a_116 a_117 a_118 a_119 - a_120 a_121 a_122 a_123 a_124 a_125 a_126 a_127 a_128 a_129 + a_000 a_001 a_002 a_003 a_004 a_005 a_006 a_007 a_008 a_009 + a_010 a_011 a_012 a_013 a_014 a_015 a_016 a_017 a_018 a_019 + a_020 a_021 a_022 a_023 a_024 a_025 a_026 a_027 a_028 a_029 + a_030 a_031 a_032 a_033 a_034 a_035 a_036 a_037 a_038 a_039 + a_040 a_041 a_042 a_043 a_044 a_045 a_046 a_047 a_048 a_049 + a_050 a_051 a_052 a_053 a_054 a_055 a_056 a_057 a_058 a_059 + a_060 a_061 a_062 a_063 a_064 a_065 a_066 a_067 a_068 a_069 + a_070 a_071 a_072 a_073 a_074 a_075 a_076 a_077 a_078 a_079 + a_080 a_081 a_082 a_083 a_084 a_085 a_086 a_087 a_088 a_089 + a_090 a_091 a_092 a_093 a_094 a_095 a_096 a_097 a_098 a_099 + a_100 a_101 a_102 a_103 a_104 a_105 a_106 a_107 a_108 a_109 + a_110 a_111 a_112 a_113 a_114 a_115 a_116 a_117 a_118 a_119 + a_120 a_121 a_122 a_123 a_124 a_125 a_126 a_127 a_128 a_129 a_130 a_131 a_132 a_133 a_134 a_135 a_136 a_137 a_138) -- ---------- diff --git a/src/comp/GenBin.hs b/src/comp/GenBin.hs index 41f09a5a7..cd40b85bd 100644 --- a/src/comp/GenBin.hs +++ b/src/comp/GenBin.hs @@ -148,7 +148,7 @@ instance Bin CDefn where 10 -> do when doTrace $ traceM ("CItype") ik <- fromBin; is <- fromBin; poss <- fromBin return (CItype ik is poss) - 11 -> do p <- fromBin; return (CPragma p) + 11 -> do p <- fromBin; return (CPragma p) n -> internalError $ "GenBin.Bin(CDefn).readBytes: " ++ show n -- ---------- @@ -222,44 +222,44 @@ instance Bin CPat where writeBytes (CPConTs i1 i2 ts ps) = do putI 9; toBin i1; toBin i2; toBin ts; toBin ps readBytes = do tag <- getI - case tag of - 0 -> do i <- fromBin; ps <- fromBin + case tag of + 0 -> do i <- fromBin; ps <- fromBin return (CPCon i ps) - 1 -> do i <- fromBin; ips <- fromBin; + 1 -> do i <- fromBin; ips <- fromBin; return (CPstruct i ips) - 2 -> do i <- fromBin; return (CPVar i) + 2 -> do i <- fromBin; return (CPVar i) 3 -> do i <- fromBin; p <- fromBin; return (CPAs i p) - 4 -> do p <- fromBin; return (CPAny p) - 5 -> do l <- fromBin; return (CPLit l) - 6 -> do pos <- fromBin; n <- fromBin; ns <- fromBin; + 4 -> do p <- fromBin; return (CPAny p) + 5 -> do l <- fromBin; return (CPLit l) + 6 -> do pos <- fromBin; n <- fromBin; ns <- fromBin; return (CPMixedLit pos n ns) - 7 -> do ops <- fromBin; return (CPOper ops) - 8 -> do i1 <- fromBin; i2 <- fromBin; p <- fromBin; + 7 -> do ops <- fromBin; return (CPOper ops) + 8 -> do i1 <- fromBin; i2 <- fromBin; p <- fromBin; return (CPCon1 i1 i2 p) - 9 -> do i1 <- fromBin; i2 <- fromBin; + 9 -> do i1 <- fromBin; i2 <- fromBin; ts <- fromBin; ps <- fromBin; return (CPConTs i1 i2 ts ps) - n -> internalError $ "GenBin.Bin(CPat).readBytes: " ++ show n + n -> internalError $ "GenBin.Bin(CPat).readBytes: " ++ show n instance Bin CPOp where writeBytes (CPRand p) = do putI 0; toBin p writeBytes (CPRator n i) = do putI 1; toBin n; toBin i readBytes = do tag <- getI - case tag of - 0 -> do p <- fromBin; return (CPRand p) - 1 -> do n <- fromBin; i <- fromBin; return (CPRator n i) - n -> internalError $ "GenBin.Bin(CPOp).readBytes: " ++ show n + case tag of + 0 -> do p <- fromBin; return (CPRand p) + 1 -> do n <- fromBin; i <- fromBin; return (CPRator n i) + n -> internalError $ "GenBin.Bin(CPOp).readBytes: " ++ show n instance Bin COp where writeBytes (CRand e) = do putI 0; toBin e writeBytes (CRator n i) = do putI 1; toBin n; toBin i readBytes = do tag <- getI - case tag of - 0 -> do e <- fromBin; return (CRand e) - 1 -> do n <- fromBin; i <- fromBin; return (CRator n i) - n -> internalError $ "GenBin.Bin(COp).readBytes: " ++ show n + case tag of + 0 -> do e <- fromBin; return (CRand e) + 1 -> do n <- fromBin; i <- fromBin; return (CRator n i) + n -> internalError $ "GenBin.Bin(COp).readBytes: " ++ show n instance Bin CLiteral where writeBytes (CLiteral pos l) = do toBin pos; toBin l @@ -272,23 +272,23 @@ instance Bin Literal where writeBytes (LReal d) = do putI 3; toBin d writeBytes (LPosition) = do putI 4 readBytes = do tag <- getI - case tag of - 0 -> do s <- fromBin; return (LString s) - 1 -> do c <- fromBin; return (LChar c) - 2 -> do il <- fromBin; return (LInt il) + case tag of + 0 -> do s <- fromBin; return (LString s) + 1 -> do c <- fromBin; return (LChar c) + 2 -> do il <- fromBin; return (LInt il) 3 -> do d <- fromBin; return (LReal d) - 4 -> return LPosition - n -> internalError $ "GenBin.Bin(Literal).readBytes: " ++ show n + 4 -> return LPosition + n -> internalError $ "GenBin.Bin(Literal).readBytes: " ++ show n instance Bin CQual where writeBytes (CQGen t p e) = do putI 0; toBin t; toBin p; toBin e writeBytes (CQFilter e) = do putI 1; toBin e readBytes = do tag <- getI - case tag of - 0 -> do t <- fromBin; p <- fromBin; e <- fromBin + case tag of + 0 -> do t <- fromBin; p <- fromBin; e <- fromBin return (CQGen t p e) - 1 -> do e <- fromBin; return (CQFilter e) - n -> internalError $ "GenBin.Bin(CQual).readBytes: " ++ show n + 1 -> do e <- fromBin; return (CQFilter e) + n -> internalError $ "GenBin.Bin(CQual).readBytes: " ++ show n instance Bin CExpr where writeBytes (CLam i e) = do putI 0; toBin i; toBin e @@ -345,72 +345,72 @@ instance Bin CExpr where toBin e_l; toBin e_rhs readBytes = do tag <- getI - case tag of - 0 -> do i <- fromBin; e <- fromBin; return (CLam i e) - 1 -> do i <- fromBin; qt <- fromBin; e <- fromBin; + case tag of + 0 -> do i <- fromBin; e <- fromBin; return (CLam i e) + 1 -> do i <- fromBin; qt <- fromBin; e <- fromBin; return (CLamT i qt e) - 2 -> do ds <- fromBin; e <- fromBin; return (Cletseq ds e) - 3 -> do ds <- fromBin; e <- fromBin; return (Cletrec ds e) - 4 -> do e <- fromBin; i <- fromBin; return (CSelect e i) - 5 -> do i <- fromBin; es <- fromBin; return (CCon i es) - 6 -> do pos <- fromBin; e <- fromBin; arms <- fromBin; + 2 -> do ds <- fromBin; e <- fromBin; return (Cletseq ds e) + 3 -> do ds <- fromBin; e <- fromBin; return (Cletrec ds e) + 4 -> do e <- fromBin; i <- fromBin; return (CSelect e i) + 5 -> do i <- fromBin; es <- fromBin; return (CCon i es) + 6 -> do pos <- fromBin; e <- fromBin; arms <- fromBin; return (Ccase pos e arms) - 7 -> do i <- fromBin; ies <- fromBin; return (CStruct i ies) - 8 -> do i <- fromBin; ies <- fromBin; return (CStructUpd i ies) - 9 -> do pos <- fromBin; e1 <- fromBin; e2 <- fromBin; + 7 -> do i <- fromBin; ies <- fromBin; return (CStruct i ies) + 8 -> do i <- fromBin; ies <- fromBin; return (CStructUpd i ies) + 9 -> do pos <- fromBin; e1 <- fromBin; e2 <- fromBin; return (Cwrite pos e1 e2) - 10 -> do pos <- fromBin; uk <- fromBin; return (CAny pos uk) - 11 -> do i <- fromBin; return (CVar i) - 12 -> do e <- fromBin; es <- fromBin; return (CApply e es) - 13 -> do e <- fromBin; es <- fromBin; return (CTaskApply e es) - 14 -> do e <- fromBin; t <- fromBin; es <- fromBin; + 10 -> do pos <- fromBin; uk <- fromBin; return (CAny pos uk) + 11 -> do i <- fromBin; return (CVar i) + 12 -> do e <- fromBin; es <- fromBin; return (CApply e es) + 13 -> do e <- fromBin; es <- fromBin; return (CTaskApply e es) + 14 -> do e <- fromBin; t <- fromBin; es <- fromBin; return (CTaskApplyT e t es) - 15 -> do l <- fromBin; return (CLit l) - 16 -> do e1 <- fromBin; i <- fromBin; e2 <- fromBin; + 15 -> do l <- fromBin; return (CLit l) + 16 -> do e1 <- fromBin; i <- fromBin; e2 <- fromBin; return (CBinOp e1 i e2) - 17 -> do e <- fromBin; qt <- fromBin; return (CHasType e qt) - 18 -> do pos <- fromBin; e1 <- fromBin; e2 <- fromBin; + 17 -> do e <- fromBin; qt <- fromBin; return (CHasType e qt) + 18 -> do pos <- fromBin; e1 <- fromBin; e2 <- fromBin; e3 <- fromBin; return (Cif pos e1 e2 e3) - 19 -> do pos <- fromBin; e1 <- fromBin; e2 <- fromBin; + 19 -> do pos <- fromBin; e1 <- fromBin; e2 <- fromBin; return (CSub pos e1 e2) - 20 -> do e1 <- fromBin; e2 <- fromBin; e3 <- fromBin; + 20 -> do e1 <- fromBin; e2 <- fromBin; e3 <- fromBin; return (CSub2 e1 e2 e3) - 21 -> do pos <- fromBin; ss <- fromBin; return (Cmodule pos ss) - 22 -> do pos <- fromBin; mi <- fromBin; ds <- fromBin; + 21 -> do pos <- fromBin; ss <- fromBin; return (Cmodule pos ss) + 22 -> do pos <- fromBin; mi <- fromBin; ds <- fromBin; return (Cinterface pos mi ds) - 23 -> do e <- fromBin; b <- fromBin; vc <- fromBin; + 23 -> do e <- fromBin; b <- fromBin; vc <- fromBin; vr <- fromBin; va <- fromBin; vf <- fromBin; vs <- fromBin; vp <- fromBin; return (CmoduleVerilog e b vc vr va vf vs vp) - 24 -> do i <- fromBin; qt <- fromBin; return (CForeignFuncC i qt) - 25 -> do b <- fromBin; ss <- fromBin; return (Cdo b ss) - 26 -> do pos <- fromBin; ss <- fromBin; return (Caction pos ss) - 27 -> do ps <- fromBin; rs <- fromBin; return (Crules ps rs) - 28 -> do es <- fromBin; return (CADump es) - 29 -> do ops <- fromBin; return (COper ops) - 30 -> do i1 <- fromBin; i2 <- fromBin; e <- fromBin; + 24 -> do i <- fromBin; qt <- fromBin; return (CForeignFuncC i qt) + 25 -> do b <- fromBin; ss <- fromBin; return (Cdo b ss) + 26 -> do pos <- fromBin; ss <- fromBin; return (Caction pos ss) + 27 -> do ps <- fromBin; rs <- fromBin; return (Crules ps rs) + 28 -> do es <- fromBin; return (CADump es) + 29 -> do ops <- fromBin; return (COper ops) + 30 -> do i1 <- fromBin; i2 <- fromBin; e <- fromBin; return (CCon1 i1 i2 e) - 31 -> do i1 <- fromBin; e <- fromBin; i2 <- fromBin; + 31 -> do i1 <- fromBin; e <- fromBin; i2 <- fromBin; return (CSelectTT i1 e i2) - 32 -> do mi <- fromBin; i <- fromBin; return (CCon0 mi i) - 33 -> do i1 <- fromBin; i2 <- fromBin; es <- fromBin; + 32 -> do mi <- fromBin; i <- fromBin; return (CCon0 mi i) + 33 -> do i1 <- fromBin; i2 <- fromBin; es <- fromBin; return (CConT i1 i2 es) - 34 -> do t <- fromBin; ies <- fromBin; return (CStructT t ies) - 35 -> do i1 <- fromBin; i2 <- fromBin; return (CSelectT i1 i2) - 36 -> do t <- fromBin; l <- fromBin; return (CLitT t l) - 37 -> do pos <- fromBin; uk <- fromBin; t <- fromBin; + 34 -> do t <- fromBin; ies <- fromBin; return (CStructT t ies) + 35 -> do i1 <- fromBin; i2 <- fromBin; return (CSelectT i1 i2) + 36 -> do t <- fromBin; l <- fromBin; return (CLitT t l) + 37 -> do pos <- fromBin; uk <- fromBin; t <- fromBin; return (CAnyT pos uk t) - 38 -> do t <- fromBin; e <- fromBin; b <- fromBin; vc <- fromBin; + 38 -> do t <- fromBin; e <- fromBin; b <- fromBin; vc <- fromBin; vr <- fromBin; va <- fromBin; vf <- fromBin; vs <- fromBin; vp <- fromBin; return (CmoduleVerilogT t e b vc vr va vf vs vp) - 39 -> do i <- fromBin; t <- fromBin; return (CForeignFuncCT i t) - 40 -> do e <- fromBin; ts <- fromBin; return (CTApply e ts) + 39 -> do i <- fromBin; t <- fromBin; return (CForeignFuncCT i t) + 40 -> do e <- fromBin; ts <- fromBin; return (CTApply e ts) 41 -> do ps <- fromBin; return (Cattributes ps) 42 -> do pos <- fromBin; e_vec <- fromBin; e_h <- fromBin; e_l <- fromBin; e_rhs <- fromBin return (CSubUpdate pos e_vec (e_h, e_l) e_rhs) - n -> internalError $ "GenBin.Bin(CExpr).readBytes: " ++ show n + n -> internalError $ "GenBin.Bin(CExpr).readBytes: " ++ show n instance Bin CDefl where writeBytes (CLValueSign d qs) = do putI 0; toBin d; toBin qs @@ -418,12 +418,12 @@ instance Bin CDefl where writeBytes (CLMatch p e) = do putI 2; toBin p; toBin e readBytes = do tag <- getI - case tag of - 0 -> do d <- fromBin; qs <- fromBin; return (CLValueSign d qs) - 1 -> do i <- fromBin; cs <- fromBin; qs <- fromBin; + case tag of + 0 -> do d <- fromBin; qs <- fromBin; return (CLValueSign d qs) + 1 -> do i <- fromBin; cs <- fromBin; qs <- fromBin; return (CLValue i cs qs) - 2 -> do p <- fromBin; e <- fromBin; return (CLMatch p e) - n -> internalError $ "GenBin.Bin(CDefl).readBytes: " ++ show n + 2 -> do p <- fromBin; e <- fromBin; return (CLMatch p e) + n -> internalError $ "GenBin.Bin(CDefl).readBytes: " ++ show n instance Bin CDef where writeBytes (CDef i qt cs) = do putI 0; toBin i; toBin qt; toBin cs @@ -431,12 +431,12 @@ instance Bin CDef where do putI 1; toBin i; toBin tvs; toBin qt; toBin cs readBytes = do tag <- getI - case tag of - 0 -> do i <- fromBin; qt <- fromBin; cs <- fromBin; + case tag of + 0 -> do i <- fromBin; qt <- fromBin; cs <- fromBin; return (CDef i qt cs) - 1 -> do i <- fromBin; tvs <- fromBin; qt <- fromBin; + 1 -> do i <- fromBin; tvs <- fromBin; qt <- fromBin; cs <- fromBin; return (CDefT i tvs qt cs) - n -> internalError $ "GenBin.Bin(CDef).readBytes: " ++ show n + n -> internalError $ "GenBin.Bin(CDef).readBytes: " ++ show n instance Bin CStmt where writeBytes (CSBindT p me ps qt e) = @@ -448,15 +448,15 @@ instance Bin CStmt where writeBytes (CSExpr me e) = do putI 4; toBin me; toBin e readBytes = do tag <- getI - case tag of - 0 -> do p <- fromBin; me <- fromBin; ps <- fromBin; qt <- fromBin; + case tag of + 0 -> do p <- fromBin; me <- fromBin; ps <- fromBin; qt <- fromBin; e <- fromBin; return (CSBindT p me ps qt e) - 1 -> do p <- fromBin; me <- fromBin; ps <- fromBin; e <- fromBin; + 1 -> do p <- fromBin; me <- fromBin; ps <- fromBin; e <- fromBin; return (CSBind p me ps e) - 2 -> do ds <- fromBin; return (CSletseq ds) - 3 -> do ds <- fromBin; return (CSletseq ds) - 4 -> do me <- fromBin; e <- fromBin; return (CSExpr me e) - n -> internalError $ "GenBin.Bin(CStmt).readBytes: " ++ show n + 2 -> do ds <- fromBin; return (CSletseq ds) + 3 -> do ds <- fromBin; return (CSletseq ds) + 4 -> do me <- fromBin; e <- fromBin; return (CSExpr me e) + n -> internalError $ "GenBin.Bin(CStmt).readBytes: " ++ show n instance Bin CMStmt where writeBytes (CMStmt s) = do putI 0; toBin s @@ -465,13 +465,13 @@ instance Bin CMStmt where writeBytes (CMTupleInterface pos es) = do putI 3; toBin pos; toBin es readBytes = do tag <- getI - case tag of - 0 -> do s <- fromBin; return (CMStmt s) - 1 -> do e <- fromBin; return (CMrules e) - 2 -> do e <- fromBin; return (CMinterface e) - 3 -> do pos <- fromBin; es <- fromBin; + case tag of + 0 -> do s <- fromBin; return (CMStmt s) + 1 -> do e <- fromBin; return (CMrules e) + 2 -> do e <- fromBin; return (CMinterface e) + 3 -> do pos <- fromBin; es <- fromBin; return (CMTupleInterface pos es) - n -> internalError $ "GenBin.Bin(CMStmt).readBytes: " ++ show n + n -> internalError $ "GenBin.Bin(CMStmt).readBytes: " ++ show n instance Bin CCaseArm where writeBytes (CCaseArm p qs e) = do toBin p; toBin qs; toBin e @@ -485,12 +485,12 @@ instance Bin CRule where do putI 1; toBin ps; toBin me; toBin qs; toBin rs readBytes = do tag <- getI - case tag of - 0 -> do ps <- fromBin; me <- fromBin; qs <- fromBin; e <- fromBin; + case tag of + 0 -> do ps <- fromBin; me <- fromBin; qs <- fromBin; e <- fromBin; return (CRule ps me qs e) - 1 -> do ps <- fromBin; me <- fromBin; qs <- fromBin; rs <- fromBin; + 1 -> do ps <- fromBin; me <- fromBin; qs <- fromBin; rs <- fromBin; return (CRuleNest ps me qs rs) - n -> internalError $ "GenBin.Bin(CRule).readBytes: " ++ show n + n -> internalError $ "GenBin.Bin(CRule).readBytes: " ++ show n -- ---------- @@ -500,12 +500,12 @@ instance Bin Pragma where writeBytes (Pproperties i ps) = do putI 0; toBin i; toBin ps writeBytes (Pnoinline is) = do putI 1; toBin is readBytes = do tag <- getI - case tag of - 0 -> do i <- fromBin + case tag of + 0 -> do i <- fromBin ps <- fromBin return (Pproperties i ps) - 1 -> do is <- fromBin; return (Pnoinline is) - n -> internalError $ "GenBin.Bin(Pragma).readBytes: " ++ show n + 1 -> do is <- fromBin; return (Pnoinline is) + n -> internalError $ "GenBin.Bin(Pragma).readBytes: " ++ show n -- ---------- -- Bin IPackage @@ -553,8 +553,8 @@ instance Bin (IExpr a) where writeBytes (ICon i ic) = do putI 4; toBin i; toBin ic writeBytes (IRefT _ _ _) = internalError "GenBin.Bin(IExpr).writeBytes: IRefT" readBytes = do tag <- getI - case tag of - 0 -> do i <- fromBin + case tag of + 0 -> do i <- fromBin t <- fromBin e <- fromBin return (ILam i t e) @@ -562,13 +562,13 @@ instance Bin (IExpr a) where ts <- fromBin es <- fromBin return (IAps e ts es) - 2 -> do i <- fromBin; return (IVar i) - 3 -> do i <- fromBin + 2 -> do i <- fromBin; return (IVar i) + 3 -> do i <- fromBin k <- fromBin e <- fromBin return (ILAM i k e) - 4 -> do i <- fromBin; ic <- fromBin; return (ICon i ic) - n -> internalError $ "GenBin.Bin(IExpr).readBytes: " ++ show n + 4 -> do i <- fromBin; ic <- fromBin; return (ICon i ic) + n -> internalError $ "GenBin.Bin(IExpr).readBytes: " ++ show n -- ---------- -- Bin IConInfo @@ -623,37 +623,37 @@ instance Bin (IConInfo a) where writeBytes (ICHandle { }) = internalError "GenBin.Bin(IConInfo).writeBytes: ICHandle" readBytes = do tag <- getI - t <- fromBin - case tag of - 0 -> -- ICDef contains the expression for the def + t <- fromBin + case tag of + 0 -> -- ICDef contains the expression for the def -- Here we use a don't-care value for the expression -- XXX Should we use an error there, so it's not silently used? return (ICDef t (icUndet t UNoMatch)) - 1 -> do p <- fromBin; return (ICPrim t (toEnum p)) - 2 -> do n <- fromBin + 1 -> do p <- fromBin; return (ICPrim t (toEnum p)) + 2 -> do n <- fromBin isC <- fromBin ps <- fromBin return (ICForeign t n isC ps Nothing) - 3 -> do i <- fromBin; j <- fromBin; return (ICCon t i j) - 4 -> do i <- fromBin; j <- fromBin; return (ICIs t i j) - 5 -> do i <- fromBin; j <- fromBin; return (ICOut t i j) - 6 -> do is <- fromBin; return (ICTuple t is) - 7 -> do i <- fromBin; j <- fromBin; return (ICSel t i j) - 8 -> do ui <- fromBin + 3 -> do i <- fromBin; j <- fromBin; return (ICCon t i j) + 4 -> do i <- fromBin; j <- fromBin; return (ICIs t i j) + 5 -> do i <- fromBin; j <- fromBin; return (ICOut t i j) + 6 -> do is <- fromBin; return (ICTuple t is) + 7 -> do i <- fromBin; j <- fromBin; return (ICSel t i j) + 8 -> do ui <- fromBin v <- fromBin tss <- fromBin return (ICVerilog t ui v tss) - 9 -> do u <- fromBin + 9 -> do u <- fromBin mv <- fromBin return (ICUndet t u mv) - 10 -> do v <- fromBin; return (ICInt t v) - 11 -> do v <- fromBin; return (ICReal t v) - 12 -> do s <- fromBin; return (ICString t s) - 13 -> do c <- fromBin; return (ICChar t c) - 14 -> do as <- fromBin; return (ICRuleAssert t as) - 15 -> do sps <- fromBin; return (ICSchedPragmas t sps) + 10 -> do v <- fromBin; return (ICInt t v) + 11 -> do v <- fromBin; return (ICReal t v) + 12 -> do s <- fromBin; return (ICString t s) + 13 -> do c <- fromBin; return (ICChar t c) + 14 -> do as <- fromBin; return (ICRuleAssert t as) + 15 -> do sps <- fromBin; return (ICSchedPragmas t sps) 16 -> do n <- fromBin; return (ICName t n) 17 -> do pps <- fromBin; return (ICAttrib t pps) 18 -> do pos <- fromBin; return (ICPosition t pos) 19 -> do it <- fromBin; return (ICType t it) - n -> internalError $ "GenBin.Bin(IConInfo).readBytes: " ++ show n + n -> internalError $ "GenBin.Bin(IConInfo).readBytes: " ++ show n diff --git a/src/comp/GenForeign.hs b/src/comp/GenForeign.hs index 9267ee9c5..203402929 100644 --- a/src/comp/GenForeign.hs +++ b/src/comp/GenForeign.hs @@ -22,48 +22,48 @@ genForeign :: ErrorHandle -> Flags -> String -> CPackage -> IO [(Id, ForeignFunction)] genForeign errh flags prefix (CPackage pkg_id _ _ _ defs _) = let - isPPforeignImport (PPforeignImport {}) = True - isPPforeignImport _ = False + isPPforeignImport (PPforeignImport {}) = True + isPPforeignImport _ = False foreignIds = [ i | (CPragma (Pproperties i pps)) <- defs, any isPPforeignImport pps ] foreignDefs = [ d | d@(CValueSign (CDefT i _ _ _)) <- defs, i `elem` foreignIds ] - foreignInfos = map extractForeignFuncInfo foreignDefs + foreignInfos = map extractForeignFuncInfo foreignDefs - genABin info@(src_id, foreign_func) = - let ffinfo = ABinForeignFuncInfo src_id foreign_func - abin = ABinForeignFunc ffinfo version - -- generate the filename - afilename_base = getIdString (ff_name foreign_func) - afilename = mkAName (bdir flags) prefix afilename_base - afilename_rel = getRelativeFilePath afilename - -- user message - abinPrintPrefix = "Foreign import file created: " - in do - -- write the file with full path - genABinFile errh afilename abin - -- report the file to the user with relative path - -- (typically just the filename, for current directory) - unless (quiet flags) $ putStrLnF $ abinPrintPrefix ++ afilename_rel - -- return the info, for dumping - return info + genABin info@(src_id, foreign_func) = + let ffinfo = ABinForeignFuncInfo src_id foreign_func + abin = ABinForeignFunc ffinfo version + -- generate the filename + afilename_base = getIdString (ff_name foreign_func) + afilename = mkAName (bdir flags) prefix afilename_base + afilename_rel = getRelativeFilePath afilename + -- user message + abinPrintPrefix = "Foreign import file created: " + in do + -- write the file with full path + genABinFile errh afilename abin + -- report the file to the user with relative path + -- (typically just the filename, for current directory) + unless (quiet flags) $ putStrLnF $ abinPrintPrefix ++ afilename_rel + -- return the info, for dumping + return info - -- check for duplicate imports and report an error - link_ids = map (ff_name . snd) foreignInfos - duplicates = findSame link_ids - mkDupErr dups = - let link_id = headOrErr "GenForeign mkDupErr link" dups - has_this_link (i,ff) = (ff_name ff == link_id) - src_ids = map fst (filter has_this_link foreignInfos) - src_ips = map (\i -> (getIdString i, getPosition i)) src_ids - link_name = getIdString link_id - pos = getPosition link_id - in (pos, EForeignFuncDuplicates link_name src_ips) + -- check for duplicate imports and report an error + link_ids = map (ff_name . snd) foreignInfos + duplicates = findSame link_ids + mkDupErr dups = + let link_id = headOrErr "GenForeign mkDupErr link" dups + has_this_link (i,ff) = (ff_name ff == link_id) + src_ids = map fst (filter has_this_link foreignInfos) + src_ips = map (\i -> (getIdString i, getPosition i)) src_ids + link_name = getIdString link_id + pos = getPosition link_id + in (pos, EForeignFuncDuplicates link_name src_ips) in - if (not (null duplicates)) - then bsError errh (map mkDupErr duplicates) - else mapM genABin foreignInfos + if (not (null duplicates)) + then bsError errh (map mkDupErr duplicates) + else mapM genABin foreignInfos -- After typechecking, the import should contain a CForeignFuncCT expression diff --git a/src/comp/GenFuncWrap.hs b/src/comp/GenFuncWrap.hs index 84e2f332c..b292cf45c 100644 --- a/src/comp/GenFuncWrap.hs +++ b/src/comp/GenFuncWrap.hs @@ -10,7 +10,7 @@ import Flags(Flags) import PPrint import Id import PreIds(idBits, idUnpack, idPack, tmpVarIds, - idActionValue, idFromActionValue_) + idActionValue, idFromActionValue_) import CSyntax import SymTab import Scheme @@ -53,21 +53,21 @@ genFuncWrap :: ErrorHandle -> Flags -> Bool -> CPackage -> SymTab -> genFuncWrap errh flags False p s = return (p, s, []) genFuncWrap errh flags True (CPackage pkgId exps imps fixs ds includes) symt = do let - -- separate out the noinline pragmas - (fpragmas, ds_no_fpragmas) = partition isNoInline ds - where isNoInline (CPragma (Pnoinline _)) = True - isNoInline _ = False - - -- Ids of functions specified as "noinline" - fs = [ i | CPragma (Pnoinline is) <- fpragmas, i <- is ] - - -- update function: - -- for noinline defs, call wrapFun to create updated defs and - -- symbol table info. for other defs, just return the def - -- with no new symbol table info. - wrap (CValueSign d@(CDef i _ _)) | i `elem` fs = - ctxReduce errh flags symt d >>= wrapFun errh pkgId - wrap d = return ([d], [], [], []) + -- separate out the noinline pragmas + (fpragmas, ds_no_fpragmas) = partition isNoInline ds + where isNoInline (CPragma (Pnoinline _)) = True + isNoInline _ = False + + -- Ids of functions specified as "noinline" + fs = [ i | CPragma (Pnoinline is) <- fpragmas, i <- is ] + + -- update function: + -- for noinline defs, call wrapFun to create updated defs and + -- symbol table info. for other defs, just return the def + -- with no new symbol table info. + wrap (CValueSign d@(CDef i _ _)) | i `elem` fs = + ctxReduce errh flags symt d >>= wrapFun errh pkgId + wrap d = return ([d], [], [], []) -- generate funcwrap info for all defs (minus the noinline pragmas) (dss, tss, fss, iss) <- mapM wrap ds_no_fpragmas >>= return . unzip4 @@ -79,26 +79,26 @@ genFuncWrap errh flags True (CPackage pkgId exps imps fixs ds includes) symt = d -- XXX genWrap doesn't add qualified fields, so we don't either - -- the new defs for the CPackage - ds' = concat dss + -- the new defs for the CPackage + ds' = concat dss - -- the new symbol table - -- only add the names as they are (qualified) - symt' = addFieldsQ + -- the new symbol table + -- only add the names as they are (qualified) + symt' = addFieldsQ (addTypesQ symt (ts ++ qts)) (concat fss) return $ - (CPackage pkgId exps imps fixs ds' includes, symt', concat iss) + (CPackage pkgId exps imps fixs ds' includes, symt', concat iss) -- --------------- ctxReduce :: ErrorHandle -> Flags -> SymTab -> CDef -> IO CDef ctxReduce errh flags symt d = case (cCtxReduceDef flags symt (CValueSign d)) of - Left msgs -> bsError errh msgs - Right (CValueSign d') -> return d' - Right dn -> internalError ("GenFuncWrap ctxReduce: " ++ - "unexpected defn: " ++ ppReadable dn) + Left msgs -> bsError errh msgs + Right (CValueSign d') -> return d' + Right dn -> internalError ("GenFuncWrap ctxReduce: " ++ + "unexpected defn: " ++ ppReadable dn) -- --------------- @@ -113,72 +113,72 @@ wrapFun :: ErrorHandle -> Id -> CDef -> wrapFun errh pkgId d@(CDef i qt@(CQType [] t) cs) = -- traces( "GenFuncWrap::wrapFun: d " ++ ppReadable d ) $ let - -- position of the function, for transfering to the new defs - pos = getIdPosition i + -- position of the function, for transfering to the new defs + pos = getIdPosition i -- propagate arguments names, if possible -- XXX names are a little uglier for classic defs -- XXX do we need to propagate type-info as well? argNames = map fst (getDefArgs cs t) - -- ---------- - -- generate a new interface + -- ---------- + -- generate a new interface - -- name of the new ifc - ifcId = mkIdPre (mkFString "Interface_") i - ifcQId = qualId pkgId ifcId - -- type of the new ifc - ifcTy = TCon (TyCon ifcQId (Just KStar) - (TIstruct (SInterface noIfcPragmas) [i])) - -- type info for the new ifc - ifcInf = TypeInfo (Just ifcQId) KStar [] - (TIstruct (SInterface noIfcPragmas) [i]) + -- name of the new ifc + ifcId = mkIdPre (mkFString "Interface_") i + ifcQId = qualId pkgId ifcId + -- type of the new ifc + ifcTy = TCon (TyCon ifcQId (Just KStar) + (TIstruct (SInterface noIfcPragmas) [i])) + -- type info for the new ifc + ifcInf = TypeInfo (Just ifcQId) KStar [] + (TIstruct (SInterface noIfcPragmas) [i]) -- pragmas for the method field_pragmas = [PIArgNames argNames] - -- defn for the new ifc - ifc = Cstruct True (SInterface noIfcPragmas) (IdKind ifcId KStar) [] + -- defn for the new ifc + ifc = Cstruct True (SInterface noIfcPragmas) (IdKind ifcId KStar) [] [CField { cf_name = i, cf_pragmas = Just field_pragmas, cf_type = qt, cf_default= [], cf_orig_type = Nothing }] [] - -- Fieldinfo for the method of the new ifc - fldInf = FieldInfo ifcQId True 0 - (i :>: toScheme (ifcTy `fn` t)) - field_pragmas + -- Fieldinfo for the method of the new ifc + fldInf = FieldInfo ifcQId True 0 + (i :>: toScheme (ifcTy `fn` t)) + field_pragmas [] -- no defaults Nothing -- no type for wrapper tracking - -- ---------- - -- generate a new module, providing that interface - - -- name of the new module - modId = makeGenFuncId i - -- expr for the new module - mode = Cmodule pos - [CMinterface (Cinterface pos Nothing [CLValueSign d []])] - -- defn for the new module - mod = CValueSign (CDef modId (CQType [] (TAp tModule ifcTy)) - [CClause [] [] mode]) - -- pragma indicating to generate this new module - gen = CPragma (Pproperties modId [PPverilog]) + -- ---------- + -- generate a new module, providing that interface + + -- name of the new module + modId = makeGenFuncId i + -- expr for the new module + mode = Cmodule pos + [CMinterface (Cinterface pos Nothing [CLValueSign d []])] + -- defn for the new module + mod = CValueSign (CDef modId (CQType [] (TAp tModule ifcTy)) + [CClause [] [] mode]) + -- pragma indicating to generate this new module + gen = CPragma (Pproperties modId [PPverilog]) in if (not (null (tv t))) then bsError errh [(getPosition i, ENoInlinePolymorphic (getIdString i))] else return $ ( - -- new top-level defs - [ifc, gen, mod], - -- ifc Id and type info (for the symbol table) - [(ifcId, ifcInf)], - -- method Id and field info (for the symbol table) - [(i, fldInf)], - -- - [(modId, ifcId, i, argNames, qt)] - ) + -- new top-level defs + [ifc, gen, mod], + -- ifc Id and type info (for the symbol table) + [(ifcId, ifcInf)], + -- method Id and field info (for the symbol table) + [(i, fldInf)], + -- + [(modId, ifcId, i, argNames, qt)] + ) wrapFun errh _ (CDef i _ _) = bsError errh [(getPosition i, ENoInlineContext (getIdBaseString i))] @@ -186,7 +186,7 @@ wrapFun errh _ (CDef i _ _) = -- this is an internal error, because only the typechecker creates CDefT wrapFun errh _ (CDefT i _ _ _) = internalError ("wrapFun: context CDefT not allowed for verilog function: " - ++ ppString i) + ++ ppString i) -- =============== @@ -206,29 +206,29 @@ addFuncWrap errh symt is (CPackage modid exps imps fixs ds includes) = do addf :: FuncInfo -> IO [CDefn] addf (mi, ti, i, args, qt) = let - -- escaped versions of the func name and type - -- (as would be generated by GenWrap) - i_ = modIdRename [] i - ti_ = ifcIdRename [] ti - - -- find the declaration for the escapted interface - -- which GenWrap created (in primitive bitified form) - -- and extract the types of the methods - method_types = - [ cf_type field - | Cstruct _ _ (IdKind ti_' _) _ fs _ <- ds, - ti_ == ti_', field <- fs, cf_name field == i ] - in - -- exactly one method should be found - case (method_types) of - [qt_@(CQType _ t_)] -> do - let -- the number of arguments - n = nArrows t_ - -- definitions for the wrapper and wrappee - d <- funcDef errh symt i qt i_ n qt_ - let d_ = funcDef_ n mi i i_ qt_ args - return [d, d_] - _ -> internalError ("addFuncWrap: " ++ ppString (ti_, i_)) + -- escaped versions of the func name and type + -- (as would be generated by GenWrap) + i_ = modIdRename [] i + ti_ = ifcIdRename [] ti + + -- find the declaration for the escapted interface + -- which GenWrap created (in primitive bitified form) + -- and extract the types of the methods + method_types = + [ cf_type field + | Cstruct _ _ (IdKind ti_' _) _ fs _ <- ds, + ti_ == ti_', field <- fs, cf_name field == i ] + in + -- exactly one method should be found + case (method_types) of + [qt_@(CQType _ t_)] -> do + let -- the number of arguments + n = nArrows t_ + -- definitions for the wrapper and wrappee + d <- funcDef errh symt i qt i_ n qt_ + let d_ = funcDef_ n mi i i_ qt_ args + return [d, d_] + _ -> internalError ("addFuncWrap: " ++ ppString (ti_, i_)) -- --------------- @@ -242,46 +242,46 @@ addFuncWrap errh symt is (CPackage modid exps imps fixs ds includes) = do -- t = the base type of the foreign function funcDef errh symt i oqt@(CQType octxs ot) i_ n (CQType _ t) = let - -- unfortunately, we have to duplicate the work that genwrap did - -- in creating the interface interface type and interface - -- conversion functions + -- unfortunately, we have to duplicate the work that genwrap did + -- in creating the interface interface type and interface + -- conversion functions - pos = getPosition i - (as, r) = getArrows ot + pos = getPosition i + (as, r) = getArrows ot - -- the arguments are always bitifiable - bitsCtx a s = CPred (CTypeclass idBits) [a, s] - size_vars = map (cTVarNum . enumId "sn" pos) [0..] - as_ctxs = zipWith bitsCtx as size_vars + -- the arguments are always bitifiable + bitsCtx a s = CPred (CTypeclass idBits) [a, s] + size_vars = map (cTVarNum . enumId "sn" pos) [0..] + as_ctxs = zipWith bitsCtx as size_vars - vs = map (setIdPosition pos) $ take n tmpVarIds - epack e = cVApply idPack [e] - es = map (epack . CVar) vs + vs = map (setIdPosition pos) $ take n tmpVarIds + epack e = cVApply idPack [e] + es = map (epack . CVar) vs - f_expr = cVApply i_ es + f_expr = cVApply i_ es - -- the result is either an actionvalue or a value - isAV = isActionValue symt r + -- the result is either an actionvalue or a value + isAV = isActionValue symt r - r_size_var = cTVarNum $ enumId "sn" pos n - r_ctxs = case (isAV) of - Just av_t -> [bitsCtx av_t r_size_var] - Nothing -> [bitsCtx r r_size_var] + r_size_var = cTVarNum $ enumId "sn" pos n + r_ctxs = case (isAV) of + Just av_t -> [bitsCtx av_t r_size_var] + Nothing -> [bitsCtx r r_size_var] - expr = if (isJust isAV) - then cVApply idFromActionValue_ [f_expr] - else cVApply idUnpack [f_expr] + expr = if (isJust isAV) + then cVApply idFromActionValue_ [f_expr] + else cVApply idUnpack [f_expr] - -- put the ctxs together - ctxs' = as_ctxs ++ r_ctxs ++ octxs - qt' = CQType ctxs' ot + -- put the ctxs together + ctxs' = as_ctxs ++ r_ctxs ++ octxs + qt' = CQType ctxs' ot in - -- XXX this code works for Action/ActionValue foreign funcs, - -- XXX but they are not handled by astate yet - if (isJust isAV) - then bsError errh [(getPosition i, ENoInlineAction (getIdBaseString i))] - else return $ - CValueSign (CDef i qt' [CClause (map CPVar vs) [] expr]) + -- XXX this code works for Action/ActionValue foreign funcs, + -- XXX but they are not handled by astate yet + if (isJust isAV) + then bsError errh [(getPosition i, ENoInlineAction (getIdBaseString i))] + else return $ + CValueSign (CDef i qt' [CClause (map CPVar vs) [] expr]) -- --------------- @@ -297,12 +297,12 @@ funcDef errh symt i oqt@(CQType octxs ot) i_ n (CQType _ t) = funcDef_ n mi i i_ qt_ args = let mstr = getIdString mi - -- input ports: _ - iports = [ oport ++ "_" ++ getIdString arg | arg <- args ] - -- output port: - oport = getIdString i + -- input ports: _ + iports = [ oport ++ "_" ++ getIdString arg | arg <- args ] + -- output port: + oport = getIdString i in - Cforeign i_ qt_ (Just mstr) (Just (iports, [oport])) + Cforeign i_ qt_ (Just mstr) (Just (iports, [oport])) -- --------------- @@ -332,8 +332,8 @@ expandSynSym symt xt = isActionValue :: SymTab -> Type -> Maybe Type isActionValue symt t = case (expandSynSym symt t) of - (TAp (TCon (TyCon i _ _)) av_t) | (qualEq i idActionValue) - -> Just av_t - _ -> Nothing + (TAp (TCon (TyCon i _ _)) av_t) | (qualEq i idActionValue) + -> Just av_t + _ -> Nothing -- =============== diff --git a/src/comp/GenSign.hs b/src/comp/GenSign.hs index f70fab5a6..b6679dfee 100644 --- a/src/comp/GenSign.hs +++ b/src/comp/GenSign.hs @@ -298,8 +298,8 @@ getInsts (CPackage _ _ imps _ pds includes) = [ i | CImpSign _ _ (CSignature _ _ _ ds) <- imps, i@(CIinstance _ (CQType _ t)) <- ds, not (all (fromPrelude . leftTyCon) (t : tyConArgs t)) ] -- XXX Might break if a Prelude type was declared outside the Prelude to be an --- instance of a Prelude typeclass, and an attempt was made to use that --- instance in a third file. +-- instance of a Prelude typeclass, and an attempt was made to use that +-- instance in a third file. fromPrelude (Just (TyCon i _ _)) = (getIdQFString i == Just fsPrelude || getIdQFString i == Just fsPreludeBSV) diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index 452b6b900..f154c4220 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -847,7 +847,7 @@ genIfc trec args knd = --traceM("genIfc: " ++ ppReadable trec ) ; -- lookup interface pragmas from symt and pass them in. iprags <- getInterfacePrags rootId - let prefix = noPrefixes { ifcp_pragmas = iprags } + let prefix = noPrefixes { ifcp_pragmas = iprags } fieldprops <- mapM (genIfcField' trec rootId prefix ) fts let (fields,ppropss) = unzip fieldprops let newprops = concat ppropss diff --git a/src/comp/GraphPaths.hs b/src/comp/GraphPaths.hs index 19378f623..bb2a18318 100644 --- a/src/comp/GraphPaths.hs +++ b/src/comp/GraphPaths.hs @@ -77,12 +77,12 @@ updatePaths mat src dst = (src_word_idx,src_bit_offset0) = src `quotRem` 32 src_bit_offset = fromIntegral src_bit_offset0 the_arr = arr mat - or_one_word :: Word32 -> Word32 -> IO () + or_one_word :: Word32 -> Word32 -> IO () or_one_word sor n = do w1 <- readArray the_arr (sor + n) w2 <- readArray the_arr (start_of_dst_row + n) writeArray the_arr (sor + n) (w1 .|. w2) or_one_row sor = mapM_ (or_one_word sor) [0..((words_per_row mat) - 1)] - update_row :: Bool -> Word32 -> IO () + update_row :: Bool -> Word32 -> IO () update_row force r = do let start_of_row = r * (words_per_row mat) w0 <- readArray the_arr (start_of_row + src_word_idx) when (force || (testBit w0 src_bit_offset)) $ diff --git a/src/comp/GraphUtil.hs b/src/comp/GraphUtil.hs index db637e8a0..4195850ed 100644 --- a/src/comp/GraphUtil.hs +++ b/src/comp/GraphUtil.hs @@ -1,10 +1,10 @@ module GraphUtil ( - extractOneCycle, - extractOneCycle_gmap, - extractOneCycle_map, - findPathEdges, - reverseMap - ) where + extractOneCycle, + extractOneCycle_gmap, + extractOneCycle_map, + findPathEdges, + reverseMap + ) where -- ================================================== -- GraphUtil @@ -34,25 +34,25 @@ extractOneCycle :: (Ord nodeT, PPrint nodeT) => [(nodeT,nodeT)] -> [nodeT] -> [nodeT] extractOneCycle edges cycle@(a:b:_) = let nodes = cycle - g = unsafePerformIO (GW.makeGraph nodes edges) - - intErr s = internalError ("extractOneCyle: " ++ s) - - findPath x y = - case (GW.findReachables g [x]) of - [ps] -> case (lookup y ps) of - Just path -> reverse path - Nothing -> intErr ("lookup: " ++ ppReadable ps) - x -> intErr ("reachables: " ++ ppReadable x) - - path_a_to_b = findPath a b - path_b_to_a = findPath b a - -- join the two paths, but with no duplicate node b in the middle - cycle_path = - path_a_to_b ++ - tailOrErr ("extractOneCycle: path_b_to_a does not contain b:" - ++ ppReadable path_b_to_a) - path_b_to_a + g = unsafePerformIO (GW.makeGraph nodes edges) + + intErr s = internalError ("extractOneCyle: " ++ s) + + findPath x y = + case (GW.findReachables g [x]) of + [ps] -> case (lookup y ps) of + Just path -> reverse path + Nothing -> intErr ("lookup: " ++ ppReadable ps) + x -> intErr ("reachables: " ++ ppReadable x) + + path_a_to_b = findPath a b + path_b_to_a = findPath b a + -- join the two paths, but with no duplicate node b in the middle + cycle_path = + path_a_to_b ++ + tailOrErr ("extractOneCycle: path_b_to_a does not contain b:" + ++ ppReadable path_b_to_a) + path_b_to_a in cycle_path extractOneCycle _ [a] = [a] -- a cycle from a node to itself extractOneCycle _ [] = @@ -61,21 +61,21 @@ extractOneCycle _ [] = -- extract a cycle given a GraphMap extractOneCycle_gmap :: (Ord nodeT, PPrint nodeT) => - G.GraphMap nodeT edgeT -> [nodeT] -> [nodeT] + G.GraphMap nodeT edgeT -> [nodeT] -> [nodeT] extractOneCycle_gmap gmap cycle = let edges = [ (r, r') | r <- cycle, r' <- cycle, r' /= r, - isJust (G.lookup (r,r') gmap) ] + isJust (G.lookup (r,r') gmap) ] in extractOneCycle edges cycle -- extract a cycle given a Map extractOneCycle_map :: (Ord nodeT, PPrint nodeT) => - M.Map nodeT [nodeT] -> [nodeT] -> [nodeT] + M.Map nodeT [nodeT] -> [nodeT] -> [nodeT] extractOneCycle_map m cycle = let edges = [ (r, r') | r <- cycle, - let rs = M.findWithDefault [] r m, - r' <- rs, - r' `elem` cycle ] + let rs = M.findWithDefault [] r m, + r' <- rs, + r' `elem` cycle ] in extractOneCycle edges cycle @@ -89,26 +89,26 @@ findPathEdges :: (Ord nodeT, PPrint nodeT) => [((nodeT, nodeT), edgeT)] findPathEdges gmap path = let - -- the path without the start node (which is same as the end) - path_minus_start = - tailOrErr - ("findPathEdges: path_minus_start" ++ ppReadable path) - path - -- the path without the end node (which is same as the start) - path_minus_end = - initOrErr - ("findPathEdges: path_minus_end: " ++ ppReadable path) - path - -- all the edges in the circular path - path_pairs = zip path_minus_end path_minus_start - -- lookup which shouldn't fail - getEdge pair = - case (G.lookup pair gmap) of - Nothing -> internalError ("findPathEdges: lookup failed: " ++ - ppReadable pair) - Just edge -> (pair,edge) + -- the path without the start node (which is same as the end) + path_minus_start = + tailOrErr + ("findPathEdges: path_minus_start" ++ ppReadable path) + path + -- the path without the end node (which is same as the start) + path_minus_end = + initOrErr + ("findPathEdges: path_minus_end: " ++ ppReadable path) + path + -- all the edges in the circular path + path_pairs = zip path_minus_end path_minus_start + -- lookup which shouldn't fail + getEdge pair = + case (G.lookup pair gmap) of + Nothing -> internalError ("findPathEdges: lookup failed: " ++ + ppReadable pair) + Just edge -> (pair,edge) in - map getEdge path_pairs + map getEdge path_pairs -- =============== @@ -117,13 +117,13 @@ findPathEdges gmap path = reverseMap :: (Ord a) => M.Map a [a] -> M.Map a [a] reverseMap m = let edges = M.toList m - startEdge (e1,_) = (e1, []) - reverseEdge (e1,es) = [(e2,[e1]) | e2 <- es] - -- make sure that the map has "[]" for nodes with no ingoing edges - -- XXX alternatively, users of this map could treat lookup failure - -- XXX as meaning the empty list - rev_edges = map startEdge edges ++ - concatMap reverseEdge edges + startEdge (e1,_) = (e1, []) + reverseEdge (e1,es) = [(e2,[e1]) | e2 <- es] + -- make sure that the map has "[]" for nodes with no ingoing edges + -- XXX alternatively, users of this map could treat lookup failure + -- XXX as meaning the empty list + rev_edges = map startEdge edges ++ + concatMap reverseEdge edges in M.fromListWith (++) rev_edges -- =============== diff --git a/src/comp/GraphWrapper.hs b/src/comp/GraphWrapper.hs index e71d7d694..e5b6d6777 100644 --- a/src/comp/GraphWrapper.hs +++ b/src/comp/GraphWrapper.hs @@ -240,7 +240,7 @@ reachable_withPath g v = preorderF_withPath [] (G.dfs g [v]) -- Check if a path exists, but don't return it hasPath :: Ord a => Graph a -> a -> a -> Bool hasPath g@(Graph graph ordmap lookuptable _) in_v out_v = - let in_int = vToInt g in_v + let in_int = vToInt g in_v out_int = vToInt g out_v g_immut = unsafePerformIO (freeze graph) in G.path g_immut in_int out_int diff --git a/src/comp/IConv.hs b/src/comp/IConv.hs index 4f9a4e008..95385dc50 100644 --- a/src/comp/IConv.hs +++ b/src/comp/IConv.hs @@ -61,7 +61,7 @@ iConvPackage errh flags r (CPackage pi _ _ _ ds _) = iConvDef :: ErrorHandle -> Flags -> SymTab -> IPackage a -> CDefn -> IDef a iConvDef errh flags r (IPackage pi _ _ ds) def = - let env = M.fromList ([(i, ICon i (ICDef t e)) | IDef i t e _ <- ds]) + let env = M.fromList ([(i, ICon i (ICDef t e)) | IDef i t e _ <- ds]) pvs = map IVar tmpVarIds in case iConvD errh flags pi r env pvs def of [d] -> d @@ -79,7 +79,7 @@ iConvVar flags r env i = Just (VarInfo (VarForg name mps) (_ :>: sc) _) -> let t = iConvSc flags r sc ops' = case mps of - Just (ips, [op]) -> Just (zip ips (repeat 0), [(op, 0)]) -- XXX a hack for single output + Just (ips, [op]) -> Just (zip ips (repeat 0), [(op, 0)]) -- XXX a hack for single output Just (ips, ops) -> Just (addSizes ips ops [] t) Nothing -> Nothing addSizes (i:is) ops ins (ITAp (ITAp arr (ITAp bit (ITNum n))) r) | arr == itArrow && bit == itBit = @@ -559,7 +559,7 @@ getMethodType flags r ti ts m = iInst selty ts iConvR :: ErrorHandle -> Flags -> SymTab -> Env a -> IPVars a -> CRule -> IExpr a iConvR errh flags r env pvs rule@(CRule rps i qs a) = - let (p, bindFn, env') = iConvQs errh flags r env pvs qs + let (p, bindFn, env') = iConvQs errh flags r env pvs qs a' = bindFn $ iConvE errh flags r env' pvs a s = case i of Nothing -> iMkStringAt (getPosition rule) "" Just i -> iConvE errh flags r env pvs i @@ -700,7 +700,7 @@ splitITApCon t = case (splitITAp t) of -- Get first argument to a (possibly quantified) function argType :: IType -> IType argType (ITAp (ITAp arr a) _) | arr == itArrow = a -argType (ITForAll _ _ t) = argType t -- A hack... +argType (ITForAll _ _ t) = argType t -- A hack... argType t = internalError ("argType: " ++ ppReadable t) -- Drop first argument to a (possibly quantified) function diff --git a/src/comp/IDropRules.hs b/src/comp/IDropRules.hs index f27bacedb..1ff450c0a 100644 --- a/src/comp/IDropRules.hs +++ b/src/comp/IDropRules.hs @@ -55,7 +55,7 @@ dropFalseRules errh flags imod@(IModule { imod_rules = (IRules sps rs), -- we treat the split rules differently, so separate them out let (splitFalseRules, nonsplitFalseRules) = - partition isSplitRule falseRules + partition isSplitRule falseRules -- warn about the non-split False rules let removeFalseRule = removeFalseRules flags @@ -65,12 +65,12 @@ dropFalseRules errh flags imod@(IModule { imod_rules = (IRules sps rs), then return () else bsWarning errh [(getPosition rid, - WRuleAlwaysFalse (dropRulePrefix rid) removeFalseRule)] + WRuleAlwaysFalse (dropRulePrefix rid) removeFalseRule)] mapM_ warnFalseRule nonsplitFalseRules -- the final set of kept rules and dropped rules, depending on the flag let (rs', dropped_rules) = - if removeFalseRule + if removeFalseRule then -- all False rules are dropped (okRules, falseRules) else -- keep the non-split rules, but always drop the split rules @@ -91,9 +91,9 @@ dropEmptyRules errh flags imod@(IModule { imod_rules = (IRules sps rs), imod_local_defs = ds }) = do -- identify empty rules which do not preempt other rules (in sps) let (emptyNonPreemptRules, okRules) = - partition (\r -> isNoActionRule r && - not (isRulePreempt (getIRuleId r) sps)) - rs + partition (\r -> isNoActionRule r && + not (isRulePreempt (getIRuleId r) sps)) + rs -- we treat the split rules differently, so separate them out let (splitEmptyRules, nonsplitEmptyRules) = @@ -107,12 +107,12 @@ dropEmptyRules errh flags imod@(IModule { imod_rules = (IRules sps rs), then return () else bsWarning errh [(getPosition rid, - WRuleNoActions (dropRulePrefix rid) removeEmptyRule)] + WRuleNoActions (dropRulePrefix rid) removeEmptyRule)] mapM_ warnEmptyRule nonsplitEmptyRules -- the final set of kept rules and dropped rules, depending on the flag let (rs', dropped_rules) = - if removeEmptyRule + if removeEmptyRule then -- all empty rules are dropped (okRules, emptyNonPreemptRules) else -- keep the non-split rules, but always drop the split rules @@ -132,7 +132,7 @@ dropEmptyRules errh flags imod@(IModule { imod_rules = (IRules sps rs), isFalseRule (IRule { irule_pred = (ICon _ (ICInt { iVal = (IntLit { ilValue = 0 }) })) } ) - = True + = True isFalseRule _ = False -- is the rule a result of splitting @@ -188,7 +188,7 @@ warnUndetPreds errh flags imod@(IModule { imod_rules = (IRules _ rs), expandExpr (IAps f ts as) = (IAps (expandExpr f) ts (map expandExpr as)) expandExpr (ICon i (ICValue {})) = expandExpr $ - fromJustOrErr ("expandExpr: " ++ ppReadable i) $ M.lookup i dmap + fromJustOrErr ("expandExpr: " ++ ppReadable i) $ M.lookup i dmap expandExpr e = e -} let diff --git a/src/comp/IExpand.hs b/src/comp/IExpand.hs index 97fd8388c..c9f5b314e 100644 --- a/src/comp/IExpand.hs +++ b/src/comp/IExpand.hs @@ -1378,9 +1378,9 @@ handlePrim rec (curClk, curRstn) ns p handlePrim rec curClkRstn ns p e@(IAps (ICon _ (ICPrim { primOp = PrimSavePortType })) _ [e_mname, e_port, e_type]) = do mname <- do m <- evalMaybe e_mname - case (m) of - Nothing -> return Nothing - Just e_name -> evalName e_name >>= return . Just + case (m) of + Nothing -> return Nothing + Just e_name -> evalName e_name >>= return . Just (port, _) <- evalString e_port t <- evalType e_type savePortType mname (VName port) t @@ -1500,7 +1500,7 @@ handlePrim rec curClkRstn ns p e@(IAps (ICon _ (ICPrim { primOp = op })) _ _) handlePrim rec curClkRstn ns p e = do when doDebug $ traceM ("handlePrim: no match " ++ (ppReadable e)) nfError "handlePrim" e --- internalError ("iExpandModule handlePrim\n" ++ ppReadable e) +-- internalError ("iExpandModule handlePrim\n" ++ ppReadable e) -- ---------- @@ -1969,9 +1969,9 @@ evalRule (ns, hide, name) asrts rId p c e = do upc <- unheapAll (predToHExpr pc) upe <- unheapAll (predToHExpr pe) -} --- upp <- unheapAll pp --- traceM ("RULE " ++ ppReadable (c', e') ++ ppReadable upp) --- traceM ("RULE " ++ ppReadable (map normPConj [p, pc, pe])) +-- upp <- unheapAll pp +-- traceM ("RULE " ++ ppReadable (c', e') ++ ppReadable upp) +-- traceM ("RULE " ++ ppReadable (map normPConj [p, pc, pe])) setAggressive module_agg return (ieAnd pp c', e', ws) @@ -2380,7 +2380,7 @@ walkNF e = upd (pConj pe p0) e' ws_e -- The special cases for PrimIf, PrimCase, PrimArrayDynSelect, - -- PrimBAnd, PrimBOr are for more accurate implicit conditions. + -- PrimBAnd, PrimBOr are for more accurate implicit conditions. IAps f@(ICon _ (ICPrim _ PrimIf)) [ty] [c, t, e] -> do (P pc c', ws_c) <- walkNF c (P pt t', ws_t) <- walkNF t @@ -2494,7 +2494,7 @@ walkNF e = [e_ref@(IRefT t ptr ref)] | (isitActionValue_ t) || (isitAction t) -> do (P p' e', ws) <- walkNF e_ref upd (pConj p0 p') (IAps f ts [e']) ws - _ -> do when doDebug $ traceM "not stvar or foreign\n" + _ -> do when doDebug $ traceM "not stvar or foreign\n" when doDebug $ traceM (show u ++ "\n") when doDebug $ traceM (show es' ++ "\n") nfError "walkNF sel" u @@ -2672,7 +2672,7 @@ evalUHn n e = do case pe of -- XXX should we eval or just unheap? P p (IAps f ts es) -> do --- f' <- evalUHn (n-1) f +-- f' <- evalUHn (n-1) f (p', es') <- evalList (evalUHn (n-1)) es return (P (pConj p p') (IAps f ts es')) _ -> return pe @@ -2726,7 +2726,7 @@ evalStaticOp' doUH doBK doUndet e resultType handler = do [_, ITNum idx_sz] [arr_e, idx_e] -> do addPredG p $ evalStaticOpInArray' doUH doBK doUndet - ic idx_e idx_sz arr_e resultType handler + ic idx_e idx_sz arr_e resultType handler {- -- XXX this situation doesn't occur, because we don't use evalStaticOp @@ -2766,9 +2766,9 @@ evalStaticOp' doUH doBK doUndet e resultType handler = do {-# INLINE evalStaticOpInArray' #-} evalStaticOpInArray' :: Bool -> Bool -> Bool -> - HExpr -> HExpr -> Integer -> + HExpr -> HExpr -> Integer -> HExpr -> IType -> - (HExpr -> (HPred, HExpr) -> G PExpr) -> G PExpr + (HExpr -> (HPred, HExpr) -> G PExpr) -> G PExpr evalStaticOpInArray' doUH doBK doUndet ic idx_e idx_sz arr_e resultType handler = do -- doUH doesn't apply here @@ -2901,11 +2901,11 @@ evalAp' e@(IAps f tys es) as = evalAp' e@(IRefT _ ptr ref) [] = do pe <- evalHeap (ptr, ref) case pe of - P _ (ICon _ _) -> return pe -- expand constants - _ -> return (pExpr e) -- keep heap pointer for rest + P _ (ICon _ _) -> return pe -- expand constants + _ -> return (pExpr e) -- keep heap pointer for rest evalAp' (IRefT t ptr ref) as = do (P p e) <- evalHeap (ptr, ref) --- when (p /= pTrue) $ traceM ("implicit function condition lost: " ++ ppReadable (p, e)) -- XXX +-- when (p /= pTrue) $ traceM ("implicit function condition lost: " ++ ppReadable (p, e)) -- XXX let e' = iePrimWhenPred t p e when doDebug $ traceM ("iref ap " ++ ppReadable (mkAp e as)) evalAp "IRefT" e' as @@ -3623,8 +3623,8 @@ conAp' _ (ICPrim _ op) fe@(ICon prim_id _) as | strictPrim op = do else (head argPositions) let isDyn (IAps (ICon _ (ICPrim _ PrimArrayDynSelect)) _ _) = True - isDyn (IAps (ICon _ (ICPrim _ PrimIf)) _ _) = True - isDyn _ = False + isDyn (IAps (ICon _ (ICPrim _ PrimIf)) _ _) = True + isDyn _ = False -- XXX we can also push the op into the arms of PrimIf/PrimArrayDynSelect -- XXX if all of the arms are IntLit, at least for single argument ops -- XXX (in the absense of this, we do a special case for PrimBNot, see below) @@ -3635,20 +3635,20 @@ conAp' _ (ICPrim _ op) fe@(ICon prim_id _) as | strictPrim op = do Just (Right e) -> return (P p e) Just (Left errmsg) -> errG (bestPosition, errmsg) Nothing -> - --internalError ("conAp' strictPrim: " ++ ppReadable (op, as')) - -- For now, make this arm a no-op, because some examples do - -- reach here with prims that do not reduce (like PrimChr) - -- (This uses the unheaped "ees", which includes the predicate.) - bldAp' "Prim 1" fe ees + --internalError ("conAp' strictPrim: " ++ ppReadable (op, as')) + -- For now, make this arm a no-op, because some examples do + -- reach here with prims that do not reduce (like PrimChr) + -- (This uses the unheaped "ees", which includes the predicate.) + bldAp' "Prim 1" fe ees else case (op, as') of (PrimBNot, [E e]) | isDyn e -> -- The iTransExpr catch-all will handle PrimIf but not arrays let handler e' = - case (doPrimOp bestPosition op [] [e']) of - Just (Right e_res) -> return (pExpr e_res) - Just (Left errmsg) -> errG (bestPosition, errmsg) - Nothing -> evalAp "Prim PrimBNot" fe [E e'] + case (doPrimOp bestPosition op [] [e']) of + Just (Right e_res) -> return (pExpr e_res) + Just (Left errmsg) -> errG (bestPosition, errmsg) + Nothing -> evalAp "Prim PrimBNot" fe [E e'] in addPredG p $ evalStaticOp e itBit1 handler -- name primitives (PrimJoinNames, [E (ICon _ (ICName { iName = n1 })), @@ -4119,7 +4119,7 @@ doArrayLength f as@[T elem_t, E arr_e] = -- update does not change the array length, so recurse into arr_e2 doArrayLength f [T elem_t, E arr_e2] handleArrayLength arr_e' = - nfError "primArrayLength" $ mkAp f [T elem_t, E arr_e'] + nfError "primArrayLength" $ mkAp f [T elem_t, E arr_e'] doArrayLength f as = internalError("IExpand.doArrayLength : " ++ ppReadable f ++ ppReadable as) @@ -4173,7 +4173,7 @@ doArraySelect f (T elem_t : E arr_e : E idx_e : as) = do handleArraySelect arr_e' = do --traceM("Select: " ++ show arr_e') nfError "primArraySelect" $ - mkAp f [T elem_t, E arr_e', E idx_e'] + mkAp f [T elem_t, E arr_e', E idx_e'] addPredG p $ evalStaticOp arr_e elem_t handleArraySelect _ -> internalError ("IExpand.doArraySelect: index: " ++ ppReadable idx_e') @@ -4208,7 +4208,7 @@ doArrayUpdate f@(ICon upd_i (ICPrim {iConType = opType})) handleArrayUpdate arr_e' = do --traceM("Update: " ++ show arr_e') nfError "primArrayUpdate" $ - mkAp f [T elem_t, E arr_e', E idx_e', E val_e'] + mkAp f [T elem_t, E arr_e', E idx_e', E val_e'] let res_t = iGetType arr_e -- result type is (PrimArray t) addPredG idx_p $ evalStaticOp arr_e res_t handleArrayUpdate _ -> internalError ("IExpand.doArrayUpdate: index: " ++ ppReadable idx_e') @@ -4676,7 +4676,7 @@ isCanon (ICon _ (ICModPort { })) = True isCanon (ICon _ (ICModParam { })) = True --isCanon (ICon _ (ICForeign { })) = True isCanon (ICon _ (ICClock { })) = True ---isCanon (IAps (ICon _ (ICPrim _ PrimBlock)) _ _) = True -- XXX is this the best way? +--isCanon (IAps (ICon _ (ICPrim _ PrimBlock)) _ _) = True -- XXX is this the best way? isCanon (IAps (ICon _ (ICSel { })) _ [_]) = True isCanon (IAps (ICon _ (ICOut { })) _ [_]) = True -- AV of foreign function application is canon @@ -4878,7 +4878,7 @@ instance HeapToDef HExpr where case c of HNF { hc_pexpr = P _ e } -> collPtrs e (IM.insert p c m) HWHNF { hc_pexpr = P _ e } -> --- traces ("collPtrs: " ++ ppReadable (p, e)) +-- traces ("collPtrs: " ++ ppReadable (p, e)) collPtrs e (IM.insert p c m) e -> internalError ("collPtrs: " ++ ppReadable e) collPtrs e m = internalError ("collPtrs: " ++ ppReadable e) diff --git a/src/comp/IExpandUtils.hs b/src/comp/IExpandUtils.hs index d632876ad..b75361c5c 100644 --- a/src/comp/IExpandUtils.hs +++ b/src/comp/IExpandUtils.hs @@ -387,7 +387,7 @@ heapCellToPExpr (HLoop mn) = internalError ("heapCellToPExpr.HLoop: " ++ ppReada 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}) = +-- 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 @@ -3280,8 +3280,8 @@ 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 PrimZeroExt = True -- should not occur +--realPrimOp PrimTrunc = True -- should not occur realPrimOp PrimExtract = True realPrimOp PrimConcat = True realPrimOp PrimSplit = True diff --git a/src/comp/IInline.hs b/src/comp/IInline.hs index f4a7df00a..2b70393ce 100644 --- a/src/comp/IInline.hs +++ b/src/comp/IInline.hs @@ -29,13 +29,13 @@ iInline inlSimp = iInline1 . iInlineS inlSimp -- . iSortDs iSortDs :: IModule a -> IModule a iSortDs imod@(IModule { imod_local_defs = ds }) = let g = [(i, fdVars e) | IDef i _ e _ <- ds ] - m = M.fromList [(i, d) | d@(IDef i _ _ _) <- ds] - get i = case M.lookup i m of - Nothing -> internalError ("iSortDs: lookup: " ++ ppReadable i) - Just d -> d - ds' = case tsort g of - Left iss -> internalError ("iSortDs: cyclic definition: " ++ ppReadable iss) - Right is -> map get is + m = M.fromList [(i, d) | d@(IDef i _ _ _) <- ds] + get i = case M.lookup i m of + Nothing -> internalError ("iSortDs: lookup: " ++ ppReadable i) + Just d -> d + ds' = case tsort g of + Left iss -> internalError ("iSortDs: cyclic definition: " ++ ppReadable iss) + Right is -> map get is in imod { imod_local_defs = ds' } @@ -51,34 +51,34 @@ iInlineS True imod@(IModule { imod_local_defs = ds, imod_rules = rs, imod_interface = ifc}) = let smap = M.fromList [ (i, iSubst smap dmap e) | IDef i _ e _ <- ds, not (isKeepId i), simple e ] - ds' = iDefsMap (iSubst smap dmap) ds + ds' = iDefsMap (iSubst smap dmap) ds dmap = M.fromList [ (i, e) | IDef i t e _ <- ds' ] - ifc' = map (inline_ifc smap dmap) ifc - rs' = irulesMap (iSubst smap dmap) rs + ifc' = map (inline_ifc smap dmap) ifc + rs' = irulesMap (iSubst smap dmap) rs state_vars' = [ (name, sv { isv_iargs = es' }) | (name, sv@(IStateVar { isv_iargs = es })) <- imod_state_insts imod, let es' = map (iSubst smap dmap) es ] - -- concatenation and bit selection are just wires, inline them + -- concatenation and bit selection are just wires, inline them -- this is to improve the performance of the ITransform pass -- ITransform should re-CSE anything that it does not simplify - simple (IAps (ICon _ (ICPrim _ PrimConcat)) _ [e1, e2]) = simple e1 && simple e2 - simple (IAps (ICon _ (ICPrim _ PrimSelect)) _ [e]) = simple e - simple (IAps (ICon _ (ICPrim _ PrimExtract)) _ [e1,e2,e3]) = simple e1 && simple e2 && simple e3 - -- boolean expressions are just gates, inline them - simple (IAps (ICon _ (ICPrim _ PrimBAnd)) _ [e1, e2]) = simple e1 && simple e2 - simple (IAps (ICon _ (ICPrim _ PrimBOr)) _ [e1, e2]) = simple e1 && simple e2 - simple (IAps (ICon _ (ICPrim _ PrimBNot)) _ [e]) = simple e - -- these are noops, inline them + simple (IAps (ICon _ (ICPrim _ PrimConcat)) _ [e1, e2]) = simple e1 && simple e2 + simple (IAps (ICon _ (ICPrim _ PrimSelect)) _ [e]) = simple e + simple (IAps (ICon _ (ICPrim _ PrimExtract)) _ [e1,e2,e3]) = simple e1 && simple e2 && simple e3 + -- boolean expressions are just gates, inline them + simple (IAps (ICon _ (ICPrim _ PrimBAnd)) _ [e1, e2]) = simple e1 && simple e2 + simple (IAps (ICon _ (ICPrim _ PrimBOr)) _ [e1, e2]) = simple e1 && simple e2 + simple (IAps (ICon _ (ICPrim _ PrimBNot)) _ [e]) = simple e + -- these are noops, inline them simple (ICon _ (ICMethArg { })) = True - simple (ICon _ (ICModPort { })) = True - simple (ICon _ (ICModParam { })) = True - simple (ICon _ (ICStateVar { })) = True - simple (ICon _ (ICValue { })) = True - simple (ICon _ (ICInt { })) = True - simple (ICon _ (ICReal { })) = True - -- - simple _ = False + simple (ICon _ (ICModPort { })) = True + simple (ICon _ (ICModParam { })) = True + simple (ICon _ (ICStateVar { })) = True + simple (ICon _ (ICValue { })) = True + simple (ICon _ (ICInt { })) = True + simple (ICon _ (ICReal { })) = True + -- + simple _ = False in imod { imod_local_defs = ds', imod_rules = rs', @@ -89,8 +89,8 @@ ruleVars (IRules sps rs) = concatMap leafVars rs where leafVars r = iValVars (irule_pred r) ++ iValVars (irule_body r) varVars (_, IStateVar { isv_iargs = es }) = - let vs = concatMap iValVars es - in vs ++ vs -- XXX + let vs = concatMap iValVars es + in vs ++ vs -- XXX -- Inline definitions used once iInline1 :: IModule a -> IModule a @@ -113,30 +113,30 @@ iInlineUseLimit use_limit ++ [ i | (IDef i _ _ _) <- ds, keepEvenUnused i] keepEvenUnused :: Id -> Bool keepEvenUnused i = hasIdProp i IdP_keepEvenUnused - defids = S.fromList [ i | IDef i _ _ _ <- ds ] - dm = M.fromList ([(i, e) | IDef i _ e _ <- ds ] ++ + defids = S.fromList [ i | IDef i _ _ _ <- ds ] + dm = M.fromList ([(i, e) | IDef i _ e _ <- ds ] ++ [ (i, e) | (IEFace i _ (Just (e,_)) _ _ _) <- ifc ]) - get i = case M.lookup i dm of (Just e) -> e; _-> internalError ("iInlineUseLimit " ++ ppString use_limit ++ ": " ++ ppReadable i) - step allIds done [] = allIds - step allIds done (i:pend) = - if i `S.member` done then - step allIds done pend - else - let is = iValVars (get i) - in -- trace ("add " ++ ppReadable (i, is)) $ - step (is ++ allIds) (S.insert i done) (nub is ++ pend) - dis = step is S.empty (remOrdDup (sort is)) - ics = [ (i, length is) | is@(i:_) <- group (sort dis), i `S.member` defids ] - onemap = M.fromList [ (i, iSubst onemap dmap (get i)) + get i = case M.lookup i dm of (Just e) -> e; _-> internalError ("iInlineUseLimit " ++ ppString use_limit ++ ": " ++ ppReadable i) + step allIds done [] = allIds + step allIds done (i:pend) = + if i `S.member` done then + step allIds done pend + else + let is = iValVars (get i) + in -- trace ("add " ++ ppReadable (i, is)) $ + step (is ++ allIds) (S.insert i done) (nub is ++ pend) + dis = step is S.empty (remOrdDup (sort is)) + ics = [ (i, length is) | is@(i:_) <- group (sort dis), i `S.member` defids ] + onemap = M.fromList [ (i, iSubst onemap dmap (get i)) | (i, n_uses) <- ics, not (isKeepId i), n_uses <= use_limit ] - ds' = iDefsMap (iSubst onemap dmap) ds - ifc' = map (inline_ifc onemap dmap) ifc - rs' = irulesMap (iSubst onemap dmap) rs - uses = M.fromList ics - getc' i = case M.lookup i uses of Just c -> c; Nothing -> 0 + ds' = iDefsMap (iSubst onemap dmap) ds + ifc' = map (inline_ifc onemap dmap) ifc + rs' = irulesMap (iSubst onemap dmap) rs + uses = M.fromList ics + getc' i = case M.lookup i uses of Just c -> c; Nothing -> 0 getc i = {- trace ("getc: " ++ ppReadable (i, getc' i)) $ -} getc' i - ds'' = filter (\ (IDef i _ _ _) -> + ds'' = filter (\ (IDef i _ _ _) -> let uses = getc i in (keepEvenUnused i || uses > 0 && isKeepId i) || uses > use_limit) ds' @@ -161,30 +161,30 @@ iValVars e = internalError ("iValVars: " ++ ppReadable e) iSubst :: (M.Map Id (IExpr a)) -> (M.Map Id (IExpr a)) -> IExpr a -> IExpr a iSubst subMap defMap e = sub e where sub (IAps f ts es) = IAps (sub f) ts (map sub es) - sub d@(ICon i val@(ICValue {})) = - case M.lookup i subMap of - Nothing -> + sub d@(ICon i val@(ICValue {})) = + case M.lookup i subMap of + Nothing -> let ev = fromJustOrErr ("IInline.iSubst ICValue def not found: " ++ ppReadable i) (M.lookup i defMap) in ICon i (val { iValDef = ev }) Just e -> e sub u@(ICon i (ICUndet t k (Just v))) = ICon i (ICUndet t k (Just (sub v))) sub c@(ICon {}) = c - sub ee = internalError ("iSubst: " ++ ppReadable ee) + sub ee = internalError ("iSubst: " ++ ppReadable ee) iSubst' :: ((IExpr a) -> Bool) -> (M.Map Id (IExpr a)) -> (M.Map Id (IExpr a)) -> IExpr a -> IExpr a iSubst' tst subMap defMap e = sub e where sub (IAps f ts es) = IAps (sub f) ts (map sub es) - sub d@(ICon i val@(ICValue {})) = - case M.lookup i subMap of - Nothing -> + sub d@(ICon i val@(ICValue {})) = + case M.lookup i subMap of + Nothing -> let ev = fromJustOrErr ("IInline.iSubst' ICValue def not found: " ++ ppReadable i) (M.lookup i defMap) in ICon i (val { iValDef = ev }) Just e -> if (tst e) then e else d sub u@(ICon i (ICUndet t k (Just v))) = ICon i (ICUndet t k (Just (sub v))) sub c@(ICon {}) = c - sub ee = internalError ("iSubst': " ++ ppReadable ee) + sub ee = internalError ("iSubst': " ++ ppReadable ee) -- ############################################################################# -- # Code to inline then eliminate Fmts from ISyntax @@ -211,10 +211,10 @@ iInlineFmtsT tst imod@(IModule { imod_local_defs = ds, imod_rules = rs, imod_interface = ifc}) = let smap = M.fromList [ (i, iSubst' tst smap dmap e) | IDef i t e _ <- ds, (t == itFmt) ] -- inline any def of type Fmt - ds' = iDefsMap (iSubst' tst smap dmap) ds + ds' = iDefsMap (iSubst' tst smap dmap) ds dmap = M.fromList [ (i, e) | IDef i t e _ <- ds' ] - ifc' = map (inline_ifc smap dmap) ifc - rs' = irulesMap (iSubst' tst smap dmap) rs + ifc' = map (inline_ifc smap dmap) ifc + rs' = irulesMap (iSubst' tst smap dmap) rs state_vars' = [ (name, sv { isv_iargs = es' }) | (name, sv@(IStateVar { isv_iargs = es })) <- imod_state_insts imod, @@ -242,8 +242,8 @@ modPromoteSome imod@(IModule { imod_local_defs = ds, ds' = map getFirst pairs change [] = False change ps = (foldr1 (||) (map getSecond ps)) - ifc' = ifc - rs' = rs + ifc' = ifc + rs' = rs state_vars' = imod_state_insts imod in (imod { imod_local_defs = ds', imod_rules = rs', @@ -342,11 +342,11 @@ splitFmtsF imod@(IModule { imod_local_defs = ds, do let ds' = [ IDef id t e p | IDef id t e p <- ds, (t /= itFmt) ] -- remove (now unused defs) updateDef = iDefMapM ssplitFmt ds'' <- mapM updateDef ds' - ifc' <- ssplitFmt_ifc ifc - rs' <- irulesMapM ssplitFmt rs + ifc' <- ssplitFmt_ifc ifc + rs' <- irulesMapM ssplitFmt rs let updateStateVar (name, sv@(IStateVar { isv_iargs = es })) = do es' <- mapM ssplitFmt es return (name, sv { isv_iargs = es' }) - state_vars' <- mapM updateStateVar (imod_state_insts imod) + state_vars' <- mapM updateStateVar (imod_state_insts imod) return imod { imod_local_defs = ds'', imod_rules = rs', imod_interface = ifc', @@ -757,63 +757,63 @@ reduceFmt e = -- if this is the first time (and a foreign function call) eliminate any type -- variables (should this have been done in IExpand?) and recurse down into the arguments reduce rm_args True (IAps (ICon fid f@(ICForeign {iConType = ict})) ts es) - | (rt == itFmt) || (any (== itFmt) at) = + | (rt == itFmt) || (any (== itFmt) at) = do es' <- mapM (reduce rm_args True) es f' <- reduce rm_args True (ICon fid f {iConType = ict'}) e' <- reduce rm_args False (IAps f' [] es') return e' where (_, rt) = itGetArrows (getInnerType ict) - at = map iGetType es - ict' = itInst ict ts + at = map iGetType es + ict' = itInst ict ts -- if this is the first time (and not a foreign function) recurse down into the arguments reduce rm_args True (IAps f ts es) = do es' <- mapM (reduce rm_args True) es f' <- reduce rm_args True f - e' <- reduce rm_args False (IAps f' ts es') + e' <- reduce rm_args False (IAps f' ts es') return e' -- if this is a foreign function call and we're removing args -- (for the value half of of an AV expression), eliminate the args. reduce True False (IAps (ICon fid f@(ICForeign {iConType = ict})) ts es) - | any (== itFmt) at = + | any (== itFmt) at = return (IAps (ICon fid f {iConType = rt}) [] []) where (at, rt) = itGetArrows (getInnerType ict) -- move "if" conditions outside of AVAction_ calls (so the type of the if is action) - reduce False False x@(IAps ica@(ICon m _) ts - [(IAps ici@(ICon _ (ICPrim _ PrimIf)) [rt] [cond, e0, e1])]) - | m == idAVAction_ = + reduce False False x@(IAps ica@(ICon m _) ts + [(IAps ici@(ICon _ (ICPrim _ PrimIf)) [rt] [cond, e0, e1])]) + | m == idAVAction_ = do e0' <- reduce False False (IAps ica ts [e0]) e1' <- reduce False False (IAps ica ts [e1]) return (IAps ici [itAction] [cond, e0', e1']) -- eliminate Fmt ifs when one half is a don't care -- we are treating Fmt like Integer or String rather than Bit#(n) - reduce rm_args False (IAps (ICon _ (ICPrim _ PrimIf)) _ - [cond, e0, (ICon _ (ICUndet it _ _))]) | it == itFmt = return e0 - reduce rm_args False (IAps (ICon _ (ICPrim _ PrimIf)) _ - [cond, (ICon _ (ICUndet it _ _)), e1]) | it == itFmt = return e1 + reduce rm_args False (IAps (ICon _ (ICPrim _ PrimIf)) _ + [cond, e0, (ICon _ (ICUndet it _ _))]) | it == itFmt = return e0 + reduce rm_args False (IAps (ICon _ (ICPrim _ PrimIf)) _ + [cond, (ICon _ (ICUndet it _ _)), e1]) | it == itFmt = return e1 -- move "if" expressions outside of Fmt concat operations - reduce rm_args False x@(IAps cc@(ICon _ (ICPrim _ PrimFmtConcat)) tc - [(IAps ci@(ICon _ (ICPrim _ PrimIf)) ti [cond, e0, e1]), e2]) = + reduce rm_args False x@(IAps cc@(ICon _ (ICPrim _ PrimFmtConcat)) tc + [(IAps ci@(ICon _ (ICPrim _ PrimIf)) ti [cond, e0, e1]), e2]) = do e0' <- reduce rm_args False (IAps cc tc [e0,e2]) e1' <- reduce rm_args False (IAps cc tc [e1,e2]) - e' <- reduce rm_args False (IAps ci ti [cond, e0', e1']) + e' <- reduce rm_args False (IAps ci ti [cond, e0', e1']) return e' - reduce rm_args False x@(IAps cc@(ICon _ (ICPrim _ PrimFmtConcat)) tc - [e2, (IAps ci@(ICon _ (ICPrim _ PrimIf)) ti [cond, e0, e1])]) = + reduce rm_args False x@(IAps cc@(ICon _ (ICPrim _ PrimFmtConcat)) tc + [e2, (IAps ci@(ICon _ (ICPrim _ PrimIf)) ti [cond, e0, e1])]) = do e0' <- reduce rm_args False (IAps cc tc [e2,e0]) e1' <- reduce rm_args False (IAps cc tc [e2,e1]) - e' <- reduce rm_args False (IAps ci ti [cond, e0', e1']) + e' <- reduce rm_args False (IAps ci ti [cond, e0', e1']) return e' -- reduce a concat of two fmt calls to a single fmt call - reduce rm_args False x@(IAps (ICon _ (ICPrim _ PrimFmtConcat)) _ - [(IAps (ICon fid fic@(ICForeign {iConType = t0})) [] es0), - (IAps (ICon _ (ICForeign {iConType = t1})) [] es1)]) = + reduce rm_args False x@(IAps (ICon _ (ICPrim _ PrimFmtConcat)) _ + [(IAps (ICon fid fic@(ICForeign {iConType = t0})) [] es0), + (IAps (ICon _ (ICForeign {iConType = t1})) [] es1)]) = do let (at0, dt) = itGetArrows t0 - (at1, _ ) = itGetArrows t1 + (at1, _ ) = itGetArrows t1 t = foldr1 itFun (at0 ++ at1 ++ [dt]) - return (IAps (ICon fid fic {iConType = t}) [] (es0 ++ es1)) + return (IAps (ICon fid fic {iConType = t}) [] (es0 ++ es1)) -- move "if" expressions (of type Fmt) outside of foreign function calls - reduce rm_args False (IAps (ICon fid f@(ICForeign {iConType = t})) [] - ((IAps ici@(ICon _ (ICPrim _ PrimIf)) [it] [cond, e0, e1]):rest)) | it == itFmt = + reduce rm_args False (IAps (ICon fid f@(ICForeign {iConType = t})) [] + ((IAps ici@(ICon _ (ICPrim _ PrimIf)) [it] [cond, e0, e1]):rest)) | it == itFmt = do n0 <- newFFCallNo n1 <- newFFCallNo n2 <- newFFCallNo @@ -826,25 +826,25 @@ reduceFmt e = e1''' <- reduce rm_args False e1'' return (IAps ici [rt] [cond, e0''', e1''']) where (_ , rt) = itGetArrows t - reduce rm_args False (IAps icf@(ICon fid f@(ICForeign {})) [] (first:rest)) - | any isIfFmt rest = + reduce rm_args False (IAps icf@(ICon fid f@(ICForeign {})) [] (first:rest)) + | any isIfFmt rest = do n <- newFFCallNo e' <- reduce rm_args False (IAps (ICon fid f {fcallNo = (Just n)}) [] rest) e'' <- addArg (IAps icf [] [first]) e' return e'' - reduce _ _ x = return x + reduce _ _ x = return x -- finally turn args of type fmt into "real" $display args remove (IAps (ICon fid (ICForeign {iConType = t})) [] []) - | rt == itAction = joinActions [] + | rt == itAction = joinActions [] where (_ , rt) = itGetArrows t remove (IAps (ICon fid f@(ICForeign {iConType = t})) [] es) - | any (== itFmt) at = expr + | any (== itFmt) at = expr where (at , rt) = itGetArrows t es' = map remove es - es'' = concatMap eliminateFormat es' + es'' = concatMap eliminateFormat es' at' = map iGetType es'' - t' = foldr1 itFun (at' ++ [rt]) + t' = foldr1 itFun (at' ++ [rt]) expr = remove (IAps (ICon fid f {iConType = t'}) [] es'') remove (IAps x ts es) = (IAps x ts (map remove es)) remove x = x diff --git a/src/comp/ILift.hs b/src/comp/ILift.hs index 9bdf89c2b..c41253af2 100644 --- a/src/comp/ILift.hs +++ b/src/comp/ILift.hs @@ -189,8 +189,8 @@ lift1 errh flags ifexp@(IAps (ICon id (ICPrim {primOp = PrimIf, iConType = conty -- ---- -- do the same for actionvalue calls, with an additional avAction_ selector loopT lifted unlifted - (firstT@(IActionCond {action = (IAps sel@(ICon i_sel (ICSel {})) sel_ts - [firstTaction@(IAps expT tsT ((icsvT@(ICon _ (svT@(ICStateVar _ _)))):argsT))]), + (firstT@(IActionCond {action = (IAps sel@(ICon i_sel (ICSel {})) sel_ts + [firstTaction@(IAps expT tsT ((icsvT@(ICon _ (svT@(ICStateVar _ _)))):argsT))]), condition = firstTcond}):restT) f | (i_sel == idAVAction_) = -- loop through the list of false actions -- first parameter is scanned false actions, second is false actions to scan @@ -204,7 +204,7 @@ lift1 errh flags ifexp@(IAps (ICon id (ICPrim {primOp = PrimIf, iConType = conty loopF scanned ((firstF@(IActionCond {action = IAps sel@(ICon i_sel (ICSel {})) sel_ts [firstFaction@(IAps expF _ ((icsvF@(ICon _ (svF@(ICStateVar _ _)))):argsF))], condition = firstFcond})):restF) | (i_sel == idAVAction_) && - (expF == expT) && (svF == svT) && + (expF == expT) && (svF == svT) && ((length argsT) == (length argsF)) = -- just make an ActionCond out of this when it matches -- eventual conversion back into IExpr will force simplification diff --git a/src/comp/ISimplify.hs b/src/comp/ISimplify.hs index 75e68bb59..e62d4f594 100644 --- a/src/comp/ISimplify.hs +++ b/src/comp/ISimplify.hs @@ -24,7 +24,7 @@ import Eval iSimplify :: (Hyper a) => IPackage a -> IPackage a iSimplify (IPackage pi lps ps ds) = - IPackage pi lps ps ({-iSimpDefs-} (iSimpDefs (iSimpDefs ds))) -- XXX + IPackage pi lps ps ({-iSimpDefs-} (iSimpDefs (iSimpDefs ds))) -- XXX iSimpDefs ds = fixUpDefs $ iDefsMap (iSimp True) ds @@ -50,25 +50,25 @@ iSimpAp n (ILam i _ e) [] (a:as) in iSimpAp n e' [] as iSimpAp _ (ICon _ (ICPrim _ prim)) ts es | m /= Nothing = r where m = doPrim prim ts es - Just r = m + Just r = m iSimpAp n f@(ICon _ (ICSel { selNo = k })) ts - es@(def : as) | n && m /= Nothing = {-trace (ppReadable (IAps f ts es, e'))-} e' + es@(def : as) | n && m /= Nothing = {-trace (ppReadable (IAps f ts es, e'))-} e' where m = getTuple def - Just ms = m - e' = iSimpAp n (iSimp n (ms !! fromInteger k)) [] as + Just ms = m + e' = iSimpAp n (iSimp n (ms !! fromInteger k)) [] as iSimpAp n e [] [] = e -- iSimp has already been called iSimpAp n f ts es = IAps f ts es getTuple :: (Hyper a) => IExpr a -> Maybe [IExpr a] getTuple (ICon di (ICDef { iConDef = def@(IAps (ICon _ (ICTuple { })) _ ms) })) | di `notElem` dVars def = - -- trace ("unfold " ++ ppReadable di) $ - Just ms + -- trace ("unfold " ++ ppReadable di) $ + Just ms getTuple (IAps (ICon iii (ICDef { iConDef = body })) ts []) = - -- trace ("getTuple " ++ ppReadable (iii,body)) $ - case iSimpAp False body ts [] of - IAps (ICon _ (ICTuple { })) _ ms -> Just ms - _ -> Nothing + -- trace ("getTuple " ++ ppReadable (iii,body)) $ + case iSimpAp False body ts [] of + IAps (ICon _ (ICTuple { })) _ ms -> Just ms + _ -> Nothing getTuple _ = Nothing @@ -118,8 +118,8 @@ isTriv (ICon _ (ICDef { })) = True isTriv _ = False isHarmless e = - --trace (ppReadable (e, onlySimple e, isPerm [] e)) $ - onlySimple e && isPerm [] e + --trace (ppReadable (e, onlySimple e, isPerm [] e)) $ + onlySimple e && isPerm [] e -- expression is a proper combinator: somehow permutes arguments and constants -- has no free variables and no embedded lambda expressions @@ -191,8 +191,8 @@ fixUp m e = e get :: M.Map Id (IExpr a) -> Id -> IExpr a -> IExpr a get m i d = let value = get2 m i d - in -- trace("Lookup " ++ (ppReadable i) ++ " => " ++ (ppReadable value)) $ - value + in -- trace("Lookup " ++ (ppReadable i) ++ " => " ++ (ppReadable value)) $ + value get2 :: M.Map Id (IExpr a) -> Id -> IExpr a -> IExpr a get2 m i d = diff --git a/src/comp/IStateLoc.hs b/src/comp/IStateLoc.hs index c3b5dfb62..6e81991d7 100644 --- a/src/comp/IStateLoc.hs +++ b/src/comp/IStateLoc.hs @@ -54,22 +54,22 @@ type IStateLoc = [IStateLocPathComponent] -- instantiated inside toplevel data IStateLocPathComponent = IStateLocPathComponent { - isl_inst_id :: Id, -- instance id (from SV instantiation or <- syntax) - isl_ifc_id :: Id, -- interface id (used in source code to access module) - isl_ifc_type :: IType, -- interface type + isl_inst_id :: Id, -- instance id (from SV instantiation or <- syntax) + isl_ifc_id :: Id, -- interface id (used in source code to access module) + isl_ifc_type :: IType, -- interface type -- Some flags - isl_vector :: Bool, -- Is a vector name - isl_inst_ignore :: Bool, -- inslpc may be eliminated from the istateloc. - isl_inst_ignore_name :: Bool, -- inst_id is ignored when making a hierarchical name + isl_vector :: Bool, -- Is a vector name + isl_inst_ignore :: Bool, -- inslpc may be eliminated from the istateloc. + isl_inst_ignore_name :: Bool, -- inst_id is ignored when making a hierarchical name isl_ifc_skip :: Bool, -- skip this level in the rule name scope lookup -- Unique index to uniquify InstTree (loops, common names) - isl_unique_index :: Maybe Integer, -- nothing if not unique, otherwise disambiguating integer + isl_unique_index :: Maybe Integer, -- nothing if not unique, otherwise disambiguating integer -- Name generation - isl_prefix :: NameGenerate, -- currently computed hierarchical prefix - isl_loop_suffix :: NameGenerate -- loop indexes to add once a "real" name is found. + isl_prefix :: NameGenerate, -- currently computed hierarchical prefix + isl_loop_suffix :: NameGenerate -- loop indexes to add once a "real" name is found. } deriving (Eq, Show, Generic.Data, Generic.Typeable) @@ -146,12 +146,12 @@ instance PPrint NameGenerate where -- indexes alway go on the end of the name -- names are joined with underscore joinNames :: NameGenerate -> NameGenerate -> NameGenerate -joinNames NameEmpty x = x -joinNames x NameEmpty = x -joinNames (NameIndex n1) (NameIndex n2) = NameIndex $ n1 ++ n2 -joinNames (Name n) (NameIndex idxs) = Name $ foldl addId_Suffixes n idxs -joinNames n1@(NameIndex {}) n2@(Name {}) = joinNames n2 n1 -joinNames (Name n1) (Name n2) = Name $ mkIdPre head_ n2 +joinNames NameEmpty x = x +joinNames x NameEmpty = x +joinNames (NameIndex n1) (NameIndex n2) = NameIndex $ n1 ++ n2 +joinNames (Name n) (NameIndex idxs) = Name $ foldl addId_Suffixes n idxs +joinNames n1@(NameIndex {}) n2@(Name {}) = joinNames n2 n1 +joinNames (Name n1) (Name n2) = Name $ mkIdPre head_ n2 where head_ = concatFString [getIdBase n1, fsUnderscore] -- The name when none is present @@ -193,7 +193,7 @@ newIStateLocTop slmap inst_id ifc_id ifc_type [] = [comp] isl_vector = False, isl_unique_index = Nothing, isl_prefix = cleanName ignore_name inst_id, - isl_loop_suffix = NameEmpty + isl_loop_suffix = NameEmpty } ignore = ignoreInstId inst_id ignore_name = ignoreInstIdName inst_id diff --git a/src/comp/ISyntax.hs b/src/comp/ISyntax.hs index 60500a76b..2ee60ba61 100644 --- a/src/comp/ISyntax.hs +++ b/src/comp/ISyntax.hs @@ -52,7 +52,7 @@ module ISyntax( getIExprPosition, getITypePosition, getIExprPositionCross, --- getITypePositionCross, +-- getITypePositionCross, getIRuleId, getIRuleStateLoc, sameClockDomain, @@ -542,7 +542,7 @@ cmpE (IRefT _ _ _) (ILam _ _ _) = GT cmpE (IRefT _ _ _) (IAps _ _ _) = GT cmpE (IRefT _ _ _) (IVar _) = GT cmpE (IRefT _ _ _) (ICon _ _) = GT -cmpE (IRefT _ p1 _) (IRefT _ p2 _) = compare p1 p2 -- XXX +cmpE (IRefT _ p1 _) (IRefT _ p2 _) = compare p1 p2 -- XXX cmpE (IRefT _ _ _) (ILAM _ _ _) = LT -- ?????????? @@ -977,20 +977,20 @@ eSubst v x e = hyper e' e' in ILam i' t (sub e') else ILam i t (sub e) --- sub ee@(IVar i) = if i == v then setPos (getIdPosition i) x else ee +-- sub ee@(IVar i) = if i == v then setPos (getIdPosition i) x else ee sub ee@(IVar i) = if i == v then x else ee sub (ILAM i k e) = ILAM i k (sub e) sub (IAps f ts es) = IAps (sub f) ts (map sub es) -- don't sub into ICUndet's optional variable because it doesn't get -- populated until after evaluation sub ee@(ICon _ _) = ee - sub ee@(IRefT _ _ _) = ee -- no free vars inside IRefT + sub ee@(IRefT _ _ _) = ee -- no free vars inside IRefT fvx = fVars' x vs = fvx `S.union` aVars' e {- setPos p (ICon i ci) = ICon (setIdPosition p i) ci setPos p (IVar i) = IVar (setIdPosition p i) --- setPos p (IAps e ts es) = IAps (setPos p e) ts es +-- setPos p (IAps e ts es) = IAps (setPos p e) ts es setPos p e = e -} @@ -1024,7 +1024,7 @@ etSubst v x e = sub e sub (ICon i ii@(ICForeign { })) = ICon i (ii { iConType = tSubst v x (iConType ii) }) sub (ICon i ii@(ICType { })) = ICon i (ii { iType = tSubst v x (iType ii) }) sub ee@(ICon _ _) = ee - sub ee@(IRefT _ _ _) = ee -- no free tyvar inside IRef + sub ee@(IRefT _ _ _) = ee -- no free tyvar inside IRef fvx = fTVars' x vs = fvx `S.union` aVars' e @@ -1090,7 +1090,7 @@ ftVars' (ILAM i _ e) = S.delete i (ftVars' e) ftVars' (IAps f ts es) = (ftVars' f) `S.union` (S.unions (map fTVars' ts)) `S.union` (S.unions (map ftVars' es)) ftVars' (ICon _ (ICUndet {imVal = Just e})) = ftVars' e -ftVars' (ICon _ _) = S.empty -- XXX +ftVars' (ICon _ _) = S.empty -- XXX ftVars' (IRefT _ _ _) = S.empty -- ============================================================ @@ -1154,7 +1154,7 @@ instance PPrint (IEFace a) where pPrint d p (IEFace i vs et rules wp fi) = text "-- args" $+$ foldr ($+$) b (map (ppMV d) vs) - where b = text "-- body" $+$ + where b = text "-- body" $+$ (case et of Just (e,t) -> ppDef d $ IDef i t e [] _ -> empty ) $+$ @@ -1165,7 +1165,7 @@ instance PPrint (IEFace a) where text "-- field info" $+$ pPrint d 0 fi $+$ -- text "-- guard" $+$ --- ppDef d wi wt we $+$ +-- ppDef d wi wt we $+$ text "" instance PPrint IAbstractInput where @@ -1306,7 +1306,7 @@ instance Hyper (IExpr a) where instance Hyper (IConInfo a) where -- hyper (ICDef x1 x2) y = hyper2 x1 x2 y - hyper ic@(ICDef x1 x2) y = y -- XXX a hack to avoid circular defs + hyper ic@(ICDef x1 x2) y = y -- XXX a hack to avoid circular defs hyper (ICPrim x1 x2) y = hyper2 x1 x2 y hyper (ICForeign x1 x2 x3 x4 x5) y = hyper5 x1 x2 x3 x4 x5 y hyper (ICCon x1 x2 x3) y = hyper3 x1 x2 x3 y @@ -1325,7 +1325,7 @@ instance Hyper (IConInfo a) where hyper (ICMethArg x1) y = hyper x1 y hyper (ICModPort x1) y = hyper x1 y hyper (ICModParam x1) y = hyper x1 y --- hyper (ICValue x1 x2 x3) y = hyper3 x1 x2 x3 y -- XXX causes cycles somehow +-- hyper (ICValue x1 x2 x3) y = hyper3 x1 x2 x3 y -- XXX causes cycles somehow hyper (ICValue x1 x2) y = y hyper (ICIFace x1 x2 x3) y = hyper3 x1 x2 x3 y hyper (ICRuleAssert x1 x2) y = hyper2 x1 x2 y @@ -1341,7 +1341,7 @@ instance Hyper (IConInfo a) where hyper (ICPred x1 x2) y = hyper2 x1 x2 y instance Hyper (IStateVar a) where - hyper x y = (x==x) `seq` y -- XXX (does not evaluate IStateVar components) + hyper x y = (x==x) `seq` y -- XXX (does not evaluate IStateVar components) -- ============================================================ -- XRef (and other utilities?) beyond this point diff --git a/src/comp/ISyntaxCheck.hs b/src/comp/ISyntaxCheck.hs index 9eccadf01..1271a7b95 100644 --- a/src/comp/ISyntaxCheck.hs +++ b/src/comp/ISyntaxCheck.hs @@ -107,29 +107,29 @@ assert False s e t x = internalError ("assert failed: " ++ s ++ "\n" ++ ppReadab tCheck :: Flags -> SymTab -> Env -> IExpr a -> IType tCheck flags symt r ec@(ILam i t e) = -- assert (kCheckErr r t == IKStar) "ILam" (ec, kCheckErr r t) $ - itFun t (tCheck flags symt (addT symt i t r) e) + itFun t (tCheck flags symt (addT symt i t r) e) tCheck flags symt r ec@(IAps f0 ts [a]) = - let f = iAps f0 ts [] in - case tCheck flags symt r f of - ITAp (ITAp arr at') rt | arr == itArrow -> - let at = tCheck flags symt r a - in --trace(ppReadable((f,tCheck r f),(a,at))) $ - assert (eqType flags symt r at at') "IAp" + let f = iAps f0 ts [] in + case tCheck flags symt r f of + ITAp (ITAp arr at') rt | arr == itArrow -> + let at = tCheck flags symt r a + in --trace(ppReadable((f,tCheck r f),(a,at))) $ + assert (eqType flags symt r at at') "IAp" (r, ec, a, (at, at') {-, (f,ft),(a,at)-}) (at, at') rt - tt -> internalError ("tCheck IAp: " ++ ppReadable(ec, f, tt)) + tt -> internalError ("tCheck IAp: " ++ ppReadable(ec, f, tt)) tCheck flags symt r (IAps f ts (e:es)) = tCheck flags symt r (IAps (IAps f ts [e]) [] es) tCheck flags symt r (IVar i) = findT i r tCheck flags symt r (ILAM i k e) = ITForAll i k (tCheck flags symt (addK i k r) e) tCheck flags symt r ec@(IAps e [t] []) = - case tCheck flags symt r e of - ITForAll i k rt -> - let kt = kCheckErr r t - rt'= tSubst i t rt - in --trace ("tCheck " ++ ppReadable ((e,et),(t,kt))) $ - assert (k == kt) "IAP" (ec, (i,k,rt), kt) (k, kt) rt' - tt -> internalError ("tCheck IAP: " ++ ppReadable (ec, tt)) + case tCheck flags symt r e of + ITForAll i k rt -> + let kt = kCheckErr r t + rt'= tSubst i t rt + in --trace ("tCheck " ++ ppReadable ((e,et),(t,kt))) $ + assert (k == kt) "IAP" (ec, (i,k,rt), kt) (k, kt) rt' + tt -> internalError ("tCheck IAP: " ++ ppReadable (ec, tt)) tCheck flags symt r (IAps f (t:ts) []) = tCheck flags symt r (IAps (IAps f [t] []) ts []) tCheck flags symt r (ICon c ic) = iConType ic @@ -164,7 +164,7 @@ kCheckErr r t = fj $ kCheck r t tCheckIPackage :: Flags -> SymTab -> IPackage a -> Bool tCheckIPackage flags symt (IPackage pi _ _ ds) = let r = emptyEnv - defOK (IDef i t e _) = + defOK (IDef i t e _) = let t' = (tCheck flags symt r e) in assert (eqType flags symt r t' t) "defOK1" (i,e,(t,t')) (t, t') True @@ -175,8 +175,8 @@ tCheckIModule flags symt (IModule { imod_type_args = iks, imod_local_defs = ds, imod_rules = rs, imod_interface = ifc }) = - let r = foldr (\ (i, k) r -> addK i k r) emptyEnv iks - defOK (IDef i t e _) = + let r = foldr (\ (i, k) r -> addK i k r) emptyEnv iks + defOK (IDef i t e _) = let t' = (tCheck flags symt r e) in assert (eqType flags symt r t' t) "defOK2" (i,e,(t,t')) (t, t') True @@ -189,16 +189,16 @@ tCheckIModule flags symt (IModule { imod_type_args = iks, Just rs -> rulesOK rs _ -> True) - rulesOK (IRules sps rs) = all ruleOK rs - ruleOK (IRule { irule_pred = p , irule_body = a }) = - let tp = tCheck flags symt r p + rulesOK (IRules sps rs) = all ruleOK rs + ruleOK (IRule { irule_pred = p , irule_body = a }) = + let tp = tCheck flags symt r p ta = tCheck flags symt r a in assert (eqType flags symt r tp itBit1) "ruleOK p" (p, tp) (p, tp) True && - assert (eqType flags symt r ta itAction) "ruleOK a" + assert (eqType flags symt r ta itAction) "ruleOK a" (a, ta) (p, tp) True - in all defOK ds && rulesOK rs && all ifcOK ifc + in all defOK ds && rulesOK rs && all ifcOK ifc ------- @@ -231,8 +231,8 @@ addK i k (E tm km eqs ps) = E tm (M.insert i k km) eqs ps findT i (E tm _ _ _) = case M.lookup i tm of - Just t -> t - Nothing -> internalError ("ISyntaxCheck.findT " ++ ppString i ++ "\n" ++ ppReadable (M.toList tm)) + Just t -> t + Nothing -> internalError ("ISyntaxCheck.findT " ++ ppString i ++ "\n" ++ ppReadable (M.toList tm)) findK i (E _ km _ _) = M.lookup i km diff --git a/src/comp/ISyntaxUtil.hs b/src/comp/ISyntaxUtil.hs index d543174b3..d733d72ff 100644 --- a/src/comp/ISyntaxUtil.hs +++ b/src/comp/ISyntaxUtil.hs @@ -120,7 +120,7 @@ isSimpleType t = t == itInteger || isitAction :: IType -> Bool isitAction (ITAp (ITCon i (IKFun IKNum IKStar) - (TIstruct SStruct [_,_] ) ) (ITNum x)) + (TIstruct SStruct [_,_] ) ) (ITNum x)) | (i == idActionValue_) = (x == 0) isitAction (ITAp (ITCon i (IKFun IKStar IKStar) _) t) | (i == idActionValue) = t == itPrimUnit @@ -129,7 +129,7 @@ isitAction x = (x == itAction) -- note this returns false for x == - because ActionValue_ 0 is really an Action isitActionValue_ :: IType -> Bool isitActionValue_ (ITAp (ITCon i (IKFun IKNum IKStar) - (TIstruct SStruct [_,_] ) ) (ITNum x)) + (TIstruct SStruct [_,_] ) ) (ITNum x)) | x > 0 = (i == idActionValue_) isitActionValue_ _ = False @@ -150,7 +150,7 @@ getInout_Size t = getAV_Size :: IType -> Integer getAV_Size (ITAp (ITCon i (IKFun IKNum IKStar) - (TIstruct SStruct [_,_] ) ) (ITNum x)) | + (TIstruct SStruct [_,_] ) ) (ITNum x)) | (i == idActionValue_) = x getAV_Size t = internalError ("getAV_Size: type is not AV_: " ++ ppReadable t) @@ -416,11 +416,11 @@ ieIf ty c t e = IAps icIf [ty] [c, t, e] ieIfx :: IType -> IExpr a -> IExpr a -> IExpr a -> IExpr a ieIfx ty c t e = if t == e then - t + t else if ty == itBit1 && isTrue t && isFalse e then - c + c else - ieIf ty c t e + ieIf ty c t e ieArraySel :: IType -> Integer -> IExpr a -> [IExpr a] -> IExpr a -- XXX check if the index is constant and return that element? @@ -451,9 +451,9 @@ isFalse _ = False iePrimWhen :: IType -> IExpr a -> IExpr a -> IExpr a iePrimWhen t p e = if isTrue p then - e + e else - IAps icPrimWhen [t] [p, e] + IAps icPrimWhen [t] [p, e] pTrue :: Pred a pTrue = PConj S.empty @@ -496,7 +496,7 @@ icNoActions = ICon idPrimNoActions (ICPrim itAction PrimNoActions) icIf :: IExpr a icIf = ICon idPrimIf (ICPrim (ITForAll i IKStar (itBit1 `itFun` ty `itFun` ty `itFun` ty)) PrimIf) where i = head tmpVarIds - ty = ITVar i + ty = ITVar i icPrimArrayDynSelect :: IExpr a icPrimArrayDynSelect = ICon idPrimArrayDynSelect (ICPrim t PrimArrayDynSelect) @@ -540,65 +540,65 @@ icPrimChr = ICon idPrimChr (ICPrim t PrimChr) icSelect :: Position -> IExpr a icSelect pos = ICon (idPrimSelectAt pos) (ICPrim t PrimSelect) where t = ITForAll k IKNum (ITForAll m IKNum (ITForAll n IKNum rt)) - rt = aitBit (ITVar n) `itFun` aitBit (ITVar k) - k:m:n:_ = tmpVarIds + rt = aitBit (ITVar n) `itFun` aitBit (ITVar k) + k:m:n:_ = tmpVarIds icPrimConcat :: IExpr a icPrimConcat = ICon idPrimConcat (ICPrim t PrimConcat) where t = ITForAll k IKNum (ITForAll m IKNum (ITForAll n IKNum rt)) - rt = aitBit (ITVar k) `itFun` aitBit (ITVar m) `itFun` aitBit (ITVar n) - k:m:n:_ = tmpVarIds + rt = aitBit (ITVar k) `itFun` aitBit (ITVar m) `itFun` aitBit (ITVar n) + k:m:n:_ = tmpVarIds icPrimMul :: IExpr a icPrimMul = ICon idPrimMul (ICPrim t PrimMul) where t = ITForAll k IKNum (ITForAll m IKNum (ITForAll n IKNum rt)) - rt = aitBit (ITVar k) `itFun` aitBit (ITVar m) `itFun` aitBit (ITVar n) - k:m:n:_ = tmpVarIds + rt = aitBit (ITVar k) `itFun` aitBit (ITVar m) `itFun` aitBit (ITVar n) + k:m:n:_ = tmpVarIds icPrimQuot :: IExpr a icPrimQuot = ICon idPrimQuot (ICPrim t PrimQuot) where t = ITForAll k IKNum (ITForAll n IKNum rt) - rt = aitBit (ITVar k) `itFun` aitBit (ITVar n) `itFun` aitBit (ITVar k) - k:n:_ = tmpVarIds + rt = aitBit (ITVar k) `itFun` aitBit (ITVar n) `itFun` aitBit (ITVar k) + k:n:_ = tmpVarIds icPrimRem :: IExpr a icPrimRem = ICon idPrimRem (ICPrim t PrimRem) where t = ITForAll k IKNum (ITForAll n IKNum rt) - rt = aitBit (ITVar k) `itFun` aitBit (ITVar n) `itFun` aitBit (ITVar n) - k:n:_ = tmpVarIds + rt = aitBit (ITVar k) `itFun` aitBit (ITVar n) `itFun` aitBit (ITVar n) + k:n:_ = tmpVarIds icPrimZeroExt :: IExpr a icPrimZeroExt = ICon idPrimZeroExt (ICPrim t PrimZeroExt) where t = ITForAll m IKNum (ITForAll k IKNum (ITForAll n IKNum rt)) - rt = aitBit (ITVar k) `itFun` aitBit (ITVar n) - k:m:n:_ = tmpVarIds + rt = aitBit (ITVar k) `itFun` aitBit (ITVar n) + k:m:n:_ = tmpVarIds icPrimSignExt :: IExpr a icPrimSignExt = ICon idPrimSignExt (ICPrim t PrimSignExt) where t = ITForAll m IKNum (ITForAll k IKNum (ITForAll n IKNum rt)) - rt = aitBit (ITVar k) `itFun` aitBit (ITVar n) - k:m:n:_ = tmpVarIds + rt = aitBit (ITVar k) `itFun` aitBit (ITVar n) + k:m:n:_ = tmpVarIds icPrimTrunc :: IExpr a icPrimTrunc = ICon idPrimTrunc (ICPrim t PrimTrunc) where t = ITForAll k IKNum (ITForAll m IKNum (ITForAll n IKNum rt)) - rt = aitBit (ITVar n) `itFun` aitBit (ITVar m) - k:m:n:_ = tmpVarIds + rt = aitBit (ITVar n) `itFun` aitBit (ITVar m) + k:m:n:_ = tmpVarIds icPrimRel :: Id -> PrimOp -> IExpr a icPrimRel id p = ICon id (ICPrim (ITForAll i IKNum (ty `itFun` ty `itFun` itBit1)) p) where i = head tmpVarIds - ty = itBit `ITAp` ITVar i + ty = itBit `ITAp` ITVar i icPrimWhen :: IExpr a icPrimWhen = ICon idPrimWhen (ICPrim t PrimWhen) where t = ITForAll i IKStar (itBit1 `itFun` ITVar i `itFun` ITVar i) - i = head tmpVarIds + i = head tmpVarIds icPrimWhenPred :: IExpr a icPrimWhenPred = ICon idPrimWhen (ICPrim t PrimWhenPred) where t = ITForAll i IKStar (itPred `itFun` ITVar i `itFun` ITVar i) - i = head tmpVarIds + i = head tmpVarIds itUninitialized :: IType itUninitialized = ITForAll i IKStar (itPosition `itFun` itString `itFun` ITVar i) @@ -616,14 +616,14 @@ icPrimSetSelPosition = ICon idPrimSetSelPosition (ICPrim t PrimSetSelPosition) icPrimSL :: IExpr a icPrimSL = ICon idPrimSL (ICPrim t PrimSL) where t = ITForAll i IKNum (ty `itFun` itNat `itFun` ty) - ty = itBit `ITAp` ITVar i - i = head tmpVarIds + ty = itBit `ITAp` ITVar i + i = head tmpVarIds icPrimSRL :: IExpr a icPrimSRL = ICon idPrimSRL (ICPrim t PrimSRL) where t = ITForAll i IKNum (ty `itFun` itNat `itFun` ty) - ty = itBit `ITAp` ITVar i - i = head tmpVarIds + ty = itBit `ITAp` ITVar i + i = head tmpVarIds icPrimEQ, icPrimULE, icPrimULT, icPrimSLE, icPrimSLT :: IExpr a icPrimEQ = icPrimRel idPrimEQ PrimEQ @@ -636,8 +636,8 @@ icPrimSLT = icPrimRel idPrimSLT PrimSLT icPrimBinVecOp :: Id -> PrimOp -> IExpr a icPrimBinVecOp id p = ICon id (ICPrim t p) where t = ITForAll i IKNum (ty `itFun` ty `itFun` ty) - i = head tmpVarIds - ty = itBit `ITAp` ITVar i + i = head tmpVarIds + ty = itBit `ITAp` ITVar i icPrimAdd, icPrimSub :: IExpr a icPrimAdd = icPrimBinVecOp idPrimAdd PrimAdd @@ -646,8 +646,8 @@ icPrimSub = icPrimBinVecOp idPrimSub PrimSub icPrimInv :: IExpr a icPrimInv = ICon idPrimSL (ICPrim t PrimInv) where t = ITForAll i IKNum (ty `itFun` ty) - i = head tmpVarIds - ty = itBit `ITAp` ITVar i + i = head tmpVarIds + ty = itBit `ITAp` ITVar i icPrimIntegerToBit :: IExpr a icPrimIntegerToBit = ICon (idFromInteger noPosition) (ICPrim t PrimIntegerToBit) @@ -668,17 +668,17 @@ icSelClockOsc :: Id -> IClock a -> IExpr a icSelClockOsc i c = IAps (ICon idClockOsc (ICSel { iConType = itClock `itFun` itBit1, selNo = 0, - numSel = 2 })) + numSel = 2 })) [] - [icClock i c] + [icClock i c] icSelClockGate :: Id -> IClock a -> IExpr a icSelClockGate i c = IAps (ICon idClockGate (ICSel { iConType = itClock `itFun` itBit1, selNo = 1, - numSel = 2 })) + numSel = 2 })) [] - [icClock i c] + [icClock i c] icNoClock, icNoReset, icNoPosition :: IExpr a icNoClock = icClock idNoClock noClock @@ -710,11 +710,11 @@ getNamedClock :: Id -> IStateVar a -> IClock a getNamedClock i v = -- XXX unQualId VModInfo case (lookup (unQualId i) (getClockMap v)) of - Just c -> c - Nothing -> internalError - ("ISyntaxUtil.getNamedClockFromMap: unknown clock " ++ - (ppReadable i) ++ (ppReadable v) ++ - (ppReadable (getClockMap v))) + Just c -> c + Nothing -> internalError + ("ISyntaxUtil.getNamedClockFromMap: unknown clock " ++ + (ppReadable i) ++ (ppReadable v) ++ + (ppReadable (getClockMap v))) getMethodClock :: Id -> IStateVar a -> IClock a getMethodClock i v@(IStateVar { isv_vmi = vmi }) = @@ -723,13 +723,13 @@ getMethodClock i v@(IStateVar { isv_vmi = vmi }) = Just n -> getNamedClock n v -- XXX unQualId VModInfo where mclock_names = - [ c | Method { vf_name = n, vf_clock = c } <- vFields vmi, - n == unQualId i] + [ c | Method { vf_name = n, vf_clock = c } <- vFields vmi, + n == unQualId i] mclock_name = - case mclock_names of - [n] -> n - _ -> internalError ("ISyntaxUtil.getMethodClock: " ++ - (ppReadable vmi) ++ (ppReadable i)) + case mclock_names of + [n] -> n + _ -> internalError ("ISyntaxUtil.getMethodClock: " ++ + (ppReadable vmi) ++ (ppReadable i)) getIfcInoutClock :: Id -> IStateVar a -> IClock a getIfcInoutClock i v@(IStateVar { isv_vmi = vmi }) = @@ -738,13 +738,13 @@ getIfcInoutClock i v@(IStateVar { isv_vmi = vmi }) = Just n -> getNamedClock n v -- XXX unQualId VModInfo where mclock_names = - [ c | Inout { vf_name = n, vf_clock = c } <- vFields vmi, - n == unQualId i] + [ c | Inout { vf_name = n, vf_clock = c } <- vFields vmi, + n == unQualId i] mclock_name = - case mclock_names of - [n] -> n - _ -> internalError ("ISyntaxUtil.getIfcInoutClock: " ++ - (ppReadable vmi) ++ (ppReadable i)) + case mclock_names of + [n] -> n + _ -> internalError ("ISyntaxUtil.getIfcInoutClock: " ++ + (ppReadable vmi) ++ (ppReadable i)) -- reset extraction utilities (like the clock extraction utilities) -- they also need noReset @@ -752,11 +752,11 @@ getNamedReset :: Id -> IStateVar a -> IReset a getNamedReset i v = -- XXX unQualId VModInfo case (lookup (unQualId i) (getResetMap v)) of - Just r -> r - Nothing -> internalError - ("ISyntaxUtil.getNamedResetFromMap: unknown reset " ++ - (ppReadable i) ++ (ppReadable v) ++ - (ppReadable (getResetMap v))) + Just r -> r + Nothing -> internalError + ("ISyntaxUtil.getNamedResetFromMap: unknown reset " ++ + (ppReadable i) ++ (ppReadable v) ++ + (ppReadable (getResetMap v))) getMethodReset :: Id -> IStateVar a -> IReset a getMethodReset i v@(IStateVar { isv_vmi = vmi }) = @@ -765,13 +765,13 @@ getMethodReset i v@(IStateVar { isv_vmi = vmi }) = Just n -> getNamedReset n v -- XXX unQualId VModInfo where mreset_names = - [ r | Method { vf_name = n, vf_reset = r } <- vFields vmi, - n == unQualId i] + [ r | Method { vf_name = n, vf_reset = r } <- vFields vmi, + n == unQualId i] mreset_name = - case mreset_names of - [n] -> n - _ -> internalError ("ISyntaxUtil.getMethodReset: " ++ - (ppReadable vmi) ++ (ppReadable i)) + case mreset_names of + [n] -> n + _ -> internalError ("ISyntaxUtil.getMethodReset: " ++ + (ppReadable vmi) ++ (ppReadable i)) getIfcInoutReset :: Id -> IStateVar a -> IReset a getIfcInoutReset i v@(IStateVar { isv_vmi = vmi }) = @@ -780,13 +780,13 @@ getIfcInoutReset i v@(IStateVar { isv_vmi = vmi }) = Just n -> getNamedReset n v -- XXX unQualId VModInfo where mreset_names = - [ r | Inout { vf_name = n, vf_reset = r } <- vFields vmi, - n == unQualId i] + [ r | Inout { vf_name = n, vf_reset = r } <- vFields vmi, + n == unQualId i] mreset_name = - case mreset_names of - [n] -> n - _ -> internalError ("ISyntaxUtil.getIfcInoutReset: " ++ - (ppReadable vmi) ++ (ppReadable i)) + case mreset_names of + [n] -> n + _ -> internalError ("ISyntaxUtil.getIfcInoutReset: " ++ + (ppReadable vmi) ++ (ppReadable i)) getClockGate :: IClock a -> IExpr a getClockGate c = @@ -795,8 +795,8 @@ getClockGate c = i == idClock && i_osc == idClockOsc && i_gate == idClockGate -> gate IAps (ICon i (ICSel { iConType = itClock })) _ [(ICon vid (ICStateVar {iVar = sv}))] -> case (lookupOutputClockWires i (getVModInfo sv)) of - (_, Nothing) -> iTrue - (_, Just _) -> icSelClockGate i c + (_, Nothing) -> iTrue + (_, Just _) -> icSelClockGate i c _ -> internalError "ISyntaxUtil.getClockGate" -- Print a user-readable string for a clock expression @@ -811,32 +811,32 @@ getClockOscString clk = let handleExpr :: IExpr a -> String handleExpr (IAps (ICon m (ICSel { })) _ - [(ICon i (ICClock { iClock = c }))]) = handleClk c + [(ICon i (ICClock { iClock = c }))]) = handleClk c handleExpr (ICon v (ICModPort { })) = -- This does not display the user-level name for a port. -- We currently expect the caller to handle that. getIdString v handleExpr (IAps (ICon m (ICSel { })) _ - (ICon vid (ICStateVar { }) : es )) = + (ICon vid (ICStateVar { }) : es )) = getIdString vid ++ "." ++ getIdString m handleExpr e = internalError ("getClockOscString: unexpected expr: " ++ - ppReadable e) + ppReadable e) handleClk :: IClock a -> String handleClk c = - case (getClockWires c) of - IAps (ICon i (ICTuple {fieldIds = [i_osc, i_gate]})) [] - [osc, gate] | i == idClock && + case (getClockWires c) of + IAps (ICon i (ICTuple {fieldIds = [i_osc, i_gate]})) [] + [osc, gate] | i == idClock && i_osc == idClockOsc && i_gate == idClockGate - -> handleExpr osc + -> handleExpr osc IAps (ICon i (ICSel { iConType = itClock })) _ - [(ICon vid (ICStateVar {iVar = sv}))] - -> -- display the BSV name, not the Verilog port - getIdString vid ++ "." ++ getIdString i - --let port = fst $ - -- lookupOutputClockPorts i (getVModInfo sv) - --in getIdString (mkOutputWireId vid port) - e -> internalError ("getClockOscString: " ++ ppReadable e) + [(ICon vid (ICStateVar {iVar = sv}))] + -> -- display the BSV name, not the Verilog port + getIdString vid ++ "." ++ getIdString i + --let port = fst $ + -- lookupOutputClockPorts i (getVModInfo sv) + --in getIdString (mkOutputWireId vid port) + e -> internalError ("getClockOscString: " ++ ppReadable e) in handleClk clk @@ -850,10 +850,10 @@ getResetString rst = -- We currently expect the caller to handle that. getIdString v handleExpr (IAps (ICon m (ICSel { })) _ - [ICon vid (ICStateVar { })]) = + [ICon vid (ICStateVar { })]) = getIdString vid ++ "." ++ getIdString m handleExpr e = internalError ("getResetString: unexpected expr: " ++ - ppReadable e) + ppReadable e) handleRst :: IReset a -> String handleRst r = handleExpr (getResetWire r) @@ -938,64 +938,64 @@ irulesMapM f (IRules sps rs) = do iGetType :: IExpr a -> IType iGetType e0 = let iGetTypePrim _ PrimIf [t] [_,_,_] = t - iGetTypePrim _ PrimConcat [_,_,ITNum n] [_,_] = itBitN n + iGetTypePrim _ PrimConcat [_,_,ITNum n] [_,_] = itBitN n iGetTypePrim _ PrimMul [_,_,ITNum n] [_,_] = itBitN n iGetTypePrim _ PrimQuot [_,_,ITNum n] [_,_] = itBitN n iGetTypePrim _ PrimRem [_,_,ITNum n] [_,_] = itBitN n - iGetTypePrim _ PrimSelect [ITNum n,_,_] [_] = itBitN n + iGetTypePrim _ PrimSelect [ITNum n,_,_] [_] = itBitN n iGetTypePrim _ PrimJoinActions [] [_,_] = itAction - iGetTypePrim _ p _ [_,_] | isBoolRes p = itBit1 - where isBoolRes PrimEQ = True - isBoolRes PrimULE = True - isBoolRes PrimULT = True - isBoolRes PrimSLE = True - isBoolRes PrimSLT = True - isBoolRes PrimBAnd = True - isBoolRes PrimBOr = True - isBoolRes PrimBNot = True - isBoolRes _ = False - iGetTypePrim _ p [ITNum n] [_,_] | isNRes p = itBitN n - where isNRes PrimAdd = True - isNRes PrimSub = True - isNRes PrimAnd = True - isNRes PrimOr = True - isNRes PrimXor = True - isNRes PrimSL = True - isNRes PrimSRL = True - isNRes PrimSRA = True - isNRes _ = False - iGetTypePrim e _ _ _ = tCheck emptyEnv e - - tCheck r (ILam i t e) = - itFun t (tCheck (addT i t r) e) - tCheck r (IAps f [] []) = tCheck r f - tCheck r (IAps e [t] []) = - case tCheck r e of - ITForAll i _ rt -> tSubst i t rt - tt -> internalError ("iGetType.tCheck: " ++ ppString (e0, e, tt, t)) - tCheck r (IAps f (t:ts) []) = tCheck r (IAps (IAps f [t] []) ts []) - tCheck r (IAps f ts es) = dropArrows (length es) (tCheck r (IAps f ts [])) - tCheck r (IVar i) = findT i r - tCheck r (ILAM i k e) = ITForAll i k (tCheck r e) - tCheck r (ICon c ic) = iConType ic - tCheck r (IRefT t _ _) = t --- tCheck _ e = internalError ("no match in ISyntaxUtil.tCheck: " ++ ppReadable e) - - emptyEnv = M.empty - - addT i t tm = M.insert i t tm - - findT i tm = - case M.lookup i tm of - Just t -> t - Nothing -> internalError ("ISyntaxUtil.findT " ++ ppString i ++ "\n" ++ ppReadable (M.toList tm)) + iGetTypePrim _ p _ [_,_] | isBoolRes p = itBit1 + where isBoolRes PrimEQ = True + isBoolRes PrimULE = True + isBoolRes PrimULT = True + isBoolRes PrimSLE = True + isBoolRes PrimSLT = True + isBoolRes PrimBAnd = True + isBoolRes PrimBOr = True + isBoolRes PrimBNot = True + isBoolRes _ = False + iGetTypePrim _ p [ITNum n] [_,_] | isNRes p = itBitN n + where isNRes PrimAdd = True + isNRes PrimSub = True + isNRes PrimAnd = True + isNRes PrimOr = True + isNRes PrimXor = True + isNRes PrimSL = True + isNRes PrimSRL = True + isNRes PrimSRA = True + isNRes _ = False + iGetTypePrim e _ _ _ = tCheck emptyEnv e + + tCheck r (ILam i t e) = + itFun t (tCheck (addT i t r) e) + tCheck r (IAps f [] []) = tCheck r f + tCheck r (IAps e [t] []) = + case tCheck r e of + ITForAll i _ rt -> tSubst i t rt + tt -> internalError ("iGetType.tCheck: " ++ ppString (e0, e, tt, t)) + tCheck r (IAps f (t:ts) []) = tCheck r (IAps (IAps f [t] []) ts []) + tCheck r (IAps f ts es) = dropArrows (length es) (tCheck r (IAps f ts [])) + tCheck r (IVar i) = findT i r + tCheck r (ILAM i k e) = ITForAll i k (tCheck r e) + tCheck r (ICon c ic) = iConType ic + tCheck r (IRefT t _ _) = t +-- tCheck _ e = internalError ("no match in ISyntaxUtil.tCheck: " ++ ppReadable e) + + emptyEnv = M.empty + + addT i t tm = M.insert i t tm + + findT i tm = + case M.lookup i tm of + Just t -> t + Nothing -> internalError ("ISyntaxUtil.findT " ++ ppString i ++ "\n" ++ ppReadable (M.toList tm)) in case e0 of - -- First some fast special cases: - (ICon c ic) -> iConType ic - e@(IAps (ICon _ (ICPrim _ p)) ts es) -> iGetTypePrim e p ts es - -- General - e -> tCheck emptyEnv e + -- First some fast special cases: + (ICon c ic) -> iConType ic + e@(IAps (ICon _ (ICPrim _ p)) ts es) -> iGetTypePrim e p ts es + -- General + e -> tCheck emptyEnv e -- input must be an interface type iGetIfcName :: IType -> Id diff --git a/src/comp/ISyntaxXRef.hs b/src/comp/ISyntaxXRef.hs index d13aaef3a..cb0c6d620 100644 --- a/src/comp/ISyntaxXRef.hs +++ b/src/comp/ISyntaxXRef.hs @@ -58,13 +58,13 @@ mapIExprPosition True (expr_0, expr_1) = in if (positionModel == noPosition) || (not (isUsefulPosition positionModel)) then expr_1 else let positionCurrent = (getIExprPositionCross expr_1) - in if (positionModel == positionCurrent) - then expr_1 - else if (isEquivIExprIncluded expr_1 expr_0) - then let pos = (getIExprPositionCross (head (extractEquivIExpr expr_1 expr_0))) - expr = (updateIExprPosition pos expr_1) - in expr - else (updateIExprPosition positionModel expr_1) + in if (positionModel == positionCurrent) + then expr_1 + else if (isEquivIExprIncluded expr_1 expr_0) + then let pos = (getIExprPositionCross (head (extractEquivIExpr expr_1 expr_0))) + expr = (updateIExprPosition pos expr_1) + in expr + else (updateIExprPosition positionModel expr_1) mapIExprPosition2 :: Bool -> (IExpr a, IExpr a) -> IExpr a mapIExprPosition2 False (expr_0, expr_1) = expr_1 @@ -73,13 +73,13 @@ mapIExprPosition2 True (expr_0, expr_1) = in if (positionModel == noPosition) || (not (isUsefulPosition positionModel)) then expr_1 else let positionCurrent = (getIExprPositionCross expr_1) - in if (positionModel == positionCurrent) - then expr_1 - else if (isEquivIExprIncluded expr_1 expr_0) - then let pos = (getIExprPositionCross (head (extractEquivIExpr expr_1 expr_0))) - expr = (updateIExprPosition2 pos expr_1) - in expr - else (updateIExprPosition2 positionModel expr_1) + in if (positionModel == positionCurrent) + then expr_1 + else if (isEquivIExprIncluded expr_1 expr_0) + then let pos = (getIExprPositionCross (head (extractEquivIExpr expr_1 expr_0))) + expr = (updateIExprPosition2 pos expr_1) + in expr + else (updateIExprPosition2 positionModel expr_1) mapIExprPositionConservative :: Bool -> (IExpr a,IExpr a) -> IExpr a mapIExprPositionConservative False (expr_0, expr_1) = expr_1 @@ -88,13 +88,13 @@ mapIExprPositionConservative True (expr_0, expr_1) = in if (positionModel == noPosition) || (not (isUsefulPosition positionModel)) then expr_1 else let positionCurrent = (getIExprPositionCross expr_1) - in if (positionModel == positionCurrent) || (isUsefulPosition positionCurrent) - then expr_1 - else if (isEquivIExprIncluded expr_1 expr_0) - then let pos = (getIExprPositionCross (head (extractEquivIExpr expr_1 expr_0))) - expr = (updateIExprPosition pos expr_1) - in expr - else (updateIExprPosition positionModel expr_1) + in if (positionModel == positionCurrent) || (isUsefulPosition positionCurrent) + then expr_1 + else if (isEquivIExprIncluded expr_1 expr_0) + then let pos = (getIExprPositionCross (head (extractEquivIExpr expr_1 expr_0))) + expr = (updateIExprPosition pos expr_1) + in expr + else (updateIExprPosition positionModel expr_1) -- ############################################################################# -- # @@ -120,28 +120,28 @@ isEquivIExprIncluded sub_expr expr@(IRefT t p r) = extractEquivIExpr :: IExpr a -> IExpr a -> [IExpr a] extractEquivIExpr sub_expr expr@(ILam i t e) = if (equivIExprs sub_expr expr) - then [expr] - else (extractEquivIExpr sub_expr e) + then [expr] + else (extractEquivIExpr sub_expr e) extractEquivIExpr sub_expr expr@(IAps e ts es) = if (equivIExprs sub_expr expr) - then [expr] - else (concatMap (extractEquivIExpr sub_expr) es) + then [expr] + else (concatMap (extractEquivIExpr sub_expr) es) extractEquivIExpr sub_expr expr@(IVar _) = if (equivIExprs sub_expr expr) - then [expr] - else [] + then [expr] + else [] extractEquivIExpr sub_expr expr@(ILAM i kind e) = if (equivIExprs sub_expr expr) - then [expr] - else (extractEquivIExpr sub_expr e) + then [expr] + else (extractEquivIExpr sub_expr e) extractEquivIExpr sub_expr expr@(ICon _ _) = if (equivIExprs sub_expr expr) - then [expr] - else [] + then [expr] + else [] extractEquivIExpr sub_expr expr@(IRefT t p r) = if (equivIExprs sub_expr expr) - then [expr] - else [] + then [expr] + else [] -- ############################################################################# -- # diff --git a/src/comp/ITransform.hs b/src/comp/ITransform.hs index 40caeb296..62e1a9450 100644 --- a/src/comp/ITransform.hs +++ b/src/comp/ITransform.hs @@ -82,8 +82,8 @@ iTransExprLoop e = iTransform :: ErrorHandle -> Flags -> String -> IModule a -> IModule a iTransform errh flags prefix = - iInline False . -- XXX only for debug - iTransform1 1 errh flags prefix . iSortDs + iInline False . -- XXX only for debug + iTransform1 1 errh flags prefix . iSortDs iTransform1 :: Integer -> ErrorHandle -> Flags -> String -> IModule a -> IModule a @@ -96,17 +96,17 @@ iTransform1 no errh flags prefix imod@(IModule { imod_state_insts = itvs, imod_rules = rs', imod_interface = ifc' } where ((itvs', rs', ifc'), ds') = runT errh flags no prefix trMod - trMod = do - mapM_ iTrDef ds + trMod = do + mapM_ iTrDef ds iTransFixupDefNames flags - rs' <- iTrRules rs + rs' <- iTrRules rs ifc' <- mapM iTrIfc ifc -- clock and reset expressions (in nc and nr) are just wires - do not simplify - itvs' <- mapM (\ (i, sv@(IStateVar { isv_iargs = es })) -> + itvs' <- mapM (\ (i, sv@(IStateVar { isv_iargs = es })) -> do es' <- mapM (iTrExprL emptyCtx []) es return (i, sv { isv_iargs = es' })) itvs - return (itvs', rs', ifc') + return (itvs', rs', ifc') iTrIfc :: IEFace a -> T (IEFace a) a iTrIfc (IEFace i its met mrs wp fi) @@ -116,42 +116,42 @@ iTrIfc (IEFace i its met mrs wp fi) iTrDef :: IDef a -> T () a iTrDef def@(IDef i t e p) = do - -- traceM ("iTrDef start " ++ ppReadable def) - e' <- iTrExprL emptyCtx [] e - -- traceM ("iTrDef process " ++ ppReadable (i, e', expVal e')) - addDefT i t e' p + -- traceM ("iTrDef start " ++ ppReadable def) + e' <- iTrExprL emptyCtx [] e + -- traceM ("iTrDef process " ++ ppReadable (i, e', expVal e')) + addDefT i t e' p iTrRule :: IRule a -> T (IRule a) a iTrRule r = do - doBO <- getDoBO - let ctx = emptyCtx - -- traceM("iTrRule start " ++ ppReadable (irule_name r)) - c' <- iTrExprL ctx [] (irule_pred r) - let c'' = optBoolExpr doBO c' - -- traceM("iTrRule cond " ++ ppReadable (irule_name r, c'')) - e' <- iTrExprL (addT c'' ctx) [] (irule_body r) - -- traceM("iTrRule body " ++ ppReadable (irule_name r, e')) - return $ r { irule_pred = c'', irule_body = e' } + doBO <- getDoBO + let ctx = emptyCtx + -- traceM("iTrRule start " ++ ppReadable (irule_name r)) + c' <- iTrExprL ctx [] (irule_pred r) + let c'' = optBoolExpr doBO c' + -- traceM("iTrRule cond " ++ ppReadable (irule_name r, c'')) + e' <- iTrExprL (addT c'' ctx) [] (irule_body r) + -- traceM("iTrRule body " ++ ppReadable (irule_name r, e')) + return $ r { irule_pred = c'', irule_body = e' } iTrRules :: IRules a -> T (IRules a) a iTrRules (IRules sps rs) = do - rs' <- mapM iTrRule rs - return (IRules sps rs') + rs' <- mapM iTrRule rs + return (IRules sps rs') iTrExprL :: Ctx a -> [(IExpr a, Integer)] -> IExpr a -> T (IExpr a) a iTrExprL ctx idxs e = expandHRef e >>= iTrExpr ctx idxs iTrExpr :: Ctx a -> [(IExpr a, Integer)] -> IExpr a -> T (IExpr a) a iTrExpr ctx idxs (IAps pif@(ICon _ (ICPrim _ PrimIf)) [t] [cnd, thn, els]) = do - doBO <- getDoBO - cnd1 <- iTrExpr ctx [] (expValShallow cnd) - let cnd' = optBoolExpr doBO cnd1 - thn' <- iTrExpr (addT cnd' ctx) idxs thn - els' <- iTrExpr (addF cnd' ctx) idxs els --- traceM ("IF " ++ ppString (IAps pif [t] [cnd', thn', els']) ++ "\n " ++ ppReadable (cnd, cnd0, cnd1)) - iTrExpr' ctx idxs pif [t] [cnd', thn', els'] + doBO <- getDoBO + cnd1 <- iTrExpr ctx [] (expValShallow cnd) + let cnd' = optBoolExpr doBO cnd1 + thn' <- iTrExpr (addT cnd' ctx) idxs thn + els' <- iTrExpr (addF cnd' ctx) idxs els +-- traceM ("IF " ++ ppString (IAps pif [t] [cnd', thn', els']) ++ "\n " ++ ppReadable (cnd, cnd0, cnd1)) + iTrExpr' ctx idxs pif [t] [cnd', thn', els'] iTrExpr ctx idxs (IAps pcase@(ICon _ (ICPrim _ PrimCase)) ts@[sz_idx, elem_ty] (idx:dflt:ces)) = do - idx' <- iTrExpr ctx [] (expValShallow idx) + idx' <- iTrExpr ctx [] (expValShallow idx) let foldFn (res_ces, res_ctx) (c,e) = do c' <- iTrExpr ctx [] (expValShallow c) let eq_e = iePrimEQ sz_idx idx' c' @@ -190,18 +190,18 @@ iTrExpr ctx idxs@((idx,sz_idx):rest_idxs) (IAps pbld@(ICon i (ICPrim _ PrimBuild (rev_es', _) <- foldM foldFn ([], ctx) (zip [0..] es) iTrExpr' ctx idxs pbld ts (reverse rev_es') iTrExpr ctx idxs (IAps pand@(ICon _ (ICPrim _ PrimBAnd)) ts [e1, e2]) = do - e1' <- iTrExpr ctx [] e1 - e2'' <- iTrExpr (addT e1' ctx) [] (expValShallow e2) - e1'' <- iTrExpr (addT e2'' ctx) [] (expValShallow e1') - iTrExpr' ctx idxs pand ts [e1'', e2''] + e1' <- iTrExpr ctx [] e1 + e2'' <- iTrExpr (addT e1' ctx) [] (expValShallow e2) + e1'' <- iTrExpr (addT e2'' ctx) [] (expValShallow e1') + iTrExpr' ctx idxs pand ts [e1'', e2''] iTrExpr ctx idxs (IAps por@(ICon _ (ICPrim _ PrimBOr)) ts [e1, e2]) = do - e1' <- iTrExpr ctx [] e1 - e2'' <- iTrExpr (addF e1' ctx) [] (expValShallow e2) - e1'' <- iTrExpr (addF e2'' ctx) [] (expValShallow e1') - iTrExpr' ctx idxs por ts [e1'', e2''] + e1' <- iTrExpr ctx [] e1 + e2'' <- iTrExpr (addF e1' ctx) [] (expValShallow e2) + e1'' <- iTrExpr (addF e2'' ctx) [] (expValShallow e1') + iTrExpr' ctx idxs por ts [e1'', e2''] iTrExpr ctx idxs (IAps f ts es) = do - es' <- mapM (iTrExpr ctx []) es - iTrExpr' ctx idxs f ts es' + es' <- mapM (iTrExpr ctx []) es + iTrExpr' ctx idxs f ts es' -- XXX This makes some conditions simpler, but maybe other things get worse? iTrExpr ctx idxs (ICon _ (ICUndet t _ _)) | t == itAction = return icNoActions iTrExpr ctx idxs (ICon i (ICUndet t k (Just e))) = do @@ -211,40 +211,40 @@ iTrExpr ctx idxs e = return e expandHRef :: IExpr a -> T (IExpr a) a expandHRef (IAps f ts es) = do - f' <- expandHRef f - es' <- mapM expandHRef es - return (IAps f' ts es') + f' <- expandHRef f + es' <- mapM expandHRef es + return (IAps f' ts es') expandHRef e@(ICon i (ICValue { })) = do - me <- getDefT i - case me of - Just e' -> return e' - Nothing -> return e + me <- getDefT i + case me of + Just e' -> return e' + Nothing -> return e -- probably not necessary -- included so we could re-run ITransform if we wanted expandHRef (ICon i (ICUndet t k (Just e))) = do e' <- expandHRef e return (ICon i (ICUndet t k (Just e'))) -expandHRef e = return e -- XXX +expandHRef e = return e -- XXX --expandHRef e = internalError ("expandHRef " ++ ppReadable e) iTrExpr' :: Ctx a -> [(IExpr a, Integer)] -> IExpr a -> [IType] -> [IExpr a] -> T (IExpr a) a iTrExpr' ctx idxs f ts es = do - errh <- gets errHandle - let (et, trans) = let ?errh = errh + errh <- gets errHandle + let (et, trans) = let ?errh = errh in iTrAp ctx f ts es - if trans then - iTrExpr ctx idxs et - else - do - e <- runCSE et - let t = iGetType e - isBool = t == itBit1 - if isBool && isT ctx e then - return iTrue - else if isBool && isF ctx e then - return iFalse - else - return e + if trans then + iTrExpr ctx idxs et + else + do + e <- runCSE et + let t = iGetType e + isBool = t == itBit1 + if isBool && isT ctx e then + return iTrue + else if isBool && isF ctx e then + return iFalse + else + return e runCSE :: IExpr a -> T (IExpr a) a runCSE e@(IAps _ _ _) = do @@ -313,37 +313,37 @@ iTrAp ctx p@(ICon _ (ICPrim _ PrimIf)) [t] [cnd, thn, els] = else if isF ctx cnd then (els, True) else if eqE thn els then (thn, True) else case (t == itBit1, thn, els) of - (True, ICon _ (ICInt { iVal = IntLit { ilValue = 1 } }), ICon _ (ICInt { iVal = IntLit { ilValue = 0 } })) -> (cnd, True) - (True, ICon _ (ICInt { iVal = IntLit { ilValue = 1 } }), _ ) -> iTrAp2 ctx iOr [] [cnd, els] - (True, ICon _ (ICInt { iVal = IntLit { ilValue = 0 } }), ICon _ (ICInt { iVal = IntLit { ilValue = 1 } })) -> iTrAp2 ctx iNot [] [cnd] - (True, ICon _ (ICInt { iVal = IntLit { ilValue = 0 } }), _ ) -> iTrAp2 ctx iAnd [] [iTrApExp ctx iNot [] [cnd], els] - (True, _, ICon _ (ICInt { iVal = IntLit { ilValue = 1 } })) -> iTrAp2 ctx iOr [] [iTrApExp ctx iNot [] [cnd], thn] - (True, _, ICon _ (ICInt { iVal = IntLit { ilValue = 0 } })) -> iTrAp2 ctx iAnd [] [cnd, thn] - (_, _, _ ) -> - case (expVal cnd, expVal thn, expVal els) of - - -- if c1 t (if c2 t e) --> if (c1 || c2) t e - (_, _, IAps (ICon _ (ICPrim _ PrimIf)) _ [cnd2, thn2, els2]) | eqE thn thn2 - -> iTrAp2 ctx p [t] [ieOr cnd cnd2, thn, els2] + (True, ICon _ (ICInt { iVal = IntLit { ilValue = 1 } }), ICon _ (ICInt { iVal = IntLit { ilValue = 0 } })) -> (cnd, True) + (True, ICon _ (ICInt { iVal = IntLit { ilValue = 1 } }), _ ) -> iTrAp2 ctx iOr [] [cnd, els] + (True, ICon _ (ICInt { iVal = IntLit { ilValue = 0 } }), ICon _ (ICInt { iVal = IntLit { ilValue = 1 } })) -> iTrAp2 ctx iNot [] [cnd] + (True, ICon _ (ICInt { iVal = IntLit { ilValue = 0 } }), _ ) -> iTrAp2 ctx iAnd [] [iTrApExp ctx iNot [] [cnd], els] + (True, _, ICon _ (ICInt { iVal = IntLit { ilValue = 1 } })) -> iTrAp2 ctx iOr [] [iTrApExp ctx iNot [] [cnd], thn] + (True, _, ICon _ (ICInt { iVal = IntLit { ilValue = 0 } })) -> iTrAp2 ctx iAnd [] [cnd, thn] + (_, _, _ ) -> + case (expVal cnd, expVal thn, expVal els) of + + -- if c1 t (if c2 t e) --> if (c1 || c2) t e + (_, _, IAps (ICon _ (ICPrim _ PrimIf)) _ [cnd2, thn2, els2]) | eqE thn thn2 + -> iTrAp2 ctx p [t] [ieOr cnd cnd2, thn, els2] {- -- This opt is an improvement, but it triggers too much inlining in some -- examples. I'm reverting it, for backwards compatibility, until we add a -- pass (after ITransform? during VeriQuirks?) that lifts subexpressions -- from defs whose expression is too large. - -- if c1 (if c2 t e) e --> if (c1 && c2) t e - (_, IAps (ICon _ (ICPrim _ PrimIf)) _ [cnd2, thn2, els2], _) | eqE els els2 - -> iTrAp2 ctx p [t] [ieAnd cnd cnd2, thn2, els] + -- if c1 (if c2 t e) e --> if (c1 && c2) t e + (_, IAps (ICon _ (ICPrim _ PrimIf)) _ [cnd2, thn2, els2], _) | eqE els els2 + -> iTrAp2 ctx p [t] [ieAnd cnd cnd2, thn2, els] -} - -- XXX Can this ever be harmful? It removes a constant... - -- if (x == k) k e --> if (x == k) x e - (cnd', _, _) | - (case cnd' of - (IAps (ICon _ (ICPrim _ PrimEQ)) _ [x, k@(ICon _ _)]) -> k == thn && thn /= x - _ -> False - ) - -> iTrAp2 ctx p [t] [cnd, x, els] - where (IAps _ _ [x, _]) = cnd' + -- XXX Can this ever be harmful? It removes a constant... + -- if (x == k) k e --> if (x == k) x e + (cnd', _, _) | + (case cnd' of + (IAps (ICon _ (ICPrim _ PrimEQ)) _ [x, k@(ICon _ _)]) -> k == thn && thn /= x + _ -> False + ) + -> iTrAp2 ctx p [t] [cnd, x, els] + where (IAps _ _ [x, _]) = cnd' -- We used to perform this tagging -- (only for bit-type, not Action, and not in the evaluator) @@ -357,9 +357,9 @@ iTrAp ctx p@(ICon _ (ICPrim _ PrimIf)) [t] [cnd, thn, els] = -- if c _ _ --> _ -- XXX This only applies if one of the don't-care has not -- XXX been tagged. Can we ignore tags? Is this opt even used? - (_, ICon _ (ICUndet { imVal = Nothing }), ICon _ (ICUndet {})) + (_, ICon _ (ICUndet { imVal = Nothing }), ICon _ (ICUndet {})) -> (els, True) - (_, ICon _ (ICUndet {}), ICon _ (ICUndet { imVal = Nothing })) + (_, ICon _ (ICUndet {}), ICon _ (ICUndet { imVal = Nothing })) -> (thn, True) {- @@ -368,13 +368,13 @@ iTrAp ctx p@(ICon _ (ICPrim _ PrimIf)) [t] [cnd, thn, els] = -- (somes modules hang in the transform stage). Until we understand why, -- I'm removing it. -- if c {e1, e2} _ --> if c {e1, e2} {_, _} - (_, ICon i (ICUndet { iuKind = u, imVal = Nothing }), + (_, ICon i (ICUndet { iuKind = u, imVal = Nothing }), IAps c@(ICon _ (ICPrim _ PrimConcat)) ts@[ITNum n, ITNum k, ITNum l] [e1, e2]) -> let t1 = itBitN n t2 = itBitN k thn' = IAps c ts [ICon i (ICUndet t1 u Nothing), ICon i (ICUndet t2 u Nothing)] in iTrAp2 ctx p [t] [cnd, thn', els] - (_, IAps c@(ICon _ (ICPrim _ PrimConcat)) ts@[ITNum n, ITNum k, ITNum l] [e1, e2], + (_, IAps c@(ICon _ (ICPrim _ PrimConcat)) ts@[ITNum n, ITNum k, ITNum l] [e1, e2], ICon i (ICUndet { iuKind = u, imVal = Nothing })) -> let t1 = itBitN n t2 = itBitN k @@ -382,29 +382,29 @@ iTrAp ctx p@(ICon _ (ICPrim _ PrimIf)) [t] [cnd, thn, els] = in iTrAp2 ctx p [t] [cnd, thn, els'] -} - -- Special case for turning pack.unpack into an identity - -- if (select _ l _ e == c) (c ++ select k m _ e) x --> IF k+m == l - -- if (select _ l _ e == c) (select _ l _ e ++ select k m _ e) x - (IAps (ICon _ (ICPrim _ PrimEQ)) _ [sel1, c], - IAps (ICon _ (ICPrim _ PrimConcat)) ts [c', sel2], - _) | eqE c c' && - (case expVal sel1 of - IAps (ICon _ (ICPrim _ PrimSelect)) [_, ITNum ls, _] [e] -> - case expVal sel2 of - IAps (ICon _ (ICPrim _ PrimSelect)) [ITNum k, ITNum m, _] [e'] -> k + m == ls && eqE e e' - ICon _ (ICUndet { imVal = Nothing }) -> True - _ -> False - _ -> False - ) - -> iTrAp2 ctx p [t] [cnd, IAps icPrimConcat ts [sel1, sel2], els] - - -- if c (x1++x2) (x1++y2) --> x1 ++ (if c x2 y2) - -- if c (x1++x2) (y1++x2) --> (if c x1 y1) ++ x2 + -- Special case for turning pack.unpack into an identity + -- if (select _ l _ e == c) (c ++ select k m _ e) x --> IF k+m == l + -- if (select _ l _ e == c) (select _ l _ e ++ select k m _ e) x + (IAps (ICon _ (ICPrim _ PrimEQ)) _ [sel1, c], + IAps (ICon _ (ICPrim _ PrimConcat)) ts [c', sel2], + _) | eqE c c' && + (case expVal sel1 of + IAps (ICon _ (ICPrim _ PrimSelect)) [_, ITNum ls, _] [e] -> + case expVal sel2 of + IAps (ICon _ (ICPrim _ PrimSelect)) [ITNum k, ITNum m, _] [e'] -> k + m == ls && eqE e e' + ICon _ (ICUndet { imVal = Nothing }) -> True + _ -> False + _ -> False + ) + -> iTrAp2 ctx p [t] [cnd, IAps icPrimConcat ts [sel1, sel2], els] + + -- if c (x1++x2) (x1++y2) --> x1 ++ (if c x2 y2) + -- if c (x1++x2) (y1++x2) --> (if c x1 y1) ++ x2 -- check if we make progress to avoid infinite loops (_, - IAps pc@(ICon _ (ICPrim _ PrimConcat)) ts@[t1,t2,_] [x1, x2], - IAps (ICon _ (ICPrim _ PrimConcat)) ts' [y1, y2] - ) | ts == ts', + IAps pc@(ICon _ (ICPrim _ PrimConcat)) ts@[t1,t2,_] [x1, x2], + IAps (ICon _ (ICPrim _ PrimConcat)) ts' [y1, y2] + ) | ts == ts', let (e1', opt1) = iTrAp ctx p [aitBit t1] [cnd, x1, y1], let (e2', opt2) = iTrAp ctx p [aitBit t2] [cnd, x2, y2], opt1 || opt2 -> @@ -430,44 +430,44 @@ iTrAp ctx p@(ICon _ (ICPrim _ PrimIf)) [t] [cnd, thn, els] = (_,_,IAps (ICon _ (ICPrim _ PrimBNot)) _ [x]) | eqE cnd x -> iTrAp2 ctx p [t] [cnd,thn,iTrue] - _ -> (IAps p [t] [cnd, thn, els], False) + _ -> (IAps p [t] [cnd, thn, els], False) -- Boolean optimization -- False && e --> False -- e && False --> False --- e1 && e2 --> e1 IF e1 IMPLIES e2 --- e2 && e1 --> e2 IF e2 IMPLIES e1 +-- e1 && e2 --> e1 IF e1 IMPLIES e2 +-- e2 && e1 --> e2 IF e2 IMPLIES e1 -- these two cases may be logically redundant, but the -- compiler might be able to optimize one path and not the other -- e1 && e2 --> False IF e1 IMPLIES ~e2 -- e2 && e1 --> False IF e2 IMPLIES ~e1 iTrAp ctx p@(ICon _ (ICPrim _ PrimBAnd)) _ [c1, c2] = - if isF ctx c1 || isF ctx c2 then (iFalse, True) -- fast special case - else if isUndet c1 || isUndet c2 then (iFalse, True) - else if implies ctx c1 c2 then (c1, True) - else if implies ctx c2 c1 then (c2, True) + if isF ctx c1 || isF ctx c2 then (iFalse, True) -- fast special case + else if isUndet c1 || isUndet c2 then (iFalse, True) + else if implies ctx c1 c2 then (c1, True) + else if implies ctx c2 c1 then (c2, True) else if impliesnot ctx c1 c2 then (iFalse, True) else if impliesnot ctx c2 c1 then (iFalse, True) - else (IAps p [] [c1, c2], False) + else (IAps p [] [c1, c2], False) -- True || e --> True -- e || True --> True --- e1 || e2 --> e1 IF e2 IMPLIES e1 --- e2 || e1 --> e2 IF e1 IMPLIES e2 +-- e1 || e2 --> e1 IF e2 IMPLIES e1 +-- e2 || e1 --> e2 IF e1 IMPLIES e2 -- these two cases may be logically redundant, but the -- compiler might be able to optimize one path and not the other --- e1 || e2 --> True IF ~e1 IMPLIES e2 +-- e1 || e2 --> True IF ~e1 IMPLIES e2 -- e1 || e2 --> True IF ~e2 IMPLIES e1 iTrAp ctx p@(ICon _ (ICPrim _ PrimBOr)) _ [c1, c2] = - if isT ctx c1 || isT ctx c2 then (iTrue, True) -- fast special case + if isT ctx c1 || isT ctx c2 then (iTrue, True) -- fast special case else if isUndet c1 || isUndet c2 then (iTrue, True) - else if implies ctx c2 c1 then (c1, True) - else if implies ctx c1 c2 then (c2, True) + else if implies ctx c2 c1 then (c1, True) + else if implies ctx c1 c2 then (c2, True) else if notimplies ctx c1 c2 then (iTrue, True) else if notimplies ctx c2 c1 then (iTrue, True) - else (IAps p [] [c1, c2], False) + else (IAps p [] [c1, c2], False) -- not True --> False -- not False --> True @@ -507,28 +507,28 @@ iTrAp ctx (ICon _ (ICPrim _ PrimEQ)) _ [e1, e2@(ICon _ (ICUndet {iuKind = u, imV iTrAp ctx rel_c@(ICon _ (ICPrim _ PrimEQ)) t1@[ITNum i1] [e', c2] | -- app of a PrimEQ with a single type variable (isIConInt c2) && -- c2 is a constant case expVal e' of - (IAps (ICon _ (ICPrim _ op)) t2@[ITNum i2] [e, c1]) -> -- app of a prim op with a single type variable - (isIConInt c1) && (not (isIConInt e)) && -- c1 is a constant, e is not a constant (to ensure progress) - ((op == PrimAdd) || (op == PrimSub) || (op == PrimXor)) && -- op is one of these - (i1 == i2) -- the type variables are the same - _ -> False + (IAps (ICon _ (ICPrim _ op)) t2@[ITNum i2] [e, c1]) -> -- app of a prim op with a single type variable + (isIConInt c1) && (not (isIConInt e)) && -- c1 is a constant, e is not a constant (to ensure progress) + ((op == PrimAdd) || (op == PrimSub) || (op == PrimXor)) && -- op is one of these + (i1 == i2) -- the type variables are the same + _ -> False = case expVal e' of - (IAps opc@(ICon _ (ICPrim _ op)) _ [e, c1]) -> - let - inv_op = case op of - PrimAdd -> PrimSub - PrimSub -> PrimAdd - PrimXor -> PrimXor + (IAps opc@(ICon _ (ICPrim _ op)) _ [e, c1]) -> + let + inv_op = case op of + PrimAdd -> PrimSub + PrimSub -> PrimAdd + PrimXor -> PrimXor _ -> internalError ("ITransform.iTrAp.inv_op: " ++ ppString op) - -- c3 == iTrap ctx inv_op t2 [c2,c1] - -- do the computation here: - c3 = case (doPrimOp (getIExprPosition opc) inv_op t1 [c2,c1]) of - Just (Right e) -> e - x -> internalError ("iTrAp: doPrimOp: " ++ ppReadable x) - in - -- any reason to use "icPrimEQ" etc instead of reusing "rel_c"? + -- c3 == iTrap ctx inv_op t2 [c2,c1] + -- do the computation here: + c3 = case (doPrimOp (getIExprPosition opc) inv_op t1 [c2,c1]) of + Just (Right e) -> e + x -> internalError ("iTrAp: doPrimOp: " ++ ppReadable x) + in + -- any reason to use "icPrimEQ" etc instead of reusing "rel_c"? iTrAp2 ctx rel_c t1 [e, c3] _ -> internalError "ITransform.iTrAp(PrimEQ).expVal e': bad form" @@ -597,13 +597,13 @@ iTrAp ctx (ICon _ (ICPrim _ PrimMul)) [se,sk@(ITNum k_size),sz] [e, ICon _ (ICIn | m /= Nothing = iTrAp2 ctx icPrimSL [sz, ITNum 32] [e', iMkLit itNat k] where e' = iTrApExp ctx icPrimConcat [sk, se, sz] [iMkLitSize k_size 0, e] m = iLog2 n - Just k = m + Just k = m -- 2^k * e --> e << k iTrAp ctx (ICon _ (ICPrim _ PrimMul)) [sk@(ITNum k_size),se,sz] [ICon _ (ICInt { iVal = IntLit { ilValue = n } }), e] | m /= Nothing = iTrAp2 ctx icPrimSL [sz, ITNum 32] [e', iMkLit itNat k] where e' = iTrApExp ctx icPrimConcat [sk, se, sz] [iMkLitSize k_size 0, e] m = iLog2 n - Just k = m + Just k = m -- 0 | e --> e -- 1 | e --> 1 @@ -707,7 +707,7 @@ iTrAp ctx (ICon _ (ICPrim _ PrimQuot)) _ [e, c] | isOne c = (e, True) iTrAp ctx (ICon _ (ICPrim _ PrimQuot)) [se,_] [e, ICon _ (ICInt { iVal = IntLit { ilValue = n } })] | m /= Nothing = iTrAp2 ctx icPrimSRL [se] [e, iMkLit itNat k] where m = iLog2 n - Just k = m + Just k = m -- e % 1 --> 0 iTrAp ctx (ICon _ (ICPrim _ PrimRem)) [_,sk] [_,c] | isOne c = (mkZero sk, True) @@ -719,7 +719,7 @@ iTrAp ctx (ICon remid (ICPrim _ PrimRem)) [se,sk@(ITNum k_size)] [e, ICon _ (ICI else iTrAp2 ctx icPrimConcat [ITNum pad, ITNum k, sk] [iMkLitSize pad 0, e'] where e' = iTrApExp ctx (icSelect (getIdPosition remid)) [(ITNum k), ITNum 0, se] [e] m = iLog2 n - Just k = m + Just k = m pad = k_size - k -- e < 0 --> False @@ -778,7 +778,7 @@ iTrAp ctx cneg@(ICon _ (ICPrim _ p)) [ty] [exp] | p == PrimNeg || p == PrimInv = case expVal exp of IAps cneg2@(ICon _ (ICPrim _ p')) [ty] [e] | p' == p -> (e, True) IAps cif@(ICon _ (ICPrim _ PrimIf)) [tif] [c, t, e] | isIConInt t || isIConInt e -> - iTrAp2 ctx cif [tif] [c, iTrApExp ctx cneg [ty] [t], iTrApExp ctx cneg [ty] [e]] + iTrAp2 ctx cif [tif] [c, iTrApExp ctx cneg [ty] [t], iTrApExp ctx cneg [ty] [e]] IAps ccat@(ICon _ (ICPrim _ PrimConcat)) ts@[l, m, _] [e1, e2] | p == PrimInv -> iTrAp2 ctx ccat ts [iTrApExp ctx cneg [l] [e1], iTrApExp ctx cneg [m] [e2]] u@(ICon i (ICUndet t k Nothing)) -> (u, True) @@ -786,25 +786,25 @@ iTrAp ctx cneg@(ICon _ (ICPrim _ p)) [ty] [exp] | p == PrimNeg || p == PrimInv = -- e >> n --> 0 ++ select (k-n) n k e iTrAp ctx (ICon srl (ICPrim _ PrimSRL)) [t@(ITNum k), _] [e, ICon _ (ICInt { iVal = IntLit { ilValue = n } })] = - let z = iMkLitSize n 0 - tt = mkNumConT (k-n) - tn = mkNumConT n - e' = iTrApExp ctx (icSelect (getIdPosition srl)) [tt, tn, t] [e] - in if n >= k then - (mkZero t, True) - else - iTrAp2 ctx icPrimConcat [tn, tt, t] [z, e'] + let z = iMkLitSize n 0 + tt = mkNumConT (k-n) + tn = mkNumConT n + e' = iTrApExp ctx (icSelect (getIdPosition srl)) [tt, tn, t] [e] + in if n >= k then + (mkZero t, True) + else + iTrAp2 ctx icPrimConcat [tn, tt, t] [z, e'] -- e << n --> trunc (e ++ 0) iTrAp ctx (ICon sl (ICPrim _ PrimSL)) [t@(ITNum k), _] [e, ICon _ (ICInt { iVal = IntLit { ilValue = n } })] = - let z = iMkLitSize n 0 - tt = mkNumConT (k-n) - tn = mkNumConT n - e' = iTrApExp ctx (icSelect (getIdPosition sl)) [tt, mkNumConT 0, t] [e] - in if n >= k then - (mkZero t, True) - else - iTrAp2 ctx icPrimConcat [tt, tn, t] [e', z] + let z = iMkLitSize n 0 + tt = mkNumConT (k-n) + tn = mkNumConT n + e' = iTrApExp ctx (icSelect (getIdPosition sl)) [tt, mkNumConT 0, t] [e] + in if n >= k then + (mkZero t, True) + else + iTrAp2 ctx icPrimConcat [tt, tn, t] [e', z] -- e :: Bit 1 >> x or e :: Bit 1 << x -> if (x == 0) e else 0 --> (x == 0) && e iTrAp ctx (ICon _ (ICPrim _ p)) [ITNum 1, ITNum t] [e, shft] | p `elem` [PrimSL, PrimSRL] = @@ -835,18 +835,18 @@ iTrAp ctx p@(ICon _ (ICPrim _ prim)) [t] [e1,e2] -- extract n k e h l --> zeroExt (h-l+1) (k-(h-l+1)) k (select (h-l+1) l n e) iTrAp ctx fun@(ICon iext (ICPrim _ PrimExtract)) ts@[tn@(ITNum n), _, ITNum k] es@[e, eh, el] | isIConInt eh && isIConInt el = --- iTrAp ctx icPrimZeroExt [mkNumConT k_sz, mkNumConT sz, mkNumConT k] [exp] - iTrAp2 ctx icPrimConcat [mkNumConT k_sz, mkNumConT sz, mkNumConT k] [iMkLitSize k_sz 0, exp] +-- iTrAp ctx icPrimZeroExt [mkNumConT k_sz, mkNumConT sz, mkNumConT k] [exp] + iTrAp2 ctx icPrimConcat [mkNumConT k_sz, mkNumConT sz, mkNumConT k] [iMkLitSize k_sz 0, exp] where exp = iTrApExp ctx (icSelect (getIdPosition iext)) [mkNumConT sz, mkNumConT l, tn] [e] - ICon _ (ICInt { iVal = IntLit { ilValue = h } }) = eh - ICon _ (ICInt { iVal = IntLit { ilValue = l } }) = el - sz = mask 32 (h-l+1) -- mask it to allow h == l-1 - k_sz = if k < sz + ICon _ (ICInt { iVal = IntLit { ilValue = h } }) = eh + ICon _ (ICInt { iVal = IntLit { ilValue = l } }) = el + sz = mask 32 (h-l+1) -- mask it to allow h == l-1 + k_sz = if k < sz then internalError("extraction size (" ++ show sz ++ ") " ++ "is larger than the expected result (" ++ show k ++ "):\n" ++ ppReadable (IAps fun ts es)) - else k - sz + else k - sz -- select n k m e --> error, n+k > m iTrAp ctx fun@(ICon sel (ICPrim _ PrimSelect)) ts@[ITNum n, ITNum k, ITNum m] as | n+k > m = @@ -860,23 +860,23 @@ iTrAp ctx (ICon sel (ICPrim _ PrimSelect)) [ITNum n, _, _] [ICon _ (ICUndet { iu {- -- XXX join with above conApN _ ctx fun@(ICon isel (ICPrim _ PrimSelect)) args@[T (ITNum k), T (ITNum m), T (ITNum n)] - | k > n-m || n-m < 0 - = compileError ("conApN select: bad bit selection\n" ++ - ppReadable (getIdPosition isel) ++ ppReadable (mkAp fun args)) + | k > n-m || n-m < 0 + = compileError ("conApN select: bad bit selection\n" ++ + ppReadable (getIdPosition isel) ++ ppReadable (mkAp fun args)) -} {- -- XXX what's this? iTrAp ctx fun@(ICon iext (ICPrim _ PrimExtract)) args@[T tn, T tk, E e, E eh, E el] - | eh == el && isNumConT tk && getNumConT tk == 1 - = iTrAp ctx icSelect [T (mkNumConT 1), T (mkNumConT 0), T tn, E exp] + | eh == el && isNumConT tk && getNumConT tk == 1 + = iTrAp ctx icSelect [T (mkNumConT 1), T (mkNumConT 0), T tn, E exp] where exp = IAps icPrimSRL [tn] [e, el] -} -- x::Bit1 == 1 --> x -- x::Bit1 == 0 --> not x iTrAp ctx e0@(ICon _ (ICPrim _ PrimEQ)) [ITNum 1] [e, ICon _ (ICInt { iVal = IntLit { ilValue = i } })] = - if i == 0 then + if i == 0 then iTrAp2 ctx iNot [] [e] else if i == 1 then (e, True) @@ -894,10 +894,10 @@ iTrAp ctx rel_c@(ICon _ (ICPrim _ p)) t1@[ITNum i1] [e', c] | (p `elem` [PrimEQ, PrimULT, PrimULE, PrimSLT, PrimSLE]) && (isIfElseOfIConInt e') = let ap (IAps i@(ICon _ (ICPrim _ PrimIf)) ts [cnd, thn, els]) = - -- the result of the "if" is now 1-bit - (IAps i [itBit1] [cnd, ap thn, ap els]) - ap (ICon _ (ICValue { iValDef = e })) = ap e - ap e = iTrApExp ctx rel_c t1 [e, c] + -- the result of the "if" is now 1-bit + (IAps i [itBit1] [cnd, ap thn, ap els]) + ap (ICon _ (ICValue { iValDef = e })) = ap e + ap e = iTrApExp ctx rel_c t1 [e, c] in (ap e', True) -- c RELOP x --> x (flip RELOP) c @@ -918,72 +918,72 @@ iTrAp ctx p@(ICon _ (ICPrim _ PrimConcat)) ts@[s1@(ITNum i1), s2@(ITNum i2), s3@ _ | i2 == 0 -> (e1, True) -- _ ++ _ --> _ [ICon _ (ICUndet { imVal = Nothing }), ICon _ (ICUndet { iuKind = u, imVal = Nothing })] - -> (icUndet (aitBit s3) u, True) + -> (icUndet (aitBit s3) u, True) -- c1 ++ (c2 ++ e) --> (c1++c2) ++ e [ICon _ (ICInt { iVal = IntLit { ilValue = c1 } }), IAps (ICon _ (ICPrim _ PrimConcat)) [ITNum isc2, se, _] [ICon _ (ICInt { iVal = IntLit { ilValue = c2 } }), e]] - -> iTrAp2 ctx p [mkNumConT isc1c2, se, s3] [iMkLitSize isc1c2 (c1 * 2^isc2 + c2), e] - where isc1c2 = i1 + isc2 + -> iTrAp2 ctx p [mkNumConT isc1c2, se, s3] [iMkLitSize isc1c2 (c1 * 2^isc2 + c2), e] + where isc1c2 = i1 + isc2 -- select ? ? ? e1 ++ (select ? ? ? e1 ++ e2) --> (select ? ? ? e1 ++ select ? ? ? e1) ++ e2 -- enables next transform - [x1@(IAps ps@(ICon _ (ICPrim _ PrimSelect)) _ [e1]), -- size l + [x1@(IAps ps@(ICon _ (ICPrim _ PrimSelect)) _ [e1]), -- size l (IAps pc@(ICon _ (ICPrim _ PrimConcat)) - [s2s@(ITNum s2i), e2s, _] - [x2@(IAps (ICon _ (ICPrim _ PrimSelect)) _ [e1']), - e2])] - | e1 == e1' - -> iTrAp2 ctx pc [s12s, e2s, s3] [ss, e2] - where ss = iTrApExp ctx pc [s1,s2s,s12s] [x1, x2] - s12s = mkNumConT (i1 + s2i) + [s2s@(ITNum s2i), e2s, _] + [x2@(IAps (ICon _ (ICPrim _ PrimSelect)) _ [e1']), + e2])] + | e1 == e1' + -> iTrAp2 ctx pc [s12s, e2s, s3] [ss, e2] + where ss = iTrApExp ctx pc [s1,s2s,s12s] [x1, x2] + s12s = mkNumConT (i1 + s2i) -- select l (m+k) n e ++ select k m n e --> select (l+k) m n e [IAps p@(ICon _ (ICPrim _ PrimSelect)) [ITNum il', ITNum imk, n] [e], IAps (ICon _ (ICPrim _ PrimSelect)) [ITNum ik', m@(ITNum im), n'] [e']] - | i1 == il' && i2 == ik' && n == n' && eqE e e' - && i3 == i1 + i2 && imk == im + i2 - -> iTrAp2 ctx p [s3, m, n] [e] + | i1 == il' && i2 == ik' && n == n' && eqE e e' + && i3 == i1 + i2 && imk == im + i2 + -> iTrAp2 ctx p [s3, m, n] [e] -- (e1 ++ select l (m+k) n e2) ++ select k m n e2 -> (e1 ++ select (l+k) m n e) [x1@(IAps pc@(ICon _ (ICPrim _ PrimConcat)) - [e1s@(ITNum e1i), sel1s@(ITNum sel1i), _] - [e1, sel1@(IAps (ICon _ (ICPrim _ PrimSelect)) + [e1s@(ITNum e1i), sel1s@(ITNum sel1i), _] + [e1, sel1@(IAps (ICon _ (ICPrim _ PrimSelect)) [ITNum il', ITNum imk, n] [e2])]), sel2@(IAps ps@(ICon _ (ICPrim _ PrimSelect)) [ITNum ik', m@(ITNum im), n'] [e2'])] - | sel1i == il' && i2 == ik' && n == n' && eqE e2 e2' + | sel1i == il' && i2 == ik' && n == n' && eqE e2 e2' && i3 == i1 + i2 && imk == im + i2 - -> iTrAp2 ctx pc [e1s, s12s, s3] [e1, ss] - where ss = iTrApExp ctx pc [sel1s,s2,s12s] [sel1, sel2] - s12s = mkNumConT (sel1i + i2) + -> iTrAp2 ctx pc [e1s, s12s, s3] [e1, ss] + where ss = iTrApExp ctx pc [sel1s,s2,s12s] [sel1, sel2] + s12s = mkNumConT (sel1i + i2) - -- _ ++ select k m n e --> select (l+k) m n e IF n-m >= l+k - -- _ ++ select k m n e --> _ ++ select (n-m) m n e IF n-m < l+k + -- _ ++ select k m n e --> select (l+k) m n e IF n-m >= l+k + -- _ ++ select k m n e --> _ ++ select (n-m) m n e IF n-m < l+k [ICon _ (ICUndet { iuKind = u, imVal = Nothing }), IAps ps@(ICon _ (ICPrim _ PrimSelect)) [ITNum ik', m@(ITNum im), n@(ITNum inn)] [e]] - | i2 == ik' && d /= i1 - -> --trace ("_ ++ sel\n" ++ ppReadable (mkAp p as)) $ + | i2 == ik' && d /= i1 + -> --trace ("_ ++ sel\n" ++ ppReadable (mkAp p as)) $ if d <= 0 then - iTrAp2 ctx ps [s3, m, n] [e] - else - iTrAp2 ctx p [mkNumConT d, tnm, s3] - [icUndet (itBitN d) u, iTrApExp ctx ps [tnm, m, n] [e]] - where nm = inn - im - d = i3 - nm - tnm = mkNumConT nm - - -- select k m n e ++ _ --> select (l+k) (m-l) n e IF m >= l + iTrAp2 ctx ps [s3, m, n] [e] + else + iTrAp2 ctx p [mkNumConT d, tnm, s3] + [icUndet (itBitN d) u, iTrApExp ctx ps [tnm, m, n] [e]] + where nm = inn - im + d = i3 - nm + tnm = mkNumConT nm + + -- select k m n e ++ _ --> select (l+k) (m-l) n e IF m >= l -- select k m n e ++ _ --> select (m+k) 0 n e ++ _ [IAps ps@(ICon _ (ICPrim _ PrimSelect)) [ITNum ik', m@(ITNum im), n@(ITNum inn)] [e], ICon _ (ICUndet { iuKind = u, imVal = Nothing })] - | i1 == ik' && (im >= i2 || d /= i2) - -> --trace ("sel ++ _\n" ++ ppReadable (mkAp p as, im, i2)) $ + | i1 == ik' && (im >= i2 || d /= i2) + -> --trace ("sel ++ _\n" ++ ppReadable (mkAp p as, im, i2)) $ if im >= i2 then - iTrAp2 ctx ps [s3, mkNumConT (im-i2), n] [e] - else - iTrAp2 ctx p [tmk, mkNumConT d, s3] - [iTrApExp ctx ps [tmk, ITNum 0, n] [e], icUndet (itBitN d) u] - where tmk = mkNumConT (im+i1) - d = i3 - (im+i1) + iTrAp2 ctx ps [s3, mkNumConT (im-i2), n] [e] + else + iTrAp2 ctx p [tmk, mkNumConT d, s3] + [iTrApExp ctx ps [tmk, ITNum 0, n] [e], icUndet (itBitN d) u] + where tmk = mkNumConT (im+i1) + d = i3 - (im+i1) -- (if c t0 e0) ++ (if c t1 e1) --> if c (t0 ++ t1) (e0 ++ e1) [IAps pif@(ICon _ (ICPrim _ PrimIf)) _ [cnd0, t0, e0], IAps (ICon _ (ICPrim _ PrimIf)) _ [cnd1, t1, e1]] | cnd0 == cnd1 -> @@ -996,27 +996,27 @@ iTrAp ctx ps@(ICon _ (ICPrim _ PrimSelect)) ts@[k@(ITNum ik), m@(ITNum im), n] [ case expVal e of -- select k m n (select n p q e) --> select k (m+p) q e IAps (ICon _ (ICPrim _ PrimSelect)) [n', ITNum ip, q] [e] - | n == n' - -> iTrAp2 ctx ps [k, mkNumConT (im+ip), q] [e] + | n == n' + -> iTrAp2 ctx ps [k, mkNumConT (im+ip), q] [e] -- select k 0 n (e1 ++ e2) --> select (k-l2) 0 l1 e1 ++ e2 IF k >= l2 IAps pc@(ICon _ (ICPrim _ PrimConcat)) [l1, l2@(ITNum il2), n'] [e1, e2] - | n == n' && im == 0 && ik >= il2 - -> iTrAp2 ctx pc [mkNumConT j, l2, k] [sel, e2] - where j = ik - il2 - sel = iTrApExp ctx ps [mkNumConT j, m, l1] [e1] + | n == n' && im == 0 && ik >= il2 + -> iTrAp2 ctx pc [mkNumConT j, l2, k] [sel, e2] + where j = ik - il2 + sel = iTrApExp ctx ps [mkNumConT j, m, l1] [e1] - -- select k m n (e1 ++ e2) --> select k m l2 e2 IF k+m <= l2 - -- --> select k (m-l2) l1 e1 IF m >= l2 + -- select k m n (e1 ++ e2) --> select k m l2 e2 IF k+m <= l2 + -- --> select k (m-l2) l1 e1 IF m >= l2 -- otherwise --> select (k + m - l2) 0 l1 e1 ++ select (l2 - m) m l2 e2 IAps pc@(ICon _ (ICPrim _ PrimConcat)) [l1, l2@(ITNum il2), n'] [e1, e2] - | n == n' - -> if im >= il2 then - iTrAp2 ctx ps [k, mkNumConT (im - il2), l1] [e1] - else if (ik + im <= il2) then - iTrAp2 ctx ps [k, m, l2] [e2] + | n == n' + -> if im >= il2 then + iTrAp2 ctx ps [k, mkNumConT (im - il2), l1] [e1] + else if (ik + im <= il2) then + iTrAp2 ctx ps [k, m, l2] [e2] else iTrAp2 ctx pc [mkNumConT l1', mkNumConT l2', k] [e1', e2'] - where e1' = iTrApExp ctx ps [mkNumConT l1', mkNumConT 0, l1] [e1] + where e1' = iTrApExp ctx ps [mkNumConT l1', mkNumConT 0, l1] [e1] l1' = ik + im - il2 e2' = iTrApExp ctx ps [mkNumConT l2', m, l2] [e2] l2' = il2 - im @@ -1037,14 +1037,14 @@ iTrAp ctx op@(ICon _ (ICPrim _ PrimAdd)) ts as = case map expVal as of [ICon _ (ICInt { iVal = IntLit { ilValue = c } } ), IAps co@(ICon _ (ICPrim _ PrimConcat)) [t1, t2@(ITNum it2), t3] [ICon _ (ICInt { iVal = IntLit { ilValue = c2 } }), e] - ] | r == 0 - -> iTrAp2 ctx co [t1, t2, t3] [iMkLit (aitBit t1) (q+c2), e] - where (q,r) = quotRem c (2^it2) + ] | r == 0 + -> iTrAp2 ctx co [t1, t2, t3] [iMkLit (aitBit t1) (q+c2), e] + where (q,r) = quotRem c (2^it2) [IAps co@(ICon _ (ICPrim _ PrimConcat)) [t1, t2@(ITNum it2), t3] [e, ICon _ (ICInt { iVal = IntLit { ilValue = 0 } })], ICon _ (ICInt { iVal = IntLit { ilValue = c } } ) - ] | q == 0 - -> iTrAp2 ctx co [t1, t2, t3] [e, iMkLit (aitBit t2) r] - where (q,r) = quotRem c (2^it2) + ] | q == 0 + -> iTrAp2 ctx co [t1, t2, t3] [e, iMkLit (aitBit t2) r] + where (q,r) = quotRem c (2^it2) _ -> iTrApTail ctx op ts as -- (e1 ++ e2) `op` (e3 ++ e4) --> (e1 `op` e3) ++ (e2 `op` e4) @@ -1160,18 +1160,18 @@ splitConstExpr _ _ _ = Nothing addT :: IExpr a -> Ctx a -> Ctx a addT e ctx = --trace ("addT\n" ++ ppReadable (e, ctx, addT' (expValAndOrCmp e) ctx)) $ - addT' (expValAndOrCmp e) ctx + addT' (expValAndOrCmp e) ctx where addT' e (Ctx vs be) = Ctx (addEqs e vs) (bAdd e be) - addEqs (IAps (ICon _ (ICPrim _ PrimEQ)) _ [i, ICon _ (ICInt { iVal = IntLit { ilValue = v } })]) vs = M.insert i v vs + addEqs (IAps (ICon _ (ICPrim _ PrimEQ)) _ [i, ICon _ (ICInt { iVal = IntLit { ilValue = v } })]) vs = M.insert i v vs -- XXX case for when the const is on the left? -- XXX case for (e1 == e2), when e1 or e2 exists in the set, add the other as the same val - addEqs (IAps (ICon _ (ICPrim _ PrimBAnd)) _ [e1, e2]) vs = addEqs e1 (addEqs e2 vs) - addEqs (IAps (ICon _ (ICPrim _ PrimBNot)) _ [e]) vs = addNEqs e vs - addEqs _ vs = vs + addEqs (IAps (ICon _ (ICPrim _ PrimBAnd)) _ [e1, e2]) vs = addEqs e1 (addEqs e2 vs) + addEqs (IAps (ICon _ (ICPrim _ PrimBNot)) _ [e]) vs = addNEqs e vs + addEqs _ vs = vs -- XXX case for != ? - addNEqs (IAps (ICon _ (ICPrim _ PrimBOr)) _ [e1, e2]) vs = addNEqs e1 (addNEqs e2 vs) - addNEqs (IAps (ICon _ (ICPrim _ PrimBNot)) _ [e]) vs = addEqs e vs - addNEqs _ vs = vs + addNEqs (IAps (ICon _ (ICPrim _ PrimBOr)) _ [e1, e2]) vs = addNEqs e1 (addNEqs e2 vs) + addNEqs (IAps (ICon _ (ICPrim _ PrimBNot)) _ [e]) vs = addEqs e vs + addNEqs _ vs = vs addF :: IExpr a -> Ctx a -> Ctx a addF e ctx = addT (ieNot e) ctx @@ -1200,36 +1200,36 @@ expValAndOr e = e isT :: Ctx a -> IExpr a -> Bool isT ctx@(Ctx vs be) e = --traces ("isT\n" ++ ppReadable (e, expValAndOrCmp e, ctx, isT' (expValAndOrCmp e))) $ - isT' (expValAndOrCmp e) + isT' (expValAndOrCmp e) where isT' e = bImplies be e || case e of IAps (ICon _ (ICPrim _ PrimEQ)) _ [i, ICon _ (ICInt { iVal = IntLit { ilValue = v } })] -> --- traces ("isT EQ" ++ ppReadable (i, v, M.toList vs)) $ - case M.lookup i vs of - Just k -> v == k +-- traces ("isT EQ" ++ ppReadable (i, v, M.toList vs)) $ + case M.lookup i vs of + Just k -> v == k Nothing -> False IAps (ICon _ (ICPrim _ PrimBNot)) _ [IAps (ICon _ (ICPrim _ PrimEQ)) _ [i, ICon _ (ICInt { iVal = IntLit { ilValue = v } })]] -> --- traces ("isT NE" ++ ppReadable (i, v, M.toList vs)) $ - case M.lookup i vs of - Just k -> v /= k +-- traces ("isT NE" ++ ppReadable (i, v, M.toList vs)) $ + case M.lookup i vs of + Just k -> v /= k Nothing -> False _ -> False isF :: Ctx a -> IExpr a -> Bool isF ctx@(Ctx vs be) e = --traces ("isF\n" ++ ppReadable (e, expValAndOrCmp e, ctx, isF' (expValAndOrCmp e))) $ - isF' (expValAndOrCmp e) + isF' (expValAndOrCmp e) where isF' e = - bImplies be (ieNot e) || + bImplies be (ieNot e) || case e of IAps (ICon _ (ICPrim _ PrimEQ)) _ [i, ICon _ (ICInt { iVal = IntLit { ilValue = v } })] -> - case M.lookup i vs of - Just k -> v /= k + case M.lookup i vs of + Just k -> v /= k Nothing -> False IAps (ICon _ (ICPrim _ PrimBNot)) _ [IAps (ICon _ (ICPrim _ PrimEQ)) _ [i, ICon _ (ICInt { iVal = IntLit { ilValue = v } })]] -> - case M.lookup i vs of - Just k -> v == k + case M.lookup i vs of + Just k -> v == k Nothing -> False _ -> False @@ -1265,14 +1265,14 @@ emptyCtx = Ctx M.empty bNothing instance PPrint (Ctx a) where pPrint d p (Ctx es be) = - (text "Ctx " $+$ text " ") - <> (pPrint d 0 (M.toList es) $+$ - pPrint d 0 be) + (text "Ctx " $+$ text " ") + <> (pPrint d 0 (M.toList es) $+$ + pPrint d 0 be) {- bSetLess :: Ctx a -> Ctx a -> Bool bSetLess (Ctx sm e) (Ctx sm' e') = - isOrdSubset (M.toList sm) (M.toList sm') && bImpliesB e' e + isOrdSubset (M.toList sm) (M.toList sm') && bImpliesB e' e -} ----------------------------------------------------------------------------- @@ -1314,10 +1314,10 @@ isAlmost _ = False iLog2 :: Integer -> Maybe Integer iLog2 i = - if i > 0 && (i `integerAnd` (i-1)) == 0 then - Just (log2 i) - else - Nothing + if i > 0 && (i `integerAnd` (i-1)) == 0 then + Just (log2 i) + else + Nothing inc (ICon i c@(ICInt { iVal = il@(IntLit { ilValue = n }) })) = -- GHC emits a warning below because it's forgotten that 'c' must be @@ -1375,13 +1375,13 @@ data TState a = TState { -- Prefix to use for generating new names (resulting from CSE) prefix :: String, -- Source of unique numbers to append to generated names - idNo :: Integer, + idNo :: Integer, -- A map of package defs. When ICValue is encountered, the def is -- looked up in this map and the assigned expression is inlined. -- The defprops are kept to be used in the fixup step that happens -- between processing defs and processing the rest of the module. - def_map :: M.Map Id (IType, IExpr a, [DefProp]), + def_map :: M.Map Id (IType, IExpr a, [DefProp]), -- A CSE map, from an expr "e" to a tuple of info for the canonical -- def ("defname") to represent it: @@ -1389,8 +1389,8 @@ data TState a = TState { -- * the def ("IDef defname deftype e") -- When the monad is run, because all exprs are inlined and then CSE'd -- back up, the defs for the package will come from this map. - cse_map :: M.Map (IExpr a) (IExpr a, IDef a) - } + cse_map :: M.Map (IExpr a) (IExpr a, IDef a) + } type T b a = State (TState a) b @@ -1431,9 +1431,9 @@ newExprT t e = do Nothing -> do n <- gets idNo let i = setBadId $ mkId noPosition (mkFString ((prefix ts) ++ itos n)) - e' = ICon i (ICValue t e) - d = IDef i t e [] -- props get lost here, but restored in iTransRenameIdsInDef - put $ ts { idNo = n+1, cse_map = M.insert e (e', d) cmap } + e' = ICon i (ICValue t e) + d = IDef i t e [] -- props get lost here, but restored in iTransRenameIdsInDef + put $ ts { idNo = n+1, cse_map = M.insert e (e', d) cmap } -- traceM ("newExprT " ++ ppString e ++ " -> " ++ ppString (e',d)) return e' @@ -1479,17 +1479,17 @@ optBoolExpr moreBoolOpt = optBoolExprN 8 moreBoolOpt optBoolExprN :: Int -> Bool -> IExpr a -> IExpr a optBoolExprN nvars moreBoolOpt = - fromBE . - (if moreBoolOpt then tryHard nvars else sSimplify) . - toBE . - (if moreBoolOpt then aOptCmp else sOptCmp) . - expValAndOrCmp + fromBE . + (if moreBoolOpt then tryHard nvars else sSimplify) . + toBE . + (if moreBoolOpt then aOptCmp else sOptCmp) . + expValAndOrCmp tryHard :: Int -> BoolExp (IExpr a) -> BoolExp (IExpr a) tryHard nvars e = - case optBoolExprQM nvars e of -- Don't try more than 8 variables. - Nothing -> {-trace ("tryHard too big " ++ ppReadable e) $ -} aSimplify e - Just e' -> {-trace (ppReadable(e, e')) -} e' + case optBoolExprQM nvars e of -- Don't try more than 8 variables. + Nothing -> {-trace ("tryHard too big " ++ ppReadable e) $ -} aSimplify e + Just e' -> {-trace (ppReadable(e, e')) -} e' fromBE :: BoolExp (IExpr a) -> IExpr a fromBE (And e1 e2) = ieAnd (fromBE e1) (fromBE e2) @@ -1506,73 +1506,73 @@ toBE (IAps (ICon _ (ICPrim _ PrimBOr)) _ [e1, e2]) = Or (toBE e1) (toBE e2) toBE (IAps (ICon _ (ICPrim _ PrimBNot)) _ [e]) = Not (toBE e) toBE (IAps (ICon _ (ICPrim _ PrimIf)) _ [e1,e2,e3]) = If (toBE e1) (toBE e2) (toBE e3) toBE e = - if e == iTrue then TT - else if e == iFalse then FF - else Var e + if e == iTrue then TT + else if e == iFalse then FF + else Var e -- A quick hack for optimizing comparisons sOptCmp :: IExpr a -> IExpr a sOptCmp e = let collEQs (IAps (ICon _ (ICPrim _ PrimBAnd)) _ [e1, e2]) = collEQs e1 ++ collEQs e2 - collEQs (IAps (ICon _ (ICPrim _ PrimEQ)) _ [v, ICon _ (ICInt { iVal = IntLit { ilValue = i } })]) = [(v, i)] - collEQs _ = [] - remNE vcs e@(IAps (ICon _ (ICPrim _ PrimEQ)) _ [v, ICon _ (ICInt { iVal = IntLit { ilValue = i } })]) = - case lookup v vcs of - Just i' | i /= i' -> iFalse - _ -> e - remNE vcs (IAps f ts es) = IAps f ts (map (remNE vcs) es) - remNE vcs e = e - - collTerms (IAps (ICon _ (ICPrim _ PrimBAnd)) _ [e1, e2]) = collTerms e1 ++ collTerms e2 - collTerms e = [e] - - remAbsurd e (IAps (ICon _ (ICPrim _ PrimBNot)) _ - [IAps (ICon _ (ICPrim _ PrimEQ)) _ - [v, ICon _ (ICInt { iConType = ITAp bit (ITNum vn), iVal = IntLit { ilValue = i } })]] : es) - | bit == itBit && vn <= 8 = loop ([0..2^vn-1] \\ [i]) es - where loop [] [] = iFalse - loop _ [] = e - loop is (IAps (ICon _ (ICPrim _ PrimBNot)) _ [IAps (ICon _ (ICPrim _ PrimEQ)) _ [v', ICon _ (ICInt { iVal = IntLit { ilValue = i } })]] : es) - | v == v' = loop (is \\ [i]) es - loop is (_:es) = loop is es - remAbsurd e (_:es) = remAbsurd e es - remAbsurd e [] = e - - remAbs e = remAbsurd e (collTerms e) + collEQs (IAps (ICon _ (ICPrim _ PrimEQ)) _ [v, ICon _ (ICInt { iVal = IntLit { ilValue = i } })]) = [(v, i)] + collEQs _ = [] + remNE vcs e@(IAps (ICon _ (ICPrim _ PrimEQ)) _ [v, ICon _ (ICInt { iVal = IntLit { ilValue = i } })]) = + case lookup v vcs of + Just i' | i /= i' -> iFalse + _ -> e + remNE vcs (IAps f ts es) = IAps f ts (map (remNE vcs) es) + remNE vcs e = e + + collTerms (IAps (ICon _ (ICPrim _ PrimBAnd)) _ [e1, e2]) = collTerms e1 ++ collTerms e2 + collTerms e = [e] + + remAbsurd e (IAps (ICon _ (ICPrim _ PrimBNot)) _ + [IAps (ICon _ (ICPrim _ PrimEQ)) _ + [v, ICon _ (ICInt { iConType = ITAp bit (ITNum vn), iVal = IntLit { ilValue = i } })]] : es) + | bit == itBit && vn <= 8 = loop ([0..2^vn-1] \\ [i]) es + where loop [] [] = iFalse + loop _ [] = e + loop is (IAps (ICon _ (ICPrim _ PrimBNot)) _ [IAps (ICon _ (ICPrim _ PrimEQ)) _ [v', ICon _ (ICInt { iVal = IntLit { ilValue = i } })]] : es) + | v == v' = loop (is \\ [i]) es + loop is (_:es) = loop is es + remAbsurd e (_:es) = remAbsurd e es + remAbsurd e [] = e + + remAbs e = remAbsurd e (collTerms e) in remAbs (remNE (collEQs e) e) aOptCmp :: IExpr a -> IExpr a aOptCmp e = - --trace ("optCmp:\n" ++ ppReadable e) $ - let (_, e') = optE M.empty e - in --(if e/=e' then traces (ppReadable (e, e')) else id) - e' + --trace ("optCmp:\n" ++ ppReadable e) $ + let (_, e') = optE M.empty e + in --(if e/=e' then traces (ppReadable (e, e')) else id) + e' optE :: ValMap a -> IExpr a -> (ValMap a, IExpr a) optE m e0@(IAps p@(ICon _ (ICPrim _ PrimBAnd)) ts [e1, e2]) = -- XXX this can't be the best way - let (m1, e2') = optE m e2 - (m2, e1') = optE m1 e1 - in if e1 /= e1' then - (m2, IAps p ts [e1', e2']) - else - let (m1, e1') = optE m e1 - (m2, e2') = optE m1 e2 - in (m2, IAps p ts [e1', e2']) + let (m1, e2') = optE m e2 + (m2, e1') = optE m1 e1 + in if e1 /= e1' then + (m2, IAps p ts [e1', e2']) + else + let (m1, e1') = optE m e1 + (m2, e2') = optE m1 e2 + in (m2, IAps p ts [e1', e2']) optE m e@(IAps p@(ICon _ (ICPrim _ cmp)) _ [v, ICon _ (ICInt { iConType = t, iVal = IntLit { ilValue = i } })]) | isCmp cmp && mn /= Nothing = - doCmp m e cmp v n i True + doCmp m e cmp v n i True where mn = getBit t - Just n = mn + Just n = mn optE m e@(IAps (ICon _ (ICPrim _ PrimBNot)) _ - [IAps p@(ICon _ (ICPrim _ cmp)) ts [v, ICon _ (ICInt { iConType = t, iVal = IntLit { ilValue = i } })]]) | isCmp cmp && mn /= Nothing = - doCmp m e cmp v n i False + [IAps p@(ICon _ (ICPrim _ cmp)) ts [v, ICon _ (ICInt { iConType = t, iVal = IntLit { ilValue = i } })]]) | isCmp cmp && mn /= Nothing = + doCmp m e cmp v n i False where mn = getBit t - Just n = mn + Just n = mn optE m e = - case vsGetSingleton e m of - Nothing -> (m, e) - Just i -> (m, iMkLit (iGetType e) i) + case vsGetSingleton e m of + Nothing -> (m, e) + Just i -> (m, iMkLit (iGetType e) i) type ValMap a = M.Map (IExpr a) ValueSet @@ -1591,14 +1591,14 @@ type ValueSet = VSetInteger vsUniv :: IExpr a -> ValueSet vsUniv (ICon i (ICValue { iValDef = IAps (ICon _ (ICPrim _ PrimRange)) _ - [ICon _ (ICInt { iVal = IntLit { ilValue = lo } }), ICon _ (ICInt { iVal = IntLit { ilValue = hi } }), _] })) = - --traces ("interval " ++ ppReadable (i,lo,hi)) $ - vFromTo lo hi + [ICon _ (ICInt { iVal = IntLit { ilValue = lo } }), ICon _ (ICInt { iVal = IntLit { ilValue = hi } }), _] })) = + --traces ("interval " ++ ppReadable (i,lo,hi)) $ + vFromTo lo hi vsUniv e = - --traces ("nointerval " ++ ppReadable e) $ - case getBit (iGetType e) of - Just n -> vFromTo 0 (2^n-1) - Nothing -> internalError "vsUniv" + --traces ("nointerval " ++ ppReadable e) $ + case getBit (iGetType e) of + Just n -> vFromTo 0 (2^n-1) + Nothing -> internalError "vsUniv" vsGetSingleton e m = case M.lookup e m of @@ -1622,18 +1622,18 @@ cmpToVS _ _ _ prim = doCmp :: ValMap a -> IExpr a -> PrimOp -> IExpr a -> Integer -> Integer -> Bool -> (ValMap a,IExpr a) doCmp m e cmp v n i norm = - let vs = vmGet v m - tvs = cmpToVS n i norm cmp - fvs = cmpToVS n i (not norm) cmp - vs' = vs `vIntersect` tvs - ivs = vs `vIntersect` fvs - m' = vmAdd v vs' m - in if vNull ivs && not (vNull vs') then - (m', iTrue) - else if vNull vs' && not (vNull ivs) then - (m', iFalse) - else - (m', e) + let vs = vmGet v m + tvs = cmpToVS n i norm cmp + fvs = cmpToVS n i (not norm) cmp + vs' = vs `vIntersect` tvs + ivs = vs `vIntersect` fvs + m' = vmAdd v vs' m + in if vNull ivs && not (vNull vs') then + (m', iTrue) + else if vNull vs' && not (vNull ivs) then + (m', iFalse) + else + (m', e) getBit :: IType -> Maybe Integer getBit (ITAp b (ITNum n)) | b == itBit = Just n @@ -1741,4 +1741,3 @@ iTransRenameId rename_map name = Nothing -> name ----------------------------------------------------------------------------- - diff --git a/src/comp/InferKind.hs b/src/comp/InferKind.hs index c90628013..4cf6cba2a 100644 --- a/src/comp/InferKind.hs +++ b/src/comp/InferKind.hs @@ -18,15 +18,15 @@ import PFPrint inferKinds :: Id -> SymTab -> [CDefn] -> Either EMsg (M.Map Id Kind) inferKinds mi s ds = run $ do let get (Ctype ik _ _) = getIK ik - get (Cdata { cd_name = name }) = getIK name - get (Cstruct _ _ ik _ _ _) = getIK ik - get (Cclass _ _ ik _ _ _) = getIK ik - get (CItype ik _ _) = getIK ik - get (CIclass _ _ ik _ _ _) = getIK ik - get (CprimType ik) = getIK ik - get _ = return [] - getIK (IdK i) = do v <- newKVar (Just i); return [(i, v)] - getIK (IdKind i k) = return [(i, k)] + get (Cdata { cd_name = name }) = getIK name + get (Cstruct _ _ ik _ _ _) = getIK ik + get (Cclass _ _ ik _ _ _) = getIK ik + get (CItype ik _ _) = getIK ik + get (CIclass _ _ ik _ _ _) = getIK ik + get (CprimType ik) = getIK ik + get _ = return [] + getIK (IdK i) = do v <- newKVar (Just i); return [(i, v)] + getIK (IdKind i k) = return [(i, k)] getIK (IdPKind i pk) = do k <- convertPKindToKind pk; return [(i, k)] ass <- mapM get ds -- assumptions about the types defined in this package @@ -35,10 +35,10 @@ inferKinds mi s ds = run $ do -- and the assumps about types from imported packages (the symtab) -- XXX this relies on the order of M.fromList, to bias earlier pairs let as' = -- place these first, so that they are shadowed by - -- any assumps of the same name in "as" - [(i, k) | (i, TypeInfo _ k _ _) <- getAllTypes s ] ++ + -- any assumps of the same name in "as" + [(i, k) | (i, TypeInfo _ k _ _) <- getAllTypes s ] ++ as ++ - map (\ (n,v) -> (qualId mi n, v)) as + map (\ (n,v) -> (qualId mi n, v)) as let as_map = M.fromList as' mapM_ (inferKDefn as_map) ds s <- getKSubst @@ -79,9 +79,9 @@ inferKDefn as (Cstruct _ _ ik vs fs _) = do (as', mk) <- unifyDefArgs i con_k vs let as'' = map_insertMany as' as doField field = do - let vs' = getFQTyVarsL (cf_type field) \\ vs - as''' <- mapM makeAssump vs' - kcCQTypeStar (map_insertMany as''' as'') (cf_type field) + let vs' = getFQTyVarsL (cf_type field) \\ vs + as''' <- mapM makeAssump vs' + kcCQTypeStar (map_insertMany as''' as'') (cf_type field) mapM_ doField fs unifyDefStar i con_k as' mk inferKDefn as (Cclass _ ps ik vs _ fs) = do @@ -94,9 +94,9 @@ inferKDefn as (Cclass _ ps ik vs _ fs) = do pv_as <- mapM makeAssump pvs let as' = map_insertMany (v_as ++ pv_as) as doField field = do - let fvs = getFQTyVarsL (cf_type field) \\ (vs ++ pvs) - fv_as <- mapM makeAssump fvs - kcCQTypeStar (map_insertMany fv_as as') (cf_type field) + let fvs = getFQTyVarsL (cf_type field) \\ (vs ++ pvs) + fv_as <- mapM makeAssump fvs + kcCQTypeStar (map_insertMany fv_as as') (cf_type field) mapM_ doField fs mapM_ (inferCPred as') ps unifyDefStar i con_k v_as mk diff --git a/src/comp/InlineReg.hs b/src/comp/InlineReg.hs index e11f1307a..02f38f5a3 100644 --- a/src/comp/InlineReg.hs +++ b/src/comp/InlineReg.hs @@ -1,7 +1,7 @@ module InlineReg ( - vInlineReg, - RegInstInfo - ) where + vInlineReg, + RegInstInfo + ) where import Data.List(partition) import qualified Data.Map as M @@ -31,32 +31,32 @@ vInlineReg :: ErrorHandle -> Flags -> [AVInst] -> ([VMItem], [RegInstInfo]) vInlineReg errh flags avis = let vco = flagsToVco flags - -- separate the RegAs from the RegN and RegUN - (regas, regns_and_reguns) = partition isRegA avis + -- separate the RegAs from the RegN and RegUN + (regas, regns_and_reguns) = partition isRegA avis - -- make a map from clock to the RegNs and RegUNs in that clock - ns_and_uns_by_clock = M.toList (partitionByClock errh regns_and_reguns) + -- make a map from clock to the RegNs and RegUNs in that clock + ns_and_uns_by_clock = M.toList (partitionByClock errh regns_and_reguns) - -- translate the partitioned RegN/RegUNs into always blocks - ns_and_uns_items = map (vInlineN errh vco) ns_and_uns_by_clock + -- translate the partitioned RegN/RegUNs into always blocks + ns_and_uns_items = map (vInlineN errh vco) ns_and_uns_by_clock - -- make a map from clock and reset to the RegAs for that pair - as_by_clock_and_reset = M.toList (partitionByClockAndReset errh regas) + -- make a map from clock and reset to the RegAs for that pair + as_by_clock_and_reset = M.toList (partitionByClockAndReset errh regas) - -- translate the partitioned RegAs into always blocks - as_items = map (vInlineA vco) as_by_clock_and_reset + -- translate the partitioned RegAs into always blocks + as_items = map (vInlineA vco) as_by_clock_and_reset - -- All the registers should all be set in an initial block -- - -- there is no guarantee that they will be reset properly - initial = mkInitialAssignments flags avis + -- All the registers should all be set in an initial block -- + -- there is no guarantee that they will be reset properly + initial = mkInitialAssignments flags avis - -- the list of items to return - items = ns_and_uns_items ++ as_items ++ initial + -- the list of items to return + items = ns_and_uns_items ++ as_items ++ initial - -- the register I/O info for AVerilog grouping - reg_infos = map (mkRegInstInfo errh flags) avis + -- the register I/O info for AVerilog grouping + reg_infos = map (mkRegInstInfo errh flags) avis in - (items, reg_infos) + (items, reg_infos) -- ============================== @@ -75,26 +75,26 @@ mkRegInstInfo :: ErrorHandle -> Flags -> AVInst -> RegInstInfo mkRegInstInfo errh flags avi = let vco = flagsToVco flags reg_id = vId (mkQOUT avi) - din_id = vId (mkDIN avi) - en_id = vId (mkEN avi) - reg_size = case (getRegWidth avi) of - (ASInt _ _ (IntLit _ _ n)) -> vSize (ATBit n) - -- the parameter expression should be constant - e -> internalError ("mkRegInstInfo: " ++ ppReadable e) - en_size = Nothing -- no range means one bit - -- find the special inputs (note that RegUN doesn't have a RST) - clk_expr = vExpr vco (getRegClock errh avi) - rstn_expr = vExpr vco (getRegReset errh avi) - non_method_ports = if (isRegUN avi) - then [clk_expr] - else [clk_expr, rstn_expr] - inst_id = avi_vname avi + din_id = vId (mkDIN avi) + en_id = vId (mkEN avi) + reg_size = case (getRegWidth avi) of + (ASInt _ _ (IntLit _ _ n)) -> vSize (ATBit n) + -- the parameter expression should be constant + e -> internalError ("mkRegInstInfo: " ++ ppReadable e) + en_size = Nothing -- no range means one bit + -- find the special inputs (note that RegUN doesn't have a RST) + clk_expr = vExpr vco (getRegClock errh avi) + rstn_expr = vExpr vco (getRegReset errh avi) + non_method_ports = if (isRegUN avi) + then [clk_expr] + else [clk_expr, rstn_expr] + inst_id = avi_vname avi in ((VId (getIdString inst_id) inst_id Nothing), (getVNameString (vName (avi_vmi avi))), -- name of the def (RegN, RegUN etc.) - non_method_ports, - [(din_id, reg_size), (en_id, en_size)], - (reg_id, reg_size)) + non_method_ports, + [(din_id, reg_size), (en_id, en_size)], + (reg_id, reg_size)) -- ============================== @@ -102,52 +102,52 @@ mkRegInstInfo errh flags avi = vInlineN :: ErrorHandle -> VConvtOpts -> (AExpr, [AVInst]) -> VMItem vInlineN errh vco (clk, avis) = let - -- partition the avis into those with resets and those without - (regns, reguns) = partition isRegN avis + -- partition the avis into those with resets and those without + (regns, reguns) = partition isRegN avis - -- partition the RegNs by reset - regns_by_reset = partitionByReset errh regns + -- partition the RegNs by reset + regns_by_reset = partitionByReset errh regns - -- translate into statements inside the always block - body_items = - -- put a comment here "initialized registers" - map (translateRegN vco) (M.toList regns_by_reset) ++ - -- put a comment here "uninitialized registers" - map (translateRegUN vco) reguns + -- translate into statements inside the always block + body_items = + -- put a comment here "initialized registers" + map (translateRegN vco) (M.toList regns_by_reset) ++ + -- put a comment here "uninitialized registers" + map (translateRegUN vco) reguns - -- event for the surrounding always block - ev = VEEposedge (vExpr vco clk) + -- event for the surrounding always block + ev = VEEposedge (vExpr vco clk) - -- use VSeq (not vSeq) so that the always block always has - -- begin/end, even when there is only one item inside it - stmt = Valways $ VAt ev $ VSeq body_items + -- use VSeq (not vSeq) so that the always block always has + -- begin/end, even when there is only one item inside it + stmt = Valways $ VAt ev $ VSeq body_items in - VMStmt { vi_translate_off = False, vi_body = stmt } + VMStmt { vi_translate_off = False, vi_body = stmt } -- generate an always block for all RegA on the same clock and reset vInlineA :: VConvtOpts -> ((AExpr, AExpr), [AVInst]) -> VMItem vInlineA vco ((clk, rstn), avis) = let - -- create the conditional inside the always block - -- (same body item as RegN!) - body_item = translateRegN vco (rstn, avis) - - -- event for the surrounding always block - ev = let v_rstn = vExpr vco rstn - v_clk = vExpr vco clk - in case (v_rstn) of - VEWConst _ _ _ v -> - if (v == 1) - then VEEposedge v_clk - else internalError - "vInlineA: unexpected constant rstn value" - _ -> VEEOr (VEEposedge v_clk) (mkEdgeReset v_rstn) + -- create the conditional inside the always block + -- (same body item as RegN!) + body_item = translateRegN vco (rstn, avis) + + -- event for the surrounding always block + ev = let v_rstn = vExpr vco rstn + v_clk = vExpr vco clk + in case (v_rstn) of + VEWConst _ _ _ v -> + if (v == 1) + then VEEposedge v_clk + else internalError + "vInlineA: unexpected constant rstn value" + _ -> VEEOr (VEEposedge v_clk) (mkEdgeReset v_rstn) -- this body has no begin/end because it is an if-stmt; - stmt = Valways $ VAt ev $ body_item + stmt = Valways $ VAt ev $ body_item in - VMStmt { vi_translate_off = False, vi_body = stmt } + VMStmt { vi_translate_off = False, vi_body = stmt } -- Assign an initial (debug) value to all RegUN @@ -155,26 +155,26 @@ mkInitialAssignments :: Flags -> [AVInst] -> [VMItem] mkInitialAssignments flags [] = [] mkInitialAssignments flags avis = let - -- make the assignment for one reg + -- make the assignment for one reg mkInit :: AVInst -> VStmt - mkInit avi = - let id = (mkQOUT avi) - -- tag the VId with the instance that would have existed without inlining. + mkInit avi = + let id = (mkQOUT avi) + -- tag the VId with the instance that would have existed without inlining. -- XXX we pass in an empty rewiring map because registers have no inouts - (_, vminst, _) = vState flags M.empty avi - qout = VLId (VId (getIdString id) id (Just vminst)) - val = case (getRegWidth avi) of - ASInt { ae_ival = IntLit { ilValue = width } } - -> let val = aaaa width - -- XXX use the ASInt ae_objid? - id = mkVId (itos val) - in VEWConst id width 16 val - e -> internalError ("mkInit: " ++ ppDebug e) - in VAssign qout val - - -- use VSeq (not vSeq) so that the initial block always has - -- begin/end, even when there is only one item inside it - stmt = Vinitial $ VSeq $ map mkInit avis + (_, vminst, _) = vState flags M.empty avi + qout = VLId (VId (getIdString id) id (Just vminst)) + val = case (getRegWidth avi) of + ASInt { ae_ival = IntLit { ilValue = width } } + -> let val = aaaa width + -- XXX use the ASInt ae_objid? + id = mkVId (itos val) + in VEWConst id width 16 val + e -> internalError ("mkInit: " ++ ppDebug e) + in VAssign qout val + + -- use VSeq (not vSeq) so that the initial block always has + -- begin/end, even when there is only one item inside it + stmt = Vinitial $ VSeq $ map mkInit avis in [VMStmt { vi_translate_off = True, vi_body = stmt }] @@ -182,38 +182,38 @@ mkInitialAssignments flags avis = -- make the conditional enable assignment to a register mkENAssignment avi = let en = VEVar (vId (mkEN avi)) - qout = VLId (vId (mkQOUT avi)) - din = VEVar (vId (mkDIN avi)) + qout = VLId (vId (mkQOUT avi)) + din = VEVar (vId (mkDIN avi)) in - Vif en (VAssignA qout din) + Vif en (VAssignA qout din) -- make the assignment on reset (to be put inside a conditional) mkRSTAssignment vco avi = let qout = VLId (vId (mkQOUT avi)) - init_val = vExpr vco (getRegInit avi) + init_val = vExpr vco (getRegInit avi) in - VAssignA qout init_val + VAssignA qout init_val translateRegN :: VConvtOpts -> (AExpr, [AVInst]) -> VStmt translateRegN vco (rstn, avis) = let - -- the assignments on reset - rstn_items = map (mkRSTAssignment vco) avis + -- the assignments on reset + rstn_items = map (mkRSTAssignment vco) avis - -- the assignments on enable - en_items = map mkENAssignment avis + -- the assignments on enable + en_items = map mkENAssignment avis - -- RST == `BSV_RESET_VALUE - v_rstn = vExpr vco rstn - v_rst = mkEqualsReset v_rstn + -- RST == `BSV_RESET_VALUE + v_rstn = vExpr vco rstn + v_rst = mkEqualsReset v_rstn in - case (v_rstn) of - VEWConst _ _ _ v -> - if (v == 1) - then vSeq en_items - else internalError - "translateRegN: unexpected constant rstn value" - _ -> Vifelse v_rst (vSeq rstn_items) (vSeq en_items) + case (v_rstn) of + VEWConst _ _ _ v -> + if (v == 1) + then vSeq en_items + else internalError + "translateRegN: unexpected constant rstn value" + _ -> Vifelse v_rst (vSeq rstn_items) (vSeq en_items) translateRegUN :: VConvtOpts -> AVInst -> VStmt translateRegUN vco avi = mkENAssignment avi diff --git a/src/comp/InlineWires.hs b/src/comp/InlineWires.hs index 65ee6e289..9c8fabdd2 100644 --- a/src/comp/InlineWires.hs +++ b/src/comp/InlineWires.hs @@ -57,71 +57,71 @@ import Flags(Flags, removeCross) aInlineWires :: Flags -> ASPackage -> (ASPackage, [WMsg], [EMsg]) aInlineWires flags pkg@(ASPackage { aspkg_state_instances = vs, aspkg_state_outputs = svars, - aspkg_values = defs, - aspkg_signal_info = si }) = + aspkg_values = defs, + aspkg_signal_info = si }) = -- trace (ppReadable rws ++ ppReadable ds) $ (aSubst rmap (pkg { aspkg_state_instances = nonwire_vs, - aspkg_state_outputs = nonwire_svars, - aspkg_values = (defs' ++ newdefs), - aspkg_inlined_ports = ws', - aspkg_signal_info = si' }), + aspkg_state_outputs = nonwire_svars, + aspkg_values = (defs' ++ newdefs), + aspkg_inlined_ports = ws', + aspkg_signal_info = si' }), warnings, errors) where -- definition map (id -> value) defmap = M.fromList [(i, e) | (ADef i _t e _) <- defs] defset = M.keysSet defmap - -- find the RWires and RWire0s, and the remaining + -- find the RWires and RWire0s, and the remaining -- instances which we will leave in the package - (rws, vs') = partition isRWire vs - (rw0s, nonrwire_vs) = partition isRWire0 vs' + (rws, vs') = partition isRWire vs + (rw0s, nonrwire_vs) = partition isRWire0 vs' (bw0s, nonrwire_vs') = partition isBypassWire0 nonrwire_vs should_inline_bw x = isBypassWire x && ((not (isClockCrossingBypassWire x)) || (removeCross flags)) (bws, nonwire_vs) = partition should_inline_bw nonrwire_vs' - -- for each RWire instance, make a tuple of: - -- * the instance name - -- * the instance outputs (whas and possibly wget) - -- * any new defs (only if the value is constant) + -- for each RWire instance, make a tuple of: + -- * the instance name + -- * the instance outputs (whas and possibly wget) + -- * any new defs (only if the value is constant) -- * any substitutions on the defs (e.g. replace wsetEn with whas) -- * any warnings to trigger -- * any errors to trigger - rwire_tuples = map mkRW rws ++ map mkRW0 rw0s ++ + rwire_tuples = map mkRW rws ++ map mkRW0 rw0s ++ map mkBW bws ++ map mkBW0 bw0s - -- record the rwire output port names in ws - ws' = concatMap (\(a,b,c,d,e,f) -> b) rwire_tuples + -- record the rwire output port names in ws + ws' = concatMap (\(a,b,c,d,e,f) -> b) rwire_tuples - -- record the signal info for RTL grouping - rwire_signal_info = map (\(a,b,c,d,e,f) -> (a,"RWire",b)) rwire_tuples - si_ips = aspsi_inlined_ports si - si' = si { aspsi_inlined_ports = rwire_signal_info ++ si_ips } + -- record the signal info for RTL grouping + rwire_signal_info = map (\(a,b,c,d,e,f) -> (a,"RWire",b)) rwire_tuples + si_ips = aspsi_inlined_ports si + si' = si { aspsi_inlined_ports = rwire_signal_info ++ si_ips } -- XXX this traverses the package once for every inlines wire -- for performance the sub should be aggregated into a map - -- perform the substitutions - -- to rename input port defs with the output names - renameADef s d@(ADef { adef_objid = i }) = - case (lookup i s) of - Nothing -> d - Just new_i -> d { adef_objid = new_i } - name_subst = concatMap (\(a,b,c,d,e,f) -> d) rwire_tuples - defs' = map (renameADef name_subst) defs - - -- any new definitions + -- perform the substitutions + -- to rename input port defs with the output names + renameADef s d@(ADef { adef_objid = i }) = + case (lookup i s) of + Nothing -> d + Just new_i -> d { adef_objid = new_i } + name_subst = concatMap (\(a,b,c,d,e,f) -> d) rwire_tuples + defs' = map (renameADef name_subst) defs + + -- any new definitions -- (to constants, when the input port was dangling) - newdefs = concatMap (\(a,b,c,d,e,f) -> c) rwire_tuples + newdefs = concatMap (\(a,b,c,d,e,f) -> c) rwire_tuples - -- ----- + -- ----- warnings = concatMap (\(a,b,c,d,e,f) -> e) rwire_tuples errors = concatMap (\(a,b,c,d,e,f) -> f) rwire_tuples - -- since the RWire output ports are now defined locally and are - -- not outputs of modules anymore, remove them from the svars list - (wire_svars, nonwire_svars) = - partition (\(i,t) -> i `elem` ws') svars + -- since the RWire output ports are now defined locally and are + -- not outputs of modules anymore, remove them from the svars list + (wire_svars, nonwire_svars) = + partition (\(i,t) -> i `elem` ws') svars - -- create a map of the rwire values methods to the signals which - -- now carry their values (whether new def or subst of existing def) - -- (this will be used to replace ASPort uses with ASDef uses) + -- create a map of the rwire values methods to the signals which + -- now carry their values (whether new def or subst of existing def) + -- (this will be used to replace ASPort uses with ASDef uses) rmap = M.fromList [(i, ASDef t i) | (i, t) <- wire_svars] -- functions for making the defs for RWire and BypassWire @@ -130,8 +130,8 @@ aInlineWires flags pkg@(ASPackage { aspkg_state_instances = vs, mkRW :: AVInst -> (AId,[AId],[ADef],[(AId,AId)],[WMsg],[EMsg]) mkRW (AVInst { avi_vname=i, - avi_iargs=(ASInt _ _ (IntLit _ _ n) : _) }) = rw_defs i n False False - mkRW (x@(_)) = internalError ("aRWire.mkRW: " ++ ppReadable x) + avi_iargs=(ASInt _ _ (IntLit _ _ n) : _) }) = rw_defs i n False False + mkRW (x@(_)) = internalError ("aRWire.mkRW: " ++ ppReadable x) mkBW0 :: AVInst -> (AId,[AId],[ADef],[(AId,AId)],[WMsg],[EMsg]) mkBW0 (AVInst { avi_vname=i }) = rw_defs i 0 False True @@ -151,46 +151,46 @@ aInlineWires flags pkg@(ASPackage { aspkg_state_instances = vs, -- a substitution (to replace ASVar by ASDef where necessary) -- any warnings encountered (i.e. enables not night) rw_defs :: AId -> ASize -> Bool -> Bool -> (AId, [AId], [ADef], [(AId, AId)], [WMsg], [EMsg]) - rw_defs i sz is_rwire0 always_en = - let - -- the rwire inputs - rw_en_id = rwireSetEnId i - rw_data_id = rwireSetArgId i - -- the rwire outputs - rw_has_id = rwireHasResId i - rw_get_id = rwireGetResId i + rw_defs i sz is_rwire0 always_en = + let + -- the rwire inputs + rw_en_id = rwireSetEnId i + rw_data_id = rwireSetArgId i + -- the rwire outputs + rw_has_id = rwireHasResId i + rw_get_id = rwireGetResId i -- we no longer report EEnableNotHigh or EEnableAlwaysLow, -- as always_enabled property is now checked in AAddScheduleDefs (wmsg, emsg) = ([], []) - -- what signal names are defined locally - -- if set enable is not defined, then whas is constant False - (whas_def, whas_subst) = + -- what signal names are defined locally + -- if set enable is not defined, then whas is constant False + (whas_def, whas_subst) = if always_en then -- no definition or substitution if always_enabled ([], []) - else if (rw_en_id `S.member` defset) then - ([], [(rw_en_id, rw_has_id)]) - else - ([ADef rw_has_id (ATBit 1) aFalse []], []) + else if (rw_en_id `S.member` defset) then + ([], [(rw_en_id, rw_has_id)]) + else + ([ADef rw_has_id (ATBit 1) aFalse []], []) -- even if the enable has been defined, the data might not be -- there because the RWire is never set or because the data -- size is 0 (though that is probably unnecessary paranoia) - (wget_def, wget_subst) = + (wget_def, wget_subst) = if (is_rwire0) then ([], []) else if (rw_data_id `S.member` defset) then - ([], [(rw_data_id, rw_get_id)]) - else - ([ADef rw_get_id (ATBit sz) (ASAny (ATBit sz) Nothing) []], - []) - -- the output names - outputs = + ([], [(rw_data_id, rw_get_id)]) + else + ([ADef rw_get_id (ATBit sz) (ASAny (ATBit sz) Nothing) []], + []) + -- the output names + outputs = -- wget (if is_rwire0 then [] else [rw_get_id]) ++ -- whas (if always_en then [] else [rw_has_id]) - in - (i, outputs, whas_def ++ wget_def, whas_subst ++ wget_subst, wmsg, emsg) + in + (i, outputs, whas_def ++ wget_def, whas_subst ++ wget_subst, wmsg, emsg) diff --git a/src/comp/InstNodes.hs b/src/comp/InstNodes.hs index 15ceed60b..867ae6507 100644 --- a/src/comp/InstNodes.hs +++ b/src/comp/InstNodes.hs @@ -282,7 +282,7 @@ isHidden' True _ _ = False isHidden' _ _ y | isUniquifier True y = False isHidden' _ True y@(Loc {node_name = i }) |isHideId i = case (M.elems $ node_children y) of - [StateVar {}] -> False + [StateVar {}] -> False _ -> True isHidden' _ False y@(Loc {node_name = i })| isHideId i = True isHidden' _ _ Loc {node_type = (Just t)} | isGeneratedIfc t = True diff --git a/src/comp/IntLit.hs b/src/comp/IntLit.hs index 43ef6069a..4b02e937b 100644 --- a/src/comp/IntLit.hs +++ b/src/comp/IntLit.hs @@ -63,7 +63,7 @@ instance Hyper IntLit where instance PVPrint IntLit where pvPrint d p (IntLit { ilValue = i, ilWidth = w, ilBase = b }) = - text $ intFormat w b i + text $ intFormat w b i intFormat :: Maybe Integer -> Integer -> Integer -> String intFormat mwidth base value | value < 0 = '-' : intFormat mwidth base (-value) diff --git a/src/comp/IntegerUtil.hs b/src/comp/IntegerUtil.hs index be738e2a0..e64481282 100644 --- a/src/comp/IntegerUtil.hs +++ b/src/comp/IntegerUtil.hs @@ -1,5 +1,5 @@ module IntegerUtil(mask, ext, integerFormat, integerFormatPref, - integerInvert, integerXor, integerSelect, aaaa, + integerInvert, integerXor, integerSelect, aaaa, integerAnd, integerOr, integerToString) where import ErrorUtil(internalError) @@ -12,9 +12,9 @@ aaaa 1 = 0 aaaa 2 = 2 aaaa 3 = 2 aaaa sz | sz >= 4 = let higher_bits = (aaaa (sz - 4)) - lower_bits = 10 - offset = (2 :: Integer) ^ (4 :: Integer) - in (offset * higher_bits) + lower_bits + lower_bits = 10 + offset = (2 :: Integer) ^ (4 :: Integer) + in (offset * higher_bits) + lower_bits aaaa _ = internalError "aaaa not defined for negative sizes" {- @@ -44,34 +44,34 @@ integerInvert x = -x - 1 integerAnd :: Integer -> Integer -> Integer integerAnd x y = loop 1 0 x y where loop :: Integer -> Integer -> Integer -> Integer -> Integer - loop bit acc x y = - if x == 0 || y == 0 then - acc - else if x == -1 && y == -1 then - -bit + acc - else - let (x', xb) = divMod x 2 - (y', yb) = divMod y 2 - in if xb == 1 && yb == 1 then - loop (bit*2) (acc+bit) x' y' - else - loop (bit*2) acc x' y' + loop bit acc x y = + if x == 0 || y == 0 then + acc + else if x == -1 && y == -1 then + -bit + acc + else + let (x', xb) = divMod x 2 + (y', yb) = divMod y 2 + in if xb == 1 && yb == 1 then + loop (bit*2) (acc+bit) x' y' + else + loop (bit*2) acc x' y' integerOr :: Integer -> Integer -> Integer integerOr x y = loop 1 0 x y where loop :: Integer -> Integer -> Integer -> Integer -> Integer - loop bit acc x y = - if x == 0 && y == 0 then - acc - else if x == -1 || y == -1 then - -bit + acc - else - let (x', xb) = divMod x 2 - (y', yb) = divMod y 2 - in if xb == 1 || yb == 1 then - loop (bit*2) (acc+bit) x' y' - else - loop (bit*2) acc x' y' + loop bit acc x y = + if x == 0 && y == 0 then + acc + else if x == -1 || y == -1 then + -bit + acc + else + let (x', xb) = divMod x 2 + (y', yb) = divMod y 2 + in if xb == 1 || yb == 1 then + loop (bit*2) (acc+bit) x' y' + else + loop (bit*2) acc x' y' integerXor :: Integer -> Integer -> Integer integerXor x y = (x `integerOr` y) `integerAnd` integerInvert (x `integerAnd` y) @@ -83,14 +83,14 @@ integerSelect k m i = internalError ("integerSelect " ++ show (k, m, i)) integerFormat :: Integer -> Integer -> Integer -> String integerFormat width base value = - if value < 0 then - '-' : integerFormat width base (-value) - else - let s = integerToString (fromInteger base) value - l = length s - w = fromInteger width - pad = if l < w then replicate (w-l) '0' else "" - in pad ++ s + if value < 0 then + '-' : integerFormat width base (-value) + else + let s = integerToString (fromInteger base) value + l = length s + w = fromInteger width + pad = if l < w then replicate (w-l) '0' else "" + in pad ++ s integerFormatPref :: Integer -> Integer -> Integer -> String integerFormatPref width 2 value = "0b" ++ integerFormat width 2 value @@ -102,14 +102,14 @@ integerFormatPref width _ value = integerFormatPref width 10 value integerToString :: Int -> Integer -> String integerToString b i | b < 2 = error "integerToString: base must be >= 2" - | i < 0 = '-' : showIntBase (toInteger b) (negate i) "" - | otherwise = showIntBase (toInteger b) i "" + | i < 0 = '-' : showIntBase (toInteger b) (negate i) "" + | otherwise = showIntBase (toInteger b) i "" -- mostly duplicates the function in the Prelude from the Haskell 98 Report showIntBase b n r | n < 0 = error "Numeric.showInt: can't show negative numbers" - | otherwise = - let (n',d) = quotRem n b - r' = digit d : r - digit d | d < 10 = toEnum (fromEnum '0' + fromIntegral d) - | otherwise = toEnum (fromEnum 'A' + fromIntegral d - 10) - in if n' == 0 then r' else showIntBase b n' r' + | otherwise = + let (n',d) = quotRem n b + r' = digit d : r + digit d | d < 10 = toEnum (fromEnum '0' + fromIntegral d) + | otherwise = toEnum (fromEnum 'A' + fromIntegral d - 10) + in if n' == 0 then r' else showIntBase b n' r' diff --git a/src/comp/Intervals.hs b/src/comp/Intervals.hs index 0d9559869..8d018c276 100644 --- a/src/comp/Intervals.hs +++ b/src/comp/Intervals.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} module Intervals(VSetInteger, vEmpty, vSing, vFromTo, vGetSing, - vCompRange, vUnion, vIntersect, vNull) where + vCompRange, vUnion, vIntersect, vNull) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804) import Prelude hiding ((<>)) @@ -14,10 +14,10 @@ data IVal = IVal Integer Integer instance PPrint IVal where pPrint d _ (IVal l h) = - if l == h then - text "[" <> pPrint d 0 l <> text "]" - else - text "[" <> pPrint d 0 l <> text ".." <> pPrint d 0 h <> text "]" + if l == h then + text "[" <> pPrint d 0 l <> text "]" + else + text "[" <> pPrint d 0 l <> text ".." <> pPrint d 0 h <> text "]" -- A set of values is represented as a list of ordered, non-overlapping intervals newtype VSetInteger = VSet [IVal] @@ -54,23 +54,23 @@ vFromTo i j = VSet [IVal i j] vUnionI :: IVal -> VSetInteger -> VSetInteger vUnionI (IVal l h) (VSet is) = VSet (add l h is) where add l h [] = [IVal l h] - add l h (i@(IVal vl vh) : is) = - if vl <= l then - if vh < l then - coal (i : add l h is) -- (l,h) above i - else if vh < h then - add vl h is -- (l,h) overlaps i - else - i : is -- (l,h) contained in i - else if vl > h then - coal (IVal l h : i : is)-- (l,h) below i - else - if vh <= h then - add l h is -- (l,h) contains i - else - add l vh is -- (l,h) overlaps i - coal (IVal l1 h1 : IVal l2 h2 : is) | h1+1 == l2 = IVal l1 h2 : is - coal is = is + add l h (i@(IVal vl vh) : is) = + if vl <= l then + if vh < l then + coal (i : add l h is) -- (l,h) above i + else if vh < h then + add vl h is -- (l,h) overlaps i + else + i : is -- (l,h) contained in i + else if vl > h then + coal (IVal l h : i : is)-- (l,h) below i + else + if vh <= h then + add l h is -- (l,h) contains i + else + add l vh is -- (l,h) overlaps i + coal (IVal l1 h1 : IVal l2 h2 : is) | h1+1 == l2 = IVal l1 h2 : is + coal is = is vUnion :: VSetInteger -> VSetInteger -> VSetInteger vUnion (VSet is) vs = foldr vUnionI vs is @@ -78,21 +78,21 @@ vUnion (VSet is) vs = foldr vUnionI vs is vIntersectI :: IVal -> VSetInteger -> VSetInteger vIntersectI (IVal l h) (VSet is) = VSet (sub l h is) where sub l h [] = [] - sub l h (i@(IVal vl vh) : is) = - if vl <= l then - if vh < l then - sub l h is -- (l,h) above i - else if vh < h then - IVal l vh : sub l h is -- (l,h) overlaps i - else - [IVal l h] -- (l,h) contained in i - else if vl > h then - [] - else - if vh <= h then - i : sub l h is -- (l,h) contains i - else - [IVal vl h] -- (l,h) overlaps i + sub l h (i@(IVal vl vh) : is) = + if vl <= l then + if vh < l then + sub l h is -- (l,h) above i + else if vh < h then + IVal l vh : sub l h is -- (l,h) overlaps i + else + [IVal l h] -- (l,h) contained in i + else if vl > h then + [] + else + if vh <= h then + i : sub l h is -- (l,h) contains i + else + [IVal vl h] -- (l,h) overlaps i vIntersect :: VSetInteger -> VSetInteger -> VSetInteger vIntersect (VSet is) vs = foldr (\ i -> vUnion (vIntersectI i vs)) vEmpty is diff --git a/src/comp/KIMisc.hs b/src/comp/KIMisc.hs index 491aaf431..78e4d8ae1 100644 --- a/src/comp/KIMisc.hs +++ b/src/comp/KIMisc.hs @@ -1,9 +1,9 @@ {-# LANGUAGE CPP #-} module KIMisc( - KVar, KSubst, apKSu, - KI, run, err, newKVar, getKSubst, + KVar, KSubst, apKSu, + KI, run, err, newKVar, getKSubst, unifyType, unifyFunc, unifyDefArgs, unifyDefAlias, unifyDefStar, - groundK) where + groundK) where import Data.List(union) import Data.Maybe(fromMaybe) @@ -126,10 +126,10 @@ instance Monad KI where return a = M $ \ s -> Right (s, a) M a >>= f = M $ \ s -> case a s of - Left e -> Left e - Right (s', b) -> - let M f' = f b - in f' s' + Left e -> Left e + Right (s', b) -> + let M f' = f b + in f' s' instance Functor KI where fmap = liftM @@ -271,19 +271,19 @@ unifyDefType t k_inferred k_expected = do pos = getPosition t t_str = pfpString t -- XXX replace Readable with String - default_err = err (pos, EUnifyKind (pfpReadable t) + default_err = err (pos, EUnifyKind (pfpReadable t) (ppReadable k_inferred') (ppReadable k_expected')) in - if (k_expected' == KStar) && (k_inferred' == KNum) - then - err (pos, EKindNumForStar t_str) - else - if (k_expected' == KNum) && (k_inferred' == KStar) - then - err (pos, EKindStarForNum t_str) - else - default_err + if (k_expected' == KStar) && (k_inferred' == KNum) + then + err (pos, EKindNumForStar t_str) + else + if (k_expected' == KNum) && (k_inferred' == KStar) + then + err (pos, EKindStarForNum t_str) + else + default_err -- Takes the function and its kind and the argument to which the function @@ -292,16 +292,16 @@ unifyFunc :: Type -> Kind -> Type -> Kind -> KI Kind unifyFunc f fk a ak = do s <- getKSubst let sfk = apKSu s fk - sak = apKSu s ak + sak = apKSu s ak -- trace "unifyFunc:" $ return () case sfk of - Kfun ak' v' -> do + Kfun ak' v' -> do -- The function has inferred kind "ak' -> ..." -- so use "ak'" as the expected kind for the argument - unifyType a sak ak' + unifyType a sak ak' -- Return the inferred result return v' - _ -> do v <- newKVar Nothing + _ -> do v <- newKVar Nothing -- The function is expected to be "sak -> ..." unifyType f sfk (Kfun sak v) return v @@ -319,41 +319,41 @@ unifyType t k_inferred k_expected = do pos = getPosition t t_str = pfpString t -- XXX replace Readable with String - default_err = err (pos, EUnifyKind (pfpReadable t) + default_err = err (pos, EUnifyKind (pfpReadable t) (ppReadable k_inferred') (ppReadable k_expected')) - -- if a type constructor is being partially applied, get the core - unapType = removeTypeAps t - -- the name of the constructor, for error messages - unapTypeName = showUnapType t + -- if a type constructor is being partially applied, get the core + unapType = removeTypeAps t + -- the name of the constructor, for error messages + unapTypeName = showUnapType t in - -- trace ("trace: unifyType: " ++ traceUnapType t) $ - if (isGroundNonFuncK k_inferred') && (isFuncK k_expected') - then - -- handle case of too many arguments - case unapType of - TCon (TyNum i _) -> err (pos, ENumKindArg) - _ -> if (unapType == t) - then -- type is not partially applied - err (pos, ETypeNoArg unapTypeName) - else - err (pos, ETypeTooManyArgs unapTypeName) - else - if (isGroundNonFuncK k_expected') && (isFuncK k_inferred') - then - -- handle case of not enough arguments - err (pos, ETypeTooFewArgs unapTypeName) - else - if (k_expected' == KStar) && (k_inferred' == KNum) - then - err (pos, EKindNumForStar t_str) - else - if (k_expected' == KNum) && (k_inferred' == KStar) - then - err (pos, EKindStarForNum t_str) - else - default_err + -- trace ("trace: unifyType: " ++ traceUnapType t) $ + if (isGroundNonFuncK k_inferred') && (isFuncK k_expected') + then + -- handle case of too many arguments + case unapType of + TCon (TyNum i _) -> err (pos, ENumKindArg) + _ -> if (unapType == t) + then -- type is not partially applied + err (pos, ETypeNoArg unapTypeName) + else + err (pos, ETypeTooManyArgs unapTypeName) + else + if (isGroundNonFuncK k_expected') && (isFuncK k_inferred') + then + -- handle case of not enough arguments + err (pos, ETypeTooFewArgs unapTypeName) + else + if (k_expected' == KStar) && (k_inferred' == KNum) + then + err (pos, EKindNumForStar t_str) + else + if (k_expected' == KNum) && (k_inferred' == KStar) + then + err (pos, EKindStarForNum t_str) + else + default_err -------------------- diff --git a/src/comp/LambdaCalcUtil.hs b/src/comp/LambdaCalcUtil.hs index c12990d5b..ade5c3ec3 100644 --- a/src/comp/LambdaCalcUtil.hs +++ b/src/comp/LambdaCalcUtil.hs @@ -189,9 +189,9 @@ mkMethodOrderMap avis = findMethodOrderSet :: MethodOrderMap -> AId -> S.Set (AId, AId) findMethodOrderSet mmap id = case M.lookup id mmap of - Just mset -> mset - Nothing -> internalError ("SimPackage.findMethodOrderSet: " ++ - "cannot find " ++ ppReadable id) + Just mset -> mset + Nothing -> internalError ("SimPackage.findMethodOrderSet: " ++ + "cannot find " ++ ppReadable id) -- ----- @@ -241,165 +241,165 @@ tsortActionsAndDefs :: MethodOrderMap -> DefMap -> ([Either ADef AAction], M.Map (AId, AId) (AId, AType)) tsortActionsAndDefs mmap defmap uses acts = let - -- we will create a graph where the edges are: - -- * "Left AId" to represent a def (by it's name) - -- * "Right Integer" to represent an action (by it's position in acts) + -- we will create a graph where the edges are: + -- * "Left AId" to represent a def (by it's name) + -- * "Right Integer" to represent an action (by it's position in acts) - -- The use of Left and Right was chosen to make Defs lower in - -- the Ord order than Actions. This way, tsort puts them first. + -- The use of Left and Right was chosen to make Defs lower in + -- the Ord order than Actions. This way, tsort puts them first. - -- ---------- - -- Defs + -- ---------- + -- Defs -- find the defs used_defs :: [ADef] used_defs = map (\ (i, (t, e)) -> ADef i t e []) (M.toList uses) - -- make edges for def-to-def dependencies - def_edges = + -- make edges for def-to-def dependencies + def_edges = [ (Left i, map Left uses) - | ADef i _ e _ <- used_defs, - let uses = M.keys $ getAExprDefs defmap M.empty [e] ] + | ADef i _ e _ <- used_defs, + let uses = M.keys $ getAExprDefs defmap M.empty [e] ] - -- ---------- - -- Actions + -- ---------- + -- Actions - -- give the actions a unique number and make a mapping - -- (this is necessary because the same action can be repeated - -- more than once ... for instance, $display on the same arguments) + -- give the actions a unique number and make a mapping + -- (this is necessary because the same action can be repeated + -- more than once ... for instance, $display on the same arguments) - -- (numbering in order also helps the Ord order, for tsort) - numbered_acts = zip [1..] acts - act_map = M.fromList numbered_acts - getAct n = case (M.lookup n act_map) of - Just d -> d - Nothing -> internalError "tsortActionsAndDefs: getAct" + -- (numbering in order also helps the Ord order, for tsort) + numbered_acts = zip [1..] acts + act_map = M.fromList numbered_acts + getAct n = case (M.lookup n act_map) of + Just d -> d + Nothing -> internalError "tsortActionsAndDefs: getAct" - -- separate the sorts of actions - -- * method calls we will re-order, respecting sequential composability - -- * foreign task/function calls we will keep in order, but allow - -- other things to come between them (because tasks can return - -- values) + -- separate the sorts of actions + -- * method calls we will re-order, respecting sequential composability + -- * foreign task/function calls we will keep in order, but allow + -- other things to come between them (because tasks can return + -- values) - isACall (_, ACall {}) = True - isACall _ = False + isACall (_, ACall {}) = True + isACall _ = False - isATaskAction (_, ATaskAction {}) = True - isATaskAction _ = False + isATaskAction (_, ATaskAction {}) = True + isATaskAction _ = False - (method_calls, foreign_calls) = partition isACall numbered_acts - task_calls = filter isATaskAction foreign_calls + (method_calls, foreign_calls) = partition isACall numbered_acts + task_calls = filter isATaskAction foreign_calls - -- ---------- - -- foreign-to-foreign edges - -- (to maintain the user-specified order of system/foreign-func calls) + -- ---------- + -- foreign-to-foreign edges + -- (to maintain the user-specified order of system/foreign-func calls) - -- (are these still needed now that we use Ord to bias tsort?) - foreign_edges = - if (length foreign_calls > 1) - then let mkEdge (n1,_) (n2,_) = (Right n2, [Right n1]) - in zipWith mkEdge (init foreign_calls) (tail foreign_calls) - else [] + -- (are these still needed now that we use Ord to bias tsort?) + foreign_edges = + if (length foreign_calls > 1) + then let mkEdge (n1,_) (n2,_) = (Right n2, [Right n1]) + in zipWith mkEdge (init foreign_calls) (tail foreign_calls) + else [] - -- ---------- - -- Action to def edges + -- ---------- + -- Action to def edges - -- any defs used by an action have to be computed before the - -- action is called + -- any defs used by an action have to be computed before the + -- action is called - act_def_edges = + act_def_edges = [ (Right n, map Left uses) - | (n, a) <- numbered_acts, + | (n, a) <- numbered_acts, let uses = M.keys $ getAActionDefs defmap M.empty [a] ] - -- ---------- - -- Action method to Action method edges + -- ---------- + -- Action method to Action method edges - -- function to create order edges - -- m1 `isBefore` m2 == True + -- function to create order edges + -- m1 `isBefore` m2 == True -- when (m1 SB m2) is in the VModInfo for the submodule - isBefore (ACall obj1 meth1 _) (ACall obj2 meth2 _) = - -- do they act on the same object? - if (obj1 /= obj2) - then False - else let mset = findMethodOrderSet mmap obj1 - in (unQualId meth1, unQualId meth2) `S.member` mset - isBefore _ _ = False - - -- order the method calls - -- The edges must be of the form (a, as) s.t. all actions in "as" - -- have to execute before "a". - meth_edges = [ (Right n1, ns) - | (n1,a1) <- method_calls, - let ns = [ Right n2 | (n2,a2) <- numbered_acts, - a2 /= a1, - a2 `isBefore` a1 ] ] - - -- ---------- - -- ActionValue method edges - - (av_meth_edges, av_meth_local_vars) = - mkAVMethEdges used_defs method_calls - - -- ---------- - -- ActionValue task edges - - -- Make edges from the task to the def that it sets - -- (ATaskValue is always a top-level def, and the Id is stored - -- in the ATaskAction by the ATaskSplice stage.) - -- (Rather than remove the def for the ATaskValue and make edges from - -- the users of that def to the ATaskAction, we leave the def in - -- the graph and just generate nothing for it when we make statements - -- from the flattened graph.) - av_task_edges = - [ (Left tmp_id, [Right n]) | + isBefore (ACall obj1 meth1 _) (ACall obj2 meth2 _) = + -- do they act on the same object? + if (obj1 /= obj2) + then False + else let mset = findMethodOrderSet mmap obj1 + in (unQualId meth1, unQualId meth2) `S.member` mset + isBefore _ _ = False + + -- order the method calls + -- The edges must be of the form (a, as) s.t. all actions in "as" + -- have to execute before "a". + meth_edges = [ (Right n1, ns) + | (n1,a1) <- method_calls, + let ns = [ Right n2 | (n2,a2) <- numbered_acts, + a2 /= a1, + a2 `isBefore` a1 ] ] + + -- ---------- + -- ActionValue method edges + + (av_meth_edges, av_meth_local_vars) = + mkAVMethEdges used_defs method_calls + + -- ---------- + -- ActionValue task edges + + -- Make edges from the task to the def that it sets + -- (ATaskValue is always a top-level def, and the Id is stored + -- in the ATaskAction by the ATaskSplice stage.) + -- (Rather than remove the def for the ATaskValue and make edges from + -- the users of that def to the ATaskAction, we leave the def in + -- the graph and just generate nothing for it when we make statements + -- from the flattened graph.) + av_task_edges = + [ (Left tmp_id, [Right n]) | (n, ATaskAction { ataskact_temp=(Just tmp_id) }) <- task_calls ] - -- ---------- - -- Action / Value method call edges - - -- like isBefore, but for Action vs Value method - isVMethSB v_obj v_meth (ACall a_obj a_meth _) = - -- do they act on the same object? - if (v_obj /= a_obj) - then False - else let mset = findMethodOrderSet mmap v_obj - in (unQualId v_meth, unQualId a_meth) `S.member` mset - isVMethSB _ _ _ = False - - isAMethSB v_obj v_meth (ACall a_obj a_meth _) = - -- do they act on the same object? - if (v_obj /= a_obj) - then False - else let mset = findMethodOrderSet mmap v_obj - in (unQualId a_meth, unQualId v_meth) `S.member` mset - isAMethSB _ _ _ = False - - -- value method calls which are SB with action methods - -- need to be properly ordered - -- Edges must be of the form (m1, m2) where the method "m2" - -- has to be executed before "m1". - mdef_edges = - [ edge | ADef i _ e _ <- used_defs, + -- ---------- + -- Action / Value method call edges + + -- like isBefore, but for Action vs Value method + isVMethSB v_obj v_meth (ACall a_obj a_meth _) = + -- do they act on the same object? + if (v_obj /= a_obj) + then False + else let mset = findMethodOrderSet mmap v_obj + in (unQualId v_meth, unQualId a_meth) `S.member` mset + isVMethSB _ _ _ = False + + isAMethSB v_obj v_meth (ACall a_obj a_meth _) = + -- do they act on the same object? + if (v_obj /= a_obj) + then False + else let mset = findMethodOrderSet mmap v_obj + in (unQualId a_meth, unQualId v_meth) `S.member` mset + isAMethSB _ _ _ = False + + -- value method calls which are SB with action methods + -- need to be properly ordered + -- Edges must be of the form (m1, m2) where the method "m2" + -- has to be executed before "m1". + mdef_edges = + [ edge | ADef i _ e _ <- used_defs, -- "aMethCalls" can return duplicates, but that's OK (obj,meth) <- aMethCalls e, - edge <- + edge <- -- def SB act - [ (Right n, [Left i]) - | (n,a) <- method_calls, - isVMethSB obj meth a ] ++ - -- act SB def (XXX can this happen?) - [ (Left i, map Right ns) - | let ns = map fst $ - filter ((isAMethSB obj meth) . snd) - method_calls, - not (null ns) ] - ] - - -- ---------- - -- check the assumption that the arguments to the actions don't - -- introduce ordering edges (that is, don't contain value method - -- calls or values from AV methods or tasks) + [ (Right n, [Left i]) + | (n,a) <- method_calls, + isVMethSB obj meth a ] ++ + -- act SB def (XXX can this happen?) + [ (Left i, map Right ns) + | let ns = map fst $ + filter ((isAMethSB obj meth) . snd) + method_calls, + not (null ns) ] + ] + + -- ---------- + -- check the assumption that the arguments to the actions don't + -- introduce ordering edges (that is, don't contain value method + -- calls or values from AV methods or tasks) isBadActionArg e = not (null (aMethCalls e)) && not (null (aMethValues e)) && @@ -407,18 +407,18 @@ tsortActionsAndDefs mmap defmap uses acts = bad_acts = concatMap (filter isBadActionArg . aact_args) acts - -- ---------- - -- put it together into one graph + -- ---------- + -- put it together into one graph - g = + g = {- - trace ("acts = " ++ ppReadable numbered_acts) $ - trace ("foreign_edges = " ++ ppReadable (foreign_edges :: [Edge])) $ - trace ("av_task_edges = " ++ ppReadable av_task_edges) $ - trace ("av_meth_edges = " ++ ppReadable av_meth_edges) $ - trace ("meth_edges = " ++ ppReadable (meth_edges :: [Edge])) $ - trace ("mdef_edges = " ++ ppReadable mdef_edges) $ - trace ("act_def_edges = " ++ ppReadable (act_def_edges :: [Edge])) $ + trace ("acts = " ++ ppReadable numbered_acts) $ + trace ("foreign_edges = " ++ ppReadable (foreign_edges :: [Edge])) $ + trace ("av_task_edges = " ++ ppReadable av_task_edges) $ + trace ("av_meth_edges = " ++ ppReadable av_meth_edges) $ + trace ("meth_edges = " ++ ppReadable (meth_edges :: [Edge])) $ + trace ("mdef_edges = " ++ ppReadable mdef_edges) $ + trace ("act_def_edges = " ++ ppReadable (act_def_edges :: [Edge])) $ -} M.fromListWith union $ concat [ foreign_edges , av_task_edges @@ -430,21 +430,21 @@ tsortActionsAndDefs mmap defmap uses acts = ] -- Convert the graph to the format expected by tsort. - g_edges = M.toList g + g_edges = M.toList g in if (not (null bad_acts)) then internalError ("tsortActionsAndDefs: unexpected inlining:\n" ++ ppReadable bad_acts) else -- tsort returns Left if there is a loop, Right if sorted. - -- (In the absense of restrictive edges, tsort uses Ord to put - -- the lower valued nodes first. Thus, we have chosen the node - -- representation to put Defs first, followed by Actions in the - -- order that they were give by the user.) - case (tsort g_edges) of - Left is -> internalError ("tsortActionsAndDefs: cyclic " ++ - ppReadable is) - Right is -> + -- (In the absense of restrictive edges, tsort uses Ord to put + -- the lower valued nodes first. Thus, we have chosen the node + -- representation to put Defs first, followed by Actions in the + -- order that they were give by the user.) + case (tsort g_edges) of + Left is -> internalError ("tsortActionsAndDefs: cyclic " ++ + ppReadable is) + Right is -> let -- lookup def and action nodes xs = map (either (Left . lookupDef defmap) (Right . getAct)) is in @@ -464,35 +464,35 @@ type Edge = (Node, [Node]) -- * a set of the ACall which are action value, mapped to the Id of the -- def used to reference it and its type mkAVMethEdges :: [ADef] -> [(Integer, AAction)] -> - ([Edge], M.Map (AId, AId) (AId, AType)) + ([Edge], M.Map (AId, AId) (AId, AType)) mkAVMethEdges ds method_calls = let - -- check whether an AMethValue is from a particular action - isMethValueOf v_obj v_meth (ACall a_obj a_meth _) = - (v_obj == a_obj) && (v_meth == a_meth) - isMethValueOf _ _ _ = False + -- check whether an AMethValue is from a particular action + isMethValueOf v_obj v_meth (ACall a_obj a_meth _) = + (v_obj == a_obj) && (v_meth == a_meth) + isMethValueOf _ _ _ = False - -- find the AMethValue references + -- find the AMethValue references -- (assume that they are lifted to their own def) - av_meth_refs = [ (i, obj, meth, ty) + av_meth_refs = [ (i, obj, meth, ty) | ADef i _ (AMethValue ty obj meth) _ <- ds ] - -- the value reference from an ActionValue needs to come after - -- the action method call. - -- Edges must be of the form (i, as) where all actions in "as" - -- have to execute before "i" is computed. - av_meth_edges = [ (Left i, map Right ns) - | (i, obj, meth, _) <- av_meth_refs, + -- the value reference from an ActionValue needs to come after + -- the action method call. + -- Edges must be of the form (i, as) where all actions in "as" + -- have to execute before "i" is computed. + av_meth_edges = [ (Left i, map Right ns) + | (i, obj, meth, _) <- av_meth_refs, let ns = map fst $ - filter ((isMethValueOf obj meth) . snd) - method_calls, - not (null ns) ] + filter ((isMethValueOf obj meth) . snd) + method_calls, + not (null ns) ] - av_meths = + av_meths = let mkPair (i,o,m,t) = ((o,m),(i,t)) in M.fromList (map mkPair av_meth_refs) in - (av_meth_edges, av_meths) + (av_meth_edges, av_meths) -- ----- @@ -843,8 +843,8 @@ aBoolAnds es = then mkAFalse else aBoolAnds' (nub (filter (not . isTrue) es)) where aBoolAnds' [] = mkATrue - aBoolAnds' [e] = e - aBoolAnds' es = APrim defaultAId mkATBool PrimBAnd es + aBoolAnds' [e] = e + aBoolAnds' es = APrim defaultAId mkATBool PrimBAnd es aBoolNot :: AExpr -> AExpr aBoolNot (APrim defaultAId t PrimBNot [e]) = e diff --git a/src/comp/Lex.hs b/src/comp/Lex.hs index ca5bac61c..5870db054 100644 --- a/src/comp/Lex.hs +++ b/src/comp/Lex.hs @@ -38,9 +38,9 @@ data LexItem = | L_conid FString | L_varsym FString | L_consym FString - | L_integer (Maybe Integer) Integer Integer -- bit size (if specified), base, value + | L_integer (Maybe Integer) Integer Integer -- bit size (if specified), base, value | L_float Rational - | L_char Char + | L_char Char | L_string String | L_lpar | L_rpar @@ -187,7 +187,7 @@ lx lf f l 0 ('#':' ':cs@(c:_)) | isDigit c = res = lx lf (mkFString fn) n 0 r in res -lx lf f l c "" = +lx lf f l c "" = [Token (mkPositionFull f (l+1) (-1) (lf_is_stdlib lf)) L_eof] lx lf f l c (' ':cs) = lx lf f l (c+1) cs lx lf f l c ('\n':cs) = lx lf f (l+1) 0 cs @@ -203,21 +203,21 @@ lx lf f l c ('-':'-':cs) | isComm cs = skipToEOL lf f l cs lx lf f l c ('{':'-':'#':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_lpragma : lx lf f l (c+3) cs lx lf f l c ('#':'-':'}':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_rpragma : lx lf f l (c+3) cs lx lf f l c ('{':'-':cs) = skipComm lf (l, c) 1 f l (c+2) cs -lx lf f l c ('(':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_lpar : lx lf f l (c+1) cs -lx lf f l c (')':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_rpar : lx lf f l (c+1) cs -lx lf f l c (',':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_comma : lx lf f l (c+1) cs -lx lf f l c (';':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_semi : lx lf f l (c+1) cs -lx lf f l c ('`':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_bquote : lx lf f l (c+1) cs -lx lf f l c ('{':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_lcurl : lx lf f l (c+1) cs -lx lf f l c ('}':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_rcurl : lx lf f l (c+1) cs -lx lf f l c ('[':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_lbra : lx lf f l (c+1) cs -lx lf f l c (']':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_rbra : lx lf f l (c+1) cs -lx lf f l c ('.':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_dot : lx lf f l (c+1) cs -lx lf f l c ('\'':cs) = +lx lf f l c ('(':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_lpar : lx lf f l (c+1) cs +lx lf f l c (')':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_rpar : lx lf f l (c+1) cs +lx lf f l c (',':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_comma : lx lf f l (c+1) cs +lx lf f l c (';':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_semi : lx lf f l (c+1) cs +lx lf f l c ('`':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_bquote : lx lf f l (c+1) cs +lx lf f l c ('{':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_lcurl : lx lf f l (c+1) cs +lx lf f l c ('}':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_rcurl : lx lf f l (c+1) cs +lx lf f l c ('[':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_lbra : lx lf f l (c+1) cs +lx lf f l c (']':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_rbra : lx lf f l (c+1) cs +lx lf f l c ('.':cs) = Token (mkPositionFull f l c (lf_is_stdlib lf)) L_dot : lx lf f l (c+1) cs +lx lf f l c ('\'':cs) = case lexLitChar' cs of Just (cc, n, '\'':cs) -> Token (mkPositionFull f l c (lf_is_stdlib lf)) (L_char cc) : lx lf f l (c+2+n) cs _ -> lexerr f l c LexBadCharLit -lx lf f l c ('"':cs) = +lx lf f l c ('"':cs) = case lexString cs l (c+1) "" of Just (str, l', c', cs') -> Token (mkPositionFull f l c (lf_is_stdlib lf)) (L_string str) : lx lf f l' c' cs' _ -> lexerr f l c LexBadStringLit @@ -284,16 +284,16 @@ lx lf f l c (x:cs) | isSym x = spanSym [] (c+1) cs p = mkPositionFull f l c (lf_is_stdlib lf) lxrs x = Token p x : lx lf f l cn cs' in case s of - "::" -> lxrs L_dcolon - ":" -> lxrs L_colon + "::" -> lxrs L_dcolon + ":" -> lxrs L_colon "=" -> lxrs L_eq "@" -> lxrs L_at - "\\" -> lxrs L_lam - "->" -> lxrs L_rarrow - "==>" -> lxrs L_drarrow - "=>" -> lxrs L_irarrow - "<-" -> lxrs L_larrow - _ -> let fs = mkFString s + "\\" -> lxrs L_lam + "->" -> lxrs L_rarrow + "==>" -> lxrs L_drarrow + "=>" -> lxrs L_irarrow + "<-" -> lxrs L_larrow + _ -> let fs = mkFString s in if not (lf_allow_sv_kws lf) && isSvSymbol s then internalError @@ -316,46 +316,46 @@ lx lf f l c (x:cs) | isAlpha x || x == '_' = spanId [] (c+1) cs Token p (L_varid fs) : lx lf f l cn cs' in case s of "$" -> lxr (L_varsym (mkFString s)) - "_" -> lxr L_uscore + "_" -> lxr L_uscore "action" -> lxr L_action - "case" -> lxr L_case - "class" -> lxr L_class - "data" -> lxr L_data - "deriving" -> lxr L_deriving - "do" -> lxr L_do + "case" -> lxr L_case + "class" -> lxr L_class + "data" -> lxr L_data + "deriving" -> lxr L_deriving + "do" -> lxr L_do "else" -> lxr L_else "foreign" -> lxr L_foreign "if" -> lxr L_if "import" -> lxr L_import - "in" -> lxr L_in + "in" -> lxr L_in "coherent" -> lxr L_coherent "incoherent" -> lxr L_incoherent - "infix" -> lxr L_infix - "infixl" -> lxr L_infixl - "infixr" -> lxr L_infixr - "interface" -> lxr L_interface - "instance" -> lxr L_instance - "let" -> lxr L_let - "letseq" -> lxr L_letseq - "module" -> lxr L_module - "of" -> lxr L_of + "infix" -> lxr L_infix + "infixl" -> lxr L_infixl + "infixr" -> lxr L_infixr + "interface" -> lxr L_interface + "instance" -> lxr L_instance + "let" -> lxr L_let + "letseq" -> lxr L_letseq + "module" -> lxr L_module + "of" -> lxr L_of -- A hack to allow multiple packages in one file. -- We need to generate a closing '}', so the package keyword has to -- be in column -1. - "package" -> + "package" -> Token (mkPositionFull f l (c-1) (lf_is_stdlib lf)) L_package : lx lf f l cn cs' - "prefix" -> lxr L_prefix - "primitive" -> lxr L_primitive - "qualified" -> lxr L_qualified - "rules" -> lxr L_rules - "signature" -> lxr L_signature - "struct" -> lxr L_struct + "prefix" -> lxr L_prefix + "primitive" -> lxr L_primitive + "qualified" -> lxr L_qualified + "rules" -> lxr L_rules + "signature" -> lxr L_signature + "struct" -> lxr L_struct "then" -> lxr L_then "type" -> lxr L_type - "valueOf" -> lxr L_valueOf - "verilog" -> lxr L_verilog - "synthesize" -> lxr L_synthesize + "valueOf" -> lxr L_valueOf + "verilog" -> lxr L_verilog + "synthesize" -> lxr L_synthesize "when" -> lxr L_when "where" -> lxr L_where _ -> if not (lf_allow_sv_kws lf) && isSvKeyword s @@ -436,10 +436,10 @@ skipToEOL lf f l ('\n':cs) = lx lf f (l+1) 0 cs skipToEOL lf f l (_:cs) = skipToEOL lf f l cs skipToEOL lf f l "" = lexerr f l 0 LexMissingNL -lexLitChar' :: String -> Maybe (Char, Int, String) -lexLitChar' ('\\':s) = lexEsc s +lexLitChar' :: String -> Maybe (Char, Int, String) +lexLitChar' ('\\':s) = lexEsc s where - lexEsc ('x':s) = let (n,s') = span isHexDigit s in Just (chr (fromInteger (readN 16 n)), 2+length n, s') + lexEsc ('x':s) = let (n,s') = span isHexDigit s in Just (chr (fromInteger (readN 16 n)), 2+length n, s') lexEsc ('n':s) = Just ('\n', 1, s) lexEsc ('t':s) = Just ('\t', 1, s) lexEsc ('r':s) = Just ('\r', 1, s) @@ -448,17 +448,17 @@ lexLitChar' ('\\':s) = lexEsc s lexEsc ('"':s) = Just ('"', 1, s) lexEsc ('\'':s) = Just ('\'', 1, s) lexEsc ('\\':s) = Just ('\\', 1, s) - lexEsc s = Nothing -lexLitChar' ('\n':_) = Nothing -- NL in strings is a bad idea -lexLitChar' (c:s) = Just (c, 1, s) -lexLitChar' "" = Nothing + lexEsc s = Nothing +lexLitChar' ('\n':_) = Nothing -- NL in strings is a bad idea +lexLitChar' (c:s) = Just (c, 1, s) +lexLitChar' "" = Nothing readN :: Integer -> String -> Integer readN radix s = foldl1 (\n d -> n * radix + d) (map (toInteger . digitToInt) s) --- maxexp = 10000 :: Int -- don't allow exponents greater than this since it would take up too much memory +-- maxexp = 10000 :: Int -- don't allow exponents greater than this since it would take up too much memory isSvKeyword :: String -> Bool isSvKeyword str = str `S.member` svKeywordSet diff --git a/src/comp/Libs/ListMap.hs b/src/comp/Libs/ListMap.hs index cda58269e..4f99b4d27 100644 --- a/src/comp/Libs/ListMap.hs +++ b/src/comp/Libs/ListMap.hs @@ -2,12 +2,12 @@ -- See LICENSE for the full license. -- module ListMap( - ListMap, - toList, fromList, - length, - null, - lookup, lookupWithDefault, lookupWithDefaultBy, lookupBy - ) where + ListMap, + toList, fromList, + length, + null, + lookup, lookupWithDefault, lookupWithDefaultBy, lookupBy + ) where --import Prelude diff --git a/src/comp/Libs/ListUtil.hs b/src/comp/Libs/ListUtil.hs index 05a4f0d74..bd8349427 100644 --- a/src/comp/Libs/ListUtil.hs +++ b/src/comp/Libs/ListUtil.hs @@ -6,8 +6,8 @@ module ListUtil where -- Repeatedly extract (and transform) values until a predicate hold. Return the list of values. unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b] unfoldr f p x | p x = [] - | otherwise = y:unfoldr f p x' - where (y, x') = f x + | otherwise = y:unfoldr f p x' + where (y, x') = f x chopList :: ([a] -> (b, [a])) -> [a] -> [b] chopList f l = unfoldr f null l diff --git a/src/comp/Libs/Parse.hs b/src/comp/Libs/Parse.hs index 8da603967..0ed9981a8 100644 --- a/src/comp/Libs/Parse.hs +++ b/src/comp/Libs/Parse.hs @@ -6,8 +6,8 @@ -- @@ consists of a b value, and a list of remaining as. module Parse(Parser, (+.+), (..+), (+..), (|||), (>>-), (>>>), (||!), (|!!), (.>), - into, lit, litp, many, many1, succeed, failure, sepBy, count, sepBy1, testp, token, recover, - ParseResult, parse, sParse, simpleParse) where + into, lit, litp, many, many1, succeed, failure, sepBy, count, sepBy1, testp, token, recover, + ParseResult, parse, sParse, simpleParse) where -- @@ Parsing combinatores with good error reporting. @@ -18,31 +18,31 @@ infixr 4 ||| , ||! , |!! type PErrMsg = String data FailAt a - = FailAt !Int [PErrMsg] a -- token pos, list of acceptable tokens, rest of tokens - deriving (Show) + = FailAt !Int [PErrMsg] a -- token pos, list of acceptable tokens, rest of tokens + deriving (Show) data ParseResult a b - = Many [(b, Int, a)] (FailAt a) -- parse succeeded with many (>1) parses) - | One b !Int a !(FailAt a) -- parse succeeded with one parse - | None !Bool !(FailAt a) -- parse failed. The Bool indicates hard fail - deriving (Show) + = Many [(b, Int, a)] (FailAt a) -- parse succeeded with many (>1) parses) + | One b !Int a !(FailAt a) -- parse succeeded with one parse + | None !Bool !(FailAt a) -- parse failed. The Bool indicates hard fail + deriving (Show) type Parser a b = a -> Int -> ParseResult a b -noFail = FailAt (-1) [] (error "noFail") -- indicates no failure yet +noFail = FailAt (-1) [] (error "noFail") -- indicates no failure yet updFail f (None w f') = None w (bestFailAt f f') updFail f (One c n as f') = One c n as (bestFailAt f f') updFail f (Many cas f') = let r = bestFailAt f f' in seq r (Many cas r) bestFailAt f@(FailAt i a t) f'@(FailAt j a' _) = - if i > j then - f - else if j > i then - f' - else if i == -1 then - noFail - else - FailAt i (a ++ a') t + if i > j then + f + else if j > i then + f' + else if i == -1 then + noFail + else + FailAt i (a ++ a') t -- Alternative (|||) :: Parser a b -> Parser a b -> Parser a b @@ -50,11 +50,11 @@ p ||| q = \as n -> case (p as n, q as n) of (pr@(None True _), _ ) -> pr (pr@(None _ f), qr ) -> updFail f qr - ( One b k as f , qr ) -> Many ((b,k,as) : l') (bestFailAt f f') where (l',f') = lf qr - ( Many l f , qr ) -> Many ( l++l') (bestFailAt f f') where (l',f') = lf qr + ( One b k as f , qr ) -> Many ((b,k,as) : l') (bestFailAt f f') where (l',f') = lf qr + ( Many l f , qr ) -> Many ( l++l') (bestFailAt f f') where (l',f') = lf qr where lf (Many l f) = (l, f) - lf (One b k as f) = ([(b,k,as)], f) - lf (None _ f) = ([], f) + lf (One b k as f) = ([(b,k,as)], f) + lf (None _ f) = ([], f) -- Alternative, but with committed choice (||!) :: Parser a b -> Parser a b -> Parser a b @@ -62,7 +62,7 @@ p ||! q = \as n -> case (p as n, q as n) of (pr@(None True _), _ ) -> pr ( None _ f , qr ) -> updFail f qr - (pr , _ ) -> pr + (pr , _ ) -> pr processAlts f [] [] = seq f (None False f) processAlts f [(b,k,as)] [] = seq f (One b k as f) @@ -79,45 +79,45 @@ doMany g cas f = Many [ (g c, n, as) | (c,n,as) <- cas] f p +.+ q = \as n-> case p as n of - None w f -> None w f - One b n' as' f -> - case q as' n' of - None w f' -> None w (bestFailAt f f') - One c n'' as'' f' -> One (b,c) n'' as'' (bestFailAt f f') - Many cas f' -> doMany (\x->(b,x)) cas (bestFailAt f f') - Many bas f -> - let rss = [ case q as' n' of { None w f -> None w f; - One c n'' as'' f' -> One (b,c) n'' as'' f'; - Many cas f' -> doMany (\x->(b,x)) cas f' } + None w f -> None w f + One b n' as' f -> + case q as' n' of + None w f' -> None w (bestFailAt f f') + One c n'' as'' f' -> One (b,c) n'' as'' (bestFailAt f f') + Many cas f' -> doMany (\x->(b,x)) cas (bestFailAt f f') + Many bas f -> + let rss = [ case q as' n' of { None w f -> None w f; + One c n'' as'' f' -> One (b,c) n'' as'' f'; + Many cas f' -> doMany (\x->(b,x)) cas f' } | (b,n',as') <- bas ] - in processAlts f [] rss + in processAlts f [] rss -- Sequence, throw away first part (..+) :: Parser a b -> Parser a c -> Parser a c p ..+ q = -- p +.+ q >>- snd \as n-> case p as n of - None w f -> None w f - One _ n' as' f -> updFail f (q as' n') - Many bas f -> processAlts f [] [ q as' n' | (_,n',as') <- bas ] + None w f -> None w f + One _ n' as' f -> updFail f (q as' n') + Many bas f -> processAlts f [] [ q as' n' | (_,n',as') <- bas ] -- Sequence, throw away second part (+..) :: Parser a b -> Parser a c -> Parser a b p +.. q = -- p +.+ q >>- fst \as n-> case p as n of - None w f -> None w f - One b n' as' f -> - case q as' n' of - None w f' -> None w (bestFailAt f f') - One _ n'' as'' f' -> One b n'' as'' (bestFailAt f f') - Many cas f' -> doMany (const b) cas (bestFailAt f f') + None w f -> None w f + One b n' as' f -> + case q as' n' of + None w f' -> None w (bestFailAt f f') + One _ n'' as'' f' -> One b n'' as'' (bestFailAt f f') + Many cas f' -> doMany (const b) cas (bestFailAt f f') Many bas f -> - let rss = [ case q as' n' of { None w f -> None w f; - One _ n'' as'' f' -> One b n'' as'' f'; - Many cas f' -> doMany (const b) cas f' } + let rss = [ case q as' n' of { None w f -> None w f; + One _ n'' as'' f' -> One b n'' as'' f'; + Many cas f' -> doMany (const b) cas f' } | (b,n',as') <- bas ] - in processAlts f [] rss + in processAlts f [] rss -- Return a fixed value (.>) :: Parser a b -> c -> Parser a c @@ -132,25 +132,25 @@ p .> v = (>>-) :: Parser a b -> (b->c) -> Parser a c p >>- f = \as n-> case p as n of - None w f -> None w f - One b n as' ff -> One (f b) n as' ff - Many bas ff -> doMany f bas ff + None w f -> None w f + One b n as' ff -> One (f b) n as' ff + Many bas ff -> doMany f bas ff -- Action on two items (>>>) :: Parser a (b,c) -> (b->c->d) -> Parser a d p >>> f = \as n-> case p as n of - None w ff -> None w ff - One (b,c) n as' ff -> One (f b c) n as' ff - Many bas ff -> doMany (\ (x,y)->f x y) bas ff + None w ff -> None w ff + One (b,c) n as' ff -> One (f b c) n as' ff + Many bas ff -> doMany (\ (x,y)->f x y) bas ff -- Use value into :: Parser a b -> (b -> Parser a c) -> Parser a c p `into` fq = \as n -> case p as n of - None w f -> None w f - One b n' as' f -> updFail f (fq b as' n') - Many bas f -> processAlts f [] [ fq b as' n' | (b,n',as') <- bas ] + None w f -> None w f + One b n' as' f -> updFail f (fq b as' n') + Many bas f -> processAlts f [] [ fq b as' n' | (b,n',as') <- bas ] -- Succeeds with a value succeed :: b -> Parser a b @@ -163,9 +163,9 @@ failure s = \as n -> None False (FailAt n [s] as) -- Fail completely if parsing proceeds a bit and then fails mustAll :: Parser a b -> Parser a b mustAll p = \as n-> - case p as n of - None False f@(FailAt x _ _) | x/=n -> None True f - r -> r + case p as n of + None False f@(FailAt x _ _) | x/=n -> None True f + r -> r -- If first alternative gives partial parse it's a failure (|!!) :: Parser a b -> Parser a b -> Parser a b @@ -196,23 +196,23 @@ p `sepBy` q = p `sepBy1` q -- Recognize a literal token lit :: (Eq a, Show a) => a -> Parser [a] a lit x = \as n -> - case as of - a:as' | a==x -> One a (n+1) as' noFail - _ -> None False (FailAt n [show x] as) + case as of + a:as' | a==x -> One a (n+1) as' noFail + _ -> None False (FailAt n [show x] as) -- Recognize a token with a predicate litp :: PErrMsg -> (a->Bool) -> Parser [a] a litp s p = \as n-> - case as of - a:as' | p a -> One a (n+1) as' noFail - _ -> None False (FailAt n [s] as) + case as of + a:as' | p a -> One a (n+1) as' noFail + _ -> None False (FailAt n [s] as) -- Generic token recognizer token :: (a -> Either PErrMsg (b,a)) -> Parser a b token f = \as n-> - case f as of - Left s -> None False (FailAt n [s] as) - Right (b, as') -> One b (n+1) as' noFail + case f as of + Left s -> None False (FailAt n [s] as) + Right (b, as') -> One b (n+1) as' noFail -- Test a semantic value testp :: String -> (b->Bool) -> Parser a b -> Parser a b @@ -221,41 +221,41 @@ testp s tst p = \ as n -> None w f -> None w f o@(One b _ _ _) -> if tst b then o else None False (FailAt n [s] as) Many bas f -> - case [ r | r@(b, _, _) <- bas, tst b] of - [] -> None False (FailAt n [s] as) - [(x,y,z)] -> One x y z f - rs -> Many rs f + case [ r | r@(b, _, _) <- bas, tst b] of + [] -> None False (FailAt n [s] as) + [(x,y,z)] -> One x y z f + rs -> Many rs f -- Try error recovery. recover :: Parser a b -> ([PErrMsg] -> a -> Maybe (a, b)) -> Parser a b recover p f = \ as n -> - case p as n of - r@(None _ fa@(FailAt n ss ts)) -> - case f ss ts of - Nothing -> r - Just (a, b) -> One b (n+1) a fa - r -> r + case p as n of + r@(None _ fa@(FailAt n ss ts)) -> + case f ss ts of + Nothing -> r + Just (a, b) -> One b (n+1) a fa + r -> r -- Parse, and check if it was ok. parse :: Parser a b -> a -> Either ([PErrMsg],a) [(b, a)] parse p as = - case p as 0 of - None w (FailAt _ ss ts) -> Left (ss,ts) - One b _ ts _ -> Right [(b,ts)] - Many bas _ -> Right [(b,ts) | (b,_,ts) <- bas ] + case p as 0 of + None w (FailAt _ ss ts) -> Left (ss,ts) + One b _ ts _ -> Right [(b,ts)] + Many bas _ -> Right [(b,ts) | (b,_,ts) <- bas ] sParse :: (Show a) => Parser [a] b -> [a] -> Either String b sParse p as = - case parse p as of - Left (ss,ts) -> Left ("Parse failed at token "++pshow ts++", expected "++unwords ss++"\n") - where pshow [] = "" - pshow (t:_) = show t - Right ((b,[]):_) -> Right b - Right ((_,t:_):_) -> Left ("Parse failed at token "++show t++", expected \n") + case parse p as of + Left (ss,ts) -> Left ("Parse failed at token "++pshow ts++", expected "++unwords ss++"\n") + where pshow [] = "" + pshow (t:_) = show t + Right ((b,[]):_) -> Right b + Right ((_,t:_):_) -> Left ("Parse failed at token "++show t++", expected \n") Right ([]) -> error("Parse.hs :: sParse unexpected pattern") simpleParse :: (Show a) => Parser [a] b -> [a] -> b simpleParse p as = - case sParse p as of - Left msg -> error msg - Right x -> x + case sParse p as of + Left msg -> error msg + Right x -> x diff --git a/src/comp/Libs/Sort.hs b/src/comp/Libs/Sort.hs index d22a2d774..8ab4f601d 100644 --- a/src/comp/Libs/Sort.hs +++ b/src/comp/Libs/Sort.hs @@ -10,15 +10,15 @@ sortLe le l = tmsort le l --sort l = tmsort (<=) l tmsort _ [] = [] -tmsort _ [x] = [x] -- just for speed +tmsort _ [x] = [x] -- just for speed tmsort le (x:xs) = msort le (upSeq le xs [x]) upSeq _ [] xs = [reverse xs] upSeq le (y:ys) xxs@(x:xs) = - if le x y then - upSeq le ys (y:xxs) - else - reverse xxs : upSeq le ys [y] + if le x y then + upSeq le ys (y:xxs) + else + reverse xxs : upSeq le ys [y] upSeq _ _ [] = error ("Sort.hs :: upSeq unexpected pattern" ) msort _ [xs] = xs @@ -28,9 +28,9 @@ mergePairs le (xs:ys:xss) = merge le xs ys : mergePairs le xss mergePairs _ xss = xss merge le xxs@(x:xs) yys@(y:ys) = - if le x y then - x:merge le xs yys - else - y:merge le xxs ys + if le x y then + x:merge le xs yys + else + y:merge le xxs ys merge _ [] yys = yys merge _ xxs [] = xxs diff --git a/src/comp/Literal.hs b/src/comp/Literal.hs index 21abe558a..f93b97148 100644 --- a/src/comp/Literal.hs +++ b/src/comp/Literal.hs @@ -4,7 +4,7 @@ import PPrint import PVPrint data Literal - = LString String + = LString String | LChar Char | LInt IntLit | LReal Double diff --git a/src/comp/MakeSymTab.hs b/src/comp/MakeSymTab.hs index e829bf0fd..bace83a55 100644 --- a/src/comp/MakeSymTab.hs +++ b/src/comp/MakeSymTab.hs @@ -133,7 +133,7 @@ mkSymTab errh (CPackage mi _ imps _ ds _) = errMultipleDef is = internalError ("MakeSymTab.mkSymTab.errMultipleDef: " ++ show is) errUnboundTyCon i = (getIdPosition i, EUnboundTyCon (pfpString i)) - errRecTypeSyn :: [Id] -> EMsg + errRecTypeSyn :: [Id] -> EMsg errRecTypeSyn scc = (getPosition scc, ETypeSynRecursive (map pfpString scc)) @@ -426,7 +426,7 @@ convInst errh mi r di@(Cinstance qt@(CQType _ t) ds) = altId _ = internalError "MakeSymTab.convInst altId" mkf d = (i, CVar (mkUId i)) where i = getLName d sds = {-trace (ppReadable supsi)-} supsi - where sups = super cls + where sups = super cls -- keep the position of the subclass contexts around (s_ids, s_preds) = unzip sups s_poss = map getPosition s_ids diff --git a/src/comp/PFPrint.hs b/src/comp/PFPrint.hs index 8bae122ef..0614b6ce7 100644 --- a/src/comp/PFPrint.hs +++ b/src/comp/PFPrint.hs @@ -1,12 +1,12 @@ module PFPrint(PPrint(..), module Pretty, PDetail(..), - ppReadable, ppReadableIndent, ppAll, ppDebug, ppString, pp80, - pparen, pfPrint, sepList, maxPrec, - PVPrint(..), - pvpReadable, pvpReadableIndent, pvpAll, pvpDebug, pvpString, pvpStringNQ, pvp80, - pvparen, - pfpReadable, pfpReadableIndent, pfpAll, pfpDebug, pfpString, pfp80, - pfparen, ppDoc - ) where + ppReadable, ppReadableIndent, ppAll, ppDebug, ppString, pp80, + pparen, pfPrint, sepList, maxPrec, + PVPrint(..), + pvpReadable, pvpReadableIndent, pvpAll, pvpDebug, pvpString, pvpStringNQ, pvp80, + pvparen, + pfpReadable, pfpReadableIndent, pfpAll, pfpDebug, pfpString, pfp80, + pfparen, ppDoc + ) where import Classic -- import Trace import PPrint diff --git a/src/comp/PPrint.hs b/src/comp/PPrint.hs index 588ddca71..63bf5ac19 100644 --- a/src/comp/PPrint.hs +++ b/src/comp/PPrint.hs @@ -1,11 +1,11 @@ {-# LANGUAGE CPP #-} module PPrint(PPrint(..), PDetail(..), module Pretty, - ppReadable, ppReadableIndent, ppAll, ppDebug, ppString, pp80, - pparen, sepList, catList, vcatList, ppr, ppDoc, - maxPrec, vsep, wrap, commaSep, encloseSep, + ppReadable, ppReadableIndent, ppAll, ppDebug, ppString, pp80, + pparen, sepList, catList, vcatList, ppr, ppDoc, + maxPrec, vsep, wrap, commaSep, encloseSep, tracePPS, ShortBool, toTF - ) where + ) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804) import Prelude hiding ((<>)) @@ -112,13 +112,13 @@ instance (PPrint a, PPrint b, PPrint c, PPrint d, PPrint e, PPrint f, PPrint g) instance (PPrint a) => PPrint [a] where pPrint d _ [] = text "[]" pPrint d _ xs = - case reverse (map (pPrint d 0) xs) of - (y:ys) -> - let ys' = map (<> text ",") ys - xs' = reverse (y:ys') --- in text "[" <> csep xs' <> text "]" - in text "[" <> sep xs' <> text "]" - [] -> trace "This cannot happen" (text "[]") + case reverse (map (pPrint d 0) xs) of + (y:ys) -> + let ys' = map (<> text ",") ys + xs' = reverse (y:ys') +-- in text "[" <> csep xs' <> text "]" + in text "[" <> sep xs' <> text "]" + [] -> trace "This cannot happen" (text "[]") instance (PPrint a, PPrint b) => PPrint (Either a b) where pPrint d p (Left x) = pparen (p>9) (text"(Left" <+> pPrint d 10 x <> text")") @@ -133,7 +133,7 @@ instance PPrint () where instance (PPrint a, PPrint b) => PPrint (M.Map a b) where pPrint d i m = vsep [pPrint d 0 k <+> text "->" <+> pPrint d 0 v - | (k, v) <- M.toList m] + | (k, v) <- M.toList m] instance (PPrint a, Ord a) => PPrint (S.Set a) where pPrint d i s = pPrint d i (S.toList s) @@ -189,4 +189,3 @@ instance PPrint ShortBool where toTF :: Bool -> ShortBool toTF True = TRUE toTF _ = FALSE - diff --git a/src/comp/PVPrint.hs b/src/comp/PVPrint.hs index 3c43ef63e..62d668440 100644 --- a/src/comp/PVPrint.hs +++ b/src/comp/PVPrint.hs @@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} module PVPrint(PVPrint(..), module Pretty, PDetail(..), - pvpReadable, pvpReadableIndent, pvpAll, pvpDebug, pvpString, pvpStringNQ, pvp80, - pvparen - ) where + pvpReadable, pvpReadableIndent, pvpAll, pvpDebug, pvpString, pvpStringNQ, pvp80, + pvparen + ) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804) import Prelude hiding ((<>)) @@ -78,13 +78,13 @@ instance (PVPrint a, PVPrint b, PVPrint c, PVPrint d, PVPrint e) => PVPrint (a, instance (PVPrint a) => PVPrint [a] where pvPrint d _ [] = text "[]" pvPrint d _ xs = - case reverse (map (pvPrint d 0) xs) of - (y:ys) -> - let ys' = map (<> text ",") ys - xs' = reverse (y:ys') --- in text "[" <> csep xs' <> text "]" - in text "[" <> sep xs' <> text "]" - [] -> trace "This cannot happen" (text "[]") + case reverse (map (pvPrint d 0) xs) of + (y:ys) -> + let ys' = map (<> text ",") ys + xs' = reverse (y:ys') +-- in text "[" <> csep xs' <> text "]" + in text "[" <> sep xs' <> text "]" + [] -> trace "This cannot happen" (text "[]") instance (PVPrint a, PVPrint b) => PVPrint (Either a b) where pvPrint d p (Left x) = pvparen (p>9) (text"(Left" <+> pvPrint d 10 x <> text")") @@ -101,4 +101,3 @@ pvparen True x = text"(" <> x <> text")" maxPrec :: Int maxPrec = 20 -} - diff --git a/src/comp/Params.hs b/src/comp/Params.hs index c193ab0d5..3e0edca74 100644 --- a/src/comp/Params.hs +++ b/src/comp/Params.hs @@ -1,10 +1,10 @@ module Params( - -- a specific stage on ISyntax for handling params - iParams, - -- functions for checking if a param's expr is legal - -- (is a constant expression, as defined by Verilog) - isConstIExpr, isConstAExpr - ) where + -- a specific stage on ISyntax for handling params + iParams, + -- functions for checking if a param's expr is legal + -- (is a constant expression, as defined by Verilog) + isConstIExpr, isConstAExpr + ) where import qualified Data.Map as M import Error(internalError, EMsg, ErrMsg(..), ErrorHandle, bsError) @@ -23,95 +23,95 @@ import Prim iParams :: ErrorHandle -> IModule a -> IO (IModule a) iParams errh imod = let - ds = imod_local_defs imod - ss = imod_state_insts imod - - {- - -- XXX not needed because we don't need to know the Ids, - -- XXX because the references are marked as ICModParam - size_ps = imod_type_args imod - inputs = imod_wire_args imod - wi = imod_external_wires imod - varginfo = wArgs wi - - -- identify which inputs are parameters - param_inputs = [ i | (i, Param {}) <- zip inputs varginfo ] - - param_ids = map fst size_ps ++ - map fst param_inputs - -} - - -- create a map of ids and the exprs they inline to - -- (with each expr already itself inlined completely) - -- (assuming that "ds" is tsorted) + ds = imod_local_defs imod + ss = imod_state_insts imod + + {- + -- XXX not needed because we don't need to know the Ids, + -- XXX because the references are marked as ICModParam + size_ps = imod_type_args imod + inputs = imod_wire_args imod + wi = imod_external_wires imod + varginfo = wArgs wi + + -- identify which inputs are parameters + param_inputs = [ i | (i, Param {}) <- zip inputs varginfo ] + + param_ids = map fst size_ps ++ + map fst param_inputs + -} + + -- create a map of ids and the exprs they inline to + -- (with each expr already itself inlined completely) + -- (assuming that "ds" is tsorted) --dmap :: M.Map Id (IExpr a) - dmap = M.fromList [ (i, iSubst dmap e) | IDef i _ e _ <- ds ] + dmap = M.fromList [ (i, iSubst dmap e) | IDef i _ e _ <- ds ] - ss' = map (inlineParams dmap) ss - imod' = imod { imod_state_insts = ss' } + ss' = map (inlineParams dmap) ss + imod' = imod { imod_state_insts = ss' } - emsgs = concatMap checkParams ss' + emsgs = concatMap checkParams ss' in - if (null emsgs) - then return imod' - else bsError errh emsgs + if (null emsgs) + then return imod' + else bsError errh emsgs inlineParams :: M.Map Id (IExpr a) -> (Id, IStateVar a) -> (Id, IStateVar a) inlineParams dmap (inst, svar) = let - -- get the relevant fields from the IStateVar - varginfo = vArgs (isv_vmi svar) - es = isv_iargs svar - - -- for each parameter instantiation argument, - -- inline variables references in its instantiation expression - inlineParam (Param {}, expr) = iSubst dmap expr - inlineParam (_, expr) = expr - - -- create the new IStateVar to return - es' = map inlineParam (zip varginfo es) - svar' = svar { isv_iargs = es' } + -- get the relevant fields from the IStateVar + varginfo = vArgs (isv_vmi svar) + es = isv_iargs svar + + -- for each parameter instantiation argument, + -- inline variables references in its instantiation expression + inlineParam (Param {}, expr) = iSubst dmap expr + inlineParam (_, expr) = expr + + -- create the new IStateVar to return + es' = map inlineParam (zip varginfo es) + svar' = svar { isv_iargs = es' } in - (inst, svar') + (inst, svar') checkParams :: (Id, IStateVar a) -> [EMsg] checkParams (inst, svar) = let - -- get the relevant fields from the IStateVar - varginfo = vArgs (isv_vmi svar) - arg_es = isv_iargs svar - - -- position for reporting errors - pos = getPosition inst - - -- users only know the instantiation arguments by position, - -- so zip with a number indicating the position - triples = zip3 [1..] varginfo arg_es - - -- check a single param - checkParam :: (Integer, VArgInfo, IExpr a) -> [EMsg] - checkParam (n, varginfo@(Param {}), expr) = - if (not (isConstIExpr expr)) - then let port_name = getIdString (getVArgInfoName varginfo) - inst_name = getIdString inst - in [(pos, EModParameterDynamic inst_name port_name)] - else [] - checkParam _ = [] + -- get the relevant fields from the IStateVar + varginfo = vArgs (isv_vmi svar) + arg_es = isv_iargs svar + + -- position for reporting errors + pos = getPosition inst + + -- users only know the instantiation arguments by position, + -- so zip with a number indicating the position + triples = zip3 [1..] varginfo arg_es + + -- check a single param + checkParam :: (Integer, VArgInfo, IExpr a) -> [EMsg] + checkParam (n, varginfo@(Param {}), expr) = + if (not (isConstIExpr expr)) + then let port_name = getIdString (getVArgInfoName varginfo) + inst_name = getIdString inst + in [(pos, EModParameterDynamic inst_name port_name)] + else [] + checkParam _ = [] in - concatMap checkParam triples + concatMap checkParam triples -- XXX copied from IInline; consider putting it in one place? iSubst :: M.Map Id (IExpr a) -> IExpr a -> IExpr a iSubst m e = sub e where sub (IAps f ts es) = IAps (sub f) ts (map sub es) - sub d@(ICon i _) = - case M.lookup i m of - Nothing -> d - Just e -> e - sub ee = internalError ("iSubst: " ++ ppReadable ee) + sub d@(ICon i _) = + case M.lookup i m of + Nothing -> d + Just e -> e + sub ee = internalError ("iSubst: " ++ ppReadable ee) -- ========== @@ -172,7 +172,7 @@ isConstAExpr _ (ASAny {}) = isConstAExpr _ e@(ASDef {}) = -- Local def references should have been inlined away internalError ("Params.isConstAExpr: inlining not complete: " ++ - ppReadable e) + ppReadable e) -- XXX could have said "False" here, so that it's available -- XXX for other uses? isConstAExpr ps (APrim { aprim_prim = op, ae_args = es }) = diff --git a/src/comp/ParseOp.hs b/src/comp/ParseOp.hs index 9432d2008..ec5f5abaa 100644 --- a/src/comp/ParseOp.hs +++ b/src/comp/ParseOp.hs @@ -147,10 +147,10 @@ pExpr ft (CCon i es) = do pExpr ft (Ccase pos e as) = do e' <- pExpr ft e let pCaseArm arm = do - new_pattern <- pPat ft (cca_pattern arm) - new_filters <- mapM (pQual ft) (cca_filters arm) - new_consequent <- pExpr ft (cca_consequent arm) - return (CCaseArm { cca_pattern = new_pattern, + new_pattern <- pPat ft (cca_pattern arm) + new_filters <- mapM (pQual ft) (cca_filters arm) + new_consequent <- pExpr ft (cca_consequent arm) + return (CCaseArm { cca_pattern = new_pattern, cca_filters = new_filters, cca_consequent = new_consequent }) as' <- mapM pCaseArm as @@ -296,33 +296,33 @@ doOne ft [] ((a,o):os) es = doOp ft a o [] os es doOne ft (CRand e:rs) os es = doOne ft rs os (e:es) doOne ft (CRator a iop:rs) [] es = doOne ft rs [(a,iop)] es doOne ft rrs@(CRator ia iop:rs) oos@((sa,sop):os) es = - let (iprec,iass) = precOfA ft ia iop - (sprec,sass) = precOfA ft sa sop - in {-if iass==FPrefix iprec && iprec <= sprec then - EMError (getIdPosition iop, ESyntax (ppId iop) []) - else-} - if iprec==sprec && (iass/=sass || iass==FInfix iprec) {- && sass /= FPrefix sprec-} then - EMError [(getIdPosition sop, EAmbOper (pfpString sop) (pfpString iop))] - else if iprec>sprec || iprec==sprec && iass==FInfixr iprec then - doOne ft rs ((ia,iop):oos) es - else - doOp ft sa sop rrs os es + let (iprec,iass) = precOfA ft ia iop + (sprec,sass) = precOfA ft sa sop + in {-if iass==FPrefix iprec && iprec <= sprec then + EMError (getIdPosition iop, ESyntax (ppId iop) []) + else-} + if iprec==sprec && (iass/=sass || iass==FInfix iprec) {- && sass /= FPrefix sprec-} then + EMError [(getIdPosition sop, EAmbOper (pfpString sop) (pfpString iop))] + else if iprec>sprec || iprec==sprec && iass==FInfixr iprec then + doOne ft rs ((ia,iop):oos) es + else + doOp ft sa sop rrs os es doOp :: FixTable -> Int -> Id -> [COp] -> [(Int, Id)] -> [CExpr] -> ErrorMonad CExpr doOp ft a op rs os es = {- if idFString op == fsMinus && a == 1 then - case es of - e:es' -> doOne ft rs os (ENegate e : es') - _ -> internalError ("Bad operator arity (1) for "++pfpString op) + case es of + e:es' -> doOne ft rs os (ENegate e : es') + _ -> internalError ("Bad operator arity (1) for "++pfpString op) else -} - case es of - e1:e2:es' -> -- XXX := to Cwrite (see above) + case es of + e1:e2:es' -> -- XXX := to Cwrite (see above) do let e' = if (op `qualEq` idAssign) then Cwrite (getPosition op) e2 e1 else CBinOp e2 op e1 doOne ft rs os (e' : es') - _ -> internalError ("ParseOp.doOp: Bad operator arity (2) for "++pfpString op) + _ -> internalError ("ParseOp.doOp: Bad operator arity (2) for "++pfpString op) precOfA ft _ i = case getIdFixity ft i of diff --git a/src/comp/Parser/BSV/CVParser.lhs b/src/comp/Parser/BSV/CVParser.lhs index c24a14409..21ebb85f4 100644 --- a/src/comp/Parser/BSV/CVParser.lhs +++ b/src/comp/Parser/BSV/CVParser.lhs @@ -4101,7 +4101,7 @@ a function definition, and a body must be present. > mbody <- pFunctionTail startPos > True > (cf_name funProto) -> args +> args > case mbody of > Nothing -> return funProto > Just e -> return funProto{ cf_default = diff --git a/src/comp/Parser/BSV/CVParserAssertion.lhs b/src/comp/Parser/BSV/CVParserAssertion.lhs index 308439635..de19394cf 100644 --- a/src/comp/Parser/BSV/CVParserAssertion.lhs +++ b/src/comp/Parser/BSV/CVParserAssertion.lhs @@ -254,7 +254,7 @@ These fix an ambiguity in the parser's handling of $ > then cvtErr noPosition (EIllegalAssertExpr "" "lower range") > else if isUnbound e2 > then return (SVA_Delay_Unbound e1) -> else do +> else do > return (SVA_Delay_Range e1 e2) > fixUnboundDelay (SVA_Delay_Const exp) = > do @@ -1304,7 +1304,7 @@ Main translation function > bClean<- cleanupProp bDeSugared > (defs, top) <- transAssertBody isAlways bClean > let nmId = mkId pos (mkFString nm) -> let ifcId = mkIdPre fs_the_ (unQualId nmId) -- XXX filename gen in top only!!! +> let ifcId = mkIdPre fs_the_ (unQualId nmId) -- XXX filename gen in top only!!! > passExpr <- mkAction onPass > failExpr <- mkAction onFail > assertMod <- instAssertMod isAlways bClean (top, passExpr, failExpr) @@ -1406,7 +1406,7 @@ Makes a sub-module for mkPropImplies. This submodule can then be replicated > let > propType = > CQType [(CPred (CTypeclass (idIsModuleAt noPosition)) -> [cTVar (idM noPosition), cTVar (idC noPosition)])] +> [cTVar (idM noPosition), cTVar (idC noPosition)])] > (TAp (cTVar (idM noPosition)) > (cTCon (mkId noPosition (mkFString "Property")))) > intType = cTCon (mkId noPosition (mkFString "Property")) diff --git a/src/comp/Parser/BSV/CVParserCommon.lhs b/src/comp/Parser/BSV/CVParserCommon.lhs index 04bb3d9a4..f59b6dd83 100644 --- a/src/comp/Parser/BSV/CVParserCommon.lhs +++ b/src/comp/Parser/BSV/CVParserCommon.lhs @@ -1269,8 +1269,8 @@ saying whether or not the declaration is local > findDecl :: Id -> [DeclaredVars] -> (Maybe DeclarationInfo, Bool) > -- the Maybe says whether it's declared > findDecl var issDs = fd issDs True where -> fd [] _ = (Nothing, False) -> fd (d:ds) isTop = +> fd [] _ = (Nothing, False) +> fd (d:ds) isTop = > case var `M.lookup` d of > Nothing -> fd ds False > x -> (x, isTop) diff --git a/src/comp/Parser/BSV/CVParserImperative.lhs b/src/comp/Parser/BSV/CVParserImperative.lhs index c04867c6c..be74532e8 100644 --- a/src/comp/Parser/BSV/CVParserImperative.lhs +++ b/src/comp/Parser/BSV/CVParserImperative.lhs @@ -418,7 +418,7 @@ XXX perhaps should see whether the following few clauses could share code > -- XXX that they *really* don't belong here... > -- rightHandSides = > -- concat ([conseq | (pos, pat, tests, conseq) <- arms] ++ -> -- [conseq | (pos, conseq) <- maybeToList dfltArm]) +> -- [conseq | (pos, conseq) <- maybeToList dfltArm]) > -- updatedVarList = S.toList updatedVars > -- variables bound in the patterns > -- allPatternVars = @@ -670,13 +670,13 @@ endfunction > convImperativeStmtsToCStmts (ISCIsModule,t,_) True [] = do > let it = case t of > Nothing -> Nothing -> Just t -> leftCon t +> Just t -> leftCon t > when (isNothing it) (cvtErr (getPosition t) EBadInterface) > return [CSExpr Nothing (CApply (CVar (idReturn noPosition)) [Cinterface noPosition it []])] > convImperativeStmtsToCStmts ((ISCModule _),t,_) True [] = do > let it = case t of > Nothing -> Nothing -> Just t -> leftCon t +> Just t -> leftCon t > when (isNothing it) (cvtErr (getPosition t) EBadInterface) > return [CSExpr Nothing (CApply (CVar (idReturn noPosition)) [Cinterface noPosition it []])] > convImperativeStmtsToCStmts _ _ [] = return [] @@ -799,7 +799,7 @@ endfunction > convImperativeStmtsToCStmts c_mt_me@(context,_,_) atEnd (ISWhile pos cond whbody : rest) > | not (isMonadicContext context) = cvtErr pos (EForbiddenWhile (pvpString context)) > convImperativeStmtsToCStmts -> c_mt_me@(context,_,_) atEnd (w@(ISWhile pos cond whbody) : rest) = +> c_mt_me@(context,_,_) atEnd (w@(ISWhile pos cond whbody) : rest) = > if stmtIsNonMonadic w > then > do e <- convImperativeStmtsToCExpr pos @@ -1189,7 +1189,7 @@ endfunction > | atEnd && all isISMethod rest = > do let it = case mt of > Nothing -> Nothing -> Just t -> leftCon t +> Just t -> leftCon t > when (isNothing it) (cvtErr (getPosition mt) EBadInterface) > let methods = [method | ISMethod _ method <- stmts] > ifc = Cinterface pos it methods @@ -1719,7 +1719,7 @@ Extract each type of statement, making sure to preserve the order > mcs = methodClauses ms > ics = map mkBSVIfc is > clss = mcs++ics -> in CLValue name [CClause [][] (Cinterface lastPos (Just constr) clss)] [] +> in CLValue name [CClause [][] (Cinterface lastPos (Just constr) clss)] [] > > isRealMethod (_,Method i _ _ _ _ _ _,_) = not (isRdyId i) > isRealMethod _ = True @@ -1733,7 +1733,7 @@ Extract each type of statement, making sure to preserve the order > chkBSVMethod m = return () > theFamilies cs as fs = do > let dup_cs = findSame cs -> when (not (null dup_cs)) $ +> when (not (null dup_cs)) $ > cvtErrs [ (getPosition c, EDuplicateClocks (getIdString c)) > | (c:_) <- dup_cs ] > let sings = map (\i -> [i]) cs @@ -1756,8 +1756,8 @@ Extract each type of statement, making sure to preserve the order > _ -> internalError "duplicate clocks" > return (if already then fams > else ((f1 `union` f2):rs)) -> res0 <- foldM unify sings as -> foldM unify res0 fs +> res0 <- foldM unify sings as +> foldM unify res0 fs > mapM_ chkBSVMethod (map second allmethods) > methods' <- mapM addClockAndReset allmethods @@ -1771,23 +1771,23 @@ Extract each type of statement, making sure to preserve the order > let methodClock nam = do > let mis = [ c | (Method n c r m i o e) <- methods', n==nam] -> (when (null mis) (cvtErr (getPosition nam) EInvalidMethod)) -> let c = case mis of +> (when (null mis) (cvtErr (getPosition nam) EInvalidMethod)) +> let c = case mis of > [Nothing] -> idNoClock > [Just ci] -> ci > _ -> internalError ("multiple method clocks | " ++ > show nam ++ " | " ++ show mis) -> return c +> return c > checkScheduleClocks fs (p,(i2s,CF,i1s)) = do (return ()) > checkScheduleClocks fs (p,(i2s,_,i1s)) = do > cs <- mapM methodClock (i1s ++ i2s) -> (when (null cs) (internalError ("empty cs at "++show p))) +> (when (null cs) (internalError ("empty cs at "++show p))) > (when (any (==idNoClock) cs) (cvtErr p EScheduleNoClock)) -> let c1 = head cs -> let fs0 = filter (elem c1) fs +> let c1 = head cs +> let fs0 = filter (elem c1) fs > (when (null fs0) (internalError ("empty fs0 at "++show p ++ > "| c1 = " ++ show c1))) -> let f = head fs0 +> let f = head fs0 > (when (not (all (\ x -> x `elem` f) cs)) > (cvtErr p EScheduleUnrelatedClocks)) > return () @@ -2513,8 +2513,8 @@ Check for use of unassigned variables; if any are found, report errors > -> ISConvMonad [ImperativeStatement] > checkImperativeStmts context stmts = > do let mInfo pos = case context of -> ISCModule t -> (t,[]) -> _ -> defaultModuleMonadInfo pos +> ISCModule t -> (t,[]) +> _ -> defaultModuleMonadInfo pos > stmtss' <- mapM (checkImperativeStmt mInfo) stmts > declaredVars <- getDeclaredVars > normallyAssignedVars <- getNormallyAssignedVars @@ -2568,8 +2568,8 @@ XXX Detecting function argument collisions TBD > return [] > checkImperativeStmt mi (ISDecl pos (Left vars) (Just typ) preds) = do > case undoTuple typ of -> Nothing -> (cvtErr pos EForbiddenTuple) -> Just ts -> do +> Nothing -> (cvtErr pos EForbiddenTuple) +> Just ts -> do > when (length ts /= length vars) > (cvtErr pos EForbiddenTuple) > let f (Left _) _ = return () diff --git a/src/comp/Parser/BSV/CVParserUtil.lhs b/src/comp/Parser/BSV/CVParserUtil.lhs index 9b3e3b5b9..aa25a68e5 100644 --- a/src/comp/Parser/BSV/CVParserUtil.lhs +++ b/src/comp/Parser/BSV/CVParserUtil.lhs @@ -11,28 +11,28 @@ it parses, rewind to before the terminator and return the list so far > stmtIsNonMonadic :: ImperativeStatement -> Bool > stmtIsNonMonadic stmt = > case stmt of -> ISDecl _ _ _ _ -> True -> ISPatEq _ _ _ -> True -> ISEqual _ _ _ -> True -> ISUpdate _ _ _ -> True +> ISDecl _ _ _ _ -> True +> ISPatEq _ _ _ -> True +> ISEqual _ _ _ -> True +> ISUpdate _ _ _ -> True > ISFunction _ _ _ -> True > ISFor _ init _ inc body -> stmtsAreNonMonadic init && -> stmtsAreNonMonadic inc && -> stmtsAreNonMonadic body -> ISWhile _ _ body -> stmtsAreNonMonadic body -> ISBeginEnd _ body -> stmtsAreNonMonadic body -> ISIf _ _ con Nothing -> stmtsAreNonMonadic con +> stmtsAreNonMonadic inc && +> stmtsAreNonMonadic body +> ISWhile _ _ body -> stmtsAreNonMonadic body +> ISBeginEnd _ body -> stmtsAreNonMonadic body +> ISIf _ _ con Nothing -> stmtsAreNonMonadic con > ISIf _ _ con (Just alt) -> stmtsAreNonMonadic con && -> stmtsAreNonMonadic alt +> stmtsAreNonMonadic alt > ISCase _ _ cs d -> (all caseIsNonMonadic cs) && -> defaultIsNonMonadic d +> defaultIsNonMonadic d > ISCaseTagged _ _ cs d -> (all caseTIsNonMonadic cs) && -> defaultIsNonMonadic d -> _ -> False -> where caseIsNonMonadic (_, _, ss) = stmtsAreNonMonadic ss -> caseTIsNonMonadic (_, _, _, ss) = stmtsAreNonMonadic ss -> defaultIsNonMonadic Nothing = True -> defaultIsNonMonadic (Just (_, ss)) = stmtsAreNonMonadic ss +> defaultIsNonMonadic d +> _ -> False +> where caseIsNonMonadic (_, _, ss) = stmtsAreNonMonadic ss +> caseTIsNonMonadic (_, _, _, ss) = stmtsAreNonMonadic ss +> defaultIsNonMonadic Nothing = True +> defaultIsNonMonadic (Just (_, ss)) = stmtsAreNonMonadic ss > let fn = (case stmt of diff --git a/src/comp/Parser/Classic/CParser.hs b/src/comp/Parser/Classic/CParser.hs index b8a294cdf..4d956d8ad 100644 --- a/src/comp/Parser/Classic/CParser.hs +++ b/src/comp/Parser/Classic/CParser.hs @@ -69,13 +69,13 @@ pExpExcludedId = pConId >>- CExpCon ||! pVarId >>- CExpVar pImport :: CParser CImport -pImport = l L_import ..+ pOptQualified +.+ pModId >>> CImpId +pImport = l L_import ..+ pOptQualified +.+ pModId >>> CImpId pFixity :: CParser CFixity pFixity = - l L_infix ..+ int +.+ pOper >>> CInfix - ||! l L_infixl ..+ int +.+ pOper >>> CInfixl - ||! l L_infixr ..+ int +.+ pOper >>> CInfixr + l L_infix ..+ int +.+ pOper >>> CInfix + ||! l L_infixl ..+ int +.+ pOper >>> CInfixl + ||! l L_infixr ..+ int +.+ pOper >>> CInfixr pOptQualified :: CParser Bool pOptQualified = l L_qualified .> True ||! succeed False @@ -84,46 +84,46 @@ pExpr :: Parser [Token] CExpr pExpr = exp0 exp0 :: CParser CExpr -exp0 = exp00 >>- (\x->case x of [CRand e] -> e; _ -> COper x) +exp0 = exp00 >>- (\x->case x of [CRand e] -> e; _ -> COper x) exp00 :: CParser [COp] -exp00 = {-negat +.+ expX +.+ exp01 >>- (\ (u,(e,es)) -> CRator 1 u : CRand e : es) - ||! -} expX +.+ exp01 >>- (\ (e, es) -> CRand e : es) +exp00 = {-negat +.+ expX +.+ exp01 >>- (\ (u,(e,es)) -> CRator 1 u : CRand e : es) + ||! -} expX +.+ exp01 >>- (\ (e, es) -> CRand e : es) exp01 :: CParser [COp] -exp01 = pOper +.+ exp00 >>- (\ (o, es) -> CRator 2 o : es) - ||! succeed [] +exp01 = pOper +.+ exp00 >>- (\ (o, es) -> CRator 2 o : es) + ||! succeed [] expX :: CParser CExpr -expX = blockKwOf L_let pDeflM +.+ l L_in ..+ exp0 >>> Cletrec - ||! blockKwOf L_letseq pDeflM +.+ l L_in ..+ exp0 >>> Cletseq - ||! l L_case +.+ exp0 +.+ l L_of ..+ blockOf noTrig pCaseArm >>>> Ccase - ||! getPos +.+ l L_lam ..+ many1 pPat +.+ l L_rarrow ..+ exp0 >>>> cLam +expX = blockKwOf L_let pDeflM +.+ l L_in ..+ exp0 >>> Cletrec + ||! blockKwOf L_letseq pDeflM +.+ l L_in ..+ exp0 >>> Cletseq + ||! l L_case +.+ exp0 +.+ l L_of ..+ blockOf noTrig pCaseArm >>>> Ccase + ||! getPos +.+ l L_lam ..+ many1 pPat +.+ l L_rarrow ..+ exp0 >>>> cLam ||! l L_if +.+ exp0 +.+ osm ..+ l L_then ..+ exp0 +.+ osm ..+ l L_else ..+ exp0 >>>>> Cif - ||! pTyConId +.+ pFieldBlock >>> CStruct - ||! l L_valueOf +.+ atyp >>- ( \ (p, t) -> cVApply (setIdPosition p idValueOf) [CHasType (anyExprAt p) (CQType [] (TAp (cTCon idBit) t))]) + ||! pTyConId +.+ pFieldBlock >>> CStruct + ||! l L_valueOf +.+ atyp >>- ( \ (p, t) -> cVApply (setIdPosition p idValueOf) [CHasType (anyExprAt p) (CQType [] (TAp (cTCon idBit) t))]) ||! aexp `into` (\ e -> - blockKwOf L_where pDefl >>- flip Cletrec e + blockKwOf L_where pDefl >>- flip Cletrec e ||! l L_lbra ..+ exp0 `into` (\ e' -> - l L_colon ..+ exp0 +.. l L_rbra >>- CSub2 e e') - ||! dc ..+ pQType >>- CHasType e - ||! pFieldBlock >>- CStructUpd e - ||! many aexp >>- cmtApply 9 e) --- ||! blkexp + l L_colon ..+ exp0 +.. l L_rbra >>- CSub2 e e') + ||! dc ..+ pQType >>- CHasType e + ||! pFieldBlock >>- CStructUpd e + ||! many aexp >>- cmtApply 9 e) +-- ||! blkexp -- The following could be atomic - ||! blockKw L_rules pRules >>- (Crules []) + ||! blockKw L_rules pRules >>- (Crules []) ||! (getPos `into` \ pos -> l L_interface `into` \ tp -> (pTyConId >>- Just) +.+ blockOf tp pTDefl >>> Cinterface pos) ||! pModule -- blocks that can be regarded as atomic blkexp :: CParser CExpr -blkexp = l L_do ..+ blockOf noTrig pStmt >>- Cdo True +blkexp = l L_do ..+ blockOf noTrig pStmt >>- Cdo True ||! l L_action `into` \pos -> blockOf noTrig pStmt >>- Caction pos --pModule :: CParser CExpr pModule = l L_module `into` \ pos -> - blockOf noTrig pMStmt >>- Cmodule pos + blockOf noTrig pMStmt >>- Cmodule pos ||! l L_verilog ..+ aexp +.+ pOParen (sepBy1 (pParen (pString +.+ cm ..+ pExpr)) cm) +.+ sepBy1 pString cm +.+ sepBy pString cm +.+ pOParen (sepBy1 (pParen (pString +.+ pVeriPortProps +.+ cm ..+ pExpr)) cm) +.+ @@ -153,8 +153,8 @@ pMStmt = pModuleInterface pModuleInterface :: CParser CMStmt pModuleInterface = getPos `into` \pos -> l L_interface `into` \ tp -> - lp ..+ sepBy exp0 (l L_comma) +.. rp >>- CMTupleInterface tp - ||! opt pTyConId +.+ blockOf tp pTDefl >>- (\ (oty, defs) -> CMinterface (Cinterface pos oty defs)) + lp ..+ sepBy exp0 (l L_comma) +.. rp >>- CMTupleInterface tp + ||! opt pTyConId +.+ blockOf tp pTDefl >>- (\ (oty, defs) -> CMinterface (Cinterface pos oty defs)) pModuleRules :: CParser CMStmt pModuleRules = blockKw L_rules pRules >>- CMrules . (Crules []) @@ -165,7 +165,7 @@ pSchedInfo = pMethodConflictInfo >>- (\mci -> SchedInfo mci [] [] []) pMethodConflictInfo :: CParser VMethodConflictInfo pMethodConflictInfo = - l L_lbra ..+ sepBy (pMeths +.+ pMethodConflictOp +.+ pMeths) cm +.. l L_rbra >>- vMethodConflictInfo + l L_lbra ..+ sepBy (pMeths +.+ pMethodConflictOp +.+ pMeths) cm +.. l L_rbra >>- vMethodConflictInfo ||! succeed (MethodConflictInfo [] [] [] [] [] [] []) where pMethodConflictOp = ltgt .> CF ||! lt .> SB ||! ltlt .> SBR ||! confOp .> C pMeths = l L_lbra ..+ sepBy pFieldId cm +.. l L_rbra ||! pFieldId >>- (:[]) @@ -191,83 +191,83 @@ pStmt = (pHVarId `into` \ i -> dc ..+ (pQType `into` \ t -> sm ..+ (piHEq i `into` \ j -> l L_larrow ..+ pExpr >>- CSBindT (kCPVar j) Nothing [] t) - ||! l L_larrow ..+ pExpr >>- CSBindT (kCPVar i) Nothing [] t) - ||! l L_larrow ..+ pExpr >>- CSBind (kCPVar i) Nothing []) --- ||! pPat +.+ dc ..+ pQType +.+ l L_larrow ..+ pExpr >>>> CSBindT + ||! l L_larrow ..+ pExpr >>- CSBindT (kCPVar i) Nothing [] t) + ||! l L_larrow ..+ pExpr >>- CSBind (kCPVar i) Nothing []) +-- ||! pPat +.+ dc ..+ pQType +.+ l L_larrow ..+ pExpr >>>> CSBindT ||! (pPat `into` \ p -> - dc ..+ pQType +.+ l L_larrow ..+ pExpr >>> CSBindT p Nothing [] - ||! l L_larrow ..+ pExpr >>- CSBind p Nothing []) - ||! blockKwOf L_let pDeflM >>- CSletrec - ||! blockKwOf L_letseq pDeflM >>- CSletseq - ||! pExpr >>- CSExpr Nothing + dc ..+ pQType +.+ l L_larrow ..+ pExpr >>> CSBindT p Nothing [] + ||! l L_larrow ..+ pExpr >>- CSBind p Nothing []) + ||! blockKwOf L_let pDeflM >>- CSletrec + ||! blockKwOf L_letseq pDeflM >>- CSletseq + ||! pExpr >>- CSExpr Nothing kCPVar i = (CPVar (setKeepId i)) aexp :: CParser CExpr -aexp = aexp' +.+ many suff >>> foldl (\ x f -> f x) +aexp = aexp' +.+ many suff >>> foldl (\ x f -> f x) suff :: CParser (CExpr -> CExpr) -suff = dot ..+ pFieldId >>- flip CSelect +suff = dot ..+ pFieldId >>- flip CSelect ||! l L_lbra ..+ exp0 `into` (\ e' -> - l L_colon ..+ exp0 +.. l L_rbra >>- \ e2 -> \ e -> CSub2 e e' e2) + l L_colon ..+ exp0 +.. l L_rbra >>- \ e2 -> \ e -> CSub2 e e' e2) aexp' :: CParser CExpr -aexp' = pAny >>- anyExprAt - ||! pVarId >>- cVar - ||! pConId >>- (\ i -> CCon i []) - ||! lp ..+ dot ..+ pFieldId +.. rp >>- CLam (Right id_x) . CSelect (cVar id_x) - ||! lp +.+ sepBy exp0 (l L_comma) +.. rp >>> mkTuple +aexp' = pAny >>- anyExprAt + ||! pVarId >>- cVar + ||! pConId >>- (\ i -> CCon i []) + ||! lp ..+ dot ..+ pFieldId +.. rp >>- CLam (Right id_x) . CSelect (cVar id_x) + ||! lp +.+ sepBy exp0 (l L_comma) +.. rp >>> mkTuple ||! numericLit ||! string ||! char ||! blkexp -- XXX maybe it should be expX pQType :: CParser CQType -pQType = pPreds +.+ pType >>> CQType +pQType = pPreds +.+ pType >>> CQType pPreds :: CParser [CPred] pPreds = lp ..+ sepBy1 pPred cm +.. rp +.. l L_irarrow ||| succeed [] pPred :: CParser CPred -pPred = pTypeclass +.+ many atyp >>> CPred +pPred = pTypeclass +.+ many atyp >>> CPred pTypeclass :: CParser CTypeclass -pTypeclass = pTyConId >>- CTypeclass +pTypeclass = pTyConId >>- CTypeclass pType :: CParser CType pType = typ0 atyp :: CParser CType -atyp = pTyConId >>- cTCon - ||! pTyVarId >>- cTVar +atyp = pTyConId >>- cTCon + ||! pTyVarId >>- cTVar ||! pTyNumId - ||! lp +.+ sepBy typ0 (l L_comma) +.. rp >>> tMkTuple + ||! lp +.+ sepBy typ0 (l L_comma) +.. rp >>> tMkTuple typ0 :: CParser CType typ0 = typ10 `into` \ t -> - l L_rarrow +.+ typ0 >>> (\ p r -> cTApplys (cTCon (idArrow p)) [t,r]) - ||! succeed t + l L_rarrow +.+ typ0 >>> (\ p r -> cTApplys (cTCon (idArrow p)) [t,r]) + ||! succeed t --mkTBinOp l op r = cTApplys (cTCon op) [l, r] typ10 :: CParser CType -typ10 = atyp +.+ many atyp >>> cTApplys +typ10 = atyp +.+ many atyp >>> cTApplys pDeflM :: CParser CDefl pDeflM = pDefl - ||! pPat +.+ eq ..+ pExpr >>> CLMatch + ||! pPat +.+ eq ..+ pExpr >>> CLMatch pDefl :: CParser CDefl pDefl = (pVarId +.+ dc ..+ pQType `into` \ (i,t) -> - dsm ..+ pClauses1 i >>- (\ e -> CLValueSign (CDef i t e) []) - ||! eq ..+ exp0 >>- (\ e -> CLValueSign (CDef i t [CClause [] [] e]) [])) - ||! pClauseAny `into` \ (i, c) -> pClauses i >>- (\ cs -> CLValue i (c:cs) []) + dsm ..+ pClauses1 i >>- (\ e -> CLValueSign (CDef i t e) []) + ||! eq ..+ exp0 >>- (\ e -> CLValueSign (CDef i t [CClause [] [] e]) [])) + ||! pClauseAny `into` \ (i, c) -> pClauses i >>- (\ cs -> CLValue i (c:cs) []) pTDefl :: CParser CDefl pTDefl = pDefl `into` \ d -> - l L_when ..+ sepBy1 pQual cm >>- updWhen d - ||! succeed d + l L_when ..+ sepBy1 pQual cm >>- updWhen d + ||! succeed d where updWhen (CLValueSign d _) qs = CLValueSign d qs updWhen (CLValue i cs _) qs = CLValue i cs qs updWhen (CLMatch _ _) _ = internalError "CParser.pTDefl.updWhen: CLMatch" @@ -285,8 +285,8 @@ pFieldDef :: CParser (Id, CExpr) pFieldDef = pFieldId +.+ eq ..+ pExpr pFieldBlock :: CParser [(Id, CExpr)] -pFieldBlock = blockBrOf pFieldDef -- use `;' ---pFieldBlock = hBlock (sepBy pFieldDef cm) -- use `,' +pFieldBlock = blockBrOf pFieldDef -- use `;' +--pFieldBlock = hBlock (sepBy pFieldDef cm) -- use `,' blockOf :: Position -> CParser a -> CParser [a] blockOf tp p = startBlock tp ..+ hBlock (sepBy p dsm +.. osm) @@ -308,7 +308,7 @@ blockBrOf :: CParser a -> CParser [a] blockBrOf p = hBlock (sepBy p dsm +.. osm) pCaseArm :: CParser CCaseArm -- (CPat, [CQual], CExpr) -pCaseArm = pPat +.+ pOQuals +.+ l L_rarrow ..+ pExpr >>- +pCaseArm = pPat +.+ pOQuals +.+ l L_rarrow ..+ pExpr >>- \ (pattern,(qualifiers,consequent)) -> CCaseArm { cca_pattern = pattern, cca_filters = qualifiers, @@ -385,9 +385,9 @@ pDefnsAndEOF = block noTrig pDefns +.. osm +.. eof pDefn' :: CParser CDefn pDefn' = pVarDefn - ||! l L_instance ..+ pQType +.+ l L_where ..+ blockOf noTrig pDefl >>> Cinstance + ||! l L_instance ..+ pQType +.+ l L_where ..+ blockOf noTrig pDefl >>> Cinstance ||! pTyDefn True - ||! pPragma >>- CPragma + ||! pPragma >>- CPragma -- parse variable definition -- XXX backtracks :( @@ -397,15 +397,15 @@ pVarDefn = (pVarId +.+ dc ..+ pQType +.. dsm `into` \(var, typ) -> pClauses1 v pTyDefn :: Bool -> CParser CDefn pTyDefn b = l L_foreign ..+ pVarId +.+ dc ..+ pQType +.+ opt (eq ..+ pString) +.+ opt (cm ..+ lp ..+ many pString +.+ pForeignRes +.. rp) >>>>> Cforeign - ||! l L_primitive ..+ pVarId +.+ dc ..+ pQType >>> Cprimitive --- ||! l L_primitive ..+ l L_class ..+ pPreds +.+ pTyConIdK +.+ many pTyVarId +.+ pFunDeps >>>>> CprimClass - ||! l L_primitive ..+ l L_type ..+ pTyConId +.+ dc ..+ pKind >>- (\ (i, k) -> CprimType (IdKind i k)) - ||! l L_type ..+ pTyConIdK +.+ many pTyVarId +.+ eq ..+ typ0 >>>> Ctype - ||! l L_struct ..+ pTyConIdK +.+ many pTyVarId +.+ eql b +.+ blockOf noTrig pQStructField +.+ pDer >>- + ||! l L_primitive ..+ pVarId +.+ dc ..+ pQType >>> Cprimitive +-- ||! l L_primitive ..+ l L_class ..+ pPreds +.+ pTyConIdK +.+ many pTyVarId +.+ pFunDeps >>>>> CprimClass + ||! l L_primitive ..+ l L_type ..+ pTyConId +.+ dc ..+ pKind >>- (\ (i, k) -> CprimType (IdKind i k)) + ||! l L_type ..+ pTyConIdK +.+ many pTyVarId +.+ eq ..+ typ0 >>>> Ctype + ||! l L_struct ..+ pTyConIdK +.+ many pTyVarId +.+ eql b +.+ blockOf noTrig pQStructField +.+ pDer >>- (\ (ik,(vs,(vis,(fs,der)))) -> Cstruct vis SStruct ik vs fs der) ||! l L_interface ..+ pTyConIdK +.+ many pTyVarId +.+ pIfcPrags +.+ eql b +.+ blockOf noTrig pQStructField +.+ pDer >>- (\ (ik,(vs,(ps,(vis,(fs,der))))) -> Cstruct vis (SInterface ps) ik vs fs der) - ||! l L_class ..+ pOptCoherence +.+ pPreds +.+ pTyConIdK +.+ many pTyVarId +.+ pFunDeps +.+ l L_where ..+ blockOf noTrig pQStructField >>>>>>> Cclass + ||! l L_class ..+ pOptCoherence +.+ pPreds +.+ pTyConIdK +.+ many pTyVarId +.+ pFunDeps +.+ l L_where ..+ blockOf noTrig pQStructField >>>>>>> Cclass pOptCoherence :: CParser (Maybe Bool) pOptCoherence = option pCoherence @@ -418,7 +418,7 @@ pForeignRes = cm ..+ (pString >>- (: []) ||! lp ..+ sepBy1 pString cm +.. rp) pFunDeps :: CParser CFunDeps pFunDeps = bar ..+ sepBy1 pFunDep cm - ||! succeed [] + ||! succeed [] pFunDep :: CParser ([Id],[Id]) pFunDep = many pTyVarId +.+ l L_rarrow ..+ many pTyVarId @@ -484,16 +484,16 @@ eql True = eq .> True eql False = eqeq .> False ||! eq .> True pTyConIdK :: CParser IdK -pTyConIdK = pTyConId >>- IdK - ||! lp ..+ pTyConId +.+ dc ..+ pKind +.. rp >>> IdKind +pTyConIdK = pTyConId >>- IdK + ||! lp ..+ pTyConId +.+ dc ..+ pKind +.. rp >>> IdKind pKind :: CParser Kind -pKind = pAKind `into` \ k -> l L_rarrow ..+ pKind >>- Kfun k +pKind = pAKind `into` \ k -> l L_rarrow ..+ pKind >>- Kfun k ||! succeed k pAKind :: CParser Kind -pAKind = star .> KStar - ||! hash .> KNum +pAKind = star .> KStar + ||! hash .> KNum ||! lp ..+ pKind +.. rp pSummandConIds :: CParser [Id] @@ -502,8 +502,8 @@ pSummandConIds = pConId >>- (:[]) pSummand' :: CParser ([Id], Either [CQType] [(Id, CQType)]) pSummand' = pSummandConIds `into` \ constr_names -> - blockBrOf pQField >>- (\ fs -> (constr_names, Right fs)) - ||! many atyp >>- (\ ts -> (constr_names, Left (map (CQType []) ts))) + blockBrOf pQField >>- (\ fs -> (constr_names, Right fs)) + ||! many atyp >>- (\ ts -> (constr_names, Left (map (CQType []) ts))) pDer :: CParser [CTypeclass] pDer = l L_deriving ..+ lp ..+ sepBy pTypeclass cm +.. rp @@ -520,27 +520,27 @@ pClauses i = many (dsm ..+ pClause i) pClause :: Id -> CParser CClause pClause i = piEq i ..+ many pAPat +.+ pOQuals +.+ eq ..+ exp0 >>>> CClause - ||! pAPat +.+ psEq i ..+ pAPat +.+ pOQuals +.+ eq ..+ exp0 >>- \ (p1,(p2,(mq,e))) -> CClause [p1,p2] mq e + ||! pAPat +.+ psEq i ..+ pAPat +.+ pOQuals +.+ eq ..+ exp0 >>- \ (p1,(p2,(mq,e))) -> CClause [p1,p2] mq e pClauseAny :: CParser (Id, CClause) -pClauseAny = pVarId +.+ (many pAPat +.+ pOQuals +.+ eq ..+ exp0 >>>> CClause) +pClauseAny = pVarId +.+ (many pAPat +.+ pOQuals +.+ eq ..+ exp0 >>>> CClause) pOQuals :: CParser [CQual] -pOQuals = pQuals >>- snd +pOQuals = pQuals >>- snd ||! succeed [] pQuals :: CParser (Position, [CQual]) pQuals = l L_when +.+ sepBy1 pQual cm pQual :: CParser CQual -pQual = pPat +.+ l L_larrow ..+ pExpr >>> CQGen noType - ||| pExpr >>- CQFilter +pQual = pPat +.+ l L_larrow ..+ pExpr >>> CQGen noType + ||| pExpr >>- CQFilter pRule :: CParser CRule pRule = many (pRulePragma +.. osm) +.+ option pLabel +.+ pQuals `into` \ (rps, (ml, (tp, qs))) -> - l L_drarrow ..+ pExpr >>- CRule rps ml qs - ||! blockKwOf L_rules pRule >>- CRuleNest rps ml qs + l L_drarrow ..+ pExpr >>- CRule rps ml qs + ||! blockKwOf L_rules pRule >>- CRuleNest rps ml qs pRules :: CParser [CRule] pRules = sepBy pRule dsm +.. osm @@ -557,8 +557,8 @@ pPat :: CParser CPat pPat = pPatApply ||! pPatOp ||! pAPat pPatApply :: CParser CPat -pPatApply = pConId `into` (\ c -> blockBrOf pPField >>- CPstruct c - ||! many1 pAPat >>- CPCon c) +pPatApply = pConId `into` (\ c -> blockBrOf pPField >>- CPstruct c + ||! many1 pAPat >>- CPCon c) pPatOp :: CParser CPat pPatOp = binop getFixity mkBinP pConOper pAPat @@ -566,42 +566,42 @@ pPatOp = binop getFixity mkBinP pConOper pAPat {- pAPat' :: CParser CPat -pAPat' = pConId +.+ blockBrOf pPField >>- (\ (c, fs) -> CPstruct c fs) +pAPat' = pConId +.+ blockBrOf pPField >>- (\ (c, fs) -> CPstruct c fs) ||! pAPat -} pAPat :: CParser CPat pAPat = pVarIdOrU `into` (\ mi -> - l L_at ..+ pAPat >>- (\ p -> case mi of + l L_at ..+ pAPat >>- (\ p -> case mi of Right i -> CPAs i p Left _ -> p ) ||! succeed (case mi of Right i -> CPVar i Left pos -> CPAny pos )) - ||! pConId >>- (\i -> CPCon i []) - ||! lp +.+ sepBy pPat (l L_comma) +.. rp >>> pMkTuple - ||! numericLit >>- (\ (CLit l) -> CPLit l) + ||! pConId >>- (\i -> CPCon i []) + ||! lp +.+ sepBy pPat (l L_comma) +.. rp >>> pMkTuple + ||! numericLit >>- (\ (CLit l) -> CPLit l) pPField :: CParser (Id, CPat) pPField = pFieldId `into` \ i -> - eq ..+ pPat >>- (\ p -> (i, p)) - ||! succeed (i, CPVar i) + eq ..+ pPat >>- (\ p -> (i, p)) + ||! succeed (i, CPVar i) pPragma :: CParser Pragma pPragma = l L_lpragma ..+ pPragma' +.. l L_rpragma - where pPragma' = l L_verilog ..+ var +.+ pVeris >>- (\ (i, pps) -> Pproperties i (PPverilog : pps)) - ||! l L_synthesize ..+ var +.+ pVeris >>- (\ (i, pps) -> Pproperties i (PPverilog : pps)) - ||! properties ..+ var +.+ pProps >>> Pproperties - ||! noinline ..+ many1 var +.. osm >>- Pnoinline + where pPragma' = l L_verilog ..+ var +.+ pVeris >>- (\ (i, pps) -> Pproperties i (PPverilog : pps)) + ||! l L_synthesize ..+ var +.+ pVeris >>- (\ (i, pps) -> Pproperties i (PPverilog : pps)) + ||! properties ..+ var +.+ pProps >>> Pproperties + ||! noinline ..+ many1 var +.. osm >>- Pnoinline pVeris = optProps pVeriGenProps - pVeriGenProps = literal (mkFString "noReady") .> PPalwaysReady [] -- deprecated + pVeriGenProps = literal (mkFString "noReady") .> PPalwaysReady [] -- deprecated ||! literal (mkFString "alwaysEnabled") .> PPalwaysEnabled [] ||! literal (mkFString "parameter") ..+ var >>- PPparam . (\i -> [i]) ||! literal (mkFString "no_default_clock") .> PPclock_osc [(idDefaultClock,"")] ||! literal (mkFString "no_default_reset") .> PPreset_port [(idDefaultReset,"")] pProps = eq ..+ l L_lcurl ..+ sepBy1 pProp cm +.. l L_rcurl pProp = literal (mkFString "alwaysReady") .> PPalwaysReady [] - ||! literal (mkFString "noReady") .> PPalwaysReady [] -- deprecated + ||! literal (mkFString "noReady") .> PPalwaysReady [] -- deprecated ||! literal (mkFString "alwaysEnabled") .> PPalwaysEnabled [] ||! literal (mkFString "scanInsert") ..+ eq ..+ int >>- PPscanInsert ||! literal (mkFString "bitBlast") .> PPbitBlast @@ -630,16 +630,16 @@ pRulePragma = l L_lpragma ..+ pRulePragma' +.. l L_rpragma ||! hide .> RPhide qvar :: CParser Id -qvar = con +.+ dot ..+ varSym >>> qualId +qvar = con +.+ dot ..+ varSym >>> qualId qcon :: CParser Id -qcon = con +.+ dot ..+ con >>> qualId +qcon = con +.+ dot ..+ con >>> qualId qvarop :: CParser Id -qvarop = con +.+ dot ..+ varop >>> qualId +qvarop = con +.+ dot ..+ varop >>> qualId qconop :: CParser Id -qconop = con +.+ dot ..+ conop >>> qualId +qconop = con +.+ dot ..+ conop >>> qualId pOper :: CParser Id pOper = pAnySym ||! l L_bquote ..+ pAnyId +.. l L_bquote diff --git a/src/comp/Position.hs b/src/comp/Position.hs index 565d6df7a..d13f2de0e 100644 --- a/src/comp/Position.hs +++ b/src/comp/Position.hs @@ -48,7 +48,7 @@ prPosition (Position fs l c pred) = if l<0 && c<0 && f=="" then "Unknown position" else let lc = if l<0 then "" else "line " ++ show3 l ++ (if c < 0 then "" else ", column "++show3 c) show3 = show --until ((>=3) . length) (' ':) . show - in case f of + in case f of "" -> lc _ -> show f' ++ (if null lc then "" else ", "++lc) @@ -61,7 +61,7 @@ prPositionConcise (Position fs l c pred) = if l<0 && c<0 && f=="" then "Unknown position" else let lc = if l<0 then "" else ":" ++ show3 l ++ (if c < 0 then "" else ":"++show3 c) show3 = show --until ((>=3) . length) (' ':) . show - in case f of + in case f of "" -> lc _ -> f' ++ lc diff --git a/src/comp/Pragma.hs b/src/comp/Pragma.hs index 263c0d81e..00df5ea28 100644 --- a/src/comp/Pragma.hs +++ b/src/comp/Pragma.hs @@ -112,7 +112,7 @@ data PProp | PPforeignImport Id -- wrapper for a foreign import -- (Id is link name, needed for dependency check, if we're -- generating the .ba file for the link name, not the src name) - | PPalwaysReady [Longname] -- no ready signals for these methods ([] means all) + | PPalwaysReady [Longname] -- no ready signals for these methods ([] means all) | PPalwaysEnabled [Longname] -- execute on every cycle | PPenabledWhenReady [Longname] -- enable is equivalent to ready | PPscanInsert Integer -- insert scan chain ports diff --git a/src/comp/PreIds.hs b/src/comp/PreIds.hs index 335fef971..310c54e75 100644 --- a/src/comp/PreIds.hs +++ b/src/comp/PreIds.hs @@ -660,9 +660,9 @@ taskIds = [ idFinish, idStop, idSWritebAV, idSWriteb, idSWriteoAV, idSWriteo, idFormat, -- - idSVA, + idSVA, -- - idDumpon, idDumpoff, idDumpvars, idDumpflush, idDumpfile, + idDumpon, idDumpoff, idDumpvars, idDumpflush, idDumpfile, idDumpall, idDumplimit, -- idTime, idSTime, diff --git a/src/comp/PreStrings.hs b/src/comp/PreStrings.hs index e72b712c4..751c24af7 100644 --- a/src/comp/PreStrings.hs +++ b/src/comp/PreStrings.hs @@ -384,9 +384,9 @@ fsTuple7 = mkFString "Tuple7" fsTuple8 = mkFString "Tuple8" fsConstAllBitsSet = mkFString "constantWithAllBitsSet" fsConstAllBitsUnset= mkFString "constantWithAllBitsUnset" -fs_the_ = mkFString "the_" -s__fire = "_fire" -fs__fire = mkFString s__fire +fs_the_ = mkFString "the_" +s__fire = "_fire" +fs__fire = mkFString s__fire fsPrimError = mkFString "primError" diff --git a/src/comp/Pred.hs b/src/comp/Pred.hs index b0d4ac22e..539eeb44e 100644 --- a/src/comp/Pred.hs +++ b/src/comp/Pred.hs @@ -1,13 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module Pred( - Qual(..), PredWithPositions(..), Pred(..), Class(..), Inst(..), + Qual(..), PredWithPositions(..), Pred(..), Class(..), Inst(..), getInsts, - removePredPositions, getPredPositions, addPredPositions, mkPredWithPositions, - expandSyn, predToType, qualToType, mkInst, - Instantiate(..), + removePredPositions, getPredPositions, addPredPositions, mkPredWithPositions, + expandSyn, predToType, qualToType, mkInst, + Instantiate(..), predToCPred, qualTypeToCQType, - ) where + ) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804) import Prelude hiding ((<>)) @@ -37,14 +37,14 @@ import CSyntaxTypes -- Schemes for other identifiers or purposes will contain empty lists. -- data Qual t - = [(PredWithPositions)] :=> t + = [(PredWithPositions)] :=> t deriving (Eq, Ord, Show) instance PPrint t => PPrint (Qual t) where pPrint d p ([] :=> t) = pparen (p>0) $ pPrint d p t pPrint d p (ps :=> t) = pparen (p>0) $ text "(" <> sepList (map (ppPred . removePredPositions) ps) (text ",") <> text ") =>" <+> pPrint d 0 t - where ppPred (IsIn c []) = ppId d (typeclassId $ name c) - ppPred (IsIn c ts) = ppId d (typeclassId $ name c) <+> sep (map (pPrint d 11) ts) + where ppPred (IsIn c []) = ppId d (typeclassId $ name c) + ppPred (IsIn c ts) = ppId d (typeclassId $ name c) <+> sep (map (pPrint d 11) ts) instance PVPrint t => PVPrint (Qual t) where pvPrint d p ([] :=> t) = pvparen (p>0) $ pvPrint d p t @@ -111,7 +111,7 @@ instance Hyper PredWithPositions where ----- data Pred - = IsIn Class [Type] + = IsIn Class [Type] deriving (Eq, Ord, Show) instance PPrint Pred where @@ -133,19 +133,19 @@ predToCPred (IsIn c ts) = CPred (name c) ts ----------------------------------------------------------------------------- data Class - = Class { - name :: CTypeclass, - csig :: [TyVar], + = Class { + name :: CTypeclass, + csig :: [TyVar], super :: [(CTypeclass, Pred)], - tyConOf :: TyCon, - funDeps :: [[Bool]], - funDeps2 :: [[Maybe Bool]], - genInsts :: [TyVar] -> Maybe [TyVar] -> Pred -> [Inst], + tyConOf :: TyCon, + funDeps :: [[Bool]], + funDeps2 :: [[Maybe Bool]], + genInsts :: [TyVar] -> Maybe [TyVar] -> Pred -> [Inst], allowIncoherent :: Maybe Bool, -- Just False = always coherent -- Just True = always incoherent -- Nothing = flag-controlled isComm :: Bool -- if the class is commutative (used for Add and Mul) - } + } -- Instances are stored as a function, to support primitive numeric typeclasses -- with an infinite number of instances (Add, Mul, etc). @@ -156,43 +156,43 @@ getInsts c = genInsts c [] Nothing (IsIn cls []) where err s = internalError $ "getInsts: no " ++ show s cls = Class { name = CTypeclass(dummyId (err "dummyId")), - csig = err "csig", - super = err "super", - genInsts = err "getInsts", - tyConOf = err "tyConOf", - funDeps = err "funDeps", - funDeps2 = err "funDeps2", + csig = err "csig", + super = err "super", + genInsts = err "getInsts", + tyConOf = err "tyConOf", + funDeps = err "funDeps", + funDeps2 = err "funDeps2", allowIncoherent = err "allowIncoherent", isComm = err "isComm" } instance Show Class where showsPrec p c = - showString "(Class " . - showsPrec 0 (name c) . - showsPrec 0 (csig c) . showString " " . - showsPrec 0 (super c) . showString " " . - showsPrec 0 (funDeps c) . - showString ")" + showString "(Class " . + showsPrec 0 (name c) . + showsPrec 0 (csig c) . showString " " . + showsPrec 0 (super c) . showString " " . + showsPrec 0 (funDeps c) . + showString ")" instance PPrint Class where pPrint d p c = - text "(Class" <+> - pPrint d 0 (name c) <> - pPrint d 0 (csig c) <+> - pPrint d 0 (super c) <+> - pPrint d 0 (getInsts c) <+> - pPrint d 0 (funDeps c) <> - text ")" + text "(Class" <+> + pPrint d 0 (name c) <> + pPrint d 0 (csig c) <+> + pPrint d 0 (super c) <+> + pPrint d 0 (getInsts c) <+> + pPrint d 0 (funDeps c) <> + text ")" instance PVPrint Class where pvPrint d p c = text "(Class" <+> - pvPrint d 0 (name c) <> - pvPrint d 0 (csig c) <+> - pvPrint d 0 (super c) <+> - pvPrint d 0 (getInsts c) <+> - pvPrint d 0 (funDeps c) <> - text ")" + pvPrint d 0 (name c) <> + pvPrint d 0 (csig c) <+> + pvPrint d 0 (super c) <+> + pvPrint d 0 (getInsts c) <+> + pvPrint d 0 (funDeps c) <> + text ")" instance Hyper Class where hyper (Class x1 x2 x3 x4 x5 x6 x7 x8 x9) y = hyper7 x1 x2 x3 x4 x5 x8 x9 y @@ -221,7 +221,7 @@ instance Types Inst where {- instance Match Pred where match (IsIn c ts) (IsIn c' ts') | c == c' = match ts ts' - | otherwise = Nothing + | otherwise = Nothing -} instance PPrint Inst where @@ -237,28 +237,28 @@ expandSyn t0 = exp [] t0 [] where exp syns (TAp f a) as = exp syns f (exp syns a [] : as) exp syns tt@(TCon (TyCon i _ (TItype n t))) as | i `elem` syns = internalError ("recursive type synonyms: " ++ ppReadable syns) - exp syns tt@(TCon (TyCon i _ (TItype n t))) as = - case genericSplitAt n as of - (as1, as2) -> if genericLength as1 < n then - -- We have expanded a synonym that was not fully applied. - -- It is all right if `type S v1 ... vn = t vn' and vn doesn't - -- occur in t. - exp syns' (inst as1 (truncType (n - genericLength as1) (fromInteger n-1) t')) as2 - else - exp syns' (inst as1 t') as2 + exp syns tt@(TCon (TyCon i _ (TItype n t))) as = + case genericSplitAt n as of + (as1, as2) -> if genericLength as1 < n then + -- We have expanded a synonym that was not fully applied. + -- It is all right if `type S v1 ... vn = t vn' and vn doesn't + -- occur in t. + exp syns' (inst as1 (truncType (n - genericLength as1) (fromInteger n-1) t')) as2 + else + exp syns' (inst as1 t') as2 where syns' = i:syns t' = setTypePosition (getIdPosition i) t - exp syns tt@(TCon (TyCon i _ _)) as | isTFun i = apTFun tt i as - exp syns t as = foldl TAp t as - - truncType 0 _ t = t - truncType k n (TAp t (TGen _ n')) | n == n' && notIn n t = truncType (k-1) (n-1) t - where notIn _ (TVar _) = True - notIn _ (TCon _) = True - notIn v (TAp t1 t2) = notIn v t1 && notIn v t2 - notIn v (TGen _ n) = v /= n - notIn v (TDefMonad _) = internalError "expandSyn,truncType (TDefMonad)" - truncType k n t = internalError ("expandSyn,truncType\n" ++ ppReadable (k, n, t0, t)) + exp syns tt@(TCon (TyCon i _ _)) as | isTFun i = apTFun tt i as + exp syns t as = foldl TAp t as + + truncType 0 _ t = t + truncType k n (TAp t (TGen _ n')) | n == n' && notIn n t = truncType (k-1) (n-1) t + where notIn _ (TVar _) = True + notIn _ (TCon _) = True + notIn v (TAp t1 t2) = notIn v t1 && notIn v t2 + notIn v (TGen _ n) = v /= n + notIn v (TDefMonad _) = internalError "expandSyn,truncType (TDefMonad)" + truncType k n t = internalError ("expandSyn,truncType\n" ++ ppReadable (k, n, t0, t)) isTFun i = i `elem` numOpNames diff --git a/src/comp/Pred2STP.hs b/src/comp/Pred2STP.hs index ff140aed0..5bb5f5f9a 100644 --- a/src/comp/Pred2STP.hs +++ b/src/comp/Pred2STP.hs @@ -300,7 +300,7 @@ addUnknownType t = do Nothing -> do when traceConv $ traceM(" making new var.") var <- mkUnknownVar - let res = (var, []) + let res = (var, []) addToTypeMap t res return res diff --git a/src/comp/Pretty.hs b/src/comp/Pretty.hs index b84079c18..8c139596a 100644 --- a/src/comp/Pretty.hs +++ b/src/comp/Pretty.hs @@ -1,7 +1,7 @@ module Pretty (module GHCPretty, pretty, - -- utils - s2par, s2docs - ) where + -- utils + s2par, s2docs + ) where import GHCPretty diff --git a/src/comp/Prim.hs b/src/comp/Prim.hs index 60192ee4a..393b42559 100644 --- a/src/comp/Prim.hs +++ b/src/comp/Prim.hs @@ -1,12 +1,12 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable #-} module Prim( - PrimOp(..), - toPrim, + PrimOp(..), + toPrim, toWString, - stringSize, - writePrimOp, readPrimOp, + stringSize, + writePrimOp, readPrimOp, PrimResult(..), PrimArg(..) - ) where + ) where import Numeric(floatToDigits) import Eval @@ -22,69 +22,69 @@ import Error(ErrMsg(..)) import qualified Data.Generics as Generic data PrimOp = - PrimAdd - | PrimSub - | PrimAnd - | PrimOr - | PrimXor + PrimAdd + | PrimSub + | PrimAnd + | PrimOr + | PrimXor - | PrimMul + | PrimMul - | PrimQuot - | PrimRem + | PrimQuot + | PrimRem - | PrimSL - | PrimSRL - | PrimSRA + | PrimSL + | PrimSRL + | PrimSRA - | PrimInv - | PrimNeg + | PrimInv + | PrimNeg - | PrimEQ + | PrimEQ - | PrimULE - | PrimULT + | PrimULE + | PrimULT - | PrimSLE - | PrimSLT + | PrimSLE + | PrimSLT - | PrimSignExt - | PrimZeroExt + | PrimSignExt + | PrimZeroExt - | PrimTrunc + | PrimTrunc - | PrimExtract - | PrimConcat - | PrimSplit + | PrimExtract + | PrimConcat + | PrimSplit - | PrimBNot - | PrimBAnd - | PrimBOr + | PrimBNot + | PrimBAnd + | PrimBOr | PrimInoutCast | PrimInoutUncast - | PrimIf - | PrimMux - | PrimPriMux + | PrimIf + | PrimMux + | PrimPriMux - | PrimFmtConcat + | PrimFmtConcat - -- Only in ATS - -- use: PrimCase e d c1 e1 c2 e2 ... cn en - -- e is the scrutinized expression, d is the default value, (ck, ek) forms a case arm - | PrimCase + -- Only in ATS + -- use: PrimCase e d c1 e1 c2 e2 ... cn en + -- e is the scrutinized expression, d is the default value, (ck, ek) forms a case arm + | PrimCase - -- Only used in intermediate code - -- primSelect ·k ·m ·n e selects k bits at position m from n bits - -- primSelect :: \/ k, m, n :: * -> Bit n -> Bit k - | PrimSelect + -- Only used in intermediate code + -- primSelect ·k ·m ·n e selects k bits at position m from n bits + -- primSelect :: \/ k, m, n :: * -> Bit n -> Bit k + | PrimSelect - -- primitives without hardware representation - | PrimIntegerToBit + -- primitives without hardware representation + | PrimIntegerToBit | PrimIntegerToUIntBits | PrimIntegerToIntBits - | PrimBitToInteger -- XXX dangerous + | PrimBitToInteger -- XXX dangerous | PrimIntegerToString -- must be called on compile-time values @@ -94,28 +94,28 @@ data PrimOp = | PrimIsStaticInteger | PrimAreStaticBits - | PrimValueOf + | PrimValueOf - | PrimWhen + | PrimWhen | PrimWhenPred -- takes abstract predicate - | PrimOrd - | PrimChr + | PrimOrd + | PrimChr - -- primRange lo hi x, promises lo <= x <= hi - | PrimRange + -- primRange lo hi x, promises lo <= x <= hi + | PrimRange - | PrimError + | PrimError | PrimGenerateError - | PrimMessage + | PrimMessage | PrimWarning | PrimPoisonedDef - | PrimDynamicError + | PrimDynamicError - | PrimStringConcat - | PrimStringToInteger - | PrimStringEQ + | PrimStringConcat + | PrimStringToInteger + | PrimStringEQ | PrimStringLength | PrimStringSplit @@ -126,20 +126,20 @@ data PrimOp = | PrimCharOrd | PrimCharChr - | PrimJoinActions - | PrimNoActions - | PrimExpIf -- "split shallow" - | PrimNoExpIf -- "nosplit shallow" + | PrimJoinActions + | PrimNoActions + | PrimExpIf -- "split shallow" + | PrimNoExpIf -- "nosplit shallow" | PrimSplitDeep - | PrimNosplitDeep - | PrimAddRules - | PrimModuleBind - | PrimModuleReturn - | PrimModuleFix - | PrimModuleClock + | PrimNosplitDeep + | PrimAddRules + | PrimModuleBind + | PrimModuleReturn + | PrimModuleFix + | PrimModuleClock | PrimModuleReset | PrimBuildModule - | PrimCurrentClock + | PrimCurrentClock | PrimCurrentReset | PrimSameFamilyClock | PrimIsAncestorClock @@ -153,23 +153,23 @@ data PrimOp = | PrimResetsOf | PrimNoReset | PrimResetUnassertedVal - | PrimJoinRules + | PrimJoinRules | PrimJoinRulesPreempt | PrimJoinRulesUrgency | PrimJoinRulesExecutionOrder | PrimJoinRulesMutuallyExclusive | PrimJoinRulesConflictFree - | PrimNoRules - | PrimRule - -- PrimAddSchedPragmas :: [SchedulePragma] -> Rules -> Rules - | PrimAddSchedPragmas + | PrimNoRules + | PrimRule + -- PrimAddSchedPragmas :: [SchedulePragma] -> Rules -> Rules + | PrimAddSchedPragmas | PrimGetName - -- primStateName :: Name -> Module b -> Module b - -- This primitive is used to name state components. + -- primStateName :: Name -> Module b -> Module b + -- This primitive is used to name state components. -- The first argument is an abstract name that is added to - -- the names of state elements instantiated by the second argument. - | PrimStateName + -- the names of state elements instantiated by the second argument. + | PrimStateName | PrimGetModuleName | PrimJoinNames @@ -178,10 +178,10 @@ data PrimOp = | PrimGetNameString | PrimMakeName - -- primStateAttrib :: Attributes -> Module b -> Module b - -- This primitive is used to add attributes to submod instantiations. + -- primStateAttrib :: Attributes -> Module b -> Module b + -- This primitive is used to add attributes to submod instantiations. -- The first argument is an abstract list of attributes. - | PrimStateAttrib + | PrimStateAttrib | PrimNoPosition | PrimPrintPosition @@ -189,9 +189,9 @@ data PrimOp = | PrimSetStringPosition | PrimGetEvalPosition - -- environment - | PrimGenC - | PrimGenVerilog + -- environment + | PrimGenC + | PrimGenVerilog | PrimGenModuleName -- elaboration-time file IO @@ -218,22 +218,22 @@ data PrimOp = -- type-tracking primitive | PrimSavePortType - -- compile time numbers - | PrimIntegerAdd - | PrimIntegerSub - | PrimIntegerNeg - | PrimIntegerMul - | PrimIntegerDiv - | PrimIntegerMod + -- compile time numbers + | PrimIntegerAdd + | PrimIntegerSub + | PrimIntegerNeg + | PrimIntegerMul + | PrimIntegerDiv + | PrimIntegerMod | PrimIntegerExp | PrimIntegerLog2 | PrimIntegerLog10 - | PrimIntegerQuot - | PrimIntegerRem + | PrimIntegerQuot + | PrimIntegerRem - | PrimIntegerEQ - | PrimIntegerLE - | PrimIntegerLT + | PrimIntegerEQ + | PrimIntegerLE + | PrimIntegerLT -- Real numbers: Show | PrimRealToString @@ -288,8 +288,8 @@ data PrimOp = | PrimRealIsInfinite | PrimRealIsNegativeZero - | PrimSeq -- args are eval in sequence - -- for side effects or strictness + | PrimSeq -- args are eval in sequence + -- for side effects or strictness | PrimSeqCond -- implicit-condition strictness | PrimUninitialized | PrimRawUninitialized -- error out with a use of an uninitialized value @@ -302,10 +302,10 @@ data PrimOp = | PrimRawUndefined -- create a "raw" undefined value | PrimIsRawUndefined -- test if a value is a "raw" undefined value | PrimImpCondOf -- XXX experimental - | PrimArrayNew -- Primitive array operators - | PrimArrayLength - | PrimArraySelect - | PrimArrayUpdate + | PrimArrayNew -- Primitive array operators + | PrimArrayLength + | PrimArraySelect + | PrimArrayUpdate | PrimArrayDynSelect | PrimArrayDynUpdate | PrimBuildArray -- only exists after IExpand and in ASyntax @@ -315,91 +315,91 @@ data PrimOp = | PrimGetParamName -- get the parameter name associated with the function value | PrimEQ3 -- === / Verilog case equality - deriving (Eq, Ord, Show, Enum, Bounded, Generic.Data, Generic.Typeable) + deriving (Eq, Ord, Show, Enum, Bounded, Generic.Data, Generic.Typeable) -- Just some size, have to be coordinated with Prelude.bs stringSize :: String -> Integer -stringSize s = toInteger (8 * length s) -- in bytes as bits +stringSize s = toInteger (8 * length s) -- in bytes as bits toPrim :: Id -> PrimOp -toPrim i = tp (getIdBaseString i) -- XXXXX +toPrim i = tp (getIdBaseString i) -- XXXXX where tp "primAdd" = PrimAdd - tp "primSub" = PrimSub - tp "primAnd" = PrimAnd - tp "primOr" = PrimOr - tp "primXor" = PrimXor - tp "primMul" = PrimMul - tp "primQuot" = PrimQuot - tp "primRem" = PrimRem - tp "primSL" = PrimSL - tp "primSRL" = PrimSRL - tp "primSRA" = PrimSRA - tp "primInv" = PrimInv - tp "primNeg" = PrimNeg - tp "primEQ" = PrimEQ + tp "primSub" = PrimSub + tp "primAnd" = PrimAnd + tp "primOr" = PrimOr + tp "primXor" = PrimXor + tp "primMul" = PrimMul + tp "primQuot" = PrimQuot + tp "primRem" = PrimRem + tp "primSL" = PrimSL + tp "primSRL" = PrimSRL + tp "primSRA" = PrimSRA + tp "primInv" = PrimInv + tp "primNeg" = PrimNeg + tp "primEQ" = PrimEQ tp "primEQ3" = PrimEQ3 - tp "primULE" = PrimULE - tp "primULT" = PrimULT - tp "primSLE" = PrimSLE - tp "primSLT" = PrimSLT - tp "primSignExt" = PrimSignExt - tp "primZeroExt" = PrimZeroExt - tp "primTrunc" = PrimTrunc - tp "primExtractInternal" = PrimExtract - tp "primConcat" = PrimConcat - tp "primSplit" = PrimSplit - tp "primBNot" = PrimBNot - tp "primBAnd" = PrimBAnd - tp "primBOr" = PrimBOr - tp "primInoutCast" = PrimInoutCast - tp "primInoutUncast" = PrimInoutUncast - tp "primIntegerToBit" = PrimIntegerToBit + tp "primULE" = PrimULE + tp "primULT" = PrimULT + tp "primSLE" = PrimSLE + tp "primSLT" = PrimSLT + tp "primSignExt" = PrimSignExt + tp "primZeroExt" = PrimZeroExt + tp "primTrunc" = PrimTrunc + tp "primExtractInternal" = PrimExtract + tp "primConcat" = PrimConcat + tp "primSplit" = PrimSplit + tp "primBNot" = PrimBNot + tp "primBAnd" = PrimBAnd + tp "primBOr" = PrimBOr + tp "primInoutCast" = PrimInoutCast + tp "primInoutUncast" = PrimInoutUncast + tp "primIntegerToBit" = PrimIntegerToBit tp "primIntegerToUIntBits" = PrimIntegerToUIntBits tp "primIntegerToIntBits" = PrimIntegerToIntBits - tp "primBitToInteger" = PrimBitToInteger + tp "primBitToInteger" = PrimBitToInteger tp "primIntegerToString" = PrimIntegerToString tp "primUIntBitsToInteger" = PrimUIntBitsToInteger tp "primIntBitsToInteger" = PrimIntBitsToInteger tp "primIsStaticInteger" = PrimIsStaticInteger tp "primAreStaticBits" = PrimAreStaticBits tp "primWhen" = PrimWhen - tp "primValueOf" = PrimValueOf - tp "primOrd" = PrimOrd - tp "primChr" = PrimChr - tp "primIf" = PrimIf - tp "primRange" = PrimRange - tp "primError" = PrimError + tp "primValueOf" = PrimValueOf + tp "primOrd" = PrimOrd + tp "primChr" = PrimChr + tp "primIf" = PrimIf + tp "primRange" = PrimRange + tp "primError" = PrimError tp "primPoisonedDef" = PrimPoisonedDef tp "primGenerateError" = PrimGenerateError - tp "primMessage" = PrimMessage + tp "primMessage" = PrimMessage tp "primWarning" = PrimWarning - tp "primDynamicError" = PrimDynamicError + tp "primDynamicError" = PrimDynamicError - tp "primJoinActions" = PrimJoinActions - tp "primNoActions" = PrimNoActions - tp "primExpIf" = PrimExpIf - tp "primNoExpIf" = PrimNoExpIf + tp "primJoinActions" = PrimJoinActions + tp "primNoActions" = PrimNoActions + tp "primExpIf" = PrimExpIf + tp "primNoExpIf" = PrimNoExpIf tp "primSplitDeep" = PrimSplitDeep - tp "primNosplitDeep" = PrimNosplitDeep - tp "primAddRules" = PrimAddRules - tp "primModuleBind" = PrimModuleBind - tp "primModuleReturn" = PrimModuleReturn - tp "primModuleFix" = PrimModuleFix - tp "primModuleClock" = PrimModuleClock + tp "primNosplitDeep" = PrimNosplitDeep + tp "primAddRules" = PrimAddRules + tp "primModuleBind" = PrimModuleBind + tp "primModuleReturn" = PrimModuleReturn + tp "primModuleFix" = PrimModuleFix + tp "primModuleClock" = PrimModuleClock tp "primModuleReset" = PrimModuleReset tp "primBuildModule" = PrimBuildModule - tp "primJoinRules" = PrimJoinRules - tp "primJoinRulesPreempt" = PrimJoinRulesPreempt - tp "primJoinRulesUrgency" = PrimJoinRulesUrgency - tp "primJoinRulesExecutionOrder" = PrimJoinRulesExecutionOrder - tp "primJoinRulesMutuallyExclusive" = PrimJoinRulesMutuallyExclusive + tp "primJoinRules" = PrimJoinRules + tp "primJoinRulesPreempt" = PrimJoinRulesPreempt + tp "primJoinRulesUrgency" = PrimJoinRulesUrgency + tp "primJoinRulesExecutionOrder" = PrimJoinRulesExecutionOrder + tp "primJoinRulesMutuallyExclusive" = PrimJoinRulesMutuallyExclusive tp "primJoinRulesConflictFree" = PrimJoinRulesConflictFree - tp "primNoRules" = PrimNoRules - tp "primRule" = PrimRule + tp "primNoRules" = PrimNoRules + tp "primRule" = PrimRule - tp "primStringConcat" = PrimStringConcat - tp "primStringToInteger" = PrimStringToInteger - tp "primStringEQ" = PrimStringEQ + tp "primStringConcat" = PrimStringConcat + tp "primStringToInteger" = PrimStringToInteger + tp "primStringEQ" = PrimStringEQ tp "primStringLength" = PrimStringLength tp "primStringSplit" = PrimStringSplit @@ -411,7 +411,7 @@ toPrim i = tp (getIdBaseString i) -- XXXXX tp "primCharChr" = PrimCharChr tp "primFmtConcat" = PrimFmtConcat - tp "primCurrentClock" = PrimCurrentClock + tp "primCurrentClock" = PrimCurrentClock tp "primCurrentReset" = PrimCurrentReset tp "primSameFamilyClock" = PrimSameFamilyClock tp "primIsAncestorClock" = PrimIsAncestorClock @@ -427,8 +427,8 @@ toPrim i = tp (getIdBaseString i) -- XXXXX tp "primResetUnassertedVal" = PrimResetUnassertedVal tp "primGetName" = PrimGetName - tp "primGetParamName" = PrimGetParamName - tp "primStateName" = PrimStateName + tp "primGetParamName" = PrimGetParamName + tp "primStateName" = PrimStateName tp "primGetModuleName" = PrimGetModuleName tp "primJoinNames" = PrimJoinNames tp "primExtendNameInteger" = PrimExtendNameInteger @@ -472,65 +472,65 @@ toPrim i = tp (getIdBaseString i) -- XXXXX tp "primSeq" = PrimSeq tp "primSeqCond" = PrimSeqCond - tp "primIntegerAdd" = PrimIntegerAdd - tp "primIntegerSub" = PrimIntegerSub - tp "primIntegerNeg" = PrimIntegerNeg - tp "primIntegerMul" = PrimIntegerMul - tp "primIntegerDiv" = PrimIntegerDiv - tp "primIntegerMod" = PrimIntegerMod - tp "primIntegerQuot" = PrimIntegerQuot - tp "primIntegerRem" = PrimIntegerRem + tp "primIntegerAdd" = PrimIntegerAdd + tp "primIntegerSub" = PrimIntegerSub + tp "primIntegerNeg" = PrimIntegerNeg + tp "primIntegerMul" = PrimIntegerMul + tp "primIntegerDiv" = PrimIntegerDiv + tp "primIntegerMod" = PrimIntegerMod + tp "primIntegerQuot" = PrimIntegerQuot + tp "primIntegerRem" = PrimIntegerRem tp "primIntegerExp" = PrimIntegerExp tp "primIntegerLog2" = PrimIntegerLog2 tp "primIntegerLog10" = PrimIntegerLog10 - tp "primIntegerEQ" = PrimIntegerEQ - tp "primIntegerLE" = PrimIntegerLE - tp "primIntegerLT" = PrimIntegerLT + tp "primIntegerEQ" = PrimIntegerEQ + tp "primIntegerLE" = PrimIntegerLE + tp "primIntegerLT" = PrimIntegerLT tp "primRealToString" = PrimRealToString tp "primIntegerToReal" = PrimIntegerToReal - tp "primRealEQ" = PrimRealEQ - tp "primRealLE" = PrimRealLE - tp "primRealLT" = PrimRealLT - tp "primRealAdd" = PrimRealAdd - tp "primRealSub" = PrimRealSub - tp "primRealNeg" = PrimRealNeg - tp "primRealMul" = PrimRealMul - tp "primRealDiv" = PrimRealDiv - tp "primRealAbs" = PrimRealAbs - tp "primRealSignum" = PrimRealSignum - tp "primRealExpE" = PrimRealExpE - tp "primRealPow" = PrimRealPow - tp "primRealLogE" = PrimRealLogE - tp "primRealLogBase" = PrimRealLogBase - tp "primRealLog2" = PrimRealLog2 - tp "primRealLog10" = PrimRealLog10 - tp "primRealToBits" = PrimRealToBits - tp "primBitsToReal" = PrimBitsToReal - tp "primRealSin" = PrimRealSin - tp "primRealCos" = PrimRealCos - tp "primRealTan" = PrimRealTan - tp "primRealSinH" = PrimRealSinH - tp "primRealCosH" = PrimRealCosH - tp "primRealTanH" = PrimRealTanH - tp "primRealASin" = PrimRealASin - tp "primRealACos" = PrimRealACos - tp "primRealATan" = PrimRealATan - tp "primRealASinH" = PrimRealASinH - tp "primRealACosH" = PrimRealACosH - tp "primRealATanH" = PrimRealATanH - tp "primRealATan2" = PrimRealATan2 - tp "primRealSqrt" = PrimRealSqrt - tp "primRealTrunc" = PrimRealTrunc - tp "primRealCeil" = PrimRealCeil - tp "primRealFloor" = PrimRealFloor - tp "primRealRound" = PrimRealRound - tp "primSplitReal" = PrimSplitReal - tp "primDecodeReal" = PrimDecodeReal + tp "primRealEQ" = PrimRealEQ + tp "primRealLE" = PrimRealLE + tp "primRealLT" = PrimRealLT + tp "primRealAdd" = PrimRealAdd + tp "primRealSub" = PrimRealSub + tp "primRealNeg" = PrimRealNeg + tp "primRealMul" = PrimRealMul + tp "primRealDiv" = PrimRealDiv + tp "primRealAbs" = PrimRealAbs + tp "primRealSignum" = PrimRealSignum + tp "primRealExpE" = PrimRealExpE + tp "primRealPow" = PrimRealPow + tp "primRealLogE" = PrimRealLogE + tp "primRealLogBase" = PrimRealLogBase + tp "primRealLog2" = PrimRealLog2 + tp "primRealLog10" = PrimRealLog10 + tp "primRealToBits" = PrimRealToBits + tp "primBitsToReal" = PrimBitsToReal + tp "primRealSin" = PrimRealSin + tp "primRealCos" = PrimRealCos + tp "primRealTan" = PrimRealTan + tp "primRealSinH" = PrimRealSinH + tp "primRealCosH" = PrimRealCosH + tp "primRealTanH" = PrimRealTanH + tp "primRealASin" = PrimRealASin + tp "primRealACos" = PrimRealACos + tp "primRealATan" = PrimRealATan + tp "primRealASinH" = PrimRealASinH + tp "primRealACosH" = PrimRealACosH + tp "primRealATanH" = PrimRealATanH + tp "primRealATan2" = PrimRealATan2 + tp "primRealSqrt" = PrimRealSqrt + tp "primRealTrunc" = PrimRealTrunc + tp "primRealCeil" = PrimRealCeil + tp "primRealFloor" = PrimRealFloor + tp "primRealRound" = PrimRealRound + tp "primSplitReal" = PrimSplitReal + tp "primDecodeReal" = PrimDecodeReal tp "primRealToDigits" = PrimRealToDigits - tp "primRealIsInfinite" = PrimRealIsInfinite - tp "primRealIsNegativeZero" = PrimRealIsNegativeZero + tp "primRealIsInfinite" = PrimRealIsInfinite + tp "primRealIsNegativeZero" = PrimRealIsNegativeZero tp "primUninitialized" = PrimUninitialized tp "primMakeRawUninitialized" = PrimRawUninitialized @@ -554,7 +554,7 @@ toPrim i = tp (getIdBaseString i) -- XXXXX tp "primBuildArray" = PrimBuildArray tp "primSetSelPosition" = PrimSetSelPosition - tp s = internalError ("unknown primitive: " ++ s ++ " " ++ prPosition (getIdPosition i)) + tp s = internalError ("unknown primitive: " ++ s ++ " " ++ prPosition (getIdPosition i)) instance PPrint PrimOp where pPrint d p op = text (toString op) @@ -735,14 +735,14 @@ evalPrimToInt PrimTrunc [_,s,_] [I i] = ans $ mask s i -- extraction, concatenation and range-checking on sized values evalPrimToInt PrimRange [s] [I lo, I hi, I x] = if x < lo || x > hi then - internalError ("evalPrimToInt: PrimRange " ++ ppReadable (lo,hi,x)) + internalError ("evalPrimToInt: PrimRange " ++ ppReadable (lo,hi,x)) else - ans $ x + ans $ x evalPrimToInt PrimExtract [n,_,m] [I e, I h, I l] = if (h-l+1 < 0) then internalError ("evalPrimToInt: PrimExtract extract negative number of bits " - ++ ppReadable ((n,m),(h,l,e))) + ++ ppReadable ((n,m),(h,l,e))) else if (l >= 0) then ans $ mask m (integerSelect (h-l+1) l e) else no_answer diff --git a/src/comp/RSchedule.hs b/src/comp/RSchedule.hs index 0d6932f2d..e4038b409 100644 --- a/src/comp/RSchedule.hs +++ b/src/comp/RSchedule.hs @@ -51,8 +51,8 @@ type StkL = [StackItem UniqueUse RRM] -- (in which case the pair tells us the rules to arbitrate). -- Other edges can't be arb'd, so the info is currently just for debugging? data UseKind = PredicateOf (RuleId,RuleId) -- one use is in a rule predicate - | ActionOf (RuleId,RuleId) -- uses are only in rule bodies - | InstanceOf (AId,AId) -- one use is in a submodule instance + | ActionOf (RuleId,RuleId) -- uses are only in rule bodies + | InstanceOf (AId,AId) -- one use is in a submodule instance deriving (Eq, Ord, Show) instance PPrint (UseKind) where @@ -79,19 +79,19 @@ data StackItem v r = Vertex (v,[v]) | Edge r -- * [RRM] rSchedule :: Id -> ResourceFlag -> [(MethodId,Integer)] -> MethodUsesMap -> - (RuleId -> RuleId -> Bool) -> ErrorMonad (RAT,[RRM]) + (RuleId -> RuleId -> Bool) -> ErrorMonad (RAT,[RRM]) rSchedule moduleId rFlag rMaxs rMap areSimult = let - concatTuple (xxs,yys) = (concat xxs, concat yys) - f = rSchedule' moduleId rFlag rMaxs areSimult + concatTuple (xxs,yys) = (concat xxs, concat yys) + f = rSchedule' moduleId rFlag rMaxs areSimult in mapM f (M.toList rMap) >>= return . concatTuple . unzip rSchedule' :: Id -> ResourceFlag -> [(MethodId,Integer)] -> - (RuleId -> RuleId -> Bool) -> - (MethodId, [(UniqueUse, MethodUsers)]) -> - ErrorMonad (RAT, [RRM]) + (RuleId -> RuleId -> Bool) -> + (MethodId, [(UniqueUse, MethodUsers)]) -> + ErrorMonad (RAT, [RRM]) rSchedule' moduleId rFlag rMaxs areSimult mu@(mId, uses0) = let -- XXX condition-insensitive resource allocation @@ -99,31 +99,31 @@ rSchedule' moduleId rFlag rMaxs areSimult mu@(mId, uses0) = -- different expression uses with the same arguments -- but different conditions, so we drop them here and in AState.hs uses = mapFst useDropCond uses0 - rMax = lookupRes mId rMaxs + rMax = lookupRes mId rMaxs - g :: UUGraph - g = uuGraph areSimult uses + g :: UUGraph + g = uuGraph areSimult uses - dropEdges = - case rFlag of - RFoff -> -- don't reschedule - errDropEdges mId rMax - RFsimple -> -- reschedule + dropEdges = + case rFlag of + RFoff -> -- don't reschedule + errDropEdges mId rMax + RFsimple -> -- reschedule -- arbitrate resource (drop edge in graph) - simpleDropEdges moduleId areSimult (mId, uses) rMax + simpleDropEdges moduleId areSimult (mId, uses) rMax in do when trace_ralloc (traceM $ "rSchedule: allocating " ++ show (length uses) ++ - " uses of " ++ ppString mId ++ "; " ++ - if rMax == 0 then "no port limit" else show rMax ++ - " ports available") + " uses of " ++ ppString mId ++ "; " ++ + if rMax == 0 then "no port limit" else show rMax ++ + " ports available") when trace_uugraph (traceM $ "rSchedule: uugraph:\n" ++ ppReadable g) -- when (rMax <= 0) (verifySC g) if length uses > 16 && fromInteger rMax >= length uses - then return ([(mId, zip (map fst uses) [1..])], []) - else do (colors, drops) <- color rMax dropEdges g - return ([(mId,colors)], drops) + then return ([(mId, zip (map fst uses) [1..])], []) + else do (colors, drops) <- color rMax dropEdges g + return ([(mId,colors)], drops) -- ============================== @@ -132,48 +132,48 @@ rSchedule' moduleId rFlag rMaxs areSimult mu@(mId, uses0) = -- build a graph with UniqueUse vertices -- and edges where two uses are simultaneous uuGraph :: (RuleId -> RuleId -> Bool) -> - [(UniqueUse, MethodUsers)] -> - UUGraph + [(UniqueUse, MethodUsers)] -> + UUGraph uuGraph areSimult uUses = let - gVertices = foldr (flip G.addVertex) G.empty [u | (u,_) <- uUses] - - -- edges for uses in rule actions - -- diff arguments and uses of the same action - -- (hasSideEffects uUse) are potential resource conflicts, - -- requiring checking whether the uses are simultaneous (simult) - -- (two uses of same action are ok if the action is idempotent, - -- which is captured in the "simult" check) - aEdges = - [(uUse, uUse', ss) | - ((uUse, (_, rs, _)), (uUse', (_, rs', _))) <- allPairs uUses, - differentArgs uUse uUse' || hasSideEffects uUse, - let ss = simult rs rs', not $ null ss] - - simult rs rs' = [ActionOf (r,r') | r <- rs, r' <- rs', areSimult r r'] - - -- edges for uses in rule predicates - -- XXX we currently assume that predicates must always occur - -- XXX but with urgency we can be smarter (a predicate's use may - -- XXX be exclusive with the execution of the action of a more - -- XXX more urgent rule) - pEdges = concat [[(uUse, uUse', ss), (uUse', uUse, ss)] | + gVertices = foldr (flip G.addVertex) G.empty [u | (u,_) <- uUses] + + -- edges for uses in rule actions + -- diff arguments and uses of the same action + -- (hasSideEffects uUse) are potential resource conflicts, + -- requiring checking whether the uses are simultaneous (simult) + -- (two uses of same action are ok if the action is idempotent, + -- which is captured in the "simult" check) + aEdges = + [(uUse, uUse', ss) | + ((uUse, (_, rs, _)), (uUse', (_, rs', _))) <- allPairs uUses, + differentArgs uUse uUse' || hasSideEffects uUse, + let ss = simult rs rs', not $ null ss] + + simult rs rs' = [ActionOf (r,r') | r <- rs, r' <- rs', areSimult r r'] + + -- edges for uses in rule predicates + -- XXX we currently assume that predicates must always occur + -- XXX but with urgency we can be smarter (a predicate's use may + -- XXX be exclusive with the execution of the action of a more + -- XXX more urgent rule) + pEdges = concat [[(uUse, uUse', ss), (uUse', uUse, ss)] | (uUse, (prs, _, _)) <- uUses, not (null prs), - (uUse', (prs', ars', _)) <- uUses, + (uUse', (prs', ars', _)) <- uUses, differentArgs uUse uUse', - let ss = [PredicateOf (p, r) | - p <- prs, r <- prs'++ars']] - - -- edges for instantiations - -- (like rule predicates, the must always occur) - iEdges = concat [[(uUse, uUse', ss), (uUse', uUse, ss)] | - (uUse, (_, _, irs)) <- uUses, not (null irs), - (uUse', (prs', ars', irs')) <- uUses, - differentArgs uUse uUse', - let ss = [InstanceOf (p, r) | - p <- irs, r <- prs'++ars'++irs']] + let ss = [PredicateOf (p, r) | + p <- prs, r <- prs'++ars']] + + -- edges for instantiations + -- (like rule predicates, the must always occur) + iEdges = concat [[(uUse, uUse', ss), (uUse', uUse, ss)] | + (uUse, (_, _, irs)) <- uUses, not (null irs), + (uUse', (prs', ars', irs')) <- uUses, + differentArgs uUse uUse', + let ss = [InstanceOf (p, r) | + p <- irs, r <- prs'++ars'++irs']] in - foldl G.addEdge gVertices (iEdges ++ pEdges ++ aEdges) + foldl G.addEdge gVertices (iEdges ++ pEdges ++ aEdges) -- ============================== @@ -182,12 +182,12 @@ uuGraph areSimult uUses = {- verifySC g = mapM_ err [(v,v',r) | (v,ns) <- G.toList g, (v', us) <- ns, - ActionOf (r,r') <- us, - r == r'] + ActionOf (r,r') <- us, + r == r'] where err bad@(u,u',r) = EMError (getIdPosition r, EGeneric (emsg bad)) - emsg (u,u',r) = "Rule `" ++ ppString r ++ - "' uses an SC method twice: `" ++ - ppString u ++ "' and `" ++ ppString u' ++ "'" + emsg (u,u',r) = "Rule `" ++ ppString r ++ + "' uses an SC method twice: `" ++ + ppString u ++ "' and `" ++ ppString u' ++ "'" -} @@ -214,39 +214,39 @@ eArbitrate moduleId (r,r') = -- Function: simpleDropEdges simpleDropEdges :: Id -> (RuleId -> RuleId -> Bool) -> - (MethodId, [(UniqueUse, MethodUsers)]) -> - Integer -> StkL -> UUGraph -> ErrorMonad (StkL, UUGraph) + (MethodId, [(UniqueUse, MethodUsers)]) -> + Integer -> StkL -> UUGraph -> ErrorMonad (StkL, UUGraph) simpleDropEdges moduleId areSimult (mId,uses) rMax st g = if all null droppable || any sameRule rs then errDropEdges mId rMax st g else EMWarning warn (st',g') where droppable = [map fromActionOf w - | v <- G.vertices g, v' <- G.neighbors g v, - w <- maybeToList (G.lookup (v,v') g), all isActionOf w] - rs = case droppable of - (xs:_) -> xs - _ -> internalError "simpleDropEdges: nothing to drop!" - sameRule (r,r') = r == r' - uses' = [u | u@(uu, _) <- uses, uu `elem` G.vertices g] - st' = [Edge (r,r',mId) | (r,r') <- rs] ++ st - - allDrops = [(r,r') | Edge (r,r',_) <- st] ++ rs + | v <- G.vertices g, v' <- G.neighbors g v, + w <- maybeToList (G.lookup (v,v') g), all isActionOf w] + rs = case droppable of + (xs:_) -> xs + _ -> internalError "simpleDropEdges: nothing to drop!" + sameRule (r,r') = r == r' + uses' = [u | u@(uu, _) <- uses, uu `elem` G.vertices g] + st' = [Edge (r,r',mId) | (r,r') <- rs] ++ st + + allDrops = [(r,r') | Edge (r,r',_) <- st] ++ rs allDropsSet = S.fromList $ map ordPair allDrops areSimult' r r' = (not (ordPair (r,r') `S.member` allDropsSet)) && areSimult r r' - g' = uuGraph areSimult' uses' - fromActionOf (ActionOf x) = x - fromActionOf _ = internalError "fromActionOf" - isActionOf (ActionOf _) = True - isActionOf _ = False - warn = (eResources mId rMax g) : (map (eArbitrate moduleId) allDrops) + g' = uuGraph areSimult' uses' + fromActionOf (ActionOf x) = x + fromActionOf _ = internalError "fromActionOf" + isActionOf (ActionOf _) = True + isActionOf _ = False + warn = (eResources mId rMax g) : (map (eArbitrate moduleId) allDrops) -- ============================== -- Function: color color :: Integer -> (StkL -> UUGraph -> ErrorMonad (StkL, UUGraph)) -> - UUGraph -> ErrorMonad ([(UniqueUse,Integer)],[RRM]) + UUGraph -> ErrorMonad ([(UniqueUse,Integer)],[RRM]) color rMax dropEdges g | rMax > 0 = colorFw rMax dropEdges [] g >>= colorBk [1..rMax] [] [] | otherwise = return ([(v,1) | v <- G.vertices g], []) @@ -254,20 +254,20 @@ color rMax dropEdges g -- forward pass: generate stack of colorable vertices and dropped edges colorFw :: Integer -> (StkL -> UUGraph -> ErrorMonad (StkL, UUGraph)) -> - StkL -> UUGraph -> ErrorMonad StkL + StkL -> UUGraph -> ErrorMonad StkL colorFw rMax dropEdges st g | G.null g = return st | otherwise = - case partition (colorable rMax g) (G.vertices g) of - (cv:_, _) -> colorFw rMax dropEdges - (Vertex (cv, G.neighbors g cv) : st) - (G.deleteVertex g cv) - (_, _) -> dropEdges st g >>= (uncurry $ colorFw rMax dropEdges) + case partition (colorable rMax g) (G.vertices g) of + (cv:_, _) -> colorFw rMax dropEdges + (Vertex (cv, G.neighbors g cv) : st) + (G.deleteVertex g cv) + (_, _) -> dropEdges st g >>= (uncurry $ colorFw rMax dropEdges) -- backward pass: pick up vertices and color them colorBk :: [Integer] -> [(UniqueUse,Integer)] -> [RRM] -> StkL -> - ErrorMonad ([(UniqueUse, Integer)], [RRM]) + ErrorMonad ([(UniqueUse, Integer)], [RRM]) colorBk _ cs es [] = return (cs,es) colorBk rMaxL cs es (Vertex vns@(v,_) : vs) = colorBk rMaxL ((v, pickColor rMaxL cs vns):cs) es vs @@ -278,15 +278,15 @@ colorBk rMaxL cs es (Edge e : vs) = colorBk rMaxL cs (e:es) vs colorable :: Integer -> UUGraph -> UniqueUse -> Bool colorable rMax g v = (toInteger $ foldr1 max $ map length $ G.ncc $ - G.filterVertices g (`elem` v:G.neighbors g v)) <= rMax + G.filterVertices g (`elem` v:G.neighbors g v)) <= rMax pickColor :: [Integer] -> [(UniqueUse, Integer)] -> (a, [UniqueUse]) -> Integer pickColor rMaxL cs (_,ns) = case rMaxL \\ [lookupRes n cs | n <- ns] of - (r:_) -> r - _ -> internalError ("pickColor\ncolors:" ++ ppReadable cs ++ - "available:" ++ ppReadable rMaxL) + (r:_) -> r + _ -> internalError ("pickColor\ncolors:" ++ ppReadable cs ++ + "available:" ++ ppReadable rMaxL) -- ============================== @@ -295,8 +295,8 @@ pickColor rMaxL cs (_,ns) = lookupRes :: (Eq a, PPrint a, PPrint b) => a -> [(a,b)] -> b -- return y s.t. (r,y) `elem` rs or die lookupRes r rs = case lookup r rs of - (Just x) -> x - Nothing -> internalError $ "RSchedule: phantom resources" ++ ppReadable r ++ ppReadable rs + (Just x) -> x + Nothing -> internalError $ "RSchedule: phantom resources" ++ ppReadable r ++ ppReadable rs -- ============================== diff --git a/src/comp/SAL.hs b/src/comp/SAL.hs index 9271805dc..88d34893a 100644 --- a/src/comp/SAL.hs +++ b/src/comp/SAL.hs @@ -1359,7 +1359,7 @@ convAPrim p@(PrimExtract) (ATBit sz2) [a, _, _] = do --convAPrim PrimRange t as = convAPrim p t as | p `elem` [ PrimAdd, PrimSub, PrimAnd, PrimOr, PrimXor, - PrimInv, PrimNeg ] = do + PrimInv, PrimNeg ] = do a_exprs <- mapM convAExpr as return $ sApply (SVar (prim1Ctx (aSize t) (primId p))) a_exprs diff --git a/src/comp/SCC.hs b/src/comp/SCC.hs index cdb2f8970..11b757d91 100644 --- a/src/comp/SCC.hs +++ b/src/comp/SCC.hs @@ -43,8 +43,8 @@ sccEdge ns rns vs dfs r vs ns [] = (vs,ns) dfs r vs ns (x:xs) - | x `sElem` vs = dfs r vs ns xs - | otherwise = case dfs r (sAdd x vs) [] (r x) of (vs', ns') -> dfs r vs' ((x:ns')++ns) xs + | x `sElem` vs = dfs r vs ns xs + | otherwise = case dfs r (sAdd x vs) [] (r x) of (vs', ns') -> dfs r vs' ((x:ns')++ns) xs rev :: (Ord node) => [Node node] -> NMap node rev ns = M.fromListWith (++) [ (d, [s]) | (s, ds) <- ns, d <- ds ] @@ -70,17 +70,17 @@ getCycles xs = otsort :: (Ord node) => [Node node] -> Either [[node]] [node] otsort ns = - let es = [(x,y) | (x, ys) <- ns, y <- ys] - vs = map fst ns - sccs = sccEdge (mFromList ns) (rev ns) vs - isCyclic [] = internalError "otsort isCyclic []" - isCyclic [v] = isElem v es - isCyclic _ = True - isElem v [] = False - isElem v ((x,y):xys) = v == x && v == y || isElem v xys - in case partition isCyclic sccs of - ([], noncycs) -> Right (concat noncycs) - (cycs, _) -> Left cycs + let es = [(x,y) | (x, ys) <- ns, y <- ys] + vs = map fst ns + sccs = sccEdge (mFromList ns) (rev ns) vs + isCyclic [] = internalError "otsort isCyclic []" + isCyclic [v] = isElem v es + isCyclic _ = True + isElem v [] = False + isElem v ((x,y):xys) = v == x && v == y || isElem v xys + in case partition isCyclic sccs of + ([], noncycs) -> Right (concat noncycs) + (cycs, _) -> Left cycs ------ @@ -97,12 +97,12 @@ tsort = ntsort ntsort :: Ord node => [Node node] -> Either [[node]] [node] ntsort g = let psq = fromOrdList [ n :-> length ns | (n, ns) <- sort g ] - m = M.fromListWith (++) [ (d, [s]) | (s, ds) <- g, d <- ds ] - get n = case M.lookup n m of Just ns -> ns; Nothing -> [] - in {- loop get psq [] -} -- XXX: leads to buggy cycles - case loop get psq [] of - Right ns -> Right ns - Left _ -> otsort g -- revert to old version to get accurate cycles + m = M.fromListWith (++) [ (d, [s]) | (s, ds) <- g, d <- ds ] + get n = case M.lookup n m of Just ns -> ns; Nothing -> [] + in {- loop get psq [] -} -- XXX: leads to buggy cycles + case loop get psq [] of + Right ns -> Right ns + Left _ -> otsort g -- revert to old version to get accurate cycles type TSPSQ node = PSQ node Int @@ -126,7 +126,7 @@ chkTsort :: (Show node, Ord node) => [Node node] -> Either [[node]] [node] -> Ei chkTsort g r@(Left _) = r chkTsort g r@(Right ons) = cloop S.empty ons where cloop _ [] = r - cloop s (n:ns) = if all (`S.member` s) xs then cloop (S.insert n s) ns else internalError ("chkTsort: " ++ show g ++ "\n" ++ show ons ++ "\n" ++ show (n, xs)) - where xs = find n m - m = M.fromList g + cloop s (n:ns) = if all (`S.member` s) xs then cloop (S.insert n s) ns else internalError ("chkTsort: " ++ show g ++ "\n" ++ show ons ++ "\n" ++ show (n, xs)) + where xs = find n m + m = M.fromList g -} diff --git a/src/comp/Scheme.hs b/src/comp/Scheme.hs index 1e9657f16..ac88dd178 100644 --- a/src/comp/Scheme.hs +++ b/src/comp/Scheme.hs @@ -39,7 +39,7 @@ instance Hyper Scheme where -- the reverse of quantify is inst (q.v.) quantify :: [TyVar] -> Qual Type -> Scheme quantify vs qt@(ps :=> t) = - Forall ks (apSub s qt) + Forall ks (apSub s qt) where vs' = [ v | v <- tv qt, v `elem` vs ] ks = map kind vs' s = mkSubst (zipWith (\ v n -> (v, TGen (getPosition v) n)) vs' [0..]) diff --git a/src/comp/SimCOpt.hs b/src/comp/SimCOpt.hs index e85a77ced..e51e0f2e7 100644 --- a/src/comp/SimCOpt.hs +++ b/src/comp/SimCOpt.hs @@ -25,7 +25,7 @@ import PPrint simCOpt :: Flags -> InstModMap -> ([SimCCBlock], [SimCCSched], [SimCCClockGroup], SimCCGateInfo) -> - ([SimCCBlock], [SimCCSched], [SimCCClockGroup], SimCCGateInfo) + ([SimCCBlock], [SimCCSched], [SimCCClockGroup], SimCCGateInfo) simCOpt flags instmodmap (blocks, scheds, clk_groups, gate_info) = let (blocks1,scheds1) = moveDefsOntoStack flags instmodmap (blocks,scheds) blocks2 = map (mapBlockFns removeUnusedLocals) blocks1 @@ -77,9 +77,9 @@ getFnRefs is_sched fn = concatMap (helper (sf_name fn, is_sched)) (sf_body fn) helper fl (SFSResets stmts) = concatMap (helper fl) stmts helper fl (SFSReturn Nothing) = [] helper fl (SFSReturn (Just e)) = fl `readsIds` (aVars e) - helper fl (SFSOutputReset rstId e) = - -- the rstId doesn't exist as an entity in the SimCCBlock - fl `readsIds` (aVars e) + helper fl (SFSOutputReset rstId e) = + -- the rstId doesn't exist as an entity in the SimCCBlock + fl `readsIds` (aVars e) -- --------------------- @@ -152,13 +152,13 @@ moveDefsOntoStack flags instmodmap (blocks,scheds) = -- wide values into the function, since they pay a construction penalty -- on each call. also don't move string constructors. shouldMove (sbid,aid) = - let sizeOkToMove = case (M.lookup (sbid,aid) btype_map) of - (Just ty) -> (ty == ATReal) || + let sizeOkToMove = case (M.lookup (sbid,aid) btype_map) of + (Just ty) -> (ty == ATReal) || ((not (isStringType ty)) && ((aSize ty) <= 64)) - Nothing -> False - -- don't move AV task defs - exprOkToMove = S.notMember (sbid,aid) atask_set + Nothing -> False + -- don't move AV task defs + exprOkToMove = S.notMember (sbid,aid) atask_set -- only move CF or WF if -keep-fires is not set cfwfOkToMove = not ((isFire aid) && (keepFires flags)) -- only move ports if -keep-fires is not set @@ -167,7 +167,7 @@ moveDefsOntoStack flags instmodmap (blocks,scheds) = -- do not move ports if this is the top module of a SystemC model isTopSysC = (genSysC flags) && (top_sbid == (Just sbid)) syscOkToMove = not (isPort && isTopSysC) - in and [ sizeOkToMove + in and [ sizeOkToMove , exprOkToMove , cfwfOkToMove , portOkToMove diff --git a/src/comp/SimDomainInfo.hs b/src/comp/SimDomainInfo.hs index 36322b2dd..6bda61487 100644 --- a/src/comp/SimDomainInfo.hs +++ b/src/comp/SimDomainInfo.hs @@ -35,10 +35,10 @@ findMaybeDomainId id_map aclk = M.lookup (aclock_osc aclk) id_map findDomainId :: DomainIdMap -> AClock -> DomainId findDomainId id_map aclk = case (findMaybeDomainId id_map aclk) of - Just i -> i - Nothing -> internalError ("SimDomainInfo.findDomainId: cannot find " ++ - ppReadable aclk ++ - ppReadable (M.toList id_map)) + Just i -> i + Nothing -> internalError ("SimDomainInfo.findDomainId: cannot find " ++ + ppReadable aclk ++ + ppReadable (M.toList id_map)) -- --------------- @@ -72,17 +72,17 @@ data DomainInfo = DomainInfo instance PPrint DomainInfo where pPrint d _ di = (text "DomainInfo") $+$ - text "clocks: " <+> pPrint d 0 (di_clocks di) $+$ - text "domains: " <+> pPrint d 0 (di_domains di) $+$ --- text "rules:" <+> pPrint d 0 (di_rules di) $+$ - text "-- Primitives" $+$ + text "clocks: " <+> pPrint d 0 (di_clocks di) $+$ + text "domains: " <+> pPrint d 0 (di_domains di) $+$ +-- text "rules:" <+> pPrint d 0 (di_rules di) $+$ + text "-- Primitives" $+$ vsep (map (pPrint d 0) (di_prims di)) $+$ - text "-- Primitives with resets in this domain" $+$ + text "-- Primitives with resets in this domain" $+$ vsep (map (pPrint d 0) (di_prim_resets di)) $+$ - text "-- Output clocks" $+$ - vsep (map (pPrint d 0) (di_output_clocks di)) $+$ - text "-- Clocks substitutions" $+$ - vsep (map (pPrint d 0) (di_clock_substs di)) + text "-- Output clocks" $+$ + vsep (map (pPrint d 0) (di_output_clocks di)) $+$ + text "-- Clocks substitutions" $+$ + vsep (map (pPrint d 0) (di_clock_substs di)) -- --------------- @@ -92,11 +92,11 @@ type DomainInfoMap = M.Map DomainId DomainInfo findDomainInfo :: DomainInfoMap -> DomainId -> DomainInfo findDomainInfo dinfo_map dom_id = case (M.lookup dom_id dinfo_map) of - Just i -> i - Nothing -> internalError - ("SimDomainInfo.findDomainInfo: cannot find " ++ - ppReadable dom_id ++ - ppReadable (M.toList dinfo_map)) + Just i -> i + Nothing -> internalError + ("SimDomainInfo.findDomainInfo: cannot find " ++ + ppReadable dom_id ++ + ppReadable (M.toList dinfo_map)) -- --------------- @@ -105,8 +105,8 @@ type ClockSubst = [(AClock, AClock)] applyClockSubst :: ClockSubst -> AClock -> AClock applyClockSubst ss a = case (lookup a ss) of - Nothing -> a - Just a' -> a' + Nothing -> a + Just a' -> a' -- --------------- diff --git a/src/comp/SimExpand.hs b/src/comp/SimExpand.hs index 33f738aaa..54ed71097 100644 --- a/src/comp/SimExpand.hs +++ b/src/comp/SimExpand.hs @@ -2146,7 +2146,7 @@ simExpandParams errh apkg = apkg' = apkg { apkg_state_instances = insts' } emsgs = concatMap (checkInstArgs port_ids) insts' - in if (null emsgs) + in if (null emsgs) then return apkg' else bsError errh emsgs diff --git a/src/comp/SimMakeCBlocks.hs b/src/comp/SimMakeCBlocks.hs index 258651826..caa3d959f 100644 --- a/src/comp/SimMakeCBlocks.hs +++ b/src/comp/SimMakeCBlocks.hs @@ -54,16 +54,16 @@ type CallMap = M.Map String [(ARuleId, [AId])] findModDef :: ModDefMap -> String -> DefMap findModDef mdmap inst = case M.lookup inst mdmap of - Just def_map -> def_map - Nothing -> internalError ("SimMakeCBlocks.findModDef: cannot find " ++ - ppReadable inst ++ ppReadable mdmap) + Just def_map -> def_map + Nothing -> internalError ("SimMakeCBlocks.findModDef: cannot find " ++ + ppReadable inst ++ ppReadable mdmap) findModMeth :: ModMethMap -> String -> MethMap findModMeth mmmap inst = case M.lookup inst mmmap of - Just meth_map -> meth_map - Nothing -> internalError ("SimMakeCBlocks.findModMeth: cannot find " ++ - ppReadable inst ++ ppReadable mmmap) + Just meth_map -> meth_map + Nothing -> internalError ("SimMakeCBlocks.findModMeth: cannot find " ++ + ppReadable inst ++ ppReadable mmmap) -- Used several places to name the top-level instance top_blk_name = "top" @@ -88,8 +88,8 @@ simMakeCBlocks flags sim_system = -- make a map from module name (as String) to the map for the defs -- in that module, so that the scheduler has access to all defs full_dmap = - let mkPair sp = (getIdString (sp_name sp), sp_local_defs sp) - in M.fromList (map mkPair pkgs) + let mkPair sp = (getIdString (sp_name sp), sp_local_defs sp) + in M.fromList (map mkPair pkgs) -- make a map from module name (as String) to the map for all methods -- in that module, so that the scheduler has access to all methods @@ -108,7 +108,7 @@ simMakeCBlocks flags sim_system = -- build the rest other_blocks = [ onePackageToBlock flags name_map full_mmap sim_system pkg - | pkg <- pkgs + | pkg <- pkgs , pkg /= top_pkg ] @@ -173,7 +173,7 @@ simMakeCBlocks flags sim_system = -- get and combine stmt lists for each clock edge stmt_infos = - map (mkScheduleStmts flags + map (mkScheduleStmts flags top_methods top_vmeth_set top_ameth_set top_gates inst_map full_dmap full_mmap call_map) scheds @@ -245,8 +245,8 @@ onePackageToBlock flags name_map full_meth_map ss pkg = raw_defs = M.elems def_map -- alphabetize the avis, by inst Id raw_avis = let -- Ord on Id is broken, so use cmpIdByName - cmpFn a b = fst a `cmpIdByName` fst b - in map snd $ sortBy cmpFn $ M.toList avinst_map + cmpFn a b = fst a `cmpIdByName` fst b + in map snd $ sortBy cmpFn $ M.toList avinst_map -- ---------- -- the SimCCBlock state info @@ -270,16 +270,16 @@ onePackageToBlock flags name_map full_meth_map ss pkg = -- ---------- -- instantiation parameters (module arguments) arg_defs = - let ains = [ (ai, name, isPort vainfo) + let ains = [ (ai, name, isPort vainfo) | (ai, vainfo) <- getSimPackageInputs pkg , not (isClock vainfo || isReset vainfo) , let name = getVArgInfoName vainfo ] - getType (AAI_Port (_,t)) = t - getType ai = internalError ("onePackageToBlock: " ++ - "unexpected abs input: " ++ - ppReadable ai) - in [ (getType ai,n,ip) | (ai,n,ip) <- ains ] + getType (AAI_Port (_,t)) = t + getType ai = internalError ("onePackageToBlock: " ++ + "unexpected abs input: " ++ + ppReadable ai) + in [ (getType ai,n,ip) | (ai,n,ip) <- ains ] -- ---------- -- gather all method ports @@ -349,19 +349,19 @@ onePackageToBlock flags name_map full_meth_map ss pkg = rst_map :: M.Map AReset [(AId, AId)] rst_map = - let edges = [ (rst, [(modId, portId)]) - | avi <- raw_avis, - (ResetArg rstId, ASReset _ rst) <- getInstArgs avi, + let edges = [ (rst, [(modId, portId)]) + | avi <- raw_avis, + (ResetArg rstId, ASReset _ rst) <- getInstArgs avi, -- confirm that the port is connected, -- and get the port name (rstId2, (Just portName, _)) - <- input_resets (vRst (avi_vmi avi)), - rstId2 == rstId, - let modId = avi_vname avi, - -- XXX we only need the String part of the Id - let portId = vName_to_id portName - ] - in M.fromListWith (++) edges + <- input_resets (vRst (avi_vmi avi)), + rstId2 == rstId, + let modId = avi_vname avi, + -- XXX we only need the String part of the Id + let portId = vName_to_id portName + ] + in M.fromListWith (++) edges findRstMods rst_port = M.findWithDefault [] rst_port rst_map @@ -371,32 +371,32 @@ onePackageToBlock flags name_map full_meth_map ss pkg = -- * the submodules which are reset by this wire -- * the output resets which are defined as this wire reset_instances = - [ (rst_id, areset_wire port, findRstMods port, findOutputRsts port) - | (rst_id, port) <- reset_list ] + [ (rst_id, areset_wire port, findRstMods port, findOutputRsts port) + | (rst_id, port) <- reset_list ] reset_fns = map cvtReset reset_instances -- map from reset wire to the source module and output reset Id reset_out_ports = - [ (wire, (mod_id, rst_id)) - | avi <- raw_avis, + [ (wire, (mod_id, rst_id)) + | avi <- raw_avis, let mod_id = avi_vname avi, - (rst_id, (wire, _, _)) <- getOutputResetPorts avi ] + (rst_id, (wire, _, _)) <- getOutputResetPorts avi ] -- in case some resets are unused, filter the used resets reset_srcs = - let used_rsts = map snd rst_defs - isUsed (i, _) = i `elem` used_rsts - in filter isUsed reset_out_ports + let used_rsts = map snd rst_defs + isUsed (i, _) = i `elem` used_rsts + in filter isUsed reset_out_ports -- ---------- -- names of input resets in_resets = - -- is it overkill to check for ResetArg? - -- we could just look for AAI_Reset in "sp_inputs pkg" - [ port_id - | (AAI_Reset port_id, ResetArg _) <- getSimPackageInputs pkg ] + -- is it overkill to check for ResetArg? + -- we could just look for AAI_Reset in "sp_inputs pkg" + [ port_id + | (AAI_Reset port_id, ResetArg _) <- getSimPackageInputs pkg ] -- ---------- -- Put it all together @@ -405,7 +405,7 @@ onePackageToBlock flags name_map full_meth_map ss pkg = (\ args -> (class_name, args)) domains state - arg_defs + arg_defs rst_defs ports pub_defs @@ -413,10 +413,10 @@ onePackageToBlock flags name_map full_meth_map ss pkg = rule_fns method_fns reset_fns - task_defs - reset_srcs - in_resets - (map fst output_resets) + task_defs + reset_srcs + in_resets + (map fst output_resets) input_clks gate_map in sim_block @@ -443,7 +443,7 @@ mkState name_map avinst = -- the only clk/rst, if any, are the defaults. -- drop them and only consider the other arguments iarg_pairs_no_clk = - filter (\ (i,e) -> not (isClock i || isReset i) ) iarg_pairs + filter (\ (i,e) -> not (isClock i || isReset i) ) iarg_pairs -- just the exprs iarg_exprs_no_clk = map snd iarg_pairs_no_clk -- we do not check whether these exprs are static, because that was @@ -514,7 +514,7 @@ cvtARule modId def_map method_order_map reset_list -- arguments to the method. cvtIFace :: Id -> [PProp] -> DefMap -> MethMap -> MethodOrderMap -> [(ResetId, AReset)] -> - AIFace -> Maybe SimCCFn + AIFace -> Maybe SimCCFn cvtIFace modId pps def_map meth_map method_order_map reset_list m = do let name = aIfaceName m inputs = aIfaceArgs m @@ -544,7 +544,7 @@ cvtIFace modId pps def_map meth_map method_order_map reset_list m = (mapMaybe (\n -> lookup n reset_list) (wpResets wp)) (men, ins, mr, _, ifcrules) <- M.lookup name meth_map let prt vn = vName_to_id vn - rt = do { (t,_) <- mr; return t } + rt = do { (t,_) <- mr; return t } en_stmts = maybe [] (\vn -> [SFSAssign True (prt vn) aTrue]) men wf_stmts = map (\i -> SFSAssign False (mkIdWillFire i) aTrue) ifcrules in_stmts = map (\(t,i,vn) -> SFSAssign True (prt vn) (ASPort t i)) ins @@ -595,9 +595,9 @@ cvtReset (rst_num, port, inst_ports, output_resets) = rstval_ref = ASPort aTBool rstval_id body = [ SFSAssign True (ae_objid port) rstval_ref ] ++ [ SFSFunctionCall inst (mkResetFnName rst) [rstval_ref] - | (inst, rst) <- inst_ports ] ++ - [ SFSOutputReset outRstId rstval_ref - | outRstId <- output_resets ] + | (inst, rst) <- inst_ports ] ++ + [ SFSOutputReset outRstId rstval_ref + | outRstId <- output_resets ] in SimCCFn (mkResetFnName (ae_objid port)) [(aTBool, rstval_id)] Nothing body @@ -643,40 +643,40 @@ buildTickStmts is_posedge inst_map prims = in concatMap mkTickStmt sorted_ticks sortTickCalls :: [(AClock, [(AId,AId,[AExpr])])] -> - [(AClock, [(AId,AId,[AExpr])])] + [(AClock, [(AId,AId,[AExpr])])] sortTickCalls ticks = let -- join ticks for the same clock grouped_ticks_map = M.fromListWith (++) ticks findCalls clk = - case (M.lookup clk grouped_ticks_map) of - Just calls -> (clk, calls) - Nothing -> internalError ("sortTickCalls: missing from map: " ++ - ppReadable clk) + case (M.lookup clk grouped_ticks_map) of + Just calls -> (clk, calls) + Nothing -> internalError ("sortTickCalls: missing from map: " ++ + ppReadable clk) clocks = M.keys grouped_ticks_map -- map from a gate to its clock clock_map = - let mkEdge clk = case (aclock_gate clk) of - (AMGate _ modId _) -> Just (modId, [clk]) + let mkEdge clk = case (aclock_gate clk) of + (AMGate _ modId _) -> Just (modId, [clk]) (ASPort _ objId) -> Just (mk_homeless_id (getIdQualString objId), [clk]) - _ -> Nothing - es = mapMaybe mkEdge clocks - in M.fromListWith (++) es + _ -> Nothing + es = mapMaybe mkEdge clocks + in M.fromListWith (++) es -- for a set of ticks, find the Ids of the submods that are ticked getModIds calls = map fst3 calls -- make the tsort edges mkEdge (clk, calls) = - let mods = getModIds calls - clocks = concat (mapMaybe (\i -> M.lookup i clock_map) mods) - in (clk, clocks) + let mods = getModIds calls + clocks = concat (mapMaybe (\i -> M.lookup i clock_map) mods) + in (clk, clocks) edges = map mkEdge (M.toList grouped_ticks_map) in case (tsort edges) of - Left is -> internalError ("sortTickCalls: cyclic " ++ ppReadable is) - Right is -> map findCalls (reverse is) + Left is -> internalError ("sortTickCalls: cyclic " ++ ppReadable is) + Right is -> map findCalls (reverse is) -- map from an edge of a clock expression to schedule stmts, tick calls, etc. data SchedStmtGroup = SchedFns { sched_stmts :: [SimCCFnStmt] @@ -692,7 +692,7 @@ combineStmtGroups (SchedFns a1 b1 c1) (SchedFns a2 b2 c2) = -- Convert a SimSchedule into a map from clock edges to pairs of -- schedule statements and tick statements. mkScheduleStmts :: Flags -> [AIFace] -> S.Set AId -> S.Set AId -> [AId] -> - InstModMap -> ModDefMap -> ModMethMap -> CallMap -> + InstModMap -> ModDefMap -> ModMethMap -> CallMap -> SimSchedule -> SchedStmtMap mkScheduleStmts flags top_ifc top_vmeth_set top_ameth_set top_gates inst_map full_def_map full_meth_map call_map sim_sched = @@ -731,10 +731,10 @@ mkScheduleStmts flags top_ifc top_vmeth_set top_ameth_set top_gates sched_ME_inhibits = mkMERuleInhibits top_vmeth_set sched_order disjoint_map sched_conflicts = - case (ss_schedule sim_sched) of - (ASchedule [ASchedEsposito cs] _) -> cs - (ASchedule as _) -> - internalError ("mkScheduleStmts: as = " ++ ppReadable as) + case (ss_schedule sim_sched) of + (ASchedule [ASchedEsposito cs] _) -> cs + (ASchedule as _) -> + internalError ("mkScheduleStmts: as = " ++ ppReadable as) gate_substs = mkGateSubstMap top_gates $ concatMap (di_clock_substs . snd) domain_infos mkStmt = mkSchedStmts top_ifc top_vmeth_set top_ameth_set @@ -872,9 +872,9 @@ mkGateInfo pkg_map top_gates inst_map scheds = qualifyId :: String -> AId -> AId qualifyId inst i = let q_str = getIdQualString i - q_str' = if (q_str == "") - then inst - else inst ++ "." ++ q_str + q_str' = if (q_str == "") + then inst + else inst ++ "." ++ q_str in setIdQualString i q_str' qualifyGate :: String -> AExpr -> AExpr @@ -909,10 +909,10 @@ mkGateInfo pkg_map top_gates inst_map scheds = mkGateInfo (inst, mod) = let modId = mk_homeless_id mod in case (M.lookup modId pkg_map) of - Just pkg -> + Just pkg -> let gate_map = zip [0..] (sp_gate_map pkg) in Just (inst, map (mkOneGateInfo inst) gate_map) - _ | isPrimitiveModule mod -> Nothing + _ | isPrimitiveModule mod -> Nothing _ -> internalError ("mkGateInfo: " ++ mod ++ "\n" ++ ppReadable (M.keys pkg_map)) in @@ -993,7 +993,7 @@ addScope scope (SFSOutputReset rstId val) = -- Create the SimCCFnStmts that correspond to a schedule node mkSchedStmts :: [AIFace] -> S.Set AId -> S.Set AId -> InstModMap -> ModDefMap -> - M.Map ARuleId [AId] -> GateSubstMap -> + M.Map ARuleId [AId] -> GateSubstMap -> [(AId, [AId])] -> M.Map AId [AId] -> SchedNode -> [SimCCFnStmt] mkSchedStmts top_ifc top_vmeth_set top_ameth_set inst_map full_dmap calls_by_rule gate_substs sched_conflicts sched_me_inhibits @@ -1033,8 +1033,8 @@ mkSchedStmts top_ifc top_vmeth_set top_ameth_set inst_map full_dmap -- Make statements for determining if a value method is ready mkValueMethodSchedStmts :: [AIFace] -> S.Set AId -> S.Set AId -> InstModMap -> ModDefMap -> GateSubstMap -> - [(AId, [AId])] -> M.Map AId [AId] -> - AId -> [SimCCFnStmt] + [(AId, [AId])] -> M.Map AId [AId] -> + AId -> [SimCCFnStmt] mkValueMethodSchedStmts top_ifc top_vmeth_set top_ameth_set inst_map full_dmap gate_substs sched_conflicts sched_me_inhibits qual_rid = @@ -1043,8 +1043,8 @@ mkValueMethodSchedStmts top_ifc top_vmeth_set top_ameth_set inst_map full_dmap -- Make statements for determining if an action method should fire mkActionMethodSchedStmts :: [AIFace] -> S.Set AId -> S.Set AId -> InstModMap -> ModDefMap -> [AId] -> GateSubstMap -> - [(AId, [AId])] -> M.Map AId [AId] -> - AId -> [SimCCFnStmt] + [(AId, [AId])] -> M.Map AId [AId] -> + AId -> [SimCCFnStmt] mkActionMethodSchedStmts top_ifc top_vmeth_set top_ameth_set inst_map full_dmap method_calls gate_substs sched_conflicts sched_me_inhibits qual_rid = @@ -1141,27 +1141,27 @@ mkRuleSchedStmts inst_map full_dmap method_calls -- used here is to explicitly add logic to prevent this case. me_inhibitors = - -- XXX we could take advantage of the fact that the inhibits are - -- XXX in order, so the lookup should be the top of the list - case (M.lookup qual_rid sched_me_inhibits) of - Nothing -> [] - Just is -> is + -- XXX we could take advantage of the fact that the inhibits are + -- XXX in order, so the lookup should be the top of the list + case (M.lookup qual_rid sched_me_inhibits) of + Nothing -> [] + Just is -> is inhibit_ids = map mkIdCanFire me_inhibitors inhibit_expr = reduce PrimBOr (map (ASDef bit_type) inhibit_ids) addInhibitExpr base_expr = - case inhibit_expr of - [] -> base_expr - [cfl] -> let not_inhibit = APrim dummy_id bit_type - PrimBNot [cfl] - in APrim dummy_id bit_type - PrimBAnd [base_expr, not_inhibit] - _ -> internalError "reduce produced a list of length > 1" + case inhibit_expr of + [] -> base_expr + [cfl] -> let not_inhibit = APrim dummy_id bit_type + PrimBNot [cfl] + in APrim dummy_id bit_type + PrimBAnd [base_expr, not_inhibit] + _ -> internalError "reduce produced a list of length > 1" -- ---------- -- Update the CF with the inhibitor updateCFStmt (SFSAssign p i e) | (i == cf) = - SFSAssign p i (addInhibitExpr e) + SFSAssign p i (addInhibitExpr e) updateCFStmt d = d qual_stmts2 = map updateCFStmt qual_stmts1 @@ -1187,8 +1187,8 @@ mkRuleSchedStmts inst_map full_dmap method_calls -- Make statements for computing value method outputs mkValueMethodExecStmts :: [AIFace] -> S.Set AId -> S.Set AId -> InstModMap -> ModDefMap -> GateSubstMap -> - [(AId, [AId])] -> M.Map AId [AId] -> - AId -> [SimCCFnStmt] + [(AId, [AId])] -> M.Map AId [AId] -> + AId -> [SimCCFnStmt] mkValueMethodExecStmts top_ifc top_vmeth_set top_ameth_set inst_map full_dmap gate_substs sched_conflicts sched_me_inhibits rid = [] @@ -1196,8 +1196,8 @@ mkValueMethodExecStmts top_ifc top_vmeth_set top_ameth_set inst_map full_dmap -- Make statements for executing an action method mkActionMethodExecStmts :: [AIFace] -> S.Set AId -> S.Set AId -> InstModMap -> ModDefMap -> GateSubstMap -> - [(AId, [AId])] -> M.Map AId [AId] -> - AId -> [SimCCFnStmt] + [(AId, [AId])] -> M.Map AId [AId] -> + AId -> [SimCCFnStmt] mkActionMethodExecStmts top_ifc top_vmeth_set top_ameth_set inst_map full_dmap gate_substs sched_conflicts sched_me_inhibits mid = let blk_id = mk_homeless_id top_blk_name @@ -1214,8 +1214,8 @@ mkActionMethodExecStmts top_ifc top_vmeth_set top_ameth_set inst_map full_dmap -- Make statements for executing a rule mkRuleExecStmts :: [AIFace] -> S.Set AId -> S.Set AId -> InstModMap -> ModDefMap -> GateSubstMap -> - [(AId, [AId])] -> M.Map AId [AId] -> - AId -> [SimCCFnStmt] + [(AId, [AId])] -> M.Map AId [AId] -> + AId -> [SimCCFnStmt] mkRuleExecStmts top_ifc top_vmeth_set top_ameth_set inst_map full_dmap gate_substs sched_conflicts sched_me_inhibits rid = let wf = mkIdWillFire rid @@ -1249,173 +1249,173 @@ tsortActionsAndDefs :: [SimCCFnStmt] tsortActionsAndDefs modId rId mmap ds acts reset_ids = let - -- we will create a graph where the edges are: - -- * "Left AId" to represent a def (by it's name) - -- * "Right Integer" to represent an action (by it's position in acts) - - -- The use of Left and Right was chosen to make Defs lower in - -- the Ord order than Actions. This way, tsort puts them first. - - -- ---------- - -- Defs - - -- the Ids of the defs - -- (we only want to make edges for variable uses from this list) - ds_ids = map adef_objid ds - -- for efficiency, make it a set - s = S.fromList ds_ids - - -- make edges for def-to-def dependencies - def_edges = [ (Left i, map Left uses) - | ADef i _ e _ <- ds, - let uses = filter (`S.member` s) (aVars e) ] - - -- ---------- - -- Actions - - -- give the actions a unique number and make a mapping - -- (this is necessary because the same action can be repeated - -- more than once ... for instance, $display on the same arguments) - - -- (numbering in order also helps the Ord order, for tsort) - numbered_acts = zip [1..] acts - act_map = M.fromList numbered_acts - getAct n = case (M.lookup n act_map) of - Just d -> d - Nothing -> internalError "tsortActionsAndDefs: getAct" - - -- separate the sorts of actions - -- * method calls we will re-order, respecting sequential composability - -- * foreign task/function calls we will keep in order, but allow - -- other things to come between them (because tasks can return - -- values) - - isACall (_, ACall {}) = True - isACall _ = False - - isATaskAction (_, ATaskAction {}) = True - isATaskAction _ = False - - (method_calls, foreign_calls) = partition isACall numbered_acts - task_calls = filter isATaskAction foreign_calls - - -- ---------- - -- foreign-to-foreign edges - -- (to maintain the user-specified order of system/foreign-func calls) - - -- (are these still needed now that we use Ord to bias tsort?) - foreign_edges = - if (length foreign_calls > 1) - then let mkEdge (n1,_) (n2,_) = (Right n2, [Right n1]) - in zipWith mkEdge (init foreign_calls) (tail foreign_calls) - else [] - - -- ---------- - -- Action to def edges - - -- any defs used by an action have to be computed before the - -- action is called - - act_def_edges = [ (Right n, map Left uses) - | (n,a) <- numbered_acts, + -- we will create a graph where the edges are: + -- * "Left AId" to represent a def (by it's name) + -- * "Right Integer" to represent an action (by it's position in acts) + + -- The use of Left and Right was chosen to make Defs lower in + -- the Ord order than Actions. This way, tsort puts them first. + + -- ---------- + -- Defs + + -- the Ids of the defs + -- (we only want to make edges for variable uses from this list) + ds_ids = map adef_objid ds + -- for efficiency, make it a set + s = S.fromList ds_ids + + -- make edges for def-to-def dependencies + def_edges = [ (Left i, map Left uses) + | ADef i _ e _ <- ds, + let uses = filter (`S.member` s) (aVars e) ] + + -- ---------- + -- Actions + + -- give the actions a unique number and make a mapping + -- (this is necessary because the same action can be repeated + -- more than once ... for instance, $display on the same arguments) + + -- (numbering in order also helps the Ord order, for tsort) + numbered_acts = zip [1..] acts + act_map = M.fromList numbered_acts + getAct n = case (M.lookup n act_map) of + Just d -> d + Nothing -> internalError "tsortActionsAndDefs: getAct" + + -- separate the sorts of actions + -- * method calls we will re-order, respecting sequential composability + -- * foreign task/function calls we will keep in order, but allow + -- other things to come between them (because tasks can return + -- values) + + isACall (_, ACall {}) = True + isACall _ = False + + isATaskAction (_, ATaskAction {}) = True + isATaskAction _ = False + + (method_calls, foreign_calls) = partition isACall numbered_acts + task_calls = filter isATaskAction foreign_calls + + -- ---------- + -- foreign-to-foreign edges + -- (to maintain the user-specified order of system/foreign-func calls) + + -- (are these still needed now that we use Ord to bias tsort?) + foreign_edges = + if (length foreign_calls > 1) + then let mkEdge (n1,_) (n2,_) = (Right n2, [Right n1]) + in zipWith mkEdge (init foreign_calls) (tail foreign_calls) + else [] + + -- ---------- + -- Action to def edges + + -- any defs used by an action have to be computed before the + -- action is called + + act_def_edges = [ (Right n, map Left uses) + | (n,a) <- numbered_acts, let uses = filter (`S.member` s) (aVars a) ] - -- ---------- - -- Action method to Action method edges + -- ---------- + -- Action method to Action method edges - -- function to create order edges - -- m1 `isBefore` m2 == True + -- function to create order edges + -- m1 `isBefore` m2 == True -- when (m1 SB m2) is in the VModInfo for the submodule - isBefore (ACall obj1 meth1 _) (ACall obj2 meth2 _) = - -- do they act on the same object? - if (obj1 /= obj2) - then False - else let mset = findMethodOrderSet mmap obj1 - in (unQualId meth1, unQualId meth2) `S.member` mset - isBefore _ _ = False - - -- order the method calls - -- The edges must be of the form (a, as) s.t. all actions in "as" - -- have to execute before "a". - meth_edges = [ (Right n1, ns) - | (n1,a1) <- method_calls, - let ns = [ Right n2 | (n2,a2) <- numbered_acts, - a2 /= a1, - a2 `isBefore` a1 ] ] - - -- ---------- - -- ActionValue method edges - - (av_meth_edges, av_meth_set, av_meth_local_vars) = - mkAVMethEdges ds method_calls - - -- ---------- - -- ActionValue task edges - - -- Make edges from the task to the def that it sets - -- (ATaskValue is always a top-level def, and the Id is stored - -- in the ATaskAction by the ATaskSplice stage.) - -- (Rather than remove the def for the ATaskValue and make edges from - -- the users of that def to the ATaskAction, we leave the def in - -- the graph and just generate nothing for it when we make statements - -- from the flattened graph.) - av_task_edges = - [ (Left tmp_id, [Right n]) | + isBefore (ACall obj1 meth1 _) (ACall obj2 meth2 _) = + -- do they act on the same object? + if (obj1 /= obj2) + then False + else let mset = findMethodOrderSet mmap obj1 + in (unQualId meth1, unQualId meth2) `S.member` mset + isBefore _ _ = False + + -- order the method calls + -- The edges must be of the form (a, as) s.t. all actions in "as" + -- have to execute before "a". + meth_edges = [ (Right n1, ns) + | (n1,a1) <- method_calls, + let ns = [ Right n2 | (n2,a2) <- numbered_acts, + a2 /= a1, + a2 `isBefore` a1 ] ] + + -- ---------- + -- ActionValue method edges + + (av_meth_edges, av_meth_set, av_meth_local_vars) = + mkAVMethEdges ds method_calls + + -- ---------- + -- ActionValue task edges + + -- Make edges from the task to the def that it sets + -- (ATaskValue is always a top-level def, and the Id is stored + -- in the ATaskAction by the ATaskSplice stage.) + -- (Rather than remove the def for the ATaskValue and make edges from + -- the users of that def to the ATaskAction, we leave the def in + -- the graph and just generate nothing for it when we make statements + -- from the flattened graph.) + av_task_edges = + [ (Left tmp_id, [Right n]) | (n, ATaskAction { ataskact_temp=(Just tmp_id) }) <- task_calls ] - -- ---------- - -- Action / Value method call edges - - -- like isBefore, but for Action vs Value method - isVMethSB v_obj v_meth (ACall a_obj a_meth _) = - -- do they act on the same object? - if (v_obj /= a_obj) - then False - else let mset = findMethodOrderSet mmap v_obj - in (unQualId v_meth, unQualId a_meth) `S.member` mset - isVMethSB _ _ _ = False - - isAMethSB v_obj v_meth (ACall a_obj a_meth _) = - -- do they act on the same object? - if (v_obj /= a_obj) - then False - else let mset = findMethodOrderSet mmap v_obj - in (unQualId a_meth, unQualId v_meth) `S.member` mset - isAMethSB _ _ _ = False - - -- value method calls which are SB with action methods - -- need to be properly ordered - -- Edges must be of the form (m1, m2) where the method "m2" - -- has to be executed before "m1". - mdef_edges = - [ edge | ADef i _ e _ <- ds, + -- ---------- + -- Action / Value method call edges + + -- like isBefore, but for Action vs Value method + isVMethSB v_obj v_meth (ACall a_obj a_meth _) = + -- do they act on the same object? + if (v_obj /= a_obj) + then False + else let mset = findMethodOrderSet mmap v_obj + in (unQualId v_meth, unQualId a_meth) `S.member` mset + isVMethSB _ _ _ = False + + isAMethSB v_obj v_meth (ACall a_obj a_meth _) = + -- do they act on the same object? + if (v_obj /= a_obj) + then False + else let mset = findMethodOrderSet mmap v_obj + in (unQualId a_meth, unQualId v_meth) `S.member` mset + isAMethSB _ _ _ = False + + -- value method calls which are SB with action methods + -- need to be properly ordered + -- Edges must be of the form (m1, m2) where the method "m2" + -- has to be executed before "m1". + mdef_edges = + [ edge | ADef i _ e _ <- ds, -- "aMethCalls" can return duplicates, but that's OK (obj,meth) <- aMethCalls e, - edge <- + edge <- -- def SB act - [ (Right n, [Left i]) - | (n,a) <- method_calls, - isVMethSB obj meth a ] ++ - -- act SB def (XXX can this happen?) - [ (Left i, map Right ns) - | let ns = map fst $ - filter ((isAMethSB obj meth) . snd) - method_calls, - not (null ns) ] - ] - - -- ---------- - -- put it together into one graph - - g = + [ (Right n, [Left i]) + | (n,a) <- method_calls, + isVMethSB obj meth a ] ++ + -- act SB def (XXX can this happen?) + [ (Left i, map Right ns) + | let ns = map fst $ + filter ((isAMethSB obj meth) . snd) + method_calls, + not (null ns) ] + ] + + -- ---------- + -- put it together into one graph + + g = {- - trace ("acts = " ++ ppReadable numbered_acts) $ - trace ("foreign_edges = " ++ ppReadable (foreign_edges :: [Edge])) $ - trace ("av_task_edges = " ++ ppReadable av_task_edges) $ - trace ("av_meth_edges = " ++ ppReadable av_meth_edges) $ - trace ("meth_edges = " ++ ppReadable (meth_edges :: [Edge])) $ - trace ("mdef_edges = " ++ ppReadable mdef_edges) $ - trace ("act_def_edges = " ++ ppReadable (act_def_edges :: [Edge])) $ + trace ("acts = " ++ ppReadable numbered_acts) $ + trace ("foreign_edges = " ++ ppReadable (foreign_edges :: [Edge])) $ + trace ("av_task_edges = " ++ ppReadable av_task_edges) $ + trace ("av_meth_edges = " ++ ppReadable av_meth_edges) $ + trace ("meth_edges = " ++ ppReadable (meth_edges :: [Edge])) $ + trace ("mdef_edges = " ++ ppReadable mdef_edges) $ + trace ("act_def_edges = " ++ ppReadable (act_def_edges :: [Edge])) $ -} M.fromListWith union $ concat [ foreign_edges , av_task_edges @@ -1427,25 +1427,25 @@ tsortActionsAndDefs modId rId mmap ds acts reset_ids = ] -- Convert the graph to the format expected by tsort. - g_edges = M.toList g - - -- ---------- - -- convert a graph node back into a def/action - -- and then to a SimCCFnStmt - - -- map def ids back to their exprs - -- (remember to substitute away AMethValue references) - defmap = M.fromList [ (i,d) | d@(ADef i _ _ _) <- ds ] - getDef i = case (M.lookup i defmap) of - Just d -> (mapAExprs substAV d) - Nothing -> internalError "tsortActionsAndDefs: getDef" - - -- function to substitute ASDef for AMethValue - substAV (AMethValue ty obj meth) = ASDef ty (mkAVMethTmpId obj meth) - substAV (APrim i t o es) = (APrim i t o (map substAV es)) - substAV (AMethCall t o m es) = (AMethCall t o m (map substAV es)) - substAV (AFunCall t o f isC es) = (AFunCall t o f isC (map substAV es)) - substAV e = e + g_edges = M.toList g + + -- ---------- + -- convert a graph node back into a def/action + -- and then to a SimCCFnStmt + + -- map def ids back to their exprs + -- (remember to substitute away AMethValue references) + defmap = M.fromList [ (i,d) | d@(ADef i _ _ _) <- ds ] + getDef i = case (M.lookup i defmap) of + Just d -> (mapAExprs substAV d) + Nothing -> internalError "tsortActionsAndDefs: getDef" + + -- function to substitute ASDef for AMethValue + substAV (AMethValue ty obj meth) = ASDef ty (mkAVMethTmpId obj meth) + substAV (APrim i t o es) = (APrim i t o (map substAV es)) + substAV (AMethCall t o m es) = (AMethCall t o m (map substAV es)) + substAV (AFunCall t o f isC es) = (AFunCall t o f isC (map substAV es)) + substAV e = e -- allow statements to be conditional on the rule not being reset reset_cond = reduce PrimBOr @@ -1453,35 +1453,35 @@ tsortActionsAndDefs modId rId mmap ds acts reset_ids = | rst_id <- reset_ids ] addRstCond s = - case reset_cond of - [] -> s - [c] -> [ SFSCond (aNot c) s [] ] + case reset_cond of + [] -> s + [c] -> [ SFSCond (aNot c) s [] ] _ -> internalError "reduce produced a list of length > 1" - -- defs are SFSAssigns, actions are actions, - -- actionvalue are assignactions + -- defs are SFSAssigns, actions are actions, + -- actionvalue are assignactions -- filter out the ATaskValue defs (see av_task_edges) - convertNode (Left (ADef _ _ (ATaskValue {}) _)) = Nothing - convertNode (Left d) = Just [mkDefAssign d] - convertNode (Right (False,acts)) = Just (map cvt_action acts) + convertNode (Left (ADef _ _ (ATaskValue {}) _)) = Nothing + convertNode (Left d) = Just [mkDefAssign d] + convertNode (Right (False,acts)) = Just (map cvt_action acts) convertNode (Right (True,acts)) = Just (addRstCond (map cvt_action acts)) cvt_action a@(ACall obj meth _) = - if (S.member (obj,meth) av_meth_set) - then SFSAssignAction False (mkAVMethTmpId obj meth) a - else SFSAction a - cvt_action a@(ATaskAction { aact_objid = f_id + if (S.member (obj,meth) av_meth_set) + then SFSAssignAction False (mkAVMethTmpId obj meth) a + else SFSAction a + cvt_action a@(ATaskAction { aact_objid = f_id , ataskact_temp = maybe_tmp_id }) = - case (maybe_tmp_id) of - Just tmp_id -> SFSAssignAction False tmp_id a - Nothing -> SFSAction a + case (maybe_tmp_id) of + Just tmp_id -> SFSAssignAction False tmp_id a + Nothing -> SFSAction a cvt_action a@(AFCall {}) = SFSAction a -- g++ sometimes has a hard time with sequences of conditionals, -- so we try to group system tasks, etc. with the same reset -- condition into one if block. -- It's OK to leave stale values for these when in reset, - -- since Verilog does as well. + -- since Verilog does as well. hasRst (Left _) = False hasRst (Right (ACall {})) = False hasRst (Right _) = True @@ -1494,26 +1494,26 @@ tsortActionsAndDefs modId rId mmap ds acts reset_ids = (group,rest) = span sameRight l in (Right (rst,[act | (Right act) <- group])):(groupRsts rest) in -- tsort returns Left if there is a loop, Right if sorted. - -- (In the absense of restrictive edges, tsort uses Ord to put - -- the lower valued nodes first. Thus, we have chosen the node - -- representation to put Defs first, followed by Actions in the - -- order that they were give by the user.) - case (tsort g_edges) of - Left iss -> + -- (In the absense of restrictive edges, tsort uses Ord to put + -- the lower valued nodes first. Thus, we have chosen the node + -- representation to put Defs first, followed by Actions in the + -- order that they were give by the user.) + case (tsort g_edges) of + Left iss -> let -- lookup def and action nodes lookupFn = either (Left . getDef) (Right . getAct) xss = map (map lookupFn) iss in internalError ("tsortActionsAndDefs: cyclic: " ++ ppReadable (modId, rId) ++ ppReadable xss) - Right is -> + Right is -> let -- lookup def and action nodes xs = map (either (Left . getDef) (Right . getAct)) is -- group by reset conditions grouped = groupRsts xs in -- declare the local temporaries - av_meth_local_vars ++ - -- convert the sorted and grouped nodes + av_meth_local_vars ++ + -- convert the sorted and grouped nodes concat (mapMaybe convertNode grouped) @@ -1531,43 +1531,43 @@ type Edge = (Node, [Node]) -- * a set of the ACall which are action value -- * a list of declarations for the new defs (holding the values) mkAVMethEdges :: [ADef] -> [(Integer, AAction)] -> - ([Edge], S.Set (AId,AId), [SimCCFnStmt]) + ([Edge], S.Set (AId,AId), [SimCCFnStmt]) mkAVMethEdges ds method_calls = let - -- check whether an AMethValue is from a particular action - isMethValueOf v_obj v_meth (ACall a_obj a_meth _) = - (v_obj == a_obj) && (v_meth == a_meth) - isMethValueOf _ _ _ = False + -- check whether an AMethValue is from a particular action + isMethValueOf v_obj v_meth (ACall a_obj a_meth _) = + (v_obj == a_obj) && (v_meth == a_meth) + isMethValueOf _ _ _ = False - -- find the AMethValue references - av_meth_refs = [ (i, refs) | ADef i _ e _ <- ds, + -- find the AMethValue references + av_meth_refs = [ (i, refs) | ADef i _ e _ <- ds, -- "aMethValues" can return duplicates - let refs = nub $ aMethValues e, - not (null refs) ] - - -- the value reference from an ActionValue needs to come after - -- the action method call. - -- Edges must be of the form (i, as) where all actions in "as" - -- have to execute before "i" is computed. - av_meth_edges = [ (Left i, map Right ns) - | (i, refs) <- av_meth_refs, - (obj,meth,_) <- refs, + let refs = nub $ aMethValues e, + not (null refs) ] + + -- the value reference from an ActionValue needs to come after + -- the action method call. + -- Edges must be of the form (i, as) where all actions in "as" + -- have to execute before "i" is computed. + av_meth_edges = [ (Left i, map Right ns) + | (i, refs) <- av_meth_refs, + (obj,meth,_) <- refs, let ns = map fst $ - filter ((isMethValueOf obj meth) . snd) - method_calls, - not (null ns) ] + filter ((isMethValueOf obj meth) . snd) + method_calls, + not (null ns) ] - mkAVMethDecl (obj,meth,ty) = - let id = mkAVMethTmpId obj meth - in SFSDef False (ty, id) Nothing + mkAVMethDecl (obj,meth,ty) = + let id = mkAVMethTmpId obj meth + in SFSDef False (ty, id) Nothing - av_meths = unions (map snd av_meth_refs) - av_meth_local_vars = map mkAVMethDecl av_meths + av_meths = unions (map snd av_meth_refs) + av_meth_local_vars = map mkAVMethDecl av_meths - av_meth_set = S.fromList (map (\ (o,m,t) -> (o,m)) av_meths) + av_meth_set = S.fromList (map (\ (o,m,t) -> (o,m)) av_meths) in - (av_meth_edges, av_meth_set, av_meth_local_vars) + (av_meth_edges, av_meth_set, av_meth_local_vars) -- We'll need to declare local variables for the actionvalues, @@ -1576,9 +1576,9 @@ mkAVMethEdges ds method_calls = mkAVMethTmpId obj meth = -- XXX make sure this Id is unique? mkId noPosition (concatFString [mkFString "AVMeth_", - getIdBase obj, - fsUnderscore, - getIdBase meth]) + getIdBase obj, + fsUnderscore, + getIdBase meth]) -- =============== @@ -1593,11 +1593,11 @@ mkGateSubstMap top_gates es = top_subst = M.fromList $ map mkTopSubst top_gates -- And update the existing substitions - substTop (orig, new) = (orig, M.findWithDefault new new top_subst) + substTop (orig, new) = (orig, M.findWithDefault new new top_subst) -- Convert a clock substitution into a gate substitution convEdge (orig_aclk, new_aclk) = - (aclock_gate orig_aclk, aclock_gate new_aclk) + (aclock_gate orig_aclk, aclock_gate new_aclk) es_subst = M.fromList $ map (substTop . convEdge) es in @@ -1609,25 +1609,25 @@ mkGateSubstMap top_gates es = substGateReferences :: GateSubstMap -> [SimCCFnStmt] -> [SimCCFnStmt] substGateReferences smap stmts = let - -- replace a gate if found in the map - substInAExpr e@(AMGate {}) = M.findWithDefault e e smap - substInAExpr e@(ASPort {}) = M.findWithDefault e e smap - -- otherwise, follow exprs - substInAExpr e@(APrim { ae_args = es }) = - e { ae_args = map substInAExpr es } - substInAExpr e@(AMethCall { ae_args = es }) = - e { ae_args = map substInAExpr es } - substInAExpr e@(ANoInlineFunCall { ae_args = es }) = - e { ae_args = map substInAExpr es } - substInAExpr e@(AFunCall { ae_args = es }) = - e { ae_args = map substInAExpr es } - substInAExpr e = e - - substInStmt (SFSAssign p i e) = (SFSAssign p i (substInAExpr e)) - substInStmt s = internalError ("substGateReferences: non-assign: " ++ - ppReadable s) + -- replace a gate if found in the map + substInAExpr e@(AMGate {}) = M.findWithDefault e e smap + substInAExpr e@(ASPort {}) = M.findWithDefault e e smap + -- otherwise, follow exprs + substInAExpr e@(APrim { ae_args = es }) = + e { ae_args = map substInAExpr es } + substInAExpr e@(AMethCall { ae_args = es }) = + e { ae_args = map substInAExpr es } + substInAExpr e@(ANoInlineFunCall { ae_args = es }) = + e { ae_args = map substInAExpr es } + substInAExpr e@(AFunCall { ae_args = es }) = + e { ae_args = map substInAExpr es } + substInAExpr e = e + + substInStmt (SFSAssign p i e) = (SFSAssign p i (substInAExpr e)) + substInStmt s = internalError ("substGateReferences: non-assign: " ++ + ppReadable s) in - map substInStmt stmts + map substInStmt stmts -- =============== @@ -1638,21 +1638,21 @@ mkMERuleInhibits top_vmeth_set sched_order disjoint_map = let -- value methods can't change state, so they don't need to inhibit - foldfunc :: (IdSet, [(AId,[AId])]) -> SchedNode -> - (IdSet, [(AId,[AId])]) - foldfunc (seen_exec_nodes, res) (Exec r) = + foldfunc :: (IdSet, [(AId,[AId])]) -> SchedNode -> + (IdSet, [(AId,[AId])]) + foldfunc (seen_exec_nodes, res) (Exec r) = if (S.member r top_vmeth_set) then (seen_exec_nodes, res) - else (S.insert r seen_exec_nodes, res) - foldfunc (seen_exec_nodes, res) (Sched r) = - case (M.lookup r disjoint_map) of - Nothing -> (seen_exec_nodes, res) - Just dset -> - let inhibit_set = S.intersection dset seen_exec_nodes - new_res = (r, S.toList inhibit_set) - in (seen_exec_nodes, new_res:res) + else (S.insert r seen_exec_nodes, res) + foldfunc (seen_exec_nodes, res) (Sched r) = + case (M.lookup r disjoint_map) of + Nothing -> (seen_exec_nodes, res) + Just dset -> + let inhibit_set = S.intersection dset seen_exec_nodes + new_res = (r, S.toList inhibit_set) + in (seen_exec_nodes, new_res:res) in - M.fromList $ reverse $ snd $ foldl foldfunc (S.empty, []) sched_order + M.fromList $ reverse $ snd $ foldl foldfunc (S.empty, []) sched_order -- =============== diff --git a/src/comp/Simplify.hs b/src/comp/Simplify.hs index 9783fda76..05ddf1214 100644 --- a/src/comp/Simplify.hs +++ b/src/comp/Simplify.hs @@ -32,8 +32,8 @@ traced name orig result = simplify :: Flags -> CPackage -> CPackage simplify flags pkg@(CPackage mi exps imps fixs ds includes) | simplifyCSyntax flags = - let (env, _) = selectSimple [] [ d | CValueSign d <- ds ] - in CPackage mi exps imps fixs (simp env ds) includes + let (env, _) = selectSimple [] [ d | CValueSign d <- ds ] + in CPackage mi exps imps fixs (simp env ds) includes | otherwise = pkg cLetRec :: [CDefl] -> CExpr -> CExpr @@ -53,10 +53,10 @@ cLetRec ds e = Cletrec (map optBind ds) e -- into -- let i .v1 ... .vn p1 .. pn p1' .. pn' :: qt = e optBind orig@(CLValueSign (CDefT i vs qt [CClause ps [] (Cletrec [CLValueSign (CDefT i' [] _ [CClause ps' [] e]) []] (CVar i''))]) []) - | i' == i'' && not (isKeepId i') && not (S.member i' (snd (getFVE e))) = + | i' == i'' && not (isKeepId i') && not (S.member i' (snd (getFVE e))) = (traced "Simplify.optBind" orig (CLValueSign (CDefT i vs qt [CClause (ps++ps') [] e]) [])) - + optBind b = b isSimple :: CExpr -> Bool @@ -111,11 +111,11 @@ instance Simp CDef where -- when q1 .. qn, q1'' .. qn'' -- ... simp r def@(CDefT i vs t cs) = - case simp r cs of - [CClause ps qs (Cletrec [CLValueSign (CDefT i' vs' _ cs) []] (CVar i''))] + case simp r cs of + [CClause ps qs (Cletrec [CLValueSign (CDefT i' vs' _ cs) []] (CVar i''))] | i' == i'' && not (isKeepId i') -> - CDefT i vs t [CClause (ps ++ ps') (qs ++ qs') e | CClause ps' qs' e <- cs] - cs -> CDefT i vs t cs + CDefT i vs t [CClause (ps ++ ps') (qs ++ qs') e | CClause ps' qs' e <- cs] + cs -> CDefT i vs t cs simp r def@(CDef _ _ _) = internalError "Simplify.Simp(CDef).simp: CDef" -- XXX susceptible to bug #168 @@ -129,7 +129,7 @@ instance Simp CClause where concat [" captured: " ++ ppString v ++ " = " ++ ppString e ++ "\n" | (v,(e,_)) <- captures]) - where patternVars = concatMap (S.toList . getPV) ps + where patternVars = concatMap (S.toList . getPV) ps r' = dropIs patternVars r (captures, _) = sepCaptures patternVars r' @@ -169,7 +169,7 @@ instance Simp CExpr where -- XXX is this susceptible to #166? analyze! simp r orig@(Cletrec [CLValueSign (CDefT i [] qtype [CClause ps [] e]) []] (CApply (CVar i') es)) - | (i == i' && not (isKeepId i) && length ps == length es + | (i == i' && not (isKeepId i) && length ps == length es && length argTypes == length es && all isCPVar ps && not (i `S.member` snd (getFVE e))) = traced "Simplify.Simp(CExpr).simp[2]" orig $ @@ -184,17 +184,17 @@ instance Simp CExpr where -- XXX is this susceptible to #166? analyze! simp r orig@(Cletrec [CLValueSign (CDefT i vs qtype [CClause ps [] e]) []] (CApply (CTApply (CVar i') ts) es)) - | (i == i' && not (isKeepId i) && length vs == length ts + | (i == i' && not (isKeepId i) && length vs == length ts && length ps == length es && all isCPVar ps && not (i `S.member` snd (getFVE e))) = traced "Simplify.Simp(CExpr).simp[3]" orig $ - simp (zip [ x | CPVar x <- ps ] ets ++ r) + simp (zip [ x | CPVar x <- ps ] ets ++ r) (apSub typeVarSubst e) where (argTypes, _) = getCQArrows qtype ets = zip es (map (apSub typeVarSubst) argTypes) typeVarSubst = mkSubst (zip vs ts) simp r orig@(Cletrec ds e) = - let capturedVars :: [Id] + let capturedVars :: [Id] capturedVars = S.toList $ S.unions $ map capturedVarsCDefl ds -- drop substitutions of vars shadowed by let-bindings rd = dropIs capturedVars r @@ -204,7 +204,7 @@ instance Simp CExpr where capturedDefs = [CLValueSign (CDefT var [] t [CClause [] [] e]) [] | (var, (e, t)) <- captures] -- sep substitutions with any capturedVars free on the RHS - (r', ds') = selectSimpleL rd' (simp rd' ds) + (r', ds') = selectSimpleL rd' (simp rd' ds) blurb =("simp[4]:\n* capturedVars =\n" ++ ppReadable capturedVars ++ "* r =\n" ++ ppReadable r ++ "* rd =\n" ++ ppReadable rd ++ diff --git a/src/comp/SpeedyString.hs b/src/comp/SpeedyString.hs index 0bdd80cdb..aa1358c75 100644 --- a/src/comp/SpeedyString.hs +++ b/src/comp/SpeedyString.hs @@ -28,13 +28,13 @@ instance Show SString where toString :: SString -> String toString (SString id) = unsafePerformIO $ - do m <- readVar strings - return $ M.findWithDefault err id m + do m <- readVar strings + return $ M.findWithDefault err id m fromString :: String -> SString fromString s = unsafePerformIO $ - do m <- readVar sstrings - return $ maybe (newSString s) id $ M.lookup (hashStr s) m >>= lookup s + do m <- readVar sstrings + return $ maybe (newSString s) id $ M.lookup (hashStr s) m >>= lookup s (++) :: SString -> SString -> SString s ++ s' = fromString $ (toString s) Prelude.++ (toString s') @@ -49,14 +49,14 @@ filter pred s = fromString $ Prelude.filter pred (toString s) newSString :: String -> SString newSString s = unsafePerformIO $ - do id <- freshInt - let ss = SString id - sm <- readVar strings - ssm <- readVar sstrings - writeVar strings $ M.insert id s sm - writeVar sstrings $ M.insertWith (Prelude.++) + do id <- freshInt + let ss = SString id + sm <- readVar strings + ssm <- readVar sstrings + writeVar strings $ M.insert id s sm + writeVar sstrings $ M.insertWith (Prelude.++) (hashStr s) [(s,ss)] ssm - return ss + return ss err = internalError "SpeedyString: inconsistent representation" @@ -91,5 +91,5 @@ nextInt = unsafePerformIO $ (newVar 0) freshInt :: IO Int freshInt = do fresh <- readVar nextInt - writeVar nextInt (fresh + 1) - return fresh + writeVar nextInt (fresh + 1) + return fresh diff --git a/src/comp/StdPrel.hs b/src/comp/StdPrel.hs index 1c91e879a..00cd04178 100644 --- a/src/comp/StdPrel.hs +++ b/src/comp/StdPrel.hs @@ -64,67 +64,67 @@ checkDVS dvs t = all (flip elem dvs) (tv t) clsAdd :: SymTab -> Class clsAdd symT = Class { - name = CTypeclass idAdd, - csig = [tvarh1, tvarh2, tvarh3], - super = [], -- [IsIn clsSize [TVar tvarh1], IsIn clsSize [TVar tvarh2], IsIn clsSize [TVar tvarh3]] - genInsts = genAddInsts symT, - tyConOf = TyCon idAdd (Just (Kfun KNum (Kfun KNum (Kfun KNum KStar)))) (TIstruct SClass []), - funDeps = [[False, False, True], [False, True, False], [True, False, False]], - funDeps2 = [[Just False, Just False, Just True], - [Just False, Just True, Just False], - [Just True, Just False, Just False]], + name = CTypeclass idAdd, + csig = [tvarh1, tvarh2, tvarh3], + super = [], -- [IsIn clsSize [TVar tvarh1], IsIn clsSize [TVar tvarh2], IsIn clsSize [TVar tvarh3]] + genInsts = genAddInsts symT, + tyConOf = TyCon idAdd (Just (Kfun KNum (Kfun KNum (Kfun KNum KStar)))) (TIstruct SClass []), + funDeps = [[False, False, True], [False, True, False], [True, False, False]], + funDeps2 = [[Just False, Just False, Just True], + [Just False, Just True, Just False], + [Just True, Just False, Just False]], allowIncoherent = Just False, isComm = True - } + } genAddInsts :: SymTab -> [TyVar] -> Maybe [TyVar] -> Pred -> [Inst] -- (C1, C2, ?) : (C1, C2, C1+C2) genAddInsts _ _ _ (IsIn c [t1@(TCon (TyNum n1 p1)), t2@(TCon (TyNum n2 _)), _]) - = [ mkInst r ([] :=> p) ] + = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t3 = TCon (TyNum (n1+n2) p1) + p = IsIn c [t1, t2, t3] + t3 = TCon (TyNum (n1+n2) p1) -- (C1, ?, C3) : (C1, C3-C1, C3) genAddInsts _ _ _ (IsIn c [t1@(TCon (TyNum i1 p1)), _, t3@(TCon (TyNum i3 _))]) - | i3 >= i1 = [ mkInst r ([] :=> p) ] + | i3 >= i1 = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t2 = TCon (TyNum (i3 - i1) p1) + p = IsIn c [t1, t2, t3] + t2 = TCon (TyNum (i3 - i1) p1) -- (?, C2, C3) : (C3-C2, C2, C3) genAddInsts _ _ _ (IsIn c [_, t2@(TCon (TyNum i2 p2)), t3@(TCon (TyNum i3 _))]) - | i3 >= i2 = [ mkInst r ([] :=> p) ] + | i3 >= i2 = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t1 = TCon (TyNum (i3 - i2) p2) + p = IsIn c [t1, t2, t3] + t1 = TCon (TyNum (i3 - i2) p2) -- (0, T, ?) : (0, T, T) genAddInsts _ _ _ (IsIn c [t1@(TCon (TyNum 0 _)), t2, _]) - = [ mkInst r ([] :=> p) ] + = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t2] + p = IsIn c [t1, t2, t2] -- (T, 0, ?) : (0, T, T) genAddInsts _ _ _ (IsIn c [t1, t2@(TCon (TyNum 0 _)), _]) - = [ mkInst r ([] :=> p) ] + = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t1] + p = IsIn c [t1, t2, t1] -- (?, T, T) : (0, T, T) genAddInsts _ _ _ (IsIn c [_, t2, t3]) - | t2 == t3 = [ mkInst r ([] :=> p) ] + | t2 == t3 = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t1 = TCon (TyNum 0 (getPosition t2)) + p = IsIn c [t1, t2, t3] + t1 = TCon (TyNum 0 (getPosition t2)) -- (T, ?, T) : (T, 0, T) genAddInsts _ _ _ (IsIn c [t1, _, t3]) - | t1 == t3 = [ mkInst r ([] :=> p) ] + | t1 == t3 = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t2 = TCon (TyNum 0 (getPosition t1)) + p = IsIn c [t1, t2, t3] + t2 = TCon (TyNum 0 (getPosition t1)) -- (T, T, C) : NumEq(T, C/2) => itself, when C is even genAddInsts symT _ _ p@(IsIn c [t1, t2, TCon (TyNum n npos)]) @@ -194,11 +194,11 @@ genAddInsts _ bvs (Just dvs) (IsIn c [t1,t2, tv@(TVar v)]) | v `notElem` dvs, checkDVS dvs (t1, t2), mgu bvs tv t3 /= Nothing = - --trace ("TAdd " ++ ppReadable (r, p)) $ - [ mkInst r ([] :=> p) ] + --trace ("TAdd " ++ ppReadable (r, p)) $ + [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t3 = TAp (TAp tAdd t1) t2 + p = IsIn c [t1, t2, t3] + t3 = TAp (TAp tAdd t1) t2 -- when satisfyFV, as a last resort: -- (T1, V, T3) : (T1, TSub#(T3, T1), T3) @@ -220,21 +220,21 @@ genAddInsts _ bvs (Just dvs) (IsIn c [t1, tv@(TVar v), t3]) v `notElem` dvs, checkDVS dvs (t1, t3), mgu bvs tv t2 /= Nothing = - --trace ("Add TMax " ++ ppReadable p) $ - [ mkInst r ([] :=> p) ] + --trace ("Add TMax " ++ ppReadable p) $ + [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t2 = cTApplys tSub [t3, t1] + p = IsIn c [t1, t2, t3] + t2 = cTApplys tSub [t3, t1] genAddInsts _ bvs (Just dvs) (IsIn c [tv@(TVar v), t2, t3]) | t2 `isKnownLTE` t3, v `notElem` dvs, checkDVS dvs (t2, t3), mgu bvs tv t1 /= Nothing = - --trace ("Add TMax " ++ ppReadable p) $ - [ mkInst r ([] :=> p) ] + --trace ("Add TMax " ++ ppReadable p) $ + [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t1 = cTApplys tSub [t3, t2] + p = IsIn c [t1, t2, t3] + t1 = cTApplys tSub [t3, t2] -- else, no instances to match genAddInsts _ _ _ _ = [] @@ -326,37 +326,37 @@ isKnownLTE _ _ = False clsMax :: Class clsMax = Class { - name = CTypeclass idMax, - csig = [tvarh1, tvarh2, tvarh3], - super = [], -- [IsIn clsSize [TVar tvarh1], IsIn clsSize [TVar tvarh2], IsIn clsSize [TVar tvarh3]] - genInsts = genMaxInsts, - tyConOf = TyCon idMax (Just (Kfun KNum (Kfun KNum (Kfun KNum KStar)))) (TIstruct SClass []), - funDeps = [[False, False, True]], - funDeps2 = [[Just False, Just False, Just True]], + name = CTypeclass idMax, + csig = [tvarh1, tvarh2, tvarh3], + super = [], -- [IsIn clsSize [TVar tvarh1], IsIn clsSize [TVar tvarh2], IsIn clsSize [TVar tvarh3]] + genInsts = genMaxInsts, + tyConOf = TyCon idMax (Just (Kfun KNum (Kfun KNum (Kfun KNum KStar)))) (TIstruct SClass []), + funDeps = [[False, False, True]], + funDeps2 = [[Just False, Just False, Just True]], allowIncoherent = Just False, isComm = True - } + } genMaxInsts :: [TyVar] -> Maybe [TyVar] -> Pred -> [Inst] -- (C1, C2, ?) : (C1, C2, max(C1,C2)) genMaxInsts _ _ (IsIn c [t1@(TCon (TyNum n1 p1)), t2@(TCon (TyNum n2 _)), _]) - = [ mkInst r ([] :=> p) ] + = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t3 = TCon (TyNum (n1 `max` n2) p1) + p = IsIn c [t1, t2, t3] + t3 = TCon (TyNum (n1 `max` n2) p1) -- (0, T, ?) : (0, T, T) genMaxInsts _ _ (IsIn c [t1@(TCon (TyNum 0 _)), t2, _]) - = [ mkInst r ([] :=> p) ] + = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t2] + p = IsIn c [t1, t2, t2] -- (T, 0, ?) : (T, 0, T) genMaxInsts _ _ (IsIn c [t1, t2@(TCon (TyNum 0 _)), _]) - = [ mkInst r ([] :=> p) ] + = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t1] + p = IsIn c [t1, t2, t1] -- (T1, T2, TMax#(T1,T2)) : itself -- (T1, T2, TMax#(T2,T1)) : itself @@ -416,37 +416,37 @@ equalMaxTerms (MaxTerms i1 s1) (MaxTerms i2 s2) = (i1 == i2) && (s1 == s2) clsMin :: Class clsMin = Class { - name = CTypeclass idMin, - csig = [tvarh1, tvarh2, tvarh3], - super = [], -- [IsIn clsSize [TVar tvarh1], IsIn clsSize [TVar tvarh2], IsIn clsSize [TVar tvarh3]] - genInsts = genMinInsts, - tyConOf = TyCon idMin (Just (Kfun KNum (Kfun KNum (Kfun KNum KStar)))) (TIstruct SClass []), - funDeps = [[False, False, True]], - funDeps2 = [[Just False, Just False, Just True]], + name = CTypeclass idMin, + csig = [tvarh1, tvarh2, tvarh3], + super = [], -- [IsIn clsSize [TVar tvarh1], IsIn clsSize [TVar tvarh2], IsIn clsSize [TVar tvarh3]] + genInsts = genMinInsts, + tyConOf = TyCon idMin (Just (Kfun KNum (Kfun KNum (Kfun KNum KStar)))) (TIstruct SClass []), + funDeps = [[False, False, True]], + funDeps2 = [[Just False, Just False, Just True]], allowIncoherent = Just False, isComm = True - } + } genMinInsts :: [TyVar] -> Maybe [TyVar] -> Pred -> [Inst] -- (C1, C2, ?) : (C1, C2, min(C1,C2)) genMinInsts _ _ (IsIn c [t1@(TCon (TyNum n1 p1)), t2@(TCon (TyNum n2 _)), _]) - = [ mkInst r ([] :=> p) ] + = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t3 = TCon (TyNum (n1 `min` n2) p1) + p = IsIn c [t1, t2, t3] + t3 = TCon (TyNum (n1 `min` n2) p1) -- (0, T, ?) : (0, T, 0) genMinInsts _ _ (IsIn c [t1@(TCon (TyNum 0 _)), t2, _]) - = [ mkInst r ([] :=> p) ] + = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t1] + p = IsIn c [t1, t2, t1] -- (T, 0, ?) : (T, 0, 0) genMinInsts _ _ (IsIn c [t1, t2@(TCon (TyNum 0 _)), _]) - = [ mkInst r ([] :=> p) ] + = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t2] + p = IsIn c [t1, t2, t2] -- (T1, T2, TMin#(T1,T2)) : itself -- (T1, T2, TMin#(T2,T1)) : itself @@ -510,16 +510,16 @@ equalMinTerms (MinTerms i1 s1) (MinTerms i2 s2) = (i1 == i2) && (s1 == s2) clsLog :: Class clsLog = Class { - name = CTypeclass idLog, - csig = [tvarh1, tvarh2], - super = [], -- [IsIn clsSize [TVar tvarh1], IsIn clsSize [TVar tvarh2], IsIn clsSize [TVar tvarh3]] - genInsts = genLogInsts, - tyConOf = TyCon idLog (Just (Kfun KNum (Kfun KNum KStar))) (TIstruct SClass []), - funDeps = [[False, True]], - funDeps2 = [[Just False, Just True]], + name = CTypeclass idLog, + csig = [tvarh1, tvarh2], + super = [], -- [IsIn clsSize [TVar tvarh1], IsIn clsSize [TVar tvarh2], IsIn clsSize [TVar tvarh3]] + genInsts = genLogInsts, + tyConOf = TyCon idLog (Just (Kfun KNum (Kfun KNum KStar))) (TIstruct SClass []), + funDeps = [[False, True]], + funDeps2 = [[Just False, Just True]], allowIncoherent = Just False, isComm = False - } + } genLogInsts :: [TyVar] -> Maybe [TyVar] -> Pred -> [Inst] @@ -529,10 +529,10 @@ genLogInsts _ _ (IsIn c [t1@(TCon (TyNum i1 p1)), _]) -- (C, ?) : (C, log(C)) genLogInsts _ _ (IsIn c [t1@(TCon (TyNum i1 p1)), _]) - | i1 > 0 = [ mkInst r ([] :=> p) ] + | i1 > 0 = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2] - t2 = TCon (TyNum (log2 i1) p1) + p = IsIn c [t1, t2] + t2 = TCon (TyNum (log2 i1) p1) -- For most C, there are multiple X for which Log#(X,C) is an instance. -- This code produces only one instance, and it would only match if the @@ -541,10 +541,10 @@ genLogInsts _ _ (IsIn c [t1@(TCon (TyNum i1 p1)), _]) {- -- (?, C) : (2^C, C) genLogInsts _ _ (IsIn c [_, t2@(TCon (TyNum i2 p2))]) - | i2 >= 0 = [ mkInst r ([] :=> p) ] + | i2 >= 0 = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2] - t1 = TCon (TyNum (2 ^ i2) p2) + p = IsIn c [t1, t2] + t1 = TCon (TyNum (2 ^ i2) p2) -} -- (T, TLog#(T)) : itself @@ -574,10 +574,10 @@ genLogInsts bvs (Just dvs) (IsIn c [tv@(TVar v),t2]) | v `notElem` dvs, checkDVS dvs t2, mgu bvs tv t1 /= Nothing = - [ mkInst r ([] :=> p) ] + [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2] - t1 = TAp tExp t2 + p = IsIn c [t1, t2] + t1 = TAp tExp t2 -} -- when satisfyFV, as a last resort: @@ -589,10 +589,10 @@ genLogInsts bvs (Just dvs) (IsIn c [t1,tv@(TVar v)]) | v `notElem` dvs, checkDVS dvs t1, mgu bvs tv t2 /= Nothing = - [ mkInst r ([] :=> p) ] + [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2] - t2 = TAp tLog t1 + p = IsIn c [t1, t2] + t2 = TAp tLog t1 -- else, no instances to match genLogInsts _ _ _ = [] @@ -601,79 +601,79 @@ genLogInsts _ _ _ = [] clsMul :: SymTab -> Class clsMul symT = Class { - name = CTypeclass idMul, - csig = [tvarh1, tvarh2, tvarh3], - super = [], -- [IsIn clsSize [TVar tvarh1], IsIn clsSize [TVar tvarh2], IsIn clsSize [TVar tvarh3]] - genInsts = genMulInsts symT, - tyConOf = TyCon idMul (Just (Kfun KNum (Kfun KNum (Kfun KNum KStar)))) (TIstruct SClass []), - funDeps = [[False, False, True], [False, True, False], [True, False, False]], - funDeps2 = [[Just False, Just False, Just True], - [Just False, Just True, Just False], - [Just True, Just False, Just False]], + name = CTypeclass idMul, + csig = [tvarh1, tvarh2, tvarh3], + super = [], -- [IsIn clsSize [TVar tvarh1], IsIn clsSize [TVar tvarh2], IsIn clsSize [TVar tvarh3]] + genInsts = genMulInsts symT, + tyConOf = TyCon idMul (Just (Kfun KNum (Kfun KNum (Kfun KNum KStar)))) (TIstruct SClass []), + funDeps = [[False, False, True], [False, True, False], [True, False, False]], + funDeps2 = [[Just False, Just False, Just True], + [Just False, Just True, Just False], + [Just True, Just False, Just False]], allowIncoherent = Just False, isComm = True - } + } genMulInsts :: SymTab -> [TyVar] -> Maybe [TyVar] -> Pred -> [Inst] -- (C1, C2, ?) : (C1, C2, C1*C2) genMulInsts _ _ _ (IsIn c [t1@(TCon (TyNum n1 p1)), t2@(TCon (TyNum n2 _)), _]) - = [ mkInst r ([] :=> p) ] + = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t3 = TCon (TyNum (n1 * n2) p1) + p = IsIn c [t1, t2, t3] + t3 = TCon (TyNum (n1 * n2) p1) -- (C1, ?, C3) : (C1, C3/C1, C3) when C3/C1 has no remainder (and C1 is not 0) genMulInsts _ _ _ (IsIn c [t1@(TCon (TyNum i1 p1)), _, t3@(TCon (TyNum i3 _))]) - | i1 /= 0 && i3 `mod` i1 == 0 = [ mkInst r ([] :=> p) ] + | i1 /= 0 && i3 `mod` i1 == 0 = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t2 = TCon (TyNum (i3 `div` i1) p1) + p = IsIn c [t1, t2, t3] + t2 = TCon (TyNum (i3 `div` i1) p1) -- (?, C2, C3) : (C3/C2, C2, C3) when C3/C2 has no remainder (and C2 is not 0) genMulInsts _ _ _ (IsIn c [_, t2@(TCon (TyNum i2 p2)), t3@(TCon (TyNum i3 _))]) - | i2 /= 0 && i3 `mod` i2 == 0 = [ mkInst r ([] :=> p) ] + | i2 /= 0 && i3 `mod` i2 == 0 = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t1 = TCon (TyNum (i3 `div` i2) p2) + p = IsIn c [t1, t2, t3] + t1 = TCon (TyNum (i3 `div` i2) p2) -- (1, T, ?) : (1, T, T) genMulInsts _ _ _ (IsIn c [t1@(TCon (TyNum 1 _)), t2, _]) - = [ mkInst r ([] :=> p) ] + = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t2] + p = IsIn c [t1, t2, t2] -- (0, T, ?) : (0, T, 0) genMulInsts _ _ _ (IsIn c [t1@(TCon (TyNum 0 _)), t2, _]) - = [ mkInst r ([] :=> p) ] + = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t1] + p = IsIn c [t1, t2, t1] -- (T, 1, ?) : (T, 1, T) genMulInsts _ _ _ (IsIn c [t1, t2@(TCon (TyNum 1 _)), _]) - = [ mkInst r ([] :=> p) ] + = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t1] + p = IsIn c [t1, t2, t1] -- (T, 0, ?) : (T, 0, 0) genMulInsts _ _ _ (IsIn c [t1, t2@(TCon (TyNum 0 _)), _]) - = [ mkInst r ([] :=> p) ] + = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t2] + p = IsIn c [t1, t2, t2] -- (?, T, T) : (1, T, T) genMulInsts _ _ _ (IsIn c [_, t2, t3]) - | t2 == t3 = [ mkInst r ([] :=> p) ] + | t2 == t3 = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t1 = TCon (TyNum 1 (getPosition t2)) + p = IsIn c [t1, t2, t3] + t1 = TCon (TyNum 1 (getPosition t2)) -- (T, ?, T) : (T, 1, T) genMulInsts _ _ _ (IsIn c [t1, _, t3]) - | t1 == t3 = [ mkInst r ([] :=> p) ] + | t1 == t3 = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t2 = TCon (TyNum 1 (getPosition t1)) + p = IsIn c [t1, t2, t3] + t2 = TCon (TyNum 1 (getPosition t1)) -- (T, T, C) : NumEq(T, sqrt(C)) => itself, when C is a perfect square genMulInsts symT _ _ p@(IsIn c [t1, t2, TCon (TyNum n npos)]) @@ -792,23 +792,23 @@ genMulInsts _ bvs (Just dvs) (IsIn c [t1,t2,tv@(TVar v)]) | v `notElem` dvs, checkDVS dvs (t1, t2), mgu bvs tv t3 /= Nothing = - [ mkInst r ([] :=> p) ] + [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t3 = TAp (TAp tMul t1) t2 + p = IsIn c [t1, t2, t3] + t3 = TAp (TAp tMul t1) t2 {- genMulInsts (Just dvs) (IsIn c [t1,TVar v,t3]) | v `notElem` dvs = - [ mkInst r ([] :=> p) ] + [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t2 = TAp (TAp tDiv t3) t1 + p = IsIn c [t1, t2, t3] + t2 = TAp (TAp tDiv t3) t1 genMulInsts (Just dvs) (IsIn c [TVar v,t2,t3]) | v `notElem` dvs = - [ mkInst r ([] :=> p) ] + [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t1 = TAp (TAp tDiv t3) t2 + p = IsIn c [t1, t2, t3] + t1 = TAp (TAp tDiv t3) t2 -} -- else, no instances to match @@ -872,31 +872,31 @@ constDifferenceMulTerms (MulTerms i mul_b) c = clsDiv :: Class clsDiv = Class { - name = CTypeclass idDiv, - csig = [tvarh1, tvarh2, tvarh3], - super = [], -- [IsIn clsSize [TVar tvarh1], IsIn clsSize [TVar tvarh2], IsIn clsSize [TVar tvarh3]] - genInsts = genDivInsts, - tyConOf = TyCon idDiv (Just (Kfun KNum (Kfun KNum (Kfun KNum KStar)))) (TIstruct SClass []), - funDeps = [[False, False, True]], - funDeps2 = [[Just False, Just False, Just True]], + name = CTypeclass idDiv, + csig = [tvarh1, tvarh2, tvarh3], + super = [], -- [IsIn clsSize [TVar tvarh1], IsIn clsSize [TVar tvarh2], IsIn clsSize [TVar tvarh3]] + genInsts = genDivInsts, + tyConOf = TyCon idDiv (Just (Kfun KNum (Kfun KNum (Kfun KNum KStar)))) (TIstruct SClass []), + funDeps = [[False, False, True]], + funDeps2 = [[Just False, Just False, Just True]], allowIncoherent = Just False, isComm = False - } + } genDivInsts :: [TyVar] -> Maybe [TyVar] -> Pred -> [Inst] -- (C1, C2, ?) : (C1, C2, C1/C2) genDivInsts _ _ (IsIn c [t1@(TCon (TyNum i1 pos)), t2@(TCon (TyNum i2 _)), _]) - = [ mkInst r ([] :=> p) ] + = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t3 = TCon (TyNum ((i1+i2-1) `div` i2) pos) + p = IsIn c [t1, t2, t3] + t3 = TCon (TyNum ((i1+i2-1) `div` i2) pos) -- (T, 1, ?) : (T, 1, T) genDivInsts _ _ (IsIn c [t1, t2@(TCon (TyNum 1 _)), _]) - = [ mkInst r ([] :=> p) ] + = [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t1] + p = IsIn c [t1, t2, t1] -- XXX Add this? -- (0, T, ?) : (0, T, 0) @@ -916,10 +916,10 @@ genDivInsts bvs (Just dvs) (IsIn c [t1,t2,tv@(TVar v)]) | v `notElem` dvs, checkDVS dvs (t1, t2), mgu bvs tv t3 /= Nothing = - [ mkInst r ([] :=> p) ] + [ mkInst r ([] :=> p) ] where r = anyTExpr (predToType p) - p = IsIn c [t1, t2, t3] - t3 = TAp (TAp tDiv t1) t2 + p = IsIn c [t1, t2, t3] + t3 = TAp (TAp tDiv t1) t2 -- else, no instances to match genDivInsts _ _ _ = [] @@ -984,8 +984,8 @@ genNumEqInsts symT _ _ (IsIn c [t1, TVar {}]) | null (tv t1) genNumEqInsts symT bvs (Just dvs) (IsIn c [t1, t2]) | TVar v <- tB, checkDVS dvs tA, mgu bvs tB tA /= Nothing, let p = IsIn c [tA, tA], let r = anyTExpr (predToType p) = - --trace ("NumEq " ++ ppReadable (r, p)) $ - [ mkInst r ([] :=> p) ] + --trace ("NumEq " ++ ppReadable (r, p)) $ + [ mkInst r ([] :=> p) ] where (tA, tB) = ordPair (t1, t2) genNumEqInsts _ _ _ _ = [] @@ -1039,12 +1039,12 @@ tyiInteger = TypeInfo (Just idInteger) KStar [] tiInteger -- all preTypes should have identifiers (i.e. be non-numeric) because the usage in MakeSymTab.hs depends on this preTypes :: [TypeInfo] preTypes = [ - tyiArrow, + tyiArrow, {- - tyiBit, - tyiInteger, - TypeInfo idString KStar [] TIabstract, - TypeInfo idSizeOf (Kfun KStar KNum) [] TIabstract, + tyiBit, + tyiInteger, + TypeInfo idString KStar [] TIabstract, + TypeInfo idSizeOf (Kfun KStar KNum) [] TIabstract, -} TypeInfo (Just idAdd) (Kfun KNum (Kfun KNum (Kfun KNum KStar))) [v1, v2, v3] (TIstruct SClass []), TypeInfo (Just idMax) (Kfun KNum (Kfun KNum (Kfun KNum KStar))) [v1, v2, v3] (TIstruct SClass []), @@ -1053,7 +1053,7 @@ preTypes = [ TypeInfo (Just idDiv) (Kfun KNum (Kfun KNum (Kfun KNum KStar))) [v1, v2, v3] (TIstruct SClass []), TypeInfo (Just idLog) (Kfun KNum (Kfun KNum KStar)) [v1, v2] (TIstruct SClass []), TypeInfo (Just idNumEq) (Kfun KNum (Kfun KNum KStar)) [v1, v2] (TIstruct SClass []) - ] + ] preClasses :: SymTab -> [Class] preClasses symT = [clsNumEq symT, @@ -1071,7 +1071,7 @@ isPreClass cl = preValues :: [(Id, VarInfo)] preValues = [ --- (idValueOf, VarInfo VarPrim (idValueOf :>: Forall [KNum] ([] :=> (TGen noPosition 0 `fn` tInteger))) Nothing) - ] +-- (idValueOf, VarInfo VarPrim (idValueOf :>: Forall [KNum] ([] :=> (TGen noPosition 0 `fn` tInteger))) Nothing) + ] -- ------------------------- diff --git a/src/comp/Subst.hs b/src/comp/Subst.hs index a653309a4..53466bda8 100644 --- a/src/comp/Subst.hs +++ b/src/comp/Subst.hs @@ -1,15 +1,15 @@ {-# LANGUAGE CPP #-} module Subst( Subst, - nullSubst, isNullSubst, (+->), mkSubst, - Types(..), (@@), merge, mergeWith, mergeListWith, + nullSubst, isNullSubst, (+->), mkSubst, + Types(..), (@@), merge, mergeWith, mergeListWith, mergeAgreements, - trimSubst, trimSubstByVars, - {- removeFromSubst, -} + trimSubst, trimSubstByVars, + {- removeFromSubst, -} apSubstToSubst, - getSubstDomain, getSubstRange, sizeSubst, + getSubstDomain, getSubstRange, sizeSubst, chkSubstOrder - ) where + ) where import PPrint import CType @@ -35,7 +35,7 @@ type Set_vars = Map.Map TyVar Set_TyVar type S_map = Map.Map TyVar Type data Subst = S S_map Set_vars - deriving (Show, Eq) + deriving (Show, Eq) instance PPrint Subst where pPrint d p (S s v) = pparen (p>0) $ text "Subst" <+> pPrint d 0 @@ -166,11 +166,11 @@ mergeListWith :: (Subst -> Subst -> Maybe Subst) -> [Maybe Subst] -> Maybe Subst mergeListWith merge_func = foldr cons (Just nullSubst) where cons :: Maybe Subst -> Maybe Subst -> Maybe Subst cons (Just s) (Just s') = - -- rtrace ("mergeListWith: Just, Just: " ++ ppReadable (merge s s', s, s')) $ - merge_func s s' + -- rtrace ("mergeListWith: Just, Just: " ++ ppReadable (merge s s', s, s')) $ + merge_func s s' cons a b = - -- rtrace ("mergeListWith: Nothing: " ++ ppReadable (a,b)) $ - Nothing + -- rtrace ("mergeListWith: Nothing: " ++ ppReadable (a,b)) $ + Nothing -- the merge func is always unification -- it is a parameter because Unify imports subst @@ -206,7 +206,7 @@ class Types t where instance Types Type where apSub (S seo _) v@(TVar u) = - case slookup u seo of + case slookup u seo of Just t -> case t of (TGen _ _) -> t -- (kind (TGen _ _)) errors out -- don't check kind @@ -275,7 +275,7 @@ trimSubstBy filterFunc (S old_map old_back) = S new_map new_back -- in numeric order. trimSubst :: TyVar -> Subst -> Subst trimSubst v (S old_map old_back) = S new_map new_back - where (new_map, _) = Map.split v old_map + where (new_map, _) = Map.split v old_map new_back = fixupBack new_map old_back -- This removes substitution entries whose LHS or RHS contains the variables. diff --git a/src/comp/SymTab.hs b/src/comp/SymTab.hs index 98af1e7d2..61ee675d3 100644 --- a/src/comp/SymTab.hs +++ b/src/comp/SymTab.hs @@ -1,17 +1,17 @@ {-# LANGUAGE CPP #-} module SymTab( - SymTab(..), VarInfo(..), ConInfo(..), TypeInfo(..), - FieldInfo(..), VarKind(..), - getAllTypes, - emptySymtab, - addVars, addTypes, addCons, addFields, addClasses, - addVarsUQ, addTypesUQ, addClassesUQ, mkDefaultQuals, - addTypesQ, addFieldsQ, - findVar, findCon, findConVis, findType, - findField, findFieldVis, findSClass, mustFindClass, - findFieldInfo, - getMethodArgNames, getIfcFieldNames, getIfcFlatMethodNames - ) where + SymTab(..), VarInfo(..), ConInfo(..), TypeInfo(..), + FieldInfo(..), VarKind(..), + getAllTypes, + emptySymtab, + addVars, addTypes, addCons, addFields, addClasses, + addVarsUQ, addTypesUQ, addClassesUQ, mkDefaultQuals, + addTypesQ, addFieldsQ, + findVar, findCon, findConVis, findType, + findField, findFieldVis, findSClass, mustFindClass, + findFieldInfo, + getMethodArgNames, getIfcFieldNames, getIfcFlatMethodNames + ) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804) import Prelude hiding ((<>)) @@ -40,35 +40,35 @@ type IdMap a = M.Map Id a data VarInfo -- the Maybe is whether the identifier has been deprecated, and why - = VarInfo !VarKind !Assump !(Maybe String) - deriving (Show) + = VarInfo !VarKind !Assump !(Maybe String) + deriving (Show) instance PPrint VarInfo where pPrint d p (VarInfo k a m) = - pparen (p>0) $ - text "VarInfo" <+> pPrint d 1 k <+> pPrint d 1 a <+> - pPrint d 1 (isJust m) + pparen (p>0) $ + text "VarInfo" <+> pPrint d 1 k <+> pPrint d 1 a <+> + pPrint d 1 (isJust m) data VarKind - = VarPrim - | VarDefn - | VarMeth - -- the maybe [String] is portlist for Verilog foreign funcs as modules - -- (as "noinline" compiles to) - | VarForg String (Maybe ([String], [String])) - deriving (Show) + = VarPrim + | VarDefn + | VarMeth + -- the maybe [String] is portlist for Verilog foreign funcs as modules + -- (as "noinline" compiles to) + | VarForg String (Maybe ([String], [String])) + deriving (Show) instance PPrint VarKind where pPrint _ _ k = text (show k) data ConInfo - = ConInfo { ci_id :: Id, + = ConInfo { ci_id :: Id, ci_visible :: Bool, ci_assump :: Assump, -- type ci_conNum :: Integer, -- constructor number ci_totalNum :: Integer -- total number of constructors - } - deriving (Show, Eq) + } + deriving (Show, Eq) -- test whether two ConInfo are identical except for the visibility conInfoEq :: ConInfo -> ConInfo -> Bool @@ -93,18 +93,18 @@ instance PPrint ConInfo where pVis True = text " (visible)" data TypeInfo - = TypeInfo { + = TypeInfo { ti_qual_id :: (Maybe Id), -- Nothing for numeric types - ti_kind :: Kind, - ti_type_vars :: [Id], - ti_sort :: TISort - } deriving (Show) + ti_kind :: Kind, + ti_type_vars :: [Id], + ti_sort :: TISort + } deriving (Show) instance PPrint TypeInfo where pPrint d p (TypeInfo _ k _ ti) = pparen (p>0) $ text "TypeInfo" <+> pPrint d 10 k <+> pPrint d 1 ti data FieldInfo - = FieldInfo { + = FieldInfo { fi_id :: Id , -- Id is the identifier of a type which has this field fi_visible :: Bool, -- Bool is if the fields of that type are visible to user fi_arity :: Int, -- Int is the arity of the type @@ -113,7 +113,7 @@ data FieldInfo fi_default :: [CClause], fi_orig_type :: Maybe CType -- original field type for wrapped fields } - deriving (Show) + deriving (Show) -- test whether two FieldInfo are identical except for the visibility fieldInfoEq :: FieldInfo -> FieldInfo -> Bool @@ -156,13 +156,13 @@ instance Hyper FieldInfo where -- The symbol table is composed of several other tables data SymTab = - S (IdMap VarInfo) (IdMap [ConInfo]) (IdMap TypeInfo) (IdMap [FieldInfo]) (IdMap Class) + S (IdMap VarInfo) (IdMap [ConInfo]) (IdMap TypeInfo) (IdMap [FieldInfo]) (IdMap Class) -- The TypeInfo is indexed by type and returns the info for that type -- (indexed generally by both qualified and unqualified name) -- The FieldInfo is indexed by field id (e.g., "_write" returns the fields of Reg) -- or by superclass (e.g. Literal returns the superclasses of "Arith") -instance Eq SymTab where -- just because we need one for forcing evaluation +instance Eq SymTab where -- just because we need one for forcing evaluation _ == _ = False showsPrecList wid (thing@[_]) z = @@ -176,22 +176,22 @@ sps wid islist = instance Show SymTab where showsPrec _ (S v c t f cl) = - showString "Vars: " . showsPrecList 0 (M.toList v) . showString "\n" . - showString "Cons: " . showsPrecList 0 (M.toList c) . showString "\n" . - showString "Types: " . showsPrecList 0 (M.toList t) . showString "\n" . - showString "Fields: " . showsPrecList 0 (M.toList f) . showString "\n" . - showString "Classes: " . showsPrecList 0 (M.toList cl) . showString "\n" + showString "Vars: " . showsPrecList 0 (M.toList v) . showString "\n" . + showString "Cons: " . showsPrecList 0 (M.toList c) . showString "\n" . + showString "Types: " . showsPrecList 0 (M.toList t) . showString "\n" . + showString "Fields: " . showsPrecList 0 (M.toList f) . showString "\n" . + showString "Classes: " . showsPrecList 0 (M.toList cl) . showString "\n" instance PPrint SymTab where pPrint d _ (S v c t f cl) = - (text "Vars:" <+> pPrint d 0 (M.toList v) ) $+$ - (text "Cons:" <+> pPrint d 0 (M.toList c) ) $+$ - (text "Types:" <+> pPrint d 0 (M.toList t) ) $+$ - (text "Fields:" <+> pPrint d 0 (M.toList f) ) $+$ - (text "Classes:" <+> pPrint d 0 (M.toList cl) ) + (text "Vars:" <+> pPrint d 0 (M.toList v) ) $+$ + (text "Cons:" <+> pPrint d 0 (M.toList c) ) $+$ + (text "Types:" <+> pPrint d 0 (M.toList t) ) $+$ + (text "Fields:" <+> pPrint d 0 (M.toList f) ) $+$ + (text "Classes:" <+> pPrint d 0 (M.toList cl) ) instance Hyper SymTab where - hyper x y = y -- XXX + hyper x y = y -- XXX emptySymtab :: SymTab emptySymtab = S M.empty M.empty M.empty M.empty M.empty @@ -261,7 +261,7 @@ addClasses mkQuals (S v c t f cl) cls = addQuals :: (Id -> [Id]) -> [(Id, a)] -> [(Id, a)] addQuals mkQuals ixs = concatMap addQuals' ixs where addQuals' pair@(name, value) = - [ (i, value) | i <- mkQuals name ] + [ (i, value) | i <- mkQuals name ] -- --------------- @@ -298,7 +298,7 @@ mkSameQual name = [name] findVar :: SymTab -> Id -> Maybe VarInfo findVar (S v _ _ _ _) i = --trace (ppReadable (show i, show (map fst (M.toList v)))) $ - M.lookup i v + M.lookup i v findCon :: SymTab -> Id -> Maybe [ConInfo] findCon (S _ c _ _ _) i = M.lookup i c @@ -351,8 +351,8 @@ findFieldInfo symtable ifcName methodName = getMethodArgNames :: SymTab -> Id -> Id -> [Id] getMethodArgNames symtable ifcId methId = case (findFieldInfo symtable ifcId methId) of - Nothing -> [] - Just finfo -> filterIArgNames (fi_pragmas finfo) + Nothing -> [] + Just finfo -> filterIArgNames (fi_pragmas finfo) getIfcFieldNames :: SymTab -> Id -> [Id] getIfcFieldNames symbolTable ifcId = fields diff --git a/src/comp/Synthesize.hs b/src/comp/Synthesize.hs index f4c675802..f37a32fc7 100644 --- a/src/comp/Synthesize.hs +++ b/src/comp/Synthesize.hs @@ -57,13 +57,13 @@ aImprove p@(ASPackage { aspkg_values = ds }) = repl (APrim aid t p es) = APrim aid t p (map repl es) repl (ANoInlineFunCall t i f es) = ANoInlineFunCall t i f (map repl es) repl (AFunCall t i f isC es) = AFunCall t i f isC (map repl es) --- repl e = internalError ("aImprove.replE " ++ ppReadable e) +-- repl e = internalError ("aImprove.replE " ++ ppReadable e) repl e = e -- aOptBoolExpr is overkill... ds' = [ ADef i t (aOptBoolExpr (repl e)) p | ADef i t e p <- ds ] p'' = aSRemoveUnused False (p { aspkg_values = ds' }) ds'' = aspkg_values p'' - in if length ds == length ds'' && ds == ds'' then -- length check is a fast check for inequality + in if length ds == length ds'' && ds == ds'' then -- length check is a fast check for inequality (if doTrace then trace "aImprove done" else id) p else @@ -255,7 +255,7 @@ synDef (i, e, props) = do es -> do let is = map (wireId i) [0..length es-1] zipWithM_ (\i e -> addDefU i e props ) is es --- trace (ppReadable (is, es)) $ return () +-- trace (ppReadable (is, es)) $ return () addDefU i (APrim i (aType e) PrimConcat (map (ASDef aTBool) (reverse is))) props synExp :: AExpr -> S [AExpr] @@ -359,7 +359,7 @@ synPrim aid t p es | isBoolOp p = return [APrim aid t p es] synPrim aid _ p es | isBoolVecOp p = do ess <- mapM synExpS es return (map ((primToFun p) aid) (transpose ess)) --- return (map (APrim _ aTBool (vecToBool p)) (transpose ess)) +-- return (map (APrim _ aTBool (vecToBool p)) (transpose ess)) synPrim aid _ PrimEQ [x, y] = do xs <- synExpS x ys <- synExpS y diff --git a/src/comp/TCMisc.hs b/src/comp/TCMisc.hs index 27509b03b..9109617c8 100644 --- a/src/comp/TCMisc.hs +++ b/src/comp/TCMisc.hs @@ -298,7 +298,7 @@ sat :: DVS -> [EPred] -> VPred -> TI ([VPred], [Bind], Subst) sat dvs ps (VPred w pr@(IsIn bts [t1, TAp szof t2])) | name bts == idBits && szof == tSizeOf = do traces ("SizeOf " ++ ppReadable pr) $ return () - tunify t1 t1 t2 -- XXX t1 + tunify t1 t1 t2 -- XXX t1 v <- newTVar KNum szof sat dvs ps (VPred w (IsIn bts [t1, v])) -} @@ -545,8 +545,8 @@ reducePred eps dvs (VPred w pp@(PredWithPositions pr@(IsIn c ts) pos)) = do (r, _) <- solvePred s ps pr' return r case res of - Nothing -> do - --traceM(" failed.") + Nothing -> do + --traceM(" failed.") return Nothing Just _ -> do -- XXX for now, no new info is learned, just sat @@ -818,7 +818,7 @@ normT t = do (ps', _) <- satisfy [] ps --unless (null ps') (internalError ("expandSynN " ++ ppReadable (t, ps'))) if not (null ps') then - return t' -- XXX could expand some + return t' -- XXX could expand some else do s <- getSubst let t''' = expandSyn (apSub s t'') diff --git a/src/comp/TCheck.hs b/src/comp/TCheck.hs index 9d00182a4..07b201c8c 100644 --- a/src/comp/TCheck.hs +++ b/src/comp/TCheck.hs @@ -766,12 +766,12 @@ tiExpr as td exp@(CmoduleVerilog name ui clks rsts args fields sch ps) = do qsses <- mapM tiArg args -- let (pses, tys) = unzip paramResults -- (pss, es') = unzip pses - let (qss, ts, ses') = unzip3 qsses - let methnames = [n | (Method { vf_name = n }) <- fields] - let clocknames = [c | (Clock c) <- fields] - let resetnames = [r | (Reset r) <- fields] - let inoutnames = [n | (Inout { vf_name = n }) <- fields] - let self_sb_methods = + let (qss, ts, ses') = unzip3 qsses + let methnames = [n | (Method { vf_name = n }) <- fields] + let clocknames = [c | (Clock c) <- fields] + let resetnames = [r | (Reset r) <- fields] + let inoutnames = [n | (Inout { vf_name = n }) <- fields] + let self_sb_methods = let mci = methodConflictInfo sch in [ m | (m,m') <- sSB mci, m == m' ] chkSchedInfo methnames sch @@ -1813,8 +1813,8 @@ recStmts ss = do ptup = pMkTuple pos (map CPVar ids) lame = CLam tid (Cletrec [CLMatch ptup (CVar tid)] (Cdo False ss')) rss = [CSBind (CPVar nid) (cVApply idMfix [lame]), CSExpr (cVApply (idReturn pos) [CSelect (CVar nid) idPrimFst])] --- trace (ppReadable (S.toList vs, ls)) $ return () --- trace (ppReadable rss) $ return () +-- trace (ppReadable (S.toList vs, ls)) $ return () +-- trace (ppReadable rss) $ return () return rss -} @@ -1867,7 +1867,7 @@ tiStmts' chke mon mt as td (CSBindT p name pprops qt e : ss) = do nid <- newVar (getPosition p) "tiStmts1" tiStmts' chke mon mt as td (CSBindT (CPVar nid) name pprops qt e : CSletrec [CLMatch p (CVar nid)] : ss) tiStmts' chke mon mt as td (CSBind (CPVar i) maybeName pprops e : ss) = do - ty <- newTVar "tiStmts' CSBind" KStar e -- XXX + ty <- newTVar "tiStmts' CSBind" KStar e -- XXX tiStmtBind chke mon mt as td i maybeName pprops e ss ty tiStmts' chke mon mt as td (CSBind p name pprops e : ss) = do nid <- newVar (getPosition p) "tiStmts2" @@ -2293,14 +2293,14 @@ tiExpl'' as0 i sc alts me oqtvts = do return r -- --- as the (local) environment --- i name of definition --- sc type signature of definition --- alts clauses of definition +-- as the (local) environment +-- i name of definition +-- sc type signature of definition +-- alts clauses of definition -- me the implicit condition patterns of an interface definition -- (an empty list for non-interfaces) --- oqt instanciated scheme --- vts variables used to instantiate sc to oqt +-- oqt instanciated scheme +-- vts variables used to instantiate sc to oqt tiExpl''' :: [Assump] -> Id -> Scheme -> [CClause] -> [CQual] -> (Qual Type, [Type]) -> TI ([VPred], CDefl) tiExpl''' as0 i sc alts me (oqt@(oqs :=> ot), vts) = do @@ -2356,7 +2356,7 @@ tiExpl''' as0 i sc alts me (oqt@(oqs :=> ot), vts) = do satTraceM ("tiExpl " ++ ppReadable i ++ " ps'(satisfy): " ++ ppReadable ps') - s <- getSubst -- get full subst + s <- getSubst -- get full subst let -- Compute the fixed variables @@ -2375,12 +2375,12 @@ tiExpl''' as0 i sc alts me (oqt@(oqs :=> ot), vts) = do -- defer them to the enclosing bindings) -- rs1 = preds which contain tyvars general/bound at this level -- "d" for deffered and "r" for retained - (ds2, rs1) = splitF fvs ps' -- non-local, local constraints + (ds2, rs1) = splitF fvs ps' -- non-local, local constraints -- All the tyvars ("avs") = the vars of qt' ("lvs") and -- the fixed vars ("fvs") - lvs = tv qt' -- local tyvars - avs = lvs `union` fvs -- all tyvars + lvs = tv qt' -- local tyvars + avs = lvs `union` fvs -- all tyvars ---- @@ -2397,7 +2397,7 @@ tiExpl''' as0 i sc alts me (oqt@(oqs :=> ot), vts) = do satTraceM ("tiExpl " ++ ppReadable i ++ " ps'(satisfyFV) " ++ ppReadable ps') - s <- getSubst -- get full subst + s <- getSubst -- get full subst let -- Compute the fixed variables @@ -2415,12 +2415,12 @@ tiExpl''' as0 i sc alts me (oqt@(oqs :=> ot), vts) = do -- defer them to the enclosing bindings) -- rs2 = preds which contain tyvars general/bound at this level -- "d" for deffered and "r" for retained - (ds3, rs2) = splitF fvs ps' -- non-local, local constraints + (ds3, rs2) = splitF fvs ps' -- non-local, local constraints -- All the tyvars ("avs") = the vars of qt' ("lvs") and -- the fixed vars ("fvs") - lvs = tv qt' -- local tyvars - avs = lvs `union` fvs -- all tyvars + lvs = tv qt' -- local tyvars + avs = lvs `union` fvs -- all tyvars let -- Bindings for solved constraints have been generated twice, @@ -2465,7 +2465,7 @@ tiExpl''' as0 i sc alts me (oqt@(oqs :=> ot), vts) = do -- list "ds". These contexts were not solved, which means a -- context reduction failure (no instance was found for those -- types). Report an error if this list "uds" is not empty. - uds = filter (null . tv) ds -- no tyvars and not solvable + uds = filter (null . tv) ds -- no tyvars and not solvable -- Ambiguous predicates -- An expression is ill-formed if its most general type ps => t @@ -2476,7 +2476,7 @@ tiExpl''' as0 i sc alts me (oqt@(oqs :=> ot), vts) = do (rs_amb, rs_unamb) = partition (any (`elem` amb_vars) . tv) rs -- Apply the substition to the code fragments - let alts'' = apSub s alts' -- new alternatives + let alts'' = apSub s alts' -- new alternatives abs = apSub s bs1 -- new dict bindings me'' = apSub s me' -- update guards @@ -2800,7 +2800,7 @@ tiImpls recursive as ibs = do -- (we will defer them to the enclosing bindings) -- rs = preds which contains tyvars general/bound at this level -- "d" for defered and "r" for retained - (ds,rs) = splitF fs ps'' -- non-local, local constraints + (ds,rs) = splitF fs ps'' -- non-local, local constraints -- Begin: find unresolvable variables @@ -3008,7 +3008,7 @@ tiLetseqDef type_env arm@(CLMatch pattern expression) = -- defs': definitions, possibly rewritten tiDefls :: [Assump] -> [CDefl] -> TI ([VPred], [Assump], [CDefl]) tiDefls type_env defs = do - dss <- mapM expCLMatch defs -- convert pattern-matches to regular defs + dss <- mapM expCLMatch defs -- convert pattern-matches to regular defs let ds = concat dss let -- impl: untyped (implicitly typed) definitions impl = doSCC ds @@ -3042,7 +3042,7 @@ chkERec _ = False -- extract untyped let-defs and sort them into interdependent groups doSCC :: [CDefl] -> [[Impl]] doSCC ds = - let g = [ (i, S.toList (snd (getFVDl d) `S.intersection` is)) | d@(CLValue i _ _) <- ds ] -- XXX CLMatch + let g = [ (i, S.toList (snd (getFVDl d) `S.intersection` is)) | d@(CLValue i _ _) <- ds ] -- XXX CLMatch is = S.fromList (map fst g) iss = scc g get i = (i, (headOrErr ("TCheck.doSCC: missing CLValue " ++ diff --git a/src/comp/TopUtils.hs b/src/comp/TopUtils.hs index ac4d2b154..12c734159 100644 --- a/src/comp/TopUtils.hs +++ b/src/comp/TopUtils.hs @@ -76,21 +76,21 @@ dump :: (PPrint a, Hyper a) => ErrorHandle -> Flags -> TimeInfo -> DumpFlag -> DumpNames -> a -> IO TimeInfo dump errh flags t d names a = - hyper a $ -- force evaluation + hyper a $ -- force evaluation dumpStr errh flags t d names (ppReadable a) ddump :: (PPrint a, Hyper a) => ErrorHandle -> Flags -> TimeInfo -> DumpFlag -> DumpNames -> a -> IO TimeInfo ddump errh flags t d names a = - hyper a $ -- force evaluation + hyper a $ -- force evaluation dumpStr errh flags t d names (ppDebug a) vdump :: (PVPrint a, Hyper a) => ErrorHandle -> Flags -> TimeInfo -> DumpFlag -> DumpNames -> a -> IO TimeInfo vdump errh flags t d names a = - hyper a $ -- force evaluation + hyper a $ -- force evaluation dumpStr errh flags t d names (pvpReadable a) @@ -98,7 +98,7 @@ sdump :: (Show a, Hyper a) => ErrorHandle -> Flags -> TimeInfo -> DumpFlag -> DumpNames -> a -> IO TimeInfo sdump errh flags t d names a = - hyper a $ -- force evaluation + hyper a $ -- force evaluation dumpStr errh flags t d names (show a) diff --git a/src/comp/Type.hs b/src/comp/Type.hs index 14ca116c9..d8381fc21 100644 --- a/src/comp/Type.hs +++ b/src/comp/Type.hs @@ -134,7 +134,7 @@ instance HasKind Type where kind (TVar u) = kind u kind tt@(TAp t _) = case kind t of Kfun _ k -> k - k -> + k -> internalError ("kind: " ++ ppReadable k ++ (show tt) ++ "\n") kind (TGen _ _) = internalError "Type.HasKind(Type).kind: TGen" kind (TDefMonad _) = internalError "Type.HasKind(Type).kind: TDefMonad" diff --git a/src/comp/TypeAnalysis.hs b/src/comp/TypeAnalysis.hs index 9d9e328d3..d9e8c89e4 100644 --- a/src/comp/TypeAnalysis.hs +++ b/src/comp/TypeAnalysis.hs @@ -1,13 +1,13 @@ module TypeAnalysis ( - TypeAnalysis(..), - analyzeType, - analyzeType', + TypeAnalysis(..), + analyzeType, + analyzeType', showType, getWidth, -- to be used with showType kVector, vsVector, kList, vsList - ) where + ) where import Data.List(genericDrop, intersperse, (\\), nub, sortBy) import Data.Char(isUpper) @@ -66,28 +66,28 @@ getWidth _ = Nothing showType :: Bool -> Id -> Kind -> [Id] -> String showType showKinds t k user_vs = let - arg_ks = getArgKinds k - arg_names = - let user_arg_names = map getIdString user_vs - in user_arg_names ++ (inexhaustable_var_names \\ user_arg_names) + arg_ks = getArgKinds k + arg_names = + let user_arg_names = map getIdString user_vs + in user_arg_names ++ (inexhaustable_var_names \\ user_arg_names) showArg :: Bool -> Kind -> String -> String - showArg True arg_k name = - (if arg_k == KNum then "numeric " else "") ++ "type " ++ name - showArg False arg_k name = name - showArgs = - "#" ++ inParens - (commaSep - (zipWith (showArg showKinds) arg_ks arg_names)) + showArg True arg_k name = + (if arg_k == KNum then "numeric " else "") ++ "type " ++ name + showArg False arg_k name = name + showArgs = + "#" ++ inParens + (commaSep + (zipWith (showArg showKinds) arg_ks arg_names)) in - pvStr t ++ - (if null arg_ks then [] else showArgs) + pvStr t ++ + (if null arg_ks then [] else showArgs) -- make [a,...,z,aa,ab,...,zy,zz,aaa,...] inexhaustable_var_names = names where names = [ x:r | r <- ([]:names), - x <- ['a'..'z'] ] + x <- ['a'..'z'] ] -- Given a list of type arguments already supplied @@ -116,16 +116,16 @@ analyzeType' flags symtab unqual_ty primpair_is_interface = doRight analyze (kin kindCheck :: CType -> Either [EMsg] CType kindCheck t = - -- "convCType" will error on too-many-args, - -- but we have to detect too-few-args - case (convCType symtab t) of - Left err -> Left [err] - Right t' -> - case (kind t') of - Kfun _ _ -> - let unapTypeName = ppString $ fst (splitTAp t) - in Left [(getPosition t, ETypeTooFewArgs unapTypeName)] - k -> Right t' + -- "convCType" will error on too-many-args, + -- but we have to detect too-few-args + case (convCType symtab t) of + Left err -> Left [err] + Right t' -> + case (kind t') of + Kfun _ _ -> + let unapTypeName = ppString $ fst (splitTAp t) + in Left [(getPosition t, ETypeTooFewArgs unapTypeName)] + k -> Right t' analyze :: CType -> Either [EMsg] TypeAnalysis analyze t = @@ -140,7 +140,7 @@ analyzeType' flags symtab unqual_ty primpair_is_interface = doRight analyze (kin if (null as) then Right Numeric else -- Right OverApplied - -- (this can't happen, because kindCheck catches it) + -- (this can't happen, because kindCheck catches it) Left [(pos, ENumKindArg)] (TCon (TyCon i _ _), as) -> -- the other fields are bogus before typechecking @@ -161,24 +161,24 @@ analyzeType' flags symtab unqual_ty primpair_is_interface = doRight analyze (kin in analyzeNonNumTCon t qi k vs as isConcrete tisort analyzeNonNumTCon :: CType -> Id -> - Kind -> [Id] -> [CType] -> Bool -> TISort -> - Either [EMsg] TypeAnalysis + Kind -> [Id] -> [CType] -> Bool -> TISort -> + Either [EMsg] TypeAnalysis -- interface analyzeNonNumTCon t qi k vs as isC (TIstruct (SInterface pragmas) fields) = if (qi == idPrimPair && (not primpair_is_interface)) then Right $ Primary qi k vs isC (w t) else - let fieldInfos = map (getFieldInfo symtab qi) fields - mkTuple (FieldInfo _ _ _ (fid :>: (Forall ks qt)) fpragmas _ morigtype) = - let as' = addGenVars as ks + let fieldInfos = map (getFieldInfo symtab qi) fields + mkTuple (FieldInfo _ _ _ (fid :>: (Forall ks qt)) fpragmas _ morigtype) = + let as' = addGenVars as ks fqtype@(ps :=> ft) = - apType (expandSynN flags symtab . rmStructArg) (inst as' qt) - is_subifc = isSubInterface ft && - -- subinterfaces have no provisos - -- XXX this check might be unnecessary - null ps - in (is_subifc, fid, fqtype, fpragmas) - in Right $ Interface qi k vs isC (map mkTuple fieldInfos) pragmas + apType (expandSynN flags symtab . rmStructArg) (inst as' qt) + is_subifc = isSubInterface ft && + -- subinterfaces have no provisos + -- XXX this check might be unnecessary + null ps + in (is_subifc, fid, fqtype, fpragmas) + in Right $ Interface qi k vs isC (map mkTuple fieldInfos) pragmas -- struct analyzeNonNumTCon t qi k vs as isC (TIstruct SStruct fields) = if (qi == idActionValue) @@ -186,13 +186,13 @@ analyzeType' flags symtab unqual_ty primpair_is_interface = doRight analyze (kin else if (qi == idPrimUnit) then Right $ Primary qi k vs isC (w t) else - let fieldInfos = map (getFieldInfo symtab qi) fields - mkPair (FieldInfo _ _ _ (i :>: (Forall ks qt)) _ _ _) = + let fieldInfos = map (getFieldInfo symtab qi) fields + mkPair (FieldInfo _ _ _ (i :>: (Forall ks qt)) _ _ _) = let as' = addGenVars as ks qt' = apType (expandSynN flags symtab . rmStructArg) (inst as' qt) t = qualToType qt' in (i, qt', w t) - in Right $ Struct qi k vs isC (map mkPair fieldInfos) (w t) + in Right $ Struct qi k vs isC (map mkPair fieldInfos) (w t) -- type alias (n is the number of type parameters) analyzeNonNumTCon t qi k vs as isC (TItype n t') = if (qi == idAction) @@ -227,53 +227,53 @@ analyzeType' flags symtab unqual_ty primpair_is_interface = doRight analyze (kin then Right $ Primary qi k vs isC (w t) else if (qi == idList) then - case (as) of - [el] -> Right $ List isC el - _ -> internalError ("analyzeType': unexpected List params: " ++ - ppReadable as) + case (as) of + [el] -> Right $ List isC el + _ -> internalError ("analyzeType': unexpected List params: " ++ + ppReadable as) else if (qi == idVector) then - case (as) of - [len,el] -> Right $ Vector isC len el (w t) - _ -> internalError ("analyzeType': unexpected Vector params: " ++ - ppReadable as) + case (as) of + [len,el] -> Right $ Vector isC len el (w t) + _ -> internalError ("analyzeType': unexpected Vector params: " ++ + ppReadable as) else - let conInfos = map (getConInfo symtab qi) constructors - getConType (ConInfo _ _ (i :>: (Forall ks (ps :=> t))) _ _) = t - getConName (ConInfo _ _ (i :>: _) _ _) = i - hasVoidArg t = - case (fst (getArrows t)) of - [TCon (TyCon i _ _)] | i == idPrimUnit -> True - _ -> False - -- an enum has fields with no data and the type has no params - is_enum = (all hasVoidArg (map getConType conInfos)) && - (k == KStar) - in - -- figure out if it's enum or tagged union - if (is_enum) - then Right $ Enum qi (map getConName conInfos) (w t) - else let -- we assume that 'ps' is empty (should we check?) - mkTuple ci = + let conInfos = map (getConInfo symtab qi) constructors + getConType (ConInfo _ _ (i :>: (Forall ks (ps :=> t))) _ _) = t + getConName (ConInfo _ _ (i :>: _) _ _) = i + hasVoidArg t = + case (fst (getArrows t)) of + [TCon (TyCon i _ _)] | i == idPrimUnit -> True + _ -> False + -- an enum has fields with no data and the type has no params + is_enum = (all hasVoidArg (map getConType conInfos)) && + (k == KStar) + in + -- figure out if it's enum or tagged union + if (is_enum) + then Right $ Enum qi (map getConName conInfos) (w t) + else let -- we assume that 'ps' is empty (should we check?) + mkTuple ci = let (tagT, unionT) = getUnionTypes (getConType ci) new_as = reorderUnionTypeArgs unionT as tf = expandSynN flags symtab $ inst new_as tagT in (getConName ci, tf, w tf) - in Right $ - TaggedUnion qi k vs isC (map mkTuple conInfos) (w t) + in Right $ + TaggedUnion qi k vs isC (map mkTuple conInfos) (w t) -- abstract analyzeNonNumTCon t qi k vs as isC (TIabstract) = - -- XXX if (k == KNum), should we return Numeric? - -- XXX such as for TAdd etc? Should TAdd#(1,2) return 3? + -- XXX if (k == KNum), should we return Numeric? + -- XXX such as for TAdd etc? Should TAdd#(1,2) return 3? Right $ Primary qi k vs isC (w t) -- anonymous struct in Classic tagged union analyzeNonNumTCon t qi k vs as isC (TIstruct (SDataCon _ _) fields) = let fieldInfos = map (getFieldInfo symtab qi) fields - mkPair (FieldInfo _ _ _ (i :>: (Forall ks qt)) _ _ _) = + mkPair (FieldInfo _ _ _ (i :>: (Forall ks qt)) _ _ _) = let as' = addGenVars as ks qt' = apType (expandSynN flags symtab . rmStructArg) (inst as' qt) t = qualToType qt' in (i, qt', w t) - in Right $ Struct qi k vs isC (map mkPair fieldInfos) (w t) + in Right $ Struct qi k vs isC (map mkPair fieldInfos) (w t) -- type class analyzeNonNumTCon t qi k vs as isC (TIstruct SClass fields) = let @@ -312,12 +312,12 @@ getConInfo symtab ty con = Nothing -> internalError ("findConInfo: not found: " ++ ppReadable con) Just [ci] -> ci Just cis -> - case [ ci | ci@(ConInfo i _ _ _ _) <- cis, qualEq ty i ] of - [ci] -> ci - [] -> internalError ("findConInfo: not found: " ++ - ppReadable con) - _ -> internalError ("findConInfo: ambiguous: " ++ - ppReadable (con,ty)) + case [ ci | ci@(ConInfo i _ _ _ _) <- cis, qualEq ty i ] of + [ci] -> ci + [] -> internalError ("findConInfo: not found: " ++ + ppReadable con) + _ -> internalError ("findConInfo: ambiguous: " ++ + ppReadable (con,ty)) -- this expects not to fail to find the field info @@ -325,7 +325,7 @@ getFieldInfo :: SymTab -> Id -> Id -> FieldInfo getFieldInfo symtab ty field = case (findFieldInfo symtab ty field) of Nothing -> internalError ("findFieldInfo: not found: " ++ - ppReadable field) + ppReadable field) Just fi -> fi @@ -334,11 +334,11 @@ getFieldInfo symtab ty field = getBitWidth :: Flags -> SymTab -> CType -> Maybe Integer getBitWidth flags symtab t = case (findSClass symtab (CTypeclass idBits)) of - Nothing -> Nothing -- Prelude hasn't been loaded :) + Nothing -> Nothing -- Prelude hasn't been loaded :) -- Bits is a coherent typeclass - Just c -> case (fst $ TI.runTI flags False symtab (getBitWidthM c)) of - Right r -> r - Left _ -> Nothing + Just c -> case (fst $ TI.runTI flags False symtab (getBitWidthM c)) of + Right r -> r + Left _ -> Nothing where getBitWidthM :: Class -> TI (Maybe Integer) getBitWidthM bitsCls = do @@ -346,27 +346,27 @@ getBitWidth flags symtab t = -- record any vars in the type, -- so that we preserve names as given by the user addBoundTVs (tv t) - -} - -- construct the proviso Bits#(t,szv) for a new var 'szv' + -} + -- construct the proviso Bits#(t,szv) for a new var 'szv' szv <- newTVar "getBitWidth" KNum t let p = IsIn bitsCls [t, szv] - vp <- mkVPredFromPred [] p - -- try to satisfy the proviso - {- Do this, if you want to return a parameterized width - -- (use FV version, to allow TAdd/TMul in the result) - (rs,_) <- satisfyFV [] [] [vp] - -} - (rs,_) <- satisfy [] [vp] - s <- getSubst - let szv' = apSub s szv - -- if it was satisfiable, then apply the substituion to 'szv' - -- and that is the width - return $ - -- if parameterized width is desired, then allow non TyNum - -- here as well (it could be a TyVar of TAp of TMul/TAdd/etc) - if (null rs) && (isTNum szv') - then Just (getTNum szv') - else Nothing + vp <- mkVPredFromPred [] p + -- try to satisfy the proviso + {- Do this, if you want to return a parameterized width + -- (use FV version, to allow TAdd/TMul in the result) + (rs,_) <- satisfyFV [] [] [vp] + -} + (rs,_) <- satisfy [] [vp] + s <- getSubst + let szv' = apSub s szv + -- if it was satisfiable, then apply the substituion to 'szv' + -- and that is the width + return $ + -- if parameterized width is desired, then allow non TyNum + -- here as well (it could be a TyVar of TAp of TMul/TAdd/etc) + if (null rs) && (isTNum szv') + then Just (getTNum szv') + else Nothing -- --------------- @@ -413,8 +413,8 @@ rmStructArg t = internalError ("rmStructArg: no arrow: " ++ ppReadable t) rmUnionRes :: CType -> CType rmUnionRes unionT = case (getArrows unionT) of - ([argT], _) -> argT - _ -> internalError ("rmUnionRes: wrong kind: " ++ ppReadable unionT) + ([argT], _) -> argT + _ -> internalError ("rmUnionRes: wrong kind: " ++ ppReadable unionT) -} -- For tagged unions, get the type of the field, which is the argument; @@ -423,8 +423,8 @@ rmUnionRes unionT = getUnionTypes :: CType -> (CType, CType) getUnionTypes unionT = case (getArrows unionT) of - ([argT], resT) -> (argT, resT) - _ -> internalError ("getUnionTypes: wrong kind: " ++ ppReadable unionT) + ([argT], resT) -> (argT, resT) + _ -> internalError ("getUnionTypes: wrong kind: " ++ ppReadable unionT) -- reorder the type arguments to a polymorphic tagged union type, -- to match the order in which they are generalized in the scheme for diff --git a/src/comp/TypeAnalysisTclUtil.hs b/src/comp/TypeAnalysisTclUtil.hs index ac5f90791..ee759e21f 100644 --- a/src/comp/TypeAnalysisTclUtil.hs +++ b/src/comp/TypeAnalysisTclUtil.hs @@ -39,53 +39,53 @@ typeAnalysisToHTclObj (Numeric) = TStr "Numeric" typeAnalysisToHTclObj (Primary t k vs isC mwidth) = tag "Primary" $ [TStr $ showType True t k vs] ++ - showPolymorphic isC ++ - showWidth mwidth + showPolymorphic isC ++ + showWidth mwidth typeAnalysisToHTclObj (Vector isC len el mwidth) = tag "Vector" $ [TStr $ showType True idVector kVector vsVector] ++ showPolymorphic isC ++ - [tagStr "length" (pvStr len)] ++ - [tagStr "elem" (pvStr el)] ++ - showWidth mwidth + [tagStr "length" (pvStr len)] ++ + [tagStr "elem" (pvStr el)] ++ + showWidth mwidth typeAnalysisToHTclObj (List isC el) = tag "List" $ [TStr $ showType True idList kList vsList] ++ showPolymorphic isC ++ - [tagStr "elem" (pvStr el)] + [tagStr "elem" (pvStr el)] typeAnalysisToHTclObj (Alias t k vs atype) = tag "Alias" $ [TStr $ showType True t k vs, - TStr (pvStr atype)] ++ - showTaggedPosition t + TStr (pvStr atype)] ++ + showTaggedPosition t typeAnalysisToHTclObj (Struct t k vs isC fs mwidth) = tag "Struct" $ [TStr $ showType True t k vs] ++ - showPolymorphic isC ++ - [tagLst "members" (map structFieldToHTclObj fs)] ++ - showWidth mwidth ++ - showTaggedPosition t + showPolymorphic isC ++ + [tagLst "members" (map structFieldToHTclObj fs)] ++ + showWidth mwidth ++ + showTaggedPosition t typeAnalysisToHTclObj (Enum t fs mwidth) = tag "Enum" $ [TStr $ showType True t KStar []] ++ - -- remove the package qualifier from the enum fields - [tagManyStr "members" (map (pvStr . unQualId) fs)] ++ - showWidth mwidth ++ - showTaggedPosition t + -- remove the package qualifier from the enum fields + [tagManyStr "members" (map (pvStr . unQualId) fs)] ++ + showWidth mwidth ++ + showTaggedPosition t typeAnalysisToHTclObj (TaggedUnion t k vs isC fs mwidth) = tag "TaggedUnion" $ - [TStr $ showType True t k vs] ++ - showPolymorphic isC ++ + [TStr $ showType True t k vs] ++ + showPolymorphic isC ++ [tagLst "members" (map unionTagToHTclObj fs)] ++ - showWidth mwidth ++ - showTaggedPosition t + showWidth mwidth ++ + showTaggedPosition t typeAnalysisToHTclObj (Interface t k vs isC fs pragmas) = -- XXX display the pragmas? tag "Interface" $ [TStr $ showType True t k vs] ++ - showPolymorphic isC ++ - [tagLst "members" (map interfaceFieldToHTclObj fs)] ++ - showTaggedPosition t ++ + showPolymorphic isC ++ + [tagLst "members" (map interfaceFieldToHTclObj fs)] ++ + showTaggedPosition t ++ (if (not $ null pragmas) then [tagLst "attributes" (map ifcPragmaToHTclObj pragmas)] else []) typeAnalysisToHTclObj (Typeclass t k vs ps fdeps allow insts fs) = tag "Typeclass" $ @@ -93,9 +93,9 @@ typeAnalysisToHTclObj (Typeclass t k vs ps fdeps allow insts fs) = showSuperclasses ps ++ showDependencies vs fdeps ++ showAllowIncoherent allow ++ - [tagLst "members" (map typeclassFieldToHTclObj fs)] ++ + [tagLst "members" (map typeclassFieldToHTclObj fs)] ++ showInstances insts ++ - showTaggedPosition t + showTaggedPosition t ----------------------------------------------------- @@ -204,59 +204,59 @@ typeAnalysisToDetail (Numeric) = TStr "Numeric Type" typeAnalysisToDetail (Primary t k vs isC mwidth) = tag "Primary" $ [TLst [TStr $ showType True t k vs]] ++ - showPolymorphic isC ++ - showWidth mwidth + showPolymorphic isC ++ + showWidth mwidth typeAnalysisToDetail (Vector isC len el mwidth) = tag "Vector" $ [TLst [TStr $ showType True idVector kVector vsVector]] ++ showPolymorphic isC ++ - [tagStr "length" (pvStr len)] ++ - [tagStr "element type" (pvStr el)] ++ - showWidth mwidth + [tagStr "length" (pvStr len)] ++ + [tagStr "element type" (pvStr el)] ++ + showWidth mwidth typeAnalysisToDetail (List isC el) = tag "List" $ [TLst [TStr $ showType True idList kList vsList]] ++ showPolymorphic isC ++ - [tagStr "element type" (pvStr el)] + [tagStr "element type" (pvStr el)] typeAnalysisToDetail (Alias t k vs atype) = tag "Alias" $ [TLst [TStr $ showType True t k vs], - tagLst "Definition" [TStr (pvStr atype)]] ++ - showTaggedPosition t + tagLst "Definition" [TStr (pvStr atype)]] ++ + showTaggedPosition t typeAnalysisToDetail (Struct t k vs isC fs mwidth) = tag "Struct" $ [TLst [TStr $ showType True t k vs]] ++ - showPolymorphic isC ++ - [tagLst "members" (map structFieldToDetail fs)] ++ - showWidth mwidth ++ - showTaggedPosition t + showPolymorphic isC ++ + [tagLst "members" (map structFieldToDetail fs)] ++ + showWidth mwidth ++ + showTaggedPosition t typeAnalysisToDetail (Enum t fs mwidth) = tag "Enum" $ [TLst [TStr $ showType True t KStar []]] ++ - -- remove the package qualifier from the enum fields - [tagManyStr "members" (map (pvStr . unQualId) fs)] ++ - showWidth mwidth ++ - showTaggedPosition t + -- remove the package qualifier from the enum fields + [tagManyStr "members" (map (pvStr . unQualId) fs)] ++ + showWidth mwidth ++ + showTaggedPosition t typeAnalysisToDetail (TaggedUnion t k vs isC fs mwidth) = tag "TaggedUnion" $ - [TLst [TStr $ showType True t k vs]] ++ - showPolymorphic isC ++ + [TLst [TStr $ showType True t k vs]] ++ + showPolymorphic isC ++ [tagLst "members" (map unionTagToDetail fs)] ++ - showWidth mwidth ++ - showTaggedPosition t + showWidth mwidth ++ + showTaggedPosition t typeAnalysisToDetail (Interface t k vs isC fs pragmas) = -- XXX display the pragmas? tag "Interface" $ [TLst [TStr $ showType True t k vs]] ++ - showPolymorphic isC ++ - [tagLst "members" (map interfaceFieldToDetail fs)] ++ + showPolymorphic isC ++ + [tagLst "members" (map interfaceFieldToDetail fs)] ++ (if (not $ null pragmas) then [tagLst "attributes" (map ifcPragmaToHTclObj pragmas)] else []) ++ - showTaggedPosition t + showTaggedPosition t typeAnalysisToDetail (Typeclass t k vs ps fdeps allow insts fs) = tag "Typeclass" $ @@ -264,10 +264,10 @@ typeAnalysisToDetail (Typeclass t k vs ps fdeps allow insts fs) = showSuperclasses ps ++ showDependencies vs fdeps ++ showAllowIncoherent allow ++ - if (null fs) then [] + if (null fs) then [] else [tagLst "members" (map typeclassFieldToDetail fs)] ++ showInstances insts ++ - showTaggedPosition t + showTaggedPosition t -- --------------- @@ -320,16 +320,16 @@ interfaceFieldToHTclObj (is_subifc, fid, (ps :=> t), fpragmas) = TLst (map ifcPragmaToHTclObj fpragmas) ] else - let (arg_ts, res_t) = getArrows t - in tagLst "method" [TStr (pvStr res_t), - TStr (pvStr (unQualId fid)), - TLst (map (TStr . pvStr) arg_ts), + let (arg_ts, res_t) = getArrows t + in tagLst "method" [TStr (pvStr res_t), + TStr (pvStr (unQualId fid)), + TLst (map (TStr . pvStr) arg_ts), TLst (map ifcPragmaToHTclObj fpragmas) - ] - {- (if (null ps) - then "" - else "provisos " ++ - inParens (commaSep (map pvStr ps))) -} + ] + {- (if (null ps) + then "" + else "provisos " ++ + inParens (commaSep (map pvStr ps))) -} interfaceFieldToDetail :: (Bool, Id, Qual Type, [IfcPragma]) -> HTclObj @@ -342,7 +342,7 @@ interfaceFieldToDetail (is_subifc, fid, (ps :=> t), fpragmas) = pvStr t, pvpStringNQ fid] else - let (arg_ts, res_t) = getArrows t + let (arg_ts, res_t) = getArrows t args' = intercalate ", " (map pvStr arg_ts) args = "(" ++ args' ++ ")" in TStr $ intercalate " " ["method", diff --git a/src/comp/TypeCheck.hs b/src/comp/TypeCheck.hs index 718d0c591..1c50a0f0c 100644 --- a/src/comp/TypeCheck.hs +++ b/src/comp/TypeCheck.hs @@ -262,7 +262,7 @@ getFreeT vs (TAp t1 t2) = getFreeT vs t1 ++ getFreeT vs t2 getFreeT vs t = [] getFreeQT :: [TyVar] -> CQType -> [TyVar] -getFreeQT vs (CQType ps t) = getFreeT vs t -- XXX ps +getFreeQT vs (CQType ps t) = getFreeT vs t -- XXX ps getFreeR vs (CRule _ mi qs e) = getFreeME vs mi ++ concatMap (getFreeQ vs) qs ++ getFreeE vs e getFreeR vs (CRuleNest _ mi qs rs) = getFreeME vs mi ++ concatMap (getFreeQ vs) qs ++ concatMap (getFreeR vs) rs diff --git a/src/comp/Unify.hs b/src/comp/Unify.hs index c0c7fddd1..1bfc01a02 100644 --- a/src/comp/Unify.hs +++ b/src/comp/Unify.hs @@ -26,7 +26,7 @@ instance Unify Type where KNum -> numUnify bound_tyvars t1 t2 _ -> internalError("unify kind mismatch: " ++ ppReadable(t1, kind t1, t2, kind t2)) mgu bound_tyvars (TAp l r) (TAp l' r') = do - (s1, eqs1) <- mgu bound_tyvars l l' + (s1, eqs1) <- mgu bound_tyvars l l' (s2, eqs2) <- mgu bound_tyvars (apSub s1 r) (apSub s1 r') Just (s2 @@ s1, fastNub (eqs1 ++ eqs2)) -- don't substitute a variable for itself @@ -82,7 +82,7 @@ varUnify bound_tyvars u v tu tv = varBindWithEqs u tv instance (Types t, Unify t) => Unify [t] where mgu bound_tyvars (x:xs) (y:ys) = do - (s1,eqs1) <- mgu bound_tyvars x y + (s1,eqs1) <- mgu bound_tyvars x y (s2,eqs2) <- mgu bound_tyvars (apSub s1 xs) (apSub s1 ys) return (s2 @@ s1, fastNub (eqs1 ++ eqs2)) mgu bound_tyvars [] [] = return (nullSubst, []) @@ -94,7 +94,7 @@ varBindWithEqs u t = fmap no_eqs $ varBind u t varBind :: TyVar -> Type -> Maybe Subst varBind u t | t == TVar u = Just nullSubst - | isUnSatSyn t = Nothing + | isUnSatSyn t = Nothing | u `elem` tv t = Nothing | kind u == kind t = Just (u +-> t) | otherwise = Nothing diff --git a/src/comp/Util.hs b/src/comp/Util.hs index b8a2e2a4a..da8fc5fe4 100644 --- a/src/comp/Util.hs +++ b/src/comp/Util.hs @@ -140,7 +140,7 @@ instance ToString Char where '\t' -> "\\t" '\a' -> "\\a" '\\' -> "\\\\" - '"' -> "\\\"" -- backslash double-quote + '"' -> "\\\"" -- backslash double-quote _ | n < 0 || n > 0x100 -> internalError "quoting a character value " ++ show n _ | n < 0x20 || n >= 0x7F -> @@ -194,9 +194,9 @@ concatMapM f as = do return (concat temp) -- Haskell Prelude definition says that this is the same as "any (eq x)" -elemBy :: (a -> a -> Bool) -> a -> [a] -> Bool -elemBy eq _ [] = False -elemBy eq x (y:ys) = eq x y || elemBy eq x ys +elemBy :: (a -> a -> Bool) -> a -> [a] -> Bool +elemBy eq _ [] = False +elemBy eq x (y:ys) = eq x y || elemBy eq x ys splitBy :: [a->Bool] -> [a] -> [[a]] splitBy [] _ = [] diff --git a/src/comp/VFinalCleanup.hs b/src/comp/VFinalCleanup.hs index a145884a5..8955bbe35 100644 --- a/src/comp/VFinalCleanup.hs +++ b/src/comp/VFinalCleanup.hs @@ -28,12 +28,12 @@ import BackendNamingConventions(createVerilogNameMapForAVInst) -- all the submodule's ports to the connected list. data ConnState = ConnState { - visited_wires :: S.Set AId, -- marking for visited nodes - visited_insts :: S.Set AId, - defs :: M.Map AId ADef, - instances :: M.Map AId AVInst, -- instances from the package + visited_wires :: S.Set AId, -- marking for visited nodes + visited_insts :: S.Set AId, + defs :: M.Map AId ADef, + instances :: M.Map AId AVInst, -- instances from the package flags :: Flags - } + } -- ============================== @@ -60,18 +60,18 @@ removeUnusedInsts :: Flags -> ASPackage -> ASPackage removeUnusedInsts flags package = package { aspkg_state_instances = ss'', aspkg_state_outputs = sos', - aspkg_values = ds' } + aspkg_values = ds' } where keepInlinedMods = keepInlined flags - ds = aspkg_values package - ss = aspkg_state_instances package - sos = aspkg_state_outputs package + ds = aspkg_values package + ss = aspkg_state_instances package + sos = aspkg_state_outputs package - os = aspkg_outputs package - ios = aspkg_inouts package - fs = aspkg_foreign_calls package + os = aspkg_outputs package + ios = aspkg_inouts package + fs = aspkg_foreign_calls package - (cdefs,cinsts) = -- traces("conn outputs is: " ++ ppReadable markedConn) $ + (cdefs,cinsts) = -- traces("conn outputs is: " ++ ppReadable markedConn) $ -- traces("conn pacakge: " ++ ppReadable package ) $ connectedNode flags markedConn ss ds ds' = filter isDefUsed ds @@ -82,27 +82,27 @@ removeUnusedInsts flags package = else ss isModuleUsed :: AVInst -> Bool isModuleUsed inst = S.member (avi_vname inst) cinsts - sos' = if (removeUnusedMods flags) - then filter isPortOfConnectedInst sos - else sos - isPortOfConnectedInst (i,_) = - -- XXX This uses a hack (getRootName) to get the instance name - (getRootName i) `S.member` (S.map (getIdString) cinsts) - - -- started with the outputs, any kept firing signals, any kept - -- instances, and the wires used in foreign function calls + sos' = if (removeUnusedMods flags) + then filter isPortOfConnectedInst sos + else sos + isPortOfConnectedInst (i,_) = + -- XXX This uses a hack (getRootName) to get the instance name + (getRootName i) `S.member` (S.map (getIdString) cinsts) + + -- started with the outputs, any kept firing signals, any kept + -- instances, and the wires used in foreign function calls avdefs = concat [afc_writes fc | (_,fcs) <- fs, fc <- fcs] markedConn :: [AId] markedConn = (map fst os) ++ (map fst ios) ++ - fires ++ instconn ++ + fires ++ instconn ++ aVars fs ++ avdefs ++ inlinedports ++ keepEvenUnused instconn = if (removeUnusedMods flags) - then [] - else concatMap (getPortIdsFromInst flags) ss + then [] + else concatMap (getPortIdsFromInst flags) ss fires = if (keepFires flags) - then [i | def@(ADef i t e _) <- ds, isFire i ] - else [] + then [i | def@(ADef i t e _) <- ds, isFire i ] + else [] inlinedports = if (keepInlinedMods) then aspkg_inlined_ports package else [] @@ -153,11 +153,11 @@ handleInst cstate instId = handleInst2 rootId -- Get AIds from an instance, ports plus clock and reset getPortIdsFromInst :: Flags -> AVInst -> [AId] getPortIdsFromInst flags inst = - cr ++ portids + cr ++ portids where - cr = aVars inst - (_,ports) = unzip $ createVerilogNameMapForAVInst flags inst - portids = map (\s -> mkId noPosition s) (nub (ports)) + cr = aVars inst + (_,ports) = unzip $ createVerilogNameMapForAVInst flags inst + portids = map (\s -> mkId noPosition s) (nub (ports)) -- XXX This is hack to get the instance name; need a better data model getRootName :: Id -> String diff --git a/src/comp/VIOProps.hs b/src/comp/VIOProps.hs index c045fb985..8c3bb729b 100644 --- a/src/comp/VIOProps.hs +++ b/src/comp/VIOProps.hs @@ -12,12 +12,12 @@ import ErrorUtil(internalError) import Id import PreIds(idPrimAction, idInout_) import VModInfo(vArgs, vFields, VName(..), VeriPortProp(..), - VArgInfo(..), VFieldInfo(..), VPort) + VArgInfo(..), VFieldInfo(..), VPort) import Prim import ASyntax import ASyntaxUtil( AVars(..) ) import BackendNamingConventions(createVerilogNameMapForAVInst, - xLateIdUsingFStringMap) + xLateIdUsingFStringMap) -- import Trace -- import Util(traces,traceM) @@ -32,313 +32,313 @@ instance Hyper IOIO where hyper x y = seq x y -- (name, input(T)/output(F), width, properties) newtype VIOProps = VIOProps [(AId, IOIO, Integer, [VeriPortProp])] - deriving (Eq) + deriving (Eq) instance Hyper VIOProps where hyper (VIOProps xs) y = hyper xs y instance PPrint VIOProps where pPrint d p (VIOProps ps) = - text "Name I/O size props" $+$ - foldr ($+$) (text "") (map pp ps) - where pp (i, io, sz, ps) = - let s = getIdString i - si = s ++ replicate (29 - length s) ' ' - n = itos sz - sn = replicate (5 - length n) ' ' ++ n + text "Name I/O size props" $+$ + foldr ($+$) (text "") (map pp ps) + where pp (i, io, sz, ps) = + let s = getIdString i + si = s ++ replicate (29 - length s) ' ' + n = itos sz + sn = replicate (5 - length n) ' ' ++ n iotxt = case (io) of - INPUT -> " I" - OUTPUT-> " O" - INOUT -> "IO" - in text si <+> text iotxt <+> - text sn <+> sep (map (pPrint d 0) ps) + INPUT -> " I" + OUTPUT-> " O" + INOUT -> "IO" + in text si <+> text iotxt <+> + text sn <+> sep (map (pPrint d 0) ps) -- assuming foreign functions do not affect the IO properties getIOProps :: Flags -> ASPackage -> (VIOProps, [VPort]) getIOProps flags ppp@(ASPackage _ _ _ os is ios vs _ ds io_ds fs _ _ _) = -- returns the VIOProps structure -- and a mapping of Verilog port names to their port properties - (VIOProps ais, [(VName (getIdString i), ps) | (i, _, _, ps) <- ais ]) + (VIOProps ais, [(VName (getIdString i), ps) | (i, _, _, ps) <- ais ]) where -- VIOProps for all outputs ois = map getOInfo os -- VIOProps for all inputs - iis = map getIInfo is + iis = map getIInfo is -- VIOProps for all inouts - iois = map getIOInfo ios - -- VIOProps for all ports (but only nonzero sized) - ais = filter nonZero (ois ++ iis ++ iois) - where nonZero (_, _, sz, _) = sz /= 0 + iois = map getIOInfo ios + -- VIOProps for all ports (but only nonzero sized) + ais = filter nonZero (ois ++ iis ++ iois) + where nonZero (_, _, sz, _) = sz /= 0 - -- construct VIOProps for an output + -- construct VIOProps for an output getOInfo :: (AId,AType) -> (AId, IOIO, Integer, [VeriPortProp]) - getOInfo (i, t) = (i, OUTPUT, size t, getOProp i) + getOInfo (i, t) = (i, OUTPUT, size t, getOProp i) - -- construct VIOProps for an input + -- construct VIOProps for an input getIInfo :: (AId,AType) -> (AId, IOIO, Integer, [VeriPortProp]) - getIInfo (i, t) = (i, INPUT, size t, getIProp i) + getIInfo (i, t) = (i, INPUT, size t, getIProp i) - -- construct VIOProps for an inout + -- construct VIOProps for an inout getIOInfo :: (AId,AType) -> (AId, IOIO, Integer, [VeriPortProp]) - getIOInfo (i, t) = (i, INOUT, size t, getIOProp i) + getIOInfo (i, t) = (i, INOUT, size t, getIOProp i) -- lookup the definition for an id getDef :: AId -> ADef - getDef i = M.findWithDefault err i defMap + getDef i = M.findWithDefault err i defMap where err = internalError ("getIOProps.getDef failed: " ++ - ppString (i, defMap)) + ppString (i, defMap)) - -- mapping from ids to their defs - defMap = M.union (M.fromList [(i, d) | d@(ADef i _ _ _) <- ds ]) + -- mapping from ids to their defs + defMap = M.union (M.fromList [(i, d) | d@(ADef i _ _ _) <- ds ]) -- XXX do the two maps ever mix? can we defined -- XXX getIOProps to only work with the ioDefMap? ioDefMap ioDefMap = M.fromList [(i, d) | d@(ADef i _ _ _) <- io_ds ] - -- ---------- - -- construct the VeriPortProp list for an output - - getOProp i = - case getDef i of - ADef _ _ e _ -> let deduced_props = getOEP e - in -- we could add any props known the ifc here - -- (such as input clocks/resets) - -- for now, we just derive this - -- (but it means that "const" outputs don't - -- also get props like "reset" or "gate") - deduced_props - - -- given the props for multiple signals, - -- compute the props that the concatenation should have + -- ---------- + -- construct the VeriPortProp list for an output + + getOProp i = + case getDef i of + ADef _ _ e _ -> let deduced_props = getOEP e + in -- we could add any props known the ifc here + -- (such as input clocks/resets) + -- for now, we just derive this + -- (but it means that "const" outputs don't + -- also get props like "reset" or "gate") + deduced_props + + -- given the props for multiple signals, + -- compute the props that the concatenation should have joinOutProps :: [[VeriPortProp]] -> [VeriPortProp] - joinOutProps (x:xs) = foldr intersect x xs - -- empty list only occurs with prims of no args - -- XXX do we have any? if they all give constant return values, - -- XXX then we could return [VPconst] here - joinOutProps [] = [] + joinOutProps (x:xs) = foldr intersect x xs + -- empty list only occurs with prims of no args + -- XXX do we have any? if they all give constant return values, + -- XXX then we could return [VPconst] here + joinOutProps [] = [] - -- construct the VeriPortProp list for an expression + -- construct the VeriPortProp list for an expression getOEP :: AExpr -> [VeriPortProp] - -- for concats, find the common properties of the pieces - getOEP (APrim _ _ PrimConcat es) = joinOutProps (map getOEP es) - -- an extraction doesn't change the properties - getOEP (APrim _ _ PrimExtract [e, _, _]) = getOEP e - -- either an output port of a submodule or an input to the ASPackage - -- (so get its properties) - getOEP (ASPort _ i) = getOVProp i - -- follow defs - getOEP (ASDef _ i) = getOProp i - -- constant values - getOEP (ASParam _ i) = [VPconst] - getOEP (ASInt _ _ _) = [VPconst] - getOEP (ASStr _ _ _) = [VPconst] - -- for any other use, we cannot conclude properties - getOEP _ = [] + -- for concats, find the common properties of the pieces + getOEP (APrim _ _ PrimConcat es) = joinOutProps (map getOEP es) + -- an extraction doesn't change the properties + getOEP (APrim _ _ PrimExtract [e, _, _]) = getOEP e + -- either an output port of a submodule or an input to the ASPackage + -- (so get its properties) + getOEP (ASPort _ i) = getOVProp i + -- follow defs + getOEP (ASDef _ i) = getOProp i + -- constant values + getOEP (ASParam _ i) = [VPconst] + getOEP (ASInt _ _ _) = [VPconst] + getOEP (ASStr _ _ _) = [VPconst] + -- for any other use, we cannot conclude properties + getOEP _ = [] -- build table of wire properties for the state element outputs wireMap_out :: M.Map AId [VeriPortProp] wireMap_out = - let submod_pairs = - -- clock and reset outputs - [(i, ps) | - v <- vs, - (i, _, (_, ps)) <- getSpecialOutputs v] ++ - -- output ports for method return values - [(veri_id, pprops) | - -- for each instance - v <- vs, - -- create the method name map - let nmap = M.fromList $ - createVerilogNameMapForAVInst flags v, - -- for each method that has an output port - vfi@(Method { vf_output = Just (vname,pprops) }) - <- vFields (avi_vmi v), - -- for each port copy - ino <- if (vf_mult vfi > 1) then + let submod_pairs = + -- clock and reset outputs + [(i, ps) | + v <- vs, + (i, _, (_, ps)) <- getSpecialOutputs v] ++ + -- output ports for method return values + [(veri_id, pprops) | + -- for each instance + v <- vs, + -- create the method name map + let nmap = M.fromList $ + createVerilogNameMapForAVInst flags v, + -- for each method that has an output port + vfi@(Method { vf_output = Just (vname,pprops) }) + <- vFields (avi_vmi v), + -- for each port copy + ino <- if (vf_mult vfi > 1) then map Just [0 .. vf_mult vfi] else [Nothing], - -- construct the method output signal name - let meth_id = mkMethId (avi_vname v) - (vf_name vfi) - ino - MethodResult, - -- convert to Verilog signal name - let veri_id = xLateIdUsingFStringMap nmap meth_id - ] - -- outputs can also come from top-level inputs; - -- we use [] for the properties of the input - -- XXX this should be OK, because the deriving of the - -- XXX property for the input would give up if it - -- XXX reached an output, and the props would be [] - input_pairs = - [ (i, []) | (i,_) <- is ] + -- construct the method output signal name + let meth_id = mkMethId (avi_vname v) + (vf_name vfi) + ino + MethodResult, + -- convert to Verilog signal name + let veri_id = xLateIdUsingFStringMap nmap meth_id + ] + -- outputs can also come from top-level inputs; + -- we use [] for the properties of the input + -- XXX this should be OK, because the deriving of the + -- XXX property for the input would give up if it + -- XXX reached an output, and the props would be [] + input_pairs = + [ (i, []) | (i,_) <- is ] -- ifc inouts can also come from argument inouts inout_pairs = [ (i, [VPinout]) | (i,_) <- ios, isNothing (M.lookup i ioDefMap) ] - in - M.unions [M.fromList submod_pairs, + in + M.unions [M.fromList submod_pairs, M.fromList input_pairs, M.fromList inout_pairs] - getOVProp :: AId -> [VeriPortProp] - getOVProp i = - case (M.lookup i wireMap_out) of - Just ps -> ps - Nothing -> - -- since we added the module inputs to the map, - -- this branch should never happen. alternatively, - -- we could not put the inputs in the map and just - -- return empty-list here; but the internal check - -- is nice to have (if it's not too expensive). - internalError ("getOVProp: could not find method " ++ - ppString i) - - -- ---------- - -- construct the VeriPortProp list for an input + getOVProp :: AId -> [VeriPortProp] + getOVProp i = + case (M.lookup i wireMap_out) of + Just ps -> ps + Nothing -> + -- since we added the module inputs to the map, + -- this branch should never happen. alternatively, + -- we could not put the inputs in the map and just + -- return empty-list here; but the internal check + -- is nice to have (if it's not too expensive). + internalError ("getOVProp: could not find method " ++ + ppString i) + + -- ---------- + -- construct the VeriPortProp list for an input getIProp :: AId -> [VeriPortProp] - getIProp i = - let derived_props = getSignalInProp i - in -- we could add any props known from the ifc here - -- (such as input clocks/resets) - -- for now, we just derive this (see comment below) - derived_props - - -- given the deduced props for multiple signals, - -- compute the props that should be deduced for a signal - -- which connects directly to all these signals (and only these) + getIProp i = + let derived_props = getSignalInProp i + in -- we could add any props known from the ifc here + -- (such as input clocks/resets) + -- for now, we just derive this (see comment below) + derived_props + + -- given the deduced props for multiple signals, + -- compute the props that should be deduced for a signal + -- which connects directly to all these signals (and only these) joinInProps :: [[VeriPortProp]] -> [VeriPortProp] - joinInProps pss = - let - -- if a signal is unused, it might as well not exist, - -- so don't count it - pss' = filter (VPunused `notElem`) pss - in - case pss' of - [] -> [VPunused] - (x:xs) -> - -- otherwise, a prop needs to be on all used signals - -- for it to be on the source - foldr intersect x xs - - -- a list the signals which are connected to - -- submodule input ports (method arguments and enables) + joinInProps pss = + let + -- if a signal is unused, it might as well not exist, + -- so don't count it + pss' = filter (VPunused `notElem`) pss + in + case pss' of + [] -> [VPunused] + (x:xs) -> + -- otherwise, a prop needs to be on all used signals + -- for it to be on the source + foldr intersect x xs + + -- a list the signals which are connected to + -- submodule input ports (method arguments and enables) wireMap_in :: M.Map Id [VeriPortProp] - wireMap_in = - let submod_pairs = - -- submodule method inputs - [(veri_id, pprops) | - -- for each instance - v <- vs, - -- create the method name map - let nmap = M.fromList $ - createVerilogNameMapForAVInst flags v, - -- for each method (not clocks or resets) - vfi@(Method {}) <- vFields (avi_vmi v), - -- for each method input part (args and enables) - (methpart, (vname, pprops)) - <- (zip (map MethodArg [1..]) (vf_inputs vfi)) ++ - case (vf_enable vfi) of - Nothing -> [] - Just port -> [(MethodEnable, port)], - -- for each port copy - ino <- if (vf_mult vfi > 1) then + wireMap_in = + let submod_pairs = + -- submodule method inputs + [(veri_id, pprops) | + -- for each instance + v <- vs, + -- create the method name map + let nmap = M.fromList $ + createVerilogNameMapForAVInst flags v, + -- for each method (not clocks or resets) + vfi@(Method {}) <- vFields (avi_vmi v), + -- for each method input part (args and enables) + (methpart, (vname, pprops)) + <- (zip (map MethodArg [1..]) (vf_inputs vfi)) ++ + case (vf_enable vfi) of + Nothing -> [] + Just port -> [(MethodEnable, port)], + -- for each port copy + ino <- if (vf_mult vfi > 1) then map Just [0 .. vf_mult vfi] else [Nothing], - -- construct the method output signal name - let meth_id = mkMethId (avi_vname v) - (vf_name vfi) - ino - methpart, - -- convert to Verilog signal name - let veri_id = xLateIdUsingFStringMap nmap meth_id - ] ++ - -- submodule argument inputs - [(d, pprops) | - (AVInst { avi_vmi = vi, avi_iargs = es }) <- vs, + -- construct the method output signal name + let meth_id = mkMethId (avi_vname v) + (vf_name vfi) + ino + methpart, + -- convert to Verilog signal name + let veri_id = xLateIdUsingFStringMap nmap meth_id + ] ++ + -- submodule argument inputs + [(d, pprops) | + (AVInst { avi_vmi = vi, avi_iargs = es }) <- vs, (a, e) <- zip (vArgs vi) es, - -- AState has converted Clock/Reset to Port - let pprops = - case a of - (Port (_,pps) _ _) -> pps - (Param _) -> [VPconst] -- XXX? - arg -> internalError - ("VIOProps wireMap_in: " ++ - "unexpected arg: " ++ - ppReadable arg) , - -- only carry these props to direct refs - let ds = aVars e, - all (\i -> okUse i e) ds, - d <- ds - ] - -- inputs can also feed into outputs; - -- we use [] for the properties of the output - -- (since it is a use that we can conclude nothing about, - -- not "unused") - -- XXX this should be OK? - output_pairs = - [ (o, []) | (o,_) <- os ] - in - M.fromList (submod_pairs ++ output_pairs) + -- AState has converted Clock/Reset to Port + let pprops = + case a of + (Port (_,pps) _ _) -> pps + (Param _) -> [VPconst] -- XXX? + arg -> internalError + ("VIOProps wireMap_in: " ++ + "unexpected arg: " ++ + ppReadable arg) , + -- only carry these props to direct refs + let ds = aVars e, + all (\i -> okUse i e) ds, + d <- ds + ] + -- inputs can also feed into outputs; + -- we use [] for the properties of the output + -- (since it is a use that we can conclude nothing about, + -- not "unused") + -- XXX this should be OK? + output_pairs = + [ (o, []) | (o,_) <- os ] + in + M.fromList (submod_pairs ++ output_pairs) -- use a map to limit search over all definition -- key is AId data is list of defs where key is used. defuseMap :: M.Map AId (S.Set AId) defuseMap = getDefUses ds - -- given a signal, this determines its props - getSignalInProp :: AId -> [VeriPortProp] - getSignalInProp i = - let - -- there are two sources of port props: - -- * wireMap_in (submod inputs, top-mod outputs) - -- * following defs (via defuseMap) to eventually - -- reach Ids in wireMap_in - -- For most of the Ids in the wireMap_in, there should be - -- no uses in the defs to follow. But some can be followed. - -- So in order to support that (and reduce the requirements - -- on defs in ASPackage), we check both sources and merge. - - wiremap_props = - case (M.lookup i wireMap_in) of - Just ps -> ps - Nothing -> [VPunused] - - defuse_props = - let user_set = M.findWithDefault (S.empty) i defuseMap - in -- is it unused? - if (S.null user_set) - then [VPunused] - else - -- determine if the uses are "direct" - -- (direct reference, concat, or extract, but no - -- other functions on the value) - let uses = [ if noUse i user_e - then Just [] - else if okUse i user_e - then Just [user] - else Nothing - | user <- S.toList user_set, + -- given a signal, this determines its props + getSignalInProp :: AId -> [VeriPortProp] + getSignalInProp i = + let + -- there are two sources of port props: + -- * wireMap_in (submod inputs, top-mod outputs) + -- * following defs (via defuseMap) to eventually + -- reach Ids in wireMap_in + -- For most of the Ids in the wireMap_in, there should be + -- no uses in the defs to follow. But some can be followed. + -- So in order to support that (and reduce the requirements + -- on defs in ASPackage), we check both sources and merge. + + wiremap_props = + case (M.lookup i wireMap_in) of + Just ps -> ps + Nothing -> [VPunused] + + defuse_props = + let user_set = M.findWithDefault (S.empty) i defuseMap + in -- is it unused? + if (S.null user_set) + then [VPunused] + else + -- determine if the uses are "direct" + -- (direct reference, concat, or extract, but no + -- other functions on the value) + let uses = [ if noUse i user_e + then Just [] + else if okUse i user_e + then Just [user] + else Nothing + | user <- S.toList user_set, let user_e = adef_expr $ getDef user ] - in - -- if any are not direct uses, - -- then we conclude nothing - if (any isNothing uses) - then [] - else let users = concat $ catMaybes uses - userprops = map getSignalInProp users - in - -- a prop is only valid if all uses - -- have that prop - joinInProps userprops - in - -- merge the props from the two sources - joinInProps [wiremap_props, defuse_props] - - -- ---------- + in + -- if any are not direct uses, + -- then we conclude nothing + if (any isNothing uses) + then [] + else let users = concat $ catMaybes uses + userprops = map getSignalInProp users + in + -- a prop is only valid if all uses + -- have that prop + joinInProps userprops + in + -- merge the props from the two sources + joinInProps [wiremap_props, defuse_props] + + -- ---------- -- construct the VeriPortProp list for an inout getIOProp :: AId -> [VeriPortProp] diff --git a/src/comp/VPrims.hs b/src/comp/VPrims.hs index 404c63d39..82f5da4ad 100644 --- a/src/comp/VPrims.hs +++ b/src/comp/VPrims.hs @@ -24,16 +24,16 @@ vMuxP parallel n = VModule { vm_name = (mkVId ("Mux_" ++ itos n)), vm_body = [regdecl,outassign,body] } where comments = [] -- XXX room to add comments - args = param : out : iss - param = VAParameter viWidth Nothing (VEConst 1) - out = VAOutput viOut rng - iss = concatMap (\ n -> [VAInput (i n) rng, VAInput (s n) Nothing]) ns - hi = mkVEOp w VSub one - lo = zero - w = VEVar viWidth - rng = Just (hi, lo) - i n = mkVId ("in_" ++ itos n) - s n = mkVId ("s_" ++ itos n) + args = param : out : iss + param = VAParameter viWidth Nothing (VEConst 1) + out = VAOutput viOut rng + iss = concatMap (\ n -> [VAInput (i n) rng, VAInput (s n) Nothing]) ns + hi = mkVEOp w VSub one + lo = zero + w = VEVar viWidth + rng = Just (hi, lo) + i n = mkVId ("in_" ++ itos n) + s n = mkVId ("s_" ++ itos n) outassign = VMAssign (VLId viOut) (VEVar viOutReg) regdecl = VMDecl (VVDecl VDReg rng [(VVar viOutReg)]) body = VMStmt{ vi_translate_off = False, @@ -44,7 +44,7 @@ vMuxP parallel n = VModule { vm_name = (mkVId ("Mux_" ++ itos n)), vs_full = True } } - ns = [0..n-1] + ns = [0..n-1] sels = map s ns ins = map i ns diff --git a/src/comp/Verilog.hs b/src/comp/Verilog.hs index d52d721a9..a21f2fa02 100644 --- a/src/comp/Verilog.hs +++ b/src/comp/Verilog.hs @@ -18,26 +18,26 @@ module Verilog( VTri(..), VVDecl(..), VVar(..), - VComment, - vvName, - vargName, + VComment, + vvName, + vargName, commonDeclTypes, getVeriInsts, vGetMainModName, vKeywords, vSeq, vVDecl, - vGroup, - vGroupWithComment, - mkVId, - idToVId, - vidToId, - getVIdString, - mkVEOp, - mkVEUnOp, + vGroup, + vGroupWithComment, + mkVId, + idToVId, + vidToId, + getVIdString, + mkVEOp, + mkVEUnOp, mkEqualsReset, mkNotEqualsReset, mkEdgeReset, mkReset, mkNotReset, - defaultVId, + defaultVId, vIsValidIdent -- vVar ) where @@ -77,26 +77,26 @@ mkSynthPragma s = text ("// " ++ synthesis_str ++ " " ++ s) -- * a list of modules -- * a comment for the entire file, not for any one module data VProgram = VProgram [VModule] VComment - deriving (Eq, Show, Generic.Data, Generic.Typeable) + deriving (Eq, Show, Generic.Data, Generic.Typeable) instance Hyper VProgram where hyper x y = (x==x) `seq` y instance PPrint VProgram where pPrint d p (VProgram ms cs) = - ppComment cs $+$ + ppComment cs $+$ assignment_delay_macro $+$ reset_level_macro $+$ - vsepEmptyLine (map (pPrint d 0) ms) $+$ - text "" + vsepEmptyLine (map (pPrint d 0) ms) $+$ + text "" where -- define BSV_ASSIGNMENT_DELAY when the user does not override it assignment_delay_macro = - text "" $+$ + text "" $+$ text "`ifdef BSV_ASSIGNMENT_DELAY" $+$ text "`else" $+$ text " `define BSV_ASSIGNMENT_DELAY" $+$ text "`endif" $+$ - text "" + text "" reset_level_macro = text "`ifdef BSV_POSITIVE_RESET" $+$ text " `define BSV_RESET_VALUE 1'b1" $+$ @@ -132,63 +132,63 @@ data VModule = vm_ports :: [([VArg],VComment)] , vm_body :: [VMItem] } - deriving (Eq, Show, Generic.Data, Generic.Typeable) + deriving (Eq, Show, Generic.Data, Generic.Typeable) instance PPrint VModule where pPrint d p vmodule = - let + let -- don't include parameters in the port list isParam (VAParameter {}) = True isParam _ = False removeParams = filter (not . isParam) - comments = ppComment (vm_comments vmodule) + comments = ppComment (vm_comments vmodule) -- ports = vm_ports vmodule - portlist = if null ports - then text "" - else pparen True $ - commaSepEmptyLine (map ppPortListGroup ports) + portlist = if null ports + then text "" + else pparen True $ + commaSepEmptyLine (map ppPortListGroup ports) - -- print the comma separated list of port names + -- print the comma separated list of port names ppPortListGroup :: ([VArg],VComment) -> Doc ppPortListGroup ([],_) = empty - ppPortListGroup (ps,_) = - -- don't print the comment, - -- no comma at the end of group (added when combining groups) - vcatList (map (ppVArgPort d) (removeParams ps)) (text ",") - - -- print the declarations (e.g. "input x;") - ppPortDeclGroup (ps, comment) = - let port_decls = ppLinesBy ppVArgDecl d ps - in ppComment comment $+$ port_decls - - modheader = - text "module" <+> labeledPPrint "DEFOF" d p (vm_name vmodule) <> - portlist <> text ";" - modbody = - -- I/O decls and VMItems are indented by two spaces, - -- and the VMItems have spaces around some items for - -- readability - let gs = groupVMItems (vm_body vmodule) - ppgroups g = text " " <> labeledPPLines "NET" d g - in text " " <> - vsepEmptyLine (map ppPortDeclGroup ports) $+$ - text "" $+$ -- empty line - vsepEmptyLine (map ppgroups gs) - modtail = - text "endmodule //" <+> labeledPPrint "IGNORE" d 0 (vm_name vmodule) - in - comments $+$ modheader $+$ modbody $+$ modtail + ppPortListGroup (ps,_) = + -- don't print the comment, + -- no comma at the end of group (added when combining groups) + vcatList (map (ppVArgPort d) (removeParams ps)) (text ",") + + -- print the declarations (e.g. "input x;") + ppPortDeclGroup (ps, comment) = + let port_decls = ppLinesBy ppVArgDecl d ps + in ppComment comment $+$ port_decls + + modheader = + text "module" <+> labeledPPrint "DEFOF" d p (vm_name vmodule) <> + portlist <> text ";" + modbody = + -- I/O decls and VMItems are indented by two spaces, + -- and the VMItems have spaces around some items for + -- readability + let gs = groupVMItems (vm_body vmodule) + ppgroups g = text " " <> labeledPPLines "NET" d g + in text " " <> + vsepEmptyLine (map ppPortDeclGroup ports) $+$ + text "" $+$ -- empty line + vsepEmptyLine (map ppgroups gs) + modtail = + text "endmodule //" <+> labeledPPrint "IGNORE" d 0 (vm_name vmodule) + in + comments $+$ modheader $+$ modbody $+$ modtail data VArg - = VAInput VId (Maybe VRange) + = VAInput VId (Maybe VRange) -- If the type is Nothing, then do not print a declaration - | VAInout VId (Maybe VId) (Maybe (Maybe VRange)) - | VAOutput VId (Maybe VRange) - | VAParameter VId (Maybe VRange) VExpr - deriving (Eq, Show, Generic.Data, Generic.Typeable) + | VAInout VId (Maybe VId) (Maybe (Maybe VRange)) + | VAOutput VId (Maybe VRange) + | VAParameter VId (Maybe VRange) VExpr + deriving (Eq, Show, Generic.Data, Generic.Typeable) -- only use this for debugging instance PPrint VArg where @@ -230,27 +230,27 @@ vargName (VAOutput i _) = i vargName (VAParameter i _ _) = i data VMItem - = VMDecl VVDecl + = VMDecl VVDecl -- VMInst: vmi_instance_params and vmi_instance_ports can be positional -- or named, thus the Either (Left = a list of expressions, -- by position, and Right = list of (name, expression) pairs) - | VMInst { vi_module_name :: VId, + | VMInst { vi_module_name :: VId, vi_inst_name :: VId, -- The string is for comments vi_inst_params :: Either [(Maybe String,VExpr)] [(VId, Maybe VExpr)], vi_inst_ports :: [(VId, Maybe VExpr)] } - | VMAssign VLValue VExpr - | VMStmt { vi_translate_off :: Bool, vi_body :: VStmt } - | VMComment VComment VMItem - -- like VMComment but specific to inlined registers, + | VMAssign VLValue VExpr + | VMStmt { vi_translate_off :: Bool, vi_body :: VStmt } + | VMComment VComment VMItem + -- like VMComment but specific to inlined registers, -- to carry info for xref generation. - -- XXX could this not have been handled in mkRegGroup? - | VMRegGroup VId String VComment VMItem - -- VMGroup: the lists of VMItem will be separated by empty lines; - -- if no spaces needed, use a list of one list. - | VMGroup { vg_translate_off :: Bool, vg_body :: [[VMItem]]} - | VMFunction VFunction - deriving (Eq, Show, Generic.Data, Generic.Typeable) + -- XXX could this not have been handled in mkRegGroup? + | VMRegGroup VId String VComment VMItem + -- VMGroup: the lists of VMItem will be separated by empty lines; + -- if no spaces needed, use a list of one list. + | VMGroup { vg_translate_off :: Bool, vg_body :: [[VMItem]]} + | VMFunction VFunction + deriving (Eq, Show, Generic.Data, Generic.Typeable) instance Ord VMItem where -- comments are just attached to other statements, @@ -285,47 +285,47 @@ instance Ord VMItem where compare (VMFunction _) (VMFunction _) = EQ compare (VMFunction _) _ = GT - compare (VMGroup _ _) (VMGroup _ _) = EQ - compare (VMGroup _ _) _ = GT + compare (VMGroup _ _) (VMGroup _ _) = EQ + compare (VMGroup _ _) _ = GT instance PPrint VMItem where - pPrint d p (VMDecl dcl) = pPrint d p dcl - pPrint d p s@(VMStmt {}) + pPrint d p (VMDecl dcl) = pPrint d p dcl + pPrint d p s@(VMStmt {}) | vi_translate_off s = mkSynthPragma "translate_off" $$ pPrint d p (vi_body s) $$ mkSynthPragma "translate_on" | otherwise = pPrint d p (vi_body s) - pPrint d p (VMAssign v e) = -- trace("Assignment :" ++ (ppReadable v) ++ " = " ++ (ppReadable e) ++ "\n") $ - sep [text "assign" <+> labeledPPrint "ASSIGN" d 45 v <+> text "=", - nest 11 (pPrint d 0 e <+> text ";")] - pPrint d p (VMInst mid iid pvs cs) = pPrint d 0 mid <> - (case pvs of - Left ps -> (if null ps then text "" - else text " #" <> pparen True (sepList (map (pv95params d) ps) comma )) - Right ps -> (if null ps then text "" - else text " #" <> - pparen True (sepList (map (\ (i, me) -> text "." <> pPrint d 0 i <> - pparen True (case me of Just e -> pPrint d 0 e; Nothing -> text "")) ps) (text ",")))) <> - text "" <+> pPrint d 0 iid <> - pparen True (sepList (map (\ (i, me) -> text "." <> pPrint d 0 i <> - pparen True (case me of + pPrint d p (VMAssign v e) = -- trace("Assignment :" ++ (ppReadable v) ++ " = " ++ (ppReadable e) ++ "\n") $ + sep [text "assign" <+> labeledPPrint "ASSIGN" d 45 v <+> text "=", + nest 11 (pPrint d 0 e <+> text ";")] + pPrint d p (VMInst mid iid pvs cs) = pPrint d 0 mid <> + (case pvs of + Left ps -> (if null ps then text "" + else text " #" <> pparen True (sepList (map (pv95params d) ps) comma )) + Right ps -> (if null ps then text "" + else text " #" <> + pparen True (sepList (map (\ (i, me) -> text "." <> pPrint d 0 i <> + pparen True (case me of Just e -> pPrint d 0 e; Nothing -> text "")) ps) (text ",")))) <> + text "" <+> pPrint d 0 iid <> + pparen True (sepList (map (\ (i, me) -> text "." <> pPrint d 0 i <> + pparen True (case me of Just e -> pPrint d 0 e; Nothing -> text "")) cs) (text ",")) - <> text ";" - pPrint d p (VMComment cs stmt) = ppComment cs $+$ pPrint d p stmt - pPrint d p g@(VMGroup _ stmtss) + <> text ";" + pPrint d p (VMComment cs stmt) = ppComment cs $+$ pPrint d p stmt + pPrint d p g@(VMGroup _ stmtss) | vg_translate_off g = mkSynthPragma "translate_off" $$ vsepEmptyLine (map (ppLines d) stmtss) $$ mkSynthPragma "translate_on" | otherwise = vsepEmptyLine (map (ppLines d) stmtss) - pPrint d p (VMFunction f) = pPrint d p f - pPrint d p (VMRegGroup inst_id def_name cs stmt) = - text "// register" <+> - pPrint d 0 inst_id $+$ - ppComment cs $+$ - pPrint d p stmt + pPrint d p (VMFunction f) = pPrint d p f + pPrint d p (VMRegGroup inst_id def_name cs stmt) = + text "// register" <+> + pPrint d 0 inst_id $+$ + ppComment cs $+$ + pPrint d p stmt pv95params d (Nothing,x) = pPrint d 0 x pv95params d (Just "", x) = pPrint d 0 x @@ -338,24 +338,24 @@ pv95params d (Just s,x) = text (" /*" ++ s ++ "*/ ") <> pPrint d 0 x groupVMItems :: [VMItem] -> [[VMItem]] groupVMItems vmis = let - -- identify which VMItems need a space before and after them - needsSpace (VMInst _ _ _ _) = True - needsSpace (VMStmt _ _) = True - needsSpace (VMFunction _) = True - needsSpace (VMGroup _ _) = True - needsSpace (VMComment _ vmi) = needsSpace vmi - needsSpace (VMRegGroup _ _ _ vmi) = needsSpace vmi - needsSpace _ = False - - groupNeedsSpace [v] = needsSpace v - groupNeedsSpace _ = False - - foldFunc v [] = [[v]] - foldFunc v (g:gs) = if (needsSpace v || groupNeedsSpace g) - then ([v]:g:gs) - else ((v:g):gs) + -- identify which VMItems need a space before and after them + needsSpace (VMInst _ _ _ _) = True + needsSpace (VMStmt _ _) = True + needsSpace (VMFunction _) = True + needsSpace (VMGroup _ _) = True + needsSpace (VMComment _ vmi) = needsSpace vmi + needsSpace (VMRegGroup _ _ _ vmi) = needsSpace vmi + needsSpace _ = False + + groupNeedsSpace [v] = needsSpace v + groupNeedsSpace _ = False + + foldFunc v [] = [[v]] + foldFunc v (g:gs) = if (needsSpace v || groupNeedsSpace g) + then ([v]:g:gs) + else ((v:g):gs) in - foldr foldFunc [] vmis + foldr foldFunc [] vmis -- Convenience function to wrap a list of items in a VMGroup. -- If the list is empty, return an empty list (don't create a group of nothing) @@ -377,91 +377,91 @@ vGroupWithComment False vmis comment = [VMComment comment (VMGroup False [vmis]) -- the first list. To do this, comment an empty group. vGroupWithComment True vmis comment = let comment_group = [VMComment comment (VMGroup False [])] - vmi_groups = groupVMItems vmis + vmi_groups = groupVMItems vmis in [VMGroup False (comment_group : vmi_groups)] data VFunction = VFunction VId (Maybe VRange) [VFDecl] VStmt - deriving (Eq, Show, Generic.Data, Generic.Typeable) + deriving (Eq, Show, Generic.Data, Generic.Typeable) type VFDecl = VVDecl -- not quite right instance PPrint VFunction where pPrint d p (VFunction name range decls stmt) = - (text "function" <+> ppR d range <> pPrint d 0 name <> text ";") - $+$ (text " " <> (ppLines d decls)) - $+$ (text " " <> pPrint d 0 stmt) + (text "function" <+> ppR d range <> pPrint d 0 name <> text ";") + $+$ (text " " <> (ppLines d decls)) + $+$ (text " " <> pPrint d 0 stmt) $+$ text "endfunction" - where ppR _ Nothing = text "" - ppR d (Just (h,l)) = ppRange d h l <+> text "" + where ppR _ Nothing = text "" + ppR d (Just (h,l)) = ppRange d h l <+> text "" data VStmt - = VAt VEventExpr VStmt - | Valways VStmt - | Vinitial VStmt - | VSeq [VStmt] - | Vcasex { vs_case_expr :: VExpr, + = VAt VEventExpr VStmt + | Valways VStmt + | Vinitial VStmt + | VSeq [VStmt] + | Vcasex { vs_case_expr :: VExpr, vs_case_arms :: [VCaseArm], - vs_parallel :: Bool, - vs_full :: Bool } -- appears unused - | Vcase { vs_case_expr :: VExpr, + vs_parallel :: Bool, + vs_full :: Bool } -- appears unused + | Vcase { vs_case_expr :: VExpr, vs_case_arms :: [VCaseArm], - vs_parallel :: Bool, - vs_full :: Bool } - | VAssign VLValue VExpr - | VAssignA VLValue VExpr - | Vif VExpr VStmt - | Vifelse VExpr VStmt VStmt - | Vdumpvars Int [VId] -- appears unused + vs_parallel :: Bool, + vs_full :: Bool } + | VAssign VLValue VExpr + | VAssignA VLValue VExpr + | Vif VExpr VStmt + | Vifelse VExpr VStmt VStmt + | Vdumpvars Int [VId] -- appears unused | VTask VId [VExpr] -- calling a verilog system task as a Bluespec foreign function of type Action - | VAssert VEventExpr [VExpr] + | VAssert VEventExpr [VExpr] | VZeroDelay -- injecting an explicit (0-tick) delay for synchronization purposes - deriving (Eq, Show, Generic.Data, Generic.Typeable) + deriving (Eq, Show, Generic.Data, Generic.Typeable) instance PPrint VStmt where - pPrint d p (VAt e s) = sep [text "@" <> pparen True (pPrint d 0 e), pPrint d 0 s] - pPrint d p (Valways (VAt e s)) = sep [text "always@" <> pparen True (pPrint d 0 e), pPrint d 0 s] - pPrint d p (Valways s) = sep [text "always", pPrint d 0 s] - pPrint d p (Vinitial s) = + pPrint d p (VAt e s) = sep [text "@" <> pparen True (pPrint d 0 e), pPrint d 0 s] + pPrint d p (Valways (VAt e s)) = sep [text "always@" <> pparen True (pPrint d 0 e), pPrint d 0 s] + pPrint d p (Valways s) = sep [text "always", pPrint d 0 s] + pPrint d p (Vinitial s) = text "`ifdef BSV_NO_INITIAL_BLOCKS" $$ text "`else // not BSV_NO_INITIAL_BLOCKS" $$ sep [text "initial", pPrint d 0 s] $$ text "`endif // BSV_NO_INITIAL_BLOCKS" - pPrint d p (VSeq ss) = text "begin" $+$ (text " " <> ppLines d ss) $+$ text "end" - pPrint d p s@(Vcasex {}) = - (text "casex" <+> pparen True (pPrint d 0 (vs_case_expr s))) <+> - pprintCaseAttributes (vs_parallel s) (vs_full s) $+$ - (text " " <> ppLines d (vs_case_arms s)) $+$ - (text "endcase") - pPrint d p s@(Vcase {}) = - (text "case" <+> pparen True (pPrint d 0 (vs_case_expr s))) <+> - pprintCaseAttributes (vs_parallel s) (vs_full s) $+$ - (text " " <> ppLines d (vs_case_arms s)) $+$ - (text "endcase") - pPrint d p (VAssign v e) = - -- if the expr doesn't fit on the same line, indent it 4 spaces - sep [ pPrint d 0 v <+> text "=", - nest 4 (pPrint d 0 e <> text ";") ] - pPrint d p (VAssignA v e) = - -- if the expr doesn't fit on the same line, indent it 4 spaces - sep [ pPrint d 0 v <+> text "<=" <+> text "`BSV_ASSIGNMENT_DELAY", - nest 4 (pPrint d 0 e <> text ";") ] + pPrint d p (VSeq ss) = text "begin" $+$ (text " " <> ppLines d ss) $+$ text "end" + pPrint d p s@(Vcasex {}) = + (text "casex" <+> pparen True (pPrint d 0 (vs_case_expr s))) <+> + pprintCaseAttributes (vs_parallel s) (vs_full s) $+$ + (text " " <> ppLines d (vs_case_arms s)) $+$ + (text "endcase") + pPrint d p s@(Vcase {}) = + (text "case" <+> pparen True (pPrint d 0 (vs_case_expr s))) <+> + pprintCaseAttributes (vs_parallel s) (vs_full s) $+$ + (text " " <> ppLines d (vs_case_arms s)) $+$ + (text "endcase") + pPrint d p (VAssign v e) = + -- if the expr doesn't fit on the same line, indent it 4 spaces + sep [ pPrint d 0 v <+> text "=", + nest 4 (pPrint d 0 e <> text ";") ] + pPrint d p (VAssignA v e) = + -- if the expr doesn't fit on the same line, indent it 4 spaces + sep [ pPrint d 0 v <+> text "<=" <+> text "`BSV_ASSIGNMENT_DELAY", + nest 4 (pPrint d 0 e <> text ";") ] pPrint d p (Vif e s) | isOne e = pPrint d p s -- optimize ifs that are always true pPrint d p (Vif e s) | isZero e = text "" -- optimize away ifs that are always false - pPrint d p (Vif e s) = - -- if it doesn't fit on one line, start on the next (indent 2) - sep [text "if (" <> pPrint d 0 e <> text ")", - nest 2 (pPrint d 0 s)] - pPrint d p (Vifelse e s1 s2) = - -- for readability, don't allow if-else to fit on one line - -- (thus, use "vcat" instead of "sep") - vcat [text "if (" <> pPrint d 0 e <> text ")", - nest 2 (pPrint d 0 s1), - text "else", - nest 2 (pPrint d 0 s2)] - pPrint d p (Vdumpvars level vars) = text "$dumpvars(" <> sepList dvargs (text ",") <> text ");" - where dvargs = (pPrint d 0 level):(map (pPrint d 0) vars) + pPrint d p (Vif e s) = + -- if it doesn't fit on one line, start on the next (indent 2) + sep [text "if (" <> pPrint d 0 e <> text ")", + nest 2 (pPrint d 0 s)] + pPrint d p (Vifelse e s1 s2) = + -- for readability, don't allow if-else to fit on one line + -- (thus, use "vcat" instead of "sep") + vcat [text "if (" <> pPrint d 0 e <> text ")", + nest 2 (pPrint d 0 s1), + text "else", + nest 2 (pPrint d 0 s2)] + pPrint d p (Vdumpvars level vars) = text "$dumpvars(" <> sepList dvargs (text ",") <> text ");" + where dvargs = (pPrint d 0 level):(map (pPrint d 0) vars) -- no parens when calling a task if it has no arguments pPrint d p (VTask task []) = pPrint d 0 task <> text ";" pPrint d p (VTask task es) = pPrint d 0 task <> text "(" <> commaList d es <> text ");" @@ -474,9 +474,9 @@ instance PPrint VStmt where ppAssert :: PDetail -> Int -> VEventExpr -> [VExpr] -> Doc --ppAssert d i ev (VEString s : es) = text (pretty 78 78 (ppAs1 d i s es)) ppAssert d i ev (VEString s1 : - VEString s2 : es) = text (s1++": assert property (@(") <> - pPrint d 0 ev <> text ")" $$ - ppAs1 d i s2 es + VEString s2 : es) = text (s1++": assert property (@(") <> + pPrint d 0 ev <> text ")" $$ + ppAs1 d i s2 es ppAssert _ _ _ es = internalError ("ppAssert: " ++ show es) ppAs1 :: PDetail -> Int -> String -> [VExpr] -> Doc @@ -512,10 +512,10 @@ isZero (VEWConst _ _ _ 0) = True isZero e = False data VLValue - = VLId VId - | VLConcat [VLValue] - | VLSub VLValue VExpr - deriving (Eq, Show, Generic.Data, Generic.Typeable) + = VLId VId + | VLConcat [VLValue] + | VLSub VLValue VExpr + deriving (Eq, Show, Generic.Data, Generic.Typeable) instance Ord VLValue where compare (VLId lid) (VLId rid) = compare lid rid @@ -523,22 +523,22 @@ instance Ord VLValue where compare _ _ = EQ instance PPrint VLValue where - pPrint d p (VLId i) = pPrint d p i - pPrint d p (VLConcat vs) = text "{ " <> commaList d vs <> text " }" - pPrint d p (VLSub i e) = pPrint d 100 i <> text "[" <> pPrint d 0 e <> text "]" + pPrint d p (VLId i) = pPrint d p i + pPrint d p (VLConcat vs) = text "{ " <> commaList d vs <> text " }" + pPrint d p (VLSub i e) = pPrint d 100 i <> text "[" <> pPrint d 0 e <> text "]" data VCaseArm - = VCaseArm [VExpr] VStmt - | VDefault VStmt - deriving (Eq, Show, Generic.Data, Generic.Typeable) + = VCaseArm [VExpr] VStmt + | VDefault VStmt + deriving (Eq, Show, Generic.Data, Generic.Typeable) instance PPrint VCaseArm where - pPrint d p (VCaseArm es s) = - -- nest the statement 4 spaces under the expr list - -- when it doesn't fit on the same line - sep [ sepList (map (labeledPPrint "NET" d 0) es) (text ",") <> text ":", - nest 4 (pPrint d 0 s) ] - pPrint d p (VDefault s) = text "default:" <+> pPrint d 0 s + pPrint d p (VCaseArm es s) = + -- nest the statement 4 spaces under the expr list + -- when it doesn't fit on the same line + sep [ sepList (map (labeledPPrint "NET" d 0) es) (text ",") <> text ":", + nest 4 (pPrint d 0 s) ] + pPrint d p (VDefault s) = text "default:" <+> pPrint d 0 s -- Always add begin end blocks -- more consistent with a "good" Verilog style vSeq :: [VStmt] -> VStmt @@ -546,9 +546,9 @@ vSeq :: [VStmt] -> VStmt vSeq ss = VSeq ss data VVDecl - = VVDecl VDType (Maybe VRange) [VVar] - | VVDWire (Maybe VRange) VVar VExpr - deriving (Eq, Show, Generic.Data, Generic.Typeable) + = VVDecl VDType (Maybe VRange) [VVar] + | VVDWire (Maybe VRange) VVar VExpr + deriving (Eq, Show, Generic.Data, Generic.Typeable) instance Ord VVDecl where compare (VVDecl _ _ _) (VVDWire _ _ _) = LT @@ -557,17 +557,17 @@ instance Ord VVDecl where compare (VVDWire mrl vl _) (VVDWire mrr vr _) = compare vl vr instance PPrint VVDecl where - pPrint d p (VVDecl t (Just (h, l)) is) = - pPrint d p t <+> ppRange d h l <+> commaList d is <> text ";" - pPrint d p (VVDecl t Nothing is) = - pPrint d p t <+> commaList d is <> text ";" - - pPrint d p (VVDWire (Just (h, l)) i e) = - sep [text "wire" <+> ppRange d h l <+> pPrint d 0 i <+> text "=", - nest 4 (pPrint d 0 e <> text ";")] - pPrint d p (VVDWire Nothing i e) = - sep [text "wire" <+> pPrint d 0 i <+> text "=", - nest 4 (pPrint d 0 e <> text ";")] + pPrint d p (VVDecl t (Just (h, l)) is) = + pPrint d p t <+> ppRange d h l <+> commaList d is <> text ";" + pPrint d p (VVDecl t Nothing is) = + pPrint d p t <+> commaList d is <> text ";" + + pPrint d p (VVDWire (Just (h, l)) i e) = + sep [text "wire" <+> ppRange d h l <+> pPrint d 0 i <+> text "=", + nest 4 (pPrint d 0 e <> text ";")] + pPrint d p (VVDWire Nothing i e) = + sep [text "wire" <+> pPrint d 0 i <+> text "=", + nest 4 (pPrint d 0 e <> text ";")] -- A short cut constructor vVDecl :: VDType -> Maybe VRange -> VVar -> VVDecl @@ -576,20 +576,20 @@ vVDecl t r v = VVDecl t r [v] data VDType = VDReg | VDWire - | VDInput | VDInout | VDOutput -- only for decls - deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable, Enum) + | VDInput | VDInout | VDOutput -- only for decls + deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable, Enum) instance PPrint VDType where - pPrint d p VDReg = text "reg" - pPrint d p VDWire = text "wire" - pPrint d p VDInput = text "input " - pPrint d p VDInout = text "inout " - pPrint d p VDOutput = text "output" + pPrint d p VDReg = text "reg" + pPrint d p VDWire = text "wire" + pPrint d p VDInput = text "input " + pPrint d p VDInout = text "inout " + pPrint d p VDOutput = text "output" data VVar - = VVar VId - | VArray VRange VId - deriving (Eq, Show, Generic.Data, Generic.Typeable) + = VVar VId + | VArray VRange VId + deriving (Eq, Show, Generic.Data, Generic.Typeable) instance Ord VVar where compare (VVar lid) (VArray _ rid) = compare lid rid @@ -598,8 +598,8 @@ instance Ord VVar where compare (VArray lr lid) (VArray rr rid) = compare lid rid instance PPrint VVar where - pPrint d p (VVar i) = pPrint d p i - pPrint d p (VArray (l, h) i) = pPrint d p i <> ppRange d l h + pPrint d p (VVar i) = pPrint d p i + pPrint d p (VArray (l, h) i) = pPrint d p i <> ppRange d l h vvName :: VVar -> VId vvName (VVar i) = i @@ -608,7 +608,7 @@ vvName (VArray _ i) = i -- the VMItem is used for inlined registers data VId = VId String Id (Maybe VMItem) - deriving (Show, Generic.Data, Generic.Typeable) + deriving (Show, Generic.Data, Generic.Typeable) instance Ord VId where compare (VId s1 _ _) (VId s2 _ _) = compare s1 s2 @@ -618,9 +618,9 @@ instance Eq VId where mkVId :: String -> VId mkVId string = VId string - (mkId noPosition - (mkFString string)) - Nothing + (mkId noPosition + (mkFString string)) + Nothing idToVId :: Id -> VId idToVId id = (VId (getIdString id) id Nothing) @@ -632,7 +632,7 @@ getVIdString :: VId -> String getVIdString (VId s _ _) = s instance PPrint VId where - pPrint d p (VId s i _) = text s + pPrint d p (VId s i _) = text s instance HasPosition VId where @@ -641,149 +641,149 @@ instance HasPosition VId where type VRange = (VExpr, VExpr) data VEventExpr - = VEEOr VEventExpr VEventExpr - | VEEposedge VExpr - | VEEnegedge VExpr - | VEE VExpr + = VEEOr VEventExpr VEventExpr + | VEEposedge VExpr + | VEEnegedge VExpr + | VEE VExpr | VEEMacro String VExpr - deriving (Eq, Show, Generic.Data, Generic.Typeable) + deriving (Eq, Show, Generic.Data, Generic.Typeable) instance PPrint VEventExpr where - pPrint d p (VEEOr e1 e2) = - -- if the second expr doesn't fit on the same line, - -- put it on the next line - sep [pPrint d 10 e1 <+> text "or", - pPrint d 10 e2] - pPrint d p (VEEposedge e) = text "posedge" <+> pPrint d 10 e - pPrint d p (VEEnegedge e) = text "negedge" <+> pPrint d 10 e - pPrint d p (VEE e) = pPrint d p e + pPrint d p (VEEOr e1 e2) = + -- if the second expr doesn't fit on the same line, + -- put it on the next line + sep [pPrint d 10 e1 <+> text "or", + pPrint d 10 e2] + pPrint d p (VEEposedge e) = text "posedge" <+> pPrint d 10 e + pPrint d p (VEEnegedge e) = text "negedge" <+> pPrint d 10 e + pPrint d p (VEE e) = pPrint d p e pPrint d p (VEEMacro s e) = text ("`" ++ s) <+> pPrint d (p+1) e data VExpr - = VEConst Integer + = VEConst Integer | VEReal Double - | VEWConst VId Integer Integer Integer -- width base value (what is VId?) - | VEUnknown Integer String - | VEString String - | VETriConst [VTri] - | VEUnOp VId VOp VExpr - | VEOp VId VExpr VOp VExpr - | VEVar VId - | VEConcat [VExpr] - | VEIndex VId VExpr - | VESelect VExpr VExpr VExpr - | VESelect1 VExpr VExpr - | VERepeat VExpr VExpr - | VEIf VExpr VExpr VExpr - | VEFctCall VId [VExpr] + | VEWConst VId Integer Integer Integer -- width base value (what is VId?) + | VEUnknown Integer String + | VEString String + | VETriConst [VTri] + | VEUnOp VId VOp VExpr + | VEOp VId VExpr VOp VExpr + | VEVar VId + | VEConcat [VExpr] + | VEIndex VId VExpr + | VESelect VExpr VExpr VExpr + | VESelect1 VExpr VExpr + | VERepeat VExpr VExpr + | VEIf VExpr VExpr VExpr + | VEFctCall VId [VExpr] | VEMacro String - deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable) + deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable) -- vVar :: String -> VExpr -- vVar = VEVar . VId instance PPrint VExpr where - pPrint d p (VEConst i) = text (itos i) + pPrint d p (VEConst i) = text (itos i) pPrint d p (VEReal r) = text (show r) - pPrint d p v@(VEWConst _ w b i) = text (createVEWConstString w b i) + pPrint d p v@(VEWConst _ w b i) = text (createVEWConstString w b i) --- pPrint d p (VEUnknown w) = text (itos w ++"'b0/*x*/") +-- pPrint d p (VEUnknown w) = text (itos w ++"'b0/*x*/") pPrint d p (VEUnknown w val) = pPrint d p v <> text " /* unspecified value */ " where wint = fromInteger w v = case val of "A" -> (VEWConst (mkVId (itos (aaaa w))) - w 2 (aaaa w)) + w 2 (aaaa w)) "0" -> (VEWConst (mkVId (itos (0::Integer))) - w 2 (0)) + w 2 (0)) "1" -> VETriConst (replicate wint V1) "X" -> VETriConst (replicate wint Vx) "Z" -> VETriConst (replicate wint Vz) _ -> internalError( "Verilog::pPrint: " ++ ppReadable val) - pPrint d p (VEString s) = text $ to_quoted_string s - pPrint d p (VEMacro s) = text ("`" ++ s) - pPrint d p (VETriConst ts) = text (itos (length ts) ++ "'b") <> foldr (<>) (text "") (map (pPrint d 0) ts) - pPrint d p (VEUnOp _ op e) = pparen (p>11) (pPrint d 0 op <> pPrint d 100 e) - pPrint d p (VEOp vid e1 op e2) = ppOp d p vid e1 op e2 - pPrint d p (VEVar i) = pPrint d p i - pPrint d p (VEConcat es) = text "{ " <> commaList d es <> text " }" - pPrint d p (VEIndex i e) = pPrint d 100 i <> text "[" <> pPrint d 0 e <> text "]" - pPrint d p (VESelect e h l) = pPrint d 100 e <> text "[" <> pPrint d 0 h <> text ":" <> pPrint d 0 l <> text "]" - pPrint d p (VESelect1 e pos) = pPrint d 100 e <> text "[" <> pPrint d 0 pos <> text "]" + pPrint d p (VEString s) = text $ to_quoted_string s + pPrint d p (VEMacro s) = text ("`" ++ s) + pPrint d p (VETriConst ts) = text (itos (length ts) ++ "'b") <> foldr (<>) (text "") (map (pPrint d 0) ts) + pPrint d p (VEUnOp _ op e) = pparen (p>11) (pPrint d 0 op <> pPrint d 100 e) + pPrint d p (VEOp vid e1 op e2) = ppOp d p vid e1 op e2 + pPrint d p (VEVar i) = pPrint d p i + pPrint d p (VEConcat es) = text "{ " <> commaList d es <> text " }" + pPrint d p (VEIndex i e) = pPrint d 100 i <> text "[" <> pPrint d 0 e <> text "]" + pPrint d p (VESelect e h l) = pPrint d 100 e <> text "[" <> pPrint d 0 h <> text ":" <> pPrint d 0 l <> text "]" + pPrint d p (VESelect1 e pos) = pPrint d 100 e <> text "[" <> pPrint d 0 pos <> text "]" pPrint d p (VERepeat e1 e2) | isZero e1 = internalError ("Verilog.pPrint - bad VERepeat: " ++ ppReadable (e1, e2)) - pPrint d p (VERepeat e1 e2) = text "{" <> pPrint d 100 e1 <> text "{" <> pPrint d 0 e2 <> text "}}" + pPrint d p (VERepeat e1 e2) = text "{" <> pPrint d 100 e1 <> text "{" <> pPrint d 0 e2 <> text "}}" -- possibly redundant but the Vif analog helps optimize foreign function calls pPrint d p (VEIf e1 e2 e3) | isOne e1 = pPrint d p e2 -- optimize conditional expressions known to be true pPrint d p (VEIf e1 e2 e3) | isZero e1 = pPrint d p e3 -- optimize conditional expressions known to be false pPrint d p (VEIf e1 e2 e3) = - pparen (p > 0) $ sep [ pPrint d 100 e1 <+> text "?", nest 2 (pPrint d 1 e2 <+> text ":"), nest 2 (pPrint d 1 e3) ] + pparen (p > 0) $ sep [ pPrint d 100 e1 <+> text "?", nest 2 (pPrint d 1 e2 <+> text ":"), nest 2 (pPrint d 1 e3) ] pPrint d p (VEFctCall f []) = pPrint d 0 f - pPrint d p (VEFctCall f es) = pPrint d 0 f <> text "(" <> commaList d es <> text ")" + pPrint d p (VEFctCall f es) = pPrint d 0 f <> text "(" <> commaList d es <> text ")" createVEWConstString :: Integer -> Integer -> Integer -> String createVEWConstString width base 0 = (itos width ++ "'" ++ baseChar base ++ "0") - where baseChar :: Integer -> String - baseChar 2 = "b" - baseChar 8 = "o" - baseChar 10 = "d" - baseChar 16 = "h" - baseChar _ = "b" + where baseChar :: Integer -> String + baseChar 2 = "b" + baseChar 8 = "o" + baseChar 10 = "d" + baseChar 16 = "h" + baseChar _ = "b" createVEWConstString width base value = (itos width ++ "'" ++ baseChar base' ++ integerFormat width' base' value) - where baseChar :: Integer -> String - baseChar 2 = "b" - baseChar 8 = "o" - baseChar 10 = "d" - baseChar 16 = "h" - baseChar b = - internalError ("baseChar: unexpected pattern: " ++ show b) - - whichBase :: Integer -> Integer -> Integer - whichBase 0 i = whichBase 16 i - whichBase _ i | i > 2000000000 = 16 - whichBase b _ = fromInteger b - whichWidth 2 w = w - whichWidth 8 w = (w+2) `div` 3 - whichWidth 10 w = 0 - whichWidth 16 w = (w+3) `div` 4 + where baseChar :: Integer -> String + baseChar 2 = "b" + baseChar 8 = "o" + baseChar 10 = "d" + baseChar 16 = "h" + baseChar b = + internalError ("baseChar: unexpected pattern: " ++ show b) + + whichBase :: Integer -> Integer -> Integer + whichBase 0 i = whichBase 16 i + whichBase _ i | i > 2000000000 = 16 + whichBase b _ = fromInteger b + whichWidth 2 w = w + whichWidth 8 w = (w+2) `div` 3 + whichWidth 10 w = 0 + whichWidth 16 w = (w+3) `div` 4 whichWidth w _ = internalError ("whichWidth: unexpected pattern: " ++ show w ) - base' = whichBase base value - width' = whichWidth base' width + base' = whichBase base value + width' = whichWidth base' width data VTri = V0 | V1 | Vx | Vz - deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable, Enum) + deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable, Enum) instance PPrint VTri where - pPrint d p V0 = text "0" - pPrint d p V1 = text "1" - pPrint d p Vx = text "x" - pPrint d p Vz = text "z" + pPrint d p V0 = text "0" + pPrint d p V1 = text "1" + pPrint d p Vx = text "x" + pPrint d p Vz = text "z" data VOp - = VNot -- logical not ! + = VNot -- logical not ! | VInv -- bit wise inverse - | VNeg - | VMul | VQuot | VRem - | VAdd | VSub - | VShL | VShR - | VShLA | VShRA - | VULT | VULE | VUGT | VUGE - | VEQ | VNE | VEQ3 | VNE3 - | VAnd -- bitwise Operations - | VXor - | VOr - | VLAnd -- logical AND and OR - | VLOr - deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable, Enum) + | VNeg + | VMul | VQuot | VRem + | VAdd | VSub + | VShL | VShR + | VShLA | VShRA + | VULT | VULE | VUGT | VUGE + | VEQ | VNE | VEQ3 | VNE3 + | VAnd -- bitwise Operations + | VXor + | VOr + | VLAnd -- logical AND and OR + | VLOr + deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable, Enum) instance PPrint VOp where - pPrint d p op = text (getOpString op) + pPrint d p op = text (getOpString op) getOpString :: VOp -> String getOpString VNot = "!" @@ -827,44 +827,44 @@ getOpString VLOr = "||" getOpFixity :: VOp -> Fixity getOpFixity op = case op of - VNot -> FInfix 15 - VInv -> FInfix 15 + VNot -> FInfix 15 + VInv -> FInfix 15 - VNeg -> FInfix 13 + VNeg -> FInfix 13 - VMul -> FInfixl 11 - VQuot -> FInfixl 11 - VRem -> FInfixl 11 + VMul -> FInfixl 11 + VQuot -> FInfixl 11 + VRem -> FInfixl 11 - VAdd -> FInfixa 10 - VSub -> FInfixl 10 + VAdd -> FInfixa 10 + VSub -> FInfixl 10 - VShL -> FInfix 9 - VShR -> FInfix 9 - VShLA -> FInfix 9 - VShRA -> FInfix 9 + VShL -> FInfix 9 + VShR -> FInfix 9 + VShLA -> FInfix 9 + VShRA -> FInfix 9 - VULT -> FInfix 8 - VULE -> FInfix 8 - VUGE -> FInfix 8 - VUGT -> FInfix 8 + VULT -> FInfix 8 + VULE -> FInfix 8 + VUGE -> FInfix 8 + VUGT -> FInfix 8 - VEQ -> FInfix 7 - VNE -> FInfix 7 + VEQ -> FInfix 7 + VNE -> FInfix 7 VEQ3 -> FInfix 7 VNE3 -> FInfix 7 - VAnd -> FInfixa 6 + VAnd -> FInfixa 6 - VXor -> FInfixa 5 + VXor -> FInfixa 5 - VOr -> FInfixa 4 + VOr -> FInfixa 4 - VLAnd-> FInfixa 3 + VLAnd-> FInfixa 3 - VLOr -> FInfixa 2 + VLOr -> FInfixa 2 --- _ -> internalError ("getOpFixity " ++ show op) +-- _ -> internalError ("getOpFixity " ++ show op) -- Only keep assoc for for Sub. Keep VAdd out of this list, since DC can -- do a better job with optimization without parens Bug 302 @@ -942,14 +942,14 @@ ppMRange d (Just (h,l)) = ppRange d h l ppOp :: PDetail -> Int -> VId -> VExpr -> VOp -> VExpr -> Doc ppOp d pd vid@(VId string id _) p1 op p2 = - let (p, lp, rp) = - case getOpFixity op of - FInfixl p -> (p, p, p+1) - FInfixr p -> (p, p+1, p) - FInfix p -> (p, p+1, p+1) - FInfixa p -> (p, p, p) + let (p, lp, rp) = + case getOpFixity op of + FInfixl p -> (p, p, p+1) + FInfixr p -> (p, p+1, p) + FInfix p -> (p, p+1, p+1) + FInfixa p -> (p, p, p) FPrefix -> (p, p, p ) - in pparen (d > PDReadable || pd>p || pd==p && keepAssoc op) + in pparen (d > PDReadable || pd>p || pd==p && keepAssoc op) (sep [pPrint d lp p1 <> text"" <+> pPrint d 0 op, pPrint d rp p2]) @@ -964,7 +964,7 @@ getVeriInsts (VProgram ms _) = nub (concatMap getInstsFromVModule ms) getInstsFromVMItem (VMComment _ i) = getInstsFromVMItem i getInstsFromVMItem (VMRegGroup _ _ _ i) = getInstsFromVMItem i getInstsFromVMItem (VMGroup _ iss) = - concatMap (concatMap getInstsFromVMItem) iss + concatMap (concatMap getInstsFromVMItem) iss getInstsFromVMItem _ = [] -- true if the declarions have the same type diff --git a/src/comp/Wires.hs b/src/comp/Wires.hs index 003f60f86..b2e851a0f 100644 --- a/src/comp/Wires.hs +++ b/src/comp/Wires.hs @@ -6,9 +6,9 @@ module Wires(ClockId, ClockDomain(..), ResetId, noClockId, noClockDomain, noResetId, noDefaultClockId, noDefaultResetId, WireProps(..), emptyWireProps, - writeClockDomain, readClockDomain, - writeResetId, readResetId - ) where + writeClockDomain, readClockDomain, + writeResetId, readResetId + ) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804) import Prelude hiding ((<>)) diff --git a/src/comp/bluetcl_Main.hsc b/src/comp/bluetcl_Main.hsc index ecfe8885a..8ac1467bb 100644 --- a/src/comp/bluetcl_Main.hsc +++ b/src/comp/bluetcl_Main.hsc @@ -1,8 +1,8 @@ /* * tclAppInit.c -- * - * Provides a default version of the main program and Tcl_AppInit - * procedure for Tcl applications (without Tk). + * Provides a default version of the main program and Tcl_AppInit + * procedure for Tcl applications (without Tk). * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -46,22 +46,22 @@ extern int Itk_SafeInit(Tcl_Interp *interp) ; * * main -- * - * This is the main program for the application. + * This is the main program for the application. * * Results: - * None: Tcl_Main never returns here, so this procedure never - * returns either. + * None: Tcl_Main never returns here, so this procedure never + * returns either. * * Side effects: - * Whatever the application does. + * Whatever the application does. * *---------------------------------------------------------------------- */ int main(argc, argv) - int argc; /* Number of command-line arguments. */ - char **argv; /* Values of command-line arguments. */ + int argc; /* Number of command-line arguments. */ + char **argv; /* Values of command-line arguments. */ { // Initialize Haskell int stat = init_haskellSystem( &argc, &argv ); @@ -75,7 +75,7 @@ main(argc, argv) Tcl_Main(argc, argv, bluetcl_AppInit); - return 0; /* Needed only to prevent compiler warning. */ + return 0; /* Needed only to prevent compiler warning. */ } /* @@ -83,16 +83,16 @@ main(argc, argv) * * Tcl_AppInit -- * - * This procedure performs application-specific initialization. - * Most applications, especially those that incorporate additional - * packages, will have their own version of this procedure. + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. * * Results: - * Returns a standard Tcl completion code, and leaves an error - * message in the interp's result if an error occurs. + * Returns a standard Tcl completion code, and leaves an error + * message in the interp's result if an error occurs. * * Side effects: - * Depends on the startup script. + * Depends on the startup script. * *---------------------------------------------------------------------- */ @@ -128,7 +128,7 @@ char userStartFile[] = "~/.bluetclrc"; int bluetcl_AppInit(interp) - Tcl_Interp *interp; /* Interpreter for application. */ + Tcl_Interp *interp; /* Interpreter for application. */ { // TCL library must be loaded from $BLUESPECDIR, so setup the right tcllibrary path here diff --git a/src/comp/bluewish_Main.hsc b/src/comp/bluewish_Main.hsc index 4ed6bbde5..616c44517 100644 --- a/src/comp/bluewish_Main.hsc +++ b/src/comp/bluewish_Main.hsc @@ -1,8 +1,8 @@ /* * tkAppInit.c -- * - * Provides a default version of the Tcl_AppInit procedure for - * use in wish and similar Tk-based applications. + * Provides a default version of the Tcl_AppInit procedure for + * use in wish and similar Tk-based applications. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -45,22 +45,22 @@ extern int Itk_SafeInit(Tcl_Interp *interp) ; * * main -- * - * This is the main program for the application. + * This is the main program for the application. * * Results: - * None: Tk_Main never returns here, so this procedure never - * returns either. + * None: Tk_Main never returns here, so this procedure never + * returns either. * * Side effects: - * Whatever the application does. + * Whatever the application does. * *---------------------------------------------------------------------- */ int main(argc, argv) - int argc; /* Number of command-line arguments. */ - char **argv; /* Values of command-line arguments. */ + int argc; /* Number of command-line arguments. */ + char **argv; /* Values of command-line arguments. */ { // Initialize Haskell int stat = init_haskellSystem( &argc, &argv ); @@ -73,7 +73,7 @@ main(argc, argv) #endif Tk_Main(argc, argv, bluewish_AppInit); - return 0; /* Needed only to prevent compiler warning. */ + return 0; /* Needed only to prevent compiler warning. */ } /* @@ -81,16 +81,16 @@ main(argc, argv) * * Tcl_AppInit -- * - * This procedure performs application-specific initialization. - * Most applications, especially those that incorporate additional - * packages, will have their own version of this procedure. + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. * * Results: - * Returns a standard Tcl completion code, and leaves an error - * message in the interp's result if an error occurs. + * Returns a standard Tcl completion code, and leaves an error + * message in the interp's result if an error occurs. * * Side effects: - * Depends on the startup script. + * Depends on the startup script. * *---------------------------------------------------------------------- */ @@ -120,7 +120,7 @@ char userStartFile[] = "~/.bluetclrc"; int bluewish_AppInit(interp) - Tcl_Interp *interp; /* Interpreter for application. */ + Tcl_Interp *interp; /* Interpreter for application. */ { // TCL library must be loaded from $BLUESPECDIR, so setup the right tcllibrary path here diff --git a/src/comp/bsc.hs b/src/comp/bsc.hs index cd6eb5f76..5a0bc090b 100644 --- a/src/comp/bsc.hs +++ b/src/comp/bsc.hs @@ -361,7 +361,7 @@ compilePackage :: IO (Bool, BinMap HeapData, HashMap) compilePackage errh - flags -- user switches + flags -- user switches dumpnames tStart binmap0 @@ -375,11 +375,11 @@ compilePackage -- Values needed for the Environment module let env = [("compilerVersion",iMkString $ version), - ("date", iMkString $ show clkTime), + ("date", iMkString $ show clkTime), ("epochTime", iMkLitSize 32 $ floor epochTime), ("buildVersion", iMkLitSize 32 $ buildnum), ("genPackageName", iMkString $ getIdBaseString pkgId), - ("testAssert", iMkRealBool $ testAssert flags) + ("testAssert", iMkRealBool $ testAssert flags) ] start flags DFimports @@ -478,7 +478,7 @@ compilePackage -- Simplify a little start flags DFsimplified - let mod' = simplify flags mod + let mod' = simplify flags mod t <- dump errh flags t DFsimplified dumpnames mod' stats flags DFsimplified mod' @@ -2204,11 +2204,11 @@ compileCDefToIDef errh flags dumpnames symt ipkg def = t <- dump errh flags t DFtypecheck dumpnames cpkg_chk start flags DFsimplified - let cpkg_simp@(CPackage _ _ _ _ [def'] _) = simplify flags cpkg_chk + let cpkg_simp@(CPackage _ _ _ _ [def'] _) = simplify flags cpkg_chk t <- dump errh flags t DFsimplified dumpnames cpkg_simp start flags DFinternal - let idef = iConvDef errh flags symt ipkg def' + let idef = iConvDef errh flags symt ipkg def' t <- dump errh flags t DFinternal dumpnames idef return (idef, not tcErrors) diff --git a/src/comp/showrules.hs b/src/comp/showrules.hs index fdbb39b9e..fb5c673c4 100644 --- a/src/comp/showrules.hs +++ b/src/comp/showrules.hs @@ -101,7 +101,7 @@ defaultOptions bluespecdir = original_path :: String -> [String] original_path bluespecdir = [ "." - , bluespecdir ++ "/Libraries" + , bluespecdir ++ "/Libraries" ] -- Description of command-line options