ghc-lib 0.20190423 → 0.20190516
raw patch · 36 files changed
+608/−356 lines, 36 filesdep ~ghc-lib-parserPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghc-lib-parser
API changes (from Hackage documentation)
- StgCmmMonad: emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped -> Int -> FCode ()
- CLabel: pprCLabel :: Platform -> CLabel -> SDoc
+ CLabel: pprCLabel :: DynFlags -> CLabel -> SDoc
- GHC: defaultObjectTarget :: Platform -> HscTarget
+ GHC: defaultObjectTarget :: Settings -> HscTarget
Files
- compiler/cmm/CLabel.hs +27/−30
- compiler/codeGen/StgCmmMonad.hs +6/−10
- compiler/coreSyn/CoreLint.hs +3/−23
- compiler/coreSyn/CorePrep.hs +0/−1
- compiler/deSugar/DsExpr.hs +0/−4
- compiler/deSugar/DsForeign.hs +1/−2
- compiler/hieFile/HieAst.hs +0/−12
- compiler/iface/BinIface.hs +8/−7
- compiler/llvmGen/LlvmCodeGen/Base.hs +3/−6
- compiler/main/CodeOutput.hs +4/−4
- compiler/main/DriverPipeline.hs +10/−4
- compiler/main/GhcMake.hs +1/−1
- compiler/main/HeaderInfo.hs +1/−1
- compiler/main/HscStats.hs +4/−3
- compiler/main/SysTools.hs +49/−8
- compiler/nativeGen/AsmCodeGen.hs +1/−1
- compiler/nativeGen/PIC.hs +24/−24
- compiler/rename/RnEnv.hs +24/−3
- compiler/rename/RnExpr.hs +3/−27
- compiler/rename/RnNames.hs +5/−3
- compiler/rename/RnSource.hs +2/−1
- compiler/simplCore/SimplMonad.hs +3/−2
- compiler/simplCore/SimplUtils.hs +9/−1
- compiler/stranal/DmdAnal.hs +200/−95
- compiler/stranal/WorkWrap.hs +37/−4
- compiler/stranal/WwLib.hs +1/−1
- compiler/typecheck/TcHsType.hs +2/−2
- compiler/typecheck/TcRnDriver.hs +1/−1
- compiler/typecheck/TcTyClsDecls.hs +117/−38
- ghc-lib.cabal +3/−3
- ghc-lib/generated/ghcversion.h +1/−1
- ghc-lib/stage1/compiler/build/ghc_boot_platform.h +0/−1
- ghc-lib/stage1/lib/settings +15/−2
- ghc/GHCi/UI.hs +35/−27
- includes/Cmm.h +6/−1
- includes/rts/storage/ClosureMacros.h +2/−2
compiler/cmm/CLabel.hs view
@@ -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
compiler/codeGen/StgCmmMonad.hs view
@@ -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
compiler/coreSyn/CoreLint.hs view
@@ -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)
compiler/coreSyn/CorePrep.hs view
@@ -55,7 +55,6 @@ import Outputable import Platform import FastString-import Config import Name ( NamedThing(..), nameSrcSpan ) import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import Data.Bits
compiler/deSugar/DsExpr.hs view
@@ -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"
compiler/deSugar/DsForeign.hs view
@@ -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:
compiler/hieFile/HieAst.hs view
@@ -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
compiler/iface/BinIface.hs view
@@ -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
compiler/llvmGen/LlvmCodeGen/Base.hs view
@@ -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
compiler/main/CodeOutput.hs view
@@ -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
compiler/main/DriverPipeline.hs view
@@ -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
compiler/main/GhcMake.hs view
@@ -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
compiler/main/HeaderInfo.hs view
@@ -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 }
compiler/main/HscStats.hs view
@@ -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)
compiler/main/SysTools.hs view
@@ -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
compiler/nativeGen/AsmCodeGen.hs view
@@ -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 -- -----------------------------------------------------------------------------
compiler/nativeGen/PIC.hs view
@@ -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
compiler/rename/RnEnv.hs view
@@ -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) ---------------
compiler/rename/RnExpr.hs view
@@ -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
compiler/rename/RnNames.hs view
@@ -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"
compiler/rename/RnSource.hs view
@@ -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)
compiler/simplCore/SimplMonad.hs view
@@ -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
compiler/simplCore/SimplUtils.hs view
@@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/stranal/DmdAnal.hs view
@@ -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 `<S><L>`. 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 <S,HU> into a demand type like+{x-><S,1*U>,y-><L,U>}<L,U>. In pictures:++ Demand ---F_e---> DmdType+ <S,HU> {x-><S,1*U>,y-><L,U>}<L,U>++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, {}<S,1*U><L,U>. 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) = {}<S,1*U><L,U>+ f_f(<2) = postProcessUnsat {}<S,1*U><L,U>++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 }
compiler/stranal/WorkWrap.hs view
@@ -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. -}
compiler/stranal/WwLib.hs view
@@ -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
compiler/typecheck/TcHsType.hs view
@@ -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
compiler/typecheck/TcRnDriver.hs view
@@ -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
compiler/typecheck/TcTyClsDecls.hs view
@@ -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
ghc-lib.cabal view
@@ -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
ghc-lib/generated/ghcversion.h view
@@ -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__ || \
ghc-lib/stage1/compiler/build/ghc_boot_platform.h view
@@ -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
ghc-lib/stage1/lib/settings view
@@ -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") ]
ghc/GHCi/UI.hs view
@@ -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
includes/Cmm.h view
@@ -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
includes/rts/storage/ClosureMacros.h view
@@ -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]; } }