diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -120,7 +120,6 @@ import Name import Unique import PrimOp -import Config import CostCentre import Outputable import FastString @@ -1151,35 +1150,35 @@ -} instance Outputable CLabel where - ppr c = sdocWithPlatform $ \platform -> pprCLabel platform c + ppr c = sdocWithDynFlags $ \dynFlags -> pprCLabel dynFlags c -pprCLabel :: Platform -> CLabel -> SDoc +pprCLabel :: DynFlags -> CLabel -> SDoc pprCLabel _ (LocalBlockLabel u) = tempLabelPrefixOrUnderscore <> pprUniqueAlways u -pprCLabel platform (AsmTempLabel u) - | not (platformUnregisterised platform) +pprCLabel dynFlags (AsmTempLabel u) + | not (platformUnregisterised $ targetPlatform dynFlags) = tempLabelPrefixOrUnderscore <> pprUniqueAlways u -pprCLabel platform (AsmTempDerivedLabel l suf) - | cGhcWithNativeCodeGen == "YES" - = ptext (asmTempLabelPrefix platform) +pprCLabel dynFlags (AsmTempDerivedLabel l suf) + | sGhcWithNativeCodeGen $ settings dynFlags + = ptext (asmTempLabelPrefix $ targetPlatform dynFlags) <> case l of AsmTempLabel u -> pprUniqueAlways u LocalBlockLabel u -> pprUniqueAlways u - _other -> pprCLabel platform l + _other -> pprCLabel dynFlags l <> ftext suf -pprCLabel platform (DynamicLinkerLabel info lbl) - | cGhcWithNativeCodeGen == "YES" - = pprDynamicLinkerAsmLabel platform info lbl +pprCLabel dynFlags (DynamicLinkerLabel info lbl) + | sGhcWithNativeCodeGen $ settings dynFlags + = pprDynamicLinkerAsmLabel (targetPlatform dynFlags) info lbl -pprCLabel _ PicBaseLabel - | cGhcWithNativeCodeGen == "YES" +pprCLabel dynFlags PicBaseLabel + | sGhcWithNativeCodeGen $ settings dynFlags = text "1b" -pprCLabel platform (DeadStripPreventer lbl) - | cGhcWithNativeCodeGen == "YES" +pprCLabel dynFlags (DeadStripPreventer lbl) + | sGhcWithNativeCodeGen $ settings dynFlags = {- `lbl` can be temp one but we need to ensure that dsp label will stay @@ -1187,23 +1186,24 @@ optional `_` (underscore) because this is how you mark non-temp symbols on some platforms (Darwin) -} - maybe_underscore $ text "dsp_" - <> pprCLabel platform lbl <> text "_dsp" + maybe_underscore dynFlags $ text "dsp_" + <> pprCLabel dynFlags lbl <> text "_dsp" -pprCLabel _ (StringLitLabel u) - | cGhcWithNativeCodeGen == "YES" +pprCLabel dynFlags (StringLitLabel u) + | sGhcWithNativeCodeGen $ settings dynFlags = pprUniqueAlways u <> ptext (sLit "_str") -pprCLabel platform lbl +pprCLabel dynFlags lbl = getPprStyle $ \ sty -> - if cGhcWithNativeCodeGen == "YES" && asmStyle sty - then maybe_underscore (pprAsmCLbl platform lbl) + if sGhcWithNativeCodeGen (settings dynFlags) && asmStyle sty + then maybe_underscore dynFlags $ pprAsmCLbl (targetPlatform dynFlags) lbl else pprCLbl lbl -maybe_underscore :: SDoc -> SDoc -maybe_underscore doc - | underscorePrefix = pp_cSEP <> doc - | otherwise = doc +maybe_underscore :: DynFlags -> SDoc -> SDoc +maybe_underscore dynFlags doc = + if sLeadingUnderscore $ settings dynFlags + then pp_cSEP <> doc + else doc pprAsmCLbl :: Platform -> CLabel -> SDoc pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _) @@ -1362,9 +1362,6 @@ -- ----------------------------------------------------------------------------- -- Machine-dependent knowledge about labels. - -underscorePrefix :: Bool -- leading underscore on assembler labels? -underscorePrefix = (cLeadingUnderscore == "YES") asmTempLabelPrefix :: Platform -> PtrString -- for formatting labels asmTempLabelPrefix platform = case platformOS platform of diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -16,7 +16,7 @@ emitLabel, - emit, emitDecl, emitProc, + emit, emitDecl, emitProcWithConvention, emitProcWithStackFrame, emitOutOfLine, emitAssign, emitStore, emitComment, emitTick, emitUnwind, @@ -738,14 +738,14 @@ emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False = do { dflags <- getDynFlags - ; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False + ; emitProc mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False } emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True -- do layout = do { dflags <- getDynFlags ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args graph' = entry MkGraph.<*> graph - ; emitProc_ mb_info lbl live (graph', tscope) offset True + ; emitProc mb_info lbl live (graph', tscope) offset True } emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame" @@ -757,16 +757,12 @@ = emitProcWithStackFrame conv mb_info lbl [] args blocks True emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped - -> Int -> FCode () -emitProc mb_info lbl live blocks offset - = emitProc_ mb_info lbl live blocks offset True - -emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped - -> Int -> Bool -> FCode () -emitProc_ mb_info lbl live blocks offset do_layout + -> Int -> Bool -> FCode () +emitProc mb_info lbl live blocks offset do_layout = do { dflags <- getDynFlags ; l <- newBlockId ; let + blks :: CmmGraph blks = labelAGraph l blocks infos | Just info <- mb_info = mapSingleton (g_entry blks) info diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -570,15 +570,9 @@ (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder)) -- Only non-rule loop breakers inhibit inlining - -- Check whether arity and demand type are consistent (only if demand analysis - -- already happened) - -- - -- Note (Apr 2014): this is actually ok. See Note [Demand analysis for trivial right-hand sides] - -- in DmdAnal. After eta-expansion in CorePrep the rhs is no longer trivial. - -- ; let dmdTy = idStrictness binder - -- ; checkL (case dmdTy of - -- StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs) - -- (mkArityMsg binder) + -- We used to check that the dmdTypeDepth of a demand signature never + -- exceeds idArity, but that is an unnecessary complication, see + -- Note [idArity varies independently of dmdTypeDepth] in DmdAnal -- Check that the binder's arity is within the bounds imposed by -- the type and the strictness signature. See Note [exprArity invariant] @@ -2565,20 +2559,6 @@ hang (text "Arg type:") 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -{- Not needed now -mkArityMsg :: Id -> MsgDoc -mkArityMsg binder - = vcat [hsep [text "Demand type has", - ppr (dmdTypeDepth dmd_ty), - text "arguments, rhs has", - ppr (idArity binder), - text "arguments,", - ppr binder], - hsep [text "Binder's strictness signature:", ppr dmd_ty] - - ] - where (StrictSig dmd_ty) = idStrictness binder --} mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc mkCastErr expr = mk_cast_err "expression" "type" (ppr expr) diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -55,7 +55,6 @@ import Outputable import Platform import FastString -import Config import Name ( NamedThing(..), nameSrcSpan ) import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import Data.Bits diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -752,10 +752,6 @@ -- HsSyn constructs that just shouldn't be here: ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket" -ds_expr _ (EWildPat {}) = panic "dsExpr:EWildPat" -ds_expr _ (EAsPat {}) = panic "dsExpr:EAsPat" -ds_expr _ (EViewPat {}) = panic "dsExpr:EViewPat" -ds_expr _ (ELazyPat {}) = panic "dsExpr:ELazyPat" ds_expr _ (HsDo {}) = panic "dsExpr:HsDo" ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld" ds_expr _ (XExpr {}) = panic "dsExpr: XExpr" diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -50,7 +50,6 @@ import FastString import DynFlags import Platform -import Config import OrdList import Pair import Util @@ -542,7 +541,7 @@ | otherwise = text ('a':show n) -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled - libffi = cLibFFI && isNothing maybe_target + libffi = sLibFFI (settings dflags) && isNothing maybe_target type_string -- libffi needs to know the result type too: diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs --- a/compiler/hieFile/HieAst.hs +++ b/compiler/hieFile/HieAst.hs @@ -870,18 +870,6 @@ HsSpliceE _ x -> [ toHie $ L mspan x ] - EWildPat _ -> [] - EAsPat _ a b -> - [ toHie $ C Use a - , toHie b - ] - EViewPat _ a b -> - [ toHie a - , toHie b - ] - ELazyPat _ a -> - [ toHie a - ] XExpr _ -> [] instance ( a ~ GhcPass p diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -92,11 +92,12 @@ (defaultDumpStyle dflags) sd QuietBinIFaceReading -> \_ -> return () - wantedGot :: Outputable a => String -> a -> a -> IO () - wantedGot what wanted got = + + wantedGot :: String -> a -> a -> (a -> SDoc) -> IO () + wantedGot what wanted got ppr' = printer (text what <> text ": " <> - vcat [text "Wanted " <> ppr wanted <> text ",", - text "got " <> ppr got]) + vcat [text "Wanted " <> ppr' wanted <> text ",", + text "got " <> ppr' got]) errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO () errorOnMismatch what wanted got = @@ -111,7 +112,7 @@ -- (This magic number does not change when we change -- GHC interface file format) magic <- get bh - wantedGot "Magic" (binaryInterfaceMagic dflags) magic + wantedGot "Magic" (binaryInterfaceMagic dflags) magic ppr errorOnMismatch "magic number mismatch: old/corrupt interface file?" (binaryInterfaceMagic dflags) magic @@ -129,12 +130,12 @@ -- Check the interface file version and ways. check_ver <- get bh let our_ver = show hiVersion - wantedGot "Version" our_ver check_ver + wantedGot "Version" our_ver check_ver text errorOnMismatch "mismatched interface file versions" our_ver check_ver check_way <- get bh let way_descr = getWayDescr dflags - wantedGot "Way" way_descr check_way + wantedGot "Way" way_descr check_way ppr when (checkHiWay == CheckHiWay) $ errorOnMismatch "mismatched interface file ways" way_descr check_way getWithUserData ncu bh diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -390,17 +390,15 @@ -- | Pretty print a 'CLabel'. strCLabel_llvm :: CLabel -> LlvmM LMString strCLabel_llvm lbl = do - platform <- getLlvmPlatform dflags <- getDynFlags - let sdoc = pprCLabel platform lbl + let sdoc = pprCLabel dflags lbl str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle) return (fsLit str) strDisplayName_llvm :: CLabel -> LlvmM LMString strDisplayName_llvm lbl = do - platform <- getLlvmPlatform dflags <- getDynFlags - let sdoc = pprCLabel platform lbl + let sdoc = pprCLabel dflags lbl depth = Outp.PartWay 1 style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify depth str = Outp.renderWithStyle dflags sdoc style @@ -416,9 +414,8 @@ strProcedureName_llvm :: CLabel -> LlvmM LMString strProcedureName_llvm lbl = do - platform <- getLlvmPlatform dflags <- getDynFlags - let sdoc = pprCLabel platform lbl + let sdoc = pprCLabel dflags lbl depth = Outp.PartWay 1 style = Outp.mkUserStyle dflags Outp.neverQualify depth str = Outp.renderWithStyle dflags sdoc style diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs --- a/compiler/main/CodeOutput.hs +++ b/compiler/main/CodeOutput.hs @@ -24,7 +24,6 @@ import Cmm ( RawCmmGroup ) import HscTypes import DynFlags -import Config import Stream (Stream) import qualified Stream import FileCleanup @@ -156,7 +155,7 @@ -> Stream IO RawCmmGroup () -> IO () outputAsm dflags this_mod location filenm cmm_stream - | cGhcWithNativeCodeGen == "YES" + | sGhcWithNativeCodeGen $ settings dflags = do ncg_uniqs <- mkSplitUniqSupply 'n' debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) @@ -226,8 +225,9 @@ mk_include i = "#include \"" ++ i ++ "\"\n" -- wrapper code mentions the ffi_arg type, which comes from ffi.h - ffi_includes | cLibFFI = "#include \"ffi.h\"\n" - | otherwise = "" + ffi_includes + | sLibFFI $ settings dflags = "#include \"ffi.h\"\n" + | otherwise = "" stub_h_file_exists <- outputForeignStubs_help stub_h stub_h_output_w diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -49,7 +49,6 @@ import Module import ErrUtils import DynFlags -import Config import Panic import Util import StringBuffer ( hGetStringBuffer ) @@ -258,16 +257,23 @@ then gopt_set dflags0 Opt_BuildDynamicToo else dflags0 + -- #16331 - when no "internal interpreter" is available but we + -- need to process some TemplateHaskell or QuasiQuotes, we automatically + -- turn on -fexternal-interpreter. + dflags2 = if not internalInterpreter && needsLinker + then gopt_set dflags1 Opt_ExternalInterpreter + else dflags1 + basename = dropExtension input_fn -- We add the directory in which the .hs files resides) to the import -- path. This is needed when we try to compile the .hc file later, if it -- imports a _stub.h file that we created here. current_dir = takeDirectory basename - old_paths = includePaths dflags1 + old_paths = includePaths dflags2 !prevailing_dflags = hsc_dflags hsc_env0 dflags = - dflags1 { includePaths = addQuoteInclude old_paths [current_dir] + dflags2 { includePaths = addQuoteInclude old_paths [current_dir] , log_action = log_action prevailing_dflags } -- use the prevailing log_action / log_finaliser, -- not the one cached in the summary. This is so @@ -362,7 +368,7 @@ = lookupHook linkHook l dflags ghcLink dflags where l LinkInMemory _ _ _ - = if cGhcWithInterpreter == "YES" + = if sGhcWithInterpreter $ settings dflags then -- Not Linking...(demand linker will do the job) return Succeeded else panicBadLink LinkInMemory diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1953,7 +1953,7 @@ -- See Note [-fno-code mode] #8025 map1 <- if hscTarget dflags == HscNothing then enableCodeGenForTH - (defaultObjectTarget (targetPlatform dflags)) + (defaultObjectTarget (settings dflags)) map0 else return map0 return $ concat $ nodeMapElts map1 diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -131,7 +131,7 @@ ideclPkgQual = Nothing, ideclSource = False, ideclSafe = False, -- Not a safe import - ideclQualified = False, + ideclQualified = NotQualified, ideclImplicit = True, -- Implicit! ideclAs = Nothing, ideclHiding = Nothing } diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -126,9 +126,10 @@ import_info _ = panic " import_info: Impossible Match" -- due to #15884 - safe_info = qual_info - qual_info False = 0 - qual_info True = 1 + safe_info False = 0 + safe_info True = 1 + qual_info NotQualified = 0 + qual_info _ = 1 as_info Nothing = 0 as_info (Just _) = 1 spec_info Nothing = (0,0,0,0,1,0,0) diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -177,6 +177,7 @@ Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs) Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) crossCompiling <- getBooleanSetting "cross compiling" + targetPlatformString <- getSetting "target platform string" targetArch <- readSetting "target arch" targetOS <- readSetting "target os" targetWordSize <- readSetting "target word size" @@ -184,6 +185,7 @@ targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack" targetHasIdentDirective <- readSetting "target has .ident directive" targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols" + tablesNextToCode <- getBooleanSetting "Tables next to code" myExtraGccViaCFlags <- getSetting "GCC extra via C opts" -- On Windows, mingw is distributed with GHC, -- so we look in TopDir/../mingw/bin, @@ -211,9 +213,9 @@ ghc_usage_msg_path = installed "ghc-usage.txt" ghci_usage_msg_path = installed "ghci-usage.txt" - -- For all systems, unlit, split, mangle are GHC utilities - -- architecture-specific stuff is done when building Config.hs - unlit_path = libexec cGHC_UNLIT_PGM + -- For all systems, unlit, split, mangle are GHC utilities + -- architecture-specific stuff is done when building Config.hs + unlit_path <- getToolSetting "unlit command" windres_path <- getToolSetting "windres command" libtool_path <- getToolSetting "libtool command" @@ -257,6 +259,29 @@ platformIsCrossCompiling = crossCompiling } + integerLibrary <- getSetting "integer library" + integerLibraryType <- case integerLibrary of + "integer-gmp" -> pure IntegerGMP + "integer-simple" -> pure IntegerSimple + _ -> pgmError $ unwords + [ "Entry for" + , show "integer library" + , "must be one of" + , show "integer-gmp" + , "or" + , show "integer-simple" + ] + + ghcWithInterpreter <- getBooleanSetting "Use interpreter" + ghcWithNativeCodeGen <- getBooleanSetting "Use native code generator" + ghcWithSMP <- getBooleanSetting "Support SMP" + ghcRTSWays <- getSetting "RTS ways" + leadingUnderscore <- getBooleanSetting "Leading underscore" + useLibFFI <- getBooleanSetting "Use LibFFI" + ghcThreaded <- getBooleanSetting "Use Threads" + ghcDebugged <- getBooleanSetting "Use Debugging" + ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw" + return $ Settings { sTargetPlatform = platform, sTmpDir = normalise tmpdir, @@ -303,7 +328,21 @@ sOpt_lo = [], sOpt_lc = [], sOpt_i = [], - sPlatformConstants = platformConstants + sPlatformConstants = platformConstants, + + sTargetPlatformString = targetPlatformString, + sIntegerLibrary = integerLibrary, + sIntegerLibraryType = integerLibraryType, + sGhcWithInterpreter = ghcWithInterpreter, + sGhcWithNativeCodeGen = ghcWithNativeCodeGen, + sGhcWithSMP = ghcWithSMP, + sGhcRTSWays = ghcRTSWays, + sTablesNextToCode = tablesNextToCode, + sLeadingUnderscore = leadingUnderscore, + sLibFFI = useLibFFI, + sGhcThreaded = ghcThreaded, + sGhcDebugged = ghcDebugged, + sGhcRtsWithLibdw = ghcRtsWithLibdw } @@ -379,10 +418,12 @@ -- against libHSrts, then both end up getting loaded, -- and things go wrong. We therefore link the libraries -- with the same RTS flags that we link GHC with. - dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0 - else dflags0 - dflags2 = if cGhcDebugged then addWay' WayDebug dflags1 - else dflags1 + dflags1 = if sGhcThreaded $ settings dflags0 + then addWay' WayThreaded dflags0 + else dflags0 + dflags2 = if sGhcDebugged $ settings dflags1 + then addWay' WayDebug dflags1 + else dflags1 dflags = updateWays dflags2 verbFlags = getVerbFlags dflags diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs --- a/compiler/nativeGen/AsmCodeGen.hs +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -852,7 +852,7 @@ | otherwise = Outputable.empty - doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle) + doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel dflags lbl) astyle) astyle = mkCodeStyle AsmStyle -- ----------------------------------------------------------------------------- diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -565,19 +565,19 @@ -- pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc -pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS = OSDarwin }) importedLbl +pprImportedSymbol dflags (Platform { platformArch = ArchX86, platformOS = OSDarwin }) importedLbl | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl = case positionIndependent dflags of False -> vcat [ text ".symbol_stub", - text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"), - text "\t.indirect_symbol" <+> pprCLabel platform lbl, - text "\tjmp *L" <> pprCLabel platform lbl + text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"), + text "\t.indirect_symbol" <+> pprCLabel dflags lbl, + text "\tjmp *L" <> pprCLabel dflags lbl <> text "$lazy_ptr", - text "L" <> pprCLabel platform lbl + text "L" <> pprCLabel dflags lbl <> text "$stub_binder:", - text "\tpushl $L" <> pprCLabel platform lbl + text "\tpushl $L" <> pprCLabel dflags lbl <> text "$lazy_ptr", text "\tjmp dyld_stub_binding_helper" ] @@ -585,16 +585,16 @@ vcat [ text ".section __TEXT,__picsymbolstub2," <> text "symbol_stubs,pure_instructions,25", - text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"), - text "\t.indirect_symbol" <+> pprCLabel platform lbl, + text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"), + text "\t.indirect_symbol" <+> pprCLabel dflags lbl, text "\tcall ___i686.get_pc_thunk.ax", text "1:", - text "\tmovl L" <> pprCLabel platform lbl + text "\tmovl L" <> pprCLabel dflags lbl <> text "$lazy_ptr-1b(%eax),%edx", text "\tjmp *%edx", - text "L" <> pprCLabel platform lbl + text "L" <> pprCLabel dflags lbl <> text "$stub_binder:", - text "\tlea L" <> pprCLabel platform lbl + text "\tlea L" <> pprCLabel dflags lbl <> text "$lazy_ptr-1b(%eax),%eax", text "\tpushl %eax", text "\tjmp dyld_stub_binding_helper" @@ -602,16 +602,16 @@ $+$ vcat [ text ".section __DATA, __la_sym_ptr" <> (if positionIndependent dflags then int 2 else int 3) <> text ",lazy_symbol_pointers", - text "L" <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"), - text "\t.indirect_symbol" <+> pprCLabel platform lbl, - text "\t.long L" <> pprCLabel platform lbl + text "L" <> pprCLabel dflags lbl <> ptext (sLit "$lazy_ptr:"), + text "\t.indirect_symbol" <+> pprCLabel dflags lbl, + text "\t.long L" <> pprCLabel dflags lbl <> text "$stub_binder"] | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl = vcat [ text ".non_lazy_symbol_pointer", - char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr:", - text "\t.indirect_symbol" <+> pprCLabel platform lbl, + char 'L' <> pprCLabel dflags lbl <> text "$non_lazy_ptr:", + text "\t.indirect_symbol" <+> pprCLabel dflags lbl, text "\t.long\t0"] | otherwise @@ -632,12 +632,12 @@ -- -- NB: No DSO-support yet -pprImportedSymbol _ platform@(Platform { platformOS = OSAIX }) importedLbl +pprImportedSymbol dflags (Platform { platformOS = OSAIX }) importedLbl = case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) -> vcat [ - text "LC.." <> pprCLabel platform lbl <> char ':', - text "\t.long" <+> pprCLabel platform lbl ] + text "LC.." <> pprCLabel dflags lbl <> char ':', + text "\t.long" <+> pprCLabel dflags lbl ] _ -> empty -- ELF / Linux @@ -669,15 +669,15 @@ -- the NCG will keep track of all DynamicLinkerLabels it uses -- and output each of them using pprImportedSymbol. -pprImportedSymbol _ platform@(Platform { platformArch = ArchPPC_64 _ }) +pprImportedSymbol dflags platform@(Platform { platformArch = ArchPPC_64 _ }) importedLbl | osElfTarget (platformOS platform) = case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) -> vcat [ text ".section \".toc\", \"aw\"", - text ".LC_" <> pprCLabel platform lbl <> char ':', - text "\t.quad" <+> pprCLabel platform lbl ] + text ".LC_" <> pprCLabel dflags lbl <> char ':', + text "\t.quad" <+> pprCLabel dflags lbl ] _ -> empty pprImportedSymbol dflags platform importedLbl @@ -691,8 +691,8 @@ in vcat [ text ".section \".got2\", \"aw\"", - text ".LC_" <> pprCLabel platform lbl <> char ':', - ptext symbolSize <+> pprCLabel platform lbl ] + text ".LC_" <> pprCLabel dflags lbl <> char ':', + ptext symbolSize <+> pprCLabel dflags lbl ] -- PLT code stubs are generated automatically by the dynamic linker. _ -> empty diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -1374,7 +1374,7 @@ f :: Int -> Int g x = x We don't want to say 'f' is out of scope; instead, we want to -return the imported 'f', so that later on the reanamer will +return the imported 'f', so that later on the renamer will correctly report "misplaced type sig". Note [Signatures for top level things] @@ -1472,18 +1472,23 @@ lookup_top keep_me = do { env <- getGlobalRdrEnv ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) + ; let candidates_msg = candidates $ map gre_name + $ filter isLocalGRE + $ globalRdrEnvElts env ; case filter (keep_me . gre_name) all_gres of - [] | null all_gres -> bale_out_with Outputable.empty + [] | null all_gres -> bale_out_with candidates_msg | otherwise -> bale_out_with local_msg (gre:_) -> return (Right (gre_name gre)) } lookup_group bound_names -- Look in the local envt (not top level) = do { mname <- lookupLocalOccRn_maybe rdr_name + ; env <- getLocalRdrEnv + ; let candidates_msg = candidates $ localRdrEnvElts env ; case mname of Just n | n `elemNameSet` bound_names -> return (Right n) | otherwise -> bale_out_with local_msg - Nothing -> bale_out_with Outputable.empty } + Nothing -> bale_out_with candidates_msg } bale_out_with msg = return (Left (sep [ text "The" <+> what @@ -1493,6 +1498,22 @@ local_msg = parens $ text "The" <+> what <+> ptext (sLit "must be given where") <+> quotes (ppr rdr_name) <+> text "is declared" + + -- Identify all similar names and produce a message listing them + candidates :: [Name] -> MsgDoc + candidates names_in_scope + = case similar_names of + [] -> Outputable.empty + [n] -> text "Perhaps you meant" <+> pp_item n + _ -> sep [ text "Perhaps you meant one of these:" + , nest 2 (pprWithCommas pp_item similar_names) ] + where + similar_names + = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name) + $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x)) + names_in_scope + + pp_item x = quotes (ppr x) <+> parens (pprDefinedAt x) --------------- diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -140,6 +140,9 @@ rnExpr (HsIPVar x v) = return (HsIPVar x v, emptyFVs) +rnExpr (HsUnboundVar x v) + = return (HsUnboundVar x v, emptyFVs) + rnExpr (HsOverLabel x _ v) = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if rebindable_on @@ -346,24 +349,6 @@ return (ArithSeq x Nothing new_seq, fvs) } {- -These three are pattern syntax appearing in expressions. -Since all the symbols are reservedops we can simply reject them. -We return a (bogus) EWildPat in each case. --} - -rnExpr (EWildPat _) = return (hsHoleExpr, emptyFVs) -- "_" is just a hole -rnExpr e@(EAsPat {}) - = do { opt_TypeApplications <- xoptM LangExt.TypeApplications - ; let msg | opt_TypeApplications - = "Type application syntax requires a space before '@'" - | otherwise - = "Did you mean to enable TypeApplications?" - ; patSynErr e (text msg) - } -rnExpr e@(EViewPat {}) = patSynErr e empty -rnExpr e@(ELazyPat {}) = patSynErr e empty - -{- ************************************************************************ * * Static values @@ -415,9 +400,6 @@ rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) -- HsWrap -hsHoleExpr :: HsExpr (GhcPass id) -hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_")) - ---------------------- -- See Note [Parsing sections] in Parser.y rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) @@ -2086,12 +2068,6 @@ sectionErr expr = hang (text "A section must be enclosed in parentheses") 2 (text "thus:" <+> (parens (ppr expr))) - -patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars) -patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:", - nest 4 (ppr e)] $$ - explanation) - ; return (EWildPat noExt, emptyFVs) } badIpBinds :: Outputable a => SDoc -> a -> SDoc badIpBinds what binds diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -267,7 +267,7 @@ , ideclName = loc_imp_mod_name , ideclPkgQual = mb_pkg , ideclSource = want_boot, ideclSafe = mod_safe - , ideclQualified = qual_only, ideclImplicit = implicit + , ideclQualified = qual_style, ideclImplicit = implicit , ideclAs = as_mod, ideclHiding = imp_details })) = setSrcSpan loc $ do @@ -275,6 +275,8 @@ pkg_imports <- xoptM LangExt.PackageImports when (not pkg_imports) $ addErr packageImportErr + let qual_only = isImportDeclQualified qual_style + -- If there's an error in loadInterface, (e.g. interface -- file not found) we get lots of spurious errors from 'filterImports' let imp_mod_name = unLoc loc_imp_mod_name @@ -1470,8 +1472,8 @@ , text "from module" <+> quotes pp_mod <+> is_redundant] pp_herald = text "The" <+> pp_qual <+> text "import of" pp_qual - | ideclQualified decl = text "qualified" - | otherwise = Outputable.empty + | isImportDeclQualified (ideclQualified decl)= text "qualified" + | otherwise = Outputable.empty pp_mod = ppr (unLoc (ideclName decl)) is_redundant = text "is redundant" diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -1552,7 +1552,8 @@ ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs -> do { (defn', fvs) <- rnDataDefn doc defn -- See Note [Complete user-supplied kind signatures] in HsDecls - ; let cusk = hsTvbAllKinded tyvars' && no_rhs_kvs + ; cusks_enabled <- xoptM LangExt.CUSKs + ; let cusk = cusks_enabled && hsTvbAllKinded tyvars' && no_rhs_kvs rn_info = DataDeclRn { tcdDataCusk = cusk , tcdFVs = fvs } ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs) diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs --- a/compiler/simplCore/SimplMonad.hs +++ b/compiler/simplCore/SimplMonad.hs @@ -21,7 +21,7 @@ import GhcPrelude -import Var ( Var, isTyVar, mkLocalVar ) +import Var ( Var, isId, mkLocalVar ) import Name ( mkSystemVarName ) import Id ( Id, mkSysLocalOrCoVar ) import IdInfo ( IdDetails(..), vanillaIdInfo, setArityInfo ) @@ -187,7 +187,8 @@ = do { uniq <- getUniqueM ; let name = mkSystemVarName uniq (fsLit "$j") join_id_ty = mkLamTypes bndrs body_ty -- Note [Funky mkLamTypes] - arity = length (filter (not . isTyVar) bndrs) + -- Note [idArity for join points] in SimplUtils + arity = length (filter isId bndrs) join_arity = length bndrs details = JoinId join_arity id_info = vanillaIdInfo `setArityInfo` arity diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -1508,7 +1508,7 @@ -> SimplM (Arity, Bool, OutExpr) -- See Note [Eta-expanding at let bindings] -- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then --- (a) rhs' has manifest arity +-- (a) rhs' has manifest arity n -- (b) if is_bot is True then rhs' applied to n args is guaranteed bottom tryEtaExpandRhs mode bndr rhs | Just join_arity <- isJoinId_maybe bndr @@ -1517,6 +1517,7 @@ -- Note [Do not eta-expand join points] -- But do return the correct arity and bottom-ness, because -- these are used to set the bndr's IdInfo (#15517) + -- Note [idArity for join points] | otherwise = do { (new_arity, is_bot, new_rhs) <- try_expand @@ -1609,6 +1610,13 @@ $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ()) $j2 = if n > 0 then $j1 else (...) eta + +Note [idArity for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because of Note [Do not eta-expand join points] we have it that the idArity +of a join point is always (less than or) equal to the join arity. +Essentially, for join points we set `idArity $j = count isId join_lam_bndrs`. +It really can be less if there are type-level binders in join_lam_bndrs. Note [Do not eta-expand PAPs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs --- a/compiler/stranal/DmdAnal.hs +++ b/compiler/stranal/DmdAnal.hs @@ -206,7 +206,6 @@ -- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ]) (res_ty `bothDmdType` arg_ty, App fun' arg') --- this is an anonymous lambda, since @dmdAnalRhsLetDown@ uses @collectBinders@ dmdAnal' env dmd (Lam var body) | isTyVar var = let @@ -286,10 +285,7 @@ -- This is used for a non-recursive local let without manifest lambdas. -- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”. dmdAnal' env dmd (Let (NonRec id rhs) body) - | useLetUp id rhs - , Nothing <- unpackTrivial rhs - -- dmdAnalRhsLetDown treats trivial right hand sides specially - -- so if we have a trival right hand side, fall through to that. + | useLetUp id = (final_ty, Let (NonRec id' rhs') body') where (body_ty, body') = dmdAnal env dmd body @@ -582,25 +578,6 @@ -} --- Trivial RHS --- See Note [Demand analysis for trivial right-hand sides] -dmdAnalTrivialRhs :: - AnalEnv -> Id -> CoreExpr -> Var -> - (DmdEnv, Id, CoreExpr) -dmdAnalTrivialRhs env id rhs fn - = (fn_fv, set_idStrictness env id fn_str, rhs) - where - fn_str = getStrictness env fn - fn_fv | isLocalId fn = unitVarEnv fn topDmd - | otherwise = emptyDmdEnv - -- Note [Remember to demand the function itself] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- fn_fv: don't forget to produce a demand for fn itself - -- Lacking this caused #9128 - -- The demand is very conservative (topDmd), but that doesn't - -- matter; trivial bindings are usually inlined, so it only - -- kicks in for top-level bindings and NOINLINE bindings - -- Let bindings can be processed in two ways: -- Down (RHS before body) or Up (body before RHS). -- dmdAnalRhsLetDown implements the Down variant: @@ -621,28 +598,23 @@ -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs - | Just fn <- unpackTrivial rhs -- See Note [Demand analysis for trivial right-hand sides] - = dmdAnalTrivialRhs env id rhs fn - - | otherwise - = (lazy_fv, id', mkLams bndrs' body') + = (lazy_fv, id', rhs') where - (bndrs, body, body_dmd) - = case isJoinId_maybe id of - Just join_arity -- See Note [Demand analysis for join points] - | (bndrs, body) <- collectNBinders join_arity rhs - -> (bndrs, body, let_dmd) - - Nothing | (bndrs, body) <- collectBinders rhs - -> (bndrs, body, mkBodyDmd env body) - - env_body = foldl' extendSigsWithLam env bndrs - (body_ty, body') = dmdAnal env_body body_dmd body - body_ty' = removeDmdTyArgs body_ty -- zap possible deep CPR info - (DmdType rhs_fv rhs_dmds rhs_res, bndrs') - = annotateLamBndrs env (isDFunId id) body_ty' bndrs - sig_ty = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res') - id' = set_idStrictness env id sig_ty + rhs_arity = idArity id + rhs_dmd + -- See Note [Demand analysis for join points] + -- See Note [idArity for join points] in SimplUtils + -- rhs_arity matches the join arity of the join point + | isJoinId id + = mkCallDmds rhs_arity let_dmd + | otherwise + -- NB: rhs_arity + -- See Note [Demand signatures are computed for a threshold demand based on idArity] + = mkRhsDmd env rhs_arity rhs + (DmdType rhs_fv rhs_dmds rhs_res, rhs') + = dmdAnal env rhs_dmd rhs + sig = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_res') + id' = set_idStrictness env id sig -- See Note [NOINLINE and strictness] @@ -666,36 +638,63 @@ || not (isStrictDmd (idDemandInfo id) || ae_virgin env) -- See Note [Optimistic CPR in the "virgin" case] -mkBodyDmd :: AnalEnv -> CoreExpr -> CleanDemand --- See Note [Product demands for function body] -mkBodyDmd env body - = case deepSplitProductType_maybe (ae_fam_envs env) (exprType body) of - Nothing -> cleanEvalDmd - Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc) - -unpackTrivial :: CoreExpr -> Maybe Id --- Returns (Just v) if the arg is really equal to v, modulo --- casts, type applications etc --- See Note [Demand analysis for trivial right-hand sides] -unpackTrivial (Var v) = Just v -unpackTrivial (Cast e _) = unpackTrivial e -unpackTrivial (Lam v e) | isTyVar v = unpackTrivial e -unpackTrivial (App e a) | isTypeArg a = unpackTrivial e -unpackTrivial _ = Nothing +-- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for +-- unleashing on the given function's @rhs@, by creating a call demand of +-- @rhs_arity@ with a body demand appropriate for possible product types. +-- See Note [Product demands for function body]. +-- For example, a call of the form @mkRhsDmd _ 2 (\x y -> (x, y))@ returns a +-- clean usage demand of @C1(C1(U(U,U)))@. +mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand +mkRhsDmd env rhs_arity rhs = + case peelTsFuns rhs_arity (findTypeShape (ae_fam_envs env) (exprType rhs)) of + Just (TsProd tss) -> mkCallDmds rhs_arity (cleanEvalProdDmd (length tss)) + _ -> mkCallDmds rhs_arity cleanEvalDmd --- | If given the RHS of a let-binding, this 'useLetUp' determines --- whether we should process the binding up (body before rhs) or --- down (rhs before body). +-- | If given the let-bound 'Id', 'useLetUp' determines whether we should +-- process the binding up (body before rhs) or down (rhs before body). -- --- We use LetDown if there is a chance to get a useful strictness signature. --- This is the case when there are manifest value lambdas or the binding is a --- join point (hence always acts like a function, not a value). -useLetUp :: Var -> CoreExpr -> Bool -useLetUp f _ | isJoinId f = False -useLetUp f (Lam v e) | isTyVar v = useLetUp f e -useLetUp _ (Lam _ _) = False -useLetUp _ _ = True - +-- We use LetDown if there is a chance to get a useful strictness signature to +-- unleash at call sites. LetDown is generally more precise than LetUp if we can +-- correctly guess how it will be used in the body, that is, for which incoming +-- demand the strictness signature should be computed, which allows us to +-- unleash higher-order demands on arguments at call sites. This is mostly the +-- case when +-- +-- * The binding takes any arguments before performing meaningful work (cf. +-- 'idArity'), in which case we are interested to see how it uses them. +-- * The binding is a join point, hence acting like a function, not a value. +-- As a big plus, we know *precisely* how it will be used in the body; since +-- it's always tail-called, we can directly unleash the incoming demand of +-- the let binding on its RHS when computing a strictness signature. See +-- [Demand analysis for join points]. +-- +-- Thus, if the binding is not a join point and its arity is 0, we have a thunk +-- and use LetUp, implying that we have no usable demand signature available +-- when we analyse the let body. +-- +-- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free +-- vars at most once, regardless of how many times it was forced in the body. +-- This makes a real difference wrt. usage demands. The other reason is being +-- able to unleash a more precise product demand on its RHS once we know how the +-- thunk was used in the let body. +-- +-- Characteristic examples, always assuming a single evaluation: +-- +-- * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that +-- the expression uses @y@ at most once. +-- * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that +-- @b@ is absent. +-- * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that +-- the expression uses @y@ strictly, because we have @f@'s demand signature +-- available at the call site. +-- * @join exit = 2*y in if a then exit else if b then exit else 3*y@ => +-- LetDown. Compared to LetUp, we find out that the expression uses @y@ +-- strictly, because we can unleash @exit@'s signature at each call site. +-- * For a more convincing example with join points, see Note [Demand analysis +-- for join points]. +-- +useLetUp :: Var -> Bool +useLetUp f = idArity f == 0 && not (isJoinId f) {- Note [Demand analysis for join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -728,22 +727,141 @@ Another win for join points! #13543. +Note [Demand signatures are computed for a threshold demand based on idArity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We compute demand signatures assuming idArity incoming arguments to approximate +behavior for when we have a call site with at least that many arguments. idArity +is /at least/ the number of manifest lambdas, but might be higher for PAPs and +trivial RHS (see Note [Demand analysis for trivial right-hand sides]). + +Because idArity of a function varies independently of its cardinality properties +(cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode +the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth' +(cf. Note [Understanding DmdType and StrictSig] in Demand). It is unsound to +unleash a demand signature when the incoming number of arguments is less than +that. See Note [What are demand signatures?] for more details on soundness. + +Why idArity arguments? Because that's a conservative estimate of how many +arguments we must feed a function before it does anything interesting with them. +Also it elegantly subsumes the trivial RHS and PAP case. + +There might be functions for which we might want to analyse for more incoming +arguments than idArity. Example: + + f x = + if expensive + then \y -> ... y ... + else \y -> ... y ... + +We'd analyse `f` under a unary call demand C(S), corresponding to idArity +being 1. That's enough to look under the manifest lambda and find out how a +unary call would use `x`, but not enough to look into the lambdas in the if +branches. + +On the other hand, if we analysed for call demand C(C(S)), we'd get useful +strictness info for `y` (and more precise info on `x`) and possibly CPR +information, but + + * We would no longer be able to unleash the signature at unary call sites + * Performing the worker/wrapper split based on this information would be + implicitly eta-expanding `f`, playing fast and loose with divergence and + even being unsound in the presence of newtypes, so we refrain from doing so. + Also see Note [Don't eta expand in w/w] in WorkWrap. + +Since we only compute one signature, we do so for arity 1. Computing multiple +signatures for different arities (i.e., polyvariance) would be entirely +possible, if it weren't for the additional runtime and implementation +complexity. + +Note [idArity varies independently of dmdTypeDepth] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to check in CoreLint that dmdTypeDepth <= idArity for a let-bound +identifier. But that means we would have to zap demand signatures every time we +reset or decrease arity. That's an unnecessary dependency, because + + * The demand signature captures a semantic property that is independent of + what the binding's current arity is + * idArity is analysis information itself, thus volatile + * We already *have* dmdTypeDepth, wo why not just use it to encode the + threshold for when to unleash the signature + (cf. Note [Understanding DmdType and StrictSig] in Demand) + +Consider the following expression, for example: + + (let go x y = `x` seq ... in go) |> co + +`go` might have a strictness signature of ``. The simplifier will identify +`go` as a nullary join point through `joinPointBinding_maybe` and float the +coercion into the binding, leading to an arity decrease: + + join go = (\x y -> `x` seq ...) |> co in go + +With the CoreLint check, we would have to zap `go`'s perfectly viable strictness +signature. + +Note [What are demand signatures?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Demand analysis interprets expressions in the abstract domain of demand +transformers. Given an incoming demand we put an expression under, its abstract +transformer gives us back a demand type denoting how other things (like +arguments and free vars) were used when the expression was evaluated. +Here's an example: + + f x y = + if x + expensive + then \z -> z + y * ... + else \z -> z * ... + +The abstract transformer (let's call it F_e) of the if expression (let's call it +e) would transform an incoming head demand into a demand type like +{x->,y->}. In pictures: + + Demand ---F_e---> DmdType + {x->,y->} + +Let's assume that the demand transformers we compute for an expression are +correct wrt. to some concrete semantics for Core. How do demand signatures fit +in? They are strange beasts, given that they come with strict rules when to +it's sound to unleash them. + +Fortunately, we can formalise the rules with Galois connections. Consider +f's strictness signature, {}. It's a single-point approximation of +the actual abstract transformer of f's RHS for arity 2. So, what happens is that +we abstract *once more* from the abstract domain we already are in, replacing +the incoming Demand by a simple lattice with two elements denoting incoming +arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom +element). Here's the diagram: + + A_2 -----f_f----> DmdType + ^ | + | α γ | + | v + Demand ---F_f---> DmdType + +With + α(C1(C1(_))) = >=2 -- example for usage demands, but similar for strictness + α(_) = <2 + γ(ty) = ty +and F_f being the abstract transformer of f's RHS and f_f being the abstracted +abstract transformer computable from our demand signature simply by + + f_f(>=2) = {} + f_f(<2) = postProcessUnsat {} + +where postProcessUnsat makes a proper top element out of the given demand type. + Note [Demand analysis for trivial right-hand sides] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider - foo = plusInt |> co + foo = plusInt |> co where plusInt is an arity-2 function with known strictness. Clearly we want plusInt's strictness to propagate to foo! But because it has no manifest lambdas, it won't do so automatically, and indeed 'co' might -have type (Int->Int->Int) ~ T, so we *can't* eta-expand. So we have a -special case for right-hand sides that are "trivial", namely variables, -casts, type applications, and the like. +have type (Int->Int->Int) ~ T. -Note that this can mean that 'foo' has an arity that is smaller than that -indicated by its demand info. e.g. if co :: (Int->Int->Int) ~ T, then -foo's arity will be zero (see Note [exprArity invariant] in CoreArity), -but its demand signature will be that of plusInt. A small example is the -test case of #8963. +Fortunately, CoreArity gives 'foo' arity 2, which is enough for LetDown to +forward plusInt's demand signature, and all is well (see Note [Newtype arity] in +CoreArity)! A small example is the test case NewtypeArity. Note [Product demands for function body] @@ -841,13 +959,6 @@ where (dmd_ty', dmd) = findBndrDmd env False dmd_ty var -annotateLamBndrs :: AnalEnv -> DFunFlag -> DmdType -> [Var] -> (DmdType, [Var]) -annotateLamBndrs env args_of_dfun ty bndrs = mapAccumR annotate ty bndrs - where - annotate dmd_ty bndr - | isId bndr = annotateLamIdBndr env args_of_dfun dmd_ty bndr - | otherwise = (dmd_ty, bndr) - annotateLamIdBndr :: AnalEnv -> DFunFlag -- is this lambda at the top of the RHS of a dfun? -> DmdType -- Demand type of body @@ -1159,12 +1270,6 @@ lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag) lookupSigEnv env id = lookupVarEnv (ae_sigs env) id - -getStrictness :: AnalEnv -> Id -> StrictSig -getStrictness env fn - | isGlobalId fn = idStrictness fn - | Just (sig, _) <- lookupSigEnv env fn = sig - | otherwise = nopSig nonVirgin :: AnalEnv -> AnalEnv nonVirgin env = env { ae_virgin = False } diff --git a/compiler/stranal/WorkWrap.hs b/compiler/stranal/WorkWrap.hs --- a/compiler/stranal/WorkWrap.hs +++ b/compiler/stranal/WorkWrap.hs @@ -9,6 +9,7 @@ import GhcPrelude +import CoreArity ( manifestArity ) import CoreSyn import CoreUnfold ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding ) import CoreUtils ( exprType, exprIsHNF ) @@ -457,7 +458,7 @@ -- See Note [Don't w/w INLINE things] -- See Note [Don't w/w inline small non-loop-breaker things] - | is_fun + | is_fun && is_eta_exp = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds res_info rhs | is_thunk -- See Note [Thunk splitting] @@ -474,9 +475,11 @@ -- See Note [Zapping DmdEnv after Demand Analyzer] and -- See Note [Zapping Used Once info in WorkWrap] - is_fun = notNull wrap_dmds || isJoinId fn_id - is_thunk = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id) - && not (isUnliftedType (idType fn_id)) + is_fun = notNull wrap_dmds || isJoinId fn_id + -- See Note [Don't eta expand in w/w] + is_eta_exp = length wrap_dmds == manifestArity rhs + is_thunk = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id) + && not (isUnliftedType (idType fn_id)) {- Note [Zapping DmdEnv after Demand Analyzer] @@ -516,6 +519,36 @@ We do not do it in the demand analyser for the same reasons outlined in Note [Zapping DmdEnv after Demand Analyzer] above. + +Note [Don't eta expand in w/w] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A binding where the manifestArity of the RHS is less than idArity of the binder +means CoreArity didn't eta expand that binding. When this happens, it does so +for a reason (see Note [exprArity invariant] in CoreArity) and we probably have +a PAP, cast or trivial expression as RHS. + +Performing the worker/wrapper split will implicitly eta-expand the binding to +idArity, overriding CoreArity's decision. Other than playing fast and loose with +divergence, it's also broken for newtypes: + + f = (\xy.blah) |> co + where + co :: (Int -> Int -> Char) ~ T + +Then idArity is 2 (despite the type T), and it can have a StrictSig based on a +threshold of 2. But we can't w/w it without a type error. + +The situation is less grave for PAPs, but the implicit eta expansion caused a +compiler allocation regression in T15164, where huge recursive instance method +groups, mostly consisting of PAPs, got w/w'd. This caused great churn in the +simplifier, when simply waiting for the PAPs to inline arrived at the same +output program. + +Note there is the worry here that such PAPs and trivial RHSs might not *always* +be inlined. That would lead to reboxing, because the analysis tacitly assumes +that we W/W'd for idArity and will propagate analysis information under that +assumption. So far, this doesn't seem to matter in practice. +See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064. -} diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs --- a/compiler/stranal/WwLib.hs +++ b/compiler/stranal/WwLib.hs @@ -134,7 +134,7 @@ -- wrap_fn_str E = case x of { (a,b) -> -- case a of { (a1,a2) -> -- E a1 a2 b y }} --- work_fn_str E = \a2 a2 b y -> +-- work_fn_str E = \a1 a2 b y -> -- let a = (a1,a2) in -- let x = (a,b) in -- E diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -2368,13 +2368,13 @@ = case splitPiTy_maybe kind of Nothing -> (reverse acc, substTy subst kind) - Just (Anon _ arg, kind') + Just (Anon af arg, kind') -> go loc occs' uniqs' subst' (tcb : acc) kind' where arg' = substTy subst arg tv = mkTyVar (mkInternalName uniq occ loc) arg' subst' = extendTCvInScope subst tv - tcb = Bndr tv (AnonTCB VisArg) + tcb = Bndr tv (AnonTCB af) (uniq:uniqs') = uniqs (occ:occs') = occs diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -1567,7 +1567,7 @@ -- Unqualified import? isUnqualified :: ImportDecl GhcRn -> Bool - isUnqualified = not . ideclQualified + isUnqualified = not . isImportDeclQualified . ideclQualified -- List of explicitly imported (or hidden) Names from a single import. -- Nothing -> No explicit imports diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -73,7 +73,9 @@ import qualified GHC.LanguageExtensions as LangExt import Control.Monad +import Data.Foldable import Data.List +import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.Set as Set @@ -288,7 +290,7 @@ inference, which means that we can do unification between kinds that aren't lifted (this historically was not true.) -The downside of not directly reading off the kinds off the RHS of +The downside of not directly reading off the kinds of the RHS of type synonyms in topological order is that we don't transparently support making synonyms of types with higher-rank kinds. But you can always specify a CUSK directly to make this work out. @@ -314,6 +316,23 @@ (but implemented strangely differently from) the treatment of type signatures in value declarations. +However, we only want to do so when we have PolyKinds. +When we have NoPolyKinds, we don't skip those decls, because we have defaulting +(#16609). Skipping won't bring us more polymorphism when we have defaulting. +Consider + + data T1 a = MkT1 T2 -- No CUSK + data T2 = MkT2 (T1 Maybe) -- Has CUSK + +If we skip the rhs of T2 during kind-checking, the kind of a remains unsolved. +With PolyKinds, we do generalization to get T1 :: forall a. a -> *. And the +program type-checks. +But with NoPolyKinds, we do defaulting to get T1 :: * -> *. Defaulting happens +in quantifyTyVars, which is called from generaliseTcTyCon. Then type-checking +(T1 Maybe) will throw a type error. + +Summary: with PolyKinds, we must skip; with NoPolyKinds, we must /not/ skip. + Open type families ~~~~~~~~~~~~~~~~~~ This treatment of type synonyms only applies to Haskell 98-style synonyms. @@ -405,9 +424,9 @@ B :-> TyConPE MkB :-> DataConPE - 2. kcTyCLGruup + 2. kcTyCLGroup - Do getInitialKinds, which will signal a promotion - error if B is used in any of the kinds needed to initialse + error if B is used in any of the kinds needed to initialise B's kind (e.g. (a :: Type)) here - Extend the type env with these initial kinds (monomorphic for @@ -491,8 +510,9 @@ -- 3. Generalise the inferred kinds -- See Note [Kind checking for type and class decls] + ; cusks_enabled <- xoptM LangExt.CUSKs ; let (cusk_decls, no_cusk_decls) - = partition (hsDeclHasCusk . unLoc) decls + = partition (hsDeclHasCusk cusks_enabled . unLoc) decls ; poly_cusk_tcs <- getInitialKinds True cusk_decls @@ -512,8 +532,10 @@ -- NB: the environment extension overrides the tycon -- promotion-errors bindings -- See Note [Type environment evolution] + ; poly_kinds <- xoptM LangExt.PolyKinds ; tcExtendKindEnvWithTyCons mono_tcs $ - mapM_ kcLTyClDecl no_cusk_decls + mapM_ kcLTyClDecl (if poly_kinds then no_cusk_decls else decls) + -- See Note [Skip decls with CUSKs in kcLTyClDecl] ; return mono_tcs } @@ -810,8 +832,8 @@ Note [Unification variables need fresh Names] Assign initial monomorophic kinds to S, T - S :: kk1 -> * -> kk2 -> * - T :: kk3 -> * -> kk4 -> * + T :: kk1 -> * -> kk2 -> * + S :: kk3 -> * -> kk4 -> * * Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and T, with these monomophic kinds. Now kind-check the declarations, @@ -900,7 +922,7 @@ tcDlassDecl2 we need {a, ka} and {b, kb} respectively to be in scope. But at that point all we have is the utterly-final Class itself. -Conclusion: the classTyVars of a class must have the same Mame as +Conclusion: the classTyVars of a class must have the same Name as that originally assigned by the user. In our example, C must have classTyVars {a, ka, x} while D has classTyVars {a, kb, y}. Despite the fact that kka and kkb got unified! @@ -1019,17 +1041,25 @@ getInitialKind cusk (SynDecl { tcdLName = dL->L _ name , tcdTyVars = ktvs , tcdRhs = rhs }) - = do { tycon <- kcLHsQTyVars name TypeSynonymFlavour cusk ktvs $ - case kind_annotation rhs of + = do { cusks_enabled <- xoptM LangExt.CUSKs + ; tycon <- kcLHsQTyVars name TypeSynonymFlavour cusk ktvs $ + case kind_annotation cusks_enabled rhs of Just ksig -> tcLHsKindSig (TySynKindCtxt name) ksig - Nothing -> newMetaKindVar + Nothing -> newMetaKindVar ; return [tycon] } where -- Keep this synchronized with 'hsDeclHasCusk'. - kind_annotation (dL->L _ ty) = case ty of - HsParTy _ lty -> kind_annotation lty - HsKindSig _ _ k -> Just k - _ -> Nothing + kind_annotation + :: Bool -- cusks_enabled? + -> LHsType GhcRn -- rhs + -> Maybe (LHsKind GhcRn) + kind_annotation False = const Nothing + kind_annotation True = go + where + go (dL->L _ ty) = case ty of + HsParTy _ lty -> go lty + HsKindSig _ _ k -> Just k + _ -> Nothing getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "getInitialKind" getInitialKind _ (XTyClDecl _) = panic "getInitialKind" @@ -1053,18 +1083,20 @@ , fdTyVars = ktvs , fdResultSig = (dL->L _ resultSig) , fdInfo = info }) - = kcLHsQTyVars name flav fam_cusk ktvs $ - case resultSig of - KindSig _ ki -> tcLHsKindSig ctxt ki - TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki - _ -- open type families have * return kind by default - | tcFlavourIsOpen flav -> return liftedTypeKind - -- closed type families have their return kind inferred - -- by default - | otherwise -> newMetaKindVar + = do { cusks_enabled <- xoptM LangExt.CUSKs + ; kcLHsQTyVars name flav (fam_cusk cusks_enabled) ktvs $ + case resultSig of + KindSig _ ki -> tcLHsKindSig ctxt ki + TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki + _ -- open type families have * return kind by default + | tcFlavourIsOpen flav -> return liftedTypeKind + -- closed type families have their return kind inferred + -- by default + | otherwise -> newMetaKindVar + } where assoc_with_no_cusk = isJust mb_parent_tycon && not parent_cusk - fam_cusk = famDeclHasCusk assoc_with_no_cusk decl + fam_cusk cusks_enabled = famDeclHasCusk cusks_enabled assoc_with_no_cusk decl flav = case info of DataFamily -> DataFamilyFlavour mb_parent_tycon OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon @@ -1525,13 +1557,15 @@ hs_pats hs_rhs_ty ; let fam_tvs = tyConTyVars fam_tc + ppr_eqn = ppr_default_eqn pats rhs_ty ; traceTc "tcDefaultAssocDecl 2" (vcat [ text "fam_tvs" <+> ppr fam_tvs , text "qtvs" <+> ppr qtvs , text "pats" <+> ppr pats , text "rhs_ty" <+> ppr rhs_ty ]) - ; pat_tvs <- traverse (extract_tv pats rhs_ty) pats + ; pat_tvs <- traverse (extract_tv ppr_eqn) pats + ; check_all_distinct_tvs ppr_eqn pat_tvs ; let subst = zipTvSubst pat_tvs (mkTyVarTys fam_tvs) ; pure $ Just (substTyUnchecked subst rhs_ty, loc) -- We also perform other checks for well-formedness and validity @@ -1542,14 +1576,12 @@ -- variable. If so, return the underlying type variable, and if -- not, throw an error. -- See Note [Type-checking default assoc decls] - extract_tv :: [Type] -- All default instance type patterns - -- (only used for error message purposes) - -> Type -- The default instance's right-hand side type + extract_tv :: SDoc -- The pretty-printed default equation -- (only used for error message purposes) -> Type -- The particular type pattern from which to extract -- its underlying type variable -> TcM TyVar - extract_tv pats rhs_ty pat = + extract_tv ppr_eqn pat = case getTyVar_maybe pat of Just tv -> pure tv Nothing -> @@ -1560,10 +1592,39 @@ -- error message with -fprint-explicit-kinds enabled. failWithTc $ pprWithExplicitKindsWhen True $ hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:") - 2 (vcat [ quotes (text "type" <+> ppr (mkTyConApp fam_tc pats) - <+> equals <+> ppr rhs_ty) - , text "The arguments to" <+> quotes (ppr fam_tc) - <+> text "must all be type variables" ]) + 2 (vcat [ppr_eqn, suggestion]) + + + -- Checks that no type variables in an associated default declaration are + -- duplicated. If that is the case, throw an error. + -- See Note [Type-checking default assoc decls] + check_all_distinct_tvs :: SDoc -- The pretty-printed default equation + -- (only used for error message purposes) + -> [TyVar] -- The type variable arguments in the + -- associated default declaration + -> TcM () + check_all_distinct_tvs ppr_eqn tvs = + let dups = findDupsEq (==) tvs in + traverse_ + (\d -> -- Per Note [Type-checking default assoc decls], we already + -- know by this point that if any arguments in the default + -- instance are duplicates, then they must be + -- invisible kind arguments. Therefore, always display the + -- error message with -fprint-explicit-kinds enabled. + failWithTc $ pprWithExplicitKindsWhen True $ + hang (text "Illegal duplicate variable" + <+> quotes (ppr (NE.head d)) <+> text "in:") + 2 (vcat [ppr_eqn, suggestion])) + dups + + ppr_default_eqn :: [Type] -> Type -> SDoc + ppr_default_eqn pats rhs_ty = + quotes (text "type" <+> ppr (mkTyConApp fam_tc pats) + <+> equals <+> ppr rhs_ty) + + suggestion :: SDoc + suggestion = text "The arguments to" <+> quotes (ppr fam_tc) + <+> text "must all be distinct type variables" tcDefaultAssocDecl _ [dL->L _ (XFamEqn _)] = panic "tcDefaultAssocDecl" tcDefaultAssocDecl _ [dL->L _ (FamEqn _ _ _ (XLHsQTyVars _) _ _)] = panic "tcDefaultAssocDecl" @@ -1591,17 +1652,35 @@ applying this substitution to the RHS. In order to create this substitution, we must first ensure that all of -the arguments in the default instance consist of type variables. The parser -already checks this to a certain degree (see RdrHsSyn.checkTyVars), but -we must be wary of kind arguments being instantiated, which the parser cannot -catch so easily. Consider this erroneous program (inspired by #11361): +the arguments in the default instance consist of distinct type variables. +This property has already been checked to some degree earlier in the compiler: +RdrHsSyn.checkTyVars ensures that all visible type arguments are type +variables, and RnTypes.bindLHsTyVarBndrs ensures that no visible type arguments +are duplicated. But these only check /visible/ arguments, however, so we still +must check the invisible kind arguments to see if these invariants are upheld. +First, we must check that all arguments are type variables. As a motivating +example, consider this erroneous program (inspired by #11361): + class C a where type F (a :: k) b :: Type type F x b = x If you squint, you'll notice that the kind of `x` is actually Type. However, we cannot substitute from [Type |-> k], so we reject this default. + +Next, we must check that all arguments are distinct. Here is another offending +example, this time taken from #13971: + + class C2 (a :: j) where + type F2 (a :: j) (b :: k) + type F2 (x :: z) (y :: z) = z + +All of the arguments in the default equation for `F2` are type variables, so +that passes the first check. However, if we were to build this substitution, +then both `j` and `k` map to `z`! In terms of visible kind application, it's as +if we had written `type F2 @z @z x y = z`, which makes it clear that we have +duplicated a use of `z`. Therefore, `F2`'s default is also rejected. Since the LHS of an associated type family default is always just variables, it won't contain any tycons. Accordingly, the patterns used in the substitution diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib -version: 0.20190423 +version: 0.20190516 license: BSD3 license-file: LICENSE category: Development @@ -49,7 +49,7 @@ compiler/nativeGen/*.h compiler/utils/*.h compiler/*.h -tested-with:GHC==8.6.3 +tested-with: GHC==8.6.3, GHC==8.4.3 source-repository head type: git location: git@github.com:digital-asset/ghc-lib.git @@ -84,7 +84,7 @@ transformers == 0.5.*, process >= 1 && < 1.7, hpc == 0.6.*, - ghc-lib-parser == 0.20190423 + ghc-lib-parser == 0.20190516 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns diff --git a/ghc-lib/generated/ghcversion.h b/ghc-lib/generated/ghcversion.h --- a/ghc-lib/generated/ghcversion.h +++ b/ghc-lib/generated/ghcversion.h @@ -6,7 +6,7 @@ #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0 -#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190423 +#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190514 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \ diff --git a/ghc-lib/stage1/compiler/build/ghc_boot_platform.h b/ghc-lib/stage1/compiler/build/ghc_boot_platform.h --- a/ghc-lib/stage1/compiler/build/ghc_boot_platform.h +++ b/ghc-lib/stage1/compiler/build/ghc_boot_platform.h @@ -3,7 +3,6 @@ #define BuildPlatform_NAME "x86_64-apple-darwin" #define HostPlatform_NAME "x86_64-apple-darwin" -#define TargetPlatform_NAME "x86_64-apple-darwin" #define x86_64_apple_darwin_BUILD 1 #define x86_64_apple_darwin_HOST 1 diff --git a/ghc-lib/stage1/lib/settings b/ghc-lib/stage1/lib/settings --- a/ghc-lib/stage1/lib/settings +++ b/ghc-lib/stage1/lib/settings @@ -1,7 +1,7 @@ -[("GCC extra via C opts", " -fwrapv -fno-builtin") +[("GCC extra via C opts", "-fwrapv -fno-builtin") ,("C compiler command", "gcc") ,("C compiler flags", "") -,("C compiler link flags", " ") +,("C compiler link flags", "") ,("C compiler supports -no-pie", "NO") ,("Haskell CPP command", "gcc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs") @@ -19,7 +19,9 @@ ,("dllwrap command", "/bin/false") ,("windres command", "/bin/false") ,("libtool command", "libtool") +,("unlit command", "$topdir/bin/ghc-lib/stage0/lib/bin/unlit") ,("cross compiling", "NO") +,("target platform string", "x86_64-apple-darwin") ,("target os", "OSDarwin") ,("target arch", "ArchX86_64") ,("target word size", "8") @@ -31,4 +33,15 @@ ,("LLVM llc command", "llc") ,("LLVM opt command", "opt") ,("LLVM clang command", "clang") +,("integer library", "integer-simple") +,("Use interpreter", "YES") +,("Use native code generator", "YES") +,("Support SMP", "YES") +,("RTS ways", "YES") +,("Tables next to code", "YES") +,("Leading underscore", "NO") +,("Use LibFFI", "NO") +,("Use Threads", "YES") +,("Use Debugging", "NO") +,("RTS expects libdw", "NO") ] diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -1618,8 +1618,11 @@ -- :def defineMacro :: GhciMonad m => Bool{-overwrite-} -> String -> m () -defineMacro _ (':':_) = - liftIO $ putStrLn "macro name cannot start with a colon" +defineMacro _ (':':_) = liftIO $ putStrLn + "macro name cannot start with a colon" +defineMacro _ ('!':_) = liftIO $ putStrLn + "macro name cannot start with an exclamation mark" + -- little code duplication allows to grep error msg defineMacro overwrite s = do let (macro_name, definition) = break isSpace s macros <- ghci_macros <$> getGHCiState @@ -1629,33 +1632,38 @@ then liftIO $ putStrLn "no macros defined" else liftIO $ putStr ("the following macros are defined:\n" ++ unlines defined) - else do - if (not overwrite && macro_name `elem` defined) - then throwGhcException (CmdLineError - ("macro '" ++ macro_name ++ "' is already defined")) - else do + else do + isCommand <- isJust <$> lookupCommand' macro_name + let check_newname + | macro_name `elem` defined = throwGhcException (CmdLineError + ("macro '" ++ macro_name ++ "' is already defined. " ++ hint)) + | isCommand = throwGhcException (CmdLineError + ("macro '" ++ macro_name ++ "' overwrites builtin command. " ++ hint)) + | otherwise = return () + hint = " Use ':def!' to overwrite." - -- compile the expression - handleSourceError GHC.printException $ do - step <- getGhciStepIO - expr <- GHC.parseExpr definition - -- > ghciStepIO . definition :: String -> IO String - let stringTy = nlHsTyVar stringTy_RDR - ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy - body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step) - `mkHsApp` (nlHsPar expr) - tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM) - new_expr = L (getLoc expr) $ ExprWithTySig noExt body tySig - hv <- GHC.compileParsedExprRemote new_expr + unless overwrite check_newname + -- compile the expression + handleSourceError GHC.printException $ do + step <- getGhciStepIO + expr <- GHC.parseExpr definition + -- > ghciStepIO . definition :: String -> IO String + let stringTy = nlHsTyVar stringTy_RDR + ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy + body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step) + `mkHsApp` (nlHsPar expr) + tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM) + new_expr = L (getLoc expr) $ ExprWithTySig noExt body tySig + hv <- GHC.compileParsedExprRemote new_expr - let newCmd = Command { cmdName = macro_name - , cmdAction = lift . runMacro hv - , cmdHidden = False - , cmdCompletionFunc = noCompletion - } + let newCmd = Command { cmdName = macro_name + , cmdAction = lift . runMacro hv + , cmdHidden = False + , cmdCompletionFunc = noCompletion + } - -- later defined macros have precedence - modifyGHCiState $ \s -> + -- later defined macros have precedence + modifyGHCiState $ \s -> let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ] in s { ghci_macros = newCmd : filtered } @@ -2649,7 +2657,7 @@ iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude = unLoc (ideclName d1) == unLoc (ideclName d2) && ideclAs d1 == ideclAs d2 - && (not (ideclQualified d1) || ideclQualified d2) + && (not (isImportDeclQualified (ideclQualified d1)) || isImportDeclQualified (ideclQualified d2)) && (ideclHiding d1 `hidingSubsumes` ideclHiding d2) where _ `hidingSubsumes` Just (False,L _ []) = True diff --git a/includes/Cmm.h b/includes/Cmm.h --- a/includes/Cmm.h +++ b/includes/Cmm.h @@ -159,14 +159,19 @@ #define BYTES_TO_WDS(n) ((n) / SIZEOF_W) #define ROUNDUP_BYTES_TO_WDS(n) (((n) + SIZEOF_W - 1) / SIZEOF_W) -/* TO_W_(n) converts n to W_ type from a smaller type */ +/* + * TO_W_(n) and TO_ZXW_(n) convert n to W_ type from a smaller type, + * with and without sign extension respectively + */ #if SIZEOF_W == 4 #define TO_I64(x) %sx64(x) #define TO_W_(x) %sx32(x) +#define TO_ZXW_(x) %zx32(x) #define HALF_W_(x) %lobits16(x) #elif SIZEOF_W == 8 #define TO_I64(x) (x) #define TO_W_(x) %sx64(x) +#define TO_ZXW_(x) %zx64(x) #define HALF_W_(x) %lobits32(x) #endif diff --git a/includes/rts/storage/ClosureMacros.h b/includes/rts/storage/ClosureMacros.h --- a/includes/rts/storage/ClosureMacros.h +++ b/includes/rts/storage/ClosureMacros.h @@ -184,8 +184,8 @@ case IND_STATIC: return IND_STATIC_LINK(p); default: - return &(p)->payload[info->layout.payload.ptrs + - info->layout.payload.nptrs]; + return &p->payload[info->layout.payload.ptrs + + info->layout.payload.nptrs]; } }