language-servers/roc
1
0
Fork 0
mirror of https://github.com/roc-lang/roc.git synced 2025-10-01 07:41:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions 6

Merge pull request #684 from rtfeldman/big-nested-pattern-match

Browse source 
pattern matching fixes
This commit is contained in:
Richard Feldman 2020-11-15 08:24:31 -05:00 • committed by GitHub
commit a55f30e512
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
11 changed files with 1060 additions and 662 deletions
Download patch file Download diff file Expand all files Collapse all files

83
compiler/constrain/src/expr.rs
View file

@ -431,6 +431,7 @@ pub fn constrain_expr(
match expected { match expected {
FromAnnotation(name, arity, _, tipe) => { FromAnnotation(name, arity, _, tipe) => {
let num_branches = branches.len() + 1;
for (index, (loc_cond, loc_body)) in branches.iter().enumerate() { for (index, (loc_cond, loc_body)) in branches.iter().enumerate() {
let cond_con = constrain_expr( let cond_con = constrain_expr(
env, env,
@ -448,7 +449,7 @@ pub fn constrain_expr(
arity, arity,
AnnotationSource::TypedIfBranch { AnnotationSource::TypedIfBranch {
index: Index::zero_based(index), index: Index::zero_based(index),
num_branches: branches.len(), num_branches,
}, },
tipe.clone(), tipe.clone(),
), ),
@ -467,7 +468,7 @@ pub fn constrain_expr(
arity, arity,
AnnotationSource::TypedIfBranch { AnnotationSource::TypedIfBranch {
index: Index::zero_based(branches.len()), index: Index::zero_based(branches.len()),
num_branches: branches.len(), num_branches,
}, },
tipe.clone(), tipe.clone(),
), ),
@ -558,15 +559,12 @@ pub fn constrain_expr(
constraints.push(expr_con); constraints.push(expr_con);
match &expected { match &expected {
FromAnnotation(name, arity, _, typ) => { FromAnnotation(name, arity, _, _typ) => {
// record the type of the whole expression in the AST // NOTE deviation from elm.
let ast_con = Eq( //
Type::Variable(*expr_var), // in elm, `_typ` is used, but because we have this `expr_var` too
expected.clone(), // and need to constrain it, this is what works and gives better error messages
Category::Storage(std::file!(), std::line!()), let typ = Type::Variable(*expr_var);
region,
);
constraints.push(ast_con);
for (index, when_branch) in branches.iter().enumerate() { for (index, when_branch) in branches.iter().enumerate() {
let pattern_region = let pattern_region =
@ -595,6 +593,10 @@ pub fn constrain_expr(
constraints.push(branch_con); constraints.push(branch_con);
} }
constraints.push(Eq(typ, expected, Category::When, region));
return exists(vec![cond_var, *expr_var], And(constraints));
} }
_ => { _ => {
@ -1119,9 +1121,11 @@ fn constrain_def(env: &Env, def: &Def, body_con: Constraint) -> Constraint {
name, name,
.. ..
}, },
Type::Function(arg_types, _, _), Type::Function(arg_types, _closure_type, ret_type),
) => { ) => {
let expected = annotation_expected; // NOTE if we ever have problems with the closure, the ignored `_closure_type`
// is probably a good place to start the investigation!
let region = def.loc_expr.region; let region = def.loc_expr.region;
let loc_body_expr = &**loc_body; let loc_body_expr = &**loc_body;
@ -1135,7 +1139,7 @@ fn constrain_def(env: &Env, def: &Def, body_con: Constraint) -> Constraint {
let ret_var = *ret_var; let ret_var = *ret_var;
let closure_var = *closure_var; let closure_var = *closure_var;
let closure_ext_var = *closure_ext_var; let closure_ext_var = *closure_ext_var;
let ret_type = Type::Variable(ret_var); let ret_type = *ret_type.clone();
vars.push(ret_var); vars.push(ret_var);
vars.push(closure_var); vars.push(closure_var);
@ -1197,12 +1201,15 @@ fn constrain_def(env: &Env, def: &Def, body_con: Constraint) -> Constraint {
&mut vars, &mut vars,
); );
let fn_type = Type::Function( let body_type = FromAnnotation(
pattern_types, def.loc_pattern.clone(),
Box::new(Type::Variable(closure_var)), arguments.len(),
Box::new(ret_type.clone()), AnnotationSource::TypedBody {
region: annotation.region,
},
ret_type.clone(),
); );
let body_type = NoExpectation(ret_type);
let ret_constraint = let ret_constraint =
constrain_expr(env, loc_body_expr.region, &loc_body_expr.value, body_type); constrain_expr(env, loc_body_expr.region, &loc_body_expr.value, body_type);
@ -1219,22 +1226,32 @@ fn constrain_def(env: &Env, def: &Def, body_con: Constraint) -> Constraint {
defs_constraint, defs_constraint,
ret_constraint, ret_constraint,
})), })),
// "the closure's type is equal to expected type"
Eq(fn_type, expected, Category::Lambda, region),
// Store type into AST vars. We use Store so errors aren't reported twice
Store(signature.clone(), *fn_var, std::file!(), std::line!()), Store(signature.clone(), *fn_var, std::file!(), std::line!()),
Store(signature, expr_var, std::file!(), std::line!()), Store(signature, expr_var, std::file!(), std::line!()),
Store(ret_type, ret_var, std::file!(), std::line!()),
closure_constraint, closure_constraint,
]), ]),
) )
} }
_ => constrain_expr( _ => {
&env, let expected = annotation_expected;
def.loc_expr.region,
&def.loc_expr.value, let ret_constraint =
annotation_expected, constrain_expr(env, def.loc_expr.region, &def.loc_expr.value, expected);
),
And(vec![
Let(Box::new(LetConstraint {
rigid_vars: Vec::new(),
flex_vars: vec![],
def_types: SendMap::default(),
defs_constraint: True,
ret_constraint,
})),
// Store type into AST vars. We use Store so errors aren't reported twice
Store(signature, expr_var, std::file!(), std::line!()),
])
}
} }
} }
None => { None => {
@ -1440,8 +1457,11 @@ pub fn rec_defs_help(
name, name,
.. ..
}, },
Type::Function(arg_types, _, _), Type::Function(arg_types, _closure_type, ret_type),
) => { ) => {
// NOTE if we ever have trouble with closure type unification, the ignored
// `_closure_type` here is a good place to start investigating
let expected = annotation_expected; let expected = annotation_expected;
let region = def.loc_expr.region; let region = def.loc_expr.region;
@ -1456,7 +1476,7 @@ pub fn rec_defs_help(
let ret_var = *ret_var; let ret_var = *ret_var;
let closure_var = *closure_var; let closure_var = *closure_var;
let closure_ext_var = *closure_ext_var; let closure_ext_var = *closure_ext_var;
let ret_type = Type::Variable(ret_var); let ret_type = *ret_type.clone();
vars.push(ret_var); vars.push(ret_var);
vars.push(closure_var); vars.push(closure_var);
@ -1523,7 +1543,7 @@ pub fn rec_defs_help(
Box::new(Type::Variable(closure_var)), Box::new(Type::Variable(closure_var)),
Box::new(ret_type.clone()), Box::new(ret_type.clone()),
); );
let body_type = NoExpectation(ret_type); let body_type = NoExpectation(ret_type.clone());
let expr_con = constrain_expr( let expr_con = constrain_expr(
env, env,
loc_body_expr.region, loc_body_expr.region,
@ -1548,6 +1568,7 @@ pub fn rec_defs_help(
// Store type into AST vars. We use Store so errors aren't reported twice // Store type into AST vars. We use Store so errors aren't reported twice
Store(signature.clone(), *fn_var, std::file!(), std::line!()), Store(signature.clone(), *fn_var, std::file!(), std::line!()),
Store(signature, expr_var, std::file!(), std::line!()), Store(signature, expr_var, std::file!(), std::line!()),
Store(ret_type, ret_var, std::file!(), std::line!()),
closure_constraint, closure_constraint,
]), ]),
); );

26
compiler/gen/src/llvm/build.rs
View file

