+generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
+ = let
+ -- useful constants
+ addr_usizeW = untaggedSizeW AddrRep
+ addr_tsizeW = taggedSizeW AddrRep
+
+ -- Get the args on the stack, with tags and suitably
+ -- dereferenced for the CCall. For each arg, return the
+ -- depth to the first word of the bits for that arg, and the
+ -- PrimRep of what was actually pushed.
+
+ pargs d [] = returnBc []
+ pargs d ((_,a):az)
+ = let arg_ty = repType (exprType (deAnnotate' a))
+
+ in case splitTyConApp_maybe arg_ty of
+ -- Don't push the FO; instead push the Addr# it
+ -- contains.
+ Just (t, _)
+ | t == foreignObjPrimTyCon
+ -> pushAtom False{-irrelevant-} d p a
+ `thenBc` \ (push_fo, _) ->
+ let foro_szW = taggedSizeW PtrRep
+ d_now = d + addr_tsizeW
+ code = push_fo `appOL` toOL [
+ UPK_TAG addr_usizeW 0 0,
+ SLIDE addr_tsizeW foro_szW
+ ]
+ in pargs d_now az `thenBc` \ rest ->
+ returnBc ((code, AddrRep) : rest)
+
+ | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
+ -> pargs (d + addr_tsizeW) az `thenBc` \ rest ->
+ parg_ArrayishRep arrPtrsHdrSize d p a
+ `thenBc` \ code ->
+ returnBc ((code,AddrRep):rest)
+
+ | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
+ -> pargs (d + addr_tsizeW) az `thenBc` \ rest ->
+ parg_ArrayishRep arrWordsHdrSize d p a
+ `thenBc` \ code ->
+ returnBc ((code,AddrRep):rest)
+
+ -- Default case: push taggedly, but otherwise intact.
+ other
+ -> pushAtom True d p a `thenBc` \ (code_a, sz_a) ->
+ pargs (d+sz_a) az `thenBc` \ rest ->
+ returnBc ((code_a, atomRep a) : rest)
+
+ -- Do magic for Ptr/Byte arrays. Push a ptr to the array on
+ -- the stack but then advance it over the headers, so as to
+ -- point to the payload.
+ parg_ArrayishRep hdrSizeW d p a
+ = pushAtom False{-irrel-} d p a `thenBc` \ (push_fo, _) ->
+ -- The ptr points at the header. Advance it over the
+ -- header and then pretend this is an Addr# (push a tag).
+ returnBc (push_fo `snocOL`
+ SWIZZLE 0 (hdrSizeW * untaggedSizeW PtrRep
+ * wORD_SIZE)
+ `snocOL`
+ PUSH_TAG addr_usizeW)
+
+ in
+ pargs d0 args_r_to_l `thenBc` \ code_n_reps ->
+ let
+ (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
+
+ push_args = concatOL pushs_arg
+ d_after_args = d0 + sum (map taggedSizeW a_reps_pushed_r_to_l)
+ a_reps_pushed_RAW
+ | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
+ = panic "ByteCodeGen.generateCCall: missing or invalid World token?"
+ | otherwise
+ = reverse (tail a_reps_pushed_r_to_l)
+
+ -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.
+ -- push_args is the code to do that.
+ -- d_after_args is the stack depth once the args are on.
+
+ -- Get the result rep.
+ (returns_void, r_rep)
+ = case maybe_getCCallReturnRep (idType fn) of
+ Nothing -> (True, VoidRep)
+ Just rr -> (False, rr)
+ {-
+ Because the Haskell stack grows down, the a_reps refer to
+ lowest to highest addresses in that order. The args for the call
+ are on the stack. Now push an unboxed, tagged Addr# indicating
+ the C function to call. Then push a dummy placeholder for the
+ result. Finally, emit a CCALL insn with an offset pointing to the
+ Addr# just pushed, and a literal field holding the mallocville
+ address of the piece of marshalling code we generate.
+ So, just prior to the CCALL insn, the stack looks like this
+ (growing down, as usual):
+
+ <arg_n>
+ ...
+ <arg_1>
+ Addr# address_of_C_fn
+ <placeholder-for-result#> (must be an unboxed type)
+
+ The interpreter then calls the marshall code mentioned
+ in the CCALL insn, passing it (& <placeholder-for-result#>),
+ that is, the addr of the topmost word in the stack.
+ When this returns, the placeholder will have been
+ filled in. The placeholder is slid down to the sequel
+ depth, and we RETURN.
+
+ This arrangement makes it simple to do f-i-dynamic since the Addr#
+ value is the first arg anyway. It also has the virtue that the
+ stack is GC-understandable at all times.
+
+ The marshalling code is generated specifically for this
+ call site, and so knows exactly the (Haskell) stack
+ offsets of the args, fn address and placeholder. It
+ copies the args to the C stack, calls the stacked addr,
+ and parks the result back in the placeholder. The interpreter
+ calls it as a normal C call, assuming it has a signature
+ void marshall_code ( StgWord* ptr_to_top_of_stack )
+ -}
+ -- resolve static address
+ get_target_info
+ = case target of
+ DynamicTarget
+ -> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)")
+ StaticTarget target
+ -> ioToBc (lookupStaticPtr target) `thenBc` \res ->
+ returnBc (True, res)
+ CasmTarget _
+ -> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec)
+ in
+ get_target_info `thenBc` \ (is_static, static_target_addr) ->
+ let
+
+ -- Get the arg reps, zapping the leading Addr# in the dynamic case
+ a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
+ | is_static = a_reps_pushed_RAW
+ | otherwise = if null a_reps_pushed_RAW
+ then panic "ByteCodeGen.generateCCall: dyn with no args"
+ else tail a_reps_pushed_RAW
+
+ -- push the Addr#
+ (push_Addr, d_after_Addr)
+ | is_static
+ = (toOL [PUSH_UBX (Right static_target_addr) addr_usizeW,
+ PUSH_TAG addr_usizeW],
+ d_after_args + addr_tsizeW)
+ | otherwise -- is already on the stack
+ = (nilOL, d_after_args)
+
+ -- Push the return placeholder. For a call returning nothing,
+ -- this is a VoidRep (tag).
+ r_usizeW = untaggedSizeW r_rep
+ r_tsizeW = taggedSizeW r_rep
+ d_after_r = d_after_Addr + r_tsizeW
+ r_lit = mkDummyLiteral r_rep
+ push_r = (if returns_void
+ then nilOL
+ else unitOL (PUSH_UBX (Left r_lit) r_usizeW))
+ `appOL`
+ unitOL (PUSH_TAG r_usizeW)
+
+ -- generate the marshalling code we're going to call
+ r_offW = 0
+ addr_offW = r_tsizeW
+ arg1_offW = r_tsizeW + addr_tsizeW
+ args_offW = map (arg1_offW +)
+ (init (scanl (+) 0 (map taggedSizeW a_reps)))
+ in
+ ioToBc (mkMarshalCode cconv
+ (r_offW, r_rep) addr_offW
+ (zip args_offW a_reps)) `thenBc` \ addr_of_marshaller ->
+ recordMallocBc addr_of_marshaller `thenBc_`
+ let
+ -- do the call
+ do_call = unitOL (CCALL (castPtr addr_of_marshaller))
+ -- slide and return
+ wrapup = mkSLIDE r_tsizeW (d_after_r - r_tsizeW - s)
+ `snocOL` RETURN r_rep
+ in
+ --trace (show (arg1_offW, args_offW , (map taggedSizeW a_reps) )) (
+ returnBc (
+ push_args `appOL`
+ push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
+ )
+ --)