[MLton-commit] r5113
Matthew Fluet
fluet at mlton.org
Fri Feb 2 11:36:42 PST 2007
Merge trunk revisions 4991:5073 into x86_64 branch
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/basis-library/build/sources.mlb
U mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-2002/top-level/basis.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis-sigs.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/mlton.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/mlton.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/mono-array.sig
A mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/mono-vector.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton.mlb
U mlton/branches/on-20050822-x86_64-branch/doc/changelog
U mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-mlb-mode.el
U mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/c.mlb
U mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/internals/c-int.mlb
U mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/internals/c-int.sml
U mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/memory/linkage-libdl.sml
U mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/memory/memory.32bit-unix.mlb
U mlton/branches/on-20050822-x86_64-branch/mlton/ast/ast-mlbs.fun
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/ast/sources.cm
U mlton/branches/on-20050822-x86_64-branch/mlton/ast/sources.mlb
U mlton/branches/on-20050822-x86_64-branch/mlton/atoms/hash-type.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/atoms/tycon.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/control/control-flags.sig
U mlton/branches/on-20050822-x86_64-branch/mlton/control/control-flags.sml
U mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/elaborate-core.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/elaborate-env.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/interface.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/interface.sig
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
U mlton/branches/on-20050822-x86_64-branch/mlton/front-end/mlb-front-end.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/main/compile.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/ssa/ssa-tree2.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/xml/monomorphise.fun
U mlton/branches/on-20050822-x86_64-branch/runtime/util/safe.h
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/build/sources.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/build/sources.mlb 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/build/sources.mlb 2007-02-02 19:35:19 UTC (rev 5113)
@@ -354,6 +354,8 @@
../mlton/word.sig
../mlton/world.sig
../mlton/world.sml
+ ../mlton/mono-array.sig
+ ../mlton/mono-vector.sig
../mlton/mlton.sig
../mlton/mlton.sml
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-2002/top-level/basis.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-2002/top-level/basis.sig 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-2002/top-level/basis.sig 2007-02-02 19:35:19 UTC (rev 5113)
@@ -218,8 +218,12 @@
structure PackReal64Little : PACK_REAL
structure PackRealBig : PACK_REAL
structure PackRealLittle : PACK_REAL
+ structure PackWord16Big : PACK_WORD
+ structure PackWord16Little : PACK_WORD
structure PackWord32Big : PACK_WORD
structure PackWord32Little : PACK_WORD
+ structure PackWord64Big : PACK_WORD
+ structure PackWord64Little : PACK_WORD
structure Posix : POSIX
structure Real32 : REAL
structure Real32Array : MONO_ARRAY
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis-sigs.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis-sigs.sml 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis-sigs.sml 2007-02-02 19:35:19 UTC (rev 5113)
@@ -92,6 +92,8 @@
signature MLTON_INT_INF = MLTON_INT_INF
signature MLTON_IO = MLTON_IO
signature MLTON_ITIMER = MLTON_ITIMER
+signature MLTON_MONO_ARRAY = MLTON_MONO_ARRAY
+signature MLTON_MONO_VECTOR = MLTON_MONO_VECTOR
signature MLTON_PLATFORM = MLTON_PLATFORM
signature MLTON_POINTER = MLTON_POINTER
signature MLTON_PROC_ENV = MLTON_PROC_ENV
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis.sig 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis.sig 2007-02-02 19:35:19 UTC (rev 5113)
@@ -218,8 +218,12 @@
structure PackReal64Little : PACK_REAL
structure PackRealBig : PACK_REAL
structure PackRealLittle : PACK_REAL
+ structure PackWord16Big : PACK_WORD
+ structure PackWord16Little : PACK_WORD
structure PackWord32Big : PACK_WORD
structure PackWord32Little : PACK_WORD
+ structure PackWord64Big : PACK_WORD
+ structure PackWord64Little : PACK_WORD
structure Posix : POSIX
structure Real32 : REAL
structure Real32Array : MONO_ARRAY
@@ -622,6 +626,8 @@
sharing type MLton.BinIO.outstream = BinIO.outstream
sharing type MLton.TextIO.instream = TextIO.instream
sharing type MLton.TextIO.outstream = TextIO.outstream
+ sharing type MLton.Word8Array.t = Word8Array.array
+ sharing type MLton.Word8Vector.t = Word8Vector.vector
end
(* bool is already defined as bool and so cannot be shared.
* So, we where these to get the needed sharing.
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis.sml 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis.sml 2007-02-02 19:35:19 UTC (rev 5113)
@@ -147,8 +147,12 @@
structure PackReal64Little = PackReal64Little
structure PackRealBig = PackRealBig
structure PackRealLittle = PackRealLittle
+ structure PackWord16Big = PackWord16Big
+ structure PackWord16Little = PackWord16Little
structure PackWord32Big = PackWord32Big
structure PackWord32Little = PackWord32Little
+ structure PackWord64Big = PackWord64Big
+ structure PackWord64Little = PackWord64Little
structure Posix = Posix
structure Real32 = Real32
structure Real32Array = Real32Array
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/mlton.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/mlton.sig 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/mlton.sig 2007-02-02 19:35:19 UTC (rev 5113)
@@ -50,5 +50,7 @@
structure Weak: MLTON_WEAK
structure Word: MLTON_WORD
structure Word8: MLTON_WORD
+ structure Word8Array: MLTON_MONO_ARRAY
+ structure Word8Vector: MLTON_MONO_VECTOR
structure World: MLTON_WORLD
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/mlton.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/mlton.sml 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/mlton.sml 2007-02-02 19:35:19 UTC (rev 5113)
@@ -81,6 +81,16 @@
type t = word
end
+structure Word8Array = struct
+ open Word8Array
+ type t = array
+end
+
+structure Word8Vector = struct
+ open Word8Vector
+ type t = vector
+end
+
val _ =
(Primitive.TopLevel.setHandler MLtonExn.topLevelHandler
; Primitive.TopLevel.setSuffix
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/mono-array.sig (from rev 5073, mlton/trunk/basis-library/mlton/mono-array.sig)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/mono-vector.sig (from rev 5073, mlton/trunk/basis-library/mlton/mono-vector.sig)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton.mlb 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton.mlb 2007-02-02 19:35:19 UTC (rev 5113)
@@ -24,6 +24,8 @@
signature MLTON_INT_INF
signature MLTON_IO
signature MLTON_ITIMER
+ signature MLTON_MONO_ARRAY
+ signature MLTON_MONO_VECTOR
signature MLTON_PLATFORM
signature MLTON_POINTER
signature MLTON_PROC_ENV
Modified: mlton/branches/on-20050822-x86_64-branch/doc/changelog
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/doc/changelog 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/doc/changelog 2007-02-02 19:35:19 UTC (rev 5113)
@@ -1,5 +1,15 @@
Here are the changes since version 20051202.
+* 2006-12-29
+ - Added command line switch -show {anns|path-map} and deprecated command
+ line switch -show-anns {false|true}. Use -show path-map to see the
+ complete MLB path map as seen by the compiler.
+
+* 2006-12-20
+ - Changed the output of command line switch -stop f to include mlb-files.
+ This is useful for generating Makefile dependencies. The old output is
+ easy to recover if necessary (e.g. grep -v '\.mlb$').
+
* 2006-12-8
- Added command line switches -{,target}-{as,cc,link}-opt-quote, which
pass their argument as a single argument to gcc (i.e., without
Modified: mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-mlb-mode.el
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-mlb-mode.el 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-mlb-mode.el 2007-02-02 19:35:19 UTC (rev 5113)
@@ -38,6 +38,10 @@
;; - find-binding-occurance (of a basid)
;; - support doc strings in mlb files
+;; TBD:
+;; - fix indentation bugs
+;; - use something more robust than `shell-command' to run shell commands
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Prelude
@@ -57,27 +61,18 @@
Unrecognized
- annotations (see `esml-mlb-show-annotations-command' and
`esml-mlb-additional-annotations'),
-- path variables (see `esml-mlb-mlb-path-map-files' and
+- path variables (see `esml-mlb-show-path-map-command',
+ `esml-mlb-mlb-path-map-files', and
`esml-mlb-additional-path-variables'), and
- path name suffices (see `esml-mlb-path-suffix-regexp') are
highlighed as warnings."
:group 'sml)
(defcustom esml-mlb-additional-annotations
- '(("allowConstant" "false" "true")
- ("allowFFI" "false" "true")
- ("allowOverload" "false" "true")
- ("allowPrim" "false" "true")
- ("allowRebindEquals" "false" "true")
- ("deadCode" "false" "true")
- ("ffiStr" "<longstrid>")
- ("forceUsed")
- ("nonexhaustiveExnMatch" "default" "ignore")
- ("nonexhaustiveMatch" "warn" "ignore" "error")
- ("redundantMatch" "warn" "ignore" "error")
- ("sequenceNonUnit" "ignore" "error" "warn")
- ("warnUnused" "false" "true"))
- "Additional annotations accepted by your compiler(s)."
+ '()
+ "Additional annotations accepted by your compiler(s). Note that ML
+Basis mode runs the `esml-mlb-show-annotations-command' to query available
+annotations automatically."
:type '(repeat (cons :tag "Annotation"
(string :tag "Name")
(repeat :tag "Values starting with the default"
@@ -86,9 +81,10 @@
:group 'esml-mlb)
(defcustom esml-mlb-additional-path-variables
- '(("LIB_MLTON_DIR" . "/usr/lib/mlton"))
+ '()
"Additional path variables that can not be found in the path map files
-specified by `esml-mlb-mlb-path-map-files'."
+specified by `esml-mlb-mlb-path-map-files' or by running the command
+`esml-mlb-show-path-map-command'."
:type '(repeat (cons (string :tag "Name") (string :tag "Value")))
:set 'esml-mlb-set-custom-and-update
:group 'esml-mlb)
@@ -135,8 +131,8 @@
:group 'esml-mlb)
(defcustom esml-mlb-show-annotations-command
- "mlton -expert true -show-anns true"
- "Shell command used to determine the annotations accepted by a compiler."
+ "mlton -expert true -show anns"
+ "Shell command used to query the available annotations."
:type 'string
:set 'esml-mlb-set-custom-and-update
:group 'esml-mlb)
@@ -149,6 +145,13 @@
:type 'string
:group 'esml-mlb)
+(defcustom esml-mlb-show-path-map-command
+ "mlton -expert true -show path-map"
+ "Shell command used to query the available path variables."
+ :type 'string
+ :set 'esml-mlb-set-custom-and-update
+ :group 'esml-mlb)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Faces
@@ -195,21 +198,28 @@
"An association list of known path variables. This variable is updated
by `esml-mlb-update'.")
+(defun esml-mlb-parse-path-variables-from-string (path-map-string)
+ (mapcar (function
+ (lambda (s) (apply 'cons (esml-split-string s "[ \t]+"))))
+ (esml-split-string path-map-string "[ \t]*\n+[ \t]*")))
+
(defun esml-mlb-parse-path-variables ()
(setq esml-mlb-path-variables
(remove-duplicates
(sort (append
esml-mlb-additional-path-variables
+ (esml-mlb-parse-path-variables-from-string
+ (with-temp-buffer
+ (save-window-excursion
+ (shell-command
+ esml-mlb-show-path-map-command
+ (current-buffer))
+ (buffer-string))))
(loop for file in esml-mlb-mlb-path-map-files
- append (mapcar (function
- (lambda (s)
- (apply 'cons
- (esml-split-string s "[ \t]+"))))
- (esml-split-string
- (with-temp-buffer
- (insert-file-contents file)
- (buffer-string))
- "[ \t]*\n+[ \t]*"))))
+ append (esml-mlb-parse-path-variables-from-string
+ (with-temp-buffer
+ (insert-file-contents file)
+ (buffer-string)))))
(function
(lambda (a b)
(string-lessp (car a) (car b)))))
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/c.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/c.mlb 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/c.mlb 2007-02-02 19:35:19 UTC (rev 5113)
@@ -14,21 +14,27 @@
*
* author: Matthias Blume (blume at research.bell-labs.com)
*)
-local
- internals/c-int.mlb
+ann
+ "forceUsed"
+ "sequenceNonUnit warn"
+ "warnUnused true"
in
- structure Tag
+ local
+ internals/c-int.mlb
+ in
+ structure Tag
- structure MLRep
+ structure MLRep
- signature C
- structure C
- signature C_DEBUG
- structure C_Debug
+ signature C
+ structure C
+ signature C_DEBUG
+ structure C_Debug
- signature ZSTRING
- structure ZString
+ signature ZSTRING
+ structure ZString
- signature DYN_LINKAGE
- structure DynLinkage
+ signature DYN_LINKAGE
+ structure DynLinkage
+ end
end
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/internals/c-int.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/internals/c-int.mlb 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/internals/c-int.mlb 2007-02-02 19:35:19 UTC (rev 5113)
@@ -2,34 +2,42 @@
$(SML_LIB)/basis/basis.mlb
../memory/memory.mlb
+in
+ ann
+ "forceUsed"
+ "sequenceNonUnit warn"
+ "warnUnused true"
+ in
+ local
+ ../c.sig
+ ../c-debug.sig
+ c-int.sig
+ c-int.sml
+ c.sml
+ c-debug.sml
- ../c.sig
- ../c-debug.sig
- c-int.sig
- c-int.sml
- c.sml
- c-debug.sml
+ ../zstring.sig
+ zstring.sml
+ tag.sml
+ in
+ structure Tag
- ../zstring.sig
- zstring.sml
- tag.sml
-in
- structure Tag
+ structure MLRep
+ signature C
+ structure C
+ signature C_INT
+ structure C_Int
+ signature C_DEBUG
+ structure C_Debug
- structure MLRep
- signature C
- structure C
- signature C_INT
- structure C_Int
- signature C_DEBUG
- structure C_Debug
+ signature ZSTRING
+ structure ZString
- signature ZSTRING
- structure ZString
+ signature DYN_LINKAGE
+ structure DynLinkage
- signature DYN_LINKAGE
- structure DynLinkage
-
- signature CMEMORY
- structure CMemory
+ signature CMEMORY
+ structure CMemory
+ end
+ end
end
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/internals/c-int.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/internals/c-int.sml 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/internals/c-int.sml 2007-02-02 19:35:19 UTC (rev 5113)
@@ -45,7 +45,9 @@
type cword = MLRep.Int.Unsigned.word
type bf = { a: addr, l: word, r: word, lr: word, m: cword, im: cword }
+(*
fun pair_type_addr (t: 'f objt) (a: addr) = (a, t)
+*)
fun strip_type (a: addr, _: 'f objt) = a
fun p_strip_type (a: addr, _: 'f objt) = a
fun strip_fun (a: addr, _: 'f) = a
@@ -62,7 +64,9 @@
val op ~>> = MLRep.Int.Unsigned.~>>
val op && = MLRep.Int.Unsigned.andb
val op || = MLRep.Int.Unsigned.orb
+(*
val op ^^ = MLRep.Int.Unsigned.xorb
+*)
val ~~ = MLRep.Int.Unsigned.notb
in
@@ -168,7 +172,7 @@
fn w => fn x => w x
val convert' : (('st, 'sc) obj, ('tt, 'tc) obj) W.witness ->
('st, 'sc) obj' -> ('tt, 'tc) obj' =
- fn w => fn x => x
+ fn _ => fn x => x
(*
* A family of types and corresponding values representing natural numbers.
@@ -399,9 +403,9 @@
local
val u2s = MLRep.Int.Signed.fromLarge o MLRep.Int.Unsigned.toLargeIntX
in
- fun ubf ({ a, l, r, lr, m, im } : bf) =
+ fun ubf ({ a, l, r=_, lr, m=_, im=_ } : bf) =
(CMemory.load_uint a << l) >> lr
- fun sbf ({ a, l, r, lr, m, im } : bf) =
+ fun sbf ({ a, l, r=_, lr, m=_, im=_ } : bf) =
u2s ((CMemory.load_uint a << l) ~>> lr)
end
end
@@ -455,7 +459,7 @@
fn (x, p) => ptr_voidptr' (p_strip_type x, p)
end
- fun ubf ({ a, l, r, lr, m, im }, x) =
+ fun ubf ({ a, l=_, r, lr=_, m, im }, x) =
CMemory.store_uint (a, (CMemory.load_uint a && im) ||
((x << r) && m))
@@ -498,7 +502,7 @@
val inject : 'o ptr -> voidptr = p_strip_type
val cast : 'o ptr T.typ -> voidptr -> 'o ptr =
- fn PTR (null, t) => (fn p => (p, t))
+ fn PTR (_, t) => (fn p => (p, t))
| _ => bug "Ptr.cast (non-pointer-type)"
val vnull : voidptr = CMemory.null
@@ -526,7 +530,7 @@
fn ((p, t as PTR (_, t')), i) => (|+! (T.sizeof t') (p, i), t)
| _ => bug "Ptr.|+| (non-pointer-type)"
val |-| : ('t, 'c) obj ptr * ('t, 'c) obj ptr -> int =
- fn ((p, t as PTR (_, t')), (p', _)) => |-! (T.sizeof t') (p, p')
+ fn ((p, PTR (_, t')), (p', _)) => |-! (T.sizeof t') (p, p')
| _ => bug "Ptr.|-| (non-pointer-type"
val sub : ('t, 'c) obj ptr * int -> ('t, 'c) obj =
@@ -539,7 +543,7 @@
fn w => fn x => w x
val convert' : (('st, 'sc) obj ptr, ('tt, 'tc) obj ptr) W.witness ->
('st, 'sc) obj ptr' -> ('tt, 'tc) obj ptr' =
- fn w => fn x => x
+ fn _ => fn x => x
val ro : ('t, 'c) obj ptr -> ('t, ro) obj ptr =
fn x => convert (W.pointer (W.ro W.trivial)) x
@@ -577,7 +581,7 @@
fn ((a, PTR (_, t)), d) => (a, T.arr (t, d))
| _ => bug "Arr.reconstruct (non-pointer)"
- fun reconstruct' (a: addr, d: 'n Dim.dim) = a
+ fun reconstruct' (a: addr, _: 'n Dim.dim) = a
fun dim (_: addr, t) = T.dim t
end
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/memory/linkage-libdl.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/memory/linkage-libdl.sml 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/memory/linkage-libdl.sml 2007-02-02 19:35:19 UTC (rev 5113)
@@ -99,8 +99,9 @@
end
(* label used for CleanUp *)
+(*
val label = "DynLinkNewEra"
-
+*)
(* generate a new "era" indicator *)
fun newEra () = ref ()
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/memory/memory.32bit-unix.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/memory/memory.32bit-unix.mlb 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlnlffi/memory/memory.32bit-unix.mlb 2007-02-02 19:35:19 UTC (rev 5113)
@@ -1,25 +1,33 @@
local
$(SML_LIB)/basis/basis.mlb
$(SML_LIB)/basis/mlton.mlb
-
- linkage.sig
- ann "allowFFI true" in
- linkage-libdl.sml
+in
+ ann
+ "forceUsed"
+ "sequenceNonUnit warn"
+ "warnUnused true"
+ in
+ local
+ linkage.sig
+ ann "allowFFI true" in
+ linkage-libdl.sml
+ end
+ bitop-fn.sml
+ mlrep-i8i16i32i32i64f32f64.sml
+ memaccess.sig
+ memaccess-a4c1s2i4l4ll8f4d8.sml
+ memalloc.sig
+ ann "allowFFI true" in
+ memalloc-a4-unix.sml
+ end
+ memory.sig
+ memory.sml
+ in
+ signature CMEMORY
+ structure CMemory
+ signature DYN_LINKAGE
+ structure DynLinkage
+ structure MLRep
+ end
end
- bitop-fn.sml
- mlrep-i8i16i32i32i64f32f64.sml
- memaccess.sig
- memaccess-a4c1s2i4l4ll8f4d8.sml
- memalloc.sig
- ann "allowFFI true" in
- memalloc-a4-unix.sml
- end
- memory.sig
- memory.sml
-in
- signature CMEMORY
- structure CMemory
- signature DYN_LINKAGE
- structure DynLinkage
- structure MLRep
end
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/ast/ast-mlbs.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/ast/ast-mlbs.fun 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/ast-mlbs.fun 2007-02-02 19:35:19 UTC (rev 5113)
@@ -128,7 +128,8 @@
else let
val () = b := true
in
- sourceFilesBasdec (Promise.force dec)
+ Buffer.add (sourceFiles, fileAbs)
+ ; sourceFilesBasdec (Promise.force dec)
end
end
| Open _ => ()
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 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.fun 2007-02-02 19:35:19 UTC (rev 5113)
@@ -11,30 +11,42 @@
open S
+structure BindingStrength =
+ struct
+ datatype t =
+ Arrow
+ | Tuple
+ | Unit
+
+ val arrow = Arrow
+ val tuple = Tuple
+ val unit = Unit
+ end
+
datatype z = datatype RealSize.t
type tycon = t
-val array = fromString "array"
-val arrow = fromString "->"
-val bool = fromString "bool"
-val exn = fromString "exn"
-val intInf = fromString "intInf"
-val list = fromString "list"
-val pointer = fromString "pointer"
-val reff = fromString "ref"
-val thread = fromString "thread"
-val tuple = fromString "*"
-val vector = fromString "vector"
-val weak = fromString "weak"
+local
+ fun make s = (s, fromString s)
+in
+ val array = make "array"
+ val arrow = make "->"
+ val bool = make "bool"
+ val exn = make "exn"
+ val intInf = make "intInf"
+ val list = make "list"
+ val pointer = make "pointer"
+ val reff = make "ref"
+ val thread = make "thread"
+ val tuple = make "*"
+ val vector = make "vector"
+ val weak = make "weak"
+end
datatype z = datatype Kind.t
datatype z = datatype AdmitsEquality.t
-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,
all: 'a list,
@@ -45,22 +57,31 @@
let
val all =
Vector.fromListMap
- (all, fn s =>
- (fromString (concat [prefix, Bits.toString (bits s)]), s))
+ (all, fn s => let
+ val name = concat [prefix, Bits.toString (bits s)]
+ in
+ {name = name,
+ size = s,
+ tycon = fromString name}
+ end)
val fromSize =
memo
(fn s =>
- case Vector.peek (all, fn (_, s') => equalsA (s, s')) of
+ case Vector.peek (all, fn {size = s', ...} => equalsA (s, s')) of
NONE => Error.bug "PrimTycons.make.fromSize"
- | SOME (tycon, _) => tycon)
- fun is t = Vector.exists (all, fn (t', _) => equals (t, t'))
+ | SOME {tycon, ...} => tycon)
+ fun is t = Vector.exists (all, fn {tycon = t', ...} => equals (t, t'))
fun de t =
- case Vector.peek (all, fn (t', _) => equals (t, t')) of
+ case Vector.peek (all, fn {tycon = t', ...} => equals (t, t')) of
NONE => Error.bug "PrimTycons.make.de"
- | SOME (_, s') => s'
+ | SOME {size, ...} => size
val prims =
- Vector.toListMap (all, fn (tycon, _) =>
- (tycon, Arity 0, admitsEquality))
+ Vector.toListMap (all, fn {name, tycon, ...} =>
+ {admitsEquality = admitsEquality,
+ kind = Arity 0,
+ name = name,
+ tycon = tycon})
+ val all = Vector.map (all, fn {tycon, size, ...} => (tycon, size))
in
(fromSize, all, is, de, prims)
end
@@ -91,6 +112,39 @@
end
end
+val prims =
+ List.map ([(array, Arity 1, Always),
+ (arrow, Arity 2, Never),
+ (bool, Arity 0, Sometimes),
+ (exn, Arity 0, Never),
+ (intInf, Arity 0, Sometimes),
+ (list, Arity 1, Sometimes),
+ (pointer, Arity 0, Always),
+ (reff, Arity 1, Always),
+ (thread, Arity 0, Never),
+ (tuple, Nary, Sometimes),
+ (vector, Arity 1, Sometimes),
+ (weak, Arity 1, Never)],
+ fn ((name, tycon), kind, admitsEquality) =>
+ {admitsEquality = admitsEquality,
+ kind = kind,
+ name = name,
+ tycon = tycon})
+ @ primChars @ primInts @ primReals @ primWords
+
+val array = #2 array
+val arrow = #2 arrow
+val bool = #2 bool
+val exn = #2 exn
+val intInf = #2 intInf
+val list = #2 list
+val pointer = #2 pointer
+val reff = #2 reff
+val thread = #2 thread
+val tuple = #2 tuple
+val vector = #2 vector
+val weak = #2 weak
+
val defaultChar = fn () =>
case !Control.defaultChar of
"char8" => char CharSize.C8
@@ -116,26 +170,15 @@
| "word64" => word (WordSize.fromBits (Bits.fromInt 64))
| _ => Error.bug "PrimTycons.defaultWord"
+val isBool = fn c => equals (c, bool)
+val isExn = fn c => equals (c, exn)
+val isPointer = fn c => equals (c, pointer)
val isIntX = fn c => equals (c, intInf) orelse isIntX c
val deIntX = fn c => if equals (c, intInf) then NONE else SOME (deIntX c)
-val prims =
- [(array, Arity 1, Always),
- (arrow, Arity 2, Never),
- (bool, Arity 0, Sometimes),
- (exn, Arity 0, Never),
- (intInf, Arity 0, Sometimes),
- (list, Arity 1, Sometimes),
- (pointer, Arity 0, Always),
- (reff, Arity 1, Always),
- (thread, Arity 0, Never),
- (tuple, Nary, Sometimes),
- (vector, Arity 1, Sometimes),
- (weak, Arity 1, Never)]
- @ primChars @ primInts @ primReals @ primWords
-
fun layoutApp (c: t,
- args: (Layout.t * {isChar: bool, needsParen: bool}) vector) =
+ args: (Layout.t * ({isChar: bool}
+ * BindingStrength.t)) vector) =
let
local
open Layout
@@ -144,37 +187,52 @@
val seq = seq
val str = str
end
- fun maybe (l, {isChar = _, needsParen}) =
- if needsParen
- then Layout.paren l
- else l
+ datatype z = datatype BindingStrength.t
+ datatype binding_context =
+ ArrowLhs
+ | ArrowRhs
+ | TupleElem
+ | Tyseq1
+ | TyseqN
+ fun maybe bindingContext (l, ({isChar = _}, bindingStrength)) =
+ case (bindingStrength, bindingContext) of
+ (Unit, _) => l
+ | (Tuple, ArrowLhs) => l
+ | (Tuple, ArrowRhs) => l
+ | (Tuple, TyseqN) => l
+ | (Arrow, ArrowRhs) => l
+ | (Arrow, TyseqN) => l
+ | _ => Layout.paren l
fun normal () =
let
val ({isChar}, lay) =
case Vector.length args of
0 => ({isChar = equals (c, defaultChar ())}, layout c)
| 1 => ({isChar = false},
- seq [maybe (Vector.sub (args, 0)), str " ", layout c])
+ seq [maybe Tyseq1 (Vector.sub (args, 0)),
+ str " ", layout c])
| _ => ({isChar = false},
- seq [Layout.tuple (Vector.toListMap (args, maybe)),
+ seq [Layout.tuple
+ (Vector.toListMap (args, maybe TyseqN)),
str " ", layout c])
in
- (lay, {isChar = isChar, needsParen = false})
+ (lay, ({isChar = isChar}, Unit))
end
in
if equals (c, arrow)
- then (mayAlign [maybe (Vector.sub (args, 0)),
- seq [str "-> ", maybe (Vector.sub (args, 1))]],
- {isChar = false, needsParen = true})
+ then (mayAlign [maybe ArrowLhs (Vector.sub (args, 0)),
+ seq [str "-> ",
+ maybe ArrowRhs (Vector.sub (args, 1))]],
+ ({isChar = false}, Arrow))
else if equals (c, tuple)
then if 0 = Vector.length args
- then (str "unit", {isChar = false, needsParen = false})
+ then (str "unit", ({isChar = false}, Unit))
else (mayAlign (Layout.separateLeft
- (Vector.toListMap (args, maybe), "* ")),
- {isChar = false, needsParen = true})
+ (Vector.toListMap (args, maybe TupleElem), "* ")),
+ ({isChar = false}, Tuple))
else if equals (c, vector)
- then if #isChar (#2 (Vector.sub (args, 0)))
- then (str "string", {isChar = false, needsParen = false})
+ then if #isChar (#1 (#2 (Vector.sub (args, 0))))
+ then (str "string", ({isChar = false}, Unit))
else normal ()
else normal ()
end
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 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.sig 2007-02-02 19:35:19 UTC (rev 5113)
@@ -27,10 +27,21 @@
val layout: t -> Layout.t
end
+signature BINDING_STRENGTH =
+ sig
+ type t
+
+ val arrow: t
+ val tuple: t
+ val unit: t
+ end
+
signature PRIM_TYCONS =
sig
include PRIM_TYCONS_SUBSTRUCTS
+ structure BindingStrength: BINDING_STRENGTH
+
type tycon
val array: tycon
@@ -57,11 +68,14 @@
val isRealX: tycon -> bool
val isWordX: tycon -> bool
val layoutApp:
- tycon * (Layout.t * {isChar: bool, needsParen: bool}) vector
- -> Layout.t * {isChar: bool, needsParen: bool}
+ tycon * (Layout.t * ({isChar: bool} * BindingStrength.t)) vector
+ -> Layout.t * ({isChar: bool} * BindingStrength.t)
val list: tycon
val pointer: tycon
- val prims: (tycon * Kind.t * AdmitsEquality.t) list
+ val prims: {admitsEquality: AdmitsEquality.t,
+ kind: Kind.t,
+ name: string,
+ tycon: tycon} list
val real: RealSize.t -> tycon
val reals: (tycon * RealSize.t) vector
val reff: tycon
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/ast/sources.cm
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/ast/sources.cm 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/sources.cm 2007-02-02 19:35:19 UTC (rev 5113)
@@ -10,6 +10,7 @@
signature ADMITS_EQUALITY
signature AST
+signature BINDING_STRENGTH
signature CHAR_SIZE
signature FIELD
signature INT_SIZE
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/ast/sources.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/ast/sources.mlb 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/sources.mlb 2007-02-02 19:35:19 UTC (rev 5113)
@@ -56,6 +56,7 @@
in
signature ADMITS_EQUALITY
signature AST
+ signature BINDING_STRENGTH
signature CHAR_SIZE
signature FIELD
signature INT_SIZE
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/atoms/hash-type.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/atoms/hash-type.fun 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/atoms/hash-type.fun 2007-02-02 19:35:19 UTC (rev 5113)
@@ -84,8 +84,9 @@
fun layout (ty: t): Layout.t =
#1 (hom {con = Tycon.layoutApp,
ty = ty,
- var = fn a => (Tyvar.layout a, {isChar = false,
- needsParen = false})})
+ var = fn a => (Tyvar.layout a,
+ ({isChar = false},
+ Tycon.BindingStrength.unit))})
val toString = Layout.toString o layout
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/atoms/tycon.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/atoms/tycon.fun 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/atoms/tycon.fun 2007-02-02 19:35:19 UTC (rev 5113)
@@ -35,7 +35,7 @@
open Layout
in
align
- (List.map (prims, fn (c, _, _) =>
+ (List.map (prims, fn {tycon = c, ...} =>
seq [layout c, str " size is ",
Int.layout (MLton.size c),
str " plist length is ",
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/control/control-flags.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/control/control-flags.sig 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/control/control-flags.sig 2007-02-02 19:35:19 UTC (rev 5113)
@@ -152,9 +152,12 @@
val inlineIntoMain: bool ref
- (* The input file on the command line, minus path and extension *)
+ (* The input file on the command line, minus path and extension. *)
val inputFile: File.t ref
+ (* Whether or not the elaborator keeps def-use information. *)
+ val keepDefUse: bool ref
+
(* Keep dot files for whatever SSA files are produced. *)
val keepDot: bool ref
@@ -192,6 +195,8 @@
val maxFunctionSize: int ref
val mlbPathMaps: string list ref
+ val mlbPathMap: unit -> {var: string,
+ path: string} list
structure Native:
sig
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/control/control-flags.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/control/control-flags.sml 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/control/control-flags.sml 2007-02-02 19:35:19 UTC (rev 5113)
@@ -706,6 +706,10 @@
default = false,
toString = Bool.toString}
+val keepDefUse = control {name = "keep def use",
+ default = true,
+ toString = Bool.toString}
+
val keepDot = control {name = "keep dot",
default = false,
toString = Bool.toString}
@@ -987,6 +991,49 @@
default = Linux,
toString = MLton.Platform.OS.toString}
+local
+ fun make (file: File.t) =
+ if not (File.canRead file) then
+ Error.bug (concat ["can't read MLB path map file: ", file])
+ else
+ List.keepAllMap
+ (File.lines file, fn line =>
+ if String.forall (line, Char.isSpace)
+ then NONE
+ else
+ case String.tokens (line, Char.isSpace) of
+ [var, path] => SOME {var = var, path = path}
+ | _ => Error.bug (concat ["strange mlb path mapping: ",
+ file, ":: ", line]))
+in
+ fun mlbPathMap () =
+ List.rev
+ (List.concat
+ [[{var = "LIB_MLTON_DIR",
+ path = !libDir},
+ {var = "TARGET_ARCH",
+ path = String.toLower (MLton.Platform.Arch.toString
+ (!targetArch))},
+ {var = "TARGET_OS",
+ path = String.toLower (MLton.Platform.OS.toString
+ (!targetOS))},
+ {var = "OBJPTR_REP",
+ path = "objptr-rep32.sml"},
+ {var = "HEADER_WORD",
+ path = "header-word32.sml"},
+ {var = "SEQINDEX_INT",
+ path = "seqindex-int32.sml"},
+ {var = "DEFAULT_CHAR",
+ path = concat ["default-", !defaultChar, ".sml"]},
+ {var = "DEFAULT_INT",
+ path = concat ["default-", !defaultInt, ".sml"]},
+ {var = "DEFAULT_REAL",
+ path = concat ["default-", !defaultReal, ".sml"]},
+ {var = "DEFAULT_WORD",
+ path = concat ["default-", !defaultWord, ".sml"]}],
+ List.concat (List.map (!mlbPathMaps, make))])
+end
+
val typeCheck = control {name = "type check",
default = false,
toString = Bool.toString}
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 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/elaborate-core.fun 2007-02-02 19:35:19 UTC (rev 5113)
@@ -658,10 +658,7 @@
val {args, instance} =
Scheme.instantiate s
in
- if Type.canUnify
- (instance,
- Type.arrow (Type.new (),
- Type.new ()))
+ if Type.isArrow instance
then
(Control.error
(region,
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/elaborate-env.fun 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/elaborate-env.fun 2007-02-02 19:35:19 UTC (rev 5113)
@@ -84,7 +84,7 @@
fun explainDoesNotAdmitEquality (t: t): Layout.t =
let
open Layout
- val wild = (str "_", {isChar = false, needsParen = false})
+ val wild = (str "_", ({isChar = false}, Tycon.BindingStrength.unit))
fun con (c, ts) =
let
fun keep {showInside: bool} =
@@ -101,7 +101,8 @@
case ! (Tycon.admitsEquality c) of
Always => NONE
| Never => SOME (bracket (#1 (keep {showInside = false})),
- {isChar = false, needsParen = false})
+ ({isChar = false},
+ Tycon.BindingStrength.unit))
| Sometimes =>
if Vector.exists (ts, Option.isSome)
then SOME (keep {showInside = true})
@@ -134,7 +135,7 @@
seq [Field.layout f, str ": ", z] :: ac),
",")),
str ending],
- {isChar = false, needsParen = false})
+ ({isChar = false}, Tycon.BindingStrength.unit))
end
| SOME v =>
Tycon.layoutApp
@@ -688,7 +689,7 @@
uses = uses}))
end
-val allTycons: Tycon.t list ref = ref (List.map (Tycon.prims, #1))
+val allTycons: Tycon.t list ref = ref (List.map (Tycon.prims, #tycon))
val newTycons: (Tycon.t * Kind.t * Region.t) list ref = ref []
val newTycon: string * Kind.t * AdmitsEquality.t * Region.t -> Tycon.t =
@@ -1154,9 +1155,13 @@
fun newUses (T {defUses, ...}, class, def) =
let
val u = Uses.new ()
- val _ = List.push (defUses, {class = class,
- def = def,
- uses = u})
+ val _ =
+ if !Control.keepDefUse then
+ List.push (defUses, {class = class,
+ def = def,
+ uses = u})
+ else
+ ()
in
u
end
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/interface.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/interface.fun 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/interface.fun 2007-02-02 19:35:19 UTC (rev 5113)
@@ -144,7 +144,8 @@
("id", TyconId.layout id)]
end
- fun layoutApp (t, _) = (layout t, {isChar = false, needsParen = false})
+ fun layoutApp (t, _) =
+ (layout t, ({isChar = false}, Etycon.BindingStrength.unit))
val copies: copy list ref = ref []
@@ -247,7 +248,7 @@
local
open Layout
- fun simple l = (l, {isChar = false, needsParen = false})
+ fun simple l = (l, ({isChar = false}, Etycon.BindingStrength.unit))
fun loop t =
case t of
Con (c, ts) => Tycon.layoutApp (c, Vector.map (ts, loop))
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/interface.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/interface.sig 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/interface.sig 2007-02-02 19:35:19 UTC (rev 5113)
@@ -15,6 +15,8 @@
structure Kind: TYCON_KIND
structure Tycon:
sig
+ structure BindingStrength: BINDING_STRENGTH
+
type t
val admitsEquality: t -> AdmitsEquality.t ref
@@ -23,8 +25,9 @@
val exn: t
val layout: t -> Layout.t
val layoutApp:
- t * (Layout.t * {isChar: bool, needsParen: bool}) vector
- -> Layout.t * {isChar: bool, needsParen: bool}
+ t * (Layout.t
+ * ({isChar: bool} * BindingStrength.t)) vector
+ -> Layout.t * ({isChar: bool} * BindingStrength.t)
val tuple: t
end
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 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/type-env.fun 2007-02-02 19:35:19 UTC (rev 5113)
@@ -84,10 +84,10 @@
structure Lay =
struct
- type t = Layout.t * {isChar: bool, needsParen: bool}
+ type t = Layout.t * ({isChar: bool} * Tycon.BindingStrength.t)
fun simple (l: Layout.t): t =
- (l, {isChar = false, needsParen = false})
+ (l, ({isChar = false}, Tycon.BindingStrength.unit))
end
structure UnifyResult =
@@ -124,7 +124,8 @@
region = ref NONE,
time = ref (Time.now ())})
-val _ = List.foreach (Tycon.prims, fn (c, _, a) => initAdmitsEquality (c, a))
+val _ = List.foreach (Tycon.prims, fn {tycon = c, admitsEquality = a, ...} =>
+ initAdmitsEquality (c, a))
structure Equality:>
sig
@@ -369,11 +370,11 @@
Trace.trace ("TypeEnv.tyvarTime", Tyvar.layout, Ref.layout Time.layout) tyvarTime
local
- type z = Layout.t * {isChar: bool, needsParen: bool}
+ type z = Layout.t * ({isChar: bool} * Tycon.BindingStrength.t)
open Layout
in
fun simple (l: Layout.t): z =
- (l, {isChar = false, needsParen = false})
+ (l, ({isChar = false}, Tycon.BindingStrength.unit))
val dontCare: z = simple (str "_")
fun bracket l = seq [str "[", l, str "]"]
fun layoutRecord (ds: (Field.t * bool * z) list, flexible: bool) =
@@ -599,8 +600,9 @@
end
fun makeLayoutPretty (): {destroy: unit -> unit,
- lay: t -> Layout.t * {isChar: bool,
- needsParen: bool}} =
+ lay: t -> Layout.t
+ * ({isChar: bool}
+ * Tycon.BindingStrength.t)} =
let
val str = Layout.str
fun con (_, c, ts) = Tycon.layoutApp (c, ts)
@@ -719,6 +721,8 @@
fun new () = unknown {canGeneralize = true,
equality = Equality.unknown ()}
+ val new = Trace.trace ("TypeEnv.Type.new", Unit.layout, layout) new
+
fun newFlex {fields, spine} =
newTy (FlexRecord {fields = fields,
spine = spine},
@@ -775,6 +779,11 @@
val unit = tuple (Vector.new0 ())
+ fun isArrow t =
+ case toType t of
+ Con (c, _) => Tycon.equals (c, Tycon.arrow)
+ | _ => false
+
fun isBool t =
case toType t of
Con (c, _) => Tycon.isBool c
@@ -938,10 +947,9 @@
(NotUnifiable (l, l'),
Unknown (Unknown.new {canGeneralize = true}))
val bracket =
- fn (l, {isChar, needsParen = _}) =>
+ fn (l, ({isChar}, _)) =>
(bracket l,
- {isChar = isChar,
- needsParen = false})
+ ({isChar = isChar}, Tycon.BindingStrength.unit))
fun notUnifiableBracket (l, l') =
notUnifiable (bracket l, bracket l')
fun flexToRecord (fields, spine) =
@@ -1653,7 +1661,7 @@
Time.layout (!time),
str " where getTime is ",
Time.layout genTime],
- Out.standard)
+ Out.error)
end
in
if not (Time.<= (genTime, !time))
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 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/type-env.sig 2007-02-02 19:35:19 UTC (rev 5113)
@@ -38,6 +38,7 @@
record: 'a SortedRecord.t -> 'a,
replaceSynonyms: bool,
var: Tyvar.t -> 'a} -> 'a
+ val isArrow: t -> bool
val isBool: t -> bool
val isCharX: t -> bool
val isExn: t -> bool
@@ -52,8 +53,8 @@
hom: t -> 'a}
val makeLayoutPretty:
unit -> {destroy: unit -> unit,
- lay: t -> Layout.t * {isChar: bool,
- needsParen: bool}}
+ lay: t -> Layout.t * ({isChar: bool}
+ * Tycon.BindingStrength.t)}
(* minTime (t, time) makes every component of t occur no later than
* time. This will display a type error message if time is before
* the definition time of some component of t.
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/front-end/mlb-front-end.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/front-end/mlb-front-end.fun 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/front-end/mlb-front-end.fun 2007-02-02 19:35:19 UTC (rev 5113)
@@ -84,46 +84,8 @@
val psi : (File.t * Ast.Basdec.t Promise.t) HashSet.t =
HashSet.new {hash = String.hash o #1}
local
- fun make (file: File.t) =
- if not (File.canRead file) then
- Error.bug (concat ["can't read MLB path map file: ", file])
- else
- List.keepAllMap
- (File.lines file, fn line =>
- if String.forall (line, Char.isSpace)
- then NONE
- else
- case String.tokens (line, Char.isSpace) of
- [var, path] => SOME {var = var, path = path}
- | _ => Error.bug (concat ["strange mlb path mapping: ",
- file, ":: ", line]))
val pathMap =
- List.rev
- (List.concat
- [[{var = "LIB_MLTON_DIR",
- path = !Control.libDir},
- {var = "TARGET_ARCH",
- path = String.toLower (MLton.Platform.Arch.toString
- (!Control.targetArch))},
- {var = "TARGET_OS",
- path = String.toLower (MLton.Platform.OS.toString
- (!Control.targetOS))},
- {var = "OBJPTR_REP",
- path = "objptr-rep32.sml"},
- {var = "HEADER_WORD",
- path = "header-word32.sml"},
- {var = "SEQINDEX_INT",
- path = "seqindex-int32.sml"},
- {var = "DEFAULT_CHAR",
- path = concat ["default-", !Control.defaultChar, ".sml"]},
- {var = "DEFAULT_INT",
- path = concat ["default-", !Control.defaultInt, ".sml"]},
- {var = "DEFAULT_REAL",
- path = concat ["default-", !Control.defaultReal, ".sml"]},
- {var = "DEFAULT_WORD",
- path = concat ["default-", !Control.defaultWord, ".sml"]}],
- List.concat (List.map (!Control.mlbPathMaps, make))])
-
+ Control.mlbPathMap ()
fun peekPathMap var' =
case List.peek (pathMap, fn {var,...} =>
var = var') of
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/main/compile.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/main/compile.fun 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/main/compile.fun 2007-02-02 19:35:19 UTC (rev 5113)
@@ -242,10 +242,9 @@
let
val _ =
List.foreach
- (Tycon.prims, fn (tycon, kind, _) =>
+ (Tycon.prims, fn {kind, name, tycon, ...} =>
extendTycon
- (E, Ast.Tycon.fromSymbol (Symbol.fromString
- (Tycon.originalName tycon),
+ (E, Ast.Tycon.fromSymbol (Symbol.fromString name,
Region.bogus),
TypeStr.tycon (tycon, kind),
{forceUsed = false, isRebind = false}))
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun 2007-02-02 19:35:19 UTC (rev 5113)
@@ -47,6 +47,11 @@
| Yes
end
+structure Show =
+ struct
+ datatype t = Anns | PathMap
+ end
+
val gcc: string ref = ref "<unset>"
val asOpts: {opt: string, pred: OptPred.t} list ref = ref []
val ccOpts: {opt: string, pred: OptPred.t} list ref = ref []
@@ -65,7 +70,7 @@
val profileSet: bool ref = ref false
val profileTimeSet: bool ref = ref false
val runtimeArgs: string list ref = ref ["@MLton"]
-val showAnns: bool ref = ref false
+val show: Show.t option ref = ref NONE
val stop = ref Place.OUT
val targetMap: unit -> {arch: MLton.Platform.Arch.t,
@@ -451,8 +456,20 @@
boolRef profileStack),
(Normal, "runtime", " <arg>", "pass arg to runtime via @MLton",
SpaceString (fn s => List.push (runtimeArgs, s))),
- (Expert, "show-anns", " {false|true}", "show annotations",
- boolRef showAnns),
+ (Expert, "show", " {anns|path-map}", "print specified data and stop",
+ SpaceString
+ (fn s =>
+ show := SOME (case s of
+ "anns" => Show.Anns
+ | "path-map" => Show.PathMap
+ | _ => usage (concat ["invalid -show arg: ", s])))),
+ (Expert, "show-anns", " {false|true}", "deprecated (use -show anns)",
+ Bool
+ (fn b =>
+ (if b then show := SOME Show.Anns else ()
+ ; Out.output
+ (Out.error,
+ "Warning: deprecated option: -show-anns. Use -show anns.\n")))),
(Normal, "show-basis", " <file>", "write out the final basis environment",
SpaceString (fn s => showBasis := SOME s)),
(Normal, "show-def-use", " <file>", "write def-use information",
@@ -583,11 +600,24 @@
| SOME c => c)
val () = MLton.Rusage.measureGC (!verbosity <> Silent)
val () =
- if !showAnns then
- (Layout.outputl (Control.Elaborate.document {expert = !expert},
- Out.standard)
+ case !show of
+ NONE => ()
+ | SOME info =>
+ (case info of
+ Show.Anns =>
+ Layout.outputl (Control.Elaborate.document {expert = !expert},
+ Out.standard)
+ | Show.PathMap =>
+ let
+ open Layout
+ in
+ outputl (align
+ (List.map (Control.mlbPathMap (),
+ fn {var, path, ...} =>
+ str (concat [var, " ", path]))),
+ Out.standard)
+ end
; let open OS.Process in exit success end)
- else ()
val () = if !profileTimeSet
then (case !codegen of
Native => profile := ProfileTimeLabel
@@ -675,10 +705,11 @@
if !keepDot andalso List.isEmpty (!keepPasses)
then keepSSA := true
else ()
- val keepDefUse =
- isSome (!showDefUse)
- orelse (Control.Elaborate.enabled Control.Elaborate.warnUnused)
- orelse (Control.Elaborate.default Control.Elaborate.warnUnused)
+ val () =
+ keepDefUse
+ := (isSome (!showDefUse)
+ orelse (Control.Elaborate.enabled Control.Elaborate.warnUnused)
+ orelse (Control.Elaborate.default Control.Elaborate.warnUnused))
val warnMatch =
(Control.Elaborate.enabled Control.Elaborate.nonexhaustiveMatch)
orelse (Control.Elaborate.enabled Control.Elaborate.redundantMatch)
@@ -688,7 +719,7 @@
Control.Elaborate.DiagEIW.Ignore)
val _ = elaborateOnly := (stop = Place.TypeCheck
andalso not (warnMatch)
- andalso not (keepDefUse))
+ andalso not (!keepDefUse))
val _ =
if !codegen = Bytecode andalso !profile <> ProfileNone
then usage (concat ["bytecode doesn't support profiling\n"])
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/ssa/ssa-tree2.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/ssa/ssa-tree2.fun 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ssa/ssa-tree2.fun 2007-02-02 19:35:19 UTC (rev 5113)
@@ -59,7 +59,8 @@
then seq [layout elt, str " ref"]
else layout elt
in
- (lay, {isChar = false, needsParen = false})
+ (lay, ({isChar = false},
+ Tycon.BindingStrength.unit))
end))))
end
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/xml/monomorphise.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/xml/monomorphise.fun 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/xml/monomorphise.fun 2007-02-02 19:35:19 UTC (rev 5113)
@@ -94,7 +94,7 @@
Property.destGetSet (Tycon.plist,
Property.initRaise ("mono", Tycon.layout))
val _ =
- List.foreach (Tycon.prims, fn (t, _, _) =>
+ List.foreach (Tycon.prims, fn {tycon = t, ...} =>
setTycon (t, fn ts => Stype.con (t, ts)))
val {set = setTyvar, get = getTyvar: Tyvar.t -> Stype.t, ...} =
Property.getSet (Tyvar.plist,
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/util/safe.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/util/safe.h 2007-02-02 16:45:13 UTC (rev 5112)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/util/safe.h 2007-02-02 19:35:19 UTC (rev 5113)
@@ -47,9 +47,14 @@
size_t res;
res = fread (buf, size, count, f);
- if (res != count)
- diee ("fread (_, %zu, %zu, _) failed (only read %zu).\n",
- size, count, res);
+ if (res != count) {
+ if (feof (f))
+ fprintf (stderr, "eof\n");
+ else
+ fprintf (stderr, "errno = %d\n", ferror (f));
+ diee ("fread ("FMTPTR", %zu, %zu, _) failed (only read %zu).\n",
+ (uintptr_t)buf, size, count, res);
+ }
}
static inline void fwrite_safe (const void *buf, size_t size, size_t count, FILE *f) {
More information about the MLton-commit
mailing list