+ = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
+
+schemeE d s p (fvs, AnnNote note body)
+ = schemeE d s p body
+
+schemeE d s p other
+ = pprPanic "ByteCodeGen.schemeE: unhandled case"
+ (pprCoreExpr (deAnnotate other))
+
+
+-- Compile code to do a tail call. Specifically, push the fn,
+-- slide the on-stack app back down to the sequel depth,
+-- and enter. Four cases:
+--
+-- 0. (Nasty hack).
+-- An application "GHC.Prim.tagToEnum# <type> unboxed-int".
+-- The int will be on the stack. Generate a code sequence
+-- to convert it to the relevant constructor, SLIDE and ENTER.
+--
+-- 1. A nullary constructor. Push its closure on the stack
+-- and SLIDE and RETURN.
+--
+-- 2. (Another nasty hack). Spot (# a::VoidRep, b #) and treat
+-- it simply as b -- since the representations are identical
+-- (the VoidRep takes up zero stack space). Also, spot
+-- (# b #) and treat it as b.
+--
+-- 3. The fn denotes a ccall. Defer to generateCCall.
+--
+-- 4. Application of a non-nullary constructor, by defn saturated.
+-- Split the args into ptrs and non-ptrs, and push the nonptrs,
+-- then the ptrs, and then do PACK and RETURN.
+--
+-- 5. Otherwise, it must be a function call. Push the args
+-- right to left, SLIDE and ENTER.
+
+schemeT :: Int -- Stack depth
+ -> Sequel -- Sequel depth
+ -> BCEnv -- stack env
+ -> AnnExpr Id VarSet
+ -> BcM BCInstrList
+
+schemeT d s p app
+
+-- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
+-- = panic "schemeT ?!?!"
+
+-- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate app)) ++ "\n") False
+-- = error "?!?!"
+
+ -- Case 0
+ | Just (arg, constr_names) <- maybe_is_tagToEnum_call
+ = pushAtom d p arg `thenBc` \ (push, arg_words) ->
+ implement_tagToId constr_names `thenBc` \ tagToId_sequence ->
+ returnBc (push `appOL` tagToId_sequence
+ `appOL` mkSLIDE 1 (d+arg_words-s)
+ `snocOL` ENTER)
+
+ -- Case 1
+ | Just con <- maybe_dcon, null args_r_to_l
+ = returnBc (
+ (PUSH_G (getName con) `consOL` mkSLIDE 1 (d-s))
+ `snocOL` ENTER
+ )
+
+ -- Case 3
+ | Just (CCall ccall_spec) <- isFCallId_maybe fn
+ = generateCCall d s p ccall_spec fn args_r_to_l
+
+ -- Case 4: Constructor application
+ | Just con <- maybe_dcon
+ = if isUnboxedTupleCon con
+ then case args_r_to_l of
+ [arg1,arg2] | isVoidRepAtom arg1 ->
+ unboxedTupleReturn d s p arg2
+ [arg1,arg2] | isVoidRepAtom arg2 ->
+ unboxedTupleReturn d s p arg1
+ _other -> unboxedTupleException
+ else doConstructorApp d s p con args_r_to_l
+
+ -- Case 5: Tail call of function
+ | otherwise
+ = doTailCall d s p fn args_r_to_l
+
+ 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 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
+
+ -- only consider this to be a constructor application iff it is
+ -- saturated. Otherwise, we'll call the constructor wrapper.
+ maybe_dcon = case isDataConId_maybe fn of
+ Just con | dataConRepArity con == n_args -> Just con
+ _ -> Nothing
+
+-- -----------------------------------------------------------------------------
+-- Generate code to build a constructor application and enter/return it.
+
+doConstructorApp
+ :: Int -> Sequel -> BCEnv
+ -> DataCon -> [AnnExpr' Id VarSet] -- args, in *reverse* order
+ -> BcM BCInstrList
+doConstructorApp d s p con args = do_pushery d con_args
+ where
+ -- The args are already in reverse order, which is the way PACK
+ -- expects them to be. We must push the non-ptrs after the ptrs.
+ con_args = nptrs ++ ptrs
+ where (ptrs, nptrs) = partition isPtr args
+ isPtr = isFollowableRep . atomRep
+
+ narg_words = sum (map (getPrimRepSize.atomRep) con_args)
+
+ do_pushery d (arg:args)
+ = pushAtom 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 []
+ = returnBc ( (PACK con narg_words `consOL`
+ mkSLIDE 1 (d - narg_words - s)) `snocOL`
+ ENTER
+ )
+
+-- -----------------------------------------------------------------------------
+-- Returning an unboxed tuple with one non-void component (the only
+-- case we can handle).
+--
+-- Remember, we don't want to *evaluate* the component that is being
+-- returned, even if it is a pointed type. We always just return.
+
+unboxedTupleReturn
+ :: Int -> Sequel -> BCEnv
+ -> AnnExpr' Id VarSet -> BcM BCInstrList
+unboxedTupleReturn d s p arg = do
+ (push, sz) <- pushAtom d p arg
+ returnBc (push `appOL`
+ mkSLIDE sz (d-s) `snocOL`
+ RETURN_UBX (atomRep arg))
+
+-- -----------------------------------------------------------------------------
+-- Generate code for a tail-call
+
+doTailCall
+ :: Int -> Sequel -> BCEnv
+ -> Id -> [AnnExpr' Id VarSet]
+ -> BcM BCInstrList
+doTailCall init_d s p fn args
+ = do_pushes init_d args (map (primRepToArgRep.atomRep) args)
+ where
+ do_pushes d [] reps = do
+ ASSERTM( null reps )
+ (push_fn, sz) <- pushAtom d p (AnnVar fn)
+ ASSERTM( sz == 1 )
+ returnBc (push_fn `appOL` (
+ mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
+ unitOL ENTER))
+ do_pushes d args reps = do
+ let (push_apply, n, rest_of_reps) = findPushSeq reps
+ (these_args, rest_of_args) = splitAt n args
+ (next_d, push_code) <- push_seq d these_args
+ instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
+ -- ^^^ for the PUSH_APPLY_ instruction
+ returnBc (push_code `appOL` (push_apply `consOL` instrs))
+
+ push_seq d [] = return (d, nilOL)
+ push_seq d (arg:args) = do
+ (push_code, sz) <- pushAtom d p arg
+ (final_d, more_push_code) <- push_seq (d+sz) args
+ return (final_d, push_code `appOL` more_push_code)
+
+-- v. similar to CgStackery.findMatch, ToDo: merge
+findPushSeq (RepP: RepP: RepP: RepP: RepP: RepP: RepP: rest)
+ = (PUSH_APPLY_PPPPPPP, 7, rest)
+findPushSeq (RepP: RepP: RepP: RepP: RepP: RepP: rest)
+ = (PUSH_APPLY_PPPPPP, 6, rest)
+findPushSeq (RepP: RepP: RepP: RepP: RepP: rest)
+ = (PUSH_APPLY_PPPPP, 5, rest)
+findPushSeq (RepP: RepP: RepP: RepP: rest)
+ = (PUSH_APPLY_PPPP, 4, rest)
+findPushSeq (RepP: RepP: RepP: rest)
+ = (PUSH_APPLY_PPP, 3, rest)
+findPushSeq (RepP: RepP: rest)
+ = (PUSH_APPLY_PP, 2, rest)
+findPushSeq (RepP: rest)
+ = (PUSH_APPLY_P, 1, rest)
+findPushSeq (RepV: rest)
+ = (PUSH_APPLY_V, 1, rest)
+findPushSeq (RepN: rest)
+ = (PUSH_APPLY_N, 1, rest)
+findPushSeq (RepF: rest)
+ = (PUSH_APPLY_F, 1, rest)
+findPushSeq (RepD: rest)
+ = (PUSH_APPLY_D, 1, rest)
+findPushSeq (RepL: rest)
+ = (PUSH_APPLY_L, 1, rest)
+findPushSeq _
+ = panic "ByteCodeGen.findPushSeq"
+
+-- -----------------------------------------------------------------------------
+-- Case expressions
+
+doCase :: Int -> Sequel -> BCEnv
+ -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
+ -> Bool -- True <=> is an unboxed tuple case, don't enter the result
+ -> BcM BCInstrList
+doCase d s p scrut bndr alts is_unboxed_tuple
+ = let