- funnyParallelOp SeqOp = True
- funnyParallelOp ParOp = True
- funnyParallelOp ForkOp = True
- funnyParallelOp _ = False
-
- discrim_ty = typeOfCoreExpr discrim
-
- alts_to_stg (CoPrimAlts _ (CoBindDefault binder rhs))
- = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
- let
- stg_deflt = StgBindDefault binder False stg_rhs
- in
- returnSUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
-
--- OK, back to real life...
-
-coreExprToStg env (CoCase discrim alts)
- = coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) ->
- alts_to_stg discrim alts `thenSUs` \ (stg_alts, alts_binds) ->
- getSUnique `thenSUs` \ uniq ->
- returnSUs (
- StgCase stg_discrim
- bOGUS_LVs
- bOGUS_LVs
- uniq
- stg_alts,
- discrim_binds `unionBags` alts_binds
- )
- where
- discrim_ty = typeOfCoreExpr discrim
- (_, discrim_ty_args, _) = getUniDataTyCon discrim_ty
-
- alts_to_stg discrim (CoAlgAlts alts deflt)
- = default_to_stg discrim deflt `thenSUs` \ (stg_deflt, deflt_binds) ->
- mapAndUnzipSUs boxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
- returnSUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
- deflt_binds `unionBags` unionManyBags alts_binds)
- where
- boxed_alt_to_stg (con, bs, rhs)
- = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
- returnSUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
- rhs_binds)
- where
- spec_con = mkSpecialisedCon con discrim_ty_args
-
- alts_to_stg discrim (CoPrimAlts alts deflt)
- = default_to_stg discrim deflt `thenSUs` \ (stg_deflt,deflt_binds) ->
- mapAndUnzipSUs unboxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
- returnSUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
- deflt_binds `unionBags` unionManyBags alts_binds)
- where
- unboxed_alt_to_stg (lit, rhs)
- = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
- returnSUs ((lit, stg_rhs), rhs_binds)
-
-#ifdef DPH
- alts_to_stg (CoParAlgAlts tycon ctxt params alts deflt)
- = default_to_stg deflt `thenSUs` \ stg_deflt ->
- mapSUs boxed_alt_to_stg alts `thenSUs` \ stg_alts ->
- returnSUs (StgParAlgAlts discrim_ty ctxt params stg_alts stg_deflt)
- where
- boxed_alt_to_stg (con, rhs)
- = coreExprToStg env rhs `thenSUs` \ stg_rhs ->
- returnSUs (con, stg_rhs)
-
- alts_to_stg (CoParPrimAlts tycon ctxt alts deflt)
- = default_to_stg deflt `thenSUs` \ stg_deflt ->
- mapSUs unboxed_alt_to_stg alts `thenSUs` \ stg_alts ->
- returnSUs (StgParPrimAlts discrim_ty ctxt stg_alts stg_deflt)
- where
- unboxed_alt_to_stg (lit, rhs)
- = coreExprToStg env rhs `thenSUs` \ stg_rhs ->
- returnSUs (lit, stg_rhs)
-#endif {- Data Parallel Haskell -}
-
- default_to_stg discrim CoNoDefault
- = returnSUs (StgNoDefault, emptyBag)
-
- default_to_stg discrim (CoBindDefault binder rhs)
- = coreExprToStg new_env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
- returnSUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
- rhs_binds)
- where
- --
- -- We convert case x of {...; x' -> ...x'...}
- -- to
- -- case x of {...; _ -> ...x... }
- --
- -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
- -- It's quite easily done: simply extend the environment to bind the
- -- default binder to the scrutinee.
- --
- new_env = case discrim of
- CoVar v -> addOneToIdEnv env binder (stgLookup env v)
- other -> env
+ scrut_ty = idType bndr
+ prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
+
+ alts_to_stg env (alts, deflt)
+ | prim_case
+ = default_to_stg env deflt `thenUs` \ deflt' ->
+ mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' ->
+ returnUs (mkStgPrimAlts scrut_ty alts' deflt')
+
+ | otherwise
+ = default_to_stg env deflt `thenUs` \ deflt' ->
+ mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' ->
+ returnUs (mkStgAlgAlts scrut_ty alts' deflt')
+
+ alg_alt_to_stg env (DataAlt con, bs, rhs)
+ = newLocalIds NotTopLevel env (filter isId bs) `thenUs` \ (env', stg_bs) ->
+ coreExprToStg env' rhs `thenUs` \ stg_rhs ->
+ returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
+ -- NB the filter isId. Some of the binders may be
+ -- existential type variables, which STG doesn't care about
+
+ prim_alt_to_stg env (LitAlt lit, args, rhs)
+ = ASSERT( null args )
+ coreExprToStg env rhs `thenUs` \ stg_rhs ->
+ returnUs (lit, stg_rhs)
+
+ default_to_stg env Nothing
+ = returnUs StgNoDefault
+
+ default_to_stg env (Just rhs)
+ = coreExprToStg env rhs `thenUs` \ stg_rhs ->
+ returnUs (StgBindDefault stg_rhs)
+ -- The binder is used for prim cases and not otherwise
+ -- (hack for old code gen)