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