[project @ 2001-05-18 14:18:34 by simonmar]

Allow unboxing strict fields through newtypes.

diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index c5dd0e1..e9563f4 100644 (file)
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -28,7 +28,7 @@ import CmdLineOpts    ( opt_DictsStrict )
 import Type            ( Type, TauType, ThetaType,
                          mkForAllTys, mkFunTys, mkTyConApp,
                          mkTyVarTys, mkPredTys, getClassPredTys_maybe,
-                         splitTyConApp_maybe
+                         splitTyConApp_maybe, repType
                        )
 import TyCon           ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon,
                          isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
@@ -427,32 +427,34 @@ chooseBoxingStrategy :: TyCon -> Type -> StrictnessMark -> StrictnessMark
        -- Transforms any MarkedUserStricts into MarkUnboxed or MarkedStrict
 chooseBoxingStrategy tycon arg_ty strict
   = case strict of
-       MarkedUserStrict | unbox arg_ty -> MarkedUnboxed
-                        | otherwise    -> MarkedStrict
-       other                           -> strict
+       MarkedUserStrict
+         | opt_UnboxStrictFields
+               && unbox arg_ty -> MarkedUnboxed
+         | otherwise -> MarkedStrict
+       other -> strict
   where
-    unbox ty = opt_UnboxStrictFields &&
-              case splitTyConApp_maybe ty of
-                 Just (arg_tycon, _) -> not (isRecursiveTyCon arg_tycon) && 
-                                        isProductTyCon arg_tycon && 
-                                        isDataTyCon arg_tycon
-                 Nothing             -> False
-       -- Recursion: check whether the *argument* type constructor is
-       -- recursive.  Checking the *parent* tycon is over-conservative
-       --
-       -- We can't look through newtypes in arguments (yet); hence isDataTyCon
-
+       -- beware: repType will go into a loop if we try this on a recursive
+       -- type (for reasons unknown...), hence the check for recursion below.
+    unbox ty =  
+       case splitTyConApp_maybe ty of
+               Nothing -> False
+               Just (arg_tycon, _)
+                 | isRecursiveTyCon arg_tycon -> False
+                 | otherwise ->
+                         case splitTyConApp_maybe (repType ty) of
+                               Nothing -> False
+                               Just (arg_tycon, _) -> isProductTyCon arg_tycon
 
 unbox_strict_arg_ty 
        :: StrictnessMark       -- After strategy choice; can't be MkaredUserStrict
        -> Type                 -- Source argument type
        -> [(Demand,Type)]      -- Representation argument types and demamds
-       
+
 unbox_strict_arg_ty NotMarkedStrict ty = [(wwLazy,   ty)]
 unbox_strict_arg_ty MarkedStrict    ty = [(wwStrict, ty)]
 unbox_strict_arg_ty MarkedUnboxed   ty 
   = zipEqual "unbox_strict_arg_ty" (dataConRepStrictness arg_data_con) arg_tys
   where
-    (_, _, arg_data_con, arg_tys) = splitProductType "unbox_strict_arg_ty" ty
-
+    (_, _, arg_data_con, arg_tys)
+        = splitProductType "unbox_strict_arg_ty" (repType ty)
 \end{code}

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index b639f21..23376f4 100644 (file)
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -39,7 +39,8 @@ import TysWiredIn     ( charTy, mkListTy )
 import PrelNames       ( pREL_ERR, pREL_GHC )
 import PrelRules       ( primOpRule )
 import Rules           ( addRule )
-import Type            ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp, mkTyVarTys,
+import Type            ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
+                         mkTyVarTys, repType, isNewType,
                          mkFunTys, mkFunTy, mkSigmaTy, splitSigmaTy, 
                          isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
                          splitFunTys, splitForAllTys, mkPredTy
@@ -303,12 +304,25 @@ mkDataConWrapId data_con
                   | otherwise ->
                        Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
 
-               MarkedUnboxed ->
-                  Case (Var arg) arg [(DataAlt con, con_args,
+               MarkedUnboxed
+                  | isNewType arg_ty ->
+                       Let (NonRec coerced_arg 
+                               (Note (Coerce rep_ty arg_ty) (Var arg)))
+                             (do_unbox coerced_arg rep_ty i')
+                  | otherwise ->
+                       do_unbox arg arg_ty i
+                 where
+                   ([coerced_arg],i') = mkLocals i [rep_ty]
+                   arg_ty = idType arg
+                   rep_ty = repType arg_ty
+
+                   do_unbox arg ty i = 
+                       case splitProductType "do_unbox" ty of
+                          (tycon, tycon_args, con, tys) ->
+                                  Case (Var arg) arg [(DataAlt con, con_args,
                                        body i' (reverse con_args ++ rep_args))]
-                  where 
-                       (con_args, i')   = mkLocals i tys
-                       (_, _, con, tys) = splitProductType "mk_case" (idType arg)
+                             where 
+                               (con_args, i')   = mkLocals i tys
 \end{code}
 
 
@@ -506,12 +520,25 @@ rebuildConArgs (arg:args) stricts us
 rebuildConArgs (arg:args) (str:stricts) us
   | isMarkedUnboxed str
   = let
-       (_, tycon_args, pack_con, con_arg_tys) = splitProductType "rebuildConArgs" (idType arg)
+       arg_ty  = idType arg
+       prod_ty | isNewType arg_ty = repType arg_ty
+               | otherwise        = arg_ty
+
+       (_, tycon_args, pack_con, con_arg_tys)
+                = splitProductType "rebuildConArgs" prod_ty
+
        unpacked_args  = zipWith (mkSysLocal SLIT("rb")) us con_arg_tys
-       (binds, args') = rebuildConArgs args stricts (drop (length con_arg_tys) us)
-       con_app        = mkConApp pack_con (map Type tycon_args ++ map Var  unpacked_args)
+
+       (binds, args') = rebuildConArgs args stricts 
+                               (drop (length con_arg_tys) us)
+
+       coerce | isNewType arg_ty = Note (Coerce arg_ty prod_ty) con_app
+              | otherwise        = con_app
+
+       con_app        = mkConApp pack_con (map Type tycon_args ++ 
+                                           map Var  unpacked_args)
     in
-    (NonRec arg con_app : binds, unpacked_args ++ args')
+    (NonRec arg coerce : binds, unpacked_args ++ args')
 
   | otherwise
   = let (binds, args') = rebuildConArgs args stricts us