diff options
Diffstat (limited to 'testsuite/tests/perf')
49 files changed, 2962 insertions, 0 deletions
diff --git a/testsuite/tests/perf/Makefile b/testsuite/tests/perf/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/perf/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/perf/compiler/Makefile b/testsuite/tests/perf/compiler/Makefile new file mode 100644 index 0000000000..7d8e96fd44 --- /dev/null +++ b/testsuite/tests/perf/compiler/Makefile @@ -0,0 +1,9 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +.PHONY: T4007 +T4007: + $(RM) -f T4007.hi T4007.o + '$(TEST_HC)' $(TEST_HC_OPTS) -c -O -ddump-rule-firings T4007.hs + diff --git a/testsuite/tests/perf/compiler/T1969.hs b/testsuite/tests/perf/compiler/T1969.hs new file mode 100644 index 0000000000..05045cccba --- /dev/null +++ b/testsuite/tests/perf/compiler/T1969.hs @@ -0,0 +1,1210 @@ + +module T1969 where + +class C a where + c :: a -> String + d :: a -> String + d x = c x + e :: a -> String + e x = c x + +data A1 = A1 +instance C A1 where + c A1 = "A1" + +data A2 = A2 +instance C A2 where + c A2 = "A2" + +data A3 = A3 +instance C A3 where + c A3 = "A3" + +data A4 = A4 +instance C A4 where + c A4 = "A4" + +data A5 = A5 +instance C A5 where + c A5 = "A5" + +data A6 = A6 +instance C A6 where + c A6 = "A6" + +data A7 = A7 +instance C A7 where + c A7 = "A7" + +data A8 = A8 +instance C A8 where + c A8 = "A8" + +data A9 = A9 +instance C A9 where + c A9 = "A9" + +data A10 = A10 +instance C A10 where + c A10 = "A10" + +data A11 = A11 +instance C A11 where + c A11 = "A11" + +data A12 = A12 +instance C A12 where + c A12 = "A12" + +data A13 = A13 +instance C A13 where + c A13 = "A13" + +data A14 = A14 +instance C A14 where + c A14 = "A14" + +data A15 = A15 +instance C A15 where + c A15 = "A15" + +data A16 = A16 +instance C A16 where + c A16 = "A16" + +data A17 = A17 +instance C A17 where + c A17 = "A17" + +data A18 = A18 +instance C A18 where + c A18 = "A18" + +data A19 = A19 +instance C A19 where + c A19 = "A19" + +data A20 = A20 +instance C A20 where + c A20 = "A20" + +data A21 = A21 +instance C A21 where + c A21 = "A21" + +data A22 = A22 +instance C A22 where + c A22 = "A22" + +data A23 = A23 +instance C A23 where + c A23 = "A23" + +data A24 = A24 +instance C A24 where + c A24 = "A24" + +data A25 = A25 +instance C A25 where + c A25 = "A25" + +data A26 = A26 +instance C A26 where + c A26 = "A26" + +data A27 = A27 +instance C A27 where + c A27 = "A27" + +data A28 = A28 +instance C A28 where + c A28 = "A28" + +data A29 = A29 +instance C A29 where + c A29 = "A29" + +data A30 = A30 +instance C A30 where + c A30 = "A30" + +data A31 = A31 +instance C A31 where + c A31 = "A31" + +data A32 = A32 +instance C A32 where + c A32 = "A32" + +data A33 = A33 +instance C A33 where + c A33 = "A33" + +data A34 = A34 +instance C A34 where + c A34 = "A34" + +data A35 = A35 +instance C A35 where + c A35 = "A35" + +data A36 = A36 +instance C A36 where + c A36 = "A36" + +data A37 = A37 +instance C A37 where + c A37 = "A37" + +data A38 = A38 +instance C A38 where + c A38 = "A38" + +data A39 = A39 +instance C A39 where + c A39 = "A39" + +data A40 = A40 +instance C A40 where + c A40 = "A40" + +data A41 = A41 +instance C A41 where + c A41 = "A41" + +data A42 = A42 +instance C A42 where + c A42 = "A42" + +data A43 = A43 +instance C A43 where + c A43 = "A43" + +data A44 = A44 +instance C A44 where + c A44 = "A44" + +data A45 = A45 +instance C A45 where + c A45 = "A45" + +data A46 = A46 +instance C A46 where + c A46 = "A46" + +data A47 = A47 +instance C A47 where + c A47 = "A47" + +data A48 = A48 +instance C A48 where + c A48 = "A48" + +data A49 = A49 +instance C A49 where + c A49 = "A49" + +data A50 = A50 +instance C A50 where + c A50 = "A50" + +data A51 = A51 +instance C A51 where + c A51 = "A51" + +data A52 = A52 +instance C A52 where + c A52 = "A52" + +data A53 = A53 +instance C A53 where + c A53 = "A53" + +data A54 = A54 +instance C A54 where + c A54 = "A54" + +data A55 = A55 +instance C A55 where + c A55 = "A55" + +data A56 = A56 +instance C A56 where + c A56 = "A56" + +data A57 = A57 +instance C A57 where + c A57 = "A57" + +data A58 = A58 +instance C A58 where + c A58 = "A58" + +data A59 = A59 +instance C A59 where + c A59 = "A59" + +data A60 = A60 +instance C A60 where + c A60 = "A60" + +data A61 = A61 +instance C A61 where + c A61 = "A61" + +data A62 = A62 +instance C A62 where + c A62 = "A62" + +data A63 = A63 +instance C A63 where + c A63 = "A63" + +data A64 = A64 +instance C A64 where + c A64 = "A64" + +data A65 = A65 +instance C A65 where + c A65 = "A65" + +data A66 = A66 +instance C A66 where + c A66 = "A66" + +data A67 = A67 +instance C A67 where + c A67 = "A67" + +data A68 = A68 +instance C A68 where + c A68 = "A68" + +data A69 = A69 +instance C A69 where + c A69 = "A69" + +data A70 = A70 +instance C A70 where + c A70 = "A70" + +data A71 = A71 +instance C A71 where + c A71 = "A71" + +data A72 = A72 +instance C A72 where + c A72 = "A72" + +data A73 = A73 +instance C A73 where + c A73 = "A73" + +data A74 = A74 +instance C A74 where + c A74 = "A74" + +data A75 = A75 +instance C A75 where + c A75 = "A75" + +data A76 = A76 +instance C A76 where + c A76 = "A76" + +data A77 = A77 +instance C A77 where + c A77 = "A77" + +data A78 = A78 +instance C A78 where + c A78 = "A78" + +data A79 = A79 +instance C A79 where + c A79 = "A79" + +data A80 = A80 +instance C A80 where + c A80 = "A80" + +data A81 = A81 +instance C A81 where + c A81 = "A81" + +data A82 = A82 +instance C A82 where + c A82 = "A82" + +data A83 = A83 +instance C A83 where + c A83 = "A83" + +data A84 = A84 +instance C A84 where + c A84 = "A84" + +data A85 = A85 +instance C A85 where + c A85 = "A85" + +data A86 = A86 +instance C A86 where + c A86 = "A86" + +data A87 = A87 +instance C A87 where + c A87 = "A87" + +data A88 = A88 +instance C A88 where + c A88 = "A88" + +data A89 = A89 +instance C A89 where + c A89 = "A89" + +data A90 = A90 +instance C A90 where + c A90 = "A90" + +data A91 = A91 +instance C A91 where + c A91 = "A91" + +data A92 = A92 +instance C A92 where + c A92 = "A92" + +data A93 = A93 +instance C A93 where + c A93 = "A93" + +data A94 = A94 +instance C A94 where + c A94 = "A94" + +data A95 = A95 +instance C A95 where + c A95 = "A95" + +data A96 = A96 +instance C A96 where + c A96 = "A96" + +data A97 = A97 +instance C A97 where + c A97 = "A97" + +data A98 = A98 +instance C A98 where + c A98 = "A98" + +data A99 = A99 +instance C A99 where + c A99 = "A99" + +data A100 = A100 +instance C A100 where + c A100 = "A100" + +data A101 = A101 +instance C A101 where + c A101 = "A101" + +data A102 = A102 +instance C A102 where + c A102 = "A102" + +data A103 = A103 +instance C A103 where + c A103 = "A103" + +data A104 = A104 +instance C A104 where + c A104 = "A104" + +data A105 = A105 +instance C A105 where + c A105 = "A105" + +data A106 = A106 +instance C A106 where + c A106 = "A106" + +data A107 = A107 +instance C A107 where + c A107 = "A107" + +data A108 = A108 +instance C A108 where + c A108 = "A108" + +data A109 = A109 +instance C A109 where + c A109 = "A109" + +data A110 = A110 +instance C A110 where + c A110 = "A110" + +data A111 = A111 +instance C A111 where + c A111 = "A111" + +data A112 = A112 +instance C A112 where + c A112 = "A112" + +data A113 = A113 +instance C A113 where + c A113 = "A113" + +data A114 = A114 +instance C A114 where + c A114 = "A114" + +data A115 = A115 +instance C A115 where + c A115 = "A115" + +data A116 = A116 +instance C A116 where + c A116 = "A116" + +data A117 = A117 +instance C A117 where + c A117 = "A117" + +data A118 = A118 +instance C A118 where + c A118 = "A118" + +data A119 = A119 +instance C A119 where + c A119 = "A119" + +data A120 = A120 +instance C A120 where + c A120 = "A120" + +data A121 = A121 +instance C A121 where + c A121 = "A121" + +data A122 = A122 +instance C A122 where + c A122 = "A122" + +data A123 = A123 +instance C A123 where + c A123 = "A123" + +data A124 = A124 +instance C A124 where + c A124 = "A124" + +data A125 = A125 +instance C A125 where + c A125 = "A125" + +data A126 = A126 +instance C A126 where + c A126 = "A126" + +data A127 = A127 +instance C A127 where + c A127 = "A127" + +data A128 = A128 +instance C A128 where + c A128 = "A128" + +data A129 = A129 +instance C A129 where + c A129 = "A129" + +data A130 = A130 +instance C A130 where + c A130 = "A130" + +data A131 = A131 +instance C A131 where + c A131 = "A131" + +data A132 = A132 +instance C A132 where + c A132 = "A132" + +data A133 = A133 +instance C A133 where + c A133 = "A133" + +data A134 = A134 +instance C A134 where + c A134 = "A134" + +data A135 = A135 +instance C A135 where + c A135 = "A135" + +data A136 = A136 +instance C A136 where + c A136 = "A136" + +data A137 = A137 +instance C A137 where + c A137 = "A137" + +data A138 = A138 +instance C A138 where + c A138 = "A138" + +data A139 = A139 +instance C A139 where + c A139 = "A139" + +data A140 = A140 +instance C A140 where + c A140 = "A140" + +data A141 = A141 +instance C A141 where + c A141 = "A141" + +data A142 = A142 +instance C A142 where + c A142 = "A142" + +data A143 = A143 +instance C A143 where + c A143 = "A143" + +data A144 = A144 +instance C A144 where + c A144 = "A144" + +data A145 = A145 +instance C A145 where + c A145 = "A145" + +data A146 = A146 +instance C A146 where + c A146 = "A146" + +data A147 = A147 +instance C A147 where + c A147 = "A147" + +data A148 = A148 +instance C A148 where + c A148 = "A148" + +data A149 = A149 +instance C A149 where + c A149 = "A149" + +data A150 = A150 +instance C A150 where + c A150 = "A150" + +data A151 = A151 +instance C A151 where + c A151 = "A151" + +data A152 = A152 +instance C A152 where + c A152 = "A152" + +data A153 = A153 +instance C A153 where + c A153 = "A153" + +data A154 = A154 +instance C A154 where + c A154 = "A154" + +data A155 = A155 +instance C A155 where + c A155 = "A155" + +data A156 = A156 +instance C A156 where + c A156 = "A156" + +data A157 = A157 +instance C A157 where + c A157 = "A157" + +data A158 = A158 +instance C A158 where + c A158 = "A158" + +data A159 = A159 +instance C A159 where + c A159 = "A159" + +data A160 = A160 +instance C A160 where + c A160 = "A160" + +data A161 = A161 +instance C A161 where + c A161 = "A161" + +data A162 = A162 +instance C A162 where + c A162 = "A162" + +data A163 = A163 +instance C A163 where + c A163 = "A163" + +data A164 = A164 +instance C A164 where + c A164 = "A164" + +data A165 = A165 +instance C A165 where + c A165 = "A165" + +data A166 = A166 +instance C A166 where + c A166 = "A166" + +data A167 = A167 +instance C A167 where + c A167 = "A167" + +data A168 = A168 +instance C A168 where + c A168 = "A168" + +data A169 = A169 +instance C A169 where + c A169 = "A169" + +data A170 = A170 +instance C A170 where + c A170 = "A170" + +data A171 = A171 +instance C A171 where + c A171 = "A171" + +data A172 = A172 +instance C A172 where + c A172 = "A172" + +data A173 = A173 +instance C A173 where + c A173 = "A173" + +data A174 = A174 +instance C A174 where + c A174 = "A174" + +data A175 = A175 +instance C A175 where + c A175 = "A175" + +data A176 = A176 +instance C A176 where + c A176 = "A176" + +data A177 = A177 +instance C A177 where + c A177 = "A177" + +data A178 = A178 +instance C A178 where + c A178 = "A178" + +data A179 = A179 +instance C A179 where + c A179 = "A179" + +data A180 = A180 +instance C A180 where + c A180 = "A180" + +data A181 = A181 +instance C A181 where + c A181 = "A181" + +data A182 = A182 +instance C A182 where + c A182 = "A182" + +data A183 = A183 +instance C A183 where + c A183 = "A183" + +data A184 = A184 +instance C A184 where + c A184 = "A184" + +data A185 = A185 +instance C A185 where + c A185 = "A185" + +data A186 = A186 +instance C A186 where + c A186 = "A186" + +data A187 = A187 +instance C A187 where + c A187 = "A187" + +data A188 = A188 +instance C A188 where + c A188 = "A188" + +data A189 = A189 +instance C A189 where + c A189 = "A189" + +data A190 = A190 +instance C A190 where + c A190 = "A190" + +data A191 = A191 +instance C A191 where + c A191 = "A191" + +data A192 = A192 +instance C A192 where + c A192 = "A192" + +data A193 = A193 +instance C A193 where + c A193 = "A193" + +data A194 = A194 +instance C A194 where + c A194 = "A194" + +data A195 = A195 +instance C A195 where + c A195 = "A195" + +data A196 = A196 +instance C A196 where + c A196 = "A196" + +data A197 = A197 +instance C A197 where + c A197 = "A197" + +data A198 = A198 +instance C A198 where + c A198 = "A198" + +data A199 = A199 +instance C A199 where + c A199 = "A199" + +data A200 = A200 +instance C A200 where + c A200 = "A200" + +data A201 = A201 +instance C A201 where + c A201 = "A201" + +data A202 = A202 +instance C A202 where + c A202 = "A202" + +data A203 = A203 +instance C A203 where + c A203 = "A203" + +data A204 = A204 +instance C A204 where + c A204 = "A204" + +data A205 = A205 +instance C A205 where + c A205 = "A205" + +data A206 = A206 +instance C A206 where + c A206 = "A206" + +data A207 = A207 +instance C A207 where + c A207 = "A207" + +data A208 = A208 +instance C A208 where + c A208 = "A208" + +data A209 = A209 +instance C A209 where + c A209 = "A209" + +data A210 = A210 +instance C A210 where + c A210 = "A210" + +data A211 = A211 +instance C A211 where + c A211 = "A211" + +data A212 = A212 +instance C A212 where + c A212 = "A212" + +data A213 = A213 +instance C A213 where + c A213 = "A213" + +data A214 = A214 +instance C A214 where + c A214 = "A214" + +data A215 = A215 +instance C A215 where + c A215 = "A215" + +data A216 = A216 +instance C A216 where + c A216 = "A216" + +data A217 = A217 +instance C A217 where + c A217 = "A217" + +data A218 = A218 +instance C A218 where + c A218 = "A218" + +data A219 = A219 +instance C A219 where + c A219 = "A219" + +data A220 = A220 +instance C A220 where + c A220 = "A220" + +data A221 = A221 +instance C A221 where + c A221 = "A221" + +data A222 = A222 +instance C A222 where + c A222 = "A222" + +data A223 = A223 +instance C A223 where + c A223 = "A223" + +data A224 = A224 +instance C A224 where + c A224 = "A224" + +data A225 = A225 +instance C A225 where + c A225 = "A225" + +data A226 = A226 +instance C A226 where + c A226 = "A226" + +data A227 = A227 +instance C A227 where + c A227 = "A227" + +data A228 = A228 +instance C A228 where + c A228 = "A228" + +data A229 = A229 +instance C A229 where + c A229 = "A229" + +data A230 = A230 +instance C A230 where + c A230 = "A230" + +data A231 = A231 +instance C A231 where + c A231 = "A231" + +data A232 = A232 +instance C A232 where + c A232 = "A232" + +data A233 = A233 +instance C A233 where + c A233 = "A233" + +data A234 = A234 +instance C A234 where + c A234 = "A234" + +data A235 = A235 +instance C A235 where + c A235 = "A235" + +data A236 = A236 +instance C A236 where + c A236 = "A236" + +data A237 = A237 +instance C A237 where + c A237 = "A237" + +data A238 = A238 +instance C A238 where + c A238 = "A238" + +data A239 = A239 +instance C A239 where + c A239 = "A239" + +data A240 = A240 +instance C A240 where + c A240 = "A240" + +data A241 = A241 +instance C A241 where + c A241 = "A241" + +data A242 = A242 +instance C A242 where + c A242 = "A242" + +data A243 = A243 +instance C A243 where + c A243 = "A243" + +data A244 = A244 +instance C A244 where + c A244 = "A244" + +data A245 = A245 +instance C A245 where + c A245 = "A245" + +data A246 = A246 +instance C A246 where + c A246 = "A246" + +data A247 = A247 +instance C A247 where + c A247 = "A247" + +data A248 = A248 +instance C A248 where + c A248 = "A248" + +data A249 = A249 +instance C A249 where + c A249 = "A249" + +data A250 = A250 +instance C A250 where + c A250 = "A250" + +data A251 = A251 +instance C A251 where + c A251 = "A251" + +data A252 = A252 +instance C A252 where + c A252 = "A252" + +data A253 = A253 +instance C A253 where + c A253 = "A253" + +data A254 = A254 +instance C A254 where + c A254 = "A254" + +data A255 = A255 +instance C A255 where + c A255 = "A255" + +data A256 = A256 +instance C A256 where + c A256 = "A256" + +data A257 = A257 +instance C A257 where + c A257 = "A257" + +data A258 = A258 +instance C A258 where + c A258 = "A258" + +data A259 = A259 +instance C A259 where + c A259 = "A259" + +data A260 = A260 +instance C A260 where + c A260 = "A260" + +data A261 = A261 +instance C A261 where + c A261 = "A261" + +data A262 = A262 +instance C A262 where + c A262 = "A262" + +data A263 = A263 +instance C A263 where + c A263 = "A263" + +data A264 = A264 +instance C A264 where + c A264 = "A264" + +data A265 = A265 +instance C A265 where + c A265 = "A265" + +data A266 = A266 +instance C A266 where + c A266 = "A266" + +data A267 = A267 +instance C A267 where + c A267 = "A267" + +data A268 = A268 +instance C A268 where + c A268 = "A268" + +data A269 = A269 +instance C A269 where + c A269 = "A269" + +data A270 = A270 +instance C A270 where + c A270 = "A270" + +data A271 = A271 +instance C A271 where + c A271 = "A271" + +data A272 = A272 +instance C A272 where + c A272 = "A272" + +data A273 = A273 +instance C A273 where + c A273 = "A273" + +data A274 = A274 +instance C A274 where + c A274 = "A274" + +data A275 = A275 +instance C A275 where + c A275 = "A275" + +data A276 = A276 +instance C A276 where + c A276 = "A276" + +data A277 = A277 +instance C A277 where + c A277 = "A277" + +data A278 = A278 +instance C A278 where + c A278 = "A278" + +data A279 = A279 +instance C A279 where + c A279 = "A279" + +data A280 = A280 +instance C A280 where + c A280 = "A280" + +data A281 = A281 +instance C A281 where + c A281 = "A281" + +data A282 = A282 +instance C A282 where + c A282 = "A282" + +data A283 = A283 +instance C A283 where + c A283 = "A283" + +data A284 = A284 +instance C A284 where + c A284 = "A284" + +data A285 = A285 +instance C A285 where + c A285 = "A285" + +data A286 = A286 +instance C A286 where + c A286 = "A286" + +data A287 = A287 +instance C A287 where + c A287 = "A287" + +data A288 = A288 +instance C A288 where + c A288 = "A288" + +data A289 = A289 +instance C A289 where + c A289 = "A289" + +data A290 = A290 +instance C A290 where + c A290 = "A290" + +data A291 = A291 +instance C A291 where + c A291 = "A291" + +data A292 = A292 +instance C A292 where + c A292 = "A292" + +data A293 = A293 +instance C A293 where + c A293 = "A293" + +data A294 = A294 +instance C A294 where + c A294 = "A294" + +data A295 = A295 +instance C A295 where + c A295 = "A295" + +data A296 = A296 +instance C A296 where + c A296 = "A296" + +data A297 = A297 +instance C A297 where + c A297 = "A297" + +data A298 = A298 +instance C A298 where + c A298 = "A298" + +data A299 = A299 +instance C A299 where + c A299 = "A299" + +data A300 = A300 +instance C A300 where + c A300 = "A300" + diff --git a/testsuite/tests/perf/compiler/T3064.hs b/testsuite/tests/perf/compiler/T3064.hs new file mode 100644 index 0000000000..328da45976 --- /dev/null +++ b/testsuite/tests/perf/compiler/T3064.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE Rank2Types, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-} +module Bug2 where + +newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a } + +instance (Monad m) => Monad (ReaderT r m) where + return a = ReaderT $ \_ -> return a + m >>= k = ReaderT $ \r -> do + a <- runReaderT m r + runReaderT (k a) r + fail msg = ReaderT $ \_ -> fail msg + +newtype ResourceT r s m v = ResourceT { unResourceT :: ReaderT r m v } + deriving (Monad) + +data Ctx = Ctx + +data Ch = Ch + +type CAT s c = ResourceT [Ch] (s,c) + +type CtxM c = ResourceT Ctx c IO + +newtype CA s c v = CA { unCA :: CAT s c (CtxM c) v } + deriving (Monad) + +class (Monad m) => MonadCA m where + type CtxLabel m + +instance MonadCA (CA s c) where + type CtxLabel (CA s c) = c + +instance (Monad m, MonadCA m, c ~ CtxLabel m) => MonadCA (CAT s c m) where + type CtxLabel (CAT s c m) = c + +runCAT :: (forall s. CAT s c m v) -> m v +runCAT action = runReaderT (unResourceT action) [] + +newRgn :: MonadCA m => (forall s. CAT s (CtxLabel m) m v) -> m v +newRgn = runCAT + +runCA :: (forall s c. CA s c v) -> IO v +runCA action = runCtxM (runCAT (unCA action)) + +runCtxM :: (forall c. CtxM c v) -> IO v +runCtxM action = runReaderT (unResourceT action) Ctx + +-- test11 :: IO () +-- test11 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn( +-- newRgn(newRgn(newRgn(newRgn(return())))))))))) + +-- test12 :: IO () +-- test12 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn( +-- newRgn(newRgn(newRgn(newRgn(return()))))))))))) + +-- test13 :: IO () +-- test13 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn( +-- newRgn(newRgn(newRgn(newRgn(return())))))))))))) + +test14 :: IO () +test14 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn( + newRgn(newRgn(newRgn(newRgn(return()))))))))))))) diff --git a/testsuite/tests/perf/compiler/T3294.hs b/testsuite/tests/perf/compiler/T3294.hs new file mode 100644 index 0000000000..25e4a2beba --- /dev/null +++ b/testsuite/tests/perf/compiler/T3294.hs @@ -0,0 +1,206 @@ +module Main where + +data X = X + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + deriving (Show) + +main = print $ X 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 diff --git a/testsuite/tests/perf/compiler/T4007.hs b/testsuite/tests/perf/compiler/T4007.hs new file mode 100644 index 0000000000..71a37841ed --- /dev/null +++ b/testsuite/tests/perf/compiler/T4007.hs @@ -0,0 +1,5 @@ + +module T4007 where + +f :: IO () +f = sequence_ (replicate 10 (putStrLn "yes")) diff --git a/testsuite/tests/perf/compiler/T4007.stderr b/testsuite/tests/perf/compiler/T4007.stderr new file mode 100644 index 0000000000..9b825fd518 --- /dev/null +++ b/testsuite/tests/perf/compiler/T4007.stderr @@ -0,0 +1,6 @@ +Rule fired: unpack +Rule fired: Class op >> +Rule fired: Class op return +Rule fired: <=# +Rule fired: fold/build +Rule fired: unpack-list diff --git a/testsuite/tests/perf/compiler/T4801.hs b/testsuite/tests/perf/compiler/T4801.hs new file mode 100644 index 0000000000..8bc02b2c77 --- /dev/null +++ b/testsuite/tests/perf/compiler/T4801.hs @@ -0,0 +1,13 @@ +-- main = print $ length [([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0)] + +-- 1.6G alloc +-- main = print $ length [([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0)] + +-- 6G alloc +-- main = print $ length [([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0)] + +-- 23G alloc +main = print $ length [([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0),([0,0,0],0)] + + + diff --git a/testsuite/tests/perf/compiler/T5030.hs b/testsuite/tests/perf/compiler/T5030.hs new file mode 100644 index 0000000000..b65e9cdd3c --- /dev/null +++ b/testsuite/tests/perf/compiler/T5030.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE TypeFamilies, GADTs, EmptyDataDecls, FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +module SlowComp where + +import Control.Monad + +------------------------------------------------------------------------------- +-- Usual Peano integers. + + +class NatInt a where + natInt :: a -> Int + +data D0 n = D0 {d0Arg :: n} +data D1 n = D1 {d1Arg :: n} + +data C0 +data C1 + +class DPosInt n where posInt :: n -> (Int,Int) +instance DPosInt () where posInt _ = (0,1) +instance DPosInt n => DPosInt (D0 n) where + posInt a = (dsum,w*2) + where + (dsum,w) = posInt $ d0Arg a +instance DPosInt n => DPosInt (D1 n) where + posInt a = (dsum+w,w*2) + where + (dsum,w) = posInt $ d1Arg a + +instance NatInt () where natInt _ = 0 +instance DPosInt n => NatInt (D0 n) where natInt a = fst $ posInt a +instance DPosInt n => NatInt (D1 n) where natInt a = fst $ posInt a + +type family DRev a +type instance DRev a = DRev' a () + +type family DRev' x acc +type instance DRev' () acc = acc +type instance DRev' (D0 a) acc = DRev' a (D0 acc) +type instance DRev' (D1 a) acc = DRev' a (D1 acc) + +type family DAddC c a b +type instance DAddC C0 (D0 a) (D0 b) = D0 (DAddC C0 a b) +type instance DAddC C0 (D1 a) (D0 b) = D1 (DAddC C0 a b) +type instance DAddC C0 (D0 a) (D1 b) = D1 (DAddC C0 a b) +type instance DAddC C0 (D1 a) (D1 b) = D0 (DAddC C1 a b) +type instance DAddC C1 (D0 a) (D0 b) = D1 (DAddC C0 a b) +type instance DAddC C1 (D1 a) (D0 b) = D0 (DAddC C1 a b) +type instance DAddC C1 (D0 a) (D1 b) = D0 (DAddC C1 a b) +type instance DAddC C1 (D1 a) (D1 b) = D1 (DAddC C1 a b) +type instance DAddC C0 () () = () +type instance DAddC C1 () () = D1 () +type instance DAddC c (D0 a) () = DAddC c (D0 a) (D0 ()) +type instance DAddC c (D1 a) () = DAddC c (D1 a) (D0 ()) +type instance DAddC c () (D0 b) = DAddC c (D0 b) (D0 ()) +type instance DAddC c () (D1 b) = DAddC c (D1 b) (D0 ()) + +type family DNorm a +type instance DNorm () = D0 () +type instance DNorm (D0 ()) = D0 () +type instance DNorm (D0 (D1 a)) = D1 a +type instance DNorm (D0 (D0 a)) = DNorm a +type instance DNorm (D1 a) = D1 a + +type family DPlus a b +type instance DPlus a b = DNorm (DRev (DAddC C0 (DRev a) (DRev b))) + +type family DDepth a +type instance DDepth () = D0 () +type instance DDepth (D0 ()) = D0 () +type instance DDepth (D1 ()) = D1 () +type instance DDepth (D1 (D0 n)) = DPlus ONE (DDepth (D1 n)) +type instance DDepth (D1 (D1 n)) = DPlus ONE (DDepth (D1 n)) + +type family DLog2 a +type instance DLog2 a = DDepth a + +type ZERO = D0 () + +type ONE = D1 () +type TWO = DPlus ONE ONE +type THREE = DPlus ONE TWO +type FOUR = DPlus TWO TWO +type FIVE = DPlus ONE FOUR +type SIX = DPlus TWO FOUR +type SEVEN = DPlus ONE SIX +type EIGHT = DPlus FOUR FOUR +type NINE = DPlus FOUR FIVE +type TEN = DPlus EIGHT TWO +type SIZE8 = EIGHT +type SIZE9 = NINE +type SIZE10 = TEN +type SIZE12 = DPlus SIX SIX +type SIZE15 = DPlus EIGHT SEVEN +type SIZE16 = DPlus EIGHT EIGHT +type SIZE17 = DPlus ONE SIZE16 +type SIZE24 = DPlus SIZE8 SIZE16 +type SIZE32 = DPlus SIZE8 SIZE24 +type SIZE30 = DPlus SIZE24 SIX + +------------------------------------------------------------------------------- +-- Description of CPU. + +class CPU cpu where + -- register address. + type RegAddrSize cpu + -- register width + type RegDataSize cpu + -- immediate width. + type ImmSize cpu + -- variables in CPU - register indices, command format variables, etc. + type CPUVars cpu :: * -> * + +data Const size = Const Integer + +data Var cpu size where + Temp :: Int -> Var cpu size + Var :: CPUVars cpu size -> Var cpu size + +------------------------------------------------------------------------------- +-- Command description monad. + +data Command cpu where + Command :: (Var cpu size) -> (Operation cpu size) -> Command cpu + +type RegVar cpu = Var cpu (RegDataSize cpu) +type Immediate cpu = Const (ImmSize cpu) + +data Operation cpu resultSize where + Add :: RegVar cpu -> Either (Immediate cpu) (RegVar cpu) -> Operation cpu (RegDataSize cpu) + Sub :: RegVar cpu -> Either (Immediate cpu) (RegVar cpu) -> Operation cpu (RegDataSize cpu) + +type CDM cpu a = IO a + +($=) :: CPU cpu => Var cpu size -> Operation cpu size -> CDM cpu () +var $= op = undefined + +tempVar :: CPU cpu => CDM cpu (Var cpu size) +tempVar = do + cnt <- liftM fst undefined + return $ Temp cnt + +op :: CPU cpu => Operation cpu size -> CDM cpu (Var cpu size) +op operation = do + v <- tempVar + v $= operation + return v + +------------------------------------------------------------------------------- +-- Dummy CPU. + +data DummyCPU = DummyCPU + +data DummyVar size where + DummyFlag :: Flag -> DummyVar ONE + DummyReg :: Int -> DummyVar SIZE16 + DummyZero :: DummyVar SIZE16 + +data Flag = C | Z | N | V + +instance CPU DummyCPU where + type RegAddrSize DummyCPU = FIVE + type RegDataSize DummyCPU = SIZE16 + type ImmSize DummyCPU = SIZE12 + type CPUVars DummyCPU = DummyVar + +------------------------------------------------------------------------------- +-- Long compiling program. + +cnst :: Integer -> Either (Immediate DummyCPU) (RegVar DummyCPU) +cnst x = Left (Const x) + +longCompilingProgram :: CDM DummyCPU () +longCompilingProgram = do +-- the number of lines below greatly affects compilation time. + x10 <- op $ Add (Var DummyZero) (cnst 10) + x10 <- op $ Add (Var DummyZero) (cnst 10) + x10 <- op $ Add (Var DummyZero) (cnst 10) + x10 <- op $ Add (Var DummyZero) (cnst 10) + x10 <- op $ Add (Var DummyZero) (cnst 10) + x10 <- op $ Add (Var DummyZero) (cnst 10) + x10 <- op $ Add (Var DummyZero) (cnst 10) + x10 <- op $ Add (Var DummyZero) (cnst 10) + x10 <- op $ Add (Var DummyZero) (cnst 10) + x10 <- op $ Add (Var DummyZero) (cnst 10) + x10 <- op $ Add (Var DummyZero) (cnst 10) + x10 <- op $ Add (Var DummyZero) (cnst 10) + x10 <- op $ Add (Var DummyZero) (cnst 10) + x10 <- op $ Add (Var DummyZero) (cnst 10) + x10 <- op $ Add (Var DummyZero) (cnst 10) + x10 <- op $ Add (Var DummyZero) (cnst 10) + return () diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T new file mode 100644 index 0000000000..b009d276c8 --- /dev/null +++ b/testsuite/tests/perf/compiler/all.T @@ -0,0 +1,153 @@ +test('T1969', + [if_wordsize(32, + compiler_stats_num_field('peak_megabytes_allocated', 13, + 19)), + # expected value: 14 (x86/Windows 17/05/10) + # 15 (x86/OS X) + # 19 (x86/OS X) + if_wordsize(64, + compiler_stats_num_field('peak_megabytes_allocated', 24, + 32)), + # expected value: 28 (amd64/Linux) + # expected value: 32 (amd64/Linux) + if_wordsize(32, + compiler_stats_num_field('max_bytes_used', 5000000, + 7000000)), + # expected value: 6707308 (x86/OS X) + # 5717704 (x86/Windows 17/05/10) + # 6149572 (x86/Linux, 31/12/09) + if_wordsize(64, + compiler_stats_num_field('max_bytes_used', 9000000, + 13000000)), + # expected value: 11404664 (amd64/Linux) + if_wordsize(32, + compiler_stats_num_field('bytes allocated', 210000000, + 270000000)), + # expected value: 215582916 (x86/Windows) + # 221667908 (x86/OS X) + if_wordsize(64, + compiler_stats_num_field('bytes allocated', 420000000, + 550000000)), + # 17/11/2009: 434,845,560 (amd64/Linux) + # 08/12/2009: 459,776,680 (amd64/Linux) + # 17/05/2010: 519,377,728 (amd64/Linux) + only_ways(['normal']) + ], + compile, + ['']) + +# This one tests for the space leak in the native code generator, +# where it holds onto the entire asm output until the end. The space +# leak reappears from time to time, so it's a good idea to have a test +# for it. The residency of this test will jump by 10MB to 40MB or so +# on x86-64 if the space leak appears. + +# Only run this one if we have an NCG: +if 'optasm' in config.compile_ways: + conf_3294 = only_ways(['normal']) +else: + conf_3294 = skip + +test('T3294', + [if_wordsize(32, + compiler_stats_num_field('max_bytes_used', 12000000, + 17000000)), + # expected value: 13049060 (x86/Linux) + if_wordsize(64, + compiler_stats_num_field('max_bytes_used', 27000000, + 34000000)), + # expected value: 32 478 408 (amd64/Linux) + # (but varies a lot, depending on when + # we GC relative to the peak). + if_wordsize(32, + compiler_stats_num_field('bytes allocated', 650000000, + 750000000)), + # expected value: 815479800 (x86/Linux) + if_wordsize(64, + compiler_stats_num_field('bytes allocated', 1200000000, + 1500000000)), + # expected value: 1357587088 (amd64/Linux) + conf_3294 + ], + compile, + ['']) + +test('T4801', + [ # expect_broken(5224), + # temporarily unbroken (#5227) + # expected value: 11 (x86/OSX): + if_wordsize(32, + compiler_stats_num_field('peak_megabytes_allocated', 30, 40)), + # expected value: 66 (amd64/Linux): + if_wordsize(64, + compiler_stats_num_field('peak_megabytes_allocated', 55, 70)), + # expected value: 353463196 (x86/Windows) + if_wordsize(32, + compiler_stats_num_field('bytes allocated', 330000000, + 370000000)), + # expected value: 145038576 (amd64/Linux): + if_wordsize(64, + compiler_stats_num_field('bytes allocated', 600000000, + 750000000)), + # expected value: 14181360 (x86/Linux) + if_wordsize(32, + compiler_stats_num_field('max_bytes_used', 11000000, + 14000000)), + # expected value: 7001696 (amd64/Linux, bindist) + # expected value: 7189848 (amd64/Linux, intree): + if_wordsize(64, + compiler_stats_num_field('max_bytes_used', 20000000, + 30000000)), + only_ways(['normal']) + ], + compile, + ['']) + +test('T3064', + [ + # expected value: 9 (x86/Linux 30-03-2011): + if_wordsize(32, + compiler_stats_num_field('peak_megabytes_allocated', 8, 11)), + # expected value: 18 (amd64/Linux): + if_wordsize(64, + compiler_stats_num_field('peak_megabytes_allocated', 11, 16)), + # expected value: 56380288 (x86/Linux) (28/6/2011) + if_wordsize(32, + compiler_stats_num_field('bytes allocated', 50000000, + 60000000)), + # expected value: 108937496 (amd64/Linux) (28/6/2011): + if_wordsize(64, + compiler_stats_num_field('bytes allocated', 100000000, + 120000000)), + # expected value: 2247016 (x86/Linux) (28/6/2011): + if_wordsize(32, + compiler_stats_num_field('max_bytes_used', 2000000, + 3000000)), + # expected value: 4032024 (amd64/Linux, intree) (28/6/2011): + if_wordsize(64, + compiler_stats_num_field('max_bytes_used', 3000000, + 5000000)), + only_ways(['normal']) + ], + compile, + ['']) + +test('T4007', + normal, + run_command, + ['$MAKE -s --no-print-directory T4007']) + +test('T5030', + [# expected value: 629864032 (x86/Darwin) + if_wordsize(32, + compiler_stats_num_field('bytes allocated', 600000000, + 650000000)), + # expected value: 1255998208 (amd64/Linux): + if_wordsize(64, + compiler_stats_num_field('bytes allocated', 1200000000, + 1300000000)), + only_ways(['normal']) + ], + compile, + ['-fcontext-stack=300']) + diff --git a/testsuite/tests/perf/should_run/3586.hs b/testsuite/tests/perf/should_run/3586.hs new file mode 100644 index 0000000000..968f2eba27 --- /dev/null +++ b/testsuite/tests/perf/should_run/3586.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS -fvia-C -optc-O3 -fexcess-precision -optc-msse3 #-} + +import Control.Monad.ST +import Data.Array.ST +import Data.Array.Base + +main = print $ runST + (do arr <- newArray (1,2000000) 137.0 :: ST s (STUArray s Int Double) + go arr 2000000 0.0 ) + + +go :: STUArray s Int Double -> Int -> Double -> ST s Double +go !a i !acc + | i < 1 = return acc + | otherwise = do + b <- unsafeRead a i + unsafeWrite a i (b+3.0) + c <- unsafeRead a i + go a (i-1) (c+acc) diff --git a/testsuite/tests/perf/should_run/3586.stdout b/testsuite/tests/perf/should_run/3586.stdout new file mode 100644 index 0000000000..626282f10c --- /dev/null +++ b/testsuite/tests/perf/should_run/3586.stdout @@ -0,0 +1 @@ +2.79999863e8 diff --git a/testsuite/tests/perf/should_run/Makefile b/testsuite/tests/perf/should_run/Makefile new file mode 100644 index 0000000000..e839342f90 --- /dev/null +++ b/testsuite/tests/perf/should_run/Makefile @@ -0,0 +1,36 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +define runT3736 +./T3736 $1 +RTS -t --machine-readable 2>&1 | grep '"bytes allocated"' | sed -e 's/.*, "//' -e 's/".*//' +endef +.PHONY: T3736 +T3736: + $(RM) -f T3736.hi T3736.o T3736 + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -O --make T3736 -rtsopts +# Check ALLOC1 is > 100 just to check with have sane results, and if so, +# the test passes if the two numbers are equal. We could check that the +# actual numbers are in the range we expect too (on the various +# platforms), but we don't currently. + ALLOC1=`$(call runT3736,1)`; ALLOC2=`$(call runT3736,2)`; if [ "$$ALLOC1" -gt 100 ] && [ "$$ALLOC1" -eq "$$ALLOC2" ]; then echo Match; else echo "Mismatch: $$ALLOC1 $$ALLOC2"; fi + +.PHONY: T2902 +T2902: + $(RM) -f T2902_A T2902_B + $(RM) -f T2902_A.hi T2902_B.hi + $(RM) -f T2902_A.o T2902_B.o + $(RM) -f T2902_A_PairingSum.hi T2902_B_PairingSum.hi T2902_Sum.hi + $(RM) -f T2902_A_PairingSum.o T2902_B_PairingSum.o T2902_Sum.o + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -O --make T2902_A -rtsopts + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -O --make T2902_B -rtsopts + BAA=`./T2902_A +RTS -t --machine-readable 2>&1 | grep '"bytes allocated"' | sed -e 's/.*, "//' -e 's/")//'`; BAB=`./T2902_B +RTS -t --machine-readable 2>&1 | grep '"bytes allocated"' | sed -e 's/.*, "//' -e 's/")//'`; [ "$$BAA" = "" ] && echo 'T2902_A: No "bytes allocated"'; [ "$$BAA" = "$$BAB" ] || echo "T2902: Mismatch in \"bytes allocated\": $$BAA $$BAB" + +.PHONY: T149 +T149: + $(RM) -f T149_A T149_A.hi T149_A.o + $(RM) -f T149_B T149_B.hi T149_B.o + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -O --make T149_A -rtsopts + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -O --make T149_B -rtsopts + BAA=`./T149_A +RTS -t --machine-readable 2>&1 | grep '"bytes allocated"' | sed -e 's/.*, "//' -e 's/")//'`; BAB=`./T149_B +RTS -t --machine-readable 2>&1 | grep '"bytes allocated"' | sed -e 's/.*, "//' -e 's/")//'`; [ "$$BAA" = "" ] && echo 'T149_A: No "bytes allocated"'; [ "$$BAA" = "$$BAB" ] || echo "T149: Mismatch in \"bytes allocated\": $$BAA $$BAB" + diff --git a/testsuite/tests/perf/should_run/MethSharing.hs b/testsuite/tests/perf/should_run/MethSharing.hs new file mode 100644 index 0000000000..fb69bd4509 --- /dev/null +++ b/testsuite/tests/perf/should_run/MethSharing.hs @@ -0,0 +1,97 @@ +module Main where + +-- This test works efficiently because the full laziness +-- pass now floats out applications +-- \x -> f y (x+1) +-- It'll float out the (f y) if that's a redex + +loop :: Double -> [Int] -> Double +{-# NOINLINE loop #-} +loop x [] = x +loop x (n:ns) = x `seq` loop (x ^ n) ns + +main = print $ loop 1 (replicate 10000000 5) + +---------------------------------------------------- +{- Roman's message of May 2010 + +I tried running nofib with -fno-method-sharing (we discussed this at some point). These are the results: + +-------------------------------------------------------------------------------- + Program Size Allocs Runtime Elapsed +-------------------------------------------------------------------------------- + + Min -0.3% -25.0% -12.5% -9.9% + Max +0.2% +159.1% +90.0% +84.7% + Geometric Mean -0.0% +2.2% +6.8% +5.1% + +This is the worst program: + + simple +0.2% +159.1% +65.3% +63.9% + +I looked at it a bit and came up with this small example: + +---- +loop :: Double -> [Int] -> Double +{-# NOINLINE loop #-} +loop x [] = x +loop x (n:ns) = x `seq` loop (x ^ n) ns + +main = print $ loop 1 (replicate 10000000 5) +---- + +This is over 2x slower with -fno-method-sharing. The culprit is, of +course, (^). Here is the difference: + +Without -fno-method-sharing: + +---- +^_rVB :: GHC.Types.Double -> GHC.Types.Int -> GHC.Types.Double ^_rVB = + GHC.Real.^ + @ GHC.Types.Double + @ GHC.Types.Int + GHC.Float.$fNumDouble + GHC.Real.$fIntegralInt + +Main.loop [InlPrag=NOINLINE (sat-args=2), Occ=LoopBreaker] + :: GHC.Types.Double -> [GHC.Types.Int] -> GHC.Types.Double Main.loop = + \ (x1_aat :: GHC.Types.Double) (ds_drG :: [GHC.Types.Int]) -> + case ds_drG of _ { + [] -> x1_aat; + : n_aav ns_aaw -> + case x1_aat of x2_aau { GHC.Types.D# ipv_srQ -> + Main.loop (^_rVB x2_aau n_aav) ns_aaw + } + } +---- + +With: + +---- +Main.loop [InlPrag=NOINLINE (sat-args=2), Occ=LoopBreaker] + :: GHC.Types.Double -> [GHC.Types.Int] -> GHC.Types.Double Main.loop = + \ (x1_aat :: GHC.Types.Double) (ds_drD :: [GHC.Types.Int]) -> + case ds_drD of _ { + [] -> x1_aat; + : n_aav ns_aaw -> + case x1_aat of x2_aau { GHC.Types.D# ipv_srN -> + Main.loop + (GHC.Real.^ + @ GHC.Types.Double + @ GHC.Types.Int + GHC.Float.$fNumDouble + GHC.Real.$fIntegralInt + x2_aau + n_aav) + ns_aaw + } + } +---- + +This is a bit disappointing. I would have expected GHC to float out +the application of (^) to the two dictionaries during full laziness +(note that (^) has arity 2 so the application is oversaturated). Why +doesn't that happen? SetLevels (if this is the right place to look) +has this: + +-}
\ No newline at end of file diff --git a/testsuite/tests/perf/should_run/MethSharing.stdout b/testsuite/tests/perf/should_run/MethSharing.stdout new file mode 100644 index 0000000000..d3827e75a5 --- /dev/null +++ b/testsuite/tests/perf/should_run/MethSharing.stdout @@ -0,0 +1 @@ +1.0 diff --git a/testsuite/tests/perf/should_run/T149_A.hs b/testsuite/tests/perf/should_run/T149_A.hs new file mode 100644 index 0000000000..dd745460c0 --- /dev/null +++ b/testsuite/tests/perf/should_run/T149_A.hs @@ -0,0 +1,25 @@ +module Main (main) where + +-- See Trac #149 + +-- Curently (with GHC 7.0) the CSE works, just, +-- but it's delicate. + + +import System.CPUTime + +main :: IO () +main = print $ playerMostOccur1 [1..m] + +m :: Int +m = 22 + +playerMostOccur1 :: [Int] -> Int +playerMostOccur1 [a] = a +playerMostOccur1 (x:xs) + | numOccur x (x:xs) > numOccur (playerMostOccur1 xs) xs = x + | otherwise = playerMostOccur1 xs + +numOccur :: Int -> [Int] -> Int +numOccur i is = length $ filter (i ==) is + diff --git a/testsuite/tests/perf/should_run/T149_B.hs b/testsuite/tests/perf/should_run/T149_B.hs new file mode 100644 index 0000000000..fcc87cdf55 --- /dev/null +++ b/testsuite/tests/perf/should_run/T149_B.hs @@ -0,0 +1,26 @@ +module Main (main) where + +-- See Trac #149 + +-- Curently (with GHC 7.0) the CSE works, just, +-- but it's delicate. + + +import System.CPUTime + +main :: IO () +main = print $ playerMostOccur2 [1..m] + +m :: Int +m = 22 + +playerMostOccur2 :: [Int] -> Int +playerMostOccur2 [a] = a +playerMostOccur2 (x:xs) + | numOccur x (x:xs) > numOccur pmo xs = x + | otherwise = pmo + where pmo = playerMostOccur2 xs + +numOccur :: Int -> [Int] -> Int +numOccur i is = length $ filter (i ==) is + diff --git a/testsuite/tests/perf/should_run/T2902_A.hs b/testsuite/tests/perf/should_run/T2902_A.hs new file mode 100644 index 0000000000..c0939104f3 --- /dev/null +++ b/testsuite/tests/perf/should_run/T2902_A.hs @@ -0,0 +1,18 @@ + +{-# LANGUAGE UnicodeSyntax #-} + +module Main (main) where + +import T2902_A_PairingSum + +f :: Int -> PSum Int Int +f n = unions $ fmap g [1..n] + where + g m = unions $ fmap fromList + [ zip [m..n] $ repeat 1 + , zip [m,2+m..n] $ repeat 2 + , zip [m,3+m..n] $ repeat 3 + ] + +main ∷ IO () +main = print $ take 20 $ toList $ f 20 diff --git a/testsuite/tests/perf/should_run/T2902_A_PairingSum.hs b/testsuite/tests/perf/should_run/T2902_A_PairingSum.hs new file mode 100644 index 0000000000..a5dd0e7803 --- /dev/null +++ b/testsuite/tests/perf/should_run/T2902_A_PairingSum.hs @@ -0,0 +1,49 @@ + +{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, FlexibleInstances #-} + +module T2902_A_PairingSum (Sum(..), PSum) where + +import T2902_Sum + +data PSum a b = Empty | Tree a b [(PSum a b)] + +instance (Ord a, Num b) ⇒ Sum PSum a b where + insert = insertX + union = unionX + unions = unionsX + extractMin = extractMinX + fromList = fromListX + toList = toListX + +insertX ∷ (Ord a, Num b) ⇒ a → b → PSum a b → PSum a b +insertX v r = unionX $ Tree v r [] + +unionX ∷ (Ord a, Num b) ⇒ PSum a b → PSum a b → PSum a b +unionX x Empty = x +unionX Empty x = x +unionX x@(Tree v r xs) y@(Tree w s ys) = + case compare v w of + LT → Tree v r (y:xs) + GT → Tree w s (x:ys) + EQ → case r + s of + 0 → z + t → insertX v t z + where z = unionX (unionsX xs) (unionsX ys) + +unionsX ∷ (Ord a, Num b) ⇒ [PSum a b] → PSum a b +unionsX [] = Empty +unionsX [x] = x +unionsX (x : y : zs) = unionX (unionX x y) (unionsX zs) + +extractMinX ∷ (Ord a, Num b) ⇒ PSum a b → ((a,b), PSum a b) +extractMinX Empty = undefined +extractMinX (Tree v r xs) = ((v,r), unionsX xs) + +fromListX ∷ (Ord a, Num b) ⇒ [(a,b)] → PSum a b +fromListX [] = Empty +fromListX ((v,r):xs) = insertX v r $ fromListX xs + +toListX ∷ (Ord a, Num b) ⇒ PSum a b → [(a,b)] +toListX Empty = [] +toListX x = let (y, z) = extractMinX x in y : toListX z + diff --git a/testsuite/tests/perf/should_run/T2902_B.hs b/testsuite/tests/perf/should_run/T2902_B.hs new file mode 100644 index 0000000000..c6558c625b --- /dev/null +++ b/testsuite/tests/perf/should_run/T2902_B.hs @@ -0,0 +1,18 @@ + +{-# LANGUAGE UnicodeSyntax #-} + +module Main (main) where + +import T2902_B_PairingSum + +f :: Int -> PSum Int Int +f n = unions $ fmap g [1..n] + where + g m = unions $ fmap fromList + [ zip [m..n] $ repeat 1 + , zip [m,2+m..n] $ repeat 2 + , zip [m,3+m..n] $ repeat 3 + ] + +main ∷ IO () +main = print $ take 20 $ toList $ f 20 diff --git a/testsuite/tests/perf/should_run/T2902_B_PairingSum.hs b/testsuite/tests/perf/should_run/T2902_B_PairingSum.hs new file mode 100644 index 0000000000..5276da818b --- /dev/null +++ b/testsuite/tests/perf/should_run/T2902_B_PairingSum.hs @@ -0,0 +1,37 @@ + +{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, FlexibleInstances #-} + +module T2902_B_PairingSum (Sum(..), PSum) where + +import T2902_Sum + +data PSum a b = Empty | Tree a b [PSum a b] + +instance (Ord a, Num b) ⇒ Sum PSum a b where + + insert v r = union $ Tree v r [] + + union x Empty = x + union Empty x = x + union x@(Tree v r xs) y@(Tree w s ys) = + case compare v w of + LT → Tree v r (y:xs) + GT → Tree w s (x:ys) + EQ → case r + s of + 0 → z + t → insert v t z + where z = union (unions xs) (unions ys) + + unions [] = Empty + unions [x] = x + unions (x : y : zs) = union (union x y) (unions zs) + + extractMin Empty = undefined + extractMin (Tree v r xs) = ((v,r), unions xs) + + fromList [] = Empty + fromList ((v,r):xs) = insert v r $ fromList xs + + toList Empty = [] + toList x = let (y, z) = extractMin x in y : toList z + diff --git a/testsuite/tests/perf/should_run/T2902_Sum.hs b/testsuite/tests/perf/should_run/T2902_Sum.hs new file mode 100644 index 0000000000..9be6b10568 --- /dev/null +++ b/testsuite/tests/perf/should_run/T2902_Sum.hs @@ -0,0 +1,14 @@ + +{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses #-} + +module T2902_Sum (Sum(..)) where + +class Sum c a b where + insert ∷ a → b → c a b → c a b + union ∷ c a b → c a b → c a b + unions ∷ [c a b] → c a b + extractMin ∷ c a b → ((a,b), c a b) + + fromList ∷ [(a,b)] → c a b + toList ∷ c a b → [(a,b)] + diff --git a/testsuite/tests/perf/should_run/T3245.hs b/testsuite/tests/perf/should_run/T3245.hs new file mode 100644 index 0000000000..f52fc27303 --- /dev/null +++ b/testsuite/tests/perf/should_run/T3245.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE ExistentialQuantification #-} + +-- The second version (count2) took ages with GHC 6.12 +-- because the typeOf function was not properly memoised + +import Data.Typeable +import System.CPUTime + +size :: Int +size = 40000 -- This was big enough to take 5 seconds in + -- the bad case on my machine. + +data Any = forall a. (Typeable a) => Any a + +int_type, int_list_type :: TypeRep +int_type = typeOf (undefined :: Int) +int_list_type = typeOf (undefined :: [Int]) + +count1 :: [Any] -> Int +count1 [] = 0 +count1 (Any x:xs) = count1 xs + (if typeOf x == int_type then 1 else 0) + +doTime x = do + start <- getCPUTime + putStr "Result: " + print x + stop <- getCPUTime + putStr "Time(sec): " + print (round $ fromIntegral (stop - start) / 1e12) + -- The 'round' rounds to an integral number of seconds + -- Should be zero if things are working right! + +main = do + let list = [MkT | i <- [1..size :: Int]] + putStrLn "count1" + let x = map Any list + doTime $ count1 x + doTime $ count1 x + doTime $ count1 x + putStrLn "" + putStrLn "count2" + let x = map (Any . (:[])) list + doTime $ count1 x + doTime $ count1 x + doTime $ count1 x + +data T = MkT +tcname :: TyCon +tcname = mkTyCon "T" +instance Typeable T where { typeOf _ = mkTyConApp tcname [] } diff --git a/testsuite/tests/perf/should_run/T3245.stdout b/testsuite/tests/perf/should_run/T3245.stdout new file mode 100644 index 0000000000..bcff7f8fd1 --- /dev/null +++ b/testsuite/tests/perf/should_run/T3245.stdout @@ -0,0 +1,15 @@ +count1 +Result: 0 +Time(sec): 0 +Result: 0 +Time(sec): 0 +Result: 0 +Time(sec): 0 + +count2 +Result: 0 +Time(sec): 0 +Result: 0 +Time(sec): 0 +Result: 0 +Time(sec): 0 diff --git a/testsuite/tests/perf/should_run/T3736.hs b/testsuite/tests/perf/should_run/T3736.hs new file mode 100644 index 0000000000..e812109611 --- /dev/null +++ b/testsuite/tests/perf/should_run/T3736.hs @@ -0,0 +1,212 @@ +{-# OPTIONS_GHC -funbox-strict-fields -O #-} +{-# LANGUAGE ExistentialQuantification #-} + +{- OPTIONS_GHC -ddump-simpl -ddump-asm -} + +module Main (main) where + +import GHC.Float (float2Int, int2Float) + +import System.Environment + +import Prelude hiding (null + ,lines,unlines + ,writeFile + ) + +import Control.Exception (assert, bracket, ) + +import Foreign.Marshal.Array (advancePtr) +import Foreign.Ptr (minusPtr) +import Foreign.Storable (Storable(..)) + +import Control.Monad (when) + +import System.IO (openBinaryFile, hClose, + hPutBuf, + Handle, IOMode(..)) + +import System.IO.Unsafe (unsafePerformIO) + +import Foreign.Ptr (Ptr) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, ) +import Foreign.Marshal.Array (copyArray) + +import qualified Foreign.ForeignPtr as F + +main :: IO () +main = do args <- getArgs + case args of + ["1"] -> mainMonolithic1Generator + ["2"] -> mainMonolithic1Composed + _ -> error "Huh?" + +type Phase = (Float, Float, Float) + +{-# INLINE saw #-} +saw :: Num a => a -> a +saw t = 1-2*t + +{-# INLINE fraction #-} +fraction :: Float -> Float +fraction x = x - int2Float (float2Int x) + +{-# INLINE generator0Freq #-} +generator0Freq :: Float -> Float -> Maybe (Float, Float) +generator0Freq freq = + \p -> Just (saw p, fraction (p+freq)) + +infixl 6 `mix`, `mixGen` + +{-# INLINE mix #-} +mix :: + (Num y) => + (s -> Maybe (y, s)) -> + (t -> Maybe (y, t)) -> + ((s,t) -> Maybe (y, (s,t))) +mix f g (s0,t0) = + do (a,s1) <- f s0 + (b,t1) <- g t0 + return ((a+b), (s1,t1)) + +data Generator a = + forall s. + Generator (s -> Maybe (a, s)) s + +{-# INLINE runGeneratorMonolithic #-} +runGeneratorMonolithic :: Int -> Generator Float -> Vector Float +runGeneratorMonolithic size' (Generator f s) = + fst $ unfoldrN size' f s + +{- SPECIALISE INLINE generator0Gen :: Float -> Float -> Generator Float -} +{-# INLINE generator0Gen #-} +generator0Gen :: Float -> Float -> Generator Float +generator0Gen freq phase = + Generator (\p -> Just (saw p, fraction (p+freq))) phase + +{- SPECIALISE INLINE mixGen :: Generator Float -> Generator Float -> Generator Float -} +{-# INLINE mixGen #-} +mixGen :: + (Num y) => + Generator y -> + Generator y -> + Generator y +mixGen (Generator f s) (Generator g t) = + Generator (\(s0,t0) -> + do (a,s1) <- f s0 + (b,t1) <- g t0 + return ((a+b), (s1,t1))) (s,t) + +{-# INLINE dl #-} +dl :: Phase +dl = (0.01008, 0.01003, 0.00990) + +{-# INLINE initPhase2 #-} +initPhase2 :: (Phase, Phase) +initPhase2 = + ((0,0.7,0.1), (0.3,0.4,0.6)) + + +size :: Int +size = 10000000 + + +mainMonolithic1Composed :: IO () +mainMonolithic1Composed = + writeFile "speed.f32" + (fst $ unfoldrN size + (let (f0,f1,f2) = dl + in generator0Freq f0 `mix` + generator0Freq f1 `mix` + generator0Freq f2) + (let (p0,p1,p2) = fst initPhase2 + in ((p0,p1),p2))) + +mainMonolithic1Generator :: IO () +mainMonolithic1Generator = + writeFile "speed.f32" + (runGeneratorMonolithic size + (let (f0,f1,f2) = dl + (p0,p1,p2) = fst initPhase2 + in generator0Gen f0 p0 `mixGen` + generator0Gen f1 p1 `mixGen` + generator0Gen f2 p2)) + +empty :: (Storable a) => Vector a +empty = unsafeCreate 0 $ const $ return () +{-# NOINLINE empty #-} + +null :: Vector a -> Bool +null (SV _ _ l) = assert (l >= 0) $ l <= 0 +{-# INLINE null #-} + +unfoldrN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a) +unfoldrN n f x0 = + if n <= 0 + then (empty, Just x0) + else unsafePerformIO $ createAndTrim' n $ \p -> go p n x0 + where + go = arguments2 $ \p i -> \x -> + if i == 0 + then return (0, n-i, Just x) + else + case f x of + Nothing -> return (0, n-i, Nothing) + Just (w,x') -> do poke p w + go (incPtr p) (i-1) x' +{-# INLINE unfoldrN #-} + +hPut :: (Storable a) => Handle -> Vector a -> IO () +hPut h v = + when (not (null v)) $ + withStartPtr v $ \ ptrS l -> + let ptrE = advancePtr ptrS l + in hPutBuf h ptrS (minusPtr ptrE ptrS) + +writeFile :: (Storable a) => FilePath -> Vector a -> IO () +writeFile f txt = + bracket (openBinaryFile f WriteMode) hClose + (\h -> hPut h txt) + +data Vector a = SV {-# UNPACK #-} !(ForeignPtr a) + {-# UNPACK #-} !Int -- offset + {-# UNPACK #-} !Int -- length + +withStartPtr :: Storable a => Vector a -> (Ptr a -> Int -> IO b) -> IO b +withStartPtr (SV x s l) f = + withForeignPtr x $ \p -> f (p `advancePtr` s) l +{-# INLINE withStartPtr #-} + +incPtr :: (Storable a) => Ptr a -> Ptr a +incPtr v = advancePtr v 1 +{-# INLINE incPtr #-} + +unsafeCreate :: (Storable a) => Int -> (Ptr a -> IO ()) -> Vector a +unsafeCreate l f = unsafePerformIO (create l f) +{-# INLINE unsafeCreate #-} + +create :: (Storable a) => Int -> (Ptr a -> IO ()) -> IO (Vector a) +create l f = do + fp <- mallocForeignPtrArray l + withForeignPtr fp $ \p -> f p + return $! SV fp 0 l + +createAndTrim' :: (Storable a) => Int + -> (Ptr a -> IO (Int, Int, b)) + -> IO (Vector a, b) +createAndTrim' l f = do + fp <- mallocForeignPtrArray l + withForeignPtr fp $ \p -> do + (off, l', res) <- f p + if assert (l' <= l) $ l' >= l + then return $! (SV fp 0 l, res) + else do ps <- create l' $ \p' -> copyArray p' (p `advancePtr` off) l' + return $! (ps, res) + +{-# INLINE arguments2 #-} +arguments2 :: (a -> b -> x) -> a -> b -> x +arguments2 f = \a b -> (f $! a) $! b + +{-# INLINE mallocForeignPtrArray #-} +mallocForeignPtrArray :: Storable a => Int -> IO (F.ForeignPtr a) +mallocForeignPtrArray = F.mallocForeignPtrArray diff --git a/testsuite/tests/perf/should_run/T3736.stdout b/testsuite/tests/perf/should_run/T3736.stdout new file mode 100644 index 0000000000..1796dc2720 --- /dev/null +++ b/testsuite/tests/perf/should_run/T3736.stdout @@ -0,0 +1 @@ +Match diff --git a/testsuite/tests/perf/should_run/T3738.hs b/testsuite/tests/perf/should_run/T3738.hs new file mode 100644 index 0000000000..1b3141c0f5 --- /dev/null +++ b/testsuite/tests/perf/should_run/T3738.hs @@ -0,0 +1,10 @@ + +module Main where + +import T3738a + +{-# INLINE bar #-} +bar :: Int -> [Int] +bar x = map (+ 2) (foo x) + +main = print (bar 2 !! 10000) diff --git a/testsuite/tests/perf/should_run/T3738.stdout b/testsuite/tests/perf/should_run/T3738.stdout new file mode 100644 index 0000000000..7ed6ff82de --- /dev/null +++ b/testsuite/tests/perf/should_run/T3738.stdout @@ -0,0 +1 @@ +5 diff --git a/testsuite/tests/perf/should_run/T3738a.hs b/testsuite/tests/perf/should_run/T3738a.hs new file mode 100644 index 0000000000..b27451d12d --- /dev/null +++ b/testsuite/tests/perf/should_run/T3738a.hs @@ -0,0 +1,6 @@ + +module T3738a where + +{-# INLINE foo #-} +foo :: Num a => a -> [a] +foo x = map (+ 1) (repeat x) diff --git a/testsuite/tests/perf/should_run/T4321.hs b/testsuite/tests/perf/should_run/T4321.hs new file mode 100644 index 0000000000..b8a0dbc4a1 --- /dev/null +++ b/testsuite/tests/perf/should_run/T4321.hs @@ -0,0 +1,15 @@ + +-- In 6.13 this stack overflowed + +module Main (main) where + +main :: IO () +main = let n = 1000000 + in print $ integrate n (1 / fromIntegral n) + +integrate :: Int -> Double -> Double +integrate n h = h * (sum (map area [1..n])) + where area :: Int -> Double + area i = let x = h * (fromIntegral i - 0.5) + in 4 / (1 + x*x) + diff --git a/testsuite/tests/perf/should_run/T4321.stdout b/testsuite/tests/perf/should_run/T4321.stdout new file mode 100644 index 0000000000..ce98a198a7 --- /dev/null +++ b/testsuite/tests/perf/should_run/T4321.stdout @@ -0,0 +1 @@ +3.1415926535897643 diff --git a/testsuite/tests/perf/should_run/T4830.hs b/testsuite/tests/perf/should_run/T4830.hs new file mode 100644 index 0000000000..e345ffc9cd --- /dev/null +++ b/testsuite/tests/perf/should_run/T4830.hs @@ -0,0 +1,15 @@ +-- Compile with O2; SpecConstr should fire nicely +-- and eliminate all allocation in inner loop + +module Main where + +foo :: Int -> Maybe (Double,Double) -> Double +foo _ Nothing = 0 +foo 0 (Just (x,y)) = x+y +foo n (Just (x,y)) = let r = f x y in r `seq` foo (n-1) (Just r) + where + f x y | x <= y = (x,y) + | otherwise = (y,x) + +main = print (foo 1000000 (Just (1,2))) + diff --git a/testsuite/tests/perf/should_run/T4830.stdout b/testsuite/tests/perf/should_run/T4830.stdout new file mode 100644 index 0000000000..9f55b2ccb5 --- /dev/null +++ b/testsuite/tests/perf/should_run/T4830.stdout @@ -0,0 +1 @@ +3.0 diff --git a/testsuite/tests/perf/should_run/T4978.hs b/testsuite/tests/perf/should_run/T4978.hs new file mode 100644 index 0000000000..6413b01fdc --- /dev/null +++ b/testsuite/tests/perf/should_run/T4978.hs @@ -0,0 +1,125 @@ +module Main (main) where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Internal (inlinePerformIO) +import qualified Data.ByteString.Internal as S +import Data.Monoid +import Foreign + +newtype Builder = Builder { + runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString] + } + +instance Monoid Builder where + mempty = empty + {-# INLINE mempty #-} + mappend = append + {-# INLINE mappend #-} + mconcat = foldr mappend mempty + {-# INLINE mconcat #-} + +empty :: Builder +empty = Builder (\ k b -> b `seq` k b) +{-# INLINE empty #-} + +singleton :: Word8 -> Builder +singleton = writeN 1 . flip poke +{-# INLINE singleton #-} + +append :: Builder -> Builder -> Builder +append (Builder f) (Builder g) = Builder (f . g) +{-# INLINE [0] append #-} + +-- Our internal buffer type +data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) + {-# UNPACK #-} !Int -- offset + {-# UNPACK #-} !Int -- used bytes + {-# UNPACK #-} !Int -- length left + +-- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any, +-- yielding a new chunk in the result lazy 'L.ByteString'. +flush :: Builder +flush = Builder $ \ k buf@(Buffer p o u l) -> + if u == 0 + then k buf + else S.PS p o u : k (Buffer p (o+u) 0 l) + +-- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'. +-- The construction work takes place if and when the relevant part of +-- the lazy 'L.ByteString' is demanded. +-- +toLazyByteString :: Builder -> L.ByteString +toLazyByteString m = L.fromChunks $ unsafePerformIO $ do + buf <- newBuffer defaultSize + return (runBuilder (m `append` flush) (const []) buf) +{-# INLINE toLazyByteString #-} + +defaultSize :: Int +defaultSize = 32 * k - overhead + where k = 1024 + overhead = 2 * sizeOf (undefined :: Int) + +-- | Sequence an IO operation on the buffer +unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder +unsafeLiftIO f = Builder $ \ k buf -> inlinePerformIO $ do + buf' <- f buf + return (k buf') +{-# INLINE unsafeLiftIO #-} + +-- | Get the size of the buffer +withSize :: (Int -> Builder) -> Builder +withSize f = Builder $ \ k buf@(Buffer _ _ _ l) -> runBuilder (f l) k buf + +-- | Ensure that there are at least @n@ many bytes available. +ensureFree :: Int -> Builder +ensureFree n = n `seq` withSize $ \ l -> + if n <= l then empty else + flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize))) +{-# INLINE [0] ensureFree #-} + +-- | Ensure that @n@ many bytes are available, and then use @f@ to write some +-- bytes into the memory. +writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder +writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f) +{-# INLINE [0] writeN #-} + +writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer +writeNBuffer n f (Buffer fp o u l) = do + withForeignPtr fp (\p -> f (p `plusPtr` (o+u))) + return (Buffer fp o (u+n) (l-n)) +{-# INLINE writeNBuffer #-} + +newBuffer :: Int -> IO Buffer +newBuffer size = do + fp <- S.mallocByteString size + return $! Buffer fp 0 0 size +{-# INLINE newBuffer #-} + +-- Merge buffer bounds checks. +{-# RULES +"append/writeN" forall a b (f::Ptr Word8 -> IO ()) + (g::Ptr Word8 -> IO ()) ws. + append (writeN a f) (append (writeN b g) ws) = + append (writeN (a+b) (\p -> f p >> g (p `plusPtr` a))) ws + +"writeN/writeN" forall a b (f::Ptr Word8 -> IO ()) + (g::Ptr Word8 -> IO ()). + append (writeN a f) (writeN b g) = + writeN (a+b) (\p -> f p >> g (p `plusPtr` a)) + +"ensureFree/ensureFree" forall a b . + append (ensureFree a) (ensureFree b) = ensureFree (max a b) + #-} + +-- Test case + +-- Argument must be a multiple of 4. +test :: Int -> Builder +test 0 = mempty +test n = singleton 1 `mappend` + (singleton 2 `mappend` + (singleton 3 `mappend` + (singleton 4 `mappend` test (n-4)))) + +main = print $ L.length $ toLazyByteString $ test 10000000 diff --git a/testsuite/tests/perf/should_run/T4978.stdout b/testsuite/tests/perf/should_run/T4978.stdout new file mode 100644 index 0000000000..825319e1c5 --- /dev/null +++ b/testsuite/tests/perf/should_run/T4978.stdout @@ -0,0 +1 @@ +10000000 diff --git a/testsuite/tests/perf/should_run/T5113.hs b/testsuite/tests/perf/should_run/T5113.hs new file mode 100644 index 0000000000..e87bcb6cad --- /dev/null +++ b/testsuite/tests/perf/should_run/T5113.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BangPatterns #-} +module Main where + +import Data.Array.Base (unsafeRead, unsafeWrite) +import Data.Array.ST +import Data.Array.Unboxed +import Control.Monad.ST + +main = print (divisorCounts 1000000 ! 342) + +isqrt :: Int -> Int +isqrt n = floor (sqrt $ fromIntegral n) + +divisorCounts :: Int -> UArray Int Int +divisorCounts n = runSTUArray $ do + let !rt = isqrt n + darr <- newArray (0,n) 1 :: ST s (STUArray s Int Int) + let inc i = unsafeRead darr i >>= \k -> unsafeWrite darr i (k+1) + note step i + | i > n = return () + | otherwise = do + inc i + note step (i+step) + count j + | j > rt = return () + | otherwise = do + note (2*j) (j*j) + count (j+2) + note 2 4 + count 3 + return darr diff --git a/testsuite/tests/perf/should_run/T5113.stdout b/testsuite/tests/perf/should_run/T5113.stdout new file mode 100644 index 0000000000..0cfbf08886 --- /dev/null +++ b/testsuite/tests/perf/should_run/T5113.stdout @@ -0,0 +1 @@ +2 diff --git a/testsuite/tests/perf/should_run/T5205.hs b/testsuite/tests/perf/should_run/T5205.hs new file mode 100644 index 0000000000..215dd42647 --- /dev/null +++ b/testsuite/tests/perf/should_run/T5205.hs @@ -0,0 +1,13 @@ + +import Control.Concurrent +import Control.Monad + +main :: IO () +main = do t <- forkIO (x >> x) + threadDelay 1000000 + killThread t + putStrLn "Done" + +x :: IO () +x = forever yield + diff --git a/testsuite/tests/perf/should_run/T5205.stdout b/testsuite/tests/perf/should_run/T5205.stdout new file mode 100644 index 0000000000..a965a70ed4 --- /dev/null +++ b/testsuite/tests/perf/should_run/T5205.stdout @@ -0,0 +1 @@ +Done diff --git a/testsuite/tests/perf/should_run/all.T b/testsuite/tests/perf/should_run/all.T new file mode 100644 index 0000000000..04133979df --- /dev/null +++ b/testsuite/tests/perf/should_run/all.T @@ -0,0 +1,148 @@ +# Tests that newArray/newArray_ is being optimised correctly + +# fortunately the values here are mostly independent of the wordsize, +# because the test allocates an unboxed array of doubles. + +test('3586', + [stats_num_field('peak_megabytes_allocated', 17, + 18), + # expected value: 17 (amd64/Linux) + stats_num_field('bytes allocated', 16000000, + 17000000), + # expected value: 16835544 (amd64/Linux) + only_ways(['normal']) + ], + compile_and_run, + ['-O']) + +test('T4830', + [stats_num_field('bytes allocated', 60000, + 200000), + # expected value: 127,000 (amd64/Linux) + only_ways(['normal']) + ], + compile_and_run, + ['-O2']) + +test('T3245', normal, compile_and_run, ['-O']) + +# Test that bytestring reading/writing isn't over-allocating. We had +# a bug in hGetBufNonBlocking in 6.13 that triggered this. +# +test('lazy-bs-alloc', + [stats_num_field('peak_megabytes_allocated', 1, + 3), + # expected value: 2 (amd64/Linux) + stats_num_field('bytes allocated', 400000, + 600000), + # expected value: 489776 (amd64/Linux) + only_ways(['normal']), + extra_run_opts('../../numeric/should_run/arith011.stdout'), + ignore_output + ], + # use a suitably big file, without bloating the repo with a new one: + compile_and_run, + ['-O']) + +# Get reproducible floating-point results on x86 +if config.arch == 'i386': + sse2_opts = '-msse2' +else: + sse2_opts = '' + +test('T4321', omit_ways(['ghci']), compile_and_run, ['-O ' + sse2_opts]) + +test('T3736', normal, run_command, ['$MAKE -s --no-print-directory T3736']) +test('T3738', + [stats_num_field('peak_megabytes_allocated', 1, + 1), + # expected value: 1 (amd64/Linux) + # expected value: 45648 (x86/Linux): + if_wordsize(32, + stats_num_field('bytes allocated', 40000, + 50000)), + if_wordsize(64, + stats_num_field('bytes allocated', 40000, + 60000)), + # expected value: 49400 (amd64/Linux) + only_ways(['normal']) + ], + compile_and_run, + ['-O']) + +test('MethSharing', + [stats_num_field('peak_megabytes_allocated', 1, + 1), + # expected value: 1 (amd64/Linux) + # expected value: 2685858140 (x86/OS X): + if_wordsize(32, + stats_num_field('bytes allocated', 300000000, + 400000000)), + # expected: 360940756 (x86/Linux) + if_wordsize(64, + stats_num_field('bytes allocated', 600000000, + 700000000)), + # expected: 640067672 (amd64/Linux) + only_ways(['normal']) + ], + compile_and_run, + ['-O']) +test('T2902', + extra_clean(['T2902_A', 'T2902_B', + 'T2902_A.hi', 'T2902_B.hi', + 'T2902_A.o', 'T2902_B.o', + 'T2902_A_PairingSum.hi', 'T2902_B_PairingSum.hi', + 'T2902_A_PairingSum.o', 'T2902_B_PairingSum.o', + 'T2902_Sum.hi', + 'T2902_Sum.o']), + run_command, + ['$MAKE -s --no-print-directory T2902']) +test('T149', + [expect_broken(149), + extra_clean(['T149_A', 'T149_B', + 'T149_A.hi', 'T149_B.hi', + 'T149_A.o', 'T149_B.o'])], + run_command, + ['$MAKE -s --no-print-directory T149']) + +test('T5113', + [ + if_wordsize(32, + stats_num_field('bytes allocated', 3000000, + 5000000)), + if_wordsize(64, + stats_num_field('bytes allocated', 8000000, + 9000000)), + only_ways(['normal']) + ], + compile_and_run, + ['-O']) + + +test('T4978', + [if_wordsize(32, + stats_num_field('bytes allocated', 9000000, + 11000000)), + if_wordsize(64, + stats_num_field('bytes allocated', 9000000, + 11000000)), + # expected value: 10137680 (amd64/Linux) + only_ways(['normal']) + ], + compile_and_run, + ['-O2']) + +test('T5205', + [if_wordsize(32, + stats_num_field('bytes allocated', 40000, + 50000)), + # expected value: 47088 (x86/Darwin) + if_wordsize(64, + stats_num_field('bytes allocated', 40000, + 60000)), + # expected value: 51320 (amd64/Linux) + only_ways(['normal']) + ], + compile_and_run, + ['-O']) + diff --git a/testsuite/tests/perf/should_run/lazy-bs-alloc.hs b/testsuite/tests/perf/should_run/lazy-bs-alloc.hs new file mode 100644 index 0000000000..76850c67d0 --- /dev/null +++ b/testsuite/tests/perf/should_run/lazy-bs-alloc.hs @@ -0,0 +1,9 @@ +module Main (main) where + +import System.Environment (getArgs) +import qualified Data.ByteString.Lazy as L + +main :: IO () +main = do + (file : _) <- getArgs + L.readFile file >>= L.putStr diff --git a/testsuite/tests/perf/space_leaks/Makefile b/testsuite/tests/perf/space_leaks/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/perf/space_leaks/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/perf/space_leaks/T2762.hs b/testsuite/tests/perf/space_leaks/T2762.hs new file mode 100644 index 0000000000..76ab04501c --- /dev/null +++ b/testsuite/tests/perf/space_leaks/T2762.hs @@ -0,0 +1,18 @@ + +module Main (main) where + +import T2762A + +main :: IO () +main = do + let content1 = concat (replicate 1000000 "1x") ++ "0" + let i1 = fst $ input content1 + view i1 + + let content2 = concat (replicate 1000001 "1y") ++ "0" + let i2 = fst $ input content2 + view i2 + +view :: [Char] -> IO () +view [] = return () +view (i : is) = i `seq` view is diff --git a/testsuite/tests/perf/space_leaks/T2762A.hs b/testsuite/tests/perf/space_leaks/T2762A.hs new file mode 100644 index 0000000000..665fa6ef72 --- /dev/null +++ b/testsuite/tests/perf/space_leaks/T2762A.hs @@ -0,0 +1,15 @@ + +module T2762A (input) where + +class InputOutput a where + input :: String -> (a, String) + +instance InputOutput Char where + input (x : bs) = (x, bs) + +instance InputOutput a => InputOutput [a] where + input ('0':bs) = ([], bs) + input ('1':bs) = case input bs of + (x, bs') -> + case input bs' of + ~(xs, bs'') -> (x : xs, bs'') diff --git a/testsuite/tests/perf/space_leaks/T4334.hs b/testsuite/tests/perf/space_leaks/T4334.hs new file mode 100644 index 0000000000..ab522f006e --- /dev/null +++ b/testsuite/tests/perf/space_leaks/T4334.hs @@ -0,0 +1,18 @@ +module Main (main) where + +import System.Environment (getArgs) + +mkText :: Int -> Int -> Char -> String +mkText ll ln c = + unlines $ [replicate k c | k <- [ll .. ll+ln]] + +main :: IO () +main = do + args <- getArgs + let (ll, ln, c) = + case args of + (a1:a2:a3:_) -> (read a1, read a2, head a3) + (a1:a2:_) -> (read a1, read a2, 'a') + (a1:_) -> (read a1, 3, 'b') + _ -> (100000, 5, 'c') + mapM_ (print . length) (lines $ mkText ll ln c) diff --git a/testsuite/tests/perf/space_leaks/T4334.stdout b/testsuite/tests/perf/space_leaks/T4334.stdout new file mode 100644 index 0000000000..2974b9f373 --- /dev/null +++ b/testsuite/tests/perf/space_leaks/T4334.stdout @@ -0,0 +1,3 @@ +1000000 +1000001 +1000002 diff --git a/testsuite/tests/perf/space_leaks/all.T b/testsuite/tests/perf/space_leaks/all.T new file mode 100644 index 0000000000..809ec01b44 --- /dev/null +++ b/testsuite/tests/perf/space_leaks/all.T @@ -0,0 +1,39 @@ + +test('space_leak_001', + # Before trac #2747 was fixed this was 565. + # Now it's: 3 (amd64/Linux) + # 4 (x86/OS X) + # 5 (x86/Linux) + [stats_num_field('peak_megabytes_allocated', 3, 5), + stats_num_field('max_bytes_used', 410000, + 450000), + # expected value: 440224 (amd64/Linux) + # 417016 (x86/OS X) + # 415672 (x86/Windows) + stats_num_field('bytes allocated', 9050000000, + 9100000000), + # expected value: 9079316016 (amd64/Linux) + # 9331570416 (x86/Linux) + # 9329073952 (x86/OS X) + # 9327959840 (x86/Windows) + omit_ways(['profasm','profthreaded','threaded1','threaded2']) + ], + compile_and_run, + ['']) + +test('T4334', + # Test for a space leak in Data.List.lines (fixed with #4334) + [extra_run_opts('1000000 2 t'), + stats_num_field('peak_megabytes_allocated', 1, 3), + # prof ways don't work well with +RTS -V0 + omit_ways(['profasm','profthreaded']) + ], + compile_and_run, ['']) + +test('T2762', + [# peak_megabytes_allocated is 2 with 7.0.2. + # Was 57 with 6.12.3. + stats_num_field('peak_megabytes_allocated', 1, 3), + only_ways(['normal']), + extra_clean(['T2762A.hi', 'T2762A.o'])], + compile_and_run, ['-O']) diff --git a/testsuite/tests/perf/space_leaks/space_leak_001.hs b/testsuite/tests/perf/space_leaks/space_leak_001.hs new file mode 100644 index 0000000000..cabde0ae9b --- /dev/null +++ b/testsuite/tests/perf/space_leaks/space_leak_001.hs @@ -0,0 +1,5 @@ + +import Data.List + +main :: IO () +main = print $ length $ show (foldl' (*) 1 [1..100000] :: Integer) diff --git a/testsuite/tests/perf/space_leaks/space_leak_001.stdout b/testsuite/tests/perf/space_leaks/space_leak_001.stdout new file mode 100644 index 0000000000..85dc4185fa --- /dev/null +++ b/testsuite/tests/perf/space_leaks/space_leak_001.stdout @@ -0,0 +1 @@ +456574 |