+ where
+ -- Detect and extract relevant info for the tagToEnum kludge.
+ maybe_is_tagToEnum_call
+ = let extract_constr_Names ty
+ = case splitTyConApp_maybe (repType ty) of
+ (Just (tyc, [])) | isDataTyCon tyc
+ -> map getName (tyConDataCons tyc)
+ other -> panic "maybe_is_tagToEnum_call.extract_constr_Ids"
+ in
+ case app of
+ (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
+ -> case isPrimOpId_maybe v of
+ Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
+ other -> Nothing
+ other -> Nothing
+
+ -- Extract the args (R->L) and fn
+ (args_r_to_l, fn) = chomp app
+ chomp expr
+ = case snd expr of
+ AnnVar v -> ([], v)
+ AnnApp f a
+ | isTypeAtom (snd a) -> chomp f
+ | otherwise -> case chomp f of (az, f) -> (a:az, f)
+ AnnNote n e -> chomp e
+ other -> pprPanic "schemeT"
+ (ppr (deAnnotate (panic "schemeT.chomp", other)))
+
+ n_args = length args_r_to_l
+
+ isTypeAtom (AnnType _) = True
+ isTypeAtom _ = False
+
+ -- decide if this is a constructor application, because we need
+ -- to rearrange the arguments on the stack if so. For building
+ -- a constructor, we put pointers before non-pointers and omit
+ -- the tags.
+ --
+ -- Also if the constructor is not saturated, we just arrange to
+ -- call the curried worker instead.
+
+ maybe_dcon = case isDataConId_maybe fn of
+ Just con | dataConRepArity con == n_args -> Just con
+ _ -> Nothing
+ is_con_call = isJust maybe_dcon
+ (Just con) = maybe_dcon
+
+ args_final_r_to_l
+ | not is_con_call
+ = args_r_to_l
+ | otherwise
+ = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l
+ where isPtr = isFollowableRep . atomRep
+
+ -- make code to push the args and then do the SLIDE-ENTER thing
+ tag_when_push = not is_con_call
+ narg_words = sum (map (get_arg_szw . atomRep . snd) args_r_to_l)
+ get_arg_szw = if tag_when_push then taggedSizeW else untaggedSizeW
+
+ do_pushery d (arg:args)
+ = pushAtom tag_when_push d p arg `thenBc` \ (push, arg_words) ->
+ do_pushery (d+arg_words) args `thenBc` \ more_push_code ->
+ returnBc (push `appOL` more_push_code)
+ do_pushery d []
+ | Just (CCall ccall_spec) <- isFCallId_maybe fn
+ = panic "schemeT.do_pushery: unexpected ccall"
+ | otherwise
+ = case maybe_dcon of
+ Just con -> returnBc (
+ (PACK con narg_words `consOL`
+ mkSLIDE 1 (d - narg_words - s)) `snocOL`
+ ENTER
+ )
+ Nothing
+ -> pushAtom True d p (AnnVar fn)
+ `thenBc` \ (push, arg_words) ->
+ returnBc (push `appOL` mkSLIDE (narg_words+arg_words)
+ (d - s - narg_words)
+ `snocOL` ENTER)
+
+
+{- Deal with a CCall. Taggedly push the args onto the stack R->L,
+ deferencing ForeignObj#s and (ToDo: adjusting addrs to point to
+ payloads in Ptr/Byte arrays). Then, generate the marshalling
+ (machine) code for the ccall, and create bytecodes to call that and
+ then return in the right way.
+-}
+generateCCall :: Int -> Sequel -- stack and sequel depths
+ -> BCEnv
+ -> CCallSpec -- where to call
+ -> Id -- of target, for type info
+ -> [AnnExpr Id VarSet] -- args (atoms)
+ -> BcM BCInstrList
+
+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?"