{-
  MsgFragments.hs: helper for backends that need to split up a message into
   multiple fragments.

  Part of Flounder: a message passing IDL for Barrelfish

  Copyright (c) 2007-2010, 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, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
-}

module MsgFragments where

import Data.Bits
import Data.List
import Data.Ord

import qualified CAbsSyntax as C
import BackendCommon (Direction (..), intf_bind_var, bindvar, msg_enum_elem_name,
                      tx_union_elem, rx_union_elem, type_c_type)
import Syntax
import Arch

-- an application level message is specified by one or more transport-level fragments
-- for UMP, we have a top-level list of non-cap fragments and separate list of caps
data MsgSpec = MsgSpec String [MsgFragment] [CapFieldTransfer]
    deriving (Show, Eq)

-- a message fragment defines the layout of a transport-level message
data MsgFragment = MsgFragment [FragmentWord] | OverflowFragment OverflowFragment
                 deriving (Show, Eq)

-- some fragments are "special" in that they can overflow and occupy an
-- arbitrary number of underlying transport messages, because their size is
-- only known at run time
data OverflowFragment =
        -- for marshalling byte arrays: type, data pointer and length fields
        BufferFragment TypeBuiltin ArgField ArgField
        -- for marshalling strings: string pointer field
        | StringFragment ArgField
        deriving (Show, Eq)

-- LMP is a special case where caps can be sent in message fragments
data LMPMsgSpec = LMPMsgSpec String [LMPMsgFragment]
    deriving (Show, Eq)

data LMPMsgFragment = LMPMsgFragment MsgFragment (Maybe CapFieldTransfer)
                 deriving (Show, Eq)

type FragmentWord = [ArgFieldFragment]

-- an arg fragment refers to a (portion of a) primitive value which is part of
-- a (possibly larger) message argument, by type, qualified name and bit offset
data ArgFieldFragment = ArgFieldFragment TypeBuiltin ArgField Int
                      | MsgCode -- implicit argument, occurs once per message
                      deriving (Show, Eq)

-- an argument field names the lowest-level field of an argument
-- each entry in the list is a field name and (optional) array index
-- eg. foo[3].bar is [NamedField "foo", ArrayField 3, NamedField "bar"]
type ArgField = [ArgFieldElt]
data ArgFieldElt = NamedField String | ArrayField Integer | TokenField
    deriving (Show, Eq)

-- modes of transfering a cap
data CapTransferMode = GiveAway | Copied
                  deriving (Show, Eq)

-- a capability is just identified by the name of its field
type CapField = ArgField

-- a capability transfer is identified by the name of its field and the type
-- of transfer requested
data CapFieldTransfer = CapFieldTransfer CapTransferMode ArgField
                  deriving (Show, Eq)

-- to generate the above, we use a slightly different intermediate
-- representation, which uses a list of fragments of individual fields
data FieldFragment = FieldFragment ArgFieldFragment
                   | CapField CapTransferMode ArgField
                   | OverflowField OverflowFragment
    deriving (Show, Eq)

-- builtin type used to transmit message code
msg_code_type :: TypeBuiltin
msg_code_type = UInt16


build_msg_spec :: Arch -> Int -> Bool -> [TypeDef] -> MessageDef -> MsgSpec
build_msg_spec arch words_per_frag contains_msgcode types (Message _ mn args _)
    -- ensure that we don't produce a completely empty message
    | (msg_frags ++ overflow_frags) == [] = MsgSpec mn [MsgFragment []] capfield_transfers
    | otherwise  = MsgSpec mn (msg_frags ++ overflow_frags) capfield_transfers
    where
        (frags, capfields, overfields)
            = partition_frags $ build_field_fragments arch types args
        field_frags = sort_field_fragments arch frags
        msg_frags = find_msg_fragments arch words_per_frag contains_msgcode field_frags
        overflow_frags = map OverflowFragment overfields
        capfield_transfers = map (\(CapField tm cf) -> (CapFieldTransfer tm cf)) capfields

