{- Register table: list of all registers Part of Mackerel: a strawman device definition DSL for Barrelfish Copyright (c) 2007, 2008, ETH Zurich. All rights reserved. This file is distributed under the terms in the attached LICENSE file. If you do not find this file, copies can be found by writing to: ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group. -} module RegisterTable where import Data.List import MackerelParser import Text.ParserCombinators.Parsec import Attr import qualified Fields as F import qualified TypeTable as TT import qualified TypeName as TN import qualified Space {-------------------------------------------------------------------- Register table: list of all registers --------------------------------------------------------------------} data Rec = Rec { name :: String, -- Unqualified name of register fl :: [F.Rec], -- List of fields (may be empty) attr :: Attr, -- Attribute (for non-field types) tpe :: TT.Rec, -- Type of this register origtype :: String, -- Original name of register type size :: Integer, -- Width in bits also :: Bool, -- Only register at this address? desc :: String, -- Description string spc_id :: String, -- Address space identifier spc :: Space.Rec, -- Address space record base :: String, -- Base variable name offset :: Integer, -- Offset of register from base arr :: ArrayLoc, -- Array of locations pos :: SourcePos -- Source code position } deriving Show -- -- Building the register table -- make_table :: [TT.Rec] -> [AST] -> String -> BitOrder -> [Space.Rec] -> [Rec] make_table rtinfo decls dn order spt = concat [ (make_reginfo rtinfo d dn order spt) | d <- decls ] make_regproto :: String -> Attr -> Bool -> RegLoc -> String -> SourcePos -> [Space.Rec] -> TT.Rec -> String -> Rec make_regproto n atrv als rloc dsc p spt t tname = let (si, s, b, o) = get_location rloc spt in Rec { name = n, fl = [], attr =atrv, tpe = t, origtype = tname, size = 0, also = als, desc = dsc, spc_id = si, spc = s, base = b, offset = o, arr = (ArrayListLoc []), pos = p } make_reginfo :: [TT.Rec] -> AST -> String -> BitOrder -> [Space.Rec] -> [Rec] make_reginfo rtinfo (RegArray n atrv als rloc aloc dsc (TypeDefn decls) p) dn order spt = let t = (TT.get_rtrec rtinfo (TN.fromParts dn n)) r = make_regproto n atrv als rloc dsc p spt t "" in [ r { fl = F.make_list dn atrv order 0 decls, size = TT.tt_size t, arr = aloc } ] make_reginfo rtinfo (RegArray n atrv als rloc aloc dsc tr@(TypeRef tname dname) p) dn order spt = let tn = TN.fromRef tr dn rt = (TT.get_rtrec rtinfo tn) r = make_regproto n atrv als rloc dsc p spt rt tname in case rt of t@(TT.Primitive {}) -> [ r { size = (TT.tt_size rt), arr = aloc } ] t@(TT.RegFormat {}) -> [ r { fl = F.inherit_list atrv (TT.fields rt), size = (TT.tt_size rt), arr = aloc } ] t@(TT.DataFormat {}) -> [ r { fl = F.inherit_list atrv (TT.fields rt), size = (TT.tt_size rt), arr = aloc } ] t@(TT.ConstType {}) -> [ r { size = case (TT.tt_width rt) of Nothing -> -1 Just i -> i, arr = aloc } ] make_reginfo rtinfo (Register n atrv als rloc dsc (TypeDefn decls) p) dn order spt = let tn = TN.fromParts dn n td = TT.get_rtrec rtinfo tn r = make_regproto n atrv als rloc dsc p spt td "" in [ r { fl = F.make_list dn atrv order 0 decls, size = TT.tt_size td, arr = (ArrayListLoc []) } ] make_reginfo rtinfo (Register n atrv als rloc dsc tr@(TypeRef tname dname) p) dn order spt = let tn = TN.fromRef tr dn rt = (TT.get_rtrec rtinfo tn) r = make_regproto n atrv als rloc dsc p spt rt tname in case rt of t@(TT.Primitive {}) -> [ r { size = (TT.tt_size rt), arr = (ArrayListLoc []) } ] t@(TT.RegFormat {}) -> [ r { fl = F.inherit_list atrv (TT.fields rt), size = (TT.tt_size rt), arr = (ArrayListLoc []) } ] t@(TT.DataFormat {}) -> [ r { fl = F.inherit_list atrv (TT.fields rt), size = (TT.tt_size rt), arr = (ArrayListLoc []) } ] t@(TT.ConstType {}) -> [ r { size = case (TT.tt_width rt) of Nothing -> -1 Just i -> i, arr = (ArrayListLoc []) } ] make_reginfo rtinfo _ _ _ _ = [] get_location :: RegLoc -> [Space.Rec] -> ( String, Space.Rec, String, Integer ) get_location RegNoLoc _ = ( "", Space.NoSpace, "", 0) get_location (RegLoc s b o) spt = ( s, Space.lookup s spt, b, o) overlap :: Rec -> Rec -> Bool overlap r1 r2 | spc_id r1 /= spc_id r2 = False | base r1 /= base r2 = False | spc r1 == Space.NoSpace = False | spc r2 == Space.NoSpace = False | otherwise = compare_extents (extents r1) (extents r2) compare_extents :: [ (Integer, Integer) ] -> [ (Integer, Integer) ] -> Bool compare_extents [] _ = False compare_extents _ [] = False compare_extents (e:es) (f:fs) | extent_overlap e f = True | otherwise = if fst e < fst f then compare_extents es (f:fs) else compare_extents (e:es) fs extent_overlap :: (Integer, Integer) -> (Integer, Integer) -> Bool extent_overlap (b1, o1) (b2, o2) | b1 > b2 = ( b2 + o2 > b1 ) | otherwise = ( b1 + o1 > b2 ) extents :: Rec -> [ (Integer, Integer) ] extents r | spc r == Space.NoSpace = [] | otherwise = [ ((offset r) + o, (extentsz (Space.t (spc r)) (size r))) | o <- arrayoffsets (arr r) (size r)] extentsz :: Space.SpaceType -> Integer -> Integer extentsz (Space.BYTEWISE s) sz = sz `div` 8 `div` s extentsz _ sz = 1 arrayoffsets :: ArrayLoc -> Integer -> [ Integer ] arrayoffsets (ArrayListLoc []) _ = [0] arrayoffsets (ArrayListLoc l) _ = (sort l) -- Return offsets in order arrayoffsets (ArrayStepLoc n 0) sz = enumFromThenTo 0 (sz `div` 8) (sz* (n-1) `div` 8) arrayoffsets (ArrayStepLoc n s) _ = enumFromThenTo 0 s (s* (n-1)) -- -- Lookups -- lookup_reg :: [Rec] -> String -> Rec lookup_reg reginfo n = head l where l = [ r | r <- reginfo, (name r) == n ] lookup_size :: [Rec] -> String -> Integer lookup_size reginfo n = (size (lookup_reg reginfo n )) -- -- Properties of registers -- is_writeable :: Rec -> Bool is_writeable r@Rec{ attr=a, tpe=t } = case t of (TT.Primitive {} ) -> attr_is_writeable a (TT.ConstType {} ) -> attr_is_writeable a _ -> any F.is_writeable (fl r) is_readable :: Rec -> Bool is_readable r@Rec{ attr=a, tpe=t } = case t of (TT.Primitive {} ) -> attr_is_readable a (TT.ConstType {} ) -> attr_is_readable a _ -> any F.is_readable (fl r) is_writeonly :: Rec -> Bool is_writeonly r@Rec{ attr=a, tpe=t } = case t of (TT.Primitive {} ) -> attr_is_writeonly a (TT.ConstType {} ) -> attr_is_writeonly a _ -> any F.is_writeonly (fl r) needs_shadow :: Rec -> Bool needs_shadow r = is_writeonly r typename :: Rec -> TN.Name typename r = (TT.tt_name (tpe r)) is_array :: Rec -> Bool is_array (Rec { arr = (ArrayListLoc []) } ) = False is_array r = True is_noaddr :: Rec -> Bool is_noaddr (Rec { spc = Space.NoSpace } ) = True is_noaddr _ = False num_elements :: Rec -> Integer num_elements Rec { arr = (ArrayListLoc l) } = toInteger (length l) num_elements Rec { arr = (ArrayStepLoc num _) } = num needs_read_before_write :: Rec -> Bool needs_read_before_write r = any F.is_rsvd (fl r) data Shadow = Shadow String TN.Name -- name type get_shadows :: [Rec] -> [Shadow] get_shadows reginfo = [ Shadow (name r) (typename r) | r <- reginfo, needs_shadow r ] get_shadow_registers :: [Rec] -> [Rec] get_shadow_registers reginfo = [ r | r <- reginfo, needs_shadow r ]