module MicroHs.Abstract( compileOpt, ) where import Prelude import MicroHs.Ident import MicroHs.Exp import MicroHs.Expr(Lit(..)) -- -- Used combinators -- * indicates that the implementation uses an indirection -- A indicates allocation in the implementation -- S x y z = x z (y z) A -- K x y = x * -- I x = x * -- B x y z = x (y z) A -- C x y z = x z y A -- S' x y z w = x (y w) (z w) A -- B' x y z w = x y (z w) A -- C' x y z w = x (y w) z A -- A x y = y * -- U x y = y x -- n@(Y x) = x n -- Z x y z = x y -- P x y z = z x y A -- R x y z = y z x A -- O x y z w = w x y A -- data MaybeApp = NotApp | IsApp Exp Exp getApp :: Exp -> MaybeApp getApp ae = case ae of App f a -> IsApp f a _ -> NotApp isPrim :: String -> Exp -> Bool isPrim s ae = case ae of Lit (LPrim ss) -> s == ss _ -> False isK :: Exp -> Bool isK = isPrim "K" isI :: Exp -> Bool isI = isPrim "I" isB :: Exp -> Bool isB = isPrim "B" isC :: Exp -> Bool isC = isPrim "C" isCC :: Exp -> Bool isCC = isPrim "C'" isY :: Exp -> Bool isY = isPrim "Y" isP :: Exp -> Bool isP = isPrim "P" cId :: Exp cId = Lit (LPrim "I") cConst :: Exp cConst = Lit (LPrim "K") cSpread :: Exp cSpread = Lit (LPrim "S") cP :: Exp cP = Lit (LPrim "P") -------------------- compileOpt :: Exp -> Exp compileOpt = improveT . compileExp compileExp :: Exp -> Exp compileExp ae = case ae of App f a -> App (compileExp f) (compileExp a) Lam x a -> abstract x a _ -> ae abstract :: Ident -> Exp -> Exp abstract x ae = case ae of Var y -> if x == y then cId else cK (Var y) App f a -> cS (abstract x f) (abstract x a) Lam y e -> abstract x $ abstract y e Lit _ -> cK ae cK :: Exp -> Exp cK e = App cConst e cS :: Exp -> Exp -> Exp cS a1 a2 = if isK a1 then cId else let r = cS2 a1 a2 in case getApp a1 of NotApp -> r IsApp k1 e1 -> if isK k1 then case getApp a2 of IsApp k2 e2 -> if isK k2 then cK (App e1 e2) else cB e1 a2 NotApp -> if isI a2 then e1 else cB e1 a2 else r cS2 :: Exp -> Exp -> Exp cS2 a1 a2 = case getApp a2 of NotApp -> cS3 a1 a2 IsApp k2 e2 -> if isK k2 then cC a1 e2 else cS3 a1 a2 cS3 :: Exp -> Exp -> Exp cS3 a1 a2 = let r = app2 cSpread a1 a2 in case getApp a1 of NotApp -> r IsApp be1 e2 -> case getApp be1 of NotApp -> r IsApp b1 e1 -> if isB b1 then cSS e1 e2 a2 else r {- --cS e1 e2 | trace ("S (" ++ toString e1 ++ ") (" ++ toString e2 ++ ")") False = undefined cS CK _ = CI -- S K e = I cS (App CK e1) (App CK e2) = cK (App e1 e2) -- S (K e1) (K e2) = K (e1 e2) cS (App CK e1) CI = e1 -- S (K e1) I = e1 cS (App CK e1) e2 = cB e1 e2 -- S (K e1) e2 = B e1 e2 cS e1 (App CK e2) = cC e1 e2 -- S e1 (K e2) = C e1 e2 cS (App (App CB e1) e2) e3 = cSS e1 e2 e3 -- S (B e1 e2) e3 = S' e1 e2 e3 cS e1 e2 = App2 CS e1 e2 -} cC :: Exp -> Exp -> Exp cC a1 e3 = let r = cC2 a1 e3 in case getApp a1 of NotApp -> r IsApp x1 e2 -> case getApp x1 of NotApp -> r IsApp bc e1 -> if isB bc then cCC e1 e2 e3 else if isC bc && isI e1 then app2 cP e2 e3 -- else if isC bc && isC e1 then -- app2 cR e2 e3 else r cC2 :: Exp -> Exp -> Exp cC2 a1 a2 = app2 cFlip a1 a2 {- cC (App (App CB e1) e2) e3 = cCC e1 e2 e3 -- C (B e1 e2) e3 = C' e1 e2 e3 cC (Var op) e2 | Just op' <- lookup op flipOps = App (Var op') e2 -- C op e = flip-op e cC (App (App CC CI) e2) e3 = app2 CP e2 e3 cC (App (App CC CC) e2) e3 = app2 CR e2 e3 cC e1 e2 = app2 CC e1 e2 -} cB :: Exp -> Exp -> Exp cB a1 a2 = let r = cB2 a1 a2 in case getApp a1 of NotApp -> r IsApp cb ck -> if isB cb && isK ck && isP a2 then Lit (LPrim "O") else r cB2 :: Exp -> Exp -> Exp cB2 a1 a2 = let r = cB3 a1 a2 in case getApp a2 of IsApp x1 x2 -> case getApp x1 of IsApp cb ck -> if isY a1 && isB cb && isK ck then x2 else r NotApp -> if isC a1 && isC x1 && isI x2 then cP else r NotApp -> r cB3 :: Exp -> Exp -> Exp cB3 a1 a2 = if isI a1 then a2 else app2 (Lit (LPrim "B")) a1 a2 {- cB (App CB CK) CP = CO -- Cons cB CY (App (App CB CK) e) = e -- B Y (B K e) = e cB CC (App CC CI) = CP -- Pair cB CI e = e -- B I e = e cB e1 e2 = app2 CB e1 e2 -} cSS :: Exp -> Exp -> Exp -> Exp cSS e1 e2 e3 = app3 (Lit (LPrim "S'")) e1 e2 e3 cCC :: Exp -> Exp -> Exp -> Exp cCC e1 e2 e3 = app3 (Lit (LPrim "C'")) e1 e2 e3 improveT :: Exp -> Exp improveT ae = case getApp ae of NotApp -> ae IsApp f a -> let ff = improveT f aa = improveT a in if isK ff && isI aa then Lit (LPrim "A") {- Using I x --> x does not improve things. else if isI ff then aa -} else if isB ff && isK aa then Lit (LPrim "Z") else if isC ff && isI aa then Lit (LPrim "U") else if isB ff && isB aa then Lit (LPrim "B'") else if isC ff && isC aa then Lit (LPrim "R") else if isCC ff && isB aa then Lit (LPrim "C'B") else let def = case getApp aa of IsApp ck e -> if isY ff && isK ck then e else kApp ff aa NotApp -> kApp ff aa in def {- case getApp ff of IsApp xf xa -> if isK xf then xa else def NotApp -> def -} kApp :: Exp -> Exp -> Exp kApp (Lit (LPrim "K")) (App (Lit (LPrim ('K':s))) x) | s == "" = App (Lit (LPrim "K2")) x | s == "2" = App (Lit (LPrim "K3")) x | s == "3" = App (Lit (LPrim "K4")) x kApp f a = App f a {- -- K I --> A -- C I --> T -- B B --> B' -- Y (K e) --> e -- K x y --> x improveT (App f a) = case (improveT f, improveT a) of (CK, CI) -> CA -- (CI, e) -> e (CY, App CK e) -> e -- (App CK e1, e2) -> e1 (e1, e2) -> App e1 e2 improveT e = e -} -------- -- Possible additions -- -- Added: -- R = C C -- R x y z = (C C x y) z = C y x z = y z x -- -- Q = C I -- Q x y z = (C I x y) z = I y x z = y x z -- -- Added: -- Z = B K -- Z x y z = B K x y z = K (x y) z = x y -- -- ZK = Z K -- ZK x y z = Z K x y z = (K x) z = x -- -- C'B = C' B -- C'B x y z w = C' B x y z w = B (x z) y w = x z (y w) -- B (B e) x y z = B e (x y) z = e (x y z) -- -- B' :: (a -> b -> c) -> a -> (d -> b) -> d -> c -- B' k f g x = k f (g x) -- -- Common: -- 817: C' B -- 616: B Z -- 531: C' C -- 352: Z K -- 305: C' S -- -- BZ = B Z -- BZ x y z w = B Z x y z w = Z (x y) z w = x y z -- -- C'C = C' C -- C'C x y z w = C' C x y z w = C (x z) y w = x z w y -- -- C'B P x y z w = P y (x z) w = w y (x z)