From f58339d3ed9d63134c5e8b0f42b76faba60bce63 Mon Sep 17 00:00:00 2001 From: Martin Elsman Date: Mon, 4 Mar 2024 17:00:58 +0100 Subject: [PATCH] Spring cleanup (#166) * fix test * fix warning * better types for improved unboxity * fix real test * fix equality --- src/Compiler/Backend/CLOS_EXP.sml | 12 +- src/Compiler/Backend/ClosExp.sml | 36 +++--- src/Compiler/Backend/JS/ExpToJs2.sml | 1 + src/Compiler/Backend/LINE_STMT.sml | 28 ++--- src/Compiler/Backend/LineStmt.sml | 82 ++++++------ src/Compiler/Backend/PrimName.sml | 4 + src/Compiler/Backend/RegAlloc.sml | 14 +-- src/Compiler/Backend/SubstAndSimplify.sml | 8 +- src/Compiler/Backend/X64/CodeGenX64.sml | 8 +- src/Compiler/Lambda/CompileDec.sml | 84 ++++++++----- src/Compiler/Lambda/CompilerEnv.sml | 36 ++---- src/Compiler/Lambda/EliminateEq.sml | 147 +++++++++++++++------- src/Compiler/Lambda/LAMBDA_EXP.sml | 2 +- src/Compiler/Lambda/LambdaBasics.sml | 20 +-- src/Compiler/Lambda/LambdaExp.sml | 14 +-- src/Compiler/Lambda/LambdaStatSem.sml | 24 ++-- src/Compiler/Lambda/OptLambda.sml | 106 ++++++++-------- src/Compiler/Regions/RType.sml | 20 +-- src/Compiler/Regions/SpreadDataType.sml | 2 +- src/Makefile.in | 3 +- src/Pickle/pickle.sml | 116 ++++++++--------- src/Runtime/Posix.c | 4 +- src/Tools/MlbMake/MLB_PROJECT.sml | 2 +- src/Tools/MlbMake/MlbProject.sml | 8 +- src/config.h.in | 10 +- test/real.sml | 12 +- 26 files changed, 435 insertions(+), 368 deletions(-) diff --git a/src/Compiler/Backend/CLOS_EXP.sml b/src/Compiler/Backend/CLOS_EXP.sml index bf8e1de4b..540db7765 100644 --- a/src/Compiler/Backend/CLOS_EXP.sml +++ b/src/Compiler/Backend/CLOS_EXP.sml @@ -54,8 +54,8 @@ signature CLOS_EXP = datatype ClosExp = VAR of lvar - | RVAR of place - | DROPPED_RVAR of place + | RVAR of {rho:place} + | DROPPED_RVAR of {rho:place} | FETCH of label | STORE of ClosExp * label | INTEGER of {value: IntInf.int, precision: int} @@ -64,7 +64,7 @@ signature CLOS_EXP = | REAL of string | F64 of string | PASS_PTR_TO_MEM of sma * int - | PASS_PTR_TO_RHO of sma + | PASS_PTR_TO_RHO of {sma: sma} | UB_RECORD of ClosExp list | CLOS_RECORD of {label: label, elems: ClosExp list * ClosExp list * ClosExp list, f64_vars: int, alloc: sma} | REGVEC_RECORD of {elems: sma list, alloc: sma} @@ -81,7 +81,7 @@ signature CLOS_EXP = clos: ClosExp option} | LETREGION of {rhos: binder list, body: ClosExp} | LET of {pat: lvar list, bind: ClosExp, scope: ClosExp} - | RAISE of ClosExp + | RAISE of {exp: ClosExp} | HANDLE of ClosExp * ClosExp | SWITCH_I of {switch: IntInf.int Switch, precision: int} | SWITCH_W of {switch: IntInf.int Switch, precision: int} @@ -91,10 +91,10 @@ signature CLOS_EXP = | CON0 of {con: con, con_kind: con_kind, aux_regions: sma list, alloc: sma} | CON1 of {con: con, con_kind: con_kind, alloc: sma, arg: ClosExp} | DECON of {con: con, con_kind: con_kind, con_exp: ClosExp} - | DEREF of ClosExp + | DEREF of {exp: ClosExp} | REF of sma * ClosExp | ASSIGN of sma * ClosExp * ClosExp - | DROP of ClosExp + | DROP of {exp: ClosExp} | RESET_REGIONS of {force: bool, regions_for_resetting: sma list} | CCALL of {name: string, diff --git a/src/Compiler/Backend/ClosExp.sml b/src/Compiler/Backend/ClosExp.sml index 11bd0ab33..794cd2144 100644 --- a/src/Compiler/Backend/ClosExp.sml +++ b/src/Compiler/Backend/ClosExp.sml @@ -62,8 +62,8 @@ struct datatype ClosExp = VAR of lvar - | RVAR of place - | DROPPED_RVAR of place + | RVAR of {rho:place} + | DROPPED_RVAR of {rho:place} | FETCH of label | STORE of ClosExp * label | INTEGER of {value: IntInf.int, precision: int} @@ -72,7 +72,7 @@ struct | REAL of string | F64 of string | PASS_PTR_TO_MEM of sma * int - | PASS_PTR_TO_RHO of sma + | PASS_PTR_TO_RHO of {sma:sma} | UB_RECORD of ClosExp list | CLOS_RECORD of {label: label, elems: ClosExp list * ClosExp list * ClosExp list, f64_vars: int, alloc: sma} | REGVEC_RECORD of {elems: sma list, alloc: sma} @@ -89,7 +89,7 @@ struct clos: ClosExp option} | LETREGION of {rhos: binder list, body: ClosExp} | LET of {pat: lvar list, bind: ClosExp, scope: ClosExp} - | RAISE of ClosExp + | RAISE of {exp: ClosExp} | HANDLE of ClosExp * ClosExp | SWITCH_I of {switch: IntInf.int Switch, precision: int} | SWITCH_W of {switch: IntInf.int Switch, precision: int} @@ -99,10 +99,10 @@ struct | CON0 of {con: con, con_kind: con_kind, aux_regions: sma list, alloc: sma} | CON1 of {con: con, con_kind: con_kind, alloc: sma, arg: ClosExp} | DECON of {con: con, con_kind: con_kind, con_exp: ClosExp} - | DEREF of ClosExp + | DEREF of {exp: ClosExp} | REF of sma * ClosExp | ASSIGN of sma * ClosExp * ClosExp - | DROP of ClosExp + | DROP of {exp: ClosExp} | RESET_REGIONS of {force: bool, regions_for_resetting: sma list} | CCALL of {name: string, @@ -190,8 +190,8 @@ struct end fun layout_ce(VAR lv) = LEAF(Lvars.pr_lvar lv) - | layout_ce(RVAR place) = Effect.layout_effect place - | layout_ce(DROPPED_RVAR place) = LEAF("D" ^ flatten1(Effect.layout_effect place)) + | layout_ce(RVAR {rho}) = Effect.layout_effect rho + | layout_ce(DROPPED_RVAR {rho}) = LEAF("D" ^ flatten1(Effect.layout_effect rho)) | layout_ce(FETCH lab) = LEAF("fetch(" ^ Labels.pr_label lab ^ ")") | layout_ce(STORE(ce,lab)) = LEAF("store(" ^ flatten1(layout_ce ce) ^ "," ^ Labels.pr_label lab ^ ")") | layout_ce(INTEGER {value,precision}) = LEAF(IntInf.toString value) @@ -200,7 +200,7 @@ struct | layout_ce(REAL s) = LEAF(s) | layout_ce(F64 s) = LEAF(s ^ "f64") | layout_ce(PASS_PTR_TO_MEM(sma,i)) = LEAF("MEM(" ^ (flatten1(pr_sma sma)) ^ "," ^ Int.toString i ^ ")") - | layout_ce(PASS_PTR_TO_RHO(sma)) = LEAF("PTR(" ^ (flatten1(pr_sma sma)) ^ ")") + | layout_ce(PASS_PTR_TO_RHO {sma}) = LEAF("PTR(" ^ (flatten1(pr_sma sma)) ^ ")") | layout_ce(UB_RECORD ces) = HNODE{start="<", finish=">", childsep=RIGHT ",", @@ -327,7 +327,7 @@ struct children=[bindings,body], childsep=LEFT (" in ")} end - | layout_ce(RAISE ce) = PP.LEAF("raise " ^ (flatten1(layout_ce ce))) + | layout_ce(RAISE {exp=ce}) = PP.LEAF("raise " ^ (flatten1(layout_ce ce))) | layout_ce(HANDLE(ce1,ce2)) = NODE{start="",finish="",childsep=RIGHT " handle ",indent=1, children=[layout_ce ce1,layout_ce ce2]} | layout_ce(SWITCH_I {switch,precision}) = layout_switch layout_ce (IntInf.toString) switch @@ -349,13 +349,13 @@ struct children=[layout_ce arg]} | layout_ce(DECON{con,con_kind,con_exp}) = LEAF("decon(" ^ Con.pr_con con ^ "(" ^ pr_con_kind con_kind ^ ")," ^ (flatten1(layout_ce con_exp)) ^ ")") - | layout_ce(DEREF ce) = LEAF("!" ^ (flatten1(layout_ce ce))) + | layout_ce(DEREF {exp=ce}) = LEAF("!" ^ (flatten1(layout_ce ce))) | layout_ce(REF(sma,ce)) = LEAF("ref " ^ (flatten1(layout_ce ce)) ^ " " ^ (flatten1(pr_sma sma))) | layout_ce(ASSIGN(sma,ce1,ce2)) = HNODE{start="", finish="", childsep=RIGHT ":=", children=[layout_ce ce1,layout_ce ce2]} - | layout_ce(DROP ce) = layout_ce ce + | layout_ce(DROP {exp=ce}) = layout_ce ce (* PP.LEAF("drop " ^ (flatten1(layout_ce ce))) *) @@ -1246,8 +1246,8 @@ struct fun lookup_rho env place (f : unit -> string) = case CE.lookupRhoOpt env place of SOME(CE.LVAR lv') => (VAR lv',NONE_SE) - | SOME(CE.RVAR place) => (RVAR place, NONE_SE) - | SOME(CE.DROPPED_RVAR place) => (DROPPED_RVAR place, NONE_SE) + | SOME(CE.RVAR place) => (RVAR {rho=place}, NONE_SE) + | SOME(CE.DROPPED_RVAR place) => (DROPPED_RVAR {rho=place}, NONE_SE) | SOME(CE.SELECT(lv',i)) => let val lv'' = fresh_lvar("lookup_rho") in (VAR lv'',SELECT_SE(lv'',i,lv')) @@ -1569,7 +1569,7 @@ struct | _ => die (s ^ "("^pr()^ "): expecting only non-dropped rvars; sma=" ^ pp_sma sma) *) - in PASS_PTR_TO_RHO sma + in PASS_PTR_TO_RHO {sma=sma} end fun unTR (MulExp.TR a) = a @@ -1919,7 +1919,7 @@ struct let val (ce,se) = ccTrip tr env lab cur_rv in - (insert_se(RAISE ce,se),NONE_SE) + (insert_se(RAISE {exp=ce},se),NONE_SE) end | MulExp.HANDLE(tr1,tr2) => (HANDLE (insert_se(ccTrip tr1 env lab cur_rv), insert_se(ccTrip tr2 env lab cur_rv)),NONE_SE) @@ -2192,7 +2192,7 @@ struct let val (ce,se) = ccTrip tr env lab cur_rv in - (insert_se(DEREF ce,se),NONE_SE) + (insert_se(DEREF {exp=ce},se),NONE_SE) end | MulExp.ASSIGN(tr1,tr2) => let @@ -2207,7 +2207,7 @@ struct let val (ce,se) = ccTrip tr env lab cur_rv in - (insert_se(DROP ce,se),NONE_SE) + (insert_se(DROP {exp=ce},se),NONE_SE) end | MulExp.EQUAL({mu_of_arg1,mu_of_arg2},tr1,tr2) => let diff --git a/src/Compiler/Backend/JS/ExpToJs2.sml b/src/Compiler/Backend/JS/ExpToJs2.sml index 8247fd425..fd73099f9 100644 --- a/src/Compiler/Backend/JS/ExpToJs2.sml +++ b/src/Compiler/Backend/JS/ExpToJs2.sml @@ -403,6 +403,7 @@ fun pToJs2 name e1 e2 : J.exp = | "__greatereq_word31" => J.Prim(">=", [e1,e2]) | "__greater_word31" => J.Prim(">", [e1,e2]) | "__equal_word31" => J.Prim("==", [e1,e2]) + | "__equal_ptr" => J.Prim("==", [e1,e2]) | "__less_real" => J.Prim("<", [e1,e2]) | "__lesseq_real" => J.Prim("<=", [e1,e2]) diff --git a/src/Compiler/Backend/LINE_STMT.sml b/src/Compiler/Backend/LINE_STMT.sml index 8d93b19c3..0b3a0a2ea 100644 --- a/src/Compiler/Backend/LINE_STMT.sml +++ b/src/Compiler/Backend/LINE_STMT.sml @@ -78,8 +78,19 @@ signature LINE_STMT = V of lvar | FV of lvar * label * label + datatype 'aty sma = + ATTOP_LI of 'aty * pp + | ATTOP_LF of 'aty * pp + | ATTOP_FI of 'aty * pp + | ATTOP_FF of 'aty * pp + | ATBOT_LI of 'aty * pp + | ATBOT_LF of 'aty * pp + | SAT_FI of 'aty * pp + | SAT_FF of 'aty * pp + | IGNORE + datatype 'aty SimpleExp = - ATOM of 'aty + ATOM of {aty:'aty} | LOAD of label | STORE of 'aty * label (* moved to LineStmt??? 2001-03-15, Niels *) | STRING of string @@ -95,12 +106,12 @@ signature LINE_STMT = | CON0 of {con: con, con_kind: con_kind, aux_regions: 'aty sma list, alloc: 'aty sma} | CON1 of {con: con, con_kind: con_kind, alloc: 'aty sma, arg: 'aty} | DECON of {con: con, con_kind: con_kind, con_aty: 'aty} - | DEREF of 'aty + | DEREF of {aty:'aty} | REF of 'aty sma * 'aty | ASSIGNREF of 'aty sma * 'aty * 'aty | PASS_PTR_TO_MEM of 'aty sma * int * bool (* Used only by CCALL *) (* The boolean is true if the region has an untagged type *) - | PASS_PTR_TO_RHO of 'aty sma (* Used only by CCALL *) + | PASS_PTR_TO_RHO of {sma:'aty sma} (* Used only by CCALL *) and ('sty,'offset,'aty) LineStmt = ASSIGN of {pat: 'aty, bind: 'aty SimpleExp} @@ -137,17 +148,6 @@ signature LINE_STMT = and ('a,'sty,'offset,'aty) Switch = SWITCH of 'aty * ('a * (('sty,'offset,'aty) LineStmt list)) list * (('sty,'offset,'aty) LineStmt list) - and 'aty sma = - ATTOP_LI of 'aty * pp - | ATTOP_LF of 'aty * pp - | ATTOP_FI of 'aty * pp - | ATTOP_FF of 'aty * pp - | ATBOT_LI of 'aty * pp - | ATBOT_LF of 'aty * pp - | SAT_FI of 'aty * pp - | SAT_FF of 'aty * pp - | IGNORE - datatype ('sty,'offset,'aty) TopDecl = FUN of label * cc * ('sty,'offset,'aty) LineStmt list | FN of label * cc * ('sty,'offset,'aty) LineStmt list diff --git a/src/Compiler/Backend/LineStmt.sml b/src/Compiler/Backend/LineStmt.sml index 807df5c10..101601d15 100644 --- a/src/Compiler/Backend/LineStmt.sml +++ b/src/Compiler/Backend/LineStmt.sml @@ -89,8 +89,19 @@ struct V of lvar | FV of lvar * label * label + datatype 'aty sma = + ATTOP_LI of 'aty * pp + | ATTOP_LF of 'aty * pp + | ATTOP_FI of 'aty * pp + | ATTOP_FF of 'aty * pp + | ATBOT_LI of 'aty * pp + | ATBOT_LF of 'aty * pp + | SAT_FI of 'aty * pp + | SAT_FF of 'aty * pp + | IGNORE + datatype 'aty SimpleExp = - ATOM of 'aty + ATOM of {aty:'aty} | LOAD of label | STORE of 'aty * label | STRING of string @@ -106,12 +117,12 @@ struct | CON0 of {con: con, con_kind: con_kind, aux_regions: 'aty sma list, alloc: 'aty sma} | CON1 of {con: con, con_kind: con_kind, alloc: 'aty sma, arg: 'aty} | DECON of {con: con, con_kind: con_kind, con_aty: 'aty} - | DEREF of 'aty + | DEREF of {aty:'aty} | REF of 'aty sma * 'aty | ASSIGNREF of 'aty sma * 'aty * 'aty | PASS_PTR_TO_MEM of 'aty sma * int * bool (* Used only by CCALL *) (* The boolean is true if the region has an untagged type *) - | PASS_PTR_TO_RHO of 'aty sma (* Used only by CCALL *) + | PASS_PTR_TO_RHO of {sma:'aty sma} (* Used only by CCALL *) and ('sty,'offset,'aty) LineStmt = ASSIGN of {pat: 'aty, bind: 'aty SimpleExp} @@ -149,17 +160,6 @@ struct and ('a,'sty,'offset,'aty) Switch = SWITCH of 'aty * ('a * (('sty,'offset,'aty) LineStmt list)) list * (('sty,'offset,'aty) LineStmt list) - and 'aty sma = - ATTOP_LI of 'aty * pp - | ATTOP_LF of 'aty * pp - | ATTOP_FI of 'aty * pp - | ATTOP_FF of 'aty * pp - | ATBOT_LI of 'aty * pp - | ATBOT_LF of 'aty * pp - | SAT_FI of 'aty * pp - | SAT_FF of 'aty * pp - | IGNORE - datatype ('sty,'offset,'aty) TopDecl = FUN of label * cc * ('sty,'offset,'aty) LineStmt list | FN of label * cc * ('sty,'offset,'aty) LineStmt list @@ -268,7 +268,7 @@ struct fun layout_se pr_aty se = (case se of - ATOM aty => layout_aty pr_aty aty + ATOM {aty} => layout_aty pr_aty aty | LOAD lab => LEAF("load(" ^ Labels.pr_label lab ^ ")") | STORE(aty,lab) => LEAF("store(" ^ pr_aty aty ^ "," ^ Labels.pr_label lab ^ ")") | STRING s => LEAF("\"" ^ String.toString s ^ "\"") @@ -314,7 +314,7 @@ struct children=[layout_aty pr_aty arg]} | DECON{con,con_kind,con_aty} => LEAF("decon(" ^ Con.pr_con con ^ "(" ^ pr_con_kind con_kind ^ ")," ^ pr_aty con_aty ^ ")") - | DEREF(aty) => LEAF("!" ^ pr_aty aty) + | DEREF {aty} => LEAF("!" ^ pr_aty aty) | REF(sma,aty) => LEAF("ref " ^ pr_aty aty ^ " " ^ pr_sma pr_aty sma) | ASSIGNREF(sma,aty1,aty2) => HNODE{start="", finish="", @@ -322,7 +322,7 @@ struct children=[layout_aty pr_aty aty1,layout_aty pr_aty aty2]} | PASS_PTR_TO_MEM(sma,i,b) => LEAF("MEM(" ^ pr_sma pr_aty sma ^ "," ^ Int.toString i ^ "," ^ Bool.toString b ^ ")") - | PASS_PTR_TO_RHO(sma) => LEAF("PTR(" ^ pr_sma pr_aty sma ^ ")")) + | PASS_PTR_TO_RHO {sma} => LEAF("PTR(" ^ pr_sma pr_aty sma ^ ")")) and layout_ls pr_sty pr_offset pr_aty simplify ls = let @@ -585,8 +585,8 @@ struct fun binder_to_binder (place,phsize) = ((place,phsize),()) (* for now, offset is unit *) fun ce_to_atom (ClosExp.VAR lv) = VAR lv - | ce_to_atom (ClosExp.RVAR place) = RVAR place - | ce_to_atom (ClosExp.DROPPED_RVAR place) = DROPPED_RVAR place + | ce_to_atom (ClosExp.RVAR {rho=place}) = RVAR place + | ce_to_atom (ClosExp.DROPPED_RVAR {rho=place}) = DROPPED_RVAR place | ce_to_atom (ClosExp.INTEGER i) = INTEGER i | ce_to_atom (ClosExp.WORD i) = WORD i | ce_to_atom (ClosExp.RECORD{elems=[],alloc=ClosExp.IGNORE,tag,maybeuntag}) = UNIT @@ -643,25 +643,25 @@ struct fun L_ce (ce,lvars_res,acc) = case ce - of ClosExp.VAR lv => maybe_assign (lvars_res, ATOM(VAR lv), acc) - | ClosExp.RVAR place => die "RVAR not implemented" - | ClosExp.DROPPED_RVAR place => die "DROPPED_RVAR not implemented" + of ClosExp.VAR lv => maybe_assign (lvars_res, ATOM {aty=VAR lv}, acc) + | ClosExp.RVAR _ => die "RVAR not implemented" + | ClosExp.DROPPED_RVAR _ => die "DROPPED_RVAR not implemented" | ClosExp.FETCH lab => maybe_assign (lvars_res, LOAD lab, acc) | ClosExp.STORE(ce,lab) => ASSIGN{pat=UNIT,bind=STORE(ce_to_atom ce,lab)}::acc - | ClosExp.INTEGER i => maybe_assign (lvars_res, ATOM(INTEGER i), acc) - | ClosExp.WORD i => maybe_assign (lvars_res, ATOM(WORD i), acc) + | ClosExp.INTEGER i => maybe_assign (lvars_res, ATOM {aty=INTEGER i}, acc) + | ClosExp.WORD i => maybe_assign (lvars_res, ATOM {aty=WORD i}, acc) | ClosExp.STRING s => maybe_assign (lvars_res, STRING s, acc) | ClosExp.REAL s => maybe_assign (lvars_res, REAL s, acc) | ClosExp.F64 s => maybe_assign (lvars_res, F64 s, acc) | ClosExp.PASS_PTR_TO_MEM(sma,i) => let fun untagged_region_type sma = case ce_of_sma sma of - SOME (ClosExp.RVAR rho) => is_region_pair rho + SOME (ClosExp.RVAR {rho}) => is_region_pair rho | _ => false val b = untagged_region_type sma in maybe_assign (lvars_res, PASS_PTR_TO_MEM(sma_to_sma sma,i,b), acc) end - | ClosExp.PASS_PTR_TO_RHO sma => maybe_assign (lvars_res, PASS_PTR_TO_RHO(sma_to_sma sma), acc) + | ClosExp.PASS_PTR_TO_RHO {sma} => maybe_assign (lvars_res, PASS_PTR_TO_RHO {sma=sma_to_sma sma}, acc) | ClosExp.UB_RECORD ces => List.foldr (fn ((ce,lv_res),acc) => L_ce(ce,[lv_res],acc)) acc (zip(ces,lvars_res)) | ClosExp.CLOS_RECORD{label,elems=(lvs,excons,rhos),f64_vars,alloc} => maybe_assign (lvars_res, CLOS_RECORD{label=label, @@ -706,7 +706,7 @@ struct L_ce(bind,[],L_ce(scope,lvars_res,acc)) | ClosExp.LET{pat,bind,scope} => SCOPE{pat=map mk_sty pat,scope=L_ce(bind,pat,L_ce(scope,lvars_res,[]))}::acc - | ClosExp.RAISE ce => RAISE{arg=ce_to_atom ce,defined_atys=map VAR lvars_res}::acc + | ClosExp.RAISE {exp=ce} => RAISE{arg=ce_to_atom ce,defined_atys=map VAR lvars_res}::acc | ClosExp.HANDLE(ce1,ce2) => let val aty = case lvars_res @@ -738,17 +738,17 @@ struct | ClosExp.DECON{con,con_kind,con_exp} => maybe_assign (lvars_res, DECON{con=con,con_kind=con_kind_to_con_kind con_kind, con_aty=ce_to_atom con_exp}, acc) - | ClosExp.DEREF ce => - maybe_assign (lvars_res, DEREF(ce_to_atom ce), acc) + | ClosExp.DEREF {exp=ce} => + maybe_assign (lvars_res, DEREF {aty=ce_to_atom ce}, acc) | ClosExp.REF(sma,ce) => maybe_assign (lvars_res, REF(sma_to_sma sma,ce_to_atom ce), acc) | ClosExp.ASSIGN(sma,ce1,ce2) => maybe_assign (lvars_res, ASSIGNREF(sma_to_sma sma,ce_to_atom ce1,ce_to_atom ce2), acc) - | ClosExp.DROP(ce) => L_ce(ce,lvars_res,acc) + | ClosExp.DROP {exp=ce} => L_ce(ce,lvars_res,acc) | ClosExp.RESET_REGIONS{force,regions_for_resetting} => (* We must have RESET_REGIONS return unit. *) RESET_REGIONS{force=force,regions_for_resetting=smas_to_smas regions_for_resetting}:: - maybe_assign (lvars_res, ATOM UNIT, acc) + maybe_assign (lvars_res, ATOM {aty=UNIT}, acc) | ClosExp.CCALL{name,rhos_for_result,args} => (case PrimName.lookup_prim name of SOME pname => PRIM{name=pname,args=ces_to_atoms rhos_for_result @ ces_to_atoms args, @@ -770,7 +770,7 @@ struct end) | ClosExp.EXPORT{name,clos_lab,arg=(ce,ft1,ft2)} => EXPORT{name=name,clos_lab=clos_lab,arg=(ce_to_atom ce,ft1,ft2)}:: - maybe_assign (lvars_res, ATOM UNIT, acc) + maybe_assign (lvars_res, ATOM {aty=UNIT}, acc) | ClosExp.FRAME{declared_lvars,declared_excons} => acc fun L_top_decl (ClosExp.FUN(lab,cc,ce)) = @@ -857,7 +857,7 @@ struct fun get_phreg_smas (smas,acc) = foldr (fn (sma,acc) => get_phreg_sma(sma,acc)) acc smas - fun get_phreg_se (ATOM atom,acc) = get_phreg_atom(atom,acc) + fun get_phreg_se (ATOM {aty=atom},acc) = get_phreg_atom(atom,acc) | get_phreg_se (LOAD lab,acc) = acc | get_phreg_se (STORE(atom,lab),acc) = get_phreg_atom(atom,acc) | get_phreg_se (STRING str,acc) = acc @@ -873,11 +873,11 @@ struct | get_phreg_se (CON0{con,con_kind,aux_regions,alloc},acc) = get_phreg_sma(alloc, get_phreg_smas(aux_regions,acc)) | get_phreg_se (CON1{con,con_kind,alloc,arg},acc) = get_phreg_sma(alloc,get_phreg_atom(arg,acc)) | get_phreg_se (DECON{con,con_kind,con_aty},acc) = get_phreg_atom(con_aty,acc) - | get_phreg_se (DEREF atom,acc) = get_phreg_atom(atom,acc) + | get_phreg_se (DEREF {aty=atom},acc) = get_phreg_atom(atom,acc) | get_phreg_se (REF(sma,atom),acc) = get_phreg_sma(sma,get_phreg_atom(atom,acc)) | get_phreg_se (ASSIGNREF(sma,atom1,atom2),acc) = get_phreg_sma(sma,get_phreg_atom(atom1,get_phreg_atom(atom2,acc))) | get_phreg_se (PASS_PTR_TO_MEM(sma,i,_),acc) = get_phreg_sma(sma,acc) - | get_phreg_se (PASS_PTR_TO_RHO sma,acc) = get_phreg_sma(sma,acc) + | get_phreg_se (PASS_PTR_TO_RHO {sma},acc) = get_phreg_sma(sma,acc) fun get_phreg_in_fun {opr,args,reg_args,fargs,clos,res,bv} = (* Operand is always a label *) get_phreg_atoms(args,get_phreg_atoms(reg_args,get_phreg_atoms(fargs,get_phreg_atom_opt(clos,get_phreg_atoms(res,[]))))) @@ -984,7 +984,7 @@ struct fun use_var_se' get_var_sma get_var_smas smash_free arg = case arg of - (ATOM atom,acc) => get_var_atom(atom,acc) + (ATOM {aty=atom},acc) => get_var_atom(atom,acc) | (LOAD lab,acc) => acc | (STORE(atom,lab),acc) => get_var_atom(atom,acc) | (STRING str,acc) => acc @@ -1000,11 +1000,11 @@ struct | (CON0{con,con_kind,aux_regions,alloc},acc) => get_var_sma(alloc, get_var_smas(aux_regions,acc)) | (CON1{con,con_kind,alloc,arg},acc) => get_var_sma(alloc,get_var_atom(arg,acc)) | (DECON{con,con_kind,con_aty},acc) => get_var_atom(con_aty,acc) - | (DEREF atom,acc) => get_var_atom(atom,acc) + | (DEREF {aty=atom},acc) => get_var_atom(atom,acc) | (REF(sma,atom),acc) => get_var_sma(sma,get_var_atom(atom,acc)) | (ASSIGNREF(sma,atom1,atom2),acc) => get_var_sma(sma,get_var_atom(atom1,get_var_atom(atom2,acc))) | (PASS_PTR_TO_MEM(sma,i,_),acc) => get_var_sma(sma,acc) - | (PASS_PTR_TO_RHO sma,acc) => get_var_sma(sma,acc) + | (PASS_PTR_TO_RHO {sma},acc) => get_var_sma(sma,acc) fun filter_out_ubf64_lvars lvs = List.filter (not o Lvars.get_ubf64) lvs @@ -1134,7 +1134,7 @@ struct res=map_atys res, bv=bv} - fun map_se (ATOM aty) = ATOM (map_aty aty) + fun map_se (ATOM {aty}) = ATOM {aty=map_aty aty} | map_se (LOAD label) = LOAD label | map_se (STORE(aty,label)) = STORE(map_aty aty,label) | map_se (STRING str) = STRING str @@ -1157,11 +1157,11 @@ struct | map_se (CON0{con,con_kind,aux_regions,alloc}) = CON0{con=con,con_kind=con_kind,aux_regions=map_smas aux_regions,alloc=map_sma alloc} | map_se (CON1{con,con_kind,alloc,arg}) = CON1{con=con,con_kind=con_kind,alloc=map_sma alloc,arg=map_aty arg} | map_se (DECON{con,con_kind,con_aty}) = DECON{con=con,con_kind=con_kind,con_aty=map_aty con_aty} - | map_se (DEREF aty) = DEREF(map_aty aty) + | map_se (DEREF {aty}) = DEREF {aty=map_aty aty} | map_se (REF(sma,aty)) = REF(map_sma sma,map_aty aty) | map_se (ASSIGNREF(sma,aty1,aty2)) = ASSIGNREF(map_sma sma,map_aty aty1,map_aty aty2) | map_se (PASS_PTR_TO_MEM(sma,i,b)) = PASS_PTR_TO_MEM(map_sma sma,i,b) - | map_se (PASS_PTR_TO_RHO(sma)) = PASS_PTR_TO_RHO(map_sma sma) + | map_se (PASS_PTR_TO_RHO {sma}) = PASS_PTR_TO_RHO {sma=map_sma sma} fun map_lss' ([]) = [] | map_lss' (ASSIGN{pat,bind}::lss) = ASSIGN{pat=map_aty pat,bind=map_se bind} :: map_lss' lss diff --git a/src/Compiler/Backend/PrimName.sml b/src/Compiler/Backend/PrimName.sml index c3dcd236e..3d181caf0 100644 --- a/src/Compiler/Backend/PrimName.sml +++ b/src/Compiler/Backend/PrimName.sml @@ -6,6 +6,7 @@ datatype prim = Equal_word31 | Equal_word32ub | Equal_word32b | Equal_int63 | Equal_int64ub | Equal_int64b | Equal_word63 | Equal_word64ub | Equal_word64b | + Equal_ptr | Less_int31 | Less_int32ub | Less_int32b | Less_word31 | Less_word32ub | Less_word32b | @@ -173,6 +174,7 @@ local ("__equal_word31", Equal_word31), ("__equal_word32ub", Equal_word32ub), ("__equal_word32b", Equal_word32b), ("__equal_int63", Equal_int63), ("__equal_int64ub", Equal_int64ub), ("__equal_int64b", Equal_int64b), ("__equal_word63", Equal_word63), ("__equal_word64ub", Equal_word64ub), ("__equal_word64b", Equal_word64b), + ("__equal_ptr", Equal_ptr), ("__less_int31", Less_int31), ("__less_int32ub", Less_int32ub), ("__less_int32b", Less_int32b), ("__less_word31", Less_word31), ("__less_word32ub", Less_word32ub), ("__less_word32b", Less_word32b), @@ -379,6 +381,7 @@ fun is_flow_prim (p:prim) : bool = | Equal_word63 => true | Equal_word64ub => true | Equal_word64b => true + | Equal_ptr => true | Less_int31 => true | Less_int32ub => true @@ -452,6 +455,7 @@ fun pp_prim (p:prim) : string = | Equal_word63 => "Equal_word63" | Equal_word64ub => "Equal_word64ub" | Equal_word64b => "Equal_word64b" + | Equal_ptr => "Equal_ptr" | Less_int31 => "Less_int31" | Less_int32ub => "Less_int32ub" diff --git a/src/Compiler/Backend/RegAlloc.sml b/src/Compiler/Backend/RegAlloc.sml index 8549e9646..9327959ea 100644 --- a/src/Compiler/Backend/RegAlloc.sml +++ b/src/Compiler/Backend/RegAlloc.sml @@ -84,11 +84,11 @@ struct fun resolve_args ([],lss) = lss | resolve_args ((atom,phreg)::args,lss) = - resolve_args (args,LS.ASSIGN{pat=atom,bind=LS.ATOM(LS.PHREG phreg)}::lss) + resolve_args (args,LS.ASSIGN{pat=atom,bind=LS.ATOM {aty=LS.PHREG phreg}}::lss) fun resolve_res ([],lss) = lss | resolve_res ((atom,phreg)::res,lss) = - resolve_res (res,LS.ASSIGN{pat=LS.PHREG phreg,bind=LS.ATOM atom}::lss) + resolve_res (res,LS.ASSIGN{pat=LS.PHREG phreg,bind=LS.ATOM {aty=atom}}::lss) fun resolve_app {clos,args,reg_args,fargs,res} = CallConv.resolve_app @@ -211,7 +211,7 @@ struct case ls of LS.PRIM{name=p,args=[x,y],res=[d]} => (* treat "d := x op y" as "d := x; d := d op y" *) (if isBinF64 p then - (LS.ASSIGN{pat=d,bind=LS.ATOM x} :: + (LS.ASSIGN{pat=d,bind=LS.ATOM {aty=x}} :: LS.PRIM{name=p,args=[d,y],res=[d]} :: coalesce_binops lss) else ls :: coalesce_binops lss) @@ -1097,10 +1097,10 @@ struct | LS.SWITCH_E sw => ig_sw (ig_lss, sw, L) | LS.CCALL _ => do_non_tail_call(L,ls) | LS.CCALL_AUTO _ => do_non_tail_call(L,ls) - | LS.ASSIGN {pat=LS.VAR lv1, bind=LS.ATOM(LS.VAR lv2)} => do_move(L,lv1,lv2) - | LS.ASSIGN {pat=LS.VAR lv1, bind=LS.ATOM(LS.PHREG lv2)} => do_move(L,lv1,lv2) - | LS.ASSIGN {pat=LS.PHREG lv1, bind=LS.ATOM(LS.VAR lv2)} => do_move(L,lv1,lv2) - | LS.ASSIGN {pat=LS.PHREG lv1, bind=LS.ATOM(LS.PHREG lv2)} => do_move(L,lv1,lv2) + | LS.ASSIGN {pat=LS.VAR lv1, bind=LS.ATOM {aty=LS.VAR lv2}} => do_move(L,lv1,lv2) + | LS.ASSIGN {pat=LS.VAR lv1, bind=LS.ATOM {aty=LS.PHREG lv2}} => do_move(L,lv1,lv2) + | LS.ASSIGN {pat=LS.PHREG lv1, bind=LS.ATOM {aty=LS.VAR lv2}} => do_move(L,lv1,lv2) + | LS.ASSIGN {pat=LS.PHREG lv1, bind=LS.ATOM {aty=LS.PHREG lv2}} => do_move(L,lv1,lv2) (* Instead, we should unfold records in LineStmt. 18/02/1999, Niels *) | LS.ASSIGN {pat= _, bind=LS.RECORD _} => do_record(L,ls) | LS.ASSIGN {pat= _, bind=LS.SCLOS_RECORD _} => do_record(L,ls) diff --git a/src/Compiler/Backend/SubstAndSimplify.sml b/src/Compiler/Backend/SubstAndSimplify.sml index 7a4f4db2b..0cdebd527 100644 --- a/src/Compiler/Backend/SubstAndSimplify.sml +++ b/src/Compiler/Backend/SubstAndSimplify.sml @@ -155,7 +155,7 @@ struct | sma_to_sma(LS.SAT_FF(atom,pp),ATYmap,RHOmap) = LS.SAT_FF(atom_to_aty(atom,ATYmap,RHOmap),pp) | sma_to_sma(LS.IGNORE,ATYmap,RHOmap) = LS.IGNORE - fun aty_eq_se(aty1,LS.ATOM aty2) = eq_aty(aty1,aty2) + fun aty_eq_se(aty1,LS.ATOM {aty=aty2}) = eq_aty(aty1,aty2) | aty_eq_se _ = false fun SS_sw(SS_lss,switch_con,LS.SWITCH(atom,sels,default),ATYmap,RHOmap) = @@ -191,7 +191,7 @@ struct fargs=atoms_to_atys fargs, bv=bv} - fun SS_se(LS.ATOM atom) = LS.ATOM (atom_to_aty' atom) + fun SS_se(LS.ATOM {aty=atom}) = LS.ATOM {aty=atom_to_aty' atom} | SS_se(LS.LOAD label) = LS.LOAD label | SS_se(LS.STORE(atom,label)) = LS.STORE(atom_to_aty' atom,label) | SS_se(LS.STRING str) = LS.STRING str @@ -215,11 +215,11 @@ struct | SS_se(LS.CON0{con,con_kind,aux_regions,alloc}) = LS.CON0{con=con,con_kind=con_kind,aux_regions=smas_to_smas aux_regions,alloc=sma_to_sma' alloc} | SS_se(LS.CON1{con,con_kind,alloc,arg}) = LS.CON1{con=con,con_kind=con_kind,alloc=sma_to_sma' alloc,arg=atom_to_aty' arg} | SS_se(LS.DECON{con,con_kind,con_aty}) = LS.DECON{con=con,con_kind=con_kind,con_aty=atom_to_aty' con_aty} - | SS_se(LS.DEREF atom) = LS.DEREF(atom_to_aty' atom) + | SS_se(LS.DEREF {aty=atom}) = LS.DEREF {aty=atom_to_aty' atom} | SS_se(LS.REF(sma,atom)) = LS.REF(sma_to_sma' sma,atom_to_aty' atom) | SS_se(LS.ASSIGNREF(sma,atom1,atom2)) = LS.ASSIGNREF(sma_to_sma' sma,atom_to_aty' atom1,atom_to_aty' atom2) | SS_se(LS.PASS_PTR_TO_MEM(sma,i,b)) = LS.PASS_PTR_TO_MEM(sma_to_sma' sma,i,b) - | SS_se(LS.PASS_PTR_TO_RHO(sma)) = LS.PASS_PTR_TO_RHO(sma_to_sma' sma) + | SS_se(LS.PASS_PTR_TO_RHO {sma}) = LS.PASS_PTR_TO_RHO {sma=sma_to_sma' sma} fun SS_lss'([]) = [] | SS_lss'(LS.ASSIGN{pat,bind}::lss) = diff --git a/src/Compiler/Backend/X64/CodeGenX64.sml b/src/Compiler/Backend/X64/CodeGenX64.sml index fdf7d5075..e475c1497 100644 --- a/src/Compiler/Backend/X64/CodeGenX64.sml +++ b/src/Compiler/Backend/X64/CodeGenX64.sml @@ -82,7 +82,7 @@ struct | LS.ASSIGN{pat,bind} => comment_fn (fn () => "ASSIGN: " ^ pr_ls ls, (case bind - of LS.ATOM src_aty => move_aty_to_aty(src_aty,pat,size_ff,C) + of LS.ATOM {aty=src_aty} => move_aty_to_aty(src_aty,pat,size_ff,C) | LS.LOAD label => load_from_label(DatLab label,pat,tmp_reg1,size_ff,C) | LS.STORE(src_aty,label) => (gen_data_lab label; @@ -410,7 +410,7 @@ struct *) | LS.BOXED _ => move_index_aty_to_aty(con_aty,pat,WORDS 1,tmp_reg1,size_ff,C) | _ => die "CG_ls: DECON used with con_kind ENUM") - | LS.DEREF aty => + | LS.DEREF {aty} => let val offset = if BI.tag_values() then 1 else 0 in move_index_aty_to_aty(aty,pat,WORDS offset,tmp_reg1,size_ff,C) end @@ -463,7 +463,7 @@ struct else alloc_ap_kill_tmp01(alloc,reg_for_result,i,size_ff,C') end - | LS.PASS_PTR_TO_RHO(alloc) => + | LS.PASS_PTR_TO_RHO {sma=alloc} => let val (reg_for_result,C') = resolve_aty_def(pat,tmp_reg1,size_ff,C) in @@ -916,6 +916,7 @@ struct | Equal_word63 => cmp_quad I.je | Equal_word64ub => cmp_quad I.je | Equal_word64b => cmp_boxed_quad I.je + | Equal_ptr => cmp_quad I.je | Less_int32ub => cmp I.jl | Less_int32b => cmp_boxed I.jl @@ -1106,6 +1107,7 @@ struct | Equal_word63 => cmpi_kill_tmp01_cmov {box=false, quad=true} I.cmoveq arg | Equal_word64ub => cmpi_kill_tmp01_cmov {box=false, quad=true} I.cmoveq arg | Equal_word64b => cmpi_kill_tmp01_cmov {box=true, quad=true} I.cmoveq arg + | Equal_ptr => cmpi_kill_tmp01_cmov {box=false, quad=true} I.cmoveq arg | Plus_int32ub => add_num_kill_tmp01 {ovf=true, tag=false, quad=false} arg | Plus_int31 => add_num_kill_tmp01 {ovf=true, tag=true, quad=false} arg diff --git a/src/Compiler/Lambda/CompileDec.sml b/src/Compiler/Lambda/CompileDec.sml index cf7daf0b5..4f74f3515 100644 --- a/src/Compiler/Lambda/CompileDec.sml +++ b/src/Compiler/Lambda/CompileDec.sml @@ -228,21 +228,26 @@ structure CompileDec: COMPILE_DEC = List.foldl (fn ((_,NONE), (n,u)) => (n+1,u) | ((_,SOME _), (n,u)) => (n,u+1)) (0,0) cs + fun get_unaries cs = + List.foldl (fn ((_,NONE), acc) => acc + | ((_,SOME ty), acc) => ty::acc) nil cs + + fun optimistic tns (_,tn,cs) : TyName * TyName.boxity = - case cs of - [(_,SOME ty)] => - let fun G tn = - if List.exists (fn tn' => TyName.eq(tn,tn')) tns - then SOME TyName.UNB_ALL - else NONE - in (tn, TyName.SINGLE (boxity_ty G ty)) - end - | _ => - let val (n,u) = nullaries_unaries cs - in if u = 0 then (tn, TyName.ENUM) - else if u = 1 then (tn, TyName.UNB_LOW) - else (tn, TyName.UNB_ALL) - end + let fun G tn = if List.exists (fn tn' => TyName.eq(tn,tn')) tns + then SOME TyName.UNB_ALL + else NONE + in case cs of + [(_,SOME ty)] => (tn, TyName.SINGLE (boxity_ty G ty)) (* zero nullaries *) + | _ => case get_unaries cs of + nil => (tn, TyName.ENUM) + | [ty] => + (case boxity_ty G ty of + TyName.UNB_LOW => (tn, TyName.UNB_ALL) + | TyName.ENUM => (tn, TyName.UNB_ALL) + | _ => (tn, TyName.UNB_LOW)) + | _ => (tn, TyName.UNB_ALL) + end fun space_for_high_tags G argty : bool = high_pointer_tagging_p() andalso @@ -269,7 +274,7 @@ structure CompileDec: COMPILE_DEC = SOME TyName.UNB_LOW => u = 1 andalso boxity_ty G ty = TyName.BOXED | SOME TyName.UNB_ALL => - u <= 128 andalso space_for_high_tags G ty + u <= 1024 andalso space_for_high_tags G ty | _ => false (* tn cannot be represented unboxed in any way... *) ) cs end @@ -421,7 +426,7 @@ structure CompileDec: COMPILE_DEC = NONE => (case Type.to_TyVar typ of NONE => die "compileType(1)" - | SOME tyvar => TYVARtype(TV.lookup "compileType" tyvar)) + | SOME tyvar => TYVARtype {tv=TV.lookup "compileType" tyvar}) | SOME funtype => let val (ty1,rvi0,ty2,rvi) = NoSome "compileType(2)" @@ -477,7 +482,7 @@ structure CompileDec: COMPILE_DEC = fun on_Type S tau = LambdaBasics.on_Type S tau - fun unTyVarType (TYVARtype tv) = tv + fun unTyVarType (TYVARtype {tv}) = tv | unTyVarType _ = die "unTyVarType" fun mk_subst a = LambdaBasics.mk_subst a @@ -705,18 +710,29 @@ Report: Opt: end) *) - abstype span = Infinite | Finite of int - with - val span_from_int = Finite - val span_infinite = Infinite - val span_256 = Finite 256 - val span_1 = Finite 1 - fun span_eq Infinite Infinite = true - | span_eq (Finite i1) (Finite i2) = i1 = i2 - | span_eq _ _ = false - fun span_eq_int Infinite i = false - | span_eq_int (Finite i1) i2 = i1 = i2 - end (*abstype*) + local + structure Span :> sig type span + val span_from_int : int -> span + val span_infinite : span + val span_256 : span + val span_1 : span + val span_eq : span -> span -> bool + val span_eq_int : span -> int -> bool + end = + struct + type span = int + fun span_from_int i = + if i < 0 then die "span_from_int" + else i + val span_infinite = ~1 + val span_256 = 256 + val span_1 = 1 + fun span_eq a b = a = b + fun span_eq_int a b = a = b + end + + in open Span + end datatype con = Con of {longid : longid, span : span, @@ -1316,7 +1332,7 @@ Det finder du nok aldrig ud af.*) (VAR{lvar=lv,instances,regvars},tau) => let fun member tv = List.exists (fn tv' => tv = tv') tyvars - fun f (t as TYVARtype tv) = + fun f (t as TYVARtype {tv}) = if member tv then t else intDefaultType() (* see compilation of test/pat.sml *) | f t = t @@ -2893,7 +2909,7 @@ the 12 lines above are very similar to the code below val tyvars_fresh = map (fn tyvar => LambdaExp.fresh_tyvar ()) tyvars val subst = mk_subst (fn () => "CompileDec.compile_application_of_c_function") - (tyvars, map TLE.TYVARtype tyvars_fresh) + (tyvars, map (fn tv => TLE.TYVARtype {tv=tv}) tyvars_fresh) (* Names for certain primitives are altered on the basis of * whether tagging of integers is enabled; see the comment @@ -2903,7 +2919,7 @@ the 12 lines above are very similar to the code below TLE.PRIM (CCALLprim {name = name, tyvars = tyvars_fresh, Type = on_Type subst tau, - instances = map TLE.TYVARtype tyvars}, + instances = map (fn tv => TLE.TYVARtype {tv=tv}) tyvars}, map (compileExp env) args) end | _ => die "compile_application_of_prim: wrong type info in ccall") @@ -3301,7 +3317,7 @@ the 12 lines above are very similar to the code below let val lvar_switch = new_lvar_from_pat pat val (tyvars', tau') = compileTypeScheme (tyvars, Type) handle ? => (print ("compile_binding.NONE: lvar = " ^ Lvars.pr_lvar lvar_switch ^ "\n"); raise ?) - val obj = VAR {lvar=lvar_switch, instances=map TYVARtype tyvars', regvars=[]} + val obj = VAR {lvar=lvar_switch, instances=map (fn tv => TYVARtype {tv=tv}) tyvars', regvars=[]} fun compile_no (i, env_rhs) = scope val raise_something = fn obj : LambdaExp => RAISE (PRIM (EXCONprim Excon.ex_BIND, []), LambdaExp.RaisedExnBind) @@ -3578,7 +3594,7 @@ the 12 lines above are very similar to the code below (* env1 \ env *) val lvars_decl = minus(lvars_env1_sorted, lvars_env_sorted) val alpha = fresh_tyvar() - in map (fn lv => {lvar=lv,tyvars = [alpha],Type=TYVARtype alpha}) (* forall alpha. alpha *) + in map (fn lv => {lvar=lv,tyvars = [alpha],Type=TYVARtype {tv=alpha}}) (* forall alpha. alpha *) lvars_decl end diff --git a/src/Compiler/Lambda/CompilerEnv.sml b/src/Compiler/Lambda/CompilerEnv.sml index 0127fac42..718e3f26a 100644 --- a/src/Compiler/Lambda/CompilerEnv.sml +++ b/src/Compiler/Lambda/CompilerEnv.sml @@ -94,26 +94,26 @@ structure CompilerEnv: COMPILER_ENV = val boolType = LambdaExp.boolType val exnType = LambdaExp.exnType val tyvar_nil = LambdaExp.fresh_eqtyvar() - val nilType = LambdaExp.CONStype([LambdaExp.TYVARtype tyvar_nil], TyName.tyName_LIST, NONE) + val nilType = LambdaExp.CONStype([LambdaExp.TYVARtype {tv=tyvar_nil}], TyName.tyName_LIST, NONE) val tyvar_cons = LambdaExp.fresh_eqtyvar() val consType = let open LambdaExp - val t = CONStype([TYVARtype tyvar_cons], TyName.tyName_LIST, NONE) - in ARROWtype([RECORDtype ([TYVARtype tyvar_cons, t],NONE)],NONE,[t],NONE) + val t = CONStype([TYVARtype {tv=tyvar_cons}], TyName.tyName_LIST, NONE) + in ARROWtype([RECORDtype ([TYVARtype {tv=tyvar_cons}, t],NONE)],NONE,[t],NONE) end val tyvar_quote = LambdaExp.fresh_eqtyvar() val quoteType = let open LambdaExp - val t = CONStype([TYVARtype tyvar_quote], TyName.tyName_FRAG, NONE) + val t = CONStype([TYVARtype {tv=tyvar_quote}], TyName.tyName_FRAG, NONE) in ARROWtype([CONStype([],TyName.tyName_STRING,NONE)],NONE,[t],NONE) end val tyvar_antiquote = LambdaExp.fresh_eqtyvar() val antiquoteType = let open LambdaExp - val t = CONStype([TYVARtype tyvar_antiquote], TyName.tyName_FRAG, NONE) - in ARROWtype([TYVARtype tyvar_antiquote],NONE,[t],NONE) + val t = CONStype([TYVARtype {tv=tyvar_antiquote}], TyName.tyName_FRAG, NONE) + in ARROWtype([TYVARtype {tv=tyvar_antiquote}],NONE,[t],NONE) end val intinfType = @@ -132,15 +132,15 @@ structure CompilerEnv: COMPILER_ENV = val listVE = initVE [(Ident.id_NIL, CON(Con.con_NIL,[tyvar_nil],nilType, - [LambdaExp.TYVARtype tyvar_nil])), + [LambdaExp.TYVARtype {tv=tyvar_nil}])), (Ident.id_CONS, CON(Con.con_CONS,[tyvar_cons],consType, - [LambdaExp.TYVARtype tyvar_cons]))] + [LambdaExp.TYVARtype {tv=tyvar_cons}]))] val fragVE = initVE [(Ident.id_QUOTE, CON(Con.con_QUOTE,[tyvar_quote],quoteType, - [LambdaExp.TYVARtype tyvar_quote])), + [LambdaExp.TYVARtype {tv=tyvar_quote}])), (Ident.id_ANTIQUOTE, CON(Con.con_ANTIQUOTE,[tyvar_antiquote],antiquoteType, - [LambdaExp.TYVARtype tyvar_antiquote]))] + [LambdaExp.TYVARtype {tv=tyvar_antiquote}]))] val initialVarEnv : VarEnv = Ident.Map.plus(Ident.Map.plus(Ident.Map.plus(boolVE,listVE),fragVE), @@ -160,18 +160,6 @@ structure CompilerEnv: COMPILER_ENV = (Ident.resetRegions, RESET_REGIONS), (Ident.forceResetting, FORCE_RESET_REGIONS), (Ident.id_REF, REF), -(* - (Ident.id_TRUE, CON(Con.con_TRUE,[],boolType,[])), - (Ident.id_FALSE, CON(Con.con_FALSE,[],boolType,[])), - (Ident.id_NIL, CON(Con.con_NIL,[tyvar_nil],nilType, - [LambdaExp.TYVARtype tyvar_nil])), - (Ident.id_CONS, CON(Con.con_CONS,[tyvar_cons],consType, - [LambdaExp.TYVARtype tyvar_cons])), - (Ident.id_QUOTE, CON(Con.con_QUOTE,[tyvar_quote],quoteType, - [LambdaExp.TYVARtype tyvar_quote])), - (Ident.id_ANTIQUOTE, CON(Con.con_ANTIQUOTE,[tyvar_antiquote],antiquoteType, - [LambdaExp.TYVARtype tyvar_antiquote])), -*) (Ident.id_INTINF, CON(Con.con_INTINF,[],intinfType, [])), (Ident.id_Div, EXCON(Excon.ex_DIV, exnType)), (Ident.id_Match, EXCON(Excon.ex_MATCH, exnType)), @@ -233,14 +221,14 @@ structure CompilerEnv: COMPILER_ENV = CENV{StrEnv=StrEnv,VarEnv=VarEnv,TyEnv=TyEnv,PathEnv=emptyPathEnv} fun declareVar (id, (lv, tyvars, tau), CENV{StrEnv,VarEnv=m,TyEnv,PathEnv}) = - let val il0 = map LambdaExp.TYVARtype tyvars + let val il0 = map (fn tv => LambdaExp.TYVARtype {tv=tv}) tyvars in CENV{StrEnv=StrEnv, TyEnv=TyEnv, VarEnv=Ident.Map.add(id, LVAR (lv,tyvars,tau,il0), m), PathEnv=PathEnv} end fun declareCon (id, (con,tyvars,tau), CENV{StrEnv,VarEnv=m,TyEnv,PathEnv}) = - let val il0 = map LambdaExp.TYVARtype tyvars + let val il0 = map (fn tv => LambdaExp.TYVARtype {tv=tv}) tyvars in CENV{StrEnv=StrEnv, TyEnv=TyEnv, VarEnv=Ident.Map.add(id,CON (con,tyvars,tau,il0), m), PathEnv=PathEnv} diff --git a/src/Compiler/Lambda/EliminateEq.sml b/src/Compiler/Lambda/EliminateEq.sml index a7462a8d7..fe895a36c 100644 --- a/src/Compiler/Lambda/EliminateEq.sml +++ b/src/Compiler/Lambda/EliminateEq.sml @@ -85,24 +85,24 @@ structure EliminateEq : ELIMINATE_EQ = | eq_tnres (_,MONOLVAR _) = die "eq_tnres.MONOLVAR" | eq_tnres _ = false - fun eq_lvres(tvs1,tvs2) = (map equality_tyvar tvs1 = map equality_tyvar tvs2) + fun eq_lvres (tvs1,tvs2) = (map equality_tyvar tvs1 = map equality_tyvar tvs2) - fun enrich_tnmap(tnmap1,tnmap2) = + fun enrich_tnmap (tnmap1,tnmap2) = TyNameMap.Fold (fn ((tn2, res2), b) => b andalso case TyNameMap.lookup tnmap1 tn2 of SOME res1 => eq_tnres(res1,res2) | NONE => false) true tnmap2 - fun enrich_lvmap(lvmap1,lvmap2) = + fun enrich_lvmap (lvmap1,lvmap2) = LvarMap.Fold (fn ((lv2, res2), b) => b andalso case LvarMap.lookup lvmap1 lv2 of SOME res1 => eq_lvres(res1,res2) | NONE => false) true lvmap2 - fun enrich((tnmap1,_,lvmap1),(tnmap2,_,lvmap2)) = + fun enrich ((tnmap1,_,lvmap1),(tnmap2,_,lvmap2)) = enrich_tnmap(tnmap1,tnmap2) andalso enrich_lvmap(lvmap1,lvmap2) - fun match_tnmap(tnmap,tnmap0) = + fun match_tnmap (tnmap,tnmap0) = let val tnmap = TyNameMap.fromList (TyNameMap.list tnmap) in TyNameMap.Fold (fn ((tn, POLYLVAR lv),()) => (case TyNameMap.lookup tnmap0 tn @@ -112,7 +112,7 @@ structure EliminateEq : ELIMINATE_EQ = tnmap end - fun match((tnmap,tvmap,lvmap),(tnmap0,_,tlvmap0)) = + fun match ((tnmap,tvmap,lvmap),(tnmap0,_,tlvmap0)) = (match_tnmap(tnmap,tnmap0), tvmap, lvmap) @@ -158,7 +158,7 @@ structure EliminateEq : ELIMINATE_EQ = val env_map : (result->result) -> env -> env = env_map (* only used at top-level *) val enrich : env * env -> bool = enrich val match : env * env -> env = match - fun restrict(e: env, {lvars:lvar list,tynames:TyName list}): lvar list * env = + fun restrict (e: env, {lvars:lvar list,tynames:TyName list}): lvar list * env = restrict'(e,{lvars=lvars,tynames=tynames}) handle x => (say "ElimiateEq.restrict failed\n"; @@ -175,7 +175,7 @@ structure EliminateEq : ELIMINATE_EQ = * Some usefull stuff * ------------------------------------------------------------ *) - fun mk_eq_tau tv = let val tau = TYVARtype tv + fun mk_eq_tau tv = let val tau = TYVARtype {tv=tv} in ARROWtype([RECORDtype ([tau,tau],NONE)],NONE,[boolType],NONE) end fun mk_eq_abs [] [] e = e @@ -206,7 +206,25 @@ structure EliminateEq : ELIMINATE_EQ = TyName.tyName_FOREIGNPTR, TyName.tyName_CHARARRAY] (*not tyName_REAL*) + fun ORELSE (e1:LambdaExp) (e2:LambdaExp) : LambdaExp = + SWITCH_C (SWITCH (e1, [((Con.con_TRUE,NONE),lamb_true)], SOME e2)) + fun ptr_eq instance_ty e1 e2 = + let val tv = fresh_tyvar() + val argty = TYVARtype {tv=tv} + val ty = ARROWtype([argty,argty],NONE,[boolType],NONE) + in PRIM(CCALLprim {name="__equal_ptr",instances=[instance_ty], + tyvars=[tv], Type=ty}, + [e1,e2]) + end + + fun allTyNamesType (p:TyName -> bool) (ty:Type) = + case ty of + TYVARtype _ => true + | ARROWtype (ts,_,ts',_) => List.all (allTyNamesType p) ts + andalso List.all (allTyNamesType p) ts' + | CONStype (ts,tn,_) => p tn andalso List.all (allTyNamesType p) ts + | RECORDtype (ts,_) => List.all (allTyNamesType p) ts (* --------------------------------------------------------------- * Generate a lambda expression for checking equality of a pair @@ -228,10 +246,10 @@ structure EliminateEq : ELIMINATE_EQ = let fun gen tau = (case tau - of (TYVARtype tv) => (case lookup_tyvar env tv - of SOME lv => VAR {lvar=lv, instances=[], regvars=[]} - | NONE => FN {pat=[(Lvars.newLvar(),RECORDtype ([TYVARtype tv, TYVARtype tv],NONE))], - body=lamb_false}) (* the function will never be applied. *) + of (TYVARtype {tv}) => (case lookup_tyvar env tv + of SOME lv => VAR {lvar=lv, instances=[], regvars=[]} + | NONE => FN {pat=[(Lvars.newLvar(),RECORDtype ([TYVARtype {tv=tv}, TYVARtype {tv=tv}],NONE))], + body=lamb_false}) (* the function will never be applied. *) (* -------------- * old; check out testprogs/eq_1.sml * if equality_tyvar tv then @@ -242,15 +260,15 @@ structure EliminateEq : ELIMINATE_EQ = | (CONStype (taus,tn,_)) => let fun apply e [] = e | apply e (tau::taus) = apply (APP(e, gen tau, NONE)) taus - fun dont_support() = - raise DONT_SUPPORT_EQ (TyName.pr_TyName tn) + fun dont_support () = + raise DONT_SUPPORT_EQ (TyName.pr_TyName tn) in if is_eq_prim_tn tn then mk_prim_eq tau else case lookup_tyname env tn of SOME (POLYLVAR lv) => apply (VAR {lvar=lv, instances=taus,regvars=[]}) taus | SOME (MONOLVAR (lv, tyvars)) => - if map (fn TYVARtype tv => tv + if map (fn TYVARtype {tv} => tv | _ => dont_support()) taus = tyvars then apply (lamb_var lv) taus else dont_support() @@ -306,14 +324,14 @@ structure EliminateEq : ELIMINATE_EQ = (* Generate a fix abstraction for a single datatype binding *) - fun gen_db env (tyvars,tn,cbs) = (* may raise DONT_SUPPORT_EQ *) + fun gen_db (nonrecursive:bool) env (tyvars,tn,cbs) = (* may raise DONT_SUPPORT_EQ *) let fun mk_tau tau = let val tau_arg = RECORDtype ([tau, tau],NONE) in ARROWtype([tau_arg],NONE,[boolType],NONE) end - val tau_tn = CONStype (map TYVARtype tyvars, tn, NONE) + val tau_tn = CONStype (map (fn tv => TYVARtype {tv=tv}) tyvars, tn, NONE) fun gen_tau [] = mk_tau tau_tn - | gen_tau (tv :: tvs) = ARROWtype([mk_tau (TYVARtype tv)], NONE, [gen_tau tvs], NONE) + | gen_tau (tv :: tvs) = ARROWtype([mk_tau (TYVARtype {tv=tv})], NONE, [gen_tau tvs], NONE) val (p,p0,p1) = (Lvars.newLvar(), Lvars.newLvar(), Lvars.newLvar()) val lvs = map (fn _ => Lvars.newLvar()) tyvars @@ -326,7 +344,7 @@ structure EliminateEq : ELIMINATE_EQ = end fun mk_abs_eq_fns [] [] e = FN {pat = [(p, RECORDtype ([tau_tn,tau_tn],NONE))], body=e} - | mk_abs_eq_fns (tv::tvs) (lv::lvs) e = FN {pat = [(lv, mk_tau (TYVARtype tv))], + | mk_abs_eq_fns (tv::tvs) (lv::lvs) e = FN {pat = [(lv, mk_tau (TYVARtype {tv=tv}))], body = mk_abs_eq_fns tvs lvs e} | mk_abs_eq_fns _ _ _ = die "mk_abs_eq_fns" @@ -343,7 +361,7 @@ structure EliminateEq : ELIMINATE_EQ = val p1' = Lvars.newLvar() fun mk_decon p' p e = monolet {lvar=p', Type=tau, - bind=PRIM(DECONprim {con=c, instances=map TYVARtype tyvars,lv_opt=SOME p'}, [lamb_var p]), + bind=PRIM(DECONprim {con=c, instances=map (fn tv => TYVARtype {tv=tv}) tyvars,lv_opt=SOME p'}, [lamb_var p]), scope=e} val lamb_eq_fn_tau = gen_type_eq env' tau val lamb_true_case = @@ -376,10 +394,19 @@ structure EliminateEq : ELIMINATE_EQ = val single = case cbs of [_] => true | _ => false + + val eq_body = + let fun varExp lv = VAR{lvar=lv,instances=nil,regvars=nil} + val body = big_sw cbs single + in if single orelse nonrecursive then body + else ORELSE (ptr_eq tau_tn (varExp p0) (varExp p1)) + body + end + val bind = mk_abs_eq_fns tyvars lvs (mk_pn p0 0 - (mk_pn p1 1 (big_sw cbs single))) + (mk_pn p1 1 eq_body)) in {lvar=lvar, regvars=[], tyvars=tyvars, Type=gen_tau tyvars, constrs=[], bind=bind} end @@ -405,9 +432,21 @@ structure EliminateEq : ELIMINATE_EQ = val env = mono_env dbs empty val env' = plus (env0, env) (* the environment in which to generate functions *) + (* Values of potentially recursive data types are checked also for pointer equality *) + val nonrecursive = + let val tns = List.map #2 dbs + fun not_in_tns tn = + List.all (fn tn' => not(TyName.eq(tn,tn'))) tns + in List.all (fn (_,_,cbs) => + List.all (fn (_,NONE) => true + | (_,SOME ty) => allTyNamesType not_in_tns ty) + cbs) + dbs + end + fun gen_dbs [] = [] | gen_dbs ((db as (_,tn,_)) :: dbs) = - if TyName.equality tn then let val function = gen_db env' db + if TyName.equality tn then let val function = gen_db nonrecursive env' db in function :: gen_dbs dbs end else gen_dbs dbs @@ -477,7 +516,7 @@ structure EliminateEq : ELIMINATE_EQ = and gen_datatype_for_list () = let val tn_list = TyName.tyName_LIST val tv = fresh_tyvar() - val tau_tv = TYVARtype tv + val tau_tv = TYVARtype {tv=tv} val cbs = [(Con.con_CONS, SOME (RECORDtype ([tau_tv, CONStype([tau_tv],tn_list,NONE)],NONE))), (Con.con_NIL, NONE)] val dbss = [[([tv], tn_list,cbs)]] @@ -495,7 +534,7 @@ structure EliminateEq : ELIMINATE_EQ = if quotation() then let val tv = fresh_tyvar() - val tau_tv = TYVARtype tv + val tau_tv = TYVARtype {tv=tv} val cbs = [(Con.con_QUOTE, SOME (CONStype([], TyName.tyName_STRING, NONE))), (Con.con_ANTIQUOTE, SOME tau_tv)] val dbss = [[([tv], TyName.tyName_FRAG, cbs)]] @@ -539,7 +578,7 @@ structure EliminateEq : ELIMINATE_EQ = val tyname = TyName.tyName_VECTOR val s = TyName.pr_TyName tyname val alpha = fresh_tyvar {} - val tau_alpha = TYVARtype alpha + val tau_alpha = TYVARtype {tv=alpha} val tau_tyname = CONStype ([tau_alpha], tyname, NONE) val lvar_eq_table = Lvars.new_named_lvar ("eq_" ^ s) val lvar_eq_alpha = Lvars.new_named_lvar "eq_'a" @@ -566,8 +605,8 @@ structure EliminateEq : ELIMINATE_EQ = in monolet {lvar = lvar_nX, Type = intDefaultType(), bind = PRIM (CCALLprim {name = "table_size", (*alpha' is instantiated to alpha (from above):*) - tyvars = [alpha'], instances = [TYVARtype alpha], - Type = ARROWtype ([CONStype ([TYVARtype alpha'], tyname, NONE)], + tyvars = [alpha'], instances = [TYVARtype {tv=alpha}], + Type = ARROWtype ([CONStype ([TYVARtype {tv=alpha'}], tyname, NONE)], NONE, [intDefaultType()], NONE)}, @@ -577,10 +616,10 @@ structure EliminateEq : ELIMINATE_EQ = fun sub var_tableX = let val alpha' = fresh_tyvar {} - val tau_alpha' = TYVARtype alpha' + val tau_alpha' = TYVARtype {tv=alpha'} in PRIM (CCALLprim {name = "word_sub0", (*alpha' is instantiated to alpha (from above):*) - tyvars = [alpha'], instances = [TYVARtype alpha], + tyvars = [alpha'], instances = [TYVARtype {tv=alpha}], Type = ARROWtype ([CONStype ([tau_alpha'], tyname, NONE), intDefaultType()], NONE, [tau_alpha'], @@ -633,22 +672,36 @@ structure EliminateEq : ELIMINATE_EQ = bind = bind_loop()} fun bind_eq_table () = - FN {pat = [(lvar_eq_alpha, tau_for_eq_fun tau_alpha)], body = - FN {pat = [(lvar_table_pair, RECORDtype ([tau_tyname, tau_tyname],NONE))], body = - monolet {lvar = lvar_table1, Type = tau_tyname, bind = - PRIM (SELECTprim {index=0}, [var_table_pair]), scope = - monolet {lvar = lvar_table2, Type = tau_tyname, bind = - PRIM (SELECTprim {index=1}, [var_table_pair]), scope = - let_nX_equal_table_size_in_bytes lvar_n1 var_table1 - (let_nX_equal_table_size_in_bytes lvar_n2 var_table2 - (FIX {functions = [function_loop()], scope = - SWITCH_C (SWITCH - (PRIM (EQUALprim {instance = RECORDtype ([intDefaultType(), - intDefaultType()],NONE)}, - [var_n1, var_n2]), - [((Con.con_TRUE,NONE), - APP (var_loop, PRIM (MINUS_INTprim(), [var_n2, INTEGER' 1]),NONE))], - SOME lamb_false))}))}}}} + FN{pat=[(lvar_eq_alpha, tau_for_eq_fun tau_alpha)], + body=FN{pat = [(lvar_table_pair, RECORDtype ([tau_tyname, tau_tyname],NONE))], + body = + monolet {lvar = lvar_table1, Type = tau_tyname, + bind = PRIM (SELECTprim {index=0}, [var_table_pair]), + scope = + monolet {lvar = lvar_table2, Type = tau_tyname, + bind = PRIM (SELECTprim {index=1}, [var_table_pair]), + scope = + ORELSE (ptr_eq tau_tyname var_table1 var_table2) + (let_nX_equal_table_size_in_bytes lvar_n1 var_table1 + (let_nX_equal_table_size_in_bytes lvar_n2 var_table2 + (FIX {functions = [function_loop()], + scope = + SWITCH_C (SWITCH (PRIM (EQUALprim {instance = RECORDtype ([intDefaultType(), + intDefaultType()],NONE)}, + [var_n1, var_n2]), + [((Con.con_TRUE,NONE), + APP (var_loop, PRIM (MINUS_INTprim(), [var_n2, INTEGER' 1]),NONE))], + SOME lamb_false + ) + ) + } + ) + ) + ) + } + } + } + } fun function_eq_table () = {lvar = lvar_eq_table, regvars = [], @@ -715,7 +768,7 @@ structure EliminateEq : ELIMINATE_EQ = | FRAME {declared_lvars,declared_excons} => (* frame is in global scope *) let val new_declared_lvars = map (fn lv => let val tv = fresh_tyvar() - in {lvar=lv,tyvars=[tv],Type=TYVARtype tv} (* dummy type scheme *) + in {lvar=lv,tyvars=[tv],Type=TYVARtype {tv=tv}} (* dummy type scheme *) end) lvars in FRAME {declared_lvars = declared_lvars @ new_declared_lvars, declared_excons = declared_excons} @@ -766,7 +819,7 @@ structure EliminateEq : ELIMINATE_EQ = case lexp of VAR {lvar, instances=[], regvars=[]} => (* maybe a recursive call *) (case lookup_lvar env lvar - of SOME tyvars => apply_eq_fns env (map TYVARtype (eq_tyvars tyvars)) lexp + of SOME tyvars => apply_eq_fns env (map (fn tv => TYVARtype {tv=tv}) (eq_tyvars tyvars)) lexp | NONE => lexp) | VAR {lvar, instances, ...} => (* not a recursive call *) (case lookup_lvar env lvar diff --git a/src/Compiler/Lambda/LAMBDA_EXP.sml b/src/Compiler/Lambda/LAMBDA_EXP.sml index 2a20cf532..3baa1dcf6 100644 --- a/src/Compiler/Lambda/LAMBDA_EXP.sml +++ b/src/Compiler/Lambda/LAMBDA_EXP.sml @@ -52,7 +52,7 @@ signature LAMBDA_EXP = val reset : unit -> unit datatype Type = - TYVARtype of tyvar + TYVARtype of {tv:tyvar} | ARROWtype of Type list * regvar option * Type list * regvar option | CONStype of Type list * TyName * regvar list option | RECORDtype of Type list * regvar option diff --git a/src/Compiler/Lambda/LambdaBasics.sml b/src/Compiler/Lambda/LambdaBasics.sml index c2473d4d8..a97d21e73 100644 --- a/src/Compiler/Lambda/LambdaBasics.sml +++ b/src/Compiler/Lambda/LambdaBasics.sml @@ -337,7 +337,7 @@ structure LambdaBasics: LAMBDA_BASICS = | NONE => ex fun on_tau ren tau = - let fun on_t (TYVARtype tv) = TYVARtype (on_tv ren tv) + let fun on_t (TYVARtype {tv}) = TYVARtype {tv=on_tv ren tv} | on_t (ARROWtype (tl,rv0,tl',rv)) = ARROWtype(map on_t tl,rv0,map on_t tl',rv) | on_t (CONStype (tl,tn,rvs)) = CONStype (map on_t tl,tn,rvs) | on_t (RECORDtype (tl,rv)) = RECORDtype (map on_t tl,rv) @@ -522,9 +522,9 @@ structure LambdaBasics: LAMBDA_BASICS = let fun tv_Subst tau = (case tau - of TYVARtype tyvar => (case List.find (fn (tyvar':tyvar, tau') => tyvar = tyvar') S - of SOME res => #2 res - | NONE => tau) + of TYVARtype {tv=tyvar} => (case List.find (fn (tyvar':tyvar, tau') => tyvar = tyvar') S + of SOME res => #2 res + | NONE => tau) | ARROWtype(taus1,rv0,taus2,rv) => ARROWtype(map tv_Subst taus1,rv0,map tv_Subst taus2,rv) | CONStype(taus,tyname,rvs) => CONStype(map tv_Subst taus,tyname,rvs) | RECORDtype (taus,rv) => RECORDtype (map tv_Subst taus,rv) @@ -565,7 +565,7 @@ structure LambdaBasics: LAMBDA_BASICS = fun equal_tyvar x y = x = y fun tyvarsType tau : tyvar Set.Set = case tau - of TYVARtype tyvar => Set.singleton tyvar + of TYVARtype {tv=tyvar} => Set.singleton tyvar | ARROWtype(taus1,_,taus2,_) => Set.union equal_tyvar (tyvarsTypes taus1) (tyvarsTypes taus2) | CONStype(taus,_,_) => tyvarsTypes taus | RECORDtype (taus,_) => tyvarsTypes taus @@ -578,7 +578,7 @@ structure LambdaBasics: LAMBDA_BASICS = | on_LambdaExp S lamb = let fun tyvars_rangeS S : tyvar Set.Set = - let val domS = map (TYVARtype o #1) S + let val domS = map ((fn tv => TYVARtype {tv=tv}) o #1) S val rangeS = on_Types S (domS) in tyvarsTypes rangeS end @@ -687,7 +687,7 @@ structure LambdaBasics: LAMBDA_BASICS = (* Equality of types, but disregarding regvar information *) fun eq_Type (tau1, tau2) = case (tau1,tau2) - of (TYVARtype tv1, TYVARtype tv2) => tv1=tv2 + of (TYVARtype {tv=tv1}, TYVARtype {tv=tv2}) => tv1=tv2 | (ARROWtype(taus1,rv0,taus1',rv1), ARROWtype(taus2,rv0',taus2',rv2)) => eq_Types(taus1,taus2) andalso eq_Types(taus1',taus2') (*andalso eq_regvar_opt (rv1,rv2)*) | (CONStype(taus1,tn1,rvs1), CONStype(taus2,tn2,rvs2)) => @@ -701,7 +701,7 @@ structure LambdaBasics: LAMBDA_BASICS = fun eq_sigma_with_il (([],tau1,[]),([],tau2,[])) = eq_Type(tau1,tau2) | eq_sigma_with_il ((tvs1,tau1,il1),(tvs2,tau2,il2)) = if length tvs1 <> length tvs2 then false - else let val tv_taus = map (fn _ => TYVARtype(fresh_tyvar())) tvs1 + else let val tv_taus = map (fn _ => TYVARtype {tv=fresh_tyvar()}) tvs1 val S1 = mk_subst (fn () => "eq_sigma_with_il1") (tvs1,tv_taus) val S2 = mk_subst (fn () => "eq_sigma_with_il2") (tvs2,tv_taus) val tau1' = on_Type S1 tau1 @@ -723,7 +723,7 @@ structure LambdaBasics: LAMBDA_BASICS = fun match_tau (S, tau, tau') = case (tau, tau') - of (TYVARtype tv, _) => add(tv,tau',S) + of (TYVARtype {tv}, _) => add(tv,tau',S) | (ARROWtype(taus1,_,taus1',_), ARROWtype(taus2,_,taus2',_)) => let val S' = match_taus(S,taus1,taus2) in match_taus(S',taus1',taus2') @@ -744,7 +744,7 @@ structure LambdaBasics: LAMBDA_BASICS = val S = match_tau(TvMap.empty,tau,tau') val subst = map (fn tv => case TvMap.lookup S tv of SOME tau => (tv,tau) - | NONE => (tv,TYVARtype tv)) tvs + | NONE => (tv,TYVARtype {tv=tv})) tvs in subst end diff --git a/src/Compiler/Lambda/LambdaExp.sml b/src/Compiler/Lambda/LambdaExp.sml index b3c5ebc63..6b9dc5661 100644 --- a/src/Compiler/Lambda/LambdaExp.sml +++ b/src/Compiler/Lambda/LambdaExp.sml @@ -51,7 +51,7 @@ structure LambdaExp : LAMBDA_EXP = datatype Type = - TYVARtype of tyvar + TYVARtype of {tv:tyvar} | ARROWtype of Type list * regvar option * Type list * regvar option | CONStype of Type list * TyName * regvar list option | RECORDtype of Type list * regvar option @@ -93,7 +93,7 @@ structure LambdaExp : LAMBDA_EXP = val unitType = RECORDtype([],NONE) val tyvars = foldType (fn tvs => - (fn TYVARtype tv => + (fn TYVARtype {tv} => if List.exists (fn x => tv=x) tvs then tvs else tv::tvs | _ => tvs)) nil @@ -718,7 +718,7 @@ structure LambdaExp : LAMBDA_EXP = fun layoutType0 (config:config) tau = case tau of - TYVARtype tv => PP.LEAF (pr_tyvar tv) + TYVARtype {tv} => PP.LEAF (pr_tyvar tv) | ARROWtype(taus,rvopt0,taus',rvopt) => let val arrow = case rvopt0 of @@ -1423,7 +1423,7 @@ structure LambdaExp : LAMBDA_EXP = fun pp_ty (out:string->unit) (ty:Type) : unit = let fun pp (ARROWtype([ty1],[ty2])) = (pp ty1; out " -> "; pp ty2) - | pp (TYVARtype tv) = pp_tv out tv + | pp (TYVARtype {tv}) = pp_tv out tv | pp (CONStype(nil,tn)) = pp_tn out tn | pp (CONStype(tys,tn)) = (out "(" ; pp_tys out "," tys ; out ")" ; pp_tn out tn) | pp (RECORDtype tys) = (out "(" ; pp_tys out "*" tys ; out ")") @@ -1487,7 +1487,7 @@ structure LambdaExp : LAMBDA_EXP = Pickle.cache "list" Pickle.listGen fun fun_TYVARtype _ = - Pickle.con1 TYVARtype (fn TYVARtype tv => tv | _ => die "pu_Type.TYVARtype") + Pickle.con1 (fn tv => TYVARtype {tv=tv}) (fn TYVARtype {tv} => tv | _ => die "pu_Type.TYVARtype") pu_tyvar fun fun_ARROWtype pu = Pickle.con1 ARROWtype (fn ARROWtype p => p | _ => die "pu_Type.ARROWtype") @@ -1831,8 +1831,8 @@ structure LambdaExp : LAMBDA_EXP = fun tyvars_Type (s: TVS.Set) (t:Type) (acc: TVS.Set) : TVS.Set = case t of - TYVARtype tv => if TVS.member tv s then acc - else TVS.insert tv acc + TYVARtype {tv} => if TVS.member tv s then acc + else TVS.insert tv acc | ARROWtype(ts1,_,ts2,_) => tyvars_Types s ts1 (tyvars_Types s ts2 acc) | CONStype(ts,_,_) => tyvars_Types s ts acc | RECORDtype (ts,_) => tyvars_Types s ts acc diff --git a/src/Compiler/Lambda/LambdaStatSem.sml b/src/Compiler/Lambda/LambdaStatSem.sml index 491f54d15..ae037da5c 100644 --- a/src/Compiler/Lambda/LambdaStatSem.sml +++ b/src/Compiler/Lambda/LambdaStatSem.sml @@ -47,7 +47,7 @@ structure LambdaStatSem: LAMBDA_STAT_SEM = type TypeScheme = tyvar list * Type fun ftv_Type Type : NatSet.Set = - let fun f (TYVARtype tyvar, s) = NatSet.insert tyvar s + let fun f (TYVARtype {tv}, s) = NatSet.insert tv s | f (ARROWtype (tl1, _, tl2, _), s) = foldl f (foldl f s tl1) tl2 | f (CONStype (ts, _, _), s) = foldl f s ts | f (RECORDtype (ts,_), s) = foldl f s ts @@ -129,28 +129,28 @@ structure LambdaStatSem: LAMBDA_STAT_SEM = val typescheme_FALSE = close_Type (CONStype([], tyName_BOOL, NONE)) val typescheme_NIL = let val tyvar = fresh_tyvar() - in close_Type (CONStype([TYVARtype tyvar], tyName_LIST, NONE)) + in close_Type (CONStype([TYVARtype {tv=tyvar}], tyName_LIST, NONE)) end val typescheme_CONS = let val tyvar = fresh_tyvar() - in close_Type (ARROWtype([RECORDtype([TYVARtype tyvar, - CONStype([TYVARtype tyvar], tyName_LIST, NONE)],NONE)], + in close_Type (ARROWtype([RECORDtype([TYVARtype {tv=tyvar}, + CONStype([TYVARtype {tv=tyvar}], tyName_LIST, NONE)],NONE)], NONE, - [CONStype([TYVARtype tyvar], tyName_LIST, NONE)], + [CONStype([TYVARtype {tv=tyvar}], tyName_LIST, NONE)], NONE)) end val typescheme_QUOTE = let val tyvar = fresh_tyvar() in close_Type (ARROWtype([CONStype([],tyName_STRING, NONE)], NONE, - [CONStype([TYVARtype tyvar], tyName_FRAG, NONE)], + [CONStype([TYVARtype {tv=tyvar}], tyName_FRAG, NONE)], NONE)) end val typescheme_ANTIQUOTE = let val tyvar = fresh_tyvar() - in close_Type (ARROWtype([TYVARtype tyvar], + in close_Type (ARROWtype([TYVARtype {tv=tyvar}], NONE, - [CONStype([TYVARtype tyvar], tyName_FRAG, NONE)], + [CONStype([TYVARtype {tv=tyvar}], tyName_FRAG, NONE)], NONE)) end val typescheme_INTINF = @@ -423,8 +423,8 @@ structure LambdaStatSem: LAMBDA_STAT_SEM = case ty of CONStype(ts,tn,_) => (lookup_tyname e tn; valid_ts e ts) | ARROWtype(ts1,_,ts2,_) => (valid_ts e ts1; valid_ts e ts2) - | TYVARtype tv => if isin_tv e tv then () - else die ("valid_t.non-bound type variable " ^ pr_tyvar tv) + | TYVARtype {tv} => if isin_tv e tv then () + else die ("valid_t.non-bound type variable " ^ pr_tyvar tv) | RECORDtype (ts,_) => valid_ts e ts and valid_ts (e:env) nil = () | valid_ts (e:env) (t::ts) = (valid_t e t; valid_ts e ts) @@ -658,7 +658,7 @@ structure LambdaStatSem: LAMBDA_STAT_SEM = | REFprim {instance,regvar} => (* as CONprim *) let val typescheme_REF = let val tyvar = fresh_tyvar() - in close_Type (ARROWtype([TYVARtype tyvar], NONE, [CONStype([TYVARtype tyvar], tyName_REF, NONE)], NONE)) + in close_Type (ARROWtype([TYVARtype {tv=tyvar}], NONE, [CONStype([TYVARtype {tv=tyvar}], tyName_REF, NONE)], NONE)) end in valid_t env instance; check_t_no_f64 "REFprim" instance; @@ -979,7 +979,7 @@ structure LambdaStatSem: LAMBDA_STAT_SEM = fun analyse_datbinds (DATBINDS dbs) : env = let fun analyse_datbind (tyvars : tyvar list,tyname,conbind: (con * Type option) list) : env = - let val ty2 = CONStype (map TYVARtype tyvars, tyname,NONE) + let val ty2 = CONStype (map (fn tv => TYVARtype {tv=tv}) tyvars, tyname,NONE) fun gen_typescheme (SOME tau) = (tyvars, ARROWtype([tau],NONE,[ty2],NONE)) | gen_typescheme NONE = (tyvars, ty2) diff --git a/src/Compiler/Lambda/OptLambda.sml b/src/Compiler/Lambda/OptLambda.sml index 215ef3b9c..9b9aae5da 100644 --- a/src/Compiler/Lambda/OptLambda.sml +++ b/src/Compiler/Lambda/OptLambda.sml @@ -485,7 +485,7 @@ structure OptLambda : OPT_LAMBDA = length tvs = length tvs' andalso let - val tv_taus = map (fn _ => TYVARtype(fresh_tyvar())) tvs + val tv_taus = map (fn _ => TYVARtype {tv=fresh_tyvar()}) tvs val S = mk_subst (fn () => "eq_lamb01.LET") (tvs,tv_taus) val S' = mk_subst (fn () => "eq_lamb02.LET") (tvs',tv_taus) val t = on_Type S t @@ -926,10 +926,10 @@ structure OptLambda : OPT_LAMBDA = * Compile time values * ----------------------------------------------------------------- *) - datatype cv = CVAR of LambdaExp + datatype cv = CVAR of {exp:LambdaExp} | CRECORD of cv list | CUNKNOWN - | CCONST of LambdaExp + | CCONST of {exp:LambdaExp} | CFN of {lexp: LambdaExp, large:bool} (* only to appear in env *) | CFIX of {N:int option, Type: Type, bind: LambdaExp, large: bool} (* only to appear in env *) | CBLKSZ of IntInf.int (* statically sized block (e.g., array or string) *) @@ -939,10 +939,10 @@ structure OptLambda : OPT_LAMBDA = fun eq_cv (cv1,cv2) = case (cv1,cv2) - of (CVAR e1,CVAR e2) => eq_lamb(e1,e2) + of (CVAR {exp=e1},CVAR {exp=e2}) => eq_lamb(e1,e2) | (CRECORD cvs1, CRECORD cvs2) => eq_cvs(cvs1,cvs2) | (CUNKNOWN, CUNKNOWN) => true - | (CCONST e1, CCONST e2) => eq_lamb(e1,e2) + | (CCONST {exp=e1}, CCONST {exp=e2}) => eq_lamb(e1,e2) | (CFN{lexp,large}, CFN{lexp=lexp2,large=large2}) => large = large2 andalso eq_lamb(lexp,lexp2) | (CFIX{N,bind,large,Type}, CFIX{N=N2,bind=bind2,large=large2,Type=Type2}) => N=N2 andalso large = large2 andalso eq_Type(Type,Type2) andalso eq_lamb(bind,bind2) @@ -958,13 +958,13 @@ structure OptLambda : OPT_LAMBDA = fun closed_small_cv (lvars_free_ok,excons_free_ok,lvar,tyvars,cv) : bool = case cv - of CVAR e1 => closed (lvars_free_ok, excons_free_ok, - FN{pat=[(lvar,unitType)],body=e1}) + of CVAR {exp=e1} => closed (lvars_free_ok, excons_free_ok, + FN{pat=[(lvar,unitType)],body=e1}) | CRECORD cvs => (List.foldl (fn (cv,acc) => acc andalso closed_small_cv(lvars_free_ok, excons_free_ok,lvar,tyvars,cv)) true cvs) | CUNKNOWN => true - | CCONST e1 => true + | CCONST _ => true | CFN{lexp,large} => (not large andalso closed (lvars_free_ok, excons_free_ok, FN{pat=[(lvar,unitType)],body=lexp})) @@ -986,7 +986,7 @@ structure OptLambda : OPT_LAMBDA = * used when compiletimevalues are exported out of scope. *) fun remove lvar (CRECORD l) = CRECORD(map (remove lvar) l) - | remove lvar (cv as (CVAR (VAR{lvar =lvar',...}))) = if Lvars.eq(lvar,lvar') then CUNKNOWN else cv + | remove lvar (cv as (CVAR {exp=VAR{lvar =lvar',...}})) = if Lvars.eq(lvar,lvar') then CUNKNOWN else cv | remove _ (cv as (CCONST _)) = cv | remove _ (cv as (CBLKSZ _)) = cv | remove _ (cv as (CBLK2SZ _)) = cv @@ -1001,10 +1001,10 @@ structure OptLambda : OPT_LAMBDA = | pp_opti (SOME i) = IntInf.toString i (* pretty printing *) - fun show_cv (CVAR (VAR x)) = " cvar " ^ Lvars.pr_lvar (#lvar x) + fun show_cv (CVAR {exp=VAR x}) = " cvar " ^ Lvars.pr_lvar (#lvar x) | show_cv (CVAR _) = "" | show_cv (CRECORD l) = concat ("[" :: (map show_cv l @ ["]"])) - | show_cv (CCONST l) = "const" + | show_cv (CCONST _) = "const" | show_cv (CFN {large=true,...}) = "(large fn)" | show_cv (CFN {large=false,...}) = "(small fn)" | show_cv (CFIX {large=true,...}) = "(large fix)" @@ -1017,7 +1017,7 @@ structure OptLambda : OPT_LAMBDA = (* substitution *) fun on_cv S cv = - let fun on (CVAR lamb) = CVAR (on_LambdaExp S lamb) + let fun on (CVAR {exp=lamb}) = CVAR {exp=on_LambdaExp S lamb} | on (cv as CCONST _) = cv | on (CRECORD cvs) = CRECORD (map on cvs) | on (CFN{lexp,large}) = CFN{lexp=on_LambdaExp S lexp,large=large} @@ -1032,17 +1032,17 @@ structure OptLambda : OPT_LAMBDA = fun eq_cv_scheme ((tvs1,cv1),(tvs2,cv2)) = length tvs1 = length tvs2 andalso - let val S = mk_subst (fn () => die "eq_cv_scheme") (tvs1, map TYVARtype tvs2) + let val S = mk_subst (fn () => die "eq_cv_scheme") (tvs1, map (fn tv => TYVARtype {tv=tv}) tvs2) in eq_cv(on_cv S cv1,cv2) end (* least upper bound *) - fun lub (cv as CVAR e1,CVAR e2) = + fun lub (cv as CVAR {exp=e1},CVAR {exp=e2}) = if eq_lamb(e1,e2) then cv else CUNKNOWN | lub (CRECORD cvals,CRECORD cvals') = (CRECORD (map lub (BasisCompat.ListPair.zipEq(cvals,cvals'))) handle BasisCompat.ListPair.UnequalLengths => die "lub") - | lub (cv as CCONST e1,CCONST e2) = + | lub (cv as CCONST {exp=e1},CCONST {exp=e2}) = if eq_lamb(e1,e2) then cv else CUNKNOWN | lub (CRNG{low=l1,high=h1},CRNG{low=l2,high=h2}) = let fun minopt (NONE,_) = NONE @@ -1560,7 +1560,7 @@ structure OptLambda : OPT_LAMBDA = | _ => NONE) | _ => NONE in case opt of - SOME e => (tick "constant-folding"; (e,CCONST e)) + SOME e => (tick "constant-folding"; (e,CCONST {exp=e})) | NONE => let datatype cmp = LT | LTE | GT | GTE fun Not LT = GTE @@ -1601,7 +1601,7 @@ structure OptLambda : OPT_LAMBDA = | PRIM(CCALLprim{name="__greatereq_int63",...},xs) => try GTE xs | _ => NONE in case opt2 of - SOME e => (tick "range-folding"; (e,CCONST e)) + SOME e => (tick "range-folding"; (e,CCONST {exp=e})) | NONE => fail end end @@ -1625,42 +1625,42 @@ structure OptLambda : OPT_LAMBDA = of SOME (tyvars,cv) => (case cv of CFN {lexp=lamb',large} => - if large andalso not(Lvars.one_use lvar) then (lamb, CVAR lamb) + if large andalso not(Lvars.one_use lvar) then (lamb, CVAR {exp=lamb}) else let val S = mk_subst (fn () => "reduce1") (tyvars, instances) val _ = decr_use lvar val lamb'' = new_instance lamb' val _ = incr_uses lamb'' val _ = if large then tick "reduce - inline-largefn" else tick "reduce - inline-smallfn" - in (on_LambdaExp S lamb'', CVAR lamb) (* reduce(env,...) *) + in (on_LambdaExp S lamb'', CVAR {exp=lamb}) (* reduce(env,...) *) end - | CVAR (lamb' as VAR{lvar=lvar',instances=instances',regvars=[]}) => + | CVAR {exp=lamb' as VAR{lvar=lvar',instances=instances',regvars=[]}} => let val S = mk_subst (fn () => "reduce2") (tyvars,instances) val _ = decr_use lvar val _ = incr_use lvar' val lamb'' = on_LambdaExp S lamb' - in if Lvars.eq(lvar,lvar') then (lamb'', CVAR lamb'') - else (tick "reduce - inline-var"; (lamb'', CVAR lamb'')) (*reduce (env, (lamb'', CVAR lamb''))*) + in if Lvars.eq(lvar,lvar') then (lamb'', CVAR {exp=lamb''}) + else (tick "reduce - inline-var"; (lamb'', CVAR {exp=lamb''})) (*reduce (env, (lamb'', CVAR lamb''))*) end - | CCONST lamb' => + | CCONST {exp=lamb'} => if is_unboxed_value lamb' orelse (aggressive_opt() andalso small_const lamb') then (decr_use lvar; tick "reduce - inline-unboxed-value"; (lamb', cv)) else if Lvars.one_use lvar then (decr_use lvar; tick "reduce - inline-const"; (lamb', cv)) - else (lamb, CVAR lamb) - | CUNKNOWN => (lamb, CVAR lamb) + else (lamb, CVAR {exp=lamb}) + | CUNKNOWN => (lamb, CVAR {exp=lamb}) | _ => let val S = mk_subst (fn () => "reduce3") (tyvars,instances) in (lamb, on_cv S cv) end) - | NONE => ((*output(!Flags.log, "none\n");*) (lamb, CVAR lamb))) + | NONE => ((*output(!Flags.log, "none\n");*) (lamb, CVAR {exp=lamb}))) | VAR _ => fail (* explicit region parameters *) - | INTEGER _ => (lamb, CCONST lamb) - | WORD _ => (lamb, CCONST lamb) - | PRIM(CONprim {con,...},[]) => if is_boolean con orelse aggressive_opt() then (lamb, CCONST lamb) + | INTEGER _ => (lamb, CCONST {exp=lamb}) + | WORD _ => (lamb, CCONST {exp=lamb}) + | PRIM(CONprim {con,...},[]) => if is_boolean con orelse aggressive_opt() then (lamb, CCONST {exp=lamb}) else fail - | STRING _ => (lamb, CCONST lamb) - | REAL _ => (lamb, CCONST lamb) - | F64 _ => (lamb, CCONST lamb) + | STRING _ => (lamb, CCONST {exp=lamb}) + | REAL _ => (lamb, CCONST {exp=lamb}) + | F64 _ => (lamb, CCONST {exp=lamb}) | LET{pat=[(lvar,tyvars,tau)],bind,scope} => let (* maybe let-float f64-binding outwards to open up for other optimisations *) @@ -1772,12 +1772,12 @@ structure OptLambda : OPT_LAMBDA = let val nth_cv = List.nth(cvs,n) handle Subscript => die "reduce4" in case nth_cv - of CVAR var => (tick "reduce - sel-var"; decr_uses lamb; - incr_uses var; reduce (env, (var,nth_cv))) - | CCONST(e as INTEGER _) => (tick "reduce - sel-int"; - decr_uses lamb; (e, nth_cv)) - | CCONST(e as WORD _) => (tick "reduce - sel-word"; - decr_uses lamb; (e, nth_cv)) + of CVAR {exp=var} => (tick "reduce - sel-var"; decr_uses lamb; + incr_uses var; reduce (env, (var,nth_cv))) + | CCONST {exp=e as INTEGER _} => (tick "reduce - sel-int"; + decr_uses lamb; (e, nth_cv)) + | CCONST {exp=e as WORD _} => (tick "reduce - sel-word"; + decr_uses lamb; (e, nth_cv)) | _ => (lamb, nth_cv) end | _ => fail @@ -1980,7 +1980,7 @@ structure OptLambda : OPT_LAMBDA = of FN{pat,body} => let val lvars = lvars_fn_pat pat val env' = updateEnv lvars - (map (fn lvar => ([], CVAR (VAR{lvar=lvar,instances=[],regvars=[]}))) lvars) env + (map (fn lvar => ([], CVAR {exp=VAR{lvar=lvar,instances=[],regvars=[]}})) lvars) env val (body',_) = contr (env', body) in (FN{pat=pat,body=body'},CUNKNOWN) end @@ -1989,9 +1989,9 @@ structure OptLambda : OPT_LAMBDA = val cv' = if noinline_lvar lvar then CUNKNOWN else if is_inlinable_fn lvar bind' then CFN{lexp=bind',large=false} else if is_fn bind' then CFN{lexp=bind',large=true} - else if is_unboxed_value bind' then CCONST bind' + else if is_unboxed_value bind' then CCONST {exp=bind'} else (case bind' - of VAR _ => CVAR bind' + of VAR _ => CVAR {exp=bind'} | _ => cv) val env' = LvarMap.add(lvar,(tyvars,cv'),env) @@ -2068,7 +2068,7 @@ structure OptLambda : OPT_LAMBDA = let val e'' = INTEGER(i,intDefaultType()) in tick "contr - table_size"; decr_uses e'; - (e'', CCONST e'') + (e'', CCONST {exp=e''}) end else fail() | _ => fail() @@ -2078,7 +2078,7 @@ structure OptLambda : OPT_LAMBDA = fun fail () = (PRIM(p,[a',i]),CUNKNOWN) fun mk s i = let val e = INTEGER(i,intDefaultType()) in tick ("contr - table2d_size" ^ s); - decr_uses a'; (e, CCONST e) + decr_uses a'; (e, CCONST {exp=e}) end in if safeLambdaExp a' then case (idx,cv) of @@ -2226,10 +2226,10 @@ structure OptLambda : OPT_LAMBDA = fun free_cv (cv,acc) = case cv of - CVAR exp => free_exp (exp,acc) + CVAR {exp} => free_exp (exp,acc) | CRECORD cvs => List.foldl free_cv acc cvs | CUNKNOWN => acc - | CCONST exp => free_exp (exp,acc) + | CCONST {exp} => free_exp (exp,acc) | CFN {lexp: LambdaExp, large:bool} => free_exp(lexp,acc) | CFIX {N,Type: Type, bind: LambdaExp, large: bool} => free_exp(bind,acc) | CBLKSZ _ => acc @@ -2301,14 +2301,14 @@ structure OptLambda : OPT_LAMBDA = | toInt (CCON1 _) = 9 fun fun_CVAR _ = - Pickle.con1 CVAR (fn CVAR a => a | _ => die "pu_contract_env.CVAR") + Pickle.con1 (fn e => CVAR {exp=e}) (fn CVAR {exp} => exp | _ => die "pu_contract_env.CVAR") LambdaExp.pu_LambdaExp fun fun_CRECORD pu = Pickle.con1 CRECORD (fn CRECORD a => a | _ => die "pu_contract_env.CRECORD") (Pickle.listGen pu) val fun_CUNKNOWN = Pickle.con0 CUNKNOWN fun fun_CCONST _ = - Pickle.con1 CCONST (fn CCONST a => a | _ => die "pu_contract_env.CCONST") + Pickle.con1 (fn e => CCONST {exp=e}) (fn CCONST {exp} => exp | _ => die "pu_contract_env.CCONST") LambdaExp.pu_LambdaExp fun fun_CFN _ = Pickle.con1 CFN (fn CFN a => a | _ => die "pu_contract_env.CFN") @@ -2644,7 +2644,7 @@ structure OptLambda : OPT_LAMBDA = end fun extend_IS IS c = let fun ext [] lv = IS(lv) - | ext (({lvar,tyvars,...}:fs)::c) lv = if Lvars.eq(lvar,lv) then SOME (map TYVARtype tyvars) + | ext (({lvar,tyvars,...}:fs)::c) lv = if Lvars.eq(lvar,lv) then SOME (map (fn tv => TYVARtype {tv=tv}) tyvars) else ext c lv in ext c end @@ -2671,8 +2671,8 @@ structure OptLambda : OPT_LAMBDA = else fresh_tyvar () fun on_tyvar S tv = - case on_Type S (TYVARtype tv) - of TYVARtype tv' => tv' + case on_Type S (TYVARtype {tv=tv}) + of TYVARtype {tv=tv'} => tv' | _ => die "on_tyvar" fun on_c S [] = [] (* memo:regvars *) @@ -2684,7 +2684,7 @@ structure OptLambda : OPT_LAMBDA = end val tyvars = get_tyvars c [] - val types = map (TYVARtype o fresh_tv) tyvars + val types = map (TYVARtype o (fn tv => {tv=tv}) o fresh_tv) tyvars val S = mk_subst (fn () => "rn_btvs_c") (tyvars, types) in on_c S c end @@ -3604,7 +3604,7 @@ structure OptLambda : OPT_LAMBDA = let fun new_tv tv = if equality_tyvar tv then fresh_eqtyvar() else fresh_tyvar() val tyvars' = map new_tv tyvars - val S = mk_subst (fn () => "new_sigma") (tyvars,map TYVARtype tyvars') + val S = mk_subst (fn () => "new_sigma") (tyvars,map (fn tv => TYVARtype {tv=tv}) tyvars') in (tyvars', on_Type S tau) end @@ -3613,7 +3613,7 @@ structure OptLambda : OPT_LAMBDA = List.length tyvars1 = List.length tyvars2 andalso let val (tyvars1,tau1) = new_sigma sigma1 val (tyvars2,tau2) = new_sigma sigma2 - val S = mk_subst (fn () => "eq_sigma") (tyvars1,map TYVARtype tyvars2) + val S = mk_subst (fn () => "eq_sigma") (tyvars1,map (fn tv => TYVARtype {tv=tv}) tyvars2) val tau1' = on_Type S tau1 in eq_Type(tau1',tau2) end diff --git a/src/Compiler/Regions/RType.sml b/src/Compiler/Regions/RType.sml index e30614e7a..8c9e6812a 100644 --- a/src/Compiler/Regions/RType.sml +++ b/src/Compiler/Regions/RType.sml @@ -45,7 +45,7 @@ struct fun pr_place r = PP.flatten1(E.layout_effect r) datatype Type = - TYVAR of tyvar + TYVAR of {tv:tyvar} | CONSTYPE of tyname * Type list * place list * arroweffect list | RECORD of Type list | FUN of Type list * arroweffect * Type list @@ -69,13 +69,13 @@ struct | BOX(TYVAR _, _) => false | BOX(BOX _,_) => false - val mkTYVAR = TYVAR + val mkTYVAR = fn tv => TYVAR {tv=tv} val mkCONSTYPE = CONSTYPE val mkRECORD = RECORD val mkFUN = FUN val mkBOX = BOX - fun unTYVAR (TYVAR a) = SOME a + fun unTYVAR (TYVAR {tv}) = SOME tv | unTYVAR _ = NONE fun unCONSTYPE (CONSTYPE a) = SOME a @@ -231,7 +231,7 @@ struct ^ " is not in scope") fun mkTy0 (ty,cone) = case ty of - L.TYVARtype alpha => ((TYVAR alpha,NONE), cone) + L.TYVARtype {tv=alpha} => ((TYVAR {tv=alpha},NONE), cone) | L.ARROWtype(tys1,rvopt0,tys2,rvopt)=> let val (eps,cone') = get_eps cone rvopt0 val (cone1,mus1) = List.foldr mkMus (cone',[]) tys1 @@ -450,7 +450,7 @@ struct fun lay_tau_rec parenthesise ty = case ty of - TYVAR v => layout_tyvar v + TYVAR {tv} => layout_tyvar tv | FUN(mus1,areff,mus2) => let val children = [layout_arg_res mus1, layout_arrow_rec areff, layout_arg_res mus2] in if parenthesise then @@ -608,7 +608,7 @@ struct let fun ftv (t,(seen,acc)) = case t of - TYVAR tv => if mem tv seen then (seen,acc) else (tv::seen,tv::acc) + TYVAR {tv} => if mem tv seen then (seen,acc) else (tv::seen,tv::acc) | CONSTYPE(_,mus,_,_) => ftv_mus (mus,(seen,acc)) | RECORD mus => ftv_mus (mus,(seen,acc)) | FUN(mus1,_,mus2) => ftv_mus (mus2,ftv_mus (mus1,(seen,acc))) @@ -743,9 +743,9 @@ struct fun cp_ty ty = case ty of - TYVAR alpha => (case applySt(St, alpha) of - NONE => (false,ty) - | SOME ty' => (true, ty')) + TYVAR {tv=alpha} => (case applySt(St, alpha) of + NONE => (false,ty) + | SOME ty' => (true, ty')) | RECORD mus => let val l = map cp_mu mus in if List.exists (#1) l @@ -1416,7 +1416,7 @@ struct | toInt (FUN _) = 3 | toInt (BOX _) = 4 fun fun_TYVAR _ = - Pickle.con1 TYVAR (fn TYVAR a => a | _ => die "pu_Type.TYVAR") + Pickle.con1 (fn tv => TYVAR {tv=tv}) (fn TYVAR {tv} => tv | _ => die "pu_Type.TYVAR") L.pu_tyvar fun fun_CONSTYPE pu_Type = Pickle.con1 CONSTYPE (fn CONSTYPE a => a | _ => die "pu_Type.CONSTYPE") diff --git a/src/Compiler/Regions/SpreadDataType.sml b/src/Compiler/Regions/SpreadDataType.sml index 10d353b19..da2efd9b7 100644 --- a/src/Compiler/Regions/SpreadDataType.sml +++ b/src/Compiler/Regions/SpreadDataType.sml @@ -207,7 +207,7 @@ struct (* We disregard region variable info in datatype declarations *) fun ty_to_mu (tau: E.Type) : R.mu = case tau of - E.TYVARtype alpha => R.mkTYVAR alpha + E.TYVARtype {tv=alpha} => R.mkTYVAR alpha | E.ARROWtype(taus1,_,taus2,_) => extend(R.mkFUN(map ty_to_mu taus1, get_eps(), map ty_to_mu taus2)) | E.CONStype(taus, tyname,_) => diff --git a/src/Makefile.in b/src/Makefile.in index a7535e871..aa8b38be7 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -122,5 +122,6 @@ clean: cd Compiler/Backend/JS && $(CLEAN) cd Compiler/Regions && $(CLEAN) cd Compiler/Lambda && $(CLEAN) - $(MAKE) -C lib/github.com/diku-dk/sml-uref clean + cd lib/github.com/diku-dk/sml-uref && $(CLEAN) + cd lib/github.com/diku-dk/sml-uref/test && $(CLEAN) rm -f mlkit diff --git a/src/Pickle/pickle.sml b/src/Pickle/pickle.sml index ecda05841..e2dca6db9 100644 --- a/src/Pickle/pickle.sml +++ b/src/Pickle/pickle.sml @@ -29,6 +29,8 @@ structure Pickle :> PICKLE = (* was : *) datatype 'a cache = NoCache | Cached of 'a | Caching + datatype 'a vcache = NoCache_v | Cached_v of 'a vector | Caching_v + infix == fun a == b : bool = false (* @@ -653,7 +655,7 @@ structure Pickle :> PICKLE = (* was : *) | NONE => Tdata(name,length fs) val hash_data = newHashCount() val res : 'a pu option ref = ref NONE - val ps : 'a pu Vector.vector cache ref = ref NoCache + val ps : 'a pu vcache ref = ref NoCache_v val fs_sz = length fs fun p () = if fs_sz = 1 then fn x => pickler (getPUPI 0) x @@ -705,14 +707,14 @@ structure Pickle :> PICKLE = (* was : *) | SOME pup => pup and getPUPI (i:int) = case !ps of - NoCache => let val _ = ps := Caching - val ps0 = map (fn f => f (getPUP())) fs - val psv = Vector.fromList ps0 - in ps := Cached psv - ; Vector.sub(psv,i) - end - | Cached psv => Vector.sub(psv,i) - | Caching => fail ("dataGen.Caching: " ^ name) + NoCache_v => let val _ = ps := Caching_v + val ps0 = map (fn f => f (getPUP())) fs + val psv = Vector.fromList ps0 + in ps := Cached_v psv + ; Vector.sub(psv,i) + end + | Cached_v psv => Vector.sub(psv,i) + | Caching_v => fail ("dataGen.Caching: " ^ name) and h v = hashComb (fn p => let val i = toInt v @@ -737,8 +739,8 @@ structure Pickle :> PICKLE = (* was : *) val bHashData = newHashCount() val aRes : 'a pu option ref = ref NONE val bRes : 'b pu option ref = ref NONE - val aPs : 'a pu Vector.vector cache ref = ref NoCache - val bPs : 'b pu Vector.vector cache ref = ref NoCache + val aPs : 'a pu vcache ref = ref NoCache_v + val bPs : 'b pu vcache ref = ref NoCache_v fun aP v s = let val i = aToInt v val s = S.outcw (Word.fromInt i, s) @@ -769,14 +771,14 @@ structure Pickle :> PICKLE = (* was : *) | SOME pup => pup and aGetPUPI (i:int) = case !aPs of - NoCache => let val _ = aPs := Caching - val ps0 = map (fn f => f (aGetPUP(),bGetPUP())) afs - val psv = Vector.fromList ps0 - in aPs := Cached psv - ; Vector.sub(psv,i) - end - | Cached psv => Vector.sub(psv,i) - | Caching => fail ("dataGen2.Caching.a: " ^ aname) + NoCache_v => let val _ = aPs := Caching_v + val ps0 = map (fn f => f (aGetPUP(),bGetPUP())) afs + val psv = Vector.fromList ps0 + in aPs := Cached_v psv + ; Vector.sub(psv,i) + end + | Cached_v psv => Vector.sub(psv,i) + | Caching_v => fail ("dataGen2.Caching.a: " ^ aname) and bP v s = let val i = bToInt v val s = S.outcw (Word.fromInt i, s) @@ -807,14 +809,14 @@ structure Pickle :> PICKLE = (* was : *) | SOME pup => pup and bGetPUPI (i:int) = case !bPs of - NoCache => let val _ = bPs := Caching - val ps0 = map (fn f => f (aGetPUP(),bGetPUP())) bfs - val psv = Vector.fromList ps0 - in bPs := Cached psv - ; Vector.sub(psv,i) - end - | Cached psv => Vector.sub(psv,i) - | Caching => fail ("dataGen2.Caching.b: " ^ bname) + NoCache_v => let val _ = bPs := Caching_v + val ps0 = map (fn f => f (aGetPUP(),bGetPUP())) bfs + val psv = Vector.fromList ps0 + in bPs := Cached_v psv + ; Vector.sub(psv,i) + end + | Cached_v psv => Vector.sub(psv,i) + | Caching_v => fail ("dataGen2.Caching.b: " ^ bname) and aH v = hashComb (fn p => let val i = aToInt v @@ -847,9 +849,9 @@ structure Pickle :> PICKLE = (* was : *) val aRes : 'a pu option ref = ref NONE val bRes : 'b pu option ref = ref NONE val cRes : 'c pu option ref = ref NONE - val aPs : 'a pu Vector.vector cache ref = ref NoCache - val bPs : 'b pu Vector.vector cache ref = ref NoCache - val cPs : 'c pu Vector.vector cache ref = ref NoCache + val aPs : 'a pu vcache ref = ref NoCache_v + val bPs : 'b pu vcache ref = ref NoCache_v + val cPs : 'c pu vcache ref = ref NoCache_v fun aP v s = let val i = aToInt v val s = S.outcw (Word.fromInt i, s) @@ -878,15 +880,15 @@ structure Pickle :> PICKLE = (* was : *) | SOME pup => pup and aGetPUPI (i:int) = case !aPs of - NoCache => let val _ = aPs := Caching - val ps0 = map (fn f => f (aGetPUP(),bGetPUP(), - cGetPUP())) afs - val psv = Vector.fromList ps0 - in aPs := Cached psv - ; Vector.sub(psv,i) - end - | Cached psv => Vector.sub(psv,i) - | Caching => fail ("dataGen3.Caching.a: " ^ aname) + NoCache_v => let val _ = aPs := Caching_v + val ps0 = map (fn f => f (aGetPUP(),bGetPUP(), + cGetPUP())) afs + val psv = Vector.fromList ps0 + in aPs := Cached_v psv + ; Vector.sub(psv,i) + end + | Cached_v psv => Vector.sub(psv,i) + | Caching_v => fail ("dataGen3.Caching.a: " ^ aname) and bP v s = let val i = bToInt v val s = S.outcw (Word.fromInt i, s) @@ -915,15 +917,15 @@ structure Pickle :> PICKLE = (* was : *) | SOME pup => pup and bGetPUPI (i:int) = case !bPs of - NoCache => let val _ = bPs := Caching - val ps0 = map (fn f => f (aGetPUP(),bGetPUP(), - cGetPUP())) bfs - val psv = Vector.fromList ps0 - in bPs := Cached psv - ; Vector.sub(psv,i) - end - | Cached psv => Vector.sub(psv,i) - | Caching => fail ("dataGen3.Caching.b: " ^ bname) + NoCache_v => let val _ = bPs := Caching_v + val ps0 = map (fn f => f (aGetPUP(),bGetPUP(), + cGetPUP())) bfs + val psv = Vector.fromList ps0 + in bPs := Cached_v psv + ; Vector.sub(psv,i) + end + | Cached_v psv => Vector.sub(psv,i) + | Caching_v => fail ("dataGen3.Caching.b: " ^ bname) and cP v s = let val i = cToInt v val s = S.outcw (Word.fromInt i, s) @@ -952,15 +954,15 @@ structure Pickle :> PICKLE = (* was : *) | SOME pup => pup and cGetPUPI (i:int) = case !cPs of - NoCache => let val _ = cPs := Caching - val ps0 = map (fn f => f (aGetPUP(),bGetPUP(), - cGetPUP())) cfs - val psv = Vector.fromList ps0 - in cPs := Cached psv - ; Vector.sub(psv,i) - end - | Cached psv => Vector.sub(psv,i) - | Caching => fail ("dataGen3.Caching.c: " ^ cname) + NoCache_v => let val _ = cPs := Caching_v + val ps0 = map (fn f => f (aGetPUP(),bGetPUP(), + cGetPUP())) cfs + val psv = Vector.fromList ps0 + in cPs := Cached_v psv + ; Vector.sub(psv,i) + end + | Cached_v psv => Vector.sub(psv,i) + | Caching_v => fail ("dataGen3.Caching.c: " ^ cname) and aH v = hashComb (fn p => let val i = aToInt v diff --git a/src/Runtime/Posix.c b/src/Runtime/Posix.c index 423745b9e..acaeb1c87 100644 --- a/src/Runtime/Posix.c +++ b/src/Runtime/Posix.c @@ -361,9 +361,9 @@ REG_POLY_FUN_HDR(sml_readVec,uintptr_t pair, Region sr, int fd, int n1) r = read(convertIntToC(fd), p, n); if (r > 0) { -#pragma GCC diagnostic ignored "-Wstringop-overflow=" + // #pragma GCC diagnostic ignored "-Wstringop-overflow=" *(p+r) = '\0'; -#pragma GCC diagnostic pop + // #pragma GCC diagnostic pop } first(pair) = (uintptr_t) s; second(pair) = convertIntToML(r); diff --git a/src/Tools/MlbMake/MLB_PROJECT.sml b/src/Tools/MlbMake/MLB_PROJECT.sml index 2e7fbbe13..aef1f81df 100644 --- a/src/Tools/MlbMake/MLB_PROJECT.sml +++ b/src/Tools/MlbMake/MLB_PROJECT.sml @@ -14,7 +14,7 @@ sig type atbdec = string (* path.{sml,sig} *) - datatype bexp = BASbexp of bdec + datatype bexp = BASbexp of {bdec:bdec} | LETbexp of bdec * bexp | LONGBIDbexp of Bid.longbid diff --git a/src/Tools/MlbMake/MlbProject.sml b/src/Tools/MlbMake/MlbProject.sml index abe9431c8..b02904206 100644 --- a/src/Tools/MlbMake/MlbProject.sml +++ b/src/Tools/MlbMake/MlbProject.sml @@ -36,7 +36,7 @@ struct end type atbdec = string (* path.{sml,sig} *) - datatype bexp = BASbexp of bdec + datatype bexp = BASbexp of {bdec:bdec} | LETbexp of bdec * bexp | LONGBIDbexp of Bid.longbid @@ -254,7 +254,7 @@ struct let fun parse_rest(bdec,ss) = case ss of - "end" :: ss => (MS.BASbexp bdec, ss) + "end" :: ss => (MS.BASbexp {bdec=bdec}, ss) | _ => parse_error1 mlbfile ("missing 'end'", ss) in case parse_bdec_opt mlbfile ss of @@ -551,7 +551,7 @@ struct fun dep_bexp (D:D) (A:A) bexp : D * A = case bexp of - MS.BASbexp bdec => dep_bdec D A bdec + MS.BASbexp {bdec} => dep_bdec D A bdec | MS.LETbexp (bdec,bexp) => let val (D1,A) = dep_bdec D A bdec val (D2,A) = dep_bexp (D+D1) A bexp @@ -839,7 +839,7 @@ struct and srcs_bexp state mlbfilehash dir mlbs anns deps bexp = case bexp - of MS.BASbexp bdec => srcs_bdec state mlbfilehash mlbs dir anns deps bdec + of MS.BASbexp {bdec} => srcs_bdec state mlbfilehash mlbs dir anns deps bdec | MS.LETbexp (bdec,bexp) => let val (s1,deps,mlbs) = srcs_bdec state mlbfilehash mlbs dir anns deps bdec diff --git a/src/config.h.in b/src/config.h.in index d56bfb17f..04d7538e6 100644 --- a/src/config.h.in +++ b/src/config.h.in @@ -1,6 +1,6 @@ /* src/config.h.in. Generated from configure.ac by autoheader. */ -/* Define to 1 if you have the header file, and it defines `DIR'. +/* Define to 1 if you have the header file, and it defines 'DIR'. */ #undef HAVE_DIRENT_H @@ -22,7 +22,7 @@ /* Define to 1 if you have the header file. */ #undef HAVE_MALLOC_H -/* Define to 1 if you have the header file, and it defines `DIR'. */ +/* Define to 1 if you have the header file, and it defines 'DIR'. */ #undef HAVE_NDIR_H /* Define to 1 if you have the header file. */ @@ -46,14 +46,14 @@ /* Define to 1 if you have the header file. */ #undef HAVE_STRING_H -/* Define to 1 if you have the header file, and it defines `DIR'. +/* Define to 1 if you have the header file, and it defines 'DIR'. */ #undef HAVE_SYS_DIR_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_IOCTL_H -/* Define to 1 if you have the header file, and it defines `DIR'. +/* Define to 1 if you have the header file, and it defines 'DIR'. */ #undef HAVE_SYS_NDIR_H @@ -102,7 +102,7 @@ /* Define to the version of this package. */ #undef PACKAGE_VERSION -/* Define to 1 if all of the C90 standard headers exist (not just the ones +/* Define to 1 if all of the C89 standard headers exist (not just the ones required in a freestanding environment). This macro is provided for backward compatibility; new code need not use it. */ #undef STDC_HEADERS diff --git a/test/real.sml b/test/real.sml index 1b9e51572..4efe23792 100644 --- a/test/real.sml +++ b/test/real.sml @@ -259,8 +259,8 @@ val test11a = handle Size => "OK" | _ => "WRONG") val test11b = - tst0 "test11b" ((fmt (StringCvt.FIX (SOME 100000)) 12.3456) - handle Size => "OK" | _ => "WRONG") + tst0 "test11b" ((fmt (StringCvt.FIX (SOME 10000)) 12.3456; "OK") + handle Size => "WRONG" | _ => "EXN") fun chkFIX (s,r, s0, s1, s2, s6) = tst ("chkFIX."^s)(fmt (StringCvt.FIX (SOME 0)) r = s0 @@ -307,8 +307,8 @@ val test12a = handle Size => "OK" | _ => "WRONG") val test12b = - tst0 "test12b" ((fmt (StringCvt.SCI (SOME 100000)) 12.3456) - handle Size => "OK" | _ => "WRONG") + tst0 "test12b" ((fmt (StringCvt.SCI (SOME 10000)) 12.3456; "OK") + handle Size => "WRONG" | _ => "EXN") fun chkSCI (r, s0, s1, s2, s6) = fmt (StringCvt.SCI (SOME 0)) r = s0 @@ -340,8 +340,8 @@ val test13a = handle Size => "OK" | _ => "WRONG") val test13b = - tst0 "test13b" ((fmt (StringCvt.GEN (SOME 100000)) 12.3456) - handle Size => "OK" | _ => "WRONG") + tst0 "test13b" ((fmt (StringCvt.GEN (SOME 10000)) 12.3456; "OK") + handle Size => "ERR" | _ => "EXN") fun chkGEN (r, s1, s2, s6, s12) = fmt (StringCvt.GEN (SOME 1)) r = s1