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