Robustify the treatement of DFunUnfolding
authorsimonpj@microsoft.com <unknown>
Mon, 31 May 2010 14:53:32 +0000 (14:53 +0000)
committersimonpj@microsoft.com <unknown>
Mon, 31 May 2010 14:53:32 +0000 (14:53 +0000)
See Note [DFun unfoldings] in CoreSyn.  The issue here is that
you can't tell how many dictionary arguments a DFun needs just
from looking at the Arity of the DFun Id: if the dictionary is
represented by a newtype the arity might include the dictionary
and value arguments of the (single) method.

So we need to record the number of arguments need by the DFun
in the DFunUnfolding itself.  Details in
   Note [DFun unfoldings] in CoreSyn

12 files changed:
compiler/coreSyn/CoreFVs.lhs
compiler/coreSyn/CoreSubst.lhs
compiler/coreSyn/CoreSyn.lhs
compiler/coreSyn/CoreUnfold.lhs
compiler/coreSyn/PprCore.lhs
compiler/deSugar/DsBinds.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/main/TidyPgm.lhs
compiler/simplCore/Simplify.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/vectorise/VectType.hs

index 1e8c9e7..46c21b2 100644 (file)
@@ -422,10 +422,10 @@ idUnfoldingVars :: Id -> VarSet
 idUnfoldingVars id
   = case realIdUnfolding id of
       CoreUnfolding { uf_tmpl = rhs, uf_src = src }
-                          | isInlineRuleSource src
-                          -> exprFreeVars rhs
-      DFunUnfolding _ args -> exprsFreeVars args
-      _                    -> emptyVarSet
+                            | isInlineRuleSource src
+                            -> exprFreeVars rhs
+      DFunUnfolding _ args -> exprsFreeVars args
+      _                      -> emptyVarSet
 \end{code}
 
 
index c5d8b83..3578037 100644 (file)
@@ -543,8 +543,8 @@ substUnfoldingSC subst unf   -- Short-cut version
   | isEmptySubst subst = unf
   | otherwise          = substUnfolding subst unf
 
-substUnfolding subst (DFunUnfolding con args)
-  = DFunUnfolding con (map (substExpr (text "dfun-unf") subst) args)
+substUnfolding subst (DFunUnfolding ar con args)
+  = DFunUnfolding ar con (map (substExpr (text "dfun-unf") subst) args)
 
 substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
        -- Retain an InlineRule!
index 2ddc7a5..b7a859f 100644 (file)
@@ -420,12 +420,17 @@ data Unfolding
                       --
                       -- Here, @f@ gets an @OtherCon []@ unfolding.
 
-  | DFunUnfolding DataCon [CoreExpr]   
-                        -- The Unfolding of a DFunId
+  | DFunUnfolding       -- The Unfolding of a DFunId  
+                       -- See Note [DFun unfoldings]
                        --     df = /\a1..am. \d1..dn. MkD (op1 a1..am d1..dn)
                        --                                 (op2 a1..am d1..dn)
-                       -- where Arity = n, the number of dict args to the dfun
-                       -- The [CoreExpr] are the superclasses and methods [op1,op2], 
+
+        Arity          -- Arity = m+n, the *total* number of args 
+                       --   (unusually, both type and value) to the dfun
+
+        DataCon        -- The dictionary data constructor (possibly a newtype datacon)
+
+        [CoreExpr]     -- The [CoreExpr] are the superclasses and methods [op1,op2], 
                        -- in positional order.
                        -- They are usually variables, but can be trivial expressions
                        -- instead (e.g. a type application).  
@@ -509,7 +514,34 @@ data UnfoldingGuidance
                          -- (where there are the right number of arguments.)
 
   | UnfNever       -- The RHS is big, so don't inline it