-- build an LMP message spec by merging in the caps from a UMP spec
build_lmp_msg_spec :: Arch -> [TypeDef] -> MessageDef -> LMPMsgSpec
build_lmp_msg_spec arch types (Message msgt msgn args msgm) = LMPMsgSpec mn (merge_caps frags caps)
    where
        MsgSpec mn frags caps = build_msg_spec arch (lmp_words arch) True types (Message msgt msgn (Arg (Builtin UInt32) Token:args) msgm)

        -- XXX: ensure that we never put a cap together with an overflow fragment
        -- even though this could work at the transport-level, the current
        -- LMP code doesn't support it
        merge_caps :: [MsgFragment] -> [CapFieldTransfer] -> [LMPMsgFragment]
        merge_caps [] [] = []
        merge_caps (mf:restf) []
            = (LMPMsgFragment mf Nothing):(merge_caps restf [])
        merge_caps [] (c:restc)
            = (LMPMsgFragment (MsgFragment []) (Just c)):(merge_caps [] restc)
        merge_caps ((mf@(OverflowFragment _)):restf) caps
            = (LMPMsgFragment mf Nothing):(merge_caps restf caps)
        merge_caps (mf:restf) (c:restc)
            = (LMPMsgFragment mf (Just c)):(merge_caps restf restc)

-- partition a list of field fragments into (ordinary fields, caps, overflow buffers/strings)
partition_frags :: [FieldFragment] -> ([FieldFragment], [FieldFragment], [OverflowFragment])
partition_frags [] = ([], [], [])
partition_frags (h:t) = case h of
    f@(FieldFragment _) -> (f:restf, restc, resto)
    f@(CapField _ _)    -> (restf, f:restc, resto)
    OverflowField o     -> (restf, restc, o:resto)
    where
        (restf, restc, resto) = partition_frags t

find_msg_fragments :: Arch -> Int -> Bool -> [FieldFragment] -> [MsgFragment]
find_msg_fragments arch words_per_frag contains_msgcode frags
    = group_frags frags first_frag
    where
        -- does the first fragment need to contain the message code?
        first_frag
            | contains_msgcode = MsgFragment [[MsgCode]]
            | otherwise        = MsgFragment []

        group_frags :: [FieldFragment] -> MsgFragment -> [MsgFragment]
        group_frags [] (MsgFragment []) = [] -- empty fragment, drop it
        group_frags [] cur = [cur] -- terminated search
        group_frags ((FieldFragment f):rest) (MsgFragment [])
            = group_frags rest (MsgFragment [[f]])
        group_frags ((FieldFragment f):rest) cur@(MsgFragment wl)
            -- can we fit another fragment into the current word?
            | can_fit_word lastword f
                = group_frags rest (MsgFragment (restwords ++ [lastword ++ [f]]))
            -- can we fit another word onto the current message fragment?
            | (length wl) < words_per_frag
                = group_frags rest (MsgFragment (wl ++ [[f]]))
            | otherwise = cur:(group_frags rest (MsgFragment [[f]]))
            where
                lastword = last wl
                restwords = init wl
                bitsizeof = bitsizeof_argfieldfrag arch

                can_fit_word :: FragmentWord -> ArgFieldFragment -> Bool
                can_fit_word word frag =
                    (sum $ map bitsizeof word) + bitsizeof frag <= wordsize arch

-- sort the list of fragments by size, to optimise packing
sort_field_fragments :: Arch -> [FieldFragment] -> [FieldFragment]
sort_field_fragments ar = sortBy cmp
    where
        cmp (FieldFragment f1) (FieldFragment f2)
            = comparing (bitsizeof_argfieldfrag ar) f1 f2

