| ... |
... |
@@ -804,23 +804,24 @@ 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)
|
|
812
|
|
-
|
|
|
811
|
+-- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls)
|
|
|
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 {" <+> vcat [ ppr cis
|
|
819
|
|
- , text "callers" <+> ppr callers
|
|
820
|
|
- , text "dict_binds" <+> ppr dict_binds ])
|
|
|
818
|
+ = do {
|
|
|
819
|
+-- debugTraceMsg (text "specImport {" <+> vcat [ ppr cis
|
|
|
820
|
+-- , text "callers" <+> ppr callers
|
|
|
821
|
+-- , text "dict_binds" <+> ppr dict_binds ])
|
|
821
|
822
|
; (env, rules1, spec_binds1) <- spec_import env callers dict_binds cis
|
|
822
|
|
- ; debugTraceMsg (text "specImport }" <+> ppr cis)
|
|
823
|
|
-
|
|
|
823
|
+-- ; debugTraceMsg (text "specImport }" <+> ppr cis)
|
|
|
824
|
+--
|
|
824
|
825
|
; (env, rules2, spec_binds2) <- go env other_calls
|
|
825
|
826
|
; return (env, rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
|
|
826
|
827
|
|
| ... |
... |
@@ -836,7 +837,7 @@ spec_import :: SpecEnv -- Passed in so that all top-level Ids are |
|
836
|
837
|
, [CoreBind] ) -- Specialised bindings
|
|
837
|
838
|
spec_import env callers dict_binds cis@(CIS fn _)
|
|
838
|
839
|
| isIn "specImport" fn callers
|
|
839
|
|
- = do { debugTraceMsg (text "specImport1-bad" <+> (ppr fn $$ text "callers" <+> ppr callers))
|
|
|
840
|
+ = do { -- debugTraceMsg (text "specImport1-bad" <+> (ppr fn $$ text "callers" <+> ppr callers))
|
|
840
|
841
|
; return (env, [], []) }
|
|
841
|
842
|
-- No warning. This actually happens all the time
|
|
842
|
843
|
-- when specialising a recursive function, because
|
| ... |
... |
@@ -844,7 +845,7 @@ spec_import env callers dict_binds cis@(CIS fn _) |
|
844
|
845
|
-- call to the original function
|
|
845
|
846
|
|
|
846
|
847
|
| null good_calls
|
|
847
|
|
- = do { debugTraceMsg (text "specImport1-no-good" <+> (ppr cis $$ text "dict_binds" <+> ppr dict_binds))
|
|
|
848
|
+ = do { -- debugTraceMsg (text "specImport1-no-good" <+> (ppr cis $$ text "dict_binds" <+> ppr dict_binds))
|
|
848
|
849
|
; return (env, [], []) }
|
|
849
|
850
|
|
|
850
|
851
|
| Just rhs <- canSpecImport dflags fn
|
| ... |
... |
@@ -854,12 +855,12 @@ spec_import env callers dict_binds cis@(CIS fn _) |
|
854
|
855
|
; eps_rules <- getExternalRuleBase
|
|
855
|
856
|
; let rule_env = se_rules env `updExternalPackageRules` eps_rules
|
|
856
|
857
|
|
|
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
|
+-- ; debugTraceMsg (text "specImport1" <+> vcat
|
|
|
859
|
+-- [ text "function:" <+> ppr fn
|
|
|
860
|
+-- , text "good calls:" <+> ppr good_calls
|
|
|
861
|
+-- , text "existing rules:" <+> ppr (getRules rule_env fn)
|
|
|
862
|
+-- , text "rhs:" <+> ppr rhs
|
|
|
863
|
+-- , text "dict_binds:" <+> ppr dict_binds ])
|
|
863
|
864
|
|
|
864
|
865
|
; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })
|
|
865
|
866
|
<- runSpecM $ specCalls True env (getRules rule_env fn) good_calls fn rhs
|
| ... |
... |
@@ -894,8 +895,9 @@ spec_import env callers dict_binds cis@(CIS fn _) |
|
894
|
895
|
; return (env, rules2 ++ rules1, final_binds) }
|
|
895
|
896
|
|
|
896
|
897
|
| otherwise
|
|
897
|
|
- = do { debugTraceMsg (hang (text "specImport1-missed")
|
|
898
|
|
- 2 (vcat [ppr cis, text "can-spec" <+> ppr (canSpecImport dflags fn)]))
|
|
|
898
|
+ = do {
|
|
|
899
|
+-- debugTraceMsg (hang (text "specImport1-missed")
|
|
|
900
|
+-- 2 (vcat [ppr cis, text "can-spec" <+> ppr (canSpecImport dflags fn)]))
|
|
899
|
901
|
; tryWarnMissingSpecs dflags callers fn good_calls
|
|
900
|
902
|
; return (env, [], [])}
|
|
901
|
903
|
|