src/asm.ml

   1 open Base
   2 include Instruction
   3
   4 type t = {
   5   abc_cpool:     Abc.cpool;
   6   method_info:   Abc.method_info list;
   7   method_body:   Abc.method_body list;
   8   class_info:    Abc.class_info  list;
   9   instance_info: Abc.instance_info list
  10 }
  11
  12 let empty_method = {
  13   name  = Cpool.make_qname "<default-method>";
  14   params= [];
  15   return= 0;
  16   flags = 0;
  17   exceptions=[];
  18   traits= [];
  19   fun_scope=Global;
  20   instructions=[];
  21 }
  22
  23
  24 (* util function *)
  25 let make_meth ?(args=[]) name body =
  26   let inst =
  27     body @ [ReturnValue] in
  28     { name  = Cpool.make_qname name;
  29       params= args;
  30       return= 0;
  31       flags = 0;
  32       exceptions=[];
  33       traits= [];
  34       fun_scope=Global;
  35       instructions=inst;
  36     }
  37
  38 let make_proc ?(args=[]) name body =
  39   let inst =
  40     body @ [ReturnVoid] in
  41     { name  = Cpool.make_qname name;
  42       params= args;
  43       return= 0;
  44       flags = 0;
  45       exceptions=[];
  46       traits= [];
  47       fun_scope=Global;
  48       instructions=inst
  49     }
  50
  51 (**
  52    - meth contains instruction list.
  53    - instruction contains meth list.
  54
  55    Thus, meth create multi-tree like structure.
  56    [fold_method f init meth] is folding this tree by [f].
  57 *)
  58 let rec fold_method f init meth =
  59   List.fold_left
  60     (fun a inst -> List.fold_left (fold_method f) a (get_config inst).meth)
  61     (f init meth)
  62     meth.instructions
  63
  64 (** [fold_instruction f init meth] is recursively folding all-instruction by [f]. *)
  65 let fold_instruction f init =
  66   fold_method
  67     (fun init' {instructions=insts}-> List.fold_left f init' insts)
  68     init
  69
  70 (**{6 Collecting some information}*)
  71
  72 (** [collect_const meth] returns all constant value which contained by [meth]. *)
  73 let collect_const meth=
  74   Cpool.append
  75     (method_const meth)
  76     @@ fold_instruction
  77     (fun cpool i-> Cpool.append cpool (get_config i).const)
  78     Cpool.empty meth
  79
  80
  81 (** [collect_klass meth] returns all class which contained by [meth]. *)
  82 let collect_klass meth =
  83   meth.instructions +>  HList.concat_map
  84     (fun i ->
  85        match (get_config i).klass with
  86            Some k -> [k]
  87          | None   -> [])
  88
  89 (** [collect_method meth] return all methods which contained by [meth]. *)
  90 let collect_method =
  91   Set.to_list $ fold_method (flip Set.add) Set.empty
  92
  93 (** {6 Assemble meth} *)
  94
  95 let add (max,current) n =
  96   let current' =
  97     current + n in
  98     if max < current' then
  99       (current',current')
 100     else
 101       (max,current')
 102
 103 let asm_method map index m =
 104   let zero =
 105     (0,0) in
 106   let configs =
 107     List.map get_config m.instructions in
 108   let (max_stack,_),(max_scope,_),local_count,bytes =
 109     List.fold_left
 110       (fun
 111          (stack,scope,count,bytes)
 112          {op=op;prefix=prefix;args=args;stack=st;scope=sc;count=c} ->
 113            let by =
 114              List.concat [
 115                prefix map;
 116                [Bytes.u8 op];
 117                args map] in
 118              add stack st,add scope sc,max count c,by::bytes)
 119       (zero,zero,1,[]) configs in
 120   let info =
 121     { Abc.params=m.params;
 122       Abc.return=m.return;
 123       Abc.name=Cpool.multiname_nget m.name map.cpool;
 124       Abc.flags=m.flags } in
 125   let body =
 126     { Abc.method_sig=index;
 127       Abc.max_stack=max_stack;
 128       Abc.local_count=List.length m.params+1;
 129       Abc.init_scope_depth=0;
 130       Abc.max_scope_depth=max_scope;
 131       Abc.code=List.concat @@ List.rev bytes;
 132       Abc.exceptions=[];
 133       Abc.trait_m=[] } in
 134       info,body
 135
 136 let asm_klass {cpool=cpool; meths=meths; klasses=klasses} klass =
 137   let class_info = {
 138     Abc.cinit   = index klass.cinit meths;
 139     Abc.trait_c = [];
 140   } in
 141   let flag = function
 142       Sealed -> Abc.Sealed
 143     | Final  -> Abc.Final
 144     | Interface -> Abc.Interface
 145     | ProtectedNs ns -> Abc.ProtectedNs (Cpool.namespace_nget ns cpool) in
 146   let method_trait m = {
 147     Abc.t_name = Cpool.multiname_nget m.name cpool;
 148     data       = Abc.MethodTrait (0,index m meths) } in
 149   let attr_trait id attr = {
 150     Abc.t_name = Cpool.multiname_nget attr cpool;
 151     data       = Abc.SlotTrait (id,0,0,0) } in
 152   let instance_info = {
 153     Abc.name_i = Cpool.multiname_nget klass.cname cpool;
 154     super_name = Cpool.multiname_nget klass.sname cpool;
 155     flags_i    = List.map flag klass.flags_k;
 156     interface  = List.map (flip index klasses) klass.interface;
 157     iinit      = index klass.iinit meths;
 158     trait_i    = (List.map method_trait klass.methods) @ (ExtList.List.mapi attr_trait klass.attributes)
 159   } in
 160     class_info,instance_info
 161
 162
 163 let assemble meth =
 164   let context =
 165     {cpool   = collect_const  meth;
 166      meths   = collect_method meth;
 167      klasses = collect_klass  meth} in
 168   let info,body =
 169     List.split @@ ExtList.List.mapi (asm_method context) context.meths in
 170   let class_info,instance_info =
 171     List.split @@ List.map (asm_klass context) context.klasses in
 172     {abc_cpool     = Cpool.to_abc context.cpool;
 173      method_info   = info;
 174      method_body   = body;
 175      class_info    = class_info;
 176      instance_info = instance_info}