Get rid of the DFunArg type and all its works
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 23 Jun 2011 07:21:51 +0000 (08:21 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 23 Jun 2011 07:21:51 +0000 (08:21 +0100)
This type was mainly there to support silent superclass
parameters for dfuns, and they have gone away.  So this
patch is another minor simplification.

(Interface format change; you need to make clean.)

14 files changed:
compiler/coreSyn/CoreFVs.lhs
compiler/coreSyn/CoreSubst.lhs
compiler/coreSyn/CoreSyn.lhs
compiler/coreSyn/CoreTidy.lhs
compiler/coreSyn/CoreUnfold.lhs
compiler/coreSyn/PprCore.lhs
compiler/iface/BinIface.hs
compiler/iface/IfaceSyn.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/main/TidyPgm.lhs
compiler/simplCore/Simplify.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/vectorise/Vectorise/Type/PADict.hs

index 3301722..f88cb0b 100644 (file)
@@ -450,7 +450,7 @@ idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id)
 stableUnfoldingVars :: Unfolding -> VarSet
 stableUnfoldingVars (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
   | isStableSource src                       = exprFreeVars rhs
-stableUnfoldingVars (DFunUnfolding _ _ args) = exprsFreeVars (dfunArgExprs args)
+stableUnfoldingVars (DFunUnfolding _ _ args) = exprsFreeVars args
 stableUnfoldingVars _                        = emptyVarSet
 \end{code}
 
index 0c954a8..3ba8afa 100644 (file)
@@ -623,7 +623,7 @@ substUnfoldingSC subst unf   -- Short-cut version
 substUnfolding subst (DFunUnfolding ar con args)
   = DFunUnfolding ar con (map subst_arg args)
   where
-    subst_arg = fmap (substExpr (text "dfun-unf") subst)
+    subst_arg = substExpr (text "dfun-unf") subst
 
 substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
        -- Retain an InlineRule!
index 7582481..872e732 100644 (file)
@@ -39,7 +39,6 @@ module CoreSyn (
 
        -- * Unfolding data types
         Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..),
-        DFunArg(..), dfunArgExprs,
 
        -- ** Constructing 'Unfolding's
        noUnfolding, evaldUnfolding, mkOtherCon,
@@ -459,7 +458,7 @@ data Unfolding
 
         DataCon        -- The dictionary data constructor (possibly a newtype datacon)
 
-        [DFunArg CoreExpr]  -- Specification of superclasses and methods, in positional order
+        [CoreExpr]      -- Specification of superclasses and methods, in positional order
 
   | CoreUnfolding {            -- An unfolding for an Id with no pragma, 
                                 -- or perhaps a NOINLINE pragma
@@ -497,21 +496,6 @@ data Unfolding
   --  uf_guidance:  Tells us about the /size/ of the unfolding template
 
 ------------------------------------------------
-data DFunArg e   -- Given (df a b d1 d2 d3)
-  = DFunPolyArg  e      -- Arg is (e a b d1 d2 d3)
-  | DFunConstArg e      -- Arg is e, which is constant
-  deriving( Functor )
-
-  -- 'e' is often CoreExpr, which are usually variables, but can
-  -- be trivial expressions instead (e.g. a type application).
-
-dfunArgExprs :: [DFunArg e] -> [e]
-dfunArgExprs [] = []
-dfunArgExprs (DFunPolyArg  e : as) = e : dfunArgExprs as
-dfunArgExprs (DFunConstArg e : as) = e : dfunArgExprs as
-
-
-------------------------------------------------
 data UnfoldingSource
   = InlineRhs          -- The current rhs of the function
                       -- Replace uf_tmpl each time around
index 377bfd8..110fd72 100644 (file)
@@ -198,7 +198,7 @@ tidyIdBndr env@(tidy_env, var_env) id
 ------------ Unfolding  --------------
 tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding
 tidyUnfolding tidy_env (DFunUnfolding ar con ids) _
-  = DFunUnfolding ar con (map (fmap (tidyExpr tidy_env)) ids)
+  = DFunUnfolding ar con (map (tidyExpr tidy_env) ids)
 tidyUnfolding tidy_env 
               unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
               unf_from_rhs
index fe3772c..f849dfa 100644 (file)
@@ -93,7 +93,7 @@ mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr)
 mkSimpleUnfolding :: CoreExpr -> Unfolding
 mkSimpleUnfolding = mkUnfolding InlineRhs False False
 
-mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding
+mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding
 mkDFunUnfolding dfun_ty ops 
   = DFunUnfolding dfun_nargs data_con ops
   where
@@ -1299,8 +1299,7 @@ exprIsConApp_maybe id_unf expr
              pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False   
         , let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
               subst    = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
-              mk_arg (DFunConstArg e) = e
-              mk_arg (DFunPolyArg e)  = mkApps e args
+              mk_arg e = mkApps e args
         = Just (con, substTys subst dfun_res_tys, map mk_arg ops)
 
        -- Look through unfoldings, but only cheap ones, because
index 8d0239d..bd6cdf4 100644 (file)
@@ -438,10 +438,6 @@ instance Outputable Unfolding where
              | otherwise          = empty
             -- Don't print the RHS or we get a quadratic 
            -- blowup in the size of the printout!
-
-instance Outputable e => Outputable (DFunArg e) where
-  ppr (DFunPolyArg e)  = braces (ppr e)
-  ppr (DFunConstArg e) = ppr e
 \end{code}
 
 -----------------------------------------------------
index 1e24f34..48a94c7 100644 (file)
@@ -18,7 +18,6 @@ import HscTypes
 import BasicTypes
 import Demand
 import Annotations
-import CoreSyn
 import IfaceSyn
 import Module
 import Name
@@ -1273,14 +1272,6 @@ instance Binary IfaceUnfolding where
          _ -> do e <- get bh
                  return (IfCompulsory e)
 
-instance Binary (DFunArg IfaceExpr) where
-    put_ bh (DFunPolyArg  e) = putByte bh 0 >> put_ bh e
-    put_ bh (DFunConstArg e) = putByte bh 1 >> put_ bh e
-    get bh = do { h <- getByte bh
-                ; case h of
-                    0 -> do { a <- get bh; return (DFunPolyArg a) }
-                    _ -> do { a <- get bh; return (DFunConstArg a) } }
-
 instance Binary IfaceNote where
     put_ bh (IfaceSCC aa) = do
            putByte bh 0
index 41732a9..e03bc29 100644 (file)
@@ -27,8 +27,6 @@ module IfaceSyn (
 #include "HsVersions.h"
 
 import IfaceType
-import CoreSyn( DFunArg, dfunArgExprs )
-import PprCore()     -- Printing DFunArgs
 import Demand
 import Annotations
 import Class
@@ -220,7 +218,7 @@ data IfaceUnfolding
   | IfLclWrapper Arity IfLclName  --     because the worker can simplify to a function in
                                   --     another module.
 
-  | IfDFunUnfold [DFunArg IfaceExpr]
+  | IfDFunUnfold [IfaceExpr]
 
 --------------------------------
 data IfaceExpr
@@ -826,7 +824,7 @@ freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e
 freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
 freeNamesIfUnfold (IfExtWrapper _ v)     = unitNameSet v
 freeNamesIfUnfold (IfLclWrapper {})      = emptyNameSet
-freeNamesIfUnfold (IfDFunUnfold vs)      = fnList freeNamesIfExpr (dfunArgExprs vs)
+freeNamesIfUnfold (IfDFunUnfold vs)      = fnList freeNamesIfExpr vs
 
 freeNamesIfExpr :: IfaceExpr -> NameSet
 freeNamesIfExpr (IfaceExt v)      = unitNameSet v
index 42a4278..3612372 100644 (file)
@@ -1563,7 +1563,7 @@ toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
     if_rhs = toIfaceExpr rhs
 
 toIfUnfolding lb (DFunUnfolding _ar _con ops)
-  = Just (HsUnfold lb (IfDFunUnfold (map (fmap toIfaceExpr) ops)))
+  = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
       -- No need to serialise the data constructor; 
       -- we can recover it from the type of the dfun
 
index 2187f03..32c0b2c 100644 (file)
@@ -1091,14 +1091,12 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
     }
 
 tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
-  = do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg ops
+  = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
        ; return (case mb_ops1 of
                            Nothing   -> noUnfolding
                     Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
   where
     doc = text "Class ops for dfun" <+> ppr name
-    tc_arg (DFunPolyArg  e) = do { e' <- tcIfaceExpr e; return (DFunPolyArg e') }
-    tc_arg (DFunConstArg e) = do { e' <- tcIfaceExpr e; return (DFunConstArg e') }
 
 tcUnfolding name ty info (IfExtWrapper arity wkr)
   = tcIfaceWrapper name ty info arity (tcIfaceExtId wkr)
