+
+-- We attempt to unbox/unpack a strict field when either:
+-- (i) The tycon is imported, and the field is marked '! !', or
+-- (ii) The tycon is defined in this module, the field is marked '!',
+-- and the -funbox-strict-fields flag is on.
+--
+-- This ensures that if we compile some modules with -funbox-strict-fields and
+-- some without, the compiler doesn't get confused about the constructor
+-- representations.
+
+unbox_strict_arg_ty :: TyCon -> StrictnessMark -> Type -> (StrictnessMark, [Type])
+unbox_strict_arg_ty tycon NotMarkedStrict ty
+ = (NotMarkedStrict, [ty])
+unbox_strict_arg_ty tycon MarkedStrict ty
+ | not opt_UnboxStrictFields
+ || not (isLocallyDefinedName (getName tycon)) = (MarkedStrict, [ty])
+unbox_strict_arg_ty tycon marked_unboxed ty
+ -- MarkedUnboxed || (MarkedStrict && opt_UnboxStrictFields && not imported)
+ = case splitAlgTyConApp_maybe ty of
+ Just (tycon,_,[])
+ -> panic (showSDoc (hcat [
+ text "unbox_strict_arg_ty: constructors for ",
+ ppr tycon,
+ text " not available."
+ ]))
+ Just (tycon,ty_args,[con])
+ -> case maybe_unpack_fields emptyUniqSet
+ (zip (dataConOrigArgTys con ty_args)
+ (dcUserStricts con))
+ of
+ Nothing -> (MarkedStrict, [ty])
+ Just tys -> (MarkedUnboxed con tys, tys)
+ _ -> (MarkedStrict, [ty])
+
+-- bail out if we encounter the same tycon twice. This avoids problems like
+--
+-- data A = !B
+-- data B = !A
+--
+-- where no useful unpacking can be done.
+
+maybe_unpack_field :: UniqSet TyCon -> Type -> StrictnessMark -> Maybe [Type]
+maybe_unpack_field set ty NotMarkedStrict
+ = Just [ty]
+maybe_unpack_field set ty MarkedStrict | not opt_UnboxStrictFields
+ = Just [ty]
+maybe_unpack_field set ty strict
+ = case splitAlgTyConApp_maybe ty of
+ Just (tycon,ty_args,[con])
+ | tycon `elementOfUniqSet` set -> Nothing
+ | otherwise ->
+ let set' = addOneToUniqSet set tycon in
+ maybe_unpack_fields set'
+ (zip (dataConOrigArgTys con ty_args)
+ (dcUserStricts con))
+ _ -> Just [ty]
+
+maybe_unpack_fields :: UniqSet TyCon -> [(Type,StrictnessMark)] -> Maybe [Type]
+maybe_unpack_fields set tys
+ | any isNothing unpacked_fields = Nothing
+ | otherwise = Just (concat (catMaybes unpacked_fields))
+ where unpacked_fields = map (\(ty,str) -> maybe_unpack_field set ty str) tys