ref: 33ca3517205eed58a0305ee2829023c216bdb3de
parent: 294d5d962a79772f4fb4feb02b3249cdc0ce146b
author: Lennart Augustsson <lennart@augustsson.net>
date: Sat Nov 4 17:50:23 EDT 2023
Bit fiddling operations
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.1
-1404
-((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' _210) ((B _12) _1)) _393))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _392))) ((A :10 (((S' P) _2) (((C' _13) _1) _1161))) ((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' _207) _12) _198))) ((A :20 (((S' B) _14) (((C' _210) _12) _199))) ((A :21 _1236) ((A :22 ((B _1277) _21)) ((A :23 (((S' _1277) _21) I)) ((A :24 _1206) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1235) ((C _197) _26))) ((A :28 (((C' _27) ((_206 _1247) _109)) ((_197 (_34 _1249)) _108))) ((A :29 ((B ((S _1277) (_34 _1249))) _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) _392)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _393)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1161)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1161))) ((A :46 ((C _43) _198)) ((A :47 ((B _200) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _200) _48)) ((A :50 T) ((A :51 ((_205 ((B (B (_195 _50))) ((B ((C' C) _54)) (B P)))) (_209 _51))) ((A :52 (((((_11 _51) ((B (_195 _50)) P)) (_38 _53)) ((B (B (_195 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_195 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_197 _465)) _54)) ((A :56 ((B (_195 _50)) (B (P _1161)))) ((A :57 ((B (_195 _50)) (BK (P _1161)))) ((A :58 ((_195 _50) ((S P) I))) ((A :59 ((B (_195 _50)) ((C (S' P)) I))) ((A :60 ((_135 ((C ((C S') _65)) I)) (_139 _60))) ((A :61 (((_1375 (K ((P (_1384 "False")) (_1384 "True")))) (_1380 _61)) (_1381 _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 ((_135 _1200) _1201)) ((A :75 ((((((((_425 _74) (_434 _75)) _1202) _1203) _1204) _1205) (_439 _75)) (_440 _75))) ((A :76 ((_135 _1210) (_139 _76))) ((A :77 ((((((((_425 _76) _1209) (((C' (C' (_136 _441))) _1209) _445)) (((C' (C' (_137 _441))) _1209) _447)) (((C' (C' (_136 _441))) _1209) _447)) (((C' (C' (_137 _441))) _1209) _447)) (_439 _77)) (_440 _77))) ((A :78 ((_69 (_79 #0)) (_79 #127))) ((A :79 _1211) ((A :80 _1212) ((A :81 (((S' _64) (_1203 #97)) ((C _1203) #122))) ((A :82 (((S' _64) (_1203 #65)) ((C _1203) #90))) ((A :83 (((S' _63) _81) _82)) ((A :84 (((S' _64) (_1203 #48)) ((C _1203) #57))) ((A :85 (((S' _63) _83) _84)) ((A :86 (((S' _64) (_1203 #32)) ((C _1203) #126))) ((A :87 (((S' _63) ((C (_136 _74)) #32)) (((S' _63) ((C (_136 _74)) #9)) ((C (_136 _74)) #10)))) ((A :88 ((S ((S (((S' _64) (_1203 #65)) ((C _1203) #90))) (_68 (((noMatch "lib/Data/Char.hs") #72) #9)))) ((B _79) (((C' (_410 _211)) (((C' (_411 _211)) _80) (_80 #65))) (_80 #97))))) ((A :89 ((S ((S (((S' _64) (_1203 #97)) ((C _1203) #97))) (_68 (((noMatch "lib/Data/Char.hs") #76) #9)))) ((B _79) (((C' (_410 _211)) (((C' (_411 _211)) _80) (_80 #97))) (_80 #65))))) ((A :90 (((_1375 (K ((C ((S ((C ==) #39)) ((B (_197 (_1383 #39))) (((C' _197) ((B _1384) _91)) (_1383 #39))))) (_1384 "'\92&''")))) (_1380 _90)) ((B (_197 (_1383 #34))) (Y ((B (P (_1383 #34))) (((S' C) ((
\ No newline at end of file
+1414
+((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' _210) ((B _12) _1)) _393))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _392))) ((A :10 (((S' P) _2) (((C' _13) _1) _1161))) ((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' _207) _12) _198))) ((A :20 (((S' B) _14) (((C' _210) _12) _199))) ((A :21 _1246) ((A :22 ((B _1287) _21)) ((A :23 (((S' _1287) _21) I)) ((A :24 _1216) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1245) ((C _197) _26))) ((A :28 (((C' _27) ((_206 _1257) _109)) ((_197 (_34 _1259)) _108))) ((A :29 ((B ((S _1287) (_34 _1259))) _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) _392)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _393)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1161)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1161))) ((A :46 ((C _43) _198)) ((A :47 ((B _200) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _200) _48)) ((A :50 T) ((A :51 ((_205 ((B (B (_195 _50))) ((B ((C' C) _54)) (B P)))) (_209 _51))) ((A :52 (((((_11 _51) ((B (_195 _50)) P)) (_38 _53)) ((B (B (_195 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_195 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_197 _465)) _54)) ((A :56 ((B (_195 _50)) (B (P _1161)))) ((A :57 ((B (_195 _50)) (BK (P _1161)))) ((A :58 ((_195 _50) ((S P) I))) ((A :59 ((B (_195 _50)) ((C (S' P)) I))) ((A :60 ((_135 ((C ((C S') _65)) I)) (_139 _60))) ((A :61 (((_1385 (K ((P (_1394 "False")) (_1394 "True")))) (_1390 _61)) (_1391 _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 ((_135 _1210) _1211)) ((A :75 ((((((((_425 _74) (_434 _75)) _1212) _1213) _1214) _1215) (_439 _75)) (_440 _75))) ((A :76 ((_135 _1220) (_139 _76))) ((A :77 ((((((((_425 _76) _1219) (((C' (C' (_136 _441))) _1219) _445)) (((C' (C' (_137 _441))) _1219) _447)) (((C' (C' (_136 _441))) _1219) _447)) (((C' (C' (_137 _441))) _1219) _447)) (_439 _77)) (_440 _77))) ((A :78 ((_69 (_79 #0)) (_79 #127))) ((A :79 _1221) ((A :80 _1222) ((A :81 (((S' _64) (_1213 #97)) ((C _1213) #122))) ((A :82 (((S' _64) (_1213 #65)) ((C _1213) #90))) ((A :83 (((S' _63) _81) _82)) ((A :84 (((S' _64) (_1213 #48)) ((C _1213) #57))) ((A :85 (((S' _63) _83) _84)) ((A :86 (((S' _64) (_1213 #32)) ((C _1213) #126))) ((A :87 (((S' _63) ((C (_136 _74)) #32)) (((S' _63) ((C (_136 _74)) #9)) ((C (_136 _74)) #10)))) ((A :88 ((S ((S (((S' _64) (_1213 #65)) ((C _1213) #90))) (_68 (((noMatch "lib/Data/Char.hs") #72) #9)))) ((B _79) (((C' (_410 _211)) (((C' (_411 _211)) _80) (_80 #65))) (_80 #97))))) ((A :89 ((S ((S (((S' _64) (_1213 #97)) ((C _1213) #97))) (_68 (((noMatch "lib/Data/Char.hs") #76) #9)))) ((B _79) (((C' (_410 _211)) (((C' (_411 _211)) _80) (_80 #97))) (_80 #65))))) ((A :90 (((_1385 (K ((C ((S ((C ==) #39)) ((B (_197 (_1393 #39))) (((C' _197) ((B _1394) _91)) (_1393 #39))))) (_1394 "'\92&''")))) (_1390 _90)) ((B (_197 (_1393 #34))) (Y ((B (P (_1393 #34))) (((S' C) ((
\ No newline at end of file
--- a/lib/Data/Int.hs
+++ b/lib/Data/Int.hs
@@ -19,7 +19,7 @@
(+) = primIntAdd
(-) = primIntSub
(*) = primIntMul
- negate x = primIntSub 0 x
+ negate x = primIntNeg x
abs x = if x < 0 then negate x else x
signum x =
case compare x 0 of
--- a/lib/Data/Word.hs
+++ b/lib/Data/Word.hs
@@ -2,6 +2,7 @@
-- See LICENSE file for full license.
module Data.Word(module Data.Word, Word) where
import Primitives
+import Data.Bits
import Data.Bool_Type
import Data.Bounded
import Data.Char
@@ -69,6 +70,20 @@
instance Enum Word where
toEnum = primIntToWord
fromEnum = primWordToInt
+
+--------------------------------
+
+instance Bits Word where
+ (.&.) = primWordAnd
+ (.|.) = primWordOr
+ xor = primWordXor
+ complement = primWordInv
+ shiftL = primWordShl
+ shiftR = primWordShr
+-- bitSizeMaybe _ = Just 64 -- XXX
+ bitSize _ = 64
+ bit n = primWordShl 1 n
+ zeroBits = 0
--------------------------------
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -34,6 +34,8 @@
primIntRem = primitive "rem"
primIntSubR :: Int -> Int -> Int
primIntSubR = primitive "subtract"
+primIntNeg :: Int -> Int
+primIntNeg = primitive "neg"
primDoubleAdd :: Double -> Double -> Double
primDoubleAdd = primitive "fadd"
@@ -72,6 +74,24 @@
primWordQuot = primitive "uquot"
primWordRem :: Word -> Word -> Word
primWordRem = primitive "urem"
+primWordAnd :: Word -> Word -> Word
+primWordAnd = primitive "and"
+primWordOr :: Word -> Word -> Word
+primWordOr = primitive "or"
+primWordXor :: Word -> Word -> Word
+primWordXor = primitive "xor"
+primWordShl :: Word -> Int -> Word
+primWordShl = primitive "shl"
+primWordShr :: Word -> Int -> Word
+primWordShr = primitive "shr"
+primWordAshr :: Word -> Int -> Word
+primWordAshr = primitive "ashr"
+primWordInv :: Word -> Word
+primWordInv = primitive "inv"
+primWordToDoubleRaw :: Word -> Double
+primWordToDoubleRaw = primitive "ffromraw"
+primWordFromDoubleRaw :: Double -> Word
+primWordFromDoubleRaw = primitive "ftoraw"
primIntEQ :: Int -> Int -> Bool
primIntEQ = primitive "=="
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -73,6 +73,16 @@
("rem", primitive "rem"), ("uquot", primitive "uquot"), ("urem", primitive "urem"),+ ("neg", primitive "neg"),+ ("and", primitive "and"),+ ("or", primitive "or"),+ ("xor", primitive "xor"),+ ("inv", primitive "inv"),+ ("shl", primitive "shl"),+ ("shr", primitive "shr"),+ ("ashr", primitive "ashr"),+ ("ftoraw", primitive "ftoraw"),+ ("ffromraw", primitive "ffromraw"), ("subtract", primitive "subtract"), ("==", primitive "=="), ("/=", primitive "/="),--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -148,10 +148,12 @@
#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,- 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_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_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,
T_ERROR, T_NODEFAULT, T_NOMATCH, T_SEQ, T_EQUAL, T_COMPARE, T_RNF,
T_IO_BIND, T_IO_THEN, T_IO_RETURN, T_IO_GETCHAR, T_IO_PUTCHAR,
@@ -648,6 +650,14 @@
{ "uquot", T_UQUOT }, { "urem", T_UREM }, { "subtract", T_SUBR },+ { "neg", T_NEG },+ { "and", T_AND },+ { "or", T_OR },+ { "xor", T_XOR },+ { "inv", T_INV },+ { "shl", T_SHL },+ { "shr", T_SHR },+ { "ashr", T_ASHR }, { "fadd" , T_FADD}, { "fsub" , T_FSUB}, { "fmul" , T_FMUL},@@ -661,6 +671,8 @@
{ "fge", T_FGE}, { "fshow", T_FSHOW}, { "fread", T_FREAD},+ { "ftoraw", T_FTORAW},+ { "ffromraw", T_FFROMRAW}, { "==", T_EQ }, { "/=", T_NE }, { "<", T_LT },@@ -1389,6 +1401,14 @@
case T_UQUOT: fprintf(f, "uquot"); break;
case T_UREM: fprintf(f, "urem"); break;
case T_SUBR: fprintf(f, "subtract"); break;
+ case T_NEG: fprintf(f, "neg"); break;
+ case T_AND: fprintf(f, "and"); break;
+ case T_OR: fprintf(f, "or"); break;
+ case T_XOR: fprintf(f, "xor"); break;
+ case T_INV: fprintf(f, "inv"); break;
+ case T_SHL: fprintf(f, "shl"); break;
+ case T_SHR: fprintf(f, "shr"); break;
+ case T_ASHR: fprintf(f, "ashr"); break;
case T_FADD: fprintf(f, "fadd"); break;
case T_FSUB: fprintf(f, "fsub"); break;
case T_FMUL: fprintf(f, "fmul"); break;
@@ -1402,6 +1422,8 @@
case T_FGE: fprintf(f, "fge"); break;
case T_FSHOW: fprintf(f, "fshow"); break;
case T_FREAD: fprintf(f, "fread"); break;
+ case T_FTORAW: fprintf(f, "ftoraw"); break;
+ case T_FFROMRAW: fprintf(f, "ffromraw"); break;
case T_EQ: fprintf(f, "=="); break;
case T_NE: fprintf(f, "/="); break;
case T_LT: fprintf(f, "<"); break;
@@ -1770,9 +1792,10 @@
#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 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 OPINT1(e) do { CHECK(1); xi = evalint(ARG(TOP(0))); e; POP(1); 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 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@@ -1834,6 +1857,14 @@
case T_SUBR: OPINT2(r = yi - xi); SETINT(n, r); RET;
case T_UQUOT: ARITHBINU(/);
case T_UREM: ARITHBINU(%);
+ case T_NEG: ARITHUN(-);
+ case T_AND: ARITHBIN(&);
+ case T_OR: ARITHBIN(|);
+ case T_XOR: ARITHBIN(^);
+ case T_INV: ARITHUN(~);
+ case T_SHL: ARITHBIN(<<);
+ case T_SHR: ARITHBINU(>>);
+ case T_ASHR: ARITHBIN(>>);
case T_FADD: FARITHBIN(+);
case T_FSUB: FARITHBIN(-);
@@ -1881,6 +1912,25 @@
n = TOP(-1);
// update n to be s
GOIND(s);
+
+ case T_FTORAW:
+ CHECK(1);
+ x = evali(ARG(TOP(0)));
+ GCCHECK(1);
+ y = alloc_node(T_INT);
+ SETVALUE(y, GETVALUE(x));
+ POP(1);
+ n = TOP(-1);
+ GOIND(y);
+ case T_FFROMRAW:
+ CHECK(1);
+ x = evali(ARG(TOP(0)));
+ GCCHECK(1);
+ y = alloc_node(T_DOUBLE);
+ SETVALUE(y, GETVALUE(x));
+ POP(1);
+ n = TOP(-1);
+ GOIND(y);
case T_EQ: CMP(==);
case T_NE: CMP(!=);
--
⑨