[MLton-devel] cvs commit: MLton.platform and gcc flags

Stephen Weeks sweeks@users.sourceforge.net
Tue, 26 Aug 2003 13:36:46 -0700


sweeks      03/08/26 13:36:46

  Modified:    .        Makefile
               basis-library/integer pack32.sml
               basis-library/misc primitive.sml
               basis-library/mlton platform.sig platform.sml process.sml
               basis-library/posix process.sml
               basis-library/real real.fun
               basis-library/sml-nj sml-nj.sml
               bin      mlton
               lib/mlton-stubs mlton.sml platform.sig
               mlton/codegen/c-codegen c-codegen.fun
               mlton/codegen/x86-codegen x86-codegen.fun
                        x86-mlton-basic.fun x86.fun
               mlton/control control.sig control.sml
               mlton/elaborate elaborate-core.fun
               mlton/main main.sml
               runtime  basis-constants.h
  Log:
  Split MLton.Platform.{arch,os} into MLton.Platform.{Arch,OS}.t.
  
  Moved platform-specific gcc and linker flags from main.sml into the
  bin/mlton script.  This was done by adding two new expert options,
  -target-cc-opt and -target-link-opt, which are like -cc-opt and
  -link-opt, except that they take an extra argument specifying the
  target (either arch or os) where they apply.
  
  This should make it much easier for people to customize the flags on
  their platform.

Revision  Changes    Path
1.95      +2 -2      mlton/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/Makefile,v
retrieving revision 1.94
retrieving revision 1.95
diff -u -r1.94 -r1.95
--- Makefile	26 Aug 2003 16:40:13 -0000	1.94
+++ Makefile	26 Aug 2003 20:36:43 -0000	1.95
@@ -106,7 +106,7 @@
 
 .PHONY: dirs
 dirs:
-	mkdir -p $(BIN) $(LIB)/$(HOST)/include
+	mkdir -p $(BIN) $(LIB)/$(HOST) $(LIB)/include
 
 .PHONY: docs
 docs:
@@ -170,7 +170,7 @@
 	@echo 'Compiling MLton runtime system for $(HOST).'
 	$(MAKE) -C runtime
 	$(CP) $(RUN)/*.a $(LIB)/$(HOST)/
-	$(CP) runtime/*.h include/*.h $(LIB)/$(HOST)/include/
+	$(CP) runtime/*.h include/*.h $(LIB)/include/
 
 .PHONY: script
 script:



1.8       +1 -1      mlton/basis-library/integer/pack32.sml

Index: pack32.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/integer/pack32.sml,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- pack32.sml	11 Apr 2003 04:31:08 -0000	1.7
+++ pack32.sml	26 Aug 2003 20:36:43 -0000	1.8
@@ -22,7 +22,7 @@
 	 end
       
       fun maybeRev w =
-	 if isBigEndian = Primitive.MLton.Platform.isBigEndian
+	 if isBigEndian = Primitive.MLton.Platform.Arch.isBigEndian
 	    then w
 	 else revWord w
 



1.72      +26 -20    mlton/basis-library/misc/primitive.sml

Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.71
retrieving revision 1.72
diff -u -r1.71 -r1.72
--- primitive.sml	18 Aug 2003 06:19:50 -0000	1.71
+++ primitive.sml	26 Aug 2003 20:36:43 -0000	1.72
@@ -514,29 +514,35 @@
 
 	    structure Platform =
 	       struct
-		  datatype arch = Sparc | X86
+		  structure Arch =
+		     struct
+			datatype t = Sparc | X86
 
-		  val arch: arch =
-		     case _const "MLton_Platform_arch": int; of
-			0 => Sparc
-		      | 1 => X86
-		      | _ => raise Fail "strange MLton_Platform_arch"
-			   
-		  datatype os = Cygwin | FreeBSD | Linux | NetBSD | SunOS
+			val host: t =
+			   case _const "MLton_Platform_Arch_host": int; of
+			      0 => Sparc
+			    | 1 => X86
+			    | _ => raise Fail "strange MLton_Platform_Arch_host"
 
-		  val os: os =
-		     case _const "MLton_Platform_os": int; of
-			0 => Cygwin
-		      | 1 => FreeBSD
-		      | 2 => Linux
-		      | 3 => NetBSD
-		      | 4 => SunOS
-		      | _ => raise Fail "strange MLton_Platform_os"
+			val isBigEndian =
+			   case host of
+			      X86 => false
+			    | Sparc => true
+		     end
 
-		  val isBigEndian =
-		     case arch of
-			X86 => false
-		      | Sparc => true
+		  structure OS =
+		     struct
+			datatype t = Cygwin | FreeBSD | Linux | NetBSD | SunOS
+
+			val host: t =
+			   case _const "MLton_Platform_OS_host": int; of
+			      0 => Cygwin
+			    | 1 => FreeBSD
+			    | 2 => Linux
+			    | 3 => NetBSD
+			    | 4 => SunOS
+			    | _ => raise Fail "strange MLton_Platform_OS_Host"
+		     end
 	       end
 
 	    structure Profile =



1.3       +16 -4     mlton/basis-library/mlton/platform.sig

Index: platform.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/platform.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- platform.sig	18 Aug 2003 06:19:51 -0000	1.2
+++ platform.sig	26 Aug 2003 20:36:44 -0000	1.3
@@ -1,8 +1,20 @@
 signature MLTON_PLATFORM =
    sig
-      datatype arch = Sparc | X86
-      val arch: arch
+      structure Arch:
+	 sig
+	    datatype t = Sparc | X86
+
+	    val host: t
+	    val fromString: string -> t option
+	    val toString: t -> string
+	 end
 	 
-      datatype os = Cygwin | FreeBSD | Linux | NetBSD | SunOS
-      val os: os
+      structure OS:
+	 sig
+	    datatype t = Cygwin | FreeBSD | Linux | NetBSD | SunOS
+
+	    val host: t
+	    val fromString: string -> t option
+	    val toString: t -> string
+	 end
    end



1.2       +29 -0     mlton/basis-library/mlton/platform.sml

Index: platform.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/platform.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- platform.sml	11 Apr 2003 04:31:09 -0000	1.1
+++ platform.sml	26 Aug 2003 20:36:44 -0000	1.2
@@ -1,4 +1,33 @@
 structure MLtonPlatform: MLTON_PLATFORM =
    struct
       open Primitive.MLton.Platform
+
+      fun peek (l, f) = List.find f l
+      fun omap (opt, f) = Option.map f opt
+	 
+      structure Arch =
+	 struct
+	    open Arch
+
+	    val all = [(Sparc, "sparc"), (X86, "x86")]
+
+	    fun fromString s = omap (peek (all, fn (_, s') => s = s'), #1)
+
+	    fun toString a = #2 (valOf (peek (all, fn (a', _) => a = a')))
+	 end
+
+      structure OS =
+	 struct
+	    open OS
+
+	    val all = [(Cygwin, "cygwin"),
+		       (FreeBSD, "freebsd"),
+		       (Linux, "linux"),
+		       (NetBSD, "netbsd"),
+		       (SunOS, "sunos")]
+	       
+	    fun fromString s = omap (peek (all, fn (_, s') => s = s'), #1)
+
+	    fun toString a = #2 (valOf (peek (all, fn (a', _) => a = a')))
+	 end
    end



1.8       +3 -3      mlton/basis-library/mlton/process.sml

Index: process.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/process.sml,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- process.sml	5 Jul 2003 19:01:44 -0000	1.7
+++ process.sml	26 Aug 2003 20:36:44 -0000	1.8
@@ -6,10 +6,10 @@
 
       type pid = Posix.Process.pid
 
-      structure Platform = MLton.Platform
+      val isCygwin = let open MLton.Platform.OS in host = Cygwin end
 	 
       fun spawne {path, args, env} =
-	 if Platform.os = Platform.Cygwin
+	 if isCygwin
 	    then Error.checkReturnResult (Prim.spawne (String.nullTerm path,
 						       C.CSS.fromList args,
 						       C.CSS.fromList env))
@@ -22,7 +22,7 @@
 	 spawne {path = path, args = args, env = Posix.ProcEnv.environ ()}
 
       fun spawnp {file, args} =
-	 if Platform.os = Platform.Cygwin
+	 if isCygwin
 	    then Error.checkReturnResult (Prim.spawnp (String.nullTerm file,
 						       C.CSS.fromList args))
 	 else	 



1.13      +1 -2      mlton/basis-library/posix/process.sml

Index: process.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/process.sml,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- process.sml	3 Jul 2003 17:10:07 -0000	1.12
+++ process.sml	26 Aug 2003 20:36:44 -0000	1.13
@@ -24,9 +24,8 @@
 	  | 0 => NONE
 	  | n => SOME n
 
-      structure Platform = MLton.Platform
       val fork =
-	 if Platform.os <> Platform.Cygwin
+	 if let open MLton.Platform.OS in host <> Cygwin end
 	    then fork
  	 else
 	    fn () =>



1.4       +8 -5      mlton/basis-library/real/real.fun

Index: real.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/real.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- real.fun	25 Aug 2003 20:00:04 -0000	1.3
+++ real.fun	26 Aug 2003 20:36:44 -0000	1.4
@@ -59,16 +59,19 @@
 	    open Prim.Math
 
 	    structure MLton = Primitive.MLton
-	    structure Platform = MLton.Platform
 	    (* Patches for Cygwin and SunOS, whose math libraries do not handle
 	     * out-of-range args.
 	     *)
 	    val (acos, asin, ln, log10) =
 	       if not MLton.native
-		  andalso (case Platform.os of
-			      Platform.Cygwin => true
-			    | Platform.SunOS => true
-			    | _ => false)
+		  andalso let
+			     open MLton.Platform.OS
+			  in
+			     case host of
+				Cygwin => true
+			      | SunOS => true
+			      | _ => false
+			  end
 		  then
 		     let
 			fun patch f x =



1.10      +4 -4      mlton/basis-library/sml-nj/sml-nj.sml

Index: sml-nj.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/sml-nj/sml-nj.sml,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- sml-nj.sml	18 Aug 2003 06:19:52 -0000	1.9
+++ sml-nj.sml	26 Aug 2003 20:36:44 -0000	1.10
@@ -23,9 +23,9 @@
 
 	    fun getHostArch () =
 	       let
-		  open Primitive.MLton.Platform
+		  open MLton.Platform.Arch
 	       in
-		  case arch of
+		  case host of
 		     X86 => "X86"
 		   | Sparc => "SPARC"
 	       end
@@ -33,9 +33,9 @@
 	    fun getOSKind () = UNIX
 	    fun getOSName () =
 	       let
-		  open Primitive.MLton.Platform
+		  open MLton.Platform.OS
 	       in
-		  case os of
+		  case host of
 		     Cygwin => "Cygwin"
 		   | FreeBSD => "FreeBSD"
 		   | Linux => "Linux"



1.24      +4 -3      mlton/bin/mlton

Index: mlton
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/mlton,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- mlton	26 Aug 2003 16:38:04 -0000	1.23
+++ mlton	26 Aug 2003 20:36:44 -0000	1.24
@@ -41,12 +41,13 @@
 # about -m.  Someday, when we think we won't run into older gcc's,
 # these should be changed to -f.
 
-# You may need to add -link-opt '-L/path/to/libgmp' before the "$@" so that the
-# linker can find the gmp.
+# You may need to add a line with -link-opt '-L/path/to/libgmp' so
+# that the linker can find the gmp.
 
 doit "$lib" \
 	-cc "$gcc"						\
 	-cc-opt "-I$lib/include"				\
+	-cc-opt '-O1'						\
 	-cc-opt '-fno-strict-aliasing -fomit-frame-pointer -w'	\
 	-target-cc-opt x86					\
 		'-fno-strength-reduce
@@ -55,7 +56,7 @@
 		-malign-functions=5
 		-malign-jumps=2
 		-malign-loops=2
-		-mcpu=pentiumpro'
+		-mcpu=pentiumpro'				\
 	-target-cc-opt sparc 					\
 		'-Wa,-xarch=v8plusa
 		-fcall-used-g5



1.24      +31 -6     mlton/lib/mlton-stubs/mlton.sml

Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/mlton.sml,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- mlton.sml	18 Aug 2003 06:19:52 -0000	1.23
+++ mlton.sml	26 Aug 2003 20:36:44 -0000	1.24
@@ -143,13 +143,38 @@
 
       structure Platform =
 	 struct
-	    datatype arch = Sparc | X86
-			     
-	    val arch: arch = X86
-			   
-	    datatype os = Cygwin | FreeBSD | Linux | NetBSD | SunOS
+	    fun peek (l, f) = List.find f l
+	    fun omap (opt, f) = Option.map f opt
+	 
+	    structure Arch =
+	       struct
+		  datatype t = Sparc | X86
 
-	    val os: os = SunOS
+		  val host: t = X86
+
+		  val all = [(Sparc, "sparc"), (X86, "x86")]
+
+		  fun fromString s = omap (peek (all, fn (_, s') => s = s'), #1)
+
+		  fun toString a = #2 (valOf (peek (all, fn (a', _) => a = a')))
+	       end
+
+	    structure OS =
+	       struct
+		  datatype t = Cygwin | FreeBSD | Linux | NetBSD | SunOS
+
+		  val host: t = Linux
+
+		  val all = [(Cygwin, "cygwin"),
+			     (FreeBSD, "freebsd"),
+			     (Linux, "linux"),
+			     (NetBSD, "netbsd"),
+			     (SunOS, "sunos")]
+	       
+		  fun fromString s = omap (peek (all, fn (_, s') => s = s'), #1)
+
+		  fun toString a = #2 (valOf (peek (all, fn (a', _) => a = a')))
+	       end
 	 end
 
       structure ProcEnv =



1.3       +16 -4     mlton/lib/mlton-stubs/platform.sig

Index: platform.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/platform.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- platform.sig	18 Aug 2003 06:19:52 -0000	1.2
+++ platform.sig	26 Aug 2003 20:36:45 -0000	1.3
@@ -1,8 +1,20 @@
 signature MLTON_PLATFORM =
    sig
-      datatype arch = Sparc | X86
-      val arch: arch
+      structure Arch:
+	 sig
+	    datatype t = Sparc | X86
+
+	    val host: t
+	    val fromString: string -> t option
+	    val toString: t -> string
+	 end
 	 
-      datatype os = Cygwin | FreeBSD | Linux | NetBSD | SunOS
-      val os: os
+      structure OS:
+	 sig
+	    datatype t = Cygwin | FreeBSD | Linux | NetBSD | SunOS
+
+	    val host: t
+	    val fromString: string -> t option
+	    val toString: t -> string
+	 end
    end



1.65      +1 -1      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.64
retrieving revision 1.65
diff -u -r1.64 -r1.65
--- c-codegen.fun	26 Aug 2003 03:53:28 -0000	1.64
+++ c-codegen.fun	26 Aug 2003 20:36:45 -0000	1.65
@@ -563,7 +563,7 @@
 	 end
       val handleMisalignedReals =
 	 !Control.align = Control.Align4
-	 andalso !Control.hostArch = Control.Sparc
+	 andalso !Control.hostArch = MLton.Platform.Arch.Sparc
       fun addr z = concat ["&(", z, ")"]
       fun realFetch z = concat ["Real64_fetch(", addr z, ")"]
       fun realMove {dst, src} =



1.48      +4 -12     mlton/mlton/codegen/x86-codegen/x86-codegen.fun

Index: x86-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-codegen.fun,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -r1.47 -r1.48
--- x86-codegen.fun	18 Aug 2003 06:19:52 -0000	1.47
+++ x86-codegen.fun	26 Aug 2003 20:36:45 -0000	1.48
@@ -92,12 +92,7 @@
 	     * that don't handle signals, since signals get used under the hood
 	     * in Cygwin.
 	     *)
-	    case !Control.hostOS of
-	       Control.Cygwin => true
-	     | Control.FreeBSD => false
-	     | Control.Linux => false
-	     | Control.NetBSD => false
-	     | _ => Error.bug "x86 can't handle hostType"
+	    !Control.hostOS = MLton.Platform.OS.Cygwin
 
 	val makeC = outputC
 	val makeS = outputS
@@ -158,12 +153,9 @@
 		    (* Drop the leading _ with Cygwin, because gcc will add it.
 		     *)
 		    val mainLabel =
-		       case !Control.hostOS of
-			  Control.Cygwin => String.dropPrefix (mainLabel, 1)
-			| Control.FreeBSD => mainLabel
-			| Control.Linux => mainLabel
-			| Control.NetBSD => mainLabel
-			| _ => Error.bug "x86 can't handle hostType"
+		       if !Control.hostOS = MLton.Platform.OS.Cygwin
+			  then String.dropPrefix (mainLabel, 1)
+		       else mainLabel
 		 in
 		    [mainLabel, if reserveEsp then C.truee else C.falsee]
 		 end



1.24      +3 -6      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.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- x86-mlton-basic.fun	18 Aug 2003 06:19:52 -0000	1.23
+++ x86-mlton-basic.fun	26 Aug 2003 20:36:45 -0000	1.24
@@ -371,12 +371,9 @@
   val fileLineLabel =
      Promise.lazy
      (fn () =>
-      Label.fromString (case !Control.hostOS of
-			   Control.Cygwin => "_LINE__"
-			 | Control.FreeBSD => "__LINE__"
-			 | Control.Linux => "__LINE__"
-			 | Control.NetBSD => "__LINE__"
-			 | _ => Error.bug "x86 can't handle hostOS"))
+      Label.fromString (if !Control.hostOS = MLton.Platform.OS.Cygwin
+			   then "_LINE__"
+			else "__LINE__"))
 					 
   val fileLine
     = fn () => if !Control.debug



1.43      +3 -6      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.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- x86.fun	22 Aug 2003 04:25:25 -0000	1.42
+++ x86.fun	26 Aug 2003 20:36:45 -0000	1.43
@@ -62,12 +62,9 @@
 	open Label
 
 	fun toString l =
-	   case !Control.hostOS of
-	      Control.Cygwin => concat ["_", Label.toString l]
-	    | Control.FreeBSD => Label.toString l
-	    | Control.Linux => Label.toString l
-	    | Control.NetBSD => Label.toString l
-	    | _ => Error.bug "x86 can't handle hostOS"
+	   if !Control.hostOS =  MLton.Platform.OS.Cygwin
+	      then concat ["_", Label.toString l]
+	   else Label.toString l
 
 	val layout = Layout.str o toString
      end



1.78      +2 -4      mlton/mlton/control/control.sig

Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.77
retrieving revision 1.78
diff -u -r1.77 -r1.78
--- control.sig	7 Jul 2003 22:50:29 -0000	1.77
+++ control.sig	26 Aug 2003 20:36:45 -0000	1.78
@@ -69,11 +69,9 @@
        | Self
       val host: host ref
 
-      datatype hostArch = datatype MLton.Platform.arch
-      val hostArch: hostArch ref
+      val hostArch: MLton.Platform.Arch.t ref
 
-      datatype hostOS = datatype MLton.Platform.os
-      val hostOS: hostOS ref
+      val hostOS: MLton.Platform.OS.t ref
 
       (* Indentation used in laying out ILs. *)
       val indentation: int ref



1.95      +4 -29     mlton/mlton/control/control.sml

Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.94
retrieving revision 1.95
diff -u -r1.94 -r1.95
--- control.sml	18 Aug 2003 06:19:52 -0000	1.94
+++ control.sml	26 Aug 2003 20:36:46 -0000	1.95
@@ -145,38 +145,13 @@
 		    default = Self,
 		    toString = Host.toString}
 
-structure HostArch =
-   struct
-      datatype t = datatype MLton.Platform.arch
-
-      val toString =
-	 fn X86 => "X86"
-	  | Sparc => "SPARC"
-   end
-
-datatype hostArch = datatype HostArch.t
-
 val hostArch = control {name = "host arch",
-			default = X86,
-			toString = HostArch.toString}
-
-structure HostOS =
-   struct
-      datatype t = datatype MLton.Platform.os
-	 
-      val toString =
-	 fn Cygwin => "Cygwin"
-	  | FreeBSD => "FreeBSD"
-	  | Linux => "Linux"
-	  | NetBSD => "NetBSD"
-	  | SunOS => "SunOS"
-   end
+			default = MLton.Platform.Arch.X86,
+			toString = MLton.Platform.Arch.toString}
 
-datatype hostOS = datatype HostOS.t
-   
 val hostOS = control {name = "host OS",
-		      default = Linux,
-		      toString = HostOS.toString}
+		      default = MLton.Platform.OS.Linux,
+		      toString = MLton.Platform.OS.toString}
 
 val indentation = control {name = "indentation",
 			   default = 3,



1.26      +1 -1      mlton/mlton/elaborate/elaborate-core.fun

Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- elaborate-core.fun	18 Aug 2003 05:34:56 -0000	1.25
+++ elaborate-core.fun	26 Aug 2003 20:36:46 -0000	1.26
@@ -405,7 +405,7 @@
 	 SOME (case a of
 		  Attribute.Cdecl => Convention.Cdecl
 		| Attribute.Stdcall =>
-		     if !Control.hostOS = Control.Cygwin
+		     if !Control.hostOS = MLton.Platform.OS.Cygwin
 			then Convention.Stdcall
 		     else Convention.Cdecl)
     | _ => NONE



1.154     +64 -143   mlton/mlton/main/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.153
retrieving revision 1.154
diff -u -r1.153 -r1.154
--- main.sml	22 Aug 2003 04:10:39 -0000	1.153
+++ main.sml	26 Aug 2003 20:36:46 -0000	1.154
@@ -40,20 +40,20 @@
 val coalesce: int option ref = ref NONE
 val expert: bool ref = ref false
 val gcc: string ref = ref "<unset>"
-val includeDirs: string list ref = ref []
 val keepGenerated = ref false
 val keepO = ref false
 val keepSML = ref false
 val linkOpts: string list ref = ref []
 val output: string option ref = ref NONE
-val optimization: int ref = ref 1
 val profileSet: bool ref = ref false
 val showBasis: bool ref = ref false
 val stop = ref Place.OUT
+val targetCCOpts: {opt: string, target: string} list ref = ref []
+val targetLinkOpts: {opt: string, target: string} list ref = ref []
 
-val hostMap: unit -> {arch: Control.hostArch,
+val hostMap: unit -> {arch: MLton.Platform.Arch.t,
 		      host: string,
-		      os: Control.hostOS} list =
+		      os: MLton.Platform.OS.t} list =
    Promise.lazy
    (fn () =>
     List.map
@@ -62,18 +62,13 @@
 	[host, arch, os] =>
 	   let
 	      val arch =
-		 case arch of
-		    "x86" => Control.X86
-		  | "sparc" => Control.Sparc
-		  | _ => Error.bug (concat ["strange arch: ", arch])
+		 case MLton.Platform.Arch.fromString arch of
+		    NONE => Error.bug (concat ["strange arch: ", arch])
+		  | SOME a => a
 	      val os =
-		 case os of
-		    "cygwin" => Control.Cygwin
-		  | "freebsd" => Control.FreeBSD
-		  | "linux" => Control.Linux
-		  | "netbsd" => Control.NetBSD
-		  | "sunos" => Control.SunOS
-		  | _ => Error.bug (concat ["strange os: ", os])
+		 case MLton.Platform.OS.fromString os of
+		    NONE => Error.bug (concat ["strange os: ", os])
+		  | SOME os => os
 	   in
 	      {arch = arch, host = host, os = os}
 	   end
@@ -84,6 +79,7 @@
       NONE => usage (concat ["invalid host ", hostString])
     | SOME {arch, os, ...} =>
 	 let
+	    datatype z = datatype MLton.Platform.Arch.t
 	    open Control
 	 in
 	    hostArch := arch
@@ -100,6 +96,7 @@
       val usage = fn s => (usage s; raise Fail "unreachable")
       open Control Popt
       fun push r = SpaceString (fn s => List.push (r, s))
+      datatype z = datatype MLton.Platform.Arch.t
    in
       List.map
       (
@@ -135,17 +132,7 @@
        (Expert, "cc", " <gcc>", "path to gcc executable",
 	SpaceString (fn s => gcc := s)),
        (Normal, "cc-opt", " <opt>", "pass option to C compiler",
-	SpaceString (fn opt =>
-		     if opt = ""
-			then ccOpts := []
-		     else 
-			if (3 = String.size opt
-			    andalso String.isPrefix {prefix = "-O",
-						     string = opt})
-			   then optimization := (Char.toInt
-						 (String.sub (opt, 2))
-						 - Char.toInt #"0")
-			else List.push (ccOpts, opt))),
+	push ccOpts),
        (Expert, "coalesce", " <n>", "coalesce chunk size for C codegen",
 	Int (fn n => coalesce := SOME n)),
        (Expert, "debug", " {false|true}", "produce executable with debug info",
@@ -248,10 +235,7 @@
 	"compute dynamic counts of limit checks",
 	boolRef limitCheckCounts),
        (Normal, "link-opt", " <opt>", "pass option to linker",
-	SpaceString (fn s =>
-		     if s = ""
-			then linkOpts := []
-		     else List.push (linkOpts, s))),
+	push linkOpts),
        (Expert, "loop-passes", " <n>", "loop optimization passes (1)",
 	Int 
 	(fn i => 
@@ -264,7 +248,9 @@
 	"may @MLton load-world be used",
 	boolRef mayLoadWorld),
        (Normal, "native",
-	if !hostArch = Sparc then " {false}" else " {true|false}",
+	if !hostArch = MLton.Platform.Arch.Sparc
+	   then " {false}"
+	else " {true|false}",
 	"use native code generator",
 	boolRef Native.native),
        (Expert, "native-commented", " <n>", "level of comments  (0)",
@@ -346,6 +332,15 @@
 		   | "o" => Place.O
 		   | "sml" => Place.SML
 		   | _ => usage (concat ["invalid -stop arg: ", s])))),
+       (Expert, "target-cc-opt", " target <opt>", "target-dependent CC option",
+	(SpaceString2
+	 (fn (target, opt) =>
+	  List.push (targetCCOpts, {opt = opt, target = target})))),
+       (Expert, "target-link-opt", " target <opt>",
+	"target-dependent link option",
+	(SpaceString2
+	 (fn (target, opt) =>
+	  List.push (targetLinkOpts, {opt = opt, target = target})))),
        (Expert, #1 trace, " name1,...", "trace compiler internals", #2 trace),
        (Expert, "text-io-buf-size", " <n>", "TextIO buffer size",
 	intRef textIOBufSize),
@@ -400,89 +395,26 @@
 	  | Self => "self"
       val lib = concat [!libDir, "/", hostString]
       val _ = Control.libDir := lib
-      val includeDirs = concat [lib, "/include"] :: !includeDirs
-      (* Much of the commentary for the C flags is taken from the gcc docs. *)
-      val standardCFlags =
-	 [
-	  (* Do not allow gcc to assume the strictest aliasing rules, in which
-	   * an object of one type is assumed never to reside at the same
-	   * address as an object of a different type, unless the types are
-	   * almost the same.
-	   *)
-	  "-fno-strict-aliasing",
-	  (* Don't keep the frame pointer in a register for functions that
-	   * don't need one.
-	   *)
-	  "-fomit-frame-pointer",
-	  "-w"]
-      val x86CFlags =
-	 standardCFlags
-	 @ [
-	    (* Don't perform the optimizations of loop strength reduction and
-	     * elimination of iteration variables.
-	     *)
-	    "-fno-strength-reduce",
-	     (* Attempt to reorder instructions to eliminate execution stalls
-	      * due to required data being unavailable.
-	      *)
-	    "-fschedule-insns",
-	    "-fschedule-insns2",
-	    (* For align-{functions,jumps,loops, we use -m for now instead of
-	     * -f because old gcc's will barf on -f, while newer ones only warn
-	     * about -m.  Someday, when we think we won't run into older gcc's,
-	     * these should be changed to -f.
-	     *)
-	    (* `-falign-functions=N'
-	     * Align the start of functions to the next power-of-two greater
-	     * than N, skipping up to N bytes.
-	     *)
-	    "-malign-functions=5",
-	    (* Align branch targets to a power-of-two boundary. *)
-	    "-malign-jumps=2",
-	    (* Align loops to a power-of-two boundary. *)
-	    "-malign-loops=2",
-            (* Assume the defaults for the machine type when scheduling
-	     * instructions.
-	     * pentiumpro is the same as i686.
-	     *)
-	     "-mcpu=pentiumpro"] 
-      val x86LinkLibs = []
-      val sparcCFlags =
-	 standardCFlags
-	 @ [
-	    (* Enable the SPARC V9 instruction set with UltraSPARC extensions. *)
-	    "-Wa,-xarch=v8plusa",
-	    (* Treat the registers g5, g7 as allocable registers that are
-	     * clobbered by function calls.
-	     *)
-	    "-fcall-used-g5",
-	    "-fcall-used-g7",
-	    (* Generate code for a 32 bit environment. *)
-	    "-m32",
-	    (* Emit integer multiply and integer divide instructions that exist
-	     * in SPARC v8 but not in SPARC v7.
-	     *)
-	    "-mv8",
-	    (* Set the instruction set, register set, and instruction scheduling 
-	     * parameters for machine type.
-	     *)
-	    "-mcpu=ultrasparc",
-	    (* Emit exit code inline at every function exit. *)
-	    "-mno-epilogue"]
-      val sparcLinkLibs = ["dl", "nsl", "socket"]
-      val (ccDefaultOpts, defaultLibs) =
-	 case !hostArch of
-	    X86 => (x86CFlags, x86LinkLibs)
-	  | Sparc => (sparcCFlags, sparcLinkLibs)
-      fun prefixAll (prefix: string, l: string list): string list =
-	 List.map (l, fn s => concat [prefix, s])
-      val defaultLibs =
-	 prefixAll ("-l", defaultLibs @ ["gdtoa", "m"])
+      val hostArch = !hostArch
+      val archStr = MLton.Platform.Arch.toString hostArch
+      val hostOS = !hostOS
+      val OSStr = MLton.Platform.OS.toString hostOS
       fun tokenize l =
-	 String.tokens (concat (List.separate (rev (!l), " ")), Char.isSpace)
-      val ccOpts = tokenize ccOpts
+	 String.tokens (concat (List.separate (l, " ")), Char.isSpace)
+      fun addTargetOpts (opts, targetOpts) =
+	 tokenize
+	 (List.append
+	  (List.fold
+	   (!targetOpts, [], fn ({opt, target}, ac) =>
+	    if target = archStr orelse target = OSStr
+	       then opt :: ac
+	    else ac),
+	   rev (!opts)))
+      val ccOpts = addTargetOpts (ccOpts, targetCCOpts)
+      val linkOpts = addTargetOpts (linkOpts, targetLinkOpts)
+      datatype z = datatype MLton.Platform.OS.t
       val linkWithGmp =
-	 case !hostOS of
+	 case hostOS of
 	    Cygwin => ["-lgmp"]
 	  | FreeBSD => ["-L/usr/local/lib/", "-lgmp"]
 	  | Linux =>
@@ -514,11 +446,10 @@
       val linkOpts =
 	 List.concat [[concat ["-L", lib],
 		       if !debug then "-lmlton-gdb" else "-lmlton"],
-		      tokenize linkOpts,
-		      defaultLibs,
+		      linkOpts,
 		      linkWithGmp]
       val _ =
-	 if !Native.native andalso !hostArch = Sparc
+	 if !Native.native andalso hostArch = MLton.Platform.Arch.Sparc
 	    then usage "can't use -native true on Sparc"
 	 else ()
       val _ =
@@ -538,7 +469,7 @@
 	    then keepSSA := true
 	 else ()
       val _ =
-	 if !hostOS = Cygwin andalso !profile = ProfileTime
+	 if hostOS = MLton.Platform.OS.Cygwin andalso !profile = ProfileTime
 	    then usage "can't use -profile time on Cygwin"
 	 else ()
       fun printVersion (out: Out.t): unit =
@@ -626,15 +557,9 @@
 			 | SOME f => f
 		     fun docc (inputs: File.t list,
 			       output: File.t,
-			       switches: string list,
-			       linkOpts: string list): unit =
+			       switches: string list): unit =
 			System.system
-			(gcc, List.concat [switches,
-					   ["-o", output],
-					   inputs,
-					   linkOpts])
-		     val definesAndIncludes =
-			prefixAll ("-I", rev (includeDirs))
+			(gcc, List.concat [switches, ["-o", output], inputs])
 		     datatype debugFormat =
 			Dwarf | DwarfPlus | Dwarf2 | Stabs | StabsPlus
 		     (* The -Wa,--gstabs says to pass the --gstabs option to the
@@ -655,23 +580,26 @@
 			   val _ =
 			      trace (Top, "Link")
 			      (fn () =>
-			       docc (inputs, output,
-				     List.concat
-				     [case host of
-					 Cross s => ["-b", s]
-				       | Self => [],
-				      if !debug then gccDebug else [],
-				      if !static then ["-static"] else []],
-				     linkOpts))
+			       System.system
+			       (gcc,
+				List.concat
+				[["-o", output],
+				 (case host of
+				     Cross s => ["-b", s]
+				   | Self => []),
+				 if !debug then gccDebug else [],
+				 if !static then ["-static"] else [],
+				 inputs,
+				 linkOpts]))
 			      ()
 			   (* gcc on Cygwin appends .exe, which I don't want, so
 			    * move the output file to it's rightful place.
-			    * Notice that we do not use !hostOS here, since we
+			    * Notice that we do not use hostOS here, since we
 			    * care about the platform we're running on, not the
 			    * platform we're generating for.
 			    *)
 			   val _ =
-			      if MLton.Platform.os = Cygwin
+			      if let open MLton.Platform.OS in host = Cygwin end
 				 then
 				    if String.contains (output, #".")
 				       then ()
@@ -705,13 +633,7 @@
 					 if SOME "c" = extension
 					    then
 					       (gccDebug @ ["-DASSERT=1"],
-						List.concat
-						[definesAndIncludes,
-						 [concat
-						  ["-O", (Int.toString
-							  (!optimization))]],
-						 ccDefaultOpts,
-						 ccOpts])
+						ccOpts)
 					 else ([asDebug], [])
 				      val switches =
 					 if !debug
@@ -738,8 +660,7 @@
 							   (Counter.next c),
 							   ".o"])
 					 else temp ".o"
-				      val _ =
-					 docc ([input], output, switches, [])
+				      val _ = docc ([input], output, switches)
 				   in
 				      output :: ac
 				   end



1.16      +9 -9      mlton/runtime/basis-constants.h

Index: basis-constants.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis-constants.h,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- basis-constants.h	18 Aug 2003 06:19:53 -0000	1.15
+++ basis-constants.h	26 Aug 2003 20:36:46 -0000	1.16
@@ -31,25 +31,25 @@
 /* ------------------------------------------------- */
 
 #if (defined (__sparc__))
