Simon Jakobi pushed to branch wip/sjakobi/T25450-print-cpu at Glasgow Haskell Compiler / GHC Commits: 0386c6bb by Simon Jakobi at 2026-05-29T02:25:57+02:00 Wibbles - - - - - 2 changed files: - compiler/GHC/Driver/Session.hs - ghc/Main.hs Changes: ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -197,6 +197,7 @@ module GHC.Driver.Session ( -- * Compiler configuration suitable for display to the user compilerInfo, showEnabledCpuFeatures, + enabledCpuFeatures, targetHasRTSWays, @@ -3542,104 +3543,6 @@ picPOpts dflags | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"] | otherwise = [] -showEnabledCpuFeatures :: DynFlags -> String -showEnabledCpuFeatures dflags = showSDocUnsafe $ renderJSON $ JSObject - [ ("tag", JSString "enabled-cpu-features") - , ("version", JSInt 1) - , ("target", JSString (platformMisc_targetPlatformString (platformMisc dflags))) - , ("features", JSArray (map JSString features)) - , ("as_m_flags", JSArray (map JSString asMFlags)) - ] - where - (features, asMFlags) = enabledCpuFeatures dflags - -enabledCpuFeatures :: DynFlags -> ([String], [String]) -enabledCpuFeatures dflags = case platformArch (targetPlatform dflags) of - ArchX86_64 -> x86FeaturesAndFlags dflags - ArchX86 -> x86FeaturesAndFlags dflags - ArchAArch64 -> - ( [ "FMA" | isFmaEnabled dflags ] - , [] - ) - ArchLoongArch64 -> - ( [ "LA664" | isLa664Enabled dflags ] - , [ "-mla664" | la664 dflags ] - ) - _ -> - ([], []) - -x86FeaturesAndFlags :: DynFlags -> ([String], [String]) -x86FeaturesAndFlags dflags = - ( [ "SSE2" | isSse2Enabled platform ] - ++ [ "SSE3" | isSse3Enabled dflags ] - ++ [ "SSSE3" | isSsse3Enabled dflags ] - ++ [ "SSE4.1" | isSse4_1Enabled dflags ] - ++ [ "SSE4.2" | isSse4_2Enabled dflags ] - ++ [ "AVX" | isAvxEnabled dflags ] - ++ [ "AVX2" | isAvx2Enabled dflags ] - ++ [ "AVX512F" | isAvx512fEnabled dflags ] - ++ [ "AVX512BW" | isAvx512bwEnabled dflags ] - ++ [ "AVX512CD" | isAvx512cdEnabled dflags ] - ++ [ "AVX512DQ" | isAvx512dqEnabled dflags ] - ++ [ "AVX512ER" | isAvx512erEnabled dflags ] - ++ [ "AVX512PF" | isAvx512pfEnabled dflags ] - ++ [ "AVX512VL" | isAvx512vlEnabled dflags ] - ++ [ "BMI1" | isBmiEnabled dflags ] - ++ [ "BMI2" | isBmi2Enabled dflags ] - ++ [ "FMA" | isFmaEnabled dflags ] - ++ [ "GFNI" | isGfniEnabled dflags ] - , x86AsMFlags dflags - ) - where - platform = targetPlatform dflags - -x86AsMFlags :: DynFlags -> [String] -x86AsMFlags dflags = - avx512Flags - ++ vectorFlags - ++ bmiFlags - ++ fmaFlags - ++ gfniFlags - where - avx512Extensions = - [ ("-mavx512bw", avx512bw dflags) - , ("-mavx512cd", avx512cd dflags) - , ("-mavx512dq", avx512dq dflags) - , ("-mavx512er", avx512er dflags) - , ("-mavx512pf", avx512pf dflags) - , ("-mavx512vl", avx512vl dflags) - ] - - hasAvx512Extension = any snd avx512Extensions - hasAvx512 = avx512f dflags || hasAvx512Extension - - avx512Flags = - [ "-mavx512f" | avx512f dflags && not hasAvx512Extension ] - ++ [ flag | (flag, True) <- avx512Extensions ] - - vectorFlags - | hasAvx512 = [] - | otherwise = - case sseAvxVersion dflags of - Just AVX2 -> ["-mavx2"] - Just AVX1 -> ["-mavx"] - Just SSE42 -> ["-msse4.2"] - Just SSE4 -> ["-msse4"] - Just SSSE3 -> ["-mssse3"] - Just SSE3 -> ["-msse3"] - _ -> [] - - bmiFlags = case bmiVersion dflags of - Just BMI2 -> ["-mbmi2"] - Just BMI1 -> ["-mbmi"] - Nothing -> [] - - fmaFlags - | fma dflags && not hasAvx512 = ["-mfma"] - | otherwise = [] - - gfniFlags = [ "-mgfni" | gfni dflags ] - -- ----------------------------------------------------------------------------- -- Compiler Info @@ -3777,6 +3680,106 @@ compilerInfo dflags queryCmdMaybe p f = expandDirectories (query (maybe "" (prgPath . p) . f)) queryFlagsMaybe p f = query (maybe "" (unwords . map escapeArg . prgFlags . p) . f) +showEnabledCpuFeatures :: DynFlags -> String +showEnabledCpuFeatures dflags = showSDocUnsafe $ renderJSON $ JSObject + [ ("tag", JSString "enabled-cpu-features") + , ("version", JSInt 1) + , ("target", JSString (platformMisc_targetPlatformString (platformMisc dflags))) + , ("features", JSArray (map JSString features)) + , ("as_m_flags", JSArray (map JSString asMFlags)) + ] + where + (features, asMFlags) = enabledCpuFeatures dflags + +enabledCpuFeatures :: DynFlags -> ([String], [String]) +enabledCpuFeatures dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> x86FeaturesAndFlags dflags + ArchX86 -> x86FeaturesAndFlags dflags + ArchAArch64 -> + ( [ "FMA" | isFmaEnabled dflags ] + , [ "-mfma" | fma dflags ] + ) + ArchLoongArch64 -> + ( [ "LA664" | isLa664Enabled dflags ] + , [ "-mla664" | isLa664Enabled dflags ] + ) + _ -> + ([], []) + +x86FeaturesAndFlags :: DynFlags -> ([String], [String]) +x86FeaturesAndFlags dflags = + -- SSE2 is determined by the target platform rather than a dynamic flag, + -- hence isSse2Enabled takes Platform while the others take DynFlags. + ( [ "SSE2" | isSse2Enabled platform ] + ++ [ "SSE3" | isSse3Enabled dflags ] + ++ [ "SSSE3" | isSsse3Enabled dflags ] + ++ [ "SSE4.1" | isSse4_1Enabled dflags ] + ++ [ "SSE4.2" | isSse4_2Enabled dflags ] + ++ [ "AVX" | isAvxEnabled dflags ] + ++ [ "AVX2" | isAvx2Enabled dflags ] + ++ [ "AVX512F" | isAvx512fEnabled dflags ] + ++ [ "AVX512BW" | isAvx512bwEnabled dflags ] + ++ [ "AVX512CD" | isAvx512cdEnabled dflags ] + ++ [ "AVX512DQ" | isAvx512dqEnabled dflags ] + ++ [ "AVX512ER" | isAvx512erEnabled dflags ] + ++ [ "AVX512PF" | isAvx512pfEnabled dflags ] + ++ [ "AVX512VL" | isAvx512vlEnabled dflags ] + ++ [ "BMI1" | isBmiEnabled dflags ] + ++ [ "BMI2" | isBmi2Enabled dflags ] + ++ [ "FMA" | isFmaEnabled dflags ] + ++ [ "GFNI" | isGfniEnabled dflags ] + , x86AsMFlags dflags + ) + where + platform = targetPlatform dflags + +x86AsMFlags :: DynFlags -> [String] +x86AsMFlags dflags = + avx512Flags + ++ vectorFlags + ++ bmiFlags + ++ fmaFlags + ++ gfniFlags + where + avx512Extensions = + [ ("-mavx512bw", avx512bw dflags) + , ("-mavx512cd", avx512cd dflags) + , ("-mavx512dq", avx512dq dflags) + , ("-mavx512er", avx512er dflags) + , ("-mavx512pf", avx512pf dflags) + , ("-mavx512vl", avx512vl dflags) + ] + + hasAvx512Extension = any snd avx512Extensions + hasAvx512 = avx512f dflags || hasAvx512Extension + + avx512Flags = + [ "-mavx512f" | avx512f dflags && not hasAvx512Extension ] + ++ [ flag | (flag, True) <- avx512Extensions ] + + vectorFlags + | hasAvx512 = [] + | otherwise = + case sseAvxVersion dflags of + Just AVX2 -> ["-mavx2"] + Just AVX1 -> ["-mavx"] + Just SSE42 -> ["-msse4.2"] + Just SSE4 -> ["-msse4"] + Just SSSE3 -> ["-mssse3"] + Just SSE3 -> ["-msse3"] + _ -> [] + + bmiFlags = case bmiVersion dflags of + Just BMI2 -> ["-mbmi2"] + Just BMI1 -> ["-mbmi"] + Nothing -> [] + + fmaFlags + | fma dflags && not hasAvx512 = ["-mfma"] + | otherwise = [] + + gfniFlags = [ "-mgfni" | gfni dflags ] + -- | Query if the target RTS has the given 'Ways'. It's computed from -- the @"RTS ways"@ field in the settings file. targetHasRTSWays :: DynFlags -> Ways -> Bool ===================================== ghc/Main.hs ===================================== @@ -280,7 +280,7 @@ main' postLoadMode units dflags0 args flagWarnings = do ShowPackages -> liftIO $ showUnits hsc_env DoFrontend f -> doFrontend f srcs DoBackpack -> doBackpack (map fst srcs) - PrintEnabledCpuFeatures -> panic "main': unexpected PrintEnabledCpuFeatures" + PrintEnabledCpuFeatures -> panic "impossible: PrintEnabledCpuFeatures handled before session setup" liftIO $ dumpFinalStats logger View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0386c6bb6a71c929e2510dc78e78d31e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0386c6bb6a71c929e2510dc78e78d31e... You're receiving this email because of your account on gitlab.haskell.org.