From: Adam Megacz Date: Sat, 16 Apr 2011 23:56:37 +0000 (-0700) Subject: merge up to ghc HEAD 16-Apr-2011 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=6cec61d14a324285dbb8ce73d4c7215f1f8d6766;hp=-c merge up to ghc HEAD 16-Apr-2011 --- 6cec61d14a324285dbb8ce73d4c7215f1f8d6766 diff --combined compiler/cmm/CLabel.hs index c151a26,4e9ef8c..c40f3b7 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@@ -51,7 -51,9 +51,7 @@@ module CLabel mkAsmTempLabel, - mkModuleInitLabel, - mkPlainModuleInitLabel, - mkModuleInitTableLabel, + mkPlainModuleInitLabel, mkSplitMarkerLabel, mkDirty_MUT_VAR_Label, @@@ -68,7 -70,10 +68,7 @@@ mkRtsPrimOpLabel, mkRtsSlowTickyCtrLabel, - moduleRegdLabel, - moduleRegTableLabel, - - mkSelectorInfoLabel, + mkSelectorInfoLabel, mkSelectorEntryLabel, mkCmmInfoLabel, @@@ -97,6 -102,7 +97,6 @@@ mkDeadStripPreventer, mkHpcTicksLabel, - mkHpcModuleNameLabel, hasCAF, infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, @@@ -196,9 -202,23 +196,9 @@@ data CLabe | StringLitLabel {-# UNPACK #-} !Unique - | ModuleInitLabel - Module -- the module name - String -- its "way" - -- at some point we might want some kind of version number in - -- the module init label, to guard against compiling modules in - -- the wrong order. We can't use the interface file version however, - -- because we don't always recompile modules which depend on a module - -- whose version has changed. - - | PlainModuleInitLabel -- without the version & way info + | PlainModuleInitLabel -- without the version & way info Module - | ModuleInitTableLabel -- table of imported modules to init - Module - - | ModuleRegdLabel - | CC_Label CostCentre | CCS_Label CostCentreStack @@@ -222,6 -242,9 +222,6 @@@ -- | Per-module table of tick locations | HpcTicksLabel Module - -- | Per-module name of the module for Hpc - | HpcModuleNameLabel - -- | Label of an StgLargeSRT | LargeSRTLabel {-# UNPACK #-} !Unique @@@ -254,6 -277,10 +254,10 @@@ data ForeignLabelSourc deriving (Eq, Ord) + closureSuffix' :: Name -> SDoc + closureSuffix' hs_fn = + if depth==0 then ptext (sLit "") else ptext (sLit $ (show depth)) + where depth = getNameDepth hs_fn -- | For debugging problems with the CLabel representation. -- We can't make a Show instance for CLabel because lots of its components don't have instances. @@@ -467,6 -494,7 +471,6 @@@ mkRtsSlowTickyCtrLabel pat = RtsLabel ( -- Constructing Code Coverage Labels mkHpcTicksLabel = HpcTicksLabel -mkHpcModuleNameLabel = HpcModuleNameLabel -- Constructing labels used for dynamic linking @@@ -491,9 -519,19 +495,9 @@@ mkStringLitLabel = StringLitLabe mkAsmTempLabel :: Uniquable a => a -> CLabel mkAsmTempLabel a = AsmTempLabel (getUnique a) mkPlainModuleInitLabel :: Module -> CLabel mkPlainModuleInitLabel mod = PlainModuleInitLabel mod -mkModuleInitTableLabel :: Module -> CLabel -mkModuleInitTableLabel mod = ModuleInitTableLabel mod - -moduleRegdLabel = ModuleRegdLabel -moduleRegTableLabel = ModuleInitTableLabel - - -- ----------------------------------------------------------------------------- -- Converting between info labels and entry/ret labels. @@@ -522,7 -560,6 +526,7 @@@ entryLblToInfoLbl cvtToClosureLbl (IdLabel n c InfoTable) = IdLabel n c Closure cvtToClosureLbl (IdLabel n c Entry) = IdLabel n c Closure cvtToClosureLbl (IdLabel n c ConEntry) = IdLabel n c Closure +cvtToClosureLbl (IdLabel n c RednCounts) = IdLabel n c Closure cvtToClosureLbl l@(IdLabel n c Closure) = l cvtToClosureLbl l = pprPanic "cvtToClosureLbl" (pprCLabel l) @@@ -557,7 -594,10 +561,7 @@@ needsCDecl (LargeSRTLabel _) = Fals needsCDecl (LargeBitmapLabel _) = False needsCDecl (IdLabel _ _ _) = True needsCDecl (CaseLabel _ _) = True -needsCDecl (ModuleInitLabel _ _) = True -needsCDecl (PlainModuleInitLabel _) = True -needsCDecl (ModuleInitTableLabel _) = True -needsCDecl ModuleRegdLabel = False +needsCDecl (PlainModuleInitLabel _) = True needsCDecl (StringLitLabel _) = False needsCDecl (AsmTempLabel _) = False @@@ -575,6 -615,7 +579,6 @@@ needsCDecl l@(ForeignLabel{}) = not (i needsCDecl (CC_Label _) = True needsCDecl (CCS_Label _) = True needsCDecl (HpcTicksLabel _) = True -needsCDecl HpcModuleNameLabel = False -- | Check whether a label is a local temporary for native code generation @@@ -687,8 -728,11 +691,8 @@@ externallyVisibleCLabel :: CLabel -> Bo externallyVisibleCLabel (CaseLabel _ _) = False externallyVisibleCLabel (StringLitLabel _) = False externallyVisibleCLabel (AsmTempLabel _) = False -externallyVisibleCLabel (ModuleInitLabel _ _) = True externallyVisibleCLabel (PlainModuleInitLabel _)= True -externallyVisibleCLabel (ModuleInitTableLabel _)= False -externallyVisibleCLabel ModuleRegdLabel = False -externallyVisibleCLabel (RtsLabel _) = True +externallyVisibleCLabel (RtsLabel _) = True externallyVisibleCLabel (CmmLabel _ _ _) = True externallyVisibleCLabel (ForeignLabel{}) = True externallyVisibleCLabel (IdLabel name _ _) = isExternalName name @@@ -696,7 -740,8 +700,7 @@@ externallyVisibleCLabel (CC_Label _) externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False externallyVisibleCLabel (HpcTicksLabel _) = True -externallyVisibleCLabel HpcModuleNameLabel = False -externallyVisibleCLabel (LargeBitmapLabel _) = False +externallyVisibleCLabel (LargeBitmapLabel _) = False externallyVisibleCLabel (LargeSRTLabel _) = False -- ----------------------------------------------------------------------------- @@@ -735,7 -780,9 +739,7 @@@ labelType (RtsLabel (RtsApInfoTable _ _ labelType (RtsLabel (RtsApFast _)) = CodeLabel labelType (CaseLabel _ CaseReturnInfo) = DataLabel labelType (CaseLabel _ _) = CodeLabel -labelType (ModuleInitLabel _ _) = CodeLabel labelType (PlainModuleInitLabel _) = CodeLabel -labelType (ModuleInitTableLabel _) = DataLabel labelType (LargeSRTLabel _) = DataLabel labelType (LargeBitmapLabel _) = DataLabel labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel @@@ -793,8 -840,10 +797,8 @@@ labelDynamic this_pkg lbl CmmLabel pkg _ _ -> True #endif - ModuleInitLabel m _ -> not opt_Static && this_pkg /= (modulePackageId m) PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m) - ModuleInitTableLabel m -> not opt_Static && this_pkg /= (modulePackageId m) - + -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. _ -> False @@@ -962,22 -1011,35 +966,22 @@@ pprCLbl (RtsLabel (RtsPrimOp primop) pprCLbl (RtsLabel (RtsSlowTickyCtr pat)) = ptext (sLit "SLOW_CALL_") <> text pat <> ptext (sLit "_ctr") pprCLbl (ForeignLabel str _ _ _) = ftext str - pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor + pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor name flavor pprCLbl (CC_Label cc) = ppr cc pprCLbl (CCS_Label ccs) = ppr ccs pprCLbl (PlainModuleInitLabel mod) = ptext (sLit "__stginit_") <> ppr mod pprCLbl (HpcTicksLabel mod) = ptext (sLit "_hpc_tickboxes_") <> ppr mod <> ptext (sLit "_hpc") - ppIdFlavor :: IdLabelInfo -> SDoc - ppIdFlavor x = pp_cSEP <> -pprCLbl HpcModuleNameLabel - = ptext (sLit "_hpc_module_name_str") - + ppIdFlavor :: Name -> IdLabelInfo -> SDoc + ppIdFlavor n x = pp_cSEP <> closureSuffix' n <> (case x of Closure -> ptext (sLit "closure") SRT -> ptext (sLit "srt") diff --combined compiler/deSugar/Desugar.lhs index 37a3cf9,5fb4ebb..603c858 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@@ -18,6 -18,7 +18,7 @@@ import I import Name import CoreSyn import CoreSubst + import CoqPass ( coqPassCoreToString, coqPassCoreToCore ) import PprCore import DsMonad import DsExpr @@@ -40,6 -41,8 +41,8 @@@ import MonadUtil import OrdList import Data.List import Data.IORef + import PrelNames + import UniqSupply \end{code} %************************************************************************ @@@ -89,7 -92,7 +92,7 @@@ deSugar hsc_en <- case target of HscNothing -> return (emptyMessages, - Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks)) + Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks, undefined, undefined)) _ -> do (binds_cvr,ds_hpc_info, modBreaks) <- if (opt_Hpc @@@ -105,18 -108,16 +108,20 @@@ ; (ds_fords, foreign_prs) <- dsForeigns fords ; ds_rules <- mapMaybeM dsRule rules ; ds_vects <- mapM dsVect vects + ; hetmet_brak <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_brak_name else return undefined + ; hetmet_esc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_esc_name else return undefined + ; let hpc_init + | opt_Hpc = hpcInitCode mod ds_hpc_info + | otherwise = empty ; return ( ds_ev_binds , foreign_prs `appOL` core_prs `appOL` spec_prs , spec_rules ++ ds_rules, ds_vects - , ds_fords, ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc) } + , ds_fords `appendStubC` hpc_init - , ds_hpc_info, modBreaks) } ++ , ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc) } ; case mb_res of { Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks) -> do + Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc) -> do { -- Add export flags to bindings keep_alive <- readIORef keep_var @@@ -141,7 -142,17 +146,17 @@@ -- The simpleOptPgm gets rid of type -- bindings plus any stupid dead code - ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps + ; dumpIfSet_dyn dflags Opt_D_coqpass "Coq Pass Output" $ text $ coqPassCoreToString ds_binds + + ; ds_binds' <- if dopt Opt_F_coqpass dflags + then do { us <- mkSplitUniqSupply '~' + ; return $ coqPassCoreToCore hetmet_brak hetmet_esc us ds_binds + } + else return ds_binds + + ; dumpIfSet_dyn dflags Opt_D_dump_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds') + + ; endPass dflags CoreDesugar ds_binds' ds_rules_for_imps ; let used_names = mkUsedNames tcg_env ; deps <- mkDependencies tcg_env @@@ -163,7 -174,7 +178,7 @@@ mg_inst_env = inst_env, mg_fam_inst_env = fam_inst_env, mg_rules = ds_rules_for_imps, - mg_binds = ds_binds, + mg_binds = ds_binds', mg_foreign = ds_fords, mg_hpc_info = ds_hpc_info, mg_modBreaks = modBreaks, diff --combined compiler/ghc.cabal.in index c509eb6,8cb64ab..0a56719 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@@ -269,6 -269,7 +269,7 @@@ Librar CoreTidy CoreUnfold CoreUtils + CoqPass ExternalCore MkCore MkExternalCore @@@ -350,7 -351,6 +351,7 @@@ TysPrim TysWiredIn CostCentre + ProfInit SCCfinal RnBinds RnEnv diff --combined compiler/hetmet index 0000000,6c949de..b18f84a mode 000000,160000..160000 --- a/compiler/hetmet +++ b/compiler/hetmet @@@ -1,0 -1,1 +1,1 @@@ -Subproject commit 6c949de6b044bda942fd0553e3eb9c0386a94e44 ++Subproject commit b18f84ae40af08b3df0214593f4e4eb0665cdf7d diff --combined compiler/main/DynFlags.hs index 9f504a1,22df6a0..832f2d2 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@@ -113,7 -113,6 +113,7 @@@ data DynFla -- debugging flags = Opt_D_dump_cmm + | Opt_D_dump_raw_cmm | Opt_D_dump_cmmz | Opt_D_dump_cmmz_pretty | Opt_D_dump_cps_cmm @@@ -128,7 -127,6 +128,7 @@@ | Opt_D_dump_asm_stats | Opt_D_dump_asm_expanded | Opt_D_dump_llvm + | Opt_D_dump_core_stats | Opt_D_dump_cpranal | Opt_D_dump_deriv | Opt_D_dump_ds @@@ -181,6 -179,10 +181,10 @@@ | 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 @@@ -252,6 -254,7 +256,6 @@@ | Opt_Pp | Opt_ForceRecomp | Opt_DryRun - | Opt_DoAsmMangling | Opt_ExcessPrecision | Opt_EagerBlackHoling | Opt_ReadUserPackageConf @@@ -288,6 -291,7 +292,6 @@@ | Opt_KeepHiDiffs | Opt_KeepHcFiles | Opt_KeepSFiles - | Opt_KeepRawSFiles | Opt_KeepTmpFiles | Opt_KeepRawTokenStream | Opt_KeepLlvmFiles @@@ -311,6 -315,7 +315,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 @@@ -396,6 -401,7 +401,6 @@@ data DynFlags = DynFlags #ifndef OMIT_NATIVE_CODEGEN targetPlatform :: Platform, -- ^ The platform we're compiling for. Used by the NCG. #endif - stolen_x86_regs :: Int, cmdlineHcIncludes :: [String], -- ^ @\-\#includes@ importPaths :: [FilePath], mainModIs :: Module, @@@ -466,6 -472,7 +471,6 @@@ pgm_P :: (String,[Option]), pgm_F :: String, pgm_c :: (String,[Option]), - pgm_m :: (String,[Option]), pgm_s :: (String,[Option]), pgm_a :: (String,[Option]), pgm_l :: (String,[Option]), @@@ -623,7 -630,6 +628,7 @@@ data DynLibLoade deriving Eq data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll + deriving (Show) -- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value initDynFlags :: DynFlags -> IO DynFlags @@@ -665,6 -671,7 +670,6 @@@ defaultDynFlags #ifndef OMIT_NATIVE_CODEGEN targetPlatform = defaultTargetPlatform, #endif - stolen_x86_regs = 4, cmdlineHcIncludes = [], importPaths = ["."], mainModIs = mAIN, @@@ -729,6 -736,7 +734,6 @@@ pgm_P = panic "defaultDynFlags: No pgm_P", pgm_F = panic "defaultDynFlags: No pgm_F", pgm_c = panic "defaultDynFlags: No pgm_c", - pgm_m = panic "defaultDynFlags: No pgm_m", pgm_s = panic "defaultDynFlags: No pgm_s", pgm_a = panic "defaultDynFlags: No pgm_a", pgm_l = panic "defaultDynFlags: No pgm_l", @@@ -890,8 -898,7 +895,8 @@@ setObjectDir f d = d{ objectDir = Jus setHiDir f d = d{ hiDir = Just f} setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d } -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file - -- \#included from the .hc file when compiling with -fvia-C. + -- \#included from the .hc file when compiling via C (i.e. unregisterised + -- builds). setOutputDir f = setObjectDir f . setHiDir f . setStubDir f setDylibInstallName f d = d{ dylibInstallName = Just f} @@@ -1052,7 -1059,16 +1057,7 @@@ parseDynamicFlags_ dflags0 args pkg_fla = runCmdLine (processArgs flag_spec args') dflags0 when (not (null errs)) $ ghcError $ errorsToGhcException errs - -- Cannot use -fPIC with registerised -fvia-C, because the mangler - -- isn't up to the job. We know that if hscTarget == HscC, then the - -- user has explicitly used -fvia-C, because -fasm is the default, - -- unless there is no NCG on this platform. The latter case is - -- checked when the -fPIC flag is parsed. - -- let (pic_warns, dflags2) - | opt_PIC && hscTarget dflags1 == HscC && cGhcUnregisterised == "NO" - = ([L noSrcSpan $ "Warning: -fvia-C is incompatible with -fPIC; ignoring -fvia-C"], - dflags1{ hscTarget = HscAsm }) #if !(x86_64_TARGET_ARCH && linux_TARGET_OS) | (not opt_Static || opt_PIC) && hscTarget dflags1 == HscLlvm = ([L noSrcSpan $ "Warning: -fllvm is incompatible with -fPIC and -" @@@ -1101,7 -1117,7 +1106,7 @@@ dynamic_flags = , Flag "pgmP" (hasArg setPgmP) , Flag "pgmF" (hasArg (\f d -> d{ pgm_F = f})) , Flag "pgmc" (hasArg (\f d -> d{ pgm_c = (f,[])})) - , Flag "pgmm" (hasArg (\f d -> d{ pgm_m = (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,[])})) @@@ -1172,8 -1188,8 +1177,8 @@@ , Flag "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles)) , Flag "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles)) , Flag "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles)) - , Flag "keep-raw-s-file" (NoArg (setDynFlag Opt_KeepRawSFiles)) - , Flag "keep-raw-s-files" (NoArg (setDynFlag Opt_KeepRawSFiles)) + , Flag "keep-raw-s-file" (NoArg (addWarn "The -keep-raw-s-file flag does nothing; it will be removed in a future GHC release")) + , Flag "keep-raw-s-files" (NoArg (addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) , Flag "keep-llvm-file" (NoArg (setDynFlag Opt_KeepLlvmFiles)) , Flag "keep-llvm-files" (NoArg (setDynFlag Opt_KeepLlvmFiles)) -- This only makes sense as plural @@@ -1211,10 -1227,8 +1216,10 @@@ , Flag "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) , Flag "ddump-cmm" (setDumpFlag Opt_D_dump_cmm) + , Flag "ddump-raw-cmm" (setDumpFlag Opt_D_dump_raw_cmm) , Flag "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz) , Flag "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty) + , Flag "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats) , Flag "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm) , Flag "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm) , Flag "ddump-asm" (setDumpFlag Opt_D_dump_asm) @@@ -1282,11 -1296,16 +1287,16 @@@ 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 (\s -> s{stolen_x86_regs = 2})) - , Flag "monly-3-regs" (noArg (\s -> s{stolen_x86_regs = 3})) - , Flag "monly-4-regs" (noArg (\s -> s{stolen_x86_regs = 4})) + , Flag "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release")) + , Flag "monly-3-regs" (NoArg (addWarn "The -monly-3-regs flag does nothing; it will be removed in a future GHC release")) + , Flag "monly-4-regs" (NoArg (addWarn "The -monly-4-regs flag does nothing; it will be removed in a future GHC release")) , Flag "msse2" (NoArg (setDynFlag Opt_SSE2)) ------ Warning opts ------------------------------------------------- @@@ -1343,10 -1362,10 +1353,10 @@@ ------ Compiler flags ----------------------------------------------- , Flag "fasm" (NoArg (setObjTarget HscAsm)) - , Flag "fvia-c" (NoArg (setObjTarget HscC >> - (addWarn "The -fvia-c flag will be removed in a future GHC release"))) - , Flag "fvia-C" (NoArg (setObjTarget HscC >> - (addWarn "The -fvia-C flag will be removed in a future GHC release"))) + , Flag "fvia-c" (NoArg + (addWarn "The -fvia-c flag does nothing; it will be removed in a future GHC release")) + , Flag "fvia-C" (NoArg + (addWarn "The -fvia-C flag does nothing; it will be removed in a future GHC release")) , Flag "fllvm" (NoArg (setObjTarget HscLlvm)) , Flag "fno-code" (NoArg (do upd $ \d -> d{ ghcLink=NoLink } @@@ -1473,6 -1492,7 +1483,6 @@@ fFlags = ( "dicts-cheap", Opt_DictsCheap, nop ), ( "excess-precision", Opt_ExcessPrecision, nop ), ( "eager-blackholing", Opt_EagerBlackHoling, nop ), - ( "asm-mangling", Opt_DoAsmMangling, nop ), ( "print-bind-result", Opt_PrintBindResult, nop ), ( "force-recomp", Opt_ForceRecomp, nop ), ( "hpc-no-auto", Opt_Hpc_No_Auto, nop ), @@@ -1581,6 -1601,7 +1591,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 ), @@@ -1644,12 -1665,10 +1655,12 @@@ defaultFlag = [ Opt_AutoLinkPackages, Opt_ReadUserPackageConf, - Opt_DoAsmMangling, - Opt_SharedImplib, +#if GHC_DEFAULT_NEW_CODEGEN + Opt_TryNewCodeGen, +#endif + Opt_GenManifest, Opt_EmbedManifest, Opt_PrintBindContents, @@@ -1671,8 -1690,12 +1682,13 @@@ impliedFlag , (Opt_ExistentialQuantification, turnOn, Opt_ExplicitForAll) , (Opt_PolymorphicComponents, turnOn, Opt_ExplicitForAll) , (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) @@@ -1966,8 -1989,8 +1982,8 @@@ setTarget l = upd se | otherwise = dfs -- Changes the target only if we're compiling object code. This is --- used by -fasm and -fvia-C, which switch from one to the other, but --- not from bytecode to object-code. The idea is that -fasm/-fvia-C +-- used by -fasm and -fllvm, which switch from one to the other, but +-- not from bytecode to object-code. The idea is that -fasm/-fllvm -- can be safely used in an OPTIONS_GHC pragma. setObjTarget :: HscTarget -> DynP () setObjTarget l = upd set @@@ -2149,17 -2172,20 +2165,17 @@@ setOptHpcDir arg = upd $ \ d -> d{hpcD -- The options below are not dependent on the version of gcc, only the -- platform. -machdepCCOpts :: DynFlags -> ([String], -- flags for all C compilations - [String]) -- for registerised HC compilations -machdepCCOpts dflags = let (flagsAll, flagsRegHc) = machdepCCOpts' dflags - in (cCcOpts ++ flagsAll, flagsRegHc) +machdepCCOpts :: DynFlags -> [String] -- flags for all C compilations +machdepCCOpts dflags = cCcOpts ++ machdepCCOpts' -machdepCCOpts' :: DynFlags -> ([String], -- flags for all C compilations - [String]) -- for registerised HC compilations -machdepCCOpts' _dflags +machdepCCOpts' :: [String] -- flags for all C compilations +machdepCCOpts' #if alpha_TARGET_ARCH - = ( ["-w", "-mieee" + = ["-w", "-mieee" #ifdef HAVE_THREADED_RTS_SUPPORT , "-D_REENTRANT" #endif - ], [] ) + ] -- For now, to suppress the gcc warning "call-clobbered -- register used for global register variable", we simply -- disable all warnings altogether using the -w flag. Oh well. @@@ -2167,17 -2193,71 +2183,17 @@@ #elif hppa_TARGET_ARCH -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! -- (very nice, but too bad the HP /usr/include files don't agree.) - = ( ["-D_HPUX_SOURCE"], [] ) - -#elif m68k_TARGET_ARCH - -- -fno-defer-pop : for the .hc files, we want all the pushing/ - -- popping of args to routines to be explicit; if we let things - -- be deferred 'til after an STGJUMP, imminent death is certain! - -- - -- -fomit-frame-pointer : *don't* - -- It's better to have a6 completely tied up being a frame pointer - -- rather than let GCC pick random things to do with it. - -- (If we want to steal a6, then we would try to do things - -- as on iX86, where we *do* steal the frame pointer [%ebp].) - = ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] ) + = ["-D_HPUX_SOURCE"] #elif i386_TARGET_ARCH -- -fno-defer-pop : basically the same game as for m68k -- -- -fomit-frame-pointer : *must* in .hc files; because we're stealing -- the fp (%ebp) for our register maps. - = let n_regs = stolen_x86_regs _dflags - in - ( - [ if opt_Static then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" - ], - [ "-fno-defer-pop", - "-fomit-frame-pointer", - -- we want -fno-builtin, because when gcc inlines - -- built-in functions like memcpy() it tends to - -- run out of registers, requiring -monly-n-regs - "-fno-builtin", - "-DSTOLEN_X86_REGS="++show n_regs ] - ) - -#elif ia64_TARGET_ARCH - = ( [], ["-fomit-frame-pointer", "-G0"] ) - -#elif x86_64_TARGET_ARCH - = ( - [], - ["-fomit-frame-pointer", - "-fno-asynchronous-unwind-tables", - -- the unwind tables are unnecessary for HC code, - -- and get in the way of -split-objs. Another option - -- would be to throw them away in the mangler, but this - -- is easier. - "-fno-builtin" - -- calling builtins like strlen() using the FFI can - -- cause gcc to run out of regs, so use the external - -- version. - ] ) - -#elif sparc_TARGET_ARCH - = ( [], ["-w"] ) - -- For now, to suppress the gcc warning "call-clobbered - -- register used for global register variable", we simply - -- disable all warnings altogether using the -w flag. Oh well. + = if opt_Static then ["-DDONT_WANT_WIN32_DLL_SUPPORT"] else [] -#elif powerpc_apple_darwin_TARGET - -- -no-cpp-precomp: - -- Disable Apple's precompiling preprocessor. It's a great thing - -- for "normal" programs, but it doesn't support register variable - -- declarations. - = ( [], ["-no-cpp-precomp"] ) #else - = ( [], [] ) + = [] #endif picCCOpts :: DynFlags -> [String] diff --combined compiler/prelude/PrelNames.lhs index 24756d5,b43373e..f4d4329 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@@ -212,6 -212,11 +212,11 @@@ basicKnownKeyName -- Other classes randomClassName, randomGenClassName, monadPlusClassName, + -- Code types + hetmet_brak_name, hetmet_esc_name, hetmet_csp_name, + hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name, + hetmet_guest_char_literal_name, + -- Annotation type checking toAnnotationWrapperName @@@ -258,6 -263,7 +263,7 @@@ gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDE gHC_MAGIC, gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST, + gHC_HETMET_CODETYPES, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception, gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL, @@@ -280,6 -286,7 +286,7 @@@ gHC_READ = mkBaseModule (fsLit "GHC.Rea gHC_NUM = mkBaseModule (fsLit "GHC.Num") gHC_INTEGER = mkIntegerModule (fsLit "GHC.Integer") gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type") + gHC_HETMET_CODETYPES = mkBaseModule (fsLit "GHC.HetMet.CodeTypes") gHC_LIST = mkBaseModule (fsLit "GHC.List") gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") @@@ -775,6 -782,16 +782,16 @@@ toPName pkg = varQual (gHC_ emptyPName pkg = varQual (gHC_PARR pkg) (fsLit "emptyP") emptyPIdKey appPName pkg = varQual (gHC_PARR pkg) (fsLit "+:+") appPIdKey + -- code type things + hetmet_brak_name, hetmet_esc_name, hetmet_csp_name :: Name + hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name, hetmet_guest_char_literal_name :: Name + hetmet_brak_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_brak") hetmet_brak_key + hetmet_esc_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_esc") hetmet_esc_key + hetmet_csp_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_csp") hetmet_csp_key + hetmet_guest_integer_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "guestIntegerLiteral") hetmet_guest_integer_literal_key + hetmet_guest_string_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "guestStringLiteral") hetmet_guest_string_literal_key + hetmet_guest_char_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "guestCharLiteral") hetmet_guest_char_literal_key + -- IO things ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName, failIOName :: Name @@@ -1086,8 -1103,12 +1103,12 @@@ opaqueTyConKe stringTyConKey :: Unique stringTyConKey = mkPreludeTyConUnique 134 + -- Heterogeneous Metaprogramming code type constructor + hetMetCodeTypeTyConKey :: Unique + hetMetCodeTypeTyConKey = mkPreludeTyConUnique 135 + ---------------- Template Haskell ------------------- --- USES TyConUniques 100-129 +-- USES TyConUniques 200-299 ----------------------------------------------------- unitTyConKey :: Unique @@@ -1133,6 -1154,10 +1154,10 @@@ parrDataConKey = mkPreludeDataConUni leftDataConKey, rightDataConKey :: Unique leftDataConKey = mkPreludeDataConUnique 25 rightDataConKey = mkPreludeDataConUnique 26 + + -- Data constructor for Heterogeneous Metaprogramming code types + hetMetCodeTypeDataConKey :: Unique + hetMetCodeTypeDataConKey = mkPreludeDataConUnique 27 \end{code} %************************************************************************ @@@ -1325,8 -1350,18 +1350,18 @@@ realToFracIdKey = mkPreludeMiscIdU toIntegerClassOpKey = mkPreludeMiscIdUnique 129 toRationalClassOpKey = mkPreludeMiscIdUnique 130 + -- code types + hetmet_brak_key, hetmet_esc_key, hetmet_csp_key :: Unique + hetmet_brak_key = mkPreludeMiscIdUnique 131 + hetmet_esc_key = mkPreludeMiscIdUnique 132 + hetmet_csp_key = mkPreludeMiscIdUnique 133 + hetmet_guest_integer_literal_key, hetmet_guest_string_literal_key, hetmet_guest_char_literal_key :: Unique + hetmet_guest_integer_literal_key = mkPreludeMiscIdUnique 134 + hetmet_guest_string_literal_key = mkPreludeMiscIdUnique 135 + hetmet_guest_char_literal_key = mkPreludeMiscIdUnique 136 + ---------------- Template Haskell ------------------- --- USES IdUniques 200-399 +-- USES IdUniques 200-499 ----------------------------------------------------- \end{code} diff --combined compiler/rename/RnExpr.lhs index 9bb9551,3a288bb..f71b17c --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@@ -25,7 -25,7 +25,7 @@@ import RnBinds ( rnLocalBindsAndThen rnMatchGroup, makeMiniFixityEnv) import HsSyn import TcRnMonad - import TcEnv ( thRnBrack ) + import TcEnv ( thRnBrack, getHetMetLevel ) import RnEnv import RnTypes ( rnHsTypeFVs, rnSplice, checkTH, mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec) @@@ -34,6 -34,7 +34,7 @@@ import DynFlag import BasicTypes ( FixityDirection(..) ) import PrelNames + import Var ( TyVar, varName ) import Name import NameSet import RdrName @@@ -84,6 -85,13 +85,13 @@@ rnExprs ls = rnExprs' ls emptyUniqSe Variables. We look up the variable and return the resulting name. \begin{code} + + -- during the renamer phase we only care about the length of the + -- current HetMet level; the actual tyvars don't + -- matter, so we use bottoms for them + dummyTyVar :: TyVar + dummyTyVar = error "tried to force RnExpr.dummyTyVar" + rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars) rnLExpr = wrapLocFstM rnExpr @@@ -157,6 -165,21 +165,21 @@@ rnExpr (NegApp e _ mkNegAppRn e' neg_name `thenM` \ final_e -> return (final_e, fv_e `plusFV` fv_neg) + rnExpr (HsHetMetBrak c e) + = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = dummyTyVar:(tcl_hetMetLevel x) }) $ rnLExpr e + ; return (HsHetMetBrak c e', fv_e) + } + rnExpr (HsHetMetEsc c t e) + = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = tail (tcl_hetMetLevel x) }) $ rnLExpr e + ; return (HsHetMetEsc c t e', fv_e) + } + rnExpr (HsHetMetCSP c e) + = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = tail (tcl_hetMetLevel x) }) $ rnLExpr e + ; return (HsHetMetCSP c e', fv_e) + } + + + ------------------------------------------ -- Template Haskell extensions -- Don't ifdef-GHCI them because we want to fail gracefully @@@ -273,7 -296,9 +296,9 @@@ rnExpr (HsIf _ p b1 b2 ; rebind <- xoptM Opt_RebindableSyntax ; if not rebind then return (HsIf Nothing p' b1' b2', plusFVs [fvP, fvB1, fvB2]) - else do { c <- liftM HsVar (lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))) + else do { hetMetLevel <- getHetMetLevel + ; n <- lookupOccRn $ mkRdrUnqual $ setOccNameDepth (length hetMetLevel) (mkVarOccFS (fsLit "ifThenElse")) + ; c <- return $ HsVar n ; return (HsIf (Just c) p' b1' b2', plusFVs [fvP, fvB1, fvB2]) }} rnExpr (HsType a) @@@ -874,15 -899,13 +899,15 @@@ rnRecStmtsAndThen s con -- ...bring them and their fixities into scope ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) + -- Fake uses of variables introduced implicitly (warning suppression, see #4404) + implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv) ; bindLocalNamesFV bound_names $ addLocalFixities fix_env bound_names $ do -- (C) do the right-hand-sides and thing-inside { segs <- rn_rec_stmts bound_names new_lhs_and_fv ; (res, fvs) <- cont segs - ; warnUnusedLocalBinds bound_names fvs + ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses) ; return (res, fvs) }} -- get all the fixity decls in any Let stmt diff --combined ghc.mk index 0f58876,9a589d7..76120ba --- a/ghc.mk +++ b/ghc.mk @@@ -227,7 -227,6 +227,7 @@@ include rules/package-config.m # ----------------------------------------------------------------------------- # Building dependencies +include rules/dependencies.mk include rules/build-dependencies.mk include rules/include-dependencies.mk @@@ -545,6 -544,7 +545,6 @@@ BUILD_DIRS += ifneq "$(GhcUnregisterised)" "YES" BUILD_DIRS += \ - $(GHC_MANGLER_DIR) \ $(GHC_SPLIT_DIR) endif @@@ -920,6 -920,7 +920,6 @@@ $(eval $(call bindist,., $(includes_H_PLATFORM) \ $(includes_H_FILES) \ includes/ghcconfig.h \ - includes/rts/Config.h \ $(INSTALL_HEADERS) \ $(INSTALL_LIBEXECS) \ $(INSTALL_LIBEXEC_SCRIPTS) \ @@@ -1211,3 -1212,15 +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 $@ diff --combined libraries/base index 0000000,ec77c2c..f643d95 mode 000000,160000..160000 --- a/libraries/base +++ b/libraries/base @@@ -1,0 -1,1 +1,1 @@@ -Subproject commit ec77c2ce0ef81e7bfee1839ddae6326f69a896ec ++Subproject commit f643d954e30d5ac635d3c0ff41ad40401fbd5e92