index c3be64b..71f7baf 100644 (file)
@@ -726,7 +726,7 @@ addExternal expose_all id = (new_needed_ids, show_unfold)
                      CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_guidance = guide } 
                                            | show_unfolding src guide
                                            -> Just (unf_ext_ids src unf_rhs)
-                      DFunUnfolding _ _ ops -> Just (exprsFvsInOrder (dfunArgExprs ops))
+                      DFunUnfolding _ _ ops -> Just (exprsFvsInOrder ops)
                      _                     -> Nothing
                   where
                     unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v])
index b187897..a1cae1c 100644 (file)
@@ -707,7 +707,7 @@ simplUnfolding :: SimplEnv-> TopLevelFlag
 simplUnfolding env _ _ _ (DFunUnfolding ar con ops)
   = return (DFunUnfolding ar con ops')
   where
-    ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops
+    ops' = map (substExpr (text "simplUnfolding") env) ops
 
 simplUnfolding env top_lvl id _
     (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
index 33ad0f0..528bb0e 100644 (file)
@@ -37,7 +37,7 @@ import Pair
 --import VarSet
 import CoreUtils  ( mkPiTypes )
 import CoreUnfold ( mkDFunUnfolding )
-import CoreSyn    ( Expr(Var), DFunArg(..), CoreExpr, varToCoreExpr )
+import CoreSyn    ( Expr(Var), CoreExpr, varToCoreExpr )
 import Id
 import MkId
 import Name
@@ -863,9 +863,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                 = dfun_id `setIdUnfolding`  mkDFunUnfolding dfun_ty dfun_args
                           `setInlinePragma` dfunInlinePragma
 
-             dfun_args :: [DFunArg CoreExpr]
-             dfun_args = map (DFunPolyArg . varToCoreExpr) sc_args ++
-                         map (DFunPolyArg . Var) meth_ids
+             dfun_args :: [CoreExpr]
+             dfun_args = map varToCoreExpr sc_args ++
+                         map Var           meth_ids
 
              main_bind = AbsBinds { abs_tvs = inst_tyvars
                                   , abs_ev_vars = dfun_ev_vars
index 3fc2d0a..ba2b395 100644 (file)
@@ -73,7 +73,7 @@ buildPADict vect_tc prepr_tc arr_tc repr
       -- Set the unfolding for the inliner.
       raw_dfun <- newExportedVar dfun_name dfun_ty
       let dfun_unf = mkDFunUnfolding dfun_ty $
-                     map (DFunPolyArg . Var) method_ids
+                     map Var method_ids
           dfun = raw_dfun `setIdUnfolding`  dfun_unf
                           `setInlinePragma` dfunInlinePragma