bdb274c9d2e80f434b4e72740156333e935ae7f6
[barrelfish] / tools / flounder / AHCI.hs
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
14 module AHCI where
15
16 import Data.Maybe
17 import Data.Either
18 import BackendCommon hiding (can_send_fn_def, register_send_fn_def)
19 import Syntax
20 import qualified Backend
21 import qualified GHBackend as GH
22 import qualified CAbsSyntax as C
23
24
25 -- handle printing of error values
26 ahci_err_fmt = C.NStr "PRIxERRV"
27 ahci_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
35 ahci_bind_type :: String -> String
36 ahci_bind_type ifn = ifscope ifn "binding"
37
38 -- Name of command completed dispatcher
39 cc_rx_fn_name ifn mn = idscope ifn mn "completed"
40
41 ahci_intf_name ifn = "ahci_" ++ ifn
42
43 ahci_init_fn_name ifn = ifscope (ahci_intf_name ifn) "init"
44
45 -- Name of the transmit function
46 tx_fn_name ifn n = idscope ifn n "ahci_send"
47
48 ahci_vtbl_name ifn = ifscope ifn "ahci_tx_vtbl"
49
50 ------------------------------------------------------------------------
51 -- Header
52 ------------------------------------------------------------------------
53
54 header :: String -> String -> Interface -> String
55 header 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
61 ahci_header_file :: String -> Interface -> [C.Unit]
62 ahci_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
92 ahci_binding_struct :: String -> [MessageDef] -> C.Unit
93 ahci_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
106 ahci_init_fn_proto :: String -> C.Unit
107 ahci_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
122 stub :: String -> String -> Interface -> String
123 stub infile outfile interface@(Interface name _ _) =
124     unlines $ C.pp_unit $ C.UnitList $ ahci_stub_body infile interface
125
126 ahci_stub_body :: String -> Interface -> [C.Unit]
127 ahci_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
197 completed_rx_struct_n = "completed_rx_st"
198 completed_rx_struct_type = C.Struct completed_rx_struct_n
199 completed_rx_struct_decl :: C.Unit
200 completed_rx_struct_decl = C.StructForwardDecl completed_rx_struct_n
201 completed_rx_struct :: String -> C.Unit
202 completed_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
221 completed_rx_typedef_n = "completed_rx_fn_t"
222 completed_rx_typedef :: C.Unit
223 completed_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
230 ahci_command_completed_rx_name = "ahci_command_completed__rx"
231 ahci_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
249 issue_command_cb_fn_n = "issue_command_cb"
250 issue_command_cb_fn :: C.Unit
251 issue_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
268 can_send_fn_def :: Interface -> C.Unit
269 can_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
282 register_send_fn_def :: Interface -> C.Unit
283 register_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
304 change_waitset_fn_def :: Interface -> C.Unit
305 change_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
328 rpc_arg :: [RPCArgument] -> String -> Maybe RPCArgument
329 rpc_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
335 get_meta_arg :: String -> String -> [(String, [(String, MetaArgument)])] -> Maybe MetaArgument
336 get_meta_arg nspc n metaargs = (lookup nspc metaargs) >>= (lookup n)
337
338 has_meta_arg :: String -> String -> [(String, [(String, MetaArgument)])] -> Bool
339 has_meta_arg nspc n metaargs = isJust $ get_meta_arg nspc n metaargs
340
341 meta_arg :: String -> String -> [(String, [(String, MetaArgument)])] -> MetaArgument
342 meta_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
347 rpc_dma_arg_name :: MessageDef -> String
348 rpc_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
352 rpc_dma_direction rpc@(RPC _ rpcargs _) = case fromJust $ rpc_arg rpcargs $ rpc_dma_arg_name rpc of
353     (RPCArgIn _ _) -> TX
354     (RPCArgOut _ _) -> RX
355
356 rpc_dma_args :: [TypeDef] -> MessageDef -> Maybe (Either C.Expr C.Expr, C.Expr)
357 rpc_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
396 cc_rx_fn :: String -> [TypeDef] -> MessageDef -> C.Unit
397 cc_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 (TypeAlias "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
455 tx_fn :: String -> [TypeDef] -> MessageDef -> C.Unit
456 tx_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
629 tx_vtbl :: Interface -> C.Unit
630 tx_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
639 ahci_init_fn :: Interface -> C.Unit
640 ahci_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"