+ = returnBc (unitOL (PACK con n_arg_words))
+ where
+ n_arg_words = d - orig_d
+
+
+-- -----------------------------------------------------------------------------
+-- 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 atomRep args)
+ where
+ do_pushes d [] reps = do
+ ASSERT( null reps ) return ()
+ (push_fn, sz) <- pushAtom d p (AnnVar fn)
+ ASSERT( sz == 1 ) return ()
+ 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 (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
+ = (PUSH_APPLY_PPPPPP, 6, rest)
+findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
+ = (PUSH_APPLY_PPPPP, 5, rest)
+findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: rest)
+ = (PUSH_APPLY_PPPP, 4, rest)
+findPushSeq (PtrArg: PtrArg: PtrArg: rest)
+ = (PUSH_APPLY_PPP, 3, rest)
+findPushSeq (PtrArg: PtrArg: rest)
+ = (PUSH_APPLY_PP, 2, rest)
+findPushSeq (PtrArg: rest)
+ = (PUSH_APPLY_P, 1, rest)
+findPushSeq (VoidArg: rest)
+ = (PUSH_APPLY_V, 1, rest)
+findPushSeq (NonPtrArg: rest)
+ = (PUSH_APPLY_N, 1, rest)
+findPushSeq (FloatArg: rest)
+ = (PUSH_APPLY_F, 1, rest)
+findPushSeq (DoubleArg: rest)
+ = (PUSH_APPLY_D, 1, rest)
+findPushSeq (LongArg: 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
+ -- Top of stack is the return itbl, as usual.
+ -- underneath it is the pointer to the alt_code BCO.
+ -- When an alt is entered, it assumes the returned value is
+ -- on top of the itbl.
+ ret_frame_sizeW = 2
+
+ -- An unlifted value gets an extra info table pushed on top
+ -- when it is returned.
+ unlifted_itbl_sizeW | isAlgCase = 0
+ | otherwise = 1
+
+ -- depth of stack after the return value has been pushed
+ d_bndr = d + ret_frame_sizeW + idSizeW bndr
+
+ -- 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.
+
projects / ghc-hetmet.git / blobdiff