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