{-
   LMP.hs: Flounder stub generator for local message passing.

  Part of Flounder: a message passing IDL for Barrelfish

  Copyright (c) 2007-2011, ETH Zurich.
  All rights reserved.

  This file is distributed under the terms in the attached LICENSE file.
  If you do not find this file, copies can be found by writing to:
  ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
-}

module LMP where

import Data.Bits

import qualified CAbsSyntax as C
import qualified Backend
import GHBackend
import MsgFragments
import Syntax
import Arch
import BackendCommon

------------------------------------------------------------------------
-- Language mapping: C identifier names
------------------------------------------------------------------------

drvname = "lmp"

-- Name of the binding struct
lmp_bind_type :: String -> String
lmp_bind_type ifn = ifscope ifn "lmp_binding"

-- Name of the local variable used for the LMP-specific binding type
lmp_bind_var_name :: String
lmp_bind_var_name = "b"
lmp_bind_var = C.Variable lmp_bind_var_name

-- Name of the bind function
lmp_bind_fn_name n = ifscope n "lmp_bind"

-- Name of the bind continuation function
lmp_bind_cont_fn_name n = ifscope n "lmp_bind_continuation"

-- Name of the init function
lmp_init_fn_name n = ifscope n "lmp_init"

-- Name of the destroy function
lmp_destroy_fn_name n = ifscope n "lmp_destroy"

-- Name of the transmit function
tx_fn_name ifn mn = idscope ifn mn "lmp_send"

-- Name of the transmit handler
tx_handler_name ifn mn = idscope ifn mn "lmp_send_handler"

-- Name of the transmit vtable
lmp_vtbl_name ifn = ifscope ifn "lmp_tx_vtbl"

-- Name of the receive handler
rx_handler_name ifn = ifscope ifn "lmp_rx_handler"

-- Names of the control functions
change_waitset_fn_name ifn = ifscope ifn "lmp_change_waitset"
control_fn_name ifn = ifscope ifn "lmp_control"
receive_next_fn_name ifn = ifscope ifn "lmp_receive_next"
get_receiving_chanstate_fn_name ifn = ifscope ifn "lmp_get_receiving_chanstate"

------------------------------------------------------------------------
-- Language mapping: Create the header file for this interconnect driver
------------------------------------------------------------------------

header :: String -> String -> Interface -> String
header infile outfile intf =
    unlines $ C.pp_unit $ header_file intf (lmp_header_body infile intf)
    where
        header_file :: Interface -> [C.Unit] -> C.Unit
        header_file interface@(Interface name _ _) body =
            let sym = "__" ++ name ++ "_LMP_H"
            in C.IfNDef sym ([ C.Define sym [] "1"] ++ body) []

lmp_header_body :: String -> Interface -> [C.Unit]
lmp_header_body infile interface@(Interface name descr decls) = [
    intf_preamble infile name descr,
    C.Blank,
    C.MultiComment [ "LMP interconnect driver" ],
    C.Blank,
    C.Include C.Standard "barrelfish/lmp_chan.h",
    C.Blank,
    lmp_binding_struct name,
    C.Blank,
    lmp_init_function_proto name,
    lmp_destroy_function_proto name,
    lmp_bind_function_proto name,
    lmp_connect_handler_proto name,
    lmp_rx_handler_proto name,
    C.Blank
    ]

lmp_binding_struct :: String -> C.Unit
lmp_binding_struct ifn = C.StructDecl (lmp_bind_type ifn) fields
  where
    fields = [
        C.Param (C.Struct $ intf_bind_type ifn) "b",
        C.Param (C.Struct "lmp_chan") "chan",
        C.Param (C.TypeName "lmp_send_flags_t") "flags"
        ]

lmp_init_function_proto :: String -> C.Unit
lmp_init_function_proto n =
    C.GVarDecl C.Extern C.NonConst
         (C.Function C.NoScope C.Void params) name Nothing
    where
      name = lmp_init_fn_name n
      params = [C.Param (C.Ptr $ C.Struct (lmp_bind_type n)) "b",
                C.Param (C.Ptr $ C.Struct "waitset") "waitset"]

lmp_destroy_function_proto :: String -> C.Unit
lmp_destroy_function_proto n =
    C.GVarDecl C.Extern C.NonConst
         (C.Function C.NoScope C.Void params) name Nothing
    where
      name = lmp_destroy_fn_name n
      params = [C.Param (C.Ptr $ C.Struct (lmp_bind_type n)) "b"]

