1{- 2 AHCI.hs: AHCI Backend implementation. Calls into libahci for disk access. 3 4 Part of Flounder: a message passing IDL for Barrelfish 5 6 Copyright (c) 2007-2010, ETH Zurich. 7 All rights reserved. 8 9 This file is distributed under the terms in the attached LICENSE file. 10 If you do not find this file, copies can be found by writing to: 11 ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group. 12-} 13 14module AHCI where 15 16import Data.Maybe 17import Data.Either 18import BackendCommon hiding (can_send_fn_def, register_send_fn_def) 19import Syntax 20import qualified Backend 21import qualified GHBackend as GH 22import qualified CAbsSyntax as C 23 24 25-- handle printing of error values 26ahci_err_fmt = C.NStr "PRIxERRV" 27ahci_printf_error msg err = C.Ex $ C.Call "printf" [fmt, err] 28 where fmt = C.StringCat [C.QStr (msg ++ ": 0x%"), ahci_err_fmt, C.QStr "\n"] 29 30------------------------------------------------------------------------ 31-- Language mapping: C identifier names 32------------------------------------------------------------------------ 33 34-- Name of the binding struct 35ahci_bind_type :: String -> String 36ahci_bind_type ifn = ifscope ifn "binding" 37 38-- Name of command completed dispatcher 39cc_rx_fn_name ifn mn = idscope ifn mn "completed" 40 41ahci_intf_name ifn = "ahci_" ++ ifn 42 43ahci_init_fn_name ifn = ifscope (ahci_intf_name ifn) "init" 44 45-- Name of the transmit function 46tx_fn_name ifn n = idscope ifn n "ahci_send" 47 48ahci_vtbl_name ifn = ifscope ifn "ahci_tx_vtbl" 49 50------------------------------------------------------------------------ 51-- Header 52------------------------------------------------------------------------ 53 54header :: String -> String -> Interface -> String 55header infile outfile interface@(Interface name _ _) = 56 unlines $ C.pp_unit $ header_file 57 where header_file = C.IfNDef sym ((C.Define sym [] "1") : body) [] 58 sym = "__" ++ name ++ "_AHCI_IF_H" 59 body = ahci_header_file infile interface 60 61ahci_header_file :: String -> Interface -> [C.Unit] 62ahci_header_file infile interface@(Interface name descr decls) = 63 let 64 (types, messagedecls) = Backend.partitionTypesMessages decls 65 rpcs = [ rpc | rpc@(RPC _ _ _) <- messagedecls ] 66 rpc_msgs = concat $ map rpc_to_msgs rpcs 67 rx_rpc_msgs = [ msg | msg@(Message MResponse _ _ _) <- rpc_msgs ] 68 tx_rpc_msgs = [ msg | msg@(Message MCall _ _ _) <- rpc_msgs ] 69 ahci_ifn = ahci_intf_name name 70 in [ 71 intf_preamble infile ahci_ifn descr, 72 C.Blank, 73 74 C.Include C.Standard $ "ahci/ahci.h", 75 C.Include C.Standard $ "if/" ++ name ++ "_defs.h", 76 C.Blank, 77 78 C.MultiComment [ "Forward declaration of binding type" ], 79 C.StructForwardDecl (ahci_bind_type ahci_ifn), 80 C.Blank, 81 82 C.MultiComment [ "The binding structure" ], 83 ahci_binding_struct name rpcs, 84 C.Blank, 85 86 C.MultiComment [ "Function to initialize an AHCI client" ], 87 ahci_init_fn_proto name, 88 89 C.Blank 90 ] 91 92ahci_binding_struct :: String -> [MessageDef] -> C.Unit 93ahci_binding_struct ifn rpcs = C.StructDecl (intf_bind_type ahci_ifn) fields 94 where 95 ahci_ifn = ahci_intf_name ifn 96 fields = [ 97 C.ParamComment "Binding supertype", 98 C.Param (C.Struct $ intf_bind_type ifn) "b", 99 C.ParamBlank, 100 101 C.ParamComment "Binding to libahci", 102 C.Param (C.Ptr $ C.Struct $ intf_bind_type "ahci") "b_lib", 103 C.ParamBlank 104 ] 105 106ahci_init_fn_proto :: String -> C.Unit 107ahci_init_fn_proto ifn = 108 C.GVarDecl C.Extern C.NonConst 109 (C.Function C.NoScope (C.TypeName "errval_t") params) 110 (ahci_init_fn_name ifn) Nothing 111 where 112 params = [ 113 C.Param (C.Ptr $ C.Struct $ ahci_bind_type $ ahci_intf_name ifn) "binding", 114 C.Param (C.Ptr $ C.Struct $ "waitset") "waitset", 115 C.Param (C.Ptr $ C.Struct $ intf_bind_type "ahci") "ahci_binding" 116 ] 117 118--------------------------------------- 119-- Implementation 120--------------------------------------- 121 122stub :: String -> String -> Interface -> String 123stub infile outfile interface@(Interface name _ _) = 124 unlines $ C.pp_unit $ C.UnitList $ ahci_stub_body infile interface 125 126ahci_stub_body :: String -> Interface -> [C.Unit] 127ahci_stub_body infile inf@(Interface ifn descr decls) = 128 let 129 (types, messagedecls) = Backend.partitionTypesMessages decls 130 rpcs = [ rpc | rpc@(RPC _ _ _) <- messagedecls ] 131 rpc_msgs = concat $ map rpc_to_msgs rpcs 132 rx_rpc_msgs = [ msg | msg@(Message MResponse _ _ _) <- rpc_msgs ] 133 tx_rpc_msgs = [ msg | msg@(Message MCall _ _ _) <- rpc_msgs ] 134 ahci_ifn = ahci_intf_name ifn 135 in [ 136 intf_preamble infile ifn descr, 137 C.Blank, 138 C.MultiComment [ "Generated Stub for AHCI" ], 139 C.Blank, 140 141 C.Include C.Standard "stdio.h", 142 C.Include C.Standard "string.h", 143 C.Include C.Standard "barrelfish/barrelfish.h", 144 C.Include C.Standard "flounder/flounder_support.h", 145 C.Include C.Standard "ahci/ahci_dma_pool.h", 146 C.Include C.Standard "ahci/ahci_util.h", 147 C.Include C.Standard "ahci/sata_fis.h", 148 C.Include C.Standard ("if/" ++ ifn ++ "_ahci_defs.h"), 149 C.Blank, 150 151 C.MultiComment [ "Forward decleration of state struct" ], 152 completed_rx_struct_decl, 153 C.Blank, 154 155 C.MultiComment [ "Command completed handler signature" ], 156 completed_rx_typedef, 157 C.Blank, 158 159 C.MultiComment [ "Command dispatch and completion state struct" ], 160 completed_rx_struct ifn, 161 C.Blank, 162 163 C.MultiComment [ "Debug printf" ], 164 C.HashIf "defined(FLOUNDER_AHCI_DEBUG) || defined(FLOUNDER_DEBUG) || defined(GLOBAL_DEBUG)" 165 [C.Define "AHCI_DEBUG" ["x..."] "printf(\"ahci_flounder: \" x)"] 166 [C.Define "AHCI_DEBUG" ["x..."] "((void)0)"], 167 C.Blank, 168 169 C.MultiComment [ "Receiver functions for AHCI" ], 170 ahci_command_completed_rx, 171 C.UnitList [ cc_rx_fn ifn types msg | msg <- rpcs ], 172 C.Blank, 173 174 C.MultiComment [ "Command issue callback for freeing resources" ], 175 issue_command_cb_fn, 176 C.Blank, 177 178 C.MultiComment [ "Message sender functions" ], 179 C.UnitList [ tx_fn ifn types msg | msg <- rpcs ], 180 C.Blank, 181 182 C.MultiComment [ "Send vtable" ], 183 tx_vtbl inf, 184 C.Blank, 185 186 C.MultiComment [ "Control functions" ], 187 can_send_fn_def inf, 188 register_send_fn_def inf, 189 default_error_handler_fn_def "ahci" ifn, 190 change_waitset_fn_def inf, 191 192 C.MultiComment [ "Binding initialization function" ], 193 ahci_init_fn inf, 194 C.Blank 195 ] 196 197completed_rx_struct_n = "completed_rx_st" 198completed_rx_struct_type = C.Struct completed_rx_struct_n 199completed_rx_struct_decl :: C.Unit 200completed_rx_struct_decl = C.StructForwardDecl completed_rx_struct_n 201completed_rx_struct :: String -> C.Unit 202completed_rx_struct ifn = C.StructDecl completed_rx_struct_n fields 203 where 204 fields = [ 205 C.ParamComment "Callback for handling message-specifics for command completion", 206 C.Param (C.Ptr $ C.TypeName completed_rx_typedef_n) "completed_fn", 207 C.ParamComment ("The " ++ ifn ++ " ahci binding"), 208 C.Param (C.Ptr $ C.Struct $ intf_bind_type ahci_ifn) (ahci_ifn ++ "_binding"), 209 C.ParamComment "The DMA region associated with this command, if any", 210 C.Param (C.Ptr $ C.Struct "ahci_dma_region") "dma_region", 211 C.ParamComment "Number of bytes in DMA region", 212 C.Param (C.TypeName "size_t") "bytes", 213 C.ParamBlank, 214 C.ParamComment "Command fis", 215 C.Param (C.Ptr C.Void) "fis", 216 C.ParamComment "User's dispatch continuation", 217 C.Param (C.Struct "event_closure") "dispatch_continuation" 218 ] 219 ahci_ifn = ahci_intf_name ifn 220 221completed_rx_typedef_n = "completed_rx_fn_t" 222completed_rx_typedef :: C.Unit 223completed_rx_typedef = C.TypeDef (C.Function C.NoScope C.Void params) completed_rx_typedef_n 224 where 225 params = [ 226 binding_param "ahci", 227 C.Param (C.Ptr completed_rx_struct_type) "completed_st" 228 ] 229 230ahci_command_completed_rx_name = "ahci_command_completed__rx" 231ahci_command_completed_rx = 232 C.FunctionDef C.Static (C.Void) ahci_command_completed_rx_name params body 233 where 234 params = [ 235 binding_param "ahci", 236 C.Param (C.Ptr C.Void) "tag" 237 ] 238 body :: [C.Stmt] 239 body = [ 240 localvar (C.Ptr completed_rx_struct_type) "st" $ 241 Just $ C.Cast (C.Ptr completed_rx_struct_type) $ C.Variable "tag", 242 C.Ex $ C.CallInd (C.DerefField (C.Variable "st") "completed_fn") [ 243 bindvar, 244 C.Variable "st" 245 ], 246 C.Ex $ C.Call "free" [C.Variable "st"] 247 ] 248 249issue_command_cb_fn_n = "issue_command_cb" 250issue_command_cb_fn :: C.Unit 251issue_command_cb_fn = C.FunctionDef C.Static C.Void issue_command_cb_fn_n params body 252 where 253 params = [C.Param (C.Ptr C.Void) "arg"] 254 body = [ 255 localvar (C.Ptr completed_rx_struct_type) "st" Nothing, 256 C.Ex $ C.Assignment (C.Variable "st") $ C.Cast (C.Ptr completed_rx_struct_type) $ C.Variable "arg", 257 C.Ex $ C.Call "free" [st_field "fis"], 258 C.Ex $ C.Assignment (st_field "fis") (C.Variable "NULL"), 259 C.SComment "XXX: use waitset_chan_trigger_closure?", 260 C.If (cont) [ 261 C.Ex $ C.CallInd cont [cont_arg] 262 ] [] 263 ] 264 st_field n = C.Variable "st" `C.DerefField` n 265 cont = C.FieldOf (st_field "dispatch_continuation") "handler" 266 cont_arg = C.FieldOf (st_field "dispatch_continuation") "arg" 267 268can_send_fn_def :: Interface -> C.Unit 269can_send_fn_def inf@(Interface ifn descr decls) = C.FunctionDef C.Static (C.TypeName "bool") name params body 270 where 271 name = (can_send_fn_name "ahci" ifn) 272 params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var] 273 body = [ 274 let bind_ptr_type = C.Ptr $ C.Struct $ ahci_bind_type $ ahci_intf_name ifn 275 in localvar bind_ptr_type "b" $ Just $ C.Cast bind_ptr_type gen_bind_var, 276 C.Return $ C.CallInd (lib_bind_var `C.DerefField` "can_send") [lib_bind_var] 277 ] 278 gen_bind_var = C.Variable intf_bind_var 279 ahci_bind_var = C.Variable "b" 280 lib_bind_var = ahci_bind_var `C.DerefField` "b_lib" 281 282register_send_fn_def :: Interface -> C.Unit 283register_send_fn_def inf@(Interface ifn descr decls) = C.FunctionDef C.Static (C.TypeName "errval_t") name params body 284 where 285 name = (register_send_fn_name "ahci" ifn) 286 params = [ 287 C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var, 288 C.Param (C.Ptr $ C.Struct "waitset") "waitset", 289 C.Param (C.Struct "event_closure") intf_cont_var 290 ] 291 body = [ 292 let bind_ptr_type = C.Ptr $ C.Struct $ ahci_bind_type $ ahci_intf_name ifn 293 in localvar bind_ptr_type "b" $ Just $ C.Cast bind_ptr_type gen_bind_var, 294 C.Return $ C.CallInd (lib_bind_var `C.DerefField` "register_send") [ 295 lib_bind_var, 296 C.Variable "waitset", 297 C.Variable intf_cont_var 298 ] 299 ] 300 gen_bind_var = C.Variable intf_bind_var 301 ahci_bind_var = C.Variable "b" 302 lib_bind_var = ahci_bind_var `C.DerefField` "b_lib" 303 304change_waitset_fn_def :: Interface -> C.Unit 305change_waitset_fn_def inf@(Interface ifn descr decls) = C.FunctionDef C.Static (C.TypeName "errval_t") name params body 306 where 307 name = ifscope (ahci_intf_name ifn) "change_waitset" 308 params = [ 309 C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var, 310 C.Param (C.Ptr $ C.Struct "waitset") "ws" 311 ] 312 body = [ 313 let bind_ptr_type = C.Ptr $ C.Struct $ ahci_bind_type $ ahci_intf_name ifn 314 in localvar bind_ptr_type "b" $ Just $ C.Cast bind_ptr_type gen_bind_var, 315 C.SBlank, 316 317 C.SComment $ "change waitset on binding", 318 C.Ex $ C.Assignment (gen_bind_var `C.DerefField` "waitset") $ C.Variable "ws", 319 C.Ex $ C.CallInd (lib_bind_var `C.DerefField` "change_waitset") [lib_bind_var, C.Variable "ws"], 320 C.SBlank, 321 322 C.Return $ C.Variable "SYS_ERR_OK" 323 ] 324 gen_bind_var = C.Variable intf_bind_var 325 ahci_bind_var = C.Variable "b" 326 lib_bind_var = ahci_bind_var `C.DerefField` "b_lib" 327 328rpc_arg :: [RPCArgument] -> String -> Maybe RPCArgument 329rpc_arg rpcargs n = listToMaybe $ filter ((== n) . rpc_arg_var_name . rpc_arg_var) rpcargs 330 where rpc_arg_var (RPCArgIn _ v) = v 331 rpc_arg_var (RPCArgOut _ v) = v 332 rpc_arg_var_name (Name n) = n 333 rpc_arg_var_name (DynamicArray n _ _) = n 334 335get_meta_arg :: String -> String -> [(String, [(String, MetaArgument)])] -> Maybe MetaArgument 336get_meta_arg nspc n metaargs = (lookup nspc metaargs) >>= (lookup n) 337 338has_meta_arg :: String -> String -> [(String, [(String, MetaArgument)])] -> Bool 339has_meta_arg nspc n metaargs = isJust $ get_meta_arg nspc n metaargs 340 341meta_arg :: String -> String -> [(String, [(String, MetaArgument)])] -> MetaArgument 342meta_arg nspc n metaargs = 343 case get_meta_arg nspc n metaargs of 344 Just v -> v 345 Nothing -> error $ "missing meta-argument " ++ n 346 347rpc_dma_arg_name :: MessageDef -> String 348rpc_dma_arg_name rpc@(RPC _ rpcargs metaargs) = case meta_arg "ata" "dma_arg" metaargs of 349 (BackendMsgArg n) -> if isJust $ rpc_arg rpcargs n then n else error ("invalid dma argument " ++ n) 350 _ -> error "dma_arg must refer to a message argument" 351 352rpc_dma_direction rpc@(RPC _ rpcargs _) = case fromJust $ rpc_arg rpcargs $ rpc_dma_arg_name rpc of 353 (RPCArgIn _ _) -> TX 354 (RPCArgOut _ _) -> RX 355 356rpc_dma_args :: [TypeDef] -> MessageDef -> Maybe (Either C.Expr C.Expr, C.Expr) 357rpc_dma_args types rpc@(RPC name rpcargs metaargs) = 358 if not $ has_meta_arg "ata" "dma_arg" metaargs 359 then Nothing 360 else Just $ case rpc_dma_direction rpc of 361 TX -> (Left dma_arg_var, dma_arg_in_length_var) 362 RX -> (Right dma_arg_var, dma_arg_out_length_var) 363 where dma_arg_var = C.Variable $ rpc_dma_arg_name rpc 364 dma_arg_in_length_var = take_dma_size $ catMaybes dma_in_size_sources 365 dma_arg_out_length_var = take_dma_size $ catMaybes dma_out_size_sources 366 dma_in_size_sources = [ 367 dma_dyn_arg_size, 368 dma_arg_type_size, 369 meta_arg_dma_size 370 ] 371 dma_out_size_sources = [ 372 dma_arg_type_size, 373 meta_arg_dma_size 374 ] 375 dma_dyn_arg_size = case rpc_arg rpcargs $ rpc_dma_arg_name rpc of 376 Just (RPCArgIn (Builtin UInt8) (DynamicArray _ l _)) -> Just $ C.Variable l 377 _ -> Nothing 378 dma_arg_type_size = case lookup_typeref types $ rpc_arg_type $ fromJust $ rpc_arg rpcargs $ rpc_dma_arg_name rpc of 379 TArray (Builtin UInt8) _ length -> Just $ C.NumConstant length 380 _ -> Nothing 381 meta_arg_dma_size = case get_meta_arg "ata" "dma_size" metaargs of 382 Nothing -> Nothing 383 Just (BackendInt v) -> Just $ C.NumConstant v 384 Just (BackendMsgArg n) -> case rpc_arg rpcargs n of 385 Nothing -> rpc_error $ "unkown dma size argument " ++ n 386 Just (RPCArgIn _ _) -> Just $ C.Variable n 387 Just (RPCArgOut _ _) -> rpc_error "dma size arg must be input argument" 388 rpc_arg_type (RPCArgIn t _) = t 389 rpc_arg_type (RPCArgOut t _) = t 390 take_dma_size xs = case xs of 391 (x:[]) -> x 392 [] -> rpc_error "unable to determine dma_size" 393 _ -> rpc_error "dma_size is ambiguous" 394 rpc_error msg = error (msg ++ " for RPC " ++ name) 395 396cc_rx_fn :: String -> [TypeDef] -> MessageDef -> C.Unit 397cc_rx_fn ifn types msg@(RPC name rpcargs metaargs) = 398 C.FunctionDef C.Static C.Void (cc_rx_fn_name ifn name) params body 399 where 400 params = [ 401 binding_param "ahci", 402 C.Param (C.Ptr completed_rx_struct_type) "completed_st" 403 ] 404 body = [ 405 localvar ahci_bind_type "b" $ Just $ st_var `C.DerefField` (ifscope ahci_ifn "binding"), 406 C.SBlank, 407 408 C.Ex $ C.Call "AHCI_DEBUG" [C.StringConstant "entering %s\n", C.Variable "__func__"], 409 C.SBlank, 410 411 case dma_dir_m of 412 Just RX -> C.StmtList [ 413 localvar (C.Ptr $ C.TypeName "uint8_t") dma_data_name $ Just $ C.Call "malloc" [dma_size], 414 C.Ex $ C.Call "ahci_dma_region_copy_out" [pr_region_var, C.Variable dma_data_name, C.NumConstant 0, dma_size], 415 C.SBlank 416 ] 417 otherwise -> C.StmtList [], 418 419 C.Ex $ C.CallInd (C.FieldOf vtbl $ rpc_resp_name name) $ [C.AddressOf gen_binding] ++ (concat $ map (output_arg_expr dma_dir_m) outargs), 420 421 if has_dma 422 then C.StmtList [ 423 C.SBlank, 424 C.SComment "free dma region", 425 C.Ex $ C.Call "ahci_dma_region_free" [pr_region_var] 426 ] 427 else C.StmtList [] 428 ] 429 ahci_ifn = ahci_intf_name ifn 430 ahci_bind_type = C.Ptr $ C.Struct $ intf_bind_type ahci_ifn 431 432 st_var = C.Variable "completed_st" 433 ahci_binding = C.Variable "b" 434 gen_binding = ahci_binding `C.DerefField` "b" 435 lib_binding = C.Variable intf_bind_var 436 dma_data_name = "_data" 437 438 (_, outargs) = partition_rpc_args rpcargs 439 vtbl = gen_binding `C.FieldOf` "rx_vtbl" 440 pr_region_var = C.Variable "completed_st" `C.DerefField` "dma_region" 441 output_arg_expr :: Maybe Direction -> MessageArgument -> [C.Expr] 442 output_arg_expr _ (Arg (Builtin ErrVal) (Name "status")) = [C.Variable "SYS_ERR_OK"] 443 output_arg_expr (Just RX) (Arg (Builtin UInt8) (DynamicArray _ _ _)) = [C.Variable dma_data_name, dma_size] 444 output_arg_expr _ arg = error ("unrecoginized output argument " ++ (show arg)) 445 446 dma_args = rpc_dma_args types msg 447 has_dma = isJust dma_args 448 dma_dir_m = if has_dma then Just dma_direction else Nothing 449 -- following variables should only be used if has_dma == True 450 --dma_size = snd $ fromJust dma_args 451 dma_size = C.Variable "completed_st" `C.DerefField` "bytes" 452 dma_direction = rpc_dma_direction msg 453 dma_arg = head $ rights [fst $ fromJust dma_args] 454 455tx_fn :: String -> [TypeDef] -> MessageDef -> C.Unit 456tx_fn ifn types msg@(RPC name rpcargs metaargs) = 457 C.FunctionDef C.Static (C.TypeName "errval_t") (tx_fn_name ifn $ rpc_call_name name) params body 458 where 459 ahci_ifn = ahci_intf_name ifn 460 (txargs, _) = partition_rpc_args rpcargs 461 params = [binding_param ifn, cont_param] ++ (concat $ map (msg_argdecl TX ifn) txargs) 462 cont_param = C.Param (C.Struct "event_closure") intf_cont_var 463 unused s = C.Ex $ C.Cast C.Void $ C.Variable s 464 body = [ 465 localvar (C.TypeName "errval_t") "err" $ Just $ C.NumConstant 0, 466 let bind_ptr_type = C.Ptr $ C.Struct $ ahci_bind_type ahci_ifn 467 in localvar bind_ptr_type "b" $ Just $ C.Cast bind_ptr_type gen_bind_var, 468 C.SBlank, 469 C.Ex $ C.Call "AHCI_DEBUG" [C.StringConstant "entering %s\n", C.Variable "__func__"], 470 C.SBlank, 471 472 C.SComment "allocate state structure", 473 localvar (C.Ptr completed_rx_struct_type) completed_st_var_n $ Just $ C.Call "calloc" [ C.NumConstant 1, C.SizeOfT completed_rx_struct_type ], 474 C.If (C.Unary C.Not completed_st_var) [ 475 C.Ex $ C.Assignment errvar $ C.Variable "LIB_ERR_MALLOC_FAIL", 476 C.Goto "cleanup" 477 ] [], 478 C.Ex $ C.Assignment (completed_st_var `C.DerefField` "completed_fn") $ C.Variable $ cc_rx_fn_name ifn name, 479 C.Ex $ C.Assignment (completed_st_var `C.DerefField` (ahci_ifn ++ "_binding")) $ ahci_bind_var, 480 C.Ex $ C.Assignment (completed_st_var `C.DerefField` "dispatch_continuation") $ C.Variable intf_cont_var, 481 C.SBlank, 482 483 C.SComment "determine sector size", 484 localvar (C.TypeName "size_t") "sector_size" $ Just $ C.NumConstant 512, 485 let identify = C.AddressOf $ libahci_bind_var `C.DerefField` "identify" 486 in C.If (C.Call "ata_identify_plss_lls_rdf" [identify]) [ 487 C.Ex $ C.Assignment (C.Variable "sector_size") $ C.Binary C.Times (C.NumConstant 2) (C.Call "ata_identify_wpls_rd" [identify]) 488 ] [], 489 C.SBlank, 490 491 if has_dma 492 then C.StmtList [ 493 C.Ex $ C.Assignment dma_size_var dma_size, 494 C.SBlank, 495 496 C.SComment "determine sector count", 497 localvar (C.TypeName "size_t") "dma_count" Nothing, 498 let round_down_expr = C.Binary C.Divide dma_size_var $ C.Variable "sector_size" 499 round_up_expr = C.Call "CEIL_DIV" [dma_size_var, C.Variable "sector_size"] 500 assign var x = C.Ex $ C.Assignment var x 501 in meta_bool_arg_if "ata" "is_write" [ 502 -- writes must be rounded down, everything else can be rounded up 503 assign (C.Variable "dma_count") round_down_expr, 504 C.SComment "recalculate read size to match rounded down sector count", 505 assign dma_size_var $ C.Binary C.Times dma_count_var $ C.Variable "sector_size" 506 ] [ 507 assign (C.Variable "dma_count") round_up_expr 508 ], 509 C.SBlank, 510 511 C.SComment "determine size of DMA region, which must be a multiple of the sector count", 512 localvar (C.TypeName "size_t") "dma_region_size" $ Just $ C.Binary C.Times dma_count_var $ C.Variable "sector_size", 513 C.SBlank, 514 515 C.SComment "setup DMA region", 516 C.Ex $ C.Assignment errvar $ C.Call "ahci_dma_region_alloc" [ (C.Variable "dma_region_size"), C.AddressOf pr_region_var ], 517 C.If (C.Call "err_is_fail" [errvar]) [ 518 ahci_printf_error "alloc_region failed" errvar, 519 C.Goto "cleanup" 520 ] [], 521 C.SBlank 522 ] 523 else C.StmtList [], 524 525 if has_dma && (dma_direction == TX) 526 then C.StmtList [ 527 C.SComment "copy in DMA data", 528 C.Ex $ C.Call "ahci_dma_region_copy_in" [ 529 pr_region_var, 530 C.Cast (C.Ptr C.Void) dma_arg, 531 C.NumConstant 0, 532 dma_size_var 533 ], 534 C.SBlank 535 ] 536 else C.StmtList [], 537 538 C.SComment "setup FIS", 539 localvar (C.TypeName "size_t") fis_size_var_n Nothing, 540 C.Ex $ C.Assignment errvar $ C.Call "sata_alloc_h2d_register_fis" [(C.AddressOf fis_var), (C.AddressOf $ C.Variable fis_size_var_n)], 541 C.If (C.Call "err_is_fail" [errvar]) [ 542 ahci_printf_error "sata_alloc_h2d_register_fis failed" errvar, 543 C.Goto "cleanup" 544 ] [], 545 C.Ex $ C.Call "sata_set_command" [fis_var, meta_arg_expr_hex "ata" "command"], 546 if has_dma 547 then C.Ex $ C.Call "sata_set_count" [fis_var, C.Variable "dma_count"] 548 else C.StmtList [], 549 if has_meta_arg "ata" "lba" metaargs 550 then C.Ex $ C.Call "sata_set_lba28" [fis_var, meta_arg_expr "ata" "lba"] 551 else C.StmtList [], 552 C.SBlank, 553 554 C.SComment "issue command", 555 C.Ex $ C.Assignment errvar $ C.Call "ahci_issue_command" [ 556 libahci_bind_var, 557 C.Call "MKCLOSURE" [C.Variable issue_command_cb_fn_n, completed_st_var], 558 completed_st_var, 559 C.Cast (C.Ptr $ C.TypeName "uint8_t") fis_var, 560 C.Variable fis_size_var_n, 561 if has_meta_arg "ata" "is_write" metaargs then meta_arg_expr "ata" "is_write" else C.Variable "false", 562 if has_dma then pr_region_var else C.Variable "NULL", 563 if has_dma then dma_size_var else C.NumConstant 0 564 ], 565 C.If (C.Call "err_is_fail" [errvar]) [ 566 ahci_printf_error "ahci_issue_command failed" errvar, 567 C.Goto "cleanup" 568 ] [], 569 C.SBlank, 570 571 C.Return $ C.Variable "SYS_ERR_OK", 572 C.SBlank, 573 574 C.Label "cleanup", 575 C.SBlank, 576 577 C.SComment "free memory", 578 C.If (completed_st_var) [ 579 C.If (fis_var) [ 580 C.Ex $ C.Call "free" [fis_var] 581 ] [], 582 C.If (pr_region_var) [ 583 C.Ex $ C.Call "ahci_dma_region_free" [pr_region_var] 584 ] [], 585 C.Ex $ C.Call "free" [completed_st_var] 586 ] [], 587 C.SBlank, 588 589 C.Return errvar 590 ] 591 592 dma_args = rpc_dma_args types msg 593 has_dma = isJust dma_args 594 -- following variables should only be used if has_dma == True 595 dma_size = snd $ fromJust dma_args 596 dma_direction = rpc_dma_direction msg 597 dma_arg = head $ lefts [fst $ fromJust dma_args] 598 599 completed_st_var_n = "completed_st" 600 completed_st_var = C.Variable completed_st_var_n 601 pr_region_var = completed_st_var `C.DerefField` "dma_region" 602 dma_size_var = completed_st_var `C.DerefField` "bytes" 603 dma_count_var = C.Variable "dma_count" 604 fis_var = completed_st_var `C.DerefField` "fis" 605 fis_size_var_n = "fis_size" 606 607 gen_bind_var = C.Variable intf_bind_var 608 ahci_bind_var = C.Variable "b" 609 libahci_bind_var = ahci_bind_var `C.DerefField` "b_lib" 610 611 meta_arg_expr_conv conv nspc n = case meta_arg nspc n metaargs of 612 (BackendInt value) -> conv value 613 (BackendMsgArg ident) -> case rpc_arg rpcargs ident of 614 Just (RPCArgIn _ _) -> C.Variable ident 615 _ -> error ("meta-argument " ++ n ++ " must refer to an input argument") 616 meta_arg_expr = meta_arg_expr_conv C.NumConstant 617 meta_arg_expr_hex = meta_arg_expr_conv C.HexConstant 618 assign_fis n expr = C.Ex $ C.Assignment (C.FieldOf fis_var n) expr 619 shift_right n expr = C.Binary C.RightShift expr (C.NumConstant n) 620 bitwise_and n expr = C.Binary C.BitwiseAnd expr $ C.HexConstant n 621 meta_bool_arg_if nspc n true_stmts false_stmts = 622 if has_meta_arg nspc n metaargs 623 then case meta_arg nspc n metaargs of 624 (BackendInt value) -> C.StmtList $ if value /= 0 then true_stmts else false_stmts 625 (BackendMsgArg ident) -> C.If (meta_arg_expr nspc n) true_stmts false_stmts 626 else C.StmtList false_stmts 627 628 629tx_vtbl :: Interface -> C.Unit 630tx_vtbl interface@(Interface ifn descr decls) = 631 C.StructDef C.Static (intf_vtbl_type ifn TX) (ahci_vtbl_name ifn) fields 632 where 633 (types, messagedecls) = Backend.partitionTypesMessages decls 634 fields = concat $ map assn_msg_handlers messagedecls 635 assn_msg_handlers (Message _ mn _ _) = [(mn, "NULL")] 636 assn_msg_handlers (RPC rpcn _ _) = [(rpc_call_name rpcn, tx_fn_name ifn $ rpc_call_name rpcn), 637 (rpc_resp_name rpcn, "NULL")] 638 639ahci_init_fn :: Interface -> C.Unit 640ahci_init_fn intf@(Interface ifn descr decls) = 641 C.FunctionDef C.NoScope (C.TypeName "errval_t") (ahci_init_fn_name ifn) params body 642 where 643 params = [ 644 C.Param (C.Ptr $ C.Struct (intf_bind_type $ ahci_intf_name ifn)) "binding", 645 C.Param (C.Ptr $ C.Struct "waitset") "waitset", 646 C.Param (C.Ptr $ C.Struct (intf_bind_type "ahci")) "ahci_binding" 647 ] 648 body = [ 649 localvar (C.TypeName "errval_t") "err" $ Just $ C.Variable "SYS_ERR_OK", 650 C.SBlank, 651 652 C.StmtList $ binding_struct_init "ahci" ifn gen_binding (C.Variable "waitset") (C.Variable $ ahci_vtbl_name ifn), 653 C.Ex $ C.Assignment (gen_binding `C.FieldOf` "change_waitset") $ C.Variable $ ifscope (ahci_intf_name ifn) "change_waitset", 654 C.SBlank, 655 656 C.Ex $ C.Assignment lib_binding (C.Variable "ahci_binding"), 657 C.Ex $ C.CallInd (lib_binding `C.DerefField` "change_waitset") [lib_binding, C.Variable "waitset"], 658 C.SBlank, 659 660 C.Ex $ C.Assignment (lib_binding `C.DerefField` "rx_vtbl" `C.FieldOf` "command_completed") (C.Variable ahci_command_completed_rx_name), 661 C.SBlank, 662 663 C.SComment "initialize DMA buffer pool with 1M space", 664 C.Ex $ C.Call "ahci_dma_pool_init" [ C.NumConstant (1024 * 1024) ], 665 C.SBlank, 666 667 C.Return $ errvar 668 ] 669 ahci_binding = C.Variable "binding" 670 gen_binding = ahci_binding `C.DerefField` "b" 671 lib_binding = ahci_binding `C.DerefField` "b_lib" 672