diff options
Diffstat (limited to 'kernel/nativelambda.ml')
| -rw-r--r-- | kernel/nativelambda.ml | 162 |
1 files changed, 48 insertions, 114 deletions
diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 91b40be7..b34eede6 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -1,20 +1,23 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Util open Names open Esubst -open Term +open Constr open Declarations open Pre_env open Nativevalues open Nativeinstr -(** This file defines the lambda code generation phase of the native compiler *) +module RelDecl = Context.Rel.Declaration + exception NotClosed @@ -82,10 +85,10 @@ let get_const_prefix env c = (* A generic map function *) -let map_lam_with_binders g f n lam = +let rec map_lam_with_binders g f n lam = match lam with - | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _ - | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> lam + | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ + | Lconstruct _ | Llazy | Lforce | Lmeta _ -> lam | Lprod(dom,codom) -> let dom' = f n dom in let codom' = f n codom in @@ -133,6 +136,23 @@ let map_lam_with_binders g f n lam = | Lmakeblock(prefix,cn,tag,args) -> let args' = Array.smartmap (f n) args in if args == args' then lam else Lmakeblock(prefix,cn,tag,args') + | Luint u -> + let u' = map_uint g f n u in + if u == u' then lam else Luint u' + | Levar (evk, ty, args) -> + let ty' = f n ty in + let args' = Array.smartmap (f n) args in + if ty == ty' && args == args' then lam else Levar (evk, ty', args') + +and map_uint g f n u = + match u with + | UintVal _ -> u + | UintDigits(prefix,c,args) -> + let args' = Array.smartmap (f n) args in + if args == args' then u else UintDigits(prefix,c,args') + | UintDecomp(prefix,c,a) -> + let a' = f n a in + if a == a' then u else UintDecomp(prefix,c,a') (*s Lift and substitution *) @@ -159,10 +179,6 @@ let rec lam_exsubst subst lam = | Lrel(id,i) -> lam_subst_rel lam id i subst | _ -> map_lam_with_binders liftn lam_exsubst subst lam -let lam_subst subst lam = - if is_subs_id subst then lam - else lam_exsubst subst lam - let lam_subst_args subst args = if is_subs_id subst then args else Array.smartmap (lam_exsubst subst) args @@ -276,71 +292,6 @@ and reduce_lapp substf lids body substa largs = Llam(Array.of_list lids, simplify (liftn (List.length lids) substf) body) | [], _::_ -> simplify_app substf body substa (Array.of_list largs) - -(* [occurrence kind k lam]: - If [kind] is [true] return [true] if the variable [k] does not appear in - [lam], return [false] if the variable appear one time and not - under a lambda, a fixpoint, a cofixpoint; else raise Not_found. - If [kind] is [false] return [false] if the variable does not appear in [lam] - else raise [Not_found] -*) - -let rec occurrence k kind lam = - match lam with - | Lrel (_,n) -> - if Int.equal n k then - if kind then false else raise Not_found - else kind - | Lvar _ | Lconst _ | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _ - | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> kind - | Lprod(dom, codom) -> - occurrence k (occurrence k kind dom) codom - | Llam(ids,body) -> - let _ = occurrence (k+Array.length ids) false body in kind - | Llet(_,def,body) -> - occurrence (k+1) (occurrence k kind def) body - | Lapp(f, args) -> - occurrence_args k (occurrence k kind f) args - | Lprim(_,_,_,args) | Lmakeblock(_,_,_,args) -> - occurrence_args k kind args - | Lcase(_,t,a,br) -> - let kind = occurrence k (occurrence k kind t) a in - let r = ref kind in - Array.iter (fun (_,ids,c) -> - r := occurrence (k+Array.length ids) kind c && !r) br; - !r - | Lif (t, bt, bf) -> - let kind = occurrence k kind t in - kind && occurrence k kind bt && occurrence k kind bf - | Lfix(_,(ids,ltypes,lbodies)) - | Lcofix(_,(ids,ltypes,lbodies)) -> - let kind = occurrence_args k kind ltypes in - let _ = occurrence_args (k+Array.length ids) false lbodies in - kind - -and occurrence_args k kind args = - Array.fold_left (occurrence k) kind args - -let occur_once lam = - try let _ = occurrence 1 true lam in true - with Not_found -> false - -(* [remove_let lam] remove let expression in [lam] if the variable is *) -(* used at most once time in the body, and does not appear under *) -(* a lambda or a fix or a cofix *) - -let rec remove_let subst lam = - match lam with - | Lrel(id,i) -> lam_subst_rel lam id i subst - | Llet(id,def,body) -> - let def' = remove_let subst def in - if occur_once body then remove_let (cons def' subst) body - else - let body' = remove_let (lift subst) body in - if def == def' && body == body' then lam else Llet(id,def',body') - | _ -> map_lam_with_binders liftn remove_let subst lam - - (*s Translation from [constr] to [lambda] *) (* Translation of constructor *) @@ -349,15 +300,17 @@ let is_value lc = match lc with | Lval _ -> true | Lmakeblock(_,_,_,args) when Array.is_empty args -> true + | Luint (UintVal _) -> true | _ -> false - + let get_value lc = match lc with | Lval v -> v - | Lmakeblock(_,_,tag,args) when Array.is_empty args -> + | Lmakeblock(_,_,tag,args) when Array.is_empty args -> Nativevalues.mk_int tag + | Luint (UintVal i) -> Nativevalues.mk_uint i | _ -> raise Not_found - + let make_args start _end = Array.init (start - _end + 1) (fun i -> Lrel (Anonymous, start - i)) @@ -405,8 +358,6 @@ module Vect = size = 0; } - let length v = v.size - let extend v = if Int.equal v.size (Array.length v.elems) then let new_size = min (2*v.size) Sys.max_array_length in @@ -420,33 +371,15 @@ module Vect = v.elems.(v.size) <- a; v.size <- v.size + 1 - let push_pos v a = - let pos = v.size in - push v a; - pos - let popn v n = v.size <- max 0 (v.size - n) let pop v = popn v 1 - let get v n = - if v.size <= n then invalid_arg "Vect.get:index out of bounds"; - v.elems.(n) - let get_last v n = if v.size <= n then invalid_arg "Vect.get:index out of bounds"; v.elems.(v.size - n - 1) - - let last v = - if Int.equal v.size 0 then invalid_arg "Vect.last:index out of bounds"; - v.elems.(v.size - 1) - - let clear v = v.size <- 0 - - let to_array v = Array.sub v.elems 0 v.size - end let empty_args = [||] @@ -466,7 +399,7 @@ module Renv = type constructor_info = tag * int * int (* nparam nrealargs *) type t = { - name_rel : name Vect.t; + name_rel : Name.t Vect.t; construct_tbl : constructor_info ConstrTable.t; } @@ -505,9 +438,9 @@ module Renv = (* What about pattern matching ?*) let is_lazy prefix t = - match kind_of_term t with + match kind t with | App (f,args) -> - begin match kind_of_term f with + begin match kind f with | Construct (c,_) -> let entry = mkInd (fst c) in (try @@ -536,16 +469,17 @@ let empty_evars = let empty_ids = [||] let rec lambda_of_constr env sigma c = - match kind_of_term c with + match kind c with | Meta mv -> let ty = meta_type sigma mv in Lmeta (mv, lambda_of_constr env sigma ty) - | Evar ev -> + | Evar (evk,args as ev) -> (match evar_value sigma ev with | None -> - let ty = evar_type sigma ev in - Levar(ev, lambda_of_constr env sigma ty) + let ty = evar_type sigma ev in + let args = Array.map (lambda_of_constr env sigma) args in + Levar(evk, lambda_of_constr env sigma ty, args) | Some t -> lambda_of_constr env sigma t) | Cast (c, _, _) -> lambda_of_constr env sigma c @@ -568,7 +502,7 @@ let rec lambda_of_constr env sigma c = Lprod(ld, Llam([|id|], lc)) | Lambda _ -> - let params, body = decompose_lam c in + let params, body = Term.decompose_lam c in let ids = get_names (List.rev params) in Renv.push_rels env ids; let lb = lambda_of_constr env sigma body in @@ -603,7 +537,7 @@ let rec lambda_of_constr env sigma c = { asw_ind = ind; asw_ci = ci; asw_reloc = tbl; - asw_finite = mib.mind_finite <> Decl_kinds.CoFinite; + asw_finite = mib.mind_finite <> CoFinite; asw_prefix = prefix} in (* translation of the argument *) @@ -642,6 +576,7 @@ let rec lambda_of_constr env sigma c = Lfix(rec_init, (names, ltypes, lbodies)) | CoFix(init,(names,type_bodies,rec_bodies)) -> + let rec_bodies = Array.map2 (Hook.get Clambda.eta_expand !global_env) rec_bodies type_bodies in let ltypes = lambda_of_args env sigma 0 type_bodies in Renv.push_rels env names; let lbodies = lambda_of_args env sigma 0 rec_bodies in @@ -649,7 +584,7 @@ let rec lambda_of_constr env sigma c = Lcofix(init, (names, ltypes, lbodies)) and lambda_of_app env sigma f args = - match kind_of_term f with + match kind f with | Const (kn,u as c) -> let kn,u = get_alias !global_env c in let cb = lookup_constant kn !global_env in @@ -727,8 +662,7 @@ let optimize lam = let lambda_of_constr env sigma c = set_global_env env; let env = Renv.make () in - let open Context.Rel.Declaration in - let ids = List.rev_map get_name !global_env.env_rel_context in + let ids = List.rev_map RelDecl.get_name !global_env.env_rel_context.env_rel_ctx in Renv.push_rels env (Array.of_list ids); let lam = lambda_of_constr env sigma c in (* if Flags.vm_draw_opt () then begin @@ -745,7 +679,7 @@ let compile_static_int31 fc args = if not fc then raise Not_found else Luint (UintVal (Uint31.of_int (Array.fold_left - (fun temp_i -> fun t -> match kind_of_term t with + (fun temp_i -> fun t -> match kind t with | Construct ((_,d),_) -> 2*temp_i+d-1 | _ -> raise NotClosed) 0 args))) |