ref: 8ca938fdab80f32b770ce009c2fdb441a41a0109
parent: de8a34be8d454fc01884b4fb4e066c562b06f4e7
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Thu Sep 21 08:36:52 EDT 2023
Implement catch.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.4
-872
-(($A :0 ((_664 _613) (($B ((($S' ($C (($C (($C $S') _3)) ((($C' ($C' $P)) ((($C' $B) _1) _596)) ($K ($K (_808 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] [ModuleName]"))))))) (($S (($S ((($S' _21) (($B _717) (_704 (_656 "-v")))) ((_733 _656) "-r"))) (($B (_698 (($O 46) $K))) (($B _762) (_703 ((_722 _784) "-i")))))) (($B (_763 _729)) ((($C' _700) (($B _762) (_703 ((_722 _784) "-o")))) (($O "out.comb") $K))))) (_704 ((_764 _804) ((_764 (_656 (($O 45) $K))) (_715 1)))))) (_725 ((_764 _804) (_656 "--")))))) (($A :1 ((($S' ($S' _664)) _30) (($B ($B ($B (_664 _694)))) ((($C' ($C' ($C' $C))) ((($C' $B) (($B ($C' $C)) ((($C' ($S' ($C' $C'))) (($B ($B ($B $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($S' ($C' $S'))))) ((($C' ($C' ($C' ($C' ($C' $C'))))) ((($C' ($S' ($C' ($C' ($C' $C'))))) (($B ($B ($B ($B $B')))) ((($C' ($S' ($C' $B))) (($B ($B ($B $C))) ((($S' $B) ($B' (($B ($S' $C')) (($B $B') (($B ($B _665)) ((($C' $B) (($B _763) (($B _684) ((($C' _799) _22) 0)))) (($B (_763 _687)) (($B (_700 "top level defns: ")) _644)))))))) ((($S' ($C' $B)) (($B $B') (($B $B') (($B $B') (($B ($B _665)) ((($C' $B) (($B _763) (($B _684) ((($C' _799) _22) 1)))) (_683 ($T (($B ($B (_763 _687))) ((($C' $B) (($B _700) ((($C' _700) _602) " = "))) (($C _422) $K))))))))))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' _23))) ((($S' $B) (($B ($C' ($C' _665))) ((($C' $B) ($B' (($B _763) (($B _689) _25)))) (($B _700) ((($C' _700) (($B (_700 _2)) _644)) (($O 10) $K)))))) (($B ($B (_664 _694))) ((($C' $B) ($B' (($B _763) (($B _684) ((($C' _799) _22) 0))))) (($B ($B (_763 _687))) ((($C' ($C' _700)) (($B ($B (_700 "final pass "))) (($B ($B (_658 6))) (($B ($B _644)) _793)))) "ms"))))))) _16))))) ($C $P)))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($C _705)) _422))) (($C _718) (_734 0)))) $K))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B (($C' $B) (($B _764) (($B _700) ((($C' _700) (($B (_700 "(($A :")) _644)) (($O 32) $K))))))) ((($C' $B) (($B ($C' _764)) ($B _422))) (($B (_764 (_700 ") "))) (($C _764) (_700 (($O 41) $K))))))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _397)) $I))) ($BK $K))) $K))))) (($B (($S' _763) (($B _760) (($B (_763 _808)) (($B (_700 "main: findIdent: ")) _602))))) (($C' _632) _599)))) _639))) (($B ($B _636)) (($B (($C' _702) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _599))) $K)))))) (($C _718) (_734 0))))))) (($C _605) (_596 "main")))) (($B (_763 _396)) (($B (_763 _596)) (($B (_700 (($O 95) $K))) _644))))))) (($A :2 "v3.4\10&") (($A :3 (($B (_665 (_687 "Type ':quit' to quit"))) ((($C' _664) (($B (_570 _5)) ($P _4))) ($K (_666 _810))))) (($A :4 ((_700 ((_700 ((_700 ((_700 "module ") _6)) "(module ")) _6)) ") where\10&import Prelude\10&import Unsafe.Coerce\10&")) (($A :5 ((_571 ((_763 _580) ((_13 ".mhsi") "> "))) (($P _5) (($C (($S (($C $equal) ":quit")) ((($C' _572) _9) _5))) ((_763 _580) (_687 "Bye")))))) (($A :6 "Interactive") (($A :7 "_it") (($A :8 ((($C' _700) (_700 ((_700 ((_700 ((_700 _7) " :: Any\10&")) _7)) " = unsafeCoerce ("))) (($O 41) $K))) (($A :9 (($B (_571 _579)) (($B $T) ((($S' ($S' $B)) (($B ($B _571)) (($B ($B _10)) (($B (($C' _700) (($C _700) (($O 10) $K)))) _8)))) ((($C' ($C' ($C' $P))) (($B ($B $BK)) (($B ($B (($C' (($S' _571) _10)) (($B ($B ($P (($B (_763 _580)) _687)))) (($B $BK) (($B ($B _578)) ($C $P))))))) (($C' _700) (($C _700) (($O 10) $K)))))) _11))))) (($A :10 ((($C' _572) (($B (_763 _580)) (_689 ((_700 _6) ".hs")))) ((_571 (_575 _772)) ((($C' _571) (($B (_763 _580)) (($C _30) (_596 _6)))) (($B _573) _775))))) (($A :11 (($B (($B (_763 _580)) (($S (($C _868) (_687 "Type must be Int or IO"))) (($B (_763 _687)) (($B (_763 _644)) _20))))) (($B _17) ($P (_596 ((_700 ((_700 _6) (($O 46) $K))) _7)))))) (($A :12 ((($C' _665) _685) ((_664 (((_15 (($P _697) _697)) $K) $K)) ($T ($K _666))))) (($A :13 ((($S' $B) (($B _664) (($C _677) _660))) (($B ($B (($C' _664) (($P (_666 _697)) ((($C' _664) _691) (($B ((($S' _696) _717) _666)) _653)))\ No newline at end of file
+874
+(($A :0 ((_664 _613) (($B ((($S' ($C (($C (($C $S') _3)) ((($C' ($C' $P)) ((($C' $B) _1) _596)) ($K ($K (_809 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] [ModuleName]"))))))) (($S (($S ((($S' _21) (($B _718) (_705 (_656 "-v")))) ((_734 _656) "-r"))) (($B (_699 (($O 46) $K))) (($B _763) (_704 ((_723 _785) "-i")))))) (($B (_764 _730)) ((($C' _701) (($B _763) (_704 ((_723 _785) "-o")))) (($O "out.comb") $K))))) (_705 ((_765 _805) ((_765 (_656 (($O 45) $K))) (_716 1)))))) (_726 ((_765 _805) (_656 "--")))))) (($A :1 ((($S' ($S' _664)) _30) (($B ($B ($B (_664 _695)))) ((($C' ($C' ($C' $C))) ((($C' $B) (($B ($C' $C)) ((($C' ($S' ($C' $C'))) (($B ($B ($B $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($S' ($C' $S'))))) ((($C' ($C' ($C' ($C' ($C' $C'))))) ((($C' ($S' ($C' ($C' ($C' $C'))))) (($B ($B ($B ($B $B')))) ((($C' ($S' ($C' $B))) (($B ($B ($B $C))) ((($S' $B) ($B' (($B ($S' $C')) (($B $B') (($B ($B _665)) ((($C' $B) (($B _764) (($B _685) ((($C' _800) _22) 0)))) (($B (_764 _688)) (($B (_701 "top level defns: ")) _644)))))))) ((($S' ($C' $B)) (($B $B') (($B $B') (($B $B') (($B ($B _665)) ((($C' $B) (($B _764) (($B _685) ((($C' _800) _22) 1)))) (_684 ($T (($B ($B (_764 _688))) ((($C' $B) (($B _701) ((($C' _701) _602) " = "))) (($C _422) $K))))))))))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' _23))) ((($S' $B) (($B ($C' ($C' _665))) ((($C' $B) ($B' (($B _764) (($B _690) _25)))) (($B _701) ((($C' _701) (($B (_701 _2)) _644)) (($O 10) $K)))))) (($B ($B (_664 _695))) ((($C' $B) ($B' (($B _764) (($B _685) ((($C' _800) _22) 0))))) (($B ($B (_764 _688))) ((($C' ($C' _701)) (($B ($B (_701 "final pass "))) (($B ($B (_658 6))) (($B ($B _644)) _794)))) "ms"))))))) _16))))) ($C $P)))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($C _706)) _422))) (($C _719) (_735 0)))) $K))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B (($C' $B) (($B _765) (($B _701) ((($C' _701) (($B (_701 "(($A :")) _644)) (($O 32) $K))))))) ((($C' $B) (($B ($C' _765)) ($B _422))) (($B (_765 (_701 ") "))) (($C _765) (_701 (($O 41) $K))))))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _397)) $I))) ($BK $K))) $K))))) (($B (($S' _764) (($B _761) (($B (_764 _809)) (($B (_701 "main: findIdent: ")) _602))))) (($C' _632) _599)))) _639))) (($B ($B _636)) (($B (($C' _703) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _599))) $K)))))) (($C _719) (_735 0))))))) (($C _605) (_596 "main")))) (($B (_764 _396)) (($B (_764 _596)) (($B (_701 (($O 95) $K))) _644))))))) (($A :2 "v3.4\10&") (($A :3 (($B (_665 (_688 "Type ':quit' to quit"))) ((($C' _664) (($B (_570 _5)) ($P _4))) ($K (_666 _811))))) (($A :4 ((_701 ((_701 ((_701 ((_701 "module ") _6)) "(module ")) _6)) ") where\10&import Prelude\10&import Unsafe.Coerce\10&")) (($A :5 ((_571 ((_764 _580) ((_13 ".mhsi") "> "))) (($P _5) (($C (($S (($C $equal) ":quit")) ((($C' _572) _9) _5))) ((_764 _580) (_688 "Bye")))))) (($A :6 "Interactive") (($A :7 "_it") (($A :8 ((($C' _701) (_701 ((_701 ((_701 ((_701 _7) " :: Any\10&")) _7)) " = unsafeCoerce ("))) ")\10&")) (($A :9 (($B (_571 _579)) (($B $T) ((($S' ($S' $B)) (($B ($B _571)) (($B ($B _10)) (($B (($C' _701) (($C _701) (($O 10) $K)))) _8)))) ((($C' ($C' ($C' $P))) (($B ($B $BK)) (($B ($B (($C' (($S' _571) _10)) (($B ($B ($P (($B (_764 _580)) _688)))) (($B $BK) (($B ($B _578)) ($C $P))))))) ((($C' ($C' _701)) ($C _701)) (($O 10) $K))))) _11))))) (($A :10 ((($C' _572) (($B (_764 _580)) (_690 ((_701 _6) ".hs")))) ((_571 (_575 _773)) ((($C' _571) (($B (_764 _580)) (($C _30) (_596 _6)))) (($B _573) _776))))) (($A :11 (($B (($B (_764 _580)) (($S (($S _870) (($S (($C _871) (_688 "Type must be Int or IO"))) _20))) (($B (_764 _688)) (($B (_764 _644)) _20))))) (($B _17) ($P (_596 ((_701 ((_701 _6) (($O 46) $K))) _7)))))) (($A :12 ((($C' _665) _686) ((_664 (((_15 (($P _698) _698)) $K) $K)) ($T ($K _666))))) (($A :13 ((($S' $B) (($B _664) (($C _678) _660))) (($B ($B (($C' _664) (($P (_666 _698)) ((($C' _664) _692) (($B ((($S' _6\ No newline at end of file
--- a/ghc/Primitives.hs
+++ b/ghc/Primitives.hs
@@ -168,8 +168,11 @@
primGetRaw :: IO Int
primGetRaw = return (-1) -- not implemented
+primCatch :: forall a . IO a -> (String -> IO a) -> IO a
+primCatch = error "primCatch"
+
-- Temporary until overloading
primIsInt :: Any -> Bool
-primIsInt = error "isInt"
+primIsInt = error "primIsInt"
primIsIO :: Any -> Bool
-primIsIO = error "isIO"
+primIsIO = error "primIsIO"
--- /dev/null
+++ b/lib/Control/Exception.hs
@@ -1,0 +1,20 @@
+module Control.Exception(
+ catch, try,
+ throwIO,
+ Exn(..)
+ ) where
+import Primitives
+import Prelude
+
+newtype Exn = Exn String
+
+catch :: forall a . IO a -> (Exn -> IO a) -> IO a
+catch ioa hdl = primCatch ioa (hdl . Exn)
+
+try :: forall a . IO a -> IO (Either Exn a)
+try ioa = catch (fmap Right ioa) (return . Left)
+
+throwIO :: forall a . Exn -> IO a
+throwIO (Exn s) =
+ let e = error s
+ in seq e (return e)
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -144,6 +144,10 @@
primWithDropArgs :: forall a . Int -> IO a -> IO a
primWithDropArgs i ioa = primThen (primDropArgs i) ioa
+-- Use string for the exception until we can do better.
+primCatch :: forall a . IO a -> ([Char] -> IO a) -> IO a
+primCatch = primitive "IO.catch"
+
-- Temporary until overloading
primIsInt :: Any -> Bool
primIsInt = primitive "isInt"
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -102,6 +102,7 @@
("IO.dropArgs", primitive "IO.dropArgs"), ("IO.performIO", primitive "IO.performIO"), ("IO.getTimeMilli", primitive "IO.getTimeMilli"),+ ("IO.catch", primitive "IO.catch"), ("isInt", primitive "isInt"), ("isIO", primitive "isIO")]
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -7,6 +7,7 @@
#include <inttypes.h>
#include <locale.h>
#include <ctype.h>
+#include <setjmp.h>
#define GCRED 1 /* do some reductions during GC */
#define FASTTAGS 1 /* compute tag by pointer subtraction */
@@ -154,7 +155,7 @@
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,
T_IO_PERFORMIO,
- T_IO_GETTIMEMILLI, T_IO_PRINT,
+ T_IO_GETTIMEMILLI, T_IO_PRINT, T_IO_CATCH,
T_IO_CCALL, T_IO_GETRAW, T_IO_FLUSH,
T_STR,
T_ISINT, T_ISIO,
@@ -262,11 +263,18 @@
heapoffs_t next_scan_index;
typedef struct {- size_t b_size;
- size_t b_pos;
+ size_t b_size;
+ size_t b_pos;
uint8_t b_buffer[1];
} BFILE;
+struct handler {+ jmp_buf hdl_buf; /* env storage */
+ struct handler *hdl_old; /* old handler */
+ stackptr_t hdl_stack; /* old stack pointer */
+ NODEPTR hdl_exn; /* used temporarily to pass the exception value */
+} *cur_handler = 0;
+
void
memerr(void)
{@@ -459,6 +467,7 @@
{ "IO.dropArgs", T_IO_DROPARGS }, { "IO.getTimeMilli", T_IO_GETTIMEMILLI }, { "IO.performIO", T_IO_PERFORMIO },+ { "IO.catch", T_IO_CATCH }, { "isInt", T_ISINT }, { "isIO", T_ISIO },};
@@ -1140,6 +1149,7 @@
case T_IO_GETTIMEMILLI: fprintf(f, "$IO.getTimeMilli"); break;
case T_IO_PERFORMIO: fprintf(f, "$IO.performIO"); break;
case T_IO_CCALL: fprintf(f, "#%s", ffi_table[GETVALUE(n)].ffi_name); break;
+ case T_IO_CATCH: fprintf(f, "$IO.catch"); break;
case T_ISINT: fprintf(f, "$isInt"); break;
case T_ISIO: fprintf(f, "$isIO"); break;
default: ERR("print tag");@@ -1398,7 +1408,7 @@
#define CHKARG4 do { CHECK(4); POP(4); n = TOP(-1); w = ARG(n); z = ARG(TOP(-2)); y = ARG(TOP(-3)); x = ARG(TOP(-4)); } while(0)/* Alloc a possible GC action, e, between setting x and popping */
-#define CHKARGEV1(e) do { CHECK(1); x = ARG(TOP(0)); e; POP(1); n = TOP(-1); } while(0)+#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 OPINT2(e) do { CHECK(2); xi = evalint(ARG(TOP(0))); yi = evalint(ARG(TOP(1))); e; POP(2); n = TOP(-1); } while(0);@@ -1471,7 +1481,19 @@
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_ERROR:
+ if (cur_handler) {+ /* Pass the string to the handler */
+ CHKARG1;
+ cur_handler->hdl_exn = x;
+ longjmp(cur_handler->hdl_buf, 1);
+ } else {+ /* No handler, so just die. */
+ 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);
@@ -1496,6 +1518,7 @@
case T_IO_DROPARGS:
case T_IO_GETTIMEMILLI:
case T_IO_CCALL:
+ case T_IO_CATCH:
RET;
case T_ISINT:
@@ -1709,6 +1732,35 @@
case FFI_IIV: FFIV(1); x = INTARG(1); y = INTARG(2); (*(void (*)(value_t, value_t))f)(x,y); RETIO(combUnit);
case FFI_III: FFI (1); x = INTARG(1); y = INTARG(2); r = (*(value_t (*)(value_t, value_t))f)(x,y); n = mkInt(r); RETIO(n);
default: ERR("T_IO_CCALL");+ }
+ }
+
+ case T_IO_CATCH:
+ {+ struct handler *h = malloc(sizeof *h);
+ if (!h)
+ memerr();
+ CHECKIO(2);
+ h->hdl_old = cur_handler;
+ h->hdl_stack = stack_ptr;
+ cur_handler = h;
+ if (setjmp(h->hdl_buf)) {+ /* An exception occurred: */
+ stack_ptr = h->hdl_stack;
+ x = h->hdl_exn; /* exception value */
+ GCCHECKSAVE(x, 1);
+ f = ARG(TOP(2)); /* second argument, handler */
+ n = new_ap(f, x);
+ cur_handler = h->hdl_old;
+ free(h);
+ POP(3);
+ goto top;
+ } else {+ /* Normal execution: */
+ n = evalio(ARG(TOP(1))); /* execute first argument */
+ cur_handler = h->hdl_old; /* restore old handler */
+ free(h);
+ RETIO(n); /* return result */
}
}
--- /dev/null
+++ b/tests/Catch.hs
@@ -1,0 +1,10 @@
+module Catch(main) where
+import Prelude
+import Control.Exception
+
+main :: IO ()
+main = do
+ x <- catch (return ("o" ++ "k")) (\ _ -> return "what?")+ putStrLn $ showString x
+ y <- catch (do { error "bang!"; return "huh?" }) (\ (Exn s) -> return s)+ putStrLn $ showString y
--- /dev/null
+++ b/tests/Catch.ref
@@ -1,0 +1,2 @@
+"ok"
+"bang!"
--- a/tests/Makefile
+++ b/tests/Makefile
@@ -19,6 +19,7 @@
$(MHS) MutRec && $(EVAL) > MutRec.out && diff MutRec.ref MutRec.out
$(MHS) LocalPoly && $(EVAL) > LocalPoly.out && diff LocalPoly.ref LocalPoly.out
$(MHS) Rank2 && $(EVAL) > Rank2.out && diff Rank2.ref Rank2.out
+ $(MHS) Catch && $(EVAL) > Catch.out && diff Catch.ref Catch.out
time:
@echo Expect about 10s runtime
--
⑨