1{- 
2  Register table: list of all registers
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 RegisterTable where
15
16import Data.List
17import MackerelParser
18import Text.ParserCombinators.Parsec
19import Attr
20import qualified Fields as F
21import qualified TypeTable as TT
22import qualified TypeName as TN
23import qualified Space
24
25{--------------------------------------------------------------------
26Register table: list of all registers 
27--------------------------------------------------------------------}
28
29data Rec = Rec { name :: String,        -- Unqualified name of register 
30                 fl :: [F.Rec],         -- List of fields (may be empty)
31                 attr :: Attr,          -- Attribute (for non-field types)
32                 tpe :: TT.Rec,         -- Type of this register
33                 origtype :: String,    -- Original name of register type
34                 size :: Integer,       -- Width in bits
35                 also :: Bool,          -- Only register at this address?
36                 desc :: String,        -- Description string
37                 spc_id :: String,      -- Address space identifier
38                 spc :: Space.Rec,      -- Address space record
39                 base :: String,        -- Base variable name
40                 offset :: Integer,     -- Offset of register from base
41                 arr :: ArrayLoc,       -- Array of locations
42                 pos :: SourcePos       -- Source code position
43               }
44         deriving Show
45
46--
47-- Building the register table
48--
49make_table :: [TT.Rec] -> [AST] -> String -> BitOrder -> [Space.Rec] -> [Rec]
50make_table rtinfo decls dn order spt = 
51    concat [ (make_reginfo rtinfo d dn order spt) | d <- decls ]
52
53
54make_regproto :: String -> Attr -> Bool -> RegLoc -> String -> SourcePos -> [Space.Rec] -> TT.Rec -> String
55                 -> Rec
56make_regproto n atrv als rloc dsc p spt t tname =
57    let (si, s, b, o) = get_location rloc spt
58    in
59      Rec { name = n,
60            fl = [],
61            attr =atrv, 
62            tpe = t,
63            origtype = tname,
64            size = 0,
65            also = als,
66            desc = dsc, 
67            spc_id = si,
68            spc = s,
69            base = b, 
70            offset = o, 
71            arr = (ArrayListLoc []),
72            pos = p } 
73
74make_reginfo :: [TT.Rec] -> AST -> String -> BitOrder -> [Space.Rec] -> [Rec]
75
76make_reginfo rtinfo (RegArray n atrv als rloc aloc dsc (TypeDefn decls) p) dn order spt =
77    let t = (TT.get_rtrec rtinfo (TN.fromParts dn n))
78        r = make_regproto n atrv als rloc dsc p spt t "<inline>"
79    in
80      [ r { fl = F.make_list dn atrv order 0 decls,
81            size = TT.tt_size t,
82            arr = aloc } ]
83
84make_reginfo rtinfo (RegArray n atrv als rloc aloc dsc tr@(TypeRef tname dname) p) dn order spt = 
85  let tn = TN.fromRef tr dn
86      rt = (TT.get_rtrec rtinfo tn)
87      r = make_regproto n atrv als rloc dsc p spt rt tname
88  in case rt of
89    t@(TT.Primitive {}) -> [ r { size = (TT.tt_size rt),
90                                 arr = aloc } ]
91    t@(TT.RegFormat {}) -> [ r { fl = F.inherit_list atrv (TT.fields rt),
92                                 size = (TT.tt_size rt),
93                                 arr = aloc } ]
94    t@(TT.DataFormat {}) -> [ r { fl = F.inherit_list atrv (TT.fields rt),
95                                 size = (TT.tt_size rt),
96                                 arr = aloc } ]
97    t@(TT.ConstType {}) -> [ r { size = case (TT.tt_width rt) of
98                                   Nothing -> -1
99                                   Just i  -> i,
100                                 arr = aloc } ]
101
102make_reginfo rtinfo (Register n atrv als rloc dsc (TypeDefn decls) p) dn order spt =
103    let tn = TN.fromParts dn n
104        td = TT.get_rtrec rtinfo tn
105        r = make_regproto n atrv als rloc dsc p spt td "<inline>"
106    in
107      [ r { fl = F.make_list dn atrv order 0 decls,
108            size = TT.tt_size td,
109            arr = (ArrayListLoc []) } ]
110
111make_reginfo rtinfo (Register n atrv als rloc dsc tr@(TypeRef tname dname) p) dn order spt =
112  let tn = TN.fromRef tr dn
113      rt = (TT.get_rtrec rtinfo tn)
114      r = make_regproto n atrv als rloc dsc p spt rt tname
115  in case rt of
116    t@(TT.Primitive {}) -> [ r { size = (TT.tt_size rt),
117                                 arr = (ArrayListLoc []) } ]
118    t@(TT.RegFormat {}) -> [ r { fl = F.inherit_list atrv (TT.fields rt),
119                                 size = (TT.tt_size rt),
120                                 arr = (ArrayListLoc []) } ]
121    t@(TT.DataFormat {}) -> [ r { fl = F.inherit_list atrv (TT.fields rt),
122                                 size = (TT.tt_size rt),
123                                 arr = (ArrayListLoc []) } ]
124    t@(TT.ConstType {}) -> [ r { size = case (TT.tt_width rt) of
125                                   Nothing -> -1
126                                   Just i  -> i,
127                                 arr = (ArrayListLoc []) } ]
128
129make_reginfo rtinfo _ _ _ _ = []
130
131get_location :: RegLoc -> [Space.Rec] -> ( String, Space.Rec, String, Integer )
132get_location RegNoLoc _ = 
133    ( "", Space.NoSpace, "", 0)
134get_location (RegLoc s b o) spt = 
135    ( s, Space.lookup s spt, b, o)
136
137overlap :: Rec -> Rec -> Bool
138overlap r1 r2
139    | spc_id r1 /= spc_id r2 = False
140    | base r1 /= base r2 = False
141    | spc r1 == Space.NoSpace = False
142    | spc r2 == Space.NoSpace = False
143    | otherwise = compare_extents (extents r1) (extents r2)
144
145compare_extents :: [ (Integer, Integer) ] -> [ (Integer, Integer) ] -> Bool
146compare_extents [] _ = False
147compare_extents _ [] = False
148compare_extents (e:es) (f:fs)
149    | extent_overlap e f = True
150    | otherwise =
151        if fst e < fst f
152            then compare_extents es (f:fs)
153            else compare_extents (e:es) fs
154
155extent_overlap :: (Integer, Integer) ->  (Integer, Integer) -> Bool
156extent_overlap (b1, o1) (b2, o2)
157    |  b1 > b2 = ( b2 + o2 > b1 )
158    | otherwise = ( b1 + o1 > b2 )
159
160extents :: Rec -> [ (Integer, Integer) ]
161extents r 
162  | spc r == Space.NoSpace = []
163  | otherwise = [ ((offset r) + o, (extentsz (Space.t (spc r)) (size r)))
164                | o <- arrayoffsets (arr r) (size r)]
165extentsz :: Space.SpaceType -> Integer -> Integer
166extentsz (Space.BYTEWISE s) sz = sz `div` 8 `div` s
167extentsz _ sz = 1
168
169arrayoffsets :: ArrayLoc -> Integer -> [ Integer ]
170arrayoffsets (ArrayListLoc []) _ = [0]
171arrayoffsets (ArrayListLoc l) _ = (sort l) -- Return offsets in order
172arrayoffsets (ArrayStepLoc n 0) sz = enumFromThenTo 0 (sz `div` 8) (sz* (n-1) `div` 8)
173arrayoffsets (ArrayStepLoc n s) _ = enumFromThenTo 0 s (s* (n-1))
174
175--
176-- Lookups
177-- 
178lookup_reg :: [Rec] -> String -> Rec 
179lookup_reg reginfo n = 
180    head l where l = [ r | r <- reginfo, (name r) == n ]
181
182lookup_size :: [Rec] -> String -> Integer              
183lookup_size reginfo n = (size (lookup_reg reginfo n ))
184
185-- 
186-- Properties of registers
187--
188
189is_writeable :: Rec -> Bool
190is_writeable r@Rec{ attr=a, tpe=t } = 
191    case t of
192      (TT.Primitive {} ) -> attr_is_writeable a
193      (TT.ConstType {} ) -> attr_is_writeable a
194      _ -> any F.is_writeable (fl r)
195
196is_readable :: Rec -> Bool
197is_readable r@Rec{ attr=a, tpe=t } = 
198    case t of
199      (TT.Primitive {} ) -> attr_is_readable a
200      (TT.ConstType {} ) -> attr_is_readable a
201      _ -> any F.is_readable (fl r)
202
203is_writeonly :: Rec -> Bool
204is_writeonly r@Rec{ attr=a, tpe=t } = 
205    case t of
206      (TT.Primitive {} ) -> attr_is_writeonly a
207      (TT.ConstType {} ) -> attr_is_writeonly a
208      _ -> any F.is_writeonly (fl r)
209
210needs_shadow :: Rec -> Bool
211needs_shadow r = is_writeonly r
212
213typename :: Rec -> TN.Name
214typename r = (TT.tt_name (tpe r))
215
216is_array :: Rec -> Bool
217is_array (Rec { arr = (ArrayListLoc []) } ) = False
218is_array r = True
219
220is_noaddr :: Rec -> Bool
221is_noaddr (Rec { spc = Space.NoSpace } ) = True
222is_noaddr _ = False
223
224num_elements :: Rec -> Integer
225num_elements Rec { arr = (ArrayListLoc l) } = toInteger (length l)
226num_elements Rec { arr = (ArrayStepLoc num _) } = num
227
228needs_read_before_write :: Rec -> Bool
229needs_read_before_write r = any F.is_rsvd (fl r)
230
231
232
233data Shadow = Shadow String TN.Name
234--                   name   type
235get_shadows :: [Rec] -> [Shadow]
236get_shadows reginfo = 
237    [ Shadow (name r) (typename r) | r <- reginfo, needs_shadow r ]
238
239get_shadow_registers :: [Rec] -> [Rec]
240get_shadow_registers reginfo = [ r | r <- reginfo, needs_shadow r ]
241