diff --git a/src/passes/2-simplify/pascaligo.ml b/src/passes/2-simplify/pascaligo.ml index 066949450..2a8218156 100644 --- a/src/passes/2-simplify/pascaligo.ml +++ b/src/passes/2-simplify/pascaligo.ml @@ -989,105 +989,80 @@ and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi -> and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun fc -> let statements = npseq_to_list fc.block.value.statements in - (* building initial record *) - let aux (el : Raw.statement) : Raw.instruction option = match el with + (* build initial record *) + let filter_assignments (el : Raw.statement) : Raw.instruction option = match el with | Raw.Instr (Assign _ as i) -> Some i | _ -> None in - let assign_instrs = List.filter_map aux statements in + let assign_instrs = List.filter_map filter_assignments statements in let%bind assign_instrs' = bind_map_list (fun el -> let%bind assign' = simpl_instruction el in let%bind assign' = assign' None in ok @@ assign') assign_instrs in - let aux prev ass_exp = - match ass_exp.expression with - | E_assign ( name , _ , _ ) -> - let expr' = e_variable name in - SMap.add name expr' prev - | _ -> prev in - let captured_list = List.filter_map + let captured_name_list = List.filter_map (fun ass_exp -> match ass_exp.expression with - | E_assign ( name, _ , _ ) -> Some name - | _ -> None ) + | E_assign ( name, _ , _ ) -> Some name | _ -> None ) assign_instrs' in - let init_record = e_record (List.fold_left aux SMap.empty assign_instrs') in - - (* replace assignments to X assignments to record in the for_collect - block which will become the body of the lambda *) - let%bind block' = simpl_block fc.block.value in - let%bind block' = block' None in - + let add_to_record (prev: expression type_name_map) (captured_name: string) = + SMap.add captured_name (e_variable captured_name) prev in + let init_record = e_record (List.fold_left add_to_record SMap.empty captured_name_list) in + (* replace references to the future lambda arguments in the for body *) + let%bind for_body = simpl_block fc.block.value in + let%bind for_body = for_body None in let replace exp = + (* TODO: map and set updated/remove must also be captured *) match exp.expression with - (* replace asignement *) | E_assign ( name , path , expr ) -> + (* replace references to fold accumulator as rhs *) let path' = ( match path with | [] -> [Access_record name] - (* This will fail for deep tuple access, see LIGO-131 *) + (* This might fail for deep tuple access, see LIGO-131 *) | _ -> ( (Access_record name) :: path ) ) in ok @@ e_assign "_COMPILER_acc" path' expr | E_variable name -> if (name = fc.var.value ) then - (* replace reference to the collection element *) + (* replace references to the collection element *) ok @@ (e_variable "_COMPILER_collec_elt") - else if (List.mem name captured_list) then - (* replace reference fold accumulator *) + else if (List.mem name captured_name_list) then + (* replace references to fold accumulator as lhs *) ok @@ e_accessor (e_variable "_COMPILER_acc") [Access_record name] else ok @@ exp | _ -> ok @@ exp in - let%bind block' = Self_ast_simplified.map_expression replace block' in - - (* append the return value *) - let rec add_return expr = match expr.expression with + let%bind for_body = Self_ast_simplified.map_expression replace for_body in + (* append the return value (the accumulator) to the for body *) + let rec add_return (expr : expression) = match expr.expression with | E_sequence (a,b) -> e_sequence a (add_return b) | _ -> e_sequence expr (e_variable "_COMPILER_acc") in - let block' = add_return block' in - - (* prepend the body with let accumulator = argument.0 in let collec_elt = argument.1 in*) + let for_body = add_return for_body in + (* prepend for body with args declaration (accumulator and collection element)*) let%bind elt_type = simpl_type_expression fc.elt_type in let acc = e_accessor (e_variable "arguments") [Access_tuple 0] in let collec_elt = e_accessor (e_variable "arguments") [Access_tuple 1] in - let block' = e_let_in ("_COMPILER_acc", None) acc @@ - e_let_in ("_COMPILER_collec_elt", Some elt_type) collec_elt (block') in - - + let for_body = e_let_in ("_COMPILER_acc", None) acc @@ + e_let_in ("_COMPILER_collec_elt", Some elt_type) collec_elt (for_body) in (* build the X_FOLD constant *) - let lambda = e_lambda "arguments" None None block' in let%bind collect = simpl_expression fc.expr in + let lambda = e_lambda "arguments" None None for_body in let op_name = match fc.collection with - | Map _ -> "MAP_FOLD" - | Set _ -> "SET_FOLD" - | List _ -> "LIST_FOLD" in + | Map _ -> "MAP_FOLD" | Set _ -> "SET_FOLD" | List _ -> "LIST_FOLD" in let fold = e_constant op_name [collect ; init_record ; lambda] in - - (* append assigments of fold result to the original captured variables *) - let aux (prev : expression option) (captured_varname : string) = + (* build sequence to re-assign fold result to the original captured variables *) + let assign_back (prev : expression option) (captured_varname : string) : expression option = let access = e_accessor (e_variable "_COMPILER_folded_record") [Access_record captured_varname] in let assign = e_assign captured_varname [] access in match prev with | None -> Some assign | Some p -> Some (e_sequence p assign) in - let ( reassign_sequence : expression option ) = List.fold_left aux None captured_list in - + let reassign_sequence = List.fold_left assign_back None captured_name_list in + (* attach the folded record to the re-assign sequence *) let final_sequence = match reassign_sequence with (* None case means that no variables were captured *) | None -> e_let_in ("_COMPILER_folded_record", None) fold (e_skip ()) | Some seq -> e_let_in ("_COMPILER_folded_record", None) fold seq in - return_statement @@ final_sequence -(** NODE TO AVOID THE DIRT: - - have a E_unsimplified 'a which is then transformed in a self pass ?? - - need to forbid that ? - for i in somelist - begin - i := .. - end - - global definition of strings -**) - let simpl_program : Raw.ast -> program result = fun t -> bind_list @@ List.map simpl_declaration @@ nseq_to_list t.decl \ No newline at end of file diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index 73a8144e2..832e7b04f 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -626,22 +626,21 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a ] ) -> (* this special case is here force annotation of the untyped lambda generated by pascaligo's for_collect loop *) - let%bind lst' = bind_list @@ List.map (type_expression e) [collect ; init_record] in - let tv_lst = List.map get_type_annotation lst' in - let tv_col = List.nth tv_lst 0 in - let tv_out = List.nth tv_lst 1 in - let collect_inner_type = match tv_col.type_value' with - | O.T_constant ( ("list"|"set"|"map") , [t]) -> t - | _ -> failwith "impossible" in - let input_type = t_tuple (tv_out::[collect_inner_type]) () in - let output_type = Some tv_out in - + let%bind (v_col , v_initr ) = bind_map_pair (type_expression e) (collect , init_record ) in + let tv_col = get_type_annotation v_col in (* this is the type of the collection *) + let tv_out = get_type_annotation v_initr in (* this is the output type of the lambda*) + let%bind col_inner_type = match tv_col.type_value' with + | O.T_constant ( ("list"|"set"|"map") , [t]) -> ok t + | _ -> + let wtype = Format.asprintf + "Loops over collections expect lists, sets or maps, type %a" O.PP.type_value tv_col in + fail @@ simple_error wtype in + let input_type = t_tuple (tv_out::[col_inner_type]) () in let e' = Environment.add_ez_binder lname input_type e in - let%bind body = type_expression ?tv_opt:output_type e' result in + let%bind body = type_expression ?tv_opt:(Some tv_out) e' result in let output_type = body.type_annotation in - let%bind lambda' = ok @@ make_a_e (E_lambda {binder = lname ; body}) (t_function input_type output_type ()) e in - - let%bind lst' = ok @@ lst'@[lambda'] in + let lambda' = make_a_e (E_lambda {binder = lname ; body}) (t_function input_type output_type ()) e in + let lst' = [v_col; v_initr ; lambda'] in let tv_lst = List.map get_type_annotation lst' in let%bind (opname', tv) = type_constant opname tv_lst tv_opt ae.location in