ref: 3a8fc35efee110baffffb20adf49feb8d9769aa4
parent: 991957120b8e2fd3a18a8eef026c6670ebee1560
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Mon Sep 18 09:20:15 EDT 2023
Implement low level equality and use it for String.
--- a/TODO
+++ b/TODO
@@ -13,9 +13,6 @@
- implement a simple readline
- implement catch (and maybe throw) using setjmp & longjmp
- make the runtime system catch ^C and stop execution
-* implement low level equality
- - maybe?
- - could be used instead of derived when all is derived
* use pointer stack during GC instead of recursion.
* add Double primitive type
* implement Data.Integer
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
-v3.3
-820
-(($A :0 ((_622 _575) (($B ((($S' ($C ((($C' ($S' _622)) (($B ($C _2)) _560)) (($B ($B (_622 _650))) ((($C' ($C' $C)) ((($C' ($S' ($C' $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $S)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' $C))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' ($C' $S'))))) ((($C' ($C' ($C' ($C' ($C' $C'))))) ((($C' ($C' ($C' ($S' ($C' $C'))))) (($B ($B ($B ($B $B')))) ((($S' $B) ($B' ($B' (($B ($S' $B)) (($B ($B _623)) ((($C' $B) (($B _717) (($B _640) ((($C' _754) _8) 0)))) (($B (_717 _643)) (($B (_656 "top level defns: ")) _604)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _623)) ((($C' $B) (($B _717) (($B _640) ((($C' _754) _8) 1)))) (_639 ($T (($B ($B (_717 _643))) ((($C' $B) (($B _656) ((($C' _656) _565) " = "))) _392)))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _623))) ((($C' $B) ($B' (($B _717) (($B _645) _11)))) (($B _656) ((($C' _656) (($B (_656 _1)) _604)) (($O 10) $K)))))) (($B ($B (_622 _650))) ((($C' $B) ($B' (($B _717) (($B _640) ((($C' _754) _8) 0))))) (($B ($B (_717 _643))) ((($C' ($C' _656)) (($B ($B (_656 "final pass "))) (($B ($B (_617 6))) (($B ($B _604)) _748)))) "ms"))))))) _3))))) (($B (($C' $C) (($B ($C _661)) _392))) (($C _674) (_691 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) ((($C' ($C' ($C' ($C' _656)))) (($B ($C' ($C' _656))) ((($C' ($C' ($C' _656))) (($B (($C' $B) (($B _656) ((($C' _656) (($B (_656 "(($A :")) _604)) (($O 32) $K))))) ($B _392))) ") "))) (($O 41) $K)))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _368)) $I))) ($BK $K))) $K))))) (($B (($S' _717) (($B _714) (($B (_717 _761)) (($B (_656 "main: findIdent: ")) _565))))) (($C' _594) _562)))) _601))) (($B ($B _598)) ((($C' $B) (($B _658) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _562))) $K)))))) (($C _674) (_691 0))))))) ($T $A))) ($T $K))) $I)) (($B (_717 _367)) (($B (_717 _560)) (($B (_656 (($O 95) $K))) _604)))))))) (($S (($S ((($S' _7) (($B _673) (_660 (_615 "-v")))) ((_690 _615) "-r"))) (($B (_654 (($O 46) $K))) (($B _716) (_659 ((_678 _739) "-i")))))) (($B (_717 _685)) ((($C' _656) (($B _716) (_659 ((_678 _739) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _750) _673) 1)) (_761 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _685)) (_660 ((_718 _759) ((_718 (_615 (($O 45) $K))) (_671 1))))))) (_681 ((_718 _759) (_615 "--")))))) (($A :1 "v3.3\10&") (($A :2 ((($S' ($S' _622)) _16) (($B ($B ($B (_622 _650)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _623) (($B (_717 _641)) (($B (_717 (_672 1000000))) _192)))))) (($B ($B ($B ($B (_622 _650))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _623))) ((($C' $B) ($B' (($B _717) (($B _640) ((($C' _754) _8) 0))))) (($B ($B (_717 _643))) ((($C' ($C' _656)) (($B ($B (_656 "combinator conversion "))) (($B ($B (_617 6))) (($B ($B _604)) _748)))) "ms")))))) (($B ($B _624)) (($B $P) (($C _568) (_560 "main")))))))) (_658 ($T ((($C' ($C' $O)) ((($C' $B) $P) _395)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_622 _575)))) (($B ($B ($B (($C' _576) ((($C' _743) (($B _673) (_681 ((_718 _759) (_615 "--"))))) 1))))) (($B ($B ($B (_717 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _551))) (($C' ($C' _658)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _717) (($B _714) (($B (_717 _761)) (($B (_656 "not found ")) _565))))) ($C _552))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($S' $C)) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _394))) (($B (_717 (_714 (_761 "primlookup")))) (($C (_696 _615)) _5)))) $K))) (_761 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "
\ No newline at end of file
+v3.4
+822
+(($A :0 ((_622 _575) (($B ((($S' ($C ((($C' ($S' _622)) (($B ($C _2)) _560)) (($B ($B (_622 _650))) ((($C' ($C' $C)) ((($C' ($S' ($C' $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $S)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' $C))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' ($C' $S'))))) ((($C' ($C' ($C' ($C' ($C' $C'))))) ((($C' ($C' ($C' ($S' ($C' $C'))))) (($B ($B ($B ($B $B')))) ((($S' $B) ($B' ($B' (($B ($S' $B)) (($B ($B _623)) ((($C' $B) (($B _717) (($B _640) ((($C' _754) _8) 0)))) (($B (_717 _643)) (($B (_656 "top level defns: ")) _604)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _623)) ((($C' $B) (($B _717) (($B _640) ((($C' _754) _8) 1)))) (_639 ($T (($B ($B (_717 _643))) ((($C' $B) (($B _656) ((($C' _656) _565) " = "))) _392)))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _623))) ((($C' $B) ($B' (($B _717) (($B _645) _11)))) (($B _656) ((($C' _656) (($B (_656 _1)) _604)) (($O 10) $K)))))) (($B ($B (_622 _650))) ((($C' $B) ($B' (($B _717) (($B _640) ((($C' _754) _8) 0))))) (($B ($B (_717 _643))) ((($C' ($C' _656)) (($B ($B (_656 "final pass "))) (($B ($B (_617 6))) (($B ($B _604)) _748)))) "ms"))))))) _3))))) (($B (($C' $C) (($B ($C _661)) _392))) (($C _674) (_691 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) ((($C' ($C' ($C' ($C' _656)))) (($B ($C' ($C' _656))) ((($C' ($C' ($C' _656))) (($B (($C' $B) (($B _656) ((($C' _656) (($B (_656 "(($A :")) _604)) (($O 32) $K))))) ($B _392))) ") "))) (($O 41) $K)))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _368)) $I))) ($BK $K))) $K))))) (($B (($S' _717) (($B _714) (($B (_717 _761)) (($B (_656 "main: findIdent: ")) _565))))) (($C' _594) _562)))) _601))) (($B ($B _598)) ((($C' $B) (($B _658) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _562))) $K)))))) (($C _674) (_691 0))))))) ($T $A))) ($T $K))) $I)) (($B (_717 _367)) (($B (_717 _560)) (($B (_656 (($O 95) $K))) _604)))))))) (($S (($S ((($S' _7) (($B _673) (_660 (_615 "-v")))) ((_690 _615) "-r"))) (($B (_654 (($O 46) $K))) (($B _716) (_659 ((_678 _739) "-i")))))) (($B (_717 _685)) ((($C' _656) (($B _716) (_659 ((_678 _739) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _750) _673) 1)) (_761 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _685)) (_660 ((_718 _759) ((_718 (_615 (($O 45) $K))) (_671 1))))))) (_681 ((_718 _759) (_615 "--")))))) (($A :1 "v3.4\10&") (($A :2 ((($S' ($S' _622)) _16) (($B ($B ($B (_622 _650)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _623) (($B (_717 _641)) (($B (_717 (_672 1000000))) _192)))))) (($B ($B ($B ($B (_622 _650))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _623))) ((($C' $B) ($B' (($B _717) (($B _640) ((($C' _754) _8) 0))))) (($B ($B (_717 _643))) ((($C' ($C' _656)) (($B ($B (_656 "combinator conversion "))) (($B ($B (_617 6))) (($B ($B _604)) _748)))) "ms")))))) (($B ($B _624)) (($B $P) (($C _568) (_560 "main")))))))) (_658 ($T ((($C' ($C' $O)) ((($C' $B) $P) _395)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_622 _575)))) (($B ($B ($B (($C' _576) ((($C' _743) (($B _673) (_681 ((_718 _759) (_615 "--"))))) 1))))) (($B ($B ($B (_717 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _551))) (($C' ($C' _658)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _717) (($B _714) (($B (_717 _761)) (($B (_656 "not found ")) _565))))) ($C _552))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($S' $C)) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _394))) (($B (_717 (_714 (_761 "primlookup")))) (($C (_696 _615)) _5)))) $K))) (_761 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "
\ No newline at end of file
--- a/ghc/Primitives.hs
+++ b/ghc/Primitives.hs
@@ -83,6 +83,9 @@
primError :: String -> a
primError = error
+primEqString :: String -> String -> Bool
+primEqString = (==)
+
primUnsafeCoerce :: a -> b
primUnsafeCoerce = unsafeCoerce
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -86,6 +86,12 @@
primSeq :: forall a b . a -> b -> b
primSeq = primitive "seq"
+--primEqual :: forall a . a -> a -> Bool
+--primEqual = primitive "equal"
+
+primEqString :: [Char] -> [Char] -> Bool
+primEqString = primitive "equal"
+
primChr :: Int -> Char
primChr = primitive "I"
primOrd :: Char -> Int
--- a/lib/Text/String.hs
+++ b/lib/Text/String.hs
@@ -1,6 +1,7 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
module Text.String(module Text.String) where
+import Primitives
import Data.Bool
import Data.Char
import Data.Either
@@ -98,7 +99,10 @@
unwords :: [String] -> String
unwords ss = concat (intersperse " " ss)
+-- Using a primitive for string equality makes a huge speed difference.
eqString :: String -> String -> Bool
+eqString = primEqString
+{-eqString axs ays =
case axs of
[] ->
@@ -109,6 +113,7 @@
case ays of
[] -> False
y:ys -> eqChar x y && eqString xs ys
+-}
leString :: String -> String -> Bool
leString axs ays =
--- a/src/MicroHs/Main.hs
+++ b/src/MicroHs/Main.hs
@@ -65,7 +65,7 @@
putStrLn $ "final pass " ++ padLeft 6 (showInt (t2-t1)) ++ "ms"
version :: String
-version = "v3.3\n"
+version = "v3.4\n"
type Program = (Ident, [LDef])
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -78,6 +78,7 @@
("u>=", primitive "u>="), ("seq", primitive "seq"), ("error", primitive "error"),+ ("equal", primitive "equal"), ("IO.>>=", primitive "IO.>>="), ("IO.>>", primitive "IO.>>"), ("IO.return", primitive "IO.return"),--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -87,7 +87,7 @@
#endif /* !defined(_MSC_VER) */
-#define VERSION "v3.3\n"
+#define VERSION "v3.4\n"
/* Keep permanent nodes for LOW_INT <= i < HIGH_INT */
#define LOW_INT (-10)
@@ -102,7 +102,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_ERROR, T_SEQ, T_EQUAL,
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,
@@ -170,7 +170,6 @@
#define FUN(p) (p)->ufun.uufun
#define ARG(p) (p)->uarg.uuarg
#define STR(p) (p)->uarg.uustring
-#define FUNPTR(p) (p)->uarg.uufunptr
#define INDIR(p) ARG(p)
#define HANDLE(p) (p)->uarg.uufile
#define NODE_SIZE sizeof(node)
@@ -390,6 +389,7 @@
{ ">=", T_GE }, { "seq", T_SEQ }, { "error", T_ERROR },+ { "equal", T_EQUAL },/* IO primops */
{ "IO.>>=", T_IO_BIND }, { "IO.>>", T_IO_THEN },@@ -1066,6 +1066,7 @@
case T_UGT: fprintf(f, "$u>"); break;
case T_UGE: fprintf(f, "$u>="); break;
case T_ERROR: fprintf(f, "$error"); break;
+ case T_EQUAL: fprintf(f, "$equal"); break;
case T_SEQ: fprintf(f, "$seq"); break;
case T_IO_BIND: fprintf(f, "$IO.>>="); break;
case T_IO_THEN: fprintf(f, "$IO.>>"); break;
@@ -1269,6 +1270,40 @@
return name;
}
+int
+equal(NODEPTR p, NODEPTR q)
+{+ top:
+ PUSH(q); /* save for GC */
+ p = evali(p);
+ q = evali(TOP(0));
+ POP(1);
+ enum node_tag ptag = GETTAG(p);
+ enum node_tag qtag = GETTAG(q);
+ if (ptag != qtag)
+ return 0;
+ switch (ptag) {+ case T_AP:
+ PUSH(ARG(p));
+ PUSH(ARG(q));
+ if (!equal(FUN(p), FUN(q))) {+ POP(2);
+ return 0;
+ }
+ q = TOP(0);
+ p = TOP(1);
+ POP(2);
+ goto top;
+ case T_INT:
+ case T_IO_CCALL:
+ return GETVALUE(p) == GETVALUE(q);
+ case T_HDL:
+ return HANDLE(p) == HANDLE(q);
+ default:
+ return 1;
+ }
+}
+
NODEPTR evalio(NODEPTR n);
/* Evaluate a node, returns when the node is in WHNF. */
@@ -1380,6 +1415,8 @@
case T_ERROR: CHKARGEV1(msg = evalstring(x)); fprintf(stderr, "error: %s\n", msg); free(msg); exit(1);
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 = equal(ARG(TOP(0)), ARG(TOP(1))); POP(2); n = TOP(-1); GOIND(r ? comTrue : combFalse);
case T_IO_ISNULLHANDLE: CHKARGEV1(hdl = evalhandleN(x)); GOIND(hdl == 0 ? comTrue : combFalse);
--- a/tests/StringTest.hs
+++ b/tests/StringTest.hs
@@ -3,6 +3,8 @@
main :: IO ()
main = do
+ putStrLn $ if eqString "abc" "abc" then "yes" else "no"
+ putStrLn $ if eqString "abc" "adc" then "yes" else "no"
putStrLn $ showInt 1234
putStrLn $ showInt 0
putStrLn $ showInt (negate 567)
--- a/tests/StringTest.ref
+++ b/tests/StringTest.ref
@@ -1,3 +1,5 @@
+yes
+no
1234
0
-567
--
⑨