fir/util/fir_type.ml

   1 (*
   2  * FIR type checker.
   3  *
   4  * ----------------------------------------------------------------
   5  *
   6  * @begin[license]
   7  * Copyright (C) 2001 Jason Hickey, Caltech
   8  *
   9  * This program is free software; you can redistribute it and/or
  10  * modify it under the terms of the GNU General Public License
  11  * as published by the Free Software Foundation; either version 2
  12  * of the License, or (at your option) any later version.
  13  *
  14  * This program is distributed in the hope that it will be useful,
  15  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  16  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17  * GNU General Public License for more details.
  18  *
  19  * You should have received a copy of the GNU General Public License
  20  * along with this program; if not, write to the Free Software
  21  * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22  *
  23  * Author: Jason Hickey
  24  * @email{jyh@cs.caltech.edu}
  25  * @end[license]
  26  *)
  27 open Debug
  28 open Symbol
  29 open Interval_set
  30
  31 open Fir
  32 open Fir_ds
  33 open Fir_set
  34 open Fir_exn
  35 open Fir_pos
  36 open Fir_env
  37 open Fir_subst
  38 open Fir_state
  39 open Fir_print
  40
  41 open Sizeof_const
  42
  43 module Pos = MakePos (struct let name = "Fir_type" end)
  44 open Pos
  45
  46
  47 (************************************************************************
  48  * WELL-KNOWN TYPES
  49  ************************************************************************)
  50
  51 let ty_int8    = TyRawInt (Rawint.Int8,  false)
  52 let ty_int16   = TyRawInt (Rawint.Int16, true)
  53 let ty_int32   = TyRawInt (Rawint.Int32, true)
  54 let ty_int64   = TyRawInt (Rawint.Int64, true)
  55 let ty_uint64  = TyRawInt (Rawint.Int64, false)
  56
  57 let ty_float32 = TyFloat Rawfloat.Single
  58 let ty_float64 = TyFloat Rawfloat.Double
  59 let ty_float80 = TyFloat Rawfloat.LongDouble
  60
  61 let ty_char       = TyRawInt (Rawint.Int8,  true)
  62 let ty_subscript  = TyRawInt (precision_subscript, signed_subscript)
  63
  64 let ty_string     = TyArray ty_char
  65 let ty_ml_string  = TyArray (TyEnum 256)
  66
  67 let int_set_zero  = IntSet.of_point 0
  68 let false_set     = int_set_zero
  69 let int_set_one   = IntSet.of_point 1
  70 let true_set      = int_set_one
  71
  72 let ty_bool = TyEnum 2
  73 let ty_unit = TyEnum 1
  74 let ty_void = TyEnum 0
  75
  76 (* Type of the FC main function. *)
  77 (*
  78  * BUG: Assumes the 2 argument form of main.
  79  *)
  80 let ty_fc_sym1 = new_symbol_string "ty_fc_main"
  81 let ty_fc_sym2 = new_symbol_string "ty_fc_main"
  82 let ty_fc_main =
  83    TyAll ( [ ty_fc_sym1; ty_fc_sym2 ],
  84       TyFun (  [  ty_int32;
  85                   TyRawData;
  86                   ty_int32;
  87                   TyFun ( [ TyVar ty_fc_sym1; ty_int32 ], ty_void );
  88                   TyVar ty_fc_sym1;
  89                   TyFun ( [ TyVar ty_fc_sym2; TyRawData; ty_int32 ], ty_void );
  90                   TyVar ty_fc_sym2
  91                ],
  92                ty_void ) )
  93
  94 (************************************************************************
  95  * UTILITIES
  96  ************************************************************************)
  97
  98 (*
  99  * Var should be an atom.
 100  *)
 101 let var_of_atom pos a =
 102    match a with
 103       AtomVar v ->
 104          v
 105     | _ ->
 106          let pos = string_pos "var_of_atom" pos in
 107             raise (FirException (pos, StringAtomError ("not a var", a)))
 108
 109 let rec var_of_fun pos a =
 110    match a with
 111       AtomTyApply (a, _, _) ->
 112          var_of_fun pos a
 113     | AtomFun v
 114     | AtomVar v ->
 115          v
 116     | _ ->
 117          let pos = string_pos "var_of_fun" pos in
 118             raise (FirException (pos, StringAtomError ("not a var", a)))
 119
 120 (************************************************************************
 121  * TYPE DEFINITIONS
 122  ************************************************************************)
 123
 124 (*
 125  * Apply the type.
 126  *)
 127 let apply_type_dir tenv pos v tyl =
 128    let pos = string_pos "apply_type_dir" pos in
 129    match tenv_lookup tenv pos v with
 130       TyDefLambda (vars, ty) ->
 131          subst_type_simul pos ty vars tyl
 132     | TyDefUnion (vars, fields) ->
 133          let len1 = List.length vars in
 134          let len2 = List.length tyl in
 135          let _ =
 136             if len1 <> len2 then
 137                raise (FirException (pos, ArityMismatch (len1, len2)))
 138          in
 139          let tags_num = List.length fields in
 140          let tag_set = IntSet.of_interval (Closed 0) (Open tags_num) in
 141             TyUnion (v, tyl, tag_set)
 142     | TyDefDTuple v ->
 143          if tyl = [] then
 144             TyDTuple (v, None)
 145          else
 146             raise (FirException (pos, StringError "dependent tuples are not polymorphic"))
 147
 148 (*
 149  * Expand the union fields.
 150  *)
 151 let apply_union_dir tenv pos v tyl =
 152    match tenv_lookup tenv pos v with
 153       TyDefUnion (vars, fields) ->
 154          if vars = [] then
 155             fields
 156          else
 157             let tvenv =
 158                let len1 = List.length vars in
 159                let len2 = List.length tyl in
 160                   if len1 <> len2 then
 161                      raise (FirException (pos, ArityMismatch (len1, len2)));
 162                   List.fold_left2 subst_add_type_var subst_empty vars tyl
 163             in
 164                List.map (List.map (fun (ty, b) -> subst_type tvenv ty, b)) fields
 165     | tyd ->
 166          raise (FirException (pos, TyDefError tyd))
 167
 168 let union_size_dir tenv pos tv =
 169    match tenv_lookup tenv pos tv with
 170       TyDefUnion (_, l) ->
 171          List.length l
 172     | tyd ->
 173          raise (FirException (string_pos "union_size" pos, TyDefError tyd))
 174
 175 (*
 176  * Expand a type one level.
 177  *)
 178 let rec tenv_expand_dir tenv pos ty =
 179    match ty with
 180       TyApply (v, tyl) ->
 181          tenv_expand_dir tenv pos (apply_type_dir tenv pos v tyl)
 182     | TyAll ([], ty)
 183     | TyExists ([], ty) ->
 184          tenv_expand_dir tenv pos ty
 185     | _ ->
 186          ty
 187
 188 (*
 189  * Destruct a union type.
 190  *)
 191 let dest_union_tydef pos ty =
 192    let pos = string_pos "dest_union_tydef" pos in
 193       match ty with
 194          TyDefUnion (vars, fields) ->
 195             vars, fields
 196        | TyDefLambda _
 197        | TyDefDTuple _ ->
 198             raise (FirException (pos, StringTydefError ("not a union type", ty)))
 199
 200 (*
 201  * Check that the type var is a dependent tuple type.
 202  *)
 203 let is_dtuple_tydef_dir tenv pos ty_var =
 204    let pos = string_pos "dest_dtuple_tydef" pos in
 205       match tenv_lookup tenv pos ty_var with
 206          TyDefDTuple _ ->
 207             true
 208        | TyDefUnion _
 209        | TyDefLambda _ ->
 210             false
 211
 212 (************************************************************************
 213  * TYPES
 214  ************************************************************************)
 215
 216 (*
 217  * Tests.
 218  *)
 219 let rec is_fun_type_dir tenv pos ty =
 220    match tenv_expand_dir tenv pos ty with
 221       TyFun _ ->
 222          true
 223     | TyAll (_, ty)
 224     | TyExists (_, ty) ->
 225          is_fun_type_dir tenv pos ty
 226     | _ ->
 227          false
 228
 229 let rec is_pointer_type_dir tenv pos ty =
 230    match tenv_expand_dir tenv pos ty with
 231       TyUnion _
 232     | TyTuple _
 233     | TyArray _
 234     | TyRawData
 235     | TyVar _
 236     | TyProject _
 237     | TyObject _
 238     | TyCase _
 239     | TyPointer _
 240     | TyFrame _
 241     | TyDTuple _ ->
 242          true
 243     | TyAll (_, ty)
 244     | TyExists (_, ty) ->
 245          is_pointer_type_dir tenv pos ty
 246     | TyInt
 247     | TyEnum _
 248     | TyRawInt _
 249     | TyFloat _
 250     | TyFun _
 251     | TyTag _ ->
 252          false
 253     | TyApply _
 254     | TyDelayed as ty ->
 255          raise (FirException (pos, StringTypeError ("invalid pointer test", ty)))
 256
 257 (*
 258  * Destructors.
 259  *)
 260 let rec dest_exists_type_dir tenv pos ty =
 261    match tenv_expand_dir tenv pos ty with
 262       TyExists (vars, ty) ->
 263          vars, ty
 264     | ty ->
 265          [], ty
 266
 267 let rec dest_all_type_dir tenv pos ty =
 268    let pos = string_pos "dest_all_type_dir" pos in
 269       match tenv_expand_dir tenv pos ty with
 270          TyAll (vars1, ty) ->
 271             let vars2, ty = dest_all_type_dir tenv pos ty in
 272                vars1 @ vars2, ty
 273        | ty ->
 274             [], ty
 275
 276 let dest_all_type_rename_dir tenv pos ty ty_vars =
 277    let pos = string_pos "dest_all_type_rename_dir" pos in
 278    let ty_vars', ty = dest_all_type_dir tenv pos ty in
 279    let len1 = List.length ty_vars' in
 280    let len2 = List.length ty_vars in
 281    let _ =
 282       if len1 <> len2 then
 283          raise (FirException (pos, ArityMismatch (len1, len2)))
 284    in
 285    let subst =
 286       List.fold_left2 (fun subst v1 v2 ->
 287             subst_add_type_var subst v1 (TyVar v2)) subst_empty ty_vars' ty_vars
 288    in
 289       subst_type subst ty
 290
 291 (*
 292  * Break apart the function type.
 293  * Also destruct the universal quantifier.
 294  *)
 295 let rec dest_all_fun_type_dir tenv pos ty =
 296    match tenv_expand_dir tenv pos ty with
 297       TyFun (ty_vars, ty_res) ->
 298          [], ty_vars, ty_res
 299     | TyAll (vars, ty) ->
 300          let vars', ty_vars, ty_res = dest_all_fun_type_dir tenv pos ty in
 301             vars @ vars', ty_vars, ty_res
 302     | ty ->
 303          raise (FirException (pos, NotAFunction ty))
 304
 305 let dest_fun_type_dir tenv pos ty =
 306    match tenv_expand_dir tenv pos ty with
 307       TyFun (ty_vars, ty_res) ->
 308          ty_vars, ty_res
 309     | ty ->
 310          raise (FirException (pos, NotAFunction ty))
 311
 312 (*
 313  * Get some random new type for the function
 314  * by using new vars for the all quantifiers.
 315  *)
 316 let poly_fun_type_dir tenv pos ty =
 317    let pos = string_pos "poly_fun_type" pos in
 318    let ty_vars, ty_args, ty_res = dest_all_fun_type_dir tenv pos ty in
 319    let ty_vars' = List.map (fun v -> TyVar (new_symbol_pre "poly" v)) ty_vars in
 320    let subst = List.fold_left2 subst_add_type_var subst_empty ty_vars ty_vars' in
 321    let ty_args = List.map (subst_type subst) ty_args in
 322    let ty_res = subst_type subst ty_res in
 323       ty_args, ty_res
 324
 325 let rec dest_union_type_dir tenv pos ty =
 326    match tenv_expand_dir tenv pos ty with
 327       TyUnion (tv, tl, i) ->
 328          tv, tl, i
 329     | _ ->
 330          raise (FirException (pos, NotAUnion ty))
 331
 332 let dest_tuple_type_dir tenv pos ty =
 333    match tenv_expand_dir tenv pos ty with
 334       TyTuple (_, tl) ->
 335          tl
 336     | ty ->
 337          raise (FirException (pos, StringTypeError ("not a tuple type", ty)))
 338
 339 let dest_dtuple_type_dir tenv pos ty =
 340    match tenv_expand_dir tenv pos ty with
 341       TyDTuple (ty_var, fields) ->
 342          ty_var, fields
 343     | ty ->
 344          raise (FirException (pos, StringTypeError ("not a dependent tuple type", ty)))
 345
 346 let dest_tag_type_dir tenv pos ty =
 347    match tenv_expand_dir tenv pos ty with
 348       TyTag (ty_var, fields) ->
 349          ty_var, fields
 350     | ty ->
 351          raise (FirException (pos, StringTypeError ("not a tag type", ty)))
 352
 353 let rec dest_array_type_dir tenv pos ty =
 354    match tenv_expand_dir tenv pos ty with
 355       TyArray ty ->
 356          ty
 357     | ty ->
 358          raise (FirException (pos, StringTypeError ("not an array type", ty)))
 359
 360 let dest_case_type_dir tenv pos ty =
 361    match tenv_expand_dir tenv pos ty with
 362       TyCase ty ->
 363          ty
 364     | ty ->
 365          raise (FirException (pos, StringTypeError ("not a case type", ty)))
 366
 367 let dest_object_type_dir tenv pos ty =
 368    match tenv_expand_dir tenv pos ty with
 369       TyObject (v, ty') ->
 370          let subst = subst_add_type_var subst_empty v ty in
 371             subst_type subst ty'
 372     | ty ->
 373          raise (FirException (pos, StringTypeError ("not an object type", ty)))
 374
 375 let unfold_object_type_dir tenv pos ty =
 376    match tenv_expand_dir tenv pos ty with
 377       TyObject (v, ty') ->
 378          let subst = subst_add_type_var subst_empty v ty in
 379             subst_type subst ty'
 380     | ty ->
 381          ty
 382
 383 let is_frame_type_dir tenv pos ty =
 384    match tenv_expand_dir tenv pos ty with
 385       TyFrame _ ->
 386          true
 387     | _ ->
 388          false
 389
 390 let dest_frame_type_dir tenv pos ty =
 391    match tenv_expand_dir tenv pos ty with
 392       TyFrame (label, tyl) ->
 393          label, tyl
 394     | ty ->
 395          raise (FirException (pos, StringTypeError ("not a frame type", ty)))
 396
 397 let is_rawdata_type_dir tenv pos ty =
 398    match tenv_expand_dir tenv pos ty with
 399       TyRawData ->
 400          true
 401     | _ ->
 402          false
 403
 404 (*
 405  * Existential unpacking.
 406  *)
 407 let unpack_type_dir tenv pos v ty =
 408    let pos = string_pos "unpack_type" pos in
 409    let vars, ty = dest_exists_type_dir tenv pos ty in
 410    let subst, _ =
 411       List.fold_left (fun (subst, i) v' ->
 412             let subst = subst_add_type_var subst v' (TyProject (v, i)) in
 413                subst, succ i) (subst_empty, 0) vars
 414    in
 415       subst_type subst ty
 416
 417 (*
 418  * Get the subscript value from the type.
 419  *)
 420 let rec sub_value_of_type_dir tenv pos ty =
 421    let pos = string_pos "sub_value_of_type" pos in
 422       match tenv_expand_dir tenv pos ty with
 423          TyInt ->
 424             IntSub
 425        | TyTag (ty_var, tyl) ->
 426             TagSub (ty_var, tyl)
 427        | TyEnum n ->
 428             EnumSub n
 429        | TyRawInt (pre, signed) ->
 430             RawIntSub (pre, signed)
 431        | TyFloat pre ->
 432             RawFloatSub pre
 433        | TyFun _ ->
 434             FunctionSub
 435        | TyUnion _
 436        | TyTuple _
 437        | TyDTuple _
 438        | TyArray _
 439        | TyCase _
 440        | TyObject _ ->
 441             BlockPointerSub
 442        | TyRawData
 443        | TyFrame _ ->
 444             RawPointerSub
 445        | TyPointer _ ->
 446             PointerInfixSub
 447        | TyVar _
 448        | TyProject _
 449        | TyDelayed ->
 450             PolySub
 451        | TyExists (_, ty)
 452        | TyAll (_, ty) ->
 453             sub_value_of_type_dir tenv pos ty
 454        | TyApply _ ->
 455             raise (Invalid_argument "sub_value_of_type")
 456
 457 (************************************************************************
 458  * GLOBAL VERSIONS
 459  ************************************************************************)
 460
 461 (*
 462  * Figure out the type of a field in a frame.
 463  *)
 464 let apply_frame genv pos v tyl (_, v_field, v_subfield) =
 465    let pos = string_pos "apply_frame_dir" pos in
 466    let vars, fields = genv_lookup_frame genv pos v in
 467    let subfields =
 468       try SymbolTable.find fields v_field with
 469          Not_found ->
 470             raise (FirException (pos, StringVarError ("unbound field", v_field)))
 471    in
 472    let ty, i =
 473       let rec search = function
 474          (v_subfield', ty, i) :: subfields ->
 475             if Symbol.eq v_subfield' v_subfield then
 476                ty, i
 477             else
 478                search subfields
 479        | [] ->
 480             raise (FirException (pos, StringVarError ("unbound subfield", v_subfield)))
 481       in
 482          search subfields
 483    in
 484    let ty = subst_type_simul pos ty vars tyl in
 485       ty, i
 486
 487 (*
 488  * All the rest are straightforward.
 489  *)
 490 let apply_type genv = apply_type_dir (tenv_of_genv genv)
 491 let apply_union genv = apply_union_dir (tenv_of_genv genv)
 492
 493 let expand_type genv = tenv_expand_dir (tenv_of_genv genv)
 494 let union_size genv = union_size_dir (tenv_of_genv genv)
 495
 496 let is_dtuple_tydef genv = is_dtuple_tydef_dir (tenv_of_genv genv)
 497
 498 let is_fun_type genv = is_fun_type_dir (tenv_of_genv genv)
 499 let is_pointer_type genv = is_pointer_type_dir (tenv_of_genv genv)
 500 let is_frame_type genv = is_frame_type_dir (tenv_of_genv genv)
 501 let is_rawdata_type genv = is_rawdata_type_dir (tenv_of_genv genv)
 502
 503 let dest_exists_type genv = dest_exists_type_dir (tenv_of_genv genv)
 504 let dest_all_type genv = dest_all_type_dir (tenv_of_genv genv)
 505 let dest_all_type_rename genv = dest_all_type_rename_dir (tenv_of_genv genv)
 506 let dest_all_fun_type genv = dest_all_fun_type_dir (tenv_of_genv genv)
 507 let dest_fun_type genv = dest_fun_type_dir (tenv_of_genv genv)
 508 let poly_fun_type genv = poly_fun_type_dir (tenv_of_genv genv)
 509 let dest_union_type genv = dest_union_type_dir (tenv_of_genv genv)
 510 let dest_tuple_type genv = dest_tuple_type_dir (tenv_of_genv genv)
 511 let dest_dtuple_type genv = dest_dtuple_type_dir (tenv_of_genv genv)
 512 let dest_tag_type genv = dest_tag_type_dir (tenv_of_genv genv)
 513 let dest_array_type genv = dest_array_type_dir (tenv_of_genv genv)
 514 let dest_case_type genv = dest_case_type_dir (tenv_of_genv genv)
 515 let dest_object_type genv = dest_object_type_dir (tenv_of_genv genv)
 516 let dest_frame_type genv = dest_frame_type_dir (tenv_of_genv genv)
 517
 518 let unfold_object_type genv = unfold_object_type_dir (tenv_of_genv genv)
 519
 520 let sub_value_of_type genv = sub_value_of_type_dir (tenv_of_genv genv)
 521
 522 let unpack_type genv = unpack_type_dir (tenv_of_genv genv)
 523
 524 (************************************************************************
 525  * EXPRESSION CHECKING
 526  ************************************************************************)
 527
 528 (*
 529  * Type of an allocation.
 530  *)
 531 let type_of_alloc_op op =
 532    match op with
 533       AllocTuple (_, ty_vars, ty, _)
 534     | AllocUnion (ty_vars, ty, _, _, _) ->
 535          TyAll (ty_vars, ty)
 536     | AllocDTuple (ty, _, _, _)
 537     | AllocArray (ty, _)
 538     | AllocVArray (ty, _, _, _)
 539     | AllocMalloc (ty, _) ->
 540          ty
 541     | AllocFrame (v, tyl) ->
 542          TyFrame (v, tyl)
 543
 544
 545 (*
 546  * Get argument and result types of unary operators.
 547  *)
 548 let type_of_unop pos op =
 549    let pos = string_pos "type_of_unop" pos in
 550       match op with
 551          NotEnumOp n ->
 552             let ty = TyEnum n in
 553                ty, ty
 554
 555        | UMinusIntOp
 556        | AbsIntOp
 557        | NotIntOp ->
 558             TyInt, TyInt
 559        | UMinusRawIntOp (pre, signed)
 560        | NotRawIntOp (pre, signed) ->
 561             let ty = TyRawInt (pre, signed) in
 562                ty, ty
 563
 564        | RawBitFieldOp (pre, signed, _, _) ->
 565             if pre = Rawint.Int64 then
 566                raise (FirException (pos, StringError "RawBitFieldOp cannot return Int64"));
 567             TyRawInt (pre, signed), TyRawInt (Rawint.Int32, signed)
 568
 569        | UMinusFloatOp pre
 570        | AbsFloatOp pre
 571        | SinFloatOp pre
 572        | CosFloatOp pre
 573        | TanFloatOp pre
 574        | ASinFloatOp pre
 575        | ACosFloatOp pre
 576        | ATanFloatOp pre
 577        | SinHFloatOp pre
 578        | CosHFloatOp pre
 579        | TanHFloatOp pre
 580        | ExpFloatOp pre
 581        | LogFloatOp pre
 582        | Log10FloatOp pre
 583        | SqrtFloatOp pre
 584        | CeilFloatOp pre
 585        | FloorFloatOp pre ->
 586             let ty = TyFloat pre in
 587                ty, ty
 588
 589        | IntOfFloatOp pre ->
 590             TyInt, TyFloat pre
 591
 592        | FloatOfIntOp pre ->
 593             TyFloat pre, TyInt
 594        | FloatOfFloatOp (pre1, pre2) ->
 595             TyFloat pre1, TyFloat pre2
 596        | FloatOfRawIntOp (fpre, rpre, rsigned) ->
 597             TyFloat fpre, TyRawInt (rpre, rsigned)
 598        | IntOfRawIntOp (pre, signed) ->
 599             TyInt, TyRawInt (pre, signed)
 600        | RawIntOfIntOp (pre, signed) ->
 601             TyRawInt (pre, signed), TyInt
 602        | RawIntOfEnumOp (pre, signed, n) ->
 603             TyRawInt (pre, signed), TyEnum n
 604        | RawIntOfRawIntOp (pre1, signed1, pre2, signed2) ->
 605             TyRawInt (pre1, signed1), TyRawInt (pre2, signed2)
 606        | RawIntOfFloatOp (pre, signed, fpre) ->
 607             TyRawInt (pre, signed), TyFloat fpre
 608
 609        | LengthOfBlockOp (subop, ty) ->
 610             let ty_res =
 611                match subop.sub_script with
 612                   IntIndex -> TyInt
 613                 | RawIntIndex (p, s) -> TyRawInt (p, s)
 614             in
 615                ty_res, ty
 616
 617        | DTupleOfDTupleOp (ty_var, ty_fields) ->
 618             TyDTuple (ty_var, None), TyDTuple (ty_var, Some ty_fields)
 619        | UnionOfUnionOp (ty_var, tyl, s1, s2) ->
 620             TyUnion (ty_var, tyl, s1), TyUnion (ty_var, tyl, s2)
 621        | RawDataOfFrameOp (ty_var, tyl) ->
 622             TyRawData, TyFrame (ty_var, tyl)
 623
 624          (* BUG: wait until we understand these *)
 625        | RawIntOfPointerOp _
 626        | PointerOfRawIntOp _
 627        | PointerOfBlockOp _ ->
 628             raise (FirException (pos, NotImplemented "type checking for rawint/pointer conversions"))
 629
 630 (*
 631  * Get the argument and result type for a binary operation.
 632  *)
 633 let type_of_binop pos op =
 634    let pos = string_pos "type_of_binop" pos in
 635       match op with
 636          (* Bitwise operations on enumerations. *)
 637          AndEnumOp n
 638        | OrEnumOp n
 639        | XorEnumOp n ->
 640             let ty = TyEnum n in
 641                ty, ty, ty
 642
 643          (* Standard binary operations on NAML ints *)
 644        | PlusIntOp
 645        | MinusIntOp
 646        | MulIntOp
 647        | DivIntOp
 648        | RemIntOp
 649        | LslIntOp
 650        | LsrIntOp
 651        | AsrIntOp
 652        | AndIntOp
 653        | OrIntOp
 654        | XorIntOp
 655        | MaxIntOp
 656        | MinIntOp ->
 657             TyInt, TyInt, TyInt
 658
 659          (* Comparisons on NAML ints *)
 660        | EqIntOp
 661        | NeqIntOp
 662        | LtIntOp
 663        | LeIntOp
 664        | GtIntOp
 665        | GeIntOp ->
 666             ty_bool, TyInt, TyInt
 667
 668          (* Similar to ML's ``compare'' function. *)
 669        | CmpIntOp ->
 670             TyInt, TyInt, TyInt
 671
 672          (*
 673           * Standard binary operations on native ints.  The precision is
 674           * the result precision; the inputs should match this precision.
 675           *)
 676        | PlusRawIntOp   (pre, signed)
 677        | MinusRawIntOp  (pre, signed)
 678        | MulRawIntOp    (pre, signed)
 679        | DivRawIntOp    (pre, signed)
 680        | RemRawIntOp    (pre, signed)
 681        | SlRawIntOp     (pre, signed)
 682        | SrRawIntOp     (pre, signed)
 683        | AndRawIntOp    (pre, signed)
 684        | OrRawIntOp     (pre, signed)
 685        | XorRawIntOp    (pre, signed)
 686        | MaxRawIntOp    (pre, signed)
 687        | MinRawIntOp    (pre, signed) ->
 688             let ty = TyRawInt (pre, signed) in
 689                ty, ty, ty
 690
 691          (*
 692           * BUG (?): Someone may want to check this one again. --emre
 693           *)
 694        | RawSetBitFieldOp (pre, signed, _, _) ->
 695             let ty = TyRawInt (pre, signed) in
 696                ty, TyRawInt (Rawint.Int32, signed), ty
 697
 698          (* Comparisons on native ints *)
 699        | EqRawIntOp     (pre, signed)
 700        | NeqRawIntOp    (pre, signed)
 701        | LtRawIntOp     (pre, signed)
 702        | LeRawIntOp     (pre, signed)
 703        | GtRawIntOp     (pre, signed)
 704        | GeRawIntOp     (pre, signed) ->
 705             let ty = TyRawInt (pre, signed) in
 706                ty_bool, ty, ty
 707
 708        | CmpRawIntOp    (pre, signed) ->
 709             let ty = TyRawInt (pre, signed) in
 710                TyInt, ty, ty
 711
 712          (* Standard binary operations on floats *)
 713        | PlusFloatOp pre
 714        | MinusFloatOp pre
 715        | MulFloatOp  pre
 716        | DivFloatOp  pre
 717        | RemFloatOp  pre
 718        | MaxFloatOp  pre
 719        | MinFloatOp  pre
 720        | ATan2FloatOp pre
 721        | PowerFloatOp pre ->
 722             let ty = TyFloat pre in
 723                ty, ty, ty
 724
 725        | LdExpFloatIntOp pre ->
 726             let ty = TyFloat pre in
 727                ty, ty, TyInt
 728
 729          (* Comparisons on floats *)
 730        | EqFloatOp   pre
 731        | NeqFloatOp  pre
 732        | LtFloatOp   pre
 733        | LeFloatOp   pre
 734        | GtFloatOp   pre
 735        | GeFloatOp   pre ->
 736             let ty = TyFloat pre in
 737                ty_bool, ty, ty
 738        | CmpFloatOp  pre ->
 739             let ty = TyFloat pre in
 740                TyInt, ty, ty
 741
 742          (*
 743           * Pointer (in)equality.  Arguments must be pointers.
 744           * BUG: this is actually polymorphic.
 745           *)
 746        | EqEqOp ty
 747        | NeqEqOp ty ->
 748             ty_bool, ty, ty
 749
 750          (*
 751           * Pointer arithmetic. The pointer in the first argument, and the
 752           * returned pointer should be infix pointers (which keep the base
 753           * pointer as well as a pointer to anywhere within the block).
 754           *)
 755        | PlusPointerOp (sub, pre, signed) ->
 756             TyPointer sub, TyPointer sub, TyRawInt (pre, signed)
 757
 758 (*
 759  * Get the type of an atom.
 760  *)
 761 let rec type_of_atom_aux genv_lookup_var genv pos a =
 762    let pos = string_pos "type_of_atom" pos in
 763       match a with
 764          AtomNil ty ->
 765             ty
 766        | AtomInt _ ->
 767             TyInt
 768        | AtomEnum (n, _) ->
 769             TyEnum n
 770        | AtomFloat x ->
 771             TyFloat (Rawfloat.precision x)
 772        | AtomRawInt i ->
 773             TyRawInt (Rawint.precision i, Rawint.signed i)
 774        | AtomVar v ->
 775             genv_lookup_var genv pos v
 776        | AtomFun v ->
 777             genv_lookup_fun genv pos v
 778        | AtomLabel _
 779        | AtomSizeof _ ->
 780             TyRawInt (precision_subscript, signed_subscript)
 781        | AtomConst (ty, _, i) ->
 782             let tv, tl, _ = dest_union_type genv pos ty in
 783                TyUnion (tv, tl, IntSet.of_point i)
 784        | AtomTyApply (_, ty, _)
 785        | AtomTyPack (_, ty, _) ->
 786             ty
 787        | AtomTyUnpack v ->
 788             let ty = genv_lookup_var genv pos v in
 789                unpack_type genv pos v ty
 790        | AtomUnop (op, a) ->
 791             let ty, _ = type_of_unop pos op in
 792                ty
 793        | AtomBinop (op, _, _) ->
 794             let ty, _, _ = type_of_binop pos op in
 795                ty
 796
 797 let type_of_atom = type_of_atom_aux genv_lookup_var
 798 let type_of_global_atom = type_of_atom_aux genv_lookup_var_or_global
 799
 800 (************************************************************************
 801  * PROGRAM TYPING
 802  ************************************************************************)
 803
 804 (*
 805  * Assume all binding occurrences have different names.
 806  * Get the type of every variable in the program.
 807  *)
 808 let rec type_exp genv e =
 809    let pos = string_pos "type_exp" (exp_pos e) in
 810       match dest_exp_core e with
 811          LetAtom (v, ty, _, e)
 812        | LetExt (v, ty, _, _, _, _, _, e)
 813        | LetSubscript (_, v, ty, _, _, e)
 814        | LetGlobal (_, v, ty, _, e) ->
 815             let genv = genv_add_var genv v ty in
 816                type_exp genv e
 817        | LetAlloc (v, op, e) ->
 818             let genv = genv_add_var genv v (type_of_alloc_op op) in
 819                type_exp genv e
 820        | TailCall _
 821        | SpecialCall _ ->
 822             genv
 823        | TypeCase (_, _, name, v, e1, e2) ->
 824             let genv = genv_add_var genv v (genv_lookup_name genv pos name) in
 825                type_exp genv e
 826        | Call (_, _, _, e)
 827        | Assert (_, _, e)
 828        | SetSubscript (_, _, _, _, _, _, e)
 829        | SetGlobal (_, _, _, _, _, e)
 830        | Memcpy (_, _, _, _, _, _, _, e)
 831        | Debug (_, e) ->
 832             type_exp genv e
 833        | Match (_, cases) ->
 834             List.fold_left (fun genv (_, _, e) ->
 835                   type_exp genv e) genv cases
 836        | MatchDTuple (_, cases) ->
 837             List.fold_left (fun genv (_, _, e) ->
 838                   type_exp genv e) genv cases
 839
 840 (*
 841  * Type for a function.
 842  *)
 843 let type_fun genv f (info, _, ty, vars, e) =
 844    let pos = string_pos "type_fun" (var_exp_pos f) in
 845    let ty_args, _ = dest_fun_type genv pos ty in
 846    let genv = List.fold_left2 genv_add_var genv vars ty_args in
 847       type_exp genv e
 848
 849 (*
 850  * Get all the var types in the program.
 851  *)
 852 let prog_genv prog =
 853    let genv = genv_of_prog prog in
 854       SymbolTable.fold type_fun genv prog.prog_funs
 855
 856 (*!
 857  * @docoff
 858  *
 859  * -*-
 860  * Local Variables:
 861  * Caml-master: "compile"
 862  * End:
 863  * -*-
 864  *)