build_field_fragments :: Arch -> [TypeDef] -> [MessageArgument] -> [FieldFragment]
build_field_fragments arch types args = concat $ map arg_fragments args
    where
        arg_fragments :: MessageArgument -> [FieldFragment]
        arg_fragments (Arg (TypeAlias _ b) v) = arg_fragments (Arg (Builtin b) v)
        arg_fragments (Arg (Builtin t) (DynamicArray n l _))
            | t `elem` [UInt8, Int8, Char]
                = [OverflowField $ BufferFragment t [NamedField n] [NamedField l]]
            | otherwise = error "dynamic arrays of types other than char/int8/uint8 are not yet supported"
        arg_fragments (Arg (Builtin b) Token) = fragment_builtin [TokenField] b
        arg_fragments (Arg (Builtin b) v) = fragment_builtin [NamedField (varname v)] b
        arg_fragments (Arg (TypeVar t) v) =
            fragment_typedef [NamedField (varname v)] (lookup_type_name types t)

        varname (Name n) = n
        varname (StringArray n _) = n
        varname (DynamicArray _ _ _)
            = error "dynamic arrays of types other than char/int8/uint8 are not yet supported"

        fragment_typedef :: ArgField -> TypeDef -> [FieldFragment]
        fragment_typedef f (TStruct _ fl) =
            concat [fragment_typeref ((NamedField fn):f) tr | TStructField tr fn <- fl]

        fragment_typedef f (TArray tr _ len) = concat [fragment_typeref i tr | i <- fields]
            where
                fields = [(ArrayField i):f | i <- [0..(len - 1)]]
        fragment_typedef f (TEnum _ _) = fragment_builtin f (enum_type arch)
        fragment_typedef f (TAlias _ _) = error "aliases unhandled here"
        fragment_typedef f (TAliasT _ b) = fragment_builtin f b

        fragment_typeref :: ArgField -> TypeRef -> [FieldFragment]
        fragment_typeref f (Builtin b) = fragment_builtin f b
        fragment_typeref f (TypeAlias _ b) = fragment_builtin f b
        fragment_typeref f (TypeVar tv) = fragment_typedef f (lookup_type_name types tv)

        fragment_builtin :: ArgField -> TypeBuiltin -> [FieldFragment]
        fragment_builtin f Cap = [CapField Copied f]
        fragment_builtin f GiveAwayCap = [CapField GiveAway f]
        fragment_builtin f String = [OverflowField $ StringFragment f]
        fragment_builtin f t =
            [FieldFragment (ArgFieldFragment t f off)
             | off <- [0, (wordsize arch) .. (bitsizeof_builtin arch t - 1)]]

bitsizeof_argfieldfrag :: Arch -> ArgFieldFragment -> Int
bitsizeof_argfieldfrag a (ArgFieldFragment t _ _)
    = min (wordsize a) (bitsizeof_builtin a t)
bitsizeof_argfieldfrag a MsgCode
    = bitsizeof_builtin a msg_code_type

bitsizeof_builtin :: Arch -> TypeBuiltin -> Int
bitsizeof_builtin _ UInt8 = 8
bitsizeof_builtin _ UInt16 = 16
bitsizeof_builtin _ UInt32 = 32
bitsizeof_builtin _ UInt64 = 64
bitsizeof_builtin _ Int8 = 8
bitsizeof_builtin _ Int16 = 16
bitsizeof_builtin _ Int32 = 32
bitsizeof_builtin _ Int64 = 64
bitsizeof_builtin a UIntPtr = ptrsize a
bitsizeof_builtin a IntPtr = ptrsize a
bitsizeof_builtin a Size = sizesize a
bitsizeof_builtin _ Bool = 1
bitsizeof_builtin _ IRef = 32 -- FIXME: move out of flounder
bitsizeof_builtin _ Char = 8
bitsizeof_builtin _ String = undefined
bitsizeof_builtin _ Cap = undefined
bitsizeof_builtin _ ErrVal = 32
bitsizeof_builtin _ GiveAwayCap = undefined


-------------------------------------------------------
-- Utility function for working with arg fields
-- This generates a C expression to access a given field
-------------------------------------------------------

argfield_expr :: Direction -> String -> ArgField -> C.Expr
argfield_expr TX mn [NamedField n] = tx_union_elem mn n
argfield_expr RX mn [NamedField n] = rx_union_elem mn n
argfield_expr TX mn [TokenField] = C.DerefField bindvar "outgoing_token"
argfield_expr RX mn [TokenField] = C.DerefField bindvar "incoming_token"
argfield_expr _ _ [ArrayField n] = error "invalid; top-level array"
argfield_expr dir mn ((NamedField n):rest)
    = C.FieldOf (argfield_expr dir mn rest) n
argfield_expr dir mn ((ArrayField i):rest)
    = C.SubscriptOf (C.DerefPtr $ argfield_expr dir mn rest) (C.NumConstant i)

-- generate a C expression for constructing the given word of a message fragment
fragment_word_to_expr :: Arch -> String -> String -> FragmentWord -> C.Expr
fragment_word_to_expr arch ifn mn frag = mkwordexpr 0 frag
    where
        mkwordexpr :: Int -> FragmentWord -> C.Expr
        mkwordexpr shift [af] = doshift shift (mkfieldexpr af)
        mkwordexpr shift (af:rest) = C.Binary C.BitwiseOr cur $ mkwordexpr rshift rest
            where
                cur = doshift shift (mkfieldexpr af)
                rshift = shift + bitsizeof_argfieldfrag arch af

        doshift :: Int -> C.Expr -> C.Expr
        doshift 0 ex = ex
        doshift n ex = C.Binary C.LeftShift
                        (C.Cast (C.TypeName "uintptr_t") ex)
                        (C.NumConstant $ toInteger n)

        mkfieldexpr :: ArgFieldFragment -> C.Expr
        mkfieldexpr MsgCode = C.Variable $ msg_enum_elem_name ifn mn
        mkfieldexpr (ArgFieldFragment t af 0) = fieldaccessor t af
        mkfieldexpr (ArgFieldFragment t af off) =
            C.Binary C.RightShift (fieldaccessor t af) (C.NumConstant $ toInteger off)

        -- special-case bool types to ensure we only get the one-bit true/false value
        -- ticket #231
        fieldaccessor Bool af
          = C.Binary C.NotEquals (argfield_expr TX mn af) (C.Variable "false")
        fieldaccessor _ af = argfield_expr TX mn af


store_arg_frags :: Arch -> String -> String -> C.Expr -> Int -> Int -> [ArgFieldFragment] -> [C.Stmt]
store_arg_frags _ _ _ _ _ _ [] = []
store_arg_frags arch ifn mn msgdata_ex word bitoff (MsgCode:rest)
    = store_arg_frags arch ifn mn msgdata_ex word (bitoff + bitsizeof_argfieldfrag arch MsgCode) rest
store_arg_frags _ _ _ _ _ _ ((ArgFieldFragment String _ _):_)
    = error "strings are not handled here"
store_arg_frags arch ifn mn msgdata_ex word bitoff (aff@(ArgFieldFragment t af argoff):rest)
    = (C.Ex expr):(store_arg_frags arch ifn mn msgdata_ex word (bitoff + bitsize) rest)
    where
        bitsize = bitsizeof_argfieldfrag arch aff
        expr = C.Assignment (argfield_expr RX mn af) assval
        assval
            | argoff == 0 = mask msgval
            | otherwise = C.Binary C.BitwiseOr (argfield_expr RX mn af)
                (C.Binary C.LeftShift
                    (C.Cast (type_c_type ifn $ Builtin t) (mask msgval))
                    (C.NumConstant $ toInteger argoff))
        msgval
            | bitoff == 0 = msgword
            | otherwise = C.Binary C.RightShift msgword (C.NumConstant $ toInteger bitoff)
        msgword = C.SubscriptOf msgdata_ex $ C.NumConstant $ toInteger word
        mask ex
            | bitsize == (wordsize arch) = ex
            | otherwise = C.Binary C.BitwiseAnd ex (C.HexConstant maskval)
            where
                maskval = (shift 1 bitsize) - 1