[MLton-commit] r6648
Matthew Fluet
fluet at mlton.org
Sun Jun 8 19:03:38 PDT 2008
Simplify implementation of _export.
Pass arguments to and returns from _export-ed SML functions via the C
frame of the stub C function. This reduces the necessary shared state
to a single word.
----------------------------------------------------------------------
U mlton/trunk/basis-library/mlton/ffi.sig
U mlton/trunk/basis-library/mlton/ffi.sml
U mlton/trunk/basis-library/mlton/pointer.sig
U mlton/trunk/basis-library/mlton/pointer.sml
U mlton/trunk/basis-library/mlton/thread.sig
U mlton/trunk/basis-library/mlton/thread.sml
U mlton/trunk/basis-library/primitive/prim-mlton.sml
U mlton/trunk/mlton/atoms/ffi.fun
U mlton/trunk/mlton/elaborate/elaborate-core.fun
----------------------------------------------------------------------
Modified: mlton/trunk/basis-library/mlton/ffi.sig
===================================================================
--- mlton/trunk/basis-library/mlton/ffi.sig 2008-06-06 16:42:09 UTC (rev 6647)
+++ mlton/trunk/basis-library/mlton/ffi.sig 2008-06-09 02:03:36 UTC (rev 6648)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2003-2007 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2003-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under a BSD-style license.
@@ -7,43 +7,41 @@
signature MLTON_FFI =
sig
- val atomicBegin: unit -> unit
- val atomicEnd: unit -> unit
- val getBool: int -> bool
- val getChar8: int -> Char.char
+ val getBool: MLtonPointer.t * int -> bool
+ val getChar8: MLtonPointer.t * int -> Char.char
(*
- val getChar16: int -> Char16.char
- val getChar32: int -> Char32.char
+ val getChar16: MLtonPointer.t * int -> Char16.char
+ val getChar32: MLtonPointer.t * int -> Char32.char
*)
- val getCPointer: int -> MLtonPointer.t
- val getInt8: int -> Int8.int
- val getInt16: int -> Int16.int
- val getInt32: int -> Int32.int
- val getInt64: int -> Int64.int
- val getObjptr: int -> 'a
- val getReal32: int -> Real32.real
- val getReal64: int -> Real64.real
- val getWord8: int -> Word8.word
- val getWord16: int -> Word16.word
- val getWord32: int -> Word32.word
- val getWord64: int -> Word64.word
- val register: int * (unit -> unit) -> unit
- val setBool: bool -> unit
- val setChar8: Char.char -> unit
+ val getCPointer: MLtonPointer.t * int -> MLtonPointer.t
+ val getInt8: MLtonPointer.t * int -> Int8.int
+ val getInt16: MLtonPointer.t * int -> Int16.int
+ val getInt32: MLtonPointer.t * int -> Int32.int
+ val getInt64: MLtonPointer.t * int -> Int64.int
+ val getObjptr: MLtonPointer.t * int -> 'a
+ val getReal32: MLtonPointer.t * int -> Real32.real
+ val getReal64: MLtonPointer.t * int -> Real64.real
+ val getWord8: MLtonPointer.t * int -> Word8.word
+ val getWord16: MLtonPointer.t * int -> Word16.word
+ val getWord32: MLtonPointer.t * int -> Word32.word
+ val getWord64: MLtonPointer.t * int -> Word64.word
+ val register: int * (MLtonPointer.t -> unit) -> unit
+ val setBool: MLtonPointer.t * int * bool -> unit
+ val setChar8: MLtonPointer.t * int * Char.char -> unit
(*
- val setChar16: Char16.char -> unit
- val setChar32: Char32.char -> unit
+ val setChar16: MLtonPointer.t * Char16.char -> unit
+ val setChar32: MLtonPointer.t * Char32.char -> unit
*)
- val setCPointer: MLtonPointer.t -> unit
- val setInt8: Int8.int -> unit
- val setInt16: Int16.int -> unit
- val setInt32: Int32.int -> unit
- val setInt64: Int64.int -> unit
- val setObjptr: 'a -> unit
- val setReal32: Real32.real -> unit
- val setReal64: Real64.real -> unit
- val setWord8: Word8.word -> unit
- val setWord16: Word16.word -> unit
- val setWord32: Word32.word -> unit
- val setWord64: Word64.word -> unit
+ val setCPointer: MLtonPointer.t * int * MLtonPointer.t -> unit
+ val setInt8: MLtonPointer.t * int * Int8.int -> unit
+ val setInt16: MLtonPointer.t * int * Int16.int -> unit
+ val setInt32: MLtonPointer.t * int * Int32.int -> unit
+ val setInt64: MLtonPointer.t * int * Int64.int -> unit
+ val setObjptr: MLtonPointer.t * int * 'a -> unit
+ val setReal32: MLtonPointer.t * int * Real32.real -> unit
+ val setReal64: MLtonPointer.t * int * Real64.real -> unit
+ val setWord8: MLtonPointer.t * int * Word8.word -> unit
+ val setWord16: MLtonPointer.t * int * Word16.word -> unit
+ val setWord32: MLtonPointer.t * int * Word32.word -> unit
+ val setWord64: MLtonPointer.t * int * Word64.word -> unit
end
Modified: mlton/trunk/basis-library/mlton/ffi.sml
===================================================================
--- mlton/trunk/basis-library/mlton/ffi.sml 2008-06-06 16:42:09 UTC (rev 6647)
+++ mlton/trunk/basis-library/mlton/ffi.sml 2008-06-09 02:03:36 UTC (rev 6648)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2003-2007 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2003-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under a BSD-style license.
@@ -8,62 +8,56 @@
structure MLtonFFI: MLTON_FFI =
struct
-structure Prim = Primitive.MLton.FFI
+val register = MLtonThread.register
-structure Pointer = Primitive.MLton.Pointer
-
local
- fun make (p: Pointer.t, get, set) =
- (fn i => get (p, C_Ptrdiff.fromInt i),
- fn x => set (p, C_Ptrdiff.fromInt 0, x))
+ fun makeGet get (p,i) = get (MLtonPointer.getPointer (p, i), 0)
+ fun makeSet set (p,i,x) = set (MLtonPointer.getPointer (p, i), 0, x)
+ fun make (get,set) = (makeGet get, makeSet set)
in
- fun getCPointer i = Pointer.getCPointer (Prim.cpointerArray, C_Ptrdiff.fromInt i)
- fun setCPointer x = Pointer.setCPointer (Prim.cpointerArray, C_Ptrdiff.fromInt 0, x)
+ val (getCPointer, setCPointer) =
+ make (MLtonPointer.getCPointer, MLtonPointer.setCPointer)
val (getInt8, setInt8) =
- make (Prim.int8Array, Pointer.getInt8, Pointer.setInt8)
+ make (MLtonPointer.getInt8, MLtonPointer.setInt8)
val (getInt16, setInt16) =
- make (Prim.int16Array, Pointer.getInt16, Pointer.setInt16)
+ make (MLtonPointer.getInt16, MLtonPointer.setInt16)
val (getInt32, setInt32) =
- make (Prim.int32Array, Pointer.getInt32, Pointer.setInt32)
+ make (MLtonPointer.getInt32, MLtonPointer.setInt32)
val (getInt64, setInt64) =
- make (Prim.int64Array, Pointer.getInt64, Pointer.setInt64)
- fun getObjptr i = Pointer.getObjptr (Prim.objptrArray, C_Ptrdiff.fromInt i)
- fun setObjptr x = Pointer.setObjptr (Prim.objptrArray, C_Ptrdiff.fromInt 0, x)
+ make (MLtonPointer.getInt64, MLtonPointer.setInt64)
+ val getObjptr = fn (p,i) => makeGet MLtonPointer.getObjptr (p,i)
+ val setObjptr = fn (p,i,x) => makeSet MLtonPointer.setObjptr (p,i,x)
val (getReal32, setReal32) =
- make (Prim.real32Array, Pointer.getReal32, Pointer.setReal32)
+ make (MLtonPointer.getReal32, MLtonPointer.setReal32)
val (getReal64, setReal64) =
- make (Prim.real64Array, Pointer.getReal64, Pointer.setReal64)
+ make (MLtonPointer.getReal64, MLtonPointer.setReal64)
val (getWord8, setWord8) =
- make (Prim.word8Array, Pointer.getWord8, Pointer.setWord8)
+ make (MLtonPointer.getWord8, MLtonPointer.setWord8)
val (getWord16, setWord16) =
- make (Prim.word16Array, Pointer.getWord16, Pointer.setWord16)
+ make (MLtonPointer.getWord16, MLtonPointer.setWord16)
val (getWord32, setWord32) =
- make (Prim.word32Array, Pointer.getWord32, Pointer.setWord32)
+ make (MLtonPointer.getWord32, MLtonPointer.setWord32)
val (getWord64, setWord64) =
- make (Prim.word64Array, Pointer.getWord64, Pointer.setWord64)
+ make (MLtonPointer.getWord64, MLtonPointer.setWord64)
end
-val atomicBegin = MLtonThread.atomicBegin
-val atomicEnd = MLtonThread.atomicEnd
-val register = MLtonThread.register
-
(* To the C-world, chars are unsigned integers. *)
-val getChar8 = Primitive.Char8.idFromWord8 o getWord8
+val getChar8 = fn (p, i) => Primitive.Char8.idFromWord8 (getWord8 (p, i))
(*
-val getChar16 = Primitive.Char16.idFromWord16 o getWord16
-val getChar32 = Primitive.Char32.idFromWord32 o getWord32
+val getChar16 = fn (p, i) => Primitive.Char16.idFromWord16 (getWord16 (p, i))
+val getChar32 = fn (p, i) => Primitive.Char32.idFromWord32 (getWord32 (p, i))
*)
-val setChar8 = setWord8 o Primitive.Char8.idToWord8
+val setChar8 = fn (p, i, x) => setWord8 (p, i, Primitive.Char8.idToWord8 x)
(*
-val setChar16 = setWord16 o Primitive.Char16.idToWord16
-val setChar32 = setWord32 o Primitive.Char32.idToWord32
+val setChar16 = fn (p, i, x) => setWord16 (p, i, Primitive.Char16.idToWord16 x)
+val setChar32 = fn (p, i, x) => setWord32 (p, i, Primitive.Char32.idToWord32 x)
*)
(* To the C-world, booleans are 32-bit integers. *)
fun intToBool (i: Int32.int): bool = i <> 0
-val getBool = intToBool o getInt32
+val getBool = fn (p, i) => intToBool(getInt32 (p, i))
fun boolToInt (b: bool): Int32.int = if b then 1 else 0
-val setBool = setInt32 o boolToInt
+val setBool = fn (p, i, x) => setInt32 (p, i, boolToInt x)
end
Modified: mlton/trunk/basis-library/mlton/pointer.sig
===================================================================
--- mlton/trunk/basis-library/mlton/pointer.sig 2008-06-06 16:42:09 UTC (rev 6647)
+++ mlton/trunk/basis-library/mlton/pointer.sig 2008-06-09 02:03:36 UTC (rev 6648)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2003-2006 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2003-2006,2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under a BSD-style license.
@@ -39,3 +39,13 @@
val sizeofPointer: word
val sub: t * word -> t
end
+
+signature MLTON_POINTER_EXTRA =
+ sig
+ include MLTON_POINTER
+
+ val getCPointer: t * int -> t
+ val setCPointer: t * int * t -> unit
+ val getObjptr: t * int -> 'a
+ val setObjptr: t * int * 'a -> unit
+ end
Modified: mlton/trunk/basis-library/mlton/pointer.sml
===================================================================
--- mlton/trunk/basis-library/mlton/pointer.sml 2008-06-06 16:42:09 UTC (rev 6647)
+++ mlton/trunk/basis-library/mlton/pointer.sml 2008-06-09 02:03:36 UTC (rev 6648)
@@ -1,11 +1,11 @@
-(* Copyright (C) 2003-2007 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2003-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under a BSD-style license.
* See the file MLton-LICENSE for details.
*)
-structure MLtonPointer: MLTON_POINTER =
+structure MLtonPointer: MLTON_POINTER_EXTRA =
struct
open Primitive.MLton.Pointer
@@ -20,11 +20,12 @@
fun wrap f (p, i) =
f (p, C_Ptrdiff.fromInt i)
in
+ val getCPointer = wrap getCPointer
val getInt8 = wrap getInt8
val getInt16 = wrap getInt16
val getInt32 = wrap getInt32
val getInt64 = wrap getInt64
- val getPointer = wrap getCPointer
+ val getObjptr = fn (p, i) => (wrap getObjptr) (p, i)
val getReal32 = wrap getReal32
val getReal64 = wrap getReal64
val getWord8 = wrap getWord8
@@ -32,16 +33,18 @@
val getWord32 = wrap getWord32
val getWord64 = wrap getWord64
end
+val getPointer = getCPointer
local
fun wrap f (p, i, x) =
f (p, C_Ptrdiff.fromInt i, x)
in
+ val setCPointer = wrap setCPointer
val setInt8 = wrap setInt8
val setInt16 = wrap setInt16
val setInt32 = wrap setInt32
val setInt64 = wrap setInt64
- val setPointer = wrap setCPointer
+ val setObjptr = fn (p, i, x) => (wrap setObjptr) (p, i, x)
val setReal32 = wrap setReal32
val setReal64 = wrap setReal64
val setWord8 = wrap setWord8
@@ -49,5 +52,6 @@
val setWord32 = wrap setWord32
val setWord64 = wrap setWord64
end
+val setPointer = setCPointer
end
Modified: mlton/trunk/basis-library/mlton/thread.sig
===================================================================
--- mlton/trunk/basis-library/mlton/thread.sig 2008-06-06 16:42:09 UTC (rev 6647)
+++ mlton/trunk/basis-library/mlton/thread.sig 2008-06-09 02:03:36 UTC (rev 6648)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2004-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under a BSD-style license.
@@ -62,7 +62,7 @@
include MLTON_THREAD
val amInSignalHandler: unit -> bool
- val register: int * (unit -> unit) -> unit
+ val register: int * (MLtonPointer.t -> unit) -> unit
val setSignalHandler: (Runnable.t -> Runnable.t) -> unit
val switchToSignalHandler: unit -> unit
end
Modified: mlton/trunk/basis-library/mlton/thread.sml
===================================================================
--- mlton/trunk/basis-library/mlton/thread.sml 2008-06-06 16:42:09 UTC (rev 6647)
+++ mlton/trunk/basis-library/mlton/thread.sml 2008-06-09 02:03:36 UTC (rev 6648)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2004-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under a BSD-style license.
@@ -222,11 +222,11 @@
local
in
- val register: int * (unit -> unit) -> unit =
+ val register: int * (MLtonPointer.t -> unit) -> unit =
let
val exports =
Array.array (Int32.toInt (Primitive.MLton.FFI.numExports),
- fn () => raise Fail "undefined export")
+ fn _ => raise Fail "undefined export")
fun loop (): unit =
let
(* Atomic 2 *)
@@ -234,14 +234,18 @@
fun doit () =
let
(* Atomic 1 *)
- val _ =
- (* atomicEnd() after getting args *)
- (Array.sub (exports, Int32.toInt (Primitive.MLton.FFI.getOp ())) ())
+ val p = Primitive.MLton.FFI.getOpArgsResPtr ()
+ val _ = atomicEnd ()
+ (* Atomic 0 *)
+ val i = MLtonPointer.getInt32 (MLtonPointer.getPointer (p, 0), 0)
+ val _ =
+ (Array.sub (exports, Int32.toInt i) p)
handle e =>
(TextIO.output
(TextIO.stdErr, "Call from C to SML raised exception.\n")
; MLtonExn.topLevelHandler e)
- (* atomicBegin() before putting res *)
+ (* Atomic 0 *)
+ val _ = atomicBegin ()
(* Atomic 1 *)
val _ = Prim.setSaved (gcState, t)
val _ = Prim.returnToC () (* implicit atomicEnd() *)
Modified: mlton/trunk/basis-library/primitive/prim-mlton.sml
===================================================================
--- mlton/trunk/basis-library/primitive/prim-mlton.sml 2008-06-06 16:42:09 UTC (rev 6647)
+++ mlton/trunk/basis-library/primitive/prim-mlton.sml 2008-06-09 02:03:36 UTC (rev 6648)
@@ -114,20 +114,8 @@
structure FFI =
struct
- val cpointerArray = #1 _symbol "MLton_FFI_CPointer": Pointer.t GetSet.t; ()
- val getOp = #1 _symbol "MLton_FFI_op": Int32.t GetSet.t;
- val int8Array = #1 _symbol "MLton_FFI_Int8": Pointer.t GetSet.t; ()
- val int16Array = #1 _symbol "MLton_FFI_Int16": Pointer.t GetSet.t; ()
- val int32Array = #1 _symbol "MLton_FFI_Int32": Pointer.t GetSet.t; ()
- val int64Array = #1 _symbol "MLton_FFI_Int64": Pointer.t GetSet.t; ()
+ val getOpArgsResPtr = #1 _symbol "MLton_FFI_opArgsResPtr": Pointer.t GetSet.t;
val numExports = _build_const "MLton_FFI_numExports": Int32.int;
- val objptrArray = #1 _symbol "MLton_FFI_Objptr": Pointer.t GetSet.t; ()
- val real32Array = #1 _symbol "MLton_FFI_Real32": Pointer.t GetSet.t; ()
- val real64Array = #1 _symbol "MLton_FFI_Real64": Pointer.t GetSet.t; ()
- val word8Array = #1 _symbol "MLton_FFI_Word8": Pointer.t GetSet.t; ()
- val word16Array = #1 _symbol "MLton_FFI_Word16": Pointer.t GetSet.t; ()
- val word32Array = #1 _symbol "MLton_FFI_Word32": Pointer.t GetSet.t; ()
- val word64Array = #1 _symbol "MLton_FFI_Word64": Pointer.t GetSet.t; ()
end
structure Finalizable =
Modified: mlton/trunk/mlton/atoms/ffi.fun
===================================================================
--- mlton/trunk/mlton/atoms/ffi.fun 2008-06-06 16:42:09 UTC (rev 6647)
+++ mlton/trunk/mlton/atoms/ffi.fun 2008-06-09 02:03:36 UTC (rev 6648)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2004-2006 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2004-2006,2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under a BSD-style license.
@@ -44,42 +44,7 @@
fun declareExports {print} =
let
- val maxMap = CType.memo (fn _ => ref ~1)
- fun bump (t, i) =
- let
- val r = maxMap t
- in
- r := Int.max (!r, i)
- end
- val _ =
- List.foreach
- (!exports, fn {args, res, ...} =>
- let
- val map = CType.memo (fn _ => Counter.new 0)
- in
- Vector.foreach (args, fn t => bump (t, Counter.next (map t)))
- ; Option.app (res, fn t => bump (t, 0))
- end)
- (* Declare the arrays and functions used for parameter passing. *)
- val _ =
- List.foreach
- (CType.all, fn t =>
- let
- val n = !(maxMap t)
- in
- if n >= 0
- then
- let
- val size = Int.toString (1 + n)
- val t = CType.toString t
- val array = concat ["MLton_FFI_", t, "_array"]
- in
- print (concat [t, " ", array, "[", size, "];\n",
- t, " *MLton_FFI_", t, " = &", array, ";\n"])
- end
- else ()
- end)
- val _ = print "Int32 MLton_FFI_op;\n"
+ val _ = print "Pointer MLton_FFI_opArgsResPtr;\n"
in
List.foreach
(!symbols, fn {name, ty} =>
@@ -92,20 +57,16 @@
List.foreach
(!exports, fn {args, convention, id, name, res} =>
let
- val varCounter = Counter.new 0
- val map = CType.memo (fn _ => Counter.new 0)
val args =
- Vector.map
- (args, fn t =>
+ Vector.mapi
+ (args, fn (i,t) =>
let
- val index = Counter.next (map t)
- val x = concat ["x", Int.toString (Counter.next varCounter)]
+ val x = concat ["x", Int.toString i]
val t = CType.toString t
in
- (x,
- concat [t, " ", x],
- concat ["\tMLton_FFI_", t, "_array[", Int.toString index,
- "] = ", x, ";\n"])
+ (concat [t, " ", x],
+ concat ["\tlocalOpArgsRes[", Int.toString (i + 1), "] = ",
+ "(Pointer)(&", x, ");\n"])
end)
val header =
concat [case res of
@@ -117,19 +78,29 @@
")) "]
else " ",
name, " (",
- concat (List.separate (Vector.toListMap (args, #2), ", ")),
+ concat (List.separate (Vector.toListMap (args, #1), ", ")),
")"]
val _ = List.push (headers, header)
+ val n =
+ 1 + (Vector.length args)
+ + (case res of NONE => 0 | SOME _ => 1)
in
print (concat [header, " {\n"])
- ; print (concat ["\tMLton_FFI_op = ", Int.toString id, ";\n"])
- ; Vector.foreach (args, fn (_, _, set) => print set)
- ; print ("\tMLton_callFromC ();\n")
+ ; print (concat ["\tPointer localOpArgsRes[", Int.toString n,"];\n"])
+ ; print (concat ["\tMLton_FFI_opArgsResPtr = (Pointer)(localOpArgsRes);\n"])
+ ; print (concat ["\tInt32 localOp = ", Int.toString id, ";\n",
+ "\tlocalOpArgsRes[0] = (Pointer)(&localOp);\n"])
+ ; Vector.foreach (args, fn (_, set) => print set)
; (case res of
NONE => ()
| SOME t =>
- print (concat
- ["\treturn MLton_FFI_", CType.toString t, "_array[0];\n"]))
+ print (concat ["\t", CType.toString t, " localRes;\n",
+ "\tlocalOpArgsRes[", Int.toString (Vector.length args + 1), "] = ",
+ "(Pointer)(&localRes);\n"]))
+ ; print ("\tMLton_callFromC ();\n")
+ ; (case res of
+ NONE => ()
+ | SOME _ => print "\treturn localRes;\n")
; print "}\n"
end)
end
Modified: mlton/trunk/mlton/elaborate/elaborate-core.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-core.fun 2008-06-06 16:42:09 UTC (rev 6647)
+++ mlton/trunk/mlton/elaborate/elaborate-core.fun 2008-06-09 02:03:36 UTC (rev 6648)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -1271,6 +1271,7 @@
fun int (i: int): Aexp.t =
Aexp.const (Aconst.makeRegion (Aconst.Int (IntInf.fromInt i), region))
val f = Var.fromSymbol (Symbol.fromString "f", region)
+ val p = Var.fromSymbol (Symbol.fromString "p", region)
in
Exp.fnn
(Vector.new1
@@ -1282,26 +1283,25 @@
(int exportId,
Exp.fnn
(Vector.new1
- (Pat.tuple (Vector.new0 ()),
+ (Pat.var p,
let
- val map = CType.memo (fn _ => Counter.new 0)
- val varCounter = Counter.new 0
val (args, decs) =
Vector.unzip
- (Vector.map
- (args, fn {ctype, name, ...} =>
+ (Vector.mapi
+ (args, fn (i, {ctype, name, ...}) =>
let
val x =
Var.fromSymbol
- (Symbol.fromString
- (concat ["x",
- Int.toString (Counter.next varCounter)]),
+ (Symbol.fromString (concat ["x", Int.toString i]),
region)
val dec =
- Dec.vall (Vector.new0 (),
- x,
- Exp.app (id (concat ["get", name]),
- int (Counter.next (map ctype))))
+ Dec.vall
+ (Vector.new0 (),
+ x,
+ Exp.app
+ (id (concat ["get", name]),
+ (Exp.tuple o Vector.new2)
+ (Exp.var p, int (i + 1))))
in
(x, dec)
end))
@@ -1311,18 +1311,20 @@
Exp.lett
(Vector.concat
[decs,
- Vector.map
- (Vector.new4
- ((newVar (), Exp.app (id "atomicEnd", Exp.unit)),
- (resVar, Exp.app (Exp.var f,
+ Vector.map
+ (Vector.new2
+ ((resVar, Exp.app (Exp.var f,
Exp.tuple (Vector.map (args, Exp.var)))),
- (newVar (), Exp.app (id "atomicBegin", Exp.unit)),
(newVar (),
(case res of
NONE => Exp.constraint (Exp.var resVar, Type.unit)
- | SOME {name, ...} =>
- Exp.app (id (concat ["set", name]),
- Exp.var resVar)))),
+ | SOME {name, ...} =>
+ Exp.app
+ (id (concat ["set", name]),
+ (Exp.tuple o Vector.new3)
+ (Exp.var p,
+ int (Vector.length args + 1),
+ Exp.var resVar))))),
fn (x, e) => Dec.vall (Vector.new0 (), x, e))],
Exp.tuple (Vector.new0 ()),
region)
More information about the MLton-commit
mailing list