[Git][ghc/ghc][wip/andreask/stgLintFix] 9 commits: CoreToStg: purge `DynFlags`.
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Fri Oct 21 09:24:44 UTC 2022
Andreas Klebinger pushed to branch wip/andreask/stgLintFix at Glasgow Haskell Compiler / GHC
Commits:
ff6f2228 by M Farkas-Dyck at 2022-10-20T16:15:51-04:00
CoreToStg: purge `DynFlags`.
- - - - -
1ebd521f by Matthew Pickering at 2022-10-20T16:16:27-04:00
ci: Make fat014 test robust
For some reason I implemented this as a makefile test rather than a
ghci_script test. Hopefully making it a ghci_script test makes it more
robust.
Fixes #22313
- - - - -
8cd6f435 by Curran McConnell at 2022-10-21T02:58:01-04:00
remove a no-warn directive from GHC.Cmm.ContFlowOpt
This patch is motivated by the desire to remove the {-# OPTIONS_GHC
-fno-warn-incomplete-patterns #-} directive at the top of
GHC.Cmm.ContFlowOpt. (Based on the text in this coding standards doc, I
understand it's a goal of the project to remove such directives.) I
chose this task because I'm a new contributor to GHC, and it seemed like
a good way to get acquainted with the patching process.
In order to address the warning that arose when I removed the no-warn
directive, I added a case to removeUnreachableBlocksProc to handle the
CmmData constructor. Clearly, since this partial function has not been
erroring out in the wild, its inputs are always in practice wrapped by
the CmmProc constructor. Therefore the CmmData case is handled by a
precise panic (which is an improvement over the partial pattern match
from before).
- - - - -
a2af7c4c by Nicolas Trangez at 2022-10-21T02:58:39-04:00
build: get rid of `HAVE_TIME_H`
As advertized by `autoreconf`:
> All current systems provide time.h; it need not be checked for.
Hence, remove the check for it in `configure.ac` and remove conditional
inclusion of the header in `HAVE_TIME_H` blocks where applicable.
The `time.h` header was being included in various source files without a
`HAVE_TIME_H` guard already anyway.
- - - - -
25cdc630 by Nicolas Trangez at 2022-10-21T02:58:39-04:00
rts: remove use of `TIME_WITH_SYS_TIME`
`autoreconf` will insert an `m4_warning` when the obsolescent
`AC_HEADER_TIME` macro is used:
> Update your code to rely only on HAVE_SYS_TIME_H,
> then remove this warning and the obsolete code below it.
> All current systems provide time.h; it need not be checked for.
> Not all systems provide sys/time.h, but those that do, all allow
> you to include it and time.h simultaneously.
Presence of `sys/time.h` was already checked in an earlier
`AC_CHECK_HEADERS` invocation, so `AC_HEADER_TIME` can be dropped and
guards relying on `TIME_WITH_SYS_TIME` can be reworked to
(unconditionally) include `time.h` and include `sys/time.h` based on
`HAVE_SYS_TIME_H`.
Note the documentation of `AC_HEADER_TIME` in (at least) Autoconf 2.67
says
> This macro is obsolescent, as current systems can include both files
> when they exist. New programs need not use this macro.
- - - - -
1fe7921c by Eric Lindblad at 2022-10-21T02:59:21-04:00
runhaskell
- - - - -
e3b3986e by David Feuer at 2022-10-21T03:00:00-04:00
Document how to quote certain names with spaces
Quoting a name for Template Haskell is a bit tricky if the second
character of that name is a single quote. The User's Guide falsely
claimed that it was impossible. Document how to do it.
Fixes #22236
- - - - -
0eba81e8 by Krzysztof Gogolewski at 2022-10-21T03:00:00-04:00
Fix syntax
- - - - -
b181f78e by Andreas Klebinger at 2022-10-21T09:24:36+00:00
Improve stg lint for unboxed sums.
It now properly lints cases where sums end up distributed
over multiple args after unarise.
Fixes #22026.
- - - - -
22 changed files:
- compiler/GHC/Cmm/ContFlowOpt.hs
- compiler/GHC/Cmm/Pipeline.hs
- compiler/GHC/CoreToStg.hs
- + compiler/GHC/Driver/Config/CoreToStg.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Stg/Lint.hs
- compiler/ghc.cabal.in
- configure.ac
- docs/users_guide/exts/template_haskell.rst
- docs/users_guide/runghc.rst
- libraries/base/System/CPUTime/Posix/ClockGetTime.hsc
- libraries/base/aclocal.m4
- libraries/base/cbits/sysconf.c
- libraries/base/include/HsBase.h
- m4/fp_check_timer_create.m4
- rts/RtsUtils.c
- rts/posix/Clock.h
- rts/posix/ticker/Pthread.c
- rts/posix/ticker/Setitimer.c
- rts/win32/GetTime.c
- testsuite/tests/driver/fat-iface/Makefile
- testsuite/tests/driver/fat-iface/all.T
Changes:
=====================================
compiler/GHC/Cmm/ContFlowOpt.hs
=====================================
@@ -1,6 +1,5 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE BangPatterns #-}
-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Cmm.ContFlowOpt
( cmmCfgOpts
@@ -21,8 +20,10 @@ import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch (mapSwitchTargets, switchTargetsToList)
import GHC.Data.Maybe
-import GHC.Utils.Panic
+import GHC.Platform
import GHC.Utils.Misc
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
import Control.Monad
@@ -422,9 +423,9 @@ predMap blocks = foldr add_preds mapEmpty blocks
add_preds block env = foldr add env (successors block)
where add lbl env = mapInsertWith (+) lbl 1 env
--- Removing unreachable blocks
-removeUnreachableBlocksProc :: CmmDecl -> CmmDecl
-removeUnreachableBlocksProc proc@(CmmProc info lbl live g)
+-- Remove unreachable blocks from procs
+removeUnreachableBlocksProc :: Platform -> CmmDecl -> CmmDecl
+removeUnreachableBlocksProc _ proc@(CmmProc info lbl live g)
| used_blocks `lengthLessThan` mapSize (toBlockMap g)
= CmmProc info' lbl live g'
| otherwise
@@ -446,3 +447,5 @@ removeUnreachableBlocksProc proc@(CmmProc info lbl live g)
used_lbls :: LabelSet
used_lbls = setFromList $ map entryLabel used_blocks
+removeUnreachableBlocksProc platform data'@(CmmData _ _) =
+ pprPanic "removeUnreachableBlocksProc: passed data declaration instead of procedure" (pdoc platform data')
=====================================
compiler/GHC/Cmm/Pipeline.hs
=====================================
@@ -156,7 +156,7 @@ cpsTop logger platform cfg proc =
return $ if cmmOptControlFlow cfg
then map (cmmCfgOptsProc splitting_proc_points) g
else g
- g <- return (map removeUnreachableBlocksProc g)
+ g <- return $ map (removeUnreachableBlocksProc platform) g
-- See Note [unreachable blocks]
dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -14,13 +14,10 @@
-- And, as we have the info in hand, we may convert some lets to
-- let-no-escapes.
-module GHC.CoreToStg ( coreToStg ) where
+module GHC.CoreToStg ( CoreToStgOpts (..), coreToStg ) where
import GHC.Prelude
-import GHC.Driver.Session
-import GHC.Driver.Config.Stg.Debug
-
import GHC.Core
import GHC.Core.Utils ( exprType, findDefault, isJoinBind
, exprIsTickedString_maybe )
@@ -50,6 +47,7 @@ import GHC.Types.SrcLoc ( mkGeneralSrcSpan )
import GHC.Unit.Module
import GHC.Data.FastString
+import GHC.Platform ( Platform )
import GHC.Platform.Ways
import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId )
@@ -62,7 +60,6 @@ import GHC.Utils.Trace
import Control.Monad (ap)
import Data.Maybe (fromMaybe)
-import Data.Tuple (swap)
-- Note [Live vs free]
-- ~~~~~~~~~~~~~~~~~~~
@@ -235,24 +232,29 @@ import Data.Tuple (swap)
-- --------------------------------------------------------------
-coreToStg :: DynFlags -> Module -> ModLocation -> CoreProgram
+coreToStg :: CoreToStgOpts -> Module -> ModLocation -> CoreProgram
-> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
-coreToStg dflags this_mod ml pgm
+coreToStg opts at CoreToStgOpts
+ { coreToStg_ways = ways
+ , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs
+ , coreToStg_InfoTableMap = opt_InfoTableMap
+ , coreToStg_stgDebugOpts = stgDebugOpts
+ } this_mod ml pgm
= (pgm'', denv, final_ccs)
where
(_, (local_ccs, local_cc_stacks), pgm')
- = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm
+ = coreTopBindsToStg opts this_mod emptyVarEnv emptyCollectedCCs pgm
-- See Note [Mapping Info Tables to Source Positions]
- (!pgm'', !denv) =
- if gopt Opt_InfoTableMap dflags
- then collectDebugInformation (initStgDebugOpts dflags) ml pgm'
- else (pgm', emptyInfoTableProvMap)
+ (!pgm'', !denv)
+ | opt_InfoTableMap
+ = collectDebugInformation stgDebugOpts ml pgm'
+ | otherwise = (pgm', emptyInfoTableProvMap)
- prof = ways dflags `hasWay` WayProf
+ prof = hasWay ways WayProf
final_ccs
- | prof && gopt Opt_AutoSccsOnIndividualCafs dflags
+ | prof && opt_AutoSccsOnIndividualCafs
= (local_ccs,local_cc_stacks) -- don't need "all CAFs" CC
| prof
= (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks)
@@ -262,7 +264,7 @@ coreToStg dflags this_mod ml pgm
(all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod
coreTopBindsToStg
- :: DynFlags
+ :: CoreToStgOpts
-> Module
-> IdEnv HowBound -- environment for the bindings
-> CollectedCCs
@@ -271,17 +273,17 @@ coreTopBindsToStg
coreTopBindsToStg _ _ env ccs []
= (env, ccs, [])
-coreTopBindsToStg dflags this_mod env ccs (b:bs)
+coreTopBindsToStg opts this_mod env ccs (b:bs)
| NonRec _ rhs <- b, isTyCoArg rhs
- = coreTopBindsToStg dflags this_mod env1 ccs1 bs
+ = coreTopBindsToStg opts this_mod env1 ccs1 bs
| otherwise
= (env2, ccs2, b':bs')
where
- (env1, ccs1, b' ) = coreTopBindToStg dflags this_mod env ccs b
- (env2, ccs2, bs') = coreTopBindsToStg dflags this_mod env1 ccs1 bs
+ (env1, ccs1, b' ) = coreTopBindToStg opts this_mod env ccs b
+ (env2, ccs2, bs') = coreTopBindsToStg opts this_mod env1 ccs1 bs
coreTopBindToStg
- :: DynFlags
+ :: CoreToStgOpts
-> Module
-> IdEnv HowBound
-> CollectedCCs
@@ -297,16 +299,18 @@ coreTopBindToStg _ _ env ccs (NonRec id e)
how_bound = LetBound TopLet 0
in (env', ccs, StgTopStringLit id str)
-coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)
+coreTopBindToStg opts at CoreToStgOpts
+ { coreToStg_platform = platform
+ } this_mod env ccs (NonRec id rhs)
= let
env' = extendVarEnv env id how_bound
how_bound = LetBound TopLet $! manifestArity rhs
- (stg_rhs, ccs') =
- initCts dflags env $
- coreToTopStgRhs dflags ccs this_mod (id,rhs)
+ (ccs', (id', stg_rhs)) =
+ initCts platform env $
+ coreToTopStgRhs opts this_mod ccs (id,rhs)
- bind = StgTopLifted $ StgNonRec id stg_rhs
+ bind = StgTopLifted $ StgNonRec id' stg_rhs
in
-- NB: previously the assertion printed 'rhs' and 'bind'
-- as well as 'id', but that led to a black hole
@@ -314,42 +318,38 @@ coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)
-- assertion again!
(env', ccs', bind)
-coreTopBindToStg dflags this_mod env ccs (Rec pairs)
+coreTopBindToStg opts at CoreToStgOpts
+ { coreToStg_platform = platform
+ } this_mod env ccs (Rec pairs)
= assert (not (null pairs)) $
let
- binders = map fst pairs
-
extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
| (b, rhs) <- pairs ]
env' = extendVarEnvList env extra_env'
-- generate StgTopBindings and CAF cost centres created for CAFs
(ccs', stg_rhss)
- = initCts dflags env' $
- mapAccumLM (\ccs rhs -> swap <$> coreToTopStgRhs dflags ccs this_mod rhs)
- ccs
- pairs
- bind = StgTopLifted $ StgRec (zip binders stg_rhss)
+ = initCts platform env' $ mapAccumLM (coreToTopStgRhs opts this_mod) ccs pairs
+ bind = StgTopLifted $ StgRec stg_rhss
in
(env', ccs', bind)
coreToTopStgRhs
- :: DynFlags
- -> CollectedCCs
+ :: CoreToStgOpts
-> Module
+ -> CollectedCCs
-> (Id,CoreExpr)
- -> CtsM (StgRhs, CollectedCCs)
+ -> CtsM (CollectedCCs, (Id, StgRhs))
-coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
+coreToTopStgRhs opts this_mod ccs (bndr, rhs)
= do { new_rhs <- coreToPreStgRhs rhs
; let (stg_rhs, ccs') =
- mkTopStgRhs dflags this_mod ccs bndr new_rhs
+ mkTopStgRhs opts this_mod ccs bndr new_rhs
stg_arity =
stgRhsArity stg_rhs
- ; return (assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs,
- ccs') }
+ ; pure (ccs', (bndr, assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs)) }
where
-- It's vital that the arity on a top-level Id matches
-- the arity of the generated STG binding, else an importing
@@ -616,7 +616,7 @@ coreToStgArgs (arg : args) = do -- Non-type argument
-- or foreign call.
-- Wanted: a better solution than this hacky warning
- platform <- targetPlatform <$> getDynFlags
+ platform <- getPlatform
let
arg_rep = typePrimRep (exprType arg)
stg_arg_rep = typePrimRep (stgArgType stg_arg)
@@ -708,10 +708,14 @@ coreToPreStgRhs expr
-- Generate a top-level RHS. Any new cost centres generated for CAFs will be
-- appended to `CollectedCCs` argument.
-mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
+mkTopStgRhs :: CoreToStgOpts -> Module -> CollectedCCs
-> Id -> PreStgRhs -> (StgRhs, CollectedCCs)
-mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs)
+mkTopStgRhs CoreToStgOpts
+ { coreToStg_platform = platform
+ , coreToStg_ExternalDynamicRefs = opt_ExternalDynamicRefs
+ , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs
+ } this_mod ccs bndr (PreStgRhs bndrs rhs)
| not (null bndrs)
= -- The list of arguments is non-empty, so not CAF
( StgRhsClosure noExtFieldSilent
@@ -724,14 +728,14 @@ mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs)
-- so this is not a function binding
| StgConApp con mn args _ <- unticked_rhs
, -- Dynamic StgConApps are updatable
- not (isDllConApp (targetPlatform dflags) (gopt Opt_ExternalDynamicRefs dflags) this_mod con args)
+ not (isDllConApp platform opt_ExternalDynamicRefs this_mod con args)
= -- CorePrep does this right, but just to make sure
assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
(ppr bndr $$ ppr con $$ ppr args)
( StgRhsCon dontCareCCS con mn ticks args, ccs )
-- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
- | gopt Opt_AutoSccsOnIndividualCafs dflags
+ | opt_AutoSccsOnIndividualCafs
= ( StgRhsClosure noExtFieldSilent
caf_ccs
upd_flag [] rhs
@@ -855,7 +859,7 @@ isPAP env _ = False
-- *down*.
newtype CtsM a = CtsM
- { unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs
+ { unCtsM :: Platform -- Needed for checking for bad coercions in coreToStgArgs
-> IdEnv HowBound
-> a
}
@@ -893,8 +897,8 @@ data LetInfo
-- The std monad functions:
-initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a
-initCts dflags env m = unCtsM m dflags env
+initCts :: Platform -> IdEnv HowBound -> CtsM a -> a
+initCts platform env m = unCtsM m platform env
@@ -905,8 +909,8 @@ returnCts :: a -> CtsM a
returnCts e = CtsM $ \_ _ -> e
thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
-thenCts m k = CtsM $ \dflags env
- -> unCtsM (k (unCtsM m dflags env)) dflags env
+thenCts m k = CtsM $ \platform env
+ -> unCtsM (k (unCtsM m platform env)) platform env
instance Applicative CtsM where
pure = returnCts
@@ -915,15 +919,15 @@ instance Applicative CtsM where
instance Monad CtsM where
(>>=) = thenCts
-instance HasDynFlags CtsM where
- getDynFlags = CtsM $ \dflags _ -> dflags
+getPlatform :: CtsM Platform
+getPlatform = CtsM const
-- Functions specific to this monad:
extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts ids_w_howbound expr
- = CtsM $ \dflags env
- -> unCtsM expr dflags (extendVarEnvList env ids_w_howbound)
+ = CtsM $ \platform env
+ -> unCtsM expr platform (extendVarEnvList env ids_w_howbound)
lookupVarCts :: Id -> CtsM HowBound
lookupVarCts v = CtsM $ \_ env -> lookupBinding env v
@@ -995,3 +999,12 @@ stgArity :: Id -> HowBound -> Arity
stgArity _ (LetBound _ arity) = arity
stgArity f ImportBound = idArity f
stgArity _ LambdaBound = 0
+
+data CoreToStgOpts = CoreToStgOpts
+ { coreToStg_platform :: Platform
+ , coreToStg_ways :: Ways
+ , coreToStg_AutoSccsOnIndividualCafs :: Bool
+ , coreToStg_InfoTableMap :: Bool
+ , coreToStg_ExternalDynamicRefs :: Bool
+ , coreToStg_stgDebugOpts :: StgDebugOpts
+ }
=====================================
compiler/GHC/Driver/Config/CoreToStg.hs
=====================================
@@ -0,0 +1,16 @@
+module GHC.Driver.Config.CoreToStg where
+
+import GHC.Driver.Config.Stg.Debug
+import GHC.Driver.Session
+
+import GHC.CoreToStg
+
+initCoreToStgOpts :: DynFlags -> CoreToStgOpts
+initCoreToStgOpts dflags = CoreToStgOpts
+ { coreToStg_platform = targetPlatform dflags
+ , coreToStg_ways = ways dflags
+ , coreToStg_AutoSccsOnIndividualCafs = gopt Opt_AutoSccsOnIndividualCafs dflags
+ , coreToStg_InfoTableMap = gopt Opt_InfoTableMap dflags
+ , coreToStg_ExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
+ , coreToStg_stgDebugOpts = initStgDebugOpts dflags
+ }
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -123,6 +123,7 @@ import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig)
import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyExprOpts )
import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO )
import GHC.Driver.Config.Core.Lint.Interactive ( lintInteractiveExpr )
+import GHC.Driver.Config.CoreToStg
import GHC.Driver.Config.CoreToStg.Prep
import GHC.Driver.Config.Logger (initLogFlags)
import GHC.Driver.Config.Parser (initParserOpts)
@@ -2141,7 +2142,7 @@ myCoreToStg :: Logger -> DynFlags -> InteractiveContext
myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do
let (stg_binds, denv, cost_centre_info)
= {-# SCC "Core2Stg" #-}
- coreToStg dflags this_mod ml prepd_binds
+ coreToStg (initCoreToStgOpts dflags) this_mod ml prepd_binds
(stg_binds_with_fvs,stg_cg_info)
<- {-# SCC "Stg2Stg" #-}
=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -46,9 +46,18 @@ are as follows:
t_1 :: TYPE r_1, ..., t_n :: TYPE r_n
s_1 :: TYPE p_1, ..., a_n :: TYPE p_n
-Then we must check that each r_i is compatible with s_i. Compatibility
-is weaker than on-the-nose equality: for example, IntRep and WordRep are
-compatible. See Note [Bad unsafe coercion] in GHC.Core.Lint.
+Before unarisation, we must check that each r_i is compatible with s_i.
+Compatibility is weaker than on-the-nose equality: for example,
+IntRep and WordRep are compatible. See Note [Bad unsafe coercion] in GHC.Core.Lint.
+
+After unarisation, a single type might correspond to multiple arguments, e.g.
+
+ (# Int# | Bool #) :: TYPE (SumRep '[ IntRep, LiftedRep ])
+
+will result in two arguments: [Int# :: TYPE 'IntRep, Bool :: TYPE LiftedRep]
+This means post unarise we potentially have to match up multiple arguments with
+the reps of a single argument in the type's definition, because the type of the function
+is *not* in unarised form.
Wrinkle: it can sometimes happen that an argument type in the type of
the function does not have a fixed runtime representation, i.e.
@@ -119,7 +128,7 @@ import Data.Maybe
import GHC.Utils.Misc
import GHC.Core.Multiplicity (scaledThing)
import GHC.Settings (Platform)
-import GHC.Core.TyCon (primRepCompatible)
+import GHC.Core.TyCon (primRepCompatible, primRepsCompatible)
import GHC.Utils.Panic.Plain (panic)
lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
@@ -332,14 +341,18 @@ lintStgAppReps _fun [] = return ()
lintStgAppReps fun args = do
lf <- getLintFlags
let platform = lf_platform lf
+
(fun_arg_tys, _res) = splitFunTys (idType fun)
- fun_arg_tys' = map (scaledThing ) fun_arg_tys :: [Type]
+ fun_arg_tys' = map scaledThing fun_arg_tys :: [Type]
+
+ -- Might be "wrongly" typed as polymorphic. See #21399
+ -- In these cases typePrimRep_maybe will return Nothing
+ -- and we abort kind checking.
fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]]
fun_arg_tys_reps = map typePrimRep_maybe fun_arg_tys'
actual_arg_reps = map (typePrimRep_maybe . stgArgType) args
match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
- -- Might be wrongly typed as polymorphic. See #21399
match_args (Nothing:_) _ = return ()
match_args (_) (Nothing:_) = return ()
match_args (Just actual_rep:actual_reps_left) (Just expected_rep:expected_reps_left)
@@ -353,21 +366,36 @@ lintStgAppReps fun args = do
-- Some reps are compatible *even* if they are not the same. E.g. IntRep and WordRep.
-- We check for that here with primRepCompatible
- | and $ zipWith (primRepCompatible platform) actual_rep expected_rep
+ | primRepsCompatible platform actual_rep expected_rep
= match_args actual_reps_left expected_reps_left
+ -- We might distribute args from within one unboxed sum over multiple
+ -- single rep args. This means we might need to match up things like:
+ -- [Just [WordRep, LiftedRep]] with [Just [WordRep],Just [LiftedRep]]
+ -- which happens here.
+ -- See Note [Linting StgApp].
+ | Just (actual,actuals) <- getOneRep actual_rep actual_reps_left
+ , Just (expected,expecteds) <- getOneRep expected_rep expected_reps_left
+ , primRepCompatible platform actual expected
+ = match_args actuals expecteds
+
| otherwise = addErrL $ hang (text "Function type reps and function argument reps mismatched") 2 $
(text "In application " <> ppr fun <+> ppr args $$
- text "argument rep:" <> ppr actual_rep $$
- text "expected rep:" <> ppr expected_rep $$
+ text "argument rep:" <> ppr actual_arg_reps $$
+ text "expected rep:" <> ppr fun_arg_tys_reps $$
-- text "expected reps:" <> ppr arg_ty_reps $$
text "unarised?:" <> ppr (lf_unarised lf))
where
isVoidRep [] = True
isVoidRep [VoidRep] = True
isVoidRep _ = False
-
- -- n_arg_ty_reps = length arg_ty_reps
+ -- Try to strip one non-void arg rep from the current argument type returning
+ -- the remaining list of arguments. We return Nothing for invalid input which
+ -- will result in a lint failure in match_args.
+ getOneRep :: [PrimRep] -> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])
+ getOneRep [] _rest = Nothing -- Void rep args are invalid at this point.
+ getOneRep [rep] rest = Just (rep,rest) -- A single arg rep arg
+ getOneRep (rep:reps) rest = Just (rep,Just reps:rest) -- Multi rep arg.
match_args _ _ = return () -- Functions are allowed to be over/under applied.
=====================================
compiler/ghc.cabal.in
=====================================
@@ -407,6 +407,7 @@ Library
GHC.Driver.Config.Core.Opt.Simplify
GHC.Driver.Config.Core.Opt.WorkWrap
GHC.Driver.Config.Core.Rules
+ GHC.Driver.Config.CoreToStg
GHC.Driver.Config.CoreToStg.Prep
GHC.Driver.Config.Diagnostic
GHC.Driver.Config.Finder
=====================================
configure.ac
=====================================
@@ -845,7 +845,7 @@ dnl off_t, because it will affect the result of that test.
AC_SYS_LARGEFILE
dnl ** check for specific header (.h) files that we are interested in
-AC_CHECK_HEADERS([ctype.h dirent.h dlfcn.h errno.h fcntl.h grp.h limits.h locale.h nlist.h pthread.h pwd.h signal.h sys/param.h sys/mman.h sys/resource.h sys/select.h sys/time.h sys/timeb.h sys/timerfd.h sys/timers.h sys/times.h sys/utsname.h sys/wait.h termios.h time.h utime.h windows.h winsock.h sched.h])
+AC_CHECK_HEADERS([ctype.h dirent.h dlfcn.h errno.h fcntl.h grp.h limits.h locale.h nlist.h pthread.h pwd.h signal.h sys/param.h sys/mman.h sys/resource.h sys/select.h sys/time.h sys/timeb.h sys/timerfd.h sys/timers.h sys/times.h sys/utsname.h sys/wait.h termios.h utime.h windows.h winsock.h sched.h])
dnl sys/cpuset.h needs sys/param.h to be included first on FreeBSD 9.1; #7708
AC_CHECK_HEADERS([sys/cpuset.h], [], [],
@@ -857,9 +857,6 @@ AC_CHECK_HEADERS([sys/cpuset.h], [], [],
dnl ** check whether a declaration for `environ` is provided by libc.
FP_CHECK_ENVIRON
-dnl ** check if it is safe to include both <time.h> and <sys/time.h>
-AC_HEADER_TIME
-
dnl ** do we have long longs?
AC_CHECK_TYPES([long long])
=====================================
docs/users_guide/exts/template_haskell.rst
=====================================
@@ -159,13 +159,14 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under
general ``'``\ ⟨thing⟩ interprets ⟨thing⟩ in an expression
context.
- A name whose second character is a single quote (sadly) cannot be
- quoted in this way, because it will be parsed instead as a quoted
- character. For example, if the function is called ``f'7`` (which
- is a legal Haskell identifier), an attempt to quote it as ``'f'7``
- would be parsed as the character literal ``'f'`` followed by the
- numeric literal ``7``. There is no current escape mechanism in
- this (unusual) situation.
+ A name whose second character is a single quote cannot be quoted in
+ exactly this way, because it will be parsed instead as a quoted
+ character. For example, if the function is called ``f'7`` (which is a
+ legal Haskell identifier), an attempt to quote it as ``'f'7`` would be
+ parsed as the character literal ``'f'`` followed by the numeric literal
+ ``7``. As for promoted constructors (:ref:`promotion-syntax`), the
+ workaround is to add a space between the quote and the name. The name of
+ the function ``f'7`` is thus written ``' f'7``.
- ``''T`` has type ``Name``, and names the type constructor ``T``.
That is, ``''``\ ⟨thing⟩ interprets ⟨thing⟩ in a type context.
=====================================
docs/users_guide/runghc.rst
=====================================
@@ -7,7 +7,7 @@ Using runghc
single: runghc
single: runhaskell
-``runghc`` (or ``runhaskell``, which is its equivalent) allows you to run Haskell programs using the interpreter, instead of having to
+``runghc``/``runhaskell`` allows you to run Haskell programs using the interpreter, instead of having to
compile them first.
.. _runghc-introduction:
=====================================
libraries/base/System/CPUTime/Posix/ClockGetTime.hsc
=====================================
@@ -2,10 +2,8 @@
#include "HsFFI.h"
#include "HsBaseConfig.h"
-#if HAVE_TIME_H
#include <unistd.h>
#include <time.h>
-#endif
module System.CPUTime.Posix.ClockGetTime
( getCPUTime
=====================================
libraries/base/aclocal.m4
=====================================
@@ -78,9 +78,7 @@ AC_DEFUN([FPTOOLS_HTYPE_INCLUDES],
# include <signal.h>
#endif
-#if HAVE_TIME_H
-# include <time.h>
-#endif
+#include <time.h>
#if HAVE_TERMIOS_H
# include <termios.h>
=====================================
libraries/base/cbits/sysconf.c
=====================================
@@ -6,9 +6,7 @@
#endif
/* for CLK_TCK */
-#if HAVE_TIME_H
#include <time.h>
-#endif
long clk_tck(void) {
#if defined(CLK_TCK)
=====================================
libraries/base/include/HsBase.h
=====================================
@@ -74,9 +74,7 @@
# include <sys/timers.h>
# endif
#endif
-#if HAVE_TIME_H
#include <time.h>
-#endif
#if HAVE_SYS_TIMEB_H && !defined(__FreeBSD__)
#include <sys/timeb.h>
#endif
=====================================
m4/fp_check_timer_create.m4
=====================================
@@ -20,9 +20,7 @@ then
#if defined(HAVE_STDLIB_H)
#include <stdlib.h>
#endif
-#if defined(HAVE_TIME_H)
#include <time.h>
-#endif
#if defined(HAVE_SIGNAL_H)
#include <signal.h>
#endif
=====================================
rts/RtsUtils.c
=====================================
@@ -15,9 +15,7 @@
#include "Schedule.h"
#include "RtsFlags.h"
-#if defined(HAVE_TIME_H)
#include <time.h>
-#endif
/* HACK: On Mac OS X 10.4 (at least), time.h doesn't declare ctime_r with
* _POSIX_C_SOURCE. If this is the case, we declare it ourselves.
=====================================
rts/posix/Clock.h
=====================================
@@ -12,9 +12,7 @@
# include <unistd.h>
#endif
-#if defined(HAVE_TIME_H)
-# include <time.h>
-#endif
+#include <time.h>
#if defined(HAVE_SYS_TIME_H)
# include <sys/time.h>
=====================================
rts/posix/ticker/Pthread.c
=====================================
@@ -44,17 +44,10 @@
#include "Schedule.h"
#include "posix/Clock.h"
-/* As recommended in the autoconf manual */
-# if defined(TIME_WITH_SYS_TIME)
-# include <sys/time.h>
-# include <time.h>
-# else
-# if defined(HAVE_SYS_TIME_H)
-# include <sys/time.h>
-# else
-# include <time.h>
-# endif
-# endif
+#include <time.h>
+#if HAVE_SYS_TIME_H
+# include <sys/time.h>
+#endif
#if defined(HAVE_SIGNAL_H)
# include <signal.h>
=====================================
rts/posix/ticker/Setitimer.c
=====================================
@@ -15,17 +15,10 @@
#include "posix/Clock.h"
#include "posix/Signals.h"
-/* As recommended in the autoconf manual */
-# if defined(TIME_WITH_SYS_TIME)
-# include <sys/time.h>
-# include <time.h>
-# else
-# if defined(HAVE_SYS_TIME_H)
-# include <sys/time.h>
-# else
-# include <time.h>
-# endif
-# endif
+#include <time.h>
+#if HAVE_SYS_TIME_H
+# include <sys/time.h>
+#endif
#if defined(HAVE_SIGNAL_H)
# include <signal.h>
=====================================
rts/win32/GetTime.c
=====================================
@@ -11,9 +11,7 @@
#include <windows.h>
-#if defined(HAVE_TIME_H)
-# include <time.h>
-#endif
+#include <time.h>
/* Convert FILETIMEs into secs */
=====================================
testsuite/tests/driver/fat-iface/Makefile
=====================================
@@ -49,7 +49,4 @@ fat010: clean
echo >> "THB.hs"
"$(TEST_HC)" $(TEST_HC_OPTS) THC.hs -fhide-source-paths -fwrite-if-simplfied-core -fprefer-byte-code
-fat014: clean
- echo ":q" | "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) -v0 -fno-code < fat014.script
-
=====================================
testsuite/tests/driver/fat-iface/all.T
=====================================
@@ -13,7 +13,7 @@ test('fat012', [unless(ghc_dynamic(), skip), extra_files(['FatTH.hs', 'FatQuote.
# Check that no objects are generated if using -fno-code and -fprefer-byte-code
test('fat013', [extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fno-code -fprefer-byte-code'])
# When using interpreter should not produce objects
-test('fat014', [extra_files(['FatTH.hs', 'FatQuote.hs'])], makefile_test, ['fat014'])
+test('fat014', [extra_files(['FatTH.hs', 'FatQuote.hs']), extra_run_opts('-fno-code')], ghci_script, ['fat014.script'])
test('fat015', [unless(ghc_dynamic(), skip), extra_files(['FatQuote.hs', 'FatQuote1.hs', 'FatQuote2.hs', 'FatTH1.hs', 'FatTH2.hs', 'FatTHTop.hs'])], multimod_compile, ['FatTHTop', '-fno-code -fwrite-interface'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/36b99dc474adf6d88cc819d9f4cababb89f57f97...b181f78e600374dd076d52363fe8b7df0bdd0b6d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/36b99dc474adf6d88cc819d9f4cababb89f57f97...b181f78e600374dd076d52363fe8b7df0bdd0b6d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221021/b6c47713/attachment-0001.html>
More information about the ghc-commits
mailing list