String literal deduplication

3 files changed, 70 insertions, 43 deletions

diff --git a/common.sml b/common.sml
index 7ed59c3..5f4eaae 100644
--- a/common.sml
+++ b/common.sml
@@ -4,6 +4,32 @@ fun $ (x, y) = x y
 infixr 0 $
 fun id x = x
 
+val compare = fn a => fn b => Int.compare (a, b)
+
+fun sort _ [] = []
+  | sort _ [x] = [x]
+  | sort le l =
+  let
+    fun divide [] accp = accp
+      | divide [x] (acc1, acc2) = (x :: acc1, acc2)
+      | divide (x :: y :: tail) (acc1, acc2) =
+        divide tail (x :: acc1, y :: acc2)
+    val (part1, part2) = divide l ([], [])
+    val part1 = sort le part1
+    val part2 = sort le part2
+
+    fun merge [] [] acc = acc
+      | merge [] ys acc = rev $ List.revAppend (ys, acc)
+      | merge xs [] acc = rev $ List.revAppend (xs, acc)
+      | merge (x :: xs) (y :: ys) acc =
+          if le (x, y) then
+            merge xs (y :: ys) (x :: acc)
+          else
+            merge (x :: xs) ys (y :: acc)
+  in
+    merge part1 part2 []
+  end
+
 fun assert truth = if not truth then raise Unreachable else ()
 
 structure Fold = struct
diff --git a/emit.fun b/emit.fun
index ea4c455..ccdb6ce 100644
--- a/emit.fun
+++ b/emit.fun
@@ -149,31 +149,57 @@ functor Emit(I: IL) = struct
 
   fun handleStrlits strlits =
   let
+    fun unique l =
+    let
+      val l = sort (op <=) l
+      fun u [] acc = rev acc
+        | u (x :: xs) [] = u xs [x]
+        | u (x :: xs) (y :: ys) =
+          if x = y then
+            u xs (y :: ys)
+          else
+            u xs (x :: y :: ys)
+    in
+      u l []
+    end
+
     fun emitStrlit id =
     let
-      val () = fprint `".S" I id `":\t" %
       val symbols = PP.T.strlit2charList (PP.?? id)
 
-      fun pc c out =
-        if Char.isPrint c andalso not (Char.isSpace c) then
-          Printf out `"'" C c `"'" %
+      datatype strPart = SpStr of string | SpOrd of int
+
+      open Char
+
+      fun collectStr (c :: cs) acc =
+        if isPrint c andalso (c = #" " orelse not (isSpace c)) then
+          collectStr cs (c :: acc)
         else
-          Printf out I (ord c) %
+          let
+            val p = SpOrd (ord c)
+            val l = collectStr cs []
+          in
+            if null acc then l else SpStr (implode $ rev acc) :: p :: l
+          end
+        | collectStr [] acc =
+            if null acc then [] else [SpStr (implode $ rev acc)]
 
-      fun outputStrlit (c :: []) = fprint A1 pc c %
-        | outputStrlit [] = raise Unreachable
-        | outputStrlit (c :: cs) = (
-          fprint A1 pc c `", " %;
-          outputStrlit cs
-        )
+     fun printPart (SpStr s) out = Printf out `"'" `s `"'" %
+       | printPart (SpOrd v) out = Printf out I v %
 
+     fun printStr [] = ()
+       | printStr (p :: ps) = (fprint A1 printPart p `", " %; printStr ps)
+
+      val parts = collectStr symbols []
     in
+      fprint `".S" I id `":\t" %;
       fprint `"db " %;
-      outputStrlit symbols
+      List.app (fn p => fprint A1 printPart p `", " %) parts;
+      fprint `"0\n" %
     end
   in
     fprint `"\n" %;
-    List.app emitStrlit strlits
+    List.app emitStrlit (unique strlits)
   end
 
   fun handleLocalIniLayouts () =
@@ -490,30 +516,6 @@ functor Emit(I: IL) = struct
     Array.appi p rinfo
   end
 
-  fun sort _ [] = []
-    | sort _ [x] = [x]
-    | sort le l =
-    let
-      fun divide [] accp = accp
-        | divide [x] (acc1, acc2) = (x :: acc1, acc2)
-        | divide (x :: y :: tail) (acc1, acc2) =
-          divide tail (x :: acc1, y :: acc2)
-      val (part1, part2) = divide l ([], [])
-      val part1 = sort le part1
-      val part2 = sort le part2
-
-      fun merge [] [] acc = acc
-        | merge [] ys acc = rev $ List.revAppend (ys, acc)
-        | merge xs [] acc = rev $ List.revAppend (xs, acc)
-        | merge (x :: xs) (y :: ys) acc =
-            if le (x, y) then
-              merge xs (y :: ys) (x :: acc)
-            else
-              merge (x :: xs) ys (y :: acc)
-    in
-      merge part1 part2 []
-    end
-
   fun updateI i = fn z =>
   let
     fun from rinfo active pool intervals stackOff  =
diff --git a/parser.fun b/parser.fun
index 754aab6..0d2c774 100644
--- a/parser.fun
+++ b/parser.fun
@@ -272,9 +272,8 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     strlits: int list
   }
 
-  val intCompare = fn a => fn b => Int.compare (a, b)
-  val lookup = fn z => Tree.lookup intCompare z
-  val lookup2 = fn z => Tree.lookup2 intCompare z
+  val lookup = fn z => Tree.lookup compare z
+  val lookup2 = fn z => Tree.lookup2 compare z
 
   fun updateCtx (Ctx ctx) = fn z =>
   let
@@ -2621,7 +2620,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     =
     let
       val newBufId = D.length types
-      val (_, aggrTypeNames) = Tree.insert intCompare aggrTypeNames id newBufId
+      val (_, aggrTypeNames) = Tree.insert compare aggrTypeNames id newBufId
 
       val status = if isSome body then "complete" else "incomplete"
 
@@ -3347,7 +3346,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
           val () = D.push localVars
             ({ name = id, pos, t, onStack = not $ isScalar t })
 
-          val (_, scope) = Tree.insert intCompare scope id varId
+          val (_, scope) = Tree.insert compare scope id varId
         in
           (varId, id, updateCtx (Ctx ctx)
             u#localScopes (fn scs => scope :: tl scs) %)
@@ -3844,7 +3843,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     =
       let
         val localVar = { name = id, pos, t, onStack = false }
-        val (_, scope) = Tree.insert intCompare scope id curVarId
+        val (_, scope) = Tree.insert compare scope id curVarId
       in
         D.push localVars localVar;
         createLocalVars scope (curVarId + 1) ts params