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 -- ==========================================================--