Optimize compiler code generation

src/boot/lib/intrinsics.ml

@@ -282,6 +282,13 @@ module Mseq = struct
     let of_ustring = of_ustring_rope
 
     let of_utf8 s = Ustring.from_utf8 s |> of_ustring
+
+    let of_ascii_string_rope s = Rope (Rope.Convert.of_ascii_string_array s)
+
+    let of_ascii_string_list s =
+      List (List.map Char.code (List.of_seq (String.to_seq s)))
+
+    let of_ascii_string = of_ascii_string_rope
   end
 end
 

src/boot/lib/intrinsics.mli

@@ -190,6 +190,12 @@ module Mseq : sig
 
     val of_utf8 : string -> int t
 
+    val of_ascii_string_rope : string -> int t
+
+    val of_ascii_string_list : string -> int t
+
+    val of_ascii_string : string -> int t
+
     (* Complexity:
      * rope (?): O(n*k), where n is the length of the sequence, k is the
      *   complexity of the function (flattens)

src/boot/lib/rope.ml

@@ -256,4 +256,10 @@ module Convert = struct
   let to_ustring_array (s : int t) : ustring = array2ustring (to_array_array s)
 
   let of_ustring_array (u : ustring) : int t = of_array_array (ustring2array u)
+
+  let of_ascii_string_array (s : string) : int t =
+    let a =
+      Array.init (String.length s) (fun i -> Char.code (String.get s i))
+    in
+    of_array_array a
 end

src/boot/lib/rope.mli

@@ -119,4 +119,8 @@ module Convert : sig
   val of_ustring_array : ustring -> int t
   (** [Rope.Convert.of_ustring_* u] converts the ustring [u] into a rope of
       integers. *)
+
+  val of_ascii_string_array : string -> int t
+  (** [Rope.Convert.of_ascii_string_* s] converts the string [s] consisting of
+      ASCII characters into a rope of integers. *)
 end

src/stdlib/mexpr/shallow-patterns.mc

@@ -776,6 +776,7 @@ lang LowerNestedPatterns = CollectBranches + ShallowBase
       match target with Left expr then
         let targetId = nameSym "_target" in
         let elseId = nameSym "_elsBranch" in
+        let els = lowerAll fallthrough in
         bindall_ [
           nulet_ elseId (ulam_ "" (lowerAll fallthrough)),
           nulet_ targetId (lowerAll expr)]

src/stdlib/ocaml/generate-env.mc

@@ -4,12 +4,14 @@ include "ocaml/external-includes.mc"
 include "mexpr/cmp.mc"
 
 type GenerateEnv = {
+  variants : Map Name (Map Name (use Ast in Type)),
   constrs : Map Name (use Ast in Type),
   records : Map (Map SID (use Ast in Type)) Name,
   exts : Map Name [ExternalImpl]
 }
 
 let emptyGenerateEnv = use MExprCmp in {
+  variants = mapEmpty nameCmp,
   constrs = mapEmpty nameCmp,
   records = mapEmpty (mapCmp cmpType),
   exts = mapEmpty nameCmp

src/stdlib/ocaml/generate.mc

@@ -147,7 +147,6 @@ lang OCamlMatchGenerate = MExprAst + OCamlAst + OCamlTopGenerate
             -> (acc, Expr)
   sem collectNestedMatches env isNestedPat acc addMatchCase =
   | t ->
-    let t : MatchRecord = t in
     -- We assume that the target is a variable because otherwise there is no
     -- easy way to determine that the expressions are the same, as we don't
     -- have access to the outer scope where variables have been defined.
@@ -231,7 +230,7 @@ lang OCamlMatchGenerate = MExprAst + OCamlAst + OCamlTopGenerate
     let n2 = length postfix in
     let targetId = nameSym "_target" in
     let lenId = nameSym "n" in
-    let cond = _isLengthAtLeast (nvar_ targetId) (addi_ (int_ n1) (int_ n2)) in
+    let cond = _isLengthAtLeast (nvar_ targetId) (int_ (addi n1 n2)) in
     -- NOTE(larshum, 2022-12-20): Add a binding for each of the non-wildcard
     -- patterns in the sequence pattern, starting with the postfix and prefix,
     -- followed by the middle.
@@ -240,7 +239,7 @@ lang OCamlMatchGenerate = MExprAst + OCamlAst + OCamlTopGenerate
       mapi
         (lam i. lam p. (p, subi_ (nvar_ lenId) (int_ (addi i 1))))
         (reverse postfix) in
-    let thn =
+    match
       let thn = generate env t.thn in
       let thn =
         foldl
@@ -251,14 +250,17 @@ lang OCamlMatchGenerate = MExprAst + OCamlAst + OCamlTopGenerate
       match middle with PName id then
         let midExpr =
           subsequence_ (nvar_ targetId) (int_ n1)
-            (subi_ (nvar_ lenId) (addi_ (int_ n1) (int_ n2)))
+            (subi_ (nvar_ lenId) (int_ (addi n1 n2)))
         in
-        bind_ (nulet_ id midExpr) thn
+        (bind_ (nulet_ id midExpr) thn, true)
+      else (thn, not (null postfixIndexedPats))
+    with (thn, usesLen) in
+    let thn =
+      if usesLen then bind_ (nulet_ lenId (length_ (nvar_ targetId))) thn
       else thn
     in
-    bindall_ [
-      nulet_ targetId (objMagic (generate env t.target)),
-      nulet_ lenId (length_ (nvar_ targetId))]
+    bind_
+      (nulet_ targetId (objMagic (generate env t.target)))
       (_if cond thn (generate env t.els))
   | TmMatch (t & {pat = PatRecord {bindings = bindings, ty = ty}}) ->
     if mapIsEmpty bindings then
@@ -377,62 +379,109 @@ lang OCamlMatchGenerate = MExprAst + OCamlAst + OCamlTopGenerate
     bind_
       (nulet_ targetId (objMagic (generate env t.target)))
       (_if (null_ (nvar_ targetId)) (generate env t.els) thn)
-  | TmMatch ({target = TmVar _, pat = PatCon pc, els = TmMatch em} & t) ->
+  | TmMatch ({target = TmVar _, pat = PatCon pc} & t) ->
     match collectNestedMatchesByConstructor env t with (arms, defaultCase) in
-		-- Assign the term of the final else-branch to a variable so that we
-		-- don't introduce unnecessary code duplication (the default case could
-		-- be large).
-		let defaultCaseName = nameSym "defaultCase" in
-		let defaultCaseVal = ulam_ "" (generate env defaultCase) in
-		let defaultCaseLet = nulet_ defaultCaseName defaultCaseVal in
+    -- Assign the term of the final else-branch to a variable so that we
+    -- don't introduce unnecessary code duplication (the default case could
+    -- be large).
+    let defaultCaseName = nameSym "defaultCase" in
+    let defaultCaseVal = ulam_ "" (generate env defaultCase) in
+    let defaultCaseLet = nulet_ defaultCaseName defaultCaseVal in
+    let toNestedMatch = lam target : Expr. lam patExpr : [(Pat, Expr)].
+      assocSeqFold
+        (lam acc. lam pat. lam thn. match_ target pat thn acc)
+        (app_ (nvar_ defaultCaseName) uunit_)
+        patExpr
+    in
+    let f = lam arm : (Name, [(Pat, Expr)]).
+      match mapLookup arm.0 env.constrs with Some argTy then
+        let patVarName = nameSym "x" in
+        let target =
+          match argTy with TyRecord _ then t.target
+          else nvar_ patVarName
+        in
+        let isUnit = match argTy with TyRecord {fields = fields} then
+          mapIsEmpty fields else false in
+        let pat = if isUnit
+          then OPatCon {ident = arm.0, args = []}-- TODO(vipa, 2021-05-12): this will break if there actually is an inner pattern that wants to look at the unit
+          else OPatCon {ident = arm.0, args = [npvar_ patVarName]} in
+        let innerPatternTerm = toNestedMatch (withType argTy (objMagic target)) arm.1 in
+        (pat, generate env innerPatternTerm)
+      else
+        let msg = join [
+          "Unknown constructor referenced in nested match expression: ",
+          nameGetStr arm.0
+        ] in
+        errorSingle [t.info] msg
+    in
 
