1 2 -- ==========================================================-- 3 -- === Simplification of abstract expressions ... ===-- 4 -- === Simplify.hs ===-- 5 -- ==========================================================-- 6 7 module Simplify where 8 import BaseDefs 9 import Utils 10 import MyUtils 11 import AbstractVals2 12 import AbstractEval2 13 import Apply 14 15 -- ==========================================================-- 16 -- 17 siVectorise :: HExpr Naam -> HExpr Naam 18 19 siVectorise (HLam vs1 (HLam vs2 e)) 20 = siVectorise (HLam (vs1++vs2) e) 21 siVectorise (HLam vs e) 22 = HLam vs (siVectorise e) 23 siVectorise (HApp (HTable t) e) 24 = HApp (HTable (map2nd siVectorise t)) (siVectorise e) 25 siVectorise (HApp f a) 26 = case siVectorise f of 27 HVAp fn args -> HVAp fn (args++[siVectorise a]) 28 HPoint p -> HVAp (HPoint p) [siVectorise a] 29 HVar v -> HVAp (HVar v) [siVectorise a] 30 non_vap -> HApp non_vap (siVectorise a) 31 siVectorise h@(HVar _) = h 32 siVectorise h@(HPoint _) = h 33 siVectorise (HMeet es) = HMeet (map siVectorise es) 34 35 36 -- ==========================================================-- 37 -- 38 siSimplify :: HExpr Naam -> HExpr Naam 39 40 siSimplify hexpr 41 = 42 let hexpr_after_one_cycle = siHOpt hexpr 43 in 44 if hexpr == hexpr_after_one_cycle 45 then hexpr 46 else siSimplify hexpr_after_one_cycle 47 48 49 -- ==========================================================-- 50 -- 51 siHOpt :: HExpr Naam -> HExpr Naam 52 53 siHOpt (HMeet es) = siHOpt_meet es 54 siHOpt (HApp h1 h2) = siHOpt_app (siHOpt h1) (siHOpt h2) 55 siHOpt p@(HPoint _) = p 56 siHOpt v@(HVar _) = v 57 siHOpt (HLam vs e) = HLam vs (siHOpt e) 58 siHOpt (HTable t) = HTable (map2nd siHOpt t) 59 60 61 -- ==========================================================-- 62 -- meet-literal simplification 63 -- 64 siHOpt_meet :: [HExpr Naam] -> HExpr Naam 65 66 siHOpt_meet es 67 = let presimplified = map siHOpt es 68 litsplit (lits, nonlits) (HPoint p) = (p:lits, nonlits) 69 litsplit (lits, nonlits) other = (lits, other:nonlits) 70 (lits, nonlits) = foldl litsplit ([],[]) presimplified 71 onelit = foldr1 (\/) lits 72 in 73 if null lits 74 then HMeet presimplified -- can't do anything 75 else if avIsTopR onelit 76 then HPoint onelit 77 else if avIsBottomR onelit 78 then aeMkMeet (HPoint onelit) nonlits 79 else aeMkMeet (HPoint onelit) ((HPoint onelit):nonlits) 80 81 82 -- ==========================================================-- 83 -- case-of-case simplification 84 -- literal-function-applied-to-literal simplification 85 -- 86 siHOpt_app :: HExpr Naam -> HExpr Naam -> HExpr Naam 87 88 siHOpt_app (HTable t) (HPoint p) 89 = siHOpt (utSureLookup t "siHOpt_app" p) 90 91 siHOpt_app (HPoint p1) (HPoint p2) 92 = HPoint (apApply p1 [p2]) 93 94 siHOpt_app h1_other h2_other = HApp h1_other h2_other 95 96 97 -- ==========================================================-- 98 -- === end Simplify.hs ===-- 99 -- ==========================================================--