OCAML_LIBS += $(absname ast/ast)
.SUBDIRS: parser filter codegen
+OCAMLINCLUDES += $(ROOT)/swflib
+OCAML_LIBS += $(ROOT)/swflib/swflib
+
FILES[] =
interCode
parser
filter
$(ROOT)/config
+
PROGRAM = habc-scm
OCamlProgram($(PROGRAM), main $(FILES))
module
binding
closureTrans
- bytes
- label
- abc
- cpool
- revList
- instruction
- iSpec
- asm
codegen
override
main
+OCAMLINCLUDES += $(ROOT)/swflib
+OCAML_LIBS += $(ROOT)/swflib/swflib
+
PROGRAM=../codegen
OCAMLOPT = ocamlopt -for-pack $(capitalize $(basename $(PROGRAM)))
OCAMLOPTLINK= ocamlopt
-OCamlProgram(gen_inst,gen_inst)
-
# test
OUNIT_LIBS+=astUtil
-OUnitTest(bytes , bytes label)
-OUnitTest(abc , abc label bytes)
-OUnitTest(revList , revList)
-OUnitTest(cpool , cpool revList)
OUnitTest(closureTrans , closureTrans module)
-OUnitTest(asm , asm cpool revList bytes)
-OUnitTest(codegenExpr , codegen label iSpec)
-OUnitTest(codegenStmt , codegen label iSpec)
-OUnitTest(codegenClass , codegen label iSpec)
+OUnitTest(codegenExpr , codegen)
+OUnitTest(codegenStmt , codegen)
+OUnitTest(codegenClass , codegen)
OUnitTest(override , override binding module)
OUnitTest(module , module)
OUnitTest(binding , binding module)
# phony
.PHONY: clean
-.DEFAULT: $(MyOCamlPackage $(PROGRAM), $(FILES))
+.DEFAULT: $(OCamlPackage $(PROGRAM), $(FILES))
+
+
match_body.h: gen_inst$(EXE) instruction.txt
./gen_inst$(EXE) -m < instruction.txt > $@
+++ /dev/null
-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
- ]
+++ /dev/null
-(**
- ABC(Action Script Bytecode) format.
-
- Provide the type of ABC and encoding function.
-
- @author mzp
- @see <http://www.adobe.com/devnet/actionscript/articles/avm2overview.pdf> 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
+++ /dev/null
-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
+++ /dev/null
-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
+++ /dev/null
-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 : Binding.slot list -> method_ -> Abc.abc
-
- val assemble_method : method_ -> t
- val assemble_slot_traits : Cpool.t -> ([< Cpool.entry ] * int) list -> Abc.trait list
- end
+++ /dev/null
-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)
| Slot of scope * int
| Member of scope * name
-type slot = name * int
-
type env = {
depth: int;
binding: (name * bind) list;
- slots: slot list;
+ slots: name list;
slot_count : int
}
let env' =
{ env with
slot_count = id;
- slots = (qname,id)::env.slots;
+ slots = qname::env.slots;
binding =
(qname,Slot (Global,id))::env.binding
} in
| Slot of scope * int
| Member of scope * name
-type slot = name * int
-
type 'expr expr =
[ 'expr Module.expr
| `BindVar of bind Node.t]
type program =
stmt' list
-val of_module : Module.program -> slot list * program
+val of_module : Module.program -> name list * program
+++ /dev/null
-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)
+++ /dev/null
-(**
- ABC primitive data type.
-
- Provide the type of ABC primitive data type and byte encodeing function.
-
- @author mzp
- @see <http://www.adobe.com/devnet/actionscript/articles/avm2overview.pdf> 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
+++ /dev/null
-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
open Base
open Ast
open Node
-open ISpec
+open MethodType
module QName = struct
- open Cpool
-
let join xs =
String.concat "." xs
let body' =
generate_expr body in
let m = {
- empty_method with
- ISpec.method_name = QName.make_global @@ Label.to_string @@ Label.make ();
+ MethodType.empty with
+ method_name = QName.make_global "";
params = List.map (const 0) args;
- instructions = body' @ [`ReturnValue] } in
+ code = body' @ [`ReturnValue] } in
[`NewFunction m]
| `Var name ->
[`GetLex (QName.of_node name)]
let generate_method scope ctx ({Ast.method_name = name;
args = args;
body = body},attrs) =
- let {instructions = inst} as m =
- {empty_method with
+ let {code = inst} as m =
+ {MethodType.empty with
fun_scope = scope;
- instructions = generate_expr body} in
+ code = generate_expr body} in
match name with
`Public {Node.value="init"} ->
{ctx with
- ISpec.iinit =
+ iinit =
{m with
method_name = QName.make_global "init";
params = List.map (const 0) @@ List.tl args;
- instructions = init_prefix @ inst @ [`Pop; `ReturnVoid]}}
+ code = init_prefix @ inst @ [`Pop; `ReturnVoid]}}
| `Public {Node.value=name} ->
{ctx with
- ISpec.instance_methods =
+ instance_methods =
{m with
method_name = QName.make_global name;
params = List.map (const 0) @@ List.tl args;
method_attrs = (attrs :> [`Final | `Override] list);
- instructions = inst @ [`ReturnValue] } :: ctx.instance_methods}
+ code = inst @ [`ReturnValue] } :: ctx.instance_methods}
| `Static {Node.value="init"} ->
{ctx with
- ISpec.cinit =
+ cinit =
{m with
method_name = QName.make_global "init";
params = List.map (const 0) args;
- instructions = inst @ [`Pop; `ReturnVoid]}}
+ code = inst @ [`Pop; `ReturnVoid]}}
| `Static {Node.value=name} ->
{ctx with
- ISpec.static_methods =
+ static_methods =
{m with
method_name = QName.make_global name;
params = List.map (const 0) args;
method_attrs = (attrs :> [`Final | `Override] list);
- instructions = inst @ [`ReturnValue] } :: ctx.static_methods}
+ code = inst @ [`ReturnValue] } :: ctx.static_methods}
let generate_class name {value = (ns,sname)} attrs methods =
let qname =
let super =
QName.make ns sname in
let init =
- { empty_method with
- ISpec.method_name = QName.make_global "init";
+ { MethodType.empty with
+ method_name = QName.make_global "init";
fun_scope = `Class qname;
- instructions = init_prefix @ [`ReturnVoid] } in
+ code = init_prefix @ [`ReturnVoid] } in
let cinit =
- { empty_method with
- ISpec.method_name = QName.make_global "cinit";
+ { MethodType.empty with
+ method_name = QName.make_global "cinit";
fun_scope = `Class qname;
- instructions = [`ReturnVoid] } in
+ code = [`ReturnVoid] } in
let empty = {
class_name = qname;
super = super;
interface = [];
instance_methods = [];
static_methods = [];
- attributes = attrs
+ attrs = attrs
} in
let klass =
List.fold_left (generate_method @@ `Class qname)
attrs
[]
-let generate _ program =
+let generate program =
let program' =
generate_program program in
- {empty_method with
+ {MethodType.empty with
method_name =
QName.make_global "";
- instructions =
+ code =
List.concat [
[ `GetLocal_0; `PushScope ];
program';
-val generate : Binding.slot list -> Override.program -> Instruction.t ISpec.method_
+val generate : Override.program -> Abc.meth
(**{6 Debug only}*)
-val generate_program : Override.program -> Instruction.t list
-
+val generate_program : Override.program -> HighInst.s list
open Base
-open Asm
open Codegen
open OUnit
open Binding
open AstUtil
-open ISpec
+open Swflib
+open Swflib.MethodType
let join xs =
String.concat "." xs
let inner args inst =
let l = Label.peek 0 in
- {empty_method with
+ {empty with
method_name = qname [] @@ Label.to_string l;
params = args;
- instructions = inst@[`ReturnValue] }
+ code = inst@[`ReturnValue] }
let _ =
("codegen.ml(expr)" >::: [
+++ /dev/null
-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)
- }
+++ /dev/null
-(**
- 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
+++ /dev/null
-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
+++ /dev/null
-gen_inst.opt
\ No newline at end of file
+++ /dev/null
-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 ()
+++ /dev/null
-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
-}
+++ /dev/null
-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"
+++ /dev/null
-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]);
+++ /dev/null
-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
+++ /dev/null
-type t
-val make : unit -> t
-val to_string : t -> string
-
-(* only debug use *)
-val peek : int -> t
open Base
-module A = Asm.Make(Instruction)
-
-let save_first f (a,b) =
- (a,f a b)
+let to_multiname (ns,name) =
+ `QName (`Namespace (String.concat "." ns),name)
let to_bytes program =
program
+> Module.of_ast
+> ClosureTrans.trans
+> Binding.of_module
- +> Tuple.T2.map2 Override.of_binding
- +> save_first Codegen.generate
- +> curry A.assemble
- +> Abc.to_bytes
+ +> (fun (a,b) ->
+ List.map to_multiname a,
+ Codegen.generate @@ Override.of_binding b)
+ +> curry Abc.compile
+ +> Abc.asm
let generate program =
program
program
+> to_bytes
+> Bytes.output_bytes ch
+
+++ /dev/null
-function| `ConstructProp (arg0,arg1) -> {default with op=0x4a; stack= ~-arg1; args=(fun ctx -> [u30 @@ Cpool.index arg0 ctx#cpool;u30 arg1]);}
-| `ConstructSuper (arg0) -> {default with op=0x49; args=const [u30 arg0]; stack= ~-(arg0+1)}
-| `Dup -> {default with op=0x2a; stack= 2}
-| `NewActivation -> {default with op=0x57; stack=1}
-| `NewArray (arg0) -> {default with op=0x56; args=const [u30 arg0]}
-| `NewObject (arg0) -> {default with op=0x55; args=const [u30 arg0]; stack=1-arg0}
-| `PopScope -> {default with op=0x1d; scope= ~-1}
-| `Swap -> {default with op=0x2b}
-| `Pop -> {default with op=0x29; stack= ~-1}
-| `Call (arg0) -> {default with op=0x41; stack= 1-(2+arg0); args=const [u30 arg0];}
-| `CallPropLex (arg0,arg1) -> {default with op=0x4c; stack= 1-arg1; const=[entry arg0]; args=fun ctx ->[cindex arg0 ctx; u30 arg1]}
-| `CallProperty (arg0,arg1) -> {default with op=0x46; stack= 1-arg1; const=[entry arg0]; args=fun ctx ->[cindex arg0 ctx; u30 arg1]}
-| `FindPropStrict (arg0) -> {default with op=0x5D; stack=1; const=[entry arg0]; args=fun ctx -> [cindex arg0 ctx]}
-| `ReturnValue -> {default with op=0x48; stack= ~-1}
-| `ReturnVoid -> {default with op=0x47}
-| `InitProperty (arg0) -> {default with op=0x68; stack= ~-2; const=[entry arg0]; args=fun ctx ->[cindex arg0 ctx]}
-| `SetProperty (arg0) -> {default with op=0x61; stack= ~-2; const=[entry arg0]; args=fun ctx ->[cindex arg0 ctx]}
-| `GetProperty (arg0) -> {default with op=0x66; const=[entry arg0]; args=fun ctx ->[cindex arg0 ctx]}
-| `GetLex (arg0) -> {default with op=0x60; stack=1; const=[entry arg0]; args=fun ctx ->[cindex arg0 ctx]}
-| `SetGlobalSlot (arg0) -> {default with op=0x6f; stack= ~-1; args=const [u30 arg0]}
-| `GetGlobalSlot (arg0) -> {default with op=0x6e; stack=1; args=const [u30 arg0]}
-| `SetSlot (arg0) -> {default with op=0x6d; args=const [u30 arg0]; stack= ~-2}
-| `GetSlot (arg0) -> {default with op=0x6c; args=const [u30 arg0]}
-| `SetLocal (arg0) -> {default with op=0x63; stack=1; args=const [u30 arg0]}
-| `SetLocal_3 -> {default with op=0xD7; stack=1}
-| `SetLocal_2 -> {default with op=0xD6; stack=1}
-| `SetLocal_1 -> {default with op=0xD5; stack=1}
-| `SetLocal_0 -> {default with op=0xD4; stack=1}
-| `GetLocal (arg0) -> {default with op=0x62; stack=1; args=const [u30 arg0];count=(arg0+1)}
-| `GetLocal_3 -> {default with op=0xD3; stack=1;count=4}
-| `GetLocal_2 -> {default with op=0xD2; stack=1;count=3}
-| `GetLocal_1 -> {default with op=0xD1; stack=1;count=2}
-| `GetLocal_0 -> {default with op=0xD0; stack=1;count=1}
-| `GetScopeObject (arg0) -> {default with op=0x65; stack=1; args=const[u8 arg0]}
-| `GetGlobalScope -> {default with op=0x64; stack=1}
-| `PushWith -> {default with op=0x1c; stack= ~-1; scope=1}
-| `PushScope -> {default with op=0x30; stack= ~-1; scope=1}
-| `PushNamespace (arg0) -> {default with op=0x31; stack=1; const=[entry arg0]; args=fun ctx -> [cindex arg0 ctx]}
-| `PushDouble (arg0) -> {default with op=0x2F; stack=1; const=[`Double arg0]; args=fun ctx -> [cindex (`Double arg0) ctx]}
-| `PushUInt (arg0) -> {default with op=0x2E; stack=1; const=[`UInt arg0]; args=fun ctx -> [cindex (`UInt arg0) ctx]}
-| `PushInt (arg0) -> {default with op=0x2D; stack=1; const=[`Int arg0]; args=fun ctx -> [cindex (`Int arg0) ctx]}
-| `PushString (arg0) -> {default with op=0x2C; stack=1; const=[`String arg0]; args=fun ctx -> [cindex (`String arg0) ctx]}
-| `PushNaN -> {default with op=0x28; stack=1}
-| `PushFalse -> {default with op=0x27; stack=1}
-| `PushTrue -> {default with op=0x26; stack=1}
-| `PushShort (arg0) -> {default with op=0x25; stack=1; args=const [u30 arg0]}
-| `PushByte (arg0) -> {default with op=0x24; stack=1; args=const [u8 arg0]}
-| `PushUndefined -> {default with op=0x21; stack=1}
-| `PushNull -> {default with op=0x20; stack=1}
-| `IfStrictNe (arg0) -> {default with op=0x1a; stack= ~-1; args=const [label_ref arg0]}
-| `IfStrictEq (arg0) -> {default with op=0x19; stack= ~-1; args=const [label_ref arg0]}
-| `IfGe (arg0) -> {default with op=0x18; stack= ~-1; args=const [label_ref arg0]}
-| `IfGt (arg0) -> {default with op=0x17; stack= ~-1; args=const [label_ref arg0]}
-| `IfLe (arg0) -> {default with op=0x16; stack= ~-1; args=const [label_ref arg0]}
-| `IfLt (arg0) -> {default with op=0x15; stack= ~-1; args=const [label_ref arg0]}
-| `IfNe (arg0) -> {default with op=0x14; stack= ~-1; args=const [label_ref arg0]}
-| `IfEq (arg0) -> {default with op=0x13; stack= ~-1; args=const [label_ref arg0]}
-| `IfFalse (arg0) -> {default with op=0x12; stack= ~-1; args=const [label_ref arg0]}
-| `IfTrue (arg0) -> {default with op=0x11; stack= ~-1; args=const [label_ref arg0]}
-| `Jump (arg0) -> {default with op=0x10; args=const [label_ref arg0]}
-| `IfNge (arg0) -> {default with op=0x0f; stack= ~-1; args=const [label_ref arg0]}
-| `IfNgt (arg0) -> {default with op=0x0e; stack= ~-1; args=const [label_ref arg0]}
-| `IfNle (arg0) -> {default with op=0x0d; stack= ~-1; args=const [label_ref arg0]}
-| `IfNlt (arg0) -> {default with op=0x0c; stack= ~-1; args=const [label_ref arg0]}
-| `Label (arg0) -> {default with op=0x09; prefix=const [label arg0]}
-| `GreaterEquals -> {default with op=0xb0; stack= ~-1}
-| `GreaterThan -> {default with op=0xaf; stack= ~-1}
-| `LessEquals -> {default with op=0xae; stack= ~-1}
-| `LessThan -> {default with op=0xad; stack= ~-1}
-| `StrictEquals -> {default with op=0xac; stack= ~-1}
-| `Equals -> {default with op=0xab; stack= ~-1}
-| `Modulo -> {default with op=0xa4; stack= ~-1}
-| `Divide -> {default with op=0xa3; stack= ~-1}
-| `Multiply -> {default with op=0xa2; stack= ~-1}
-| `Subtract -> {default with op=0xa1; stack= ~-1}
-| `Add -> {default with op=0xa0; stack= ~-1}
-| `Multiply_i -> {default with op=0xc7; stack= ~-1}
-| `Subtract_i -> {default with op=0xc6; stack= ~-1}
-| `Add_i -> {default with op=0xc5; stack= ~-1}
-| `Convert_u -> {default with op=0x77}
-| `Convert_b -> {default with op=0x76}
-| `Convert_d -> {default with op=0x75}
-| `Convert_s -> {default with op=0x74}
-| `Convert_i -> {default with op=0x73}
-| `Coerce_s -> {default with op=0x85}
-| `Coerce_a -> {default with op=0x82}
-| `Coerce -> {default with op=0x80}
-| `NewClass (arg0) -> {default with op=0x58; class_=Some arg0; args=fun ctx -> [u30 @@ RevList.index arg0 ctx#classes];}
-| `NewFunction (arg0) -> {default with op=0x40; stack=1; method_=Some arg0; args=fun ctx->[u30 @@ RevList.index arg0 ctx#methods];}
+++ /dev/null
-| `ConstructProp of Cpool.multiname*int
-| `ConstructSuper of int
-| `Dup
-| `NewActivation
-| `NewArray of int
-| `NewObject of int
-| `PopScope
-| `Swap
-| `Pop
-| `Call of int
-| `CallPropLex of Cpool.multiname*int
-| `CallProperty of Cpool.multiname*int
-| `FindPropStrict of Cpool.multiname
-| `ReturnValue
-| `ReturnVoid
-| `InitProperty of Cpool.multiname
-| `SetProperty of Cpool.multiname
-| `GetProperty of Cpool.multiname
-| `GetLex of Cpool.multiname
-| `SetGlobalSlot of int
-| `GetGlobalSlot of int
-| `SetSlot of int
-| `GetSlot of int
-| `SetLocal of int
-| `SetLocal_3
-| `SetLocal_2
-| `SetLocal_1
-| `SetLocal_0
-| `GetLocal of int
-| `GetLocal_3
-| `GetLocal_2
-| `GetLocal_1
-| `GetLocal_0
-| `GetScopeObject of int
-| `GetGlobalScope
-| `PushWith
-| `PushScope
-| `PushNamespace of Cpool.namespace
-| `PushDouble of float
-| `PushUInt of int
-| `PushInt of int
-| `PushString of string
-| `PushNaN
-| `PushFalse
-| `PushTrue
-| `PushShort of int
-| `PushByte of int
-| `PushUndefined
-| `PushNull
-| `IfStrictNe of Label.t
-| `IfStrictEq of Label.t
-| `IfGe of Label.t
-| `IfGt of Label.t
-| `IfLe of Label.t
-| `IfLt of Label.t
-| `IfNe of Label.t
-| `IfEq of Label.t
-| `IfFalse of Label.t
-| `IfTrue of Label.t
-| `Jump of Label.t
-| `IfNge of Label.t
-| `IfNgt of Label.t
-| `IfNle of Label.t
-| `IfNlt of Label.t
-| `Label of Label.t
-| `GreaterEquals
-| `GreaterThan
-| `LessEquals
-| `LessThan
-| `StrictEquals
-| `Equals
-| `Modulo
-| `Divide
-| `Multiply
-| `Subtract
-| `Add
-| `Multiply_i
-| `Subtract_i
-| `Add_i
-| `Convert_u
-| `Convert_b
-| `Convert_d
-| `Convert_s
-| `Convert_i
-| `Coerce_s
-| `Coerce_a
-| `Coerce
-| `NewClass of class_
-| `NewFunction of method_
+++ /dev/null
-(**
-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
+++ /dev/null
-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
+++ /dev/null
-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
OUnitTest(rename, rename)
# phony
-.DEFAULT: $(MyOCamlPackage $(PROGRAM), $(FILES))
+.DEFAULT: $(OCamlPackage $(PROGRAM), $(FILES))
.PHONY: clean
clean:
ocaml-clean
OCAMLOPTLINK = ocamlopt
OCAML_WARN_FLAGS=-w Alez -warn-error A
-
OUNIT_LIBS += astUtil
OUnitTest(lexer ,lexer parsec)
OUnitTest(sexp ,sexp parsec)
# phony
.PHONY: clean
-.DEFAULT: $(MyOCamlPackage $(PROGRAM), $(FILES))
+.DEFAULT: $(OCamlPackage $(PROGRAM), $(FILES))
clean:
ocaml-clean closTrans.mli
abc
UseCamlp4(pa_openin pa_oo pa_field)
-PROGRAM=../swflib
+PROGRAM=swflib
OCAMLINCLUDES += $(ROOT)/base
OCAML_LIBS += $(ROOT)/base/base
# phony
.PHONY: clean
-.DEFAULT:
-MyOCamlPackage($(PROGRAM), $(FILES))
+.DEFAULT: $(OCamlLibrary $(PROGRAM), $(FILES))
%.type.h: gen_typemap$(EXE)
./gen_typemap$(EXE) -$> > $@
module A = Asm.Make(LowInst)
module C = Compile.Make(HighInst)
-include AbcType
-include MethodType
-
-let asm : LowInst.t abc -> Bytes.t list = A.to_bytes
-let compile : Cpool.multiname list -> HighInst.s method_ -> LowInst.t abc = C.to_abc
-
-let output : out_channel -> Bytes.t list -> unit =
- Bytes.output_bytes
+type abc = LowInst.t AbcType.t
+type meth = HighInst.s MethodType.method_
+let asm : abc -> Bytes.t list = A.to_bytes
+let compile : Cpool.multiname list -> meth -> abc = C.to_abc
+let output : out_channel -> Bytes.t list -> unit = Bytes.output_bytes
method_traits: trait list
}
-type 'a abc = {
+type 'a t = {
cpool: cpool;
method_info: method_info list;
metadata: int list;
open AbcType
val empty_cpool : cpool
- val to_bytes : S.t abc -> Bytes.t list
+ val to_bytes : S.t AbcType.t -> Bytes.t list
(**{6 Debug only}*)
val of_cpool : cpool -> Bytes.t list
ims;sms
]
- let methods ({code=code} as m) =
+ let rec methods ({code=code} as m) =
List.concat [
- filter_map Inst.method_ code;
- HList.concat_map methods_of_class @@ filter_map Inst.class_ code;
+ HList.concat_map methods @@ filter_map (Inst.method_) code;
+ HList.concat_map methods @@ HList.concat_map methods_of_class @@ filter_map Inst.class_ code;
[m];
]
module Make :
functor (Inst : Inst) ->
sig
- val to_abc : Cpool.multiname list -> Inst.s method_ -> Inst.t AbcType.abc
+ val to_abc : Cpool.multiname list -> Inst.s method_ -> Inst.t AbcType.t
val __to_cpool : Inst.s method_ -> Cpool.t
end
~ocaml:"(Label.t,int) either"
~byte:"function
Left label -> label_ref label
- | Right address -> s24 address"
+ | Right address -> s24 address";
+ write "label_def"
+ ~ocaml:"Label.t"
+ ~byte:"fun l ->label l"
| "-high" ->
cpool "c_int" ~ocaml:"int" ~entry:"`Int";
cpool "c_uint" ~ocaml:"int" ~entry:"`UInt";
lit "u30" ~ocaml:"int";
lit "u8" ~ocaml:"int";
high "label" ~ocaml:"Label.t" ~cpool:"None" ~arg:"Left _x";
+ high "label_def" ~ocaml:"Label.t" ~cpool:"None" ~arg:"_x";
base "method_" ~cpool:"None" ~arg:"index _x _ctx#methods"
~clas:"None" ~meth:"Some _x";
base "class_" ~cpool:"None" ~arg:"index _x _ctx#classes"
GreaterEquals(0xb0) -> stack= ~-1
# Jump/Conditonal Jump
-Label of label(0x09) -> prefix=const [label _0];_s=const []
+Label of label_def(0x09)
IfNlt of label(0x0c) -> stack= ~-1
IfNle of label(0x0d) -> stack= ~-1
IfNgt of label(0x0e) -> stack= ~-1
static_methods: 'a method_ list;
attrs: Cpool.multiname list
}
+
+let empty = {
+ method_attrs = [];
+ method_name = `QName (`Namespace "","");
+ params = [];
+ return = 0;
+ method_flags = 0;
+ code = [];
+ traits = [];
+ exceptions = [];
+ fun_scope = `Global
+}
OSDN Git Service
