Skip to content

Commit

Permalink
Add generator-specific context (#11471)
Browse files Browse the repository at this point in the history 
* [generators] add gctx.ml to lose dependency on common.ml

* also port genhl to gctx

* adapt genjs

argh

* genlua

* re-port has_feature

* neko

* python

* swf

* php

* cpp

* cleanup

* more cleanup

* final cleanup maybe
  • Loading branch information
@Simn
Simn authored Nov 22, 2024
1 parent a25a3c6 commit e253d37
Show file tree
Hide file tree
Showing 38 changed files with 520 additions and 418 deletions.
15 changes: 4 additions & 11 deletions src/codegen/codegen.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -418,13 +418,12 @@ end
Build a default safe-cast expression :
{ var $t = <e>; if( Std.is($t,<t>) ) $t else throw "Class cast error"; }
*)
let default_cast ?(vtmp="$t") com e texpr t p =
let api = com.basic in
let default_cast ?(vtmp="$t") api std e texpr t p =
let vtmp = alloc_var VGenerated vtmp e.etype e.epos in
let var = mk (TVar (vtmp,Some e)) api.tvoid p in
let vexpr = mk (TLocal vtmp) e.etype p in
let texpr = Texpr.Builder.make_typeexpr texpr p in
let is = Texpr.Builder.resolve_and_make_static_call com.std "isOfType" [vexpr;texpr] p in
let is = Texpr.Builder.resolve_and_make_static_call std "isOfType" [vexpr;texpr] p in
let enull = Texpr.Builder.make_null vexpr.etype p in
let eop = Texpr.Builder.binop OpEq vexpr enull api.tbool p in
let echeck = Texpr.Builder.binop OpBoolOr is eop api.tbool p in
Expand Down Expand Up @@ -453,12 +452,12 @@ module UnificationCallback = struct
List.map (fun e -> f e t_dynamic) el
end;;

let interpolate_code com code tl f_string f_expr p =
let interpolate_code error code tl f_string f_expr p =
let exprs = Array.of_list tl in
let i = ref 0 in
let err msg =
let pos = { p with pmin = p.pmin + !i } in
com.error msg pos
error msg pos
in
let regex = Str.regexp "[{}]" in
let rec loop m = match m with
Expand Down Expand Up @@ -487,12 +486,6 @@ let interpolate_code com code tl f_string f_expr p =
in
loop (Str.full_split regex code)

let map_source_header com f =
match Common.defined_value_safe com Define.SourceHeader with
| "" -> ()
| s -> f s


(* Static extensions for classes *)
module ExtClass = struct
let add_static_init c cf e p =
Expand Down
8 changes: 4 additions & 4 deletions src/compiler/generate.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -174,11 +174,11 @@ let generate ctx tctx ext actx =
with Not_found ->
None
in
Genswf.generate header,"swf"
Genswf.generate header com.Common.native_libs.swf_libs com.Common.flash_version,"swf"
| Neko ->
Genneko.generate,"neko"
Genneko.generate com.neko_lib_paths,"neko"
| Js ->
Genjs.generate,"js"
Genjs.generate com.js_gen,"js"
| Lua ->
Genlua.generate,"lua"
| Php ->
Expand All @@ -201,7 +201,7 @@ let generate ctx tctx ext actx =
else begin
Common.log com ("Generating " ^ name ^ ": " ^ com.file);
let t = Timer.timer ["generate";name] in
generate com;
generate (Common.to_gctx com);
t()
end
end
147 changes: 30 additions & 117 deletions src/context/common.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -348,11 +348,6 @@ class virtual abstract_hxb_lib = object(self)
method virtual get_string_pool : string -> string array option
end

type context_main = {
mutable main_class : path option;
mutable main_expr : texpr option;
}