lmp_bind_function_proto :: String -> C.Unit
lmp_bind_function_proto n =
    C.GVarDecl C.Extern C.NonConst
         (C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing
    where
      name = lmp_bind_fn_name n
      params = lmp_bind_params n

lmp_bind_params n = [ C.Param (C.Ptr $ C.Struct (lmp_bind_type n)) "b",
                 C.Param (C.TypeName "iref_t") "iref",
                 C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var,
                 C.Param (C.Ptr $ C.TypeName "void") "st",
                 C.Param (C.Ptr $ C.Struct "waitset") "waitset",
                 C.Param (C.TypeName "idc_bind_flags_t") "flags",
                 C.Param (C.TypeName "size_t") "lmp_buflen" ]

lmp_rx_handler_proto ifn = C.GVarDecl C.Extern C.NonConst
    (C.Function C.NoScope C.Void [C.Param (C.Ptr C.Void) "arg"])
    (rx_handler_name ifn) Nothing

lmp_connect_handler_proto :: String -> C.Unit
lmp_connect_handler_proto ifn = C.GVarDecl C.Extern C.NonConst
    (C.Function C.NoScope (C.TypeName "errval_t") lmp_connect_handler_params)
    (drv_connect_handler_name drvname ifn) Nothing

lmp_connect_handler_params :: [C.Param]
lmp_connect_handler_params
    = [C.Param (C.Ptr $ C.Void) "st",
       C.Param (C.TypeName "size_t") "buflen_words",
       C.Param (C.Struct "capref") "endpoint",
       C.Param (C.Ptr $ C.Ptr $ C.Struct "lmp_chan") "retchan"]


------------------------------------------------------------------------
-- Language mapping: Create the stub (implementation) for this interconnect driver
------------------------------------------------------------------------

stub :: Arch -> String -> String -> Interface -> String
stub arch infile outfile intf =
    unlines $ C.pp_unit $ lmp_stub_body arch infile intf

lmp_stub_body :: Arch -> String -> Interface -> C.Unit
lmp_stub_body arch infile intf@(Interface ifn descr decls) = C.UnitList [
    intf_preamble infile ifn descr,
    C.Blank,
    C.MultiComment [ "Generated Stub for LMP on " ++ archname arch ],
    C.Blank,

    C.Include C.Standard "string.h",
    C.Include C.Standard "barrelfish/barrelfish.h",
    C.Include C.Standard "flounder/flounder_support.h",
    C.Include C.Standard "flounder/flounder_support_lmp.h",
    C.Include C.Standard ("if/" ++ ifn ++ "_defs.h"),
    C.Blank,

    C.MultiComment [ "Send handler functions" ],
    C.UnitList [ tx_handler arch ifn m | m <- msg_specs ],
    C.Blank,

    C.MultiComment [ "Message sender functions" ],
    C.UnitList [ tx_fn ifn types m | m <- messages ],
    C.Blank,

    C.MultiComment [ "Send vtable" ],
    tx_vtbl ifn messages,

    C.MultiComment [ "Receive handler" ],
    rx_handler arch ifn types messages msg_specs,
    C.Blank,

    C.MultiComment [ "Control functions" ],
    can_send_fn_def drvname ifn,
    register_send_fn_def drvname ifn,
    default_error_handler_fn_def drvname ifn,
    change_waitset_fn_def ifn,
    control_fn_def ifn,
    receive_next_fn_def ifn,
    get_receiving_chanstate_fn_def ifn,

    C.MultiComment [ "Functions to initialise/destroy the binding state" ],
    lmp_init_fn ifn,
    lmp_destroy_fn ifn,
    C.Blank,

    C.MultiComment [ "Bind function" ],
    lmp_bind_cont_fn ifn,
    lmp_bind_fn ifn,
    C.Blank,

    C.MultiComment [ "Connect callback for export" ],
    lmp_connect_handler_fn ifn
    ]
    where
        (types, messagedecls) = Backend.partitionTypesMessages decls
        messages = rpcs_to_msgs messagedecls
        msg_specs = [build_lmp_msg_spec arch types m | m <- messages]

lmp_init_fn :: String -> C.Unit
lmp_init_fn ifn = C.FunctionDef C.NoScope C.Void (lmp_init_fn_name ifn) params [
    C.StmtList common_init,
    C.Ex $ C.Call "lmp_chan_init" [C.AddressOf $ C.DerefField lmp_bind_var "chan"],
    C.Ex $ C.Assignment (C.FieldOf (common_field "tx_cont_chanstate") "trigger") (C.AddressOf $ C.FieldOf (C.DerefField lmp_bind_var "chan") "send_waitset"),
    C.Ex $ C.Assignment (common_field "change_waitset") (C.Variable $ change_waitset_fn_name ifn),
    C.Ex $ C.Assignment (common_field "control") (C.Variable $ control_fn_name ifn),
    C.Ex $ C.Assignment (common_field "receive_next") (C.Variable $ receive_next_fn_name ifn),
    C.Ex $ C.Assignment (common_field "get_receiving_chanstate") (C.Variable $ get_receiving_chanstate_fn_name ifn),
    C.Ex $ C.Assignment
            (C.DerefField lmp_bind_var "flags")
            (C.Variable "LMP_SEND_FLAGS_DEFAULT")]
    where
      params = [C.Param (C.Ptr $ C.Struct (lmp_bind_type ifn)) lmp_bind_var_name,
                C.Param (C.Ptr $ C.Struct "waitset") "waitset"]
      common_field f = lmp_bind_var `C.DerefField` "b" `C.FieldOf` f
      common_init = binding_struct_init drvname ifn
        (C.DerefField lmp_bind_var "b")
        (C.Variable "waitset")
        (C.Variable $ lmp_vtbl_name ifn)

lmp_destroy_fn :: String -> C.Unit
lmp_destroy_fn ifn = C.FunctionDef C.NoScope C.Void (lmp_destroy_fn_name ifn) params [
    C.StmtList common_destroy,
    C.Ex $ C.Call "lmp_chan_destroy" [C.AddressOf $ C.DerefField lmp_bind_var "chan"]]
    where
      params = [C.Param (C.Ptr $ C.Struct (lmp_bind_type ifn)) lmp_bind_var_name]
      common_destroy = binding_struct_destroy ifn (C.DerefField lmp_bind_var "b")

lmp_bind_fn :: String -> C.Unit
lmp_bind_fn ifn =
    C.FunctionDef C.NoScope (C.TypeName "errval_t") (lmp_bind_fn_name ifn) params [
        localvar (C.TypeName "errval_t") "err" Nothing,
        C.Ex $ C.Call (lmp_init_fn_name ifn) [lmp_bind_var, C.Variable "waitset"],
        C.Ex $ C.Assignment (intf_bind_field "st") (C.Variable "st"),
        C.Ex $ C.Assignment (intf_bind_field "bind_cont") (C.Variable intf_cont_var),
        C.Ex $ C.Assignment errvar $ C.Call "lmp_chan_bind"
            [C.AddressOf $ lmp_bind_var `C.DerefField` "chan",
             C.StructConstant "lmp_bind_continuation"
                [("handler", C.Variable (lmp_bind_cont_fn_name ifn)),
                 ("st", lmp_bind_var)],
             C.AddressOf $ intf_bind_field "event_qnode",
             C.Variable "iref",
             C.Variable "lmp_buflen"],
        C.If (C.Call "err_is_fail" [errvar])
            [C.Ex $ C.Call (lmp_destroy_fn_name ifn) [lmp_bind_var]] [],
        C.Return errvar
    ]
    where
      params = lmp_bind_params ifn
      intf_bind_field = C.FieldOf (C.DerefField lmp_bind_var "b")

lmp_bind_cont_fn :: String -> C.Unit
lmp_bind_cont_fn ifn =
    C.FunctionDef C.Static C.Void (lmp_bind_cont_fn_name ifn) params [
        localvar (C.Ptr $ C.Struct $ lmp_bind_type ifn)
            lmp_bind_var_name (Just $ C.Variable "st"),
        localvar (C.Ptr $ C.Struct $ intf_bind_type ifn)
             intf_bind_var (Just $ C.AddressOf $ lmp_bind_var `C.DerefField` "b"),
        C.SBlank,

        C.If (C.Call "err_is_ok" [errvar])
            [C.SComment "allocate a cap receive slot",
             C.Ex $ C.Assignment errvar $
                        C.Call "lmp_chan_alloc_recv_slot" [chanaddr],
             C.If (C.Call "err_is_fail" [errvar])
                [C.Ex $ C.Assignment errvar $
                        C.Call "err_push"
                                [errvar, C.Variable "LIB_ERR_LMP_ALLOC_RECV_SLOT"],
                 C.Goto "fail"] [],
             C.SBlank,

             C.SComment "register for receive",
             C.Ex $ C.Assignment errvar $ C.Call "lmp_chan_register_recv"
                [chanaddr, C.FieldOf intf_var "waitset",
                 C.StructConstant "event_closure"
                        [("handler", C.Variable $ rx_handler_name ifn),
                         ("arg", lmp_bind_var)]],
             C.If (C.Call "err_is_fail" [errvar])
                [C.Ex $ C.Assignment errvar $
                        C.Call "err_push"
                                [errvar, C.Variable "LIB_ERR_CHAN_REGISTER_RECV"],
                 C.Goto "fail"] [],
             C.Ex $ C.Call (connect_handlers_fn_name ifn) [C.Variable intf_bind_var]]
            [C.Label "fail",
             C.Ex $ C.Call (lmp_destroy_fn_name ifn) [lmp_bind_var]],
        C.SBlank,

        C.Ex $ C.CallInd (intf_var `C.FieldOf` "bind_cont")
            [intf_var `C.FieldOf` "st", errvar, C.AddressOf intf_var]
    ]
    where
      params = [C.Param (C.Ptr C.Void) "st",
                C.Param (C.TypeName "errval_t") "err",
                C.Param (C.Ptr $ C.Struct "lmp_chan") "chan"]
      intf_var = C.DerefField lmp_bind_var "b"
      errvar = C.Variable "err"
      chanaddr = C.Variable "chan"

lmp_connect_handler_fn :: String -> C.Unit
lmp_connect_handler_fn ifn = C.FunctionDef C.NoScope (C.TypeName "errval_t")
    (drv_connect_handler_name "lmp" ifn) lmp_connect_handler_params [
    localvar (C.Ptr $ C.Struct $ export_type ifn) "e" $ Just $ C.Variable "st",
    localvar (C.TypeName "errval_t") "err" Nothing,
    C.SBlank,
    C.SComment "allocate storage for binding",
    localvar (C.Ptr $ C.Struct $ lmp_bind_type ifn) lmp_bind_var_name
        $ Just $ C.Call "malloc" [C.SizeOfT $ C.Struct $ lmp_bind_type ifn],
    C.If (C.Binary C.Equals lmp_bind_var (C.Variable "NULL"))
        [C.Return $ C.Variable "LIB_ERR_MALLOC_FAIL"] [],
    C.SBlank,

    localvar (C.Ptr $ C.Struct $ intf_bind_type ifn)
         intf_bind_var (Just $ C.AddressOf $ lmp_bind_var `C.DerefField` "b"),
    C.Ex $ C.Call (lmp_init_fn_name ifn) [lmp_bind_var,
                                          exportvar `C.DerefField` "waitset"],
    C.SBlank,

    C.SComment "run user's connect handler",
    C.Ex $ C.Call "assert" [(C.DerefField exportvar "connect_cb")],
    C.Ex $ C.Assignment errvar $ C.CallInd (C.DerefField exportvar "connect_cb")
                       [C.DerefField exportvar "st", bindvar],
    C.If (C.Call "err_is_fail" [errvar])
        [C.SComment "connection refused",
         C.Ex $ C.Call (lmp_destroy_fn_name ifn) [lmp_bind_var],
         C.Return $ errvar] [],
    C.SBlank,

    C.SComment "accept the connection and setup the channel",
    C.SComment "FIXME: user policy needed to decide on the size of the message buffer?",
    C.Ex $ C.Assignment errvar $ C.Call "lmp_chan_accept"
                                [C.AddressOf $ C.DerefField lmp_bind_var "chan",
                                 C.Variable "buflen_words", C.Variable "endpoint"],
    C.If (C.Call "err_is_fail" [errvar])
        [C.Ex $ C.Assignment errvar $ C.Call "err_push"
                    [errvar, C.Variable "LIB_ERR_LMP_CHAN_ACCEPT"],
         report_user_err errvar,
         C.Return $ errvar] [],
    C.SBlank,

    C.SComment "allocate a cap receive slot",
    C.Ex $ C.Assignment errvar $
            C.Call "lmp_chan_alloc_recv_slot" [chanaddr],
    C.If (C.Call "err_is_fail" [errvar])
        [C.Ex $ C.Assignment errvar $ C.Call "err_push"
                        [errvar, C.Variable "LIB_ERR_LMP_ALLOC_RECV_SLOT"],
         report_user_err errvar,
         C.Return $ errvar] [],
    C.SBlank,

    C.Ex $ C.Call (connect_handlers_fn_name ifn) [C.Variable intf_bind_var],
    C.SBlank,

    C.SComment "register for receive",
    C.Ex $ C.Assignment errvar $ C.Call "lmp_chan_register_recv"
        [chanaddr, C.DerefField bindvar "waitset",
         C.StructConstant "event_closure"
            [("handler", C.Variable $ rx_handler_name ifn),
             ("arg", lmp_bind_var)]],
    C.If (C.Call "err_is_fail" [errvar])
        [C.Ex $ C.Assignment errvar $ C.Call "err_push"
                        [errvar, C.Variable "LIB_ERR_CHAN_REGISTER_RECV"],
         report_user_err errvar,
         C.Return $ errvar] [],
    C.SBlank,

    C.Ex $ C.Assignment (C.DerefPtr $ C.Variable "retchan") chanaddr,
    C.SBlank,
    C.Return $ C.Variable "SYS_ERR_OK"]
    where
        exportvar = C.Variable "e"
        chanaddr = C.AddressOf $ C.DerefField lmp_bind_var "chan"

change_waitset_fn_def :: String -> C.Unit
change_waitset_fn_def ifn =
    C.FunctionDef C.Static (C.TypeName "errval_t") (change_waitset_fn_name ifn) params [
        localvar (C.Ptr $ C.Struct $ lmp_bind_type ifn)
            lmp_bind_var_name (Just $ C.Cast (C.Ptr C.Void) bindvar),
        C.SBlank,

        C.SComment "Migrate register and TX continuation notifications",
        C.Ex $ C.Call "flounder_support_migrate_notify" [register_chanstate, C.Variable "ws"],
        C.Ex $ C.Call "flounder_support_migrate_notify" [tx_cont_chanstate, C.Variable "ws"],
        C.SBlank,
        C.Ex $ C.Call (disconnect_handlers_fn_name ifn) [bindvar],

        C.SComment "change waitset on binding",
        C.Ex $ C.Assignment
            (bindvar `C.DerefField` "waitset")
            (C.Variable "ws"),
        C.SBlank,

        C.Ex $ C.Call (connect_handlers_fn_name ifn) [bindvar],

        C.SComment "Migrate send and receive notifications",
        C.Ex $ C.Call "lmp_chan_migrate_recv" [chanaddr, C.Variable "ws"],
        C.Ex $ C.Call "lmp_chan_migrate_send" [chanaddr, C.Variable "ws"],
        C.SBlank,

        C.Return $ C.Variable "SYS_ERR_OK"
    ]
    where
        register_chanstate = C.AddressOf $ C.DerefField bindvar "register_chanstate"
        tx_cont_chanstate = C.AddressOf $ C.DerefField bindvar "tx_cont_chanstate"
        chanaddr = C.AddressOf $ C.DerefField lmp_bind_var "chan"
        params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var,
                  C.Param (C.Ptr $ C.Struct "waitset") "ws"]

