mlton/closure-convert/abstract-value.fun

   1 (* Copyright (C) 2017 Matthew Fluet.
   2  * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 functor AbstractValue (S: ABSTRACT_VALUE_STRUCTS): ABSTRACT_VALUE =
  11 struct
  12
  13 open S
  14 open Sxml
  15
  16 structure Dset = DisjointSet
  17
  18 structure Lambda =
  19    struct
  20       datatype t = Lambda of {lambda: Sxml.Lambda.t,
  21                               hash: Word.t}
  22
  23       val newHash = Random.word
  24
  25       fun new lambda = Lambda {lambda = lambda,
  26                                hash = newHash ()}
  27
  28       fun hash (Lambda {hash, ...}) = hash
  29
  30       fun dest (Lambda {lambda, ...}) = lambda
  31
  32       fun equals (Lambda r, Lambda r') =
  33          #hash r = #hash r'
  34          andalso Sxml.Lambda.equals (#lambda r, #lambda r')
  35
  36       fun layout (Lambda {lambda, ...}) =
  37          let open Layout
  38          in seq [str "lambda ", Sxml.Var.layout (Sxml.Lambda.arg lambda)]
  39          end
  40    end
  41
  42 structure Lambdas = UniqueSet (structure Element = Lambda
  43                                val cacheSize: int = 5
  44                                val bits: int = 13)
  45
  46 structure LambdaNode:
  47    sig
  48       type t
  49
  50       val addHandler: t * (Lambda.t -> unit) -> unit
  51       val coerce: {from: t, to: t} -> unit
  52       val lambda: Sxml.Lambda.t -> t
  53       val layout: t -> Layout.t
  54       val new: unit -> t
  55       val toSet: t -> Lambdas.t
  56       val unify: t * t -> unit
  57    end =
  58    struct
  59       datatype t = LambdaNode of {me: Lambdas.t ref,
  60                                   handlers: (Lambda.t -> unit) list ref,
  61                                   coercedTo: t list ref} Dset.t
  62
  63       fun toSet (LambdaNode d) = !(#me (Dset.! d))
  64
  65       val layout = Lambdas.layout o toSet
  66
  67       fun newSet s = LambdaNode (Dset.singleton {me = ref s,
  68                                                  handlers = ref [],
  69                                                  coercedTo = ref []})
  70
  71       fun new () = newSet Lambdas.empty
  72
  73       fun lambda l = newSet (Lambdas.singleton (Lambda.new l))
  74
  75       fun handles (h: Lambda.t -> unit, s: Lambdas.t): unit =
  76          Lambdas.foreach (s, fn l => h l)
  77
  78       fun handless (hs: (Lambda.t -> unit) list, s: Lambdas.t): unit =
  79          List.foreach (hs, fn h => handles (h, s))
  80
  81       fun addHandler (LambdaNode d, h: Lambda.t -> unit) =
  82          let val {me, handlers, ...} = Dset.! d
  83          in List.push (handlers, h)
  84             ; handles (h, !me)
  85          end
  86
  87       fun send (LambdaNode d, s): unit =
  88          let val {me, coercedTo, handlers, ...} = Dset.! d
  89             val diff = Lambdas.- (s, !me)
  90          in if Lambdas.isEmpty diff
  91                then ()
  92             else (me := Lambdas.+ (diff, !me)
  93                   ; List.foreach (!coercedTo, fn to => send (to, diff))
  94                   ; handless (!handlers, diff))
  95          end
  96
  97       val send =
  98          Trace.trace2
  99          ("AbstractValue.LambdaNode.send",
 100           layout, Lambdas.layout, Unit.layout)
 101          send
 102
 103       fun equals (LambdaNode d, LambdaNode d') = Dset.equals (d, d')
 104
 105       fun coerce {from = from as LambdaNode d, to: t}: unit =
 106          if equals (from, to)
 107             then ()
 108          else let
 109                  val {me, coercedTo, ...} = Dset.! d
 110               in
 111                  if List.exists (!coercedTo, fn ls => equals (ls, to))
 112                     then ()
 113                  else (List.push (coercedTo, to)
 114                        ; send (to, !me))
 115               end
 116
 117       fun update (c, h, diff) =
 118          if Lambdas.isEmpty diff
 119             then ()
 120          else (List.foreach (c, fn to => send (to, diff))
 121                ; handless (h, diff))
 122
 123       fun unify (LambdaNode d, LambdaNode d'): unit =
 124          if Dset.equals (d, d')
 125             then ()
 126          else
 127             let
 128                val {me = ref m, coercedTo = ref c, handlers = ref h, ...} =
 129                   Dset.! d
 130                val {me = ref m', coercedTo = ref c', handlers = ref h', ...} =
 131                   Dset.! d'
 132                val diff = Lambdas.- (m, m')
 133                val diff' = Lambdas.- (m', m)
 134             in Dset.union (d, d')
 135                ; (Dset.:=
 136                   (d, {me = ref (if Lambdas.isEmpty diff
 137                                    then m'
 138                                 else Lambdas.+ (m', diff)),
 139                        coercedTo = ref (List.fold
 140                                         (c', c, fn (n', ac) =>
 141                                          if List.exists (c, fn n =>
 142                                                          equals (n, n'))
 143                                             then ac
 144                                          else n' :: ac)),
 145                        handlers = ref (List.appendRev (h, h'))}))
 146                ; update (c, h, diff')
 147                ; update (c', h', diff)
 148             end
 149
 150 (*
 151       val unify =
 152          Trace.trace2
 153          ("AbstractValue.LambdaNode.unify", layout, layout, Unit.layout)
 154          unify
 155 *)
 156    end
 157
 158 structure UnaryTycon =
 159    struct
 160       datatype t = Array | Ref | Vector | Weak
 161
 162       val toString =
 163          fn Array => "Array"
 164           | Ref => "Ref"
 165           | Vector => "Vector"
 166           | Weak => "Weak"
 167
 168       val equals: t * t -> bool = op =
 169
 170       val layout = Layout.str o toString
 171    end
 172
 173 datatype tree =
 174    Lambdas of LambdaNode.t
 175  | Tuple of t vector
 176  | Type of Type.t
 177  | Unify of UnaryTycon.t * t
 178
 179 withtype t = {tree: tree,
 180               ty: Type.t,
 181               ssaType: Ssa.Type.t option ref} Dset.t
 182
 183 fun new (tree: tree, ty: Type.t): t =
 184    Dset.singleton {ssaType = ref NONE,
 185                    tree = tree,
 186                    ty = ty}
 187
 188 local
 189    fun make sel : t -> 'a = sel o Dset.!
 190 in
 191    val ssaType = make #ssaType
 192    val tree = make #tree
 193    val ty = make #ty
 194 end
 195
 196 fun layout v =
 197    let open Layout
 198    in case tree v of
 199       Type t => seq [str "Type ", Type.layout t]
 200     | Unify (t, v) => paren (seq [UnaryTycon.layout t, str " ", layout v])
 201     | Tuple vs => Vector.layout layout vs
 202     | Lambdas l => LambdaNode.layout l
 203    end
 204
 205 fun isEmpty v =
 206    case tree v of
 207       Lambdas n => Lambdas.isEmpty (LambdaNode.toSet n)
 208     | Tuple vs => Vector.exists (vs, isEmpty)
 209     | Unify (UnaryTycon.Ref, v) => isEmpty v
 210     | _ => false
 211
 212 (* used in closure converter *)
 213 fun equals (v, v') =
 214    Dset.equals (v, v')
 215    orelse
 216    (case (tree v,      tree v') of
 217        (Type t,        Type t')   =>
 218           if Type.equals (t, t')
 219              then true
 220           else Error.bug "AbstractValue.equals: different types"
 221      | (Unify (t, v), Unify (t', v'))     =>
 222           UnaryTycon.equals (t, t') andalso equals (v, v')
 223      | (Tuple vs,  Tuple vs')  => Vector.forall2 (vs, vs', equals)
 224      | (Lambdas n, Lambdas n') => Lambdas.equals (LambdaNode.toSet n,
 225                                                  LambdaNode.toSet n')
 226      | _ => Error.bug "AbstractValue.equals: different values")
 227
 228 fun addHandler (v, h) =
 229    case tree v of
 230       Lambdas n => LambdaNode.addHandler (n, h)
 231     | _ => Error.bug "AbstractValue.addHandler: non-lambda"
 232
 233 local
 234    val {hom, destroy} =
 235       Type.makeMonoHom
 236       {con = fn (t, tycon, vs) =>
 237        let val new = fn tree => new (tree, t)
 238        in if Tycon.equals (tycon, Tycon.arrow)
 239              then {isFirstOrder = false,
 240                    make = fn () => new (Lambdas (LambdaNode.new ()))}
 241           else
 242              if Vector.forall (vs, #isFirstOrder)
 243                 then {isFirstOrder = true,
 244                       make = let val v = new (Type t)
 245                              in fn () => v
 246                              end}
 247              else
 248                 {isFirstOrder = false,
 249                  make = let
 250                            fun mutable mt =
 251                               let val make = #make (Vector.first vs)
 252                               in fn () => new (Unify (mt, make ()))
 253                               end
 254                         in if Tycon.equals (tycon, Tycon.reff)
 255                               then mutable UnaryTycon.Ref
 256                            else if Tycon.equals (tycon, Tycon.array)
 257                                    then mutable UnaryTycon.Array
 258                            else if Tycon.equals (tycon, Tycon.vector)
 259                                    then mutable UnaryTycon.Vector
 260                            else if Tycon.equals (tycon, Tycon.weak)
 261                                    then mutable UnaryTycon.Weak
 262                            else if Tycon.equals (tycon, Tycon.tuple)
 263                                    then (fn () =>
 264                                          new (Tuple
 265                                               (Vector.map (vs, fn {make, ...} =>
 266                                                            make ()))))
 267                            else Error.bug "AbstractValue.fromType: non-arrow"
 268                         end}
 269        end}
 270 in
 271    val destroy = destroy
 272    val typeIsFirstOrder = #isFirstOrder o hom
 273    fun fromType t = #make (hom t) ()
 274 end
 275
 276 val fromType = Trace.trace ("AbstractValue.fromType", Type.layout, layout) fromType
 277
 278 fun tuple (vs: t vector): t = new (Tuple vs,
 279                                    Type.tuple (Vector.map (vs, ty)))
 280
 281 fun select (v, i) =
 282    case tree v of
 283       Type t => fromType (Vector.sub (Type.deTuple t, i))
 284     | Tuple vs => Vector.sub (vs, i)
 285     | _ => Error.bug "AbstractValue.select: expected tuple"
 286
 287 fun deRef v =
 288    case tree v of
 289       Type t => fromType (Type.deRef t)
 290     | Unify (_, v) => v
 291     | _ => Error.bug "AbstractValue.deRef"
 292
 293 val deRef = Trace.trace ("AbstractValue.deRef", layout, layout) deRef
 294
 295 fun deWeak v =
 296    case tree v of
 297       Type t => fromType (Type.deWeak t)
 298     | Unify (_, v) => v
 299     | _ => Error.bug "AbstractValue.deWeak"
 300
 301 fun deArray v =
 302    case tree v of
 303       Type t => fromType (Type.deArray t)
 304     | Unify (_, v) => v
 305     | _ => Error.bug "AbstractValue.deArray"
 306
 307 fun deVector v =
 308    case tree v of
 309       Type t => fromType (Type.deVector t)
 310     | Unify (_, v) => v
 311     | _ => Error.bug "AbstractValue.deVector"
 312
 313 fun lambda (l: Sxml.Lambda.t, t: Type.t): t =
 314    new (Lambdas (LambdaNode.lambda l), t)
 315
 316 fun unify (v, v') =
 317    if Dset.equals (v, v')
 318       then ()
 319    else let val t = tree v
 320             val t' = tree v'
 321         in Dset.union (v, v')
 322            ; (case (t, t') of
 323                  (Type t, Type t') => if Type.equals (t, t')
 324                                          then ()
 325                                       else Error.bug "AbstractValue.unify: different types"
 326                | (Unify (_, v), Unify (_, v')) => unify (v, v')
 327                | (Tuple vs, Tuple vs') => Vector.foreach2 (vs, vs', unify)
 328                | (Lambdas l, Lambdas l') => LambdaNode.unify (l, l')
 329                | _ => Error.bug "AbstractValue.unify: different values")
 330         end
 331
 332 val unify = Trace.trace2 ("AbstractValue.unify", layout, layout, Unit.layout) unify
 333
 334 fun coerce {from: t, to: t}: unit =
 335    if Dset.equals (from, to)
 336       then ()
 337    else (case (tree from, tree to) of
 338             (Type t,    Type t')    => if Type.equals (t, t')
 339                                           then ()
 340                                        else Error.bug "coerce"
 341           | (Unify _, Unify _) =>
 342                (* Can't do a coercion for vectors, since that would imply
 343                 * walking over the entire vector and coercing each element
 344                 *)
 345                unify (from, to)
 346           | (Tuple vs,  Tuple vs')  =>
 347                Vector.foreach2 (vs, vs', fn (v, v') =>
 348                                 coerce {from = v, to = v'})
 349           | (Lambdas l, Lambdas l') => LambdaNode.coerce {from = l, to = l'}
 350           | _ => Error.bug "AbstractValue.coerce: different values")
 351
 352 val coerce = Trace.trace ("AbstractValue.coerce",
 353                           fn {from, to} =>
 354                           let open Layout
 355                           in record [("from", layout from),
 356                                      ("to" , layout to)]
 357                           end, Unit.layout) coerce
 358
 359 structure Dest =
 360    struct
 361       datatype dest =
 362          Array of t
 363        | Lambdas of Lambdas.t
 364        | Ref of t
 365        | Tuple of t vector
 366        | Type of Type.t
 367        | Vector of t
 368        | Weak of t
 369    end
 370
 371 fun dest v =
 372    case tree v of
 373       Type t => Dest.Type t
 374     | Unify (mt, v) => (case mt of
 375                            UnaryTycon.Array => Dest.Array v
 376                          | UnaryTycon.Ref => Dest.Ref v
 377                          | UnaryTycon.Vector => Dest.Vector v
 378                          | UnaryTycon.Weak => Dest.Weak v)
 379     | Tuple vs => Dest.Tuple vs
 380     | Lambdas l => Dest.Lambdas (LambdaNode.toSet l)
 381
 382 open Dest
 383
 384 (*---------------------------------------------------*)
 385 (*                     primApply                     *)
 386 (*---------------------------------------------------*)
 387
 388 val {get = serialValue: Type.t -> t, ...} =
 389    Property.get (Type.plist, Property.initFun fromType)
 390
 391 fun primApply {prim: Type.t Prim.t, args: t vector, resultTy: Type.t}: t =
 392    let
 393       fun result () = fromType resultTy
 394       fun typeError () =
 395          (Control.message
 396           (Control.Silent, fn () =>
 397            let open Layout
 398            in align [seq [str "prim: ", Prim.layout prim],
 399                      seq [str "args: ", Vector.layout layout args]]
 400            end)
 401           ; Error.bug "AbstractValue.primApply: type error")
 402       fun arg i = Vector.sub (args, i)
 403       val n = Vector.length args
 404       fun oneArg () =
 405          if n = 1
 406             then arg 0
 407          else Error.bug "AbstractValue.primApply.oneArg"
 408       fun twoArgs () =
 409          if n = 2
 410             then (arg 0, arg 1)
 411          else Error.bug "AbstractValue.primApply.twoArgs"
 412       fun threeArgs () =
 413          if n = 3
 414             then (arg 0, arg 1, arg 2)
 415          else Error.bug "AbstractValue.primApply.threeArgs"
 416       fun fiveArgs () =
 417          if n = 5
 418             then (arg 0, arg 1, arg 2, arg 3, arg 4)
 419          else Error.bug "AbstractValue.primApply.fiveArgs"
 420       datatype z = datatype Prim.Name.t
 421    in
 422       case Prim.name prim of
 423          Array_copyArray =>
 424             let val (da, _, sa, _, _) = fiveArgs ()
 425             in (case (dest da, dest sa) of
 426                    (Array dx, Array sx) => unify (dx, sx)
 427                  | (Type _, Type _) => ()
 428                  | _ => typeError ()
 429                 ; result ())
 430             end
 431        | Array_copyVector =>
 432             let val (da, _, sa, _, _) = fiveArgs ()
 433             in (case (dest da, dest sa) of
 434                    (Array dx, Vector sx) => unify (dx, sx)
 435                  | (Type _, Type _) => ()
 436                  | _ => typeError ()
 437                 ; result ())
 438             end
 439        | Array_toArray =>
 440             let val r = result ()
 441             in (case (dest (oneArg ()), dest r) of
 442                    (Type _, Type _) => ()
 443                  | (Array x, Array y) =>
 444                       (* Can't do a coercion here because that would imply
 445                        * walking over each element of the array and coercing it.
 446                        *)
 447                       unify (x, y)
 448                  | _ => typeError ())
 449                ; r
 450             end
 451        | Array_toVector =>
 452             let val r = result ()
 453             in (case (dest (oneArg ()), dest r) of
 454                    (Type _, Type _) => ()
 455                  | (Array x, Vector y) =>
 456                       (* Can't do a coercion here because that would imply
 457                        * walking over each element of the array and coercing it.
 458                        *)
 459                       unify (x, y)
 460                  | _ => typeError ())
 461                ; r
 462             end
 463        | Array_sub =>
 464             (case dest (#1 (twoArgs ())) of
 465                 Array x => x
 466               | Type _ => result ()
 467               | _ => typeError ())
 468        | Array_update =>
 469             let val (a, _, x) = threeArgs ()
 470             in (case dest a of
 471                    Array x' => coerce {from = x, to = x'} (* unify (x, x') *)
 472                  | Type _ => ()
 473                  | _ => typeError ())
 474                ; result ()
 475             end
 476        | MLton_deserialize => serialValue resultTy
 477        | MLton_serialize =>
 478             let val arg = oneArg ()
 479             in coerce {from = arg, to = serialValue (ty arg)}
 480                ; result ()
 481             end
 482        | Ref_assign =>
 483             let val (r, x) = twoArgs ()
 484             in (case dest r of
 485                    Ref x' => coerce {from = x, to = x'} (* unify (x, x') *)
 486                  | Type _ => ()
 487                  | _ => typeError ())
 488                ; result ()
 489             end
 490        | Ref_deref => (case dest (oneArg ()) of
 491                           Ref v => v
 492                         | Type _ => result ()
 493                         | _ => typeError ())
 494        | Ref_ref =>
 495             let
 496                val r = result ()
 497                val _ =
 498                   case dest r of
 499                      Ref x => coerce {from = oneArg (), to = x} (* unify (oneArg (), x) *)
 500                    | Type _ => ()
 501                    | _ => typeError ()
 502             in
 503                r
 504             end
 505        | Vector_sub =>
 506             (case dest (#1 (twoArgs ())) of
 507                 Vector x => x
 508               | Type _ => result ()
 509               | _ => typeError ())
 510        | Vector_vector =>
 511             let
 512                 val r = result ()
 513                 val _ =
 514                    case dest r of
 515                       Vector x => Vector.foreach (args, fn arg => coerce {from = arg, to = x})
 516                     | Type _ => ()
 517                     | _ => typeError ()
 518             in
 519                r
 520             end
 521        | Weak_get =>
 522             (case dest (oneArg ()) of
 523                 Weak v => v
 524               | Type _ => result ()
 525               | _ => typeError ())
 526        | Weak_new =>
 527             let
 528                val r = result ()
 529                val _ =
 530                   case dest r of
 531                      Type _ => ()
 532                    | Weak x => coerce {from = oneArg (), to = x}
 533                    | _ => typeError ()
 534             in
 535                r
 536             end
 537        | _ => result ()
 538    end
 539
 540 end