content: {- 
    Type table: list of all register types
     
    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 TypeTable where
  
  import MackerelParser
  import Attr
  import Text.ParserCombinators.Parsec
  import Text.ParserCombinators.Parsec.Pos
  import qualified Fields as F
  import qualified TypeName as TN
  
  {--------------------------------------------------------------------
  
  --------------------------------------------------------------------}
  
  data Val = Val { cname :: String,
                   cval :: Expr,
                   cdesc :: String,
                   ctype :: TN.Name,
                   cpos :: SourcePos }
           deriving Show
  
  data Rec = RegFormat  { tt_name :: TN.Name, 
                          tt_size :: Integer,
                          fields :: [F.Rec],
                          tt_desc :: String,
                          pos :: SourcePos }
           | DataFormat { tt_name :: TN.Name, 
                          tt_size :: Integer,
                          fields :: [F.Rec],
                          tt_desc :: String,
                          wordsize :: Integer,
                          pos :: SourcePos }
           | ConstType  { tt_name :: TN.Name,
                          tt_size :: Integer,
                          tt_vals :: [ Val ], 
                          tt_width :: Maybe Integer,
                          tt_desc :: String,
                          pos  :: SourcePos }
           | Primitive  { tt_name :: TN.Name,
                          tt_size :: Integer,
                          tt_attr :: Attr }
             deriving Show 
                
  type_name :: Rec -> String
  type_name r = TN.toString $ tt_name r
  
  devname :: Rec -> String
  devname r = TN.devName $ tt_name r
  
  type_kind :: Rec -> String
  type_kind RegFormat  {} = "Register"
  type_kind DataFormat {} = "Data"
  type_kind ConstType  {} = "Constant"
  type_kind Primitive  {} = "Primitive"
  
  -- Is this a primitive (i.e. non-record-like) type.  A key issue here
  -- is that this includes constants types; otherwise this is equivalent
  -- to is_builtin below.
  is_primitive :: Rec -> Bool
  is_primitive Primitive {} = True
  is_primitive ConstType {} = True
  is_primitive _ = False
  
  is_builtin :: Rec -> Bool
  is_builtin Primitive { tt_name = n } = TN.is_builtin_type n
  is_builtin _ = False
  
  builtin_size :: String -> Integer
  builtin_size "uint8" = 8
  builtin_size "uint16" = 16
  builtin_size "uint32" = 32
  builtin_size "uint64" = 64
  
  make_rtypetable :: DeviceFile -> [Rec]
  make_rtypetable (DeviceFile (Device devname bitorder _ _ decls) _) = 
    (concat [ make_rtrec d devname bitorder | d <- decls ])
    ++ 
    [ Primitive (TN.fromParts devname ("uint" ++ (show w))) w NOATTR 
    | w <- [ 8, 16, 32, 64 ] ] 
  
  make_rtrec :: AST -> String -> BitOrder -> [Rec]
  make_rtrec (RegType nm dsc (TypeDefn decls) p) dev order = 
      [ RegFormat { tt_name = TN.fromParts dev nm,
                    tt_size = (calc_tt_size decls),
                    fields = F.make_list dev NOATTR order 0 decls,
                    tt_desc = dsc,
                    pos = p } ]
  
  make_rtrec (Register nm tt_attrib _ _ dsc (TypeDefn decls) p) dev order = 
      [ RegFormat { tt_name = TN.fromParts dev nm,
                    tt_size = (calc_tt_size decls),
                    fields = F.make_list dev tt_attrib order 0 decls,
                    tt_desc = "Implicit type of " ++ dsc ++ " register",
                    pos = p } ]
  
  make_rtrec (RegArray nm tt_attrib _ _ _ dsc (TypeDefn decls) p) dev order = 
      [ RegFormat { tt_name = TN.fromParts dev nm,
                    tt_size = (calc_tt_size decls),
                    fields = F.make_list dev NOATTR order 0 decls,
                    tt_desc = "Implicit type of " ++ dsc ++ " register array",
                    pos = p } ]
  
  make_rtrec (DataType nm dsc (TypeDefn decls) o w p) dev devorder = 
      let order = if o == NOORDER then devorder else o
          sz = calc_tt_size decls
      in
        [ DataFormat { tt_name = TN.fromParts dev nm,
                       tt_size = sz,
                       fields = F.make_list dev RW order w decls,
                       tt_desc = dsc,
                       wordsize = if w == 0 then sz else w,
                       pos = p } ]
  make_rtrec (Constants nm d vs w p) dev devorder = 
    let tn = TN.fromParts dev nm 
        vl = [ make_val tn v | v <- vs ]
    in
     [ ConstType { tt_name = tn,
                   tt_size = case w of 
                     Nothing -> calc_const_size vl
                     Just t -> t,
                   tt_vals = vl,
                   tt_desc = d,
                   tt_width = w,
                   pos = p } ]
  make_rtrec _ _ _ = []
                     
  calc_const_size :: [Val] -> Integer
  calc_const_size vs = 
    let m = maximum [ i | t@Val { cval = (ExprConstant i) } <- vs ] 
    in
     if m <= 0xff then 8
     else if m <= 0xffff then 16
          else if m <= 0xffffffff then 32
               else 64
  
  -- Building constant lists
  make_val :: TN.Name -> AST -> Val
  make_val tn (ConstVal i e d p) 
      = Val { cname = i, cval = e, cdesc = d, ctype = tn, cpos = p }
  
  calc_tt_size :: [AST] -> Integer
  calc_tt_size decls = sum [ sz | (RegField _ sz _ _ _ _) <- decls ]
  
  get_rtrec :: [Rec] -> TN.Name -> Rec
  get_rtrec rtinfo nm = 
      let l  = [ rt | rt <- rtinfo, (tt_name rt) == nm ]
      in
        if (length l) > 0
        then head l
        else RegFormat { tt_name = TN.null,
                         tt_size = 32,
                         fields = [],
                         tt_desc = "Failed to find type" ++ show nm,
                         pos = initialPos "no file" }
  