control_fn_def :: String -> C.Unit
control_fn_def ifn =
    C.FunctionDef C.Static (C.TypeName "errval_t") (control_fn_name ifn) params [
        localvar (C.Ptr $ C.Struct $ lmp_bind_type ifn)
            lmp_bind_var_name (Just $ C.Cast (C.Ptr C.Void) $ C.Variable intf_bind_var),
        C.SBlank,

        C.Ex $ C.Assignment
            (C.DerefField lmp_bind_var "flags")
            (C.Call "idc_control_to_lmp_flags" [C.Variable "control", C.DerefField lmp_bind_var "flags"]),
        C.SBlank,

        C.Return $ C.Variable "SYS_ERR_OK"
    ]
    where
        params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var,
                  C.Param (C.TypeName "idc_control_t") "control"]

receive_next_fn_def :: String -> C.Unit
receive_next_fn_def ifn =
    C.FunctionDef C.Static (C.TypeName "errval_t") (receive_next_fn_name ifn) params [
        localvar (C.TypeName "errval_t") "err" Nothing,
        localvar (C.Ptr $ C.Struct $ lmp_bind_type ifn)
            lmp_bind_var_name (Just $ C.Cast (C.Ptr C.Void) $ C.Variable intf_bind_var),
        localvar (C.Struct "event_closure") "recv_closure"
            (Just $ C.StructConstant "event_closure" [
                ("handler", C.Variable $ rx_handler_name ifn),
                ("arg", C.Variable intf_bind_var)]),
        C.SBlank,
        C.SComment "register for another receive notification",
        C.Ex $ C.Assignment errvar $ C.Call "lmp_chan_register_recv"
            [chanaddr, C.DerefField bindvar "waitset", C.Variable "recv_closure"],
        C.Ex $ C.Call "assert" [C.Call "err_is_ok" [errvar]],
        C.Return $ C.Variable "SYS_ERR_OK"
    ]
    where
        params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var]
        chanaddr = C.AddressOf $ C.DerefField lmp_bind_var "chan"