type context = {
compilation_step : int;
mutable stage : compiler_stage;
Expand All @@ -371,15 +366,15 @@ type context = {
mutable config : platform_config;
empty_class_path : ClassPath.class_path;
class_paths : ClassPaths.class_paths;
main : context_main;
main : Gctx.context_main;
mutable package_rules : (string,package_rule) PMap.t;
mutable report_mode : report_mode;
(* communication *)
mutable print : string -> unit;
mutable error : ?depth:int -> string -> pos -> unit;
mutable error : Gctx.error_function;
mutable error_ext : Error.error -> unit;
mutable info : ?depth:int -> ?from_macro:bool -> string -> pos -> unit;
mutable warning : ?depth:int -> ?from_macro:bool -> warning -> Warning.warning_option list list -> string -> pos -> unit;
mutable warning : Gctx.warning_function;
mutable warning_options : Warning.warning_option list list;
mutable get_messages : unit -> compiler_message list;
mutable filter_messages : (compiler_message -> bool) -> unit;
Expand Down Expand Up @@ -433,6 +428,32 @@ type context = {
mutable hxb_writer_config : HxbWriterConfig.t option;
}

let to_gctx com = {
Gctx.platform = com.platform;
defines = com.defines;
basic = com.basic;
class_paths = com.class_paths;
run_command = com.run_command;
run_command_args = com.run_command_args;
warning = com.warning;
error = com.error;
print = com.print;
debug = com.debug;
file = com.file;
version = com.version;
features = com.features;
modules = com.modules;
main = com.main;
types = com.types;
resources = com.resources;
native_libs = (match com.platform with
| Jvm -> (com.native_libs.java_libs :> NativeLibraries.native_library_base list)
| Flash -> (com.native_libs.swf_libs :> NativeLibraries.native_library_base list)
| _ -> []);
include_files = com.include_files;
std = com.std;
}

let enter_stage com stage =
(* print_endline (Printf.sprintf "Entering stage %s" (s_compiler_stage stage)); *)
com.stage <- stage
Expand Down Expand Up @@ -522,9 +543,6 @@ let defines_for_external ctx =
| split -> PMap.add (String.concat "-" split) v added_underscore;
) ctx.defines.values PMap.empty

let get_es_version com =
try int_of_string (defined_value com Define.JsEs) with _ -> 0

let short_platform_name = function
| Cross -> "x"
| Js -> "js"
Expand Down Expand Up @@ -587,7 +605,7 @@ let get_config com =
(* impossible to reach. see update_platform_config *)
raise Exit
| Js ->
let es6 = get_es_version com >= 6 in
let es6 = Gctx.get_es_version com.defines >= 6 in
{
default_config with
pf_static = false;
Expand Down Expand Up @@ -927,27 +945,6 @@ let flash_versions = List.map (fun v ->
v, string_of_int maj ^ (if min = 0 then "" else "_" ^ string_of_int min)
) [9.;10.;10.1;10.2;10.3;11.;11.1;11.2;11.3;11.4;11.5;11.6;11.7;11.8;11.9;12.0;13.0;14.0;15.0;16.0;17.0;18.0;19.0;20.0;21.0;22.0;23.0;24.0;25.0;26.0;27.0;28.0;29.0;31.0;32.0]

let flash_version_tag = function
| 6. -> 6
| 7. -> 7
| 8. -> 8
| 9. -> 9
| 10. | 10.1 -> 10
| 10.2 -> 11
| 10.3 -> 12
| 11. -> 13
| 11.1 -> 14
| 11.2 -> 15
| 11.3 -> 16
| 11.4 -> 17
| 11.5 -> 18
| 11.6 -> 19
| 11.7 -> 20
| 11.8 -> 21
| 11.9 -> 22
| v when v >= 12.0 && float_of_int (int_of_float v) = v -> int_of_float v + 11
| v -> failwith ("Invalid SWF version " ^ string_of_float v)

let update_platform_config com =
match com.platform with
| CustomTarget _ ->
Expand Down Expand Up @@ -1093,90 +1090,6 @@ let hash f =
done;
if Sys.word_size = 64 then Int32.to_int (Int32.shift_right (Int32.shift_left (Int32.of_int !h) 1) 1) else !h

let url_encode s add_char =
let hex = "0123456789ABCDEF" in
for i = 0 to String.length s - 1 do
let c = String.unsafe_get s i in
match c with
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '-' | '.' ->
add_char c
| _ ->
add_char '%';
add_char (String.unsafe_get hex (int_of_char c lsr 4));
add_char (String.unsafe_get hex (int_of_char c land 0xF));
done

let url_encode_s s =
let b = Buffer.create 0 in
url_encode s (Buffer.add_char b);
Buffer.contents b

(* UTF8 *)

let to_utf8 str p =
let u8 = try
UTF8.validate str;
str;
with
UTF8.Malformed_code ->
(* ISO to utf8 *)
let b = UTF8.Buf.create 0 in
String.iter (fun c -> UTF8.Buf.add_char b (UCharExt.of_char c)) str;
UTF8.Buf.contents b
in
let ccount = ref 0 in
UTF8.iter (fun c ->
let c = UCharExt.code c in
if (c >= 0xD800 && c <= 0xDFFF) || c >= 0x110000 then Error.abort "Invalid unicode char" p;
incr ccount;
if c > 0x10000 then incr ccount;
) u8;
u8, !ccount

let utf16_add buf c =
let add c =
Buffer.add_char buf (char_of_int (c land 0xFF));
Buffer.add_char buf (char_of_int (c lsr 8));
in
if c >= 0 && c < 0x10000 then begin
if c >= 0xD800 && c <= 0xDFFF then failwith ("Invalid unicode char " ^ string_of_int c);
add c;
end else if c < 0x110000 then begin
let c = c - 0x10000 in
add ((c asr 10) + 0xD800);
add ((c land 1023) + 0xDC00);
end else
failwith ("Invalid unicode char " ^ string_of_int c)

let utf8_to_utf16 str zt =
let b = Buffer.create (String.length str * 2) in
(try UTF8.iter (fun c -> utf16_add b (UCharExt.code c)) str with Invalid_argument _ | UCharExt.Out_of_range -> ()); (* if malformed *)
if zt then utf16_add b 0;
Buffer.contents b

let utf16_to_utf8 str =
let b = Buffer.create 0 in
let add c = Buffer.add_char b (char_of_int (c land 0xFF)) in
let get i = int_of_char (String.unsafe_get str i) in
let rec loop i =
if i >= String.length str then ()
else begin
let c = get i in
if c < 0x80 then begin
add c;
loop (i + 2);
end else if c < 0x800 then begin
let c = c lor ((get (i + 1)) lsl 8) in
add c;
add (c lsr 8);
loop (i + 2);
end else
die "" __LOC__;
end
in
loop 0;
Buffer.contents b

let add_diagnostics_message ?(depth = 0) ?(code = None) com s p kind sev =
if sev = MessageSeverity.Error then com.has_error <- true;
let di = com.shared.shared_display_information in
Expand Down
6 changes: 5 additions & 1 deletion src/context/nativeLibraries.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -23,14 +23,18 @@ type native_lib_flags =
| FlagIsStd
| FlagIsExtern

class virtual ['a,'data] native_library (name : string) (file_path : string) = object(self)
class virtual native_library_base (name : string) (file_path : string) = object(self)
val mutable flags : native_lib_flags list = []

method add_flag flag = flags <- flag :: flags
method has_flag flag = List.mem flag flags

method get_name = name
method get_file_path = file_path
end

class virtual ['a,'data] native_library (name : string) (file_path : string) = object(self)
inherit native_library_base name file_path

method virtual build : path -> pos -> Ast.package option
method virtual close : unit
Expand Down
4 changes: 2 additions & 2 deletions src/context/sourcemaps.ml
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
open Extlib_leftovers
open Globals
open Common
open Gctx

(**
Characters used for base64 VLQ encoding
Expand Down Expand Up @@ -127,7 +127,7 @@ class sourcemap_writer (generated_file:string) =
output_string channel ("\"sources\":[" ^
(String.concat "," (List.map (fun s -> "\"" ^ to_url s ^ "\"") sources)) ^
"],\n");
if Common.defined com Define.SourceMapContent then begin
if Gctx.defined com Define.SourceMapContent then begin
output_string channel ("\"sourcesContent\":[" ^
(String.concat "," (List.map (fun s -> try "\"" ^ StringHelper.s_escape (Std.input_file ~bin:true s) ^ "\"" with _ -> "null") sources)) ^
"],\n");
Expand Down
Loading

0 comments on commit e253d37

Please sign in to comment.