+\end{code}
+
+
+Note [DFun unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~
+The Arity in a DFunUnfolding is total number of args (type and value)
+that the DFun needs to produce a dictionary.  That's not necessarily 
+related to the ordinary arity of the dfun Id, esp if the class has
+one method, so the dictionary is represented by a newtype.  Example
+
+     class C a where { op :: a -> Int }
+     instance C a -> C [a] where op xs = op (head xs)
 
+The instance translates to
+
+     $dfCList :: forall a. C a => C [a]  -- Arity 2!
+     $dfCList = /\a.\d. $copList {a} d |> co
+     $copList :: forall a. C a => [a] -> Int  -- Arity 2!
+     $copList = /\a.\d.\xs. op {a} d (head xs)
+
+Now we might encounter (op (dfCList {ty} d) a1 a2)
+and we want the (op (dfList {ty} d)) rule to fire, because $dfCList
+has all its arguments, even though its (value) arity is 2.  That's
+why we cache the number of expected 
+
+
+\begin{code}
 -- Constants for the UnfWhen constructor
 needSaturated, unSaturatedOk :: Bool
 needSaturated = False
index e645fab..e73e4b0 100644 (file)
@@ -40,6 +40,7 @@ import StaticFlags
 import DynFlags
 import CoreSyn
 import PprCore         ()      -- Instances
+import TcType          ( tcSplitSigmaTy, tcSplitDFunHead )
 import OccurAnal
 import CoreSubst hiding( substTy )
 import CoreFVs         ( exprFreeVars )
@@ -126,8 +127,16 @@ mkCoreUnfolding top_lvl src expr arity guidance
                    uf_expandable = exprIsExpandable expr,
                    uf_guidance   = guidance }
 
-mkDFunUnfolding :: DataCon -> [Id] -> Unfolding
-mkDFunUnfolding con ops = DFunUnfolding con (map Var ops)
+mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding
+mkDFunUnfolding dfun_ty ops 
+  = DFunUnfolding dfun_nargs data_con ops
+  where
+    (tvs, theta, head_ty) = tcSplitSigmaTy dfun_ty
+         -- NB: tcSplitSigmaTy: do not look through a newtype
+         --     when the dictionary type is a newtype
+    (cls, _)   = tcSplitDFunHead head_ty
+    dfun_nargs = length tvs + length theta
+    data_con   = classDataCon cls
 
 mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
 mkWwInlineRule id expr arity
@@ -1223,13 +1232,15 @@ exprIsConApp_maybe id_unf expr
 
     analyse (Var fun) args
        | Just con <- isDataConWorkId_maybe fun
-        , is_saturated
+        , count isValArg args == idArity fun
        , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args
        = Just (con, stripTypeArgs univ_ty_args, rest_args)
 
        -- Look through dictionary functions; see Note [Unfolding DFuns]
