ref: 5773add4587d5622aba8ab52c9ea6980bd5ddf6f
parent: de1a985cb74165f0b8689e5ba52391db288e4369
author: Lennart Augustsson <lennart@augustsson.net>
date: Sun Nov 5 12:46:15 EST 2023
Add FNEG primitive.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.1
-1437
-((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _212) ((B _12) _1)) _395))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _394))) ((A :10 (((S' P) _2) (((C' _13) _1) _1179))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _209) _12) _200))) ((A :20 (((S' B) _14) (((C' _212) _12) _201))) ((A :21 _1264) ((A :22 ((B _1305) _21)) ((A :23 (((S' _1305) _21) I)) ((A :24 _1234) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1263) ((C _199) _26))) ((A :28 (((C' _27) ((_208 _1275) _111)) ((_199 (_34 _1277)) _110))) ((A :29 ((B ((S _1305) (_34 _1277))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _394)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _395)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1179)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1179))) ((A :46 ((C _43) _200)) ((A :47 ((B _202) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _202) _48)) ((A :50 T) ((A :51 ((_207 ((B (B (_197 _50))) ((B ((C' C) _54)) (B P)))) (_211 _51))) ((A :52 (((((_11 _51) ((B (_197 _50)) P)) (_38 _53)) ((B (B (_197 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_197 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_199 _467)) _54)) ((A :56 ((B (_197 _50)) (B (P _1179)))) ((A :57 ((B (_197 _50)) (BK (P _1179)))) ((A :58 ((_197 _50) ((S P) I))) ((A :59 ((B (_197 _50)) ((C (S' P)) I))) ((A :60 ((_137 ((C ((C S') _65)) I)) (_141 _60))) ((A :61 (((_1408 (K ((P (_1417 "False")) (_1417 "True")))) (_1413 _61)) (_1414 _61))) ((A :62 ((_69 _67) _68)) ((A :63 (R _68)) ((A :64 (T _67)) ((A :65 ((P _68) _67)) ((A :66 _68) ((A :67 K) ((A :68 A) ((A :69 P) ((A :70 (T K)) ((A :71 (T A)) ((A :72 (K (noDefault "Bounded.minBound"))) ((A :73 (K (noDefault "Bounded.maxBound"))) ((A :74 ((_137 _1228) _1229)) ((A :75 ((((((((_427 _74) (_436 _75)) _1230) _1231) _1232) _1233) (_441 _75)) (_442 _75))) ((A :76 ((_137 _1238) (_141 _76))) ((A :77 ((((((((_427 _76) _1237) (((C' (C' (_138 _443))) _1237) _447)) (((C' (C' (_139 _443))) _1237) _449)) (((C' (C' (_138 _443))) _1237) _449)) (((C' (C' (_139 _443))) _1237) _449)) (_441 _77)) (_442 _77))) ((A :78 ((_69 (_79 #0)) (_79 #127))) ((A :79 _1239) ((A :80 _1240) ((A :81 (((S' _64) (_1231 #97)) ((C _1231) #122))) ((A :82 (((S' _64) (_1231 #65)) ((C _1231) #90))) ((A :83 (((S' _63) _81) _82)) ((A :84 (((S' _64) (_1231 #48)) ((C _1231) #57))) ((A :85 (((S' _63) _84) (((S' _63) (((S' _64) (_1231 #97)) ((C _1231) #102))) (((S' _64) (_1231 #70)) ((C _1231) #70))))) ((A :86 (((S' _63) _83) _84)) ((A :87 (((S' _64) (_1231 #32)) ((C _1231) #126))) ((A :88 (((S' _63) ((C (_138 _74)) #32)) (((S' _63) ((C (_138 _74)) #9)) ((C (_138 _74)) #10)))) ((A :89 ((S ((S (((S' _64) (_1231 #48)) ((C _1231) #57))) ((S ((S (((S' _64) (_1231 #97)) ((C _1231) #102))) ((S ((C (((S' _64) (_1231 #65)) ((C _1231) #70))) (_24 "digitToInt"))) (((C' (_413 _213)) _80) (((_413 _213) (_80 #65)) #10))))) (((C' (_413 _213)) _80) (((_413 _213) (_80 #97)) #10))))) (((C' (_413 _213)) _80) (_80 #48)))) ((A :90 ((S ((S (((S' _64) (_1231 #65)) ((C _1231) #90))) (_68 (((noMatch "lib/Data/Char.hs") #82) #9)))) ((B _79) ((
\ No newline at end of file
+1538
+((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _271) ((B _12) _1)) _454))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _453))) ((A :10 (((S' P) _2) (((C' _13) _1) _1279))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _268) _12) _259))) ((A :20 (((S' B) _14) (((C' _271) _12) _260))) ((A :21 _1365) ((A :22 ((B _1406) _21)) ((A :23 (((S' _1406) _21) I)) ((A :24 _1335) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1364) ((C _258) _26))) ((A :28 (((C' _27) ((_267 _1376) _170)) ((_258 (_34 _1378)) _169))) ((A :29 ((B ((S _1406) (_34 _1378))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _453)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _454)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1279)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1279))) ((A :46 ((C _43) _259)) ((A :47 ((B _261) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _261) _48)) ((A :50 T) ((A :51 ((_266 ((B (B (_256 _50))) ((B ((C' C) _54)) (B P)))) (_270 _51))) ((A :52 (((((_11 _51) ((B (_256 _50)) P)) (_38 _53)) ((B (B (_256 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_256 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_258 _557)) _54)) ((A :56 ((B (_256 _50)) (B (P _1279)))) ((A :57 ((B (_256 _50)) (BK (P _1279)))) ((A :58 ((_256 _50) ((S P) I))) ((A :59 ((B (_256 _50)) ((C (S' P)) I))) ((A :60 ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C))))))))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C)))))))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C))))))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C)))))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C))))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C)))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B C)))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B C))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B C)))))))))))) ((B (B (B (B (B (B (B (B (B (B (B C))))))))))) ((B (B (B (B (B (B (B (B (B (B C)))))))))) ((B (B (B (B (B (B (B (B (B C))))))))) ((B (B (B (B (B (B (B (B C)))))))) ((B (B (B (B (B (B (B C))))))) ((B (B (B (B (B (B C)))))) ((B (B (B (B (B C))))) ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P))))))))))))))))))))) ((A :61 (T (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :62 (T (K (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :63 (T (K (K (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :64 (T (K (K (K (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :65 (T (K (K (K (K (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :66 (T (K (K (K (K (K (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :67 (T (K (K (K (K (K (K (BK (BK (BK (BK (BK (BK (BK (BK
\ No newline at end of file
--- a/lib/Data/Double.hs
+++ b/lib/Data/Double.hs
@@ -22,6 +22,7 @@
(+) = primDoubleAdd
(-) = primDoubleSub
(*) = primDoubleMul
+ negate = primDoubleNeg
abs x = if x < 0.0 then negate x else x
signum x =
case compare x 0.0 of
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -45,6 +45,8 @@
primDoubleMul = primitive "fmul"
primDoubleDiv :: Double -> Double -> Double
primDoubleDiv = primitive "fdiv"
+primDoubleNeg :: Double -> Double
+primDoubleNeg = primitive "fneg"
primDoubleEQ :: Double -> Double -> Bool
primDoubleEQ = primitive "feq"
primDoubleNE :: Double -> Double -> Bool
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -147,11 +147,11 @@
#define ERR(s) do { fprintf(stderr, "ERR: %s\n", s); exit(1); } while(0)-enum node_tag { T_FREE, T_IND, T_AP, T_INT, T_DOUBLE, T_HDL, T_S, T_K, T_I, T_B, T_C,+enum node_tag { T_FREE, T_IND, T_AP, T_INT, T_DBL, T_HDL, T_S, T_K, T_I, T_B, T_C,T_A, T_Y, T_SS, T_BB, T_CC, T_P, T_R, T_O, T_T, T_BK,
T_ADD, T_SUB, T_MUL, T_QUOT, T_REM, T_SUBR, T_UQUOT, T_UREM, T_NEG,
T_AND, T_OR, T_XOR, T_INV, T_SHL, T_SHR, T_ASHR,
- T_FADD, T_FSUB, T_FMUL, T_FDIV, T_ITOF,
+ T_FADD, T_FSUB, T_FMUL, T_FDIV, T_FNEG, T_ITOF,
T_FEQ, T_FNE, T_FLT, T_FLE, T_FGT, T_FGE, T_FSHOW, T_FREAD,
T_FTORAW, T_FFROMRAW,
T_EQ, T_NE, T_LT, T_LE, T_GT, T_GE, T_ULT, T_ULE, T_UGT, T_UGE,
@@ -191,9 +191,9 @@
#define GETVALUE(p) (p)->u.value
// to squeeze a double into value_t we must exactly copy and read the bits
// this is a stm, and not an exp
-#define GETDOUBLEVALUE(p) (p)->u.doublevalue
+#define GETDBLVALUE(p) (p)->u.doublevalue
#define SETVALUE(p,v) (p)->u.value = v
-#define SETDOUBLEVALUE(p,v) (p)->u.doublevalue = v
+#define SETDBLVALUE(p,v) (p)->u.doublevalue = v
#define FUN(p) (p)->u.s.fun
#define ARG(p) (p)->u.s.arg
#define NEXT(p) FUN(p)
@@ -225,9 +225,9 @@
#define GETTAG(p) ((p)->ufun.uutag & 1 ? (int)((p)->ufun.uutag >> 1) : T_AP)
#define SETTAG(p,t) do { if (t != T_AP) (p)->ufun.uutag = ((t) << 1) + 1; } while(0)#define GETVALUE(p) (p)->uarg.uuvalue
-#define GETDOUBLEVALUE(p) (p)->uarg.uudoublevalue
+#define GETDBLVALUE(p) (p)->uarg.uudoublevalue
#define SETVALUE(p,v) (p)->uarg.uuvalue = v
-#define SETDOUBLEVALUE(p,v) (p)->uarg.uudoublevalue = v
+#define SETDBLVALUE(p,v) (p)->uarg.uudoublevalue = v
#define FUN(p) (p)->ufun.uufun
#define ARG(p) (p)->uarg.uuarg
#define STR(p) (p)->uarg.uustring
@@ -662,6 +662,7 @@
{ "fsub" , T_FSUB}, { "fmul" , T_FMUL}, { "fdiv", T_FDIV},+ { "fneg", T_FNEG}, { "itof", T_ITOF}, { "feq", T_FEQ}, { "fne", T_FNE},@@ -1352,7 +1353,7 @@
fputc(')', f);break;
case T_INT: fprintf(f, "#%"PRIvalue, GETVALUE(n)); break;
- case T_DOUBLE: fprintf(f, "%%%f", GETDOUBLEVALUE(n)); break;
+ case T_DBL: fprintf(f, "%%%f", GETDBLVALUE(n)); break;
case T_STR:
{const char *p = STR(n);
@@ -1413,6 +1414,7 @@
case T_FSUB: fprintf(f, "fsub"); break;
case T_FMUL: fprintf(f, "fmul"); break;
case T_FDIV: fprintf(f, "fdiv"); break;
+ case T_FNEG: fprintf(f, "fneg"); break;
case T_ITOF: fprintf(f, "itof"); break;
case T_FEQ: fprintf(f, "feq"); break;
case T_FNE: fprintf(f, "fne"); break;
@@ -1511,8 +1513,8 @@
mkDouble(double d)
{NODEPTR n;
- n = alloc_node(T_DOUBLE);
- SETDOUBLEVALUE(n, d);
+ n = alloc_node(T_DBL);
+ SETDBLVALUE(n, d);
return n;
}
@@ -1599,16 +1601,16 @@
/* Evaluate to a Double */
static inline double
-evaldouble(NODEPTR n)
+evaldbl(NODEPTR n)
{n = evali(n);
#if SANITY
- if (GETTAG(n) != T_DOUBLE) {+ if (GETTAG(n) != T_DBL) {fprintf(stderr, "bad tag %d\n", GETTAG(n));
- ERR("evaldouble");+ ERR("evaldbl");}
#endif
- return GETDOUBLEVALUE(n);
+ return GETDBLVALUE(n);
}
/* Evaluate to a T_HDL */
@@ -1791,16 +1793,18 @@
#define CHKARGEV1(e) do { CHECK(1); x = ARG(TOP(0)); e; POP(1); n = TOP(-1); } while(0) #define SETINT(n,r) do { SETTAG((n), T_INT); SETVALUE((n), (r)); } while(0)-#define SETDOUBLE(n,d) do { SETTAG((n), T_DOUBLE); SETDOUBLEVALUE((n), (d)); } while(0)+#define SETDBL(n,d) do { SETTAG((n), T_DBL); SETDBLVALUE((n), (d)); } while(0) #define OPINT1(e) do { CHECK(1); xi = evalint(ARG(TOP(0))); e; POP(1); n = TOP(-1); } while(0); #define OPINT2(e) do { CHECK(2); xi = evalint(ARG(TOP(0))); yi = evalint(ARG(TOP(1))); e; POP(2); n = TOP(-1); } while(0);-#define OPDOUBLE2(e) do { CHECK(2); xd = evaldouble(ARG(TOP(0))); yd = evaldouble(ARG(TOP(1))); e; POP(2); n = TOP(-1); } while(0);+#define OPDBL1(e) do { CHECK(1); xd = evaldbl(ARG(TOP(0))); e; POP(1); n = TOP(-1); } while(0);+#define OPDBL2(e) do { CHECK(2); xd = evaldbl(ARG(TOP(0))); yd = evaldbl(ARG(TOP(1))); e; POP(2); n = TOP(-1); } while(0); #define ARITHUN(op) do { OPINT1(r = op xi); SETINT(n, r); RET; } while(0) #define ARITHBIN(op) do { OPINT2(r = xi op yi); SETINT(n, r); RET; } while(0) #define ARITHBINU(op) do { OPINT2(r = (value_t)((uvalue_t)xi op (uvalue_t)yi)); SETINT(n, r); RET; } while(0)-#define FARITHBIN(op) do { OPDOUBLE2(rd = xd op yd); SETDOUBLE(n, rd); RET; } while(0) // TODO FIXME+#define FARITHUN(op) do { OPDBL1(rd = op xd); SETDBL(n, rd); RET; } while(0)+#define FARITHBIN(op) do { OPDBL2(rd = xd op yd); SETDBL(n, rd); RET; } while(0) #define CMP(op) do { OPINT2(r = xi op yi); GOIND(r ? combTrue : combFalse); } while(0)-#define CMPF(op) do { OPDOUBLE2(r = xd op yd); GOIND(r ? combTrue : combFalse); } while(0)+#define CMPF(op) do { OPDBL2(r = xd op yd); GOIND(r ? combTrue : combFalse); } while(0) #define CMPU(op) do { OPINT2(r = (uvalue_t)xi op (uvalue_t)yi); GOIND(r ? combTrue : combFalse); } while(0) for(;;) {@@ -1830,7 +1834,7 @@
case T_STR: GCCHECK(strNodes(strlen(STR(n)))); GOIND(mkStringC(STR(n)));
case T_INT: RET;
- case T_DOUBLE: RET;
+ case T_DBL: RET;
case T_HDL: RET;
case T_S: GCCHECK(2); CHKARG3; GOAP(new_ap(x, z), new_ap(y, z)); /* S x y z = x z (y z) */
@@ -1870,7 +1874,8 @@
case T_FSUB: FARITHBIN(-);
case T_FMUL: FARITHBIN(*);
case T_FDIV: FARITHBIN(/);
- case T_ITOF: OPINT1(rd = (double)xi); SETDOUBLE(n, rd); RET;
+ case T_FNEG: FARITHUN(-);
+ case T_ITOF: OPINT1(rd = (double)xi); SETDBL(n, rd); RET;
case T_FEQ: CMPF(==);
case T_FNE: CMPF(!=);
case T_FLT: CMPF(<);
@@ -1892,7 +1897,7 @@
// check that the double exists
CHECK(1);
// evaluate it
- xd = evaldouble(ARG(TOP(0)));
+ xd = evaldbl(ARG(TOP(0)));
// turn it into a string
char str[30];
/* Using 16 decimals will lose some precision.
@@ -1926,7 +1931,7 @@
CHECK(1);
x = evali(ARG(TOP(0)));
GCCHECK(1);
- y = alloc_node(T_DOUBLE);
+ y = alloc_node(T_DBL);
SETVALUE(y, GETVALUE(x));
POP(1);
n = TOP(-1);
@@ -2229,7 +2234,7 @@
value_t r, x, y;
double rd, xd;
#define INTARG(n) evalint(ARG(TOP(n)))
-#define DBLARG(n) evaldouble(ARG(TOP(n)))
+#define DBLARG(n) evaldbl(ARG(TOP(n)))
#define FFIV(n) CHECKIO(n)
#define FFI(n) CHECKIO(n); GCCHECK(1)
/* This isn't great, but this is MicroHs, so it's good enough. */
--
⑨