X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDynFlags.hs;h=df4052cff4d2824efefd24302faa92c8a37dd3da;hb=e1b45af148b2db08518a543f58c28a60c1f815b6;hp=359ea39ec8806ccaa3a696278342a8ba2b32191f;hpb=97c186be0bd51ebe0fb4c28df8836f03e3dbd06d;p=ghc-hetmet.git

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 359ea39..df4052c 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -29,6 +29,7 @@ module DynFlags (
 	GhcLink(..), isNoLink,
 	PackageFlag(..),
 	Option(..),
+	DynLibLoader(..),
         fFlags, xFlags,
 
 	-- Configuration of the core-to-core and stg-to-stg phases
@@ -93,6 +94,7 @@ import Util		( split )
 #endif
 
 import Data.Char
+import System.FilePath
 import System.IO        ( hPutStrLn, stderr )
 
 -- -----------------------------------------------------------------------------
@@ -332,6 +334,7 @@ data DynFlags = DynFlags {
 
   outputFile		:: Maybe String,
   outputHi		:: Maybe String,
+  dynLibLoader		:: DynLibLoader,
 
   -- | This is set by DriverPipeline.runPipeline based on where
   --	its output is going.
@@ -458,6 +461,12 @@ defaultObjectTarget
   | cGhcWithNativeCodeGen == "YES" 	=  HscAsm
   | otherwise				=  HscC
 
+data DynLibLoader
+  = Deployable
+  | Wrapped (Maybe String)
+  | SystemDependent
+  deriving Eq
+
 initDynFlags dflags = do
  -- someday these will be dynamic flags
  ways <- readIORef v_Ways
@@ -504,6 +513,7 @@ defaultDynFlags =
 
 	outputFile		= Nothing,
 	outputHi		= Nothing,
+	dynLibLoader		= Deployable,
 	dumpPrefix		= Nothing,
 	dumpPrefixForce		= Nothing,
 	includePaths		= [],
@@ -600,6 +610,15 @@ setHcSuf      f d = d{ hcSuf      = f}
 setOutputFile f d = d{ outputFile = f}
 setOutputHi   f d = d{ outputHi   = f}
 
+parseDynLibLoaderMode f d =
+ case splitAt 8 f of
+   ("deploy", "")       -> d{ dynLibLoader = Deployable }
+   ("sysdep", "")       -> d{ dynLibLoader = SystemDependent }
+   ("wrapped", "")      -> d{ dynLibLoader = Wrapped Nothing }
+   ("wrapped:", "hard") -> d{ dynLibLoader = Wrapped Nothing }
+   ("wrapped:", flex)   -> d{ dynLibLoader = Wrapped (Just flex) }
+   (_,_)                -> error "Unknown dynlib loader"
+
 setDumpPrefixForce f d = d { dumpPrefixForce = f}
 
 -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]
@@ -774,6 +793,10 @@ runWhen :: Bool -> CoreToDo -> CoreToDo
 runWhen True  do_this = do_this
 runWhen False do_this = CoreDoNothing
 
+runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
+runMaybe (Just x) f = f x
+runMaybe Nothing  _ = CoreDoNothing
+
 getCoreToDo :: DynFlags -> [CoreToDo]
 getCoreToDo dflags
   | Just todo <- coreToDo dflags = todo -- set explicitly by user
@@ -790,8 +813,7 @@ getCoreToDo dflags
     rule_check    = ruleCheck dflags
     vectorisation = dopt Opt_Vectorise dflags
 
-    maybe_rule_check phase | Just s <- rule_check = CoreDoRuleCheck phase s
-                           | otherwise            = CoreDoNothing
+    maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
 
     simpl_phase phase iter = CoreDoPasses
                                [ CoreDoSimplify (SimplPhase phase) [
@@ -842,7 +864,7 @@ getCoreToDo dflags
 
         -- We run vectorisation here for now, but we might also try to run
         -- it later
-        runWhen vectorisation (CoreDoPasses [ CoreDoVectorisation, simpl_gently]),
+        runWhen vectorisation (CoreDoPasses [ CoreDoVectorisation, simpl_gently ]),
 
 	-- Specialisation is best done before full laziness
 	-- so that overloaded functions have all their dictionary lambdas manifest
@@ -989,6 +1011,7 @@ dynamic_flags = [
   ,  ( "c"		, NoArg (upd $ \d -> d{ ghcLink=NoLink } ))
   ,  ( "no-link"	, NoArg (upd $ \d -> d{ ghcLink=NoLink } )) -- Dep.
   ,  ( "shared"		, NoArg (upd $ \d -> d{ ghcLink=LinkDynLib } ))
+  ,  ( "dynload"	, HasArg (upd . parseDynLibLoaderMode))
 
 	------- Libraries ---------------------------------------------------
   ,  ( "L"		, Prefix addLibraryPath )
@@ -1332,7 +1355,10 @@ xFlags = [
 
 impliedFlags :: [(DynFlag, [DynFlag])]
 impliedFlags = [
-  ( Opt_GADTs, [Opt_RelaxedPolyRec] )	-- We want type-sig variables to be completely rigid for GADTs
+   ( Opt_GADTs, 	      [Opt_RelaxedPolyRec] )	-- We want type-sig variables to 
+							-- 	be completely rigid for GADTs
+ , ( Opt_ScopedTypeVariables, [Opt_RelaxedPolyRec] )	-- Ditto for scoped type variables; see
+							-- 	Note [Scoped tyvars] in TcBinds
   ]
 
 glasgowExtsFlags = [
@@ -1567,32 +1593,28 @@ setTmpDir :: FilePath -> DynFlags -> DynFlags
 setTmpDir dir dflags = dflags{ tmpDir = canonicalise dir }
   where
 #if !defined(mingw32_HOST_OS)
-     canonicalise p = normalisePath p
+     canonicalise p = normalise p
 #else
-	-- Canonicalisation of temp path under win32 is a bit more
-	-- involved: (a) strip trailing slash, 
-	-- 	     (b) normalise slashes
-	--	     (c) just in case, if there is a prefix /cygdrive/x/, change to x:
-	-- 
-     canonicalise path = normalisePath (xltCygdrive (removeTrailingSlash path))
-
-        -- if we're operating under cygwin, and TMP/TEMP is of
-	-- the form "/cygdrive/drive/path", translate this to
-	-- "drive:/path" (as GHC isn't a cygwin app and doesn't
-	-- understand /cygdrive paths.)
-     xltCygdrive path
-      | "/cygdrive/" `isPrefixOf` path = 
-	  case drop (length "/cygdrive/") path of
-	    drive:xs@('/':_) -> drive:':':xs
-	    _ -> path
-      | otherwise = path
-
-        -- strip the trailing backslash (awful, but we only do this once).
-     removeTrailingSlash path = 
-       case last path of
-         '/'  -> init path
-         '\\' -> init path
-         _    -> path
+     -- Canonicalisation of temp path under win32 is a bit more
+     -- involved: (a) strip trailing slash,
+     --      (b) normalise slashes
+     --     (c) just in case, if there is a prefix /cygdrive/x/, change to x:
+     canonicalise path = removeTrailingSlash $ normalise $ xltCygdrive path
+
+     -- if we're operating under cygwin, and TMP/TEMP is of
+     -- the form "/cygdrive/drive/path", translate this to
+     -- "drive:/path" (as GHC isn't a cygwin app and doesn't
+     -- understand /cygdrive paths.)
+     cygdrivePrefix = [pathSeparator] ++ "/cygdrive/" ++ [pathSeparator]
+     xltCygdrive path = case maybePrefixMatch cygdrivePrefix path of
+                        Just (drive:sep:xs)
+                         | isPathSeparator sep -> drive:':':pathSeparator:xs
+                        _ -> path
+
+     -- strip the trailing backslash (awful, but we only do this once).
+     removeTrailingSlash path
+      | isPathSeparator (last path) = init path
+      | otherwise                   = path
 #endif
 
 -----------------------------------------------------------------------------