Barry cleanup (#183)

* fix optimiser bug with selection of tuples containing tuples
* barry cleanup

.github/workflows/main.yml

@@ -146,6 +146,11 @@ jobs:
         run: |
           make -C js/test test
 
+      - name: Build and run Barry tests
+        run: |
+          make barry
+          make -C test/barry all
+
       - name: Build binary distribution
         run: |
           make mlkit_bin_dist

NEWS.md

@@ -1,5 +1,10 @@
 ## MLKit NEWS
 
+* mael 2024-09-23: Optimiser bug fix with static selection of tuples containing
+  tuples.
+
+* mael 2024-09-17: Cleanup and tests of Barry, a Standard ML barrifier.
+
 * mael 2024-06-27: Fix recursive-function specialisation bug (issue #177).
 
 ### MLKit version 4.7.11 is released

src/Common/KitBarry.sml

@@ -2,13 +2,15 @@ structure K =
   let structure KC = KitCompiler(ExecutionBarry)
       val () = Flags.turn_off "cross_module_opt"
       val () = Flags.turn_off "unbox_reals"
+      val () = Flags.turn_off "eliminate_polymorphic_equality"
+      val () = Flags.turn_off "uncurrying"
       val () = List.app Flags.block_entry
                         ["garbage_collection",
                          "generational_garbage_collection",
                          "values_64bit", "unbox_reals", "tag_values", "tag_pairs",
                          "repository", "reml", "region_profiling", "region_inference",
                          "print_region_flow_graph", "print_all_program_points",
-                         "preserve_tail_calls", "dangling_pointers"
+                         "preserve_tail_calls", "dangling_pointers", "report_boxities", "high_pointer_tagging"
                       ]
 
   in KitMain(KC)

src/Common/TYNAME.sig

@@ -32,6 +32,7 @@ signature TYNAME =
 
     val freshTyName    : {tycon : tycon, arity : int, equality : bool} -> TyName
     val pr_TyName      : TyName -> string
+    val pr_TyName'     : TyName -> string
     val pr_TyName_repl : TyName -> string        (* for type-index value printing in the REPL,
                                                   * non-predefined type names are printed with
                                                   * their internal id... *)

src/Common/TyName.sml

@@ -190,6 +190,14 @@ structure TyName :> TYNAME =
                    else str))
       end
 
+    fun pr_TyName' ({tycon,name,...}:TyName) : string =
+	let val str = TyCon.pr_TyCon tycon
+            val (i,s) = Name.key name
+            val s = if Name.baseGet() = s then "" else s
+	in str ^ ":" ^ Int.toString i ^ ":" ^ s
+	end
+
+
     fun setBoxity (tn: TyName, b:boxity) : unit =
         case boxity tn of
             BOXED => #boxity tn := b

src/Compiler/CompileToLamb.sml

@@ -20,8 +20,6 @@ structure CompileToLamb: COMPILE_TO_LAMB =
     (*  Dynamic Flags.                                                        *)
     (* ---------------------------------------------------------------------- *)
 
-    val eliminate_polymorphic_equality_p = Flags.is_on0 "eliminate_polymorphic_equality"
-
     val type_check_lambda_p = Flags.is_on0 "type_check_lambda"
 
     val print_opt_lambda_expression = Flags.is_on0 "print_opt_lambda_expression"
@@ -140,7 +138,6 @@ structure CompileToLamb: COMPILE_TO_LAMB =
     (* ---------------------------------------------------------------------- *)
 
     fun elim_eq_lambda (env,lamb) =
-      if eliminate_polymorphic_equality_p() then
 	(chat "[begin eliminating polymorphic equality]";
 	 Timing.timing_begin();
 	 let val (lamb', env') =
@@ -154,8 +151,6 @@ structure CompileToLamb: COMPILE_TO_LAMB =
 	   else ();
 	   (lamb', env')
 	 end)
-      else (lamb, EliminateEq.empty)
-
 
     (* ---------------------------------------------------------------------- *)
     (*   Optimise the lambda code                                             *)

src/Compiler/Lambda/Con.sml

@@ -15,7 +15,13 @@ structure Con :> CON where type name = Name.name =
     fun mk_con (s: string) : con = {str=s,name=Name.new()}
 
     fun pr_con ({str,...}: con) : string = str
-    fun pr_con' ({str,name}: con) : string = str ^ "_" ^ Int.toString (#1(Name.key name))
+
+    fun pr_con' ({str,name}: con) : string =  (* for Barry and debugging *)
+	let val (i,s) = Name.key name
+            val s = if Name.baseGet() = s then "" else s
+	    val str = if str = "" then "c:" else str ^ ":"
+	in str ^ Int.toString i ^ ":" ^ s
+	end
 
     fun name ({name,...}: con) : name = name
 

src/Compiler/Lambda/EliminateEq.sml

@@ -8,6 +8,8 @@ structure EliminateEq : ELIMINATE_EQ =
 
     open LambdaExp
 
+    val eliminate_polymorphic_equality_p = Flags.is_on0 "eliminate_polymorphic_equality"
+
     fun die s = Crash.impossible ("EliminateEq." ^ s)
     fun log s = (TextIO.output(!Flags.log, s); TextIO.flushOut (!Flags.log))
 
@@ -159,13 +161,15 @@ structure EliminateEq : ELIMINATE_EQ =
       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 =
-          restrict'(e,{lvars=lvars,tynames=tynames})
-          handle x =>
-               (say "ElimiateEq.restrict failed\n";
-                say "The equality environment is:\n";
-                PP.outputTree(say,  layout_env e, 70);
-                say "(end of equality environment)\n";
-                raise x)
+          if eliminate_polymorphic_equality_p () then
+            restrict'(e,{lvars=lvars,tynames=tynames})
+            handle x =>
+                   (say "ElimiateEq.restrict failed\n";
+                    say "The equality environment is:\n";
+                    PP.outputTree(say,  layout_env e, 70);
+                    say "(end of equality environment)\n";
+                    raise x)
+          else (nil,empty)
       type StringTree = PP.StringTree
       val layout_env : env -> StringTree = layout_env
     end
@@ -911,24 +915,25 @@ structure EliminateEq : ELIMINATE_EQ =
          | _ => lexp
 
     fun elim_eq (env0, PGM ((datbinds as DATBINDS dbss), lexp)) : LambdaPgm * env =
-      let
-        val op + = plus
-        val (f', env_builtin_dat) = gen_datatype_builtin_eq ()
-        val env1 = env0 + env_builtin_dat
-        val (f, env_dat) = gen_datatype_eq env1 dbss
-        val env2 = env1 + env_dat
-        val _ = env_frame := empty
-        val lexp1 = t env2 lexp                         (* env_frame is updated as a side-effect. *)
-        val env_export = env_dat + (!env_frame)
-        val lexp2 = extend_frame env_dat lexp1          (* don't put eq. functions for built-in
-                                                         * datatypes in frame. For in-lining, we
-                                                         * better introduce them in each module. *)
-      in (PGM (datbinds, (f' o f) lexp2), env_export)
-      end handle e as DONT_SUPPORT_EQ s =>
-        (log ("\n ** Equality not supported for datatype " ^ s ^ "\n");
-         log (" ** Rewrite the program to use an explicit equality function\n");
-         log (" ** for this particular datatype.\n\n");
-         raise e)
+        if eliminate_polymorphic_equality_p() then
+          let val op + = plus
+              val (f', env_builtin_dat) = gen_datatype_builtin_eq ()
+              val env1 = env0 + env_builtin_dat
+              val (f, env_dat) = gen_datatype_eq env1 dbss
+              val env2 = env1 + env_dat
+              val _ = env_frame := empty
+              val lexp1 = t env2 lexp                         (* env_frame is updated as a side-effect. *)
+              val env_export = env_dat + (!env_frame)
+              val lexp2 = extend_frame env_dat lexp1          (* don't put eq. functions for built-in
+                                                               * datatypes in frame. For in-lining, we
+                                                               * better introduce them in each module. *)
+          in (PGM (datbinds, (f' o f) lexp2), env_export)
+          end handle e as DONT_SUPPORT_EQ s =>
+                     (log ("\n ** Equality not supported for datatype " ^ s ^ "\n");
+                      log (" ** Rewrite the program to use an explicit equality function\n");
+                      log (" ** for this particular datatype.\n\n");
+                      raise e)
+        else (PGM(datbinds,lexp), empty)
 
     val pu =
         let fun resultToInt (MONOLVAR _) = 0

src/Compiler/Lambda/Excon.sml

@@ -19,7 +19,12 @@ structure Excon :> EXCON where type name = Name.name =
 
     fun mk_excon (s: string) : excon = {str=s,name=Name.new()}
 
-    fun pr_excon' ({str,name}: excon) : string = str ^ "_" ^ Int.toString (#1(Name.key name))
+    fun pr_excon' ({str,name}: excon) : string =  (* for Barry and debugging *)
+	let val (i,s) = Name.key name
+            val s = if Name.baseGet() = s then "" else s
+	    val str = if str = "" then "e:" else str ^ ":"
+	in str ^ Int.toString i ^ ":" ^ s
+	end
 
     fun pr_excon ({str,name}: excon) : string =
         if print_excon_name() then