ref: 0fb3336eea81e0b4eaccd63197f07bf0312b1bd4
parent: bcec20e056243e68d6646b6aee6baf6b44738832
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Mon Aug 28 16:06:50 EDT 2023
Add Word primitive type.
--- a/Makefile
+++ b/Makefile
@@ -45,6 +45,7 @@
$(GHCC) -c lib/Data/Maybe.hs
$(GHCC) -c lib/Data/List.hs
$(GHCC) -c lib/Text/String.hs
+ $(GHCC) -c lib/Data/Word.hs
$(GHCC) -c lib/System/IO.hs
$(GHCC) -c lib/System/Environment.hs
$(GHCC) -c lib/Prelude.hs
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.2
-720
-(($A :0 ((_536 _490) ((($S' ($C ((($C' ($S' _536)) ($C _2)) (($B ($B (_536 _564))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B ($B $B))))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) (($B $B) (($B $B) (($B $C') (($B ($S' _537)) ((($C' $B) (($B _625) (($B _554) ((($C' _663) _8) 0)))) (($B (_625 _557)) (($B (_570 "top level defns: ")) _518)))))))) ((($S' $B) (($B $B) (($B ($C' $B)) (($B ($B $B)) (($B ($B _537)) ((($C' $B) (($B _625) (($B _554) ((($C' _663) _8) 1)))) (_553 ($T (($B ($B (_625 _557))) ((($C' $B) _570) (($B (_570 " = ")) _386))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _537))) ((($C' $B) (($B $B) (($B _625) (($B _559) _11)))) (($B ($B (_570 _1))) (($B (($C' _570) _518)) (_570 (($O 10) $K))))))) (($B ($B (_536 _564))) ((($C' $B) (($B $B) (($B _625) (($B _554) ((($C' _663) _8) 0))))) (($B ($B (_625 _557))) (($B ($B (_570 "final pass "))) ((($C' ($C' _570)) (($B ($B (_531 6))) (($B ($B _518)) _657))) "ms")))))))) _3)))) _515))) (($B (($C' $C) (($B ($C _575)) _386))) (($C _588) (_605 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_570 "(($A :"))))) (($B ($B (($C' $B) (($B _570) _518)))) (($B ($B ($B (_570 (($O 32) $K))))) ((($C' $B) (($B ($C' _570)) ($B _386))) (($B (_570 ") ")) (($C _570) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _363)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _625) (($B _622) (($B (_625 _672)) (($B (_570 "main: findIdent: ")) _462))))) ($C _508)))) (($B ($B _512)) (($B (($C' _572) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B ($C $P))) $K)))))) (($C _588) (_605 0)))))) (($B (_625 _362)) (($B (_570 (($O 95) $K))) _518))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _587) (_574 (_529 "-v")))) ((_604 _529) "-r"))) (($B (_568 (($O 46) $K))) (($B _624) (_573 ((_592 _648) "-i")))))) (($B (_625 _599)) ((($C' _570) (($B _624) (_573 ((_592 _648) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _659) _587) 1)) (_672 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _599)) (_574 ((_626 _668) ((_626 (_529 (($O 45) $K))) (_585 1)))))))) (($A :1 "v3.2\10&") (($A :2 ((($S' ($S' _536)) _16) (($B ($B ($B (_536 _564)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _537) (($B (_625 _555)) (($B (_625 (_586 1000000))) _189)))))) (($B ($B ($B ($B (_536 _564))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _537))) ((($C' $B) (($B $B) (($B _625) (($B _554) ((($C' _663) _8) 0))))) (($B ($B (_625 _557))) (($B ($B (_570 "combinator conversion "))) ((($C' ($C' _570)) (($B ($B (_531 6))) (($B ($B _518)) _657))) "ms"))))))) (($B ($B _538)) (($B $P) (($C _414) "main"))))))) (_572 ($T ((($C' ($C' $O)) ((($C' $B) $P) _389)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_625 _6)))) ($C $C))) (($B ($B $Y)) (($B ($B ($B _356))) (($C' ($C' _572)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _625) (($B _622) (($B (_625 _672)) (_570 "not found "))))) ($C _357))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _388))) (($B (_625 (_622 (_672 "primlookup")))) (($C (_608 _529)) _5))))) (_672 "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 "S'") $S')) (($O (($P (($O 80) $K)) $P)) (($O (($P (($O 73) $K)) $I)) (($O (($P (($O 83) $K)) $S)) (($O (($P (($O 84) $K)) $T)) (($O (($P (($O 89) $K)) $Y)) (($O (($P "B'") $B')) (($O (($P "BK") $BK)) (($O (($P (($O 43) $K)) $+)) (($O (($P (($O 45) $K
\ No newline at end of file
+726
+(($A :0 ((_536 _490) ((($S' ($C ((($C' ($S' _536)) ($C _2)) (($B ($B (_536 _564))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B $B')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _537)) ((($C' $B) (($B _625) (($B _554) ((($C' _663) _8) 0)))) (($B (_625 _557)) (($B (_570 "top level defns: ")) _518)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _537)) ((($C' $B) (($B _625) (($B _554) ((($C' _663) _8) 1)))) (_553 ($T (($B ($B (_625 _557))) ((($C' $B) _570) (($B (_570 " = ")) _386))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _537))) ((($C' $B) ($B' (($B _625) (($B _559) _11)))) (($B ($B (_570 _1))) (($B (($C' _570) _518)) (_570 (($O 10) $K))))))) (($B ($B (_536 _564))) ((($C' $B) ($B' (($B _625) (($B _554) ((($C' _663) _8) 0))))) (($B ($B (_625 _557))) (($B ($B (_570 "final pass "))) ((($C' ($C' _570)) (($B ($B (_531 6))) (($B ($B _518)) _657))) "ms")))))))) _3)))) _515))) (($B (($C' $C) (($B ($C _575)) _386))) (($C _588) (_605 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_570 "(($A :"))))) (($B ($B (($C' $B) (($B _570) _518)))) (($B ($B ($B (_570 (($O 32) $K))))) ((($C' $B) (($B ($C' _570)) ($B _386))) (($B (_570 ") ")) (($C _570) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _363)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _625) (($B _622) (($B (_625 _672)) (($B (_570 "main: findIdent: ")) _462))))) ($C _508)))) (($B ($B _512)) (($B (($C' _572) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B ($C $P))) $K)))))) (($C _588) (_605 0)))))) (($B (_625 _362)) (($B (_570 (($O 95) $K))) _518))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _587) (_574 (_529 "-v")))) ((_604 _529) "-r"))) (($B (_568 (($O 46) $K))) (($B _624) (_573 ((_592 _648) "-i")))))) (($B (_625 _599)) ((($C' _570) (($B _624) (_573 ((_592 _648) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _659) _587) 1)) (_672 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _599)) (_574 ((_626 _668) ((_626 (_529 (($O 45) $K))) (_585 1)))))))) (($A :1 "v3.2\10&") (($A :2 ((($S' ($S' _536)) _16) (($B ($B ($B (_536 _564)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _537) (($B (_625 _555)) (($B (_625 (_586 1000000))) _189)))))) (($B ($B ($B ($B (_536 _564))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _537))) ((($C' $B) ($B' (($B _625) (($B _554) ((($C' _663) _8) 0))))) (($B ($B (_625 _557))) (($B ($B (_570 "combinator conversion "))) ((($C' ($C' _570)) (($B ($B (_531 6))) (($B ($B _518)) _657))) "ms"))))))) (($B ($B _538)) (($B $P) (($C _414) "main"))))))) (_572 ($T ((($C' ($C' $O)) ((($C' $B) $P) _389)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_625 _6)))) ($C $C))) (($B ($B $Y)) (($B ($B ($B _356))) (($C' ($C' _572)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _625) (($B _622) (($B (_625 _672)) (_570 "not found "))))) ($C _357))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _388))) (($B (_625 (_622 (_672 "primlookup")))) (($C (_608 _529)) _5))))) (_672 "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 "S'") $S')) (($O (($P (($O 80) $K)) $P)) (($O (($P (($O 73) $K)) $I)) (($O (($P (($O 83) $K)) $S)) (($O (($P (($O 84) $K)) $T)) (($O (($P (($O 89) $K)) $Y)) (($O (($P "B'") $B')) (($O (($P "BK") $BK)) (($O (($P (($O 43) $K)) $+)) (($O (($P (($O 45) $K)) $-)) (($O (($P (($O 42) $K))
\ No newline at end of file
--- a/ghc/Primitives.hs
+++ b/ghc/Primitives.hs
@@ -87,6 +87,12 @@
primSeq :: a -> b -> b
primSeq = seq
+primWordEQ :: Word -> Word -> Bool
+primWordEQ = (==)
+
+primWordNE :: Word -> Word -> Bool
+primWordNE = (/=)
+
primWordAdd :: Word -> Word -> Word
primWordAdd = (+)
@@ -101,6 +107,18 @@
primWordRem :: Word -> Word -> Word
primWordRem = rem
+
+primWordLT :: Word -> Word -> Bool
+primWordLT = (<)
+
+primWordLE :: Word -> Word -> Bool
+primWordLE = (<=)
+
+primWordGT :: Word -> Word -> Bool
+primWordGT = (>)
+
+primWordGE :: Word -> Word -> Bool
+primWordGE = (>=)
------
--- /dev/null
+++ b/lib/Data/Word.hs
@@ -1,0 +1,64 @@
+-- Copyright 2023 Lennart Augustsson
+-- See LICENSE file for full license.
+module Data.Word(module Data.Word) where
+import Primitives
+import Data.Bool_Type
+import qualified Data.Char as C
+import qualified Data.Int as I
+import Data.List
+import Text.String
+
+--type Word = Primitives.Word
+
+--Yinfixl 6 +,-
+--Yinfixl 7 *
+
+-- Arithmetic
+(+) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> {-Data.Word.-}Word+(+) = primWordAdd
+(-) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> {-Data.Word.-}Word+(-) = primWordSub
+(*) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> {-Data.Word.-}Word+(*) = primWordMul
+quot :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> {-Data.Word.-}Word+quot = primWordQuot
+rem :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> {-Data.Word.-}Word+rem = primWordRem
+
+--------------------------------
+
+--Yinfix 4 ==,/=,<,<=,>,>=
+
+-- Comparison
+(==) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> Bool+(==) = primWordEQ
+(/=) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> Bool+(/=) = primWordNE
+
+(<) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> Bool+(<) = primWordLT
+(<=) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> Bool+(<=) = primWordLE
+(>) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> Bool+(>) = primWordGT
+(>=) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> Bool+(>=) = primWordGE
+
+eqWord :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> Bool+eqWord = (==)
+
+intToWord :: Int -> Word
+intToWord = primUnsafeCoerce
+
+wordToInt :: Word -> Int
+wordToInt = primUnsafeCoerce
+
+--------------------------------
+
+showWord :: Word -> C.String
+showWord n =
+ let
+ c = C.chr ((I.+) (C.ord '0') (wordToInt (rem n (intToWord 10))))
+ in case n < intToWord 10 of
+ False -> showWord (quot n (intToWord 10)) ++ [c]
+ True -> [c]
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -40,6 +40,19 @@
primIntGE :: Int -> Int -> Bool
primIntGE = primitive ">="
+primWordEQ :: Word -> Word -> Bool
+primWordEQ = primitive "=="
+primWordNE :: Word -> Word -> Bool
+primWordNE = primitive "/="
+primWordLT :: Word -> Word -> Bool
+primWordLT = primitive "u<"
+primWordLE :: Word -> Word -> Bool
+primWordLE = primitive "<="
+primWordGT :: Word -> Word -> Bool
+primWordGT = primitive ">"
+primWordGE :: Word -> Word -> Bool
+primWordGE = primitive ">="
+
primCharEQ :: Char -> Char -> Bool
primCharEQ = primitive "=="
primCharNE :: Char -> Char -> Bool
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -501,8 +501,8 @@
showString fn ++ ": "
++ "line " ++ showInt line ++ ", col " ++ showInt col ++ ":\n"
-- ++ " found: " ++ tokenString (head ts)
--- ++ show lf ++ "\n"
--- ++ show fs
+--X ++ show _lf ++ "\n"
+--X ++ show _fs
--tokenString :: Token -> String
--tokenString
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -66,6 +66,10 @@
("<=", primitive "<="), (">", primitive ">"), (">=", primitive ">="),+ ("u<", primitive "u<"),+ ("u<=", primitive "u<="),+ ("u>", primitive "u>"),+ ("u>=", primitive "u>="), ("seq", primitive "seq"), ("error", primitive "error"), ("IO.>>=", primitive "IO.>>="),--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -44,7 +44,8 @@
long tv_usec;
} timeval;
-int gettimeofday(struct timeval * tp, struct timezone * tzp)
+int
+gettimeofday(struct timeval * tp, struct timezone * tzp)
{static const uint64_t EPOCH = ((uint64_t) 116444736000000000ULL);
@@ -83,7 +84,9 @@
enum node_tag { T_FREE, T_IND, T_AP, T_INT, 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_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_ERROR, T_SEQ,
+ 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_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_PERFORMIO,
@@ -361,6 +364,10 @@
{ "==", T_EQ }, { "/=", T_NE }, { "<", T_LT },+ { "u<", T_ULT },+ { "u<=", T_ULE },+ { "u>", T_UGT },+ { "u>=", T_UGE }, { "<=", T_LE }, { ">", T_GT }, { ">=", T_GE },@@ -627,7 +634,7 @@
return n;
}
-NODEPTR mkInt(int i);
+NODEPTR mkInt(int64_t i);
/* Table of labelled nodes for sharing during parsing. */
struct shared_entry {@@ -980,6 +987,10 @@
case T_LE: fprintf(f, "$<="); break;
case T_GT: fprintf(f, "$>"); break;
case T_GE: fprintf(f, "$>="); break;
+ case T_ULT: fprintf(f, "$u<"); break;
+ case T_ULE: fprintf(f, "$u<="); break;
+ case T_UGT: fprintf(f, "$u>"); break;
+ case T_UGE: fprintf(f, "$u>="); break;
case T_ERROR: fprintf(f, "$error"); break;
case T_SEQ: fprintf(f, "$seq"); break;
case T_IO_BIND: fprintf(f, "$IO.>>="); break;
@@ -1028,7 +1039,7 @@
}
NODEPTR
-mkInt(int i)
+mkInt(int64_t i)
{#if INTTABLE
if (LOW_INT <= i && i < HIGH_INT) {@@ -1225,6 +1236,7 @@
#define ARITHBIN(op) do { OPINT2(r = xi op yi); SETINT(n, r); RET; } while(0) #define ARITHBINU(op) do { OPINT2(r = (int64_t)((uint64_t)xi op (uint64_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 = (uint64_t)xi op (uint64_t)yi); GOIND(r ? comTrue : combFalse); } while(0) for(;;) {num_reductions++;
@@ -1285,6 +1297,10 @@
case T_LE: CMP(<=);
case T_GT: CMP(>);
case T_GE: CMP(>=);
+ case T_ULT: CMPU(<);
+ case T_ULE: CMPU(<=);
+ case T_UGT: CMPU(>);
+ case T_UGE: CMPU(>=);
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 */
--- a/tests/Makefile
+++ b/tests/Makefile
@@ -13,6 +13,7 @@
$(MHS) Guard && $(EVAL) > Guard.out && diff Guard.ref Guard.out
$(MHS) Newtype && $(EVAL) > Newtype.out && diff Newtype.ref Newtype.out
$(MHS) LitMatch && $(EVAL) > LitMatch.out && diff LitMatch.ref LitMatch.out
+ $(MHS) Word && $(EVAL) > Word.out && diff Word.ref Word.out
time:
@echo Expect about 10s runtime
--- /dev/null
+++ b/tests/Word.hs
@@ -1,0 +1,14 @@
+module Word(main) where
+import Prelude
+import qualified Data.Word as W
+
+main :: IO ()
+main = do
+ putStrLn $ showInt 4294967295
+ putStrLn $ W.showWord (W.intToWord 1000)
+ putStrLn $ W.showWord twoTo32M1
+ putStrLn $ W.showWord $ (W.*) twoTo32M1 twoTo32M1
+
+twoTo32M1 :: Word
+twoTo32M1 = W.intToWord 4294967295
+
--- /dev/null
+++ b/tests/Word.ref
@@ -1,0 +1,4 @@
+4294967295
+1000
+4294967295
+18446744065119617025
--
⑨