ocaml/middle_end/semantics_of_primitives.ml

(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                       Pierre Chambart, OCamlPro                        *)
(*           Mark Shinwell and Leo White, Jane Street Europe              *)
(*                                                                        *)
(*   Copyright 2013--2016 OCamlPro SAS                                    *)
(*   Copyright 2014--2016 Jane Street Group LLC                           *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

[@@@ocaml.warning "+a-4-9-30-40-41-42"]

type effects = No_effects | Only_generative_effects | Arbitrary_effects
type coeffects = No_coeffects | Has_coeffects

let for_primitive (prim : Lambda.primitive) =
  match prim with
  | Pignore | Pidentity -> No_effects, No_coeffects
  | Pmakeblock _
  | Pmakearray (_, Mutable) -> Only_generative_effects, No_coeffects
  | Pmakearray (_, Immutable) -> No_effects, No_coeffects
  | Pduparray (_, Immutable) ->
    No_effects, No_coeffects  (* Pduparray (_, Immutable) is allowed only on
                                 immutable arrays. *)
  | Pduparray (_, Mutable) | Pduprecord _ ->
    Only_generative_effects, Has_coeffects
  | Pccall { prim_name =
      ( "caml_format_float" | "caml_format_int" | "caml_int32_format"
      | "caml_nativeint_format" | "caml_int64_format" ) } ->
    No_effects, No_coeffects
  | Plazyforce
  | Pccall _ -> Arbitrary_effects, Has_coeffects
  | Praise _ -> Arbitrary_effects, No_coeffects
  | Pnot
  | Pnegint
  | Paddint
  | Psubint
  | Pmulint
  | Pandint
  | Porint
  | Pxorint
  | Plslint
  | Plsrint
  | Pasrint
  | Pintcomp _ -> No_effects, No_coeffects
  | Pdivint
  | Pmodint ->
    No_effects, No_coeffects  (* Will not raise [Division_by_zero]. *)
  | Poffsetint _ -> No_effects, No_coeffects
  | Poffsetref _ -> Arbitrary_effects, Has_coeffects
  | Pintoffloat
  | Pfloatofint
  | Pnegfloat
  | Pabsfloat
  | Paddfloat
  | Psubfloat
  | Pmulfloat
  | Pdivfloat
  | Pfloatcomp _ -> No_effects, No_coeffects
  | Pstringlength
  | Parraylength _ ->
    No_effects, Has_coeffects  (* That old chestnut: [Obj.truncate]. *)
  | Pisint
  | Pisout
  | Pbittest
  | Pbintofint _
  | Pintofbint _
  | Pcvtbint _
  | Pnegbint _
  | Paddbint _
  | Psubbint _
  | Pmulbint _
  | Pdivbint _
  | Pmodbint _
  | Pandbint _
  | Porbint _
  | Pxorbint _
  | Plslbint _
  | Plsrbint _
  | Pasrbint _
  | Pbintcomp _ -> No_effects, No_coeffects
  | Pbigarraydim _ ->
    No_effects, Has_coeffects  (* Some people resize bigarrays in place. *)
  | Pfield _
  | Pfloatfield _
  | Pgetglobal _
  | Parrayrefu _
  | Pstringrefu
  | Pstring_load_16 true
  | Pstring_load_32 true
  | Pstring_load_64 true
  | Pbigarrayref (true, _, _, _)
  | Pbigstring_load_16 true
  | Pbigstring_load_32 true
  | Pbigstring_load_64 true ->
    No_effects, Has_coeffects
  | Parrayrefs _
  | Pstringrefs
  | Pstring_load_16 false
  | Pstring_load_32 false
  | Pstring_load_64 false
  | Pbigarrayref (false, _, _, _)
  | Pbigstring_load_16 false
  | Pbigstring_load_32 false
  | Pbigstring_load_64 false ->
    (* May trigger a bounds check exception. *)
    Arbitrary_effects, Has_coeffects
  | Psetfield _
  | Psetfloatfield _
  | Psetglobal _
  | Parraysetu _
  | Parraysets _
  | Pstringsetu
  | Pstringsets
  | Pstring_set_16 _
  | Pstring_set_32 _
  | Pstring_set_64 _
  | Pbigarrayset _
  | Pbigstring_set_16 _
  | Pbigstring_set_32 _
  | Pbigstring_set_64 _ ->
    (* Whether or not some of these are "unsafe" is irrelevant; they always
       have an effect. *)
    Arbitrary_effects, No_coeffects
  | Pctconst _ -> No_effects, No_coeffects
  | Pbswap16
  | Pbbswap _ -> No_effects, No_coeffects
  | Pint_as_pointer -> No_effects, No_coeffects
  | Popaque -> Arbitrary_effects, Has_coeffects
  | Ploc _ ->
    Misc.fatal_error "[Ploc] should have been eliminated by [Translcore]"
  | Prevapply
  | Pdirapply
  | Psequand
  | Psequor ->
    Misc.fatal_errorf "The primitive %a should have been eliminated by the \
        [Closure_conversion] pass."
      Printlambda.primitive prim

type return_type =
  | Float
  | Other

let return_type_of_primitive (prim:Lambda.primitive) =
  match prim with
  | Pfloatofint
  | Pnegfloat
  | Pabsfloat
  | Paddfloat
  | Psubfloat
  | Pmulfloat
  | Pdivfloat
  | Pfloatfield _
  | Parrayrefu Pfloatarray
  | Parrayrefs Pfloatarray ->
    Float
  | _ ->
    Other