ref: 619765986b7567051393d4570a00d7643de083f0
dir: /src/MicroHs/Abstract.hs/
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)