[commit: ghc] master: Refactor inferConstraints not to use CPS (95cbb55)

git at git.haskell.org git at git.haskell.org
Tue Feb 21 14:29:17 UTC 2017


Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/95cbb55cf7dfeaae466f0512af28a92914faacb5/ghc

>---------------------------------------------------------------

commit 95cbb55cf7dfeaae466f0512af28a92914faacb5
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Feb 21 14:27:30 2017 +0000

    Refactor inferConstraints not to use CPS
    
    For some odd reason inferConstraints was using a CPS style,
    which is entirely unnecessary.  This patch straightens it out.
    
    No change in what it does.


>---------------------------------------------------------------

95cbb55cf7dfeaae466f0512af28a92914faacb5
 compiler/typecheck/TcDeriv.hs      | 10 ++++++----
 compiler/typecheck/TcDerivInfer.hs | 33 +++++++++++++++------------------
 2 files changed, 21 insertions(+), 22 deletions(-)

diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 55b7d6d..86f0409 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -1010,16 +1010,18 @@ mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args
        dfun_name            <- newDFunName' cls tycon
        case mtheta of
         Nothing -> -- Infer context
-          inferConstraints tvs cls cls_tys inst_ty rep_tc rep_tc_args mechanism
-            $ \inferred_constraints tvs' inst_tys' ->
-            return $ InferTheta $ DS
+          do { (inferred_constraints, tvs', inst_tys')
+                 <- inferConstraints tvs cls cls_tys inst_ty
+                                     rep_tc rep_tc_args mechanism
+             ; return $ InferTheta $ DS
                    { ds_loc = loc
                    , ds_name = dfun_name, ds_tvs = tvs'
                    , ds_cls = cls, ds_tys = inst_tys'
                    , ds_tc = rep_tc
                    , ds_theta = inferred_constraints
                    , ds_overlap = overlap_mode
-                   , ds_mechanism = mechanism }
+                   , ds_mechanism = mechanism } }
+
         Just theta -> do -- Specified context
             return $ GivenTheta $ DS
                    { ds_loc = loc
diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs
index 02e9f1f..22c0503 100644
--- a/compiler/typecheck/TcDerivInfer.hs
+++ b/compiler/typecheck/TcDerivInfer.hs
@@ -48,8 +48,7 @@ import Data.Maybe
 
 inferConstraints :: [TyVar] -> Class -> [TcType] -> TcType
                  -> TyCon -> [TcType] -> DerivSpecMechanism
-                 -> ([ThetaOrigin] -> [TyVar] -> [TcType] -> TcM a)
-                 -> TcM a
+                 -> TcM ([ThetaOrigin], [TyVar], [TcType])
 -- inferConstraints figures out the constraints needed for the
 -- instance declaration generated by a 'deriving' clause on a
 -- data type declaration. It also returns the new in-scope type
@@ -67,15 +66,15 @@ inferConstraints :: [TyVar] -> Class -> [TcType] -> TcType
 -- before being used in the instance declaration
 inferConstraints tvs main_cls cls_tys inst_ty
                  rep_tc rep_tc_args
-                 mechanism thing
+                 mechanism
   | is_generic && not is_anyclass     -- Generic constraints are easy
-  = thing [mkThetaOriginFromPreds []] tvs inst_tys
+  = return ([], tvs, inst_tys)
 
   | is_generic1 && not is_anyclass    -- Generic1 needs Functor
   = ASSERT( length rep_tc_tvs > 0 )   -- See Note [Getting base classes]
     ASSERT( length cls_tys   == 1 )   -- Generic1 has a single kind variable
     do { functorClass <- tcLookupClass functorClassName
-       ; con_arg_constraints (get_gen1_constraints functorClass) thing }
+       ; con_arg_constraints (get_gen1_constraints functorClass) }
 
   | otherwise  -- The others are a bit more complicated
   = -- See the comment with all_rep_tc_args for an explanation of
@@ -83,14 +82,14 @@ inferConstraints tvs main_cls cls_tys inst_ty
     ASSERT2( equalLength rep_tc_tvs all_rep_tc_args
            , ppr main_cls <+> ppr rep_tc
              $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )
-    infer_constraints $ \arg_constraints tvs' inst_tys' ->
-      do { traceTc "inferConstraints" $ vcat
+      do { (arg_constraints, tvs', inst_tys') <- infer_constraints
+         ; traceTc "inferConstraints" $ vcat
                 [ ppr main_cls <+> ppr inst_tys'
                 , ppr arg_constraints
                 ]
-         ; thing (stupid_constraints ++ extra_constraints
-                     ++ sc_constraints ++ arg_constraints)
-                 tvs' inst_tys' }
+         ; return (stupid_constraints ++ extra_constraints
+                    ++ sc_constraints ++ arg_constraints
+                  , tvs', inst_tys') }
   where
     is_anyclass = isDerivSpecAnyClass mechanism
     infer_constraints
@@ -108,9 +107,8 @@ inferConstraints tvs main_cls cls_tys inst_ty
     con_arg_constraints :: (CtOrigin -> TypeOrKind
                                      -> Type
                                      -> [([PredOrigin], Maybe TCvSubst)])
-                        -> ([ThetaOrigin] -> [TyVar] -> [TcType] -> TcM a)
-                        -> TcM a
-    con_arg_constraints get_arg_constraints thing
+                        -> TcM ([ThetaOrigin], [TyVar], [TcType])
+    con_arg_constraints get_arg_constraints
       = let (predss, mbSubsts) = unzip
               [ preds_and_mbSubst
               | data_con <- tyConDataCons rep_tc
@@ -136,7 +134,7 @@ inferConstraints tvs main_cls cls_tys inst_ty
             preds'       = map (substPredOrigin subst') preds
             inst_tys'    = substTys subst' inst_tys
             tvs'         = tyCoVarsOfTypesWellScoped inst_tys'
-        in thing [mkThetaOriginFromPreds preds'] tvs' inst_tys'
+        in return ([mkThetaOriginFromPreds preds'], tvs', inst_tys')
 
     is_generic  = main_cls `hasKey` genClassKey
     is_generic1 = main_cls `hasKey` gen1ClassKey
@@ -243,9 +241,8 @@ typeToTypeKind = liftedTypeKind `mkFunTy` liftedTypeKind
 -- for an explanation of how these constraints are used to determine the
 -- derived instance context.
 inferConstraintsDAC :: Class -> [TyVar] -> [TcType]
-                    -> ([ThetaOrigin] -> [TyVar] -> [TcType] -> TcM a)
-                    -> TcM a
-inferConstraintsDAC cls tvs inst_tys thing
+                    -> TcM ([ThetaOrigin], [TyVar], [TcType])
+inferConstraintsDAC cls tvs inst_tys
   = do { let gen_dms = [ (sel_id, dm_ty)
                        | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]
 
@@ -254,7 +251,7 @@ inferConstraintsDAC cls tvs inst_tys thing
             --      to mk_wanteds in simplifyDeriv.  If we omit this, the
             --      unification variables will wrongly be untouchable.
 
-       ; thing theta_origins tvs inst_tys }
+       ; return (theta_origins, tvs, inst_tys) }
   where
     cls_tvs = classTyVars cls
     empty_subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet tvs))



More information about the ghc-commits mailing list