ref: 85934531635bf5b05a242813c002d7504bdff043
parent: 446865966672cec3cc50835052a06d8c7f62b063
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Fri Sep 22 06:55:26 EDT 2023
Add 'rnf' primitive.
--- a/Makefile
+++ b/Makefile
@@ -68,6 +68,7 @@
$(GHCC) -c lib/Unsafe/Coerce.hs
$(GHCC) -c lib/Data/Integer.hs
$(GHCC) -c lib/Control/Monad/State/Strict.hs
+ $(GHCC) -c lib/Control/DeepSeq.hs
# $(GHCC) -c lib/Debug/Trace.hs
$(GHCC) -c lib/Control/Exception.hs
$(GHCC) -c src/System/Console/SimpleReadline.hs
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.5
-883
-(($A :0 _741) (($A :1 (_0 "undefined")) (($A :2 $I) (($A :3 ((($C' $B) _770) (($C _45) _2))) (($A :4 ((($C' _3) (_787 _42)) ((_45 _785) _41))) (($A :5 (($B (($S _816) _785)) _0)) (($A :6 $T) (($A :7 ($T $I)) (($A :8 (($B (_45 _157)) _7)) (($A :9 (($B ($B (_44 _6))) ((($C' $B) (($B $C) _7)) ($B _7)))) (($A :10 (($B ($B (_44 _6))) ((($C' $B) (($B $C) _7)) ($BK _7)))) (($A :11 (($B (_44 _6)) $P)) (($A :12 (($B ($B (_44 _6))) (($B (($C' $C) _7)) ($B $P)))) (($A :13 _12) (($A :14 (($B (_44 _6)) ($B ($P _711)))) (($A :15 (($B (_44 _6)) ($BK ($P _711)))) (($A :16 ((_44 _6) (($S $P) $I))) (($A :17 (($B (_44 _6)) (($C ($S' $P)) $I))) (($A :18 (($B $Y) (($B ($B ($P (_11 _85)))) ((($C' $B) (($B ($C' $B)) ($B _9))) ((($C' ($C' $B)) ($B _9)) (($B ($B _11)) _86)))))) (($A :19 (($B $Y) (($B ($B ($P (_11 _711)))) (($B ($C' $B)) ($B _10))))) (($A :20 _0) (($A :21 ($T (_11 _711))) (($A :22 (($C $C) _29)) (($A :23 ($T _28)) (($A :24 (($P _29) _28)) (($A :25 _29) (($A :26 (($C (($C $S') _24)) $I)) (($A :27 (($C $S) _24)) (($A :28 $K) (($A :29 $A) (($A :30 _746) (($A :31 _747) (($A :32 ((($S' _23) (_738 97)) (($C _738) 122))) (($A :33 ((($S' _23) (_738 65)) (($C _738) 90))) (($A :34 ((($S' _22) _32) _33)) (($A :35 ((($S' _23) (_738 48)) (($C _738) 57))) (($A :36 ((($S' _23) (_738 32)) (($C _738) 126))) (($A :37 _735) (($A :38 _736) (($A :39 _738) (($A :40 _737) (($A :41 (($B $BK) $T)) (($A :42 ($BK $T)) (($A :43 $P) (($A :44 $I) (($A :45 $B) (($A :46 $I) (($A :47 $K) (($A :48 $C) (($A :49 _742) (($A :50 (($C (($C $S') _157)) _158)) (($A :51 ((($C' ($S' ($C' $B))) $B) $I)) (($A :52 _712) (($A :53 _713) (($A :54 _714) (($A :55 _715) (($A :56 _716) (($A :57 _717) (($A :58 (_53 0)) (($A :59 _723) (($A :60 _724) (($A :61 _725) (($A :62 _726) (($A :63 _727) (($A :64 _728) (($A :65 _59) (($A :66 ($BK $K)) (($A :67 (($B $BK) (($B ($B $BK)) $P))) (($A :68 (($B ($B ($B $BK))) (($B ($B ($B $BK))) (($B ($B ($B $C))) (($B ($B $C)) $P))))) (($A :69 ((($S' $S) ((($S' ($S' $C)) ((($C' ($C' $S)) ((($C' $B) (($B ($S' $S')) ((($C' $B) (($B _22) (_62 0))) (_59 0)))) (($B ($B (($C' $P) (_57 1)))) _52))) ($C $P))) _55)) _56)) (($A :70 _66) (($A :71 ((($S' $C) (($B ($P _146)) ((($C' ($C' $B)) ((($C' $C) _59) _146)) _147))) (($B (($C' ($C' ($C' $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) (($B (($C' ($C' ($C' $C))) (($B ($B ($B (($S' $S') (_59 0))))) (($B (($C' ($C' $C)) (($B ($B (($S' $S') (_59 1)))) (($B (($C' $C) (($B (($C' $S') (_59 2))) ($C _71)))) ($C _71))))) ($C _71))))) ($C _71)))) ($T $K))) ($T $A)))) (($C _69) 4)))) (($A :72 (_78 _47)) (($A :73 ((_93 (_50 _72)) _70)) (($A :74 (($C ((($C' $B) (($P _85) ((($C' ($C' $O)) $P) $K))) ((($S' ($C' ($C' ($C' $B)))) (($B ($B ($B ($B _75)))) ((($S' ($C' ($C' $B))) (($B ($B ($B _75))) ((($S' ($C' $B)) (($B ($B _75)) ((($C' $B) (($B _91) ($T 0))) _74))) ((($C' $B) (($B _91) ($T 1))) _74)))) ((($C' $B) (($B _91) ($T 2))) _74)))) ((($C' $B) (($B _91) ($T 3))) _74)))) (($B $T) (($B ($B $P)) (($C' _52) (_54 4)))))) (($A :75 (($S $S) (($B $BK) (($B $BK) ((($S' $S) $T) (($B $BK) (($B $BK) (($C ((($S' $C') $S) (($B ($B ($B ($S $B)))) (($B ($B ($B ($B ($B $BK))))) (($B (($S' ($C' $B)) (($B $B') $B'))) (($B ($B ($B ($B ($B ($S $B)))))) (($B ($B ($B ($B ($B ($B ($B $BK))))))) ((($C' $B) ($B' ($B' (($B ($C' ($C' ($C' $C)))) (($B (($C' $B) ($B' (($B $C) _61)))) (($B (($C' $B) _86)) _75)))))) (($B (($C' $B) _86)) ($C _75)))))))))) (((_710 "lib/Data/IntMap.hs") 3) 8))))))))) (($A :76 ((_45 (_91 _157)) _74)) (($A :77 ((($C' $C) ((($C' $C) ($C _71)) (_0 "Data.IntMap.!"))) $I)) (($A :78 (($B (($C' $B) $T)) (($B ($B $Y)) ((($C' ($C' ($S' ($S' $C)))) (($B (($S' $B) (($B ($S' $P)) ($C _67)))) (($B ($B (($C' ($S' $C)) (($B (($S' ($S' $S')) _59)) ((($C' ($C' $B)) (($B $B') ($B _44))) ((($C' ($C' _44)) _72) ((((_68 _66) _66) _66) _66))))))) ($B (($C' $B) _67))))) ((($C' $B) (($B ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($S' ($S' ($S' ($S' ($S' $C))))) (($B ($B ($B ($B ($B (($S' $S') (_59 0))))))) ((($S' ($S' ($S' ($S' ($S' $C
\ No newline at end of file
+887
+(($A :0 _774) (($A :1 (($B _820) _0)) (($A :2 ((($S' _820) _0) $I)) (($A :3 _744) (($A :4 (_3 "undefined")) (($A :5 $I) (($A :6 ((($C' $B) _773) (($C _48) _5))) (($A :7 ((($C' _6) (_791 _45)) ((_48 _789) _44))) (($A :8 (($B (($S _820) _789)) _3)) (($A :9 $T) (($A :10 ($T $I)) (($A :11 (($B (_48 _160)) _10)) (($A :12 (($B ($B (_47 _9))) ((($C' $B) (($B $C) _10)) ($B _10)))) (($A :13 (($B ($B (_47 _9))) ((($C' $B) (($B $C) _10)) ($BK _10)))) (($A :14 (($B (_47 _9)) $P)) (($A :15 (($B ($B (_47 _9))) (($B (($C' $C) _10)) ($B $P)))) (($A :16 _15) (($A :17 (($B (_47 _9)) ($B ($P _714)))) (($A :18 (($B (_47 _9)) ($BK ($P _714)))) (($A :19 ((_47 _9) (($S $P) $I))) (($A :20 (($B (_47 _9)) (($C ($S' $P)) $I))) (($A :21 (($B $Y) (($B ($B ($P (_14 _88)))) ((($C' $B) (($B ($C' $B)) ($B _12))) ((($C' ($C' $B)) ($B _12)) (($B ($B _14)) _89)))))) (($A :22 (($B $Y) (($B ($B ($P (_14 _714)))) (($B ($C' $B)) ($B _13))))) (($A :23 _3) (($A :24 ($T (_14 _714))) (($A :25 (($C $C) _32)) (($A :26 ($T _31)) (($A :27 (($P _32) _31)) (($A :28 _32) (($A :29 (($C (($C $S') _27)) $I)) (($A :30 (($C $S) _27)) (($A :31 $K) (($A :32 $A) (($A :33 _749) (($A :34 _750) (($A :35 ((($S' _26) (_741 97)) (($C _741) 122))) (($A :36 ((($S' _26) (_741 65)) (($C _741) 90))) (($A :37 ((($S' _25) _35) _36)) (($A :38 ((($S' _26) (_741 48)) (($C _741) 57))) (($A :39 ((($S' _26) (_741 32)) (($C _741) 126))) (($A :40 _738) (($A :41 _739) (($A :42 _741) (($A :43 _740) (($A :44 (($B $BK) $T)) (($A :45 ($BK $T)) (($A :46 $P) (($A :47 $I) (($A :48 $B) (($A :49 $I) (($A :50 $K) (($A :51 $C) (($A :52 _745) (($A :53 (($C (($C $S') _160)) _161)) (($A :54 ((($C' ($S' ($C' $B))) $B) $I)) (($A :55 _715) (($A :56 _716) (($A :57 _717) (($A :58 _718) (($A :59 _719) (($A :60 _720) (($A :61 (_56 0)) (($A :62 _726) (($A :63 _727) (($A :64 _728) (($A :65 _729) (($A :66 _730) (($A :67 _731) (($A :68 _62) (($A :69 ($BK $K)) (($A :70 (($B $BK) (($B ($B $BK)) $P))) (($A :71 (($B ($B ($B $BK))) (($B ($B ($B $BK))) (($B ($B ($B $C))) (($B ($B $C)) $P))))) (($A :72 ((($S' $S) ((($S' ($S' $C)) ((($C' ($C' $S)) ((($C' $B) (($B ($S' $S')) ((($C' $B) (($B _25) (_65 0))) (_62 0)))) (($B ($B (($C' $P) (_60 1)))) _55))) ($C $P))) _58)) _59)) (($A :73 _69) (($A :74 ((($S' $C) (($B ($P _149)) ((($C' ($C' $B)) ((($C' $C) _62) _149)) _150))) (($B (($C' ($C' ($C' $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) (($B (($C' ($C' ($C' $C))) (($B ($B ($B (($S' $S') (_62 0))))) (($B (($C' ($C' $C)) (($B ($B (($S' $S') (_62 1)))) (($B (($C' $C) (($B (($C' $S') (_62 2))) ($C _74)))) ($C _74))))) ($C _74))))) ($C _74)))) ($T $K))) ($T $A)))) (($C _72) 4)))) (($A :75 (_81 _50)) (($A :76 ((_96 (_53 _75)) _73)) (($A :77 (($C ((($C' $B) (($P _88) ((($C' ($C' $O)) $P) $K))) ((($S' ($C' ($C' ($C' $B)))) (($B ($B ($B ($B _78)))) ((($S' ($C' ($C' $B))) (($B ($B ($B _78))) ((($S' ($C' $B)) (($B ($B _78)) ((($C' $B) (($B _94) ($T 0))) _77))) ((($C' $B) (($B _94) ($T 1))) _77)))) ((($C' $B) (($B _94) ($T 2))) _77)))) ((($C' $B) (($B _94) ($T 3))) _77)))) (($B $T) (($B ($B $P)) (($C' _55) (_57 4)))))) (($A :78 (($S $S) (($B $BK) (($B $BK) ((($S' $S) $T) (($B $BK) (($B $BK) (($C ((($S' $C') $S) (($B ($B ($B ($S $B)))) (($B ($B ($B ($B ($B $BK))))) (($B (($S' ($C' $B)) (($B $B') $B'))) (($B ($B ($B ($B ($B ($S $B)))))) (($B ($B ($B ($B ($B ($B ($B $BK))))))) ((($C' $B) ($B' ($B' (($B ($C' ($C' ($C' $C)))) (($B (($C' $B) ($B' (($B $C) _64)))) (($B (($C' $B) _89)) _78)))))) (($B (($C' $B) _89)) ($C _78)))))))))) (((_713 "lib/Data/IntMap.hs") 3) 8))))))))) (($A :79 ((_48 (_94 _160)) _77)) (($A :80 ((($C' $C) ((($C' $C) ($C _74)) (_3 "Data.IntMap.!"))) $I)) (($A :81 (($B (($C' $B) $T)) (($B ($B $Y)) ((($C' ($C' ($S' ($S' $C)))) (($B (($S' $B) (($B ($S' $P)) ($C _70)))) (($B ($B (($C' ($S' $C)) (($B (($S' ($S' $S')) _62)) ((($C' ($C' $B)) (($B $B') ($B _47))) ((($C' ($C' _47)) _75) ((((_71 _69) _69) _69) _69))))))) ($B (($C' $B) _70))))) ((($C' $B) (($B ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($S' ($S' ($S' ($S' ($S' $C))
\ No newline at end of file
--- a/ghc/Primitives.hs
+++ b/ghc/Primitives.hs
@@ -6,7 +6,9 @@
Int,
IO,
Word,
+ NFData,
) where
+import Control.DeepSeq
import Control.Exception(try)
import Data.Time
import Data.Time.Clock.POSIX
@@ -184,3 +186,6 @@
EQ -> 0
GT -> 1
+
+primRnf :: (NFData a) => a -> ()
+primRnf = rnf
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -151,6 +151,9 @@
primCatch :: forall a . IO a -> ([Char] -> IO a) -> IO a
primCatch = primitive "IO.catch"
+primRnf :: forall a . a -> ()
+primRnf = primitive "rnf"
+
-- Temporary until overloading
primIsInt :: Any -> Bool
primIsInt = primitive "isInt"
--- a/src/MicroHs/Interactive.hs
+++ b/src/MicroHs/Interactive.hs
@@ -1,5 +1,6 @@
module MicroHs.Interactive(module MicroHs.Interactive) where
import Prelude
+import Control.DeepSeq
import Control.Exception
import qualified MicroHs.StateIO as S
import MicroHs.Compile
@@ -101,7 +102,7 @@
putStrLn $ showInt $ unsafeCoerce val
else do
putStrLn "Warning: not an Int"
- mio <- try (print ((unsafeCoerce val)::Int))
+ mio <- try (print (force ((unsafeCoerce val)::Int)))
case mio of
Left e -> err e
Right _ -> return ()
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -84,6 +84,7 @@
("error", primitive "error"), ("equal", primitive "equal"), ("compare", primitive "compare"),+ ("rnf", primitive "rnf"), ("IO.>>=", primitive "IO.>>="), ("IO.>>", primitive "IO.>>"), ("IO.return", primitive "IO.return"),--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -150,7 +150,7 @@
T_A, T_Y, T_SS, T_BB, T_CC, T_P, T_O, T_T, T_BK, T_ADD, T_SUB, T_MUL,
T_QUOT, T_REM, T_SUBR, T_UQUOT, T_UREM,
T_EQ, T_NE, T_LT, T_LE, T_GT, T_GE, T_ULT, T_ULE, T_UGT, T_UGE,
- T_ERROR, T_SEQ, T_EQUAL, T_COMPARE,
+ T_ERROR, T_SEQ, T_EQUAL, T_COMPARE, T_RNF,
T_IO_BIND, T_IO_THEN, T_IO_RETURN, T_IO_GETCHAR, T_IO_PUTCHAR,
T_IO_SERIALIZE, T_IO_DESERIALIZE, T_IO_OPEN, T_IO_CLOSE, T_IO_ISNULLHANDLE,
T_IO_STDIN, T_IO_STDOUT, T_IO_STDERR, T_IO_GETARGS, T_IO_DROPARGS,
@@ -396,7 +396,7 @@
/* Needed during reduction */
NODEPTR intTable[HIGH_INT - LOW_INT];
-NODEPTR combFalse, comTrue, combUnit, combCons;
+NODEPTR combFalse, combTrue, combUnit, combCons;
NODEPTR combCC, combIOBIND;
/* One node of each kind for primitives, these are never GCd. */
@@ -447,6 +447,7 @@
{ "error", T_ERROR }, { "equal", T_EQUAL }, { "compare", T_COMPARE },+ { "rnf", T_RNF },/* IO primops */
{ "IO.>>=", T_IO_BIND }, { "IO.>>", T_IO_THEN },@@ -492,7 +493,7 @@
SETTAG(n, primops[j].tag);
switch (primops[j].tag) {case T_K: combFalse = n; break;
- case T_A: comTrue = n; break;
+ case T_A: combTrue = n; break;
case T_I: combUnit = n; break;
case T_O: combCons = n; break;
case T_CC: combCC = n; break;
@@ -510,7 +511,7 @@
SETTAG(n, t);
switch (t) {case T_K: combFalse = n; break;
- case T_A: comTrue = n; break;
+ case T_A: combTrue = n; break;
case T_I: combUnit = n; break;
case T_O: combCons = n; break;
case T_CC: combCC = n; break;
@@ -1016,6 +1017,7 @@
void
find_sharing(NODEPTR n)
{+ top:
while (GETTAG(n) == T_IND)
n = INDIR(n);
//printf("find_sharing %p %llu ", n, LABEL(n));@@ -1034,7 +1036,8 @@
//printf("unmarked\n");set_bit(marked_bits, n);
find_sharing(FUN(n));
- find_sharing(ARG(n));
+ n = ARG(n);
+ goto top;
}
} else {/* Not an application, so do nothing */
@@ -1132,6 +1135,7 @@
case T_ERROR: fprintf(f, "$error"); break;
case T_EQUAL: fprintf(f, "$equal"); break;
case T_COMPARE: fprintf(f, "$compare"); break;
+ case T_RNF: fprintf(f, "$rnf"); break;
case T_SEQ: fprintf(f, "$seq"); break;
case T_IO_BIND: fprintf(f, "$IO.>>="); break;
case T_IO_THEN: fprintf(f, "$IO.>>"); break;
@@ -1394,6 +1398,32 @@
}
}
+void
+rnf_rec(NODEPTR n)
+{+ top:
+ if (test_bit(marked_bits, n))
+ return;
+ set_bit(marked_bits, n);
+ n = evali(n);
+ if (GETTAG(n) == T_AP) {+ rnf_rec(FUN(n));
+ n = ARG(n);
+ goto top;
+ }
+}
+
+void
+rnf(NODEPTR n)
+{+ /* Mark visited nodes to avoid getting stuck in loops. */
+ marked_bits = calloc(free_map_nwords, sizeof(bits_t));
+ if (!marked_bits)
+ memerr();
+ rnf_rec(n);
+ free(marked_bits);
+}
+
NODEPTR evalio(NODEPTR n);
/* Evaluate a node, returns when the node is in WHNF. */
@@ -1436,8 +1466,8 @@
#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 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 CMP(op) do { OPINT2(r = xi op yi); GOIND(r ? comTrue : combFalse); } while(0)-#define CMPU(op) do { OPINT2(r = (uvalue_t)xi op (uvalue_t)yi); GOIND(r ? comTrue : combFalse); } while(0)+#define CMP(op) do { OPINT2(r = xi op yi); 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(;;) {num_reductions++;
@@ -1518,11 +1548,13 @@
}
case T_SEQ: CHECK(2); eval(ARG(TOP(0))); POP(2); n = TOP(-1); y = ARG(n); GOIND(y); /* seq x y = eval(x); y */
- case T_EQUAL: r = compare(ARG(TOP(0)), ARG(TOP(1))); POP(2); n = TOP(-1); GOIND(r==0 ? comTrue : combFalse);
+ case T_EQUAL: r = compare(ARG(TOP(0)), ARG(TOP(1))); POP(2); n = TOP(-1); GOIND(r==0 ? combTrue : combFalse);
case T_COMPARE: r = compare(ARG(TOP(0)), ARG(TOP(1))); POP(2); n = TOP(-1); SETINT(n, r); RET;
- case T_IO_ISNULLHANDLE: CHKARGEV1(hdl = evalhandleN(x)); GOIND(hdl == 0 ? comTrue : combFalse);
+ case T_RNF: rnf(ARG(TOP(0))); POP(1); n = TOP(-1); GOIND(combUnit);
+ case T_IO_ISNULLHANDLE: CHKARGEV1(hdl = evalhandleN(x)); GOIND(hdl == 0 ? combTrue : combFalse);
+
case T_IO_PERFORMIO: CHKARGEV1(x = evalio(x)); GOIND(x);
case T_IO_BIND:
@@ -1549,7 +1581,7 @@
x = evali(ARG(TOP(0)));
n = TOP(0);
POP(1);
- GOIND(GETTAG(x) == T_INT ? comTrue : combFalse);
+ GOIND(GETTAG(x) == T_INT ? combTrue : combFalse);
case T_ISIO:
CHECK(1);
@@ -1557,7 +1589,7 @@
n = TOP(0);
POP(1);
l = GETTAG(x);
- GOIND(T_IO_BIND <= l && l <= T_IO_FLUSH ? comTrue : combFalse);
+ GOIND(T_IO_BIND <= l && l <= T_IO_FLUSH ? combTrue : combFalse);
default:
fprintf(stderr, "bad tag %d\n", GETTAG(n));
--
⑨