1{- 2 Checks: Mackerel compile-time checks 3 4 Part of Mackerel: a strawman device definition DSL for Barrelfish 5 6 Copyright (c) 2007, 2008, ETH Zurich. 7 All rights reserved. 8 9 This file is distributed under the terms in the attached LICENSE file. 10 If you do not find this file, copies can be found by writing to: 11 ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group. 12-} 13 14module Checks where 15 16import MackerelParser 17import Text.ParserCombinators.Parsec 18import Text.ParserCombinators.Parsec.Pos 19import System.FilePath 20import qualified TypeName as TN 21import qualified TypeTable as TT 22import qualified RegisterTable as RT 23import qualified Space 24import qualified Dev 25import qualified Fields 26import qualified Data.Maybe 27 28import Text.Printf 29import Data.List 30import System.Environment 31import System.Exit 32import System.IO 33 34data MacError = MacError SourcePos String 35 deriving Show 36 37data CheckResult = Either String [ MacError ] 38 39check_all :: String -> Dev.Rec -> Maybe [String] 40check_all inf dev = 41 let errors = (check_devname inf dev) ++ 42 (check_rous dev) ++ 43 (check_dous dev) ++ 44 (check_undef_consts dev) ++ 45 (check_undef_regtypes dev) ++ 46 (check_dup_types dev ) ++ 47 (check_dup_regs dev ) ++ 48 (check_dup_vals dev ) ++ 49 (check_overlap dev ) ++ 50 (check_undef_spaces dev ) 51 in 52 if (length errors) > 0 53 then 54 let sort_errs = [ ((sourceName p), 55 (sourceLine p), 56 (sourceColumn p), 57 s) | (MacError p s) <- errors ] 58 in Just [ printf "%s:%d:%d: %s" n l c s | (n,l,c,s) <- sort sort_errs ] 59 else Nothing 60 61 62check_devname :: String -> Dev.Rec -> [ MacError ] 63check_devname inf dev = 64 let (devname_f, ext) = splitExtension $ takeFileName inf 65 devname_d = Dev.name dev 66 in 67 if devname_f /= devname_d 68 then [ (MacError (initialPos inf) 69 (printf "File %s describes dev %s not %s" inf devname_d devname_f))] 70 else [] 71 72-- 73-- Check for Registers of Unusual Size 74-- 75 76check_rous :: Dev.Rec -> [ MacError ] 77check_rous d = 78 [ make_rous_error t 79 | t@(TT.RegFormat {}) <- (Dev.types d), check_rous_type t ] 80 ++ 81 [ make_rous_error t 82 | RT.Rec { RT.tpe = t@(TT.ConstType {}) } <- (Dev.registers d), check_rous_type t ] 83 84check_rous_type t = notElem (TT.tt_size t) [ 8, 16, 32, 64 ] 85make_rous_error t = 86 (MacError (TT.pos t) 87 (if TT.tt_size t == -1 88 then 89 (printf "Register type '%s' (%s) has no width() specifier" 90 (TT.type_name t) (TT.tt_desc t)) 91 else 92 (printf "Type '%s' (%s) is a Register Of Unusual Size (%d bits)" 93 (TT.type_name t) (TT.tt_desc t) (TT.tt_size t)))) 94 95-- 96-- Check for Data types of Unusual Size 97-- 98 99check_dous :: Dev.Rec -> [ MacError ] 100check_dous d = 101 [ make_dous_error t | t@(TT.DataFormat {}) <- (Dev.types d), check_dous_type t ] 102 103-- XXX Make this a bit more lenient. 104check_dous_type t = notElem (TT.tt_size t) [ 8, 16, 32, 64, 96, 128, 160, 224, 105 256, 384, 512 ] 106make_dous_error t = 107 (MacError (TT.pos t) 108 (printf "Data type '%s' (%s) is a Datatype Of Unusual Size (%d bits)" 109 (TT.type_name t) 110 (TT.tt_desc t) 111 (TT.tt_size t))) 112 113-- 114-- Check for undefined constant types: every use of a constant type in 115-- a register definition must have a corresponding constant type 116-- definition. 117-- 118check_undef_consts :: Dev.Rec -> [ MacError ] 119check_undef_consts d = 120 let clist = [ (TT.tt_name c) | c@(TT.ConstType {}) <- Dev.all_types d ] 121 in 122 concat [ check_undef_consts_reg r clist | r <- (Dev.registers d) ] 123 124check_undef_consts_reg :: RT.Rec -> [ TN.Name ] -> [MacError] 125check_undef_consts_reg r clist = 126 [ make r f | f <- (RT.fl r), check r clist f ] 127 where 128 check r clist f = 129 case Fields.tpe f of 130 Nothing -> False 131 Just t -> notElem t clist 132 make r f = 133 (MacError (Fields.pos f) 134 (printf "Field '%s' (%s) of register '%s' (%s) is of undefined type '%s'" 135 (Fields.name f) (Fields.desc f) (RT.name r) (RT.desc r) (TN.toString $ Data.Maybe.fromJust $ Fields.tpe f))) 136 137-- 138-- Check for undefined register types (every register must have a type) 139-- 140check_undef_regtypes :: Dev.Rec -> [ MacError ] 141check_undef_regtypes d = 142 [ make r | r <- (Dev.registers d), not (check r (Dev.types d)) ] 143 where 144 check r ttbl = TN.is_builtin_type (RT.typename r) 145 || elem (RT.typename r) [ (TT.tt_name t) | t <- (Dev.types d)] 146 make r = (MacError (RT.pos r) 147 (printf "Register '%s' (%s) is of undefined type '%s'" 148 (RT.name r) (RT.desc r) (RT.origtype r) )) 149 150 151 152check_dups :: [String] -> ( String -> MacError ) -> [ MacError ] 153check_dups names errfn = [ errfn n | n <- names \\ nub names ] 154 155-- 156-- Duplicate types 157-- 158check_dup_types :: Dev.Rec -> [ MacError ] 159check_dup_types d = 160 let names = map TT.tt_name (Dev.types d) 161 dups = [ n | n <- names \\ nub names ] 162 in [ make_dup_type_error d n | n <- dups ] 163 164make_dup_type_error :: Dev.Rec -> TN.Name -> MacError 165make_dup_type_error d n = 166 let cl = [ (TT.pos c, TT.tt_desc c) | c <- (Dev.types d), (TT.tt_name c) == n ] 167 l = sort cl 168 (p, _) = head l 169 in 170 (MacError p 171 (printf "Type name '%s' is multiply defined, as:%s" (TN.toString n) 172 (concat [ (printf "\n '%s' (%s)" td (show tp))::String | (tp, td) <- l ]))) 173 174-- 175-- Duplicate register names 176-- 177check_dup_regs :: Dev.Rec -> [ MacError ] 178check_dup_regs d = 179 check_dups (map RT.name rtbl) (make_dup_reg_error rtbl) 180 where rtbl = Dev.registers d 181 182make_dup_reg_error :: [RT.Rec] -> String -> MacError 183make_dup_reg_error rtbl n = 184 let l = [ (RT.pos c, RT.desc c) | c <- rtbl, (RT.name c) == n ] 185 (p, _) = head l 186 in 187 (MacError p 188 (printf "Register '%s' is multiply defined, as:%s" n 189 (concat [ (printf "\n '%s' (%s)" td (show tp))::String | (tp, td) <- l ]))) 190 191-- 192-- Duplicate constant values 193-- 194check_dup_vals :: Dev.Rec -> [ MacError ] 195check_dup_vals d = 196 let cvals = concat([ [ v | v <- TT.tt_vals c ] | c@(TT.ConstType {}) <- (Dev.types d) ]) 197 in check_dups (map TT.cname cvals) (make_dup_val_error cvals) 198 199make_dup_val_error cvl n = 200 let l = [ (TT.cpos c, TT.cdesc c) | c <- cvl, (TT.cname c) == n ] 201 (p, _) = head l 202 in 203 (MacError p 204 (printf "Constant value '%s' is multiply defined, as:%s" n 205 (concat [ (printf "\n '%s' (%s)" td (show tp))::String | (tp, td) <- l ]))) 206 207-- 208-- Undefined address spaces 209-- 210check_undef_spaces :: Dev.Rec -> [MacError ] 211check_undef_spaces d = 212 let l = [ (RT.spc_id r, RT.pos r) 213 | r <- (Dev.registers d), (RT.spc r) == Space.UndefinedSpace ] 214 in 215 [ MacError p (printf "Undefined address space '%s'" n) 216 | (n,p) <- l ] 217 218-- 219-- Registers overlapping 220-- 221check_overlap :: Dev.Rec -> [ MacError ] 222check_overlap d = 223 let l = [ r | r <- Dev.registers d, not (RT.also r) ] 224 in 225 check_overlap1 l 226 227check_overlap1 [] = [] 228check_overlap1 [s] = [] 229check_overlap1 (h:t) = 230 (check_overlap1 t) 231 ++ 232 [ make_overlap_error h te | te <- t, RT.overlap h te ] 233 234make_overlap_error :: RT.Rec -> RT.Rec -> MacError 235make_overlap_error r1 r2 = 236 MacError (RT.pos r1) (printf "Register '%s' overlaps with register '%s' at '%s'" (RT.name r1) (RT.name r2) (show (RT.pos r2)) ) 237