towards unboxing through newtypes

Mon Sep 18 14:44:50 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * towards unboxing through newtypes
  Sat Aug  5 21:42:05 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * towards unboxing through newtypes
    Fri Jul 14 12:02:32 EDT 2006  kevind@bu.edu

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 289fdef..486745c 100644 (file)
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -23,7 +23,8 @@ module DataCon (
        isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
        isVanillaDataCon, classDataCon, 
 
        isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
        isVanillaDataCon, classDataCon, 
 

-       splitProductType_maybe, splitProductType,
+       splitProductType_maybe, splitProductType, deepSplitProductType,
+        deepSplitProductType_maybe

     ) where
 
 #include "HsVersions.h"
     ) where
 
 #include "HsVersions.h"

@@ -31,13 +32,13 @@ module DataCon (
 import Type            ( Type, ThetaType, 
                          substTyWith, substTyVar, mkTopTvSubst, 
                          mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTy, mkTyVarTys, 
 import Type            ( Type, ThetaType, 
                          substTyWith, substTyVar, mkTopTvSubst, 
                          mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTy, mkTyVarTys, 

-                         splitTyConApp_maybe, 
+                         splitTyConApp_maybe, newTyConInstRhs,

                          mkPredTys, isStrictPred, pprType
                        )
 import Coercion                ( isEqPred, mkEqPred )
 import TyCon           ( TyCon, FieldLabel, tyConDataCons, 
                          isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon,
                          mkPredTys, isStrictPred, pprType
                        )
 import Coercion                ( isEqPred, mkEqPred )
 import TyCon           ( TyCon, FieldLabel, tyConDataCons, 
                          isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon,

-                          isNewTyCon )
+                          isNewTyCon, isRecursiveTyCon )

 import Class           ( Class, classTyCon )
 import Name            ( Name, NamedThing(..), nameUnique )
 import Var             ( TyVar, Id )
 import Class           ( Class, classTyCon )
 import Name            ( Name, NamedThing(..), nameUnique )
 import Var             ( TyVar, Id )

@@ -687,6 +688,20 @@ splitProductType str ty
        Nothing    -> pprPanic (str ++ ": not a product") (pprType ty)
 
 
        Nothing    -> pprPanic (str ++ ": not a product") (pprType ty)
 
 

+deepSplitProductType_maybe ty
+  = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty
+       ; let {result 
+             | isNewTyCon tycon && not (isRecursiveTyCon tycon)
+             = deepSplitProductType_maybe (newTyConInstRhs tycon tycon_args)
+             | otherwise = Just res}
+       ; result
+       }
+          
+deepSplitProductType str ty 
+  = case deepSplitProductType_maybe ty of
+      Just stuff -> stuff
+      Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
+

 computeRep :: [StrictnessMark]         -- Original arg strictness
           -> [Type]                    -- and types
           -> ([StrictnessMark],        -- Representation arg strictness
 computeRep :: [StrictnessMark]         -- Original arg strictness
           -> [Type]                    -- and types
           -> ([StrictnessMark],        -- Representation arg strictness

@@ -698,6 +713,7 @@ computeRep stricts tys
     unbox NotMarkedStrict ty = [(NotMarkedStrict, ty)]
     unbox MarkedStrict    ty = [(MarkedStrict,    ty)]
     unbox MarkedUnboxed   ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
     unbox NotMarkedStrict ty = [(NotMarkedStrict, ty)]
     unbox MarkedStrict    ty = [(MarkedStrict,    ty)]
     unbox MarkedUnboxed   ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys

-                            where
-                              (_, _, arg_dc, arg_tys) = splitProductType "unbox_strict_arg_ty" ty
+                               where
+                                 (tycon, tycon_args, arg_dc, arg_tys) 
+                                     = deepSplitProductType "unbox_strict_arg_ty" ty

 \end{code}
 \end{code}

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index bc45f52..1485f48 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -21,6 +21,7 @@ module MkId (
        mkPrimOpId, mkFCallId,
 
        mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
        mkPrimOpId, mkFCallId,
 
        mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,

+        mkUnpackCase, mkProductBox,

 
        -- And some particular Ids; see below for why they are wired in
        wiredInIds, ghcPrimIds,
 
        -- And some particular Ids; see below for why they are wired in
        wiredInIds, ghcPrimIds,

@@ -45,8 +46,9 @@ import TysPrim                ( openAlphaTyVars, alphaTyVar, alphaTy,
                        )
 import TysWiredIn      ( charTy, mkListTy )
 import PrelRules       ( primOpRules )
                        )
 import TysWiredIn      ( charTy, mkListTy )
 import PrelRules       ( primOpRules )

-import Type            ( TyThing(..), mkForAllTy, tyVarsOfTypes )
-import Coercion         ( mkSymCoercion, mkUnsafeCoercion )
+import Type            ( TyThing(..), mkForAllTy, tyVarsOfTypes, newTyConInstRhs )
+import Coercion         ( mkSymCoercion, mkUnsafeCoercion, 
+                          splitRecNewTypeCo_maybe )

 import TcType          ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, 
                          mkTyConApp, mkTyVarTys, mkClassPred, 
                          mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, 
 import TcType          ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, 
                          mkTyConApp, mkTyVarTys, mkClassPred, 
                          mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, 

@@ -71,11 +73,11 @@ import DataCon              ( DataCon, DataConIds(..), dataConTyCon, dataConUnivTyVars,
                          dataConRepArgTys, dataConRepType, 
                          dataConSig, dataConStrictMarks, dataConExStricts, 
                          splitProductType, isVanillaDataCon, dataConFieldType,
                          dataConRepArgTys, dataConRepType, 
                          dataConSig, dataConStrictMarks, dataConExStricts, 
                          splitProductType, isVanillaDataCon, dataConFieldType,

-                         dataConInstOrigArgTys
+                         dataConInstOrigArgTys, deepSplitProductType

                        )
 import Id              ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, 
                          mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
                        )
 import Id              ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, 
                          mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,

-                         mkTemplateLocal, idName
+                         mkTemplateLocal, idName, mkWildId

                        )
 import IdInfo          ( IdInfo, noCafIdInfo,  setUnfoldingInfo, 
                          setArityInfo, setSpecInfo, setCafInfo,
                        )
 import IdInfo          ( IdInfo, noCafIdInfo,  setUnfoldingInfo, 
                          setArityInfo, setSpecInfo, setCafInfo,

@@ -316,14 +318,9 @@ mkDataConIds wrap_name wkr_name data_con
                        Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
 
                MarkedUnboxed
                        Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
 
                MarkedUnboxed

-                  ->case splitProductType "do_unbox" (idType arg) of
-                          (tycon, tycon_args, con, tys) ->
-                                  Case (Var arg) arg result_ty  
-                                       [(DataAlt con, 
-                                         con_args,
-                                         body i' (reverse con_args ++ rep_args))]
-                             where 
-                               (con_args, i') = mkLocals i tys
+                  -> unboxProduct i (Var arg) (idType arg) the_body result_ty
+                      where
+                        the_body i con_args = body i (reverse con_args ++ rep_args)

 
 mAX_CPR_SIZE :: Arity
 mAX_CPR_SIZE = 10
 
 mAX_CPR_SIZE :: Arity
 mAX_CPR_SIZE = 10

@@ -563,7 +560,75 @@ mkRecordSelId tycon field_label
        field_lbls  = dataConFieldLabels data_con
 
     error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
        field_lbls  = dataConFieldLabels data_con
 
     error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg

-    full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id]) 
+    full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id])
+
+-- unbox a product type...
+-- we will recurse into newtypes, casting along the way, and unbox at the
+-- first product data constructor we find. e.g.
+--  
+--   data PairInt = PairInt Int Int
+--   newtype S = MkS PairInt
+--   newtype T = MkT S
+--
+-- If we have e = MkT (MkS (PairInt 0 1)) and some body expecting a list of
+-- ids, we get (modulo int passing)
+--
+--   case (e `cast` (sym CoT)) `cast` (sym CoS) of
+--     PairInt a b -> body [a,b]
+--
+-- The Ints passed around are just for creating fresh locals
+unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> Type -> CoreExpr
+unboxProduct i arg arg_ty body res_ty
+  = mkUnpackCase the_id arg con_args boxing_con rhs
+  where 
+    (_, _, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty
+    ([the_id], i') = mkLocals i [arg_ty]
+    (con_args, i'') = mkLocals i' tys
+    rhs = body i'' con_args
+
+mkUnpackCase ::  Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
+mkUnpackCase bndr arg unpk_args boxing_con body
+  = Case cast_arg bndr (exprType body) [(DataAlt boxing_con, unpk_args, body)]
+  where
+  cast_arg = go (idType bndr) arg
+  go ty arg 
+    | res@(tycon, tycon_args, _, _)  <- splitProductType "mkUnpackCase" ty
+    , isNewTyCon tycon && not (isRecursiveTyCon tycon)
+    = go (newTyConInstRhs tycon tycon_args) 
+         (unwrapNewTypeBody tycon tycon_args arg)
+    | otherwise = arg
+
+-- ...and the dual
+reboxProduct :: [Unique]     -- uniques to create new local binders
+             -> Type         -- type of product to box
+             -> ([Unique],   -- remaining uniques
+                 CoreExpr,   -- boxed product
+                 [Id])       -- Ids being boxed into product
+reboxProduct us ty
+  = let 
+       (tycon, tycon_args, pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty
+ 
+        us' = dropList con_arg_tys us
+
+       arg_ids  = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
+
+        bind_rhs = mkProductBox arg_ids ty
+
+    in
+      (us', bind_rhs, arg_ids)
+
+mkProductBox :: [Id] -> Type -> CoreExpr
+mkProductBox arg_ids ty 
+  = result_expr
+  where 
+    (tycon, tycon_args, pack_con, con_arg_tys) = splitProductType "mkProductBox" ty
+
+    result_expr
+      | isNewTyCon tycon 
+      = wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args))
+      | otherwise = mkConApp pack_con (map Type tycon_args ++ map Var arg_ids)
+
+    wrap expr = wrapNewTypeBody tycon tycon_args expr

 
 
 -- (mkReboxingAlt us con xs rhs) basically constructs the case
 
 
 -- (mkReboxingAlt us con xs rhs) basically constructs the case

@@ -610,21 +675,11 @@ mkReboxingAlt us con args rhs
        -- Term variable case
     go (arg:args) (str:stricts) us
       | isMarkedUnboxed str
        -- Term variable case
     go (arg:args) (str:stricts) us
       | isMarkedUnboxed str

-      = let
-          ty = idType arg
-          
-         (tycon, tycon_args, pack_con, con_arg_tys)
-                = splitProductType "mkReboxingAlt" ty
-
-         unpacked_args  = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
-         (binds, args') = go args stricts (dropList con_arg_tys us)
-         con_app | isNewTyCon tycon = ASSERT( isSingleton unpacked_args )
-                                      wrapNewTypeBody tycon tycon_args (Var (head unpacked_args))
-                                       -- ToDo: is this right?  Jun06
-                 | otherwise = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
-       in
-       (NonRec arg con_app : binds, unpacked_args ++ args')
-
+      = 
+        let (binds, unpacked_args')        = go args stricts us'
+            (us', bind_rhs, unpacked_args) = reboxProduct us (idType arg)
+        in
+            (NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args')

       | otherwise
       = let (binds, args') = go args stricts us
         in  (binds, arg:args')
       | otherwise
       = let (binds, args') = go args stricts us
         in  (binds, arg:args')

diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 6adda66..3fc8477 100644 (file)
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -171,10 +171,9 @@ dmdAnal sigs dmd (Cast e co)
     (dmd_ty, e') = dmdAnal sigs dmd' e
     to_co        = snd (coercionKind co)
     dmd'
     (dmd_ty, e') = dmdAnal sigs dmd' e
     to_co        = snd (coercionKind co)
     dmd'

---      | Just (tc, args) <- splitTyConApp_maybe to_co
-      = evalDmd
---      , isRecursiveTyCon tc = evalDmd
---      | otherwise           = dmd
+      | Just (tc, args) <- splitTyConApp_maybe to_co
+      , isRecursiveTyCon tc = evalDmd
+      | otherwise           = dmd

        -- This coerce usually arises from a recursive
         -- newtype, and we don't want to look inside them
        -- for exactly the same reason that we don't look
        -- This coerce usually arises from a recursive
         -- newtype, and we don't want to look inside them
        -- for exactly the same reason that we don't look

diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index c4e78eb..8b4f6aa 100644 (file)
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -15,9 +15,10 @@ import Id            ( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo,
                           setIdInfo
                        )
 import IdInfo          ( vanillaIdInfo )
                           setIdInfo
                        )
 import IdInfo          ( vanillaIdInfo )

-import DataCon         ( splitProductType_maybe, splitProductType )
+import DataCon         ( deepSplitProductType_maybe, splitProductType )

 import NewDemand       ( Demand(..), DmdResult(..), Demands(..) ) 
 import NewDemand       ( Demand(..), DmdResult(..), Demands(..) ) 

-import MkId            ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID )
+import MkId            ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID,
+                          mkUnpackCase, mkProductBox )

 import TysWiredIn      ( tupleCon )
 import Type            ( Type, isUnLiftedType, mkFunTys,
                          splitForAllTys, splitFunTys, splitRecNewType_maybe, isAlgType
 import TysWiredIn      ( tupleCon )
 import Type            ( Type, isUnLiftedType, mkFunTys,
                          splitForAllTys, splitFunTys, splitRecNewType_maybe, isAlgType

@@ -341,17 +342,17 @@ mkWWstr_one arg
        -- Unpack case
       Eval (Prod cs)
        | Just (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys) 
        -- Unpack case
       Eval (Prod cs)
        | Just (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys) 

-               <- splitProductType_maybe (idType arg)
+               <- deepSplitProductType_maybe (idType arg)

        -> getUniquesUs                 `thenUs` \ uniqs ->
           let
             unpk_args      = zipWith mk_ww_local uniqs inst_con_arg_tys
             unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs
        -> getUniquesUs                 `thenUs` \ uniqs ->
           let
             unpk_args      = zipWith mk_ww_local uniqs inst_con_arg_tys
             unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs

-            unbox_fn       = mk_unpk_case arg unpk_args data_con arg_tycon
+            unbox_fn       = mkUnpackCase (sanitiseCaseBndr arg) (Var arg) unpk_args data_con

             rebox_fn       = Let (NonRec arg con_app) 
             rebox_fn       = Let (NonRec arg con_app) 

-            con_app        = mkConApp data_con (map Type tycon_arg_tys ++ map Var unpk_args)
+            con_app        = mkProductBox unpk_args (idType arg)

           in
           mkWWstr unpk_args_w_ds               `thenUs` \ (worker_args, wrap_fn, work_fn) ->
           in
           mkWWstr unpk_args_w_ds               `thenUs` \ (worker_args, wrap_fn, work_fn) ->

-          returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn)
+          returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) 

                           -- Don't pass the arg, rebox instead
 
        -- `seq` demand; evaluate in wrapper in the hope
                           -- Don't pass the arg, rebox instead
 
        -- `seq` demand; evaluate in wrapper in the hope

@@ -443,13 +444,13 @@ mkWWcpr body_ty RetCPR
        ubx_tup_con                    = tupleCon Unboxed n_con_args
        ubx_tup_ty                     = exprType ubx_tup_app
        ubx_tup_app                    = mkConApp ubx_tup_con (map Type con_arg_tys   ++ arg_vars)
        ubx_tup_con                    = tupleCon Unboxed n_con_args
        ubx_tup_ty                     = exprType ubx_tup_app
        ubx_tup_app                    = mkConApp ubx_tup_con (map Type con_arg_tys   ++ arg_vars)

-        con_app                               = mkConApp data_con    (map Type tycon_arg_tys ++ arg_vars)
+        con_app                               = mkProductBox arg_vars body_ty

       in
       returnUs (\ wkr_call -> Case wkr_call wrap_wild (exprType con_app)  [(DataAlt ubx_tup_con, args, con_app)],
                \ body     -> workerCase body work_wild ubx_tup_ty [(DataAlt data_con,    args, ubx_tup_app)],
                ubx_tup_ty)
     where
       in
       returnUs (\ wkr_call -> Case wkr_call wrap_wild (exprType con_app)  [(DataAlt ubx_tup_con, args, con_app)],
                \ body     -> workerCase body work_wild ubx_tup_ty [(DataAlt data_con,    args, ubx_tup_app)],
                ubx_tup_ty)
     where

-      (_, tycon_arg_tys, data_con, con_arg_tys) = splitProductType "mkWWcpr" body_ty
+      (_, tycon_arg_tys, data_con, con_arg_tys) = deepSplitProductType "mkWWcpr" body_ty

       n_con_args  = length con_arg_tys
       con_arg_ty1 = head con_arg_tys
 
       n_con_args  = length con_arg_tys
       con_arg_ty1 = head con_arg_tys
 

@@ -495,7 +496,7 @@ mk_unpk_case arg unpk_args boxing_con boxing_tycon body
   = Case (Var arg) 
         (sanitiseCaseBndr arg)
          (exprType body)
   = Case (Var arg) 
         (sanitiseCaseBndr arg)
          (exprType body)

-        [(DataAlt boxing_con, unpk_args, body)]
+        [(DataAlt boxing_con, unpk_args, body) ]

 
 mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)]
 
 
 mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)]
 

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index a23c6ba..d67ae90 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -36,7 +36,8 @@ import TcMType                ( newKindVar, checkValidTheta, checkValidType,
 import TcType          ( TcKind, TcType, Type, tyVarsOfType, mkPhiTy,
                          mkArrowKind, liftedTypeKind, mkTyVarTys, 
                          tcSplitSigmaTy, tcEqTypes, tcGetTyVar_maybe )
 import TcType          ( TcKind, TcType, Type, tyVarsOfType, mkPhiTy,
                          mkArrowKind, liftedTypeKind, mkTyVarTys, 
                          tcSplitSigmaTy, tcEqTypes, tcGetTyVar_maybe )

-import Type            ( PredType(..), splitTyConApp_maybe, mkTyVarTy
+import Type            ( PredType(..), splitTyConApp_maybe, mkTyVarTy,
+                          newTyConInstRhs

                          -- pprParendType, pprThetaArrow
                        )
 import Generics                ( validGenericMethodType, canDoGenerics )
                          -- pprParendType, pprThetaArrow
                        )
 import Generics                ( validGenericMethodType, canDoGenerics )

@@ -606,14 +607,21 @@ chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark
 chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang
   = case bang of
        HsNoBang                                    -> NotMarkedStrict
 chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang
   = case bang of
        HsNoBang                                    -> NotMarkedStrict

-       HsStrict | unbox_strict_fields && can_unbox -> MarkedUnboxed
-       HsUnbox  | can_unbox                        -> MarkedUnboxed
+       HsStrict | unbox_strict_fields 
+                   && can_unbox arg_ty                     -> MarkedUnboxed
+       HsUnbox  | can_unbox arg_ty                 -> MarkedUnboxed

        other                                       -> MarkedStrict
   where
        other                                       -> MarkedStrict
   where

-    can_unbox = case splitTyConApp_maybe arg_ty of
-                  Nothing             -> False
-                  Just (arg_tycon, _) -> not (isNewTyCon arg_tycon) && not (isRecursiveTyCon tycon) &&
-                                         isProductTyCon arg_tycon
+    -- we can unbox if the type is a chain of newtypes with a product tycon
+    -- at the end
+    can_unbox arg_ty = case splitTyConApp_maybe arg_ty of
+                  Nothing                      -> False
+                  Just (arg_tycon, tycon_args) -> 
+                       not (isRecursiveTyCon tycon) &&
+                      isProductTyCon arg_tycon &&
+                       (if isNewTyCon arg_tycon then 
+                            can_unbox (newTyConInstRhs arg_tycon tycon_args)
+                        else True)

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index fd8e8c5..c3013ab 100644 (file)
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -56,7 +56,7 @@ module Type (
        predTypeRep, mkPredTy, mkPredTys,
 
        -- Newtypes
        predTypeRep, mkPredTy, mkPredTys,
 
        -- Newtypes

-       splitRecNewType_maybe,
+       splitRecNewType_maybe, newTyConInstRhs,

 
        -- Lifting and boxity
        isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType,
 
        -- Lifting and boxity
        isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType,

@@ -410,6 +410,12 @@ splitNewTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 splitNewTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 splitNewTyConApp_maybe other         = Nothing
 
 splitNewTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 splitNewTyConApp_maybe other         = Nothing
 

+-- get instantiated newtype rhs, the arguments had better saturate 
+-- the constructor
+newTyConInstRhs :: TyCon -> [Type] -> Type
+newTyConInstRhs tycon tys =
+    let (tvs, ty) = newTyConRhs tycon in substTyWith tvs tys ty
+

 \end{code}
 
 
 \end{code}