{- 
  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, Universitaetstrasse 6, 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 "<inline>"
    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 "<inline>"
    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 ]
