{- 
   BackendCommon: Common code used by most backends
   
  Part of Flounder: a message passing IDL for Barrelfish
   
  Copyright (c) 2007-2010, 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 BackendCommon where

import qualified CAbsSyntax as C
import Syntax

data Direction = TX | RX
    deriving (Show, Eq)

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

-- Scope a list of strings
ifscope :: String -> String -> String
--ifscope ifn s = ifn ++ "$" ++ s
ifscope ifn s = ifn ++ "_" ++ s

idscope :: String -> String -> String -> String
idscope ifn s suffix  = ifscope ifn (s ++ "__" ++ suffix)

drvscope :: String -> String -> String -> String
drvscope drv ifn s = ifscope ifn (drv ++ "_" ++ s)

-- Name of the binding struct for an interface type
intf_bind_type :: String -> String
intf_bind_type ifn = ifscope ifn "binding"

-- Variable used to refer to a binding
intf_bind_var = "_binding"

-- Name of the binding struct for an interface type
intf_frameinfo_type :: String -> String
intf_frameinfo_type ifn = ifscope ifn "frameinfo"

-- Variable used to refer to a continuation
intf_frameinfo_var = "_frameinfo"



-- Name of the bind continuation function type for an interface type
intf_bind_cont_type :: String -> String
intf_bind_cont_type ifn = ifscope ifn "bind_continuation_fn"

-- Variable used to refer to a continuation
intf_cont_var = "_continuation"

-- name of the export state struct
export_type n = ifscope n "export"

-- Name of the enumeration of message numbers
msg_enum_name :: String -> String
msg_enum_name ifn = ifscope ifn "msg_enum"

-- Name of each element of the message number enumeration
msg_enum_elem_name :: String -> String -> String
msg_enum_elem_name ifn mn = idscope ifn mn "msgnum" 

-- Name of the type of a message function
msg_sig_type :: String -> MessageDef -> Direction -> String
msg_sig_type ifn m@(RPC _ _ _) _ = idscope ifn (msg_name m) "rpc_method_fn"
msg_sig_type ifn m TX = idscope ifn (msg_name m) "tx_method_fn"
msg_sig_type ifn m RX =  idscope ifn (msg_name m) "rx_method_fn"

-- Name of a given message definition
msg_name :: MessageDef -> String
msg_name (Message _ n _ _) = n
msg_name (RPC n _ _) = n

-- Name of the static inline wrapper for sending messages
tx_wrapper_name :: String -> String -> String
tx_wrapper_name ifn mn = idscope ifn mn "tx"

-- Names of the underlying messages that are constructed from an RPC
rpc_call_name n = n ++ "_call"
rpc_resp_name n = n ++ "_response"

-- Name of the struct holding message args for SAR
msg_argstruct_name :: String -> String -> String
msg_argstruct_name ifn n = idscope ifn n "args"

-- Name of the union type holding all the arguments for a message
binding_arg_union_type :: String -> String
binding_arg_union_type ifn = ifscope ifn "arg_union"

-- Name of the C type for a concrete flounder type, struct, or enum
type_c_struct, type_c_enum :: String -> String -> String
type_c_struct ifn n = "_" ++ idscope ifn n "struct"
type_c_enum ifn e = ifscope ifn e

type_c_name :: String -> TypeRef -> String
type_c_name ifn (Builtin Cap) = undefined
type_c_name ifn (Builtin GiveAwayCap) = undefined
type_c_name ifn (Builtin String) = undefined
type_c_name ifn (Builtin t) = (show t) ++ "_t"
type_c_name ifn (TypeVar t) = type_c_name1 ifn t
type_c_name ifn (TypeAlias t _) = type_c_name1 ifn t

type_c_name1 :: String -> String -> String
type_c_name1 ifn tn = (ifscope ifn tn) ++ "_t"

type_c_type :: String -> TypeRef -> C.TypeSpec
type_c_type ifn (Builtin Cap) = C.Struct "capref"
type_c_type ifn (Builtin GiveAwayCap) = C.Struct "capref"
type_c_type ifn (Builtin Char) = C.TypeName "char"
type_c_type ifn (Builtin Bool) = C.TypeName "bool"
type_c_type ifn (Builtin String) = C.Ptr $ C.TypeName "char"
type_c_type ifn t = C.TypeName $ type_c_name ifn t

-- TX pointers should be const
type_c_type_dir :: Direction -> String -> TypeRef -> C.TypeSpec
type_c_type_dir TX ifn tr = case type_c_type ifn tr of
    C.Ptr t -> C.Ptr $ C.ConstT t
    t -> t
type_c_type_dir RX ifn tr = type_c_type ifn tr

-- Array types in the msg args struct should only be pointers to the storage
type_c_type_msgstruct :: String -> [TypeDef] -> TypeRef -> C.TypeSpec
type_c_type_msgstruct ifn typedefs t
    = case lookup_typeref typedefs t of
        TArray tr n _ -> C.Ptr $ type_c_type ifn t
        _ -> type_c_type ifn t

-- Name of the struct type for the method vtable
intf_vtbl_type :: String -> Direction -> String
intf_vtbl_type ifn TX = ifscope ifn "tx_vtbl"
intf_vtbl_type ifn RX = ifscope ifn "rx_vtbl"

connect_callback_name n = ifscope n "connect_fn" 
drv_connect_handler_name drv n = drvscope drv n "connect_handler"
drv_connect_fn_name drv n = drvscope drv n "connect"
drv_accept_fn_name drv n = drvscope drv n "accept"
can_send_fn_name drv n = drvscope drv n "can_send"
register_send_fn_name drv n = drvscope drv n "register_send"
default_error_handler_fn_name drv n = drvscope drv n "default_error_handler"
generic_control_fn_name drv n = drvscope drv n "control"

can_send_fn_type ifn = ifscope ifn "can_send_fn"
register_send_fn_type ifn = ifscope ifn "register_send_fn"
change_waitset_fn_type ifn = ifscope ifn "change_waitset_fn"
control_fn_type ifn = ifscope ifn "control_fn"
error_handler_fn_type ifn = ifscope ifn "error_handler_fn"


------------------------------------------------------------------------
-- Code shared by backend implementations
------------------------------------------------------------------------

intf_preamble :: String -> String -> Maybe String -> C.Unit
intf_preamble infile name descr = 
    let dstr = case descr of
                 Nothing -> "not specified"
                 Just s -> s
    in
    C.MultiComment [ 
          "Copyright (c) 2010, ETH Zurich.",
          "All rights reserved.",
          "",
          "INTERFACE NAME: " ++ name,
          "INTEFACE FILE: " ++ infile,
          "INTERFACE DESCRIPTION: " ++ dstr,
          "",
          "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, Universitaetstr.6, CH-8092 Zurich.",
          "Attn: Systems Group.",
          "",
          "THIS FILE IS AUTOMATICALLY GENERATED BY FLOUNDER: DO NOT EDIT!" ]

--
-- Convert each RPC definition to a pair of underlying call/response messages
--
rpcs_to_msgs :: [MessageDef] -> [MessageDef]
rpcs_to_msgs ml = concat $ map rpc_to_msgs ml

rpc_to_msgs :: MessageDef -> [MessageDef]
rpc_to_msgs (RPC n rpcargs bckargs) = [Message MCall (rpc_call_name n) inargs bckargs,
                                       Message MResponse (rpc_resp_name n) outargs bckargs]
    where
        (inargs, outargs) = partition_rpc_args rpcargs
rpc_to_msgs m = [m]


-- partition a list of RPC arguments to lists of input and output arguments
partition_rpc_args :: [RPCArgument] -> ([MessageArgument], [MessageArgument])
partition_rpc_args [] = ([], [])
partition_rpc_args (first:rest) = case first of
    RPCArgIn t v -> ((Arg t v):restin, restout)
    RPCArgOut t v -> (restin, (Arg t v):restout)
    where
        (restin, restout) = partition_rpc_args rest

msg_argdecl :: Direction -> String -> MessageArgument -> [C.Param]
msg_argdecl dir ifn (Arg tr (Name n)) = 
    [ C.Param (type_c_type_dir dir ifn tr) n ]
msg_argdecl RX ifn (Arg tr (DynamicArray n l)) = 
    [ C.Param (C.Ptr $ type_c_type_dir RX ifn tr) n, 
      C.Param (type_c_type_dir RX ifn size) l ]
msg_argdecl TX ifn (Arg tr (DynamicArray n l)) = 
    [ C.Param (C.Ptr $ C.ConstT $ type_c_type_dir TX ifn tr) n, 
      C.Param (type_c_type_dir TX ifn size) l ]

msg_argstructdecl :: String -> [TypeDef] -> MessageArgument -> [C.Param]
msg_argstructdecl ifn typedefs (Arg tr (Name n)) = 
    [ C.Param (type_c_type_msgstruct ifn typedefs tr) n ]
msg_argstructdecl ifn typedefs a = msg_argdecl RX ifn a

rpc_argdecl :: String -> RPCArgument -> [C.Param]
rpc_argdecl ifn (RPCArgIn tr v) = msg_argdecl TX ifn (Arg tr v)
rpc_argdecl ifn (RPCArgOut tr (Name n)) = [ C.Param (C.Ptr $ type_c_type ifn tr) n ]
rpc_argdecl ifn (RPCArgOut tr (DynamicArray n l)) = 
    [ C.Param (C.Ptr $ C.Ptr $ type_c_type ifn tr) n, 
      C.Param (C.Ptr $ type_c_type ifn size) l ]

-- XXX: kludge wrapper to pass array types by reference in RPC
rpc_argdecl2 :: String -> [TypeDef] -> RPCArgument -> [C.Param]
rpc_argdecl2 ifn typedefs arg@(RPCArgOut tr (Name n))
    = case lookup_typeref typedefs tr of
      TArray _ _ _ -> [ C.Param (C.Ptr $ C.Ptr $ type_c_type ifn tr) n ]
      _ -> rpc_argdecl ifn arg
rpc_argdecl2 ifn _ arg = rpc_argdecl ifn arg

-- binding parameter for a function
binding_param ifname = C.Param (C.Ptr $ C.Struct $ intf_bind_type ifname) intf_bind_var


--
-- Generate the code to initialise/destroy a binding structure instance
--
binding_struct_init :: String -> String -> C.Expr -> C.Expr ->  C.Expr -> [C.Stmt]
binding_struct_init drv ifn binding_var waitset_ex tx_vtbl_ex = [
    C.Ex $ C.Assignment (C.FieldOf binding_var "st") (C.Variable "NULL"),
    C.Ex $ C.Assignment (C.FieldOf binding_var "waitset") waitset_ex,
    C.Ex $ C.Call "event_mutex_init" [C.AddressOf $ C.FieldOf binding_var "mutex", waitset_ex],
    C.Ex $ C.Assignment (C.FieldOf binding_var "can_send")
                                (C.Variable $ can_send_fn_name drv ifn),
    C.Ex $ C.Assignment (C.FieldOf binding_var "register_send")
                                (C.Variable $ register_send_fn_name drv ifn),
    C.Ex $ C.Assignment (C.FieldOf binding_var "error_handler")
                                (C.Variable $ default_error_handler_fn_name drv ifn),
    C.Ex $ C.Assignment (C.FieldOf binding_var "tx_vtbl") tx_vtbl_ex,
    C.Ex $ C.Call "memset" [C.AddressOf $ C.FieldOf binding_var "rx_vtbl",
                            C.NumConstant 0,
                            C.Call "sizeof" [C.FieldOf binding_var "rx_vtbl"]],
    C.Ex $ C.Call "flounder_support_waitset_chanstate_init"
            [C.AddressOf $ C.FieldOf binding_var "register_chanstate"],
    C.Ex $ C.Call "flounder_support_waitset_chanstate_init"
            [C.AddressOf $ C.FieldOf binding_var "tx_cont_chanstate"],
    C.StmtList
        [C.Ex $ C.Assignment (C.FieldOf binding_var f) (C.NumConstant 0)
         | f <- ["tx_msgnum", "rx_msgnum", "tx_msg_fragment", "rx_msg_fragment",
                 "tx_str_pos", "rx_str_pos", "tx_str_len", "rx_str_len"]],
    C.Ex $ C.Assignment (C.FieldOf binding_var "bind_cont") (C.Variable "NULL")]

binding_struct_destroy :: String -> C.Expr -> [C.Stmt]
binding_struct_destroy ifn binding_var
    = [C.Ex $ C.Call "flounder_support_waitset_chanstate_destroy"
            [C.AddressOf $ C.FieldOf binding_var "register_chanstate"],
       C.Ex $ C.Call "flounder_support_waitset_chanstate_destroy"
            [C.AddressOf $ C.FieldOf binding_var "tx_cont_chanstate"]]

--
-- Generate a generic can_send function
--
can_send_fn_def :: String -> String -> C.Unit
can_send_fn_def drv ifn = 
    C.FunctionDef C.Static (C.TypeName "bool") (can_send_fn_name drv ifn) params [
        C.Return $ C.Binary C.Equals (bindvar `C.DerefField` "tx_msgnum") (C.NumConstant 0)
    ]
    where
        params = [ C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) "b" ]
        bindvar = C.Variable "b"

