← Back to branch summary

~ubuntu-branches/debian/sid/ocaml/sid

« back to all changes in this revision

Viewing changes to bytecomp/matching.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stefano Zacchiroli
  • Date: 2009-02-22 08:49:13 UTC
  • mfrom: (12.1.1 squeeze)
  • Revision ID: james.westby@ubuntu.com-20090222084913-3i0uw2bhd0lgw0ok
* Uploading to unstable
* debian/control: bump dh-ocaml to (>= 0.4) to avoid buggy ocamlinit.mk

Show diffs side-by-side

added added

removed removed

Lines of Context:
bytecomp/matching.ml
10
10
(*                                                                     *)
11
11
(***********************************************************************)
12
12
 
13
 
(* $Id: matching.ml,v 1.67.12.1 2007/06/08 08:03:16 garrigue Exp $ *)
 
13
(* $Id: matching.ml,v 1.71 2008/08/01 16:57:10 mauny Exp $ *)
14
14
 
15
15
(* Compilation of pattern matching *)
16
16
 
203
203
          let l' = all_record_args l' in
204
204
          p, List.fold_right (fun (_,p) r -> p::r) l' rem
205
205
      | _ -> p,List.fold_right (fun (_,p) r -> p::r) l rem)
206
 
  | _ -> fatal_error "Matching.ctx_matcher"
 
206
  | Tpat_lazy omega ->
 
207
      (fun q rem -> match q.pat_desc with
 
208
      | Tpat_lazy arg -> p, (arg::rem)
 
209
      | _          -> p, (omega::rem))
 
210
 | _ -> fatal_error "Matching.ctx_matcher"
207
211
 
208
212
 
209
213
 
616
620
| Tpat_array pats ->
617
621
    List.fold_left extract_vars r pats
618
622
| Tpat_variant (_,Some p, _) -> extract_vars r p
 
623
| Tpat_lazy p -> extract_vars r p
619
624
| Tpat_or (p,_,_) -> extract_vars r p
620
625
| Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> r
621
626
 
683
688
  | {pat_desc=Tpat_array _} -> true
684
689
  | _ -> false
685
690
 
 
691
and group_lazy = function
 
692
  | {pat_desc = Tpat_lazy _} -> true
 
693
  | _ -> false
 
694
 
686
695
let get_group p = match p.pat_desc with
687
696
| Tpat_any -> group_var
688
697
| Tpat_constant _ -> group_constant
691
700
| Tpat_record _ -> group_record
692
701
| Tpat_array _ -> group_array
693
702
| Tpat_variant (_,_,_) -> group_variant
 
703
| Tpat_lazy _ -> group_lazy
694
704
|  _ -> fatal_error "Matching.get_group"
695
705
 
696
706
 
1287
1297
let divide_var ctx pm =
1288
1298
  divide_line ctx_lshift make_var_matching get_args_var omega ctx pm
1289
1299
 
 
1300
(* Matching and forcing a lazy value *)
 
1301
 
 
1302
let get_arg_lazy p rem = match p with
 
1303
| {pat_desc = Tpat_any} -> omega :: rem
 
1304
| {pat_desc = Tpat_lazy arg} -> arg :: rem
 
1305
| _ ->  assert false
 
1306
 
 
1307
let matcher_lazy p rem = match p.pat_desc with
 
1308
| Tpat_or (_,_,_)     -> raise OrPat
 
1309
| Tpat_var _          -> get_arg_lazy omega rem
 
1310
| _                   -> get_arg_lazy p rem
 
1311
 
 
1312
(* Inlining the tag tests before calling the primitive that works on
 
1313
   lazy blocks. This is alse used in translcore.ml.
 
1314
   No call other than Obj.tag when the value has been forced before.
 
1315
*)
 
1316
 
 
1317
let prim_obj_tag =
 
1318
  {prim_name = "caml_obj_tag";
 
1319
   prim_arity = 1; prim_alloc = false;
 
1320
   prim_native_name = "";
 
1321
   prim_native_float = false}
 
1322
 
 
1323
let get_mod_field modname field =
 
1324
  lazy (
 
1325
    try
 
1326
      let mod_ident = Ident.create_persistent modname in
 
1327
      let env = Env.open_pers_signature modname Env.initial in
 
1328
      let p = try
 
1329
        match Env.lookup_value (Longident.Lident field) env with
 
1330
        | (Path.Pdot(_,_,i), _) -> i
 
1331
        | _ -> fatal_error ("Primitive "^modname^"."^field^" not found.")
 
1332
      with Not_found -> fatal_error ("Primitive "^modname^"."^field^" not found.")
 
1333
      in
 
1334
      Lprim(Pfield p, [Lprim(Pgetglobal mod_ident, [])])
 
1335
    with Not_found -> fatal_error ("Module "^modname^" unavailable.")
 
1336
  )
 
