Merge branch 'introduce-multi-stage'

Makefile

@@ -14,17 +14,25 @@ INSTDEF_YAML=$(BYTECOMP)/vminstdef.yaml
 DUNE=dune
 INSTTYPE_GEN=$(FRONTEND)/__insttype.gen.ml
 ATTYPE_GEN=$(FRONTEND)/__attype.gen.ml
+CODETYPE_GEN=$(FRONTEND)/__codetype.gen.ml
+UNLIFTCODE_GEN=$(FRONTEND)/__unliftcode.gen.ml
 VM_GEN=$(BYTECOMP)/__vm.gen.ml
-IR_GEN=$(BYTECOMP)/__ir.gen.ml
-EVAL_GEN=$(FRONTEND)/__evaluator.gen.ml
+IR_GEN_0=$(BYTECOMP)/__ir_0.gen.ml
+IR_GEN_1=$(BYTECOMP)/__ir_1.gen.ml
+EVAL_GEN_0=$(FRONTEND)/__evaluator_0.gen.ml
+EVAL_GEN_1=$(FRONTEND)/__evaluator_1.gen.ml
 PRIM_PDF_GEN=$(FRONTEND)/__primitives_pdf_mode.gen.ml
 PRIM_TEXT_GEN=$(FRONTEND)/__primitives_text_mode.gen.ml
 GENS= \
   $(INSTTYPE_GEN) \
   $(ATTYPE_GEN) \
+  $(CODETYPE_GEN) \
+  $(UNLIFTCODE_GEN) \
   $(VM_GEN) \
-  $(IR_GEN) \
-  $(EVAL_GEN) \
+  $(IR_GEN_0) \
+  $(IR_GEN_1) \
+  $(EVAL_GEN_0) \
+  $(EVAL_GEN_1) \
   $(PRIM_PDF_GEN) \
   $(PRIM_TEXT_GEN)
 GENCODE_DIR=tools/gencode
@@ -47,17 +55,29 @@ gen: $(GENS)
 $(ATTYPE_GEN): $(INSTDEF)
 	$(GENCODE) --gen-attype > $@
 
+$(CODETYPE_GEN): $(INSTDEF)
+	$(GENCODE) --gen-codetype > $@
+
+$(UNLIFTCODE_GEN):
+	$(GENCODE) --gen-unliftcode > $@
+
 $(INSTTYPE_GEN): $(INSTDEF)
 	$(GENCODE) --gen-insttype > $@
 
 $(VM_GEN): $(INSTDEF)
 	$(GENCODE) --gen-vm > $@
 
-$(IR_GEN): $(INSTDEF)
-	$(GENCODE) --gen-ir > $@
+$(IR_GEN_0): $(INSTDEF)
+	$(GENCODE) --gen-ir-0 > $@
+
+$(IR_GEN_1): $(INSTDEF)
+	$(GENCODE) --gen-ir-1 > $@
+
+$(EVAL_GEN_0): $(INSTDEF)
+	$(GENCODE) --gen-interps-0 > $@
 
-$(EVAL_GEN): $(INSTDEF)
-	$(GENCODE) --gen-interps > $@
+$(EVAL_GEN_1): $(INSTDEF)
+	$(GENCODE) --gen-interps-1 > $@
 
 $(PRIM_PDF_GEN): $(INSTDEF)
 	$(GENCODE) --gen-pdf-mode-prims > $@

gen_code.rb

@@ -60,7 +60,7 @@ def gen_text_mode_prims
   gen_prims("is-text-mode-primitive")
 end
 
-def gen_interps
+def gen_interps_0
   YAML.load_stream(ARGF.read) do |inst|
     if (inst["is-pdf-mode-primitive"] || inst["is-text-mode-primitive"]) && !default_false(inst["no-interp"]) then
       tmpn = 0
@@ -85,11 +85,11 @@ def gen_interps
       puts "  | #{inst["inst"]}(#{astargs.join ', '}) ->"
       valueidents.each do |pair|
         ident, astident = pair
-        puts "      let #{ident} = interpret env #{astident} in"
+        puts "      let #{ident} = interpret_0 env #{astident} in"
       end
       otheridents.each do |tri|
         ident, type, astident = tri
