|
| 1 | +-- | Atom C code generation. |
| 2 | +module Language.Atom.Code |
| 3 | + ( Config (..) |
| 4 | + , writeC |
| 5 | + , defaults |
| 6 | + , cType |
| 7 | + , RuleCoverage |
| 8 | + ) where |
| 9 | + |
| 10 | +import Data.List |
| 11 | +import Data.Maybe |
| 12 | +import Text.Printf |
| 13 | + |
| 14 | +import Language.Atom.Analysis |
| 15 | +import Language.Atom.Elaboration |
| 16 | +import Language.Atom.Expressions |
| 17 | +import Language.Atom.Scheduling |
| 18 | + |
| 19 | +-- | C code configuration parameters. |
| 20 | +data Config = Config |
| 21 | + { cFuncName :: String -- ^ Alternative primary function name. Leave empty to use compile name. |
| 22 | + , cStateName :: String -- ^ Name of state variable structure. Default: state |
| 23 | + , cCode :: [Name] -> [Name] -> [(Name, Type)] -> (String, String) -- ^ Custom C code to insert above and below, given assertion names, coverage names, and probe names and types. |
| 24 | + , cRuleCoverage :: Bool -- ^ Enable rule coverage tracking. |
| 25 | + , cAssert :: Bool -- ^ Enable assertions and functional coverage. |
| 26 | + , cAssertName :: String -- ^ Name of assertion function. Type: void assert(int, bool, uint64_t); |
| 27 | + , cCoverName :: String -- ^ Name of coverage function. Type: void cover(int, bool, uint64_t); |
| 28 | + } |
| 29 | + |
| 30 | +-- | Default C code configuration parameters (default function name, no pre/post code, ANSI C types). |
| 31 | +defaults :: Config |
| 32 | +defaults = Config |
| 33 | + { cFuncName = "" |
| 34 | + , cStateName = "state" |
| 35 | + , cCode = \ _ _ _ -> ("", "") |
| 36 | + , cRuleCoverage = True |
| 37 | + , cAssert = True |
| 38 | + , cAssertName = "assert" |
| 39 | + , cCoverName = "cover" |
| 40 | + } |
| 41 | + |
| 42 | +showConst :: Const -> String |
| 43 | +showConst c = case c of |
| 44 | + CBool True -> "true" |
| 45 | + CBool False -> "false" |
| 46 | + CInt8 a -> show a |
| 47 | + CInt16 a -> show a |
| 48 | + CInt32 a -> show a ++ "L" |
| 49 | + CInt64 a -> show a ++ "LL" |
| 50 | + CWord8 a -> show a |
| 51 | + CWord16 a -> show a |
| 52 | + CWord32 a -> show a ++ "UL" |
| 53 | + CWord64 a -> show a ++ "ULL" |
| 54 | + CFloat a -> show a ++ "F" |
| 55 | + CDouble a -> show a |
| 56 | + |
| 57 | + |
| 58 | +-- | C99 type naming rules. |
| 59 | +cType :: Type -> String |
| 60 | +cType t = case t of |
| 61 | + Bool -> "bool" |
| 62 | + Int8 -> "int8_t" |
| 63 | + Int16 -> "int16_t" |
| 64 | + Int32 -> "int32_t" |
| 65 | + Int64 -> "int64_t" |
| 66 | + Word8 -> "uint8_t" |
| 67 | + Word16 -> "uint16_t" |
| 68 | + Word32 -> "uint32_t" |
| 69 | + Word64 -> "uint64_t" |
| 70 | + Float -> "float" |
| 71 | + Double -> "double" |
| 72 | + |
| 73 | +codeUE :: Config -> [(UE, String)] -> String -> (UE, String) -> String |
| 74 | +codeUE config ues d (ue, n) = d ++ cType (typeOf ue) ++ " " ++ n ++ " = " ++ basic operands ++ ";\n" |
| 75 | + where |
| 76 | + operands = map (fromJust . flip lookup ues) $ ueUpstream ue |
| 77 | + basic :: [String] -> String |
| 78 | + basic operands = concat $ case ue of |
| 79 | + UVRef (UV _ n _) -> [cStateName config, ".", n] |
| 80 | + UVRef (UVArray (UA _ n _) _) -> [cStateName config, ".", n, "[", a, "]"] |
| 81 | + UVRef (UVArray (UAExtern n _) _) -> [n, "[", a, "]"] |
| 82 | + UVRef (UVExtern n _) -> [n] |
| 83 | + UCast _ _ -> ["(", cType (typeOf ue), ") ", a] |
| 84 | + UConst c -> [showConst c] |
| 85 | + UAdd _ _ -> [a, " + ", b] |
| 86 | + USub _ _ -> [a, " - ", b] |
| 87 | + UMul _ _ -> [a, " * ", b] |
| 88 | + UDiv _ _ -> [a, " / ", b] |
| 89 | + UMod _ _ -> [a, " % ", b] |
| 90 | + UNot _ -> ["! ", a] |
| 91 | + UAnd _ -> intersperse " && " operands |
| 92 | + UBWNot _ -> ["~ ", a] |
| 93 | + UBWAnd _ _ -> [a, " & ", b] |
| 94 | + UBWOr _ _ -> [a, " | ", b] |
| 95 | + UShift _ n -> (if n >= 0 then [a, " << ", show n] else [a, " >> ", show (negate n)]) |
| 96 | + UEq _ _ -> [a, " == ", b] |
| 97 | + ULt _ _ -> [a, " < " , b] |
| 98 | + UMux _ _ _ -> [a, " ? " , b, " : ", c] |
| 99 | + UF2B _ -> ["*((", ct Word32, " *) &(", a, "))"] |
| 100 | + UD2B _ -> ["*((", ct Word64, " *) &(", a, "))"] |
| 101 | + UB2F _ -> ["*((", ct Float , " *) &(", a, "))"] |
| 102 | + UB2D _ -> ["*((", ct Double, " *) &(", a, "))"] |
| 103 | + where |
| 104 | + ct = cType |
| 105 | + a = head operands |
| 106 | + b = operands !! 1 |
| 107 | + c = operands !! 2 |
| 108 | + |
| 109 | +type RuleCoverage = [(Name, Int, Int)] |
| 110 | + |
| 111 | +writeC :: Name -> Config -> StateHierarchy -> [Rule] -> Schedule -> [Name] -> [Name] -> [(Name, Type)] -> IO RuleCoverage |
| 112 | +writeC name config state rules schedule assertionNames coverageNames probeNames = do |
| 113 | + writeFile (name ++ ".c") c |
| 114 | + writeFile (name ++ ".h") h |
| 115 | + return [ (ruleName r, div (ruleId r) 32, mod (ruleId r) 32) | r <- rules' ] |
| 116 | + where |
| 117 | + (preCode, postCode) = cCode config assertionNames coverageNames probeNames |
| 118 | + c = unlines |
| 119 | + [ "#include <stdbool.h>" |
| 120 | + , "#include <stdint.h>" |
| 121 | + , "" |
| 122 | + , preCode |
| 123 | + , "" |
| 124 | + , "static " ++ cType Word64 ++ " __global_clock = 0;" |
| 125 | + , codeIf (cRuleCoverage config) $ "static const " ++ cType Word32 ++ " __coverage_len = " ++ show covLen ++ ";" |
| 126 | + , codeIf (cRuleCoverage config) $ "static " ++ cType Word32 ++ " __coverage[" ++ show covLen ++ "] = {" ++ (concat $ intersperse ", " $ replicate covLen "0") ++ "};" |
| 127 | + , codeIf (cRuleCoverage config) $ "static " ++ cType Word32 ++ " __coverage_index = 0;" |
| 128 | + , declState True $ StateHierarchy (cStateName config) [state] |
| 129 | + , concatMap (codeRule config) rules' |
| 130 | + , codeAssertionChecks config assertionNames coverageNames rules |
| 131 | + , "void " ++ funcName ++ "() {" |
| 132 | + , concatMap (codePeriodPhase config) schedule |
| 133 | + , " __global_clock = __global_clock + 1;" |
| 134 | + , "}" |
| 135 | + , "" |
| 136 | + , postCode |
| 137 | + ] |
| 138 | + |
| 139 | + h = unlines |
| 140 | + [ "#include <stdbool.h>" |
| 141 | + , "#include <stdint.h>" |
| 142 | + , "" |
| 143 | + , "void " ++ funcName ++ "();" |
| 144 | + , "" |
| 145 | + , declState False $ StateHierarchy (cStateName config) [state] |
| 146 | + ] |
| 147 | + |
| 148 | + funcName = if null (cFuncName config) then name else cFuncName config |
| 149 | + |
| 150 | + rules' :: [Rule] |
| 151 | + rules' = concat [ r | (_, _, r) <- schedule ] |
| 152 | + |
| 153 | + covLen = 1 + div (maximum $ map ruleId rules') 32 |
| 154 | + |
| 155 | +codeIf :: Bool -> String -> String |
| 156 | +codeIf a b = if a then b else "" |
| 157 | + |
| 158 | +declState :: Bool -> StateHierarchy -> String |
| 159 | +declState define a = (if define then "" else "extern ") ++ init (init (f1 "" a)) ++ (if define then " =\n" ++ f2 "" a else "") ++ ";\n" |
| 160 | + where |
| 161 | + f1 i a = case a of |
| 162 | + StateHierarchy name items -> i ++ "struct { /* " ++ name ++ " */\n" ++ concatMap (f1 (" " ++ i)) items ++ i ++ "} " ++ name ++ ";\n" |
| 163 | + StateVariable name c -> i ++ cType (typeOf c) ++ " " ++ name ++ ";\n" |
| 164 | + StateArray name c -> i ++ cType (typeOf $ head c) ++ " " ++ name ++ "[" ++ show (length c) ++ "];\n" |
| 165 | + |
| 166 | + f2 i a = case a of |
| 167 | + StateHierarchy name items -> i ++ "{ /* " ++ name ++ " */\n" ++ intercalate ",\n" (map (f2 (" " ++ i)) items) ++ "\n" ++ i ++ "}" |
| 168 | + StateVariable name c -> i ++ "/* " ++ name ++ " */ " ++ showConst c |
| 169 | + StateArray name c -> i ++ "/* " ++ name ++ " */ {" ++ intercalate ", " (map showConst c) ++ "}" |
| 170 | + |
| 171 | +codeRule :: Config -> Rule -> String |
| 172 | +codeRule config rule@(Rule _ _ _ _ _ _ _) = |
| 173 | + "/* " ++ show rule ++ " */\n" ++ |
| 174 | + "static void __r" ++ show (ruleId rule) ++ "() {\n" ++ |
| 175 | + concatMap (codeUE config ues " ") ues ++ |
| 176 | + " if (" ++ id (ruleEnable rule) ++ ") {\n" ++ |
| 177 | + concatMap codeAction (ruleActions rule) ++ |
| 178 | + codeIf (cRuleCoverage config) (" __coverage[" ++ covWord ++ "] = __coverage[" ++ covWord ++ "] | (1 << " ++ covBit ++ ");\n") ++ |
| 179 | + " }\n" ++ |
| 180 | + concatMap codeAssign (ruleAssigns rule) ++ |
| 181 | + "}\n\n" |
| 182 | + where |
| 183 | + ues = topo $ allUEs rule |
| 184 | + id ue = fromJust $ lookup ue ues |
| 185 | + |
| 186 | + codeAction :: (([String] -> String), [UE]) -> String |
| 187 | + codeAction (f, args) = " " ++ f (map id args) ++ ";\n" |
| 188 | + |
| 189 | + covWord = show $ div (ruleId rule) 32 |
| 190 | + covBit = show $ mod (ruleId rule) 32 |
| 191 | + |
| 192 | + codeAssign :: (UV, UE) -> String |
| 193 | + codeAssign (uv, ue) = concat [" ", lh, " = ", id ue, ";\n"] |
| 194 | + where |
| 195 | + lh = case uv of |
| 196 | + UV _ n _ -> concat [cStateName config, ".", n] |
| 197 | + UVArray (UA _ n _) index -> concat [cStateName config, ".", n, "[", id index, "]"] |
| 198 | + UVArray (UAExtern n _) index -> concat [n, "[", id index, "]"] |
| 199 | + UVExtern n _ -> n |
| 200 | + |
| 201 | +codeRule _ _ = "" |
| 202 | + |
| 203 | +codeAssertionChecks :: Config -> [Name] -> [Name] -> [Rule] -> String |
| 204 | +codeAssertionChecks config assertionNames coverageNames rules = codeIf (cAssert config) $ |
| 205 | + "static void __assertion_checks() {\n" ++ |
| 206 | + concatMap (codeUE config ues " ") ues ++ |
| 207 | + concat [ " if (" ++ id enable ++ ") " ++ cAssertName config ++ "(" ++ assertionId name ++ ", " ++ id check ++ ", __global_clock);\n" | Assert name enable check <- rules ] ++ |
| 208 | + concat [ " if (" ++ id enable ++ ") " ++ cCoverName config ++ "(" ++ coverageId name ++ ", " ++ id check ++ ", __global_clock);\n" | Cover name enable check <- rules ] ++ |
| 209 | + "}\n\n" |
| 210 | + where |
| 211 | + ues = topo $ concat [ [a, b] | Assert _ a b <- rules ] ++ concat [ [a, b] | Cover _ a b <- rules ] |
| 212 | + id ue = fromJust $ lookup ue ues |
| 213 | + assertionId :: Name -> String |
| 214 | + assertionId name = show $ fromJust $ elemIndex name assertionNames |
| 215 | + coverageId :: Name -> String |
| 216 | + coverageId name = show $ fromJust $ elemIndex name coverageNames |
| 217 | + |
| 218 | +codePeriodPhase :: Config -> (Int, Int, [Rule]) -> String |
| 219 | +codePeriodPhase config (period, phase, rules) = unlines |
| 220 | + [ printf " {" |
| 221 | + , printf " static %s __scheduling_clock = %i;" (cType clockType) phase |
| 222 | + , printf " if (__scheduling_clock == 0) {" |
| 223 | + , intercalate "\n" $ map callRule rules |
| 224 | + , printf " __scheduling_clock = %i;" (period - 1) |
| 225 | + , printf " }" |
| 226 | + , printf " else {" |
| 227 | + , printf " __scheduling_clock = __scheduling_clock - 1;" |
| 228 | + , printf " }" |
| 229 | + , printf " }" |
| 230 | + ] |
| 231 | + where |
| 232 | + clockType | period < 2 ^ 8 = Word8 |
| 233 | + | period < 2 ^ 16 = Word16 |
| 234 | + | otherwise = Word32 |
| 235 | + callRule r = concat [" ", codeIf (cAssert config) "__assertion_checks(); ", "__r", show (ruleId r), "(); /* ", show r, " */"] |
| 236 | + |
0 commit comments