-        | DFunUnfolding con ops <- unfolding
-        , is_saturated
+        | DFunUnfolding dfun_nargs con ops <- unfolding
+        , let sat = length args == dfun_nargs    -- See Note [DFun arity check]
+          in if sat then True else 
+             pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False   
         , let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
              subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
         = Just (con, substTys subst dfun_res_tys, 
@@ -1241,7 +1252,6 @@ exprIsConApp_maybe id_unf expr
        = -- pprTrace "expanding" (ppr fun $$ ppr rhs) $
           analyse rhs args
         where
-         is_saturated = count isValArg args == idArity fun
          unfolding = id_unf fun
 
     analyse _ _ = Nothing
@@ -1282,3 +1292,8 @@ So to split it up we just need to apply the ops $c1, $c2 etc
 to the very same args as the dfun.  It takes a little more work
 to compute the type arguments to the dictionary constructor.
 
+Note [DFun arity check]
+~~~~~~~~~~~~~~~~~~~~~~~
+Here we check that the total number of supplied arguments (inclding 
+type args) matches what the dfun is expecting.  This may be *less*
+than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
\ No newline at end of file
index 209ebfb..37e22cf 100644 (file)
@@ -386,10 +386,11 @@ instance Outputable UnfoldingSource where
   ppr InlineRhs         = ptext (sLit "<vanilla>")
 
 instance Outputable Unfolding where
-  ppr NoUnfolding             = ptext (sLit "No unfolding")
-  ppr (OtherCon cs)           = ptext (sLit "OtherCon") <+> ppr cs
-  ppr (DFunUnfolding con ops) = ptext (sLit "DFun") <+> ppr con
-                                 <+> brackets (pprWithCommas pprParendExpr ops)
+  ppr NoUnfolding               = ptext (sLit "No unfolding")
+  ppr (OtherCon cs)             = ptext (sLit "OtherCon") <+> ppr cs
+  ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)  
+                                   <+> ppr con
+                                   <+> brackets (pprWithCommas pprParendExpr ops)
   ppr (CoreUnfolding { uf_src = src
                      , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
                      , uf_is_conlike=conlike, uf_is_cheap=cheap
index bfe4323..2c6f361 100644 (file)
@@ -462,6 +462,7 @@ dsSpecs poly_id poly_rhs prags
           ; spec_name <- newLocalName poly_name
           ; wrap_fn   <- dsCoercion spec_co
            ; let ds_spec_expr = wrap_fn (Var poly_id)
+                 spec_ty = exprType ds_spec_expr
           ; case decomposeRuleLhs ds_spec_expr of {
               Nothing -> do { warnDs (decomp_msg spec_co)
                              ; return Nothing } ;
@@ -473,10 +474,9 @@ dsSpecs poly_id poly_rhs prags
                bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } 
                   | otherwise -> do
 
-          { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (realIdUnfolding poly_id)
+          { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
 
-          ; let spec_ty = exprType ds_spec_expr
-                spec_id  = mkLocalId spec_name spec_ty 
+          ; let spec_id  = mkLocalId spec_name spec_ty 
                            `setInlinePragma` inl_prag
                            `setIdUnfolding`  spec_unf
                 inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
@@ -511,12 +511,13 @@ dsSpecs poly_id poly_rhs prags
             2 (pprHsWrapper (ppr poly_id) spec_co)
             
 
-specUnfolding :: (CoreExpr -> CoreExpr) -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
-specUnfolding wrap_fn (DFunUnfolding con ops)
+specUnfolding :: (CoreExpr -> CoreExpr) -> Type 
+              -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
+specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
   = do { let spec_rhss = map wrap_fn ops
        ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
-       ; return (DFunUnfolding con (map Var spec_ids), spec_ids `zip` spec_rhss) }
-specUnfolding _ _
+       ; return (mkDFunUnfolding spec_ty (map Var spec_ids), spec_ids `zip` spec_rhss) }
+specUnfolding _ _ _
   = return (noUnfolding, [])
 
 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
index 07b1268..5c236b3 100644 (file)
@@ -1545,7 +1545,7 @@ toIfUnfolding lb unf@(CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
        -- have stuck in NoUnfolding.  For supercompilation we want 
        -- to see that unfolding!
 
-toIfUnfolding lb (DFunUnfolding _con ops)
+toIfUnfolding lb (DFunUnfolding _ar _con 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 d8bd414..1f846d3 100644 (file)
@@ -1053,11 +1053,9 @@ tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
   = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
        ; return (case mb_ops1 of
                            Nothing   -> noUnfolding
-                    Just ops1 -> DFunUnfolding data_con ops1) }
+                    Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
   where
     doc = text "Class ops for dfun" <+> ppr name
-    (_, cls, _) = tcSplitDFunTy dfun_ty
-    data_con = classDataCon cls
 \end{code}
 
 For unfoldings we try to do the job lazily, so that we never type check
index 0245978..6a0a2cf 100644 (file)
@@ -709,10 +709,10 @@ addExternal expose_all id = (new_needed_ids, show_unfold)
     mb_unfold_ids :: Maybe (IdSet, [Id])       -- Nothing => don't unfold
     mb_unfold_ids = case unfoldingInfo idinfo of
                      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 ops)
-                     _                   -> Nothing
+                                           | show_unfolding src guide
+                                           -> Just (unf_ext_ids src unf_rhs)
+                     DFunUnfolding _ ops -> Just (exprsFvsInOrder ops)
+                     _                     -> Nothing
                   where
                     unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v])
                     unf_ext_ids _           unf_rhs = exprFvsInOrder unf_rhs
@@ -1094,8 +1094,8 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info
 
 ------------ Unfolding  --------------
 tidyUnfolding :: TidyEnv -> CoreExpr -> Maybe StrictSig -> Unfolding -> Unfolding
-tidyUnfolding tidy_env _ _ (DFunUnfolding con ids)
-  = DFunUnfolding con (map (tidyExpr tidy_env) ids)
+tidyUnfolding tidy_env _ _ (DFunUnfolding ar con ids)
+  = DFunUnfolding ar con (map (tidyExpr tidy_env) ids)
 tidyUnfolding tidy_env tidy_rhs strict_sig
               unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
   | isInlineRuleSource src
index b0718e4..ec7e190 100644 (file)
@@ -705,8 +705,8 @@ simplUnfolding :: SimplEnv-> TopLevelFlag
               -> OccInfo -> OutExpr
               -> Unfolding -> SimplM Unfolding
 -- Note [Setting the new unfolding]
-simplUnfolding env _ _ _ _ (DFunUnfolding con ops)
-  = return (DFunUnfolding con ops')
+simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops)
+  = return (DFunUnfolding ar con ops')
   where
     ops' = map (substExpr (text "simplUnfolding") env) ops
 
index 55fc342..374fb6d 100644 (file)
@@ -32,6 +32,7 @@ import DataCon
 import Class
 import Var
 import CoreUnfold ( mkDFunUnfolding )
+import CoreSyn   ( Expr(Var) )
 import Id
 import MkId
 import Name
@@ -704,9 +705,9 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi _)
 -- Ordinary instances
 
 tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
 = do { let rigid_info = InstSkol
-             inst_ty    = idType dfun_id
-             loc        = getSrcSpan dfun_id
+ = do { let rigid_info = InstSkol
+            inst_ty    = idType dfun_id
+            loc        = getSrcSpan dfun_id
 
         -- Instantiate the instance decl with skolem constants
        ; (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
@@ -773,7 +774,8 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
        ; let dict_constr   = classDataCon clas
              this_dict_id  = instToId this_dict
             dict_bind     = mkVarBind this_dict_id dict_rhs
-             dict_rhs      = foldl mk_app inst_constr (sc_ids ++ meth_ids)
+             dict_rhs      = foldl mk_app inst_constr sc_meth_ids
+             sc_meth_ids   = sc_ids ++ meth_ids
             inst_constr   = L loc $ wrapId (mkWpTyApps inst_tys')
                                            (dataConWrapId dict_constr)
                      -- We don't produce a binding for the dict_constr; instead we
@@ -791,7 +793,7 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
                -- See Note [ClassOp/DFun selection]
                -- See also note [Single-method classes]
              dfun_id_w_fun = dfun_id  
-                             `setIdUnfolding`  mkDFunUnfolding dict_constr (sc_ids ++ meth_ids)
+                             `setIdUnfolding`  mkDFunUnfolding inst_ty (map Var sc_meth_ids)
                              `setInlinePragma` dfunInlinePragma
 
              main_bind = AbsBinds
index 37d65db..37022cf 100644 (file)
@@ -802,16 +802,16 @@ buildPADict vect_tc prepr_tc arr_tc repr
       method_ids <- mapM (method args) paMethods
 
       pa_tc  <- builtin paTyCon
-      pa_con <- builtin paDataCon
+      pa_dc  <- builtin paDataCon
       let dict = mkLams (tvs ++ args)
-               $ mkConApp pa_con
+               $ mkConApp pa_dc
                $ Type inst_ty : map (method_call args) method_ids
 
           dfun_ty = mkForAllTys tvs
                   $ mkFunTys (map varType args) (mkTyConApp pa_tc [inst_ty])
 
       raw_dfun <- newExportedVar dfun_name dfun_ty
-      let dfun = raw_dfun `setIdUnfolding` mkDFunUnfolding pa_con method_ids
+      let dfun = raw_dfun `setIdUnfolding` mkDFunUnfolding dfun_ty (map Var method_ids)
                           `setInlinePragma` dfunInlinePragma
 
       hoistBinding dfun dict