path: root/bytecomp/matching.ml

(***********************************************************************)
(*                                                                     *)
(*                           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 ())