-		let toNestedMatch = lam target : Expr. lam patExpr : [(Pat, Expr)].
-			assocSeqFold
-				(lam acc. lam pat. lam thn. match_ target pat thn acc)
-				(app_ (nvar_ defaultCaseName) uunit_)
-				patExpr
-		in
-		let f = lam arm : (Name, [(Pat, Expr)]).
-			match mapLookup arm.0 env.constrs with Some argTy then
-				let patVarName = nameSym "x" in
-				let target =
-					match argTy with TyRecord _ then t.target
-					else nvar_ patVarName
-				in
-				let isUnit = match argTy with TyRecord {fields = fields} then
-					mapIsEmpty fields else false in
-				let pat = if isUnit
-					then OPatCon {ident = arm.0, args = []}-- TODO(vipa, 2021-05-12): this will break if there actually is an inner pattern that wants to look at the unit
-					else OPatCon {ident = arm.0, args = [npvar_ patVarName]} in
-				let innerPatternTerm = toNestedMatch (withType argTy (objMagic target)) arm.1 in
-				(pat, generate env innerPatternTerm)
-			else
-				let msg = join [
-					"Unknown constructor referenced in nested match expression: ",
-					nameGetStr arm.0
-				] in
-				errorSingle [t.info] msg
-		in
-		let flattenedMatch =
-			_omatch_ (objMagic (generate env t.target))
-				(snoc
-						(map f (mapBindings arms))
-						(pvarw_, (app_ (nvar_ defaultCaseName) uunit_)))
-		in bind_ defaultCaseLet flattenedMatch
+    let cases = map f (mapBindings arms) in
+    let target = objMagic (generate env t.target) in
+    if and (casesCoverAllConstructorsOfTarget env cases t)
+           (not (casesReferToDefault env defaultCaseName cases)) then
+      _omatch_ target cases
+    else
+      let flattenedMatch =
+        _omatch_ target (snoc cases (pvarw_, app_ (nvar_ defaultCaseName) uunit_))
+      in bind_ defaultCaseLet flattenedMatch
   | TmMatch t -> generateMatchBaseCase env (TmMatch t)
