@@ -27,16 +27,12 @@ let arity_of_var (meta : Lam_stats.t) (v : Ident.t) =
2727 (* * for functional parameter, if it is a high order function,
2828 if it's not from function parameter, we should warn
2929 *)
30- begin
3130 match Ident_hashtbl. find_opt meta.ident_tbl v with
3231 | Some (FunctionId {arity;_} ) -> arity
3332 | Some _
3433 | None ->
35- (* Format.fprintf Format.err_formatter *)
36- (* "@[%s %a is not function/functor@]@." meta.filename Ident.print v ; *)
37- Arity_na
34+ Lam_arity. na
3835
39- end
4036
4137(* we need record all aliases -- since not all aliases are eliminated,
4238 mostly are toplevel bindings
@@ -48,36 +44,29 @@ let rec get_arity
4844 (lam : Lam.t ) :
4945 Lam_arity. t =
5046 match lam with
51- | Lconst _ -> Arity_info ( true , [] , false )
47+ | Lconst _ -> Lam_arity. non_function_arity_info
5248 | Lvar v -> arity_of_var meta v
5349 | Llet (_ ,_ ,_ , l ) -> get_arity meta l
54-
55- (* begin match Parsetree_util.has_arity prim_attributes with *)
56- (* | Some arity -> *)
57- (* (\* Ext_log.dwarn __LOC__ "arity %d" arity; *\) *)
58- (* Determin(false, [arity, None], false) *)
59- (* | None -> NA *)
60- (* end *)
6150 | Lprim {primitive = Pfield (n,_);
6251 args = [ Lglobal_module id ]; _} ->
6352 begin match (Lam_compile_env. cached_find_ml_id_pos id n meta.env).arity with
6453 | Single x -> x
65- | Submodule _ -> Arity_na
54+ | Submodule _ -> Lam_arity. na
6655 end
6756 | Lprim {primitive = Pfield (m,_);
6857 args = [ Lprim {primitive = Pfield (n,_);
6958 args = [ Lglobal_module id]} ]
7059 ; _} ->
7160 begin match (Lam_compile_env. cached_find_ml_id_pos id n meta.env).arity with
7261 | Submodule subs -> subs.(m)
73- | Single _ -> Arity_na
62+ | Single _ -> Lam_arity. na
7463 end
75-
76- | Lprim { primitive = Pfield _ ; _} -> Arity_na (* * TODO *)
77- | Lprim { primitive = Praise ; _} -> Arity_info ( true , [] , true )
78- | Lprim {primitive = Pccall _ ; _} -> Arity_info ( false , [] , false )
64+ (* TODO: all information except Pccall is complete, we could
65+ get more arity information
66+ * )
67+ | Lprim {primitive = Praise ; _} -> Lam_arity. raise_arity_info
7968 | Lglobal_module _ (* TODO: fix me never going to happen assert false *)
80- | Lprim _ -> Arity_info ( true , [] , false )
69+ | Lprim _ -> Lam_arity. na (* CHECK * )
8170 (* shall we handle primitive in a direct way,
8271 since we know all the information
8372 Invariant: all primitive application is fully applied,
@@ -90,41 +79,33 @@ let rec get_arity
9079 it seems true that primitive is always fully applied, however,
9180 it can return a function
9281 *)
93- | Lletrec (_ , body ) ->
94- get_arity meta body
95- (* | Lapply(Lprim( p, _), _args, _info) -> *)
96- (* Determin(true, [], false) (\** Invariant : primtive application is always complete.. *\) *)
82+ | Lletrec (_ , body ) -> get_arity meta body
9783
9884 | Lapply {fn = app ; args; _ } -> (* detect functor application *)
9985 let fn = get_arity meta app in
10086 begin match fn with
101- | Arity_na -> Arity_na
87+ | Arity_na -> Lam_arity. na
10288 | Arity_info (b , xs , tail ) ->
10389 let rec take (xs : _ list ) arg_length =
10490 match xs with
105- | ( x ) :: xs ->
106- if arg_length = x then Lam_arity. Arity_info (b, xs, tail)
91+ | x :: yys ->
92+ if arg_length = x then Lam_arity. info b yys tail
10793 else if arg_length > x then
108- take xs (arg_length - x)
109- else Arity_info (b,
110- (x - arg_length ) :: xs ,
111- tail)
94+ take yys (arg_length - x)
95+ else Lam_arity. info b
96+ (( x - arg_length ) :: yys)
97+ tail
11298 | [] ->
113- if tail then Arity_info (b, [] , tail)
114- else if not b then
115- Arity_na
116- else Arity_na
99+ if tail then Lam_arity. info b [] tail
100+ else Lam_arity. na
117101 (* Actually, you can not have truly deministic arities
118102 for example [fun x -> x ]
119103 *)
120- (* Ext_pervasives.failwithf ~loc:__LOC__ "%s %s" *)
121- (* (Format.asprintf "%a" pp_arities fn) *)
122- (* (Lam_util.string_of_lambda lam) *)
123104 in
124105 take xs (List. length args)
125106 end
126- | Lfunction {arity; function_kind; params; body = l } ->
127- Lam_arity. merge arity (get_arity meta l )
107+ | Lfunction {arity; body} ->
108+ Lam_arity. merge arity (get_arity meta body )
128109 | Lswitch (l, {sw_failaction;
129110 sw_consts;
130111 sw_blocks;
@@ -141,30 +122,30 @@ let rec get_arity
141122 | None -> all_lambdas meta (Ext_list. map snd sw )
142123 | Some v -> all_lambdas meta (v:: Ext_list. map snd sw)
143124 end
144- | Lstaticraise _ -> Arity_na (* since it will not be in tail position *)
145125 | Lstaticcatch (_ , _ , handler ) -> get_arity meta handler
146126 | Ltrywith (l1 , _ , l2 ) ->
147127 all_lambdas meta [l1;l2]
148128 | Lifthenelse (l1 , l2 , l3 ) ->
149129 all_lambdas meta [l2;l3]
150130 | Lsequence (_ , l2 ) -> get_arity meta l2
151- | Lsend (u , m , o , ll , v ) -> Arity_na
152- | Lifused (v , l ) -> Arity_na
131+ | Lstaticraise _ (* since it will not be in tail position *)
132+ | Lsend _
133+ | Lifused _ -> Lam_arity. na
153134 | Lwhile _
154135 | Lfor _
155- | Lassign _ -> Arity_info ( true , [] , false )
136+ | Lassign _ -> Lam_arity. non_function_arity_info
156137
157138and all_lambdas meta (xs : Lam.t list ) =
158139 match xs with
159140 | y :: ys ->
160141 let arity = get_arity meta y in
161142 List. fold_left (fun exist (v : Lam.t ) ->
162143 match (exist : Lam_arity.t ) with
163- | Arity_na -> Arity_na
164- | Arity_info (b , xs , tail ) ->
144+ | Arity_na -> Lam_arity. na
145+ | Arity_info (bbb , xxxs , tail ) ->
165146 begin
166147 match get_arity meta v with
167- | Arity_na -> Arity_na
148+ | Arity_na -> Lam_arity. na
168149 | Arity_info (u ,ys ,tail2 ) ->
169150 let rec aux (b ,acc ) xs ys =
170151 match xs,ys with
@@ -175,8 +156,8 @@ and all_lambdas meta (xs : Lam.t list) =
175156 aux (b,x::acc) [] xs
176157 | x ::xs , y ::ys when x = y -> aux (b, (y :: acc)) xs ys
177158 | _ , _ -> (false , List. rev acc, false ) in
178- let (b,acc, tail3) = aux ( u && b , [] ) xs ys in
179- Arity_info (b, acc, tail3)
159+ let (b,acc, tail3) = aux ( u && bbb , [] ) xxxs ys in
160+ Lam_arity. info b acc tail3
180161 end
181162 ) arity ys
182163 | _ -> assert false
0 commit comments