From bb81d3f5097531b18257157cb36dade24f4f40e8 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Tue, 17 Dec 2024 23:04:30 +0000 Subject: [PATCH] working with loose ends --- src/ir_def/check_ir.ml | 2 +- src/ir_def/construct.ml | 34 +++++++++++++++ src/ir_def/construct.mli | 2 + src/lowering/desugar.ml | 41 +++++++++++-------- src/mo_frontend/typing.ml | 4 +- test/run-drun/upgrade-migration/Migration2.mo | 10 +++-- test/run-drun/upgrade-migration/version1.mo | 2 +- 7 files changed, 71 insertions(+), 24 deletions(-) diff --git a/src/ir_def/check_ir.ml b/src/ir_def/check_ir.ml index 37e84da5623..bc88a40244d 100644 --- a/src/ir_def/check_ir.ml +++ b/src/ir_def/check_ir.ml @@ -241,7 +241,7 @@ let rec check_typ env typ : unit = if not (Lib.List.is_strictly_ordered T.compare_field fields) then error env no_region "variant type's fields are not distinct and sorted %s" (T.string_of_typ typ) | T.Mut typ -> - error env no_region "unexpected T.Mut" + error env no_region "unexpected T.Mut %s" (T.string_of_typ typ) | T.Typ c -> error env no_region "unexpected T.Typ" diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index 6564490287e..7d0c53177b3 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -790,8 +790,42 @@ let objE sort typ_flds flds = in go [] [] [] flds + let recordE flds = objE T.Object [] flds +let objectE sort flds (tfs : T.field list) = + let rec go ds fields = function + | [] -> + blockE + (List.rev ds) + (newObjE sort fields + (T.Obj (sort, List.sort T.compare_field tfs))) + | (lab, exp)::flds -> + let v, typ, ds = + match T.lookup_val_field_opt lab tfs with + | None -> assert false + | Some typ -> + if T.is_mut typ + then + let v = fresh_var lab typ in + v, typ, varD v exp :: ds + else + match exp.it with + | VarE (Const, v) -> + var v typ, typ, ds + | _ -> + let v = fresh_var lab typ in + v, typ, letD v exp :: ds + in + let field = { + it = {name = lab; var = id_of_var v}; + at = no_region; + note = typ + } in + go ds (field::fields) flds + in + go [] [] flds + let check_call_perform_status success mk_failure = ifE (callE diff --git a/src/ir_def/construct.mli b/src/ir_def/construct.mli index 26387ef5097..3fd690004a4 100644 --- a/src/ir_def/construct.mli +++ b/src/ir_def/construct.mli @@ -147,6 +147,8 @@ val (-*-) : exp -> exp -> exp (* application *) val objE : obj_sort -> (lab * con) list -> (lab * exp) list -> exp +val objectE : obj_sort -> (lab * exp) list -> field list -> exp + (* Records *) val recordE : (lab * exp) list -> exp diff --git a/src/lowering/desugar.ml b/src/lowering/desugar.ml index 0e411d08143..b3bcffc81bc 100644 --- a/src/lowering/desugar.ml +++ b/src/lowering/desugar.ml @@ -561,12 +561,17 @@ and build_actor at ts exp_opt self_id es obj_typ = primE (I.OtherPrim "rts_stable_memory_size") []; natE Numerics.Nat.zero]) (primE (I.ICStableRead ty) []) - (let fields' = List.map (fun (i,t) -> - let t' = match T.lookup_val_field_opt i dom_fields with - | None -> t - | Some t -> t - in - T.{lab = i; typ = T.Opt (T.as_immut t'); src = T.empty_src}) ids in + (let fields' = + List.map + (fun (i,t) -> + T.{lab = i; typ = T.Opt (T.as_immut t); src = T.empty_src}) + ((List.map (fun T.{lab;typ;_} -> (lab,typ)) dom_fields) @ + (List.filter_map + (fun (i,t) -> + match T.lookup_val_field_opt i dom_fields with + | Some t -> None (* ignore overriden *) + | None -> Some (i, t) (* retain others *)) + ids)) in let ty' = T.Obj (T.Memory, List.sort T.compare_field fields') in let v = fresh_var "v" ty' in (* let fields'' = List.map (fun (i,t) -> @@ -581,28 +586,28 @@ and build_actor at ts exp_opt self_id es obj_typ = (* let v_res = fresh_var "v_res" ty in *) letE v (primE (I.ICStableRead ty') []) (letE v_dom - (objE T.Object [] - (List.map (fun T.{lab=i;typ=t;_} -> - let vi = fresh_var ("v_"^i) t in - (i, switch_optE (dotE (varE v) i (T.Opt t)) + (objectE T.Object + (List.map (fun T.{lab=i;typ=t;_} -> + let vi = fresh_var ("v_"^i) (T.as_immut t) in + (i, switch_optE (dotE (varE v) i (T.Opt (T.as_immut t))) (primE (Ir.OtherPrim "trap") - [textE ("stable variable "^i^"required but no found")]) + [textE ("stable variable " ^ i ^ " expected but not found")]) (varP vi) (varE vi) - t)) dom_fields)) - (letE v_rng (callE e [] (varE v)) - (objE T.Memory [] + (T.as_immut t))) dom_fields) dom_fields) + (letE v_rng (callE e [] (varE v_dom)) + (objectE T.Memory (List.map (fun T.{lab=i;typ=t;_} -> i, match T.lookup_val_field_opt i rng_fields with (* produced by migration *) - | Some t -> optE (dotE (varE v_rng) i t) (* wrap in ? _*) - | None -> + | Some t -> optE (dotE (varE v_rng) i (T.as_immut t)) (* wrap in ?_*) + | None -> (* not produced by migration *) match T.lookup_val_field_opt i dom_fields with | Some t -> nullE() (* consumed by migration (not produced) *) (*TBR: could also reuse if compatible *) - | None -> dotE (varE v) i (T.Opt t)) - fields))))) + | None -> dotE (varE v) i t) + fields) fields)))) in let ds = varD state (optE migration) diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index 28174f385e7..520acb5860c 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -1368,7 +1368,8 @@ and infer_exp'' env exp : T.typ = error_in [Flags.ICMode; Flags.RefMode] env exp.at "M0069" "non-toplevel actor; an actor can only be declared at the toplevel of a program" | _ -> () - end; + end; + let _t_opt = Option.map (infer_exp env) exp_opt in let env' = if obj_sort.it = T.Actor then { env with @@ -2687,6 +2688,7 @@ and infer_dec env dec : T.typ = (*TODO exp_opt *) let (t, _, _, _) = T.Env.find id.it env.vals in if not env.pre then begin + let _t_opt = Option.map (infer_exp env) exp_opt in let c = T.Env.find id.it env.typs in let ve0 = check_class_shared_pat env shared_pat obj_sort in let cs, tbs, te, ce = check_typ_binds env typ_binds in diff --git a/test/run-drun/upgrade-migration/Migration2.mo b/test/run-drun/upgrade-migration/Migration2.mo index 5573827a568..2ece7b34597 100644 --- a/test/run-drun/upgrade-migration/Migration2.mo +++ b/test/run-drun/upgrade-migration/Migration2.mo @@ -1,10 +1,14 @@ +import Prim "mo:prim"; module { - public func run( o : { var three : [var (Nat,Nat)] } ) : + public func run( pre : { var three : [var (Nat,Nat)] } ) : { var four : [var (Nat,Nat)] } { + let post = { - var four = o.three; - } + var four = pre.three; + }; + Prim.debugPrint(debug_show{pre;post}); + post } } \ No newline at end of file diff --git a/test/run-drun/upgrade-migration/version1.mo b/test/run-drun/upgrade-migration/version1.mo index a427813e44a..973d14a23ac 100644 --- a/test/run-drun/upgrade-migration/version1.mo +++ b/test/run-drun/upgrade-migration/version1.mo @@ -1,7 +1,7 @@ import Prim "mo:prim"; import Migration "Migration1"; -actor { +actor [Migration.run] { Prim.debugPrint("Version 1");