549 lines
20 KiB
OCaml
549 lines
20 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* Objective Caml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. All rights reserved. This file is distributed *)
|
|
(* under the terms of the Q Public License version 1.0. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* $Id$ *)
|
|
|
|
(* Compilation of pattern matching *)
|
|
|
|
open Misc
|
|
open Location
|
|
open Asttypes
|
|
open Primitive
|
|
open Types
|
|
open Typedtree
|
|
open Lambda
|
|
|
|
(* See Peyton-Jones, "The Implementation of functional programming
|
|
languages", chapter 5. *)
|
|
|
|
type pattern_matching =
|
|
{ mutable cases : (pattern list * lambda) list;
|
|
args : (lambda * let_kind) list }
|
|
|
|
(* To group lines of patterns with identical keys *)
|
|
|
|
let add_line patl_action pm =
|
|
pm.cases <- patl_action :: pm.cases; pm
|
|
|
|
let add make_matching_fun division key patl_action args =
|
|
try
|
|
let pm = List.assoc key division in
|
|
pm.cases <- patl_action :: pm.cases;
|
|
division
|
|
with Not_found ->
|
|
let pm = make_matching_fun args in
|
|
pm.cases <- patl_action :: pm.cases;
|
|
(key, pm) :: division
|
|
|
|
(* To find reasonable names for let-bound and lambda-bound idents *)
|
|
|
|
let rec name_pattern default = function
|
|
(pat :: patl, action) :: rem ->
|
|
begin match pat.pat_desc with
|
|
Tpat_var id -> id
|
|
| Tpat_alias(p, id) -> id
|
|
| _ -> name_pattern default rem
|
|
end
|
|
| _ -> Ident.create default
|
|
|
|
(* To let-bind expressions to variables *)
|
|
|
|
let bind str var exp body =
|
|
match exp with
|
|
Lvar var' when Ident.same var var' -> body
|
|
| _ -> Llet(str, var, exp, body)
|
|
|
|
(* To remove aliases and bind named components *)
|
|
|
|
let any_pat =
|
|
{ pat_desc = Tpat_any; pat_loc = Location.none;
|
|
pat_type = Ctype.none; pat_env = Env.empty }
|
|
|
|
let simplify_matching m =
|
|
match m.args with
|
|
[] -> m
|
|
| (arg, mut) :: argl ->
|
|
let rec simplify = function
|
|
(pat :: patl, action as patl_action) :: rem ->
|
|
begin match pat.pat_desc with
|
|
Tpat_var id ->
|
|
(any_pat :: patl, bind Alias id arg action) ::
|
|
simplify rem
|
|
| Tpat_alias(p, id) ->
|
|
simplify ((p :: patl, bind Alias id arg action) :: rem)
|
|
| _ ->
|
|
patl_action :: simplify rem
|
|
end
|
|
| cases -> cases in
|
|
{ args = m.args; cases = simplify m.cases }
|
|
|
|
(* Matching against a constant *)
|
|
|
|
let make_constant_matching = function
|
|
[] -> fatal_error "Matching.make_constant_matching"
|
|
| (arg :: argl) -> {cases = []; args = argl}
|
|
|
|
let divide_constant {cases = cl; args = al} =
|
|
let rec divide = function
|
|
({pat_desc = Tpat_constant cst} :: patl, action) :: rem ->
|
|
let (constants, others) = divide rem in
|
|
(add make_constant_matching constants cst (patl, action) al, others)
|
|
| cl ->
|
|
([], {cases = cl; args = al})
|
|
in divide cl
|
|
|
|
(* Matching against a constructor *)
|
|
|
|
let make_field_args binding_kind arg first_pos last_pos argl =
|
|
let rec make_args pos =
|
|
if pos > last_pos
|
|
then argl
|
|
else (Lprim(Pfield pos, [arg]), binding_kind) :: make_args (pos + 1)
|
|
in make_args first_pos
|
|
|
|
let make_constr_matching cstr = function
|
|
[] -> fatal_error "Matching.make_constr_matching"
|
|
| ((arg, mut) :: argl) ->
|
|
let newargs =
|
|
match cstr.cstr_tag with
|
|
Cstr_constant _ | Cstr_block _ ->
|
|
make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl
|
|
| Cstr_exception _ ->
|
|
make_field_args Alias arg 1 cstr.cstr_arity argl in
|
|
{cases = []; args = newargs}
|
|
|
|
let divide_constructor {cases = cl; args = al} =
|
|
let rec divide = function
|
|
({pat_desc = Tpat_construct(cstr, args)} :: patl, action) :: rem ->
|
|
let (constructs, others) = divide rem in
|
|
(add (make_constr_matching cstr) constructs
|
|
cstr.cstr_tag (args @ patl, action) al,
|
|
others)
|
|
| cl ->
|
|
([], {cases = cl; args = al})
|
|
in divide cl
|
|
|
|
(* Matching against a variable *)
|
|
|
|
let divide_var {cases = cl; args = al} =
|
|
let rec divide = function
|
|
({pat_desc = Tpat_any} :: patl, action) :: rem ->
|
|
let (vars, others) = divide rem in
|
|
(add_line (patl, action) vars, others)
|
|
| cl ->
|
|
(make_constant_matching al, {cases = cl; args = al})
|
|
in divide cl
|
|
|
|
(* Matching against a tuple pattern *)
|
|
|
|
let make_tuple_matching num_comps = function
|
|
[] -> fatal_error "Matching.make_tuple_matching"
|
|
| (arg, mut) :: argl ->
|
|
let rec make_args pos =
|
|
if pos >= num_comps
|
|
then argl
|
|
else (Lprim(Pfield pos, [arg]), Alias) :: make_args (pos + 1) in
|
|
{cases = []; args = make_args 0}
|
|
|
|
let divide_tuple arity {cases = cl; args = al} =
|
|
let rec divide = function
|
|
({pat_desc = Tpat_tuple args} :: patl, action) :: rem ->
|
|
let (tuples, others) = divide rem in
|
|
(add_line (args @ patl, action) tuples, others)
|
|
| ({pat_desc = Tpat_any} :: patl, action) :: rem ->
|
|
let (tuples, others) = divide rem in
|
|
(add_line (replicate_list any_pat arity @ patl, action) tuples, others)
|
|
| cl ->
|
|
(make_tuple_matching arity al, {cases = cl; args = al})
|
|
in divide cl
|
|
|
|
(* Matching against a record pattern *)
|
|
|
|
let make_record_matching all_labels = function
|
|
[] -> fatal_error "Matching.make_tuple_matching"
|
|
| ((arg, mut) :: argl) ->
|
|
let rec make_args pos =
|
|
if pos >= Array.length all_labels then argl else begin
|
|
let lbl = all_labels.(pos) in
|
|
let access =
|
|
match lbl.lbl_repres with
|
|
Record_regular -> Pfield lbl.lbl_pos
|
|
| Record_float -> Pfloatfield lbl.lbl_pos in
|
|
let str =
|
|
match lbl.lbl_mut with
|
|
Immutable -> Alias
|
|
| Mutable -> StrictOpt in
|
|
(Lprim(access, [arg]), str) :: make_args(pos + 1)
|
|
end in
|
|
{cases = []; args = make_args 0}
|
|
|
|
let divide_record all_labels {cases = cl; args = al} =
|
|
let num_fields = Array.length all_labels in
|
|
let record_matching_line lbl_pat_list =
|
|
let patv = Array.create num_fields any_pat in
|
|
List.iter (fun (lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list;
|
|
Array.to_list patv in
|
|
let rec divide = function
|
|
({pat_desc = Tpat_record lbl_pat_list} :: patl, action) :: rem ->
|
|
let (records, others) = divide rem in
|
|
(add_line (record_matching_line lbl_pat_list @ patl, action) records,
|
|
others)
|
|
| ({pat_desc = Tpat_any} :: patl, action) :: rem ->
|
|
let (records, others) = divide rem in
|
|
(add_line (record_matching_line [] @ patl, action) records, others)
|
|
| cl ->
|
|
(make_record_matching all_labels al, {cases = cl; args = al})
|
|
in divide cl
|
|
|
|
(* Matching against an or pattern. *)
|
|
|
|
let rec flatten_orpat_match pat =
|
|
match pat.pat_desc with
|
|
Tpat_or(p1, p2) -> flatten_orpat_match p1 @ flatten_orpat_match p2
|
|
| _ -> [[pat], lambda_unit]
|
|
|
|
let divide_orpat = function
|
|
{cases = (orpat :: patl, act) :: casel; args = arg1 :: argl as args} ->
|
|
({cases = flatten_orpat_match orpat; args = [arg1]},
|
|
{cases = [patl, act]; args = argl},
|
|
{cases = casel; args = args})
|
|
| _ ->
|
|
fatal_error "Matching.divide_orpat"
|
|
|
|
(* Matching against an array pattern *)
|
|
|
|
let make_array_matching kind len = function
|
|
[] -> fatal_error "Matching.make_array_matching"
|
|
| ((arg, mut) :: argl) ->
|
|
let rec make_args pos =
|
|
if pos >= len
|
|
then argl
|
|
else (Lprim(Parrayrefu kind, [arg; Lconst(Const_base(Const_int pos))]),
|
|
StrictOpt) :: make_args (pos + 1) in
|
|
{cases = []; args = make_args 0}
|
|
|
|
let divide_array kind {cases = cl; args = al} =
|
|
let rec divide = function
|
|
({pat_desc = Tpat_array(args)} :: patl, action) :: rem ->
|
|
let len = List.length args in
|
|
let (constructs, others) = divide rem in
|
|
(add (make_array_matching kind len) constructs len
|
|
(args @ patl, action) al,
|
|
others)
|
|
| cl ->
|
|
([], {cases = cl; args = al})
|
|
in divide cl
|
|
|
|
(* To combine sub-matchings together *)
|
|
|
|
let combine_var (lambda1, total1) (lambda2, total2) =
|
|
if total1 then (lambda1, true)
|
|
else if lambda2 = Lstaticfail then (lambda1, total1)
|
|
else (Lcatch(lambda1, lambda2), total2)
|
|
|
|
let make_test_sequence tst arg const_lambda_list =
|
|
List.fold_right
|
|
(fun (c, act) rem ->
|
|
Lifthenelse(Lprim(tst, [arg; Lconst(Const_base c)]), act, rem))
|
|
const_lambda_list Lstaticfail
|
|
|
|
let make_switch_or_test_sequence arg const_lambda_list int_lambda_list =
|
|
let min_key =
|
|
List.fold_right (fun (k, l) m -> min k m) int_lambda_list max_int in
|
|
let max_key =
|
|
List.fold_right (fun (k, l) m -> max k m) int_lambda_list min_int in
|
|
(* min_key and max_key can be arbitrarily large, so watch out for
|
|
overflow in the following comparison *)
|
|
if List.length int_lambda_list <= 1 + max_key / 4 - min_key / 4 then
|
|
(* Sparse matching -- use a sequence of tests
|
|
(4 bytecode instructions per test) *)
|
|
make_test_sequence (Pintcomp Ceq) arg const_lambda_list
|
|
else begin
|
|
(* Dense matching -- use a jump table
|
|
(2 bytecode instructions + 1 word per entry in the table) *)
|
|
let numcases = max_key - min_key + 1 in
|
|
let cases =
|
|
List.map (fun (key, l) -> (key - min_key, l)) int_lambda_list in
|
|
let offsetarg =
|
|
if min_key = 0 then arg else Lprim(Poffsetint(-min_key), [arg]) in
|
|
Lswitch(offsetarg,
|
|
{sw_numconsts = numcases; sw_consts = cases;
|
|
sw_numblocks = 0; sw_blocks = []; sw_checked = true})
|
|
end
|
|
|
|
let make_bitvect_check arg int_lambda_list =
|
|
let bv = String.make 32 '\000' in
|
|
List.iter
|
|
(fun (n, l) ->
|
|
bv.[n lsr 3] <- Char.chr(Char.code bv.[n lsr 3] lor (1 lsl (n land 7))))
|
|
int_lambda_list;
|
|
Lifthenelse(Lprim(Pbittest, [Lconst(Const_base(Const_string bv)); arg]),
|
|
lambda_unit, Lstaticfail)
|
|
|
|
let prim_string_equal =
|
|
Pccall{prim_name = "string_equal";
|
|
prim_arity = 2; prim_alloc = false;
|
|
prim_native_name = ""; prim_native_float = false}
|
|
|
|
let combine_constant arg cst (const_lambda_list, total1) (lambda2, total2) =
|
|
let lambda1 =
|
|
match cst with
|
|
Const_int _ ->
|
|
let int_lambda_list =
|
|
List.map (function Const_int n, l -> n,l | _ -> assert false)
|
|
const_lambda_list in
|
|
make_switch_or_test_sequence arg const_lambda_list int_lambda_list
|
|
| Const_char _ ->
|
|
let int_lambda_list =
|
|
List.map (function Const_char c, l -> (Char.code c, l)
|
|
| _ -> assert false)
|
|
const_lambda_list in
|
|
if List.for_all (fun (c, l) -> l = lambda_unit) const_lambda_list then
|
|
make_bitvect_check arg int_lambda_list
|
|
else
|
|
make_switch_or_test_sequence arg const_lambda_list int_lambda_list
|
|
| Const_string _ ->
|
|
make_test_sequence prim_string_equal arg const_lambda_list
|
|
| Const_float _ ->
|
|
make_test_sequence (Pfloatcomp Ceq) arg const_lambda_list
|
|
in (Lcatch(lambda1, lambda2), total2)
|
|
|
|
let combine_constructor arg cstr (tag_lambda_list, total1) (lambda2, total2) =
|
|
if cstr.cstr_consts < 0 then begin
|
|
(* Special cases for exceptions *)
|
|
let lambda1 =
|
|
List.fold_right
|
|
(fun (ex, act) rem ->
|
|
match ex with
|
|
| Cstr_exception path ->
|
|
Lifthenelse(Lprim(Pintcomp Ceq,
|
|
[Lprim(Pfield 0, [arg]); transl_path path]),
|
|
act, rem)
|
|
| _ -> assert false)
|
|
tag_lambda_list Lstaticfail
|
|
in (Lcatch(lambda1, lambda2), total2)
|
|
end else begin
|
|
(* Regular concrete type *)
|
|
let rec split_cases = function
|
|
[] -> ([], [])
|
|
| (cstr, act) :: rem ->
|
|
let (consts, nonconsts) = split_cases rem in
|
|
match cstr with
|
|
Cstr_constant n -> ((n, act) :: consts, nonconsts)
|
|
| Cstr_block n -> (consts, (n, act) :: nonconsts)
|
|
| _ -> assert false in
|
|
let (consts, nonconsts) = split_cases tag_lambda_list in
|
|
let lambda1 =
|
|
match (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) with
|
|
(1, 0, [0, act], []) -> act
|
|
| (0, 1, [], [0, act]) -> act
|
|
| (1, 1, [0, act1], [0, act2]) ->
|
|
Lifthenelse(arg, act2, act1)
|
|
| (1, 1, [0, act1], []) ->
|
|
Lifthenelse(arg, Lstaticfail, act1)
|
|
| (1, 1, [], [0, act2]) ->
|
|
Lifthenelse(arg, act2, Lstaticfail)
|
|
| (_, _, _, _) ->
|
|
Lswitch(arg, {sw_numconsts = cstr.cstr_consts;
|
|
sw_consts = consts;
|
|
sw_numblocks = cstr.cstr_nonconsts;
|
|
sw_blocks = nonconsts;
|
|
sw_checked = false}) in
|
|
if total1
|
|
&& List.length tag_lambda_list = cstr.cstr_consts + cstr.cstr_nonconsts
|
|
then (lambda1, true)
|
|
else (Lcatch(lambda1, lambda2), total2)
|
|
end
|
|
|
|
let combine_orpat (lambda1, total1) (lambda2, total2) (lambda3, total3) =
|
|
(Lcatch(Lsequence(lambda1, lambda2), lambda3), total3)
|
|
|
|
let combine_array kind arg (len_lambda_list, total1) (lambda2, total2) =
|
|
let lambda1 =
|
|
match len_lambda_list with
|
|
[] -> Lstaticfail (* does not happen? *)
|
|
| [n, act] ->
|
|
Lifthenelse(Lprim(Pintcomp Ceq,
|
|
[Lprim(Parraylength kind, [arg]);
|
|
Lconst(Const_base(Const_int n))]),
|
|
act, Lstaticfail)
|
|
| _ ->
|
|
let max_len =
|
|
List.fold_left (fun m (n, act) -> max m n) 0 len_lambda_list in
|
|
Lswitch(Lprim(Parraylength kind, [arg]),
|
|
{sw_numblocks = 0; sw_blocks = []; sw_checked = true;
|
|
sw_numconsts = max_len + 1; sw_consts = len_lambda_list}) in
|
|
(Lcatch(lambda1, lambda2), total2)
|
|
|
|
(* Insertion of debugging events *)
|
|
|
|
let rec event_branch repr lam =
|
|
begin match lam, repr with
|
|
(_, None) ->
|
|
lam
|
|
| (Levent(lam', ev), Some r) ->
|
|
incr r;
|
|
Levent(lam', {lev_loc = ev.lev_loc;
|
|
lev_kind = ev.lev_kind;
|
|
lev_repr = repr;
|
|
lev_env = ev.lev_env})
|
|
| (Llet(str, id, lam, body), _) ->
|
|
Llet(str, id, lam, event_branch repr body)
|
|
| (_, Some r) ->
|
|
(* incr r;
|
|
Levent(lam, {lev_loc = -1;
|
|
lev_kind = Lev_before;
|
|
lev_repr = repr;
|
|
lev_env = Env.Env_empty})
|
|
*) fatal_error "Matching.event_branch"
|
|
end
|
|
|
|
(* The main compilation function.
|
|
Input: a pattern matching.
|
|
Output: a lambda term, a "total" flag (true if we're sure that the
|
|
matching covers all cases; this is an approximation). *)
|
|
|
|
let rec compile_match repr m =
|
|
|
|
let rec compile_list = function
|
|
[] -> ([], true)
|
|
| (key, pm) :: rem ->
|
|
let (lambda1, total1) = compile_match repr pm in
|
|
let (list2, total2) = compile_list rem in
|
|
((key, lambda1) :: list2, total1 & total2) in
|
|
|
|
match m with
|
|
{ cases = [] } ->
|
|
(Lstaticfail, false)
|
|
| { cases = ([], action) :: rem; args = argl } ->
|
|
if is_guarded action then begin
|
|
let (lambda, total) =
|
|
compile_match None { cases = rem; args = argl }
|
|
in
|
|
(Lcatch(event_branch repr action, lambda), total)
|
|
end else
|
|
(event_branch repr action, true)
|
|
| { args = (arg, str) :: argl } ->
|
|
let v = name_pattern "match" m.cases in
|
|
let newarg = Lvar v in
|
|
let pm =
|
|
simplify_matching
|
|
{ cases = m.cases; args = (newarg, Alias) :: argl } in
|
|
let (lam, total) =
|
|
match pm.cases with
|
|
(pat :: patl, action) :: _ ->
|
|
begin match pat.pat_desc with
|
|
Tpat_any ->
|
|
let (vars, others) = divide_var pm in
|
|
combine_var (compile_match repr vars)
|
|
(compile_match repr others)
|
|
| Tpat_constant cst ->
|
|
let (constants, others) = divide_constant pm in
|
|
combine_constant newarg cst
|
|
(compile_list constants) (compile_match repr others)
|
|
| Tpat_tuple patl ->
|
|
let (tuples, others) = divide_tuple (List.length patl) pm in
|
|
combine_var (compile_match repr tuples)
|
|
(compile_match repr others)
|
|
| Tpat_construct(cstr, patl) ->
|
|
let (constrs, others) = divide_constructor pm in
|
|
combine_constructor newarg cstr
|
|
(compile_list constrs) (compile_match repr others)
|
|
| Tpat_record((lbl, _) :: _) ->
|
|
let (records, others) = divide_record lbl.lbl_all pm in
|
|
combine_var (compile_match repr records)
|
|
(compile_match repr others)
|
|
| Tpat_array(patl) ->
|
|
let kind = Typeopt.array_pattern_kind pat in
|
|
let (arrays, others) = divide_array kind pm in
|
|
combine_array kind newarg (compile_list arrays)
|
|
(compile_match repr others)
|
|
| Tpat_or(pat1, pat2) ->
|
|
(* Avoid duplicating the code of the action *)
|
|
let (or_match, remainder_line, others) = divide_orpat pm in
|
|
combine_orpat (compile_match None or_match)
|
|
(compile_match repr remainder_line)
|
|
(compile_match repr others)
|
|
| _ ->
|
|
fatal_error "Matching.compile_match1"
|
|
end
|
|
| _ -> fatal_error "Matching.compile_match2" in
|
|
(bind str v arg lam, total)
|
|
| _ -> assert false
|
|
|
|
(* The entry points *)
|
|
|
|
let compile_matching repr handler_fun arg pat_act_list =
|
|
let pm =
|
|
{ cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
|
|
args = [arg, Strict] } in
|
|
let (lambda, total) = compile_match repr pm in
|
|
if total then lambda else Lcatch(lambda, handler_fun())
|
|
|
|
let partial_function loc () =
|
|
Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
|
|
[transl_path Predef.path_match_failure;
|
|
Lconst(Const_block(0,
|
|
[Const_base(Const_string !Location.input_name);
|
|
Const_base(Const_int loc.loc_start);
|
|
Const_base(Const_int loc.loc_end)]))])])
|
|
|
|
let for_function loc repr param pat_act_list =
|
|
compile_matching repr (partial_function loc) param pat_act_list
|
|
|
|
let for_trywith param pat_act_list =
|
|
compile_matching None (fun () -> Lprim(Praise, [param])) param pat_act_list
|
|
|
|
let for_let loc param pat body =
|
|
compile_matching None (partial_function loc) param [pat, body]
|
|
|
|
(* Handling of tupled functions and matches *)
|
|
|
|
exception Cannot_flatten
|
|
|
|
let flatten_pattern size p =
|
|
match p.pat_desc with
|
|
Tpat_tuple args -> args
|
|
| Tpat_any -> replicate_list any_pat size
|
|
| _ -> raise Cannot_flatten
|
|
|
|
let flatten_cases size cases =
|
|
List.map (function (pat :: _, act) -> (flatten_pattern size pat, act)
|
|
| _ -> assert false)
|
|
cases
|
|
|
|
let for_tupled_function loc paraml pats_act_list =
|
|
let pm =
|
|
{ cases = pats_act_list;
|
|
args = List.map (fun id -> (Lvar id, Strict)) paraml } in
|
|
let (lambda, total) = compile_match None pm in
|
|
if total then lambda else Lcatch(lambda, partial_function loc ())
|
|
|
|
let for_multiple_match loc paraml pat_act_list =
|
|
let pm1 =
|
|
{ cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
|
|
args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] } in
|
|
let pm2 =
|
|
simplify_matching pm1 in
|
|
try
|
|
let idl = List.map (fun _ -> Ident.create "match") paraml in
|
|
let pm3 =
|
|
{ cases = flatten_cases (List.length paraml) pm2.cases;
|
|
args = List.map (fun id -> (Lvar id, Alias)) idl } in
|
|
let (lambda, total) = compile_match None pm3 in
|
|
let lambda2 =
|
|
if total then lambda else Lcatch(lambda, partial_function loc ()) in
|
|
List.fold_right2 (bind Strict) idl paraml lambda2
|
|
with Cannot_flatten ->
|
|
let (lambda, total) = compile_match None pm2 in
|
|
if total then lambda else Lcatch(lambda, partial_function loc ())
|