1 2 -- ==========================================================-- 3 -- === Strictness analyser -- v6 StrictAn6.hs ===-- 4 -- ==========================================================-- 5 6 module StrictAn6 where 7 import BaseDefs 8 import Utils 9 import MyUtils 10 import BarakiConc3 11 import Constructors 12 import PrintResults 13 import AbstractVals2 14 import DomainExpr 15 import TExpr2DExpr 16 import AbstractMisc 17 import Inverse 18 import AbstractEval2 19 import Simplify 20 import FrontierGENERIC2 21 import SmallerLattice 22 import AbsConc3 23 24 import List(transpose) -- 1.3 25 import Char(isLower,isUpper) 26 27 -- ==========================================================-- 28 -- Call analyser and format results 29 -- 30 saMain :: AnnExpr Naam TExpr -> 31 TypeDependancy -> 32 AList Naam TExpr -> 33 AList Naam [Naam] -> 34 AList Naam (HExpr Naam) -> 35 [TypeDef] -> 36 [Flag] -> 37 AList Domain Int -> 38 [Char] 39 40 saMain typedTree typeDAR simplestTEnv freeVars builtins dataDefs flags table 41 = let domaindTree 42 = tx2dxAnnTree typeDAR typedTree 43 recGroups 44 = saMkGroups domaindTree 45 simplestDEnv 46 = map2nd (tx2dx typeDAR) simplestTEnv 47 simplestDs 48 = map2nd dxApplyDSubst_2 simplestDEnv 49 statics 50 = (simplestDEnv, simplestDs, cargs, 51 freeVars, flags, (pLim, mLim, lLim, uLim, sRat), table) 52 cargs 53 = saMkCargs dataDefs 54 mindless_inv 55 = SimpleInv `elem` utSCflags statics 56 use_baraki 57 = NoBaraki `notElem` utSCflags statics 58 saResult 59 = saUndoCAFkludge (saGroups statics builtins recGroups) 60 setting_info 61 = saSettingInfo pLim mLim lLim uLim sRat mindless_inv use_baraki 62 result 63 = concat (map (saPrinter statics mindless_inv) saResult) 64 pLim 65 = case head (filter isP flags) of {PolyLim n -> n} 66 mLim 67 = case head (filter isM flags) of {MonoLim n -> n} 68 lLim 69 = case head (filter isL flags) of {LowerLim n -> n} 70 uLim 71 = case head (filter isU flags) of {UpperLim n -> n} 72 sRat 73 = case head (filter isS flags) of {ScaleUp n -> n} 74 isP x 75 = case x of {PolyLim _ -> True; _ -> False} 76 isM x 77 = case x of {MonoLim _ -> True; _ -> False} 78 isL x 79 = case x of {LowerLim _ -> True; _ -> False} 80 isU x 81 = case x of {UpperLim _ -> True; _ -> False} 82 isS x 83 = case x of {ScaleUp _ -> True; _ -> False} 84 in 85 if ForceAll `notElem` flags 86 then setting_info ++ result 87 else 88 if typedTree == typedTree && 89 typeDAR == typeDAR && 90 simplestTEnv == simplestTEnv && 91 freeVars == freeVars && 92 builtins == builtins && 93 dataDefs == dataDefs && 94 flags == flags && 95 table == table 96 then setting_info ++ result 97 else panic "saMain: Forcing failed." 98 99 100 101 -- ==========================================================-- 102 -- 103 saSettingInfo :: Int -> Int -> Int -> Int -> Int -> Bool -> Bool -> String 104 105 saSettingInfo pLim mLim lLim uLim sRat mindless_inv use_baraki 106 = "\n================\n" ++ 107 "=== Settings ===\n" ++ 108 "================\n" ++ 109 "\nScaleup ratio = " ++ show sRat ++ "/10" ++ 110 "\nLower lattice size limit = " ++ show lLim ++ 111 "\nUpper lattice size limit = " ++ show uLim ++ 112 (if use_baraki then 113 --"\nMonomorphic generalisation limit = " ++ show mLim ++ 114 "\nPolymorphic generalisation limit = " ++ show pLim 115 else 116 "\nNot using Gebreselassie Baraki's generalisation technique.") ++ 117 (if mindless_inv then 118 "\nUsing inefficient inverses" else "") 119 ++ "\n\n\n" ++ 120 "==================\n" ++ 121 "=== Strictness ===\n" ++ 122 "==================\n" 123 124 125 126 -- ==========================================================-- 127 -- 128 saGroups :: StaticComponent -> 129 AList Naam (HExpr Naam) -> 130 DefnGroup (Naam, AnnExpr Naam DExpr) -> 131 [SAInfo] 132 133 saGroups statics beta [] = [] 134 135 {- New Idea. (or a return to an old idea?) 136 Instead of remaking the HExpr's from the AnnExpr's on every 137 fixpointing iteration, just do it at the start, and during fixpointing 138 allow the system to plug in the appropriate current values. This 139 saves a lot of wasted effort and also allows us to do some 140 optimisations on the HExpr's immediately after they are created. 141 Assumption: in a recursive fn, all calls to self are done at the 142 basic instance. 143 -} 144 145 {- Non recursive function binding. 146 =============================== 147 148 The current beta will contain bindings for all functions 149 preceding this one. This fn does not call itself, so we 150 chuck it into "sa" with beta as it is, supplying none of the 151 free vars. Then optimise it. Then knock it into a 152 frontier representation. 153 -} 154 155 saGroups statics beta ((False, [(defname, defrhs)]): rest) 156 = let hrhs 157 = siVectorise (optFunc (sa statics beta defrhs)) 158 defDexpr 159 = utSureLookup (utSCdexprs statics) "sa(1)" defname 160 defDomain 161 = saCAFkludge (utSureLookup (utSCdomains statics) "sa(2)" defname) 162 optFunc 163 = if Simp `elem` utSCflags statics then siSimplify else id 164 show_hexprs 165 = ShowHExpr `elem` utSCflags statics 166 callSearchResult 167 = saNonRecStartup statics defname defDomain hrhs 168 route 169 = saGetResult (last callSearchResult) 170 betaAug 171 = [(defname, HPoint route)] 172 restInfo 173 = saGroups statics (betaAug++beta) rest 174 in 175 (if show_hexprs then [SAHExpr defname hrhs] else []) 176 ++ 177 callSearchResult 178 ++ 179 restInfo 180 181 182 {- Recursive function binding. 183 =========================== 184 185 This is not so simple. As before, beta as supplied contains 186 bindings for all functions preceding this group. When we call 187 "sa", we cannot substitute anything for recursive calls because 188 this needs to be done dynamically by the fixpointer. So again, we 189 call "sa" with beta as supplied, then stuff the resultants through 190 the optimiser. 191 192 Subsequently we make up some initial approximations for these things 193 and hand over the problem to the fixpointer. 194 -} 195 196 saGroups statics beta ((True, defs):rest) 197 = let defNames 198 = map first defs 199 defRhss 200 = map second defs 201 hrhss 202 = map (siVectorise.optFunc.sa statics beta) defRhss 203 defDexprs 204 = map (utSureLookup (utSCdexprs statics) "sa(3)") defNames 205 defDomains 206 = map (utSureLookup (utSCdomains statics) "sa(4)") defNames 207 callFixResult 208 = saFixStartup statics defNames 209 (map saCAFkludge defDomains) hrhss 210 fixpoints 211 = map saGetResult (filter saIsResult callFixResult) 212 betaAug 213 = myZip2 defNames (map HPoint fixpoints) 214 optFunc 215 = if Simp `elem` utSCflags statics then siSimplify else id 216 show_hexprs 217 = ShowHExpr `elem` utSCflags statics 218 restinfo 219 = saGroups statics (betaAug++beta) rest 220 in 221 (if show_hexprs then myZipWith2 SAHExpr defNames hrhss else []) 222 ++ 223 callFixResult 224 ++ 225 restinfo 226 227 228 229 -- ==========================================================-- 230 -- 231 saFixStartup :: StaticComponent -> 232 [Naam] -> -- names of fns in groups 233 [Domain] -> -- final domains of functions 234 [HExpr Naam] -> -- trees 235 [SAInfo] 236 saFixStartup 237 statics 238 names 239 domains 240 trees 241 = 242 let 243 final_arg_dss 244 = map saGetArgs domains 245 (poly_limit, mono_limit, low_limit, high_limit, scale_ratio) 246 = utSClims statics 247 sequence 248 = slMakeSequence (utSCsizes statics) scale_ratio 249 final_arg_dss low_limit high_limit 250 init_arg_dss 251 = map second (saGetNextRec sequence) 252 targ_ds 253 = map saGetRes domains 254 init_domains 255 = myZipWith2 saMkFunc init_arg_dss targ_ds 256 final_domains 257 = myZipWith2 saMkFunc final_arg_dss targ_ds 258 safe_and_live_bottoms 259 = map avBottomR init_domains 260 result 261 = saFixMain statics 262 names 263 sequence 264 init_arg_dss 265 targ_ds 266 final_arg_dss 267 safe_and_live_bottoms 268 safe_and_live_bottoms 269 trees 270 0 271 local_commentary 272 = saMakeSizeInfo sequence names 273 in 274 local_commentary 275 ++ 276 result 277 278 279 280 -- ==========================================================-- 281 -- 282 saNonRecStartup :: StaticComponent -> 283 Naam -> -- name of fn 284 Domain -> -- final domain of function 285 HExpr Naam -> -- tree 286 [SAInfo] 287 saNonRecStartup 288 statics 289 name 290 domain 291 tree 292 = 293 let 294 final_arg_ds 295 = saGetArgs domain 296 (poly_limit, mono_limit, low_limit, high_limit, scale_ratio) 297 = utSClims statics 298 sequence 299 = slMakeSequence (utSCsizes statics) scale_ratio 300 [final_arg_ds] low_limit high_limit 301 init_arg_ds 302 = second (saGetNextNonRec sequence) 303 targ_d 304 = saGetRes domain 305 init_domain 306 = saMkFunc init_arg_ds targ_d 307 final_domains 308 = saMkFunc final_arg_ds targ_d 309 max0_init_safe 310 = avBottomR init_domain 311 min1_init_live 312 = avTopR init_domain 313 local_commentary 314 = saMakeSizeInfo sequence [name] 315 result 316 = saNonRecSearch statics 317 name 318 sequence 319 init_arg_ds 320 targ_d 321 final_arg_ds 322 max0_init_safe 323 min1_init_live 324 tree 325 in 326 local_commentary 327 ++ 328 result 329 330 331 332 -- ==========================================================-- 333 -- 334 saNonRecSearch :: StaticComponent -> 335 Naam -> -- name of fn 336 Sequence -> -- sequence 337 [Domain] -> -- prev arg domains 338 Domain -> -- target domain 339 [Domain] -> -- final arg domains 340 Route -> -- max1 initialiser 341 Route -> -- min0 initialiser 342 HExpr Naam -> -- the tree 343 [SAInfo] 344 saNonRecSearch 345 statics 346 name 347 sequence 348 old_arg_ds 349 targ_d 350 final_arg_ds 351 old_safe_abstraction 352 old_live_abstraction 353 tree 354 = 355 let 356 finished_after_this_search 357 = saSequenceIsEmpty (saGetSeqTail sequence) 358 given_up_early 359 = saGivenUpEarly sequence 360 (size, curr_arg_ds) 361 = saGetNextNonRec sequence 362 given_up_early_result 363 = head (saFinalExpansion statics 364 [final_domain] 365 [old_domain] 366 [old_safe_abstraction]) 367 done_result 368 = if given_up_early 369 then [SAGiveUp [name], 370 SAResult name final_domain given_up_early_result] 371 else [SAResult name final_domain next_safe] 372 curr_domain 373 = saMkFunc curr_arg_ds targ_d 374 final_domain 375 = saMkFunc final_arg_ds targ_d 376 old_domain 377 = saMkFunc old_arg_ds targ_d 378 curr_safe_initialiser 379 = acConc Live curr_domain old_domain old_safe_abstraction {-Live safe-} 380 curr_live_initialiser 381 = acConc Safe curr_domain old_domain old_live_abstraction {-Safe live-} 382 (next_safe, next_safe_evals) 383 = fsMakeFrontierRep Safe False 384 tree 385 curr_domain 386 final_arg_ds 387 curr_live_initialiser 388 curr_safe_initialiser 389 (next_live, next_live_evals) 390 = fsMakeFrontierRep Live False 391 tree 392 curr_domain 393 final_arg_ds 394 curr_live_initialiser 395 curr_safe_initialiser 396 local_commentary 397 = [SASearch Safe name size next_safe_evals, 398 SASearch Live name size next_live_evals] 399 not_done_result 400 = saNonRecSearch statics 401 name 402 (saGetSeqTail sequence) 403 curr_arg_ds 404 targ_d 405 final_arg_ds 406 next_safe 407 next_live 408 tree 409 in 410 if finished_after_this_search 411 then local_commentary ++ done_result 412 else local_commentary ++ not_done_result 413 414 415 416 -- ==========================================================-- 417 -- 418 saFixMain :: StaticComponent -> 419 [Naam] -> -- names of fns in group 420 Sequence -> -- expansion sequence for each function 421 [[Domain]] -> -- previous argument domains 422 [Domain] -> -- target domains of functions 423 [[Domain]] -> -- final argument domains 424 [Route] -> -- safe abstractions in a previous lattice 425 [Route] -> -- live abstractions in a previous lattice 426 [HExpr Naam] -> -- trees 427 Int -> 428 [SAInfo] -- final result ?!?! 429 430 saFixMain 431 statics 432 names 433 sequences 434 prev_arg_dss 435 targ_ds 436 final_arg_dss 437 prev_safe 438 prev_live 439 trees 440 lev 441 = 442 let 443 finished 444 = saSequenceIsEmpty sequences 445 gave_up_early 446 = saGivenUpEarly sequences 447 curr_arg_dss 448 = map second (saGetNextRec sequences) 449 sizes_here 450 = map first (saGetNextRec sequences) 451 prev_domains 452 = myZipWith2 saMkFunc prev_arg_dss targ_ds 453 curr_domains 454 = myZipWith2 saMkFunc curr_arg_dss targ_ds 455 curr_safe 456 = myZipWith3 (acConc Safe) curr_domains prev_domains prev_safe 457 curr_live 458 = myZipWith3 (acConc Live) curr_domains prev_domains prev_live 459 max0_init 460 = curr_live 461 --myZipWith3 (acConc Live) 462 --curr_domains prev_domains prev_live {-Live safe-} 463 min1_init 464 = curr_safe 465 --myZipWith3 (acConc Safe) 466 --curr_domains prev_domains prev_safe {-Safe live-} 467 thisSizeInfo 468 = saFixAtSizeLive statics 469 curr_live 470 names 471 curr_domains 472 final_arg_dss 473 targ_ds 474 trees 475 min1_init 476 max0_init 477 sizes_here 478 lev 479 (safe_fixes_at_this_size, live_fixes_at_this_size) 480 = case last thisSizeInfo of SASL ss ls -> (ss, ls) 481 final_domains 482 = myZipWith2 saMkFunc final_arg_dss targ_ds 483 finished_result 484 = (if gave_up_early then [SAGiveUp names] else []) ++ 485 myZipWith3 SAResult names final_domains 486 (if gave_up_early 487 then finished_fixes_gave_up_early 488 else prev_safe) 489 finished_fixes_gave_up_early 490 = saFinalExpansion statics 491 final_domains 492 prev_domains 493 prev_safe 494 not_finished_result 495 = init thisSizeInfo ++ 496 saFixMain statics 497 names 498 (saGetSeqTail sequences) 499 curr_arg_dss 500 targ_ds 501 final_arg_dss 502 safe_fixes_at_this_size 503 live_fixes_at_this_size 504 trees 505 (lev+1) 506 in 507 if finished 508 then finished_result 509 else not_finished_result 510 511 512 513 -- ==========================================================-- 514 -- 515 saFixAtSizeLive :: StaticComponent -> 516 [Route] -> -- live abstractions 517 [Naam] -> -- names of fns in group 518 [Domain] -> -- current domains of functions 519 [[Domain]] -> -- arg domains at full size 520 [Domain] -> -- target domains 521 [HExpr Naam] -> -- the trees 522 [Route] -> -- safe min1 inits (const for this latt) 523 [Route] -> -- live max0 inits (const for this latt) 524 [Int] -> -- size of arg lattices 525 Int -> 526 [SAInfo] -- safe and live abstractions of fixpoint 527 saFixAtSizeLive 528 statics 529 live_abstractions 530 names 531 curr_domains 532 big_argdss 533 targ_ds 534 trees 535 min1_init 536 max0_init 537 sizes 538 lev 539 = 540 let 541 big_domains 542 = myZipWith2 saMkFunc big_argdss targ_ds 543 big_live_abstractions 544 = myZipWith3 (acConc Live) big_domains curr_domains live_abstractions 545 curr_live_beta 546 = myZip2 names big_live_abstractions 547 trees_live 548 = map (saHSubst curr_live_beta) trees 549 next_live_with_evals 550 = myZipWith5 (fsMakeFrontierRep Live (lev==0)) 551 trees_live 552 curr_domains 553 big_argdss 554 min1_init 555 live_abstractions --max0_init 556 (next_live, next_live_evals) 557 = unzip2 next_live_with_evals 558 got_fixed_point 559 = myAndWith2 (\a b -> a == b) next_live live_abstractions 560 fixed_point_result 561 = work_here_commentary ++ 562 saFixAtSizeSafe statics 563 next_live 564 next_live 565 names 566 curr_domains 567 big_argdss 568 targ_ds 569 trees 570 min1_init 571 max0_init 572 sizes 573 lev 574 work_here_commentary 575 = myZipWith3 (SASearch Live) names sizes next_live_evals 576 not_fixed_point_result 577 = work_here_commentary ++ 578 saFixAtSizeLive statics 579 next_live 580 names 581 curr_domains 582 big_argdss 583 targ_ds 584 trees 585 min1_init 586 max0_init 587 sizes 588 lev 589 in 590 if got_fixed_point 591 then fixed_point_result 592 else not_fixed_point_result 593 594 595 596 -- ==========================================================-- 597 -- 598 saFixAtSizeSafe :: StaticComponent -> 599 [Route] -> -- safe abstractions 600 [Route] -> -- live abstractions 601 [Naam] -> -- names of fns in group 602 [Domain] -> -- current domains of functions 603 [[Domain]] -> -- arg domains at full size 604 [Domain] -> -- target domains 605 [HExpr Naam] -> -- the trees 606 [Route] -> -- safe min1 inits (const for this latt) 607 [Route] -> -- live max0 inits (const for this latt) 608 [Int] -> -- size of arg lattices 609 Int -> 610 [SAInfo] -- safe and live abstractions of fixpoint 611 saFixAtSizeSafe 612 statics 613 safe_abstractions 614 live_fixes 615 names 616 curr_domains 617 big_argdss 618 targ_ds 619 trees 620 min1_init 621 max0_init 622 sizes 623 lev 624 = 625 let 626 big_domains 627 = myZipWith2 saMkFunc big_argdss targ_ds 628 big_safe_abstractions 629 = myZipWith3 (acConc Safe) big_domains curr_domains safe_abstractions 630 curr_safe_beta 631 = myZip2 names big_safe_abstractions 632 trees_safe 633 = map (saHSubst curr_safe_beta) trees 634 next_safe_with_evals 635 = myZipWith5 (fsMakeFrontierRep Safe (lev==0)) 636 trees_safe 637 curr_domains 638 big_argdss 639 min1_init --safe_abstractions 640 safe_abstractions --live_fixes --max0_init 641 (next_safe, next_safe_evals) 642 = unzip2 next_safe_with_evals 643 got_fixed_point 644 = myAndWith2 (\a b -> a == b) next_safe safe_abstractions 645 fixed_point_result 646 = work_here_commentary ++ 647 [SASL safe_abstractions live_fixes] 648 work_here_commentary 649 = myZipWith3 (SASearch Safe) names sizes next_safe_evals 650 not_fixed_point_result 651 = work_here_commentary ++ 652 saFixAtSizeSafe statics 653 next_safe 654 live_fixes 655 names 656 curr_domains 657 big_argdss 658 targ_ds 659 trees 660 min1_init 661 max0_init 662 sizes 663 lev 664 in 665 if got_fixed_point 666 then fixed_point_result 667 else not_fixed_point_result 668 669 670 671 -- ==========================================================-- 672 -- 673 saFinalExpansion :: StaticComponent -> 674 [Domain] -> 675 [Domain] -> 676 [Route] -> 677 [Route] 678 saFinalExpansion 679 statics 680 final_domains 681 curr_domains 682 safe_abstractions 683 = 684 let 685 use_baraki 686 = False --NoBaraki `notElem` (utSCflags statics) 687 (poly_limit, mono_limit, lower_limit, upper_limit, scale_ratio) 688 = utSClims statics 689 (dexprs, dsubsts) 690 = unzip2 (myZipWith2 dxDiff final_domains curr_domains) 691 result 692 = myZipWith3 (bcMakeInstance use_baraki mono_limit Safe) 693 dexprs dsubsts safe_abstractions 694 in 695 result 696 697 698 -- ==========================================================-- 699 -- 700 saIsResult :: SAInfo -> Bool 701 702 saIsResult (SAResult _ _ _) = True 703 saIsResult anyElse = False 704 705 saGetResult (SAResult name domain route) = route 706 707 708 -- ==========================================================-- 709 -- 710 saPrinter :: StaticComponent -> Bool -> SAInfo -> [Char] 711 712 saPrinter statics mi (SAResult name domain route) 713 = prPrintFunction mi statics name (domain, route) 714 715 saPrinter statics mi (SASearch mode name size n) 716 = "Evaluated at size " ++ 717 rjustify 7 (show size) ++ 718 " using " ++ 719 rjustify 4 (show n) ++ 720 " evals " ++ 721 (case mode of {Safe -> "safe"; Live -> "live"}) ++ 722 " \"" ++ name ++ "\"\n" 723 724 saPrinter statics mi (SASizes name useSizes noUseSizes) 725 = "\nDomains for \"" ++ name ++ "\" are\n" ++ 726 saPrinter_aux True useSizes ++ saPrinter_aux False noUseSizes ++ "\n" 727 728 saPrinter statics mi (SAHExpr name tree) 729 = "\nAbstract tree for \"" ++ name ++ "\" is\n\n" ++ show tree ++ "\n\n" 730 731 saPrinter statics mi (SAGiveUp names) 732 = "Giving up on " ++ 733 interleave " and " (map (\n -> "\"" ++ n ++ "\"") names) ++ 734 ".\n" 735 736 737 saPrinter_aux use [] 738 = "" 739 saPrinter_aux use ((s,ds):sds) 740 = rjustify 8 (show s) ++ " " ++ 741 (if use then " " else "*") ++ " " 742 ++ show ds ++ "\n" ++ saPrinter_aux use sds 743 744 745 -- ==========================================================-- 746 -- 747 saUndoCAFkludge :: [SAInfo] -> [SAInfo] 748 749 saUndoCAFkludge [] 750 = [] 751 saUndoCAFkludge (saInfo:saInfos) 752 = let rest 753 = saUndoCAFkludge saInfos 754 this 755 = case saInfo of 756 SAResult name domain route 757 -> [SAResult name (saCAFkludgeInverse domain) route] 758 SASearch mode name size n 759 -> if size < 2 then [] else [saInfo] 760 SASizes name [(sizes,[])] [] 761 -> [] 762 SASizes name useSizes noUseSizes 763 -> [saInfo] 764 SAHExpr name tree 765 -> [saInfo] 766 SAGiveUp names 767 -> [saInfo] 768 in 769 this ++ rest 770 771 772 -- ==========================================================-- 773 -- 774 saCAFkludge, saCAFkludgeInverse :: Domain -> Domain 775 776 saCAFkludge (Func dss dt) = Func dss dt 777 saCAFkludge non_func_dom = Func [] non_func_dom 778 779 saCAFkludgeInverse (Func [] dt) = dt 780 saCAFkludgeInverse (Func dss dt) = Func dss dt 781 saCAFkludgeInverse non_fn_dom = non_fn_dom 782 783 784 -- ==========================================================-- 785 -- 786 saMkFunc :: [Domain] -> Domain -> Domain 787 788 saMkFunc [] dt = dt 789 saMkFunc dss dt = Func dss dt 790 791 792 -- ==========================================================-- 793 -- 794 saSequenceIsEmpty (use, noUse) = null use 795 saGetNextRec ((u:us), noUse) = u 796 saGetNextNonRec (([u]:us), noUse) = u 797 saGetSeqTail (u:us, noUse) = (us, noUse) 798 saGivenUpEarly (use, noUse) = not (null noUse) 799 800 801 -- ==========================================================-- 802 -- 803 saGetArgs (Func dss dt) = dss 804 saGetRes (Func dss dt) = dt 805 806 807 -- ==========================================================-- 808 -- 809 saMakeSizeInfo :: Sequence -> [Naam] -> [SAInfo] 810 811 saMakeSizeInfo (use, noUse) names 812 = let useT = transpose use 813 noUseT 814 = transpose noUse 815 noUseT2 = (if null noUse then [[] | _ <- useT] else noUseT) 816 in 817 myZipWith3 SASizes names useT noUseT2 818 819 820 -- ==========================================================-- 821 -- 822 saHSubst :: RSubst -> 823 HExpr Naam -> 824 HExpr Naam 825 826 saHSubst fenv (HVar v@('_':_)) = HPoint (utSureLookup fenv "sa(8)" v) 827 saHSubst fenv (HVar v_other) = HVar v_other 828 saHSubst fenv (HApp e1 e2) = HApp (saHSubst fenv e1) (saHSubst fenv e2) 829 saHSubst fenv (HMeet es) = HMeet (map (saHSubst fenv) es) 830 saHSubst fenv (HLam vs e) = HLam vs (saHSubst fenv e) 831 saHSubst fenv (HPoint p) = HPoint p 832 saHSubst fenv (HTable t) = HTable (map2nd (saHSubst fenv) t) 833 saHSubst fenv (HVAp f es) = HVAp (saHSubst fenv f) (map (saHSubst fenv) es) 834 835 836 -- ==========================================================-- 837 -- 838 saMkGroups :: AnnExpr Naam DExpr -> 839 DefnGroup (AnnDefn Naam DExpr) 840 841 saMkGroups (_, ALet rf subdefs rest) = (rf, subdefs):saMkGroups rest 842 saMkGroups (_, anyThingElse ) = [] 843 844 845 -- ==========================================================-- 846 -- The strictness analyser proper: the magic function "S" 847 -- Now rather heavily modified (in version 0.300 and above) 848 -- and no longer bearing much relationship to the original 849 -- mathematics 850 -- 851 sa :: StaticComponent -> 852 AList Naam (HExpr Naam) -> 853 AnnExpr Naam DExpr -> 854 HExpr Naam 855 856 sa statics beta (dtau, AConstr _) 857 = panic "sa: AConstr encountered" 858 859 sa statics beta (dtau, ALet _ _ _) 860 = panic "sa: ALet encountered" 861 862 sa statics beta (dtau, ANum n) 863 = HPoint One 864 865 sa statics beta (dtau, AAp e1 e2) 866 = HApp (sa statics beta e1) (sa statics beta e2) 867 868 sa statics beta (dtau, ALam vs e) 869 = HLam vs (sa statics beta e) 870 871 sa statics beta (dtau, AVar v) 872 {- This is complicated. If it's a constructor, make up the 873 constructor at the right instantiation and put in place. 874 If it's a function which is accounted for in beta, do likewise. 875 If it's a function which is not accounted for in beta, ignore it, 876 since it must be a call to the current recursive group. 877 If it's a variable, look it up in beta, and if it isn't there, 878 just leave alone. Otherwise replace. This allows the 879 case-statement-algorithm to work properly. 880 -} 881 = let isConstructor 882 = isUpper (head v) 883 isVariable 884 = isLower (head v) 885 isFunction 886 = head v == '_' 887 v_dtype_simple 888 = utSureLookup (utSCdexprs statics) "sa(5)" v 889 v_instance 890 = txGetInstantiations v_dtype_simple dtau 891 v_lookup 892 = utLookup beta v 893 accounted_for 894 = case v_lookup of {Just _ -> True; _ -> False} 895 v_lookup_result 896 = case v_lookup of {Just x -> x} 897 v_lookup_point 898 = case v_lookup_result of {HPoint p -> p} 899 use_baraki 900 = NoBaraki `notElem` (utSCflags statics) 901 (pLim, mLim, lLim, uLim, scale_ratio) 902 = utSClims statics 903 f_at_instance 904 = bcMakeInstance use_baraki pLim Safe 905 v_dtype_simple v_instance v_lookup_point 906 mindless_inv 907 = SimpleInv `elem` (utSCflags statics) 908 c_at_instance 909 = coMakeConstructorInstance 910 mindless_inv 911 (utSureLookup (utSCconstrelems statics) "sa(7)" v) 912 v_dtype_simple v_instance 913 in 914 if isConstructor 915 then HPoint c_at_instance 916 else 917 if isVariable && accounted_for 918 then v_lookup_result 919 else 920 if isVariable && not accounted_for 921 then HVar v 922 else 923 if isFunction && accounted_for 924 then HPoint f_at_instance 925 else 926 if isFunction && not accounted_for 927 then HVar v 928 else panic "sa(var)" 929 930 931 932 sa statics beta (dtau, ACase (dtau_sw, expr_sw) alts) 933 {- This is even more complicated. 934 Get all the constructors in case. 935 Make them all up at the relevant instance. 936 Make all the points in dtau_sw. 937 For each one, gather the maxinverses and constructors 938 which give that point. For each of these, make up an 939 environment to augment beta with, "sa" the relevant 940 alternative with that value and HMeet all the values 941 together (yuck). 942 -} 943 = let 944 ---------------------------------------------------------- 945 -- check for special case of case-ing on a known value -- 946 ---------------------------------------------------------- 947 948 caseOfKnownVal 949 = case expr_sw of 950 AVar v_sw -> isLower (head v_sw) && 951 v_sw `elem` map first beta 952 anyElse -> False 953 954 v_sw_pt = case utSureLookup beta "sa(??)" 955 (case expr_sw of AVar v_sw -> v_sw) 956 of HPoint p -> p 957 958 doCaseOpt = NoCaseOpt `notElem` (utSCflags statics) 959 960 mindless_inv = SimpleInv `elem` (utSCflags statics) 961 962 ---------------------------------------------------------- 963 -- to do with domains, and misc stuff -- 964 ---------------------------------------------------------- 965 966 sw_domain = dxApplyDSubst_2 dtau_sw 967 968 all_sw_points = amAllRoutes sw_domain 969 970 dtau_sw_top = avTopR sw_domain 971 972 outDomainBottom = HPoint (avBottomR (dxApplyDSubst_2 dtau)) 973 974 unMkFrel (MkFrel xs) = xs 975 976 ---------------------------------------------------------- 977 -- make a load of info about the alts -- 978 ---------------------------------------------------------- 979 980 constructorNames = map first alts 981 982 constrSimpDTypes = map (utSureLookup (utSCdexprs statics) "sa(9)") 983 constructorNames 984 985 constrSimpDFinal = let getDxt (DXFunc _ dxt) = dxt 986 getDxt other_dx = other_dx 987 in map getDxt constrSimpDTypes 988 989 constrInstances = map (\si -> txGetInstantiations si dtau_sw) 990 constrSimpDFinal 991 992 constrDomains = myZipWith2 dxApplyDSubst 993 constrInstances constrSimpDTypes 994 995 constrCElems = map (utSureLookup (utSCconstrelems statics) "sa(10)") 996 constructorNames 997 998 constrActuals = myZipWith3 (coMakeConstructorInstance mindless_inv) 999 constrCElems constrSimpDTypes constrInstances 1000 1001 conIsCAF con = case con of { Rep _ -> False; _ -> True} 1002 1003 allConstrNumbers = 0 `myIntsFromTo` (length alts - 1) 1004 1005 allAltInfo 1006 = [(constrActuals ## n, -- the constructor itself 1007 constrDomains ## n, -- the constructor's domain 1008 conIsCAF (constrActuals ## n), -- is-a-caf flag 1009 first (second (alts ## n)), -- arguments on this alt 1010 second (second (alts ## n))) -- rhs for this alt 1011 | n <- allConstrNumbers] 1012 1013 ---------------------------------------------------------- 1014 -- the maxInverse of a constructor at a point -- 1015 ---------------------------------------------------------- 1016 1017 maxInvsCon con cd isCAF pt 1018 = if isCAF 1019 then if pt == dtau_sw_top then [[]] else [] 1020 else map unMkFrel (inMaxInverse mindless_inv cd con pt) 1021 1022 ---------------------------------------------------------- 1023 -- make the table mapping switch expression definedness -- 1024 -- to definedness of the entire case expression, OR, -- 1025 -- if we can do case-of-case optimisation, just compute -- 1026 -- rhs-definedness based on the known value (v_sw_pt) -- 1027 -- of the switch expression. -- 1028 ---------------------------------------------------------- 1029 1030 switch_hexpr = sa statics beta (dtau_sw, expr_sw) 1031 1032 result 1033 = if caseOfKnownVal && doCaseOpt 1034 then second (outval v_sw_pt) 1035 else HApp (HTable (map outval all_sw_points)) switch_hexpr 1036 1037 ---------------------------------------------------------- 1038 -- given a value for the switch expression, finds the -- 1039 -- definedness of the entire case expression (outval) -- 1040 ---------------------------------------------------------- 1041 1042 outval r 1043 = (r, aeMkMeet outDomainBottom (concat (map (f r) allConstrNumbers))) 1044 1045 f pt cnum 1046 = let (con, cd, isCAF, params, rhs) = allAltInfo ## cnum 1047 mis = map (map HPoint) (maxInvsCon con cd isCAF pt) 1048 allenvs = map (myZip2 params) mis 1049 doOneRhs :: [(Naam, HExpr Naam)] -> HExpr Naam 1050 doOneRhs env = sa statics (env++beta) rhs 1051 in 1052 (map doOneRhs allenvs) :: [HExpr Naam] 1053 1054 ---------------------------------------------------------- 1055 -- -- 1056 ---------------------------------------------------------- 1057 in 1058 result 1059 1060 1061 -- ==========================================================-- 1062 -- 1063 saMkCargs :: [TypeDef] -> AList Naam [ConstrElem] 1064 1065 saMkCargs [] = [] 1066 saMkCargs ((typename, tvars, calts):rest) 1067 = map doOne calts ++ saMkCargs rest 1068 where 1069 doOne (name, tdefexprs) = (name, map f tdefexprs) 1070 f (TDefVar v) = ConstrVar (find v tvars) 1071 f (TDefCons _ _) = ConstrRec 1072 find v (v2:vs) = if v == v2 then 0 else 1 + find v vs 1073 1074 1075 -- ==========================================================-- 1076 -- === End StrictAn6.hs ===-- 1077 -- ==========================================================--