1337
 
 
1338
let code_force_lazy_block =
 
1339
  get_mod_field "CamlinternalLazy" "force_lazy_block"
 
1340
;;
 
1341
 
 
1342
(* inline_lazy_force inlines the beginning of the code of Lazy.force. When
 
1343
   the value argument is tagged as:
 
1344
   - forward, take field 0
 
1345
   - lazy, call the primitive that forces (without testing again the tag)
 
1346
   - anything else, return it
 
1347
 
 
1348
   Using Lswitch below relies on the fact that the GC does not shortcut
 
1349
   Forward(val_out_of_heap).
 
1350
*)
 
1351
 
 
1352
let inline_lazy_force_cond arg loc =
 
1353
  let idarg = Ident.create "lzarg" in
 
1354
  let varg = Lvar idarg in
 
1355
  let tag = Ident.create "tag" in
 
1356
  let force_fun = Lazy.force code_force_lazy_block in
 
1357
  Llet(Strict, idarg, arg,
 
1358
       Llet(Alias, tag, Lprim(Pccall prim_obj_tag, [varg]),
 
1359
            Lifthenelse(
 
1360
              (* if (tag == Obj.forward_tag) then varg.(0) else ... *)
 
1361
              Lprim(Pintcomp Ceq,
 
1362
                    [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))]),
 
1363
              Lprim(Pfield 0, [varg]),
 
1364
              Lifthenelse(
 
1365
                (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *)
 
1366
                Lprim(Pintcomp Ceq,
 
1367
                      [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))]),
 
1368
                Lapply(force_fun, [varg], loc),
 
1369
                (* ... arg *)
 
1370
                  varg))))
 
1371
 
 
1372
let inline_lazy_force_switch arg loc =
 
1373
  let idarg = Ident.create "lzarg" in
 
1374
  let varg = Lvar idarg in
 
1375
  let force_fun = Lazy.force code_force_lazy_block in
 
1376
  Llet(Strict, idarg, arg,
 
1377
       Lifthenelse(
 
1378
         Lprim(Pisint, [varg]), varg,
 
1379
         (Lswitch
 
1380
            (varg,
 
1381
             { sw_numconsts = 0; sw_consts = [];   
 
1382
               sw_numblocks = (max Obj.lazy_tag Obj.forward_tag) + 1;
 
1383
               sw_blocks =
 
1384
                 [ (Obj.forward_tag, Lprim(Pfield 0, [varg]));
 
1385
                   (Obj.lazy_tag,
 
1386
                    Lapply(force_fun, [varg], loc)) ];
 
1387
               sw_failaction = Some varg } ))))
 
1388
 
 
1389
let inline_lazy_force =
 
1390
  if !Clflags.native_code then
 
1391
    (* Lswitch generates compact and efficient native code *)
 
1392
    inline_lazy_force_switch
 
1393
  else
 
1394
    (* generating bytecode: Lswitch would generate too many rather big
 
1395
       tables (~ 250 elts); conditionals are better *)
 
1396
    inline_lazy_force_cond
 
1397
 
 
1398
let make_lazy_matching def = function
 
1399
    [] -> fatal_error "Matching.make_lazy_matching"
 
1400
  | (arg,mut) :: argl ->
 
1401
      { cases = [];
 
1402
        args =
 
1403
          (inline_lazy_force arg Location.none, Strict) :: argl;
 
1404
        default = make_default matcher_lazy def }
 
1405
 
 
1406
let divide_lazy p ctx pm =
 
1407
  divide_line
 
1408
    (filter_ctx p)
 
1409
    make_lazy_matching
 
1410
    get_arg_lazy
 
1411
    p ctx pm
 
1412
 
1290
1413
(* Matching against a tuple pattern *)
1291
1414
 
1292
1415
 
2335
2458
      compile_test (compile_match repr partial) partial
2336
2459
        (divide_array kind) (combine_array arg kind partial)
2337
2460
        ctx pm
 
2461
  | Tpat_lazy _ ->
 
2462
      compile_no_test
 
2463
        (divide_lazy (normalize_pat pat))
 
2464
        ctx_combine repr partial ctx pm
2338
2465
  | Tpat_variant(lab, _, row) ->
2339
2466
      compile_test (compile_match repr partial) partial
2340
2467
        (divide_variant !row)
2577
2704
      end
2578
2705
  with Unused ->
2579
2706
    assert false (* ; partial_function loc () *)
2580