[MLton-commit] r4991
Matthew Fluet
fluet at mlton.org
Tue Dec 19 12:09:56 PST 2006
Merge trunk revisions 4907:4990 into x86_64 branch
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf0.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml
U mlton/branches/on-20050822-x86_64-branch/bin/mlton-script
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/ide/emacs/esml-util.el
U mlton/branches/on-20050822-x86_64-branch/mlton/backend/limit-check.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/main/lookup-constant.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun
U mlton/branches/on-20050822-x86_64-branch/package/mingw/mlton.bat
U mlton/branches/on-20050822-x86_64-branch/runtime/gc/array-allocate.c
U mlton/branches/on-20050822-x86_64-branch/runtime/gc/new-object.c
U mlton/branches/on-20050822-x86_64-branch/runtime/gc/stack.c
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf0.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf0.sml 2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf0.sml 2006-12-19 20:09:46 UTC (rev 4991)
@@ -334,6 +334,7 @@
structure IntInf =
struct
structure Prim = Primitive.IntInf
+ structure MLton = Primitive.MLton
structure A = Primitive.Array
structure V = Primitive.Vector
@@ -876,8 +877,11 @@
Sz.+ (Sz.* (bytesPerMPLimb, Sz.zextdFromSeqIndex num),
Sz.+ (Sz.* (bytesPerMPLimb, Sz.zextdFromSeqIndex extra),
Sz.+ (bytesPerMPLimb, (* isneg Field *)
- bytesPerArrayHeader (* Array Header *)
- )))
+ Sz.+ (bytesPerArrayHeader, (* Array Header *)
+ case MLton.Align.align of (* alignment *)
+ MLton.Align.Align4 => 0w3
+ | MLton.Align.Align8 => 0w7
+ ))))
end
(* badObjptr{Int,Word}{,Tagged} is the fixnum IntInf.int whose
@@ -1202,13 +1206,16 @@
Int32.+ (Int32.quot (bpl, bpd),
if Int32.mod (bpl, bpd) = 0
then 0 else 1)
+ val bytes =
+ Sz.+ (Sz.+ (bytesPerArrayHeader (* Array Header *),
+ Sz.+ (0w1 (* sign *),
+ case MLton.Align.align of (* alignment *)
+ MLton.Align.Align4 => 0w3
+ | MLton.Align.Align8 => 0w7)),
+ Sz.* (Sz.zextdFromInt32 dpl,
+ Sz.zextdFromSeqIndex (numLimbs arg)))
in
- Prim.toString
- (arg, base,
- Sz.+ (Sz.+ (bytesPerArrayHeader (* Array Header *),
- 0w1 (* sign *)),
- Sz.* (Sz.zextdFromInt32 dpl,
- Sz.zextdFromSeqIndex (numLimbs arg))))
+ Prim.toString (arg, base, bytes)
end
fun mkBigLog2 {fromSmall: {smallLog2: Primitive.Int32.int} -> 'a,
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml 2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml 2006-12-19 20:09:46 UTC (rev 4991)
@@ -32,6 +32,17 @@
val gcState = #1 _symbol "gcStateAddress": t GetSet.t; ()
end
+structure Align =
+ struct
+ datatype t = Align4 | Align8
+
+ val align =
+ case _build_const "MLton_Align_align": Int32.int; of
+ 4 => Align4
+ | 8 => Align8
+ | _ => raise Primitive.Exn.Fail8 "MLton_Align_align"
+ end
+
structure CallStack =
struct
(* The most recent caller is at index 0 in the array. *)
Modified: mlton/branches/on-20050822-x86_64-branch/bin/mlton-script
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/bin/mlton-script 2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/bin/mlton-script 2006-12-19 20:09:46 UTC (rev 4991)
@@ -70,46 +70,45 @@
# The darwin linker complains (loudly) about non-existent library
# search paths.
darwinLinkOpts=''
-if [ -d '/opt/local/lib' ]; then
- darwinLinkOpts="$darwinLinkOpts -L/opt/local/lib"
-fi
if [ -d '/sw/lib' ]; then
darwinLinkOpts="$darwinLinkOpts -L/sw/lib"
fi
+if [ -d '/opt/local/lib' ]; then
+ darwinLinkOpts="$darwinLinkOpts -L/opt/local/lib"
+fi
doit "$lib" \
-cc "$gcc" \
- -cc-opt "-I$lib/include" \
+ -cc-opt-quote "-I$lib/include" \
-cc-opt '-O1' \
- -cc-opts '-fno-strict-aliasing -fomit-frame-pointer -w' \
+ -cc-opt '-fno-strict-aliasing -fomit-frame-pointer -w' \
-mlb-path-map "$lib/mlb-path-map" \
- -target-as-opts amd64 '-m32 -mtune=opteron' \
- -target-cc-opts amd64 '-m32 -mtune=opteron' \
- -target-cc-opts darwin \
+ -target-as-opt amd64 '-m32 -mtune=opteron' \
+ -target-cc-opt amd64 '-m32 -mtune=opteron' \
+ -target-cc-opt darwin \
'-I/opt/local/include -I/sw/include' \
- -target-cc-opts freebsd '-I/usr/local/include' \
- -target-cc-opts netbsd '-I/usr/pkg/include' \
- -target-cc-opts openbsd '-I/usr/local/include' \
- -target-cc-opts solaris \
- '-Wa,-xarch=v8plusa
- -mcpu=ultrasparc' \
- -target-cc-opts sparc '-mcpu=v8 -m32' \
- -target-cc-opts x86 \
+ -target-cc-opt freebsd '-I/usr/local/include' \
+ -target-cc-opt netbsd '-I/usr/pkg/include' \
+ -target-cc-opt openbsd '-I/usr/local/include' \
+ -target-cc-opt solaris \
+ '-Wa,-xarch=v8plusa -mcpu=ultrasparc' \
+ -target-cc-opt sparc '-mcpu=v8 -m32' \
+ -target-cc-opt x86 \
'-fno-strength-reduce
-fschedule-insns
-fschedule-insns2
-malign-functions=5
-malign-jumps=2
-malign-loops=2' \
- -target-link-opts amd64 '-m32' \
- -target-link-opts darwin "$darwinLinkOpts" \
- -target-link-opts freebsd '-L/usr/local/lib/' \
- -target-link-opts mingw \
+ -target-link-opt amd64 '-m32' \
+ -target-link-opt darwin "$darwinLinkOpts" \
+ -target-link-opt freebsd '-L/usr/local/lib/' \
+ -target-link-opt mingw \
'-lws2_32 -lkernel32 -lpsapi -lnetapi32' \
- -target-link-opts netbsd \
+ -target-link-opt netbsd \
'-Wl,-R/usr/pkg/lib -L/usr/pkg/lib/' \
- -target-link-opts openbsd '-L/usr/local/lib/' \
- -target-link-opts solaris '-lnsl -lsocket -lrt' \
- -link-opts '-lgdtoa -lm -lgmp' \
+ -target-link-opt openbsd '-L/usr/local/lib/' \
+ -target-link-opt solaris '-lnsl -lsocket -lrt' \
+ -link-opt '-lgdtoa -lm -lgmp' \
-profile-exclude '<basis>' \
"$@"
Modified: mlton/branches/on-20050822-x86_64-branch/doc/changelog
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/doc/changelog 2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/doc/changelog 2006-12-19 20:09:46 UTC (rev 4991)
@@ -1,5 +1,12 @@
Here are the changes since version 20051202.
+* 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
+ tokenization at spaces). These options support using headers and
+ libraries (including the MLton runtime headers and libraries) from a
+ path with spaces.
+
* 2006-12-02
- Extensive reorganization of garbage collector, runtime system, and
Basis Library implementation. (This is in preparation for future
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 2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-mlb-mode.el 2006-12-19 20:09:46 UTC (rev 4991)
@@ -242,21 +242,23 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Syntax and highlighting
-(defconst esml-mlb-string-continue-regexp "\\(\\\\[ \t\n]+\\\\\\)")
+(defconst esml-mlb-string-continue-regexp "\\(?:\\\\[ \t\n]+\\\\\\)")
(defconst esml-mlb-string-char-regexp
- (concat "\\(" esml-mlb-string-continue-regexp
- "*\\([^\n\"\\]\\|\\\\[^ \t\n]\\)\\)"))
+ (concat "\\(?:" esml-mlb-string-continue-regexp
+ "*\\(?:[^\n\"\\]\\|\\\\[^ \t\n]\\)\\)"))
(defconst esml-mlb-inside-string-regexp
(concat "\"" esml-mlb-string-char-regexp "*"
esml-mlb-string-continue-regexp "*"))
(defconst esml-mlb-string-regexp (concat esml-mlb-inside-string-regexp "\""))
-(defconst esml-mlb-inside-comment-regexp "(\\*\\([^*]\\|\\*[^)]\\)*")
+(defconst esml-mlb-inside-comment-regexp "(\\*\\(?:[^*]\\|\\*[^)]\\)*")
(defconst esml-mlb-comment-regexp
(concat esml-mlb-inside-comment-regexp "\\*)"))
(defconst esml-mlb-path-var-chars "A-Za-z0-9_")
(defconst esml-mlb-unquoted-path-chars "-A-Za-z0-9_/.")
(defconst esml-mlb-unquoted-path-or-ref-chars
(concat esml-mlb-unquoted-path-chars "()$"))
+(defconst esml-mlb-compiler-ann-prefix
+ (concat "\\(?:" esml-mlb-string-char-regexp "*:[ \t]*\\)"))
(defun esml-mlb-<token>-to-regexp (<token>)
(let* ((<token>-to-regexp
@@ -309,7 +311,7 @@
;; annotations
(,(apply
'concat
- "\"[ \t]*\\("
+ "\"[ \t]*" esml-mlb-compiler-ann-prefix "?\\("
(reduce
(function
(lambda (regexps name-values)
@@ -484,7 +486,7 @@
;; annotation values
((esml-point-preceded-by
- (concat "\"[ \t\n]*\\("
+ (concat "\"[ \t\n]*" esml-mlb-compiler-ann-prefix "?\\("
(regexp-opt (mapcar 'car esml-mlb-annotations))
"\\)[ \t\n]+\\(" esml-mlb-string-char-regexp "*\\)"))
(let* ((annot (assoc (match-string 1) esml-mlb-annotations))
@@ -511,7 +513,8 @@
(concat "\\<ann[ \t\n]+\\([ \t\n]+\\|" esml-mlb-string-regexp
"\\|" esml-mlb-comment-regexp "\\)*\"[^\"]*"))
(esml-point-preceded-by
- (concat "\"[ \t\n]*\\(" esml-mlb-string-char-regexp "*\\)")))
+ (concat "\"[ \t\n]*" esml-mlb-compiler-ann-prefix "?\\("
+ esml-mlb-string-char-regexp "*\\)")))
(let* ((name-prefix (match-string 1))
(name-completion (try-completion name-prefix esml-mlb-annotations))
(name (if (eq t name-completion) name-prefix name-completion)))
Modified: mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-util.el
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-util.el 2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-util.el 2006-12-19 20:09:46 UTC (rev 4991)
@@ -32,11 +32,8 @@
(forward-char (length str))
(insert str)))
-;; workaround for incompatibility between GNU Emacs and XEmacs
(defun esml-split-string (string separator)
- (if (string-match "XEmacs" emacs-version)
- (split-string string separator t)
- (remove* "" (split-string string separator))))
+ (remove* "" (split-string string separator) :test 'equal))
;; workaround for incompatibility between GNU Emacs and XEmacs
(defun esml-replace-regexp-in-string (str regexp rep)
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/backend/limit-check.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/backend/limit-check.fun 2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/backend/limit-check.fun 2006-12-19 20:09:46 UTC (rev 4991)
@@ -429,9 +429,7 @@
end
fun bigAllocation (bytesNeeded: Operand.t): unit =
let
- val extraBytes =
- Bytes.+ (Runtime.arrayHeaderSize,
- blockCheckAmount {blockIndex = i})
+ val extraBytes = blockCheckAmount {blockIndex = i}
in
case bytesNeeded of
Operand.Const c =>
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/main/lookup-constant.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/main/lookup-constant.fun 2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/main/lookup-constant.fun 2006-12-19 20:09:46 UTC (rev 4991)
@@ -24,7 +24,10 @@
val int = Int.toString
open Control
in
- [("MLton_Codegen_codegen", fn () => int (case !codegen of
+ [("MLton_Align_align", fn () => int (case !align of
+ Align4 => 4
+ | Align8 => 8)),
+ ("MLton_Codegen_codegen", fn () => int (case !codegen of
Bytecode => 0
| CCodegen => 1
| Native => 2)),
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun 2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun 2006-12-19 20:09:46 UTC (rev 4991)
@@ -47,19 +47,20 @@
| Yes
end
+val gcc: string ref = ref "<unset>"
val asOpts: {opt: string, pred: OptPred.t} list ref = ref []
-val buildConstants: bool ref = ref false
val ccOpts: {opt: string, pred: OptPred.t} list ref = ref []
+val linkOpts: {opt: string, pred: OptPred.t} list ref = ref []
+
+val buildConstants: bool ref = ref false
val coalesce: int option ref = ref NONE
val debugRuntime: bool ref = ref false
val expert: bool ref = ref false
val explicitAlign: Control.align option ref = ref NONE
val explicitCodegen: Control.codegen option ref = ref NONE
-val gcc: string ref = ref "<unset>"
val keepGenerated = ref false
val keepO = ref false
val keepSML = ref false
-val linkOpts: {opt: string, pred: OptPred.t} list ref = ref []
val output: string option ref = ref NONE
val profileSet: bool ref = ref false
val profileTimeSet: bool ref = ref false
@@ -140,11 +141,12 @@
usage (concat ["invalid -", flag, " flag: ", s])
open Control Popt
datatype z = datatype MLton.Platform.Arch.t
- fun splitString f opts =
- List.foreach (String.tokens (opts, Char.isSpace), f)
- fun splitString2 f (target, opts) =
- List.foreach (String.tokens (opts, Char.isSpace),
- fn opt => f (target, opt))
+ fun tokenizeOpt f opts =
+ List.foreach (String.tokens (opts, Char.isSpace),
+ fn opt => f opt)
+ fun tokenizeTargetOpt f (target, opts) =
+ List.foreach (String.tokens (opts, Char.isSpace),
+ fn opt => f (target, opt))
in
List.map
(
@@ -159,24 +161,22 @@
| _ => usage (concat ["invalid -align flag: ",
s]))))),
(Normal, "as-opt", " <opt>", "pass option to assembler",
- SpaceString (fn s =>
- List.push (asOpts, {opt = s, pred = OptPred.Yes}))),
- (Expert, "as-opts", " <opts>", "pass options to assembler",
+ (SpaceString o tokenizeOpt)
+ (fn s => List.push (asOpts, {opt = s, pred = OptPred.Yes}))),
+ (Expert, "as-opt-quote", " <opt>", "pass (quoted) option to assembler",
SpaceString
- (splitString (fn s =>
- List.push (asOpts, {opt = s, pred = OptPred.Yes})))),
+ (fn s => List.push (asOpts, {opt = s, pred = OptPred.Yes}))),
(Expert, "build-constants", " {false|true}",
"output C file that prints basis constants",
boolRef buildConstants),
(Expert, "cc", " <gcc>", "path to gcc executable",
SpaceString (fn s => gcc := s)),
(Normal, "cc-opt", " <opt>", "pass option to C compiler",
- SpaceString (fn s =>
- List.push (ccOpts, {opt = s, pred = OptPred.Yes}))),
- (Expert, "cc-opts", " <opts>", "pass options to C compiler",
+ (SpaceString o tokenizeOpt)
+ (fn s => List.push (ccOpts, {opt = s, pred = OptPred.Yes}))),
+ (Expert, "cc-opt-quote", " <opt>", "pass (quoted) option to C compiler",
SpaceString
- (splitString (fn s =>
- List.push (ccOpts, {opt = s, pred = OptPred.Yes})))),
+ (fn s => List.push (ccOpts, {opt = s, pred = OptPred.Yes}))),
(Expert, "coalesce", " <n>", "coalesce chunk size for C codegen",
Int (fn n => coalesce := SOME n)),
(Normal, "codegen",
@@ -306,12 +306,11 @@
end
| NONE => usage (concat ["invalid -keep-pass flag: ", s])))),
(Normal, "link-opt", " <opt>", "pass option to linker",
- SpaceString (fn s =>
- List.push (linkOpts, {opt = s, pred = OptPred.Yes}))),
- (Expert, "link-opts", " <opts>", "pass options to linker",
+ (SpaceString o tokenizeOpt)
+ (fn s => List.push (linkOpts, {opt = s, pred = OptPred.Yes}))),
+ (Expert, "link-opt-quote", " <opt>", "pass (quoted) option to linker",
SpaceString
- (splitString (fn s =>
- List.push (linkOpts, {opt = s, pred = OptPred.Yes})))),
+ (fn s => List.push (linkOpts, {opt = s, pred = OptPred.Yes}))),
(Expert, "loop-passes", " <n>", "loop optimization passes (1)",
Int
(fn i =>
@@ -501,32 +500,29 @@
(target := (if t = "self" then Self else Cross t);
setTargetType (t, usage)))),
(Normal, "target-as-opt", " <target> <opt>", "target-dependent assembler option",
+ (SpaceString2 o tokenizeTargetOpt)
+ (fn (target, opt) =>
+ List.push (asOpts, {opt = opt, pred = OptPred.Target target}))),
+ (Expert, "target-as-opt-quote", " <target> <opt>", "target-dependent assembler option (quoted)",
(SpaceString2
(fn (target, opt) =>
List.push (asOpts, {opt = opt, pred = OptPred.Target target})))),
- (Expert, "target-as-opts", " <target> <opts>", "target-dependent assembler options",
- (SpaceString2
- (splitString2
- (fn (target, opt) =>
- List.push (asOpts, {opt = opt, pred = OptPred.Target target}))))),
(Normal, "target-cc-opt", " <target> <opt>", "target-dependent C compiler option",
+ (SpaceString2 o tokenizeTargetOpt)
+ (fn (target, opt) =>
+ List.push (ccOpts, {opt = opt, pred = OptPred.Target target}))),
+ (Expert, "target-cc-opt-quote", " <target> <opt>", "target-dependent C compiler option (quoted)",
(SpaceString2
(fn (target, opt) =>
List.push (ccOpts, {opt = opt, pred = OptPred.Target target})))),
- (Expert, "target-cc-opts", " <target> <opts>", "target-dependent C compiler options",
- (SpaceString2
- (splitString2
- (fn (target, opt) =>
- List.push (ccOpts, {opt = opt, pred = OptPred.Target target}))))),
(Normal, "target-link-opt", " <target> <opt>", "target-dependent linker option",
+ (SpaceString2 o tokenizeTargetOpt)
+ (fn (target, opt) =>
+ List.push (linkOpts, {opt = opt, pred = OptPred.Target target}))),
+ (Expert, "target-link-opt-quote", " <target> <opt>", "target-dependent linker option (quoted)",
(SpaceString2
(fn (target, opt) =>
List.push (linkOpts, {opt = opt, pred = OptPred.Target target})))),
- (Expert, "target-link-opts", " <target> <opts>", "target-dependent linker options",
- (SpaceString2
- (splitString2
- (fn (target, opt) =>
- List.push (linkOpts, {opt = opt, pred = OptPred.Target target}))))),
(Expert, #1 trace, " name1,...", "trace compiler internals", #2 trace),
(Expert, "type-check", " {false|true}", "type check ILs",
boolRef typeCheck),
Modified: mlton/branches/on-20050822-x86_64-branch/package/mingw/mlton.bat
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/package/mingw/mlton.bat 2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/package/mingw/mlton.bat 2006-12-19 20:09:46 UTC (rev 4991)
@@ -32,7 +32,7 @@
set linkopts=-lgdtoa -lm
set linkopts=%linkopts% -lgmp -lws2_32 -lkernel32 -lpsapi -lnetapi32
-%mlton% @MLton load-world %world% ram-slop 0.5 -- %lib% -cc %cc% -cc-opt "-I%lib%\include" -cc-opts "%ccopts%" -mlb-path-map "%lib%\mlb-path-map" -link-opts "%linkopts%" %*
+%mlton% @MLton load-world %world% ram-slop 0.5 -- %lib% -cc %cc% -cc-opt-quote "-I%lib%\include" -cc-opt "%ccopts%" -mlb-path-map "%lib%\mlb-path-map" -link-opt "%linkopts%" %*
goto :eof
:setdir
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/array-allocate.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/array-allocate.c 2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/array-allocate.c 2006-12-19 20:09:46 UTC (rev 4991)
@@ -10,66 +10,74 @@
size_t ensureBytesFree,
GC_arrayLength numElements,
GC_header header) {
- uintmax_t arraySizeMax;
- size_t arraySize;
+ uintmax_t arraySizeMax, arraySizeAlignedMax;
+ size_t arraySize, arraySizeAligned;
size_t bytesPerElement;
uint16_t bytesNonObjptrs;
uint16_t numObjptrs;
pointer frontier;
pointer last;
- pointer res;
+ pointer result;
splitHeader(s, header, NULL, NULL, &bytesNonObjptrs, &numObjptrs);
if (DEBUG)
fprintf (stderr, "GC_arrayAllocate (%zu, "FMTARRLEN", "FMTHDR")\n",
ensureBytesFree, numElements, header);
bytesPerElement = bytesNonObjptrs + (numObjptrs * OBJPTR_SIZE);
- arraySizeMax =
- alignMax ((uintmax_t)bytesPerElement * (uintmax_t)numElements + GC_ARRAY_HEADER_SIZE,
- s->alignment);
- if (arraySizeMax >= (uintmax_t)SIZE_MAX)
+ arraySizeMax =
+ (uintmax_t)bytesPerElement * (uintmax_t)numElements + GC_ARRAY_HEADER_SIZE;
+ arraySizeAlignedMax = alignMax (arraySizeMax, s->alignment);
+ if (arraySizeAlignedMax >= (uintmax_t)SIZE_MAX)
die ("Out of memory: cannot allocate array with %s bytes.",
- uintmaxToCommaString(arraySizeMax));
+ uintmaxToCommaString(arraySizeAlignedMax));
arraySize = (size_t)arraySizeMax;
- if (arraySize < GC_ARRAY_HEADER_SIZE + OBJPTR_SIZE)
+ arraySizeAligned = (size_t)arraySizeAlignedMax;
+ if (arraySizeAligned < GC_ARRAY_HEADER_SIZE + OBJPTR_SIZE) {
/* Create space for forwarding pointer. */
- arraySize = GC_ARRAY_HEADER_SIZE + OBJPTR_SIZE;
+ arraySize = GC_ARRAY_HEADER_SIZE;
+ arraySizeAligned = align(GC_ARRAY_HEADER_SIZE + OBJPTR_SIZE, s->alignment);
+ }
if (DEBUG_ARRAY)
- fprintf (stderr, "array with "FMTARRLEN" elts of size %zu and total size %s. Ensure %s bytes free.\n",
+ fprintf (stderr,
+ "Array with "FMTARRLEN" elts of size %zu and size %s and aligned size %s. "
+ "Ensure %s bytes free.\n",
numElements, bytesPerElement,
uintmaxToCommaString(arraySize),
+ uintmaxToCommaString(arraySizeAligned),
uintmaxToCommaString(ensureBytesFree));
- if (arraySize >= s->controls.oldGenArraySize) {
- if (not hasHeapBytesFree (s, arraySize, ensureBytesFree)) {
+ if (arraySizeAligned >= s->controls.oldGenArraySize) {
+ if (not hasHeapBytesFree (s, arraySizeAligned, ensureBytesFree)) {
enter (s);
- performGC (s, arraySize, ensureBytesFree, FALSE, TRUE);
+ performGC (s, arraySizeAligned, ensureBytesFree, FALSE, TRUE);
leave (s);
}
frontier = s->heap.start + s->heap.oldGenSize;
- last = frontier + arraySize;
- s->heap.oldGenSize += arraySize;
- s->cumulativeStatistics.bytesAllocated += arraySize;
+ s->heap.oldGenSize += arraySizeAligned;
+ s->cumulativeStatistics.bytesAllocated += arraySizeAligned;
} else {
size_t bytesRequested;
+ pointer newFrontier;
- bytesRequested = arraySize + ensureBytesFree;
+ bytesRequested = arraySizeAligned + ensureBytesFree;
if (not hasHeapBytesFree (s, 0, bytesRequested)) {
enter (s);
performGC (s, 0, bytesRequested, FALSE, TRUE);
leave (s);
}
frontier = s->frontier;
- last = frontier + arraySize;
- assert (isFrontierAligned (s, last));
- s->frontier = last;
+ newFrontier = frontier + arraySizeAligned;
+ assert (isFrontierAligned (s, newFrontier));
+ s->frontier = newFrontier;
}
+ last = frontier + arraySize;
*((GC_arrayCounter*)(frontier)) = 0;
frontier = frontier + GC_ARRAY_COUNTER_SIZE;
*((GC_arrayLength*)(frontier)) = numElements;
frontier = frontier + GC_ARRAY_LENGTH_SIZE;
*((GC_header*)(frontier)) = header;
frontier = frontier + GC_HEADER_SIZE;
- res = frontier;
+ result = frontier;
+ assert (isAligned ((size_t)result, s->alignment));
/* Initialize all pointers with BOGUS_OBJPTR. */
if (1 <= numObjptrs and 0 < numElements) {
pointer p;
@@ -94,10 +102,10 @@
}
}
}
- GC_profileAllocInc (s, arraySize);
+ GC_profileAllocInc (s, arraySizeAligned);
if (DEBUG_ARRAY) {
- fprintf (stderr, "GC_arrayAllocate done. res = "FMTPTR" frontier = "FMTPTR"\n",
- (uintptr_t)res, (uintptr_t)s->frontier);
+ fprintf (stderr, "GC_arrayAllocate done. result = "FMTPTR" frontier = "FMTPTR"\n",
+ (uintptr_t)result, (uintptr_t)s->frontier);
displayGCState (s, stderr);
}
assert (ensureBytesFree <= (size_t)(s->limitPlusSlop - s->frontier));
@@ -105,5 +113,5 @@
* unless we did the GC, we never set s->currentThread->stack->used
* to reflect what the mutator did with stackTop.
*/
- return res;
+ return result;
}
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/new-object.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/new-object.c 2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/new-object.c 2006-12-19 20:09:46 UTC (rev 4991)
@@ -37,6 +37,7 @@
GC_profileAllocInc (s, bytesRequested);
*((GC_header*)frontier) = header;
result = frontier + GC_NORMAL_HEADER_SIZE;
+ assert (isAligned ((size_t)result, s->alignment));
if (DEBUG)
fprintf (stderr, FMTPTR " = newObject ("FMTHDR", %zu, %s)\n",
(uintptr_t)result,
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/stack.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/stack.c 2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/stack.c 2006-12-19 20:09:46 UTC (rev 4991)
@@ -50,17 +50,29 @@
/* Pointer to the topmost word in use on the stack. */
pointer getStackTop (GC_state s, GC_stack stack) {
- return getStackBottom (s, stack) + stack->used;
+ pointer res;
+
+ res = getStackBottom (s, stack) + stack->used;
+ assert (isAligned ((size_t)res, s->alignment));
+ return res;
}
/* Pointer to the end of stack. */
pointer getStackLimitPlusSlop (GC_state s, GC_stack stack) {
- return getStackBottom (s, stack) + stack->reserved;
+ pointer res;
+
+ res = getStackBottom (s, stack) + stack->reserved;
+ // assert (isAligned ((size_t)res, s->alignment));
+ return res;
}
/* The maximum value which is valid for stackTop. */
pointer getStackLimit (GC_state s, GC_stack stack) {
- return getStackLimitPlusSlop (s, stack) - sizeofStackSlop (s);
+ pointer res;
+
+ res = getStackLimitPlusSlop (s, stack) - sizeofStackSlop (s);
+ // assert (isAligned ((size_t)res, s->alignment));
+ return res;
}
More information about the MLton-commit
mailing list