From ba83a03d6cdf9d01b1bbb6863a4e1415da68aaa0 Mon Sep 17 00:00:00 2001 From: mzp Date: Tue, 8 Sep 2009 22:31:43 +0900 Subject: [PATCH] add swflib --- OMakefile | 2 +- swflib/OMakefile | 50 +++++++ swflib/abc.ml | 264 +++++++++++++++++++++++++++++++++++ swflib/abc.mli | 114 +++++++++++++++ swflib/abcTest.ml | 174 +++++++++++++++++++++++ swflib/asm.ml | 369 +++++++++++++++++++++++++++++++++++++++++++++++++ swflib/asm.mli | 25 ++++ swflib/asmTest.ml | 241 ++++++++++++++++++++++++++++++++ swflib/bytes.ml | 127 +++++++++++++++++ swflib/bytes.mli | 67 +++++++++ swflib/bytesTest.ml | 83 +++++++++++ swflib/cpool.ml | 174 +++++++++++++++++++++++ swflib/cpool.mli | 39 ++++++ swflib/cpoolTest.ml | 76 ++++++++++ swflib/gen_inst.ml | 123 +++++++++++++++++ swflib/iSpec.ml | 65 +++++++++ swflib/instruction.mlp | 30 ++++ swflib/instruction.txt | 114 +++++++++++++++ swflib/label.ml | 14 ++ swflib/label.mli | 6 + swflib/revList.ml | 33 +++++ swflib/revList.mli | 7 + swflib/revListTest.ml | 37 +++++ 23 files changed, 2233 insertions(+), 1 deletion(-) create mode 100644 swflib/OMakefile create mode 100644 swflib/abc.ml create mode 100644 swflib/abc.mli create mode 100644 swflib/abcTest.ml create mode 100644 swflib/asm.ml create mode 100644 swflib/asm.mli create mode 100644 swflib/asmTest.ml create mode 100644 swflib/bytes.ml create mode 100644 swflib/bytes.mli create mode 100644 swflib/bytesTest.ml create mode 100644 swflib/cpool.ml create mode 100644 swflib/cpool.mli create mode 100644 swflib/cpoolTest.ml create mode 100644 swflib/gen_inst.ml create mode 100644 swflib/iSpec.ml create mode 100644 swflib/instruction.mlp create mode 100644 swflib/instruction.txt create mode 100644 swflib/label.ml create mode 100644 swflib/label.mli create mode 100644 swflib/revList.ml create mode 100644 swflib/revList.mli create mode 100644 swflib/revListTest.ml diff --git a/OMakefile b/OMakefile index bce3559..12a9070 100644 --- a/OMakefile +++ b/OMakefile @@ -232,7 +232,7 @@ config.ml: ################################################ OCAMLINCLUDES += $(ROOT) -.SUBDIRS: scm xml driver base lib camlp4 +.SUBDIRS: scm xml driver base lib camlp4 swflib # ------------------------------ # all diff --git a/swflib/OMakefile b/swflib/OMakefile new file mode 100644 index 0000000..7223814 --- /dev/null +++ b/swflib/OMakefile @@ -0,0 +1,50 @@ + +# build +OCAMLPACKS[] = + extlib + xml-light + oUnit + str + +FILES[] = + bytes + label + abc + cpool + revList + instruction + iSpec + asm +UseCamlp4(pa_openin pa_oo) +PROGRAM=../swflib + +OCAMLINCLUDES += $(ROOT)/base +OCAML_LIBS += $(ROOT)/base/base + + +OCAMLOPT = ocamlopt -for-pack $(capitalize $(basename $(PROGRAM))) +OCAMLOPTLINK= ocamlopt + +OCamlProgram(gen_inst,gen_inst) + +# test +OUnitTest(bytes , bytes label) +OUnitTest(abc , abc label bytes) +OUnitTest(revList , revList) +OUnitTest(cpool , cpool revList) +OUnitTest(asm , asm cpool revList bytes) + +# phony +.PHONY: clean +.DEFAULT: $(MyOCamlPackage $(PROGRAM), $(FILES)) +match_body.h: gen_inst$(EXE) instruction.txt + ./gen_inst$(EXE) -m < instruction.txt > $@ + +opcode.h: gen_inst$(EXE) instruction.txt + ./gen_inst$(EXE) -t < instruction.txt > $@ + +.SCANNER: instruction.ml : instruction.mlp + grep "#include \"" $< | sed 's/.*"\(.*\)".*/'$@': \1/' + +clean: + ocaml-clean opcode.h match_body.h instruction.ml gen_inst$(EXE) diff --git a/swflib/abc.ml b/swflib/abc.ml new file mode 100644 index 0000000..2a52a46 --- /dev/null +++ b/swflib/abc.ml @@ -0,0 +1,264 @@ +open Base +open Bytes + +(* ---------------------------------------- + Type + ---------------------------------------- *) +type namespace = { + kind:int; namespace_name:int +} + +type namespace_set = int list + +type multiname = + QName of int * int + | Multiname of int * int + +type cpool = { + int: int list; + uint: int list; + double: float list; + string: string list; + namespace: namespace list; + namespace_set: namespace_set list; + multiname: multiname list; +} + +type method_info = { + params: int list; + return: int; + method_name: int; + method_flags: int; +} +type trait_attr = + ATTR_Final | ATTR_Override | ATTR_Medadata + +type trait_data = + SlotTrait of int * int * int * int + | MethodTrait of int * int * trait_attr list + | GetterTrait of int * int * trait_attr list + | SetterTrait of int * int * trait_attr list + | ClassTrait of int * int + | FunctionTrait of int * int + | ConstTrait of int * int * int * int + +type trait = { + trait_name:int; + data:trait_data +} + +type script = { + init: int; + script_traits: trait list +} + +type class_info = { + cinit: int; + class_traits: trait list +} + +type class_flag = + Sealed | Final | Interface | ProtectedNs of int + +type instance_info={ + instance_name: int; + super_name: int; + instance_flags: class_flag list; + interface: int list; + iinit: int; + instance_traits:trait list +} + +type method_body = { + method_sig: int; + max_stack: int; + local_count: int; + init_scope_depth: int; + max_scope_depth: int; + code: Bytes.t list; + exceptions: int list; + method_traits: trait list +} + +type abc = { + cpool: cpool; + method_info: method_info list; + metadata: int list; + classes: class_info list; + instances: instance_info list; + scripts: script list; + method_bodies: method_body list +} + +(* ---------------------------------------- + Utils + ---------------------------------------- *) +let dummy _ = [u30 0] + +let array f xs = + let ys = + HList.concat_map f xs in + (u30 (List.length xs))::ys + +(* ---------------------------------------- + Constant Pool + ---------------------------------------- *) +let empty_cpool = + { int=[]; uint=[]; double=[]; string=[]; namespace=[]; namespace_set=[]; multiname=[]} + +let cpool_map f xs = + let ys = + HList.concat_map f xs in + let size = + 1+ List.length xs in + (u30 size)::ys + +let of_string str = + array (fun c -> [u8 (Char.code c)]) @@ ExtString.String.explode str + +let of_ns {kind=kind;namespace_name=name} = + [u8 kind; u30 name] + +let of_ns_set = + array (fun ns->[u30 ns]) + +let of_multiname = + function + QName (ns,name) -> + [u8 0x07;u30 ns; u30 name] + | Multiname (name,ns_set) -> + [u8 0x09;u30 name; u30 ns_set] + +let of_cpool cpool = + List.concat [ + cpool_map (fun x->[s32 x]) cpool.int; + cpool_map (fun x->[u32 x]) cpool.uint; + cpool_map (fun x->[d64 x]) cpool.double; + cpool_map of_string cpool.string; + cpool_map of_ns cpool.namespace; + cpool_map of_ns_set cpool.namespace_set; + cpool_map of_multiname cpool.multiname; + ] + +(* ---------------------------------------- + Trait + ---------------------------------------- *) +let of_trait_attrs attrs = + let of_attr attr = List.assoc attr [ATTR_Final ,0x01; + ATTR_Override,0x02; + ATTR_Medadata,0x04] in + List.fold_left (lor) 0 @@ List.map of_attr attrs + +(* kind field contains two four-bit fields. The lower four bits determine the kind of this trait. + The upper four bits comprise a bit vector providing attributes of the trait. *) +let kind attr kind = + u8 @@ ((of_trait_attrs attr) lsl 4) lor kind + +let of_trait_body = + function + SlotTrait (slot_id,type_name,vindex,vkind) -> + if vindex = 0 then + [u8 0;u30 slot_id; u30 type_name;u30 0] + else + [u8 0;u30 slot_id; u30 type_name;u30 vindex;u8 vkind] + | MethodTrait (disp_id,meth,attrs) -> + [kind attrs 1;u30 disp_id; u30 meth] + | GetterTrait (disp_id,meth,attrs) -> + [kind attrs 2;u30 disp_id; u30 meth] + | SetterTrait (disp_id,meth,attrs) -> + [kind attrs 3;u30 disp_id; u30 meth] + | ClassTrait (slot_id,classi) -> + [u8 4; u30 slot_id; u30 classi] + | FunctionTrait (slot_id,func) -> + [u8 5;u30 slot_id; u30 func] + | ConstTrait (slot_id,type_name,vindex,vkind) -> + if vindex = 0 then + [u8 6;u30 slot_id; u30 type_name;u30 0] + else + [u8 6;u30 slot_id; u30 type_name;u30 vindex;u8 vkind] + +let of_trait {trait_name=name; data=data} = + List.concat [[u30 name]; + of_trait_body data] + +(* ---------------------------------------- + Other + ---------------------------------------- *) +let of_method_info info = + List.concat [[u30 (List.length info.params); + u30 info.return]; + List.map u30 info.params; + [u30 info.method_name; + u8 info.method_flags]] + +let of_script {init=init; script_traits=traits} = + (u30 init)::array of_trait traits + +let of_method_body body = + let t = + Label.make () in + List.concat [ + [ u30 body.method_sig; + u30 body.max_stack; + u30 body.local_count; + u30 body.init_scope_depth; + u30 body.max_scope_depth]; + [backpatch 0 (fun addr map -> to_int_list [u30 (find map t - addr)])]; + body.code; + [label t]; + dummy body.exceptions; + array of_trait body.method_traits] + +let of_class {cinit=init; class_traits=traits} = + List.concat [ + [u30 init]; + array of_trait traits] + +let of_instance {instance_name = name; + super_name = sname; + instance_flags = flags; + interface = inf; + iinit = init; + instance_traits = traits} = + let flag = + function + Sealed -> 0x01 + | Final -> 0x02 + | Interface -> 0x04 + | ProtectedNs _ -> 0x08 in + let flags' = + List.fold_left (fun x y -> x lor (flag y)) 0 flags in + let ns = + flags + +> HList.concat_map begin function + ProtectedNs ns -> [u30 ns] + | Sealed | Final | Interface -> [] + end + +> function [] -> [] | x::_ -> [x] in + List.concat [ + [u30 name; + u30 sname; + u8 flags']; + ns; + array (fun x -> [u30 x]) inf; + [u30 init]; + array of_trait traits] + + +let to_bytes { cpool=cpool; + method_info=info; + metadata=metadata; + classes=classes; + instances=instances; + scripts=scripts; + method_bodies=bodies; } = + List.concat [ + [ u16 16; u16 46; ]; + of_cpool cpool; + array of_method_info info; + dummy metadata; + array of_instance instances; + HList.concat_map of_class classes; + array of_script scripts; + array of_method_body bodies + ] diff --git a/swflib/abc.mli b/swflib/abc.mli new file mode 100644 index 0000000..74fd80f --- /dev/null +++ b/swflib/abc.mli @@ -0,0 +1,114 @@ +(** + ABC(Action Script Bytecode) format. + + Provide the type of ABC and encoding function. + + @author mzp + @see AVM2 Overview(pdf) 4.2 abcFile - 4.10 Script +*) + +type namespace = { + kind:int; namespace_name:int +} + +type namespace_set = int list + +type multiname = + QName of int * int + | Multiname of int * int + +type cpool = { + int: int list; + uint: int list; + double: float list; + string: string list; + namespace: namespace list; + namespace_set: namespace_set list; + multiname: multiname list; +} + +type method_info = { + params: int list; + return: int; + method_name: int; + method_flags:int; +} + +type trait_attr = + ATTR_Final | ATTR_Override | ATTR_Medadata + +type trait_data = + SlotTrait of int * int * int * int + | MethodTrait of int * int * trait_attr list + | GetterTrait of int * int * trait_attr list + | SetterTrait of int * int * trait_attr list + | ClassTrait of int * int + | FunctionTrait of int * int + | ConstTrait of int * int * int * int + +type trait = { + trait_name:int; + data:trait_data +} + +type script = { + init: int; + script_traits: trait list +} + +type class_info = { + cinit: int; + class_traits: trait list +} + +type class_flag = + Sealed | Final | Interface | ProtectedNs of int + +type instance_info={ + instance_name: int; + super_name: int; + instance_flags: class_flag list; + interface: int list; + iinit: int; + instance_traits:trait list +} + +type method_body = { + method_sig: int; + max_stack: int; + local_count: int; + init_scope_depth: int; + max_scope_depth: int; + code: Bytes.t list; + exceptions: int list; + method_traits: trait list +} + +type abc = { + cpool: cpool; + method_info: method_info list; + metadata: int list; + classes: class_info list; + instances: instance_info list; + scripts: script list; + method_bodies: method_body list +} + +(* cpool *) +val empty_cpool : cpool + +(** + Byte serializer for {!Abc}. +*) +val to_bytes : abc -> Bytes.t list + +(**{6 Debug only}*) + +val of_cpool : cpool -> Bytes.t list +val of_method_info : method_info -> Bytes.t list +val of_script : script -> Bytes.t list +val of_trait : trait -> Bytes.t list +val of_method_body : method_body -> Bytes.t list + +val of_class : class_info -> Bytes.t list +val of_instance : instance_info -> Bytes.t list diff --git a/swflib/abcTest.ml b/swflib/abcTest.ml new file mode 100644 index 0000000..22589a9 --- /dev/null +++ b/swflib/abcTest.ml @@ -0,0 +1,174 @@ +open Base +open Abc +open OUnit +open Bytes + +let cpool = + { empty_cpool with + int = [~-1;42]; + uint = [42]; + string = ["abc"]; + namespace = [{kind=0x08; namespace_name=1}]; + namespace_set = [[1;2]]; + multiname=[QName (0,1);Multiname (2,3)] } + +let info = + { params=[]; return=1; method_name=2; method_flags=3 } + +let body = + { method_sig=1; + max_stack=2; + local_count=3; + init_scope_depth=4; + max_scope_depth=5; + code=[u8 1;u8 2;u8 3;s24 1]; + exceptions=[]; + method_traits=[] } + +let script = + {init=0x7F; script_traits=[]} + +let ok x y = + OUnit.assert_equal (to_int_list x) (to_int_list y) + +let _ = + ("abc.ml" >::: + ["of_script test" >:: + (fun () -> + ok [u30 0x7F; u30 0] @@ of_script script); + "of_trait test" >:: + (fun () -> + ok [u30 1;u8 0; u30 1; u30 2; u30 3; u8 4; ] @@ + of_trait {trait_name=1; data=SlotTrait (1,2,3,4)}; + ok [u30 1;u8 0; u30 1; u30 2; u30 0] @@ + of_trait {trait_name=1; data=SlotTrait (1,2,0,4)}; + ok [u30 1;u8 1; u30 1; u30 2] @@ + of_trait {trait_name=1; data=MethodTrait (1,2,[])}; + ok [u30 1;u8 2; u30 1; u30 2] @@ + of_trait {trait_name=1; data=GetterTrait (1,2,[])}; + ok [u30 1;u8 3; u30 1; u30 2] @@ + of_trait {trait_name=1; data=SetterTrait (1,2,[])}; + ok [u30 1;u8 4; u30 1; u30 2] @@ + of_trait {trait_name=1; data=ClassTrait (1,2)}; + ok [u30 1;u8 5; u30 1; u30 2] @@ + of_trait {trait_name=1; data=FunctionTrait (1,2)}; + ok [u30 1;u8 6; u30 1; u30 2; u30 3; u8 4] @@ + of_trait {trait_name=1; data=ConstTrait (1,2,3,4)}; + ok [u30 1;u8 6; u30 1; u30 2; u30 0] @@ + of_trait {trait_name=1; data=ConstTrait (1,2,0,4)}); + "of_method_info test" >:: + (fun () -> + ok + [u30 0; u30 1; u30 2; u8 3] @@ + of_method_info info); + "of_method_body test" >:: + (fun () -> + ok [u30 1; + u30 2; + u30 3; + u30 4; + u30 5; + u30 6; u8 1; u8 2; u8 3;s24 1; + u30 0; + u30 0] @@ + of_method_body body); + "of_cpool test" >:: + (fun () -> + ok [u30 1;(* int *) + u30 1;(* uint *) + u30 1;(* double *) + u30 1;(* string *) + u30 1;(* ns *) + u30 1;(* ns_set *) + u30 1 (* mname *)] @@ + of_cpool empty_cpool; + ok [u30 3; s32 ~-1; s32 42; (* int *) + u30 2; u32 42; (* uint *) + u30 1; (* double *) + u30 2; u30 3; u8 0x61; u8 0x62; u8 0x63; (* string *) + u30 2; u8 0x08; u30 1; (* ns *) + u30 2; u30 2; u30 1; u30 2; (* ns_set *) + u30 3; u8 0x07; u30 0; u30 1; + u8 0x09; u30 2; u30 3; (* mname *)] @@ + of_cpool cpool); + "of_class test" >:: + (fun () -> + ok [u30 10; u30 0] @@ + of_class {cinit=10; class_traits=[]}); + "of_instance test" >:: + (fun () -> + ok [u30 1; (* name *) + u30 2; (* super name *) + u8 3; (* flags *) + u30 4; (* interface count *) + u30 1; u30 2; u30 3; u30 4; (* interface *) + u30 5; (* iinit *) + u30 0; (* traits count *) ] @@ + of_instance { + instance_name=1; + super_name=2; + instance_flags=[Sealed;Final]; + interface=[1;2;3;4]; + iinit=5; + instance_traits=[]}); + "of_instance protected ns" >:: + (fun () -> + ok [u30 1; (* name *) + u30 2; (* super name *) + u8 8; (* flags *) + u30 1; (* protected ns *) + u30 4; (* interface count *) + u30 1; u30 2; u30 3; u30 4; (* interface *) + u30 5; (* iinit *) + u30 0; (* traits count *) ] @@ + of_instance { + instance_name=1; + super_name=2; + instance_flags=[ProtectedNs 1]; + interface=[1;2;3;4]; + iinit=5; + instance_traits=[]}); + "spimle abc" >:: + (fun () -> + ok [u16 16; u16 46;(* version *) + u30 1; u30 1; u30 1; u30 1; u30 1; u30 1; u30 1; + (* cpool *) + u30 0; (* info *) + u30 0; (* meta *) + u30 0; (* class *) + u30 0; (* script *) + u30 0; (* body *) ] @@ + to_bytes { + cpool = empty_cpool; + method_info = []; + metadata = []; + classes = []; + instances = []; + scripts = []; + method_bodies = []}); + "full abc" >:: + (fun () -> + ok (List.concat [ + (* version *) [ u16 16; u16 46]; + (* cpool *) of_cpool {empty_cpool with string=["foo"] }; + (* info *) [ u30 1]; of_method_info info; + (* meta *) [u30 0]; + (* class *) [u30 0]; + (* script *) [u30 1]; of_script script; + (* body *) [u30 1]; [u30 1; + u30 2; + u30 3; + u30 4; + u30 5; + u30 6;u8 1; u8 2; u8 3;s24 1; + u30 0; + u30 0] ]) @@ + Abc.to_bytes { + cpool = {empty_cpool with string=["foo"] } ; + method_info = [info]; + metadata = []; + classes = []; + instances = []; + scripts = [script]; + method_bodies = [body]}) + ] ) +> run_test_tt_main diff --git a/swflib/asm.ml b/swflib/asm.ml new file mode 100644 index 0000000..e5f1be7 --- /dev/null +++ b/swflib/asm.ml @@ -0,0 +1,369 @@ +open Base +open Bytes + +(* data flow *) +let fork2 f g x = (f x, g x) +let fork3 f g h x = (f x, g x, h x) +let fork4 f g h i x = (f x, g x, h x, i x) + +let with2 f g (a,b) = (f a, g b) +let with3 f g h (a,b,c) = (f a, g b, h c) +let with4 f g h i (a,b,c,d) = (f a, g b, h c, i d) + +let join2 f (a,b) = f a b +let join3 f (a,b,c) = f a b c +let join4 f (a,b,c,d) = f a b c d + +module type Spec = sig + type t + val spec : t -> t ISpec.t +end + +type t = { + cpool: Cpool.t; + method_info: Abc.method_info list; + method_body: Abc.method_body list; + class_info: Abc.class_info list; + instance_info: Abc.instance_info list +} + +module Make(Spec:Spec) = struct + (* type *) + type method_ = Spec.t ISpec.method_ + type class_ = Spec.t ISpec.class_ + type context = Spec.t ISpec.context + type instruction = Spec.t + + (* fold *) + type ghost = [ + `Script of method_ + | `InstanceMethod of method_ + | `StaticMethod of method_ + | `InstanceInit of method_ + | `ClassInit of method_ + ] + + (* help me : + I want to write: + type inst [ ghost | Spec.t] + + But compiler says: "Spec.t is not poly variants" + *) + type inst = [ + ghost + | `Inst of Spec.t ] + + let method_ : inst -> method_ option = + function + `InstanceMethod m + | `StaticMethod m + | `Script m + | `InstanceInit m + | `ClassInit m -> + Some m + | `Inst inst -> + ((Spec.spec inst).ISpec.method_) + + let class_ : inst -> class_ option = + function + `InstanceMethod _ | `StaticMethod _ | `Script _ | `InstanceInit _ | `ClassInit _ -> + None + | `Inst inst -> + ((Spec.spec inst).ISpec.class_) + + let fold f init inst = + let rec loop ctx inst = + let method_ctx = + match method_ inst with + Some {ISpec.instructions=instructions} -> + let instructions' = + instructions + +> List.map (fun i -> `Inst i) in + let ctx' = + List.fold_left loop (ctx#current_method <- init#current_method) + (instructions' :> inst list) in + (ctx'#sub_method <- ctx'#current_method)#current_method <- + ctx#current_method + | None -> + ctx in + let class_ctx = + match class_ inst with + Some { ISpec.iinit=iinit; + cinit=cinit; + instance_methods = im; + static_methods = sm } -> + let ctx' = + loop method_ctx (`InstanceInit iinit) in + let ctx'' = + loop ctx' (`ClassInit cinit) in + let ctx''' = + List.fold_left (fun ctx m -> loop ctx (`InstanceMethod m)) ctx'' im in + List.fold_left (fun ctx m -> loop ctx (`StaticMethod m)) ctx''' sm + | None -> + method_ctx in + f class_ctx inst in + loop init inst + + (* dataflow block *) + let filter_const inst = + let inst_const = + match inst with + #ghost -> + [] + | `Inst i -> + (Spec.spec i).ISpec.const in + let method_const = + match method_ inst with + Some {ISpec.method_name = name } -> + [name] + | None -> + [] in + let class_const = + match class_ inst with + Some {ISpec.class_name=class_name; super=super; attributes=attributes} -> + class_name::super::attributes + | None -> + [] in + inst_const @ (method_const :> Cpool.entry list) @ (class_const :> Cpool.entry list) + + let filter_class = + function + #ghost -> + None + | `Inst inst -> + ((Spec.spec inst).ISpec.class_) (* extra paren is inserted for tuarge-mode *) + + let filter_method = + (method_) (* extra paren is inserted for tuarge-mode *) + + let if_some f init = + function + Some x -> + f init x + | None -> + init + + let make_context ctx const (class_ : class_ option) (method_ : method_ option) = + let ctx = + ctx#cpool <- List.fold_left (flip Cpool.add) ctx#cpool const in + let ctx = + if_some (fun ctx c -> ctx#classes <- RevList.add c ctx#classes ) ctx class_ in + let ctx = + if_some (fun ctx m -> ctx#methods <- RevList.add m ctx#methods ) ctx method_ in + ctx + + (* make *) + let make_inst ctx = + function + #ghost -> + None + | `Inst inst -> + let {ISpec.op=op; prefix=prefix; args=args} = + Spec.spec inst in + Some (List.concat [ + prefix (ctx :> context); + [u8 op]; + args (ctx :> context)]) + + let make_class ~cpool ~classes ~methods inst = + let make c = + let flag = + function + `Sealed -> Abc.Sealed + | `Final -> Abc.Final + | `Interface -> Abc.Interface + | `ProtectedNs ns -> Abc.ProtectedNs (Cpool.index ns cpool) in + let method_attr = + function `Override -> Abc.ATTR_Override + | `Final -> Abc.ATTR_Final in + let method_trait m = { + Abc.trait_name = Cpool.index m.ISpec.method_name cpool; + data = Abc.MethodTrait (0, + RevList.index m methods, + List.map method_attr m.ISpec.method_attrs) } in + let attr_trait id attr = { + Abc.trait_name = Cpool.index attr cpool; + data = Abc.SlotTrait (id+1,0,0,0) } in + let class_info = { + Abc.cinit = RevList.index c.ISpec.cinit methods; + class_traits = List.map method_trait c.ISpec.static_methods + } in + let instance_info = { + Abc.instance_name = + Cpool.index c.ISpec.class_name cpool; + super_name = + Cpool.index c.ISpec.super cpool; + instance_flags = + List.map flag c.ISpec.class_flags; + interface = + List.map (flip RevList.index classes) c.ISpec.interface; + iinit = + RevList.index c.ISpec.iinit methods; + instance_traits = + List.concat [ + List.map method_trait c.ISpec.instance_methods; + ExtList.List.mapi attr_trait c.ISpec.attributes + ] + } in + class_info,instance_info in + sure make @@ class_ inst + + (* make method *) + let empty_usage = object + val stack = (0,0) with accessor + val scope = (0,0) with accessor + end + + let add_usage i (current,max_value)= + (current + i, max max_value (current+i)) + let filter_usage usage = + function + #ghost -> + usage + | `Inst inst -> + let {ISpec.stack=stack; scope=scope} = + Spec.spec inst in + let usage = + usage#stack <- add_usage stack usage#stack in + let usage = + usage#scope <- add_usage scope usage#scope in + usage + + let mn_name = + function + `QName (_,str) -> + str + | `Multiname (str,_) -> + str + + let make_method ~cpool ~insts ~usage inst = + let make m = + let info = + { Abc.params = m.ISpec.params; + return = m.ISpec.return; + method_name = Cpool.index (`String (mn_name m.ISpec.method_name)) cpool; + method_flags = m.ISpec.method_flags } in + let body = + { Abc.method_sig = -1; (* dummy *) + max_stack = snd usage#stack; + local_count = List.length m.ISpec.params+1; + init_scope_depth = 0; + max_scope_depth = snd usage#scope; + code = List.concat @@ List.rev insts; + exceptions = []; + method_traits = [] } in + info,body in + sure make @@ method_ inst + + let ($>) g f x = f (g x) + + (* pipeline *) + let pipeline (ctx :'a) inst : 'a = + inst + +> fork2 + (fork2 + (fork3 filter_const filter_class filter_method $> join3 (make_context ctx)) + id + $> fork4 + fst + (curry make_inst) + (fun (ctx,inst) -> + make_class + ~cpool:ctx#cpool + ~classes:ctx#classes + ~methods:ctx#methods + inst) + (fun (ctx,inst) -> + make_method + ~cpool:ctx#cpool + ~insts:ctx#sub_method#insts + ~usage:ctx#sub_method#usage + inst)) + (filter_usage ctx#current_method#usage) + +> (fun ((ctx, inst, c, m), usage) -> + let current_method = + if_some (fun c i -> c#insts <- i::c#insts) ctx#current_method inst in + let current_method = + current_method#usage <- usage in + let ctx = + ctx#current_method <- current_method in + let ctx = + if_some (fun c m -> c#abc_methods <- m::c#abc_methods) ctx m in + let ctx = + if_some (fun c m -> c#abc_classes <- m::c#abc_classes) ctx c in + ctx) + + let context = object + val cpool = Cpool.empty with accessor + val abc_methods = [] with accessor + val abc_classes = [] with accessor + + val methods = RevList.empty with accessor + val classes = RevList.empty with accessor + + val current_method = object + val insts = [] with accessor + val usage = empty_usage with accessor + end with accessor + + val sub_method = object + val insts = [] with accessor + val usage = empty_usage with accessor + end with accessor + end + + let assemble_slot_traits cpool xs = + xs + +> List.map (fun (name,id)-> { + Abc.trait_name = Cpool.index name cpool; + data = Abc.SlotTrait (id,0,0,0); + }) + + let assemble_method m = + let ctx = + fold pipeline context (`Script m) in + { + cpool = ctx#cpool; + method_info = List.rev_map fst ctx#abc_methods; + method_body = ctx#abc_methods + +> List.rev_map snd + +> ExtList.List.mapi (fun i m -> {m with Abc.method_sig=i}); + class_info = List.rev_map fst ctx#abc_classes; + instance_info = List.rev_map snd ctx#abc_classes; + } + + let assemble slots m = + let { cpool = cpool; + method_info = info; + method_body = body; + class_info = class_info; + instance_info = instance_info} = + assemble_method m in + let cpool,slots' = + map_accum_left + (fun cpool ((ns,name),i)-> + let qname = + `QName(`Namespace (String.concat "." ns), name) in + (Cpool.add qname cpool,(qname,i))) + cpool + slots in + let slot_traits = + assemble_slot_traits cpool slots' in + let class_traits = + let n = + List.length slots in + ExtList.List.mapi + (fun i {Abc.instance_name=name} -> + {Abc.trait_name=name; data=Abc.ClassTrait (i+n+1,i)}) + instance_info in + { Abc.cpool = Cpool.to_abc cpool; + method_info = info; + method_bodies = body; + metadata = []; + classes = class_info; + instances = instance_info; + scripts = [{ + Abc.init = List.length info - 1; + script_traits = slot_traits @ class_traits + }]} +end diff --git a/swflib/asm.mli b/swflib/asm.mli new file mode 100644 index 0000000..34997a0 --- /dev/null +++ b/swflib/asm.mli @@ -0,0 +1,25 @@ +module type Spec = sig + type t + val spec : t -> t ISpec.t +end + +type t = { + cpool: Cpool.t; + method_info: Abc.method_info list; + method_body: Abc.method_body list; + class_info: Abc.class_info list; + instance_info: Abc.instance_info list +} + + +module Make: functor(Spec : Spec) -> + sig + type method_ = Spec.t ISpec.method_ + type class_ = Spec.t ISpec.class_ + type instruction = Spec.t + + val assemble : ((string list * string) * int) list -> method_ -> Abc.abc + + val assemble_method : method_ -> t + val assemble_slot_traits : Cpool.t -> ([< Cpool.entry ] * int) list -> Abc.trait list + end diff --git a/swflib/asmTest.ml b/swflib/asmTest.ml new file mode 100644 index 0000000..454fc30 --- /dev/null +++ b/swflib/asmTest.ml @@ -0,0 +1,241 @@ +open Base +open OUnit +open ISpec +open Asm +open Bytes + +(* start prefix *) +let test_cases = ref [] +let test name body = + test_cases := (name >:: body)::!test_cases;; + +let ok = + OUnit.assert_equal + +(* test util *) +let empty_method = +{ ISpec.method_attrs = []; + method_name = `QName (`Namespace "",""); + params = []; + return = 0; + method_flags = 0; + instructions = []; + traits = []; + exceptions = []; + fun_scope = `Global +} + +let insts insts = + {empty_method with instructions=insts} + +(* stub module *) +module Inst = struct + type t = + [ `OpOnly1 | `OpOnly2 + | `OpOnly3 | `OpOnly4 + | `WithArgs | `WithPrefix + | `String | `Int + | `StackAdd | `StackDel + | `ScopeAdd | `ScopeDel + | `Meth + | `Class ] + + let default : t ISpec.t = { + op=0; + args=const []; + prefix=const []; + const=[]; + method_ = None; + class_ = None; + stack=0; + scope=0; + count=0; + } + + let spec = + function + `OpOnly1 -> + {default with op=101} + | `OpOnly2 -> + {default with op=102} + | `OpOnly3 -> + {default with op=103} + | `OpOnly4 -> + {default with op=104} + | `WithArgs -> + {default with args=const [u8 1]} + | `WithPrefix -> + {default with prefix=const [u8 2]} + | `String -> + {default with const=[`String "foo"]} + | `Int -> + {default with const=[`Int 42]} + | `StackAdd -> + {default with stack=1} + | `StackDel -> + {default with stack= -1} + | `ScopeAdd -> + {default with scope=1} + | `ScopeDel -> + {default with scope= -1} + | `Meth -> + {default with method_ = + Some {(insts [`OpOnly1]) with + method_name = `QName (`Namespace "","f")}} + | `Class -> + {default with class_ = Some { + class_name = `QName (`Namespace "","Foo"); + super = `QName (`Namespace "","Object"); + class_flags= [`Sealed]; + cinit = insts [`OpOnly1]; + iinit = insts [`OpOnly2]; + interface = []; + instance_methods = [insts [`OpOnly3]]; + static_methods = [insts [`OpOnly4]]; + attributes = []; + } + } +end + +module A = Asm.Make(Inst) + +let _ = test "Instruction" begin + fun () -> + let {method_info=mi; + method_body=mb} = + A.assemble_method @@ insts [`OpOnly1; `OpOnly2] in + ok 1 @@ List.length mi; + ok 1 @@ List.length mb; + ok 0 @@ (List.hd mb).Abc.method_sig; + ok [u8 101; u8 102] @@ (List.hd mb).Abc.code +end + +let _ = test "args/prefix" begin + fun () -> + let {method_info=mi; + method_body=mb} = + A.assemble_method @@ insts [`WithArgs; `WithPrefix] in + ok 1 @@ List.length mi; + ok 1 @@ List.length mb; + ok 0 @@ (List.hd mb).Abc.method_sig; + ok [u8 0; u8 1; + u8 2; u8 0] @@ (List.hd mb).Abc.code +end + +let _ = test "constant" begin + fun () -> + let {cpool=cpool} = + A.assemble_method @@ insts [`String; `Int; `Meth] in + let cpool' = + List.fold_left (flip Cpool.add) Cpool.empty [ + `String "foo"; + `Int 42; + `QName (`Namespace "","f"); + `QName (`Namespace "",""); + ] in + ok cpool' cpool +end + +let _ = test "stack" begin + fun () -> + let {method_info=mi; + method_body=mb} = + A.assemble_method @@ insts [`StackAdd; `StackAdd; `StackDel] in + ok 1 @@ List.length mi; + ok 1 @@ List.length mb; + ok 2 @@ (List.hd mb).Abc.max_stack; +end + +let _ = test "scope" begin + fun () -> + let {method_info=mi; + method_body=mb} = + A.assemble_method @@ insts [`ScopeAdd; `ScopeAdd; `ScopeDel] in + ok 1 @@ List.length mi; + ok 1 @@ List.length mb; + ok 2 @@ (List.hd mb).Abc.max_scope_depth; + ok 0 @@ (List.hd mb).Abc.init_scope_depth +end + +let _ = test "method" begin + fun () -> + let {method_info=mi; + method_body=mb} = + A.assemble_method @@ insts [`Meth] in + ok 2 @@ List.length mi; + ok 2 @@ List.length mb; + ok 0 @@ (List.nth mb 0).Abc.method_sig; + ok 1 @@ (List.nth mb 1).Abc.method_sig; + ok [u8 101] @@ (List.nth mb 0).Abc.code; + ok [u8 0] @@ (List.nth mb 1).Abc.code; +end + +let _ = test "method dup" begin + (* same method should NOT be unified for AVM2 restriction *) + fun () -> + let {method_info=mi; + method_body=mb} = + A.assemble_method @@ insts [`Meth; `Meth] in + ok 3 @@ List.length mi; + ok 3 @@ List.length mb +end + +let method_trait { Abc.trait_name = name; data = data} = + open Abc in + match data with + | MethodTrait (0,i,[]) -> + (name,i) + | MethodTrait _ | SlotTrait _ + | GetterTrait _ | SetterTrait _ + | ClassTrait _ | FunctionTrait _ + | ConstTrait _ -> + failwith "munt not happen" + +let _ = test "class" begin + fun () -> + let {method_info = mi; + method_body = mb; + instance_info = ii; + class_info = ci; + cpool = cp } = + A.assemble_method @@ insts [`Class] in + let nth_method i = + (List.nth mb i).Abc.code in + ok 1 @@ List.length ci; + ok 1 @@ List.length ii; + ok 5 @@ List.length mi; + ok 5 @@ List.length mb; + let assert_cpool expect acutal = + ok (Cpool.index expect cp) @@ acutal in + let c = + List.hd ci in + let i = + List.hd ii in + (* class info *) + ok [u8 101] @@ nth_method c.Abc.cinit; + begin match c.Abc.class_traits with + [t] -> + let (name,method_i) = + method_trait t in + ok [u8 104] @@ nth_method method_i; + assert_cpool (`QName (`Namespace "","")) @@ name + | _::_ | [] -> + assert_failure "must not happen" end; + (* instance info *) + assert_cpool (`QName (`Namespace "","Foo")) @@ i.Abc.instance_name; + assert_cpool (`QName (`Namespace "","Object")) @@ i.Abc.super_name; + ok [Abc.Sealed] @@ i.Abc.instance_flags; + ok [u8 102] @@ (List.nth mb i.Abc.iinit).Abc.code; + begin match i.Abc.instance_traits with + [t] -> + let (name,method_i) = + method_trait t in + ok [u8 103] @@ nth_method method_i; + assert_cpool (`QName (`Namespace "","")) @@ name + | _::_ | [] -> + assert_failure "must not happen" end; +end + +(* end prefix *) +let _ = + run_test_tt_main ("asm.ml" >::: !test_cases) diff --git a/swflib/bytes.ml b/swflib/bytes.ml new file mode 100644 index 0000000..334fcb7 --- /dev/null +++ b/swflib/bytes.ml @@ -0,0 +1,127 @@ +open Base +exception Out_of_range + +type address = int +type map = (Label.t * address) list + +type base = [ + `U8 of int +| `U16 of int +| `S24 of int +| `U30 of int32 +| `U32 of int32 +| `S32 of int32 +| `D64 of float ] + +type label = [ +| `Backpatch of int * (address -> map -> int list) (* (size,fun current_address map -> [...]) *) +| `Label of Label.t ] + +type t = [ base | label ] + +let u8 n = + if 0 <=n && n <= 0xFF then + `U8 n + else + raise Out_of_range + +let u16 n = + if 0 <= n && n <= 0xFFFF then + `U16 n + else + raise Out_of_range + +let u30 n = + `U30 (Int32.of_int n) +let u32 n = + `U30 (Int32.of_int n) +let s32 n = + `S32 (Int32.of_int n) +let s24 n = + `S24 n +let d64 f = + `D64 f + +let label x = + `Label x + +let backpatch size f = + `Backpatch (size,f) + +(** encode "base" to bytes *) +let (&/) = Int32.logand +let (|/) = Int32.logor +let (>>) = Int32.shift_right_logical + +let split_byte nth value size = + List.map (fun i-> nth value (i*8)) @@ range 0 size + +let split_byte_int = + split_byte (fun n i-> (n lsr i) land 0xFF) + +let split_byte_int64 value size = + List.map Int64.to_int @@ + split_byte + (fun n i->(Int64.logand (Int64.shift_right_logical n i) 0xFFL)) + value size + +let rec of_base : base -> int list = + function + `U8 x -> + split_byte_int x 1 + | `U16 x -> + split_byte_int x 2 + | `S24 x -> + split_byte_int x 3 + | `D64 f -> + split_byte_int64 (Int64.bits_of_float f) 8 + | `U30 x | `U32 x | `S32 x -> + if x = 0l then + [0] + else + unfold + (fun x -> + if x = 0l then + None + else if 0l < x && x <= 0x7Fl then + Some (Int32.to_int (x &/ 0x7Fl),0l) + else + let next = + x >> 7 in + let current = + Int32.to_int ((x &/ 0x7Fl) |/ 0x80l) in + Some (current,next)) x + +let rec of_label addr map = + function + [] -> + (fun _ -> []),map + | `Label t::xs -> + let f,map' = + of_label addr ((t,addr)::map) xs in + f,map' + | `Backpatch (size, patch)::xs -> + let f,map' = + of_label (addr+size) map xs in + (fun m -> patch addr m @ f m),map' + | #base as base::xs -> + let bytes = + of_base base in + let f,map' = + of_label (addr + List.length bytes) map xs in + (fun m -> bytes @ f m),map' + +let find : map -> Label.t -> address = flip List.assoc + +let label_ref label = + backpatch 3 (fun addr m -> of_base @@ `S24 (find m label - (addr + 3))) + +let to_int_list xs = + let f,map = + of_label 0 [] xs in + f map + +let rec output_bytes ch bytes = + bytes + +> to_int_list + +> List.iter (output_byte ch) diff --git a/swflib/bytes.mli b/swflib/bytes.mli new file mode 100644 index 0000000..07495b4 --- /dev/null +++ b/swflib/bytes.mli @@ -0,0 +1,67 @@ +(** + ABC primitive data type. + + Provide the type of ABC primitive data type and byte encodeing function. + + @author mzp + @see AVM2 Overview(pdf) +*) + +(** the type of a primitive data type *) +type t + +exception Out_of_range + +(** {6 Create data type }*) + +(** create u8 + +@raise InvalidArgumnet If n > 0xFF or n < 0. *) +val u8 : int -> t + +(** create u16 + +@raise InvalidArgumnet If n > 0xFFFF or n < 0. *) +val u16 : int -> t + +(** create u30 *) +val u30 : int -> t + +(** create u32 *) +val u32 : int -> t + +(** create d64 *) +val d64 : float -> t + +(** create s32 *) +val s32 : int -> t + +(** create s24 *) +val s24 : int -> t + +(** [label l] create label. This label is refered by [lable_ref l]. + + This value is removed when encode. *) +val label : Label.t -> t + +(** [label_ref l] refer to [label l] position. + + This value become s24 when encode. *) +val label_ref : Label.t -> t + +type address = int +type map +val find : map -> Label.t -> address +val backpatch : int -> (address -> map -> int list) -> t + +(**{6 Encode}*) + +(** + [to_int_list xs] encode [xs] to [int list]. +*) +val to_int_list : t list -> int list + +(** + [output_bytes ch xs] output encoded [xs] to [ch] +*) +val output_bytes: out_channel -> t list -> unit diff --git a/swflib/bytesTest.ml b/swflib/bytesTest.ml new file mode 100644 index 0000000..25a47dd --- /dev/null +++ b/swflib/bytesTest.ml @@ -0,0 +1,83 @@ +open Base +open OUnit +open Bytes + +let encode x = + Bytes.to_int_list [x] + +let ok expect xs = + assert_equal ~printer:Std.dump expect @@ + to_int_list xs + +let same ?msg expect actual = + assert_equal ?msg (to_int_list expect) (to_int_list actual) + +let _ = + ("bytes.ml" >::: [ + "u8" >:: + (fun () -> + ok [50] [u8 50]; + ok [0] [u8 0]; + ok [0xFF] [u8 0xFF]; + assert_raises Out_of_range + (fun () -> u8 0x100); + assert_raises Out_of_range + (fun () -> u8 ~-1)); + "u16" >:: + (fun () -> + (* memo: little endian *) + ok [0xfe;0xca] [u16 0xcafe]; + ok [0;0] [u16 0]; + ok [0xFF;0xFF] [u16 0xFFFF]; + assert_raises Out_of_range + (fun () -> u16 0x10000); + assert_raises Out_of_range + (fun () -> u16 ~-1)); + "s24" >:: + (fun () -> + ok [0xcb;0xfe;0xca] [s24 0xcafecb]; + ok [0xfe;0xca;0] [s24 0xcafe]; + ok [0;0;0] [s24 0]; + ok [1;0;0] [s24 1]; + ok [0xFF;0xFF;0xFF] [s24 0xFFFFFF]; + ok [0xFF;0xFF;0xFF] [s24 ~-1]); + "u30" >::: [ + "1byte" >:: + (fun () -> + ok [0] [u30 0]; + ok [0x7F] [u30 0x7F]); + "2byte" >:: + (fun () -> + ok [0xFF;0x30] [u30 0x187F]; + ok [0xFF;0x01] [u30 0xFF]; + ok [0xFF;0x7F] [u30 0x3FFF]); + "3byte/15-21bit" >:: + (fun () -> + ok [0xFF;0xFF;0x01] [u30 0x7FFF]; + ok [0xFF;0xFF;0x7F] [u30 0x1F_FFFF]); + "4 byte/22-28bit" >:: + (fun () -> + ok [0xFF;0xFF;0xFF;0x01] [u30 0x003F_FFFF]; + ok [0xFF;0xFF;0xFF;0x7F] [u30 0x0FFF_FFFF]); + "5 byte/29-35bit" >:: + (fun () -> + ok [0xFF;0xFF;0xFF;0xFF;0x01] [u30 0x1FFF_FFFF]; + ok [0xFF;0xFF;0xFF;0xFF;0x3] [u30 0x3FFF_FFFF])]; + "s32" >:: + (fun () -> + ok [0x00] [s32 0]; + ok [0x20] [s32 0x20]; + ok [0xF6;0xFF;0xFF;0xFF;0xF] [s32 ~-10]); + "d64" >:: + (fun () -> + ok [0;0;0;0;0;0;0xe8;0x3f] [d64 0.75]); + "label" >:: + (fun () -> + let l = + Label.make () in + same ~msg:"back" [s24 ~-3] [label l;label_ref l]; + same ~msg:"none" [s24 0] [label_ref l;label l]; + same ~msg:"u8" [s24 1; u8 1] [label_ref l;u8 1;label l]; + same ~msg:"s24" [s24 3; s24 1] [label_ref l;s24 1;label l] + ); + ]) +> run_test_tt_main diff --git a/swflib/cpool.ml b/swflib/cpool.ml new file mode 100644 index 0000000..adb97b6 --- /dev/null +++ b/swflib/cpool.ml @@ -0,0 +1,174 @@ +open Base + +type namespace = [ + `Namespace of string +| `PackageNamespace of string +| `PackageInternalNamespace of string +| `ProtectedNamespace of string +| `ExplicitNamespace of string +| `StaticProtectedNamespace of string +| `PrivateNamespace of string ] + +type namespace_set = namespace list + +type multiname = [ + `QName of namespace * string +| `Multiname of string * namespace_set +] + +type entry = [ +| `Int of int +| `UInt of int +| `Double of float +| `String of string +| namespace +| multiname +] + +type t = { + int: int RevList.t; + uint: int RevList.t; + double: float RevList.t; + string: string RevList.t; + namespace: namespace RevList.t; + namespace_set: namespace_set RevList.t; + multiname: multiname RevList.t; +} + +let empty = + {int = RevList.empty; + uint = RevList.empty; + double = RevList.empty; + string = RevList.empty; + namespace = RevList.empty; + namespace_set = RevList.empty; + multiname = RevList.empty} + +let ns_name = + function + `Namespace name + | `PackageNamespace name + | `PackageInternalNamespace name + | `ProtectedNamespace name + | `ExplicitNamespace name + | `StaticProtectedNamespace name + | `PrivateNamespace name -> + name + +let add x xs = + if RevList.mem x xs then + xs + else + RevList.add x xs + +let add_list xs ys = + RevList.add_list (List.filter (fun x -> not (RevList.mem x ys)) xs) ys + +let add_namespace ns cpool = + {cpool with + string = cpool.string + +> add (ns_name ns); + namespace = add ns cpool.namespace } + +let add_multiname name cpool = + match name with + `QName (ns,str) -> + let cpool = + {cpool with + string = cpool.string + +> add str; + multiname = add name cpool.multiname } in + add_namespace ns cpool + | `Multiname (str,ns_set) -> + {cpool with + string = cpool.string + +> add_list (List.map ns_name ns_set) + +> add str; + namespace = add_list ns_set cpool.namespace; + namespace_set = add ns_set cpool.namespace_set; + multiname = add name cpool.multiname } + +let add entry cpool = + match entry with + `Int n -> + { cpool with int= add n cpool.int } + | `UInt n -> + { cpool with uint= add n cpool.uint } + | `String s -> + { cpool with string = add s cpool.string } + | `Double d -> + { cpool with double = add d cpool.double } + | #namespace as ns -> + add_namespace ns cpool + | #multiname as m -> + add_multiname m cpool + +(* conversion *) +(* + assumption: + - list has only unique element +*) +let rindex x set = + 1 + RevList.index x set + +let index entry cpool = + match entry with + `Int n -> + rindex n cpool.int + | `UInt n -> + rindex n cpool.uint + | `Double d -> + rindex d cpool.double + | `String s -> + rindex s cpool.string + | #namespace as ns -> + rindex ns cpool.namespace + | #multiname as m -> + rindex m cpool.multiname + +let of_namespace {string=string} (ns : namespace) = + let i = + rindex (ns_name ns) string in + let kind = + match ns with + `Namespace _ -> + 0x08 + | `PackageNamespace _ -> + 0x16 + | `PackageInternalNamespace _ -> + 0x17 + | `ProtectedNamespace _ -> + 0x18 + | `ExplicitNamespace _ -> + 0x19 + | `StaticProtectedNamespace _ -> + 0x1A + | `PrivateNamespace _ -> + 0x05 in + {Abc.kind=kind; namespace_name=i} + +let of_namespace_set {namespace=namespace} nss = + List.map (fun ns -> rindex ns namespace) nss + +let of_multiname {namespace=namespace; namespace_set=namespace_set; string=string} : multiname -> Abc.multiname = + function + `QName (ns,s) -> + Abc.QName (rindex ns namespace, rindex s string) + | `Multiname (s,nss) -> + Abc.Multiname (rindex s string,rindex nss namespace_set) + +let to_abc cpool = + { Abc.int = RevList.to_list cpool.int; + Abc.uint = RevList.to_list cpool.uint; + Abc.double = RevList.to_list cpool.double; + Abc.string = RevList.to_list cpool.string; + Abc.namespace = cpool.namespace + +> RevList.to_list + +> List.map (of_namespace cpool); + Abc.namespace_set = cpool.namespace_set + +> RevList.to_list + +> List.map (of_namespace_set cpool); + Abc.multiname = cpool.multiname + +> RevList.to_list + +> List.map (of_multiname cpool) + } diff --git a/swflib/cpool.mli b/swflib/cpool.mli new file mode 100644 index 0000000..c3a2817 --- /dev/null +++ b/swflib/cpool.mli @@ -0,0 +1,39 @@ +(** + Constant pool(CPool). + + CPool create the map from a value to the index, or a list of the value. + *) + +(** A type of namespace *) +type namespace = [ + `Namespace of string +| `PackageNamespace of string +| `PackageInternalNamespace of string +| `ProtectedNamespace of string +| `ExplicitNamespace of string +| `StaticProtectedNamespace of string +| `PrivateNamespace of string ] + +type namespace_set = namespace list + +(** A type of multiname *) +type multiname = [ + `QName of namespace * string +| `Multiname of string * namespace_set +] + +type entry = [ +| `Int of int +| `UInt of int +| `Double of float +| `String of string +| namespace +| multiname +] + +type t + +val empty : t +val add : [< entry] -> t -> t +val index : [< entry] -> t -> int +val to_abc : t -> Abc.cpool diff --git a/swflib/cpoolTest.ml b/swflib/cpoolTest.ml new file mode 100644 index 0000000..c9fc91b --- /dev/null +++ b/swflib/cpoolTest.ml @@ -0,0 +1,76 @@ +open Base +open Cpool +open Bytes +open OUnit + +let empty_cpool = + { Abc.int = []; + uint = []; + double = []; + string = []; + namespace = []; + namespace_set = []; + multiname = []} + +let test_index value = + let cpool = + Cpool.add value Cpool.empty in + assert_equal 1 (Cpool.index value cpool) + +let ok cpool value = + assert_equal cpool (to_abc @@ Cpool.add value Cpool.empty) + +let _ = + ("cpool.ml" >::: [ + "int" >:: + (fun () -> + test_index (`Int 42); + test_index (`Int ~-42)); + "uint" >:: + (fun () -> + test_index (`UInt 42)); + "string" >:: + (fun () -> + test_index (`String "foobar")); + "multiname" >:: + (fun () -> + test_index (`QName ((`Namespace "std"),"print")); + test_index (`Multiname ("print",[])); + test_index (`Multiname ("print",[`Namespace "std"]))); + "literal cpool" >:: + (fun () -> + ok {empty_cpool with Abc.string=["foobar"]} (`String "foobar"); + ok {empty_cpool with Abc.int=[30]} (`Int 30); + ok {empty_cpool with Abc.int=[~-30]} (`Int ~-30); + ok {empty_cpool with Abc.uint=[42]} (`UInt 42)); + "qname cpool" >:: + (fun () -> + ok + {empty_cpool with + Abc.string = ["foobar"; "std"]; + namespace = [{Abc.kind=0x08; namespace_name=2}]; + multiname = [Abc.QName (1,1)]} + (`QName (`Namespace "std","foobar"))); + "multiname cpool" >:: + (fun () -> + ok + {empty_cpool with + Abc.string = ["std";"foobar"]; + namespace = [{Abc.kind=0x08; namespace_name=1}]; + namespace_set= [[1]]; + multiname=[Abc.Multiname (2,1)]} + (`Multiname ("foobar",[`Namespace "std"]))); + "cpool entry should be unique" >:: + (fun () -> + let cpool = + List.fold_left (flip Cpool.add) empty [`String "foo"; `String "bar"; `String "foo"] in + assert_equal 1 (Cpool.index (`String "foo") cpool); + assert_equal {empty_cpool with Abc.string=["foo";"bar"]} (to_abc cpool)); + "index is not change" >:: + (fun () -> + let cpool1 = + Cpool.add (`Int 42) empty in + let cpool2 = + Cpool.add (`Int 42) cpool1 in + assert_equal (Cpool.index (`Int 42) cpool1) (Cpool.index (`Int 42) cpool2)) + ]) +> run_test_tt_main diff --git a/swflib/gen_inst.ml b/swflib/gen_inst.ml new file mode 100644 index 0000000..3b54225 --- /dev/null +++ b/swflib/gen_inst.ml @@ -0,0 +1,123 @@ +open Str + +type decl = { + name:string; + args:string list; + body:string +} + +let mapi f xs = + let rec sub f n = + function + [] -> [] + | x::xs -> (f n x)::sub f (n+1) xs in + sub f 0 xs + +(* parsing *) +let parse s = + if string_match (regexp "^#\\|^$") s 0 then + None + else + match bounded_split (regexp " *: *") s 2 with + [decl;body] -> + begin match bounded_split (regexp " *of *") decl 2 with + [name] -> Some {name=name;args=[]; body=body} + | [name;args] -> Some {name=name;args=split (regexp " *\\* *") args; body=body} + | _ -> failwith ("invalid decl format:"^decl) + end + | _ -> + failwith ("invalid file format: "^s) + +(* + output type decl + + Example: + | `PushInt of int + | `Pop + ... +*) +let type_of_decl {name=name;args=args} = + if args = [] then + Printf.sprintf "| `%s" name + else + Printf.sprintf "| `%s of %s" name (String.concat "*" args) + +let output_types decls = + print_endline (String.concat "\n" (List.map type_of_decl decls)) + +(* + output match clause + + Example: + let get_config = function + | `Dup -> {default with op=0x2a; stack= 2} + | `NewActivation -> {default with op=0x57; stack=1} + | `NewArray (arg0) -> {default with op=0x56; args=const [Bytes.u30 arg0]} + ... +*) +let clause_of_decl {name=name;args=args;body=body} = + let args' = + if args = [] then + "" + else + Printf.sprintf "(%s)" (String.concat "," (mapi (fun n _ -> Printf.sprintf "arg%d" n) args)) in + Printf.sprintf "| `%s %s -> {default with %s}" name args' body + +let output_match decls = + let func = + (String.concat "\n" (List.map clause_of_decl decls)) in + Printf.printf "function%s\n" func + +(* output string function +let string_of_instruction = function + | Dup -> "Dup(" ^ ")" + | NewActivation -> "NewActivation(" ^ ")" + | NewArray (arg0) -> "NewArray(" ^ (Std.dump arg0) ^ ")" +*) +let clause_of_output {name=name;args=args} = + let args' = + if args = [] then + "" + else + Printf.sprintf "(%s)" (String.concat "," (mapi (fun n _ -> Printf.sprintf "arg%d" n) args)) in + let prefix = + Printf.sprintf "| %s %s -> \"%s(\"" name args' name in + let mid = + mapi (fun i _ -> Printf.sprintf "(Std.dump arg%d)" i) args in + let postfix = + "\")\"" in + String.concat " ^ " ([prefix]@mid@[postfix]) + +let output_string decls = + let func = + (String.concat "\n" (List.map clause_of_output decls)) in + Printf.printf "let string_of_instruction = function%s\n" func + + +let f _ = + let decls = + ref [] in + try + while true do + match parse (read_line ()) with + Some x -> + decls := x::!decls + | _ -> + () + done + with End_of_file -> + let decls' = + !decls in + match Sys.argv.(1) with + "-t" -> + output_types decls' + | "-m" -> + output_match decls' + | "-s" -> + output_string decls' + | _ -> + failwith "invalid option" + + +let _ = if not !Sys.interactive then + f () diff --git a/swflib/iSpec.ml b/swflib/iSpec.ml new file mode 100644 index 0000000..d1d5b69 --- /dev/null +++ b/swflib/iSpec.ml @@ -0,0 +1,65 @@ +type function_scope = + [ `Global + | `Class of Cpool.multiname] + +type class_type = + [ `Sealed + | `Final + | `Interface + | `ProtectedNs of Cpool.namespace] + +type 'a method_ = { + method_name: Cpool.multiname; + params: int list; + return: int; + method_flags: int; + instructions: 'a list; + traits: int list; + exceptions: int list; + fun_scope: function_scope; + method_attrs : [`Override | `Final] list +} +type 'a class_ = { + class_name: Cpool.multiname; + super: Cpool.multiname; + class_flags: class_type list; + cinit: 'a method_; + iinit: 'a method_; + interface: 'a class_ list; + instance_methods: 'a method_ list; + static_methods: 'a method_ list; + attributes: Cpool.multiname list +} + +(* + Because I want use structual subtyping, I use object as record. +*) +class type ['a] context = object + method cpool: Cpool.t + method methods: 'a method_ RevList.t + method classes: 'a class_ RevList.t +end + +type 'a t = { + op: int; + args: 'a context -> Bytes.t list; + prefix: 'a context -> Bytes.t list; + const: Cpool.entry list; + method_: 'a method_ option; + class_ : 'a class_ option; + stack : int; + scope : int; + count : int; +} + +let empty_method = { + method_attrs = []; + method_name = `QName (`Namespace "",""); + params = []; + return = 0; + method_flags = 0; + instructions = []; + traits= []; + exceptions= []; + fun_scope= `Global +} diff --git a/swflib/instruction.mlp b/swflib/instruction.mlp new file mode 100644 index 0000000..8a9f84b --- /dev/null +++ b/swflib/instruction.mlp @@ -0,0 +1,30 @@ +open Base +open Bytes +open ISpec + +type t = [ +#include "opcode.h" +] +and class_ = t ISpec.class_ +and method_ = t ISpec.method_ + +let default : t ISpec.t = { + op=0; + args=const []; + prefix=const []; + const=[]; + method_ = None; + class_ = None; + stack=0; + scope=0; + count=0; +} + +let cindex entry ctx = + u30 (Cpool.index entry ctx#cpool) + +let entry name = + (name :> Cpool.entry) + +let spec = +#include "match_body.h" diff --git a/swflib/instruction.txt b/swflib/instruction.txt new file mode 100644 index 0000000..f974dc4 --- /dev/null +++ b/swflib/instruction.txt @@ -0,0 +1,114 @@ +NewFunction of method_: op=0x40; stack=1; method_=Some arg0; args=fun ctx->[u30 @@ RevList.index arg0 ctx#methods]; +NewClass of class_:op=0x58; class_=Some arg0; args=fun ctx -> [u30 @@ RevList.index arg0 ctx#classes]; + +# Conversion +Coerce: op=0x80 +Coerce_a: op=0x82 +Coerce_s: op=0x85 + +Convert_i: op=0x73 +Convert_s: op=0x74 +Convert_d: op=0x75 +Convert_b: op=0x76 +Convert_u: op=0x77 + +# Arith +Add_i: op=0xc5; stack= ~-1 +Subtract_i: op=0xc6; stack= ~-1 +Multiply_i: op=0xc7; stack= ~-1 +Add: op=0xa0; stack= ~-1 +Subtract: op=0xa1; stack= ~-1 +Multiply: op=0xa2; stack= ~-1 +Divide: op=0xa3; stack= ~-1 +Modulo: op=0xa4; stack= ~-1 + +# Predicator +Equals: op=0xab; stack= ~-1 +StrictEquals: op=0xac; stack= ~-1 +LessThan: op=0xad; stack= ~-1 +LessEquals: op=0xae; stack= ~-1 +GreaterThan: op=0xaf; stack= ~-1 +GreaterEquals: op=0xb0; stack= ~-1 + +# Jump/Conditonal Jump +Label of Label.t: op=0x09; prefix=const [label arg0] +IfNlt of Label.t: op=0x0c; stack= ~-1; args=const [label_ref arg0] +IfNle of Label.t: op=0x0d; stack= ~-1; args=const [label_ref arg0] +IfNgt of Label.t: op=0x0e; stack= ~-1; args=const [label_ref arg0] +IfNge of Label.t: op=0x0f; stack= ~-1; args=const [label_ref arg0] +Jump of Label.t: op=0x10; args=const [label_ref arg0] +IfTrue of Label.t: op=0x11; stack= ~-1; args=const [label_ref arg0] +IfFalse of Label.t: op=0x12; stack= ~-1; args=const [label_ref arg0] +IfEq of Label.t: op=0x13; stack= ~-1; args=const [label_ref arg0] +IfNe of Label.t: op=0x14; stack= ~-1; args=const [label_ref arg0] +IfLt of Label.t: op=0x15; stack= ~-1; args=const [label_ref arg0] +IfLe of Label.t: op=0x16; stack= ~-1; args=const [label_ref arg0] +IfGt of Label.t: op=0x17; stack= ~-1; args=const [label_ref arg0] +IfGe of Label.t: op=0x18; stack= ~-1; args=const [label_ref arg0] +IfStrictEq of Label.t: op=0x19; stack= ~-1; args=const [label_ref arg0] +IfStrictNe of Label.t: op=0x1a; stack= ~-1; args=const [label_ref arg0] + +# Literal +PushNull: op=0x20; stack=1 +PushUndefined: op=0x21; stack=1 +PushByte of int: op=0x24; stack=1; args=const [u8 arg0] +PushShort of int: op=0x25; stack=1; args=const [u30 arg0] +PushTrue: op=0x26; stack=1 +PushFalse: op=0x27; stack=1 +PushNaN: op=0x28; stack=1 +PushString of string: op=0x2C; stack=1; const=[`String arg0]; args=fun ctx -> [cindex (`String arg0) ctx] +PushInt of int: op=0x2D; stack=1; const=[`Int arg0]; args=fun ctx -> [cindex (`Int arg0) ctx] +PushUInt of int: op=0x2E; stack=1; const=[`UInt arg0]; args=fun ctx -> [cindex (`UInt arg0) ctx] +PushDouble of float: op=0x2F; stack=1; const=[`Double arg0]; args=fun ctx -> [cindex (`Double arg0) ctx] +PushNamespace of Cpool.namespace: op=0x31; stack=1; const=[entry arg0]; args=fun ctx -> [cindex arg0 ctx] + +# Scope +PushScope: op=0x30; stack= ~-1; scope=1 +PushWith: op=0x1c; stack= ~-1; scope=1 +GetGlobalScope:op=0x64; stack=1 +GetScopeObject of int:op=0x65; stack=1; args=const[u8 arg0] + +# Register +GetLocal_0: op=0xD0; stack=1;count=1 +GetLocal_1: op=0xD1; stack=1;count=2 +GetLocal_2: op=0xD2; stack=1;count=3 +GetLocal_3: op=0xD3; stack=1;count=4 +GetLocal of int: op=0x62; stack=1; args=const [u30 arg0];count=(arg0+1) +SetLocal_0: op=0xD4; stack=1 +SetLocal_1: op=0xD5; stack=1 +SetLocal_2: op=0xD6; stack=1 +SetLocal_3: op=0xD7; stack=1 +SetLocal of int: op=0x63; stack=1; args=const [u30 arg0] + +GetSlot of int: op=0x6c; args=const [u30 arg0] +SetSlot of int: op=0x6d; args=const [u30 arg0]; stack= ~-2 +GetGlobalSlot of int: op=0x6e; stack=1; args=const [u30 arg0] +SetGlobalSlot of int: op=0x6f; stack= ~-1; args=const [u30 arg0] + +GetLex of Cpool.multiname: op=0x60; stack=1; const=[entry arg0]; args=fun ctx ->[cindex arg0 ctx] +GetProperty of Cpool.multiname: op=0x66; const=[entry arg0]; args=fun ctx ->[cindex arg0 ctx] +SetProperty of Cpool.multiname: op=0x61; stack= ~-2; const=[entry arg0]; args=fun ctx ->[cindex arg0 ctx] +InitProperty of Cpool.multiname: op=0x68; stack= ~-2; const=[entry arg0]; args=fun ctx ->[cindex arg0 ctx] + +# FunctionCall +ReturnVoid: op=0x47 +ReturnValue: op=0x48; stack= ~-1 +FindPropStrict of Cpool.multiname: op=0x5D; stack=1; const=[entry arg0]; args=fun ctx -> [cindex arg0 ctx] +CallProperty of Cpool.multiname * int: op=0x46; stack= 1-arg1; const=[entry arg0]; args=fun ctx ->[cindex arg0 ctx; u30 arg1] +CallPropLex of Cpool.multiname * int: op=0x4c; stack= 1-arg1; const=[entry arg0]; args=fun ctx ->[cindex arg0 ctx; u30 arg1] +Call of int: op=0x41; stack= 1-(2+arg0); args=const [u30 arg0]; +Pop: op=0x29; stack= ~-1 +Swap:op=0x2b +PopScope:op=0x1d; scope= ~-1 + +NewObject of int:op=0x55; args=const [u30 arg0]; stack=1-arg0 +NewArray of int:op=0x56; args=const [u30 arg0] +NewActivation:op=0x57; stack=1 + + +Dup: op=0x2a; stack= 2 + +# Class + +ConstructSuper of int: op=0x49; args=const [u30 arg0]; stack= ~-(arg0+1) +ConstructProp of Cpool.multiname*int: op=0x4a; stack= ~-arg1; args=(fun ctx -> [u30 @@ Cpool.index arg0 ctx#cpool;u30 arg1]); diff --git a/swflib/label.ml b/swflib/label.ml new file mode 100644 index 0000000..ed1ccd7 --- /dev/null +++ b/swflib/label.ml @@ -0,0 +1,14 @@ +type t = int + +let count = + ref 0 + +let make () = + count := !count+1; + !count + +let peek n = + !count+1+n + +let to_string n = + Printf.sprintf "$%d" n diff --git a/swflib/label.mli b/swflib/label.mli new file mode 100644 index 0000000..a4f32c0 --- /dev/null +++ b/swflib/label.mli @@ -0,0 +1,6 @@ +type t +val make : unit -> t +val to_string : t -> string + +(* only debug use *) +val peek : int -> t diff --git a/swflib/revList.ml b/swflib/revList.ml new file mode 100644 index 0000000..a92ea1a --- /dev/null +++ b/swflib/revList.ml @@ -0,0 +1,33 @@ +(** +Index immutable Set. + +If you add some elements to a set, [index] is not change. +*) +open Base + +type 'a t = 'a list + +let empty = + [] + +let add x xs = + x::xs + +let add_list xs ys = + List.fold_left (flip add) ys xs + +let rec index x = + function + [] -> + raise Not_found + | y::ys -> + if x = y then + List.length ys + else + index x ys + +let to_list xs = + List.rev xs + +let mem x xs = + List.mem x xs diff --git a/swflib/revList.mli b/swflib/revList.mli new file mode 100644 index 0000000..ff1604f --- /dev/null +++ b/swflib/revList.mli @@ -0,0 +1,7 @@ +type 'a t +val add : 'a -> 'a t -> 'a t +val add_list : 'a list -> 'a t -> 'a t +val index : 'a -> 'a t -> int +val to_list : 'a t -> 'a list +val empty : 'a t +val mem : 'a -> 'a t -> bool diff --git a/swflib/revListTest.ml b/swflib/revListTest.ml new file mode 100644 index 0000000..37b5a46 --- /dev/null +++ b/swflib/revListTest.ml @@ -0,0 +1,37 @@ +open Base +open RevList +open OUnit + +let _ = + ("ISet" >::: [ + "index is immutable" >:: + (fun () -> + let set1 = + RevList.add 0 empty in + let set2 = + RevList.add 1 set1 in + assert_equal (index 0 set1) (RevList.index 0 set2)); + "mem" >:: + (fun () -> + assert_equal false (RevList.mem 0 empty); + assert_equal true (RevList.mem 0 (RevList.add 0 empty))); + "index" >:: + (fun () -> + let set = + RevList.add 42 empty in + assert_equal 0 (RevList.index 42 set)); + "to_list" >:: + (fun () -> + let set1 = + RevList.add 42 empty in + let set2 = + RevList.add 0 set1 in + assert_equal [42;0] (RevList.to_list set2)); + "add_list" >:: + (fun () -> + let set1 = + RevList.add_list [1;2;3] empty in + let set2 = + RevList.add 3 (RevList.add 2 (RevList.add 1 empty)) in + assert_equal set1 set2) + ]) +> run_test_tt_main -- 2.11.0