From: Adam Megacz Date: Wed, 20 Apr 2011 17:29:56 +0000 (-0700) Subject: merge upstream HEAD X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=cf5905ea24904cf73a041fd7535e8723a668cb9a;hp=-c merge upstream HEAD --- cf5905ea24904cf73a041fd7535e8723a668cb9a diff --combined compiler/cmm/CLabel.hs index c40f3b7,901b13b..a7dabc6 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@@ -101,7 -101,7 +101,7 @@@ module CLabel hasCAF, infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, - isMathFun, + isMathFun, isCas, isCFunctionLabel, isGcPtrLabel, labelDynamic, pprCLabel @@@ -254,10 -254,6 +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. @@@ -594,9 -590,17 +594,17 @@@ maybeAsmTemp (AsmTempLabel uq) = Jus maybeAsmTemp _ = Nothing + -- | Check whether a label corresponds to our cas function. + -- We #include the prototype for this, so we need to avoid + -- generating out own C prototypes. + isCas :: CLabel -> Bool + isCas (CmmLabel pkgId fn _) = pkgId == rtsPackageId && fn == fsLit "cas" + isCas _ = False + + -- | Check whether a label corresponds to a C function that has -- a prototype in a system header somehere, or is built-in - -- to the C compiler. For these labels we abovoid generating our + -- to the C compiler. For these labels we avoid generating our -- own C prototypes. isMathFun :: CLabel -> Bool isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs @@@ -969,7 -973,7 +977,7 @@@ pprCLbl (RtsLabel (RtsSlowTickyCtr pat) 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 @@@ -980,8 -984,8 +988,8 @@@ pprCLbl (PlainModuleInitLabel mod pprCLbl (HpcTicksLabel mod) = ptext (sLit "_hpc_tickboxes_") <> ppr mod <> ptext (sLit "_hpc") -ppIdFlavor :: IdLabelInfo -> SDoc -ppIdFlavor x = pp_cSEP <> +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/main/DynFlags.hs index 832f2d2,fa05195..70358ee --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@@ -40,7 -40,7 +40,7 @@@ module DynFlags initDynFlags, -- DynFlags -> IO DynFlags getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] - getVerbFlag, + getVerbFlags, updOptLevel, setTmpDir, setPackageName, @@@ -181,10 -181,6 +181,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 -311,6 +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 @@@ -878,10 -873,10 +878,10 @@@ getOpts dflags opts = reverse (opts dfl -- | Gets the verbosity flag for the current verbosity level. This is fed to -- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included - getVerbFlag :: DynFlags -> String - getVerbFlag dflags - | verbosity dflags >= 3 = "-v" - | otherwise = "" + getVerbFlags :: DynFlags -> [String] + getVerbFlags dflags + | verbosity dflags >= 4 = ["-v"] + | otherwise = [] setObjectDir, setHiDir, setStubDir, setOutputDir, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, @@@ -1287,11 -1282,6 +1287,11 @@@ dynamic_flags = 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")) @@@ -1591,7 -1581,6 +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 ), @@@ -1684,11 -1673,6 +1684,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) diff --combined compiler/rename/RnEnv.lhs index a5aa5e1,c4ad95a..a6503a8 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@@ -12,7 -12,7 +12,7 @@@ module RnEnv lookupLocalDataTcNames, lookupSigOccRn, lookupFixityRn, lookupTyFixityRn, lookupInstDeclBndr, lookupSubBndr, lookupConstructorFields, - lookupSyntaxName, lookupSyntaxTable, + lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse, lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, getLookupOccRn, addUsedRdrNames, @@@ -36,7 -36,6 +36,7 @@@ import LoadIface ( loadInterfaceForName, loadSrcInterface ) import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) +import TcEnv ( getHetMetLevel ) import HsSyn import RdrHsSyn ( extractHsTyRdrTyVars ) import RdrName @@@ -755,17 -754,28 +755,28 @@@ We treat the orignal (standard) names a checks the type of the user thing against the type of the standard thing. \begin{code} + lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars) + -- Different to lookupSyntaxName because in the non-rebindable + -- case we desugar directly rather than calling an existing function + -- Hence the (Maybe (SyntaxExpr Name)) return type + lookupIfThenElse + = do { rebind <- xoptM Opt_RebindableSyntax + ; if not rebind + then return (Nothing, emptyFVs) + else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse")) + ; return (Just (HsVar ite), unitFV ite) } } + lookupSyntaxName :: Name -- The standard name -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name - = xoptM Opt_RebindableSyntax `thenM` \ rebindable_on -> - if not rebindable_on then normal_case - else - -- Get the similarly named thing from the local environment - lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> - return (HsVar usr_name, unitFV usr_name) - where - normal_case = return (HsVar std_name, emptyFVs) + = do ec <- getHetMetLevel + std_name' <- return $ setNameDepth (length ec) std_name + rebindable_on <- xoptM Opt_RebindableSyntax + if not rebindable_on + then return (HsVar std_name', emptyFVs) + else do usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name')) + return (HsVar usr_name, unitFV usr_name) + -- Get the similarly named thing from the local environment lookupSyntaxTable :: [Name] -- Standard names -> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames diff --combined compiler/rename/RnExpr.lhs index f71b17c,d11249a..1b7eef0 --- 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,7 -34,6 +34,7 @@@ import DynFlag import BasicTypes ( FixityDirection(..) ) import PrelNames +import Var ( TyVar, varName ) import Name import NameSet import RdrName @@@ -85,13 -84,6 +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 @@@ -165,21 -157,6 +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 @@@ -291,15 -268,10 +291,10 @@@ rnExpr (ExprWithTySig expr pty rnExpr (HsIf _ p b1 b2) = do { (p', fvP) <- rnLExpr p - ; (b1', fvB1) <- rnLExpr b1 - ; (b2', fvB2) <- rnLExpr b2 - ; rebind <- xoptM Opt_RebindableSyntax - ; if not rebind - then return (HsIf Nothing p' b1' b2', plusFVs [fvP, fvB1, fvB2]) - 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]) }} + ; (b1', fvB1) <- rnLExpr b1 + ; (b2', fvB2) <- rnLExpr b2 + ; (mb_ite, fvITE) <- lookupIfThenElse + ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } rnExpr (HsType a) = rnHsTypeFVs doc a `thenM` \ (t, fvT) -> diff --combined compiler/types/TypeRep.lhs index aa1f941,7fdf4ae..1be55d7 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@@ -485,9 -485,7 +485,7 @@@ pprKind = pprTyp pprParendKind = pprParendType ppr_type :: Prec -> Type -> SDoc - ppr_type _ (TyVarTy tv) -- Note [Infix type variables] - | isSymOcc (getOccName tv) = parens (ppr tv) - | otherwise = ppr tv + ppr_type _ (TyVarTy tv) = ppr_tvar tv ppr_type p (PredTy pred) = maybeParen p TyConPrec $ ifPprDebug (ptext (sLit "")) <> (ppr pred) ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys @@@ -543,8 -541,6 +541,8 @@@ ppr_tc_app _ tc [ty | tc `hasKey` argTypeKindTyConKey = ptext (sLit "??") ppr_tc_app p tc tys + | [ecvar,ty] <- tys, tc `hasKey` hetMetCodeTypeTyConKey + = ptext (sLit "<[") <> pprType ty <> ptext (sLit "]>@") <> ppr ecvar | isTupleTyCon tc && tyConArity tc == length tys = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys))) | otherwise @@@ -572,14 -568,19 +570,19 @@@ ppr_tc t else ptext (sLit "")) | otherwise = empty + ppr_tvar :: TyVar -> SDoc + ppr_tvar tv -- Note [Infix type variables] + | isSymOcc (getOccName tv) = parens (ppr tv) + | otherwise = ppr tv + ------------------- pprForAll :: [TyVar] -> SDoc pprForAll [] = empty pprForAll tvs = ptext (sLit "forall") <+> sep (map pprTvBndr tvs) <> dot pprTvBndr :: TyVar -> SDoc - pprTvBndr tv | isLiftedTypeKind kind = ppr tv - | otherwise = parens (ppr tv <+> dcolon <+> pprKind kind) + pprTvBndr tv | isLiftedTypeKind kind = ppr_tvar tv + | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind) where kind = tyVarKind tv \end{code}