get_receiving_chanstate_fn_def :: String -> C.Unit
get_receiving_chanstate_fn_def ifn =
    C.FunctionDef C.Static (C.Ptr $ C.Struct "waitset_chanstate") (get_receiving_chanstate_fn_name ifn) params [
        localvar (C.Ptr $ C.Struct $ lmp_bind_type ifn)
            lmp_bind_var_name (Just $ C.Cast (C.Ptr C.Void) $ C.Variable intf_bind_var),
        C.SBlank,
        C.Return $ C.Call "lmp_chan_get_receiving_channel" [C.AddressOf $ C.DerefField lmp_bind_var "chan"]
    ]
    where
        params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var]

handler_preamble :: String -> C.Stmt
handler_preamble ifn = C.StmtList
    [C.SComment "Get the binding state from our argument pointer",
     localvar (C.Ptr $ C.Struct $ intf_bind_type ifn)
         intf_bind_var (Just $ C.Variable "arg"),
     localvar (C.Ptr $ C.Struct $ lmp_bind_type ifn)
         lmp_bind_var_name (Just $ C.Variable "arg"),
     localvar (C.TypeName "errval_t") "err" Nothing,
     C.SBlank]

tx_handler :: Arch -> String -> LMPMsgSpec -> C.Unit
tx_handler arch ifn (LMPMsgSpec mn msgfrags) =
    C.FunctionDef C.Static C.Void (tx_handler_name ifn mn) [C.Param (C.Ptr C.Void) "arg"] [
        handler_preamble ifn,
        C.Ex $ C.Call "thread_mutex_lock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"],
        C.SComment "Switch on current outgoing message fragment",
        C.Switch (C.DerefField bindvar "tx_msg_fragment") cases bad,
        C.SBlank,
        C.If (C.Call "lmp_err_is_transient" [errvar])
            -- transient errors
            [C.SComment "Construct retry closure and register it",
             localvar (C.Struct "event_closure") "retry_closure"
                    (Just $ C.StructConstant "event_closure" [
                            ("handler", C.Variable $ tx_handler_name ifn mn),
                            ("arg", C.Variable "arg")]),
             C.Ex $ C.Assignment errvar
                        (C.Call "lmp_chan_register_send" [
                            C.AddressOf $ C.DerefField lmp_bind_var "chan",
                            C.DerefField bindvar "waitset",
                            C.Variable "retry_closure"]),
             C.Ex $ C.Call "assert" [C.Call "err_is_ok" [errvar]]]
             -- permanent errors
            [C.SComment "Report error to user",
             report_user_tx_err errvar
            ],
        C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"]
        ]
    where
        cases = [let isLast = (i == length msgfrags - 1) in
                 C.Case (C.NumConstant $ toInteger i)
                 $ (tx_handler_case arch ifn mn frag isLast) ++ [gentest isLast]
                 | (frag, i) <- zip msgfrags [0 ..]]
        bad = [C.Ex $ C.Call "assert" [C.Unary C.Not $ C.StringConstant "invalid fragment"],
            C.Ex $ C.Assignment errvar (C.Variable "FLOUNDER_ERR_INVALID_STATE")]

        -- generate the if() that checks the result of sending
        gentest isLast = C.If (C.Call "err_is_ok" [errvar])
          (if isLast then -- if the last fragment succeeds, we're done
            finished_send ++ [
            C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"],
                    C.ReturnVoid]
           else
            [C.Ex $ C.PostInc $ C.DerefField bindvar "tx_msg_fragment",
             C.SComment "fall through to next fragment"])
          -- else case is always the same
          [C.Break]
        tx_msgnum_field = C.DerefField bindvar "tx_msgnum"

tx_handler_case :: Arch -> String -> String -> LMPMsgFragment -> Bool -> [C.Stmt]
tx_handler_case arch ifn mn (LMPMsgFragment (MsgFragment words) cap) isLast =
    [C.Ex $ C.Assignment errvar (C.Call send_fn_name args)]
    where
        send_fn_name = "lmp_chan_send" ++ show (length words)
        args = [chan_arg, flag_arg, cap_arg] ++ (map (fragment_word_to_expr arch ifn mn) words)
        chan_arg = C.AddressOf $ C.DerefField lmp_bind_var "chan"
        lmp_sync_flag f -- only set the sync flag on the last fragment
            | isLast = f
            | otherwise = C.Binary C.BitwiseAnd f $ C.Unary C.BitwiseNot (C.Variable "LMP_FLAG_SYNC")
        giveaway_flag f = case cap of
            Just (CapFieldTransfer GiveAway _) -> C.Binary C.BitwiseOr f (C.Variable "LMP_FLAG_GIVEAWAY")
            _ -> f
        flag_arg = (lmp_sync_flag . giveaway_flag) flag_var
        flag_var = C.DerefField lmp_bind_var "flags"
        cap_arg = case cap of
            Just (CapFieldTransfer _ af) -> argfield_expr TX mn af
            Nothing -> C.Variable "NULL_CAP"