-#define MLton_Platform_arch 0
+#define MLton_Platform_Arch_host 0
 #elif (defined (__i386__))
-#define MLton_Platform_arch 1
+#define MLton_Platform_Arch_host 1
 #else
-#error MLton_Platform_arch not defined
+#error MLton_Platform_Arch_host not defined
 #endif
 
 #if (defined (__CYGWIN__))
-#define MLton_Platform_os 0
+#define MLton_Platform_OS_host 0
 #elif (defined (__FreeBSD__))
-#define MLton_Platform_os 1
+#define MLton_Platform_OS_host 1
 #elif (defined (__linux__))
-#define MLton_Platform_os 2
+#define MLton_Platform_OS_host 2
 #elif (defined (__NetBSD__))
-#define MLton_Platform_os 3
+#define MLton_Platform_OS_host 3
 #elif (defined (__sun__))
-#define MLton_Platform_os 4
+#define MLton_Platform_OS_host 4
 #else
-#error MLton_Platform_os not defined
+#error MLton_Platform_OS_host not defined
 #endif
 
 #if (defined (__sun__))





-------------------------------------------------------
This SF.net email is sponsored by: VM Ware
With VMware you can run multiple operating systems on a single machine.
WITHOUT REBOOTING! Mix Linux / Windows / Novell virtual machines
at the same time. Free trial click here:http://www.vmware.com/wl/offer/358/0
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel