Commit 27cc66bf authored by Camil Staps's avatar Camil Staps 🍃

Merge branch '81-runtime-error-with-currying-constructors' into 'master'

Resolve "Runtime error with currying constructors"

Closes #81

See merge request !109
parents 01f01dc6 15d1e089
Pipeline #25963 canceled with stages
in 1 minute and 25 seconds
......@@ -106,6 +106,8 @@ const char *instruction_type (BC_WORD i) {
case Cbuildhr30: return "l";
case Cbuildhr31: return "l";
case Cbuildhr40: return "l";
case Cbuild_node_rtn: return "n";
case Cbuild_node2_rtn: return "";
case Cbuild_r: return "nnlnn";
case Cbuild_ra0: return "nnl";
case Cbuild_ra1: return "nnln";
......
......@@ -78,6 +78,8 @@ enum {
INSTRUCTION(buildhr30)
INSTRUCTION(buildhr31)
INSTRUCTION(buildhr40)
INSTRUCTION(build_node_rtn)
INSTRUCTION(build_node2_rtn)
INSTRUCTION(build_r)
INSTRUCTION(build_ra0)
INSTRUCTION(build_ra1)
......
......@@ -388,35 +388,6 @@ void add_instruction(int16_t i) {
store_code_elem(BYTEWIDTH_INSTRUCTION, i);
}
struct word *add_add_arg_labels(void) {
int i;
for(i=0; i<N_ADD_ARG_LABELS; ++i)
if (Fadd_arg_label_used[i]) {
char label_name[11];
sprintf(label_name,"_add_arg%d",i);
struct label *label = enter_label(label_name);
if (label->label_module_n != -1) {
make_label_global(label);
label->label_offset = pgrm.code_size<<2;
}
add_instruction(Cadd_arg0+i);
}
if (general_add_arg_label_used) {
fprintf(stderr,"Warning: currying of functions with more than 32 arguments is not implemented.\n");
struct label *label=enter_label("_add_arg");
if (label->label_module_n!=-1) {
make_label_global(label);
label->label_offset=pgrm.code_size<<2;
}
add_instruction(Cadd_arg);
}
return pgrm.code;
}
void add_code_and_data_offsets(void) {
int i;
size_t code_offset,data_offset;
......@@ -937,6 +908,46 @@ void add_instruction_w_internal_label_label(int16_t i,int32_t n1,struct label *l
store_code_label_value(label_name,0);
}
struct word *add_add_arg_labels(void) {
int i;
for(i=0; i<N_ADD_ARG_LABELS; ++i)
if (Fadd_arg_label_used[i]) {
if (i>0) {
/* Three instructions above add_arg is the code used for fast
* applies of constructors. build_node returns; notB is not used. */
if (i==1) {
add_instruction(Cbuild_node2_rtn);
add_instruction(CnotB);
} else {
add_instruction_w(Cbuild_node_rtn,i-1);
}
add_instruction(CnotB);
}
char label_name[11];
sprintf(label_name,"_add_arg%d",i);
struct label *label = enter_label(label_name);
if (label->label_module_n != -1) {
make_label_global(label);
label->label_offset = pgrm.code_size<<2;
}
add_instruction(Cadd_arg0+i);
}
if (general_add_arg_label_used) {
fprintf(stderr,"Warning: currying of functions with more than 32 arguments is not implemented.\n");
struct label *label=enter_label("_add_arg");
if (label->label_module_n!=-1) {
make_label_global(label);
label->label_offset=pgrm.code_size<<2;
}
add_instruction(Cadd_arg);
}
return pgrm.code;
}
static char *specialized_jsr_labels[] = {
/* 0*/ "eqAC",
/* 1*/ "cmpAC",
......
......@@ -365,19 +365,14 @@ void wprint_node(WINDOW *win, BC_WORD *node, int with_arguments) {
}
void debugger_update_a_stack(BC_WORD *ptr) {
char _tmp[256];
BC_WORD *start = asp + 1;
mvwprintw(winh_a, 0, 0, "A-stack (%d)\n", ptr-start+1);
wrefresh(winh_a);
wmove(win_a, 0, 0);
while (start <= ptr) {
print_label(_tmp, 256, 0, (BC_WORD*) *start, program, hp, heap_size);
wprintw(win_a, "%3d %s", ptr-start, _tmp);
if (hp <= (BC_WORD*) *start && (BC_WORD*) *start < hp + heap_size) {
wprintw(win_a, " ");
wprint_node(win_a, (BC_WORD*) *start, 0);
}
wprintw(win_a, "%3d ",ptr-start);
wprint_node(win_a, (BC_WORD*) *start, 0);
wprintw(win_a, "\n");
start++;
}
......
......@@ -498,6 +498,7 @@ eval_to_hnf_return_failure:
pc = (BC_WORD*)program->symbol_table[program->start_symbol_id].offset;
}
BC_WORD fast_ap_descriptor=0;
#ifdef COMPUTED_GOTOS
goto **(void**)pc;
# include "interpret_instructions.h"
......
......@@ -27,4 +27,4 @@ typedef int64_t CleanInt;
#define BCGEN_INSTRUCTION_TABLE_SIZE 512
#define ABC_MAGIC_NUMBER 0x2a434241
#define ABC_VERSION 8
#define ABC_VERSION 9
......@@ -6,6 +6,7 @@ brainfuck
cafs
chars
compress
curry
e
fills
fsieve
......
[(Cons 1 (Cons 2 (Cons 3 Nil))),(Cons2 1 2 (Cons2 1 3 Nil)),(Cons3 1 2 3 (Cons3 1 2 4 Nil))]
halt at 4
102 524186 524288
[(Cons 1 (Cons 2 (Cons 3 Nil))),(Cons2 1 2 (Cons2 1 3 Nil)),(Cons3 1 2 3 (Cons3 1 2 4 Nil))]
halt at 4
102 262042 262144
module curry
:: List
= Cons Int List
| Cons2 Int Int List
| Cons3 Int Int Int List
| Nil
foldr :: (.a -> .(.b -> .b)) .b ![.a] -> .b
foldr op r l = foldr l
where
foldr [] = r
foldr [a:x] = op a (foldr x)
Start =
[ foldr Cons Nil [1,2,3]
, foldr (Cons2 1) Nil [2,3]
, foldr (Cons3 1 2) Nil [3,4]
]
Version: 1.4
Global
ProjectRoot: .
Target: StdEnv
Exec: {Project}/curry
ByteCode: {Project}/curry.bc
CodeGen
CheckStacks: False
CheckIndexes: False
GenerateByteCode: True
OptimiseABC: True
Application
HeapSize: 2097152
StackSize: 512000
ExtraMemory: 8192
IntialHeapSize: 204800
HeapSizeMultiplier: 4096
ShowExecutionTime: False
ShowGC: False
ShowStackSize: False
MarkingCollector: False
DisableRTSFlags: False
StandardRuntimeEnv: True
Profile
Memory: False
MemoryMinimumHeapSize: 0
Time: False
Stack: False
Dynamics: False
GenericFusion: False
DescExL: True
Output
Output: ShowConstructors
Font: Monaco
FontSize: 9
WriteStdErr: False
Link
LinkMethod: Static
GenerateRelocations: False
GenerateSymbolTable: False
GenerateLinkMap: False
LinkResources: False
ResourceSource:
GenerateDLL: False
ExportedNames:
StripByteCode: True
KeepByteCodeSymbols: True
PrelinkByteCode: True
Paths
Path: {Project}
Precompile:
Postlink:
MainModule
Name: curry
Dir: {Project}
Compiler
NeverMemoryProfile: False
NeverTimeProfile: False
StrictnessAnalysis: True
ListTypes: StrictExportTypes
ListAttributes: True
Warnings: True
Verbose: True
ReadableABC: False
ReuseUniqueNodes: True
Fusion: False
......@@ -23,7 +23,7 @@ lit_char :: !Char -> Expr TChar
lit_short :: !Int -> Expr TShort
lit_int :: !Int -> Expr TInt
instance to_word TWord, TChar, TInt, TShort, (TPtr t), TReal
instance to_word TWord, TPtrOffset, TChar, TInt, TShort, (TPtr t), TReal
instance to_bool TWord
instance to_char TWord
instance to_int TWord
......@@ -51,7 +51,7 @@ instance ^ (Expr TReal)
(&.) infixl 6 :: !(Expr TWord) !(Expr TWord) -> Expr TWord
(|.) infixl 6 :: !(Expr TWord) !(Expr TWord) -> Expr TWord
(<<.) infix 7 :: !(Expr TWord) !(Expr TWord) -> Expr TWord
(<<.) infix 7 :: !(Expr a) !(Expr a) -> Expr a
(>>.) infix 7 :: !(Expr a) !(Expr a) -> Expr a
xorI :: !(Expr TWord) !(Expr TWord) -> Expr TWord
~. :: !(Expr TWord) -> Expr TWord
......@@ -150,6 +150,7 @@ small_integer :: !(Expr TInt) -> Expr TWord
static_character :: !(Expr TChar) -> Expr TWord
static_boolean :: !(Expr TWord) -> Expr TWord
caf_list :: Expr (TPtr TWord)
fast_ap_descriptor :: Expr TWord
push_c :: !(Expr (TPtr TWord)) !Target -> Target
pop_pc_from_c :: !Target -> Target
......
......@@ -197,12 +197,13 @@ lit_short i = toString i
lit_int :: !Int -> Expr TInt
lit_int i = toString i
instance to_word TWord where to_word e = e
instance to_word TChar where to_word e = "(BC_WORD)("+-+e+-+")"
instance to_word TInt where to_word e = "(BC_WORD)("+-+e+-+")"
instance to_word TShort where to_word e = "(BC_WORD)("+-+e+-+")"
instance to_word (TPtr t) where to_word e = "(BC_WORD)("+-+e+-+")"
instance to_word TReal where to_word e = "*(BC_WORD*)&("+-+e+-+")"
instance to_word TWord where to_word e = e
instance to_word TPtrOffset where to_word e = "(BC_WORD)("+-+e+-+")"
instance to_word TChar where to_word e = "(BC_WORD)("+-+e+-+")"
instance to_word TInt where to_word e = "(BC_WORD)("+-+e+-+")"
instance to_word TShort where to_word e = "(BC_WORD)("+-+e+-+")"
instance to_word (TPtr t) where to_word e = "(BC_WORD)("+-+e+-+")"
instance to_word TReal where to_word e = "*(BC_WORD*)&("+-+e+-+")"
instance to_bool TWord
where
......@@ -264,7 +265,7 @@ instance ^ (Expr TReal) where ^ a b = "pow("+-+a+-+","+-+b+-+")"
(|.) infixl 6 :: !(Expr TWord) !(Expr TWord) -> Expr TWord
(|.) a b = "("+-+a+-+"|"+-+b+-+")"
(<<.) infix 7 :: !(Expr TWord) !(Expr TWord) -> Expr TWord
(<<.) infix 7 :: !(Expr a) !(Expr a) -> Expr a
(<<.) a b = "("+-+a+-+"<<"+-+b+-+")"
(>>.) infix 7 :: !(Expr a) !(Expr a) -> Expr a
......@@ -495,6 +496,9 @@ static_boolean b = "(BC_WORD)&static_booleans[("+-+b+-+") ? 2 : 0]"
caf_list :: Expr (TPtr TWord)
caf_list = "(BC_WORD*)caf_list"
fast_ap_descriptor :: Expr TWord
fast_ap_descriptor = "fast_ap_descriptor";
push_c :: !(Expr (TPtr TWord)) !Target -> Target
push_c v t = append ("\t*++csp=(BC_WORD)"+-+v+-+";") t
......
......@@ -56,7 +56,7 @@ instance ^ (Expr TReal)
(&.) infixl 6 :: !(Expr TWord) !(Expr TWord) -> Expr TWord
(|.) infixl 6 :: !(Expr TWord) !(Expr TWord) -> Expr TWord
(<<.) infix 7 :: !(Expr TWord) !(Expr TWord) -> Expr TWord
(<<.) infix 7 :: !(Expr a) !(Expr a) -> Expr a
(>>.) infix 7 :: !(Expr a) !(Expr a) -> Expr a
xorI :: !(Expr TWord) !(Expr TWord) -> Expr TWord
~. :: !(Expr TWord) -> Expr TWord
......@@ -153,6 +153,7 @@ small_integer :: !(Expr TInt) -> Expr TWord
static_character :: !(Expr TChar) -> Expr TWord
static_boolean :: !(Expr TWord) -> Expr TWord
caf_list :: Expr (TPtr TWord)
fast_ap_descriptor :: Expr TWord
push_c :: !(Expr (TPtr TWord)) !Target -> Target
pop_pc_from_c :: !Target -> Target
......
......@@ -182,6 +182,8 @@ where
[ "(func (export \"get_"+++{if (c=='-') '_' c \\ c <-: v}+++"\") (result i32) (global.get $g-"+++v+++"))" \\ v <- rt_vars ] ++
[ "(func (export \"set_"+++{if (c=='-') '_' c \\ c <-: v}+++"\") (param i32) (global.set $g-"+++v+++" (local.get 0)))" \\ v <- rt_vars ] ++
[ "(global $g-fast-ap-descriptor (mut i64) (i64.const 0))" ] ++
IF_GLOBAL_TEMP_VARS ["(global $vw"+++toString i+++" (mut i32) (i32.const 0))" \\ i <- [0..maxList [i.temp_vars.tv_i32 \\ i <- is]]] [] ++
IF_GLOBAL_TEMP_VARS ["(global $vq"+++toString i+++" (mut i64) (i64.const 0))" \\ i <- [0..maxList [i.temp_vars.tv_i64 \\ i <- is]]] [] ++
IF_GLOBAL_TEMP_VARS ["(global $vd"+++toString i+++" (mut f64) (f64.const 0))" \\ i <- [0..maxList [i.temp_vars.tv_f64 \\ i <- is]]] [] ++
......@@ -269,6 +271,7 @@ where
| v=="hp" = I32
| v=="hp-free" = I32
| v=="hp-size" = I32
| v=="fast-ap-descriptor" = I64
| otherwise = abort ("unknown variable "+++v+++"\n")
instr_unimplemented :: !Target -> Target
......@@ -397,7 +400,7 @@ instance ^ (Expr TReal) where ^ a b = Ecall "clean_powR" [a,b]
(|.) infixl 6 :: !(Expr TWord) !(Expr TWord) -> Expr TWord
(|.) a b = Eor (type2 a b) a b
(<<.) infix 7 :: !(Expr TWord) !(Expr TWord) -> Expr TWord
(<<.) infix 7 :: !(Expr a) !(Expr a) -> Expr a
(<<.) a b = Eshl (type2 a b) a b
(>>.) infix 7 :: !(Expr a) !(Expr a) -> Expr a
......@@ -733,6 +736,9 @@ where
caf_list :: Expr (TPtr TWord)
caf_list = Econst I32 (97*8)
fast_ap_descriptor :: Expr TWord
fast_ap_descriptor = Ivar (Global "g-fast-ap-descriptor")
C = rt_var "csp"
push_c :: !(Expr (TPtr TWord)) !Target -> Target
......
......@@ -3530,6 +3530,7 @@ all_instructions opts t = bootstrap $ collect_instructions opts $ map (\i -> i t
new_local TWord (n @ 0) \d ->
if_then_else (to_short_ptr d @ 0 ==. lit_short (8*ns)) (
new_local TShort (to_short_ptr d @ -1) \arity ->
fast_ap_descriptor .= d - to_word (arity <<. if_i64_or_i32_expr (lit_short 4) (lit_short 3)) :.
Pc .= to_word_ptr (to_word_ptr (d + (lit_word (ns*2-1) * if_i64_or_i32_expr (lit_word 8) (lit_word 4)) - lit_word 2) @ 0) :.
rewind_ptr Pc 3 :.
if_then_else (arity <=. lit_short 1) (
......@@ -3560,7 +3561,27 @@ all_instructions opts t = bootstrap $ collect_instructions opts $ map (\i -> i t
Pc .= to_word_ptr (to_word_ptr (d + if_i64_or_i32_expr (lit_word 6) (lit_word 2)) @ 0)
))
] ++
[ instr "add_arg0" Nothing $
[ instr "build_node2_rtn" Nothing $
ensure_hp 3 :.
pop_pc_from_c :.
Hp @ 0 .= fast_ap_descriptor + if_i64_or_i32_expr (lit_word 32) (lit_word 16) :.
Hp @ 1 .= A @ 0 :.
Hp @ 2 .= A @ -1 :.
A @ -1 .= to_word Hp :.
shrink_a 1
, instr "build_node_rtn" Nothing $
new_local TPtrOffset (to_ptr_offset (Pc @ 1)) \n_args_m_2 ->
ensure_hp (n_args_m_2 + lit_hword 3) :.
Hp @ 0 .= fast_ap_descriptor + to_word ((n_args_m_2 + lit_hword 2) <<. if_i64_or_i32_expr (lit_hword 4) (lit_hword 3)) :.
Hp @ 1 .= A @ 0 :.
Hp @ 2 .= to_word (Hp @? 3) :.
pop_pc_from_c :.
Hp @ 3 .= A @ -1 :.
unrolled_loop [1..32] (\i -> n_args_m_2 <. lit_hword i) (\i -> Hp @ (i+3) .= A @ (-1-i)) :.
shrink_a (n_args_m_2 + lit_hword 1) :.
A @ 0 .= to_word Hp :.
advance_ptr Hp (n_args_m_2 + lit_hword 3)
, instr "add_arg0" Nothing $
ensure_hp 2 :.
new_local (TPtr TWord) (to_word_ptr (A @ 0)) \n ->
pop_pc_from_c :.
......
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