Refactor buildClass and mkDictSelId a bit, to avoid the no_unf argument
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 8 May 2014 09:31:53 +0000 (10:31 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 8 May 2014 09:59:14 +0000 (10:59 +0100)
No change in functionality, just a cleaner story, with the RHS for
dictionary selectors being treated less specially than before.

compiler/basicTypes/MkId.lhs
compiler/iface/BuildTyCl.lhs
compiler/iface/TcIface.lhs
compiler/main/TidyPgm.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/vectorise/Vectorise/Type/TyConDecl.hs

index 38922fc..5f4b792 100644 (file)
@@ -20,7 +20,7 @@ have a standard form, namely:
 -- for details
 
 module MkId (
-        mkDictFunId, mkDictFunTy, mkDictSelId,
+        mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs,
 
         mkPrimOpId, mkFCallId,
 
@@ -272,39 +272,36 @@ at the outside.  When dealing with classes it's very convenient to
 recover the original type signature from the class op selector.
 
 \begin{code}
-mkDictSelId :: DynFlags
-            -> Bool         -- True <=> don't include the unfolding
-                            -- Little point on imports without -O, because the
-                            -- dictionary itself won't be visible
-           -> Name          -- Name of one of the *value* selectors 
+mkDictSelId :: Name         -- Name of one of the *value* selectors 
                             -- (dictionary superclass or method)
             -> Class -> Id
-mkDictSelId dflags no_unf name clas
+mkDictSelId name clas
   = mkGlobalId (ClassOpId clas) name sel_ty info
   where
-    sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
-        -- We can't just say (exprType rhs), because that would give a type
-        --      C a -> C a
-        -- for a single-op class (after all, the selector is the identity)
-        -- But it's type must expose the representation of the dictionary
-        -- to get (say)         C a -> (a -> a)
+    tycon                 = classTyCon clas
+    sel_names      = map idName (classAllSelIds clas)
+    new_tycon             = isNewTyCon tycon
+    [data_con]            = tyConDataCons tycon
+    tyvars                = dataConUnivTyVars data_con
+    arg_tys               = dataConRepArgTys data_con  -- Includes the dictionary superclasses
+    val_index      = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name
+
+    sel_ty = mkForAllTys tyvars (mkFunTy (mkClassPred clas (mkTyVarTys tyvars))
+                                         (getNth arg_tys val_index))
 
     base_info = noCafIdInfo
                 `setArityInfo`         1
                 `setStrictnessInfo`    strict_sig
-                `setUnfoldingInfo`     (if no_unf then noUnfolding
-                                       else mkImplicitUnfolding dflags rhs)
-                  -- In module where class op is defined, we must add
-                  -- the unfolding, even though it'll never be inlined
-                  -- because we use that to generate a top-level binding
-                  -- for the ClassOp
-
-    info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma
+
+    info | new_tycon
+         = base_info `setInlinePragInfo` alwaysInlinePragma
+                     `setUnfoldingInfo`  mkInlineUnfolding (Just 1) (mkDictSelRhs clas val_index)
                   -- See Note [Single-method classes] in TcInstDcls
                   -- for why alwaysInlinePragma
-         | otherwise = base_info  `setSpecInfo`       mkSpecInfo [rule]
-                                 `setInlinePragInfo` neverInlinePragma
-                  -- Add a magic BuiltinRule, and never inline it
+
+         | otherwise
+         = base_info `setSpecInfo` mkSpecInfo [rule]
+                  -- Add a magic BuiltinRule, but no unfolding
                   -- so that the rule is always available to fire.
                   -- See Note [ClassOp/DFun selection] in TcInstDcls
 
@@ -326,25 +323,26 @@ mkDictSelId dflags no_unf name clas
     strict_sig = mkClosedStrictSig [arg_dmd] topRes
     arg_dmd | new_tycon = evalDmd
             | otherwise = mkManyUsedDmd $
-                          mkProdDmd [ if the_arg_id == id then evalDmd else absDmd
-                                    | id <- arg_ids ]
-
+                          mkProdDmd [ if name == sel_name then evalDmd else absDmd
+                                    | sel_name <- sel_names ]
+
+mkDictSelRhs :: Class
+             -> Int         -- 0-indexed selector among (superclasses ++ methods)
+             -> CoreExpr
+mkDictSelRhs clas val_index
+  = mkLams tyvars (Lam dict_id rhs_body)
+  where
     tycon                 = classTyCon clas
     new_tycon             = isNewTyCon tycon
     [data_con]            = tyConDataCons tycon
     tyvars                = dataConUnivTyVars data_con
     arg_tys               = dataConRepArgTys data_con  -- Includes the dictionary superclasses
 
-    -- 'index' is a 0-index into the *value* arguments of the dictionary
-    val_index      = assoc "MkId.mkDictSelId" sel_index_prs name
-    sel_index_prs  = map idName (classAllSelIds clas) `zip` [0..]
-
     the_arg_id     = getNth arg_ids val_index
     pred                  = mkClassPred clas (mkTyVarTys tyvars)
     dict_id               = mkTemplateLocal 1 pred
     arg_ids               = mkTemplateLocalsNum 2 arg_tys
 
-    rhs = mkLams tyvars  (Lam dict_id   rhs_body)
     rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
              | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
                                 [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)]
index e412d7e..033e8c6 100644 (file)
@@ -254,10 +254,7 @@ type TcMethInfo = (Name, DefMethSpec, Type)
         -- A temporary intermediate, to communicate between 
         -- tcClassSigs and buildClass.
 
-buildClass :: Bool             -- True <=> do not include unfoldings 
-                               --          on dict selectors
-                               -- Used when importing a class without -O
-          -> Name -> [TyVar] -> [Role] -> ThetaType
+buildClass :: Name -> [TyVar] -> [Role] -> ThetaType
           -> [FunDep TyVar]               -- Functional dependencies
           -> [ClassATItem]                -- Associated types
           -> [TcMethInfo]                 -- Method info
@@ -265,10 +262,9 @@ buildClass :: Bool         -- True <=> do not include unfoldings
           -> RecFlag                      -- Info for type constructor
           -> TcRnIf m n Class
 
-buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
+buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
   = fixM  $ \ rec_clas ->      -- Only name generation inside loop
     do { traceIf (text "buildClass")
-        ; dflags <- getDynFlags
 
        ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
                -- The class name is the 'parent' for this datacon, not its tycon,
@@ -282,7 +278,7 @@ buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc
              -- Make selectors for the superclasses 
        ; sc_sel_names <- mapM  (newImplicitBinder tycon_name . mkSuperDictSelOcc) 
                                [1..length sc_theta]
-        ; let sc_sel_ids = [ mkDictSelId dflags no_unf sc_name rec_clas 
+        ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas 
                            | sc_name <- sc_sel_names]
              -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we 
              -- can construct names for the selectors. Thus
@@ -348,14 +344,13 @@ buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc
   where
     mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
     mk_op_item rec_clas (op_name, dm_spec, _) 
-      = do { dflags <- getDynFlags
-           ; dm_info <- case dm_spec of
+      = do { dm_info <- case dm_spec of
                           NoDM      -> return NoDefMeth
                           GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc
                                          ; return (GenDefMeth dm_name) }
                           VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
                                          ; return (DefMeth dm_name) }
-           ; return (mkDictSelId dflags no_unf op_name rec_clas, dm_info) }
+           ; return (mkDictSelId op_name rec_clas, dm_info) }
 \end{code}
 
 Note [Class newtypes and equality predicates]
index 01a2114..12e4e94 100644 (file)
@@ -527,7 +527,7 @@ tc_iface_decl _parent ignore_prags
     ; cls  <- fixM $ \ cls -> do
               { ats  <- mapM (tc_at cls) rdr_ats
               ; traceIf (text "tc-iface-class4" <+> ppr tc_occ)
-              ; buildClass ignore_prags tc_name tyvars roles ctxt fds ats sigs mindef tc_isrec }
+              ; buildClass tc_name tyvars roles ctxt fds ats sigs mindef tc_isrec }
     ; return (ATyCon (classTyCon cls)) }
   where
    tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
index b20658b..1055e3d 100644 (file)
@@ -26,6 +26,7 @@ import VarEnv
 import VarSet
 import Var
 import Id
+import MkId             ( mkDictSelRhs )
 import IdInfo
 import InstEnv
 import FamInstEnv
@@ -566,7 +567,9 @@ getTyConImplicitBinds :: TyCon -> [CoreBind]
 getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))
 
 getClassImplicitBinds :: Class -> [CoreBind]
-getClassImplicitBinds cls = map get_defn (classAllSelIds cls)
+getClassImplicitBinds cls
+  = [ NonRec op (mkDictSelRhs cls val_index)
+    | (op, val_index) <- classAllSelIds cls `zip` [0..] ]
 
 get_defn :: Id -> CoreBind
 get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))
index f11295a..9f45732 100644 (file)
@@ -638,7 +638,7 @@ tcTyClDecl1 _parent rec_info
                ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
                ; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs
                ; mindef <- tcClassMinimalDef class_name sigs sig_stuff
-               ; clas <- buildClass False {- Must include unfoldings for selectors -}
+               ; clas <- buildClass
                             class_name tvs' roles ctxt' fds' at_stuff
                             sig_stuff mindef tc_isrec
                ; traceTc "tcClassDecl" (ppr fundeps $$ ppr tvs' $$ ppr fds')
index a8159b0..37a07f7 100644 (file)
@@ -59,7 +59,6 @@ vectTyConDecl tycon name'
            -- NB: 'buildClass' attaches new quantifiers and dictionaries to the method types
        ; cls' <- liftDs $
                    buildClass
-                     False                      -- include unfoldings on dictionary selectors
                      name'                      -- new name: "V:Class"
                      (tyConTyVars tycon)        -- keep original type vars
                      (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety