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