[MLton-commit] r4890
Matthew Fluet
fluet at mlton.org
Thu Nov 30 20:35:10 PST 2006
Fixed a bug in elaboration of FFI forms; unary FFI types (e.g., array,
ref, vector) could be used in places where MLton.Pointer.t was
required. This would later cause the compiler to raise the TypeError
exception, along with a lot of XML IL.
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/doc/changelog
U mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.sig
U mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/elaborate-core.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/type-env.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/type-env.sig
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/doc/changelog
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/doc/changelog 2006-12-01 04:05:56 UTC (rev 4889)
+++ mlton/branches/on-20050822-x86_64-branch/doc/changelog 2006-12-01 04:35:07 UTC (rev 4890)
@@ -1,5 +1,11 @@
Here are the changes since version 20051202.
-
+
+* 2006-11-30
+ - Fixed a bug in elaboration of FFI forms; unary FFI types (e.g.,
+ array, ref, vector) could be used in places where MLton.Pointer.t was
+ required. This would later cause the compiler to raise the TypeError
+ exception, along with a lot of XML IL.
+
* 2006-08-03
- Fixed a bug in the "useless" SSA optimization, caused by calling
an imported C function and then ignoring the result.
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.fun 2006-12-01 04:05:56 UTC (rev 4889)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.fun 2006-12-01 04:35:07 UTC (rev 4890)
@@ -33,6 +33,7 @@
val isBool = fn c => equals (c, bool)
val isExn = fn c => equals (c, exn)
+val isPointer = fn c => equals (c, pointer)
local
fun 'a make (prefix: string,
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.sig 2006-12-01 04:05:56 UTC (rev 4889)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.sig 2006-12-01 04:35:07 UTC (rev 4890)
@@ -53,6 +53,7 @@
val isCharX: tycon -> bool
val isExn: tycon -> bool
val isIntX: tycon -> bool
+ val isPointer: tycon -> bool
val isRealX: tycon -> bool
val isWordX: tycon -> bool
val layoutApp:
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/elaborate-core.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/elaborate-core.fun 2006-12-01 04:05:56 UTC (rev 4889)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/elaborate-core.fun 2006-12-01 04:35:07 UTC (rev 4890)
@@ -785,9 +785,9 @@
then SOME {ctype = CType.pointer, name = "Pointer"}
else NONE
- fun toCType (t: t): {ctype: CType.t, name: string} option =
- case toNullaryCType t of
- NONE => toUnaryCType t
+ fun toCType (ty: t): {ctype: CType.t, name: string} option =
+ case toNullaryCType ty of
+ NONE => toUnaryCType ty
| SOME {ctype, name} => SOME {ctype = ctype, name = name}
val toCType =
@@ -802,46 +802,47 @@
type z = {ctype: CType.t, name: string, ty: t}
- fun parse (ty: t): (z vector * z option) option =
+ fun toCBaseType (ty: t): z option =
+ case toCType ty of
+ NONE => NONE
+ | SOME {ctype, name} =>
+ SOME {ctype = ctype, name = name, ty = ty}
+ fun toCArgType (ty: t): z vector option =
+ case deTupleOpt ty of
+ NONE =>
+ (case toCBaseType ty of
+ NONE => NONE
+ | SOME z => SOME (Vector.new1 z))
+ | SOME tys =>
+ Exn.withEscape
+ (fn esc =>
+ (SOME o Vector.map)
+ (tys, fn ty =>
+ case toCBaseType ty of
+ NONE => esc NONE
+ | SOME z => z))
+ fun toCRetType (ty: t): z option option =
+ case toCBaseType ty of
+ NONE => if Type.isUnit ty
+ then SOME NONE
+ else NONE
+ | SOME z => SOME (SOME z)
+ fun toCFunType (ty: t): (z vector * z option) option =
case deArrowOpt ty of
NONE => NONE
- | SOME (t1, t2) =>
- let
- fun finish (ts: z vector) =
- case toCType t2 of
- NONE =>
- if Type.isUnit t2
- then SOME (ts, NONE)
- else NONE
- | SOME {ctype, name} =>
- SOME (ts, SOME {ctype = ctype, name = name, ty = t2})
- in
- case deTupleOpt t1 of
- NONE =>
- (case toCType t1 of
- NONE => NONE
- | SOME {ctype, name} =>
- finish (Vector.new1 {ctype = ctype,
- name = name,
- ty = t1}))
- | SOME ts =>
- let
- val cts = Vector.map (ts, toCType)
- in
- 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
+ | SOME (arg, ret) =>
+ (case toCArgType arg of
+ NONE => NONE
+ | SOME arg =>
+ (case toCRetType ret of
+ NONE => NONE
+ | SOME ret => SOME (arg, ret)))
+ fun toCPtrType (ty: t): z option =
+ if Type.isPointer ty
+ then let val {ctype, name} = valOf (toCType ty)
+ in SOME {ctype = ctype, name = name, ty = ty}
+ end
+ else NONE
end
fun parseIEAttributes (attributes: ImportExportAttribute.t list): Convention.t option =
@@ -879,7 +880,7 @@
str "invalid type for _import",
Type.layoutPretty elabedTy)
in
- case Type.parse expandedTy of
+ case Type.toCFunType expandedTy of
NONE =>
let
val () = invalidType ()
@@ -1042,11 +1043,11 @@
Control.error
(region, str "invalid type for _address",
Type.layoutPretty elabedTy)
+ val () =
+ case Type.toCPtrType expandedTy of
+ NONE => (error (); ())
+ | SOME _ => ()
val expandedPtrTy = expandedTy
- val () =
- case Type.toCType expandedPtrTy of
- SOME {ctype = CType.Pointer, ...} => ()
- | _ => (error (); ())
val addrExp =
mkAddress {expandedPtrTy = expandedPtrTy,
name = name,
@@ -1106,9 +1107,9 @@
end
end)
val ctypeCbTy =
- case Type.toCType expandedCbTy of
- SOME {ctype, ...} => ctype
- | NONE => (error (); CType.word (WordSize.default, {signed = false}))
+ case Type.toCBaseType expandedCbTy of
+ NONE => (error (); CType.word (WordSize.default, {signed = false}))
+ | SOME {ctype, ...} => ctype
val addrExp =
mkAddress {expandedPtrTy = Type.word (WordSize.pointer ()),
name = name,
@@ -1178,13 +1179,13 @@
end)
end)
val ctypeCbTy =
- case Type.toCType expandedCbTy of
- SOME {ctype, ...} => ctype
- | NONE => (error (); CType.word (WordSize.default, {signed = false}))
+ case Type.toCBaseType expandedCbTy of
+ NONE => (error (); CType.word (WordSize.default, {signed = false}))
+ | SOME {ctype, ...} => ctype
val () =
- case Type.toCType expandedPtrTy of
- SOME {ctype = CType.Pointer, ...} => ()
- | _ => (error (); ())
+ case Type.toCPtrType expandedPtrTy of
+ NONE => (error (); ())
+ | SOME _ => ()
val ptrArg = Var.newNoname ()
val ptrExp = Cexp.var (ptrArg, expandedPtrTy)
val symExp =
@@ -1227,9 +1228,9 @@
Type.layoutPretty elabedTy)
val expandedCbTy = expandedTy
val ctypeCbTy =
- case Type.toCType expandedCbTy of
- SOME {ctype, ...} => ctype
- | NONE => (error (); CType.word (WordSize.default, {signed = false}))
+ case Type.toCBaseType expandedCbTy of
+ NONE => (error (); CType.word (WordSize.default, {signed = false}))
+ | SOME {ctype, ...} => ctype
val isBool = Type.isBool expandedCbTy
val addrExp =
mkAddress {expandedPtrTy = Type.word (WordSize.pointer ()),
@@ -1266,7 +1267,7 @@
; Convention.Cdecl)
| SOME c => c
val (exportId, args, res) =
- case Type.parse expandedTy of
+ case Type.toCFunType expandedTy of
NONE =>
(invalidType ()
; (0, Vector.new0 (), NONE))
@@ -2821,9 +2822,9 @@
| SOME (fptrTy, cfTy) => (fptrTy, cfTy)
end)
val () =
- case Type.toCType expandedFPtrTy of
- SOME {ctype = CType.Pointer, ...} => ()
- | _ => (error (); ())
+ case Type.toCPtrType expandedFPtrTy of
+ NONE => (error (); ())
+ | SOME _ => ()
val fptr = Var.newNoname ()
val fptrArg = Cexp.var (fptr, expandedFPtrTy)
in
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/type-env.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/type-env.fun 2006-12-01 04:05:56 UTC (rev 4889)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/type-env.fun 2006-12-01 04:35:07 UTC (rev 4890)
@@ -797,6 +797,11 @@
| Overload Overload.Int => true
| _ => false
+ fun isPointer t =
+ case toType t of
+ Con (c, _) => Tycon.isPointer c
+ | _ => false
+
fun isUnit t =
case toType t of
Record r =>
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/type-env.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/type-env.sig 2006-12-01 04:05:56 UTC (rev 4889)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/type-env.sig 2006-12-01 04:35:07 UTC (rev 4890)
@@ -42,6 +42,7 @@
val isCharX: t -> bool
val isExn: t -> bool
val isInt: t -> bool
+ val isPointer: t -> bool
val isUnit: t -> bool
val layout: t -> Layout.t
val layoutPretty: t -> Layout.t
More information about the MLton-commit
mailing list