@ -752,30 +752,27 @@ pub fn build_exp_expr<'a, 'ctx, 'env>(
let mut field_types = Vec::with_capacity_in(num_fields, env.arena); let mut field_types = Vec::with_capacity_in(num_fields, env.arena);
let mut field_vals = Vec::with_capacity_in(num_fields, env.arena); let mut field_vals = Vec::with_capacity_in(num_fields, env.arena);
for (field_symbol, tag_field_layout) in let tag_field_layouts = fields[*tag_id as usize];
arguments.iter().zip(fields[*tag_id as usize].iter()) for (field_symbol, tag_field_layout) in arguments.iter().zip(tag_field_layouts.iter()) {
{ let val = load_symbol(env, scope, field_symbol);
// note field_layout is the layout of the argument.
// tag_field_layout is the layout that the tag will store
// these are different for recursive tag unions
let (val, field_layout) = load_symbol_and_layout(env, scope, field_symbol);
let field_size = tag_field_layout.stack_size(ptr_size);
// Zero-sized fields have no runtime representation. // Zero-sized fields have no runtime representation.
// The layout of the struct expects them to be dropped! // The layout of the struct expects them to be dropped!
if field_size != 0 { if !tag_field_layout.is_dropped_because_empty() {
let field_type = let field_type =
basic_type_from_layout(env.arena, env.context, tag_field_layout, ptr_size); basic_type_from_layout(env.arena, env.context, tag_field_layout, ptr_size);
field_types.push(field_type); field_types.push(field_type);
if let Layout::RecursivePointer = tag_field_layout { if let Layout::RecursivePointer = tag_field_layout {
let ptr = allocate_with_refcount(env, field_layout, val).into(); let ptr = allocate_with_refcount(env, &tag_layout, val);
let ptr = cast_basic_basic( let ptr = cast_basic_basic(
builder, builder,
ptr, ptr.into(),
ctx.i64_type().ptr_type(AddressSpace::Generic).into(), ctx.i64_type().ptr_type(AddressSpace::Generic).into(),
); );
field_vals.push(ptr); field_vals.push(ptr);
} else { } else {
field_vals.push(val); field_vals.push(val);
@ -993,8 +990,7 @@ pub fn allocate_with_refcount<'a, 'ctx, 'env>(
// bytes per element // bytes per element
let bytes_len = len_type.const_int(value_bytes, false); let bytes_len = len_type.const_int(value_bytes, false);
// TODO fix offset let offset = crate::llvm::refcounting::refcount_offset(env, layout);
let offset = (env.ptr_bytes as u64).max(value_bytes);
let ptr = { let ptr = {
let len = bytes_len; let len = bytes_len;
@ -1011,7 +1007,7 @@ pub fn allocate_with_refcount<'a, 'ctx, 'env>(
// We must return a pointer to the first element: // We must return a pointer to the first element:
let ptr_bytes = env.ptr_bytes; let ptr_bytes = env.ptr_bytes;
let int_type = ptr_int(ctx, ptr_bytes); let int_type = ptr_int(ctx, ptr_bytes);
let ptr_as_int = builder.build_ptr_to_int(ptr, int_type, "list_cast_ptr"); let ptr_as_int = builder.build_ptr_to_int(ptr, int_type, "allocate_refcount_pti");
let incremented = builder.build_int_add( let incremented = builder.build_int_add(
ptr_as_int, ptr_as_int,
ctx.i64_type().const_int(offset, false), ctx.i64_type().const_int(offset, false),
@ -1019,7 +1015,7 @@ pub fn allocate_with_refcount<'a, 'ctx, 'env>(
); );
let ptr_type = get_ptr_type(&value_type, AddressSpace::Generic); let ptr_type = get_ptr_type(&value_type, AddressSpace::Generic);
let list_element_ptr = builder.build_int_to_ptr(incremented, ptr_type, "list_cast_ptr"); let list_element_ptr = builder.build_int_to_ptr(incremented, ptr_type, "allocate_refcount_itp");
// subtract ptr_size, to access the refcount // subtract ptr_size, to access the refcount
let refcount_ptr = builder.build_int_sub( let refcount_ptr = builder.build_int_sub(

122
compiler/gen/src/llvm/refcounting.rs
View file

@ -89,46 +89,7 @@ pub fn decrement_refcount_layout<'a, 'ctx, 'env>(
RecursivePointer => todo!("TODO implement decrement layout of recursive tag union"), RecursivePointer => todo!("TODO implement decrement layout of recursive tag union"),
Union(tags) => { Union(tags) => {
debug_assert!(!tags.is_empty()); build_dec_union(env, layout_ids, tags, value);
let wrapper_struct = value.into_struct_value();
// read the tag_id
let tag_id = env
.builder
.build_extract_value(wrapper_struct, 0, "read_tag_id")
.unwrap()
.into_int_value();
// next, make a jump table for all possible values of the tag_id
let mut cases = Vec::with_capacity_in(tags.len(), env.arena);
let merge_block = env.context.append_basic_block(parent, "decrement_merge");
for (tag_id, field_layouts) in tags.iter().enumerate() {
let block = env.context.append_basic_block(parent, "tag_id_decrement");
env.builder.position_at_end(block);
for (i, field_layout) in field_layouts.iter().enumerate() {
if field_layout.contains_refcounted() {
let field_ptr = env
.builder
.build_extract_value(wrapper_struct, i as u32, "decrement_struct_field")
.unwrap();
decrement_refcount_layout(env, parent, layout_ids, field_ptr, field_layout)
}
}
env.builder.build_unconditional_branch(merge_block);
cases.push((env.context.i8_type().const_int(tag_id as u64, false), block));
}
let (_, default_block) = cases.pop().unwrap();
env.builder.build_switch(tag_id, default_block, &cases);
env.builder.position_at_end(merge_block);
} }
RecursiveUnion(tags) => { RecursiveUnion(tags) => {
@ -749,6 +710,7 @@ fn decrement_refcount_help<'a, 'ctx, 'env>(
], ],
) )
.into_struct_value(); .into_struct_value();
let has_overflowed = builder let has_overflowed = builder
.build_extract_value(add_with_overflow, 1, "has_overflowed") .build_extract_value(add_with_overflow, 1, "has_overflowed")
.unwrap(); .unwrap();
@ -759,6 +721,7 @@ fn decrement_refcount_help<'a, 'ctx, 'env>(
ctx.bool_type().const_int(1 as u64, false), ctx.bool_type().const_int(1 as u64, false),
"has_overflowed", "has_overflowed",
); );
// build blocks // build blocks
let then_block = ctx.append_basic_block(parent, "then"); let then_block = ctx.append_basic_block(parent, "then");
let else_block = ctx.append_basic_block(parent, "else"); let else_block = ctx.append_basic_block(parent, "else");
@ -780,6 +743,7 @@ fn decrement_refcount_help<'a, 'ctx, 'env>(
// build else block // build else block
{ {
builder.position_at_end(else_block); builder.position_at_end(else_block);
let max = builder.build_int_compare( let max = builder.build_int_compare(
IntPredicate::EQ, IntPredicate::EQ,
refcount, refcount,
@ -903,14 +867,20 @@ pub fn build_dec_union_help<'a, 'ctx, 'env>(
let wrapper_struct = arg_val.into_struct_value(); let wrapper_struct = arg_val.into_struct_value();
// let tag_id_u8 = cast_basic_basic(env.builder, tag_id.into(), env.context.i8_type().into());
// next, make a jump table for all possible values of the tag_id // next, make a jump table for all possible values of the tag_id
let mut cases = Vec::with_capacity_in(tags.len(), env.arena); let mut cases = Vec::with_capacity_in(tags.len(), env.arena);
let merge_block = env.context.append_basic_block(parent, "decrement_merge"); let merge_block = env.context.append_basic_block(parent, "decrement_merge");
for (tag_id, field_layouts) in tags.iter().enumerate() { for (tag_id, field_layouts) in tags.iter().enumerate() {
// if none of the fields are or contain anything refcounted, just move on
if !field_layouts
.iter()
.any(|x| x.is_refcounted() || x.contains_refcounted())
{
continue;
}
let block = env.context.append_basic_block(parent, "tag_id_decrement"); let block = env.context.append_basic_block(parent, "tag_id_decrement");
env.builder.position_at_end(block); env.builder.position_at_end(block);
@ -926,18 +896,19 @@ pub fn build_dec_union_help<'a, 'ctx, 'env>(
for (i, field_layout) in field_layouts.iter().enumerate() { for (i, field_layout) in field_layouts.iter().enumerate() {
if let Layout::RecursivePointer = field_layout { if let Layout::RecursivePointer = field_layout {
// a *i64 pointer to the recursive data // this field has type `*i64`, but is really a pointer to the data we want
// we need to cast this pointer to the appropriate type let ptr_as_i64_ptr = env
let field_ptr = env
.builder .builder
.build_extract_value(wrapper_struct, i as u32, "decrement_struct_field") .build_extract_value(wrapper_struct, i as u32, "decrement_struct_field")
.unwrap(); .unwrap();
// recursively decrement debug_assert!(ptr_as_i64_ptr.is_pointer_value());
// therefore we must cast it to our desired type
let union_type = block_of_memory(env.context, &layout, env.ptr_bytes); let union_type = block_of_memory(env.context, &layout, env.ptr_bytes);
let recursive_field_ptr = cast_basic_basic( let recursive_field_ptr = cast_basic_basic(
env.builder, env.builder,
field_ptr, ptr_as_i64_ptr,
union_type.ptr_type(AddressSpace::Generic).into(), union_type.ptr_type(AddressSpace::Generic).into(),
) )
.into_pointer_value(); .into_pointer_value();
@ -956,7 +927,7 @@ pub fn build_dec_union_help<'a, 'ctx, 'env>(
// TODO do this decrement before the recursive call? // TODO do this decrement before the recursive call?
// Then the recursive call is potentially TCE'd // Then the recursive call is potentially TCE'd
decrement_refcount_ptr(env, parent, &layout, field_ptr.into_pointer_value()); decrement_refcount_ptr(env, parent, &layout, recursive_field_ptr);
} else if field_layout.contains_refcounted() { } else if field_layout.contains_refcounted() {
let field_ptr = env let field_ptr = env
.builder .builder
@ -977,8 +948,6 @@ pub fn build_dec_union_help<'a, 'ctx, 'env>(
cases.reverse(); cases.reverse();
let (_, default_block) = cases.pop().unwrap();
env.builder.position_at_end(before_block); env.builder.position_at_end(before_block);
// read the tag_id // read the tag_id
@ -998,7 +967,7 @@ pub fn build_dec_union_help<'a, 'ctx, 'env>(
// switch on it // switch on it
env.builder env.builder
.build_switch(current_tag_id, default_block, &cases); .build_switch(current_tag_id, merge_block, &cases);
env.builder.position_at_end(merge_block); env.builder.position_at_end(merge_block);
@ -1105,10 +1074,18 @@ pub fn build_inc_union_help<'a, 'ctx, 'env>(
// next, make a jump table for all possible values of the tag_id // next, make a jump table for all possible values of the tag_id
let mut cases = Vec::with_capacity_in(tags.len(), env.arena); let mut cases = Vec::with_capacity_in(tags.len(), env.arena);
let merge_block = env.context.append_basic_block(parent, "decrement_merge"); let merge_block = env.context.append_basic_block(parent, "increment_merge");
for (tag_id, field_layouts) in tags.iter().enumerate() { for (tag_id, field_layouts) in tags.iter().enumerate() {
let block = env.context.append_basic_block(parent, "tag_id_decrement"); // if none of the fields are or contain anything refcounted, just move on
if !field_layouts
.iter()
.any(|x| x.is_refcounted() || x.contains_refcounted())
{
continue;
}
let block = env.context.append_basic_block(parent, "tag_id_increment");
env.builder.position_at_end(block); env.builder.position_at_end(block);
let wrapper_type = basic_type_from_layout( let wrapper_type = basic_type_from_layout(
@ -1123,18 +1100,19 @@ pub fn build_inc_union_help<'a, 'ctx, 'env>(
for (i, field_layout) in field_layouts.iter().enumerate() { for (i, field_layout) in field_layouts.iter().enumerate() {
if let Layout::RecursivePointer = field_layout { if let Layout::RecursivePointer = field_layout {
// a *i64 pointer to the recursive data // this field has type `*i64`, but is really a pointer to the data we want
// we need to cast this pointer to the appropriate type let ptr_as_i64_ptr = env
let field_ptr = env
.builder .builder
.build_extract_value(wrapper_struct, i as u32, "decrement_struct_field") .build_extract_value(wrapper_struct, i as u32, "increment_struct_field")
.unwrap(); .unwrap();
// recursively increment debug_assert!(ptr_as_i64_ptr.is_pointer_value());
// therefore we must cast it to our desired type
let union_type = block_of_memory(env.context, &layout, env.ptr_bytes); let union_type = block_of_memory(env.context, &layout, env.ptr_bytes);
let recursive_field_ptr = cast_basic_basic( let recursive_field_ptr = cast_basic_basic(
env.builder, env.builder,
field_ptr, ptr_as_i64_ptr,
union_type.ptr_type(AddressSpace::Generic).into(), union_type.ptr_type(AddressSpace::Generic).into(),
) )
.into_pointer_value(); .into_pointer_value();
@ -1151,9 +1129,9 @@ pub fn build_inc_union_help<'a, 'ctx, 'env>(
// Because it's an internal-only function, use the fast calling convention. // Because it's an internal-only function, use the fast calling convention.
call.set_call_convention(FAST_CALL_CONV); call.set_call_convention(FAST_CALL_CONV);
// TODO do this increment before the recursive call? // TODO do this decrement before the recursive call?
// Then the recursive call is potentially TCE'd // Then the recursive call is potentially TCE'd
increment_refcount_ptr(env, &layout, field_ptr.into_pointer_value()); increment_refcount_ptr(env, &layout, recursive_field_ptr);
} else if field_layout.contains_refcounted() { } else if field_layout.contains_refcounted() {
let field_ptr = env let field_ptr = env
.builder .builder
@ -1169,12 +1147,10 @@ pub fn build_inc_union_help<'a, 'ctx, 'env>(
cases.push((env.context.i8_type().const_int(tag_id as u64, false), block)); cases.push((env.context.i8_type().const_int(tag_id as u64, false), block));
} }
let (_, default_block) = cases.pop().unwrap();
env.builder.position_at_end(before_block); env.builder.position_at_end(before_block);
env.builder env.builder
.build_switch(tag_id_u8.into_int_value(), default_block, &cases); .build_switch(tag_id_u8.into_int_value(), merge_block, &cases);
env.builder.position_at_end(merge_block); env.builder.position_at_end(merge_block);
@ -1221,6 +1197,17 @@ fn get_refcount_ptr<'a, 'ctx, 'env>(
get_refcount_ptr_help(env, layout, ptr_as_int) get_refcount_ptr_help(env, layout, ptr_as_int)
} }
pub fn refcount_offset<'a, 'ctx, 'env>(env: &Env<'a, 'ctx, 'env>, layout: &Layout<'a>) -> u64 {
let value_bytes = layout.stack_size(env.ptr_bytes) as u64;
match layout {
Layout::Builtin(Builtin::List(_, _)) => env.ptr_bytes as u64,
Layout::Builtin(Builtin::Str) => env.ptr_bytes as u64,
Layout::RecursivePointer | Layout::RecursiveUnion(_) => env.ptr_bytes as u64,
_ => (env.ptr_bytes as u64).max(value_bytes),
}
}
fn get_refcount_ptr_help<'a, 'ctx, 'env>( fn get_refcount_ptr_help<'a, 'ctx, 'env>(
env: &Env<'a, 'ctx, 'env>, env: &Env<'a, 'ctx, 'env>,
layout: &Layout<'a>, layout: &Layout<'a>,
@ -1229,12 +1216,7 @@ fn get_refcount_ptr_help<'a, 'ctx, 'env>(
let builder = env.builder; let builder = env.builder;
let ctx = env.context; let ctx = env.context;
let value_bytes = layout.stack_size(env.ptr_bytes) as u64; let offset = refcount_offset(env, layout);
let offset = match layout {
Layout::Builtin(Builtin::List(_, _)) => env.ptr_bytes as u64,
Layout::Builtin(Builtin::Str) => env.ptr_bytes as u64,
_ => (env.ptr_bytes as u64).max(value_bytes),
};
// pointer to usize // pointer to usize
let refcount_type = ptr_int(ctx, env.ptr_bytes); let refcount_type = ptr_int(ctx, env.ptr_bytes);

162
compiler/gen/tests/gen_primitives.rs
View file

@ -1277,6 +1277,108 @@ mod gen_primitives {
); );
} }
#[test]
#[ignore]
fn rbtree_balance_inc_dec() {
// TODO does not define a variable correctly, but all is well with the type signature
assert_non_opt_evals_to!(
indoc!(
r#"
app Test provides [ main ] imports []
NodeColor : [ Red, Black ]
Dict k : [ Node NodeColor k (Dict k) (Dict k), Empty ]
# balance : NodeColor, k, Dict k, Dict k -> Dict k
balance = \color, key, left, right ->
when right is
Node Red rK rLeft rRight ->
when left is
Node Red _ _ _ ->
Node
Red
key
Empty
Empty
_ ->
Node color rK (Node Red key left rLeft) rRight
_ ->
Empty
main : Dict Int
main =
balance Red 0 Empty Empty
"#
),
0,
i64
);
}
#[test]
fn rbtree_balance_3() {
assert_non_opt_evals_to!(
indoc!(
r#"
app Test provides [ main ] imports []
Dict k : [ Node k (Dict k) (Dict k), Empty ]
balance : k, Dict k -> Dict k
balance = \key, left ->
Node key left Empty
main : Dict Int
main =
balance 0 Empty
"#
),
1,
i64
);
}
#[test]
fn rbtree_balance_2() {
assert_non_opt_evals_to!(
indoc!(
r#"
app Test provides [ main ] imports []
NodeColor : [ Red, Black ]
Dict k : [ Node NodeColor k (Dict k), Empty ]
balance : NodeColor, k, Dict k, Dict k -> Dict k
balance = \color, key, left, right ->
when right is
Node Red rK _ ->
when left is
Node Red _ _ ->
Node
Red
key
Empty
_ ->
Node color rK (Node Red key left )
_ ->
Empty
main : Dict Int
main =
balance Red 0 Empty Empty
"#
),
0,
i64
);
}
#[test] #[test]
#[ignore] #[ignore]
fn rbtree_balance() { fn rbtree_balance() {
@ -1289,18 +1391,38 @@ mod gen_primitives {
Dict k v : [ Node NodeColor k v (Dict k v) (Dict k v), Empty ] Dict k v : [ Node NodeColor k v (Dict k v) (Dict k v), Empty ]
Key k : Num k
balance : NodeColor, k, v, Dict k v, Dict k v -> Dict k v balance : NodeColor, k, v, Dict k v, Dict k v -> Dict k v
balance = \color, key, value, left, right -> balance = \color, key, value, left, right ->
when right is when right is
Node Red lK lV (Node Red llK llV llLeft llRight) lRight -> Empty Node Red rK rV rLeft rRight ->
Empty -> Empty when left is
Node Red lK lV lLeft lRight ->
Node
Red
key
value
(Node Black lK lV lLeft lRight)
(Node Black rK rV rLeft rRight)
_ ->
Node color rK rV (Node Red key value left rLeft) rRight
main : Dict Int {} _ ->
when left is
Node Red lK lV (Node Red llK llV llLeft llRight) lRight ->
Node
Red
lK
lV
(Node Black llK llV llLeft llRight)
(Node Black key value lRight right)
_ ->
Node color key value left right
main : Dict Int Int
main = main =
balance Red 0 {} Empty Empty balance Red 0 0 Empty Empty
"# "#
), ),
1, 1,
@ -1310,6 +1432,34 @@ mod gen_primitives {
#[test] #[test]
#[ignore] #[ignore]
fn linked_list_guarded_double_pattern_match() {
// the important part here is that the first case (with the nested Cons) does not match
// TODO this also has undefined behavior
assert_non_opt_evals_to!(
indoc!(
r#"
app Test provides [ main ] imports []
ConsList a : [ Cons a (ConsList a), Nil ]
balance : ConsList Int -> Int
balance = \right ->
when right is
Cons 1 (Cons 1 _) -> 3
_ -> 3
main : Int
main =
when balance Nil is
_ -> 3
"#
),
3,
i64
);
}
#[test]
fn linked_list_double_pattern_match() { fn linked_list_double_pattern_match() {
assert_non_opt_evals_to!( assert_non_opt_evals_to!(
indoc!( indoc!(

356
compiler/mono/src/decision_tree.rs
View file

@ -11,6 +11,7 @@ use roc_module::symbol::Symbol;
/// COMPILE CASES /// COMPILE CASES
type Label = u64; type Label = u64;
const RECORD_TAG_NAME: &str = "#Record";
/// Users of this module will mainly interact with this function. It takes /// Users of this module will mainly interact with this function. It takes
/// some normal branches and gives out a decision tree that has "labels" at all /// some normal branches and gives out a decision tree that has "labels" at all
@ -189,7 +190,7 @@ fn to_decision_tree(raw_branches: Vec<Branch>) -> DecisionTree {
fn is_complete(tests: &[Test]) -> bool { fn is_complete(tests: &[Test]) -> bool {
let length = tests.len(); let length = tests.len();
debug_assert!(length > 0); debug_assert!(length > 0);
match tests.get(length - 1) { match tests.last() {
None => unreachable!("should never happen"), None => unreachable!("should never happen"),
Some(v) => match v { Some(v) => match v {
Test::IsCtor { union, .. } => length == union.alternatives.len(), Test::IsCtor { union, .. } => length == union.alternatives.len(),
@ -395,7 +396,7 @@ fn test_at_path<'a>(selected_path: &Path, branch: &Branch<'a>, all_tests: &mut V
render_as: RenderAs::Tag, render_as: RenderAs::Tag,
alternatives: vec![Ctor { alternatives: vec![Ctor {
tag_id: TagId(0), tag_id: TagId(0),
name: TagName::Global("#Record".into()), name: TagName::Global(RECORD_TAG_NAME.into()),
arity: destructs.len(), arity: destructs.len(),
}], }],
}; };
@ -418,7 +419,7 @@ fn test_at_path<'a>(selected_path: &Path, branch: &Branch<'a>, all_tests: &mut V
all_tests.push(IsCtor { all_tests.push(IsCtor {
tag_id: 0, tag_id: 0,
tag_name: TagName::Global("#Record".into()), tag_name: TagName::Global(RECORD_TAG_NAME.into()),
union, union,
arguments, arguments,
}); });
@ -538,7 +539,7 @@ fn to_relevant_branch_help<'a>(
tag_id, tag_id,
.. ..
} => { } => {
debug_assert!(test_name == &TagName::Global("#Record".into())); debug_assert!(test_name == &TagName::Global(RECORD_TAG_NAME.into()));
let sub_positions = destructs.into_iter().enumerate().map(|(index, destruct)| { let sub_positions = destructs.into_iter().enumerate().map(|(index, destruct)| {
let pattern = match destruct.typ { let pattern = match destruct.typ {
DestructType::Guard(guard) => guard.clone(), DestructType::Guard(guard) => guard.clone(),
@ -934,32 +935,59 @@ pub fn optimize_when<'a>(
) )
} }
fn path_to_expr_help<'a>( #[derive(Debug)]
env: &mut Env<'a, '_>, struct PathInstruction {
mut symbol: Symbol, index: u64,
mut path: &Path, tag_id: u8,
mut layout: Layout<'a>, }
) -> (Symbol, StoresVec<'a>, Layout<'a>) {
let mut stores = bumpalo::collections::Vec::new_in(env.arena); fn reverse_path(mut path: &Path) -> Vec<PathInstruction> {
let mut result = Vec::new();
loop { loop {
match path { match path {
Path::Unbox(unboxed) => { Path::Unbox(nested) => {
path = unboxed; path = nested;
} }
Path::Empty => break, Path::Empty => break,
Path::Index { Path::Index {
index, index,
tag_id, tag_id,
path: nested, path: nested,
} => match Wrapped::opt_from_layout(&layout) { } => {
result.push(PathInstruction {
index: *index,
tag_id: *tag_id,
});
path = nested;
}
}
}
result.reverse();
result
}
fn path_to_expr_help<'a>(
env: &mut Env<'a, '_>,
mut symbol: Symbol,
path: &Path,
mut layout: Layout<'a>,
) -> (Symbol, StoresVec<'a>, Layout<'a>) {
let mut stores = bumpalo::collections::Vec::new_in(env.arena);
let instructions = reverse_path(path);
let mut it = instructions.iter().peekable();
while let Some(PathInstruction { index, tag_id }) = it.next() {
match Wrapped::opt_from_layout(&layout) {
None => { None => {
// this MUST be an index into a single-element (hence unwrapped) record // this MUST be an index into a single-element (hence unwrapped) record
debug_assert_eq!(*index, 0); debug_assert_eq!(*index, 0);
debug_assert_eq!(*tag_id, 0); debug_assert_eq!(*tag_id, 0);
debug_assert_eq!(**nested, Path::Empty); debug_assert!(it.peek().is_none());
let field_layouts = vec![layout.clone()]; let field_layouts = vec![layout.clone()];
@ -981,10 +1009,10 @@ fn path_to_expr_help<'a>(
Some(wrapped) => { Some(wrapped) => {
let field_layouts = match &layout { let field_layouts = match &layout {
Layout::Union(layouts) | Layout::RecursiveUnion(layouts) => { Layout::Union(layouts) | Layout::RecursiveUnion(layouts) => {
layouts[*tag_id as usize].to_vec() layouts[*tag_id as usize]
} }
Layout::Struct(layouts) => layouts.to_vec(), Layout::Struct(layouts) => layouts,
other => vec![other.clone()], other => env.arena.alloc([other.clone()]),
}; };
debug_assert!(*index < field_layouts.len() as u64); debug_assert!(*index < field_layouts.len() as u64);
@ -996,7 +1024,7 @@ fn path_to_expr_help<'a>(
let inner_expr = Expr::AccessAtIndex { let inner_expr = Expr::AccessAtIndex {
index: *index, index: *index,
field_layouts: env.arena.alloc(field_layouts), field_layouts,
structure: symbol, structure: symbol,
wrapped, wrapped,
}; };
@ -1005,9 +1033,7 @@ fn path_to_expr_help<'a>(
stores.push((symbol, inner_layout.clone(), inner_expr)); stores.push((symbol, inner_layout.clone(), inner_expr));
layout = inner_layout; layout = inner_layout;
path = nested;
} }
},
} }
} }
@ -1143,80 +1169,19 @@ fn test_to_equality<'a>(
} }
} }
// TODO procs and layout are currently unused, but potentially required type Tests<'a> = std::vec::Vec<(
// for defining optional fields? bumpalo::collections::Vec<'a, (Symbol, Layout<'a>, Expr<'a>)>,
// if not, do remove Symbol,
#[allow(clippy::too_many_arguments, clippy::needless_collect)] Symbol,
fn decide_to_branching<'a>( Layout<'a>,
)>;
fn stores_and_condition<'a>(
env: &mut Env<'a, '_>, env: &mut Env<'a, '_>,
procs: &mut Procs<'a>,
layout_cache: &mut LayoutCache<'a>,
cond_symbol: Symbol, cond_symbol: Symbol,
cond_layout: Layout<'a>, cond_layout: &Layout<'a>,
ret_layout: Layout<'a>, test_chain: Vec<(Path, Test<'a>)>,
decider: Decider<'a, Choice<'a>>, ) -> (Tests<'a>, Option<(Symbol, JoinPointId, Stmt<'a>)>) {
jumps: &Vec<(u64, Stmt<'a>)>,
) -> Stmt<'a> {
use Choice::*;
use Decider::*;
match decider {
Leaf(Jump(label)) => {
// we currently inline the jumps: does fewer jumps but produces a larger artifact
let (_, expr) = jumps
.iter()
.find(|(l, _)| l == &label)
.expect("jump not in list of jumps");
expr.clone()
}
Leaf(Inline(expr)) => expr,
Chain {
test_chain,
success,
failure,
} => {
// generate a switch based on the test chain
let pass_expr = decide_to_branching(
env,
procs,
layout_cache,
cond_symbol,
cond_layout.clone(),
ret_layout.clone(),
*success,
jumps,
);
let fail_expr = decide_to_branching(
env,
procs,
layout_cache,
cond_symbol,
cond_layout.clone(),
ret_layout.clone(),
*failure,
jumps,
);
let fail = &*env.arena.alloc(fail_expr);
let pass = &*env.arena.alloc(pass_expr);
let branching_symbol = env.unique_symbol();
let branching_layout = Layout::Builtin(Builtin::Int1);
let mut cond = Stmt::Cond {
cond_symbol,
cond_layout: cond_layout.clone(),
branching_symbol,
branching_layout,
pass,
fail,
ret_layout,
};
let true_symbol = env.unique_symbol();
let mut tests = Vec::with_capacity(test_chain.len()); let mut tests = Vec::with_capacity(test_chain.len());
let mut guard = None; let mut guard = None;
@ -1255,34 +1220,30 @@ fn decide_to_branching<'a>(
} }
} }
let mut current_symbol = branching_symbol; (tests, guard)
}
// TODO There must be some way to remove this iterator/loop
let nr = (tests.len() as i64) - 1 + (guard.is_some() as i64);
fn compile_guard<'a>(
env: &mut Env<'a, '_>,
ret_layout: Layout<'a>,
id: JoinPointId,
stmt: &'a Stmt<'a>,
fail: &'a Stmt<'a>,
mut cond: Stmt<'a>,
) -> Stmt<'a> {
// the guard is the final thing that we check, so needs to be layered on first!
let test_symbol = env.unique_symbol();
let arena = env.arena; let arena = env.arena;
let accum_symbols = std::iter::once(true_symbol) cond = Stmt::Cond {
.chain((0..nr).map(|_| env.unique_symbol())) cond_symbol: test_symbol,
.rev() cond_layout: Layout::Builtin(Builtin::Int1),
.collect::<Vec<_>>(); branching_symbol: test_symbol,
branching_layout: Layout::Builtin(Builtin::Int1),
let mut accum_it = accum_symbols.into_iter(); pass: arena.alloc(cond),
fail,
// the guard is the final thing that we check, so needs to be layered on first! ret_layout,
if let Some((_, id, stmt)) = guard { };
let accum = accum_it.next().unwrap();
let test_symbol = env.unique_symbol();
let and_expr = Expr::RunLowLevel(LowLevel::And, arena.alloc([test_symbol, accum]));
// write to the branching symbol
cond = Stmt::Let(
current_symbol,
and_expr,
Layout::Builtin(Builtin::Int1),
arena.alloc(cond),
);
// calculate the guard value // calculate the guard value
let param = Param { let param = Param {
@ -1290,34 +1251,39 @@ fn decide_to_branching<'a>(
layout: Layout::Builtin(Builtin::Int1), layout: Layout::Builtin(Builtin::Int1),
borrow: false, borrow: false,
}; };
cond = Stmt::Join {
Stmt::Join {
id, id,
parameters: arena.alloc([param]), parameters: arena.alloc([param]),
remainder: arena.alloc(stmt), remainder: stmt,
continuation: arena.alloc(cond), continuation: arena.alloc(cond),
}; }
// load all the variables (the guard might need them);
current_symbol = accum;
} }
for ((new_stores, lhs, rhs, _layout), accum) in tests.into_iter().rev().zip(accum_it) { fn compile_test<'a>(
env: &mut Env<'a, '_>,
ret_layout: Layout<'a>,
stores: bumpalo::collections::Vec<'a, (Symbol, Layout<'a>, Expr<'a>)>,
lhs: Symbol,
rhs: Symbol,
fail: &'a Stmt<'a>,
mut cond: Stmt<'a>,
) -> Stmt<'a> {
// if test_symbol then cond else fail
let test_symbol = env.unique_symbol(); let test_symbol = env.unique_symbol();
let test = Expr::RunLowLevel( let arena = env.arena;
LowLevel::Eq,
bumpalo::vec![in arena; lhs, rhs].into_bump_slice(),
);
let and_expr = Expr::RunLowLevel(LowLevel::And, arena.alloc([test_symbol, accum])); cond = Stmt::Cond {
cond_symbol: test_symbol,
cond_layout: Layout::Builtin(Builtin::Int1),
branching_symbol: test_symbol,
branching_layout: Layout::Builtin(Builtin::Int1),
pass: arena.alloc(cond),
fail,
ret_layout,
};
// write to the branching symbol let test = Expr::RunLowLevel(LowLevel::Eq, arena.alloc([lhs, rhs]));
cond = Stmt::Let(
current_symbol,
and_expr,
Layout::Builtin(Builtin::Int1),
arena.alloc(cond),
);
// write to the test symbol // write to the test symbol
cond = Stmt::Let( cond = Stmt::Let(
@ -1328,21 +1294,117 @@ fn decide_to_branching<'a>(
); );
// stores are in top-to-bottom order, so we have to add them in reverse // stores are in top-to-bottom order, so we have to add them in reverse
for (symbol, layout, expr) in new_stores.into_iter().rev() { for (symbol, layout, expr) in stores.into_iter().rev() {
cond = Stmt::Let(symbol, expr, layout, arena.alloc(cond)); cond = Stmt::Let(symbol, expr, layout, arena.alloc(cond));
} }
current_symbol = accum; cond
} }
cond = Stmt::Let( fn compile_tests<'a>(
true_symbol, env: &mut Env<'a, '_>,
Expr::Literal(Literal::Bool(true)), ret_layout: Layout<'a>,
Layout::Builtin(Builtin::Int1), tests: Tests<'a>,
arena.alloc(cond), opt_guard: Option<(Symbol, JoinPointId, Stmt<'a>)>,
fail: &'a Stmt<'a>,
mut cond: Stmt<'a>,
) -> Stmt<'a> {
let arena = env.arena;
// the guard is the final thing that we check, so needs to be layered on first!
if let Some((_, id, stmt)) = opt_guard {
cond = compile_guard(env, ret_layout.clone(), id, arena.alloc(stmt), fail, cond);
}
for (new_stores, lhs, rhs, _layout) in tests.into_iter().rev() {
cond = compile_test(env, ret_layout.clone(), new_stores, lhs, rhs, fail, cond);
}
cond
}
// TODO procs and layout are currently unused, but potentially required
// for defining optional fields?
// if not, do remove
#[allow(clippy::too_many_arguments, clippy::needless_collect)]
fn decide_to_branching<'a>(
env: &mut Env<'a, '_>,
procs: &mut Procs<'a>,
layout_cache: &mut LayoutCache<'a>,
cond_symbol: Symbol,
cond_layout: Layout<'a>,
ret_layout: Layout<'a>,
decider: Decider<'a, Choice<'a>>,
jumps: &Vec<(u64, Stmt<'a>)>,
) -> Stmt<'a> {
use Choice::*;
use Decider::*;
let arena = env.arena;
match decider {
Leaf(Jump(label)) => {
// we currently inline the jumps: does fewer jumps but produces a larger artifact
let (_, expr) = jumps
.iter()
.find(|(l, _)| l == &label)
.expect("jump not in list of jumps");
expr.clone()
}
Leaf(Inline(expr)) => expr,
Chain {
test_chain,
success,
failure,
} => {
// generate a (nested) if-then-else
let pass_expr = decide_to_branching(
env,
procs,
layout_cache,
cond_symbol,
cond_layout.clone(),
ret_layout.clone(),
*success,
jumps,
); );
cond let fail_expr = decide_to_branching(
env,
procs,
layout_cache,
cond_symbol,
cond_layout.clone(),
ret_layout.clone(),
*failure,
jumps,
);
let (tests, guard) = stores_and_condition(env, cond_symbol, &cond_layout, test_chain);
let number_of_tests = tests.len() as i64 + guard.is_some() as i64;
debug_assert!(number_of_tests > 0);
let fail = env.arena.alloc(fail_expr);
if number_of_tests == 1 {
// if there is just one test, compile to a simple if-then-else
compile_tests(env, ret_layout, tests, guard, fail, pass_expr)
} else {
// otherwise, we use a join point so the code for the `else` case
// is only generated once.
let fail_jp_id = JoinPointId(env.unique_symbol());
let jump = arena.alloc(Stmt::Jump(fail_jp_id, &[]));
let test_stmt = compile_tests(env, ret_layout, tests, guard, jump, pass_expr);
Stmt::Join {
id: fail_jp_id,
parameters: &[],
continuation: fail,
remainder: arena.alloc(test_stmt),
}
}
} }
FanOut { FanOut {
path, path,

4
compiler/mono/src/ir.rs
View file

@ -1134,7 +1134,6 @@ impl<'a> Stmt<'a> {
alloc.intersperse( alloc.intersperse(
vec![ vec![
remainder.to_doc(alloc),
alloc alloc
.text("joinpoint ") .text("joinpoint ")
.append(join_point_to_doc(alloc, *id)) .append(join_point_to_doc(alloc, *id))
@ -1142,6 +1141,8 @@ impl<'a> Stmt<'a> {
.append(alloc.intersperse(it, alloc.space())) .append(alloc.intersperse(it, alloc.space()))
.append(":"), .append(":"),
continuation.to_doc(alloc).indent(4), continuation.to_doc(alloc).indent(4),
alloc.text("in"),
remainder.to_doc(alloc),
], ],
alloc.hardline(), alloc.hardline(),
) )
@ -4397,6 +4398,7 @@ fn store_pattern<'a>(
field_layouts: arg_layouts.clone().into_bump_slice(), field_layouts: arg_layouts.clone().into_bump_slice(),
structure: outer_symbol, structure: outer_symbol,
}; };
match argument { match argument {
Identifier(symbol) => { Identifier(symbol) => {
// store immediately in the given symbol // store immediately in the given symbol

1
compiler/mono/src/layout.rs
View file

@ -435,6 +435,7 @@ impl<'a> Layout<'a> {
match self { match self {
Layout::Builtin(Builtin::List(_, _)) => true, Layout::Builtin(Builtin::List(_, _)) => true,
Layout::RecursiveUnion(_) => true, Layout::RecursiveUnion(_) => true,
Layout::RecursivePointer => true,
_ => false, _ => false,
} }
} }

580
compiler/mono/tests/test_mono.rs
View file

@ -116,11 +116,17 @@ mod test_mono {
let the_same = result == expected; let the_same = result == expected;
if !the_same { if !the_same {
println!("{}", result);
let expected_lines = expected.split("\n").collect::<Vec<&str>>(); let expected_lines = expected.split("\n").collect::<Vec<&str>>();
let result_lines = result.split("\n").collect::<Vec<&str>>(); let result_lines = result.split("\n").collect::<Vec<&str>>();
for line in &result_lines {
if !line.is_empty() {
println!(" {}", line);
} else {
println!("");
}
}
assert_eq!(expected_lines, result_lines); assert_eq!(expected_lines, result_lines);
assert_eq!(0, 1); assert_eq!(0, 1);
} }
@ -183,15 +189,13 @@ mod test_mono {
indoc!( indoc!(
r#" r#"
procedure Test.0 (): procedure Test.0 ():
let Test.10 = 0i64; let Test.8 = 0i64;
let Test.11 = 3i64; let Test.9 = 3i64;
let Test.2 = Just Test.10 Test.11; let Test.2 = Just Test.8 Test.9;
let Test.6 = true; let Test.5 = 0i64;
let Test.7 = 0i64; let Test.6 = Index 0 Test.2;
let Test.8 = Index 0 Test.2; let Test.7 = lowlevel Eq Test.5 Test.6;
let Test.9 = lowlevel Eq Test.7 Test.8; if Test.7 then
let Test.5 = lowlevel And Test.9 Test.6;
if Test.5 then
let Test.1 = Index 1 Test.2; let Test.1 = Index 1 Test.2;
ret Test.1; ret Test.1;
else else
@ -310,29 +314,27 @@ mod test_mono {
indoc!( indoc!(
r#" r#"
procedure Num.32 (#Attr.2, #Attr.3): procedure Num.32 (#Attr.2, #Attr.3):
let Test.19 = 0i64; let Test.17 = 0i64;
let Test.15 = lowlevel NotEq #Attr.3 Test.19; let Test.13 = lowlevel NotEq #Attr.3 Test.17;
if Test.15 then if Test.13 then
let Test.17 = 1i64; let Test.15 = 1i64;
let Test.18 = lowlevel NumDivUnchecked #Attr.2 #Attr.3; let Test.16 = lowlevel NumDivUnchecked #Attr.2 #Attr.3;
let Test.16 = Ok Test.17 Test.18; let Test.14 = Ok Test.15 Test.16;
ret Test.16; ret Test.14;
else else
let Test.13 = 0i64; let Test.11 = 0i64;
let Test.14 = Struct {}; let Test.12 = Struct {};
let Test.12 = Err Test.13 Test.14; let Test.10 = Err Test.11 Test.12;
ret Test.12; ret Test.10;
procedure Test.0 (): procedure Test.0 ():
let Test.10 = 1000i64; let Test.8 = 1000i64;
let Test.11 = 10i64; let Test.9 = 10i64;
let Test.2 = CallByName Num.32 Test.10 Test.11; let Test.2 = CallByName Num.32 Test.8 Test.9;
let Test.6 = true; let Test.5 = 1i64;
let Test.7 = 1i64; let Test.6 = Index 0 Test.2;
let Test.8 = Index 0 Test.2; let Test.7 = lowlevel Eq Test.5 Test.6;
let Test.9 = lowlevel Eq Test.7 Test.8; if Test.7 then
let Test.5 = lowlevel And Test.9 Test.6;
if Test.5 then
let Test.1 = Index 1 Test.2; let Test.1 = Index 1 Test.2;
ret Test.1; ret Test.1;
else else
@ -386,15 +388,13 @@ mod test_mono {
ret Test.5; ret Test.5;
procedure Test.0 (): procedure Test.0 ():
let Test.12 = 0i64; let Test.10 = 0i64;
let Test.13 = 41i64; let Test.11 = 41i64;
let Test.1 = Just Test.12 Test.13; let Test.1 = Just Test.10 Test.11;
let Test.8 = true; let Test.7 = 0i64;
let Test.9 = 0i64; let Test.8 = Index 0 Test.1;
let Test.10 = Index 0 Test.1; let Test.9 = lowlevel Eq Test.7 Test.8;
let Test.11 = lowlevel Eq Test.9 Test.10; if Test.9 then
let Test.7 = lowlevel And Test.11 Test.8;
if Test.7 then
let Test.2 = Index 1 Test.1; let Test.2 = Index 1 Test.1;
let Test.4 = 1i64; let Test.4 = 1i64;
let Test.3 = CallByName Num.14 Test.2 Test.4; let Test.3 = CallByName Num.14 Test.2 Test.4;
@ -442,20 +442,24 @@ mod test_mono {
r#" r#"
procedure Test.1 (Test.2): procedure Test.1 (Test.2):
let Test.5 = 2i64; let Test.5 = 2i64;
let Test.11 = true; joinpoint Test.11:
let Test.12 = 2i64; let Test.9 = 0i64;
let Test.15 = lowlevel Eq Test.12 Test.5; ret Test.9;
let Test.13 = lowlevel And Test.15 Test.11; in
let Test.8 = false; let Test.10 = 2i64;
jump Test.7 Test.8; let Test.13 = lowlevel Eq Test.10 Test.5;
joinpoint Test.7 Test.14: if Test.13 then
let Test.10 = lowlevel And Test.14 Test.13; joinpoint Test.7 Test.12:
if Test.10 then if Test.12 then
let Test.6 = 42i64; let Test.6 = 42i64;
ret Test.6; ret Test.6;
else else
let Test.9 = 0i64; jump Test.11;
ret Test.9; in
let Test.8 = false;
jump Test.7 Test.8;
else
jump Test.11;
procedure Test.0 (): procedure Test.0 ():
let Test.4 = Struct {}; let Test.4 = Struct {};
@ -511,30 +515,33 @@ mod test_mono {
ret Test.6; ret Test.6;
procedure Test.0 (): procedure Test.0 ():
let Test.17 = 0i64;
let Test.19 = 0i64; let Test.19 = 0i64;
let Test.21 = 0i64; let Test.20 = 41i64;
let Test.22 = 41i64; let Test.18 = Just Test.19 Test.20;
let Test.20 = Just Test.21 Test.22; let Test.2 = Just Test.17 Test.18;
let Test.2 = Just Test.19 Test.20; joinpoint Test.14:
let Test.10 = true; let Test.8 = 1i64;
ret Test.8;
in
let Test.9 = Index 1 Test.2;
let Test.10 = 0i64;
let Test.11 = Index 0 Test.9;
let Test.16 = lowlevel Eq Test.10 Test.11;
if Test.16 then
let Test.12 = 0i64; let Test.12 = 0i64;
let Test.11 = Index 1 Test.2; let Test.13 = Index 0 Test.2;
let Test.13 = Index 0 Test.11; let Test.15 = lowlevel Eq Test.12 Test.13;
let Test.18 = lowlevel Eq Test.12 Test.13; if Test.15 then
let Test.16 = lowlevel And Test.18 Test.10;
let Test.14 = 0i64;
let Test.15 = Index 0 Test.2;
let Test.17 = lowlevel Eq Test.14 Test.15;
let Test.9 = lowlevel And Test.17 Test.16;
if Test.9 then
let Test.7 = Index 1 Test.2; let Test.7 = Index 1 Test.2;
let Test.3 = Index 1 Test.7; let Test.3 = Index 1 Test.7;
let Test.5 = 1i64; let Test.5 = 1i64;
let Test.4 = CallByName Num.14 Test.3 Test.5; let Test.4 = CallByName Num.14 Test.3 Test.5;
ret Test.4; ret Test.4;
else else
let Test.8 = 1i64; jump Test.14;
ret Test.8; else
jump Test.14;
"# "#
), ),
) )
@ -555,26 +562,29 @@ mod test_mono {
ret Test.6; ret Test.6;
procedure Test.0 (): procedure Test.0 ():
let Test.16 = 2i64; let Test.14 = 2i64;
let Test.17 = 3i64; let Test.15 = 3i64;
let Test.3 = Struct {Test.16, Test.17}; let Test.3 = Struct {Test.14, Test.15};
let Test.8 = true; joinpoint Test.11:
let Test.10 = 4i64;
let Test.9 = Index 0 Test.3;
let Test.15 = lowlevel Eq Test.10 Test.9;
let Test.13 = lowlevel And Test.15 Test.8;
let Test.12 = 3i64;
let Test.11 = Index 1 Test.3;
let Test.14 = lowlevel Eq Test.12 Test.11;
let Test.7 = lowlevel And Test.14 Test.13;
if Test.7 then
let Test.4 = 9i64;
ret Test.4;
else
let Test.1 = Index 0 Test.3; let Test.1 = Index 0 Test.3;
let Test.2 = Index 1 Test.3; let Test.2 = Index 1 Test.3;
let Test.5 = CallByName Num.14 Test.1 Test.2; let Test.5 = CallByName Num.14 Test.1 Test.2;
ret Test.5; ret Test.5;
in
let Test.7 = Index 0 Test.3;
let Test.8 = 4i64;
let Test.13 = lowlevel Eq Test.8 Test.7;
if Test.13 then
let Test.9 = Index 1 Test.3;
let Test.10 = 3i64;
let Test.12 = lowlevel Eq Test.10 Test.9;
if Test.12 then
let Test.4 = 9i64;
ret Test.4;
else
jump Test.11;
else
jump Test.11;
"# "#
), ),
) )
@ -698,6 +708,9 @@ mod test_mono {
r#" r#"
procedure Test.1 (Test.4): procedure Test.1 (Test.4):
let Test.2 = 0u8; let Test.2 = 0u8;
joinpoint Test.8 Test.3:
ret Test.3;
in
switch Test.2: switch Test.2:
case 1: case 1:
let Test.9 = 1i64; let Test.9 = 1i64;
@ -711,8 +724,6 @@ mod test_mono {
let Test.11 = 3i64; let Test.11 = 3i64;
jump Test.8 Test.11; jump Test.8 Test.11;
joinpoint Test.8 Test.3:
ret Test.3;
procedure Test.0 (): procedure Test.0 ():
let Test.6 = Struct {}; let Test.6 = Struct {};
@ -798,21 +809,20 @@ mod test_mono {
indoc!( indoc!(
r#" r#"
procedure Test.1 (Test.4): procedure Test.1 (Test.4):
let Test.22 = 1i64; let Test.18 = 1i64;
let Test.23 = 2i64; let Test.19 = 2i64;
let Test.2 = Ok Test.22 Test.23; let Test.2 = Ok Test.18 Test.19;
let Test.18 = true; joinpoint Test.8 Test.3:
let Test.19 = 1i64; ret Test.3;
let Test.20 = Index 0 Test.2; in
let Test.21 = lowlevel Eq Test.19 Test.20; let Test.15 = 1i64;
let Test.17 = lowlevel And Test.21 Test.18; let Test.16 = Index 0 Test.2;
let Test.17 = lowlevel Eq Test.15 Test.16;
if Test.17 then if Test.17 then
let Test.13 = true; let Test.12 = Index 1 Test.2;
let Test.15 = 3i64; let Test.13 = 3i64;
let Test.14 = Index 1 Test.2; let Test.14 = lowlevel Eq Test.13 Test.12;
let Test.16 = lowlevel Eq Test.15 Test.14; if Test.14 then
let Test.12 = lowlevel And Test.16 Test.13;
if Test.12 then
let Test.9 = 1i64; let Test.9 = 1i64;
jump Test.8 Test.9; jump Test.8 Test.9;
else else
@ -821,8 +831,6 @@ mod test_mono {
else else
let Test.11 = 3i64; let Test.11 = 3i64;
jump Test.8 Test.11; jump Test.8 Test.11;
joinpoint Test.8 Test.3:
ret Test.3;
procedure Test.0 (): procedure Test.0 ():
let Test.6 = Struct {}; let Test.6 = Struct {};
@ -901,18 +909,17 @@ mod test_mono {
procedure Test.1 (Test.3): procedure Test.1 (Test.3):
let Test.6 = 10i64; let Test.6 = 10i64;
let Test.14 = true; joinpoint Test.8 Test.13:
let Test.10 = 5i64;
let Test.9 = CallByName Bool.5 Test.6 Test.10;
jump Test.8 Test.9;
joinpoint Test.8 Test.15:
let Test.13 = lowlevel And Test.15 Test.14;
if Test.13 then if Test.13 then
let Test.7 = 0i64; let Test.7 = 0i64;
ret Test.7; ret Test.7;
else else
let Test.12 = 42i64; let Test.12 = 42i64;
ret Test.12; ret Test.12;
in
let Test.10 = 5i64;
let Test.9 = CallByName Bool.5 Test.6 Test.10;
jump Test.8 Test.9;
procedure Test.0 (): procedure Test.0 ():
let Test.5 = Struct {}; let Test.5 = Struct {};
@ -977,11 +984,9 @@ mod test_mono {
r#" r#"
procedure Test.0 (): procedure Test.0 ():
let Test.2 = 0i64; let Test.2 = 0i64;
let Test.6 = true; let Test.5 = 1i64;
let Test.7 = 1i64; let Test.6 = lowlevel Eq Test.5 Test.2;
let Test.8 = lowlevel Eq Test.7 Test.2; if Test.6 then
let Test.5 = lowlevel And Test.8 Test.6;
if Test.5 then
let Test.3 = 12i64; let Test.3 = 12i64;
ret Test.3; ret Test.3;
else else
@ -1195,6 +1200,71 @@ mod test_mono {
), ),
indoc!( indoc!(
r#" r#"
procedure List.3 (#Attr.2, #Attr.3):
let Test.38 = lowlevel ListLen #Attr.2;
let Test.34 = lowlevel NumLt #Attr.3 Test.38;
if Test.34 then
let Test.36 = 1i64;
let Test.37 = lowlevel ListGetUnsafe #Attr.2 #Attr.3;
let Test.35 = Ok Test.36 Test.37;
ret Test.35;
else
let Test.32 = 0i64;
let Test.33 = Struct {};
let Test.31 = Err Test.32 Test.33;
ret Test.31;
procedure List.4 (#Attr.2, #Attr.3, #Attr.4):
let Test.14 = lowlevel ListLen #Attr.2;
let Test.12 = lowlevel NumLt #Attr.3 Test.14;
if Test.12 then
let Test.13 = lowlevel ListSet #Attr.2 #Attr.3 #Attr.4;
ret Test.13;
else
ret #Attr.2;
procedure Test.1 (Test.2):
let Test.39 = 0i64;
let Test.28 = CallByName List.3 Test.2 Test.39;
let Test.30 = 0i64;
let Test.29 = CallByName List.3 Test.2 Test.30;
let Test.7 = Struct {Test.28, Test.29};
joinpoint Test.25:
let Test.18 = Array [];
ret Test.18;
in
let Test.19 = Index 0 Test.7;
let Test.20 = 1i64;
let Test.21 = Index 0 Test.19;
let Test.27 = lowlevel Eq Test.20 Test.21;
if Test.27 then
let Test.22 = Index 1 Test.7;
let Test.23 = 1i64;
let Test.24 = Index 0 Test.22;
let Test.26 = lowlevel Eq Test.23 Test.24;
if Test.26 then
let Test.17 = Index 0 Test.7;
let Test.3 = Index 1 Test.17;
let Test.16 = Index 1 Test.7;
let Test.4 = Index 1 Test.16;
let Test.15 = 0i64;
let Test.9 = CallByName List.4 Test.2 Test.15 Test.4;
let Test.10 = 0i64;
let Test.8 = CallByName List.4 Test.9 Test.10 Test.3;
ret Test.8;
else
dec Test.2;
jump Test.25;
else
dec Test.2;
jump Test.25;
procedure Test.0 ():
let Test.40 = 1i64;
let Test.41 = 2i64;
let Test.6 = Array [Test.40, Test.41];
let Test.5 = CallByName Test.1 Test.6;
ret Test.5;
"# "#
), ),
) )
@ -1226,18 +1296,18 @@ mod test_mono {
indoc!( indoc!(
r#" r#"
procedure List.3 (#Attr.2, #Attr.3): procedure List.3 (#Attr.2, #Attr.3):
let Test.40 = lowlevel ListLen #Attr.2; let Test.38 = lowlevel ListLen #Attr.2;
let Test.36 = lowlevel NumLt #Attr.3 Test.40; let Test.34 = lowlevel NumLt #Attr.3 Test.38;
if Test.36 then if Test.34 then
let Test.38 = 1i64; let Test.36 = 1i64;
let Test.39 = lowlevel ListGetUnsafe #Attr.2 #Attr.3; let Test.37 = lowlevel ListGetUnsafe #Attr.2 #Attr.3;
let Test.37 = Ok Test.38 Test.39; let Test.35 = Ok Test.36 Test.37;
ret Test.37; ret Test.35;
else else
let Test.34 = 0i64; let Test.32 = 0i64;
let Test.35 = Struct {}; let Test.33 = Struct {};
let Test.33 = Err Test.34 Test.35; let Test.31 = Err Test.32 Test.33;
ret Test.33; ret Test.31;
procedure List.4 (#Attr.2, #Attr.3, #Attr.4): procedure List.4 (#Attr.2, #Attr.3, #Attr.4):
let Test.14 = lowlevel ListLen #Attr.2; let Test.14 = lowlevel ListLen #Attr.2;
@ -1249,23 +1319,25 @@ mod test_mono {
ret #Attr.2; ret #Attr.2;
procedure Test.1 (Test.2): procedure Test.1 (Test.2):
let Test.41 = 0i64; let Test.39 = 0i64;
let Test.30 = CallByName List.3 Test.2 Test.41; let Test.28 = CallByName List.3 Test.2 Test.39;
let Test.32 = 0i64; let Test.30 = 0i64;
let Test.31 = CallByName List.3 Test.2 Test.32; let Test.29 = CallByName List.3 Test.2 Test.30;
let Test.7 = Struct {Test.30, Test.31}; let Test.7 = Struct {Test.28, Test.29};
let Test.20 = true; joinpoint Test.25:
let Test.22 = 1i64; let Test.18 = Array [];
let Test.21 = Index 0 Test.7; ret Test.18;
let Test.23 = Index 0 Test.21; in
let Test.29 = lowlevel Eq Test.22 Test.23; let Test.19 = Index 0 Test.7;
let Test.27 = lowlevel And Test.29 Test.20; let Test.20 = 1i64;
let Test.25 = 1i64; let Test.21 = Index 0 Test.19;
let Test.24 = Index 1 Test.7; let Test.27 = lowlevel Eq Test.20 Test.21;
let Test.26 = Index 0 Test.24; if Test.27 then
let Test.28 = lowlevel Eq Test.25 Test.26; let Test.22 = Index 1 Test.7;
let Test.19 = lowlevel And Test.28 Test.27; let Test.23 = 1i64;
if Test.19 then let Test.24 = Index 0 Test.22;
let Test.26 = lowlevel Eq Test.23 Test.24;
if Test.26 then
let Test.17 = Index 0 Test.7; let Test.17 = Index 0 Test.7;
let Test.3 = Index 1 Test.17; let Test.3 = Index 1 Test.17;
let Test.16 = Index 1 Test.7; let Test.16 = Index 1 Test.7;
@ -1277,13 +1349,15 @@ mod test_mono {
ret Test.8; ret Test.8;
else else
dec Test.2; dec Test.2;
let Test.18 = Array []; jump Test.25;
ret Test.18; else
dec Test.2;
jump Test.25;
procedure Test.0 (): procedure Test.0 ():
let Test.42 = 1i64; let Test.40 = 1i64;
let Test.43 = 2i64; let Test.41 = 2i64;
let Test.6 = Array [Test.42, Test.43]; let Test.6 = Array [Test.40, Test.41];
let Test.5 = CallByName Test.1 Test.6; let Test.5 = CallByName Test.1 Test.6;
ret Test.5; ret Test.5;
"# "#
@ -1430,19 +1504,18 @@ mod test_mono {
ret Test.12; ret Test.12;
procedure Test.1 (Test.2, Test.3): procedure Test.1 (Test.2, Test.3):
jump Test.7 Test.2 Test.3;
joinpoint Test.7 Test.2 Test.3: joinpoint Test.7 Test.2 Test.3:
let Test.16 = true; let Test.15 = 0i64;
let Test.17 = 0i64; let Test.16 = lowlevel Eq Test.15 Test.2;
let Test.18 = lowlevel Eq Test.17 Test.2; if Test.16 then
let Test.15 = lowlevel And Test.18 Test.16;
if Test.15 then
ret Test.3; ret Test.3;
else else
let Test.13 = 1i64; let Test.13 = 1i64;
let Test.10 = CallByName Num.15 Test.2 Test.13; let Test.10 = CallByName Num.15 Test.2 Test.13;
let Test.11 = CallByName Num.16 Test.2 Test.3; let Test.11 = CallByName Num.16 Test.2 Test.3;
jump Test.7 Test.10 Test.11; jump Test.7 Test.10 Test.11;
in
jump Test.7 Test.2 Test.3;
procedure Test.0 (): procedure Test.0 ():
let Test.5 = 10i64; let Test.5 = 10i64;
@ -1767,20 +1840,19 @@ mod test_mono {
indoc!( indoc!(
r#" r#"
procedure Test.0 (): procedure Test.0 ():
let Test.8 = 0i64;
let Test.10 = 0i64; let Test.10 = 0i64;
let Test.12 = 0i64; let Test.12 = 0i64;
let Test.14 = 0i64; let Test.14 = 1i64;
let Test.16 = 1i64; let Test.13 = Z Test.14;
let Test.15 = Z Test.16;
let Test.13 = S Test.14 Test.15;
let Test.11 = S Test.12 Test.13; let Test.11 = S Test.12 Test.13;
let Test.2 = S Test.10 Test.11; let Test.9 = S Test.10 Test.11;
let Test.6 = true; let Test.2 = S Test.8 Test.9;
let Test.7 = 1i64; let Test.5 = 1i64;
let Test.8 = Index 0 Test.2; let Test.6 = Index 0 Test.2;
let Test.9 = lowlevel Eq Test.7 Test.8; dec Test.2;
let Test.5 = lowlevel And Test.9 Test.6; let Test.7 = lowlevel Eq Test.5 Test.6;
if Test.5 then if Test.7 then
let Test.3 = 0i64; let Test.3 = 0i64;
ret Test.3; ret Test.3;
else else
@ -1810,36 +1882,35 @@ mod test_mono {
indoc!( indoc!(
r#" r#"
procedure Test.0 (): procedure Test.0 ():
let Test.14 = 0i64;
let Test.16 = 0i64;
let Test.18 = 0i64; let Test.18 = 0i64;
let Test.20 = 0i64; let Test.20 = 1i64;
let Test.22 = 0i64; let Test.19 = Z Test.20;
let Test.24 = 1i64; let Test.17 = S Test.18 Test.19;
let Test.23 = Z Test.24; let Test.15 = S Test.16 Test.17;
let Test.21 = S Test.22 Test.23; let Test.2 = S Test.14 Test.15;
let Test.19 = S Test.20 Test.21; let Test.11 = 0i64;
let Test.2 = S Test.18 Test.19; let Test.12 = Index 0 Test.2;
let Test.14 = true; let Test.13 = lowlevel Eq Test.11 Test.12;
let Test.15 = 0i64;
let Test.16 = Index 0 Test.2;
let Test.17 = lowlevel Eq Test.15 Test.16;
let Test.13 = lowlevel And Test.17 Test.14;
if Test.13 then if Test.13 then
let Test.8 = true; let Test.7 = Index 1 Test.2;
let Test.10 = 0i64; inc Test.7;
let Test.9 = Index 1 Test.2; let Test.8 = 0i64;
inc Test.9; let Test.9 = Index 0 Test.7;
let Test.11 = Index 0 Test.9; dec Test.7;
dec Test.9; let Test.10 = lowlevel Eq Test.8 Test.9;
let Test.12 = lowlevel Eq Test.10 Test.11; if Test.10 then
let Test.7 = lowlevel And Test.12 Test.8;
if Test.7 then
let Test.4 = Index 1 Test.2; let Test.4 = Index 1 Test.2;
dec Test.2;
let Test.3 = 1i64; let Test.3 = 1i64;
ret Test.3; ret Test.3;
else else
dec Test.2;
let Test.5 = 0i64; let Test.5 = 0i64;
ret Test.5; ret Test.5;
else else
dec Test.2;
let Test.6 = 0i64; let Test.6 = 0i64;
ret Test.6; ret Test.6;
"# "#
@ -1872,12 +1943,10 @@ mod test_mono {
ret Test.13; ret Test.13;
procedure Test.1 (Test.6): procedure Test.1 (Test.6):
let Test.19 = true; let Test.18 = Index 0 Test.6;
let Test.21 = false; let Test.19 = false;
let Test.20 = Index 0 Test.6; let Test.20 = lowlevel Eq Test.19 Test.18;
let Test.22 = lowlevel Eq Test.21 Test.20; if Test.20 then
let Test.18 = lowlevel And Test.22 Test.19;
if Test.18 then
let Test.8 = Index 1 Test.6; let Test.8 = Index 1 Test.6;
ret Test.8; ret Test.8;
else else
@ -1885,11 +1954,9 @@ mod test_mono {
ret Test.10; ret Test.10;
procedure Test.1 (Test.6): procedure Test.1 (Test.6):
let Test.32 = true; let Test.29 = Index 0 Test.6;
let Test.34 = false; let Test.30 = false;
let Test.33 = Index 0 Test.6; let Test.31 = lowlevel Eq Test.30 Test.29;
let Test.35 = lowlevel Eq Test.34 Test.33;
let Test.31 = lowlevel And Test.35 Test.32;
if Test.31 then if Test.31 then
let Test.8 = 3i64; let Test.8 = 3i64;
ret Test.8; ret Test.8;
@ -1898,19 +1965,19 @@ mod test_mono {
ret Test.10; ret Test.10;
procedure Test.0 (): procedure Test.0 ():
let Test.38 = true; let Test.34 = true;
let Test.37 = Struct {Test.38}; let Test.33 = Struct {Test.34};
let Test.5 = CallByName Test.1 Test.37; let Test.5 = CallByName Test.1 Test.33;
let Test.36 = false; let Test.32 = false;
let Test.28 = Struct {Test.36}; let Test.26 = Struct {Test.32};
let Test.3 = CallByName Test.1 Test.28; let Test.3 = CallByName Test.1 Test.26;
let Test.26 = true; let Test.24 = true;
let Test.27 = 11i64; let Test.25 = 11i64;
let Test.25 = Struct {Test.26, Test.27}; let Test.23 = Struct {Test.24, Test.25};
let Test.4 = CallByName Test.1 Test.25; let Test.4 = CallByName Test.1 Test.23;
let Test.23 = false; let Test.21 = false;
let Test.24 = 7i64; let Test.22 = 7i64;
let Test.15 = Struct {Test.23, Test.24}; let Test.15 = Struct {Test.21, Test.22};
let Test.2 = CallByName Test.1 Test.15; let Test.2 = CallByName Test.1 Test.15;
let Test.14 = CallByName Num.16 Test.2 Test.3; let Test.14 = CallByName Num.16 Test.2 Test.3;
let Test.12 = CallByName Num.16 Test.14 Test.4; let Test.12 = CallByName Num.16 Test.14 Test.4;
@ -1943,30 +2010,33 @@ mod test_mono {
ret Test.6; ret Test.6;
procedure Test.0 (): procedure Test.0 ():
let Test.17 = 0i64;
let Test.19 = 0i64; let Test.19 = 0i64;
let Test.21 = 0i64; let Test.20 = 41i64;
let Test.22 = 41i64; let Test.18 = Just Test.19 Test.20;
let Test.20 = Just Test.21 Test.22; let Test.2 = Just Test.17 Test.18;
let Test.2 = Just Test.19 Test.20; joinpoint Test.14:
let Test.10 = true; let Test.8 = 1i64;
ret Test.8;
in
let Test.9 = Index 1 Test.2;
let Test.10 = 0i64;
let Test.11 = Index 0 Test.9;
let Test.16 = lowlevel Eq Test.10 Test.11;
if Test.16 then
let Test.12 = 0i64; let Test.12 = 0i64;
let Test.11 = Index 1 Test.2; let Test.13 = Index 0 Test.2;
let Test.13 = Index 0 Test.11; let Test.15 = lowlevel Eq Test.12 Test.13;
let Test.18 = lowlevel Eq Test.12 Test.13; if Test.15 then
let Test.16 = lowlevel And Test.18 Test.10;
let Test.14 = 0i64;
let Test.15 = Index 0 Test.2;
let Test.17 = lowlevel Eq Test.14 Test.15;
let Test.9 = lowlevel And Test.17 Test.16;
if Test.9 then
let Test.7 = Index 1 Test.2; let Test.7 = Index 1 Test.2;
let Test.3 = Index 1 Test.7; let Test.3 = Index 1 Test.7;
let Test.5 = 1i64; let Test.5 = 1i64;
let Test.4 = CallByName Num.14 Test.3 Test.5; let Test.4 = CallByName Num.14 Test.3 Test.5;
ret Test.4; ret Test.4;
else else
let Test.8 = 1i64; jump Test.14;
ret Test.8; else
jump Test.14;
"# "#
), ),
) )
@ -2055,18 +2125,18 @@ mod test_mono {
indoc!( indoc!(
r#" r#"
procedure List.3 (#Attr.2, #Attr.3): procedure List.3 (#Attr.2, #Attr.3):
let Test.42 = lowlevel ListLen #Attr.2; let Test.40 = lowlevel ListLen #Attr.2;
let Test.38 = lowlevel NumLt #Attr.3 Test.42; let Test.36 = lowlevel NumLt #Attr.3 Test.40;
if Test.38 then if Test.36 then
let Test.40 = 1i64; let Test.38 = 1i64;
let Test.41 = lowlevel ListGetUnsafe #Attr.2 #Attr.3; let Test.39 = lowlevel ListGetUnsafe #Attr.2 #Attr.3;
let Test.39 = Ok Test.40 Test.41; let Test.37 = Ok Test.38 Test.39;
ret Test.39; ret Test.37;
else else
let Test.36 = 0i64; let Test.34 = 0i64;
let Test.37 = Struct {}; let Test.35 = Struct {};
let Test.35 = Err Test.36 Test.37; let Test.33 = Err Test.34 Test.35;
ret Test.35; ret Test.33;
procedure List.4 (#Attr.2, #Attr.3, #Attr.4): procedure List.4 (#Attr.2, #Attr.3, #Attr.4):
let Test.18 = lowlevel ListLen #Attr.2; let Test.18 = lowlevel ListLen #Attr.2;
@ -2078,21 +2148,23 @@ mod test_mono {
ret #Attr.2; ret #Attr.2;
procedure Test.1 (Test.2, Test.3, Test.4): procedure Test.1 (Test.2, Test.3, Test.4):
let Test.33 = CallByName List.3 Test.4 Test.2; let Test.31 = CallByName List.3 Test.4 Test.2;
let Test.34 = CallByName List.3 Test.4 Test.3; let Test.32 = CallByName List.3 Test.4 Test.3;
let Test.12 = Struct {Test.33, Test.34}; let Test.12 = Struct {Test.31, Test.32};
let Test.23 = true; joinpoint Test.28:
let Test.25 = 1i64; let Test.21 = Array [];
let Test.24 = Index 0 Test.12; ret Test.21;
let Test.26 = Index 0 Test.24; in
let Test.32 = lowlevel Eq Test.25 Test.26; let Test.22 = Index 0 Test.12;
let Test.30 = lowlevel And Test.32 Test.23; let Test.23 = 1i64;
let Test.28 = 1i64; let Test.24 = Index 0 Test.22;
let Test.27 = Index 1 Test.12; let Test.30 = lowlevel Eq Test.23 Test.24;
let Test.29 = Index 0 Test.27; if Test.30 then
let Test.31 = lowlevel Eq Test.28 Test.29; let Test.25 = Index 1 Test.12;
let Test.22 = lowlevel And Test.31 Test.30; let Test.26 = 1i64;
if Test.22 then let Test.27 = Index 0 Test.25;
let Test.29 = lowlevel Eq Test.26 Test.27;
if Test.29 then
let Test.20 = Index 0 Test.12; let Test.20 = Index 0 Test.12;
let Test.5 = Index 1 Test.20; let Test.5 = Index 1 Test.20;
let Test.19 = Index 1 Test.12; let Test.19 = Index 1 Test.12;
@ -2102,14 +2174,16 @@ mod test_mono {
ret Test.13; ret Test.13;
else else
dec Test.4; dec Test.4;
let Test.21 = Array []; jump Test.28;
ret Test.21; else
dec Test.4;
jump Test.28;
procedure Test.0 (): procedure Test.0 ():
let Test.9 = 0i64; let Test.9 = 0i64;
let Test.10 = 0i64; let Test.10 = 0i64;
let Test.43 = 1i64; let Test.41 = 1i64;
let Test.11 = Array [Test.43]; let Test.11 = Array [Test.41];
let Test.8 = CallByName Test.1 Test.9 Test.10 Test.11; let Test.8 = CallByName Test.1 Test.9 Test.10 Test.11;
ret Test.8; ret Test.8;
"# "#

65
compiler/reporting/tests/test_reporting.rs
View file

@ -1047,7 +1047,7 @@ mod test_reporting {
r#" r#"
── TYPE MISMATCH ─────────────────────────────────────────────────────────────── ── TYPE MISMATCH ───────────────────────────────────────────────────────────────
Something is off with the 1st branch of this `if` expression: Something is off with the `then` branch of this `if` expression:
2│ x = if True then 3.14 else 4 2│ x = if True then 3.14 else 4
^^^^ ^^^^
@ -1084,12 +1084,14 @@ mod test_reporting {
r#" r#"
── TYPE MISMATCH ─────────────────────────────────────────────────────────────── ── TYPE MISMATCH ───────────────────────────────────────────────────────────────
Something is off with the 1st branch of this `when` expression: Something is off with the body of the `x` definition:
4│ _ -> 3.14 1│ x : Int
^^^^ 2│ x =
3│> when True is
4│> _ -> 3.14
The 1st branch is a float of type: This `when`expression produces:
Float Float
@ -1123,15 +1125,15 @@ mod test_reporting {
1│ x : Int -> Int 1│ x : Int -> Int
2│ x = \_ -> 3.14 2│ x = \_ -> 3.14
^^^^^^^^^^ ^^^^
The body is an anonymous function of type: The body is a float of type:
Int -> Float Float
But the type annotation on `x` says it should be: But the type annotation on `x` says it should be:
Int -> Int Int
Tip: You can convert between Int and Float using functions like Tip: You can convert between Int and Float using functions like
`Num.toFloat` and `Num.round`. `Num.toFloat` and `Num.round`.
@ -1664,7 +1666,7 @@ mod test_reporting {
r#" r#"
── TYPE MISMATCH ─────────────────────────────────────────────────────────────── ── TYPE MISMATCH ───────────────────────────────────────────────────────────────
This `if` has an `else` branch with a different type from its `then` branch: Something is off with the `else` branch of this `if` expression:
2│ f = \x, y -> if True then x else y 2│ f = \x, y -> if True then x else y
^ ^
@ -1673,12 +1675,10 @@ mod test_reporting {
b b
but the `then` branch has the type: But the type annotation on `f` says it should be:
a a
I need all branches in an `if` to have the same type!
Tip: Your type annotation uses `b` and `a` as separate type variables. Tip: Your type annotation uses `b` and `a` as separate type variables.
Your code seems to be saying they are the same though. Maybe they Your code seems to be saying they are the same though. Maybe they
should be the same your type annotation? Maybe your code uses them in should be the same your type annotation? Maybe your code uses them in
@ -1707,15 +1707,15 @@ mod test_reporting {
1│ f : Bool -> msg 1│ f : Bool -> msg
2│ f = \_ -> Foo 2│ f = \_ -> Foo
^^^^^^^^^ ^^^
The body is an anonymous function of type: This `Foo` global tag has the type:
Bool -> [ Foo ]a [ Foo ]a
But the type annotation on `f` says it should be: But the type annotation on `f` says it should be:
Bool -> msg msg
Tip: The type annotation uses the type variable `msg` to say that this Tip: The type annotation uses the type variable `msg` to say that this
definition can produce any type of value. But in the body I see that definition can produce any type of value. But in the body I see that
@ -1830,18 +1830,19 @@ mod test_reporting {
Something is off with the body of the `f` definition: Something is off with the body of the `f` definition:
1│ f : Bool -> Int 1│ f : Bool -> Int
2│> f = \_ -> 2│ f = \_ ->
3│> ok = 3 3│ ok = 3
4│> 4│
5│> Ok 5│ Ok
^^
The body is an anonymous function of type: This `Ok` global tag has the type:
Bool -> [ Ok ]a [ Ok ]a
But the type annotation on `f` says it should be: But the type annotation on `f` says it should be:
Bool -> Int Int
"# "#
), ),
) )
@ -2141,15 +2142,15 @@ mod test_reporting {
1│ f : [ A ] -> [ A, B ] 1│ f : [ A ] -> [ A, B ]
2│ f = \a -> a 2│ f = \a -> a
^^^^^^^ ^
The body is an anonymous function of type: This `a` value is a:
[ A ] -> [ A ] [ A ]
But the type annotation on `f` says it should be: But the type annotation on `f` says it should be:
[ A ] -> [ A, B ] [ A, B ]
Tip: Looks like a closed tag union does not have the `B` tag. Tip: Looks like a closed tag union does not have the `B` tag.
@ -2179,15 +2180,15 @@ mod test_reporting {
1│ f : [ A ] -> [ A, B, C ] 1│ f : [ A ] -> [ A, B, C ]
2│ f = \a -> a 2│ f = \a -> a
^^^^^^^ ^
The body is an anonymous function of type: This `a` value is a:
[ A ] -> [ A ] [ A ]
But the type annotation on `f` says it should be: But the type annotation on `f` says it should be:
[ A ] -> [ A, B, C ] [ A, B, C ]
Tip: Looks like a closed tag union does not have the `C` and `B` tags. Tip: Looks like a closed tag union does not have the `C` and `B` tags.

95
compiler/solve/tests/solve_expr.rs
View file

@ -3519,4 +3519,99 @@ mod solve_expr {
"Int, Int, List (Num a), Int, Num a -> [ Pair Int (List (Num a)) ]", "Int, Int, List (Num a), Int, Num a -> [ Pair Int (List (Num a)) ]",
); );
} }
#[test]
fn rbtree_old_balance_simplified() {
infer_eq_without_problem(
indoc!(
r#"
app Test provides [ main ] imports []
Dict k : [ Node k (Dict k) (Dict k), Empty ]
balance : k, Dict k -> Dict k
balance = \key, left ->
Node key left Empty
main : Dict Int
main =
balance 0 Empty
"#
),
"Dict Int",
);
}
#[test]
fn rbtree_balance_simplified() {
infer_eq_without_problem(
indoc!(
r#"
app Test provides [ main ] imports []
Dict k : [ Node k (Dict k) (Dict k), Empty ]
node = \x,y,z -> Node x y z
balance : k, Dict k -> Dict k
balance = \key, left ->
node key left Empty
main : Dict Int
main =
balance 0 Empty
"#
),
"Dict Int",
);
}
#[test]
fn rbtree_balance() {
infer_eq_without_problem(
indoc!(
r#"
app Test provides [ main ] imports []
NodeColor : [ Red, Black ]
Dict k v : [ Node NodeColor k v (Dict k v) (Dict k v), Empty ]
balance : NodeColor, k, v, Dict k v, Dict k v -> Dict k v
balance = \color, key, value, left, right ->
when right is
Node Red rK rV rLeft rRight ->
when left is
Node Red lK lV lLeft lRight ->
Node
Red
key
value
(Node Black lK lV lLeft lRight)
(Node Black rK rV rLeft rRight)
_ ->
Node color rK rV (Node Red key value left rLeft) rRight
_ ->
when left is
Node Red lK lV (Node Red llK llV llLeft llRight) lRight ->
Node
Red
lK
lV
(Node Black llK llV llLeft llRight)
(Node Black key value lRight right)
_ ->
Node color key value left right
main : Dict Int Int
main =
balance Red 0 0 Empty Empty
"#
),
"Dict Int Int",
);
}
} }

38
compiler/unify/src/unify.rs
View file

@ -180,7 +180,8 @@ fn unify_alias(
// Alias wins // Alias wins
merge(subs, &ctx, Alias(symbol, args.to_owned(), real_var)) merge(subs, &ctx, Alias(symbol, args.to_owned(), real_var))
} }
RecursionVar { .. } | RigidVar(_) => unify_pool(subs, pool, real_var, ctx.second), RecursionVar { structure, .. } => unify_pool(subs, pool, real_var, *structure),
RigidVar(_) => unify_pool(subs, pool, real_var, ctx.second),
Alias(other_symbol, other_args, other_real_var) => { Alias(other_symbol, other_args, other_real_var) => {
if symbol == *other_symbol { if symbol == *other_symbol {
if args.len() == other_args.len() { if args.len() == other_args.len() {
@ -240,7 +241,8 @@ fn unify_structure(
problems problems
} }
FlatType::RecursiveTagUnion(_, _, _) => { FlatType::RecursiveTagUnion(rec, _, _) => {
debug_assert!(is_recursion_var(subs, *rec));
let structure_rank = subs.get(*structure).rank; let structure_rank = subs.get(*structure).rank;
let self_rank = subs.get(ctx.first).rank; let self_rank = subs.get(ctx.first).rank;
let other_rank = subs.get(ctx.second).rank; let other_rank = subs.get(ctx.second).rank;
@ -593,7 +595,7 @@ fn unify_tag_union_not_recursive_recursive(
tag_problems tag_problems
} else { } else {
let flat_type = FlatType::RecursiveTagUnion(recursion_var, unique_tags2, rec2.ext); let flat_type = FlatType::TagUnion(unique_tags2, rec2.ext);
let sub_record = fresh(subs, pool, ctx, Structure(flat_type)); let sub_record = fresh(subs, pool, ctx, Structure(flat_type));
let ext_problems = unify_pool(subs, pool, rec1.ext, sub_record); let ext_problems = unify_pool(subs, pool, rec1.ext, sub_record);
@ -616,7 +618,7 @@ fn unify_tag_union_not_recursive_recursive(
tag_problems tag_problems
} }
} else if unique_tags2.is_empty() { } else if unique_tags2.is_empty() {
let flat_type = FlatType::RecursiveTagUnion(recursion_var, unique_tags1, rec1.ext); let flat_type = FlatType::TagUnion(unique_tags1, rec1.ext);
let sub_record = fresh(subs, pool, ctx, Structure(flat_type)); let sub_record = fresh(subs, pool, ctx, Structure(flat_type));
let ext_problems = unify_pool(subs, pool, sub_record, rec2.ext); let ext_problems = unify_pool(subs, pool, sub_record, rec2.ext);
@ -641,8 +643,8 @@ fn unify_tag_union_not_recursive_recursive(
let other_tags = union(unique_tags1.clone(), &unique_tags2); let other_tags = union(unique_tags1.clone(), &unique_tags2);
let ext = fresh(subs, pool, ctx, Content::FlexVar(None)); let ext = fresh(subs, pool, ctx, Content::FlexVar(None));
let flat_type1 = FlatType::RecursiveTagUnion(recursion_var, unique_tags1, ext); let flat_type1 = FlatType::TagUnion(unique_tags1, ext);
let flat_type2 = FlatType::RecursiveTagUnion(recursion_var, unique_tags2, ext); let flat_type2 = FlatType::TagUnion(unique_tags2, ext);
let sub1 = fresh(subs, pool, ctx, Structure(flat_type1)); let sub1 = fresh(subs, pool, ctx, Structure(flat_type1));
let sub2 = fresh(subs, pool, ctx, Structure(flat_type2)); let sub2 = fresh(subs, pool, ctx, Structure(flat_type2));
@ -855,6 +857,7 @@ fn unify_shared_tags(
new_tags.extend(fields.into_iter()); new_tags.extend(fields.into_iter());
let flat_type = if let Some(rec) = recursion_var { let flat_type = if let Some(rec) = recursion_var {
debug_assert!(is_recursion_var(subs, rec));
FlatType::RecursiveTagUnion(rec, new_tags, new_ext_var) FlatType::RecursiveTagUnion(rec, new_tags, new_ext_var)
} else { } else {
FlatType::TagUnion(new_tags, new_ext_var) FlatType::TagUnion(new_tags, new_ext_var)
@ -924,6 +927,7 @@ fn unify_flat_type(
} }
(RecursiveTagUnion(recursion_var, tags1, ext1), TagUnion(tags2, ext2)) => { (RecursiveTagUnion(recursion_var, tags1, ext1), TagUnion(tags2, ext2)) => {
debug_assert!(is_recursion_var(subs, *recursion_var));
// this never happens in type-correct programs, but may happen if there is a type error // this never happens in type-correct programs, but may happen if there is a type error
let union1 = gather_tags(subs, tags1.clone(), *ext1); let union1 = gather_tags(subs, tags1.clone(), *ext1);
let union2 = gather_tags(subs, tags2.clone(), *ext2); let union2 = gather_tags(subs, tags2.clone(), *ext2);
@ -939,6 +943,7 @@ fn unify_flat_type(
} }
(TagUnion(tags1, ext1), RecursiveTagUnion(recursion_var, tags2, ext2)) => { (TagUnion(tags1, ext1), RecursiveTagUnion(recursion_var, tags2, ext2)) => {
debug_assert!(is_recursion_var(subs, *recursion_var));
let union1 = gather_tags(subs, tags1.clone(), *ext1); let union1 = gather_tags(subs, tags1.clone(), *ext1);
let union2 = gather_tags(subs, tags2.clone(), *ext2); let union2 = gather_tags(subs, tags2.clone(), *ext2);
@ -946,6 +951,8 @@ fn unify_flat_type(
} }
(RecursiveTagUnion(rec1, tags1, ext1), RecursiveTagUnion(rec2, tags2, ext2)) => { (RecursiveTagUnion(rec1, tags1, ext1), RecursiveTagUnion(rec2, tags2, ext2)) => {
debug_assert!(is_recursion_var(subs, *rec1));
debug_assert!(is_recursion_var(subs, *rec2));
let union1 = gather_tags(subs, tags1.clone(), *ext1); let union1 = gather_tags(subs, tags1.clone(), *ext1);
let union2 = gather_tags(subs, tags2.clone(), *ext2); let union2 = gather_tags(subs, tags2.clone(), *ext2);
@ -1153,13 +1160,16 @@ fn unify_recursion(
// unify the structure variable with this Structure // unify the structure variable with this Structure
unify_pool(subs, pool, structure, ctx.second) unify_pool(subs, pool, structure, ctx.second)
} }
RigidVar(_) => mismatch!("RecursionVar {:?} with rigid {:?}", ctx.first, &other),
FlexVar(_) | RigidVar(_) => { FlexVar(_) => merge(
// TODO special-case boolean here subs,
// In all other cases, if left is flex, defer to right. ctx,
// (This includes using right's name if both are flex and named.) RecursionVar {
merge(subs, ctx, other.clone()) structure,
} opt_name: opt_name.clone(),
},
),
Alias(_, _, actual) => { Alias(_, _, actual) => {
// look at the type the alias stands for // look at the type the alias stands for
@ -1227,3 +1237,7 @@ fn gather_tags(
_ => TagUnionStructure { tags, ext: var }, _ => TagUnionStructure { tags, ext: var },
} }
} }
fn is_recursion_var(subs: &Subs, var: Variable) -> bool {
matches!(subs.get_without_compacting(var).content, Content::RecursionVar { .. })
}