tx_handler_case arch ifn mn (LMPMsgFragment (OverflowFragment _) (Just _)) _ =
    error "cannot send caps in same fragment as strings/buffers: NYI"

tx_handler_case arch ifn mn (LMPMsgFragment (OverflowFragment (StringFragment af)) Nothing) isLast =
    [C.Ex $ C.Assignment errvar (C.Call "flounder_stub_lmp_send_string" args)]
    where
        args = [chan_arg, flag_arg, string_arg, pos_arg, len_arg]
        chan_arg = C.AddressOf $ C.DerefField lmp_bind_var "chan"
        flag_arg -- only set the sync flag on the last fragment
            | isLast = flag_var
            | otherwise = C.Binary C.BitwiseAnd flag_var $ C.Unary C.BitwiseNot (C.Variable "LMP_FLAG_SYNC")
        flag_var = C.DerefField lmp_bind_var "flags"
        string_arg = argfield_expr TX mn af
        pos_arg = C.AddressOf $ C.DerefField bindvar "tx_str_pos"
        len_arg = C.AddressOf $ C.DerefField bindvar "tx_str_len"

tx_handler_case arch ifn mn (LMPMsgFragment (OverflowFragment (BufferFragment _ afn afl)) Nothing) isLast =
    [C.Ex $ C.Assignment errvar (C.Call "flounder_stub_lmp_send_buf" args)]
    where
        args = [chan_arg, flag_arg, buf_arg, len_arg, pos_arg]
        chan_arg = C.AddressOf $ C.DerefField lmp_bind_var "chan"
        flag_arg -- only set the sync flag on the last fragment
            | isLast = flag_var
            | otherwise = C.Binary C.BitwiseAnd flag_var $ C.Unary C.BitwiseNot (C.Variable "LMP_FLAG_SYNC")
        flag_var = C.DerefField lmp_bind_var "flags"
        buf_arg = argfield_expr TX mn afn
        len_arg = argfield_expr TX mn afl
        pos_arg = C.AddressOf $ C.DerefField bindvar "tx_str_pos"

tx_fn :: String -> [TypeDef] -> MessageDef -> C.Unit
tx_fn ifn typedefs msg@(Message mtype n args _) =
    C.FunctionDef C.Static (C.TypeName "errval_t") (tx_fn_name ifn n) params body
    where
        params = [binding_param ifn, cont_param] ++ (
                    concat [ msg_argdecl TX ifn a | a <- args ])
        cont_param = C.Param (C.Struct "event_closure") intf_cont_var
        body = [
            -- check size of message
            C.StmtList [ tx_fn_arg_check_size ifn typedefs n a | a <- args ],
            C.SComment "check that we can accept an outgoing message",
            C.Ex $ C.Call "thread_mutex_lock" [C.AddressOf $ C.DerefField bindvar "send_mutex"],
            C.Ex $ C.Assignment binding_error (C.Variable "SYS_ERR_OK"),
            C.If (C.Binary C.NotEquals tx_msgnum_field (C.NumConstant 0))
                [C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "send_mutex"],
                 C.Return $ C.Variable "FLOUNDER_ERR_TX_BUSY"] [],
            C.SBlank,
            C.SComment "register send continuation",
            C.StmtList $ register_txcont (C.Variable intf_cont_var),
            C.SBlank,
            C.SComment "store message number and arguments",
            C.Ex $ C.Assignment binding_outgoing_token (C.Binary C.BitwiseAnd binding_incoming_token (C.Variable "~1" )),
            C.Ex $ C.Call "thread_get_outgoing_token" [C.AddressOf binding_outgoing_token],
            C.Ex $ C.Assignment tx_msgnum_field (C.Variable $ msg_enum_elem_name ifn n),
            C.Ex $ C.Assignment tx_msgfrag_field (C.NumConstant 0),
            C.StmtList [ tx_arg_assignment ifn typedefs n a | a <- args ],
            C.StmtList $ start_send drvname ifn n args,
            C.SBlank,
            C.SComment "try to send!",
            C.Ex $ C.Call (tx_handler_name ifn n) [C.Variable intf_bind_var],
            C.StmtList $ block_sending (C.Variable intf_cont_var),
            C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "send_mutex"],
            C.SBlank,
            C.Return binding_error
            ]
        tx_msgnum_field = C.DerefField bindvar "tx_msgnum"
        tx_msgfrag_field = C.DerefField bindvar "tx_msg_fragment"
        binding_incoming_token = C.DerefField bindvar "incoming_token"
        binding_outgoing_token = C.DerefField bindvar "outgoing_token"

tx_vtbl :: String -> [MessageDef] -> C.Unit
tx_vtbl ifn ml =
    C.StructDef C.Static (intf_vtbl_type ifn TX) (lmp_vtbl_name ifn) fields
    where
        fields = [let mn = msg_name m in (mn, tx_fn_name ifn mn) | m <- ml]

rx_handler :: Arch -> String -> [TypeDef] -> [MessageDef] -> [LMPMsgSpec] -> C.Unit
rx_handler arch ifn typedefs msgdefs msgs =
    C.FunctionDef C.NoScope C.Void (rx_handler_name ifn) [C.Param (C.Ptr C.Void) "arg"] [
        handler_preamble ifn,
        localvar (C.Struct "lmp_recv_msg") "msg" (Just $ C.Variable "LMP_RECV_MSG_INIT"),
        localvar (C.Struct "capref") "cap" Nothing,
        localvar (C.TypeName "int") "__attribute__ ((unused)) no_register" (Just $ C.NumConstant 0),
        localvar (C.TypeName "int") "call_msgnum" $ Just $ C.NumConstant 0,

        -- declare closure for retry
        localvar (C.Struct "event_closure") "recv_closure"
            (Just $ C.StructConstant "event_closure" [
                ("handler", C.Variable $ rx_handler_name ifn),
                ("arg", C.Variable "arg")]),
        C.SBlank,

        C.Ex $ C.Call "thread_mutex_lock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"],

        C.DoWhile (C.Call "err_is_ok" [errvar]) [

        C.If (C.Unary C.Not $ C.Call "lmp_chan_can_recv" [chanaddr]) [C.Goto "out"] [],

        C.SComment "try to retrieve a message from the channel",
        C.Ex $ C.Assignment errvar
                $ C.Call "lmp_chan_recv" [chanaddr,
                        C.AddressOf $ C.Variable "msg",
                        C.AddressOf $ C.Variable "cap"],

        C.SComment "check if we succeeded",
        C.If (C.Call "err_is_fail" [errvar])
            -- if err_is_fail, check err_no
            [C.If (C.Binary C.Equals (C.Call "err_no" [errvar]) (C.Variable "LIB_ERR_NO_LMP_MSG"))
                [C.SComment "no message",
                 C.Ex $ C.Assignment errvar $ C.Variable "SYS_ERR_OK",
                 C.Continue]
                [C.SComment "real error",
                 report_user_err $ C.Call "err_push" [errvar, C.Variable "LIB_ERR_LMP_CHAN_RECV"],
                 C.ReturnVoid]
            ]
            [],
        C.SBlank,

        C.SComment "get or allocate a new receive slot if needed",
        localvar (C.TypeName "struct capref") "nextslot" (Just (
            C.Call "thread_get_next_recv_slot" []
        )),
        C.If (C.Unary C.Not $ C.Call "capref_is_null" [C.Variable "cap"])
        [
            C.If (C.Call "capref_is_null" [ C.Variable "nextslot" ]) [
                 C.Ex $ C.Assignment errvar $
                    C.Call "lmp_chan_alloc_recv_slot" [chanaddr],
                 C.If (C.Call "err_is_fail" [errvar])
                    [report_user_err $
                        C.Call "err_push" [errvar, C.Variable "LIB_ERR_LMP_ALLOC_RECV_SLOT"]]
                    []
            ] [
                C.Ex $ C.Call "lmp_chan_set_recv_slot" [chanaddr, C.Variable "nextslot" ]
            ]
        ] [
            -- Free popped recv slot if we didn't use it!
            C.SComment "Free the popped receive slot, if we did not use it",
            C.Ex $ C.Call "slot_free" [ C.Variable "nextslot" ]
        ],
        C.SBlank,

        C.SComment "is this the start of a new message?",
        C.If (C.Binary C.Equals rx_msgnum_field (C.NumConstant 0)) [
            C.SComment "check message length",
            C.If (C.Binary C.Equals msglen (C.NumConstant 0)) [
                report_user_err $ C.Variable "FLOUNDER_ERR_RX_EMPTY_MSG",
                C.Break] [],

            C.SComment "unmarshall message number from first word, set fragment to 0",
            C.Ex $ C.Assignment rx_msgnum_field $
                C.Binary C.BitwiseAnd (C.SubscriptOf msgwords $ C.NumConstant 0) msgnum_mask,
            C.Ex $ C.Assignment rx_msgfrag_field (C.NumConstant 0)
        ] [],
        C.SBlank,

        C.SComment "switch on message number and fragment number",
        C.Switch rx_msgnum_field msgnum_cases bad_msgnum
        ], -- end of the while(1) loop

        C.Label "out",
        C.If (C.Unary C.Not (C.Variable "no_register"))
            [C.SComment "re-register for another receive notification",
            C.Ex $ C.Assignment errvar $ C.Call "lmp_chan_register_recv"
                [chanaddr, C.DerefField bindvar "waitset", C.Variable "recv_closure"],
            C.Ex $ C.Call "assert" [C.Call "err_is_ok" [errvar]]]
            [],
        C.If (C.Variable "call_msgnum") [C.Ex $ C.Assignment rx_msgnum_field (C.NumConstant 0)] [],
        C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"],
        C.Switch (C.Variable "call_msgnum") call_cases [C.Break]
        ]
    where
        chanaddr = C.AddressOf $ C.DerefField lmp_bind_var "chan"
        msglen = C.Variable "msg" `C.FieldOf` "buf" `C.FieldOf` "msglen"
        msgwords = C.Variable "msg" `C.FieldOf` "words"
        msgnum_mask = C.HexConstant ((shift 1 msgnum_bits) - 1)
        msgnum_bits = bitsizeof_argfieldfrag arch MsgCode
        rx_msgnum_field = C.DerefField bindvar "rx_msgnum"
        rx_msgfrag_field = C.DerefField bindvar "rx_msg_fragment"
        binding_incoming_token = C.DerefField bindvar "incoming_token"

        capref_is_null c = C.Call "capref_is_null" [C.Variable c]
        in_rpc = (C.Call "thread_get_rpc_in_progress" [])
        need_slot_alloc c = C.Binary C.And (C.Unary C.Not (capref_is_null c))
                                           (C.Unary C.Not in_rpc)

        call_cases = [C.Case (C.Variable $ msg_enum_elem_name ifn mn) (call_msgnum_case msgdef msg)
                            | (msgdef, msg@(LMPMsgSpec mn _)) <- zip msgdefs msgs]

        call_msgnum_case msgdef@(Message mtype mn msgargs _) (LMPMsgSpec _ frags) =
            [C.StmtList $ call_handler drvname ifn typedefs mtype mn msgargs, C.Break]

        msgnum_cases = [C.Case (C.Variable $ msg_enum_elem_name ifn mn) (msgnum_case msgdef msg)
                            | (msgdef, msg@(LMPMsgSpec mn _)) <- zip msgdefs msgs]

        msgnum_case msgdef@(Message _ _ msgargs _) (LMPMsgSpec mn frags) = [
            C.Switch rx_msgfrag_field
                [C.Case (C.NumConstant $ toInteger i) $
                    (if i == 0 then start_recv drvname ifn typedefs mn msgargs
                     else [])
                    ++ msgfrag_case msgdef (frags !! i) (i == length frags - 1)
                 | i <- [0 .. length frags - 1]]
                bad_msgfrag,
            C.Break]

        bad_msgnum = [report_user_err $ C.Variable "FLOUNDER_ERR_RX_INVALID_MSGNUM",
                      C.Goto "out"]

        bad_msgfrag = [report_user_err $ C.Variable "FLOUNDER_ERR_INVALID_STATE",
                      C.Goto "out"]

        msgfrag_case :: MessageDef -> LMPMsgFragment -> Bool -> [C.Stmt]
        msgfrag_case msg@(Message _ mn _ _) (LMPMsgFragment (MsgFragment wl) cap) isLast = [
            C.SComment "check length",
            -- XXX: LRPC always delivers a message of a fixed size
            C.If (if (length wl < lrpc_words arch)
                    then C.Binary C.GreaterThan msglen
                            (C.NumConstant $ toInteger $ lrpc_words arch)
                    else C.Binary C.NotEquals msglen
                            (C.NumConstant $ toInteger $ length wl)) [
                report_user_err $ C.Variable "FLOUNDER_ERR_RX_INVALID_LENGTH",
                C.Goto "out"] [],
            C.SBlank,

            C.StmtList $ concat [store_arg_frags arch ifn mn msgwords word 0 afl
                                 | (afl, word) <- zip wl [0..]],
            case cap of
                Just (CapFieldTransfer _ af) -> C.StmtList [
                      C.Ex $ C.Assignment (argfield_expr RX mn af) (C.Variable "cap")
                     ]
                Nothing -> C.StmtList [],
            C.SBlank,

            msgfrag_case_prolog msg isLast,
            C.Break]

        msgfrag_case msg@(Message _ mn _ _) (LMPMsgFragment (OverflowFragment (StringFragment af)) _) isLast = [
            C.Ex $ C.Assignment errvar (C.Call "flounder_stub_lmp_recv_string" args),
            C.If (C.Call "err_is_ok" [errvar])
                [msgfrag_case_prolog msg isLast]
                -- error from string receive code, check if it's permanent
                [C.If (C.Binary C.NotEquals
                        (C.Call "err_no" [errvar])
                        (C.Variable "FLOUNDER_ERR_BUF_RECV_MORE"))
                    [report_user_err errvar] -- real error
                    [] -- will receive more next time
                ],
            C.Break]
            where
                args = [msg_arg, string_arg, pos_arg, len_arg, maxsize]
                msg_arg = C.AddressOf $ C.Variable "msg"
                string_arg = argfield_expr RX mn af
                pos_arg = C.AddressOf $ C.DerefField bindvar "rx_str_pos"
                len_arg = C.AddressOf $ C.DerefField bindvar "rx_str_len"
                maxsize = C.SizeOf $ string_arg

        msgfrag_case msg@(Message _ mn _ _) (LMPMsgFragment (OverflowFragment (BufferFragment _ afn afl)) _) isLast = [
            C.Ex $ C.Assignment errvar (C.Call "flounder_stub_lmp_recv_buf" args),
            C.If (C.Call "err_is_ok" [errvar])
                [msgfrag_case_prolog msg isLast]
                -- error from receive code, check if it's permanent
                [C.If (C.Binary C.NotEquals
                        (C.Call "err_no" [errvar])
                        (C.Variable "FLOUNDER_ERR_BUF_RECV_MORE"))
                    [report_user_err errvar] -- real error
                    [] -- will receive more next time
                ],
            C.Break]
            where
                args = [msg_arg, buf_arg, len_arg, pos_arg, maxsize]
                msg_arg = C.AddressOf $ C.Variable "msg"
                buf_arg = C.Cast (C.Ptr C.Void) $ argfield_expr RX mn afn
                len_arg = C.AddressOf $ argfield_expr RX mn afl
                pos_arg = C.AddressOf $ C.DerefField bindvar "rx_str_pos"
                maxsize = C.SizeOf $ argfield_expr RX mn afn

        msgfrag_case_prolog :: MessageDef -> Bool -> C.Stmt
        -- intermediate fragment
        msgfrag_case_prolog _ False
            = C.Ex $ C.PostInc $ C.DerefField bindvar "rx_msg_fragment"

        -- last fragment: call handler and zero message number
        msgfrag_case_prolog (Message mtype mn msgargs _) True
            = C.StmtList [
                C.StmtList $ (finished_recv_nocall drvname ifn typedefs mtype mn msgargs),
                                C.Goto "out"
            ]
            where
                lmp_chan = C.AddressOf $ C.DerefField lmp_bind_var "chan"