-        puts "      let #{ident} = #{FUNCPREFIX}#{type} (interpret env #{astident}) in"
+        puts "      let #{ident} = #{FUNCPREFIX}#{type} (interpret_0 env #{astident}) in"
       end
       puts "      let reducef = reduce_beta_list in" if inst["needs-reducef"]
       puts "        begin"
@@ -300,7 +300,7 @@ def gen_ml
 opt.on('--gen-ir') {|v| func = method(:gen_ircases) }
 opt.on('--gen-insttype') {|v| func = method(:gen_insttype) }
 opt.on('--gen-attype') {|v| func = method(:gen_attype) }
-opt.on('--gen-interps') {|v| func = method(:gen_interps) }
+opt.on('--gen-interps-0') {|v| func = method(:gen_interps_0) }
 opt.on('--gen-pdf-mode-prims') {|v| func = method(:gen_pdf_mode_prims) }
 opt.on('--gen-text-mode-prims') {|v| func = method(:gen_text_mode_prims) }
 opt.on('--ml') {|v| func = method(:gen_ml) }

satysfi.opam

@@ -30,7 +30,7 @@ depends: [
   "dune" {build}
   "menhir"
   "ocamlfind" {build}
-  "otfm" {= "0.3.3+satysfi"}
+  "otfm" {= "0.3.4+satysfi"}
   "ppx_deriving"
   "re" {build}
   "uutf"

src/backend/fontFormat.ml

@@ -486,6 +486,23 @@ let result_bind x f =
   | Error(e) -> Error(e :> error)
 
 
+let select_langsys gxxx_langsys script =
+  let open ResultMonad in
+    gxxx_langsys script >>= fun langsys_res ->
+    let langsys =
+      match langsys_res with
+      | (Some(langsys), _)   -> langsys
+      | (None, langsys :: _) -> langsys
+      | (None, [])           -> remains_to_be_implemented "no langsys"
+        (* temporary; should depend on the current language system *)
+    in
+    return langsys
+
+
+let select_gpos_langsys = select_langsys Otfm.gpos_langsys
+let select_gsub_langsys = select_langsys Otfm.gsub_langsys
+
+
 let get_mark_table srcpath units_per_em d =
   let script_tag = "latn" in  (* temporary; should depend on the script *)
   let mktbl = MarkTable.create () in
@@ -503,8 +520,7 @@ let get_mark_table srcpath units_per_em d =
               return ()
 
           | Some(script) ->
-              Otfm.gpos_langsys script >>= fun (langsys, _) ->
-                (* temporary; should depend on the current language system *)
+              select_gpos_langsys script >>= fun langsys ->
               Otfm.gpos_feature langsys >>= fun (_, featurelst) ->
               begin
                 match featurelst |> List.find_opt (fun gf -> Otfm.gpos_feature_tag gf = "mark") with
@@ -808,8 +824,7 @@ let get_ligature_table srcpath (submap : subset_map) (d : Otfm.decoder) : Ligatu
 
     | Some(scriptlst) ->
         pickup scriptlst (fun gs -> Otfm.gsub_script_tag gs = script_tag) `Missing_script >>= fun script ->
-        Otfm.gsub_langsys script >>= fun (langsys, _) ->
-          (* temporary; should depend on the current language system *)
+        select_gsub_langsys script >>= fun langsys ->
         Otfm.gsub_feature langsys >>= fun (_, featurelst) ->
         pickup featurelst (fun gf -> Otfm.gsub_feature_tag gf = "liga") `Missing_feature >>= fun feature ->
         () |> Otfm.gsub feature ~lig:(fun () (gid, liginfolst) ->
@@ -939,7 +954,7 @@ let get_kerning_table srcpath (d : Otfm.decoder) =
 
     | Some(scriptlst) ->
         pickup scriptlst (fun gs -> Otfm.gpos_script_tag gs = script_tag) `Missing_script >>= fun script ->
-        Otfm.gpos_langsys script >>= fun (langsys, _) ->
+        select_gpos_langsys script >>= fun langsys ->
           (* temporary; should depend on the current language system *)
         Otfm.gpos_feature langsys >>= fun (_, featurelst) ->
         pickup featurelst (fun gf -> Otfm.gpos_feature_tag gf = "kern") `Missing_feature >>= fun feature ->
@@ -2109,7 +2124,7 @@ let get_math_decoder (fontname : string) (abspath : abs_path) : (math_decoder *
 
             | Some(scriptlst) ->
                 pickup scriptlst (fun gs -> Otfm.gsub_script_tag gs = "math") `Missing_script >>= fun script_math ->
-                Otfm.gsub_langsys script_math >>= fun (langsys, _) ->
+                select_gsub_langsys script_math >>= fun langsys ->
                 Otfm.gsub_feature langsys >>= fun (_, featurelst) ->
                 pickup featurelst (fun gf -> Otfm.gsub_feature_tag gf = "ssty") `Missing_feature
           in

src/dune

@@ -39,7 +39,7 @@
 
 (rule
  (targets types.ml)
- (deps    (:src types.cppo.ml) __insttype.gen.ml __attype.gen.ml)
+ (deps    (:src types.cppo.ml) __insttype.gen.ml __attype.gen.ml __codetype.gen.ml __unliftcode.gen.ml)
  (action  (run %{bin:cppo} %{src} -o %{targets})))
 
 (rule
@@ -49,12 +49,12 @@
 
 (rule
  (targets ir.ml)
- (deps    (:src ir.cppo.ml) __ir.gen.ml)
+ (deps    (:src ir.cppo.ml) __ir_0.gen.ml __ir_1.gen.ml)
  (action  (run %{bin:cppo} %{src} -o %{targets})))
 
 (rule
  (targets evaluator.ml)
- (deps    (:src evaluator.cppo.ml) __evaluator.gen.ml)
+ (deps    (:src evaluator.cppo.ml) __evaluator_0.gen.ml __evaluator_1.gen.ml)
  (action  (run %{bin:cppo} %{src} -o %{targets})))
 
 (rule

src/frontend/bytecomp/bytecomp.ml

@@ -2,27 +2,41 @@
 open MyUtil
 open LengthInterface
 open Types
+open EvalUtil
 
 
-let compile_and_exec env ast =
-  let (ir, env) = Ir.transform_ast env ast in
-  let code = Compiler.compile ir [] in
-  (*
+let compile_and_exec_0 (env : environment) (ast : abstract_tree) : syntactic_value =
+  let (ir, env) = Ir.transform_ast_0 env ast in
+  let instrs = Compiler.compile ir [] in
+(*
   Format.printf "IR:\n%s\n" (show_ir ir);  (* for debug *)
   List.iter (fun inst -> Format.printf "%s\n" (show_instruction inst)) code;  (* for debug *)
-  *)
-    Vm.exec [] (env, []) code []
+*)
+  Vm.exec [] (env, []) instrs []
 
-let compile_environment env =
+
+let compile_environment (env : environment) : unit =
   let (binds, _) = env in
-    binds |> EvalVarIDMap.iter (fun evid loc ->
-        match !loc with
-        | PrimitiveWithEnvironment(parbr, env1, arity, astf) ->
-          begin
-            match compile_and_exec env (Function([], parbr)) with
-            | CompiledFuncWithEnvironment([], _, _, framesize, body, env1) ->
-              loc := CompiledPrimitiveWithEnvironment(arity, [], framesize, body, env1, astf)
-            | _ -> ()
-          end
-        | _ -> ()
-      )
+  binds |> EvalVarIDMap.iter (fun evid loc ->
+    match !loc with
+    | PrimitiveClosure(parbr, env1, arity, astf) ->
+        begin
+          match compile_and_exec_0 env (Function([], parbr)) with
+          | CompiledClosure([], _, _, framesize, body, env1) ->
+              loc := CompiledPrimitiveClosure(arity, [], framesize, body, env1, astf)
+          | _ ->
+              ()
+        end
+
+    | _ ->
+        ()
+  )
+
+
+let compile_and_exec_1 (env : environment) (ast : abstract_tree) : code_value =
+  let (ir, env) = Ir.transform_ast_1 env ast in
+  let instrs = Compiler.compile ir [] in
+  let value = Vm.exec [] (env, []) instrs [] in
+  match value with
+  | CodeValue(cv) -> cv
+  | _             -> report_bug_value "compile_and_exec_1: not a CodeValue(...)" value