[MLton] cvs commit: changed typing for C functions
Stephen Weeks
sweeks@mlton.org
Mon, 12 Apr 2004 10:53:11 -0700
sweeks 04/04/12 10:53:08
Modified: mlton/ast prim-tycons.fun prim-tycons.sig
mlton/atoms atoms.fun atoms.sig c-function.fun
c-function.sig c-type.fun c-type.sig ffi.sig
hash-type.fun hash-type.sig prim.fun prim.sig
rep-type.fun rep-type.sig sources.cm type-ops.fun
type-ops.sig
mlton/backend backend.fun limit-check.fun machine.fun
machine.sig profile.fun rssa.fun rssa.sig
signal-check.fun ssa-to-rssa.fun
mlton/closure-convert abstract-value.fun abstract-value.sig
closure-convert.fun closure-convert.sig
mlton/codegen/c-codegen c-codegen.fun
mlton/codegen/x86-codegen x86-mlton-basic.fun
x86-mlton-basic.sig x86-mlton.fun x86-mlton.sig
x86-pseudo.sig x86.fun x86.sig
mlton/core-ml core-ml.fun core-ml.sig
mlton/defunctorize defunctorize.fun
mlton/elaborate elaborate-core.fun type-env.fun
mlton/ssa analyze.sig direct-exp.fun direct-exp.sig
redundant-tests.fun shrink.fun ssa-tree.fun
ssa-tree.sig type-check.fun
mlton/xml implement-exceptions.fun monomorphise.fun
simplify-types.fun type-check.fun xml-tree.fun
xml-tree.sig
Log:
MAIL changed typing for C functions
Another overhaul of types for C functions. Now, CFunction.t is
polymorphic in the type used for its arguments and result. Each IL
fills in the type needed for its type system. The types are
translated by each pass, ending up with representation types in the
Rssa and Machine.
Because C functions are treated as primitives in XML and SSA,
primitives are now also polymorphic in the type.
Improved type checking of primapps.
Removed primitive pointer tycon (for C pointers) and associated types.
The basis library uses Word32.word.
Revision Changes Path
1.22 +0 -2 mlton/mlton/ast/prim-tycons.fun
Index: prim-tycons.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.fun,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- prim-tycons.fun 4 Apr 2004 06:50:14 -0000 1.21
+++ prim-tycons.fun 12 Apr 2004 17:52:46 -0000 1.22
@@ -23,7 +23,6 @@
val exn = fromString "exn"
val intInf = fromString "intInf"
val list = fromString "list"
-val pointer = fromString "pointer"
val preThread = fromString "preThread"
val reff = fromString "ref"
val thread = fromString "thread"
@@ -91,7 +90,6 @@
(exn, Arity 0, Never),
(intInf, Arity 0, Always),
(list, Arity 1, Sometimes),
- (pointer, Arity 0, Always),
(preThread, Arity 0, Never),
(reff, Arity 1, Always),
(thread, Arity 0, Never),
1.12 +0 -1 mlton/mlton/ast/prim-tycons.sig
Index: prim-tycons.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- prim-tycons.sig 18 Mar 2004 03:22:21 -0000 1.11
+++ prim-tycons.sig 12 Apr 2004 17:52:46 -0000 1.12
@@ -48,7 +48,6 @@
tycon * (Layout.t * {isChar: bool, needsParen: bool}) vector
-> Layout.t * {isChar: bool, needsParen: bool}
val list: tycon
- val pointer: tycon
val preThread: tycon
val prims: (tycon * Kind.t * AdmitsEquality.t) list
val real: RealSize.t -> tycon
1.15 +11 -10 mlton/mlton/atoms/atoms.fun
Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- atoms.fun 4 Apr 2004 06:50:14 -0000 1.14
+++ atoms.fun 12 Apr 2004 17:52:47 -0000 1.15
@@ -42,24 +42,25 @@
structure Const = Const (structure IntX = IntX
structure RealX = RealX
structure WordX = WordX)
- structure RepType = RepType (structure CType = CType
+ structure CFunction = CFunction ()
+ structure Prim = Prim (structure CFunction = CFunction
+ structure CType = CType
+ structure Con = Con
+ structure Const = Const
+ structure IntSize = IntSize
+ structure RealSize = RealSize
+ structure WordSize = WordSize)
+ structure RepType = RepType (structure CFunction = CFunction
+ structure CType = CType
structure IntSize = IntSize
structure IntX = IntX
structure Label = Label
structure PointerTycon = PointerTycon
+ structure Prim = Prim
structure RealSize = RealSize
structure Runtime = Runtime
structure WordSize = WordSize
structure WordX = WordX)
- structure CFunction = CFunction (structure RepType = RepType)
- structure Prim = Prim (structure CFunction = CFunction
- structure CType = CType
- structure Con = Con
- structure Const = Const
- structure IntSize = IntSize
- structure RealSize = RealSize
- structure RepType = RepType
- structure WordSize = WordSize)
structure Ffi = Ffi (structure CFunction = CFunction
structure CType = CType)
structure ObjectType = RepType.ObjectType
1.16 +1 -1 mlton/mlton/atoms/atoms.sig
Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- atoms.sig 4 Apr 2004 06:50:14 -0000 1.15
+++ atoms.sig 12 Apr 2004 17:52:47 -0000 1.16
@@ -56,9 +56,9 @@
sharing Label = RepType.Label
sharing ObjectType = RepType.ObjectType
sharing PointerTycon = ObjectType.PointerTycon = RepType.PointerTycon
+ sharing Prim = RepType.Prim
sharing RealSize = Prim.RealSize = RealX.RealSize = RepType.RealSize
= Tycon.RealSize
- sharing RepType = CFunction.RepType = Prim.RepType
sharing RealX = Const.RealX
sharing Runtime = ObjectType.Runtime = RepType.Runtime
sharing SourceInfo = ProfileExp.SourceInfo
1.6 +42 -132 mlton/mlton/atoms/c-function.fun
Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-function.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- c-function.fun 4 Apr 2004 06:50:14 -0000 1.5
+++ c-function.fun 12 Apr 2004 17:52:48 -0000 1.6
@@ -3,17 +3,6 @@
open S
-structure Type = RepType
-structure CType = Type.CType
-
-local
- open Type
-in
- structure IntSize = IntSize
- structure RealSize = RealSize
- structure WordSize = WordSize
-end
-
structure Convention =
struct
datatype t =
@@ -27,22 +16,23 @@
val layout = Layout.str o toString
end
-datatype t = T of {args: Type.t vector,
- bytesNeeded: int option,
- convention: Convention.t,
- ensuresBytesFree: bool,
- mayGC: bool,
- maySwitchThreads: bool,
- modifiesFrontier: bool,
- modifiesStackTop: bool,
- name: string,
- return: Type.t}
+datatype 'a t = T of {args: 'a vector,
+ bytesNeeded: int option,
+ convention: Convention.t,
+ ensuresBytesFree: bool,
+ mayGC: bool,
+ maySwitchThreads: bool,
+ modifiesFrontier: bool,
+ modifiesStackTop: bool,
+ name: string,
+ return: 'a}
fun layout (T {args, bytesNeeded, convention, ensuresBytesFree, mayGC,
maySwitchThreads, modifiesFrontier, modifiesStackTop, name,
- return, ...}) =
+ return, ...},
+ layoutType) =
Layout.record
- [("args", Vector.layout Type.layout args),
+ [("args", Vector.layout layoutType args),
("bytesNeeded", Option.layout Int.layout bytesNeeded),
("convention", Convention.layout convention),
("ensuresBytesFree", Bool.layout ensuresBytesFree),
@@ -51,28 +41,44 @@
("modifiesFrontier", Bool.layout modifiesFrontier),
("modifiesStackTop", Bool.layout modifiesStackTop),
("name", String.layout name),
- ("return", Type.layout return)]
+ ("return", layoutType return)]
local
fun make f (T r) = f r
in
- val args = make #args
- val bytesNeeded = make #bytesNeeded
- val ensuresBytesFree = make #ensuresBytesFree
- val mayGC = make #mayGC
- val maySwitchThreads = make #maySwitchThreads
- val modifiesFrontier = make #modifiesFrontier
- val modifiesStackTop = make #modifiesStackTop
- val name = make #name
- val return = make #return
+ fun args z = make #args z
+ fun bytesNeeded z = make #bytesNeeded z
+ fun ensuresBytesFree z = make #ensuresBytesFree z
+ fun mayGC z = make #mayGC z
+ fun maySwitchThreads z = make #maySwitchThreads z
+ fun modifiesFrontier z = make #modifiesFrontier z
+ fun modifiesStackTop z = make #modifiesStackTop z
+ fun name z = make #name z
+ fun return z = make #return z
end
fun equals (f, f') = name f = name f'
+fun map (T {args, bytesNeeded, convention, ensuresBytesFree, mayGC,
+ maySwitchThreads, modifiesFrontier, modifiesStackTop, name,
+ return},
+ f) =
+ T {args = Vector.map (args, f),
+ bytesNeeded = bytesNeeded,
+ convention = convention,
+ ensuresBytesFree = ensuresBytesFree,
+ mayGC = mayGC,
+ maySwitchThreads = maySwitchThreads,
+ modifiesFrontier = modifiesFrontier,
+ modifiesStackTop = modifiesStackTop,
+ name = name,
+ return = f return}
+
fun isOk (T {ensuresBytesFree, mayGC, maySwitchThreads, modifiesFrontier,
- modifiesStackTop, return, ...}): bool =
+ modifiesStackTop, return, ...},
+ {isUnit}): bool =
(if maySwitchThreads
- then mayGC andalso RepType.isUnit return
+ then mayGC andalso isUnit return
else true)
andalso
(if ensuresBytesFree orelse maySwitchThreads
@@ -82,52 +88,11 @@
(if mayGC
then (modifiesFrontier andalso modifiesStackTop)
else true)
-
-val isOk = Trace.trace ("CFunction.isOk", layout, Bool.layout) isOk
-
-val equals =
- Trace.trace2 ("CFunction.equals", layout, layout, Bool.layout) equals
-
-datatype z = datatype Convention.t
-
-local
- open Type
-in
- val Int32 = int (IntSize.I (Bits.fromInt 32))
- val Word32 = word (Bits.fromInt 32)
- val bool = bool
- val cPointer = cPointer
- val gcState = gcState
- val string = word8Vector
- val unit = unit
-end
-
-local
- fun make b =
- T {args = let
- open Type
- in
- Vector.new5 (gcState, Word32, bool, cPointer (), Int32)
- end,
- bytesNeeded = NONE,
- convention = Cdecl,
- ensuresBytesFree = true,
- mayGC = true,
- maySwitchThreads = b,
- modifiesFrontier = true,
- modifiesStackTop = true,
- name = "GC_gc",
- return = unit}
- val t = make true
- val f = make false
-in
- fun gc {maySwitchThreads = b} = if b then t else f
-end
fun vanilla {args, name, return} =
T {args = args,
bytesNeeded = NONE,
- convention = Cdecl,
+ convention = Convention.Cdecl,
ensuresBytesFree = false,
mayGC = false,
maySwitchThreads = false,
@@ -135,60 +100,5 @@
modifiesStackTop = false,
name = name,
return = return}
-
-val allocTooLarge =
- vanilla {args = Vector.new0 (),
- name = "MLton_allocTooLarge",
- return = unit}
-
-val bug = vanilla {args = Vector.new1 string,
- name = "MLton_bug",
- return = unit}
-
-val profileEnter =
- vanilla {args = Vector.new1 gcState,
- name = "GC_profileEnter",
- return = unit}
-
-val profileInc =
- vanilla {args = Vector.new2 (gcState, Word32),
- name = "GC_profileInc",
- return = unit}
-
-val profileLeave =
- vanilla {args = Vector.new1 gcState,
- name = "GC_profileLeave",
- return = unit}
-
-val returnToC =
- T {args = Vector.new0 (),
- bytesNeeded = NONE,
- convention = Cdecl,
- ensuresBytesFree = false,
- modifiesFrontier = true,
- modifiesStackTop = true,
- mayGC = true,
- maySwitchThreads = true,
- name = "Thread_returnToC",
- return = unit}
-
-fun prototype (T {args, convention, name, return, ...}) =
- let
- val c = Counter.new 0
- fun arg t = concat [CType.toString (Type.toCType t),
- " x", Int.toString (Counter.next c)]
- in
- concat [if Type.isUnit return
- then "void"
- else CType.toString (Type.toCType return),
- if convention <> Convention.Cdecl
- then concat [" __attribute__ ((",
- Convention.toString convention,
- ")) "]
- else " ",
- name, " (",
- concat (List.separate (Vector.toListMap (args, arg), ", ")),
- ")"]
- end
end
1.3 +33 -46 mlton/mlton/atoms/c-function.sig
Index: c-function.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-function.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- c-function.sig 4 Apr 2004 06:50:14 -0000 1.2
+++ c-function.sig 12 Apr 2004 17:52:48 -0000 1.3
@@ -9,13 +9,12 @@
signature C_FUNCTION_STRUCTS =
sig
- structure RepType: REP_TYPE
end
signature C_FUNCTION =
sig
include C_FUNCTION_STRUCTS
-
+
structure Convention:
sig
datatype t = Cdecl | Stdcall
@@ -24,50 +23,38 @@
val toString: t -> string
end
- datatype t = T of {args: RepType.t vector,
- (* bytesNeeded = SOME i means that the i'th
- * argument to the function is a word that
- * specifies the number of bytes that must be
- * free in order for the C function to succeed.
- * Limit check insertion is responsible for
- * making sure that the bytesNeeded is available.
- *)
- bytesNeeded: int option,
- convention: Convention.t,
- ensuresBytesFree: bool,
- mayGC: bool,
- maySwitchThreads: bool,
- modifiesFrontier: bool,
- modifiesStackTop: bool,
- name: string,
- return: RepType.t}
+ datatype 'a t = T of {args: 'a vector,
+ (* bytesNeeded = SOME i means that the i'th
+ * argument to the function is a word that
+ * specifies the number of bytes that must be
+ * free in order for the C function to succeed.
+ * Limit check insertion is responsible for
+ * making sure that the bytesNeeded is available.
+ *)
+ bytesNeeded: int option,
+ convention: Convention.t,
+ ensuresBytesFree: bool,
+ mayGC: bool,
+ maySwitchThreads: bool,
+ modifiesFrontier: bool,
+ modifiesStackTop: bool,
+ name: string,
+ return: 'a}
- val allocTooLarge: t
- val args: t -> RepType.t vector
- val bug: t
- val bytesNeeded: t -> int option
- val ensuresBytesFree: t -> bool
- val equals: t * t -> bool
- val gc: {maySwitchThreads: bool} -> t
- val isOk: t -> bool
- val layout: t -> Layout.t
- val mayGC: t -> bool
- val maySwitchThreads: t -> bool
- val modifiesFrontier: t -> bool
- val modifiesStackTop: t -> bool
- val name: t -> string
- val profileEnter: t
- val profileInc: t
- val profileLeave: t
- val prototype: t -> string
- val return: t -> RepType.t
- (* returnToC is not really a C function. Calls to it must be handled
- * specially by each codegen to ensure that the C stack is handled
- * correctly. However, for the purposes of everything up to the
- * backend it looks like a call to C.
- *)
- val returnToC: t
- val vanilla: {args: RepType.t vector,
+ val args: 'a t -> 'a vector
+ val bytesNeeded: 'a t -> int option
+ val ensuresBytesFree: 'a t -> bool
+ val equals: 'a t * 'a t -> bool
+ val isOk: 'a t * {isUnit: 'a -> bool} -> bool
+ val layout: 'a t * ('a -> Layout.t) -> Layout.t
+ val map: 'a t * ('a -> 'b) -> 'b t
+ val mayGC: 'a t -> bool
+ val maySwitchThreads: 'a t -> bool
+ val modifiesFrontier: 'a t -> bool
+ val modifiesStackTop: 'a t -> bool
+ val name: 'a t -> string
+ val return: 'a t -> 'a
+ val vanilla: {args: 'a vector,
name: string,
- return: RepType.t} -> t
+ return: 'a} -> 'a t
end
1.5 +10 -0 mlton/mlton/atoms/c-type.fun
Index: c-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-type.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- c-type.fun 4 Apr 2004 06:50:14 -0000 1.4
+++ c-type.fun 12 Apr 2004 17:52:48 -0000 1.5
@@ -14,6 +14,16 @@
val all = [Pointer, Real32, Real64, Word8, Word16, Word32, Word64]
+val bool = Word32
+
+val char = Word8
+
+val pointer = Pointer
+
+val preThread = Pointer
+
+val thread = Pointer
+
val equals: t * t -> bool = op =
fun memo (f: t -> 'a): t -> 'a =
1.5 +12 -0 mlton/mlton/atoms/c-type.sig
Index: c-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-type.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- c-type.sig 4 Apr 2004 06:50:14 -0000 1.4
+++ c-type.sig 12 Apr 2004 17:52:48 -0000 1.5
@@ -1,3 +1,10 @@
+(* Copyright (C) 2004 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under the GNU General Public License (GPL).
+ * Please see the file MLton-LICENSE for license information.
+ *)
+
type int = Int.t
signature C_TYPE_STRUCTS =
@@ -19,11 +26,16 @@
val align: t * Bytes.t -> Bytes.t
val all: t list
+ val bool: t
+ val char: t
val equals: t * t -> bool
val memo: (t -> 'a) -> t -> 'a
(* name: R{32,64} W{8,16,32,64} *)
val name: t -> string
val layout: t -> Layout.t
+ val pointer: t
+ val preThread: t
val size: t -> Bytes.t
+ val thread: t
val toString: t -> string
end
1.6 +0 -1 mlton/mlton/atoms/ffi.sig
Index: ffi.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/ffi.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- ffi.sig 4 Apr 2004 06:50:14 -0000 1.5
+++ ffi.sig 12 Apr 2004 17:52:48 -0000 1.6
@@ -11,7 +11,6 @@
sig
structure CFunction: C_FUNCTION
structure CType: C_TYPE
- sharing CType = CFunction.RepType.CType
end
signature FFI =
1.12 +186 -125 mlton/mlton/atoms/hash-type.fun
Index: hash-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/hash-type.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- hash-type.fun 4 Apr 2004 06:50:14 -0000 1.11
+++ hash-type.fun 12 Apr 2004 17:52:48 -0000 1.12
@@ -205,136 +205,197 @@
con = fn (tycon', bs) => (Tycon.equals (tycon, tycon')
orelse Vector.exists (bs, fn b => b))}
-structure P = PointerTycon
-
-fun fromRepType (t: RepType.t): t =
+fun checkPrimApp {args, prim, result, targs}: bool =
let
- fun bug () = Error.bug (concat ["Type.fromRepType: ", RepType.toString t])
- datatype z = datatype RepType.dest
- in
- case RepType.dest t of
- Int s => int s
- | Real s => real s
- | Pointer p =>
- (case List.peek ([(P.thread, thread),
- (P.word8Vector, word8Vector)],
- fn (p', _) => P.equals (p, p')) of
- NONE => bug ()
- | SOME (_, t) => t)
- | Seq ts => if 0 = Vector.length ts then unit else bug ()
- | Sum _ => if RepType.isBool t then bool else bug ()
- | Word s => word (WordSize.fromBits s)
- | _ => bug ()
- end
-
-val fromRepType =
- Trace.trace ("Type.fromRepType", RepType.layout, layout) fromRepType
-
-local
- val {get, set, ...} =
- Property.getSetOnce (Tycon.plist, Property.initConst NONE)
- val () =
- List.foreach ([Tycon.array, Tycon.reff, Tycon.vector], fn t =>
- set (t, SOME (RepType.cPointer ())))
- fun doit (ts, f) = Vector.foreach (ts, fn (c, s) => set (c, SOME (f s)))
- val () = doit (Tycon.ints, RepType.int)
- val () = doit (Tycon.reals, RepType.real)
- val () = set (Tycon.thread, SOME RepType.thread)
- val () = doit (Tycon.words, RepType.word o WordSize.bits)
-in
- fun toRepType (t: t): RepType.t =
- let
- fun bug () = Error.bug (concat ["Type.toRepType: ", toString t])
+ datatype z = datatype Prim.Name.t
+ fun done (args', result') =
+ Vector.equals (args, Vector.fromList args', equals)
+ andalso equals (result, result')
+ fun targ i = Vector.sub (targs, i)
+ fun oneTarg f =
+ 1 = Vector.length targs
+ andalso done (f (targ 0))
+ local
+ fun make f s = let val t = f s in done ([t], t) end
in
- case dest t of
- Con (c, _) =>
- (case get c of
- NONE => bug ()
- | SOME t => t)
- | Var _ => bug ()
+ val intUnary = make int
+ val realUnary = make real
+ val wordUnary = make word
end
-end
-
-fun checkPrimApp {args, prim, result}: bool =
- let
- fun check () =
- case Prim.typeCheck (prim, Vector.map (args, toRepType)) of
- NONE => false
- | SOME t => equals (result, fromRepType t)
- datatype z = datatype Prim.Name.t
+ local
+ fun make f s = let val t = f s in done ([t, t], t) end
+ in
+ val intBinary = make int
+ val realBinary = make real
+ val wordBinary = make word
+ end
+ local
+ fun make f s = let val t = f s in done ([t, t], bool) end
+ in
+ val intCompare = make int
+ val realCompare = make real
+ val wordCompare = make word
+ end
+ fun intInfBinary () = done ([intInf, intInf, defaultWord], intInf)
+ fun intInfShift () = done ([intInf, defaultWord, defaultWord], intInf)
+ fun intInfUnary () = done ([intInf, defaultWord], intInf)
+ fun real3 s = done ([real s, real s, real s], real s)
+ val pointer = defaultWord
+ val word8Array = array word8
+ val wordVector = vector defaultWord
+ fun wordShift s = done ([word s, defaultWord], word s)
in
case Prim.name prim of
- Array_array => true
- | Array_array0Const => true
- | Array_length => true
- | Array_sub => true
- | Array_toVector => true
- | Array_update => true
- | Exn_extra => true
- | Exn_name => true
- | Exn_setExtendExtra => true
- | Exn_setInitExtra => true
- | Exn_setTopLevelHandler => true
- | GC_collect => true
- | GC_pack => true
- | GC_unpack => true
- | IntInf_add => true
- | IntInf_andb => true
- | IntInf_arshift => true
- | IntInf_compare => true
- | IntInf_equal => true
- | IntInf_gcd => true
- | IntInf_lshift => true
- | IntInf_mul => true
- | IntInf_neg => true
- | IntInf_notb => true
- | IntInf_orb => true
- | IntInf_quot => true
- | IntInf_rem => true
- | IntInf_sub => true
- | IntInf_toString => true
- | IntInf_toVector => true
- | IntInf_toWord => true
- | IntInf_xorb => true
- | MLton_bogus => true
- | MLton_bug => true
- | MLton_eq => true
- | MLton_equal => true
- | MLton_halt => true
- | MLton_handlesSignals => true
- | MLton_installSignalHandler => true
- | MLton_size => true
- | MLton_touch => true
- | Pointer_getInt _ => true
- | Pointer_getPointer => true
- | Pointer_getReal _ => true
- | Pointer_getWord _ => true
- | Pointer_setInt _ => true
- | Pointer_setPointer => true
- | Pointer_setReal _ => true
- | Pointer_setWord _ => true
- | Ref_assign => true
- | Ref_deref => true
- | Ref_ref => true
- | Thread_atomicBegin => true
- | Thread_atomicEnd => true
- | Thread_canHandle => true
- | Thread_copy => true
- | Thread_copyCurrent => true
- | Thread_returnToC => true
- | Thread_switchTo => true
- | Vector_length => true
- | Vector_sub => true
- | Weak_canGet => true
- | Weak_get => true
- | Weak_new => true
- | Word_toIntInf => true
- | WordVector_toIntInf => true
- | Word8Array_subWord => true
- | Word8Array_updateWord => true
- | Word8Vector_subWord => true
- | World_save => true
- | _ => check ()
+ Array_array => oneTarg (fn targ => ([defaultInt], array targ))
+ | Array_array0Const => oneTarg (fn targ => ([], array targ))
+ | Array_length => oneTarg (fn t => ([array t], defaultInt))
+ | Array_sub => oneTarg (fn t => ([array t, defaultInt], t))
+ | Array_toVector => oneTarg (fn t => ([array t], vector t))
+ | Array_update => oneTarg (fn t => ([array t, defaultInt, t], unit))
+ | Exn_extra => oneTarg (fn t => ([exn], t))
+ | Exn_name => done ([exn], string)
+ | Exn_setExtendExtra =>
+ oneTarg (fn t => ([arrow (tuple (Vector.new2 (string, t)), t)],
+ unit))
+ | Exn_setInitExtra => oneTarg (fn t => ([t], unit))
+ | Exn_setTopLevelHandler => done ([arrow (exn, unit)], unit)
+ | FFI f => done (Vector.toList (CFunction.args f), CFunction.return f)
+ | FFI_Symbol {ty, ...} => done ([], ty)
+ | GC_collect => done ([], unit)
+ | GC_pack => done ([], unit)
+ | GC_unpack => done ([], unit)
+ | IntInf_add => intInfBinary ()
+ | IntInf_andb => intInfBinary ()
+ | IntInf_arshift => intInfShift ()
+ | IntInf_compare => done ([intInf, intInf], defaultInt)
+ | IntInf_equal => done ([intInf, intInf], bool)
+ | IntInf_gcd => intInfBinary ()
+ | IntInf_lshift => intInfShift ()
+ | IntInf_mul => intInfBinary ()
+ | IntInf_neg => intInfUnary ()
+ | IntInf_notb => intInfUnary ()
+ | IntInf_orb => intInfBinary ()
+ | IntInf_quot => intInfBinary ()
+ | IntInf_rem => intInfBinary ()
+ | IntInf_sub => intInfBinary ()
+ | IntInf_toString => done ([intInf, defaultInt, defaultWord], string)
+ | IntInf_toVector => done ([intInf], vector defaultWord)
+ | IntInf_toWord => done ([intInf], defaultWord)
+ | IntInf_xorb => intInfBinary ()
+ | Int_add s => intBinary s
+ | Int_addCheck s => intBinary s
+ | Int_equal s => intCompare s
+ | Int_ge s => intCompare s
+ | Int_gt s => intCompare s
+ | Int_le s => intCompare s
+ | Int_lt s => intCompare s
+ | Int_mul s => intBinary s
+ | Int_mulCheck s => intBinary s
+ | Int_neg s => intUnary s
+ | Int_negCheck s => intUnary s
+ | Int_quot s => intBinary s
+ | Int_rem s => intBinary s
+ | Int_sub s => intBinary s
+ | Int_subCheck s => intBinary s
+ | Int_toInt (s, s') => done ([int s], int s')
+ | Int_toReal (s, s') => done ([int s], real s')
+ | Int_toWord (s, s') => done ([int s], word s')
+ | MLton_bogus => oneTarg (fn t => ([], t))
+ | MLton_bug => done ([string], unit)
+ | MLton_eq => oneTarg (fn t => ([t, t], bool))
+ | MLton_equal => oneTarg (fn t => ([t, t], bool))
+ | MLton_halt => done ([defaultInt], unit)
+ | MLton_handlesSignals => done ([], bool)
+ | MLton_installSignalHandler => done ([], unit)
+ | MLton_size => oneTarg (fn t => ([reff t], defaultInt))
+ | MLton_touch => oneTarg (fn t => ([t], unit))
+ | Pointer_getInt s => done ([pointer, defaultInt], int s)
+ | Pointer_getPointer => oneTarg (fn t => ([pointer, defaultInt], t))
+ | Pointer_getReal s => done ([pointer, defaultInt], real s)
+ | Pointer_getWord s => done ([pointer, defaultInt], word s)
+ | Pointer_setInt s => done ([pointer, defaultInt, int s], unit)
+ | Pointer_setPointer => oneTarg (fn t => ([pointer, defaultInt, t], unit))
+ | Pointer_setReal s => done ([pointer, defaultInt, real s], unit)
+ | Pointer_setWord s => done ([pointer, defaultInt, word s], unit)
+ | Real_Math_acos s => realUnary s
+ | Real_Math_asin s => realUnary s
+ | Real_Math_atan s => realUnary s
+ | Real_Math_atan2 s => realBinary s
+ | Real_Math_cos s => realUnary s
+ | Real_Math_exp s => realUnary s
+ | Real_Math_ln s => realUnary s
+ | Real_Math_log10 s => realUnary s
+ | Real_Math_sin s => realUnary s
+ | Real_Math_sqrt s => realUnary s
+ | Real_Math_tan s => realUnary s
+ | Real_abs s => realUnary s
+ | Real_add s => realBinary s
+ | Real_div s => realBinary s
+ | Real_equal s => realCompare s
+ | Real_ge s => realCompare s
+ | Real_gt s => realCompare s
+ | Real_ldexp s => done ([real s, defaultInt], real s)
+ | Real_le s => realCompare s
+ | Real_lt s => realCompare s
+ | Real_mul s => realBinary s
+ | Real_muladd s => real3 s
+ | Real_mulsub s => real3 s
+ | Real_neg s => realUnary s
+ | Real_qequal s => realCompare s
+ | Real_round s => realUnary s
+ | Real_sub s => realBinary s
+ | Real_toInt (s, s') => done ([real s], int s')
+ | Real_toReal (s, s') => done ([real s], real s')
+ | Ref_assign => oneTarg (fn t => ([reff t, t], unit))
+ | Ref_deref => oneTarg (fn t => ([reff t], t))
+ | Ref_ref => oneTarg (fn t => ([t], reff t))
+ | Thread_atomicBegin => done ([], unit)
+ | Thread_atomicEnd => done ([], unit)
+ | Thread_canHandle => done ([], defaultInt)
+ | Thread_copy => done ([thread], thread)
+ | Thread_copyCurrent => done ([], unit)
+ | Thread_returnToC => done ([], unit)
+ | Thread_switchTo => done ([thread], unit)
+ | Vector_length => oneTarg (fn t => ([vector t], defaultInt))
+ | Vector_sub => oneTarg (fn t => ([vector t, defaultInt], t))
+ | Weak_canGet => oneTarg (fn t => ([weak t], bool))
+ | Weak_get => oneTarg (fn t => ([weak t], t))
+ | Weak_new => oneTarg (fn t => ([t], weak t))
+ | Word8Array_subWord => done ([word8Array, defaultInt], defaultWord)
+ | Word8Array_updateWord =>
+ done ([word8Array, defaultInt, defaultWord], unit)
+ | Word8Vector_subWord => done ([word8Vector, defaultInt], defaultWord)
+ | WordVector_toIntInf => done ([wordVector], intInf)
+ | Word_add s => wordBinary s
+ | Word_addCheck s => wordBinary s
+ | Word_andb s => wordBinary s
+ | Word_arshift s => wordShift s
+ | Word_div s => wordBinary s
+ | Word_equal s => wordCompare s
+ | Word_ge s => wordCompare s
+ | Word_gt s => wordCompare s
+ | Word_le s => wordCompare s
+ | Word_lshift s => wordShift s
+ | Word_lt s => wordCompare s
+ | Word_mod s => wordBinary s
+ | Word_mul s => wordBinary s
+ | Word_mulCheck s => wordBinary s
+ | Word_neg s => wordUnary s
+ | Word_notb s => wordUnary s
+ | Word_orb s => wordBinary s
+ | Word_rol s => wordShift s
+ | Word_ror s => wordShift s
+ | Word_rshift s => wordShift s
+ | Word_sub s => wordBinary s
+ | Word_toInt (s, s') => done ([word s], int s')
+ | Word_toIntInf => done ([defaultWord], intInf)
+ | Word_toIntX (s, s') => done ([word s], int s')
+ | Word_toWord (s, s') => done ([word s], word s')
+ | Word_toWordX (s, s') => done ([word s], word s')
+ | Word_xorb s => wordBinary s
+ | World_save => done ([defaultWord], unit)
+ | _ => Error.bug (concat ["Type.checkPrimApp got strange prim: ",
+ Prim.toString prim])
end
end
1.7 +3 -2 mlton/mlton/atoms/hash-type.sig
Index: hash-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/hash-type.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- hash-type.sig 4 Apr 2004 06:50:14 -0000 1.6
+++ hash-type.sig 12 Apr 2004 17:52:48 -0000 1.7
@@ -28,8 +28,9 @@
end
val checkPrimApp: {args: t vector,
- prim: Prim.t,
- result: t} -> bool
+ prim: t Prim.t,
+ result: t,
+ targs: t vector} -> bool
val containsTycon: t * Tycon.t -> bool
(* O(1) time *)
val equals: t * t -> bool
1.76 +213 -220 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.75
retrieving revision 1.76
diff -u -r1.75 -r1.76
--- prim.fun 4 Apr 2004 06:50:14 -0000 1.75
+++ prim.fun 12 Apr 2004 17:52:48 -0000 1.76
@@ -33,7 +33,7 @@
| SideEffect
end
-datatype t =
+datatype 'a t =
Array_array (* backend *)
| Array_array0Const (* constant propagation *)
| Array_length (* ssa to rssa *)
@@ -47,9 +47,9 @@
| Exn_setExtendExtra (* implement exceptions *)
| Exn_setInitExtra (* implement exceptions *)
| Exn_setTopLevelHandler (* implement exceptions *)
- | FFI of CFunction.t (* ssa to rssa *)
+ | FFI of 'a CFunction.t (* ssa to rssa *)
| FFI_Symbol of {name: string,
- ty: RepType.t} (* codegen *)
+ ty: 'a} (* codegen *)
| GC_collect (* ssa to rssa *)
| GC_pack (* ssa to rssa *)
| GC_unpack (* ssa to rssa *)
@@ -115,14 +115,14 @@
| MLton_serialize (* unused *)
| MLton_size (* ssa to rssa *)
| MLton_touch (* backend *)
- | Pointer_getInt of IntSize.t (* backend *)
- | Pointer_getPointer (* backend *)
- | Pointer_getReal of RealSize.t (* backend *)
- | Pointer_getWord of WordSize.t (* backend *)
- | Pointer_setInt of IntSize.t (* backend *)
- | Pointer_setPointer (* backend *)
- | Pointer_setReal of RealSize.t (* backend *)
- | Pointer_setWord of WordSize.t (* backend *)
+ | Pointer_getInt of IntSize.t (* ssa to rssa *)
+ | Pointer_getPointer (* ssa to rssa *)
+ | Pointer_getReal of RealSize.t (* ssa to rssa *)
+ | Pointer_getWord of WordSize.t (* ssa to rssa *)
+ | Pointer_setInt of IntSize.t (* ssa to rssa *)
+ | Pointer_setPointer (* ssa to rssa *)
+ | Pointer_setReal of RealSize.t (* ssa to rssa *)
+ | Pointer_setWord of WordSize.t (* ssa to rssa *)
| Real_Math_acos of RealSize.t (* codegen *)
| Real_Math_asin of RealSize.t (* codegen *)
| Real_Math_atan of RealSize.t (* codegen *)
@@ -168,7 +168,7 @@
*)
| Thread_switchTo (* ssa to rssa *)
| Vector_length (* ssa to rssa *)
- | Vector_sub (* backend *)
+ | Vector_sub (* ssa to rssa *)
| Weak_canGet (* ssa to rssa *)
| Weak_get (* ssa to rssa *)
| Weak_new (* ssa to rssa *)
@@ -208,11 +208,11 @@
| World_save (* ssa to rssa *)
fun name p = p
-
+
(* The values of these strings are important since they are referred to
* in the basis library code. See basis-library/misc/primitive.sml.
*)
-fun toString (n: t): string =
+fun toString (n: 'a t): string =
let
fun int (s: IntSize.t, str: string): string =
concat ["Int", IntSize.toString s, "_", str]
@@ -389,9 +389,9 @@
| World_save => "World_save"
end
-val layout = Layout.str o toString
+fun layout p = Layout.str (toString p)
-val equals: t * t -> bool =
+val equals: 'a t * 'a t -> bool =
fn (Array_array, Array_array) => true
| (Array_array0Const, Array_array0Const) => true
| (Array_length, Array_length) => true
@@ -555,7 +555,164 @@
| (World_save, World_save) => true
| _ => false
-val allocTooLarge = FFI CFunction.allocTooLarge
+val map: 'a t * ('a -> 'b) -> 'b t =
+ fn (p, f) =>
+ case p of
+ Array_array => Array_array
+ | Array_array0Const => Array_array0Const
+ | Array_length => Array_length
+ | Array_sub => Array_sub
+ | Array_toVector => Array_toVector
+ | Array_update => Array_update
+ | Char_toWord8 => Char_toWord8
+ | Exn_extra => Exn_extra
+ | Exn_keepHistory => Exn_keepHistory
+ | Exn_name => Exn_name
+ | Exn_setExtendExtra => Exn_setExtendExtra
+ | Exn_setInitExtra => Exn_setInitExtra
+ | Exn_setTopLevelHandler => Exn_setTopLevelHandler
+ | FFI func => FFI (CFunction.map (func, f))
+ | FFI_Symbol {name, ty} => FFI_Symbol {name = name, ty = f ty}
+ | GC_collect => GC_collect
+ | GC_pack => GC_pack
+ | GC_unpack => GC_unpack
+ | Int_add z => Int_add z
+ | Int_addCheck z => Int_addCheck z
+ | Int_equal z => Int_equal z
+ | Int_ge z => Int_ge z
+ | Int_gt z => Int_gt z
+ | Int_le z => Int_le z
+ | Int_lt z => Int_lt z
+ | Int_mul z => Int_mul z
+ | Int_mulCheck z => Int_mulCheck z
+ | Int_neg z => Int_neg z
+ | Int_negCheck z => Int_negCheck z
+ | Int_quot z => Int_quot z
+ | Int_rem z => Int_rem z
+ | Int_sub z => Int_sub z
+ | Int_subCheck z => Int_subCheck z
+ | Int_toInt z => Int_toInt z
+ | Int_toReal z => Int_toReal z
+ | Int_toWord z => Int_toWord z
+ | IntInf_add => IntInf_add
+ | IntInf_andb => IntInf_andb
+ | IntInf_arshift => IntInf_arshift
+ | IntInf_compare => IntInf_compare
+ | IntInf_equal => IntInf_equal
+ | IntInf_gcd => IntInf_gcd
+ | IntInf_lshift => IntInf_lshift
+ | IntInf_mul => IntInf_mul
+ | IntInf_neg => IntInf_neg
+ | IntInf_notb => IntInf_notb
+ | IntInf_orb => IntInf_orb
+ | IntInf_quot => IntInf_quot
+ | IntInf_rem => IntInf_rem
+ | IntInf_sub => IntInf_sub
+ | IntInf_toString => IntInf_toString
+ | IntInf_toVector => IntInf_toVector
+ | IntInf_toWord => IntInf_toWord
+ | IntInf_xorb => IntInf_xorb
+ | MLton_bogus => MLton_bogus
+ | MLton_bug => MLton_bug
+ | MLton_deserialize => MLton_deserialize
+ | MLton_eq => MLton_eq
+ | MLton_equal => MLton_equal
+ | MLton_halt => MLton_halt
+ | MLton_handlesSignals => MLton_handlesSignals
+ | MLton_installSignalHandler => MLton_installSignalHandler
+ | MLton_serialize => MLton_serialize
+ | MLton_size => MLton_size
+ | MLton_touch => MLton_touch
+ | Pointer_getInt z => Pointer_getInt z
+ | Pointer_getPointer => Pointer_getPointer
+ | Pointer_getReal z => Pointer_getReal z
+ | Pointer_getWord z => Pointer_getWord z
+ | Pointer_setInt z => Pointer_setInt z
+ | Pointer_setPointer => Pointer_setPointer
+ | Pointer_setReal z => Pointer_setReal z
+ | Pointer_setWord z => Pointer_setWord z
+ | Real_Math_acos z => Real_Math_acos z
+ | Real_Math_asin z => Real_Math_asin z
+ | Real_Math_atan z => Real_Math_atan z
+ | Real_Math_atan2 z => Real_Math_atan2 z
+ | Real_Math_cos z => Real_Math_cos z
+ | Real_Math_exp z => Real_Math_exp z
+ | Real_Math_ln z => Real_Math_ln z
+ | Real_Math_log10 z => Real_Math_log10 z
+ | Real_Math_sin z => Real_Math_sin z
+ | Real_Math_sqrt z => Real_Math_sqrt z
+ | Real_Math_tan z => Real_Math_tan z
+ | Real_abs z => Real_abs z
+ | Real_add z => Real_add z
+ | Real_div z => Real_div z
+ | Real_equal z => Real_equal z
+ | Real_ge z => Real_ge z
+ | Real_gt z => Real_gt z
+ | Real_ldexp z => Real_ldexp z
+ | Real_le z => Real_le z
+ | Real_lt z => Real_lt z
+ | Real_mul z => Real_mul z
+ | Real_muladd z => Real_muladd z
+ | Real_mulsub z => Real_mulsub z
+ | Real_neg z => Real_neg z
+ | Real_qequal z => Real_qequal z
+ | Real_round z => Real_round z
+ | Real_sub z => Real_sub z
+ | Real_toInt z => Real_toInt z
+ | Real_toReal z => Real_toReal z
+ | Ref_assign => Ref_assign
+ | Ref_deref => Ref_deref
+ | Ref_ref => Ref_ref
+ | String_toWord8Vector => String_toWord8Vector
+ | Thread_atomicBegin => Thread_atomicBegin
+ | Thread_atomicEnd => Thread_atomicEnd
+ | Thread_canHandle => Thread_canHandle
+ | Thread_copy => Thread_copy
+ | Thread_copyCurrent => Thread_copyCurrent
+ | Thread_returnToC => Thread_returnToC
+ | Thread_switchTo => Thread_switchTo
+ | Vector_length => Vector_length
+ | Vector_sub => Vector_sub
+ | Weak_canGet => Weak_canGet
+ | Weak_get => Weak_get
+ | Weak_new => Weak_new
+ | Word_add z => Word_add z
+ | Word_addCheck z => Word_addCheck z
+ | Word_andb z => Word_andb z
+ | Word_arshift z => Word_arshift z
+ | Word_div z => Word_div z
+ | Word_equal z => Word_equal z
+ | Word_ge z => Word_ge z
+ | Word_gt z => Word_gt z
+ | Word_le z => Word_le z
+ | Word_lshift z => Word_lshift z
+ | Word_lt z => Word_lt z
+ | Word_mod z => Word_mod z
+ | Word_mul z => Word_mul z
+ | Word_mulCheck z => Word_mulCheck z
+ | Word_neg z => Word_neg z
+ | Word_notb z => Word_notb z
+ | Word_orb z => Word_orb z
+ | Word_rol z => Word_rol z
+ | Word_ror z => Word_ror z
+ | Word_rshift z => Word_rshift z
+ | Word_sub z => Word_sub z
+ | Word_toInt z => Word_toInt z
+ | Word_toIntInf => Word_toIntInf
+ | Word_toIntX z => Word_toIntX z
+ | Word_toWord z => Word_toWord z
+ | Word_toWordX z => Word_toWordX z
+ | Word_xorb z => Word_xorb z
+ | WordVector_toIntInf => WordVector_toIntInf
+ | Word8_toChar => Word8_toChar
+ | Word8Array_subWord => Word8Array_subWord
+ | Word8Array_updateWord => Word8Array_updateWord
+ | Word8Vector_subWord => Word8Vector_subWord
+ | Word8Vector_toString => Word8Vector_toString
+ | World_save => World_save
+
+val cast: 'a t -> 'b t = fn p => map (p, fn _ => Error.bug "Prim.cast")
+
val array = Array_array
val assign = Ref_assign
val bogus = MLton_bogus
@@ -637,11 +794,13 @@
val mayRaise = mayOverflow
-val kind: t -> Kind.t =
+val kind: 'a t -> Kind.t =
+ fn p =>
let
datatype z = datatype Kind.t
in
- fn Array_array => Moveable
+ case p of
+ Array_array => Moveable
| Array_array0Const => Moveable
| Array_length => Functional
| Array_sub => DependsOnState
@@ -798,10 +957,8 @@
local
fun make k p = k = kind p
in
- val isFunctional = make Kind.Functional
- val isFunctional =
- Trace.trace ("isFunctional", layout, Bool.layout) isFunctional
- val maySideEffect = make Kind.SideEffect
+ fun isFunctional p = Kind.Functional = kind p
+ fun maySideEffect p = Kind.SideEffect = kind p
end
local
@@ -875,7 +1032,7 @@
(Word_sub s),
(Word_xorb s)]
in
- val all: t list =
+ val all: unit t list =
[Array_array,
Array_array0Const,
Array_length,
@@ -921,6 +1078,8 @@
MLton_serialize,
MLton_size,
MLton_touch,
+ Pointer_getPointer,
+ Pointer_setPointer,
Ref_assign,
Ref_deref,
Ref_ref,
@@ -972,7 +1131,6 @@
List.concatMap (all, fn s => [get s, set s])
in
List.concat [doit (IntSize.prims, Pointer_getInt, Pointer_setInt),
- [Pointer_getPointer, Pointer_setPointer],
doit (RealSize.all, Pointer_getReal, Pointer_setReal),
doit (WordSize.prims, Pointer_getWord, Pointer_setWord)]
end
@@ -980,7 +1138,7 @@
local
val table: {hash: word,
- prim: t,
+ prim: unit t,
string: string} HashSet.t =
HashSet.new {hash = #hash}
val () =
@@ -998,25 +1156,23 @@
()
end)
in
- val fromString: string -> t =
+ val fromString: string -> 'a t =
fn name =>
- #prim
- (HashSet.lookupOrInsert
- (table, String.hash name,
- fn {string, ...} => name = string,
- fn () => Error.bug (concat ["unknown primitive: ", name])))
+ cast
+ (#prim
+ (HashSet.lookupOrInsert
+ (table, String.hash name,
+ fn {string, ...} => name = string,
+ fn () => Error.bug (concat ["unknown primitive: ", name]))))
end
-val fromString =
- Trace.trace ("Prim.fromString", String.layout, layout) fromString
-
fun 'a extractTargs {args: 'a vector,
deArray: 'a -> 'a,
deArrow: 'a -> 'a * 'a,
deRef: 'a -> 'a,
deVector: 'a -> 'a,
deWeak: 'a -> 'a,
- prim: t,
+ prim: 'a t,
result: 'a} =
let
val one = Vector.new1
@@ -1076,22 +1232,27 @@
structure ApplyResult =
struct
- type prim = t
- datatype 'a t =
- Apply of prim * 'a list
+ type 'a prim = 'a t
+
+ datatype ('a, 'b) t =
+ Apply of 'a prim * 'b list
| Bool of bool
| Const of Const.t
| Overflow
| Unknown
- | Var of 'a
+ | Var of 'b
val truee = Bool true
val falsee = Bool false
val layoutPrim = layout
- fun layout layoutX =
- let open Layout
- in fn Apply (p, args) => seq [layoutPrim p, List.layout layoutX args]
+
+ fun layout layoutX ar =
+ let
+ open Layout
+ in
+ case ar of
+ Apply (p, args) => seq [layoutPrim p, List.layout layoutX args]
| Bool b => Bool.layout b
| Const c => Const.layout c
| Overflow => str "Overflow"
@@ -1127,7 +1288,9 @@
* A x = B y --> false
*)
-fun 'a apply (p, args, varEquals) =
+fun ('a, 'b) apply (p: 'a t,
+ args: 'b ApplyArg.t list,
+ varEquals: 'b * 'b -> bool): ('a, 'b) ApplyResult.t =
let
datatype z = datatype t
datatype z = datatype Const.t
@@ -1135,7 +1298,7 @@
val int = ApplyResult.Const o Const.int
val intInf = ApplyResult.Const o Const.intInf
val intInfConst = intInf o IntInf.fromInt
- fun word (w: WordX.t): 'a ApplyResult.t =
+ fun word (w: WordX.t): ('a, 'b) ApplyResult.t =
ApplyResult.Const (Const.word w)
val word8Vector = ApplyResult.Const o Const.word8Vector
val t = ApplyResult.truee
@@ -1238,9 +1401,9 @@
fun someVars () =
let
datatype z = datatype ApplyResult.t
- fun add (x: 'a, i: IntX.t): 'a ApplyResult.t =
+ fun add (x: 'b, i: IntX.t): ('a, 'b) ApplyResult.t =
if IntX.isZero i then Var x else Unknown
- fun mul (x: 'a, i: IntX.t, s: IntSize.t, neg) =
+ fun mul (x: 'b, i: IntX.t, s: IntSize.t, neg) =
(case IntX.toInt i of
0 => int (IntX.zero s)
| 1 => Var x
@@ -1587,7 +1750,9 @@
else someVars ()
end
-fun layoutApp (p: t, args: 'a vector, layoutArg: 'a -> Layout.t): Layout.t =
+fun ('a, 'b) layoutApp (p: 'a t,
+ args: 'b vector,
+ layoutArg: 'b -> Layout.t): Layout.t =
let
fun arg i = layoutArg (Vector.sub (args, i))
open Layout
@@ -1657,178 +1822,6 @@
| Word_xorb _ => two "^"
| _ => seq [layout p, str " ", Vector.layout layoutArg args]
end
-
-structure Type = RepType
-
-fun typeCheck (p: t, ts: Type.t vector): Type.t option =
- let
- fun nullary res =
- if 0 = Vector.length ts
- then res
- else NONE
- fun unary (t0, res) =
- if 1 = Vector.length ts
- andalso Type.isSubtype (Vector.sub (ts, 0), t0)
- then SOME res
- else NONE
- fun two f =
- if 2 = Vector.length ts
- then f (Vector.sub (ts, 0), Vector.sub (ts, 1))
- else NONE
- fun twoWord f =
- two (fn (t, t') =>
- if Bits.equals (Type.width t, Type.width t')
- then SOME (f (t, t'))
- else NONE)
- fun binary (t0, t1, res) =
- two (fn (t0', t1') =>
- if Type.isSubtype (Vector.sub (ts, 0), t0)
- andalso Type.isSubtype (Vector.sub (ts, 1), t1)
- then SOME res
- else NONE)
- fun ternary (t0, t1, t2, res) =
- if 3 = Vector.length ts
- andalso Type.isSubtype (Vector.sub (ts, 0), t0)
- andalso Type.isSubtype (Vector.sub (ts, 1), t1)
- andalso Type.isSubtype (Vector.sub (ts, 2), t2)
- then SOME res
- else NONE
- local
- open Type
- in
- val defaultInt = defaultInt
- val defaultWord = defaultWord
- val int = int
- val real = real
- val word = word o WordSize.bits
- end
- local
- fun make f s = let val t = f s in unary (t, t) end
- in
- val intUnary = make int
- val realUnary = make real
- val wordUnary = make word
- end
- local
- fun make f s = let val t = f s in binary (t, t, t) end
- in
- val intBinary = make int
- val realBinary = make real
- val wordBinary = make word
- end
- local
- fun make f s = let val t = f s in binary (t, t, Type.bool) end
- in
- val intCompare = make int
- val realCompare = make real
- val wordCompare = make word
- end
- fun wordShift s = binary (word s, defaultWord, word s)
- fun wordShift' f = two (fn (t, t') => SOME (f (t, t')))
- fun real3 s =
- let
- val t = real s
- in
- ternary (t, t, t, t)
- end
- in
- case p of
- FFI f =>
- let
- val CFunction.T {args, return, ...} = f
- in
- if Vector.equals (ts, args, Type.isSubtype)
- then SOME return
- else NONE
- end
- | FFI_Symbol {ty, ...} => nullary (SOME ty)
- | Int_add s => intBinary s
- | Int_addCheck s => intBinary s
- | Int_equal s => intCompare s
- | Int_ge s => intCompare s
- | Int_gt s => intCompare s
- | Int_le s => intCompare s
- | Int_lt s => intCompare s
- | Int_mul s => intBinary s
- | Int_mulCheck s => intBinary s
- | Int_neg s => intUnary s
- | Int_negCheck s => intUnary s
- | Int_quot s => intBinary s
- | Int_rem s => intBinary s
- | Int_sub s => intBinary s
- | Int_subCheck s => intBinary s
- | Int_toInt (s, s') => unary (int s, int s')
- | Int_toReal (s, s') => unary (int s, real s')
- | Int_toWord (s, s') => unary (int s, word s')
- | MLton_eq =>
- two (fn (t1, t2) =>
- if Type.isSubtype (t1, t2) orelse Type.isSubtype (t2, t1)
- then SOME Type.bool
- else NONE)
- | Real_Math_acos s => realUnary s
- | Real_Math_asin s => realUnary s
- | Real_Math_atan s => realUnary s
- | Real_Math_atan2 s => realBinary s
- | Real_Math_cos s => realUnary s
- | Real_Math_exp s => realUnary s
- | Real_Math_ln s => realUnary s
- | Real_Math_log10 s => realUnary s
- | Real_Math_sin s => realUnary s
- | Real_Math_sqrt s => realUnary s
- | Real_Math_tan s => realUnary s
- | Real_abs s => realUnary s
- | Real_add s => realBinary s
- | Real_div s => realBinary s
- | Real_equal s => realCompare s
- | Real_ge s => realCompare s
- | Real_gt s => realCompare s
- | Real_ldexp s => binary (real s, defaultInt, real s)
- | Real_le s => realCompare s
- | Real_lt s => realCompare s
- | Real_mul s => realBinary s
- | Real_muladd s => real3 s
- | Real_mulsub s => real3 s
- | Real_neg s => realUnary s
- | Real_qequal s => realCompare s
- | Real_round s => realUnary s
- | Real_sub s => realBinary s
- | Real_toInt (s, s') => unary (real s, int s')
- | Real_toReal (s, s') => unary (real s, real s')
- | Thread_returnToC => nullary (SOME Type.unit)
- | Word_add s => twoWord Type.add
- | Word_addCheck s => wordBinary s
- | Word_andb s => two Type.andb
- | Word_arshift s => wordShift s
- | Word_div s => wordBinary s
- | Word_equal s => wordCompare s
- | Word_ge s => wordCompare s
- | Word_gt s => wordCompare s
- | Word_le s => wordCompare s
- | Word_lshift s => wordShift' Type.lshift
- | Word_lt s => wordCompare s
- | Word_mod s => wordBinary s
- | Word_mul s => twoWord Type.mul
- | Word_mulCheck s => wordBinary s
- | Word_neg s => wordUnary s
- | Word_notb s => wordUnary s
- | Word_orb s => two Type.orb
- | Word_rol s => wordShift s
- | Word_ror s => wordShift s
- | Word_rshift s => wordShift' Type.rshift
- | Word_sub s => wordBinary s
- | Word_toInt (s, s') => unary (word s, int s')
- | Word_toIntX (s, s') => unary (word s, int s')
- | Word_toWord (s, s') => unary (word s, word s')
- | Word_toWordX (s, s') => unary (word s, word s')
- | Word_xorb s => wordBinary s
- | _ => Error.bug (concat ["strange primitive to Prim.typeCheck: ",
- toString p])
- end
-
-val typeCheck =
- Trace.trace2 ("Prim.typeCheck", layout, Vector.layout Type.layout,
- Option.layout Type.layout)
- typeCheck
structure Name =
struct
1.58 +73 -76 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -r1.57 -r1.58
--- prim.sig 4 Apr 2004 06:50:14 -0000 1.57
+++ prim.sig 12 Apr 2004 17:52:48 -0000 1.58
@@ -13,13 +13,10 @@
structure Const: CONST
structure IntSize: INT_SIZE
structure RealSize: REAL_SIZE
- structure RepType: REP_TYPE
structure WordSize: WORD_SIZE
- sharing CType = RepType.CType
- sharing IntSize = Const.IntX.IntSize = RepType.IntSize
- sharing RealSize = Const.RealX.RealSize = RepType.RealSize
- sharing RepType = CFunction.RepType
- sharing WordSize = Const.WordX.WordSize = RepType.WordSize
+ sharing IntSize = Const.IntX.IntSize
+ sharing RealSize = Const.RealX.RealSize
+ sharing WordSize = Const.WordX.WordSize
end
signature PRIM =
@@ -28,7 +25,7 @@
structure Name:
sig
- datatype t =
+ datatype 'a t =
Array_array (* backend *)
| Array_array0Const (* constant propagation *)
| Array_length (* ssa to rssa *)
@@ -42,9 +39,9 @@
| Exn_setExtendExtra (* implement exceptions *)
| Exn_setInitExtra (* implement exceptions *)
| Exn_setTopLevelHandler (* implement exceptions *)
- | FFI of CFunction.t (* ssa to rssa *)
+ | FFI of 'a CFunction.t (* ssa to rssa *)
| FFI_Symbol of {name: string,
- ty: RepType.t} (* codegen *)
+ ty: 'a} (* codegen *)
| GC_collect (* ssa to rssa *)
| GC_pack (* ssa to rssa *)
| GC_unpack (* ssa to rssa *)
@@ -202,12 +199,10 @@
| Word8Vector_toString (* type inference *)
| World_save (* ssa to rssa *)
- val layout: t -> Layout.t
- val toString: t -> string
+ val layout: 'a t -> Layout.t
+ val toString: 'a t -> string
end
- type t
-
structure ApplyArg:
sig
datatype 'a t =
@@ -219,52 +214,54 @@
end
structure ApplyResult:
sig
- type prim
- datatype 'a t =
- Apply of prim * 'a list
+ type 'a prim
+ datatype ('a, 'b) t =
+ Apply of 'a prim * 'b list
| Bool of bool
| Const of Const.t
| Overflow
| Unknown
- | Var of 'a
+ | Var of 'b
- val layout: ('a -> Layout.t) -> 'a t -> Layout.t
- end where type prim = t
-
- val allocTooLarge: t
- val apply: t * 'a ApplyArg.t list * ('a * 'a -> bool) -> 'a ApplyResult.t
- val array: t
- val assign: t
- val bogus: t
- val bug: t
- val deref: t
- val deserialize: t
- val eq: t (* pointer equality *)
- val equal: t (* polymorphic equality *)
- val equals: t * t -> bool
+ val layout: ('b -> Layout.t) -> ('a, 'b) t -> Layout.t
+ end
+
+ type 'a t
+ sharing type t = ApplyResult.prim
+ val apply:
+ 'a t * 'b ApplyArg.t list * ('b * 'b -> bool) -> ('a, 'b) ApplyResult.t
+ val array: 'a t
+ val assign: 'a t
+ val bogus: 'a t
+ val bug: 'a t
+ val deref: 'a t
+ val deserialize: 'a t
+ val eq: 'a t (* pointer equality *)
+ val equal: 'a t (* polymorphic equality *)
+ val equals: 'a t * 'a t -> bool
val extractTargs: {args: 'a vector,
deArray: 'a -> 'a,
deArrow: 'a -> 'a * 'a,
deRef: 'a -> 'a,
deVector: 'a -> 'a,
deWeak: 'a -> 'a,
- prim: t,
+ prim: 'a t,
result: 'a} -> 'a vector
- val ffi: CFunction.t -> t
- val ffiSymbol: {name: string, ty: RepType.t} -> t
- val fromString: string -> t
- val gcCollect: t
- val intInfEqual: t
- val intAdd: IntSize.t -> t
- val intAddCheck: IntSize.t -> t
- val intEqual: IntSize.t -> t
- val intMul: IntSize.t -> t
- val intMulCheck: IntSize.t -> t
- val intSub: IntSize.t -> t
- val intSubCheck: IntSize.t -> t
- val intToInt: IntSize.t * IntSize.t -> t
- val intToWord: IntSize.t * WordSize.t -> t
- val isCommutative: t -> bool
+ val ffi: 'a CFunction.t -> 'a t
+ val ffiSymbol: {name: string, ty: 'a} -> 'a t
+ val fromString: string -> 'a t
+ val gcCollect: 'a t
+ val intInfEqual: 'a t
+ val intAdd: IntSize.t -> 'a t
+ val intAddCheck: IntSize.t -> 'a t
+ val intEqual: IntSize.t -> 'a t
+ val intMul: IntSize.t -> 'a t
+ val intMulCheck: IntSize.t -> 'a t
+ val intSub: IntSize.t -> 'a t
+ val intSubCheck: IntSize.t -> 'a t
+ val intToInt: IntSize.t * IntSize.t -> 'a t
+ val intToWord: IntSize.t * WordSize.t -> 'a t
+ val isCommutative: 'a t -> bool
(*
* isFunctional p = true iff p always returns same result when given
* same args and has no side effects.
@@ -272,37 +269,37 @@
* examples: Array_length, MLton_equal, Int_add
* not examples: Array_array, Array_sub, Ref_deref, Ref_ref
*)
- val isFunctional: t -> bool
- val layout: t -> Layout.t
- val layoutApp: t * 'a vector * ('a -> Layout.t) -> Layout.t
+ val isFunctional: 'a t -> bool
+ val layout: 'a t -> Layout.t
+ val layoutApp: 'a t * 'b vector * ('b -> Layout.t) -> Layout.t
+ val map: 'a t * ('a -> 'b) -> 'b t
(* Int_addCheck, Int_mulCheck, Int_subCheck *)
- val mayOverflow: t -> bool
- val mayRaise: t -> bool
+ val mayOverflow: 'a t -> bool
+ val mayRaise: 'a t -> bool
(* examples: Array_update, Ref_assign
* not examples: Array_array, Array_sub, Ref_deref, Ref_ref
*)
- val maySideEffect: t -> bool
- val name: t -> Name.t
- val reff: t
- val serialize: t
- val toString: t -> string
- val typeCheck: t * RepType.t vector -> RepType.t option
- val vectorLength: t
- val vectorSub: t
- val wordAdd: WordSize.t -> t
- val wordAddCheck: WordSize.t -> t
- val wordAndb: WordSize.t -> t
- val wordEqual: WordSize.t -> t
- val wordGe: WordSize.t -> t
- val wordGt: WordSize.t -> t
- val wordLe: WordSize.t -> t
- val wordLt: WordSize.t -> t
- val wordLshift: WordSize.t -> t
- val wordMul: WordSize.t -> t
- val wordMulCheck: WordSize.t -> t
- val wordRshift: WordSize.t -> t
- val wordSub: WordSize.t -> t
- val wordToInt: WordSize.t * IntSize.t -> t
- val wordToIntX: WordSize.t * IntSize.t -> t
- val wordToWord: WordSize.t * WordSize.t -> t
+ val maySideEffect: 'a t -> bool
+ val name: 'a t -> 'a Name.t
+ val reff: 'a t
+ val serialize: 'a t
+ val toString: 'a t -> string
+ val vectorLength: 'a t
+ val vectorSub: 'a t
+ val wordAdd: WordSize.t -> 'a t
+ val wordAddCheck: WordSize.t -> 'a t
+ val wordAndb: WordSize.t -> 'a t
+ val wordEqual: WordSize.t -> 'a t
+ val wordGe: WordSize.t -> 'a t
+ val wordGt: WordSize.t -> 'a t
+ val wordLe: WordSize.t -> 'a t
+ val wordLt: WordSize.t -> 'a t
+ val wordLshift: WordSize.t -> 'a t
+ val wordMul: WordSize.t -> 'a t
+ val wordMulCheck: WordSize.t -> 'a t
+ val wordRshift: WordSize.t -> 'a t
+ val wordSub: WordSize.t -> 'a t
+ val wordToInt: WordSize.t * IntSize.t -> 'a t
+ val wordToIntX: WordSize.t * IntSize.t -> 'a t
+ val wordToWord: WordSize.t * WordSize.t -> 'a t
end
1.2 +244 -1 mlton/mlton/atoms/rep-type.fun
Index: rep-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/rep-type.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- rep-type.fun 4 Apr 2004 06:50:14 -0000 1.1
+++ rep-type.fun 12 Apr 2004 17:52:48 -0000 1.2
@@ -10,6 +10,8 @@
open S
+structure CFunction = Prim.CFunction
+
type int = Int.t
structure Type =
@@ -761,6 +763,20 @@
(1 + 2 * Int.toIntInf (PointerTycon.index p),
WordSize.default))
+fun arrayOffsetIsOk {base: t, index: t, pointerTy, result: t}: bool =
+ isSubtype (index, defaultInt)
+ andalso
+ case dest base of
+ Pointer p =>
+ (case pointerTy p of
+ ObjectType.Array ty =>
+ isSubtype (ty, result)
+ orelse
+ (* Get a word from a word8 array.*)
+ (equals (result, defaultWord) andalso equals (ty, word8))
+ | _ => false)
+ | _ => isCPointer base
+
fun offset (t: t, {offset, pointerTy, width}): t option =
let
fun frag t =
@@ -776,7 +792,7 @@
(case pointerTy p of
ObjectType.Array _ =>
if Bytes.equals (offset, Runtime.arrayLengthOffset)
- then SOME Type.defaultInt
+ then SOME defaultInt
else NONE
| ObjectType.Normal t => SOME (frag t)
| _ => NONE)
@@ -803,6 +819,13 @@
Option.layout layout)
offset
+fun offsetIsOk {base, offset = off, pointerTy, result} =
+ case offset (base, {offset = off,
+ pointerTy = pointerTy,
+ width = width result}) of
+ NONE => false
+ | SOME t => isSubtype (t, result)
+
structure GCField = Runtime.GCField
fun ofGCField (f: GCField.t): t =
@@ -825,5 +848,225 @@
end
fun castIsOk _ = true
+
+fun checkPrimApp {args: t vector, prim: t Prim.t, result: t option}: bool =
+ let
+ fun done t =
+ case result of
+ NONE => true
+ | SOME t' => isSubtype (t, t')
+ fun nullary res =
+ 0 = Vector.length args
+ andalso done res
+ fun arg i = Vector.sub (args, i)
+ fun unary (t0, res) =
+ 1 = Vector.length args
+ andalso isSubtype (arg 0, t0)
+ andalso done res
+ fun two f = 2 = Vector.length args andalso f (arg 0, arg 1)
+ fun twoOpt f =
+ two (fn z =>
+ case f z of
+ NONE => false
+ | SOME t => done t)
+ fun twoWord f =
+ two (fn (t, t') =>
+ Bits.equals (width t, width t') andalso done (f (t, t')))
+ fun binary (t0, t1, res) =
+ two (fn (t0', t1') =>
+ isSubtype (arg 0, t0)
+ andalso isSubtype (arg 1, t1)
+ andalso done res)
+ fun ternary (t0, t1, t2, res) =
+ 3 = Vector.length args
+ andalso isSubtype (arg 0, t0)
+ andalso isSubtype (arg 1, t1)
+ andalso isSubtype (arg 2, t2)
+ andalso done res
+ local
+ open Type
+ in
+ val defaultInt = defaultInt
+ val defaultWord = defaultWord
+ val int = int
+ val real = real
+ val word = word o WordSize.bits
+ end
+ local
+ fun make f s = let val t = f s in unary (t, t) end
+ in
+ val intUnary = make int
+ val realUnary = make real
+ val wordUnary = make word
+ end
+ local
+ fun make f s = let val t = f s in binary (t, t, t) end
+ in
+ val intBinary = make int
+ val realBinary = make real
+ val wordBinary = make word
+ end
+ local
+ fun make f s = let val t = f s in binary (t, t, bool) end
+ in
+ val intCompare = make int
+ val realCompare = make real
+ val wordCompare = make word
+ end
+ fun wordShift s = binary (word s, defaultWord, word s)
+ fun wordShift' f = two (fn (t, t') => done (f (t, t')))
+ fun real3 s =
+ let
+ val t = real s
+ in
+ ternary (t, t, t, t)
+ end
+ datatype z = datatype Prim.Name.t
+ in
+ case Prim.name prim of
+ FFI f =>
+ let
+ val CFunction.T {args = expects, return, ...} = f
+ in
+ Vector.equals (args, expects, isSubtype) andalso done return
+ end
+ | FFI_Symbol {ty, ...} => nullary ty
+ | Int_add s => intBinary s
+ | Int_addCheck s => intBinary s
+ | Int_equal s => intCompare s
+ | Int_ge s => intCompare s
+ | Int_gt s => intCompare s
+ | Int_le s => intCompare s
+ | Int_lt s => intCompare s
+ | Int_mul s => intBinary s
+ | Int_mulCheck s => intBinary s
+ | Int_neg s => intUnary s
+ | Int_negCheck s => intUnary s
+ | Int_quot s => intBinary s
+ | Int_rem s => intBinary s
+ | Int_sub s => intBinary s
+ | Int_subCheck s => intBinary s
+ | Int_toInt (s, s') => unary (int s, int s')
+ | Int_toReal (s, s') => unary (int s, real s')
+ | Int_toWord (s, s') => unary (int s, word s')
+ | MLton_eq =>
+ two (fn (t1, t2) =>
+ (isSubtype (t1, t2) orelse isSubtype (t2, t1))
+ andalso done bool)
+ | Real_Math_acos s => realUnary s
+ | Real_Math_asin s => realUnary s
+ | Real_Math_atan s => realUnary s
+ | Real_Math_atan2 s => realBinary s
+ | Real_Math_cos s => realUnary s
+ | Real_Math_exp s => realUnary s
+ | Real_Math_ln s => realUnary s
+ | Real_Math_log10 s => realUnary s
+ | Real_Math_sin s => realUnary s
+ | Real_Math_sqrt s => realUnary s
+ | Real_Math_tan s => realUnary s
+ | Real_abs s => realUnary s
+ | Real_add s => realBinary s
+ | Real_div s => realBinary s
+ | Real_equal s => realCompare s
+ | Real_ge s => realCompare s
+ | Real_gt s => realCompare s
+ | Real_ldexp s => binary (real s, defaultInt, real s)
+ | Real_le s => realCompare s
+ | Real_lt s => realCompare s
+ | Real_mul s => realBinary s
+ | Real_muladd s => real3 s
+ | Real_mulsub s => real3 s
+ | Real_neg s => realUnary s
+ | Real_qequal s => realCompare s
+ | Real_round s => realUnary s
+ | Real_sub s => realBinary s
+ | Real_toInt (s, s') => unary (real s, int s')
+ | Real_toReal (s, s') => unary (real s, real s')
+ | Thread_returnToC => nullary unit
+ | Word_add s => twoWord add
+ | Word_addCheck s => wordBinary s
+ | Word_andb s => twoOpt andb
+ | Word_arshift s => wordShift s
+ | Word_div s => wordBinary s
+ | Word_equal s => wordCompare s
+ | Word_ge s => wordCompare s
+ | Word_gt s => wordCompare s
+ | Word_le s => wordCompare s
+ | Word_lshift s => wordShift' lshift
+ | Word_lt s => wordCompare s
+ | Word_mod s => wordBinary s
+ | Word_mul s => twoWord mul
+ | Word_mulCheck s => wordBinary s
+ | Word_neg s => wordUnary s
+ | Word_notb s => wordUnary s
+ | Word_orb s => twoOpt orb
+ | Word_rol s => wordShift s
+ | Word_ror s => wordShift s
+ | Word_rshift s => wordShift' rshift
+ | Word_sub s => wordBinary s
+ | Word_toInt (s, s') => unary (word s, int s')
+ | Word_toIntX (s, s') => unary (word s, int s')
+ | Word_toWord (s, s') => unary (word s, word s')
+ | Word_toWordX (s, s') => unary (word s, word s')
+ | Word_xorb s => wordBinary s
+ | _ => Error.bug (concat ["strange primitive to Prim.typeCheck: ",
+ Prim.toString prim])
+ end
+
+val checkPrimApp =
+ Trace.trace ("RepType.checkPrimApp",
+ fn {args, prim, result} =>
+ Layout.record [("args", Vector.layout layout args),
+ ("prim", Prim.layout prim),
+ ("result", Option.layout layout result)],
+ Bool.layout)
+ checkPrimApp
+
+structure BuiltInCFunction =
+ struct
+ open CFunction
+
+ type t = Type.t CFunction.t
+
+ datatype z = datatype Convention.t
+
+ val bug = vanilla {args = Vector.new1 string,
+ name = "MLton_bug",
+ return = unit}
+
+ local
+ open Type
+ in
+ val Int32 = int (IntSize.I (Bits.fromInt 32))
+ val Word32 = word (Bits.fromInt 32)
+ val bool = bool
+ val cPointer = cPointer
+ val gcState = gcState
+ val string = word8Vector
+ val unit = unit
+ end
+
+ local
+ fun make b =
+ T {args = let
+ open Type
+ in
+ Vector.new5 (gcState, Word32, bool, cPointer (), Int32)
+ end,
+ bytesNeeded = NONE,
+ convention = Cdecl,
+ ensuresBytesFree = true,
+ mayGC = true,
+ maySwitchThreads = b,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = "GC_gc",
+ return = unit}
+ val t = make true
+ val f = make false
+ in
+ fun gc {maySwitchThreads = b} = if b then t else f
+ end
+ end
end
1.2 +23 -5 mlton/mlton/atoms/rep-type.sig
Index: rep-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/rep-type.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- rep-type.sig 4 Apr 2004 06:50:14 -0000 1.1
+++ rep-type.sig 12 Apr 2004 17:52:55 -0000 1.2
@@ -7,23 +7,27 @@
signature REP_TYPE_STRUCTS =
sig
+ structure CFunction: C_FUNCTION
structure CType: C_TYPE
structure IntSize: INT_SIZE
structure IntX: INT_X
structure Label: LABEL
structure PointerTycon: POINTER_TYCON
+ structure Prim: PRIM
structure RealSize: REAL_SIZE
structure Runtime: RUNTIME
structure WordSize: WORD_SIZE
structure WordX: WORD_X
- sharing IntSize = IntX.IntSize
- sharing WordSize = WordX.WordSize
+ sharing CFunction = Prim.CFunction
+ sharing IntSize = IntX.IntSize = Prim.IntSize
+ sharing RealSize = Prim.RealSize
+ sharing WordSize = Prim.WordSize = WordX.WordSize
end
signature REP_TYPE =
sig
include REP_TYPE_STRUCTS
-
+
structure ObjectType: OBJECT_TYPE
(*
* - Junk is used for padding. You can stick any value in, but you
@@ -55,12 +59,19 @@
val address: t -> t
val align: t * Bytes.t -> Bytes.t
val andb: t * t -> t option
+ val arrayOffsetIsOk: {base: t,
+ index: t,
+ pointerTy: PointerTycon.t -> ObjectType.t,
+ result: t} -> bool
val bool: t
val bytes: t -> Bytes.t
val castIsOk: {from: t,
fromInt: IntX.t option,
to: t,
tyconTy: PointerTycon.t -> ObjectType.t} -> bool
+ val checkPrimApp: {args: t vector,
+ prim: t Prim.t,
+ result: t option} -> bool
val char: t
val cPointer: unit -> t
val constant: WordX.t -> t
@@ -88,9 +99,10 @@
val mul: t * t -> t
val name: t -> string (* simple one letter abbreviation *)
val ofGCField: Runtime.GCField.t -> t
- val offset: t * {offset: Bytes.t,
+ val offsetIsOk: {base: t,
+ offset: Bytes.t,
pointerTy: PointerTycon.t -> ObjectType.t,
- width: Bits.t} -> t option
+ result: t} -> bool
val orb: t * t -> t option
val pointer: PointerTycon.t -> t
val pointerHeader: PointerTycon.t -> t
@@ -108,4 +120,10 @@
val word8: t
val wordVector: t
val word8Vector: t
+
+ structure BuiltInCFunction:
+ sig
+ val bug: t CFunction.t
+ val gc: {maySwitchThreads: bool} -> t CFunction.t
+ end
end
1.21 +2 -2 mlton/mlton/atoms/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- sources.cm 4 Apr 2004 06:50:14 -0000 1.20
+++ sources.cm 12 Apr 2004 17:52:56 -0000 1.21
@@ -66,14 +66,14 @@
pointer-tycon.fun
object-type.sig
label.sig
-rep-type.sig
-rep-type.fun
c-function.sig
c-function.fun
const.sig
const.fun
prim.sig
prim.fun
+rep-type.sig
+rep-type.fun
ffi.sig
ffi.fun
func.sig
1.12 +0 -1 mlton/mlton/atoms/type-ops.fun
Index: type-ops.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- type-ops.fun 4 Apr 2004 06:50:14 -0000 1.11
+++ type-ops.fun 12 Apr 2004 17:52:56 -0000 1.12
@@ -29,7 +29,6 @@
val exn = nullary Tycon.exn
val int = IntSize.memoize (fn s => nullary (Tycon.int s))
val intInf = nullary Tycon.intInf
- val pointer = nullary Tycon.pointer
val preThread = nullary Tycon.preThread
val real = RealSize.memoize (fn s => nullary (Tycon.real s))
val thread = nullary Tycon.thread
1.9 +0 -1 mlton/mlton/atoms/type-ops.sig
Index: type-ops.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- type-ops.sig 9 Oct 2003 18:17:31 -0000 1.8
+++ type-ops.sig 12 Apr 2004 17:52:56 -0000 1.9
@@ -60,7 +60,6 @@
val isTuple: t -> bool
val list: t -> t
val nth: t * int -> t
- val pointer: t
val preThread: t
val real: realSize -> t
val reff: t -> t
1.65 +1 -1 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -r1.64 -r1.65
--- backend.fun 4 Apr 2004 06:50:16 -0000 1.64
+++ backend.fun 12 Apr 2004 17:52:56 -0000 1.65
@@ -542,7 +542,7 @@
{args = (Vector.new1
(globalString "backend thought control shouldn't reach here")),
frameInfo = NONE,
- func = CFunction.bug,
+ func = Type.BuiltInCFunction.bug,
return = NONE}
val {get = labelInfo: Label.t -> {args: (Var.t * Type.t) vector},
set = setLabelInfo, ...} =
1.48 +5 -0 mlton/mlton/backend/limit-check.fun
Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -r1.47 -r1.48
--- limit-check.fun 4 Apr 2004 06:50:16 -0000 1.47
+++ limit-check.fun 12 Apr 2004 17:52:57 -0000 1.48
@@ -66,6 +66,11 @@
open S
open Rssa
+structure CFunction =
+ struct
+ open CFunction Type.BuiltInCFunction
+ end
+
structure Statement =
struct
open Statement
1.60 +20 -34 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.59
retrieving revision 1.60
diff -u -r1.59 -r1.60
--- machine.fun 4 Apr 2004 06:50:16 -0000 1.59
+++ machine.fun 12 Apr 2004 17:52:57 -0000 1.60
@@ -304,7 +304,7 @@
value: Operand.t} vector}
| PrimApp of {args: Operand.t vector,
dst: Operand.t option,
- prim: Prim.t}
+ prim: Type.t Prim.t}
| ProfileLabel of ProfileLabel.t
val layout =
@@ -398,11 +398,11 @@
Arith of {args: Operand.t vector,
dst: Operand.t,
overflow: Label.t,
- prim: Prim.t,
+ prim: Type.t Prim.t,
success: Label.t}
| CCall of {args: Operand.t vector,
frameInfo: FrameInfo.t option,
- func: CFunction.t,
+ func: Type.t CFunction.t,
return: Label.t option}
| Call of {label: Label.t,
live: Operand.t vector,
@@ -431,7 +431,7 @@
record
[("args", Vector.layout Operand.layout args),
("frameInfo", Option.layout FrameInfo.layout frameInfo),
- ("func", CFunction.layout func),
+ ("func", CFunction.layout (func, Type.layout)),
("return", Option.layout Label.layout return)]]
| Call {label, live, return} =>
seq [str "Call ",
@@ -473,7 +473,7 @@
frameInfo: FrameInfo.t}
| CReturn of {dst: Operand.t option,
frameInfo: FrameInfo.t option,
- func: CFunction.t}
+ func: Type.t CFunction.t}
| Func
| Handler of {frameInfo: FrameInfo.t,
handles: Operand.t vector}
@@ -493,7 +493,7 @@
record
[("dst", Option.layout Operand.layout dst),
("frameInfo", Option.layout FrameInfo.layout frameInfo),
- ("func", CFunction.layout func)]]
+ ("func", CFunction.layout (func, Type.layout))]]
| Func => str "Func"
| Handler {frameInfo, handles} =>
seq [str "Handler ",
@@ -921,10 +921,13 @@
datatype z = datatype Operand.t
fun ok () =
case x of
- ArrayOffset (z as {base, index, ...}) =>
+ ArrayOffset {base, index, ty} =>
(checkOperand (base, alloc)
; checkOperand (index, alloc)
- ; arrayOffsetIsOk z)
+ ; Type.arrayOffsetIsOk {base = Operand.ty base,
+ index = Operand.ty index,
+ pointerTy = tyconTy,
+ result = ty})
| Cast (z, t) =>
(checkOperand (z, alloc)
; (Type.castIsOk
@@ -958,12 +961,10 @@
; (case base of
Operand.GCState => true
| _ =>
- (case Type.offset (Operand.ty base,
- {offset = offset,
- pointerTy = tyconTy,
- width = Type.width ty}) of
- NONE => false
- | SOME t => Type.isSubtype (t, ty))))
+ Type.offsetIsOk {base = Operand.ty base,
+ offset = offset,
+ pointerTy = tyconTy,
+ result = ty}))
| Real _ => true
| Register _ => Alloc.doesDefine (alloc, x)
| SmallIntInf w => 0wx1 = Word.andb (w, 0wx1)
@@ -1005,20 +1006,6 @@
in
Err.check ("operand", ok, fn () => Operand.layout x)
end
- and arrayOffsetIsOk {base: Operand.t, index: Operand.t, ty} =
- Type.isSubtype (Operand.ty index, Type.defaultInt)
- andalso
- case Type.dest (Operand.ty base) of
- Type.Pointer p =>
- (case tyconTy p of
- ObjectType.Array ty' =>
- Type.isSubtype (ty', ty)
- orelse
- (* Get a word from a word8 array.*)
- (Type.equals (ty, Type.defaultWord)
- andalso Type.equals (ty', Type.word8))
- | _ => false)
- | _ => Type.isCPointer (Operand.ty base)
fun checkOperands (v, a) =
Vector.foreach (v, fn z => checkOperand (z, a))
fun check' (x, name, isOk, layout) =
@@ -1327,17 +1314,16 @@
andalso jump (overflow, alloc)
andalso jump (success, alloc)
andalso
- (case (Prim.typeCheck
- (prim, Vector.map (args, Operand.ty))) of
- NONE => false
- | SOME t => Type.isSubtype (t, Operand.ty dst))
-
+ Type.checkPrimApp
+ {args = Vector.map (args, Operand.ty),
+ prim = prim,
+ result = SOME (Operand.ty dst)}
end
| CCall {args, frameInfo = fi, func, return} =>
let
val _ = checkOperands (args, alloc)
in
- CFunction.isOk func
+ CFunction.isOk (func, {isUnit = Type.isUnit})
andalso
Vector.equals (args, CFunction.args func,
fn (z, t) =>
1.43 +4 -4 mlton/mlton/backend/machine.sig
Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- machine.sig 4 Apr 2004 06:50:16 -0000 1.42
+++ machine.sig 12 Apr 2004 17:52:57 -0000 1.43
@@ -108,7 +108,7 @@
value: Operand.t} vector}
| PrimApp of {args: Operand.t vector,
dst: Operand.t option,
- prim: Prim.t}
+ prim: Type.t Prim.t}
| ProfileLabel of ProfileLabel.t
val foldOperands: t * 'a * (Operand.t * 'a -> 'a) -> 'a
@@ -136,11 +136,11 @@
Arith of {args: Operand.t vector,
dst: Operand.t,
overflow: Label.t,
- prim: Prim.t,
+ prim: Type.t Prim.t,
success: Label.t}
| CCall of {args: Operand.t vector,
frameInfo: FrameInfo.t option,
- func: CFunction.t,
+ func: Type.t CFunction.t,
(* return is NONE iff the func doesn't return.
* Else, return must be SOME l, where l is of CReturn
* kind with a matching func.
@@ -167,7 +167,7 @@
frameInfo: FrameInfo.t}
| CReturn of {dst: Operand.t option,
frameInfo: FrameInfo.t option,
- func: CFunction.t}
+ func: Type.t CFunction.t}
| Func
| Handler of {frameInfo: FrameInfo.t,
handles: Operand.t vector}
1.34 +28 -0 mlton/mlton/backend/profile.fun
Index: profile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- profile.fun 4 Apr 2004 06:50:17 -0000 1.33
+++ profile.fun 12 Apr 2004 17:52:57 -0000 1.34
@@ -4,6 +4,34 @@
open S
open Rssa
+structure CFunction =
+ struct
+ open CFunction
+
+ local
+ open Type
+ in
+ val gcState = gcState
+ val Word32 = word (Bits.fromInt 32)
+ val unit = unit
+ end
+
+ val profileEnter =
+ vanilla {args = Vector.new1 gcState,
+ name = "GC_profileEnter",
+ return = unit}
+
+ val profileInc =
+ vanilla {args = Vector.new2 (gcState, Word32),
+ name = "GC_profileInc",
+ return = unit}
+
+ val profileLeave =
+ vanilla {args = Vector.new1 gcState,
+ name = "GC_profileLeave",
+ return = unit}
+ end
+
type sourceSeq = int list
structure InfoNode =
1.48 +27 -45 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -r1.47 -r1.48
--- rssa.fun 4 Apr 2004 06:50:17 -0000 1.47
+++ rssa.fun 12 Apr 2004 17:52:57 -0000 1.48
@@ -168,7 +168,7 @@
value: Operand.t} vector}
| PrimApp of {args: Operand.t vector,
dst: (Var.t * Type.t) option,
- prim: Prim.t}
+ prim: Type.t Prim.t}
| Profile of ProfileExp.t
| ProfileLabel of ProfileLabel.t
| SetExnStackLocal
@@ -272,11 +272,11 @@
Arith of {args: Operand.t vector,
dst: Var.t,
overflow: Label.t,
- prim: Prim.t,
+ prim: Type.t Prim.t,
success: Label.t,
ty: Type.t}
| CCall of {args: Operand.t vector,
- func: CFunction.t,
+ func: Type.t CFunction.t,
return: Label.t option}
| Call of {args: Operand.t vector,
func: Func.t,
@@ -303,7 +303,7 @@
| CCall {args, func, return} =>
seq [str "CCall ",
record [("args", Vector.layout Operand.layout args),
- ("func", CFunction.layout func),
+ ("func", CFunction.layout (func, Type.layout)),
("return", Option.layout Label.layout return)]]
| Call {args, func, return} =>
seq [Func.layout func, str " ",
@@ -321,7 +321,7 @@
CCall {args = (Vector.new1
(Operand.Const
(Const.string "control shouldn't reach here"))),
- func = CFunction.bug,
+ func = Type.BuiltInCFunction.bug,
return = NONE}
fun 'a foldDefLabelUse (t, a: 'a,
@@ -406,7 +406,7 @@
struct
datatype t =
Cont of {handler: Handler.t}
- | CReturn of {func: CFunction.t}
+ | CReturn of {func: Type.t CFunction.t}
| Handler
| Jump
@@ -420,7 +420,7 @@
record [("handler", Handler.layout handler)]]
| CReturn {func} =>
seq [str "CReturn ",
- record [("func", CFunction.layout func)]]
+ record [("func", CFunction.layout (func, Type.layout))]]
| Handler => str "Handler"
| Jump => str "Jump"
end
@@ -995,7 +995,13 @@
datatype z = datatype Operand.t
fun ok () =
case x of
- ArrayOffset z => arrayOffsetIsOk z
+ ArrayOffset {base, index, ty} =>
+ (checkOperand base
+ ; checkOperand index
+ ; Type.arrayOffsetIsOk {base = Operand.ty base,
+ index = Operand.ty index,
+ pointerTy = tyconTy,
+ result = ty})
| Cast (z, ty) =>
(checkOperand z
; (Type.castIsOk
@@ -1014,12 +1020,10 @@
| GCState => true
| Line => true
| Offset {base, offset, ty} =>
- (case Type.offset (Operand.ty base,
- {offset = offset,
- pointerTy = tyconTy,
- width = Type.width ty}) of
- NONE => false
- | SOME t => Type.isSubtype (t, ty))
+ Type.offsetIsOk {base = Operand.ty base,
+ offset = offset,
+ pointerTy = tyconTy,
+ result = ty}
| PointerTycon _ => true
| Runtime _ => true
| SmallIntInf _ => true
@@ -1027,25 +1031,6 @@
in
Err.check ("operand", ok, fn () => Operand.layout x)
end
- and arrayOffsetIsOk {base, index, ty} =
- let
- val _ = checkOperand base
- val _ = checkOperand index
- in
- Type.isSubtype (Operand.ty index, Type.defaultInt)
- andalso
- case Type.dest (Operand.ty base) of
- Type.Pointer p =>
- (case tyconTy p of
- ObjectType.Array ty' =>
- Type.isSubtype (ty', ty)
- orelse
- (* Get a word from a word8 array.*)
- (Type.equals (ty, Type.defaultWord)
- andalso Type.equals (ty', Type.word8))
- | _ => false)
- | _ => Type.isCPointer (Operand.ty base)
- end
val checkOperand =
Trace.trace ("checkOperand", Operand.layout, Unit.layout)
checkOperand
@@ -1090,13 +1075,10 @@
end
| PrimApp {args, dst, prim} =>
(Vector.foreach (args, checkOperand)
- ; (case (Prim.typeCheck
- (prim, Vector.map (args, Operand.ty))) of
- NONE => false
- | SOME t =>
- case dst of
- NONE => true
- | SOME (_, t') => Type.isSubtype (t, t')))
+ ; (Type.checkPrimApp
+ {args = Vector.map (args, Operand.ty),
+ prim = prim,
+ result = Option.map (dst, #2)}))
| Profile _ => true
| ProfileLabel _ => true
| SetExnStackLocal => true
@@ -1210,16 +1192,16 @@
andalso labelIsNullaryJump overflow
andalso labelIsNullaryJump success
andalso
- (case (Prim.typeCheck
- (prim, Vector.map (args, Operand.ty))) of
- NONE => false
- | SOME t => Type.isSubtype (t, ty))
+ Type.checkPrimApp
+ {args = Vector.map (args, Operand.ty),
+ prim = prim,
+ result = SOME ty}
end
| CCall {args, func, return} =>
let
val _ = checkOperands args
in
- CFunction.isOk func
+ CFunction.isOk (func, {isUnit = Type.isUnit})
andalso
Vector.equals (args, CFunction.args func,
fn (z, t) =>
1.30 +4 -4 mlton/mlton/backend/rssa.sig
Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- rssa.sig 4 Apr 2004 06:50:17 -0000 1.29
+++ rssa.sig 12 Apr 2004 17:52:58 -0000 1.30
@@ -83,7 +83,7 @@
value: Operand.t} vector}
| PrimApp of {args: Operand.t vector,
dst: (Var.t * Type.t) option,
- prim: Prim.t}
+ prim: Type.t Prim.t}
| Profile of ProfileExp.t
| ProfileLabel of ProfileLabel.t
| SetExnStackLocal
@@ -111,11 +111,11 @@
Arith of {args: Operand.t vector,
dst: Var.t,
overflow: Label.t, (* Must be nullary. *)
- prim: Prim.t,
+ prim: Type.t Prim.t,
success: Label.t, (* Must be nullary. *)
ty: Type.t}
| CCall of {args: Operand.t vector,
- func: CFunction.t,
+ func: Type.t CFunction.t,
(* return is NONE iff the CFunction doesn't return.
* Else, return must be SOME l, where l is of kind
* CReturn. The return should be nullary if the C
@@ -157,7 +157,7 @@
sig
datatype t =
Cont of {handler: Handler.t}
- | CReturn of {func: CFunction.t}
+ | CReturn of {func: Type.t CFunction.t}
| Handler
| Jump
1.22 +5 -0 mlton/mlton/backend/signal-check.fun
Index: signal-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/signal-check.fun,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- signal-check.fun 16 Mar 2004 06:38:27 -0000 1.21
+++ signal-check.fun 12 Apr 2004 17:52:58 -0000 1.22
@@ -11,6 +11,11 @@
open S
open Rssa
+structure CFunction =
+ struct
+ open CFunction Type.BuiltInCFunction
+ end
+
structure Graph = DirectedGraph
local
open Graph
1.67 +34 -4 mlton/mlton/backend/ssa-to-rssa.fun
Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.66
retrieving revision 1.67
diff -u -r1.66 -r1.67
--- ssa-to-rssa.fun 4 Apr 2004 06:50:17 -0000 1.66
+++ ssa-to-rssa.fun 12 Apr 2004 17:52:58 -0000 1.67
@@ -26,9 +26,19 @@
structure GCField = GCField
end
+structure Prim =
+ struct
+ open Prim
+
+ type t = Type.t Prim.t
+ end
+
structure CFunction =
struct
- open CFunction
+ open CFunction
+ open Type.BuiltInCFunction
+
+ type t = Type.t CFunction.t
local
open Type
@@ -106,6 +116,18 @@
val unpack = make "GC_unpack"
end
+ val returnToC =
+ T {args = Vector.new0 (),
+ bytesNeeded = NONE,
+ convention = Cdecl,
+ ensuresBytesFree = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ mayGC = true,
+ maySwitchThreads = true,
+ name = "Thread_returnToC",
+ return = unit}
+
val threadSwitchTo =
T {args = Vector.new2 (Type.thread, Word32),
bytesNeeded = NONE,
@@ -162,6 +184,8 @@
struct
open Prim.Name
+ type t = Type.t t
+
fun cFunctionRaise (n: t): CFunction.t =
let
datatype z = datatype CFunction.Convention.t
@@ -591,9 +615,9 @@
| _ => false
end
- val x86CodegenImplements =
+ val x86CodegenImplements: t -> bool =
Trace.trace ("x86CodegenImplements", layout, Bool.layout)
- x86CodegenImplements
+ x86CodegenImplements
end
datatype z = datatype Operand.t
@@ -823,6 +847,11 @@
Vector.keepAllMap (xs, fn x =>
Option.map (toRtype (varType x), fn _ =>
varOp x))
+ fun translatePrim p =
+ Prim.map (p, fn t =>
+ case toRtype t of
+ NONE => Type.unit
+ | SOME t => t)
fun translateTransfer (t: S.Transfer.t): Statement.t list * Transfer.t =
case t of
S.Transfer.Arith {args, overflow, prim, success, ty} =>
@@ -843,7 +872,7 @@
([], Transfer.Arith {dst = temp,
args = vos args,
overflow = overflow,
- prim = prim,
+ prim = translatePrim prim,
success = noOverflow,
ty = ty})
end
@@ -990,6 +1019,7 @@
end
| S.Exp.PrimApp {prim, targs, args, ...} =>
let
+ val prim = translatePrim prim
fun a i = Vector.sub (args, i)
fun cast () =
move (Operand.cast (varOp (a 0),
1.12 +2 -2 mlton/mlton/closure-convert/abstract-value.fun
Index: abstract-value.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/abstract-value.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- abstract-value.fun 19 Feb 2004 22:42:10 -0000 1.11
+++ abstract-value.fun 12 Apr 2004 17:52:59 -0000 1.12
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -373,7 +373,7 @@
val {get = serialValue: Type.t -> t, ...} =
Property.get (Type.plist, Property.initFun fromType)
-fun primApply {prim: Prim.t, args: t vector, resultTy: Type.t}: t =
+fun primApply {prim: Type.t Prim.t, args: t vector, resultTy: Type.t}: t =
let
fun result () = fromType resultTy
fun typeError () =
1.6 +2 -2 mlton/mlton/closure-convert/abstract-value.sig
Index: abstract-value.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/abstract-value.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- abstract-value.sig 9 Oct 2003 18:17:32 -0000 1.5
+++ abstract-value.sig 12 Apr 2004 17:52:59 -0000 1.6
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -59,7 +59,7 @@
val isEmpty: t -> bool (* no possible values correspond to me *)
val lambda: Sxml.Lambda.t * Sxml.Type.t (* The type of the lambda. *) -> t
val layout: t -> Layout.t
- val primApply: {prim: Sxml.Prim.t,
+ val primApply: {prim: Sxml.Type.t Sxml.Prim.t,
args: t vector,
resultTy: Sxml.Type.t} -> t
val select: t * int -> t
1.34 +2 -1 mlton/mlton/closure-convert/closure-convert.fun
Index: closure-convert.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/closure-convert.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- closure-convert.fun 3 Mar 2004 02:09:02 -0000 1.33
+++ closure-convert.fun 12 Apr 2004 17:52:59 -0000 1.34
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -870,6 +870,7 @@
end
| SprimExp.PrimApp {prim, targs, args} =>
let
+ val prim = Prim.map (prim, convertType)
open Prim.Name
fun arg i = Vector.sub (args, i)
val v1 = Vector.new1
1.5 +1 -1 mlton/mlton/closure-convert/closure-convert.sig
Index: closure-convert.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/closure-convert.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- closure-convert.sig 12 Dec 2002 01:14:22 -0000 1.4
+++ closure-convert.sig 12 Apr 2004 17:52:59 -0000 1.5
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
1.77 +29 -5 mlton/mlton/codegen/c-codegen/c-codegen.fun
Index: c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.76
retrieving revision 1.77
diff -u -r1.76 -r1.77
--- c-codegen.fun 4 Apr 2004 06:50:18 -0000 1.76
+++ c-codegen.fun 12 Apr 2004 17:53:00 -0000 1.77
@@ -35,7 +35,6 @@
structure RealSize = RealSize
structure RealX = RealX
structure Register = Register
- structure RepType = RepType
structure Runtime = Runtime
structure Statement = Statement
structure Switch = Switch
@@ -67,6 +66,31 @@
| _ => false
end
+structure CFunction =
+ struct
+ open CFunction
+
+ fun prototype (T {args, convention, name, return, ...}) =
+ let
+ val c = Counter.new 0
+ fun arg t = concat [CType.toString (Type.toCType t),
+ " x", Int.toString (Counter.next c)]
+ in
+ concat
+ [if Type.isUnit return
+ then "void"
+ else CType.toString (Type.toCType return),
+ if convention <> Convention.Cdecl
+ then concat [" __attribute__ ((",
+ Convention.toString convention,
+ ")) "]
+ else " ",
+ name, " (",
+ concat (List.separate (Vector.toListMap (args, arg), ", ")),
+ ")"]
+ end
+ end
+
val traceGotoLabel = Trace.trace ("gotoLabel", Label.layout, Unit.layout)
structure IntX =
@@ -187,8 +211,8 @@
| _ => false
end
-fun creturn (t: RepType.t): string =
- concat ["CReturn", CType.name (RepType.toCType t)]
+fun creturn (t: Type.t): string =
+ concat ["CReturn", CType.name (Type.toCType t)]
fun outputIncludes (includes, print) =
(List.foreach (includes, fn i => (print "#include <";
@@ -658,7 +682,7 @@
(name, fn () =>
concat
["extern ",
- CType.toString (RepType.toCType ty),
+ CType.toString (Type.toCType ty),
" ", name, ";\n"])
| _ => ())
| _ => ())
@@ -971,7 +995,7 @@
else ()
val _ = print "\t"
val _ =
- if RepType.isUnit returnTy
+ if Type.isUnit returnTy
then ()
else print (concat [creturn returnTy, " = "])
val _ = C.call (name, args, print)
1.29 +2 -2 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun
Index: x86-mlton-basic.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- x86-mlton-basic.fun 4 Apr 2004 06:50:19 -0000 1.28
+++ x86-mlton-basic.fun 12 Apr 2004 17:53:00 -0000 1.29
@@ -1,11 +1,11 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor x86MLtonBasic(S: X86_MLTON_BASIC_STRUCTS): X86_MLTON_BASIC =
+functor x86MLtonBasic (S: X86_MLTON_BASIC_STRUCTS): X86_MLTON_BASIC =
struct
open S
1.30 +11 -2 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig
Index: x86-mlton-basic.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- x86-mlton-basic.sig 4 Apr 2004 06:50:19 -0000 1.29
+++ x86-mlton-basic.sig 12 Apr 2004 17:53:01 -0000 1.30
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -9,17 +9,26 @@
signature X86_MLTON_BASIC_STRUCTS =
sig
- structure x86 : X86_PSEUDO
structure Machine: MACHINE
+ structure x86: X86_PSEUDO
sharing x86.CFunction = Machine.CFunction
+ sharing x86.CType = Machine.CType
sharing x86.Label = Machine.Label
sharing x86.ProfileLabel = Machine.ProfileLabel
+ sharing x86.RepType = Machine.RepType
sharing x86.Runtime = Machine.Runtime
end
signature X86_MLTON_BASIC =
sig
include X86_MLTON_BASIC_STRUCTS
+
+ structure CFunction: C_FUNCTION
+ structure CType: C_TYPE
+ structure RepType: REP_TYPE
+ sharing CFunction = RepType.CFunction
+ sharing CType = RepType.CType
+ sharing RepType = Machine.RepType
val init : unit -> unit
1.58 +3 -3 mlton/mlton/codegen/x86-codegen/x86-mlton.fun
Index: x86-mlton.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.fun,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -r1.57 -r1.58
--- x86-mlton.fun 5 Mar 2004 03:50:53 -0000 1.57
+++ x86-mlton.fun 12 Apr 2004 17:53:01 -0000 1.58
@@ -29,7 +29,7 @@
live: x86.Label.t -> x86.Operand.t list,
liveInfo: x86Liveness.LiveInfo.t}
- fun prim {prim : Prim.t,
+ fun prim {prim : RepType.t Prim.t,
args : (Operand.t * Size.t) vector,
dsts : (Operand.t * Size.t) vector,
transInfo = {...} : transInfo}
@@ -1582,7 +1582,7 @@
fun creturn {dsts: (x86.Operand.t * x86.Size.t) vector,
frameInfo: x86.FrameInfo.t option,
- func: CFunction.t,
+ func: RepType.t CFunction.t,
label: x86.Label.t,
transInfo = {live, liveInfo, ...}: transInfo}
= let
@@ -1613,7 +1613,7 @@
AppendList.appends [default (), comment_end]
end
- fun arith {prim : Prim.t,
+ fun arith {prim : RepType.t Prim.t,
args : (Operand.t * Size.t) vector,
dsts : (Operand.t * Size.t) vector,
overflow : Label.t,
1.17 +5 -5 mlton/mlton/codegen/x86-codegen/x86-mlton.sig
Index: x86-mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.sig,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- x86-mlton.sig 18 Mar 2004 03:22:24 -0000 1.16
+++ x86-mlton.sig 12 Apr 2004 17:53:01 -0000 1.17
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -28,7 +28,7 @@
liveInfo: x86Liveness.LiveInfo.t}
(* arith, c call, and primitive assembly sequences. *)
- val arith: {prim: Machine.Prim.t,
+ val arith: {prim: RepType.t Machine.Prim.t,
args: (x86.Operand.t * x86.Size.t) vector,
dsts: (x86.Operand.t * x86.Size.t) vector,
overflow: x86.Label.t,
@@ -36,15 +36,15 @@
transInfo : transInfo} -> x86.Block.t' AppendList.t
val ccall: {args: (x86.Operand.t * x86.Size.t) vector,
frameInfo: x86.FrameInfo.t option,
- func: Machine.CFunction.t,
+ func: RepType.t Machine.CFunction.t,
return: x86.Label.t option,
transInfo: transInfo} -> x86.Block.t' AppendList.t
val creturn: {dsts: (x86.Operand.t * x86.Size.t) vector,
frameInfo: x86.FrameInfo.t option,
- func: Machine.CFunction.t,
+ func: RepType.t Machine.CFunction.t,
label: x86.Label.t,
transInfo: transInfo} -> x86.Block.t' AppendList.t
- val prim: {prim: Machine.Prim.t,
+ val prim: {prim: RepType.t Machine.Prim.t,
args: (x86.Operand.t * x86.Size.t) vector,
dsts: (x86.Operand.t * x86.Size.t) vector,
transInfo: transInfo} -> x86.Block.t' AppendList.t
1.23 +5 -3 mlton/mlton/codegen/x86-codegen/x86-pseudo.sig
Index: x86-pseudo.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-pseudo.sig,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- x86-pseudo.sig 4 Apr 2004 06:50:19 -0000 1.22
+++ x86-pseudo.sig 12 Apr 2004 17:53:01 -0000 1.23
@@ -13,8 +13,10 @@
structure CFunction: C_FUNCTION
structure CType: C_TYPE
structure Label: ID
+ structure RepType: REP_TYPE
structure Runtime: RUNTIME
- sharing CType = CFunction.RepType.CType
+ sharing CFunction = RepType.CFunction
+ sharing CType = RepType.CType
val tracer : string -> ('a -> 'b) ->
(('a -> 'b) * (unit -> unit))
@@ -425,7 +427,7 @@
frameInfo: FrameInfo.t} -> t
val creturn: {dsts: (Operand.t * Size.t) vector,
frameInfo: FrameInfo.t option,
- func: CFunction.t,
+ func: RepType.t CFunction.t,
label: Label.t} -> t
val func: {label: Label.t,
live: MemLocSet.t} -> t
@@ -467,7 +469,7 @@
val raisee : {live: MemLocSet.t} -> t
val ccall : {args: (Operand.t * Size.t) list,
frameInfo: FrameInfo.t option,
- func: CFunction.t,
+ func: RepType.t CFunction.t,
return: Label.t option,
target: Label.t} -> t
end
1.52 +2 -4 mlton/mlton/codegen/x86-codegen/x86.fun
Index: x86.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.fun,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -r1.51 -r1.52
--- x86.fun 4 Apr 2004 06:50:19 -0000 1.51
+++ x86.fun 12 Apr 2004 17:53:02 -0000 1.52
@@ -43,8 +43,6 @@
open S
- structure RepType = CFunction.RepType
-
structure Label =
struct
open Label
@@ -3720,7 +3718,7 @@
live: MemLocSet.t}
| CReturn of {dsts: (Operand.t * Size.t) vector,
frameInfo: FrameInfo.t option,
- func: CFunction.t,
+ func: RepType.t CFunction.t,
label: Label.t}
val toString
@@ -3979,7 +3977,7 @@
| Raise of {live: MemLocSet.t}
| CCall of {args: (Operand.t * Size.t) list,
frameInfo: FrameInfo.t option,
- func: CFunction.t,
+ func: RepType.t CFunction.t,
return: Label.t option,
target: Label.t}
1.32 +13 -9 mlton/mlton/codegen/x86-codegen/x86.sig
Index: x86.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.sig,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- x86.sig 4 Apr 2004 06:50:19 -0000 1.31
+++ x86.sig 12 Apr 2004 17:53:02 -0000 1.32
@@ -13,18 +13,22 @@
structure CFunction: C_FUNCTION
structure CType: C_TYPE
structure Label: ID
- structure ProfileLabel: PROFILE_LABEL
+ structure ProfileLabel: PROFILE_LABEL
+ structure RepType: REP_TYPE
structure Runtime: RUNTIME
- sharing CType = CFunction.RepType.CType
+ sharing CFunction = RepType.CFunction
+ sharing CType = RepType.CType
end
signature X86 =
sig
structure CFunction: C_FUNCTION
+ structure CType: C_TYPE
structure Label: ID
+ structure RepType: REP_TYPE
structure Runtime: RUNTIME
- structure CType: C_TYPE
- sharing CType = CFunction.RepType.CType
+ sharing CFunction = RepType.CFunction
+ sharing CType = RepType.CType
val tracer : string -> ('a -> 'b) ->
(('a -> 'b) * (unit -> unit))
@@ -307,7 +311,7 @@
val size : t -> Size.t option
val eq : t * t -> bool
- val cReturnTemps: CFunction.RepType.t -> {src: t, dst: MemLoc.t} list
+ val cReturnTemps: RepType.t -> {src: t, dst: MemLoc.t} list
end
structure Instruction :
@@ -1073,7 +1077,7 @@
live: MemLocSet.t}
| CReturn of {dsts: (Operand.t * Size.t) vector,
frameInfo: FrameInfo.t option,
- func: CFunction.t,
+ func: RepType.t CFunction.t,
label: Label.t}
val cont : {label: Label.t,
@@ -1081,7 +1085,7 @@
frameInfo: FrameInfo.t} -> t
val creturn: {dsts: (Operand.t * Size.t) vector,
frameInfo: FrameInfo.t option,
- func: CFunction.t,
+ func: RepType.t CFunction.t,
label: Label.t} -> t
val func : {label: Label.t,
live: MemLocSet.t} -> t
@@ -1161,7 +1165,7 @@
| Raise of {live: MemLocSet.t}
| CCall of {args: (Operand.t * Size.t) list,
frameInfo: FrameInfo.t option,
- func: CFunction.t,
+ func: RepType.t CFunction.t,
return: Label.t option,
target: Label.t}
@@ -1193,7 +1197,7 @@
val raisee : {live: MemLocSet.t} -> t
val ccall: {args: (Operand.t * Size.t) list,
frameInfo: FrameInfo.t option,
- func: CFunction.t,
+ func: RepType.t CFunction.t,
return: Label.t option,
target: Label.t} -> t
end
1.18 +1 -1 mlton/mlton/core-ml/core-ml.fun
Index: core-ml.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/core-ml.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- core-ml.fun 19 Feb 2004 22:42:11 -0000 1.17
+++ core-ml.fun 12 Apr 2004 17:53:03 -0000 1.18
@@ -165,7 +165,7 @@
| Let of dec vector * exp
| List of exp vector
| PrimApp of {args: exp vector,
- prim: Prim.t,
+ prim: Type.t Prim.t,
targs: Type.t vector}
| Raise of {exn: exp,
region: Region.t}
1.17 +1 -1 mlton/mlton/core-ml/core-ml.sig
Index: core-ml.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/core-ml.sig,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- core-ml.sig 18 Mar 2004 03:22:25 -0000 1.16
+++ core-ml.sig 12 Apr 2004 17:53:04 -0000 1.17
@@ -86,7 +86,7 @@
| Let of dec vector * t
| List of t vector
| PrimApp of {args: t vector,
- prim: Prim.t,
+ prim: Type.t Prim.t,
targs: Type.t vector}
| Raise of {exn: t,
region: Region.t}
1.16 +13 -13 mlton/mlton/defunctorize/defunctorize.fun
Index: defunctorize.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/defunctorize/defunctorize.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- defunctorize.fun 18 Mar 2004 03:22:25 -0000 1.15
+++ defunctorize.fun 12 Apr 2004 17:53:04 -0000 1.16
@@ -806,21 +806,21 @@
| PrimApp {args, prim, targs} =>
let
val args = Vector.map (args, #1 o loopExp)
- val targs = Vector.map (targs, loopTy)
- fun app prim =
- Xexp.primApp {args = args,
- prim = prim,
- targs = targs,
- ty = ty}
- fun id () = Vector.sub (args, 0)
datatype z = datatype Prim.Name.t
in
- case Prim.name prim of
- Char_toWord8 => id ()
- | String_toWord8Vector => id ()
- | Word8_toChar => id ()
- | Word8Vector_toString => id ()
- | _ => app prim
+ if (case Prim.name prim of
+ Char_toWord8 => true
+ | String_toWord8Vector => true
+ | Word8_toChar => true
+ | Word8Vector_toString => true
+ | _ => false)
+ then Vector.sub (args, 0)
+ else
+ Xexp.primApp {args = args,
+ prim = Prim.map (prim, loopTy),
+ targs = Vector.map (targs, loopTy),
+ ty = ty}
+
end
| Raise {exn, region} =>
Xexp.raisee ({exn = #1 (loopExp exn),
1.97 +102 -74 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.96
retrieving revision 1.97
diff -u -r1.96 -r1.97
--- elaborate-core.fun 4 Apr 2004 06:50:20 -0000 1.96
+++ elaborate-core.fun 12 Apr 2004 17:53:04 -0000 1.97
@@ -628,9 +628,9 @@
val info = Trace.info "elaborateDec"
val elabExpInfo = Trace.info "elaborateExp"
-structure RepType =
+structure Type =
struct
- open CoreML.RepType
+ open Type
fun sized (all: 'a list,
toString: 'a -> string,
@@ -640,65 +640,97 @@
List.map (all, fn a =>
(make a, concat [prefix, toString a], makeType a))
- val nullary: (t * string * Tycon.t) list =
- [(bool, "Bool", Tycon.bool),
- (char, "Char", Tycon.char),
- (cPointer (), "Pointer", Tycon.pointer),
- (thread, "Pointer", Tycon.preThread),
- (thread, "Pointer", Tycon.thread)]
- @ sized (IntSize.all, IntSize.toString, "Int", int, Tycon.int)
- @ sized (RealSize.all, RealSize.toString, "Real", real, Tycon.real)
- @ sized (WordSize.all, WordSize.toString, "Word",
- word o WordSize.bits,
- Tycon.word)
+ val nullary: (string * CType.t * Tycon.t) list =
+ let
+ fun sized (tycon: Bits.t -> Tycon.t) =
+ List.map
+ ([CType.Word8, CType.Word16, CType.Word32, CType.Word64],
+ fn cty =>
+ let
+ val c = tycon (Bytes.toBits (CType.size cty))
+ val s = Tycon.toString c
+ val s =
+ CharVector.tabulate
+ (String.size s, fn i =>
+ let
+ val c = String.sub (s, i)
+ in
+ if i = 0 then Char.toUpper c else c
+ end)
+ in
+ (s, cty, c)
+ end)
+ in
+ [("Bool", CType.bool, Tycon.bool),
+ ("Char", CType.char, Tycon.char),
+ ("Pointer", CType.preThread, Tycon.preThread),
+ ("Thread", CType.thread, Tycon.thread)]
+ @ sized (Tycon.int o IntSize.I)
+ @ [("Real32", CType.Real32, Tycon.real RealSize.R32),
+ ("Real64", CType.Real64, Tycon.real RealSize.R64)]
+ @ sized (Tycon.word o WordSize.fromBits)
+ end
+
+ val nullary =
+ List.map (nullary, fn (name, ctype, tycon) =>
+ {ctype = ctype, name = name, tycon = tycon})
val unary: Tycon.t list =
[Tycon.array, Tycon.reff, Tycon.vector]
- fun fromType (t: Type.t): (t * string) option =
- case Type.deConOpt t of
+ fun toCType (t: t): {ctype: CType.t, name: string} option =
+ case deConOpt t of
NONE => NONE
| SOME (c, ts) =>
- case List.peek (nullary, fn (_, _, c') => Tycon.equals (c, c')) of
+ case List.peek (nullary, fn {tycon = c', ...} =>
+ Tycon.equals (c, c')) of
NONE =>
if List.exists (unary, fn c' => Tycon.equals (c, c'))
andalso 1 = Vector.length ts
- andalso isSome (fromType (Vector.sub (ts, 0)))
- then SOME (cPointer (), "Pointer")
+ andalso isSome (toCType (Vector.sub (ts, 0)))
+ then SOME {ctype = CType.pointer, name = "Pointer"}
else NONE
- | SOME (t, s, _) => SOME (t, s)
-
- val fromType =
- Trace.trace ("RepType.fromType",
- Type.layoutPretty,
- Option.layout (Layout.tuple2 (layout, String.layout)))
- fromType
+ | SOME {ctype, name, ...} => SOME {ctype = ctype, name = name}
- fun parse (ty: Type.t)
- : ((t * string) vector * (t * string) option) option =
- case Type.deArrowOpt ty of
+ type z = {ctype: CType.t, name: string, ty: t}
+
+ fun parse (ty: t): (z vector * z option) option =
+ case deArrowOpt ty of
NONE => NONE
| SOME (t1, t2) =>
let
- fun finish (ts: (t * string) vector) =
- case fromType t2 of
+ fun finish (ts: z vector) =
+ case toCType t2 of
NONE =>
if Type.isUnit t2
then SOME (ts, NONE)
else NONE
- | SOME t => SOME (ts, SOME t)
+ | SOME {ctype, name} =>
+ SOME (ts, SOME {ctype = ctype, name = name, ty = t2})
in
- case Type.deTupleOpt t1 of
+ case deTupleOpt t1 of
NONE =>
- (case fromType t1 of
+ (case toCType t1 of
NONE => NONE
- | SOME u => finish (Vector.new1 u))
+ | SOME {ctype, name} =>
+ finish (Vector.new1 {ctype = ctype,
+ name = name,
+ ty = t1}))
| SOME ts =>
let
- val us = Vector.map (ts, fromType)
+ val cts = Vector.map (ts, toCType)
in
- if Vector.forall (us, isSome)
- then finish (Vector.map (us, valOf))
+ if Vector.forall (cts, isSome)
+ then
+ finish (Vector.map2
+ (ts, cts, fn (ty, z) =>
+ let
+ val {ctype, name} = valOf z
+ in
+ {ctype = ctype,
+ name = name,
+ ty = ty}
+ end))
else NONE
end
end
@@ -719,35 +751,34 @@
fun import {attributes: Attribute.t list,
name: string,
ty: Type.t,
- region: Region.t}: Prim.t =
+ region: Region.t}: Type.t Prim.t =
let
fun error l = Control.error (region, l, Layout.empty)
fun invalidAttributes () =
error (seq [str "invalid attributes for import: ",
List.layout Attribute.layout attributes])
in
- case RepType.parse ty of
+ case Type.parse ty of
NONE =>
- (case RepType.fromType ty of
- NONE =>
- let
- val _ =
- Control.error
- (region,
- str "invalid type for import: ",
- Type.layoutPretty ty)
- in
- Prim.bogus
- end
- | SOME (t, _) =>
- case attributes of
- [] => Prim.ffiSymbol {name = name, ty = t}
+ if isSome (Type.toCType ty)
+ then
+ (case attributes of
+ [] => Prim.ffiSymbol {name = name, ty = ty}
| _ =>
let
- val _ = invalidAttributes ()
+ val () = invalidAttributes ()
in
Prim.bogus
end)
+ else
+ let
+ val () =
+ Control.error (region,
+ str "invalid type for import: ",
+ Type.layoutPretty ty)
+ in
+ Prim.bogus
+ end
| SOME (args, result) =>
let
val convention =
@@ -756,7 +787,7 @@
; Convention.Cdecl)
| SOME c => c
val func =
- CFunction.T {args = Vector.map (args, #1),
+ CFunction.T {args = Vector.map (args, #ty),
bytesNeeded = NONE,
convention = convention,
ensuresBytesFree = false,
@@ -766,8 +797,8 @@
maySwitchThreads = false,
name = name,
return = (case result of
- NONE => RepType.unit
- | SOME (t, _) => t)}
+ NONE => Type.unit
+ | SOME {ty, ...} => ty)}
in
Prim.ffi func
end
@@ -785,29 +816,27 @@
; Convention.Cdecl)
| SOME c => c
val (exportId, args, res) =
- case RepType.parse ty of
+ case Type.parse ty of
NONE =>
- (Control.error
- (region,
- seq [str "invalid type for exported function: ",
- Type.layoutPretty ty],
- Layout.empty)
+ (Control.error (region,
+ seq [str "invalid type for exported function: ",
+ Type.layoutPretty ty],
+ Layout.empty)
; (0, Vector.new0 (), NONE))
- | SOME (us, t) =>
+ | SOME (args, result) =>
let
val id =
- Ffi.addExport {args = Vector.map (us, RepType.toCType o #1),
+ Ffi.addExport {args = Vector.map (args, #ctype),
convention = convention,
name = name,
- res = Option.map (t, RepType.toCType o #1)}
+ res = Option.map (result, #ctype)}
in
- (id, us, t)
+ (id, args, result)
end
open Ast
fun id (name: string) =
Aexp.longvid (Longvid.short
- (Vid.fromSymbol (Symbol.fromString name,
- region)))
+ (Vid.fromSymbol (Symbol.fromString name, region)))
fun int (i: int): Aexp.t =
Aexp.const (Aconst.makeRegion (Aconst.Int (IntInf.fromInt i), region))
val f = Var.fromSymbol (Symbol.fromString "f", region)
@@ -829,9 +858,8 @@
val (args, decs) =
Vector.unzip
(Vector.map
- (args, fn (u, name) =>
+ (args, fn {ctype, name, ...} =>
let
- val u = RepType.toCType u
val x =
Var.fromSymbol
(Symbol.fromString
@@ -842,7 +870,7 @@
Dec.vall (Vector.new0 (),
x,
Exp.app (id (concat ["get", name]),
- int (Counter.next (map u))))
+ int (Counter.next (map ctype))))
in
(x, dec)
end))
@@ -861,7 +889,7 @@
(newVar (),
(case res of
NONE => Exp.constraint (Exp.var resVar, Type.unit)
- | SOME (_, name) =>
+ | SOME {name, ...} =>
Exp.app (id (concat ["set", name]),
Exp.var resVar)))),
fn (x, e) => Dec.vall (Vector.new0 (), x, e))],
@@ -1975,7 +2003,7 @@
targs = targs},
result)
end
- fun eta (p: Prim.t): Cexp.t =
+ fun eta (p: Type.t Prim.t): Cexp.t =
case Type.deArrowOpt expandedTy of
NONE =>
wrap (primApp {args = Vector.new0 (),
1.34 +15 -10 mlton/mlton/elaborate/type-env.fun
Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- type-env.fun 4 Apr 2004 06:50:21 -0000 1.33
+++ type-env.fun 12 Apr 2004 17:53:04 -0000 1.34
@@ -1172,7 +1172,13 @@
| UnifyResult.Unified => Unified
val word8 = word WordSize.byte
-
+
+ val synonyms =
+ List.map
+ ([(Tycon.char, Tycon.word WordSize.byte),
+ (Tycon.preThread, Tycon.thread)],
+ fn (c, c') => (c, c', con (c, Vector.new0 ())))
+
fun 'a simpleHom {con: t * Tycon.t * 'a vector -> 'a,
expandOpaque: bool,
record: t * (Field.t * 'a) vector -> 'a,
@@ -1217,15 +1223,14 @@
val real = default (real RealSize.default, Tycon.defaultReal)
val word = default (word WordSize.default, Tycon.defaultWord)
val con =
- fn (t, c, ts) =>
- if replaceSynonyms
- then if Tycon.equals (c, Tycon.char)
- then con (word8, Tycon.word WordSize.byte,
- Vector.new0 ())
- else if Tycon.equals (c, Tycon.preThread)
- then con (thread, Tycon.thread, Vector.new0 ())
- else con (t, c, ts)
- else con (t, c, ts)
+ if not replaceSynonyms
+ then con
+ else
+ fn (t, c, ts) =>
+ case List.peek (synonyms, fn (c', _, _) =>
+ Tycon.equals (c, c')) of
+ NONE => con (t, c, ts)
+ | SOME (_, c, t) => con (t, c, Vector.new0 ())
in
makeHom {con = con,
expandOpaque = expandOpaque,
1.12 +1 -1 mlton/mlton/ssa/analyze.sig
Index: analyze.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/analyze.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- analyze.sig 18 Mar 2004 03:22:25 -0000 1.11
+++ analyze.sig 12 Apr 2004 17:53:05 -0000 1.12
@@ -28,7 +28,7 @@
fromType: Type.t -> 'a,
layout: 'a -> Layout.t,
primApp: {args: 'a vector,
- prim: Prim.t,
+ prim: Type.t Prim.t,
resultType: Type.t,
resultVar: Var.t option,
targs: Type.t vector} -> 'a,
1.17 +3 -3 mlton/mlton/ssa/direct-exp.fun
Index: direct-exp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- direct-exp.fun 18 Feb 2004 04:24:10 -0000 1.16
+++ direct-exp.fun 12 Apr 2004 17:53:05 -0000 1.17
@@ -14,7 +14,7 @@
struct
datatype t =
- Arith of {prim: Prim.t,
+ Arith of {prim: Type.t Prim.t,
args: t vector,
overflow: t,
ty: Type.t}
@@ -43,14 +43,14 @@
| Let of {decs: {var: Var.t, exp: t} list,
body: t}
| Name of t * (Var.t -> t)
- | PrimApp of {prim: Prim.t,
+ | PrimApp of {prim: Type.t Prim.t,
targs: Type.t vector,
args: t vector,
ty: Type.t}
| Profile of ProfileExp.t
| Raise of t
| Runtime of {args: t vector,
- prim: Prim.t,
+ prim: Type.t Prim.t,
ty: Type.t}
| Select of {tuple: t,
offset: int,
1.14 +2 -2 mlton/mlton/ssa/direct-exp.sig
Index: direct-exp.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.sig,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- direct-exp.sig 18 Mar 2004 03:22:25 -0000 1.13
+++ direct-exp.sig 12 Apr 2004 17:53:05 -0000 1.14
@@ -27,7 +27,7 @@
| Int of IntSize.t * (IntX.t * t) vector
| Word of WordSize.t * (WordX.t * t) vector
- val arith: {prim: Prim.t,
+ val arith: {prim: Type.t Prim.t,
args: t vector,
overflow: t,
ty: Type.t} -> t
@@ -66,7 +66,7 @@
t * Return.Handler.t * Label.t -> Label.t * Block.t list
val name: t * (Var.t -> t) -> t
val primApp: {args: t vector,
- prim: Prim.t,
+ prim: Type.t Prim.t,
targs: Type.t vector,
ty: Type.t} -> t
val profile: ProfileExp.t -> t
1.19 +4 -2 mlton/mlton/ssa/redundant-tests.fun
Index: redundant-tests.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/redundant-tests.fun,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- redundant-tests.fun 18 Mar 2004 03:22:25 -0000 1.18
+++ redundant-tests.fun 12 Apr 2004 17:53:05 -0000 1.19
@@ -367,11 +367,13 @@
end)
val noChange = (statements, transfer)
fun arith (args: Var.t vector,
- prim: Prim.t,
+ prim: Type.t Prim.t,
success: Label.t)
: Statement.t vector * Transfer.t =
let
- fun simplify (prim: Prim.t, x: Var.t, s: IntSize.t) =
+ fun simplify (prim: Type.t Prim.t,
+ x: Var.t,
+ s: IntSize.t) =
let
val res = Var.newNoname ()
in
1.39 +15 -12 mlton/mlton/ssa/shrink.fun
Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink.fun,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- shrink.fun 4 Apr 2004 06:50:21 -0000 1.38
+++ shrink.fun 12 Apr 2004 17:53:05 -0000 1.39
@@ -172,15 +172,7 @@
end
end
-val traceApply =
- Trace.trace ("Prim.apply",
- fn (p, args, _: VarInfo.t * VarInfo.t -> bool) =>
- let open Layout
- in seq [Prim.layout p, str " ",
- List.layout (Prim.ApplyArg.layout
- (Var.layout o VarInfo.var)) args]
- end,
- Prim.ApplyResult.layout (Var.layout o VarInfo.var))
+val traceApplyInfo = Trace.info "Prim.apply"
fun shrinkFunction (globals: Statement.t vector) =
let
@@ -619,8 +611,8 @@
end
else ()
end) arg
- fun primApp (prim: Prim.t, args: VarInfo.t vector)
- : VarInfo.t Prim.ApplyResult.t =
+ fun primApp (prim: Type.t Prim.t, args: VarInfo.t vector)
+ : (Type.t, VarInfo.t) Prim.ApplyResult.t =
case Prim.name prim of
Prim.Name.FFI _ => Prim.ApplyResult.Unknown
| _ =>
@@ -642,7 +634,18 @@
| _ => Prim.ApplyArg.Var vi)
| _ => Prim.ApplyArg.Var vi)
in
- traceApply Prim.apply
+ Trace.traceInfo'
+ (traceApplyInfo,
+ fn (p, args, _) =>
+ let
+ open Layout
+ in
+ seq [Prim.layout p, str " ",
+ List.layout (Prim.ApplyArg.layout
+ (Var.layout o VarInfo.var)) args]
+ end,
+ Prim.ApplyResult.layout (Var.layout o VarInfo.var))
+ Prim.apply
(prim, Vector.toList args', VarInfo.equals)
handle e =>
Error.bug (concat ["Prim.apply raised ",
1.69 +3 -3 mlton/mlton/ssa/ssa-tree.fun
Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.68
retrieving revision 1.69
diff -u -r1.68 -r1.69
--- ssa-tree.fun 4 Apr 2004 06:50:21 -0000 1.68
+++ ssa-tree.fun 12 Apr 2004 17:53:06 -0000 1.69
@@ -210,7 +210,7 @@
ConApp of {con: Con.t,
args: Var.t vector}
| Const of Const.t
- | PrimApp of {prim: Prim.t,
+ | PrimApp of {prim: Type.t Prim.t,
targs: Type.t vector,
args: Var.t vector}
| Profile of ProfileExp.t
@@ -573,7 +573,7 @@
structure Transfer =
struct
datatype t =
- Arith of {prim: Prim.t,
+ Arith of {prim: Type.t Prim.t,
args: Var.t vector,
overflow: Label.t, (* Must be nullary. *)
success: Label.t, (* Must be unary. *)
@@ -589,7 +589,7 @@
args: Var.t vector}
| Raise of Var.t vector
| Return of Var.t vector
- | Runtime of {prim: Prim.t,
+ | Runtime of {prim: Type.t Prim.t,
args: Var.t vector,
return: Label.t} (* Must be nullary. *)
1.56 +5 -5 mlton/mlton/ssa/ssa-tree.sig
Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -r1.55 -r1.56
--- ssa-tree.sig 4 Apr 2004 06:50:21 -0000 1.55
+++ ssa-tree.sig 12 Apr 2004 17:53:07 -0000 1.56
@@ -82,7 +82,7 @@
con: Con.t}
| Const of Const.t
| PrimApp of {args: Var.t vector,
- prim: Prim.t,
+ prim: Type.t Prim.t,
targs: Type.t vector}
| Profile of ProfileExp.t
| Select of {offset: int,
@@ -142,7 +142,7 @@
datatype t =
Arith of {args: Var.t vector,
overflow: Label.t, (* Must be nullary. *)
- prim: Prim.t,
+ prim: Type.t Prim.t,
success: Label.t, (* Must be unary. *)
ty: Type.t} (* int or word *)
| Bug (* MLton thought control couldn't reach here. *)
@@ -160,7 +160,7 @@
| Raise of Var.t vector
| Return of Var.t vector
| Runtime of {args: Var.t vector,
- prim: Prim.t,
+ prim: Type.t Prim.t,
return: Label.t} (* Must be nullary. *)
val equals: t * t -> bool
@@ -254,9 +254,9 @@
val clear: t -> unit
val clearTop: t -> unit
- val foreachPrim: t * (Prim.t -> unit) -> unit
+ val foreachPrim: t * (Type.t Prim.t -> unit) -> unit
val foreachVar: t * (Var.t * Type.t -> unit) -> unit
- val hasPrim: t * (Prim.t -> bool) -> bool
+ val hasPrim: t * (Type.t Prim.t -> bool) -> bool
val layouts: t * (Layout.t -> unit) -> unit
val layoutStats: t -> Layout.t
val profile: t -> t
1.31 +2 -1 mlton/mlton/ssa/type-check.fun
Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/type-check.fun,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- type-check.fun 4 Apr 2004 06:50:21 -0000 1.30
+++ type-check.fun 12 Apr 2004 17:53:07 -0000 1.31
@@ -381,7 +381,8 @@
val () =
if Type.checkPrimApp {args = args,
prim = prim,
- result = resultType}
+ result = resultType,
+ targs = targs}
then ()
else error ("bad primapp",
let
1.15 +1 -1 mlton/mlton/xml/implement-exceptions.fun
Index: implement-exceptions.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/implement-exceptions.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- implement-exceptions.fun 3 Mar 2004 02:09:08 -0000 1.14
+++ implement-exceptions.fun 12 Apr 2004 17:53:08 -0000 1.15
@@ -54,7 +54,7 @@
let
val sumTycon = Tycon.newNoname ()
val sumType = Type.con (sumTycon, Vector.new0 ())
- fun find (nameString: string, isName: Prim.Name.t -> bool)
+ fun find (nameString: string, isName: Type.t Prim.Name.t -> bool)
: Var.t * Type.t * PrimExp.t =
let
val var =
1.16 +4 -4 mlton/mlton/xml/monomorphise.fun
Index: monomorphise.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/monomorphise.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- monomorphise.fun 24 Feb 2004 02:28:07 -0000 1.15
+++ monomorphise.fun 12 Apr 2004 17:53:08 -0000 1.16
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -306,9 +306,9 @@
handler = monoExp handler}
| XprimExp.Lambda l => SprimExp.Lambda (monoLambda l)
| XprimExp.PrimApp {prim, targs, args} =>
- SprimExp.PrimApp {prim = prim,
- targs = monoTypes targs,
- args = monoVarExps args}
+ SprimExp.PrimApp {args = monoVarExps args,
+ prim = Prim.map (prim, monoType),
+ targs = monoTypes targs}
| XprimExp.Profile e => SprimExp.Profile e
| XprimExp.Raise {exn, filePos} =>
SprimExp.Raise {exn = monoVarExp exn,
1.10 +1 -1 mlton/mlton/xml/simplify-types.fun
Index: simplify-types.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/simplify-types.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- simplify-types.fun 18 Feb 2004 04:24:24 -0000 1.9
+++ simplify-types.fun 12 Apr 2004 17:53:08 -0000 1.10
@@ -272,7 +272,7 @@
| I.PrimExp.Lambda l => O.PrimExp.Lambda (fixLambda l)
| I.PrimExp.PrimApp {args, prim, targs} =>
O.PrimExp.PrimApp {args = Vector.map (args, fixVarExp),
- prim = prim,
+ prim = Prim.map (prim, fixType),
targs = Vector.map (targs, fixType)}
| I.PrimExp.Profile e => O.PrimExp.Profile e
| I.PrimExp.Raise {exn, filePos} =>
1.17 +2 -1 mlton/mlton/xml/type-check.fun
Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/type-check.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- type-check.fun 4 Apr 2004 06:50:22 -0000 1.16
+++ type-check.fun 12 Apr 2004 17:53:08 -0000 1.17
@@ -229,7 +229,8 @@
val () =
if Type.checkPrimApp {args = checkVarExps args,
prim = prim,
- result = ty}
+ result = ty,
+ targs = targs}
then ()
else error "bad primapp"
in
1.20 +1 -1 mlton/mlton/xml/xml-tree.fun
Index: xml-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.fun,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- xml-tree.fun 18 Feb 2004 04:24:24 -0000 1.19
+++ xml-tree.fun 12 Apr 2004 17:53:08 -0000 1.20
@@ -174,7 +174,7 @@
handler: exp}
| Lambda of lambda
| PrimApp of {args: VarExp.t vector,
- prim: Prim.t,
+ prim: Type.t Prim.t,
targs: Type.t vector}
| Profile of ProfileExp.t
| Raise of {exn: VarExp.t,
1.14 +3 -3 mlton/mlton/xml/xml-tree.sig
Index: xml-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.sig,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- xml-tree.sig 9 Oct 2003 18:17:35 -0000 1.13
+++ xml-tree.sig 12 Apr 2004 17:53:08 -0000 1.14
@@ -103,7 +103,7 @@
try: exp}
| Lambda of Lambda.t
| PrimApp of {args: VarExp.t vector,
- prim: Prim.t,
+ prim: Type.t Prim.t,
targs: Type.t vector}
| Profile of ProfileExp.t
| Raise of {exn: VarExp.t,
@@ -167,7 +167,7 @@
val foreachPrimExp: t * (Var.t * Type.t * PrimExp.t -> unit) -> unit
val foreachVarExp: t * (VarExp.t -> unit) -> unit
val fromPrimExp: PrimExp.t * Type.t -> t
- val hasPrim: t * (Prim.t -> bool) -> bool
+ val hasPrim: t * (Type.t Prim.t -> bool) -> bool
val layout: t -> Layout.t
val make: {decs: Dec.t list, result: VarExp.t} -> t
val prefix: t * Dec.t -> t
@@ -211,7 +211,7 @@
val lett: {decs: Dec.t list, body: t} -> t
val monoVar: Var.t * Type.t -> t
val primApp: {args: t vector,
- prim: Prim.t,
+ prim: Type.t Prim.t,
targs: Type.t vector,
ty: Type.t} -> t
val raisee: {exn: t, filePos: string option} * Type.t -> t