--
-- generate a generic register_send function
--
register_send_fn_def :: String -> String -> C.Unit
register_send_fn_def drv ifn =
    C.FunctionDef C.Static (C.TypeName "errval_t") (register_send_fn_name drv ifn) params [
        C.Return $ C.Call "flounder_support_register"
            [C.Variable "ws",
             C.AddressOf $ bindvar `C.DerefField` "register_chanstate",
             C.Variable intf_cont_var,
             C.Call (can_send_fn_name drv ifn) [bindvar]]
    ]
    where
        params = [ C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) "b",
                   C.Param (C.Ptr $ C.Struct "waitset") "ws",
                   C.Param (C.Struct "event_closure") intf_cont_var ]
        bindvar = C.Variable "b"

--
-- generate a default error handler (which the user should replace!)
--
default_error_handler_fn_def :: String -> String -> C.Unit
default_error_handler_fn_def drv ifn =
    C.FunctionDef C.Static C.Void (default_error_handler_fn_name drv ifn) params [
        C.Ex $ C.Call "DEBUG_ERR"
            [errvar, C.StringConstant $
             "asynchronous error in Flounder-generated " ++
             ifn ++ " " ++ drv ++ " binding (default handler)" ],
        C.Ex $ C.Call "abort" []
    ]
    where
        params = [ C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) "b",
                   C.Param (C.TypeName "errval_t") "err" ]

