ref: 79a65fa8bd327a76d1e6514faf091eb9ec43eae9
parent: c68e543a7fe254cea6222b919148a4269dfbe04f
author: Lennart Augustsson <lennart@augustsson.net>
date: Mon Dec 23 07:08:52 EST 2024
More reductions of partial pplications.
--- a/src/MicroHs/Abstract.hs
+++ b/src/MicroHs/Abstract.hs
@@ -67,6 +67,15 @@
isP :: Exp -> Bool
isP = isPrim "P"
+isZ :: Exp -> Bool
+isZ = isPrim "Z"
+
+isK2 :: Exp -> Bool
+isK2 = isPrim "K2"
+
+isK3 :: Exp -> Bool
+isK3 = isPrim "K3"
+
cId :: Exp
cId = Lit (LPrim "I")
@@ -272,6 +281,12 @@
Lit (LPrim "R")
else if isCC ff && isB aa then
Lit (LPrim "C'B")
+ else if isZ ff && isK aa then
+ Lit (LPrim "K2")
+ else if isZ ff && isK2 aa then
+ Lit (LPrim "K3")
+ else if isZ ff && isK3 aa then
+ Lit (LPrim "K4")
else
let
def =
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -621,7 +621,7 @@
NODEPTR combK, combTrue, combUnit, combCons, combPair;
NODEPTR combCC, combZ, combIOBIND, combIORETURN, combIOCCBIND, combB;
NODEPTR combLT, combEQ, combGT;
-NODEPTR combShowExn, combU, combK2;
+NODEPTR combShowExn, combU, combK2, combK3;
NODEPTR combBININT1, combBININT2, combUNINT1;
NODEPTR combBINDBL1, combBINDBL2, combUNDBL1;
NODEPTR combBINBS1, combBINBS2;
@@ -825,6 +825,7 @@
case T_Z: combZ = n; break;
case T_U: combU = n; break;
case T_K2: combK2 = n; break;
+ case T_K3: combK3 = n; break;
case T_IO_BIND: combIOBIND = n; break;
case T_IO_RETURN: combIORETURN = n; break;
case T_IO_CCBIND: combIOCCBIND = n; break;
@@ -860,6 +861,7 @@
case T_Z: combZ = n; break;
case T_U: combU = n; break;
case T_K2: combK2 = n; break;
+ case T_K3: combK3 = n; break;
case T_IO_BIND: combIOBIND = n; break;
case T_IO_RETURN: combIORETURN = n; break;
case T_IO_CCBIND: combIOCCBIND = n; break;
@@ -3040,8 +3042,8 @@
case T_I: CHKARG1; GOIND(x); /* I x = *x */
case T_Y: CHKARG1; GOAP(x, n); /* n@(Y x) = x n */
case T_B: GCCHECK(1); CHKARG3; GOAP(x, new_ap(y, z)); /* B x y z = x (y z) */
- case T_BB: if (!HASNARGS(4)) { /* 2 or 3 arguments, use B' x y = B (x y) */- GCCHECK(1); CHKARG2; red_bb++; GOAP(combB, new_ap(x, y)); } else {+ case T_BB: if (!HASNARGS(4)) {+ GCCHECK(1); CHKARG2; red_bb++; GOAP(combB, new_ap(x, y)); } else { /* B' x y = B (x y) */GCCHECK(2); CHKARG4; GOAP(new_ap(x, y), new_ap(z, w)); } /* B' x y z w = x y (z w) */
case T_Z: CHKARG3; GOAP(x, y); /* Z x y z = x y */
case T_C: GCCHECK(1); CHKARG3; GOAP(new_ap(x, z), y); /* C x y z = x z y */
@@ -3049,16 +3051,18 @@
case T_P: GCCHECK(1); CHKARG3; GOAP(new_ap(z, x), y); /* P x y z = z x y */
case T_R: GCCHECK(1); CHKARG3; GOAP(new_ap(y, z), x); /* R x y z = y z x */
case T_O: GCCHECK(1); CHKARG4; GOAP(new_ap(w, x), y); /* O x y z w = w x y */
- case T_K2: if (!HASNARGS(3)) { /* 2 arguments, use K2 x y = K x */- CHKARG2; red_k2++; GOAP(combK, x); } else {+ case T_K2: if (!HASNARGS(3)) {+ CHKARG2; red_k2++; GOAP(combK, x); } else { /* K2 x y = K x */CHKARG3; GOIND(x); } /* K2 x y z = *x */
case T_K3: if (!HASNARGS(4)) {- if (HASNARGS(3)) {- CHKARG3; red_k3++; GOAP(combK, x); } else { /* K3 x y z = K x */- CHKARG2; red_k3++; GOAP(combK2, x); }} else { /* K3 x y = K2 x */+ CHKARG2; red_k3++; GOAP(combK2, x); } else { /* K3 x y = K2 x */CHKARG4; GOIND(x); } /* K3 x y z w = *x */
- case T_K4: CHECK(5); POP(5); n = TOP(-1); x = ARG(TOP(-5)); GOIND(x); /* K4 x y z w v = *x */
- case T_CCB: GCCHECK(2); CHKARG4; GOAP(new_ap(x, z), new_ap(y, w)); /* C'B x y z w = x z (y w) */
+ case T_K4: if (!HASNARGS(5)) {+ CHKARG2; red_k4++; GOAP(combK3, x); } else { /* K4 x y = K3 x */+ CHECK(5); POP(5); n = TOP(-1); x = ARG(TOP(-5)); GOIND(x); } /* K4 x y z w v = *x */
+ case T_CCB: if (!HASNARGS(4)) {+ GCCHECK(2); CHKARG3; GOAP(new_ap(combB, new_ap(x, z)), y); } else { /* C'B x y z = B (x z) y */+ GCCHECK(2); CHKARG4; GOAP(new_ap(x, z), new_ap(y, w)); } /* C'B x y z w = x z (y w) */
/*
* Strict primitives require evaluating the arguments before we can proceed.
--- /dev/null
+++ b/tests/PartRed.hs
@@ -1,0 +1,73 @@
+module PartRed where
+import Primitives
+
+k2 :: Int -> Int -> Int -> Int
+k2 x y z = x
+
+f2 :: Int -> Int
+f2 = k2 1 2
+
+k3 :: Int -> Int -> Int -> Int -> Int
+k3 x y z w = x
+
+f3 :: Int -> Int
+f3 = k3 1 2 3
+
+f32 :: Int -> Int -> Int
+f32 = k3 1 2
+
+k4 :: Int -> Int -> Int -> Int -> Int -> Int
+k4 x y z w v = x
+
+f4 :: Int -> Int
+f4 = k4 1 2 3 4
+
+f42 :: Int -> Int -> Int -> Int
+f42 = k4 1 2
+
+f43 :: Int -> Int -> Int
+f43 = k4 1 2 3
+
+
+-----
+
+type S a = (a->a, a->a)
+
+sInt :: S Int
+sInt = (id, primIntNeg)
+
+j :: S a -> (a -> a) -> a -> a
+j d x y = snd d (x y)
+
+k :: (Int -> Int) -> Int -> Int
+k = j sInt
+
+---
+
+c'b :: (Int -> Int -> Int) -> (Int -> Int) -> Int -> Int -> Int
+c'b x y z w = x z (y w)
+
+fc'b :: Int -> Int
+fc'b = c'b primIntAdd primIntNeg 99
+
+main :: IO ()
+main = do
+ cprint k2
+ cprint f2
+ cprint k3
+ cprint f3
+ cprint f32
+ cprint k4
+ cprint f4
+ cprint f42
+ cprint f43
+ --
+ cprint k
+ --
+ cprint c'b
+ cprint fc'b
+
+
+-- C'B x y z = B (x z) y
+-- Z x y = K (x y)
+-- R x y = C y x