+
+  sem casesCoverAllConstructorsOfTarget : GenerateEnv -> [(Pat, Expr)] -> MatchRecord -> Bool
+  sem casesCoverAllConstructorsOfTarget env arms =
+  | t ->
+    -- NOTE(larshum, 2025-10-20): The type of the target seems to have been
+    -- lost at this stage, but the pattern contains the correct type
+    -- information.
+    let ty = unwrapType (tyPat t.pat) in
+    match ty with TyCon {ident = ident} then
+      match mapLookup ident env.variants with Some constrs then
+        eqi (length arms) (mapSize constrs)
+      else errorSingle [infoPat t.pat] "env.variants lookup failed"
+    else errorSingle [infoPat t.pat] "expected TyCon"
+
+  sem casesReferToDefault : GenerateEnv -> Name -> [(Pat, Expr)] -> Bool
+  sem casesReferToDefault env id =
+  | cases ->
+    let caseRefersToDefault = lam c.
+      match c with (_, e) in
+      containsIdentifier id false e
+    in
+    any caseRefersToDefault cases
+
+  sem containsIdentifier : Name -> Bool -> Expr -> Bool
+  sem containsIdentifier id acc =
+  | TmVar t -> or acc (nameEq t.ident id)
+  | e -> if acc then true else sfold_Expr_Expr (containsIdentifier id) false e
 end
 
 lang OCamlGenerate = MExprAst + OCamlAst + OCamlTopGenerate + OCamlMatchGenerate
   sem generate (env : GenerateEnv) =
   | TmSeq {tms = tms} ->
+    let toAsciiString = lam tms.
+      let isAsciiChar = lam c.
+        and (geqi (char2int c) 0) (lti (char2int c) 128)
+      in
+      recursive let helper = lam tm.
+        match tm with TmConst {val = CChar {val = c}} then
+          if isAsciiChar c then Some c
+          else None ()
+        else None ()
+      in
+      optionMapM helper tms
+    in
     -- NOTE(vipa, 2021-05-14): Assume that explicit Consts have the same type, since the program wouldn't typecheck otherwise
     let innerGenerate = lam tm.
       let tm = generate env tm in
       match tm with TmConst _ then tm
       else objMagic tm in
-    app_
-      (objMagic (OTmVarExt {ident = (intrinsicOpSeq "Helpers.of_array")}))
-      (OTmArray {tms = map innerGenerate tms})
+    match toAsciiString tms with Some s then
+      app_
+        (objMagic (OTmVarExt {ident = intrinsicOpSeq "Helpers.of_ascii_string"}))
+        (OTmString {text = s})
+    else
+      app_
+        (objMagic (OTmVarExt {ident = intrinsicOpSeq "Helpers.of_array"}))
+        (OTmArray {tms = map innerGenerate tms})
   | TmRecord t ->
     if mapIsEmpty t.bindings then TmRecord t
     else
@@ -554,7 +603,7 @@ lang OCamlGenerate = MExprAst + OCamlAst + OCamlTopGenerate + OCamlMatchGenerate
     let msg = "Reached a never term, which should be impossible in a well-typed program." in
     TmApp {
       lhs = OTmVarExt {ident = "failwith"},
-      rhs = OTmString {text = escapeString (infoErrorString t.info msg)},
+      rhs = OTmString {text = infoErrorString t.info msg},
       ty = t.ty,
       info = NoInfo ()
     }
@@ -625,7 +674,8 @@ let _typeLiftEnvToGenerateEnv = use MExprAst in
       else error "Type lifting error"
     else match ty with TyVariant {constrs = constrs} then
       let constrs = mapMap unwrapType constrs in
-      {env with constrs = mapUnion env.constrs constrs}
+      {env with constrs = mapUnion env.constrs constrs,
+                variants = mapInsert name constrs env.variants}
     else
       env
   in

src/stdlib/ocaml/pprint.mc

@@ -625,7 +625,7 @@ lang OCamlPrettyPrint =
                     "with", join arms])
       else never
     else never
-  | OTmString t -> (env, join ["\"", t.text, "\""])
+  | OTmString t -> (env, join ["\"", escapeString t.text, "\""])
   | OTmLabel {label = label, arg = arg} ->
     match pprintCode indent env arg with (env, arg) then
       (env, join ["~", label, ":(", arg, ")"])