Verified Commit 6b739b79 authored by Camil Staps's avatar Camil Staps 🚀

Return DeserializedValue from copy_to_host when hyperstrict is set

parent 4072012b
Pipeline #17553 passed with stages
in 17 minutes and 25 seconds
......@@ -102,6 +102,7 @@ deserialize` strict dsets {graph,descinfo,modules,bytecode} thisexe w
pgm
heap dsets.heap_size stack dsets.stack_size
asp bsp csp heap
strict
# graph_node = string_to_interpreter int_syms graph ie_settings
#! (ie,_) = make_finalizer ie_settings
# ie = {ie_finalizer=ie, ie_snode_ptr=0, ie_snodes=create_array_ 1}
......@@ -177,6 +178,7 @@ get_start_rule_as_expression dsets prog filename w
pgm
heap dsets.heap_size stack dsets.stack_size
asp bsp csp heap
False
# start_node = build_start_node ie_settings
#! (ie,_) = make_finalizer ie_settings
# ie = {ie_finalizer=ie, ie_snode_ptr=0, ie_snodes=create_array_ 1}
......@@ -186,9 +188,9 @@ get_start_rule_as_expression dsets prog filename w
// it to the finalizer_list anyway. This is just to ensure that the first
// call to interpret gets the right argument.
build_interpretation_environment :: !Pointer !Pointer !Int !Pointer !Int !Pointer !Pointer !Pointer !Pointer -> Pointer
build_interpretation_environment pgm heap hsize stack ssize asp bsp csp hp = code {
ccall build_interpretation_environment "ppIpIpppp:p"
build_interpretation_environment :: !Pointer !Pointer !Int !Pointer !Int !Pointer !Pointer !Pointer !Pointer !Bool -> Pointer
build_interpretation_environment pgm heap hsize stack ssize asp bsp csp hp strict = code {
ccall build_interpretation_environment "ppIpIppppI:p"
}
build_start_node :: !Pointer -> Pointer
......
......@@ -49,10 +49,19 @@ extern void *e__ABC_PInterpreter_PInternal__dinterpret__29;
extern void *e__ABC_PInterpreter_PInternal__dinterpret__30;
extern void *e__ABC_PInterpreter_PInternal__dinterpret__31;
extern void *e__ABC_PInterpreter__dDV__ParseError;
extern void *e__ABC_PInterpreter__dDV__HeapFull;
extern void *e__ABC_PInterpreter__dDV__StackOverflow;
extern void *e__ABC_PInterpreter__dDV__Halt;
extern void *e__ABC_PInterpreter__dDV__IllegalInstruction;
extern void *e__ABC_PInterpreter__dDV__HostHeapFull;
extern void *e__ABC_PInterpreter__dDV__Ok;
struct interpretation_environment *build_interpretation_environment(
struct program *program,
BC_WORD *heap, BC_WORD heap_size, BC_WORD *stack, BC_WORD stack_size,
BC_WORD *asp, BC_WORD *bsp, BC_WORD *csp, BC_WORD *hp) {
BC_WORD *asp, BC_WORD *bsp, BC_WORD *csp, BC_WORD *hp,
int hyperstrict) {
struct interpretation_environment *ie = safe_malloc(sizeof(struct interpretation_environment));
ie->host = safe_malloc(sizeof(struct host_status));
ie->program = program;
......@@ -67,7 +76,7 @@ struct interpretation_environment *build_interpretation_environment(
ie->caf_list[0] = 0;
ie->caf_list[1] = &ie->caf_list[1];
ie->options.in_first_semispace=1;
ie->options.hyperstrict=0;
ie->options.hyperstrict=hyperstrict != 0;
#if DEBUG_CLEAN_LINKS > 0
EPRINTF("Building interpretation_environment %p\n",ie);
#endif
......@@ -889,37 +898,98 @@ static inline void restore_and_translate_descriptors(struct InterpretationEnviro
}
}
static int evaluate_all_children(struct interpretation_environment *ie) {
BC_WORD *start_a_stack=ie->asp;
ie->asp[1]=ie->asp[0];
ie->asp++;
while (ie->asp > start_a_stack) {
BC_WORD *node=(BC_WORD*)ie->asp[0];
if (!(node[0] & 2)) {
if (interpret_ie(ie, (BC_WORD*)node[0]) != 0) {
ie->asp=start_a_stack;
EPRINTF("Failed to interpret\n");
return -1;
}
}
node=(BC_WORD*)*ie->asp--;
int16_t a_arity=((int16_t*)node[0])[-1];
int16_t ab_arity=a_arity;
if (a_arity > 256) { /* record */
a_arity=((int16_t*)node[0])[0];
ab_arity=((int16_t*)node[0])[-1]-256;
}
if (a_arity > 0) {
if (!(((BC_WORD*)node[1])[0] & 2))
*++ie->asp=node[1];
if (a_arity > 1) {
if (ab_arity==2) {
if (!(((BC_WORD*)node[2])[0] & 2))
*++ie->asp=node[2];
} else {
BC_WORD *rest=(BC_WORD*)node[2];
for (a_arity-=2; a_arity>=0; a_arity--)
if (!(((BC_WORD*)rest[a_arity])[0] & 2))
*++ie->asp=rest[a_arity];
}
}
}
}
return 0;
}
extern void __interpret__garbage__collect(struct interpretation_environment*);
int copy_to_host_or_garbage_collect(struct InterpretationEnvironment *clean_ie,
BC_WORD *host_heap, BC_WORD **target, BC_WORD *node) {
struct interpretation_environment *ie = (struct interpretation_environment*) clean_ie->__ie_finalizer->cur->arg;
int words_needed=COPIED_NODE_SIZE(node, 0);
int copy_to_host_or_garbage_collect(struct interpretation_environment *ie,
BC_WORD **target, BC_WORD *node, int hyperstrict_if_requested) {
int words_needed=0;
if (hyperstrict_if_requested && ie->options.hyperstrict) {
*++ie->asp=(BC_WORD)node;
evaluate_all_children(ie);
node=(BC_WORD*)*ie->asp--;
words_needed+=2;
}
words_needed+=COPIED_NODE_SIZE(node, 0);
if (words_needed > ie->host->host_hp_free) {
*ie->host->host_a_ptr++=(BC_WORD)clean_ie;
*ie->host->host_a_ptr++=(BC_WORD)ie->host->clean_ie;
__interpret__garbage__collect(ie);
ie->host->clean_ie=clean_ie=(struct InterpretationEnvironment*)*--ie->host->host_a_ptr;
host_heap=ie->host->host_hp_ptr;
ie->host->clean_ie=(struct InterpretationEnvironment*)*--ie->host->host_a_ptr;
if (words_needed > ie->host->host_hp_free) {
EPRINTF("not enough memory to copy node back to host\n");
interpreter_exit(1);
}
}
BC_WORD *new_heap=COPY_TO_HOST(clean_ie,host_heap,target,node,0);
int words_used=new_heap-host_heap;
BC_WORD *new_heap;
if (hyperstrict_if_requested && ie->options.hyperstrict) {
*target=ie->host->host_hp_ptr;
ie->host->host_hp_ptr[0]=(BC_WORD)&e__ABC_PInterpreter__dDV__Ok+IF_MACH_O_ELSE(16,8)+2;
new_heap=COPY_TO_HOST(ie->host->clean_ie,&ie->host->host_hp_ptr[2],(BC_WORD**)&ie->host->host_hp_ptr[1],node,0);
} else {
new_heap=COPY_TO_HOST(ie->host->clean_ie,ie->host->host_hp_ptr,target,node,0);
}
int words_used=new_heap-ie->host->host_hp_ptr;
if (words_used != words_needed) {
EPRINTF("internal error in copy_to_host: precomputed words needed %d does not match actual number %d\n",words_needed,words_used);
interpreter_exit(1);
}
restore_and_translate_descriptors(clean_ie, ie->program, node);
restore_and_translate_descriptors(ie->host->clean_ie, ie->program, node);
return words_used;
}
// Used to communicate redirect host thunks with the ASM interface; see #51
/* Used to communicate redirect host thunks with the ASM interface; see #51 */
void *__interpret__copy__node__asm_redirect_node;
/**
......@@ -975,8 +1045,7 @@ BC_WORD copy_interpreter_to_host(void *__dummy_0, void *__dummy_1,
interpreter_exit(1);
}
return copy_to_host_or_garbage_collect(ie->host->clean_ie, ie->host->host_hp_ptr,
(BC_WORD**)&__interpret__copy__node__asm_redirect_node, node);
return copy_to_host_or_garbage_collect(ie, (BC_WORD**)&__interpret__copy__node__asm_redirect_node, node, 1);
}
/**
......@@ -1057,6 +1126,5 @@ BC_WORD copy_interpreter_to_host_n(void *__dummy_0, void *__dummy_1,
interpreter_exit(1);
}
return copy_to_host_or_garbage_collect(ie->host->clean_ie, ie->host->host_hp_ptr,
(BC_WORD**)&__interpret__copy__node__asm_redirect_node, node);
return copy_to_host_or_garbage_collect(ie, (BC_WORD**)&__interpret__copy__node__asm_redirect_node, node, 1);
}
......@@ -5,8 +5,8 @@
#include "interpret.h"
void interpreter_finalizer(BC_WORD interpret_node);
int copy_to_host_or_garbage_collect(struct InterpretationEnvironment *clean_ie,
BC_WORD *host_heap, BC_WORD **target, BC_WORD *node);
int copy_to_host_or_garbage_collect(struct interpretation_environment *ie,
BC_WORD **target, BC_WORD *node, int hyperstrict_if_requested);
extern BC_WORD *__interpret__evaluate__host(
struct interpretation_environment *ie, BC_WORD *node);
#ifdef WINDOWS
......
......@@ -9120,9 +9120,8 @@ jsr_eval_host_node_with_args:
*ie->host->host_a_ptr++=(BC_WORD)ie->host->clean_ie;
for (int i=instr_arg; i>=1; i--) {
int added_words=copy_to_host_or_garbage_collect(
ie->host->clean_ie, ie->host->host_hp_ptr,
(BC_WORD**)ie->host->host_a_ptr++, (BC_WORD*)asp[-i]);
int added_words=copy_to_host_or_garbage_collect(ie,
(BC_WORD**)ie->host->host_a_ptr++, (BC_WORD*)asp[-i], 0);
if (added_words<0) {
EPRINTF("copying to host failed\n");
interpreter_exit(1);
......
[37,37,37,37,37,37,37,37,37,37,37,37,37,37,37,37,37,37,37,37]
[(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37),(DV_Ok 37)]
......@@ -3,58 +3,77 @@ module GraphTest
import StdEnv
import StdMaybe
from Data.Func import hyperstrict
from Data.Func import hyperstrict, instance Functor ((->) a)
import Data.Functor
import System.OS
import ABC.Interpreter
instance Functor DeserializedValue
where
fmap f v = case v of
DV_Ok v -> DV_Ok (f v)
DV_ParseError -> DV_ParseError
DV_HeapFull -> DV_HeapFull
DV_StackOverflow -> DV_StackOverflow
DV_Halt -> DV_Halt
DV_IllegalInstruction -> DV_IllegalInstruction
DV_HostHeapFull -> DV_HostHeapFull
Start w
# (graph,w) = serialize_for_interpretation graph "GraphTest.bc" w
# graph = case graph of
Nothing -> abort "Could not serialize the graph; is GraphTest.bc up to date?\n"
Just g -> g
# (Just (intsquare,sub5,sub3_10,sumints,rev,foldr,ap1,ap3,map,reverse_string,reverse_array,reverse_boxed_array,reverse_recarr,recarr,toInt_rec,sumtup),w) = deserialize defaultDeserializationSettings graph (IF_WINDOWS "GraphTest.exe" "GraphTest") w
= use intsquare sub5 sub3_10 sumints rev foldr ap1 ap3 map reverse_string reverse_array reverse_boxed_array reverse_recarr recarr toInt_rec sumtup
# (DV_Ok (intsquare,sub5,sub3_10,sumints,rev,foldr,ap1,ap3,map,reverse_string,reverse_array,reverse_boxed_array,reverse_recarr,recarr,toInt_rec,repeat,sumtup),w) = deserializeStrict defaultDeserializationSettings graph (IF_WINDOWS "GraphTest.exe" "GraphTest") w
= use intsquare sub5 sub3_10 sumints rev foldr ap1 ap3 map reverse_string reverse_array reverse_boxed_array reverse_recarr recarr toInt_rec repeat sumtup
where
use ::
(Int -> Int)
(Int Int Int Int Int -> Int)
(Int Int Int -> Int)
([Int] -> Int)
(A.a: [a] -> [a])
(A.a b: (a b -> b) b [a] -> b)
((Int -> Int) -> Int)
((Int Int Int -> Int) -> Int)
(A.a b: (a -> b) [a] -> [b])
(String -> String)
({#Int} -> {#Int})
({Char} -> {Char})
({#TestRecord} -> {#TestRecord})
(Int -> DeserializedValue Int)
(Int Int Int Int Int -> DeserializedValue Int)
(Int Int Int -> DeserializedValue Int)
([Int] -> DeserializedValue Int)
(A.a: [a] -> DeserializedValue [a])
(A.a b: (a (DeserializedValue b) -> b) b [a] -> DeserializedValue b)
((Int -> Int) -> DeserializedValue Int)
((Int Int Int -> Int) -> DeserializedValue Int)
(A.a b: (a -> b) [a] -> DeserializedValue [b])
(String -> DeserializedValue String)
({#Int} -> DeserializedValue {#Int})
({Char} -> DeserializedValue {Char})
({#TestRecord} -> DeserializedValue {#TestRecord})
{#TestRecord}
(TestRecord -> Int)
((Int,Int,(Int,Int)) -> Int)
-> [Int]
use intsquare sub5 sub3_10 sumints rev foldr ap1 ap3 map reverse_string reverse_array reverse_boxed_array reverse_recarr recarr toInt_rec sumtup =
[ intsquare 6 + intsquare 1
(TestRecord -> DeserializedValue Int)
(A.a: a -> DeserializedValue [a])
((Int,Int,(Int,Int)) -> DeserializedValue Int)
-> [DeserializedValue Int]
use intsquare sub5 sub3_10 sumints rev foldr ap1 ap3 imap reverse_string reverse_array reverse_boxed_array reverse_recarr recarr toInt_rec repeat sumtup =
[ case (intsquare 6, intsquare 1) of
(DV_Ok a, DV_Ok b) -> DV_Ok (a+b)
(err, _) -> err
, sub5 (last [1..47]) 1 2 3 (square 2)
, sub3_10 -20 -30 3
, sumints [1,1,2,3,4,5,6,7,8]
, last (rev [37,36..0])
, length (last (rev [[1..i] \\ i <- [37,36..0]]))
, last <$> rev [37,36..0]
, length <$> last <$> rev [[1..i] \\ i <- [37,36..0]]
, ap1 (\x -> x - 5)
, ap1 (flip (-) 5)
, ap3 (\x y z -> 10*x + 3*y + z)
, foldr (\x y -> x + y) 0 [1,2,3,4,5,6,7,8,1]
, toInt (last (rev [TestA,TestB]))
, length [c \\ c <-: reverse_string "0123456789012345678901234567890123456"]
, length [i \\ i <-: reverse_array {#i \\ i <- [0..36]}]
, length [c \\ c <-: reverse_boxed_array {c\\ c <- ['A'..'e']}]
, sum [toInt x \\ x <-: recarr]
, sum [toInt x \\ x <-: reverse_recarr arr]
, foldr (\x (DV_Ok y) -> x + y) 0 [1,2,3,4,5,6,7,8,1]
, toInt <$> last <$> rev [TestA,TestB]
, length <$> toList <$> reverse_string "0123456789012345678901234567890123456"
, length <$> toList <$> reverse_array {#i \\ i <- [0..36]}
, length <$> toList <$> reverse_boxed_array {c\\ c <- ['A'..'e']}
, DV_Ok (sum [toInt x \\ x <-: recarr])
, sum <$> map toInt <$> toList <$> reverse_recarr arr
, toInt_rec {tr_a=37*37,tr_b=TestA,tr_c=False}
, flip (!!) 100 <$> repeat 37
, sumtup (5,10,(15,7))
: map (\x -> if (x == 0 || x == 10) 37 42) [0,10]
: case imap (\x -> if (x == 0 || x == 10) 37 42) [0,10] of
DV_Ok res -> [DV_Ok r \\ r <- res]
]
where
toList arr = [x \\ x <-: arr]
:: TestT = TestA | TestB
instance toInt TestT
......@@ -87,6 +106,7 @@ graph = hyperstrict
, reverse_recarr
, arr
, toInt_rec
, repeat
, \(a,b,(c,d)) -> a + b + c + d + 0
)
where
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment