| ... |
... |
@@ -804,20 +804,22 @@ spec_imports :: SpecEnv -- Passed in so that all top-level Ids are in s |
|
804
|
804
|
, [CoreBind] ) -- Specialised bindings
|
|
805
|
805
|
spec_imports env callers dict_binds calls
|
|
806
|
806
|
= do { let import_calls = dVarEnvElts calls
|
|
807
|
|
--- ; debugTraceMsg (text "specImports {" <+>
|
|
808
|
|
--- vcat [ text "calls:" <+> ppr import_calls
|
|
809
|
|
--- , text "dict_binds:" <+> ppr dict_binds ])
|
|
|
807
|
+ ; debugTraceMsg (text "specImports {" <+>
|
|
|
808
|
+ vcat [ text "calls:" <+> ppr import_calls
|
|
|
809
|
+ , text "dict_binds:" <+> ppr dict_binds ])
|
|
810
|
810
|
; (env, rules, spec_binds) <- go env import_calls
|
|
811
|
|
--- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls)
|
|
|
811
|
+ ; debugTraceMsg (text "End specImports }" <+> ppr import_calls)
|
|
812
|
812
|
|
|
813
|
813
|
; return (env, rules, spec_binds) }
|
|
814
|
814
|
where
|
|
815
|
815
|
go :: SpecEnv -> [CallInfoSet] -> CoreM (SpecEnv, [CoreRule], [CoreBind])
|
|
816
|
816
|
go env [] = return (env, [], [])
|
|
817
|
817
|
go env (cis : other_calls)
|
|
818
|
|
- = do { -- debugTraceMsg (text "specImport {" <+> ppr cis)
|
|
|
818
|
+ = do { debugTraceMsg (text "specImport {" <+> vcat [ ppr cis
|
|
|
819
|
+ , text "callers" <+> ppr callers
|
|
|
820
|
+ , text "dict_binds" <+> ppr dict_binds ])
|
|
819
|
821
|
; (env, rules1, spec_binds1) <- spec_import env callers dict_binds cis
|
|
820
|
|
- ; -- debugTraceMsg (text "specImport }" <+> ppr cis)
|
|
|
822
|
+ ; debugTraceMsg (text "specImport }" <+> ppr cis)
|
|
821
|
823
|
|
|
822
|
824
|
; (env, rules2, spec_binds2) <- go env other_calls
|
|
823
|
825
|
; return (env, rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
|
| ... |
... |
@@ -834,13 +836,16 @@ spec_import :: SpecEnv -- Passed in so that all top-level Ids are |
|
834
|
836
|
, [CoreBind] ) -- Specialised bindings
|
|
835
|
837
|
spec_import env callers dict_binds cis@(CIS fn _)
|
|
836
|
838
|
| isIn "specImport" fn callers
|
|
837
|
|
- = return (env, [], []) -- No warning. This actually happens all the time
|
|
838
|
|
- -- when specialising a recursive function, because
|
|
839
|
|
- -- the RHS of the specialised function contains a recursive
|
|
840
|
|
- -- call to the original function
|
|
|
839
|
+ = do { debugTraceMsg (text "specImport1-bad" <+> (ppr fn $$ text "callers" <+> ppr callers))
|
|
|
840
|
+ ; return (env, [], []) }
|
|
|
841
|
+ -- No warning. This actually happens all the time
|
|
|
842
|
+ -- when specialising a recursive function, because
|
|
|
843
|
+ -- the RHS of the specialised function contains a recursive
|
|
|
844
|
+ -- call to the original function
|
|
841
|
845
|
|
|
842
|
846
|
| null good_calls
|
|
843
|
|
- = return (env, [], [])
|
|
|
847
|
+ = do { debugTraceMsg (text "specImport1-no-good" <+> (ppr cis $$ text "dict_binds" <+> ppr dict_binds))
|
|
|
848
|
+ ; return (env, [], []) }
|
|
844
|
849
|
|
|
845
|
850
|
| Just rhs <- canSpecImport dflags fn
|
|
846
|
851
|
= do { -- Get rules from the external package state
|
| ... |
... |
@@ -849,12 +854,12 @@ spec_import env callers dict_binds cis@(CIS fn _) |
|
849
|
854
|
; eps_rules <- getExternalRuleBase
|
|
850
|
855
|
; let rule_env = se_rules env `updExternalPackageRules` eps_rules
|
|
851
|
856
|
|
|
852
|
|
--- ; debugTraceMsg (text "specImport1" <+> vcat
|
|
853
|
|
--- [ text "function:" <+> ppr fn
|
|
854
|
|
--- , text "good calls:" <+> ppr good_calls
|
|
855
|
|
--- , text "existing rules:" <+> ppr (getRules rule_env fn)
|
|
856
|
|
--- , text "rhs:" <+> ppr rhs
|
|
857
|
|
--- , text "dict_binds:" <+> ppr dict_binds ])
|
|
|
857
|
+ ; debugTraceMsg (text "specImport1" <+> vcat
|
|
|
858
|
+ [ text "function:" <+> ppr fn
|
|
|
859
|
+ , text "good calls:" <+> ppr good_calls
|
|
|
860
|
+ , text "existing rules:" <+> ppr (getRules rule_env fn)
|
|
|
861
|
+ , text "rhs:" <+> ppr rhs
|
|
|
862
|
+ , text "dict_binds:" <+> ppr dict_binds ])
|
|
858
|
863
|
|
|
859
|
864
|
; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })
|
|
860
|
865
|
<- runSpecM $ specCalls True env (getRules rule_env fn) good_calls fn rhs
|
| ... |
... |
@@ -889,7 +894,9 @@ spec_import env callers dict_binds cis@(CIS fn _) |
|
889
|
894
|
; return (env, rules2 ++ rules1, final_binds) }
|
|
890
|
895
|
|
|
891
|
896
|
| otherwise
|
|
892
|
|
- = do { tryWarnMissingSpecs dflags callers fn good_calls
|
|
|
897
|
+ = do { debugTraceMsg (hang (text "specImport1-missed")
|
|
|
898
|
+ 2 (vcat [ppr cis, text "can-spec" <+> ppr (canSpecImport dflags fn)]))
|
|
|
899
|
+ ; tryWarnMissingSpecs dflags callers fn good_calls
|
|
893
|
900
|
; return (env, [], [])}
|
|
894
|
901
|
|
|
895
|
902
|
where
|
| ... |
... |
@@ -1698,15 +1705,15 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
|
1698
|
1705
|
-- , text "useful: " <+> ppr useful
|
|
1699
|
1706
|
-- , text "already_covered:" <+> ppr already_covered
|
|
1700
|
1707
|
-- , text "useful: " <+> ppr useful
|
|
1701
|
|
--- , text "all_rule_bndrs:" <+> ppr all_rule_bndrs
|
|
|
1708
|
+-- , text "all_rule_bndrs:" <+> ppr (sep (map (pprBndr LambdaBind) all_rule_bndrs))
|
|
1702
|
1709
|
-- , text "rule_lhs_args:" <+> ppr rule_lhs_args
|
|
1703
|
|
--- , text "spec_bndrs:" <+> ppr spec_bndrs
|
|
|
1710
|
+-- , text "spec_bndrs:" <+> ppr (sep (map (pprBndr LambdaBind) spec_bndrs))
|
|
1704
|
1711
|
-- , text "dx_binds:" <+> ppr dx_binds
|
|
1705
|
1712
|
-- , text "spec_args: " <+> ppr spec_args
|
|
1706
|
|
--- , text "rhs_bndrs" <+> ppr rhs_bndrs
|
|
|
1713
|
+-- , text "rhs_bndrs" <+> ppr (sep (map (pprBndr LambdaBind) rhs_bndrs))
|
|
1707
|
1714
|
-- , text "rhs_body" <+> ppr rhs_body
|
|
1708
|
|
--- , text "subst''" <+> ppr subst'' ]) $
|
|
1709
|
|
--- return ()
|
|
|
1715
|
+-- , text "subst''" <+> ppr subst''
|
|
|
1716
|
+-- ]) $ return ()
|
|
1710
|
1717
|
|
|
1711
|
1718
|
|
|
1712
|
1719
|
; if not useful -- No useful specialisation
|