--
-- generate a generic control function that does nothing
--
generic_control_fn_def :: String -> String -> C.Unit
generic_control_fn_def drv ifn = 
    C.FunctionDef C.Static (C.TypeName "errval_t") (generic_control_fn_name drv ifn) params [
        C.SComment "no control flags are supported",
        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"]

-- register a transmit continuation
register_txcont :: C.Expr -> [C.Stmt]
register_txcont cont_ex = [
    C.If (C.Binary C.NotEquals (cont_ex `C.FieldOf` "handler") (C.Variable "NULL"))
        [localvar (C.TypeName "errval_t") "_err" Nothing,
         C.Ex $ C.Assignment errvar $ C.Call "flounder_support_register"
            [bindvar `C.DerefField` "waitset",
             C.AddressOf $ bindvar `C.DerefField` "tx_cont_chanstate",
             cont_ex,
             C.Variable "false"],
         C.SComment "may fail if previous continuation hasn't fired yet",
         C.If (C.Call "err_is_fail" [errvar])
            [C.If (C.Binary C.Equals (C.Call "err_no" [errvar])
                                     (C.Variable "LIB_ERR_CHAN_ALREADY_REGISTERED"))
                [C.Return $ C.Variable "FLOUNDER_ERR_TX_BUSY"]
                [C.Ex $ C.Call "assert" [C.Unary C.Not $ C.StringConstant "shouldn't happen"],
                 C.Return $ errvar] ] []
         ] []
    ] where
        errvar = C.Variable "_err"

-- starting a send: just a debug hook
start_send :: String -> String -> String -> [MessageArgument] -> [C.Stmt]
start_send drvn ifn mn msgargs
    = [C.Ex $ C.Call "FL_DEBUG" [C.StringConstant $
                                 drvn ++ " TX " ++ ifn ++ "." ++ mn ++ "\n"]]

-- finished a send: clear msgnum, trigger pending waitsets/events
finished_send :: [C.Stmt]
finished_send = [
    C.Ex $ C.Assignment tx_msgnum_field (C.NumConstant 0)] ++
    [C.Ex $ C.Call "flounder_support_trigger_chan" [wsaddr ws]
    | ws <- ["tx_cont_chanstate", "register_chanstate"]]
    where
        tx_msgnum_field = C.DerefField bindvar "tx_msgnum"
        wsaddr ws = C.AddressOf $ bindvar `C.DerefField` ws

-- start receiving: allocate space for any static arrays in message
start_recv :: String -> String -> [TypeDef] -> String -> [MessageArgument] -> [C.Stmt]
start_recv drvn ifn typedefs mn msgargs
  = concat [
    [C.Ex $ C.Assignment (field fn)
          $ C.Call "malloc" [C.SizeOfT $ type_c_type ifn tr],
     C.Ex $ C.Call "assert" [C.Binary C.NotEquals (field fn) (C.Variable "NULL")]
    ] | Arg tr (Name fn) <- msgargs, is_array tr]
    
    where
      field fn = rx_union_elem mn fn
      is_array tr = case lookup_typeref typedefs tr of
        TArray _ _ _ -> True
        _ -> False

-- finished recv: debug, run handler and clean up
finished_recv :: String -> String -> [TypeDef] -> String -> [MessageArgument] -> [C.Stmt]
finished_recv drvn ifn typedefs mn msgargs
    = [C.Ex $ C.Call "FL_DEBUG" [C.StringConstant $
                                 drvn ++ " RX " ++ ifn ++ "." ++ mn ++ "\n"],
       C.Ex $ C.Call "assert" [C.Binary C.NotEquals handler (C.Variable "NULL")],
       C.Ex $ C.CallInd handler (bindvar:args),
       C.Ex $ C.Assignment rx_msgnum_field (C.NumConstant 0)]
    where
        rx_msgnum_field = C.DerefField bindvar "rx_msgnum"
        handler = C.DerefField bindvar "rx_vtbl" `C.FieldOf` mn
        args = concat [mkargs tr a | Arg tr a <- msgargs]
        mkargs tr (Name n) = case lookup_typeref typedefs tr of
          TArray _ _ _ -> [C.DerefPtr $ rx_union_elem mn n]
          _ -> [rx_union_elem mn n]
        mkargs _ (DynamicArray n l) = [rx_union_elem mn n, rx_union_elem mn l]

tx_arg_assignment :: String -> [TypeDef] -> String -> MessageArgument -> C.Stmt
tx_arg_assignment ifn typedefs mn (Arg tr v) = case v of
    Name an -> C.Ex $ C.Assignment (tx_union_elem mn an) (srcarg an)
    DynamicArray an len -> C.StmtList [
        C.Ex $ C.Assignment (tx_union_elem mn an) (C.Cast (C.Ptr typespec) (C.Variable an)),
        C.Ex $ C.Assignment (tx_union_elem mn len) (C.Variable len)]
    where
        typespec = type_c_type ifn tr
        srcarg an = 
          case lookup_typeref typedefs tr of
            -- XXX: I have no idea why GCC requires a cast for the array type
            TArray _ _ _ -> C.Cast (C.Ptr typespec) (C.Variable an)
            _             -> case typespec of
              -- we may need to cast away the const on a pointer
              C.Ptr _ -> C.Cast typespec (C.Variable an)
              _ -> C.Variable an


tx_union_elem :: String -> String -> C.Expr
tx_union_elem mn fn
   = bindvar `C.DerefField` "tx_union" `C.FieldOf` mn `C.FieldOf` fn

rx_union_elem :: String -> String -> C.Expr
rx_union_elem mn fn
   = bindvar `C.DerefField` "rx_union" `C.FieldOf` mn `C.FieldOf` fn

-- misc common bits of C
localvar = C.VarDecl C.NoScope C.NonConst
errvar = C.Variable "err"
bindvar = C.Variable intf_bind_var
report_user_err ex = C.Ex $ C.CallInd (C.DerefField bindvar "error_handler") [bindvar, ex]
report_user_tx_err ex = C.StmtList [
    report_user_err ex,
    C.Ex $ C.Assignment tx_msgnum_field (C.NumConstant 0),
    C.Ex $ C.Call "flounder_support_trigger_chan" [wsaddr "register_chanstate"],
    C.Ex $ C.Call "flounder_support_deregister_chan" [wsaddr "tx_cont_chanstate"]
    ] where
        tx_msgnum_field = C.DerefField bindvar "tx_msgnum"
        wsaddr ws = C.AddressOf $ bindvar `C.DerefField` ws
