PrimOp-MutVar.dl

/*
  HINT: is interpreted -/+

  primop effectful
    + "newMutVar#"   :: %a -> {"State#" %s} -> {"GHC.Prim.Unit#" {"MutVar#" %s %a}}
    + "readMutVar#"  :: {"MutVar#" %s %a} -> {"State#" %s} -> {"GHC.Prim.Unit#" %a}
    + "writeMutVar#" :: {"MutVar#" %s %a} -> %a -> {"State#" %s} -> {"GHC.Prim.(##)"}

  primop pure
    - "sameMutVar#" :: {"MutVar#" %s %a} -> {"MutVar#" %s %a} -> T_Int64

  primop effectful
    + "atomicModifyMutVar#" :: {"MutVar#" %s %a} -> (%a -> %b) -> {"State#" %s} -> {"GHC.Prim.Unit#" %c}
    + "casMutVar#"          :: {"MutVar#" %s %a} -> %a -> %a -> {"State#" %s} -> {"GHC.Prim.(#,#)" T_Int64 %a}
*/

.decl MutVar(ext_result:Variable, ty_node:Variable, item:Variable)
.output MutVar

// "newMutVar#" :: %a -> {"State#" %s} -> {"GHC.Prim.Unit#" {"MutVar#" %s %a}}
// new mut var
USED("PrimOp-MutVar-01")
//Called(r, op),
MutVar(r, ty_node, item) :-
  op = "newMutVar#",
  Call(r, op, _),
  // initial item
  CallArgument(r, 0, item),
  // extract result node
  RetTup1Node0(op, ty_node),
  NEW_REACHABLE(r)
  .
  // CHECKED

// "readMutVar#" :: {"MutVar#" %s %a} -> {"State#" %s} -> {"GHC.Prim.Unit#" %a}
USED("PrimOp-MutVar-02")
//Called(r, op),
TypeVarPointsTo(r, ty_node, item) :-
  op = "readMutVar#",
  Call(r, op, _),
  // lookup mut var items
  CallArgument(r, 0, arr),
  ExternalOrigin(arr, ext_result, arr_node),
  MutVar(ext_result, arr_node, item),
  // lookup result node
  RetTup1Node0(op, ty_node),
  NEW_REACHABLE(r)
  .
  // CHECKED

// "writeMutVar#" :: {"MutVar#" %s %a} -> %a -> {"State#" %s} -> {"GHC.Prim.(##)"}
// extend mut var
USED("PrimOp-MutVar-03")
//Called(r, op),
MutVar(ext_result, ty_node, item) :-
  op = "writeMutVar#",
  Call(r, op, _),
  // item to write
  CallArgument(r, 1, item),
  // lookup mut var
  CallArgument(r, 0, arr),
  ExternalOrigin(arr, ext_result, ty_node),
  // validation
  MutVar(ext_result, ty_node, _),
  NEW_REACHABLE(r)
  .
  // CHECKED

// "atomicModifyMutVar#" :: {"MutVar#" %s %a} -> (%a -> %b) -> {"State#" %s} -> {"GHC.Prim.Unit#" %c}
// TODO: check how atomicModifyMutVar# works, this type signature does not reflect its semantics
Error(r, "Unsupported (reachable) primop: atomicModifyMutVar# (TBD)") :-
  Call(r, "atomicModifyMutVar#", _),
  HasInst(f, r),
  ReachableCode(f).

// "casMutVar#" :: {"MutVar#" %s %a} -> %a -> %a -> {"State#" %s} -> {"GHC.Prim.(#,#)" T_Int64 %a}
// extend mut var
USED("PrimOp-MutVar-04")
//Called(r, op),
TypeVarPointsTo(r, ty_node, new_item),
TypeVarPointsTo(r, ty_node, item),
MutVar(ext_result, arr_node, new_item) :-
  op = "casMutVar#",
  Call(r, op, _),
  // new item
  CallArgument(r, 2, new_item),
  // lookup mut var
  CallArgument(r, 0, arr),
  ExternalOrigin(arr, ext_result, arr_node),
  // mut var items
  MutVar(ext_result, arr_node, item),
  // extract result node
  RetTup(op, "GHC.Prim.(#,#)", 1, ty_node),
  NEW_REACHABLE(r)
  .
  // CHECKED