Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC

Commits:

1 changed file:

Changes:

  • compiler/GHC/HsToCore/Binds.hs
    ... ... @@ -1071,7 +1071,7 @@ dsSpec poly_rhs (SpecPragE { spe_fn_nm = poly_nm
    1071 1071
     dsSpec_help :: Name -> Id -> CoreExpr              -- Function to specialise
    
    1072 1072
                 -> InlinePragma -> [Var] -> CoreExpr
    
    1073 1073
                 -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
    
    1074
    -dsSpec_help poly_nm poly_id poly_rhs inl bndrs ds_call
    
    1074
    +dsSpec_help poly_nm poly_id poly_rhs inl orig_bndrs ds_call
    
    1075 1075
       = do {
    
    1076 1076
            -- Simplify the (desugared) call; see wrinkle (SP1)
    
    1077 1077
            -- in Note [Desugaring new-form SPECIALISE pragmas]
    
    ... ... @@ -1079,21 +1079,20 @@ dsSpec_help poly_nm poly_id poly_rhs inl bndrs ds_call
    1079 1079
            ; let simpl_opts = initSimpleOpts dflags
    
    1080 1080
                  core_call  = simpleOptExprNoInline simpl_opts ds_call
    
    1081 1081
     
    
    1082
    -       ; case prepareSpecLHS poly_id bndrs core_call of {
    
    1082
    +       ; case decomposeCall poly_id [] core_call of {
    
    1083 1083
                 Nothing -> do { diagnosticDs (DsRuleLhsTooComplicated ds_call core_call)
    
    1084 1084
                                ; return Nothing } ;
    
    1085 1085
     
    
    1086
    -            Just (bndr_set, spec_const_binds, rule_lhs_args) ->
    
    1086
    +            Just (rev_binds, rule_lhs_args) ->
    
    1087 1087
     
    
    1088
    -    do { let const_bndrs = mkVarSet (bindersOfBinds spec_const_binds)
    
    1089
    -             all_bndrs   = bndr_set `unionVarSet` const_bndrs
    
    1090
    -                  -- all_bndrs: all binders in core_call that should be quantified
    
    1088
    +    do { let orig_bndr_set = mkVarSet orig_bndrs
    
    1089
    +             rule_bndrs = scopedSort (exprsSomeFreeVarsList (`elemVarSet` orig_bndr_set)
    
    1090
    +                                                            rule_lhs_args)
    
    1091
    +             spec_binds = grabSpecBinds orig_bndr_set (mkVarSet rule_bndrs) rev_binds
    
    1092
    +             spec_binds_bndr_set = mkVarSet (bindersOfBinds spec_binds)
    
    1093
    +             spec_bndrs = filterOut (`elemVarSet` spec_binds_bndr_set) rule_bndrs
    
    1091 1094
     
    
    1092
    -             -- rule_bndrs; see (SP3) in Note [Desugaring new-form SPECIALISE pragmas]
    
    1093
    -             rule_bndrs = scopedSort (exprsSomeFreeVarsList (`elemVarSet` all_bndrs) rule_lhs_args)
    
    1094
    -             spec_bndrs = filterOut (`elemVarSet` const_bndrs) rule_bndrs
    
    1095
    -
    
    1096
    -             mk_spec_body fn_body = mkLets spec_const_binds  $
    
    1095
    +             mk_spec_body fn_body = mkLets spec_binds  $
    
    1097 1096
                                         mkApps fn_body rule_lhs_args
    
    1098 1097
                                         -- ToDo: not mkCoreApps!  That uses exprType on fun which
    
    1099 1098
                                         --       fails in specUnfolding, sigh
    
    ... ... @@ -1117,11 +1116,64 @@ dsSpec_help poly_nm poly_id poly_rhs inl bndrs ds_call
    1117 1116
                             rule_bndrs poly_id rule_lhs_args
    
    1118 1117
                             spec_bndrs mk_spec_body inl } } }
    
    1119 1118
     
    
    1120
    -prepareSpecLHS :: Id -> [EvVar] -> CoreExpr
    
    1121
    -               -> Maybe (VarSet, [CoreBind], [CoreExpr])
    
    1122
    --- See Note [prepareSpecLHS]
    
    1123
    -prepareSpecLHS poly_id evs the_call
    
    1124
    -  = go (mkVarSet evs) [] the_call
    
    1119
    +decomposeCall :: Id -> CoreExpr
    
    1120
    +               -> Maybe ( [CoreBind]    -- Reversed bindings
    
    1121
    +                        , [CoreExpr] )  -- Args of the call
    
    1122
    +decomposeCall poly_id binds
    
    1123
    +  = go [] binds
    
    1124
    +  where
    
    1125
    +    go acc (Let bind body)
    
    1126
    +      = go (bind:acc) body
    
    1127
    +    go add e
    
    1128
    +      | Just (Var fun, args) <- collectArgs e
    
    1129
    +      = assertPpr (fun == poly_id) (ppr fun $$ ppr poly_id) $
    
    1130
    +        Just (acc, args)
    
    1131
    +      | otherwise
    
    1132
    +      = Nothing
    
    1133
    +
    
    1134
    +
    
    1135
    +grabSpecBinds :: VarSet -> VarSet -> [CoreBind] -> [CoreBind]
    
    1136
    +grabSpecBinds orig_bndrs rule_bndrs rev_binds
    
    1137
    +   = rename_binds ++ spec_binds
    
    1138
    +  where
    
    1139
    +    (known_bndrs, rename_binds, other_binds)
    
    1140
    +        = get_renamings rule_bndrs ([],[]) rev_binds
    
    1141
    +    spec_binds = pick_spec_binds known_bndrs other_binds
    
    1142
    +
    
    1143
    +    ------------------------
    
    1144
    +    get_renamings :: VarSet  -- Variables bound by a successful match on the call
    
    1145
    +                  -> ([CoreBind],[CoreBind])   -- Accumulating parameter, in order
    
    1146
    +                  -> [CoreBind]     -- Reversed, innermost first
    
    1147
    +                  -> ( VarSet
    
    1148
    +                     , [CoreBind]   -- Renamings, in order
    
    1149
    +                     , [CoreBind])  -- Other bindings, in order
    
    1150
    +    get_renamings _ acc [] acc
    
    1151
    +
    
    1152
    +    get_renamings bndrs (rn_binds, other_binds) (bind : binds)
    
    1153
    +      | NonRec d r <- bind
    
    1154
    +      , d `elemVarSet` bndrs
    
    1155
    +      , Just (v, mco) <- getCastedVar r
    
    1156
    +      , let flipped_bind = NonRec v (mkCastMCo (Var d) (mkSymMCo mco))
    
    1157
    +      = get_renamings (bndrs `extendVarSet` v)
    
    1158
    +                      (flipped_bind:rn_binds, other_binds)
    
    1159
    +                      binds
    
    1160
    +      | otherwise
    
    1161
    +      = get_renamings bndrs (rn_binds, bind:other_binds) binds
    
    1162
    +
    
    1163
    +    ------------------------
    
    1164
    +    pick_spec_binds :: VarSet -> [CoreBind] -> [CoreBind]
    
    1165
    +    pick_spec_binds known_bndrs [] = []
    
    1166
    +    pick_spec_binds known_bndrs (bind:binds)
    
    1167
    +      | all keep_me (rhssOfBind bind)
    
    1168
    +      , let known_bndrs' = known_bndrs `extendVarSetList` bindersOfBind bind
    
    1169
    +      = bind : pick_spec_binds known_bndrs' binds
    
    1170
    +      | otherwise
    
    1171
    +      = pick_spec_binds known_bndrs binds
    
    1172
    +      where
    
    1173
    +        keep_me rhs = isEmptyVarSet (exprSomFreeVars bad_var rhs)
    
    1174
    +        bad_var v = v `elemVarSet` orig_bndrs && not (bndr `elemVarSet` known_bndrs)
    
    1175
    +
    
    1176
    +{-
    
    1125 1177
       where
    
    1126 1178
         go :: VarSet        -- Quantified variables, or dependencies thereof
    
    1127 1179
            -> [CoreBind]    -- Reversed list of constant evidence bindings
    
    ... ... @@ -1133,7 +1185,7 @@ prepareSpecLHS poly_id evs the_call
    1133 1185
           | not (all (isPredTy . varType) bndrs)
    
    1134 1186
             -- A normal 'let' is too complicated
    
    1135 1187
             -- But we definitely include quantified constraints
    
    1136
    -        -- E.g. this is fine:  let (d :: forall a. Eq a => Eq (f a) = d2
    
    1188
    +        -- E.g. this is fine:  let (d :: forall a. Eq a => Eq (f a) = d2)
    
    1137 1189
           = Nothing
    
    1138 1190
     
    
    1139 1191
           -- (a) (1) in Note [prepareSpecLHS]
    
    ... ... @@ -1156,10 +1208,10 @@ prepareSpecLHS poly_id evs the_call
    1156 1208
           = Nothing
    
    1157 1209
     
    
    1158 1210
         transfer_to_spec_rhs qevs rhs
    
    1159
    -      = isEmptyVarSet $ exprSomeFreeVars is_quant_id rhs
    
    1160 1211
           where
    
    1161 1212
             is_quant_id v = isId v && v `elemVarSet` qevs
    
    1162 1213
           -- See (a) (2) in Note [prepareSpecLHS]
    
    1214
    +-}
    
    1163 1215
     
    
    1164 1216
     finishSpecPrag :: Name -> CoreExpr                    -- RHS to specialise
    
    1165 1217
                    -> [Var] -> Id -> [CoreExpr]           -- RULE LHS pattern