1{-
2  MsgFragments.hs: helper for backends that need to split up a message into
3   multiple fragments.
4
5  Part of Flounder: a message passing IDL for Barrelfish
6
7  Copyright (c) 2007-2010, ETH Zurich.
8  All rights reserved.
9
10  This file is distributed under the terms in the attached LICENSE file.
11  If you do not find this file, copies can be found by writing to:
12  ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
13-}
14
15module MsgFragments where
16
17import Data.Bits
18import Data.List
19import Data.Ord
20
21import qualified CAbsSyntax as C
22import BackendCommon (Direction (..), intf_bind_var, bindvar, msg_enum_elem_name,
23                      tx_union_elem, rx_union_elem, type_c_type)
24import Syntax
25import Arch
26
27-- an application level message is specified by one or more transport-level fragments
28-- for UMP, we have a top-level list of non-cap fragments and separate list of caps
29data MsgSpec = MsgSpec String [MsgFragment] [CapFieldTransfer]
30    deriving (Show, Eq)
31
32-- a message fragment defines the layout of a transport-level message
33data MsgFragment = MsgFragment [FragmentWord] | OverflowFragment OverflowFragment
34                 deriving (Show, Eq)
35
36-- some fragments are "special" in that they can overflow and occupy an
37-- arbitrary number of underlying transport messages, because their size is
38-- only known at run time
39data OverflowFragment =
40        -- for marshalling byte arrays: type, data pointer and length fields
41        BufferFragment TypeBuiltin ArgField ArgField
42        -- for marshalling strings: string pointer field
43        | StringFragment ArgField
44        deriving (Show, Eq)
45
46-- LMP is a special case where caps can be sent in message fragments
47data LMPMsgSpec = LMPMsgSpec String [LMPMsgFragment]
48    deriving (Show, Eq)
49
50data LMPMsgFragment = LMPMsgFragment MsgFragment (Maybe CapFieldTransfer)
51                 deriving (Show, Eq)
52
53type FragmentWord = [ArgFieldFragment]
54
55-- an arg fragment refers to a (portion of a) primitive value which is part of
56-- a (possibly larger) message argument, by type, qualified name and bit offset
57data ArgFieldFragment = ArgFieldFragment TypeBuiltin ArgField Int
58                      | MsgCode -- implicit argument, occurs once per message
59                      deriving (Show, Eq)
60
61-- an argument field names the lowest-level field of an argument
62-- each entry in the list is a field name and (optional) array index
63-- eg. foo[3].bar is [NamedField "foo", ArrayField 3, NamedField "bar"]
64type ArgField = [ArgFieldElt]
65data ArgFieldElt = NamedField String | ArrayField Integer | TokenField
66    deriving (Show, Eq)
67
68-- modes of transfering a cap
69data CapTransferMode = GiveAway | Copied
70                  deriving (Show, Eq)
71
72-- a capability is just identified by the name of its field
73type CapField = ArgField
74
75-- a capability transfer is identified by the name of its field and the type
76-- of transfer requested
77data CapFieldTransfer = CapFieldTransfer CapTransferMode ArgField
78                  deriving (Show, Eq)
79
80-- to generate the above, we use a slightly different intermediate
81-- representation, which uses a list of fragments of individual fields
82data FieldFragment = FieldFragment ArgFieldFragment
83                   | CapField CapTransferMode ArgField
84                   | OverflowField OverflowFragment
85    deriving (Show, Eq)
86
87-- builtin type used to transmit message code
88msg_code_type :: TypeBuiltin
89msg_code_type = UInt16
90
91
92build_msg_spec :: Arch -> Int -> Bool -> [TypeDef] -> MessageDef -> MsgSpec
93build_msg_spec arch words_per_frag contains_msgcode types (Message _ mn args _)
94    -- ensure that we don't produce a completely empty message
95    | (msg_frags ++ overflow_frags) == [] = MsgSpec mn [MsgFragment []] capfield_transfers
96    | otherwise  = MsgSpec mn (msg_frags ++ overflow_frags) capfield_transfers
97    where
98        (frags, capfields, overfields)
99            = partition_frags $ build_field_fragments arch types args
100        field_frags = sort_field_fragments arch frags
101        msg_frags = find_msg_fragments arch words_per_frag contains_msgcode field_frags
102        overflow_frags = map OverflowFragment overfields
103        capfield_transfers = map (\(CapField tm cf) -> (CapFieldTransfer tm cf)) capfields
104
105-- build an LMP message spec by merging in the caps from a UMP spec
106build_lmp_msg_spec :: Arch -> [TypeDef] -> MessageDef -> LMPMsgSpec
107build_lmp_msg_spec arch types (Message msgt msgn args msgm) = LMPMsgSpec mn (merge_caps frags caps)
108    where
109        MsgSpec mn frags caps = build_msg_spec arch (lmp_words arch) True types (Message msgt msgn (Arg (Builtin UInt32) Token:args) msgm)
110
111        -- XXX: ensure that we never put a cap together with an overflow fragment
112        -- even though this could work at the transport-level, the current
113        -- LMP code doesn't support it
114        merge_caps :: [MsgFragment] -> [CapFieldTransfer] -> [LMPMsgFragment]
115        merge_caps [] [] = []
116        merge_caps (mf:restf) []
117            = (LMPMsgFragment mf Nothing):(merge_caps restf [])
118        merge_caps [] (c:restc)
119            = (LMPMsgFragment (MsgFragment []) (Just c)):(merge_caps [] restc)
120        merge_caps ((mf@(OverflowFragment _)):restf) caps
121            = (LMPMsgFragment mf Nothing):(merge_caps restf caps)
122        merge_caps (mf:restf) (c:restc)
123            = (LMPMsgFragment mf (Just c)):(merge_caps restf restc)
124
125-- partition a list of field fragments into (ordinary fields, caps, overflow buffers/strings)
126partition_frags :: [FieldFragment] -> ([FieldFragment], [FieldFragment], [OverflowFragment])
127partition_frags [] = ([], [], [])
128partition_frags (h:t) = case h of
129    f@(FieldFragment _) -> (f:restf, restc, resto)
130    f@(CapField _ _)    -> (restf, f:restc, resto)
131    OverflowField o     -> (restf, restc, o:resto)
132    where
133        (restf, restc, resto) = partition_frags t
134
135find_msg_fragments :: Arch -> Int -> Bool -> [FieldFragment] -> [MsgFragment]
136find_msg_fragments arch words_per_frag contains_msgcode frags
137    = group_frags frags first_frag
138    where
139        -- does the first fragment need to contain the message code?
140        first_frag
141            | contains_msgcode = MsgFragment [[MsgCode]]
142            | otherwise        = MsgFragment []
143
144        group_frags :: [FieldFragment] -> MsgFragment -> [MsgFragment]
145        group_frags [] (MsgFragment []) = [] -- empty fragment, drop it
146        group_frags [] cur = [cur] -- terminated search
147        group_frags ((FieldFragment f):rest) (MsgFragment [])
148            = group_frags rest (MsgFragment [[f]])
149        group_frags ((FieldFragment f):rest) cur@(MsgFragment wl)
150            -- can we fit another fragment into the current word?
151            | can_fit_word lastword f
152                = group_frags rest (MsgFragment (restwords ++ [lastword ++ [f]]))
153            -- can we fit another word onto the current message fragment?
154            | (length wl) < words_per_frag
155                = group_frags rest (MsgFragment (wl ++ [[f]]))
156            | otherwise = cur:(group_frags rest (MsgFragment [[f]]))
157            where
158                lastword = last wl
159                restwords = init wl
160                bitsizeof = bitsizeof_argfieldfrag arch
161
162                can_fit_word :: FragmentWord -> ArgFieldFragment -> Bool
163                can_fit_word word frag =
164                    (sum $ map bitsizeof word) + bitsizeof frag <= wordsize arch
165
166-- sort the list of fragments by size, to optimise packing
167sort_field_fragments :: Arch -> [FieldFragment] -> [FieldFragment]
168sort_field_fragments ar = sortBy cmp
169    where
170        cmp (FieldFragment f1) (FieldFragment f2)
171            = comparing (bitsizeof_argfieldfrag ar) f1 f2
172
173build_field_fragments :: Arch -> [TypeDef] -> [MessageArgument] -> [FieldFragment]
174build_field_fragments arch types args = concat $ map arg_fragments args
175    where
176        arg_fragments :: MessageArgument -> [FieldFragment]
177        arg_fragments (Arg (TypeAlias _ b) v) = arg_fragments (Arg (Builtin b) v)
178        arg_fragments (Arg (Builtin t) (DynamicArray n l _))
179            | t `elem` [UInt8, Int8, Char]
180                = [OverflowField $ BufferFragment t [NamedField n] [NamedField l]]
181            | otherwise = error "dynamic arrays of types other than char/int8/uint8 are not yet supported"
182        arg_fragments (Arg (Builtin b) Token) = fragment_builtin [TokenField] b
183        arg_fragments (Arg (Builtin b) v) = fragment_builtin [NamedField (varname v)] b
184        arg_fragments (Arg (TypeVar t) v) =
185            fragment_typedef [NamedField (varname v)] (lookup_type_name types t)
186
187        varname (Name n) = n
188        varname (StringArray n _) = n
189        varname (DynamicArray _ _ _)
190            = error "dynamic arrays of types other than char/int8/uint8 are not yet supported"
191
192        fragment_typedef :: ArgField -> TypeDef -> [FieldFragment]
193        fragment_typedef f (TStruct _ fl) =
194            concat [fragment_typeref ((NamedField fn):f) tr | TStructField tr fn <- fl]
195
196        fragment_typedef f (TArray tr _ len) = concat [fragment_typeref i tr | i <- fields]
197            where
198                fields = [(ArrayField i):f | i <- [0..(len - 1)]]
199        fragment_typedef f (TEnum _ _) = fragment_builtin f (enum_type arch)
200        fragment_typedef f (TAlias _ _) = error "aliases unhandled here"
201        fragment_typedef f (TAliasT _ b) = fragment_builtin f b
202
203        fragment_typeref :: ArgField -> TypeRef -> [FieldFragment]
204        fragment_typeref f (Builtin b) = fragment_builtin f b
205        fragment_typeref f (TypeAlias _ b) = fragment_builtin f b
206        fragment_typeref f (TypeVar tv) = fragment_typedef f (lookup_type_name types tv)
207
208        fragment_builtin :: ArgField -> TypeBuiltin -> [FieldFragment]
209        fragment_builtin f Cap = [CapField Copied f]
210        fragment_builtin f GiveAwayCap = [CapField GiveAway f]
211        fragment_builtin f String = [OverflowField $ StringFragment f]
212        fragment_builtin f t =
213            [FieldFragment (ArgFieldFragment t f off)
214             | off <- [0, (wordsize arch) .. (bitsizeof_builtin arch t - 1)]]
215
216bitsizeof_argfieldfrag :: Arch -> ArgFieldFragment -> Int
217bitsizeof_argfieldfrag a (ArgFieldFragment t _ _)
218    = min (wordsize a) (bitsizeof_builtin a t)
219bitsizeof_argfieldfrag a MsgCode
220    = bitsizeof_builtin a msg_code_type
221
222bitsizeof_builtin :: Arch -> TypeBuiltin -> Int
223bitsizeof_builtin _ UInt8 = 8
224bitsizeof_builtin _ UInt16 = 16
225bitsizeof_builtin _ UInt32 = 32
226bitsizeof_builtin _ UInt64 = 64
227bitsizeof_builtin _ Int8 = 8
228bitsizeof_builtin _ Int16 = 16
229bitsizeof_builtin _ Int32 = 32
230bitsizeof_builtin _ Int64 = 64
231bitsizeof_builtin a UIntPtr = ptrsize a
232bitsizeof_builtin a IntPtr = ptrsize a
233bitsizeof_builtin a Size = sizesize a
234bitsizeof_builtin _ Bool = 1
235bitsizeof_builtin _ IRef = 32 -- FIXME: move out of flounder
236bitsizeof_builtin _ Char = 8
237bitsizeof_builtin _ String = undefined
238bitsizeof_builtin _ Cap = undefined
239bitsizeof_builtin _ ErrVal = 32
240bitsizeof_builtin _ GiveAwayCap = undefined
241
242
243-------------------------------------------------------
244-- Utility function for working with arg fields
245-- This generates a C expression to access a given field
246-------------------------------------------------------
247
248argfield_expr :: Direction -> String -> ArgField -> C.Expr
249argfield_expr TX mn [NamedField n] = tx_union_elem mn n
250argfield_expr RX mn [NamedField n] = rx_union_elem mn n
251argfield_expr TX mn [TokenField] = C.DerefField bindvar "outgoing_token"
252argfield_expr RX mn [TokenField] = C.DerefField bindvar "incoming_token"
253argfield_expr _ _ [ArrayField n] = error "invalid; top-level array"
254argfield_expr dir mn ((NamedField n):rest)
255    = C.FieldOf (argfield_expr dir mn rest) n
256argfield_expr dir mn ((ArrayField i):rest)
257    = C.SubscriptOf (C.DerefPtr $ argfield_expr dir mn rest) (C.NumConstant i)
258
259-- generate a C expression for constructing the given word of a message fragment
260fragment_word_to_expr :: Arch -> String -> String -> FragmentWord -> C.Expr
261fragment_word_to_expr arch ifn mn frag = mkwordexpr 0 frag
262    where
263        mkwordexpr :: Int -> FragmentWord -> C.Expr
264        mkwordexpr shift [af] = doshift shift (mkfieldexpr af)
265        mkwordexpr shift (af:rest) = C.Binary C.BitwiseOr cur $ mkwordexpr rshift rest
266            where
267                cur = doshift shift (mkfieldexpr af)
268                rshift = shift + bitsizeof_argfieldfrag arch af
269
270        doshift :: Int -> C.Expr -> C.Expr
271        doshift 0 ex = ex
272        doshift n ex = C.Binary C.LeftShift
273                        (C.Cast (C.TypeName "uintptr_t") ex)
274                        (C.NumConstant $ toInteger n)
275
276        mkfieldexpr :: ArgFieldFragment -> C.Expr
277        mkfieldexpr MsgCode = C.Variable $ msg_enum_elem_name ifn mn
278        mkfieldexpr (ArgFieldFragment t af 0) = fieldaccessor t af
279        mkfieldexpr (ArgFieldFragment t af off) =
280            C.Binary C.RightShift (fieldaccessor t af) (C.NumConstant $ toInteger off)
281
282        -- special-case bool types to ensure we only get the one-bit true/false value
283        -- ticket #231
284        fieldaccessor Bool af
285          = C.Binary C.NotEquals (argfield_expr TX mn af) (C.Variable "false")
286        fieldaccessor _ af = argfield_expr TX mn af
287
288
289store_arg_frags :: Arch -> String -> String -> C.Expr -> Int -> Int -> [ArgFieldFragment] -> [C.Stmt]
290store_arg_frags _ _ _ _ _ _ [] = []
291store_arg_frags arch ifn mn msgdata_ex word bitoff (MsgCode:rest)
292    = store_arg_frags arch ifn mn msgdata_ex word (bitoff + bitsizeof_argfieldfrag arch MsgCode) rest
293store_arg_frags _ _ _ _ _ _ ((ArgFieldFragment String _ _):_)
294    = error "strings are not handled here"
295store_arg_frags arch ifn mn msgdata_ex word bitoff (aff@(ArgFieldFragment t af argoff):rest)
296    = (C.Ex expr):(store_arg_frags arch ifn mn msgdata_ex word (bitoff + bitsize) rest)
297    where
298        bitsize = bitsizeof_argfieldfrag arch aff
299        expr = C.Assignment (argfield_expr RX mn af) assval
300        assval
301            | argoff == 0 = mask msgval
302            | otherwise = C.Binary C.BitwiseOr (argfield_expr RX mn af)
303                (C.Binary C.LeftShift
304                    (C.Cast (type_c_type ifn $ Builtin t) (mask msgval))
305                    (C.NumConstant $ toInteger argoff))
306        msgval
307            | bitoff == 0 = msgword
308            | otherwise = C.Binary C.RightShift msgword (C.NumConstant $ toInteger bitoff)
309        msgword = C.SubscriptOf msgdata_ex $ C.NumConstant $ toInteger word
310        mask ex
311            | bitsize == (wordsize arch) = ex
312            | otherwise = C.Binary C.BitwiseAnd ex (C.HexConstant maskval)
313            where
314                maskval = (shift 1 bitsize) - 1
315