From: Adam Megacz Date: Mon, 25 Apr 2011 00:31:58 +0000 (-0700) Subject: Merge branch 'master' of http://darcs.haskell.org/ghc X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=1c6d61ee06972de3c4797e1925e265f7dc7c361c;hp=-c Merge branch 'master' of darcs.haskell.org/ghc --- 1c6d61ee06972de3c4797e1925e265f7dc7c361c diff --combined compiler/basicTypes/Name.lhs index de8a3a3,f2ae963..aac7670 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@@ -64,7 -64,6 +64,7 @@@ module Name getSrcLoc, getSrcSpan, getOccString, pprInfixName, pprPrefixName, pprModulePrefix, + getNameDepth, setNameDepth, -- Re-export the OccName stuff module OccName @@@ -107,17 -106,12 +107,18 @@@ data Name = Name --(note later when changing Int# -> FastInt: is that still true about UNPACK?) n_loc :: !SrcSpan -- Definition site } + deriving Typeable -- NOTE: we make the n_loc field strict to eliminate some potential -- (and real!) space leaks, due to the fact that we don't look at -- the SrcLoc in a Name all that often. +setNameDepth :: Int -> Name -> Name +setNameDepth depth name = name { n_occ = setOccNameDepth depth (n_occ name) } + +getNameDepth :: Name -> Int +getNameDepth name = getOccNameDepth $ n_occ name + data NameSort = External Module @@@ -370,8 -364,6 +371,6 @@@ instance Uniquable Name wher instance NamedThing Name where getName n = n - INSTANCE_TYPEABLE0(Name,nameTc,"Name") - instance Data Name where -- don't traverse? toConstr _ = abstractConstr "Name" diff --combined compiler/basicTypes/OccName.lhs index c528acb,5489ea7..bae5419 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@@ -25,8 -25,8 +25,8 @@@ module OccName -- ** Construction -- $real_vs_source_data_constructors - tcName, clsName, tcClsName, dataName, varName, - tvName, srcDataName, + tcName, clsName, tcClsName, dataName, varName, varNameDepth, + tvName, srcDataName, setOccNameDepth, getOccNameDepth, -- ** Pretty Printing pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief, @@@ -114,7 -114,7 +114,7 @@@ import Data.Dat %************************************************************************ \begin{code} -data NameSpace = VarName -- Variables, including "real" data constructors +data NameSpace = VarName Int -- Variables, including "real" data constructors; Int is the syntactic HetMet bracket depth | DataName -- "Source" data constructors | TvName -- Type variables | TcClsName -- Type constructors and classes; Haskell has them @@@ -144,7 -144,6 +144,7 @@@ tcName, clsName, tcClsName :: NameSpace dataName, srcDataName :: NameSpace tvName, varName :: NameSpace +varNameDepth :: Int -> NameSpace -- Though type constructors and classes are in the same name space now, -- the NameSpace type is abstract, so we can easily separate them later @@@ -156,23 -155,8 +156,23 @@@ dataName = DataNam srcDataName = DataName -- Haskell-source data constructors should be -- in the Data name space -tvName = TvName -varName = VarName +tvName = TvName + +varName = VarName 0 +varNameDepth = VarName + +getOccNameDepth :: OccName -> Int +getOccNameDepth name = + case occNameSpace name of + (VarName d) -> d + _ -> 0 +setOccNameDepth :: Int -> OccName -> OccName +setOccNameDepth depth name = + case occNameSpace name of + (VarName _) -> name{ occNameSpace = VarName depth } + ns -> if depth==0 + then name + else error ("tried to change the depth of a name in namespace " ++ (showSDoc $ ppr name)) isDataConNameSpace :: NameSpace -> Bool isDataConNameSpace DataName = True @@@ -188,27 -172,27 +188,27 @@@ isTvNameSpace _ = Fals isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors isVarNameSpace TvName = True -isVarNameSpace VarName = True +isVarNameSpace (VarName _) = True isVarNameSpace _ = False isValNameSpace :: NameSpace -> Bool isValNameSpace DataName = True -isValNameSpace VarName = True +isValNameSpace (VarName _) = True isValNameSpace _ = False pprNameSpace :: NameSpace -> SDoc pprNameSpace DataName = ptext (sLit "data constructor") -pprNameSpace VarName = ptext (sLit "variable") +pprNameSpace (VarName _) = ptext (sLit "variable") pprNameSpace TvName = ptext (sLit "type variable") pprNameSpace TcClsName = ptext (sLit "type constructor or class") pprNonVarNameSpace :: NameSpace -> SDoc -pprNonVarNameSpace VarName = empty +pprNonVarNameSpace (VarName _) = empty pprNonVarNameSpace ns = pprNameSpace ns pprNameSpaceBrief :: NameSpace -> SDoc pprNameSpaceBrief DataName = char 'd' -pprNameSpaceBrief VarName = char 'v' +pprNameSpaceBrief (VarName _) = char 'v' pprNameSpaceBrief TvName = ptext (sLit "tv") pprNameSpaceBrief TcClsName = ptext (sLit "tc") \end{code} @@@ -225,6 -209,7 +225,7 @@@ data OccName = OccNam { occNameSpace :: !NameSpace , occNameFS :: !FastString } + deriving Typeable \end{code} @@@ -237,8 -222,6 +238,6 @@@ instance Ord OccName wher compare (OccName sp1 s1) (OccName sp2 s2) = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) - INSTANCE_TYPEABLE0(OccName,occNameTc,"OccName") - instance Data OccName where -- don't traverse? toConstr _ = abstractConstr "OccName" @@@ -349,7 -332,7 +348,7 @@@ easy to build an OccEnv \begin{code} instance Uniquable OccName where -- See Note [The Unique of an OccName] - getUnique (OccName VarName fs) = mkVarOccUnique fs + getUnique (OccName (VarName depth) fs) = mkVarOccUnique fs depth getUnique (OccName DataName fs) = mkDataOccUnique fs getUnique (OccName TvName fs) = mkTvOccUnique fs getUnique (OccName TcClsName fs) = mkTcOccUnique fs @@@ -446,7 -429,7 +445,7 @@@ setOccNameSpace sp (OccName _ occ) = Oc isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool -isVarOcc (OccName VarName _) = True +isVarOcc (OccName (VarName _) _) = True isVarOcc _ = False isTvOcc (OccName TvName _) = True @@@ -458,12 -441,12 +457,12 @@@ isTcOcc _ = Fals -- | /Value/ 'OccNames's are those that are either in -- the variable or data constructor namespaces isValOcc :: OccName -> Bool -isValOcc (OccName VarName _) = True +isValOcc (OccName (VarName _) _) = True isValOcc (OccName DataName _) = True isValOcc _ = False isDataOcc (OccName DataName _) = True -isDataOcc (OccName VarName s) +isDataOcc (OccName (VarName _) s) | isLexCon s = pprPanic "isDataOcc: check me" (ppr s) -- Jan06: I don't think this should happen isDataOcc _ = False @@@ -472,7 -455,7 +471,7 @@@ -- a symbol (e.g. @:@, or @[]@) isDataSymOcc :: OccName -> Bool isDataSymOcc (OccName DataName s) = isLexConSym s -isDataSymOcc (OccName VarName s) +isDataSymOcc (OccName (VarName _) s) | isLexConSym s = pprPanic "isDataSymOcc: check me" (ppr s) -- Jan06: I don't think this should happen isDataSymOcc _ = False @@@ -483,7 -466,7 +482,7 @@@ isSymOcc :: OccName -> Bool isSymOcc (OccName DataName s) = isLexConSym s isSymOcc (OccName TcClsName s) = isLexConSym s -isSymOcc (OccName VarName s) = isLexSym s +isSymOcc (OccName (VarName _) s) = isLexSym s isSymOcc (OccName TvName s) = isLexSym s -- Pretty inefficient! @@@ -655,7 -638,7 +654,7 @@@ mkDFunOcc :: String -- ^ Typically th -- what the mother module will call it. mkDFunOcc info_str is_boot set - = chooseUniqueOcc VarName (prefix ++ info_str) set + = chooseUniqueOcc (VarName 0) (prefix ++ info_str) set where prefix | is_boot = "$fx" | otherwise = "$f" @@@ -694,7 -677,7 +693,7 @@@ guys never show up in error messages. \begin{code} mkMethodOcc :: OccName -> OccName -mkMethodOcc occ@(OccName VarName _) = occ +mkMethodOcc occ@(OccName (VarName _) _) = occ mkMethodOcc occ = mk_simple_deriv varName "$m" occ \end{code} @@@ -830,22 -813,21 +829,22 @@@ isSymbolASCII c = c `elem` "!#$%&*+./<= \begin{code} instance Binary NameSpace where - put_ bh VarName = do - putByte bh 0 + put_ bh (VarName depth) = do if depth > 255-4 + then error "FIXME: no support for serializing VarNames at this syntactic depth" + else putByte bh ((fromIntegral ((depth+3) :: Int))) put_ bh DataName = do - putByte bh 1 + putByte bh 0 put_ bh TvName = do - putByte bh 2 + putByte bh 1 put_ bh TcClsName = do - putByte bh 3 + putByte bh 2 get bh = do h <- getByte bh case h of - 0 -> do return VarName - 1 -> do return DataName - 2 -> do return TvName - _ -> do return TcClsName + 0 -> do return DataName + 1 -> do return TvName + 2 -> do return TcClsName + n -> do return (VarName (fromIntegral (n-3))) instance Binary OccName where put_ bh (OccName aa ab) = do diff --combined compiler/main/DynFlags.hs index 70358ee,67065d0..e292722 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@@ -1,6 -1,3 +1,3 @@@ - {-# OPTIONS_GHC -w #-} - -- Temporary, until rtsIsProfiled is fixed - -- | -- Dynamic flags -- @@@ -35,8 -32,17 +32,17 @@@ module DynFlags DPHBackend(..), dphPackageMaybe, wayNames, + Settings(..), + ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, + extraGccViaCFlags, systemPackageConfig, + pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T, + pgm_sysman, pgm_windres, pgm_lo, pgm_lc, + opt_L, opt_P, opt_F, opt_c, opt_m, opt_a, opt_l, + opt_windres, opt_lo, opt_lc, + + -- ** Manipulating DynFlags - defaultDynFlags, -- DynFlags + defaultDynFlags, -- Settings -> DynFlags initDynFlags, -- DynFlags -> IO DynFlags getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] @@@ -61,7 -67,6 +67,6 @@@ getStgToDo, -- * Compiler configuration suitable for display to the user - Printable(..), compilerInfo #ifdef GHCI -- Only in stage 2 can we be sure that the RTS @@@ -90,10 -95,14 +95,14 @@@ import Maybes ( orElse import SrcLoc import FastString import Outputable + #ifdef GHCI import Foreign.C ( CInt ) + #endif import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) + #ifdef GHCI import System.IO.Unsafe ( unsafePerformIO ) + #endif import Data.IORef import Control.Monad ( when ) @@@ -101,7 -110,7 +110,7 @@@ import Data.Cha import Data.List import Data.Map (Map) import qualified Data.Map as Map - import Data.Maybe + -- import Data.Maybe import System.FilePath import System.IO ( stderr, hPutChar ) @@@ -181,10 -190,6 +190,10 @@@ data DynFla | Opt_DoCmmLinting | Opt_DoAsmLinting + | Opt_F_coqpass -- run the core-to-core coqPass (does whatever CoqPass.hs says) + | Opt_D_coqpass -- run the core-to-string coqPass and dumps the result + | Opt_D_dump_coqpass -- dumps the output of the core-to-core coqPass + | Opt_WarnIsError -- -Werror; makes warnings fatal | Opt_WarnDuplicateExports | Opt_WarnHiShadows @@@ -315,7 -320,6 +324,7 @@@ data ExtensionFla | Opt_GHCForeignImportPrim | Opt_ParallelArrays -- Syntactic support for parallel arrays | Opt_Arrows -- Arrow-notation syntax + | Opt_ModalTypes -- Heterogeneous Metaprogramming (modal types, brackets, escape, CSP) | Opt_TemplateHaskell | Opt_QuasiQuotes | Opt_ImplicitParams @@@ -445,41 -449,13 +454,13 @@@ data DynFlags = DynFlags libraryPaths :: [String], frameworkPaths :: [String], -- used on darwin only cmdlineFrameworks :: [String], -- ditto - tmpDir :: String, -- no trailing '/' - ghcUsagePath :: FilePath, -- Filled in by SysTools - ghciUsagePath :: FilePath, -- ditto rtsOpts :: Maybe String, rtsOptsEnabled :: RtsOptsEnabled, hpcDir :: String, -- ^ Path to store the .mix files - -- options for particular phases - opt_L :: [String], - opt_P :: [String], - opt_F :: [String], - opt_c :: [String], - opt_m :: [String], - opt_a :: [String], - opt_l :: [String], - opt_windres :: [String], - opt_lo :: [String], -- LLVM: llvm optimiser - opt_lc :: [String], -- LLVM: llc static compiler - - -- commands for particular phases - pgm_L :: String, - pgm_P :: (String,[Option]), - pgm_F :: String, - pgm_c :: (String,[Option]), - pgm_s :: (String,[Option]), - pgm_a :: (String,[Option]), - pgm_l :: (String,[Option]), - pgm_dll :: (String,[Option]), - pgm_T :: String, - pgm_sysman :: String, - pgm_windres :: String, - pgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser - pgm_lc :: (String,[Option]), -- LLVM: llc static compiler + settings :: Settings, -- For ghc -M depMakefile :: FilePath, @@@ -489,8 -465,6 +470,6 @@@ -- Package flags extraPkgConfs :: [FilePath], - topDir :: FilePath, -- filled in by SysTools - systemPackageConfig :: FilePath, -- ditto -- ^ The @-package-conf@ flags given on the command line, in the order -- they appeared. @@@ -525,6 -499,105 +504,105 @@@ haddockOptions :: Maybe String } + data Settings = Settings { + sGhcUsagePath :: FilePath, -- Filled in by SysTools + sGhciUsagePath :: FilePath, -- ditto + sTopDir :: FilePath, + sTmpDir :: String, -- no trailing '/' + -- You shouldn't need to look things up in rawSettings directly. + -- They should have their own fields instead. + sRawSettings :: [(String, String)], + sExtraGccViaCFlags :: [String], + sSystemPackageConfig :: FilePath, + -- commands for particular phases + sPgm_L :: String, + sPgm_P :: (String,[Option]), + sPgm_F :: String, + sPgm_c :: (String,[Option]), + sPgm_s :: (String,[Option]), + sPgm_a :: (String,[Option]), + sPgm_l :: (String,[Option]), + sPgm_dll :: (String,[Option]), + sPgm_T :: String, + sPgm_sysman :: String, + sPgm_windres :: String, + sPgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser + sPgm_lc :: (String,[Option]), -- LLVM: llc static compiler + -- options for particular phases + sOpt_L :: [String], + sOpt_P :: [String], + sOpt_F :: [String], + sOpt_c :: [String], + sOpt_m :: [String], + sOpt_a :: [String], + sOpt_l :: [String], + sOpt_windres :: [String], + sOpt_lo :: [String], -- LLVM: llvm optimiser + sOpt_lc :: [String] -- LLVM: llc static compiler + + } + + ghcUsagePath :: DynFlags -> FilePath + ghcUsagePath dflags = sGhcUsagePath (settings dflags) + ghciUsagePath :: DynFlags -> FilePath + ghciUsagePath dflags = sGhciUsagePath (settings dflags) + topDir :: DynFlags -> FilePath + topDir dflags = sTopDir (settings dflags) + tmpDir :: DynFlags -> String + tmpDir dflags = sTmpDir (settings dflags) + rawSettings :: DynFlags -> [(String, String)] + rawSettings dflags = sRawSettings (settings dflags) + extraGccViaCFlags :: DynFlags -> [String] + extraGccViaCFlags dflags = sExtraGccViaCFlags (settings dflags) + systemPackageConfig :: DynFlags -> FilePath + systemPackageConfig dflags = sSystemPackageConfig (settings dflags) + pgm_L :: DynFlags -> String + pgm_L dflags = sPgm_L (settings dflags) + pgm_P :: DynFlags -> (String,[Option]) + pgm_P dflags = sPgm_P (settings dflags) + pgm_F :: DynFlags -> String + pgm_F dflags = sPgm_F (settings dflags) + pgm_c :: DynFlags -> (String,[Option]) + pgm_c dflags = sPgm_c (settings dflags) + pgm_s :: DynFlags -> (String,[Option]) + pgm_s dflags = sPgm_s (settings dflags) + pgm_a :: DynFlags -> (String,[Option]) + pgm_a dflags = sPgm_a (settings dflags) + pgm_l :: DynFlags -> (String,[Option]) + pgm_l dflags = sPgm_l (settings dflags) + pgm_dll :: DynFlags -> (String,[Option]) + pgm_dll dflags = sPgm_dll (settings dflags) + pgm_T :: DynFlags -> String + pgm_T dflags = sPgm_T (settings dflags) + pgm_sysman :: DynFlags -> String + pgm_sysman dflags = sPgm_sysman (settings dflags) + pgm_windres :: DynFlags -> String + pgm_windres dflags = sPgm_windres (settings dflags) + pgm_lo :: DynFlags -> (String,[Option]) + pgm_lo dflags = sPgm_lo (settings dflags) + pgm_lc :: DynFlags -> (String,[Option]) + pgm_lc dflags = sPgm_lc (settings dflags) + opt_L :: DynFlags -> [String] + opt_L dflags = sOpt_L (settings dflags) + opt_P :: DynFlags -> [String] + opt_P dflags = sOpt_P (settings dflags) + opt_F :: DynFlags -> [String] + opt_F dflags = sOpt_F (settings dflags) + opt_c :: DynFlags -> [String] + opt_c dflags = sOpt_c (settings dflags) + opt_m :: DynFlags -> [String] + opt_m dflags = sOpt_m (settings dflags) + opt_a :: DynFlags -> [String] + opt_a dflags = sOpt_a (settings dflags) + opt_l :: DynFlags -> [String] + opt_l dflags = sOpt_l (settings dflags) + opt_windres :: DynFlags -> [String] + opt_windres dflags = sOpt_windres (settings dflags) + opt_lo :: DynFlags -> [String] + opt_lo dflags = sOpt_lo (settings dflags) + opt_lc :: DynFlags -> [String] + opt_lc dflags = sOpt_lc (settings dflags) + wayNames :: DynFlags -> [WayName] wayNames = map wayName . ways @@@ -647,8 -720,8 +725,8 @@@ initDynFlags dflags = d -- | The normal 'DynFlags'. Note that they is not suitable for use in this form -- and must be fully initialized by 'GHC.newSession' first. - defaultDynFlags :: DynFlags - defaultDynFlags = + defaultDynFlags :: Settings -> DynFlags + defaultDynFlags mySettings = DynFlags { ghcMode = CompManager, ghcLink = LinkBinary, @@@ -698,25 -771,11 +776,11 @@@ libraryPaths = [], frameworkPaths = [], cmdlineFrameworks = [], - tmpDir = cDEFAULT_TMPDIR, rtsOpts = Nothing, rtsOptsEnabled = RtsOptsSafeOnly, hpcDir = ".hpc", - opt_L = [], - opt_P = (if opt_PIC - then ["-D__PIC__", "-U __PIC__"] -- this list is reversed - else []), - opt_F = [], - opt_c = [], - opt_a = [], - opt_m = [], - opt_l = [], - opt_windres = [], - opt_lo = [], - opt_lc = [], - extraPkgConfs = [], packageFlags = [], pkgDatabase = Nothing, @@@ -725,25 -784,7 +789,7 @@@ buildTag = panic "defaultDynFlags: No buildTag", rtsBuildTag = panic "defaultDynFlags: No rtsBuildTag", splitInfo = Nothing, - -- initSysTools fills all these in - ghcUsagePath = panic "defaultDynFlags: No ghciUsagePath", - ghciUsagePath = panic "defaultDynFlags: No ghciUsagePath", - topDir = panic "defaultDynFlags: No topDir", - systemPackageConfig = panic "no systemPackageConfig: call GHC.setSessionDynFlags", - pgm_L = panic "defaultDynFlags: No pgm_L", - pgm_P = panic "defaultDynFlags: No pgm_P", - pgm_F = panic "defaultDynFlags: No pgm_F", - pgm_c = panic "defaultDynFlags: No pgm_c", - pgm_s = panic "defaultDynFlags: No pgm_s", - pgm_a = panic "defaultDynFlags: No pgm_a", - pgm_l = panic "defaultDynFlags: No pgm_l", - pgm_dll = panic "defaultDynFlags: No pgm_dll", - pgm_T = panic "defaultDynFlags: No pgm_T", - pgm_sysman = panic "defaultDynFlags: No pgm_sysman", - pgm_windres = panic "defaultDynFlags: No pgm_windres", - pgm_lo = panic "defaultDynFlags: No pgm_lo", - pgm_lc = panic "defaultDynFlags: No pgm_lc", - -- end of initSysTools values + settings = mySettings, -- ghc -M values depMakefile = "Makefile", depIncludePkgDeps = False, @@@ -917,9 -958,9 +963,9 @@@ setDumpPrefixForce f d = d { dumpPrefix -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] -- Config.hs should really use Option. - setPgmP f d = let (pgm:args) = words f in d{ pgm_P = (pgm, map Option args)} - addOptl f d = d{ opt_l = f : opt_l d} - addOptP f d = d{ opt_P = f : opt_P d} + setPgmP f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P = (pgm, map Option args)}) + addOptl f = alterSettings (\s -> s { sOpt_l = f : sOpt_l s}) + addOptP f = alterSettings (\s -> s { sOpt_P = f : sOpt_P s}) setDepMakefile :: FilePath -> DynFlags -> DynFlags @@@ -1100,30 -1141,30 +1146,30 @@@ dynamic_flags = ------- Specific phases -------------------------------------------- -- need to appear before -pgmL to be parsed as LLVM flags. - , Flag "pgmlo" (hasArg (\f d -> d{ pgm_lo = (f,[])})) - , Flag "pgmlc" (hasArg (\f d -> d{ pgm_lc = (f,[])})) - , Flag "pgmL" (hasArg (\f d -> d{ pgm_L = f})) + , Flag "pgmlo" (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) + , Flag "pgmlc" (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])}))) + , Flag "pgmL" (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f}))) , Flag "pgmP" (hasArg setPgmP) - , Flag "pgmF" (hasArg (\f d -> d{ pgm_F = f})) - , Flag "pgmc" (hasArg (\f d -> d{ pgm_c = (f,[])})) + , Flag "pgmF" (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) + , Flag "pgmc" (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) , Flag "pgmm" (HasArg (\_ -> addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) - , Flag "pgms" (hasArg (\f d -> d{ pgm_s = (f,[])})) - , Flag "pgma" (hasArg (\f d -> d{ pgm_a = (f,[])})) - , Flag "pgml" (hasArg (\f d -> d{ pgm_l = (f,[])})) - , Flag "pgmdll" (hasArg (\f d -> d{ pgm_dll = (f,[])})) - , Flag "pgmwindres" (hasArg (\f d -> d{ pgm_windres = f})) + , Flag "pgms" (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) + , Flag "pgma" (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) + , Flag "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) + , Flag "pgmdll" (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])}))) + , Flag "pgmwindres" (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f}))) -- need to appear before -optl/-opta to be parsed as LLVM flags. - , Flag "optlo" (hasArg (\f d -> d{ opt_lo = f : opt_lo d})) - , Flag "optlc" (hasArg (\f d -> d{ opt_lc = f : opt_lc d})) - , Flag "optL" (hasArg (\f d -> d{ opt_L = f : opt_L d})) + , Flag "optlo" (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s}))) + , Flag "optlc" (hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s}))) + , Flag "optL" (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) , Flag "optP" (hasArg addOptP) - , Flag "optF" (hasArg (\f d -> d{ opt_F = f : opt_F d})) - , Flag "optc" (hasArg (\f d -> d{ opt_c = f : opt_c d})) - , Flag "optm" (hasArg (\f d -> d{ opt_m = f : opt_m d})) - , Flag "opta" (hasArg (\f d -> d{ opt_a = f : opt_a d})) + , Flag "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) + , Flag "optc" (hasArg (\f -> alterSettings (\s -> s { sOpt_c = f : sOpt_c s}))) + , Flag "optm" (hasArg (\f -> alterSettings (\s -> s { sOpt_m = f : sOpt_m s}))) + , Flag "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) , Flag "optl" (hasArg addOptl) - , Flag "optwindres" (hasArg (\f d -> d{ opt_windres = f : opt_windres d})) + , Flag "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) , Flag "split-objs" (NoArg (if can_split @@@ -1287,11 -1328,6 +1333,11 @@@ setVerbosity (Just 2))) , Flag "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats)) + ------ Coq-in-GHC --------------------------- + , Flag "dcoqpass" (NoArg (setDynFlag Opt_D_coqpass)) + , Flag "ddump-coqpass" (NoArg (setDynFlag Opt_D_dump_coqpass)) + , Flag "fcoqpass" (NoArg (setDynFlag Opt_F_coqpass)) + ------ Machine dependant (-m) stuff --------------------------- , Flag "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release")) @@@ -1327,7 -1363,7 +1373,7 @@@ , Flag "fcontext-stack" (intSuffix (\n d -> d{ ctxtStkDepth = n })) , Flag "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) , Flag "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) - , Flag "ffloat-all-lams" (intSuffix (\n d -> d{ floatLamArgs = Nothing })) + , Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) ------ Profiling ---------------------------------------------------- @@@ -1591,7 -1627,6 +1637,7 @@@ xFlags = deprecatedForExtension "DoRec"), ( "DoRec", Opt_DoRec, nop ), ( "Arrows", Opt_Arrows, nop ), + ( "ModalTypes", Opt_ModalTypes, nop ), ( "ParallelArrays", Opt_ParallelArrays, nop ), ( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ), ( "QuasiQuotes", Opt_QuasiQuotes, nop ), @@@ -1684,11 -1719,6 +1730,11 @@@ impliedFlag , (Opt_FlexibleInstances, turnOn, Opt_TypeSynonymInstances) , (Opt_FunctionalDependencies, turnOn, Opt_MultiParamTypeClasses) + , (Opt_ModalTypes, turnOn, Opt_RankNTypes) + , (Opt_ModalTypes, turnOn, Opt_ExplicitForAll) + --, (Opt_ModalTypes, turnOn, Opt_RebindableSyntax) + , (Opt_ModalTypes, turnOff, Opt_MonomorphismRestriction) + , (Opt_RebindableSyntax, turnOff, Opt_ImplicitPrelude) -- NB: turn off! , (Opt_GADTs, turnOn, Opt_GADTSyntax) @@@ -1849,18 -1879,20 +1895,20 @@@ foreign import ccall unsafe "rts_isProf rtsIsProfiled :: Bool rtsIsProfiled = unsafePerformIO rtsIsProfiledIO /= 0 + #endif checkTemplateHaskellOk :: Bool -> DynP () - checkTemplateHaskellOk turn_on + #ifdef GHCI + checkTemplateHaskellOk turn_on | turn_on && rtsIsProfiled = addErr "You can't use Template Haskell with a profiled compiler" | otherwise = return () #else - -- In stage 1 we don't know that the RTS has rts_isProfiled, + -- In stage 1 we don't know that the RTS has rts_isProfiled, -- so we simply say "ok". It doesn't matter because TH isn't -- available in stage 1 anyway. - checkTemplateHaskellOk turn_on = return () + checkTemplateHaskellOk _ = return () #endif {- ********************************************************************** @@@ -1917,6 -1949,10 +1965,10 @@@ unSetExtensionFlag f = upd (\dfs -> xop -- (except for -fno-glasgow-exts, which is treated specially) -------------------------- + alterSettings :: (Settings -> Settings) -> DynFlags -> DynFlags + alterSettings f dflags = dflags { settings = f (settings dflags) } + + -------------------------- setDumpFlag' :: DynFlag -> DynP () setDumpFlag' dump_flag = do { setDynFlag dump_flag @@@ -2131,7 -2167,7 +2183,7 @@@ splitPathList s = filter notNull (split -- tmpDir, where we store temporary files. setTmpDir :: FilePath -> DynFlags -> DynFlags - setTmpDir dir dflags = dflags{ tmpDir = normalise dir } + setTmpDir dir = alterSettings (\s -> s { sTmpDir = normalise dir }) -- we used to fix /cygdrive/c/.. on Windows, but this doesn't -- seem necessary now --SDM 7/2/2008 @@@ -2156,17 -2192,16 +2208,16 @@@ setOptHpcDir arg = upd $ \ d -> d{hpcD -- There are some options that we need to pass to gcc when compiling -- Haskell code via C, but are only supported by recent versions of -- gcc. The configure script decides which of these options we need, - -- and puts them in the file "extra-gcc-opts" in $topdir, which is - -- read before each via-C compilation. The advantage of having these - -- in a separate file is that the file can be created at install-time - -- depending on the available gcc version, and even re-generated later - -- if gcc is upgraded. + -- and puts them in the "settings" file in $topdir. The advantage of + -- having these in a separate file is that the file can be created at + -- install-time depending on the available gcc version, and even + -- re-generated later if gcc is upgraded. -- -- The options below are not dependent on the version of gcc, only the -- platform. machdepCCOpts :: DynFlags -> [String] -- flags for all C compilations - machdepCCOpts dflags = cCcOpts ++ machdepCCOpts' + machdepCCOpts _ = cCcOpts ++ machdepCCOpts' machdepCCOpts' :: [String] -- flags for all C compilations machdepCCOpts' @@@ -2238,30 -2273,35 +2289,35 @@@ can_split = cSupportsSplitObjs == "YES -- ----------------------------------------------------------------------------- -- Compiler Info - data Printable = String String - | FromDynFlags (DynFlags -> String) - - compilerInfo :: [(String, Printable)] - compilerInfo = [("Project name", String cProjectName), - ("Project version", String cProjectVersion), - ("Booter version", String cBooterVersion), - ("Stage", String cStage), - ("Build platform", String cBuildPlatformString), - ("Host platform", String cHostPlatformString), - ("Target platform", String cTargetPlatformString), - ("Have interpreter", String cGhcWithInterpreter), - ("Object splitting supported", String cSupportsSplitObjs), - ("Have native code generator", String cGhcWithNativeCodeGen), - ("Support SMP", String cGhcWithSMP), - ("Unregisterised", String cGhcUnregisterised), - ("Tables next to code", String cGhcEnableTablesNextToCode), - ("RTS ways", String cGhcRTSWays), - ("Leading underscore", String cLeadingUnderscore), - ("Debug on", String (show debugIsOn)), - ("LibDir", FromDynFlags topDir), - ("Global Package DB", FromDynFlags systemPackageConfig), - ("C compiler flags", String (show cCcOpts)), - ("Gcc Linker flags", String (show cGccLinkerOpts)), - ("Ld Linker flags", String (show cLdLinkerOpts)) - ] + compilerInfo :: DynFlags -> [(String, String)] + compilerInfo dflags + = -- We always make "Project name" be first to keep parsing in + -- other languages simple, i.e. when looking for other fields, + -- you don't have to worry whether there is a leading '[' or not + ("Project name", cProjectName) + -- Next come the settings, so anything else can be overridden + -- in the settings file (as "lookup" uses the first match for the + -- key) + : rawSettings dflags + ++ [("Project version", cProjectVersion), + ("Booter version", cBooterVersion), + ("Stage", cStage), + ("Build platform", cBuildPlatformString), + ("Host platform", cHostPlatformString), + ("Target platform", cTargetPlatformString), + ("Have interpreter", cGhcWithInterpreter), + ("Object splitting supported", cSupportsSplitObjs), + ("Have native code generator", cGhcWithNativeCodeGen), + ("Support SMP", cGhcWithSMP), + ("Unregisterised", cGhcUnregisterised), + ("Tables next to code", cGhcEnableTablesNextToCode), + ("RTS ways", cGhcRTSWays), + ("Leading underscore", cLeadingUnderscore), + ("Debug on", show debugIsOn), + ("LibDir", topDir dflags), + ("Global Package DB", systemPackageConfig dflags), + ("C compiler flags", show cCcOpts), + ("Gcc Linker flags", show cGccLinkerOpts), + ("Ld Linker flags", show cLdLinkerOpts) + ] diff --combined compiler/typecheck/TcRnTypes.lhs index ada8180,8858c13..79f2a74 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@@ -373,7 -373,6 +373,7 @@@ data TcLclEnv -- Changes as we move in -- We still need the unsullied global name env so that -- we can look up record field names + tcl_hetMetLevel :: [TyVar], -- The current environment classifier level (list-of-names) tcl_env :: TcTypeEnv, -- The local type environment: Ids and -- TyVars defined in this module @@@ -510,9 -509,7 +510,9 @@@ data TcTyThin | ATcId { -- Ids defined in this module; may not be fully zonked tct_id :: TcId, - tct_level :: ThLevel } + tct_level :: ThLevel, + tct_hetMetLevel :: [TyVar] + } | ATyVar Name TcType -- The type to which the lexically scoped type vaiable -- is currently refined. We only need the Name @@@ -527,8 -524,7 +527,8 @@@ instance Outputable TcTyThing where -- ppr elt@(ATcId {}) = text "Identifier" <> brackets (ppr (tct_id elt) <> dcolon <> ppr (varType (tct_id elt)) <> comma - <+> ppr (tct_level elt)) + <+> ppr (tct_level elt) + <+> ppr (tct_hetMetLevel elt)) ppr (ATyVar tv _) = text "Type variable" <+> quotes (ppr tv) ppr (AThing k) = text "AThing" <+> ppr k @@@ -1042,9 -1038,6 +1042,6 @@@ data SkolemInf -- polymorphic Ids, and are now checking that their RHS -- constraints are satisfied. - | RuntimeUnkSkol -- a type variable used to represent an unknown - -- runtime type (used in the GHCi debugger) - | BracketSkol -- Template Haskell bracket | UnkSkol -- Unhelpful info (until I improve it) @@@ -1079,8 -1072,7 +1076,7 @@@ pprSkolInfo (InferSkol ids) = sep [ pte -- UnkSkol -- For type variables the others are dealt with by pprSkolTvBinding. -- For Insts, these cases should not happen - pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol") - pprSkolInfo RuntimeUnkSkol = WARN( True, text "pprSkolInfo: RuntimeUnkSkol" ) ptext (sLit "RuntimeUnkSkol") + pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol") \end{code} diff --combined ghc.mk index 76120ba,b00d925..3d3c3a6 --- a/ghc.mk +++ b/ghc.mk @@@ -750,7 -750,7 +750,7 @@@ TAGS: TAGS_compile # ----------------------------------------------------------------------------- # Installation - install: install_packages install_libs install_libexecs install_headers \ + install: install_libs install_packages install_libexecs install_headers \ install_libexec_scripts install_bins install_topdirs ifeq "$(HADDOCK_DOCS)" "YES" install: install_docs @@@ -904,7 -904,7 +904,7 @@@ $(eval $(call bindist,., README \ INSTALL \ configure config.sub config.guess install-sh \ - extra-gcc-opts.in \ + settings.in \ packages \ Makefile \ mk/config.mk.in \ @@@ -933,7 -933,7 +933,7 @@@ compiler/stage2/doc \ $(wildcard libraries/*/dist-install/doc/) \ $(wildcard libraries/*/*/dist-install/doc/) \ - $(filter-out extra-gcc-opts,$(INSTALL_LIBS)) \ + $(filter-out settings,$(INSTALL_LIBS)) \ $(filter-out %/project.mk mk/config.mk %/mk/install.mk,$(MAKEFILE_LIST)) \ mk/project.mk \ mk/install.mk.in \ @@@ -954,7 -954,7 +954,7 @@@ BIN_DIST_MK = $(BIN_DIST_PREP_DIR)/bind unix-binary-dist-prep: "$(RM)" $(RM_OPTS_REC) bindistprep/ "$(MKDIRHIER)" $(BIN_DIST_PREP_DIR) - set -e; for i in packages LICENSE compiler ghc rts libraries utils docs libffi includes driver mk rules Makefile aclocal.m4 config.sub config.guess install-sh extra-gcc-opts.in ghc.mk inplace distrib/configure.ac distrib/README distrib/INSTALL; do ln -s ../../$$i $(BIN_DIST_PREP_DIR)/; done + set -e; for i in packages LICENSE compiler ghc rts libraries utils docs libffi includes driver mk rules Makefile aclocal.m4 config.sub config.guess install-sh settings.in ghc.mk inplace distrib/configure.ac distrib/README distrib/INSTALL; do ln -s ../../$$i $(BIN_DIST_PREP_DIR)/; done echo "HADDOCK_DOCS = $(HADDOCK_DOCS)" >> $(BIN_DIST_MK) echo "LATEX_DOCS = $(LATEX_DOCS)" >> $(BIN_DIST_MK) echo "BUILD_DOCBOOK_HTML = $(BUILD_DOCBOOK_HTML)" >> $(BIN_DIST_MK) @@@ -1043,7 -1043,7 +1043,7 @@@ SRC_DIST_DIRS = mk rules docs distrib b SRC_DIST_FILES += \ configure.ac config.guess config.sub configure \ aclocal.m4 README ANNOUNCE HACKING LICENSE Makefile install-sh \ - ghc.spec.in ghc.spec extra-gcc-opts.in VERSION \ + ghc.spec.in ghc.spec settings.in VERSION \ boot boot-pkgs packages ghc.mk SRC_DIST_TARBALL = $(SRC_DIST_NAME)-src.tar.bz2 @@@ -1158,7 -1158,7 +1158,7 @@@ distclean : clea "$(RM)" $(RM_OPTS) config.cache config.status config.log mk/config.h mk/stamp-h "$(RM)" $(RM_OPTS) mk/config.mk mk/are-validating.mk mk/project.mk "$(RM)" $(RM_OPTS) mk/config.mk.old mk/project.mk.old - "$(RM)" $(RM_OPTS) extra-gcc-opts docs/users_guide/ug-book.xml + "$(RM)" $(RM_OPTS) settings docs/users_guide/ug-book.xml "$(RM)" $(RM_OPTS) compiler/ghc.cabal compiler/ghc.cabal.old "$(RM)" $(RM_OPTS) ghc/ghc-bin.cabal "$(RM)" $(RM_OPTS) libraries/base/include/HsBaseConfig.h @@@ -1211,15 -1211,3 +1211,15 @@@ phase_0_builds: $(utils/genprimopcode_d .PHONY: phase_1_builds phase_1_builds: $(PACKAGE_DATA_MKS) +# ----------------------------------------------------------------------------- +# Support for writing GHC passes in Coq + +compiler/hetmet/Makefile: + git submodule update --init compiler/hetmet + cd compiler/hetmet/; git checkout master +compiler/hetmet/build/CoqPass.hs: compiler/hetmet/Makefile $(wildcard compiler/hetmet/src/*.v) $(wildcard compiler/hetmet/src/*.hs) + cd compiler/hetmet; make build/CoqPass.hs +compiler/stage1/build/CoqPass.hs: compiler/hetmet/build/CoqPass.hs + cp compiler/hetmet/build/CoqPass.hs $@ +compiler/stage2/build/CoqPass.hs: compiler/hetmet/build/CoqPass.hs + cp compiler/hetmet/build/CoqPass.hs $@