+ -- depth of stack after the extra info table for an unboxed return
+ -- has been pushed, if any. This is the stack depth at the
+ -- continuation.
+ d_alts = d_bndr + unlifted_itbl_sizeW
+
+ -- Env in which to compile the alts, not including
+ -- any vars bound by the alts themselves
+ p_alts = addToFM p bndr (d_bndr - 1)
+
+ bndr_ty = idType bndr
+ isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
+
+ -- given an alt, return a discr and code for it.
+ codeALt alt@(DEFAULT, _, (_,rhs))
+ = schemeE d_alts s p_alts rhs `thenBc` \ rhs_code ->
+ returnBc (NoDiscr, rhs_code)
+ codeAlt alt@(discr, bndrs, (_,rhs))
+ -- primitive or nullary constructor alt: no need to UNPACK
+ | null real_bndrs = do
+ rhs_code <- schemeE d_alts s p_alts rhs
+ returnBc (my_discr alt, rhs_code)
+ -- algebraic alt with some binders
+ | ASSERT(isAlgCase) otherwise =
+ let
+ (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
+ ptr_sizes = map idSizeW ptrs
+ nptrs_sizes = map idSizeW nptrs
+ bind_sizes = ptr_sizes ++ nptrs_sizes
+ size = sum ptr_sizes + sum nptrs_sizes
+ -- the UNPACK instruction unpacks in reverse order...
+ p' = addListToFM p_alts
+ (zip (reverse (ptrs ++ nptrs))
+ (mkStackOffsets d_alts (reverse bind_sizes)))
+ in do
+ rhs_code <- schemeE (d_alts+size) s p' rhs
+ return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
+ where
+ real_bndrs = filter (not.isTyVar) bndrs
+
+
+ my_discr (DEFAULT, binds, rhs) = NoDiscr {-shouldn't really happen-}
+ my_discr (DataAlt dc, binds, rhs)
+ | isUnboxedTupleCon dc
+ = unboxedTupleException
+ | otherwise
+ = DiscrP (dataConTag dc - fIRST_TAG)
+ my_discr (LitAlt l, binds, rhs)
+ = case l of MachInt i -> DiscrI (fromInteger i)
+ MachFloat r -> DiscrF (fromRational r)
+ MachDouble r -> DiscrD (fromRational r)
+ MachChar i -> DiscrI (ord i)
+ _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
+
+ maybe_ncons
+ | not isAlgCase = Nothing
+ | otherwise
+ = case [dc | (DataAlt dc, _, _) <- alts] of
+ [] -> Nothing
+ (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
+
+ -- the bitmap is relative to stack depth d, i.e. before the
+ -- BCO, info table and return value are pushed on.
+ -- This bit of code is v. similar to buildLivenessMask in CgBindery,
+ -- except that here we build the bitmap from the known bindings of
+ -- things that are pointers, whereas in CgBindery the code builds the
+ -- bitmap from the free slots and unboxed bindings.
+ -- (ToDo: merge?)
+ bitmap = intsToReverseBitmap d{-size-} (sortLe (<=) rel_slots)
+ where
+ binds = fmToList p
+ rel_slots = concat (map spread binds)
+ spread (id, offset)
+ | isFollowableArg (idCgRep id) = [ rel_offset ]
+ | otherwise = []
+ where rel_offset = d - offset - 1
+
+ in do
+ alt_stuff <- mapM codeAlt alts
+ alt_final <- mkMultiBranch maybe_ncons alt_stuff
+ let
+ alt_bco_name = getName bndr
+ alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
+ 0{-no arity-} d{-bitmap size-} bitmap True{-is alts-}
+ -- in
+-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
+-- "\n bitmap = " ++ show bitmap) $ do
+ scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut
+ alt_bco' <- emitBc alt_bco
+ let push_alts
+ | isAlgCase = PUSH_ALTS alt_bco'
+ | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty)
+ returnBc (push_alts `consOL` scrut_code)
+
+
+-- -----------------------------------------------------------------------------
+-- Deal with a CCall.
+
+-- Taggedly push the args onto the stack R->L,
+-- deferencing ForeignObj#s and 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_sizeW = cgRepSizeW NonPtrArg
+
+ -- 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
+ -- CgRep 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 == arrayPrimTyCon || t == mutableArrayPrimTyCon
+ -> pargs (d + addr_sizeW) az `thenBc` \ rest ->
+ parg_ArrayishRep arrPtrsHdrSize d p a
+ `thenBc` \ code ->
+ returnBc ((code,NonPtrArg):rest)
+
+ | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
+ -> pargs (d + addr_sizeW) az `thenBc` \ rest ->
+ parg_ArrayishRep arrWordsHdrSize d p a
+ `thenBc` \ code ->
+ returnBc ((code,NonPtrArg):rest)
+
+ -- Default case: push taggedly, but otherwise intact.
+ other
+ -> pushAtom 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 hdrSize d p a
+ = pushAtom d p a `thenBc` \ (push_fo, _) ->
+ -- The ptr points at the header. Advance it over the
+ -- header and then pretend this is an Addr#.
+ returnBc (push_fo `snocOL` SWIZZLE 0 hdrSize)
+
+ 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 cgRepSizeW a_reps_pushed_r_to_l)
+ a_reps_pushed_RAW
+ | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidArg
+ = 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, VoidArg)
+ 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 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):