diff options
| author | Patrick Palka <patrick@parcs.ath.cx> | 2013-08-30 12:54:22 -0400 |
|---|---|---|
| committer | Patrick Palka <patrick@parcs.ath.cx> | 2013-08-30 12:54:22 -0400 |
| commit | 26bf3dd478dce53eb50c2ce13821d61e416e3fe7 (patch) | |
| tree | 7b025b1eca208e96cf5e1916dd12f0054fda79ea | |
| parent | 6d755c08ca125d991a95fbdc3ae1dc0608b722f1 (diff) | |
| parent | 85c1715d086bf2d35bc05133398f462919f2aa7b (diff) | |
| download | haskell-26bf3dd478dce53eb50c2ce13821d61e416e3fe7.tar.gz | |
Merge branch 'master' into ghc-parmake-gsoc
Conflicts:
compiler/main/DynFlags.hs
compiler/utils/FastString.lhs
58 files changed, 1592 insertions, 945 deletions
diff --git a/aclocal.m4 b/aclocal.m4 index e742e907d6..7e555446a1 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -464,6 +464,7 @@ AC_DEFUN([FP_SETTINGS], SettingsPerlCommand="$PerlCmd" SettingsDllWrapCommand="/bin/false" SettingsWindresCommand="/bin/false" + SettingsLibtoolCommand="libtool" SettingsTouchCommand='touch' if test -z "$LlcCmd" then @@ -490,6 +491,7 @@ AC_DEFUN([FP_SETTINGS], AC_SUBST(SettingsPerlCommand) AC_SUBST(SettingsDllWrapCommand) AC_SUBST(SettingsWindresCommand) + AC_SUBST(SettingsLibtoolCommand) AC_SUBST(SettingsTouchCommand) AC_SUBST(SettingsLlcCommand) AC_SUBST(SettingsOptCommand) diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 838e368ea6..dfde994417 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -381,17 +381,16 @@ data OverlapFlag -- its ambiguous which to choose) | OverlapOk { isSafeOverlap :: Bool } - -- | Like OverlapOk, but also ignore this instance - -- if it doesn't match the constraint you are - -- trying to resolve, but could match if the type variables - -- in the constraint were instantiated + -- | Silently ignore this instance if you find any other that matches the + -- constraing you are trying to resolve, including when checking if there are + -- instances that do not match, but unify. -- -- Example: constraint (Foo [b]) -- instances (Foo [Int]) Incoherent -- (Foo [a]) -- Without the Incoherent flag, we'd complain that -- instantiating 'b' would change which instance - -- was chosen + -- was chosen. See also note [Incoherent instances] | Incoherent { isSafeOverlap :: Bool } deriving (Eq, Data, Typeable) diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 1df8e848b8..d3624dac6b 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -18,7 +18,7 @@ module CmmExpr , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet , regSetToList , regUsedIn - + , Area(..) , module CmmMachOp , module CmmType @@ -119,7 +119,11 @@ data CmmLit -- Invariant: must be a continuation BlockId -- See Note [Continuation BlockId] in CmmNode. - | CmmHighStackMark -- stands for the max stack space used during a procedure + | CmmHighStackMark -- A late-bound constant that stands for the max + -- #bytes of stack space used during a procedure. + -- During the stack-layout pass, CmmHighStackMark + -- is replaced by a CmmInt for the actual number + -- of bytes used deriving Eq cmmExprType :: DynFlags -> CmmExpr -> CmmType @@ -336,7 +340,7 @@ data GlobalReg | LongReg -- long int registers (64-bit, really) {-# UNPACK #-} !Int -- its number - | XmmReg -- 128-bit SIMD vector register + | XmmReg -- 128-bit SIMD vector register {-# UNPACK #-} !Int -- its number -- STG registers diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 8b3bac3b4f..9b1bce4b57 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -257,13 +257,10 @@ cgDataCon data_con -- Stuff to support splitting --------------------------------------------------------------- --- If we're splitting the object, we need to externalise all the --- top-level names (and then make sure we only use the externalised --- one in any C label we use which refers to this name). - maybeExternaliseId :: DynFlags -> Id -> FCode Id maybeExternaliseId dflags id - | gopt Opt_SplitObjs dflags, -- Externalise the name for -split-objs + | gopt Opt_SplitObjs dflags, -- See Note [Externalise when splitting] + -- in StgCmmMonad isInternalName name = do { mod <- getModuleName ; returnFC (setIdName id (externalise mod)) } | otherwise = returnFC id diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index ce5491dc10..dccefd0fb0 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -30,6 +30,7 @@ import StgCmmForeign (emitPrimCall) import MkGraph import CoreSyn ( AltCon(..) ) import SMRep +import BlockId import Cmm import CmmInfo import CmmUtils @@ -476,7 +477,17 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details ; let node_points = nodeMustPointToIt dflags lf_info node' = if node_points then Just node else Nothing ; when node_points (ldvEnterClosure cl_info) - + -- Emit new label that might potentially be a header + -- of a self-recursive tail call. See Note + -- [Self-recursive tail calls] in StgCmmExpr + ; u <- newUnique + ; let loop_header_id = mkBlockId u + ; emitLabel loop_header_id + -- Extend reader monad with information that + -- self-recursive tail calls can be optimized into local + -- jumps + ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do + { -- Main payload ; entryHeapCheck cl_info node' arity arg_regs $ do { -- ticky after heap check to avoid double counting @@ -490,7 +501,8 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details -- heap check, to reduce live vars over check ; when node_points $ load_fvs node lf_info fv_bindings ; void $ cgExpr body - }} + }}} + } -- A function closure pointer may be tagged, so we diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 611a570d70..04297b4258 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -27,10 +27,9 @@ module StgCmmClosure ( lfDynTag, maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable, - nodeMustPointToIt, - CallMethod(..), getCallMethod, - - isKnownFun, funTag, tagForArity, + -- * Used by other modules + CgLoc(..), SelfLoopInfo, CallMethod(..), + nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod, -- * ClosureInfo ClosureInfo, @@ -69,11 +68,14 @@ module StgCmmClosure ( import StgSyn import SMRep import Cmm +import PprCmmExpr() +import BlockId import CLabel import Id import IdInfo import DataCon +import FastString import Name import Type import TypeRep @@ -85,6 +87,37 @@ import DynFlags import Util ----------------------------------------------------------------------------- +-- Data types and synonyms +----------------------------------------------------------------------------- + +-- These data types are mostly used by other modules, especially StgCmmMonad, +-- but we define them here because some functions in this module need to +-- have access to them as well + +data CgLoc + = CmmLoc CmmExpr -- A stable CmmExpr; that is, one not mentioning + -- Hp, so that it remains valid across calls + + | LneLoc BlockId [LocalReg] -- A join point + -- A join point (= let-no-escape) should only + -- be tail-called, and in a saturated way. + -- To tail-call it, assign to these locals, + -- and branch to the block id + +instance Outputable CgLoc where + ppr (CmmLoc e) = ptext (sLit "cmm") <+> ppr e + ppr (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs + +type SelfLoopInfo = (Id, BlockId, [LocalReg]) + +-- used by ticky profiling +isKnownFun :: LambdaFormInfo -> Bool +isKnownFun (LFReEntrant _ _ _ _) = True +isKnownFun LFLetNoEscape = True +isKnownFun _ = False + + +----------------------------------------------------------------------------- -- Representations ----------------------------------------------------------------------------- @@ -122,23 +155,23 @@ isGcPtrRep _ = False -- tail call or return that identifier. data LambdaFormInfo - = LFReEntrant -- Reentrant closure (a function) - TopLevelFlag -- True if top level - !RepArity -- Arity. Invariant: always > 0 - !Bool -- True <=> no fvs + = LFReEntrant -- Reentrant closure (a function) + TopLevelFlag -- True if top level + !RepArity -- Arity. Invariant: always > 0 + !Bool -- True <=> no fvs ArgDescr -- Argument descriptor (should really be in ClosureInfo) - | LFThunk -- Thunk (zero arity) + | LFThunk -- Thunk (zero arity) TopLevelFlag - !Bool -- True <=> no free vars - !Bool -- True <=> updatable (i.e., *not* single-entry) + !Bool -- True <=> no free vars + !Bool -- True <=> updatable (i.e., *not* single-entry) StandardFormInfo - !Bool -- True <=> *might* be a function type + !Bool -- True <=> *might* be a function type - | LFCon -- A saturated constructor application - DataCon -- The constructor + | LFCon -- A saturated constructor application + DataCon -- The constructor - | LFUnknown -- Used for function arguments and imported things. + | LFUnknown -- Used for function arguments and imported things. -- We know nothing about this closure. -- Treat like updatable "LFThunk"... -- Imported things which we *do* know something about use @@ -149,10 +182,10 @@ data LambdaFormInfo -- because then we know the entry code will do -- For a function, the entry code is the fast entry point - | LFUnLifted -- A value of unboxed type; + | LFUnLifted -- A value of unboxed type; -- always a value, needs evaluation - | LFLetNoEscape -- See LetNoEscape module for precise description + | LFLetNoEscape -- See LetNoEscape module for precise description | LFBlackHole -- Used for the closures allocated to hold the result -- of a CAF. We want the target of the update frame to @@ -175,7 +208,7 @@ data StandardFormInfo -- case x of -- con a1,..,an -> ak -- and the constructor is from a single-constr type. - WordOff -- 0-origin offset of ak within the "goods" of + WordOff -- 0-origin offset of ak within the "goods" of -- constructor (Recall that the a1,...,an may be laid -- out in the heap in a non-obvious order.) @@ -205,9 +238,9 @@ mkLFLetNoEscape :: LambdaFormInfo mkLFLetNoEscape = LFLetNoEscape ------------- -mkLFReEntrant :: TopLevelFlag -- True of top level - -> [Id] -- Free vars - -> [Id] -- Args +mkLFReEntrant :: TopLevelFlag -- True of top level + -> [Id] -- Free vars + -> [Id] -- Args -> ArgDescr -- Argument descriptor -> LambdaFormInfo @@ -256,7 +289,7 @@ mkLFImported :: Id -> LambdaFormInfo mkLFImported id | Just con <- isDataConWorkId_maybe id , isNullaryRepDataCon con - = LFCon con -- An imported nullary constructor + = LFCon con -- An imported nullary constructor -- We assume that the constructor is evaluated so that -- the id really does point directly to the constructor @@ -465,49 +498,65 @@ When black-holing, single-entry closures could also be entered via node (rather than directly) to catch double-entry. -} data CallMethod - = EnterIt -- No args, not a function + = EnterIt -- No args, not a function - | JumpToIt -- A join point + | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop - | ReturnIt -- It's a value (function, unboxed value, + | ReturnIt -- It's a value (function, unboxed value, -- or constructor), so just return it. | SlowCall -- Unknown fun, or known fun with -- too few args. | DirectEntry -- Jump directly, with args in regs - CLabel -- The code label - RepArity -- Its arity + CLabel -- The code label + RepArity -- Its arity getCallMethod :: DynFlags -> Name -- Function being applied - -> CafInfo -- Can it refer to CAF's? - -> LambdaFormInfo -- Its info - -> RepArity -- Number of available arguments + -> Id -- Function Id used to chech if it can refer to + -- CAF's and whether the function is tail-calling + -- itself + -> LambdaFormInfo -- Its info + -> RepArity -- Number of available arguments + -> CgLoc -- Passed in from cgIdApp so that we can + -- handle let-no-escape bindings and self-recursive + -- tail calls using the same data constructor, + -- JumpToIt. This saves us one case branch in + -- cgIdApp + -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call? -> CallMethod -getCallMethod dflags _name _ lf_info _n_args +getCallMethod _ _ id _ n_args _cg_loc (Just (self_loop_id, block_id, args)) + | id == self_loop_id, n_args == length args + -- If these patterns match then we know that: + -- * function is performing a self-recursive call in a tail position + -- * number of parameters of the function matches functions arity. + -- See Note [Self-recursive tail calls] in StgCmmExpr for more details + = JumpToIt block_id args + +getCallMethod dflags _name _ lf_info _n_args _cg_loc _self_loop_info | nodeMustPointToIt dflags lf_info && gopt Opt_Parallel dflags - = -- If we're parallel, then we must always enter via node. + = -- If we're parallel, then we must always enter via node. -- The reason is that the closure may have been -- fetched since we allocated it. EnterIt -getCallMethod dflags name caf (LFReEntrant _ arity _ _) n_args +getCallMethod dflags name id (LFReEntrant _ arity _ _) n_args _cg_loc _self_loop_info | n_args == 0 = ASSERT( arity /= 0 ) ReturnIt -- No args at all | n_args < arity = SlowCall -- Not enough args - | otherwise = DirectEntry (enterIdLabel dflags name caf) arity + | otherwise = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity -getCallMethod _ _name _ LFUnLifted n_args +getCallMethod _ _name _ LFUnLifted n_args _cg_loc _self_loop_info = ASSERT( n_args == 0 ) ReturnIt -getCallMethod _ _name _ (LFCon _) n_args +getCallMethod _ _name _ (LFCon _) n_args _cg_loc _self_loop_info = ASSERT( n_args == 0 ) ReturnIt -getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_args - | is_fun -- it *might* be a function, so we must "call" it (which is always safe) - = SlowCall -- We cannot just enter it [in eval/apply, the entry code +getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun) n_args _cg_loc _self_loop_info + | is_fun -- it *might* be a function, so we must "call" it (which is always safe) + = SlowCall -- We cannot just enter it [in eval/apply, the entry code -- is the fast-entry code] -- Since is_fun is False, we are *definitely* looking at a data value @@ -527,27 +576,24 @@ getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_arg | otherwise -- Jump direct to code for single-entry thunks = ASSERT( n_args == 0 ) - DirectEntry (thunkEntryLabel dflags name caf std_form_info updatable) 0 + DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info updatable) 0 -getCallMethod _ _name _ (LFUnknown True) _n_args +getCallMethod _ _name _ (LFUnknown True) _n_arg _cg_locs _self_loop_info = SlowCall -- might be a function -getCallMethod _ name _ (LFUnknown False) n_args +getCallMethod _ name _ (LFUnknown False) n_args _cg_loc _self_loop_info = ASSERT2( n_args == 0, ppr name <+> ppr n_args ) EnterIt -- Not a function -getCallMethod _ _name _ LFBlackHole _n_args - = SlowCall -- Presumably the black hole has by now +getCallMethod _ _name _ LFBlackHole _n_args _cg_loc _self_loop_info + = SlowCall -- Presumably the black hole has by now -- been updated, but we don't know with -- what, so we slow call it -getCallMethod _ _name _ LFLetNoEscape _n_args - = JumpToIt +getCallMethod _ _name _ LFLetNoEscape _n_args (LneLoc blk_id lne_regs) _self_loop_info + = JumpToIt blk_id lne_regs -isKnownFun :: LambdaFormInfo -> Bool -isKnownFun (LFReEntrant _ _ _ _) = True -isKnownFun LFLetNoEscape = True -isKnownFun _ = False +getCallMethod _ _ _ _ _ _ _ = panic "Unknown call method" ----------------------------------------------------------------------------- -- staticClosureRequired @@ -680,7 +726,6 @@ mkCmmInfo ClosureInfo {..} , cit_prof = closureProf , cit_srt = NoC_SRT } - -------------------------------------- -- Building ClosureInfos -------------------------------------- diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 6b010bbce0..331e65819f 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -160,7 +160,7 @@ cgLetNoEscapeClosure bndr cc_slot _unused_cc args body return ( lneIdInfo dflags bndr args , code ) where - code = forkProc $ do { + code = forkLneBody $ do { ; withNewTickyCounterLNE (idName bndr) args $ do ; restoreCurrentCostCentre cc_slot ; arg_regs <- bindArgsToRegs args @@ -632,18 +632,20 @@ cgConApp con stg_args cgIdApp :: Id -> [StgArg] -> FCode ReturnKind cgIdApp fun_id [] | isVoidId fun_id = emitReturn [] cgIdApp fun_id args = do - dflags <- getDynFlags - fun_info <- getCgIdInfo fun_id + dflags <- getDynFlags + fun_info <- getCgIdInfo fun_id + self_loop_info <- getSelfLoop let cg_fun_id = cg_id fun_info - -- NB. use (cg_id fun_info) instead of fun_id, because the former - -- may be externalised for -split-objs. - -- See StgCmm.maybeExternaliseId. + -- NB: use (cg_id fun_info) instead of fun_id, because + -- the former may be externalised for -split-objs. + -- See Note [Externalise when splitting] in StgCmmMonad + fun_arg = StgVarArg cg_fun_id - fun_name = idName cg_fun_id - fun = idInfoToAmode fun_info - lf_info = cg_lf fun_info + fun_name = idName cg_fun_id + fun = idInfoToAmode fun_info + lf_info = cg_lf fun_info node_points dflags = nodeMustPointToIt dflags lf_info - case (getCallMethod dflags fun_name (idCafInfo cg_fun_id) lf_info (length args)) of + case (getCallMethod dflags fun_name cg_fun_id lf_info (length args) (cg_loc fun_info) self_loop_info) of -- A value in WHNF, so we can just return it. ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged? @@ -663,14 +665,87 @@ cgIdApp fun_id args = do then directCall NativeNodeCall lbl arity (fun_arg:args) else directCall NativeDirectCall lbl arity args } - -- Let-no-escape call - JumpToIt -> let (LneLoc blk_id lne_regs) = cg_loc fun_info - in do - { adjustHpBackwards -- always do this before a tail-call - ; cmm_args <- getNonVoidArgAmodes args - ; emitMultiAssign lne_regs cmm_args - ; emit (mkBranch blk_id) - ; return AssignedDirectly } + -- Let-no-escape call or self-recursive tail-call + JumpToIt blk_id lne_regs -> do + { adjustHpBackwards -- always do this before a tail-call + ; cmm_args <- getNonVoidArgAmodes args + ; emitMultiAssign lne_regs cmm_args + ; emit (mkBranch blk_id) + ; return AssignedDirectly } + +-- Note [Self-recursive tail calls] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Self-recursive tail calls can be optimized into a local jump in the same +-- way as let-no-escape bindings (see Note [What is a non-escaping let] in +-- stgSyn/CoreToStg.lhs). Consider this: +-- +-- foo.info: +-- a = R1 // calling convention +-- b = R2 +-- goto L1 +-- L1: ... +-- ... +-- ... +-- L2: R1 = x +-- R2 = y +-- call foo(R1,R2) +-- +-- Instead of putting x and y into registers (or other locations required by the +-- calling convention) and performing a call we can put them into local +-- variables a and b and perform jump to L1: +-- +-- foo.info: +-- a = R1 +-- b = R2 +-- goto L1 +-- L1: ... +-- ... +-- ... +-- L2: a = x +-- b = y +-- goto L1 +-- +-- This can be done only when function is calling itself in a tail position +-- and only if the call passes number of parameters equal to function's arity. +-- Note that this cannot be performed if a function calls itself with a +-- continuation. +-- +-- This in fact implements optimization known as "loopification". It was +-- described in "Low-level code optimizations in the Glasgow Haskell Compiler" +-- by Krzysztof Woś, though we use different approach. Krzysztof performed his +-- optimization at the Cmm level, whereas we perform ours during code generation +-- (Stg-to-Cmm pass) essentially making sure that optimized Cmm code is +-- generated in the first place. +-- +-- Implementation is spread across a couple of places in the code: +-- +-- * FCode monad stores additional information in its reader environment +-- (cgd_self_loop field). This information tells us which function can +-- tail call itself in an optimized way (it is the function currently +-- being compiled), what is the label of a loop header (L1 in example above) +-- and information about local registers in which we should arguments +-- before making a call (this would be a and b in example above). +-- +-- * Whenever we are compiling a function, we set that information to reflect +-- the fact that function currently being compiled can be jumped to, instead +-- of called. We also have to emit a label to which we will be jumping. Both +-- things are done in closureCodyBody in StgCmmBind. +-- +-- * When we began compilation of another closure we remove the additional +-- information from the environment. This is done by forkClosureBody +-- in StgCmmMonad. Other functions that duplicate the environment - +-- forkLneBody, forkAlts, codeOnly - duplicate that information. In other +-- words, we only need to clean the environment of the self-loop information +-- when compiling right hand side of a closure (binding). +-- +-- * When compiling a call (cgIdApp) we use getCallMethod to decide what kind +-- of call will be generated. getCallMethod decides to generate a self +-- recursive tail call when (a) environment stores information about +-- possible self tail-call; (b) that tail call is to a function currently +-- being compiled; (c) number of passed arguments is equal to function's +-- arity. + emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 17bad247e2..27d4fd6386 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -26,7 +26,7 @@ module StgCmmMonad ( mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto, mkCall, mkCmmCall, - forkClosureBody, forkAlts, forkProc, codeOnly, + forkClosureBody, forkLneBody, forkAlts, codeOnly, ConTagZ, @@ -44,10 +44,10 @@ module StgCmmMonad ( getModuleName, -- ideally we wouldn't export these, but some other modules access internal state - getState, setState, getInfoDown, getDynFlags, getThisPackage, + getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, getThisPackage, -- more localised access to monad state - CgIdInfo(..), CgLoc(..), + CgIdInfo(..), getBinds, setBinds, -- out of general friendliness, we also export ... @@ -60,6 +60,7 @@ import Cmm import StgCmmClosure import DynFlags import Hoopl +import Maybes import MkGraph import BlockId import CLabel @@ -100,11 +101,10 @@ infixr 9 `thenFC` -- - A reader monad, for CgInfoDownwards, containing -- - DynFlags, -- - the current Module --- - the static top-level environmnet -- - the update-frame offset -- - the ticky counter label -- - the Sequel (the continuation to return to) - +-- - the self-recursive tail call information -------------------------------------------------------- @@ -169,51 +169,48 @@ fixC fcode = FCode ( data CgInfoDownwards -- information only passed *downwards* by the monad = MkCgInfoDown { - cgd_dflags :: DynFlags, - cgd_mod :: Module, -- Module being compiled - cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame - cgd_ticky :: CLabel, -- Current destination for ticky counts - cgd_sequel :: Sequel -- What to do at end of basic block + cgd_dflags :: DynFlags, + cgd_mod :: Module, -- Module being compiled + cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame + cgd_ticky :: CLabel, -- Current destination for ticky counts + cgd_sequel :: Sequel, -- What to do at end of basic block + cgd_self_loop :: Maybe SelfLoopInfo -- Which tail calls can be compiled + -- as local jumps? See Note + -- [Self-recursive tail calls] in + -- StgCmmExpr } type CgBindings = IdEnv CgIdInfo data CgIdInfo = CgIdInfo - { cg_id :: Id -- Id that this is the info for + { cg_id :: Id -- Id that this is the info for -- Can differ from the Id at occurrence sites by -- virtue of being externalised, for splittable C + -- See Note [Externalise when splitting] , cg_lf :: LambdaFormInfo , cg_loc :: CgLoc -- CmmExpr for the *tagged* value } -data CgLoc - = CmmLoc CmmExpr -- A stable CmmExpr; that is, one not mentioning - -- Hp, so that it remains valid across calls - - | LneLoc BlockId [LocalReg] -- A join point - -- A join point (= let-no-escape) should only - -- be tail-called, and in a saturated way. - -- To tail-call it, assign to these locals, - -- and branch to the block id +-- Note [Externalise when splitting] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- If we're splitting the object with -fsplit-objs, we need to +-- externalise *all* the top-level names, and then make sure we only +-- use the externalised one in any C label we use which refers to this +-- name. instance Outputable CgIdInfo where ppr (CgIdInfo { cg_id = id, cg_loc = loc }) = ppr id <+> ptext (sLit "-->") <+> ppr loc -instance Outputable CgLoc where - ppr (CmmLoc e) = ptext (sLit "cmm") <+> ppr e - ppr (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs - - -- Sequel tells what to do with the result of this expression data Sequel - = Return Bool -- Return result(s) to continuation found on the stack - -- True <=> the continuation is update code (???) + = Return Bool -- Return result(s) to continuation found on the stack. + -- True <=> the continuation is update code (???) | AssignTo - [LocalReg] -- Put result(s) in these regs and fall through - -- NB: no void arguments here + [LocalReg] -- Put result(s) in these regs and fall through + -- NB: no void arguments here -- Bool -- Should we adjust the heap pointer back to -- recover space that's unused on this path? @@ -300,7 +297,8 @@ initCgInfoDown dflags mod , cgd_mod = mod , cgd_updfr_off = initUpdFrameOff dflags , cgd_ticky = mkTopTickyCtrLabel - , cgd_sequel = initSequel } + , cgd_sequel = initSequel + , cgd_self_loop = Nothing } initSequel :: Sequel initSequel = Return False @@ -330,10 +328,10 @@ data CgState data HeapUsage = HeapUsage { - virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word - -- Incremented whenever we allocate + virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word + -- Incremented whenever we allocate realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr - -- Used in instruction addressing modes + -- Used in instruction addressing modes } type VirtualHpOffset = WordOff @@ -447,6 +445,16 @@ newUnique = do getInfoDown :: FCode CgInfoDownwards getInfoDown = FCode $ \info_down state -> (# info_down,state #) +getSelfLoop :: FCode (Maybe SelfLoopInfo) +getSelfLoop = do + info_down <- getInfoDown + return $ cgd_self_loop info_down + +withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a +withSelfLoop self_loop code = do + info_down <- getInfoDown + withInfoDown code (info_down {cgd_self_loop = Just self_loop}) + instance HasDynFlags FCode where getDynFlags = liftM cgd_dflags getInfoDown @@ -473,7 +481,7 @@ getModuleName = do { info <- getInfoDown; return (cgd_mod info) } withSequel :: Sequel -> FCode a -> FCode a withSequel sequel code = do { info <- getInfoDown - ; withInfoDown code (info {cgd_sequel = sequel }) } + ; withInfoDown code (info {cgd_sequel = sequel, cgd_self_loop = Nothing }) } getSequel :: FCode Sequel getSequel = do { info <- getInfoDown @@ -518,15 +526,12 @@ setTickyCtrLabel ticky code = do -------------------------------------------------------- forkClosureBody :: FCode () -> FCode () --- forkClosureBody takes a code, $c$, and compiles it in a --- fresh environment, except that: --- - compilation info and statics are passed in unchanged. --- - local bindings are passed in unchanged --- (it's up to the enclosed code to re-bind the --- free variables to a field of the closure) --- --- The current state is passed on completely unaltered, except that --- C-- from the fork is incorporated. +-- forkClosureBody compiles body_code in environment where: +-- - sequel, update stack frame and self loop info are +-- set to fresh values +-- - state is set to a fresh value, except for local bindings +-- that are passed in unchanged. It's up to the enclosed code to +-- re-bind the free variables to a field of the closure. forkClosureBody body_code = do { dflags <- getDynFlags @@ -534,26 +539,25 @@ forkClosureBody body_code ; us <- newUniqSupply ; state <- getState ; let body_info_down = info { cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff dflags } + , cgd_updfr_off = initUpdFrameOff dflags + , cgd_self_loop = Nothing } fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } ((),fork_state_out) = doFCode body_code body_info_down fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out } -forkProc :: FCode a -> FCode a --- 'forkProc' takes a code and compiles it in the *current* environment, --- returning the graph thus constructed. +forkLneBody :: FCode a -> FCode a +-- 'forkLneBody' takes a body of let-no-escape binding and compiles +-- it in the *current* environment, returning the graph thus constructed. -- -- The current environment is passed on completely unchanged to -- the successor. In particular, any heap usage from the enclosed -- code is discarded; it should deal with its own heap consumption. --- forkProc is used to compile let-no-escape bindings. -forkProc body_code +forkLneBody body_code = do { info_down <- getInfoDown ; us <- newUniqSupply ; state <- getState - ; let info_down' = info_down -- { cgd_sequel = initSequel } - fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } - (result, fork_state_out) = doFCode body_code info_down' fork_state_in + ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } + (result, fork_state_out) = doFCode body_code info_down fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out ; return result } @@ -563,10 +567,10 @@ codeOnly :: FCode () -> FCode () -- Used in almost-circular code to prevent false loop dependencies codeOnly body_code = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state, - cgs_hp_usg = cgs_hp_usg state } + ; us <- newUniqSupply + ; state <- getState + ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state + , cgs_hp_usg = cgs_hp_usg state } ((), fork_state_out) = doFCode body_code info_down fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out } @@ -585,9 +589,8 @@ forkAlts branch_fcodes where (us1,us2) = splitUniqSupply us branch_state = (initCgState us1) { - cgs_binds = cgs_binds state, - cgs_hp_usg = cgs_hp_usg state } - + cgs_binds = cgs_binds state + , cgs_hp_usg = cgs_hp_usg state } (_us, results) = mapAccumL compile us branch_fcodes (branch_results, branch_out_states) = unzip results ; setState $ foldl stateIncUsage state branch_out_states diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 25a751b423..2e6d907b51 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -22,7 +22,7 @@ module CoreSubst ( deShadowBinds, substSpec, substRulesForImportedIds, substTy, substCo, substExpr, substExprSC, substBind, substBindSC, substUnfolding, substUnfoldingSC, - substUnfoldingSource, lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc, + lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc, substTickish, -- ** Operations on substitutions @@ -665,36 +665,13 @@ substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work = NoUnfolding | otherwise -- But keep a stable one! - = seqExpr new_tmpl `seq` - new_src `seq` - unf { uf_tmpl = new_tmpl, uf_src = new_src } + = seqExpr new_tmpl `seq` + unf { uf_tmpl = new_tmpl } where new_tmpl = substExpr (text "subst-unf") subst tmpl - new_src = substUnfoldingSource subst src substUnfolding _ unf = unf -- NoUnfolding, OtherCon -------------------- -substUnfoldingSource :: Subst -> UnfoldingSource -> UnfoldingSource -substUnfoldingSource (Subst in_scope ids _ _) (InlineWrapper wkr) - | Just wkr_expr <- lookupVarEnv ids wkr - = case wkr_expr of - Var w1 -> InlineWrapper w1 - _other -> -- WARN( True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr - -- <+> ifPprDebug (equals <+> ppr wkr_expr) ) - -- Note [Worker inlining] - InlineStable -- It's not a wrapper any more, but still inline it! - - | Just w1 <- lookupInScope in_scope wkr = InlineWrapper w1 - | otherwise = -- WARN( True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr ) - -- This can legitimately happen. The worker has been inlined and - -- dropped as dead code, because we don't treat the UnfoldingSource - -- as an "occurrence". - -- Note [Worker inlining] - InlineStable - -substUnfoldingSource _ src = src - ------------------ substIdOcc :: Subst -> Id -> Id -- These Ids should not be substituted to non-Ids diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index ede3a4052b..dd7307d190 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -739,12 +739,12 @@ data UnfoldingSource -- (see MkId.lhs, calls to mkCompulsoryUnfolding). -- Inline absolutely always, however boring the context. - | InlineWrapper Id -- This unfolding is a the wrapper in a - -- worker/wrapper split from the strictness analyser - -- The Id is the worker-id - -- Used to abbreviate the uf_tmpl in interface files - -- which don't need to contain the RHS; - -- it can be derived from the strictness info + | InlineWrapper -- This unfolding is the wrapper in a + -- worker/wrapper split from the strictness + -- analyser + -- + -- cf some history in TcIface's Note [wrappers + -- in interface files] @@ -844,9 +844,9 @@ isStableSource :: UnfoldingSource -> Bool -- Keep the unfolding template isStableSource InlineCompulsory = True isStableSource InlineStable = True -isStableSource (InlineWrapper {}) = True +isStableSource InlineWrapper = True isStableSource InlineRhs = False - + -- | Retrieves the template of an unfolding: panics if none is known unfoldingTemplate :: Unfolding -> CoreExpr unfoldingTemplate = uf_tmpl diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs index 8d45fbb9b4..f0c947246a 100644 --- a/compiler/coreSyn/CoreTidy.lhs +++ b/compiler/coreSyn/CoreTidy.lhs @@ -215,15 +215,10 @@ tidyUnfolding tidy_env unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) unf_from_rhs | isStableSource src - = unf { uf_tmpl = tidyExpr tidy_env unf_rhs, -- Preserves OccInfo - uf_src = tidySrc tidy_env src } + = unf { uf_tmpl = tidyExpr tidy_env unf_rhs } -- Preserves OccInfo | otherwise = unf_from_rhs tidyUnfolding _ unf _ = unf -- NoUnfolding or OtherCon - -tidySrc :: TidyEnv -> UnfoldingSource -> UnfoldingSource -tidySrc tidy_env (InlineWrapper w) = InlineWrapper (tidyVarOcc tidy_env w) -tidySrc _ inl_info = inl_info \end{code} Note [Tidy IdInfo] diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 83a40d299a..bbf9e0eb40 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -101,9 +101,9 @@ mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding mkDFunUnfolding bndrs con ops = DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = ops } -mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding -mkWwInlineRule id expr arity - = mkCoreUnfolding (InlineWrapper id) True +mkWwInlineRule :: CoreExpr -> Arity -> Unfolding +mkWwInlineRule expr arity + = mkCoreUnfolding InlineWrapper True (simpleOptExpr expr) arity (UnfWhen unSaturatedOk boringCxtNotOk) diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index ddf4406081..06f167cce0 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -139,33 +139,33 @@ Various possibilities suggest themselves: \begin{code} applyTypeToArg :: Type -> CoreExpr -> Type --- ^ Determines the type resulting from applying an expression to a function with the given type +-- ^ Determines the type resulting from applying an expression with given type +-- to a given argument expression applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty applyTypeToArg fun_ty _ = funResultTy fun_ty applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type -- ^ A more efficient version of 'applyTypeToArg' when we have several arguments. -- The first argument is just for debugging, and gives some context -applyTypeToArgs _ op_ty [] = op_ty - -applyTypeToArgs e op_ty (Type ty : args) - = -- Accumulate type arguments so we can instantiate all at once - go [ty] args +applyTypeToArgs e op_ty args + = go op_ty args where - go rev_tys (Type ty : args) = go (ty:rev_tys) args - go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args - where - op_ty' = applyTysD msg op_ty (reverse rev_tys) - msg = ptext (sLit "applyTypeToArgs") <+> - panic_msg e op_ty - -applyTypeToArgs e op_ty (_ : args) - = case (splitFunTy_maybe op_ty) of - Just (_, res_ty) -> applyTypeToArgs e res_ty args - Nothing -> pprPanic "applyTypeToArgs" (panic_msg e op_ty) - -panic_msg :: CoreExpr -> Type -> SDoc -panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty + go op_ty [] = op_ty + go op_ty (Type ty : args) = go_ty_args op_ty [ty] args + go op_ty (_ : args) | Just (_, res_ty) <- splitFunTy_maybe op_ty + = go res_ty args + go _ _ = pprPanic "applyTypeToArgs" panic_msg + + -- go_ty_args: accumulate type arguments so we can instantiate all at once + go_ty_args op_ty rev_tys (Type ty : args) + = go_ty_args op_ty (ty:rev_tys) args + go_ty_args op_ty rev_tys args + = go (applyTysD panic_msg_w_hdr op_ty (reverse rev_tys)) args + + panic_msg_w_hdr = hang (ptext (sLit "applyTypeToArgs")) 2 panic_msg + panic_msg = vcat [ ptext (sLit "Expression:") <+> pprCoreExpr e + , ptext (sLit "Type:") <+> ppr op_ty + , ptext (sLit "Args:") <+> ppr args ] \end{code} %************************************************************************ @@ -1623,10 +1623,10 @@ tryEtaReduce bndrs body -- for why we have an accumulating coercion go [] fun co | ok_fun fun - , let result = mkCast fun co - , not (any (`elemVarSet` exprFreeVars result) bndrs) - = Just result -- Check for any of the binders free in the result - -- including the accumulated coercion + , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co + , not (any (`elemVarSet` used_vars) bndrs) + = Just (mkCast fun co) -- Check for any of the binders free in the result + -- including the accumulated coercion go (b : bs) (App fun arg) co | Just co' <- ok_arg b arg co diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 0a6914e0b8..64e7d63590 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -422,7 +422,7 @@ instance Outputable UnfoldingGuidance where instance Outputable UnfoldingSource where ppr InlineCompulsory = ptext (sLit "Compulsory") - ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w + ppr InlineWrapper = ptext (sLit "Wrapper") ppr InlineStable = ptext (sLit "InlineStable") ppr InlineRhs = ptext (sLit "<vanilla>") diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 7a8fd2da70..218b00e8d0 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1127,6 +1127,19 @@ repSts (BodyStmt e _ _ _ : ss) = ; z <- repNoBindSt e2 ; (ss2,zs) <- repSts ss ; return (ss2, z : zs) } +repSts (ParStmt stmt_blocks _ _ : ss) = + do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks + ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1 + ss1 = concat ss_s + ; z <- repParSt stmt_blocks2 + ; (ss2, zs) <- addBinds ss1 (repSts ss) + ; return (ss1++ss2, z : zs) } + where + rep_stmt_block :: ParStmtBlock Name Name -> DsM ([GenSymBind], Core [TH.StmtQ]) + rep_stmt_block (ParStmtBlock stmts _ _) = + do { (ss1, zs) <- repSts (map unLoc stmts) + ; zs1 <- coreList stmtQTyConName zs + ; return (ss1, zs1) } repSts [LastStmt e _] = do { e2 <- repLE e ; z <- repNoBindSt e2 @@ -1618,6 +1631,9 @@ repLetSt (MkC ds) = rep2 letSName [ds] repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ) repNoBindSt (MkC e) = rep2 noBindSName [e] +repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ) +repParSt (MkC sss) = rep2 parSName [sss] + -------------- Range (Arithmetic sequences) ----------- repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ) repFrom (MkC x) = rep2 fromEName [x] diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index cb2538f574..db4c177b90 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -53,8 +53,9 @@ Global bindings (where clauses) type HsLocalBinds id = HsLocalBindsLR id id -data HsLocalBindsLR idL idR -- Bindings in a 'let' expression - -- or a 'where' clause +-- | Bindings in a 'let' expression +-- or a 'where' clause +data HsLocalBindsLR idL idR = HsValBinds (HsValBindsLR idL idR) | HsIPBinds (HsIPBinds idR) | EmptyLocalBinds @@ -62,15 +63,20 @@ data HsLocalBindsLR idL idR -- Bindings in a 'let' expression type HsValBinds id = HsValBindsLR id id -data HsValBindsLR idL idR -- Value bindings (not implicit parameters) - = ValBindsIn -- Before renaming RHS; idR is always RdrName - (LHsBindsLR idL idR) [LSig idR] -- Not dependency analysed - -- Recursive by default - - | ValBindsOut -- After renaming RHS; idR can be Name or Id - [(RecFlag, LHsBinds idL)] -- Dependency analysed, later bindings - -- in the list may depend on earlier - -- ones. +-- | Value bindings (not implicit parameters) +data HsValBindsLR idL idR + = -- | Before renaming RHS; idR is always RdrName + -- Not dependency analysed + -- Recursive by default + ValBindsIn + (LHsBindsLR idL idR) [LSig idR] + + -- | After renaming RHS; idR can be Name or Id + -- Dependency analysed, + -- later bindings in the list may depend on earlier + -- ones. + | ValBindsOut + [(RecFlag, LHsBinds idL)] [LSig Name] deriving (Data, Typeable) @@ -121,35 +127,38 @@ data HsBindLR idL idR fun_tick :: Maybe (Tickish Id) -- ^ Tick to put on the rhs, if any } - | PatBind { -- The pattern is never a simple variable; - -- That case is done by FunBind + -- | The pattern is never a simple variable; + -- That case is done by FunBind + | PatBind { pat_lhs :: LPat idL, pat_rhs :: GRHSs idR (LHsExpr idR), - pat_rhs_ty :: PostTcType, -- Type of the GRHSs - bind_fvs :: NameSet, -- See Note [Bind free vars] + pat_rhs_ty :: PostTcType, -- ^ Type of the GRHSs + bind_fvs :: NameSet, -- ^ See Note [Bind free vars] pat_ticks :: (Maybe (Tickish Id), [Maybe (Tickish Id)]) -- ^ Tick to put on the rhs, if any, and ticks to put on -- the bound variables. } - | VarBind { -- Dictionary binding and suchlike - var_id :: idL, -- All VarBinds are introduced by the type checker - var_rhs :: LHsExpr idR, -- Located only for consistency - var_inline :: Bool -- True <=> inline this binding regardless + -- | Dictionary binding and suchlike. + -- All VarBinds are introduced by the type checker + | VarBind { + var_id :: idL, + var_rhs :: LHsExpr idR, -- ^ Located only for consistency + var_inline :: Bool -- ^ True <=> inline this binding regardless -- (used for implication constraints only) } - | AbsBinds { -- Binds abstraction; TRANSLATION + | AbsBinds { -- Binds abstraction; TRANSLATION abs_tvs :: [TyVar], - abs_ev_vars :: [EvVar], -- Includes equality constraints + abs_ev_vars :: [EvVar], -- ^ Includes equality constraints - -- AbsBinds only gets used when idL = idR after renaming, + -- | AbsBinds only gets used when idL = idR after renaming, -- but these need to be idL's for the collect... code in HsUtil -- to have the right type abs_exports :: [ABExport idL], - abs_ev_binds :: TcEvBinds, -- Evidence bindings - abs_binds :: LHsBinds idL -- Typechecked user bindings + abs_ev_binds :: TcEvBinds, -- ^ Evidence bindings + abs_binds :: LHsBinds idL -- ^ Typechecked user bindings } deriving (Data, Typeable) @@ -166,15 +175,15 @@ data HsBindLR idL idR -- See Note [AbsBinds] data ABExport id - = ABE { abe_poly :: id -- Any INLINE pragmas is attached to this Id + = ABE { abe_poly :: id -- ^ Any INLINE pragmas is attached to this Id , abe_mono :: id - , abe_wrap :: HsWrapper -- See Note [AbsBinds wrappers] + , abe_wrap :: HsWrapper -- ^ See Note [AbsBinds wrappers] -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly - , abe_prags :: TcSpecPrags -- SPECIALISE pragmas + , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas } deriving (Data, Typeable) +-- | Used for the NameSet in FunBind and PatBind prior to the renamer placeHolderNames :: NameSet --- Used for the NameSet in FunBind and PatBind prior to the renamer placeHolderNames = panic "placeHolderNames" \end{code} @@ -501,43 +510,55 @@ serves for both. \begin{code} type LSig name = Located (Sig name) -data Sig name -- Signatures and pragmas - = -- An ordinary type signature - -- f :: Num a => a -> a +-- | Signatures and pragmas +data Sig name + = -- | An ordinary type signature + -- @f :: Num a => a -> a@ TypeSig [Located name] (LHsType name) - -- A type signature for a default method inside a class - -- default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool + -- | A type signature for a default method inside a class + -- + -- > default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool + -- | GenericSig [Located name] (LHsType name) - -- A type signature in generated code, notably the code + -- | A type signature in generated code, notably the code -- generated for record selectors. We simply record -- the desired Id itself, replete with its name, type -- and IdDetails. Otherwise it's just like a type -- signature: there should be an accompanying binding | IdSig Id - -- An ordinary fixity declaration - -- infixl *** 8 + -- | An ordinary fixity declaration + -- + -- > infixl *** 8 + -- | FixSig (FixitySig name) - -- An inline pragma - -- {#- INLINE f #-} + -- | An inline pragma + -- + -- > {#- INLINE f #-} + -- | InlineSig (Located name) -- Function name InlinePragma -- Never defaultInlinePragma - -- A specialisation pragma - -- {-# SPECIALISE f :: Int -> Int #-} - | SpecSig (Located name) -- Specialise a function or datatype ... + -- | A specialisation pragma + -- + -- > {-# SPECIALISE f :: Int -> Int #-} + -- + | SpecSig (Located name) -- Specialise a function or datatype ... (LHsType name) -- ... to these types - InlinePragma -- The pragma on SPECIALISE_INLINE form + InlinePragma -- The pragma on SPECIALISE_INLINE form. -- If it's just defaultInlinePragma, then we said -- SPECIALISE, not SPECIALISE_INLINE - -- A specialisation pragma for instance declarations only - -- {-# SPECIALISE instance Eq [Int] #-} - | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the - -- current instance decl + -- | A specialisation pragma for instance declarations only + -- + -- > {-# SPECIALISE instance Eq [Int] #-} + -- + -- (Class tys); should be a specialisation of the + -- current instance declaration + | SpecInstSig (LHsType name) deriving (Data, Typeable) @@ -545,9 +566,9 @@ type LFixitySig name = Located (FixitySig name) data FixitySig name = FixitySig (Located name) Fixity deriving (Data, Typeable) --- TsSpecPrags conveys pragmas from the type checker to the desugarer +-- | TsSpecPrags conveys pragmas from the type checker to the desugarer data TcSpecPrags - = IsDefaultMethod -- Super-specialised: a default method should + = IsDefaultMethod -- ^ Super-specialised: a default method should -- be macro-expanded at every call site | SpecPrags [LTcSpecPrag] deriving (Data, Typeable) @@ -556,9 +577,11 @@ type LTcSpecPrag = Located TcSpecPrag data TcSpecPrag = SpecPrag - Id -- The Id to be specialised - HsWrapper -- An wrapper, that specialises the polymorphic function - InlinePragma -- Inlining spec for the specialised function + Id + HsWrapper + InlinePragma + -- ^ The Id to be specialised, an wrapper that specialises the + -- polymorphic function, and inlining spec for the specialised function deriving (Data, Typeable) noSpecPrags :: TcSpecPrags @@ -572,9 +595,7 @@ isDefaultMethod :: TcSpecPrags -> Bool isDefaultMethod IsDefaultMethod = True isDefaultMethod (SpecPrags {}) = False -\end{code} -\begin{code} isFixityLSig :: LSig name -> Bool isFixityLSig (L _ (FixSig {})) = True isFixityLSig _ = False diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index ccbfc63a31..27286ca928 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -121,19 +121,19 @@ is Less Cool because \begin{code} -- | A Haskell expression. data HsExpr id - = HsVar id -- ^ variable - | HsIPVar HsIPName -- ^ implicit parameter + = HsVar id -- ^ Variable + | HsIPVar HsIPName -- ^ Implicit parameter | HsOverLit (HsOverLit id) -- ^ Overloaded literals | HsLit HsLit -- ^ Simple (non-overloaded) literals - | HsLam (MatchGroup id (LHsExpr id)) -- Currently always a single match + | HsLam (MatchGroup id (LHsExpr id)) -- ^ Lambda abstraction. Currently always a single match - | HsLamCase PostTcType (MatchGroup id (LHsExpr id)) -- Lambda-case + | HsLamCase PostTcType (MatchGroup id (LHsExpr id)) -- ^ Lambda-case - | HsApp (LHsExpr id) (LHsExpr id) -- Application + | HsApp (LHsExpr id) (LHsExpr id) -- ^ Application - -- Operator applications: + -- | Operator applications: -- NB Bracketed ops such as (+) come out as Vars. -- NB We need an expr for the operator in an OpApp/Section since @@ -144,17 +144,20 @@ data HsExpr id Fixity -- Renamer adds fixity; bottom until then (LHsExpr id) -- right operand - | NegApp (LHsExpr id) -- negated expr - (SyntaxExpr id) -- Name of 'negate' + -- | Negation operator. Contains the negated expression and the name + -- of 'negate' + | NegApp (LHsExpr id) + (SyntaxExpr id) - | HsPar (LHsExpr id) -- Parenthesised expr; see Note [Parens in HsSyn] + | HsPar (LHsExpr id) -- ^ Parenthesised expr; see Note [Parens in HsSyn] | SectionL (LHsExpr id) -- operand; see Note [Sections in HsSyn] (LHsExpr id) -- operator | SectionR (LHsExpr id) -- operator; see Note [Sections in HsSyn] (LHsExpr id) -- operand - | ExplicitTuple -- Used for explicit tuples and sections thereof + -- | Used for explicit tuples and sections thereof + | ExplicitTuple [HsTupArg id] Boxity @@ -168,9 +171,11 @@ data HsExpr id (LHsExpr id) -- then part (LHsExpr id) -- else part - | HsMultiIf PostTcType [LGRHS id (LHsExpr id)] -- Multi-way if + -- | Multi-way if + | HsMultiIf PostTcType [LGRHS id (LHsExpr id)] - | HsLet (HsLocalBinds id) -- let(rec) + -- | let(rec) + | HsLet (HsLocalBinds id) (LHsExpr id) | HsDo (HsStmtContext Name) -- The parameterisation is unimportant @@ -179,22 +184,24 @@ data HsExpr id [ExprLStmt id] -- "do":one or more stmts PostTcType -- Type of the whole expression - | ExplicitList -- syntactic list + -- | Syntactic list: [a,b,c,...] + | ExplicitList PostTcType -- Gives type of components of list (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness [LHsExpr id] - | ExplicitPArr -- syntactic parallel array: [:e1, ..., en:] + -- | Syntactic parallel array: [:e1, ..., en:] + | ExplicitPArr PostTcType -- type of elements of the parallel array [LHsExpr id] - -- Record construction + -- | Record construction | RecordCon (Located id) -- The constructor. After type checking -- it's the dataConWrapId of the constructor PostTcExpr -- Data con Id applied to type args (HsRecordBinds id) - -- Record update + -- | Record update | RecordUpd (LHsExpr id) (HsRecordBinds id) -- (HsMatchGroup Id) -- Filled in by the type checker to be @@ -207,7 +214,8 @@ data HsExpr id -- For a type family, the arg types are of the *instance* tycon, -- not the family tycon - | ExprWithTySig -- e :: type + -- | Expression with an explicit type signature. @e :: type@ + | ExprWithTySig (LHsExpr id) (LHsType id) @@ -216,12 +224,14 @@ data HsExpr id (LHsType Name) -- Retain the signature for -- round-tripping purposes - | ArithSeq -- Arithmetic sequence + -- | Arithmetic sequence + | ArithSeq PostTcExpr (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromList witness (ArithSeqInfo id) - | PArrSeq -- arith. sequence for parallel array + -- | Arithmetic sequence for parallel array + | PArrSeq PostTcExpr -- [:e1..e2:] or [:e1, e2..e3:] (ArithSeqInfo id) @@ -250,6 +260,7 @@ data HsExpr id ----------------------------------------------------------- -- Arrow notation extension + -- | @proc@ notation for Arrows | HsProc (LPat id) -- arrow abstraction, proc (LHsCmdTop id) -- body of the abstraction -- always has an empty stack @@ -315,20 +326,21 @@ data HsExpr id | HsUnboundVar RdrName deriving (Data, Typeable) --- HsTupArg is used for tuple sections +-- | HsTupArg is used for tuple sections -- (,a,) is represented by ExplicitTuple [Mising ty1, Present a, Missing ty3] -- Which in turn stands for (\x:ty1 \y:ty2. (x,a,y)) data HsTupArg id - = Present (LHsExpr id) -- The argument - | Missing PostTcType -- The argument is missing, but this is its type + = Present (LHsExpr id) -- ^ The argument + | Missing PostTcType -- ^ The argument is missing, but this is its type deriving (Data, Typeable) tupArgPresent :: HsTupArg id -> Bool tupArgPresent (Present {}) = True tupArgPresent (Missing {}) = False -type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be - -- pasted back in by the desugarer +-- | Typechecked splices, waiting to be +-- pasted back in by the desugarer +type PendingSplice = (Name, LHsExpr Id) \end{code} diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index b0bb88789d..c4c1bcd69e 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -414,5 +414,3 @@ getWayDescr dflags where tag = buildTag dflags -- if this is an unregisterised build, make sure our interfaces -- can't be used by a registerised build. - - diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 497c3ae525..8dc4188bb9 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -583,9 +583,7 @@ data IfaceUnfolding Bool -- OK to inline even if context is boring IfaceExpr - | IfExtWrapper Arity IfExtName -- NB: sometimes we need a IfExtName (not just IfLclName) - | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in - -- another module. + | IfWrapper IfaceExpr -- cf TcIface's Note [wrappers in interface files] | IfDFunUnfold [IfaceBndr] [IfaceExpr] @@ -600,20 +598,15 @@ instance Binary IfaceUnfolding where put_ bh b put_ bh c put_ bh d - put_ bh (IfLclWrapper a n) = do + put_ bh (IfWrapper e) = do putByte bh 2 - put_ bh a - put_ bh n - put_ bh (IfExtWrapper a n) = do - putByte bh 3 - put_ bh a - put_ bh n + put_ bh e put_ bh (IfDFunUnfold as bs) = do - putByte bh 4 + putByte bh 3 put_ bh as put_ bh bs put_ bh (IfCompulsory e) = do - putByte bh 5 + putByte bh 4 put_ bh e get bh = do h <- getByte bh @@ -626,13 +619,9 @@ instance Binary IfaceUnfolding where c <- get bh d <- get bh return (IfInlineRule a b c d) - 2 -> do a <- get bh - n <- get bh - return (IfLclWrapper a n) - 3 -> do a <- get bh - n <- get bh - return (IfExtWrapper a n) - 4 -> do as <- get bh + 2 -> do e <- get bh + return (IfWrapper e) + 3 -> do as <- get bh bs <- get bh return (IfDFunUnfold as bs) _ -> do e <- get bh @@ -1299,10 +1288,7 @@ instance Outputable IfaceUnfolding where ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok), pprParendIfaceExpr e] - ppr (IfLclWrapper a wkr) = ptext (sLit "Worker(lcl):") <+> ppr wkr - <+> parens (ptext (sLit "arity") <+> int a) - ppr (IfExtWrapper a wkr) = ptext (sLit "Worker(ext):") <+> ppr wkr - <+> parens (ptext (sLit "arity") <+> int a) + ppr (IfWrapper e) = ptext (sLit "Wrapper:") <+> parens (ppr e) ppr (IfDFunUnfold bs es) = hang (ptext (sLit "DFun:") <+> sep (map ppr bs) <> dot) 2 (sep (map pprParendIfaceExpr es)) @@ -1460,8 +1446,7 @@ freeNamesIfUnfold :: IfaceUnfolding -> NameSet freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e -freeNamesIfUnfold (IfExtWrapper _ v) = unitNameSet v -freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet +freeNamesIfUnfold (IfWrapper e) = freeNamesIfExpr e freeNamesIfUnfold (IfDFunUnfold bs es) = fnList freeNamesIfBndr bs &&& fnList freeNamesIfExpr es freeNamesIfExpr :: IfaceExpr -> NameSet diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 765bee2d6d..d3b56d1f7b 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1723,7 +1723,7 @@ toIfaceIdInfo id_info inline_hsinfo, unfold_hsinfo] of [] -> NoInfo infos -> HasInfo infos - -- NB: strictness must appear in the list before unfolding + -- NB: strictness and arity must appear in the list before unfolding -- See TcIface.tcUnfolding where ------------ Arity -------------- @@ -1762,10 +1762,7 @@ toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity -> case guidance of UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs _other -> IfCoreUnfold True if_rhs - InlineWrapper w | isExternalName n -> IfExtWrapper arity n - | otherwise -> IfLclWrapper arity (getFS n) - where - n = idName w + InlineWrapper -> IfWrapper if_rhs InlineCompulsory -> IfCompulsory if_rhs InlineRhs -> IfCoreUnfold False if_rhs -- Yes, even if guidance is UnfNever, expose the unfolding diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index ae517ec0ab..dffd69b9ed 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -34,7 +34,6 @@ import CoreSyn import CoreUtils import CoreUnfold import CoreLint -import WorkWrap ( mkWrapper ) import MkCore ( castBottomExpr ) import Id import MkId @@ -46,7 +45,7 @@ import DataCon import PrelNames import TysWiredIn import TysPrim ( superKindTyConName ) -import BasicTypes ( Arity, strongLoopBreaker ) +import BasicTypes ( strongLoopBreaker ) import Literal import qualified Var import VarEnv @@ -55,7 +54,7 @@ import Name import NameEnv import NameSet import OccurAnal ( occurAnalyseExpr ) -import Demand ( isBottomingSig ) +import Demand import Module import UniqFM import UniqSupply @@ -1205,6 +1204,25 @@ do_one (IfaceRec pairs) thing_inside %* * %************************************************************************ +Note [wrappers in interface files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to have a nice clever scheme in interface files for +wrappers. A wrapper's unfolding can be reconstructed from its worker's +id and its strictness. This decreased .hi file size (sometimes +significantly, for modules like GHC.Classes with many high-arity w/w +splits) and had a slight corresponding effect on compile times. + +However, when we added the second demand analysis, this scheme lead to +some Core lint errors. The second analysis could change the strictness +signatures, which sometimes resulted in a wrapper's regenerated +unfolding applying the wrapper to too many arguments. + +Instead of repairing the clever .hi scheme, we abandoned it in favor +of simplicity. The .hi sizes are usually insignificant (excluding the ++1M for base libraries), and compile time barely increases (~+1% for +nofib). The nicer upshot is that unfolding sources no longer include +an Id, so, eg, substitutions need not traverse them any longer. + \begin{code} tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails tcIdDetails _ IfVanillaId = return VanillaId @@ -1247,17 +1265,18 @@ tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding tcUnfolding name _ info (IfCoreUnfold stable if_expr) = do { dflags <- getDynFlags ; mb_expr <- tcPragExpr name if_expr - ; let unf_src = if stable then InlineStable else InlineRhs - ; return (case mb_expr of - Nothing -> NoUnfolding - Just expr -> mkUnfolding dflags unf_src - True {- Top level -} - is_bottoming - expr) } + ; let unf_src | stable = InlineStable + | otherwise = InlineRhs + ; return $ case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkUnfolding dflags unf_src + True {- Top level -} + (isBottomingSig strict_sig) + expr + } where -- Strictness should occur before unfolding! - is_bottoming = isBottomingSig $ strictnessInfo info - + strict_sig = strictnessInfo info tcUnfolding name _ _ (IfCompulsory if_expr) = do { mb_expr <- tcPragExpr name if_expr ; return (case mb_expr of @@ -1282,30 +1301,15 @@ tcUnfolding name dfun_ty _ (IfDFunUnfold bs ops) doc = text "Class ops for dfun" <+> ppr name (_, _, cls, _) = tcSplitDFunTy dfun_ty -tcUnfolding name ty info (IfExtWrapper arity wkr) - = tcIfaceWrapper name ty info arity (tcIfaceExtId wkr) -tcUnfolding name ty info (IfLclWrapper arity wkr) - = tcIfaceWrapper name ty info arity (tcIfaceLclId wkr) - -------------- -tcIfaceWrapper :: Name -> Type -> IdInfo -> Arity -> IfL Id -> IfL Unfolding -tcIfaceWrapper name ty info arity get_worker - = do { mb_wkr_id <- forkM_maybe doc get_worker - ; us <- newUniqueSupply - ; dflags <- getDynFlags - ; return (case mb_wkr_id of - Nothing -> noUnfolding - Just wkr_id -> make_inline_rule dflags wkr_id us) } +tcUnfolding name _ info (IfWrapper if_expr) + = do { mb_expr <- tcPragExpr name if_expr + ; return $ case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkWwInlineRule expr arity -- see Note [wrappers in interface files] + } where - doc = text "Worker for" <+> ppr name - - make_inline_rule dflags wkr_id us - = mkWwInlineRule wkr_id - (initUs_ us (mkWrapper dflags ty strict_sig) wkr_id) - arity - -- Again we rely here on strictness info - -- always appearing before unfolding - strict_sig = strictnessInfo info + -- Arity should occur before unfolding! + arity = arityInfo info \end{code} For unfoldings we try to do the job lazily, so that we never type check diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index c005a46873..8fc44ed81f 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -295,6 +295,9 @@ link NoLink _ _ _ link LinkBinary dflags batch_attempt_linking hpt = link' dflags batch_attempt_linking hpt +link LinkStaticLib dflags batch_attempt_linking hpt + = link' dflags batch_attempt_linking hpt + link LinkDynLib dflags batch_attempt_linking hpt = link' dflags batch_attempt_linking hpt @@ -311,6 +314,10 @@ link' dflags batch_attempt_linking hpt | batch_attempt_linking = do let + staticLink = case ghcLink dflags of + LinkStaticLib -> True + _ -> platformBinariesAreStaticLibs (targetPlatform dflags) + home_mod_infos = eltsUFM hpt -- the packages we depend on @@ -330,9 +337,9 @@ link' dflags batch_attempt_linking hpt let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) obj_files = concatMap getOfiles linkables - exe_file = exeFileName dflags + exe_file = exeFileName staticLink dflags - linking_needed <- linkingNeeded dflags linkables pkg_deps + linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps if not (gopt Opt_ForceRecomp dflags) && not linking_needed then do debugTraceMsg dflags 2 (text exe_file <+> ptext (sLit "is up to date, linking not required.")) @@ -343,9 +350,10 @@ link' dflags batch_attempt_linking hpt -- Don't showPass in Batch mode; doLink will do that for us. let link = case ghcLink dflags of - LinkBinary -> linkBinary - LinkDynLib -> linkDynLibCheck - other -> panicBadLink other + LinkBinary -> linkBinary + LinkStaticLib -> linkStaticLibCheck + LinkDynLib -> linkDynLibCheck + other -> panicBadLink other link dflags obj_files pkg_deps debugTraceMsg dflags 3 (text "link: done") @@ -359,12 +367,12 @@ link' dflags batch_attempt_linking hpt return Succeeded -linkingNeeded :: DynFlags -> [Linkable] -> [PackageId] -> IO Bool -linkingNeeded dflags linkables pkg_deps = do +linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [PackageId] -> IO Bool +linkingNeeded dflags staticLink linkables pkg_deps = do -- if the modification time on the executable is later than the -- modification times on all of the objects and libraries, then omit -- linking (unless the -fforce-recomp flag was given). - let exe_file = exeFileName dflags + let exe_file = exeFileName staticLink dflags e_exe_time <- tryIO $ getModificationUTCTime exe_file case e_exe_time of Left _ -> return True @@ -482,10 +490,11 @@ doLink dflags stop_phase o_files | otherwise = case ghcLink dflags of - NoLink -> return () - LinkBinary -> linkBinary dflags o_files [] - LinkDynLib -> linkDynLibCheck dflags o_files [] - other -> panicBadLink other + NoLink -> return () + LinkBinary -> linkBinary dflags o_files [] + LinkStaticLib -> linkStaticLibCheck dflags o_files [] + LinkDynLib -> linkDynLibCheck dflags o_files [] + other -> panicBadLink other -- --------------------------------------------------------------------------- @@ -1770,11 +1779,14 @@ getHCFilePackages filename = -- the packages. linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO () -linkBinary dflags o_files dep_packages = do +linkBinary = linkBinary' False + +linkBinary' :: Bool -> DynFlags -> [FilePath] -> [PackageId] -> IO () +linkBinary' staticLink dflags o_files dep_packages = do let platform = targetPlatform dflags mySettings = settings dflags verbFlags = getVerbFlags dflags - output_fn = exeFileName dflags + output_fn = exeFileName staticLink dflags -- get the full list of packages to link with, by combining the -- explicit packages with the auto packages and all of their @@ -1815,13 +1827,15 @@ linkBinary dflags o_files dep_packages = do extraLinkObj <- mkExtraObjToLinkIntoBinary dflags noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages - pkg_link_opts <- if platformBinariesAreStaticLibs platform - then -- If building an executable really means - -- making a static library (e.g. iOS), then - -- we don't want the options (like -lm) - -- that getPackageLinkOpts gives us. #7720 - return [] - else getPackageLinkOpts dflags dep_packages + pkg_link_opts <- do + (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages + return $ if staticLink + then package_hs_libs -- If building an executable really means making a static + -- library (e.g. iOS), then we only keep the -l options for + -- HS packages, because libtool doesn't accept other options. + -- In the case of iOS these need to be added by hand to the + -- final link in Xcode. + else package_hs_libs ++ extra_libs ++ other_flags pkg_framework_path_opts <- if platformUsesFrameworks platform @@ -1869,14 +1883,17 @@ linkBinary dflags o_files dep_packages = do let os = platformOS (targetPlatform dflags) in if os == OSOsf3 then ["-lpthread", "-lexc"] else if os `elem` [OSMinGW32, OSFreeBSD, OSOpenBSD, - OSNetBSD, OSHaiku, OSQNXNTO] + OSNetBSD, OSHaiku, OSQNXNTO, OSiOS] then [] else ["-lpthread"] | otherwise = [] rc_objs <- maybeCreateManifest dflags output_fn - SysTools.runLink dflags ( + let link = if staticLink + then SysTools.runLibtool + else SysTools.runLink + link dflags ( map SysTools.Option verbFlags ++ [ SysTools.Option "-o" , SysTools.FileOption "" output_fn @@ -1899,6 +1916,7 @@ linkBinary dflags o_files dep_packages = do -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog -- on x86. ++ (if sLdSupportsCompactUnwind mySettings && + not staticLink && platformOS platform == OSDarwin && platformArch platform `elem` [ArchX86, ArchX86_64] then ["-Wl,-no_compact_unwind"] @@ -1911,7 +1929,8 @@ linkBinary dflags o_files dep_packages = do -- whether this is something we ought to fix, but -- for now this flags silences them. ++ (if platformOS platform == OSDarwin && - platformArch platform == ArchX86 + platformArch platform == ArchX86 && + not staticLink then ["-Wl,-read_only_relocs,suppress"] else []) @@ -1937,17 +1956,20 @@ linkBinary dflags o_files dep_packages = do throwGhcExceptionIO (InstallationError ("cannot move binary")) -exeFileName :: DynFlags -> FilePath -exeFileName dflags +exeFileName :: Bool -> DynFlags -> FilePath +exeFileName staticLink dflags | Just s <- outputFile dflags = - case platformOS (targetPlatform dflags) of + case platformOS (targetPlatform dflags) of OSMinGW32 -> s <?.> "exe" - OSiOS -> s <?.> "a" - _ -> s + _ -> if staticLink + then s <?.> "a" + else s | otherwise = if platformOS (targetPlatform dflags) == OSMinGW32 then "main.exe" - else "a.out" + else if staticLink + then "liba.a" + else "a.out" where s <?.> ext | null (takeExtension s) = s <.> ext | otherwise = s @@ -2014,6 +2036,13 @@ linkDynLibCheck dflags o_files dep_packages linkDynLib dflags o_files dep_packages +linkStaticLibCheck :: DynFlags -> [String] -> [PackageId] -> IO () +linkStaticLibCheck dflags o_files dep_packages + = do + when (platformOS (targetPlatform dflags) `notElem` [OSiOS, OSDarwin]) $ + throwGhcExceptionIO (ProgramError "Static archive creation only supported on Darwin/OS X/iOS") + linkBinary' True dflags o_files dep_packages + -- ----------------------------------------------------------------------------- -- Running CPP diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 89ba319238..37b016b4ad 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -66,7 +66,7 @@ module DynFlags ( ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, extraGccViaCFlags, systemPackageConfig, pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T, - pgm_sysman, pgm_windres, pgm_lo, pgm_lc, + pgm_sysman, pgm_windres, pgm_libtool, pgm_lo, pgm_lc, opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_windres, opt_lo, opt_lc, @@ -101,6 +101,7 @@ module DynFlags ( flagsPackage, supportedLanguagesAndExtensions, + languageExtensions, -- ** DynFlags C compiler options picCCOpts, picPOpts, @@ -277,6 +278,7 @@ data GeneralFlag -- optimisation opts | Opt_Strictness + | Opt_LateDmdAnal | Opt_KillAbsence | Opt_KillOneShot | Opt_FullLaziness @@ -500,6 +502,7 @@ data ExtensionFlag | Opt_TypeFamilies | Opt_OverloadedStrings | Opt_OverloadedLists + | Opt_NumDecimals | Opt_DisambiguateRecordFields | Opt_RecordWildCards | Opt_RecordPuns @@ -513,7 +516,7 @@ data ExtensionFlag | Opt_PolyKinds -- Kind polymorphism | Opt_DataKinds -- Datatype promotion | Opt_InstanceSigs - + | Opt_StandaloneDeriving | Opt_DeriveDataTypeable | Opt_AutoDeriveTypeable -- Automatic derivation of Typeable @@ -583,6 +586,8 @@ data DynFlags = DynFlags { -- during the upsweep, where Nothing ==> compile as -- many in parallel as there are CPUs. + maxRelevantBinds :: Maybe Int, -- ^ Maximum number of bindings from the type envt + -- to show in type error messages simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function @@ -591,6 +596,7 @@ data DynFlags = DynFlags { liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating -- See CoreMonad.FloatOutSwitches + historySize :: Int, cmdlineHcIncludes :: [String], -- ^ @\-\#includes@ @@ -803,6 +809,7 @@ data Settings = Settings { sPgm_T :: String, sPgm_sysman :: String, sPgm_windres :: String, + sPgm_libtool :: String, sPgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser sPgm_lc :: (String,[Option]), -- LLVM: llc static compiler -- options for particular phases @@ -858,6 +865,8 @@ pgm_sysman :: DynFlags -> String pgm_sysman dflags = sPgm_sysman (settings dflags) pgm_windres :: DynFlags -> String pgm_windres dflags = sPgm_windres (settings dflags) +pgm_libtool :: DynFlags -> String +pgm_libtool dflags = sPgm_libtool (settings dflags) pgm_lo :: DynFlags -> (String,[Option]) pgm_lo dflags = sPgm_lo (settings dflags) pgm_lc :: DynFlags -> (String,[Option]) @@ -953,6 +962,7 @@ data GhcLink | LinkInMemory -- ^ Use the in-memory dynamic linker (works for both -- bytecode and object code). | LinkDynLib -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms) + | LinkStaticLib -- ^ Link objects into a static lib deriving (Eq, Show) isNoLink :: GhcLink -> Bool @@ -1249,12 +1259,14 @@ defaultDynFlags mySettings = maxSimplIterations = 4, shouldDumpSimplPhase = Nothing, ruleCheck = Nothing, + maxRelevantBinds = Just 6, simplTickFactor = 100, specConstrThreshold = Just 2000, specConstrCount = Just 3, specConstrRecursive = 3, liberateCaseThreshold = Just 2000, floatLamArgs = Just 0, -- Default: float only if no fvs + historySize = 20, strictnessBefore = [], @@ -1681,7 +1693,7 @@ setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, setPgmP, addOptl, addOptc, addOptP, - addCmdlineFramework, addHaddockOpts, addGhciScript, + addCmdlineFramework, addHaddockOpts, addGhciScript, setInteractivePrint :: String -> DynFlags -> DynFlags setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce @@ -1966,7 +1978,7 @@ safeFlagCheck cmdl dflags = apFix f = if safeInferOn dflags then id else f - safeFailure loc str + safeFailure loc str = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " ++ str] {- ********************************************************************** @@ -2056,6 +2068,7 @@ dynamic_flags = [ , Flag "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) , Flag "pgmdll" (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])}))) , Flag "pgmwindres" (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f}))) + , Flag "pgmlibtool" (hasArg (\f -> alterSettings (\s -> s { sPgm_libtool = f}))) -- need to appear before -optl/-opta to be parsed as LLVM flags. , Flag "optlo" (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s}))) @@ -2090,6 +2103,7 @@ dynamic_flags = [ -------- Linking ---------------------------------------------------- , Flag "no-link" (noArg (\d -> d{ ghcLink=NoLink })) , Flag "shared" (noArg (\d -> d{ ghcLink=LinkDynLib })) + , Flag "staticlib" (noArg (\d -> d{ ghcLink=LinkStaticLib })) , Flag "dynload" (hasArg parseDynLibLoaderMode) , Flag "dylib-install-name" (hasArg setDylibInstallName) -- -dll-split is an internal flag, used only during the GHC build @@ -2293,6 +2307,9 @@ dynamic_flags = [ , Flag "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1))) -- If the number is missing, use 1 + + , Flag "fmax-relevant-binds" (intSuffix (\n d -> d{ maxRelevantBinds = Just n })) + , Flag "fno-max-relevant-binds" (noArg (\d -> d{ maxRelevantBinds = Nothing })) , Flag "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n })) , Flag "fmax-simplifier-iterations" (intSuffix (\n d -> d{ maxSimplIterations = n })) , Flag "fsimpl-tick-factor" (intSuffix (\n d -> d{ simplTickFactor = n })) @@ -2308,6 +2325,7 @@ dynamic_flags = [ , Flag "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) , Flag "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) , Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) + , Flag "fhistory-size" (intSuffix (\n d -> d{ historySize = n })) , Flag "funfolding-creation-threshold" (intSuffix (\n d -> d {ufCreationThreshold = n})) @@ -2512,6 +2530,7 @@ fFlags = [ ( "error-spans", Opt_ErrorSpans, nop ), ( "print-explicit-foralls", Opt_PrintExplicitForalls, nop ), ( "strictness", Opt_Strictness, nop ), + ( "late-dmd-anal", Opt_LateDmdAnal, nop ), ( "specialise", Opt_Specialise, nop ), ( "float-in", Opt_FloatIn, nop ), ( "static-argument-transformation", Opt_StaticArgumentTransformation, nop ), @@ -2578,7 +2597,7 @@ fFlags = [ fLangFlags :: [FlagSpec ExtensionFlag] fLangFlags = [ ( "th", Opt_TemplateHaskell, - \on -> deprecatedForExtension "TemplateHaskell" on + \on -> deprecatedForExtension "TemplateHaskell" on >> checkTemplateHaskellOk on ), ( "fi", Opt_ForeignFunctionInterface, deprecatedForExtension "ForeignFunctionInterface" ), @@ -2670,7 +2689,7 @@ xFlags = [ ( "TypeOperators", Opt_TypeOperators, nop ), ( "ExplicitNamespaces", Opt_ExplicitNamespaces, nop ), ( "RecursiveDo", Opt_RecursiveDo, nop ), -- Enables 'mdo' and 'rec' - ( "DoRec", Opt_RecursiveDo, + ( "DoRec", Opt_RecursiveDo, deprecatedForExtension "RecursiveDo" ), ( "Arrows", Opt_Arrows, nop ), ( "ParallelArrays", Opt_ParallelArrays, nop ), @@ -2683,6 +2702,7 @@ xFlags = [ deprecatedForExtension "NamedFieldPuns" ), ( "DisambiguateRecordFields", Opt_DisambiguateRecordFields, nop ), ( "OverloadedStrings", Opt_OverloadedStrings, nop ), + ( "NumDecimals", Opt_NumDecimals, nop), ( "OverloadedLists", Opt_OverloadedLists, nop), ( "GADTs", Opt_GADTs, nop ), ( "GADTSyntax", Opt_GADTSyntax, nop ), diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index e925e0648d..5fc21f3084 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -310,7 +310,7 @@ load how_much = do let main_mod = mainModIs dflags a_root_is_Main = any ((==main_mod).ms_mod) mod_graph - do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib + do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib when (ghcLink dflags == LinkBinary && isJust ofile && not do_linking) $ diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs index 66034e0b50..68b4e2b2a2 100644 --- a/compiler/main/GhcMonad.hs +++ b/compiler/main/GhcMonad.hs @@ -97,6 +97,10 @@ data Session = Session !(IORef HscEnv) instance Functor Ghc where fmap f m = Ghc $ \s -> f `fmap` unGhc m s +instance Applicative Ghc where + pure = return + g <*> m = do f <- g; a <- m; return (f a) + instance Monad Ghc where return a = Ghc $ \_ -> return a m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s @@ -157,6 +161,10 @@ liftGhcT m = GhcT $ \_ -> m instance Functor m => Functor (GhcT m) where fmap f m = GhcT $ \s -> f `fmap` unGhcT m s +instance Applicative m => Applicative (GhcT m) where + pure x = GhcT $ \_ -> pure x + g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s + instance Monad m => Monad (GhcT m) where return x = GhcT $ \_ -> return x m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index cc8dfe3eb7..fb832ff2e3 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -867,16 +867,19 @@ getPackageLibraryPath dflags pkgs = collectLibraryPaths :: [PackageConfig] -> [FilePath] collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps)) --- | Find all the link options in these and the preload packages -getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String] +-- | Find all the link options in these and the preload packages, +-- returning (package hs lib options, extra library options, other flags) +getPackageLinkOpts :: DynFlags -> [PackageId] -> IO ([String], [String], [String]) getPackageLinkOpts dflags pkgs = collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs -collectLinkOpts :: DynFlags -> [PackageConfig] -> [String] -collectLinkOpts dflags ps = concat (map all_opts ps) - where - libs p = packageHsLibs dflags p ++ extraLibraries p - all_opts p = map ("-l" ++) (libs p) ++ ldOptions p +collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String]) +collectLinkOpts dflags ps = + ( + concatMap (map ("-l" ++) . packageHsLibs dflags) ps, + concatMap (map ("-l" ++) . extraLibraries) ps, + concatMap ldOptions ps + ) packageHsLibs :: DynFlags -> PackageConfig -> [String] packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index ebc197473d..1b83592118 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -15,7 +15,7 @@ module SysTools ( runUnlit, runCpp, runCc, -- [Option] -> IO () runPp, -- [Option] -> IO () runSplit, -- [Option] -> IO () - runAs, runLink, -- [Option] -> IO () + runAs, runLink, runLibtool, -- [Option] -> IO () runMkDLL, runWindres, runLlvmOpt, @@ -261,6 +261,7 @@ initSysTools mbMinusB split_script = installed cGHC_SPLIT_PGM windres_path <- getSetting "windres command" + libtool_path <- getSetting "libtool command" tmpdir <- getTemporaryDirectory @@ -331,6 +332,7 @@ initSysTools mbMinusB sPgm_T = touch_path, sPgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan", sPgm_windres = windres_path, + sPgm_libtool = libtool_path, sPgm_lo = (lo_prog,[]), sPgm_lc = (lc_prog,[]), -- Hans: this isn't right in general, but you can @@ -717,6 +719,15 @@ runLink dflags args = do mb_env <- getGccEnv args2 runSomethingFiltered dflags id "Linker" p args2 mb_env +runLibtool :: DynFlags -> [Option] -> IO () +runLibtool dflags args = do + linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags + let args1 = map Option (getOpts dflags opt_l) + args2 = [Option "-static"] ++ args1 ++ args ++ linkargs + libtool = pgm_libtool dflags + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "Linker" libtool args2 mb_env + runMkDLL :: DynFlags -> [Option] -> IO () runMkDLL dflags args = do let (p,args0) = pgm_dll dflags @@ -1243,7 +1254,8 @@ linkDynLib dflags0 o_files dep_packages pkgs _ -> filter ((/= rtsPackageId) . packageConfigId) pkgs - let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts + let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts + in package_hs_libs ++ extra_libs ++ other_flags -- probably _stub.o files let extra_ld_inputs = ldInputs dflags @@ -1338,6 +1350,7 @@ linkDynLib dflags0 o_files dep_packages ++ map Option pkg_lib_path_opts ++ map Option pkg_link_opts ) + OSiOS -> throwGhcExceptionIO (ProgramError "dynamic libraries are not supported on iOS target") _ -> do ------------------------------------------------------------------- -- Making a DSO diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 174054ee61..214e7f3315 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -815,12 +815,7 @@ dffvLetBndr vanilla_unfold id = case src of InlineRhs | vanilla_unfold -> dffvExpr rhs | otherwise -> return () - InlineWrapper v -> insert v _ -> dffvExpr rhs - -- For a wrapper, externalise the wrapper id rather than the - -- fvs of the rhs. The two usually come down to the same thing - -- but I've seen cases where we had a wrapper id $w but a - -- rhs where $w had been inlined; see Trac #3922 go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) = extendScopeList bndrs $ mapM_ dffvExpr args diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 203e1e271c..cdd53d199b 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -41,6 +41,7 @@ import Data.Map ( Map ) import qualified Data.Map as Map import Data.List ( partition, (\\), find ) import qualified Data.Set as Set +import System.FilePath ((</>)) import System.IO \end{code} @@ -1468,7 +1469,7 @@ printMinimalImports imports_w_usage ; this_mod <- getModule ; dflags <- getDynFlags ; liftIO $ - do { h <- openFile (mkFilename this_mod) WriteMode + do { h <- openFile (mkFilename dflags this_mod) WriteMode ; printForUser dflags h neverQualify (vcat (map ppr imports')) } -- The neverQualify is important. We are printing Names -- but they are in the context of an 'import' decl, and @@ -1477,7 +1478,11 @@ printMinimalImports imports_w_usage -- not import Blag( Blag.f, Blag.g )! } where - mkFilename this_mod = moduleNameString (moduleName this_mod) ++ ".imports" + mkFilename dflags this_mod + | Just d <- dumpDir dflags = d </> basefn + | otherwise = basefn + where + basefn = moduleNameString (moduleName this_mod) ++ ".imports" mk_minimal (L l decl, used, unused) | null unused diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 205dde1969..90a83d6a8e 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -10,7 +10,6 @@ general, all of these functions return a renamed thing, and a set of free variables. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See @@ -27,8 +26,8 @@ module RnPat (-- main entry points rnHsRecFields1, HsRecFieldContext(..), - -- Literals - rnLit, rnOverLit, + -- Literals + rnLit, rnOverLit, -- Pattern Error messages that are also used elsewhere checkTupSize, patSigErr @@ -39,13 +38,13 @@ module RnPat (-- main entry points import {-# SOURCE #-} RnExpr ( rnLExpr ) #ifdef GHCI import {-# SOURCE #-} TcSplice ( runQuasiQuotePat ) -#endif /* GHCI */ +#endif /* GHCI */ #include "HsVersions.h" import HsSyn import TcRnMonad -import TcHsSyn ( hsOverLitName ) +import TcHsSyn ( hsOverLitName ) import RnEnv import RnTypes import DynFlags @@ -55,21 +54,22 @@ import NameSet import RdrName import BasicTypes import Util -import ListSetOps ( removeDups ) +import ListSetOps ( removeDups ) import Outputable import SrcLoc import FastString -import Literal ( inCharRange ) -import Control.Monad ( when ) +import Literal ( inCharRange ) import TysWiredIn ( nilDataCon ) import DataCon ( dataConName ) +import Control.Monad ( when ) +import Data.Ratio \end{code} %********************************************************* -%* * - The CpsRn Monad -%* * +%* * + The CpsRn Monad +%* * %********************************************************* Note [CpsRn monad] @@ -77,7 +77,7 @@ Note [CpsRn monad] The CpsRn monad uses continuation-passing style to support this style of programming: - do { ... + do { ... ; ns <- bindNames rs ; ...blah... } @@ -96,7 +96,7 @@ p1 scope over p2,p3. \begin{code} newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars) } - -- See Note [CpsRn monad] + -- See Note [CpsRn monad] instance Monad CpsRn where return x = CpsRn (\k -> k x) @@ -144,9 +144,9 @@ pattern, because it never occurs in a constructed position. See Trac #7336. %********************************************************* -%* * - Name makers -%* * +%* * + Name makers +%* * %********************************************************* Externally abstract type of name makers, @@ -154,13 +154,13 @@ which is how you go from a RdrName to a Name \begin{code} data NameMaker - = LamMk -- Lambdas - Bool -- True <=> report unused bindings - -- (even if True, the warning only comes out - -- if -fwarn-unused-matches is on) + = LamMk -- Lambdas + Bool -- True <=> report unused bindings + -- (even if True, the warning only comes out + -- if -fwarn-unused-matches is on) | LetMk -- Let bindings, incl top level - -- Do *not* check for unused bindings + -- Do *not* check for unused bindings TopLevelFlag MiniFixityEnv @@ -186,21 +186,21 @@ rnHsSigCps sig newPatName :: NameMaker -> Located RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name = CpsRn (\ thing_inside -> - do { name <- newLocalBndrRn rdr_name - ; (res, fvs) <- bindLocalName name (thing_inside name) - ; when report_unused $ warnUnusedMatches [name] fvs - ; return (res, name `delFV` fvs) }) + do { name <- newLocalBndrRn rdr_name + ; (res, fvs) <- bindLocalName name (thing_inside name) + ; when report_unused $ warnUnusedMatches [name] fvs + ; return (res, name `delFV` fvs) }) newPatName (LetMk is_top fix_env) rdr_name = CpsRn (\ thing_inside -> do { name <- case is_top of NotTopLevel -> newLocalBndrRn rdr_name TopLevel -> newTopSrcBinder rdr_name - ; bindLocalName name $ -- Do *not* use bindLocalNameFV here - -- See Note [View pattern usage] + ; bindLocalName name $ -- Do *not* use bindLocalNameFV here + -- See Note [View pattern usage] addLocalFixities fix_env [name] $ - thing_inside name }) - + thing_inside name }) + -- Note: the bindLocalName is somewhat suspicious -- because it binds a top-level name as a local name. -- however, this binding seems to work, and it only exists for @@ -219,9 +219,9 @@ report unused variables at the binding level. So we must use bindLocalName here, *not* bindLocalNameFV. Trac #3943. %********************************************************* -%* * - External entry points -%* * +%* * + External entry points +%* * %********************************************************* There are various entry points to renaming patterns, depending on @@ -230,8 +230,8 @@ There are various entry points to renaming patterns, depending on (e.g., in a case or lambda, but not in a let or at the top-level, because of the way mutually recursive bindings are handled) (3) whether the a type signature in the pattern can bind - lexically-scoped type variables (for unpacking existential - type vars in data constructors) + lexically-scoped type variables (for unpacking existential + type vars in data constructors) (4) whether we do duplicate and unused variable checking (5) whether there are fixity declarations associated with the names bound by the patterns that need to be brought into scope with them. @@ -251,18 +251,18 @@ rnPats :: HsMatchContext Name -- for error messages -> ([LPat Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnPats ctxt pats thing_inside - = do { envs_before <- getRdrEnvs + = do { envs_before <- getRdrEnvs - -- (1) rename the patterns, bringing into scope all of the term variables - -- (2) then do the thing inside. - ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do + -- (1) rename the patterns, bringing into scope all of the term variables + -- (2) then do the thing inside. + ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do { -- Check for duplicated and shadowed names - -- Must do this *after* renaming the patterns - -- See Note [Collect binders only after renaming] in HsUtils + -- Must do this *after* renaming the patterns + -- See Note [Collect binders only after renaming] in HsUtils -- Because we don't bind the vars all at once, we can't - -- check incrementally for duplicates; - -- Nor can we check incrementally for shadowing, else we'll - -- complain *twice* about duplicates e.g. f (x,x) = ... + -- check incrementally for duplicates; + -- Nor can we check incrementally for shadowing, else we'll + -- complain *twice* about duplicates e.g. f (x,x) = ... ; addErrCtxt doc_pat $ checkDupAndShadowedNames envs_before $ collectPatsBinders pats' @@ -274,7 +274,7 @@ rnPat :: HsMatchContext Name -- for error messages -> LPat RdrName -> (LPat Name -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -- Variables bound by pattern do not - -- appear in the result FreeVars + -- appear in the result FreeVars rnPat ctxt pat thing_inside = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat') @@ -283,7 +283,7 @@ applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatName mk rdr); return n } -- ----------- Entry point 2: rnBindPat ------------------- -- Binds local names; in a recursive scope that involves other bound vars --- e.g let { (x, Just y) = e1; ... } in ... +-- e.g let { (x, Just y) = e1; ... } in ... -- * does NOT allows type sig to bind type vars -- * local namemaker -- * no unused and duplicate checking @@ -299,9 +299,9 @@ rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat) %********************************************************* -%* * - The main event -%* * +%* * + The main event +%* * %********************************************************* \begin{code} @@ -356,9 +356,9 @@ rnPatAndThen mk (LitPat lit) rnPatAndThen _ (NPat lit mb_neg _eq) = do { lit' <- liftCpsFV $ rnOverLit lit ; mb_neg' <- liftCpsFV $ case mb_neg of - Nothing -> return (Nothing, emptyFVs) - Just _ -> do { (neg, fvs) <- lookupSyntaxName negateName - ; return (Just neg, fvs) } + Nothing -> return (Nothing, emptyFVs) + Just _ -> do { (neg, fvs) <- lookupSyntaxName negateName + ; return (Just neg, fvs) } ; eq' <- liftCpsFV $ lookupSyntaxName eqName ; return (NPat lit' mb_neg' eq') } @@ -368,7 +368,7 @@ rnPatAndThen mk (NPlusKPat rdr lit _ _) ; minus <- liftCpsFV $ lookupSyntaxName minusName ; ge <- liftCpsFV $ lookupSyntaxName geName ; return (NPlusKPat (L (nameSrcSpan new_name) new_name) lit' ge minus) } - -- The Report says that n+k patterns must be in Integral + -- The Report says that n+k patterns must be in Integral rnPatAndThen mk (AsPat rdr pat) = do { new_name <- newPatName mk rdr @@ -418,7 +418,7 @@ rnPatAndThen mk (QuasiQuotePat qq) = do { pat <- liftCps $ runQuasiQuotePat qq ; L _ pat' <- rnLPatAndThen mk pat ; return pat' } -#endif /* GHCI */ +#endif /* GHCI */ rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat) @@ -430,27 +430,27 @@ rnConPatAndThen :: NameMaker -> CpsRn (Pat Name) rnConPatAndThen mk con (PrefixCon pats) - = do { con' <- lookupConCps con - ; pats' <- rnLPatsAndThen mk pats - ; return (ConPatIn con' (PrefixCon pats')) } + = do { con' <- lookupConCps con + ; pats' <- rnLPatsAndThen mk pats + ; return (ConPatIn con' (PrefixCon pats')) } rnConPatAndThen mk con (InfixCon pat1 pat2) - = do { con' <- lookupConCps con - ; pat1' <- rnLPatAndThen mk pat1 - ; pat2' <- rnLPatAndThen mk pat2 - ; fixity <- liftCps $ lookupFixityRn (unLoc con') - ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' } + = do { con' <- lookupConCps con + ; pat1' <- rnLPatAndThen mk pat1 + ; pat2' <- rnLPatAndThen mk pat2 + ; fixity <- liftCps $ lookupFixityRn (unLoc con') + ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' } rnConPatAndThen mk con (RecCon rpats) - = do { con' <- lookupConCps con - ; rpats' <- rnHsRecPatsAndThen mk con' rpats - ; return (ConPatIn con' (RecCon rpats')) } + = do { con' <- lookupConCps con + ; rpats' <- rnHsRecPatsAndThen mk con' rpats + ; return (ConPatIn con' (RecCon rpats')) } -------------------- rnHsRecPatsAndThen :: NameMaker - -> Located Name -- Constructor - -> HsRecFields RdrName (LPat RdrName) - -> CpsRn (HsRecFields Name (LPat Name)) + -> Located Name -- Constructor + -> HsRecFields RdrName (LPat RdrName) + -> CpsRn (HsRecFields Name (LPat Name)) rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) = do { flds <- liftCpsFV $ rnHsRecFields1 (HsRecFieldPat con) VarPat hs_rec_fields ; flds' <- mapM rn_field (flds `zip` [1..]) @@ -460,7 +460,7 @@ rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) (hsRecFieldArg fld) ; return (fld { hsRecFieldArg = arg' }) } - -- Suppress unused-match reporting for fields introduced by ".." + -- Suppress unused-match reporting for fields introduced by ".." nested_mk Nothing mk _ = mk nested_mk (Just _) mk@(LetMk {}) _ = mk nested_mk (Just n) (LamMk report_unused) n' = LamMk (report_unused && (n' <= n)) @@ -468,9 +468,9 @@ rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) %************************************************************************ -%* * - Record fields -%* * +%* * + Record fields +%* * %************************************************************************ \begin{code} @@ -504,21 +504,21 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } ; return (all_flds, mkFVs (getFieldIds all_flds)) } where mb_con = case ctxt of - HsRecFieldCon con | not (isUnboundName con) -> Just con - HsRecFieldPat con | not (isUnboundName con) -> Just con - _other -> Nothing - -- The unbound name test is because if the constructor - -- isn't in scope the constructor lookup will add an error - -- add an error, but still return an unbound name. - -- We don't want that to screw up the dot-dot fill-in stuff. + HsRecFieldCon con | not (isUnboundName con) -> Just con + HsRecFieldPat con | not (isUnboundName con) -> Just con + _other -> Nothing + -- The unbound name test is because if the constructor + -- isn't in scope the constructor lookup will add an error + -- add an error, but still return an unbound name. + -- We don't want that to screw up the dot-dot fill-in stuff. doc = case mb_con of Nothing -> ptext (sLit "constructor field name") Just con -> ptext (sLit "field of constructor") <+> quotes (ppr con) rn_fld pun_ok parent (HsRecField { hsRecFieldId = fld - , hsRecFieldArg = arg - , hsRecPun = pun }) + , hsRecFieldArg = arg + , hsRecPun = pun }) = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc True parent doc) fld ; arg' <- if pun then do { checkErr pun_ok (badPun fld) @@ -528,31 +528,31 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } , hsRecFieldArg = arg' , hsRecPun = pun }) } - rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat - -> Maybe Name -- The constructor (Nothing for an update - -- or out of scope constructor) - -> [HsRecField Name (Located arg)] -- Explicit fields - -> RnM [HsRecField Name (Located arg)] -- Filled in .. fields + rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat + -> Maybe Name -- The constructor (Nothing for an update + -- or out of scope constructor) + -> [HsRecField Name (Located arg)] -- Explicit fields + -> RnM [HsRecField Name (Located arg)] -- Filled in .. fields rn_dotdot Nothing _mb_con _flds -- No ".." at all = return [] rn_dotdot (Just {}) Nothing _flds -- ".." on record update = do { addErr (badDotDot ctxt); return [] } rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match = ASSERT( n == length flds ) - do { loc <- getSrcSpanM -- Rather approximate + do { loc <- getSrcSpanM -- Rather approximate ; dd_flag <- xoptM Opt_RecordWildCards ; checkErr dd_flag (needFlagDotDot ctxt) - ; (rdr_env, lcl_env) <- getRdrEnvs + ; (rdr_env, lcl_env) <- getRdrEnvs ; con_fields <- lookupConstructorFields con ; let present_flds = getFieldIds flds parent_tc = find_tycon rdr_env con -- For constructor uses (but not patterns) -- the arg should be in scope (unqualified) - -- ignoring the record field itself - -- Eg. data R = R { x,y :: Int } + -- ignoring the record field itself + -- Eg. data R = R { x,y :: Int } -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y} - arg_in_scope fld + arg_in_scope fld = rdr `elemLocalRdrEnv` lcl_env || notNull [ gre | gre <- lookupGRE_RdrName rdr rdr_env , case gre_par gre of @@ -576,8 +576,8 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } , hsRecFieldArg = L loc (mk_arg arg_rdr) , hsRecPun = False } | gre <- dot_dot_gres - , let fld = gre_name gre - arg_rdr = mkRdrUnqual (nameOccName fld) ] } + , let fld = gre_name gre + arg_rdr = mkRdrUnqual (nameOccName fld) ] } check_disambiguation :: Bool -> Maybe Name -> RnM Parent -- When disambiguation is on, @@ -592,7 +592,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } -- That's the parent to use for looking up record fields. find_tycon env con = case lookupGRE_Name env con of - [GRE { gre_par = ParentIs p }] -> p + [GRE { gre_par = ParentIs p }] -> p gres -> pprPanic "find_tycon" (ppr con $$ ppr gres) dup_flds :: [[RdrName]] @@ -606,20 +606,20 @@ getFieldIds flds = map (unLoc . hsRecFieldId) flds needFlagDotDot :: HsRecFieldContext -> SDoc needFlagDotDot ctxt = vcat [ptext (sLit "Illegal `..' in record") <+> pprRFC ctxt, - ptext (sLit "Use -XRecordWildCards to permit this")] + ptext (sLit "Use -XRecordWildCards to permit this")] badDotDot :: HsRecFieldContext -> SDoc badDotDot ctxt = ptext (sLit "You cannot use `..' in a record") <+> pprRFC ctxt badPun :: Located RdrName -> SDoc badPun fld = vcat [ptext (sLit "Illegal use of punning for field") <+> quotes (ppr fld), - ptext (sLit "Use -XNamedFieldPuns to permit this")] + ptext (sLit "Use -XNamedFieldPuns to permit this")] dupFieldErr :: HsRecFieldContext -> [RdrName] -> SDoc dupFieldErr ctxt dups = hsep [ptext (sLit "duplicate field name"), quotes (ppr (head dups)), - ptext (sLit "in record"), pprRFC ctxt] + ptext (sLit "in record"), pprRFC ctxt] pprRFC :: HsRecFieldContext -> SDoc pprRFC (HsRecFieldCon {}) = ptext (sLit "construction") @@ -629,9 +629,9 @@ pprRFC (HsRecFieldUpd {}) = ptext (sLit "update") %************************************************************************ -%* * +%* * \subsubsection{Literals} -%* * +%* * %************************************************************************ When literals occur we have to make sure @@ -643,28 +643,40 @@ rnLit :: HsLit -> RnM () rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c) rnLit _ = return () +-- Turn a Fractional-looking literal which happens to be an integer into an +-- Integer-looking literal. +generalizeOverLitVal :: OverLitVal -> OverLitVal +generalizeOverLitVal (HsFractional (FL {fl_value=val})) + | denominator val == 1 = HsIntegral (numerator val) +generalizeOverLitVal lit = lit + rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars) -rnOverLit lit@(OverLit {ol_val=val}) - = do { let std_name = hsOverLitName val - ; (from_thing_name, fvs) <- lookupSyntaxName std_name - ; let rebindable = case from_thing_name of - HsVar v -> v /= std_name - _ -> panic "rnOverLit" - ; return (lit { ol_witness = from_thing_name - , ol_rebindable = rebindable }, fvs) } +rnOverLit origLit + = do { opt_NumDecimals <- xoptM Opt_NumDecimals + ; let { lit@(OverLit {ol_val=val}) + | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)} + | otherwise = origLit + } + ; let std_name = hsOverLitName val + ; (from_thing_name, fvs) <- lookupSyntaxName std_name + ; let rebindable = case from_thing_name of + HsVar v -> v /= std_name + _ -> panic "rnOverLit" + ; return (lit { ol_witness = from_thing_name + , ol_rebindable = rebindable }, fvs) } \end{code} %************************************************************************ -%* * +%* * \subsubsection{Errors} -%* * +%* * %************************************************************************ \begin{code} patSigErr :: Outputable a => a -> SDoc patSigErr ty = (ptext (sLit "Illegal signature in pattern:") <+> ppr ty) - $$ nest 4 (ptext (sLit "Use -XScopedTypeVariables to permit it")) + $$ nest 4 (ptext (sLit "Use -XScopedTypeVariables to permit it")) bogusCharError :: Char -> SDoc bogusCharError c diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 13e468f685..75d5364f63 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -880,7 +880,7 @@ reOrderNodes depth bndr_set weak_fvs (node : nodes) binds | Just inl_source <- isStableCoreUnfolding_maybe (idUnfolding bndr) = case inl_source of - InlineWrapper {} -> 10 -- Note [INLINE pragmas] + InlineWrapper -> 10 -- Note [INLINE pragmas] _other -> 3 -- Data structures are more important than this -- so that dictionary/method recursion unravels -- Note that this case hits all InlineRule things, so we @@ -1643,7 +1643,7 @@ When the scrutinee is a GlobalId we must take care in two ways i) In order to *know* whether 'x' occurs free in the RHS, we need its occurrence info. BUT, we don't gather occurrence info for GlobalIds. That's the reason for the (small) occ_gbl_scrut env in - OccEnv is for: it says "gather occurrence info for these. + OccEnv is for: it says "gather occurrence info for these". ii) We must call localiseId on 'x' first, in case it's a GlobalId, or has an External Name. See, for example, SimplEnv Note [Global Ids in diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 62e167a79e..a3101f715e 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -121,6 +121,7 @@ getCoreToDo dflags cse = gopt Opt_CSE dflags spec_constr = gopt Opt_SpecConstr dflags liberate_case = gopt Opt_LiberateCase dflags + late_dmd_anal = gopt Opt_LateDmdAnal dflags static_args = gopt Opt_StaticArgumentTransformation dflags rules_on = gopt Opt_EnableRewriteRules dflags eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags @@ -294,7 +295,15 @@ getCoreToDo dflags maybe_rule_check (Phase 0), -- Final clean-up simplification: - simpl_phase 0 ["final"] max_iter + simpl_phase 0 ["final"] max_iter, + + runWhen late_dmd_anal $ CoreDoPasses [ + CoreDoStrictness, + CoreDoWorkerWrapper, + simpl_phase 0 ["post-late-ww"] max_iter + ], + + maybe_rule_check (Phase 0) ] \end{code} diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index f0f894d744..d006f7f6eb 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -30,7 +30,6 @@ import Demand ( StrictSig(..), dmdTypeDepth ) import PprCore ( pprParendExpr, pprCoreExpr ) import CoreUnfold import CoreUtils -import qualified CoreSubst import CoreArity import Rules ( lookupRule, getRules ) import TysPrim ( realWorldStatePrimTy ) @@ -737,8 +736,7 @@ simplUnfolding env top_lvl id _ , uf_src = src, uf_guidance = guide }) | isStableSource src = do { expr' <- simplExpr rule_env expr - ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src - is_top_lvl = isTopLevel top_lvl + ; let is_top_lvl = isTopLevel top_lvl ; case guide of UnfWhen sat_ok _ -- Happens for INLINE things -> let guide' = UnfWhen sat_ok (inlineBoringOk expr') @@ -747,14 +745,14 @@ simplUnfolding env top_lvl id _ -- for dfuns for single-method classes; see -- Note [Single-method classes] in TcInstDcls. -- A test case is Trac #4138 - in return (mkCoreUnfolding src' is_top_lvl expr' arity guide') + in return (mkCoreUnfolding src is_top_lvl expr' arity guide') -- See Note [Top-level flag on inline rules] in CoreUnfold _other -- Happens for INLINABLE things -> let bottoming = isBottomingId id in bottoming `seq` -- See Note [Force bottoming field] do dflags <- getDynFlags - return (mkUnfolding dflags src' is_top_lvl bottoming expr') + return (mkUnfolding dflags src is_top_lvl bottoming expr') -- If the guidance is UnfIfGoodArgs, this is an INLINABLE -- unfolding, and we need to make sure the guidance is kept up -- to date with respect to any changes in the unfolding. diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index a5df7d52bc..0518367658 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -560,7 +560,7 @@ Note [NoSpecConstr] ~~~~~~~~~~~~~~~~~~~ The ignoreDataCon stuff allows you to say {-# ANN type T NoSpecConstr #-} -to mean "don't specialise on arguments of this type. It was added +to mean "don't specialise on arguments of this type". It was added before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised regardless of size; and then we needed a way to turn that *off*. Now that we have ForceSpecConstr, this NoSpecConstr is probably redundant. diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index e697dfe1ff..cc4010503b 100644 --- a/compiler/stranal/WorkWrap.lhs +++ b/compiler/stranal/WorkWrap.lhs @@ -11,7 +11,7 @@ -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details -module WorkWrap ( wwTopBinds, mkWrapper ) where +module WorkWrap ( wwTopBinds ) where import CoreSyn import CoreUnfold ( certainlyWillInline, mkInlineUnfolding, mkWwInlineRule ) @@ -19,7 +19,6 @@ import CoreUtils ( exprType, exprIsHNF ) import CoreArity ( exprArity ) import Var import Id -import Type ( Type ) import IdInfo import UniqSupply import BasicTypes @@ -358,7 +357,7 @@ splitFun dflags fn_id fn_info wrap_dmds res_info rhs -- The inl_inline is bound to be False, else we would not be -- making a wrapper - wrap_id = fn_id `setIdUnfolding` mkWwInlineRule work_id wrap_rhs arity + wrap_id = fn_id `setIdUnfolding` mkWwInlineRule wrap_rhs arity `setInlinePragma` wrap_prag `setIdOccInfo` NoOccInfo -- Zap any loop-breaker-ness, to avoid bleating from Lint @@ -390,6 +389,9 @@ get_one_shots (Lam b e) | otherwise = get_one_shots e get_one_shots (Tick _ e) = get_one_shots e get_one_shots _ = noOneShotInfo + +noOneShotInfo :: [Bool] +noOneShotInfo = repeat False \end{code} Note [Thunk splitting] @@ -446,27 +448,3 @@ splitThunk dflags fn_id rhs = do (_, wrap_fn, work_fn) <- mkWWstr dflags [fn_id] return [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ] \end{code} - - -%************************************************************************ -%* * -\subsection{The worker wrapper core} -%* * -%************************************************************************ - -@mkWrapper@ is called when importing a function. We have the type of -the function and the name of its worker, and we want to make its body (the wrapper). - -\begin{code} -mkWrapper :: DynFlags - -> Type -- Wrapper type - -> StrictSig -- Wrapper strictness info - -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id - -mkWrapper dflags fun_ty (StrictSig (DmdType _ demands res_info)) = do - (_, wrap_fn, _) <- mkWwBodies dflags fun_ty demands res_info noOneShotInfo - return wrap_fn - -noOneShotInfo :: [Bool] -noOneShotInfo = repeat False -\end{code} diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 0a691651fb..144678e4dd 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -1477,7 +1477,7 @@ mkNewTypeEqn orig dflags tvs ptext (sLit "GeneralizedNewtypeDeriving on this class;") $$ ptext (sLit "the last parameter of") <+> quotes (ppr (className cls)) <+> - ptext (sLit "is at role N") + ptext (sLit "is at role Nominal") \end{code} diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 4023311d3a..307e922633 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -500,7 +500,7 @@ solve it. \begin{code} mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg mkIrredErr ctxt cts - = do { (ctxt, binds_msg) <- relevantBindings ctxt ct1 + = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct1 ; mkErrorMsg ctxt ct1 (msg $$ binds_msg) } where (ct1:_) = cts @@ -516,7 +516,8 @@ mkHoleError ctxt ct@(CHoleCan { cc_occ = occ }) msg = vcat [ hang (ptext (sLit "Found hole") <+> quotes (ppr occ)) 2 (ptext (sLit "with type:") <+> pprType (ctEvPred (cc_ev ct))) , ppUnless (null tyvars_msg) (ptext (sLit "Where:") <+> vcat tyvars_msg) ] - ; (ctxt, binds_doc) <- relevantBindings ctxt ct + ; (ctxt, binds_doc) <- relevantBindings False ctxt ct + -- The 'False' means "don't filter the bindings; see Trac #8191 ; mkErrorMsg ctxt ct (msg $$ binds_doc) } where loc_msg tv @@ -532,7 +533,7 @@ mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct) ---------------- mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg mkIPErr ctxt cts - = do { (ctxt, bind_msg) <- relevantBindings ctxt ct1 + = do { (ctxt, bind_msg) <- relevantBindings True ctxt ct1 ; mkErrorMsg ctxt ct1 (msg $$ bind_msg) } where (ct1:_) = cts @@ -583,7 +584,7 @@ mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg -- Wanted constraints only! mkEqErr1 ctxt ct | isGiven ev - = do { (ctxt, binds_msg) <- relevantBindings ctxt ct + = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct ; let (given_loc, given_msg) = mk_given (cec_encl ctxt) ; dflags <- getDynFlags ; mkEqErr_help dflags ctxt (given_msg $$ binds_msg) @@ -591,7 +592,7 @@ mkEqErr1 ctxt ct Nothing ty1 ty2 } | otherwise -- Wanted or derived - = do { (ctxt, binds_msg) <- relevantBindings ctxt ct + = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct ; (ctxt, tidy_orig) <- zonkTidyOrigin ctxt (ctLocOrigin (cc_loc ct)) ; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig ; dflags <- getDynFlags @@ -931,7 +932,7 @@ mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult) mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) | null matches -- No matches but perhaps several unifiers = do { let (is_ambig, ambig_msg) = mkAmbigMsg ct - ; (ctxt, binds_msg) <- relevantBindings ctxt ct + ; (ctxt, binds_msg) <- relevantBindings True ctxt ct ; traceTc "mk_dict_err" (ppr ct $$ ppr is_ambig $$ ambig_msg) ; return (ctxt, cannot_resolve_msg is_ambig binds_msg ambig_msg) } @@ -1171,17 +1172,25 @@ getSkolemInfo (implic:implics) tv -- careful to zonk the Id's type first, so it has to be in the monad. -- We must be careful to pass it a zonked type variable, too. -relevantBindings :: ReportErrCtxt -> Ct +relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering + -- See Trac #8191 + -> ReportErrCtxt -> Ct -> TcM (ReportErrCtxt, SDoc) -relevantBindings ctxt ct - = do { (tidy_env', docs) <- go (cec_tidy ctxt) (6, emptyVarSet) - (reverse (tcl_bndrs lcl_env)) +relevantBindings want_filtering ctxt ct + = do { dflags <- getDynFlags + ; (tidy_env', docs, discards) + <- go (cec_tidy ctxt) (maxRelevantBinds dflags) + emptyVarSet [] False + (reverse (tcl_bndrs lcl_env)) -- The 'reverse' makes us work from outside in - -- Blargh; maybe have a flag for this "6" ; traceTc "relevantBindings" (ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env]) ; let doc = hang (ptext (sLit "Relevant bindings include")) - 2 (vcat docs) + 2 (vcat docs $$ max_msg) + max_msg | discards + = ptext (sLit "(Some bindings suppressed; use -fmax-relevant-binds=N or -fno-max-relevant-binds)") + | otherwise = empty + ; if null docs then return (ctxt, empty) else do { traceTc "rb" doc @@ -1190,28 +1199,38 @@ relevantBindings ctxt ct lcl_env = ctLocEnv (cc_loc ct) ct_tvs = tyVarsOfCt ct - go :: TidyEnv -> (Int, TcTyVarSet) - -> [TcIdBinder] -> TcM (TidyEnv, [SDoc]) - go tidy_env (_,_) [] - = return (tidy_env, []) - go tidy_env (n_left,tvs_seen) (TcIdBndr id _ : tc_bndrs) - | n_left <= 0, ct_tvs `subVarSet` tvs_seen - = -- We have run out of n_left, and we - -- already have bindings mentioning all of ct_tvs - go tidy_env (n_left,tvs_seen) tc_bndrs - | otherwise + run_out :: Maybe Int -> Bool + run_out Nothing = False + run_out (Just n) = n <= 0 + + dec_max :: Maybe Int -> Maybe Int + dec_max = fmap (\n -> n - 1) + + go :: TidyEnv -> Maybe Int -> TcTyVarSet -> [SDoc] -> Bool + -> [TcIdBinder] + -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out + -- because of lack of fuel + go tidy_env _ _ docs discards [] + = return (tidy_env, reverse docs, discards) + go tidy_env n_left tvs_seen docs discards (TcIdBndr id _ : tc_bndrs) = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id) ; let id_tvs = tyVarsOfType tidy_ty doc = sep [ pprPrefixOcc id <+> dcolon <+> ppr tidy_ty , nest 2 (parens (ptext (sLit "bound at") <+> ppr (getSrcLoc id)))] - ; if id_tvs `intersectsVarSet` ct_tvs - && (n_left > 0 || not (id_tvs `subVarSet` tvs_seen)) - -- Either we n_left is big enough, - -- or this binding mentions a new type variable - then do { (env', docs) <- go tidy_env' (n_left - 1, tvs_seen `unionVarSet` id_tvs) tc_bndrs - ; return (env', doc:docs) } - else go tidy_env (n_left, tvs_seen) tc_bndrs } + new_seen = tvs_seen `unionVarSet` id_tvs + + ; if (want_filtering && id_tvs `disjointVarSet` ct_tvs) + -- We want to filter out this binding anyway + then go tidy_env n_left tvs_seen docs discards tc_bndrs + + else if run_out n_left && id_tvs `subVarSet` tvs_seen + -- We've run out of n_left fuel and this binding only + -- mentions aleady-seen type variables, so discard it + then go tidy_env n_left tvs_seen docs True tc_bndrs + + -- Keep this binding, decrement fuel + else go tidy_env' (dec_max n_left) new_seen (doc:docs) discards tc_bndrs } ----------------------- warnDefaulting :: Cts -> Type -> TcM () diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 43b4f36aa2..94787eb39b 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -916,12 +916,13 @@ data Ct cc_loc :: CtLoc } - | CNonCanonical { -- See Note [NonCanonical Semantics] + | CNonCanonical { -- See Note [NonCanonical Semantics] cc_ev :: CtEvidence, cc_loc :: CtLoc } - | CHoleCan { + | CHoleCan { -- Treated as an "insoluble" constraint + -- See Note [Insoluble constraints] cc_ev :: CtEvidence, cc_loc :: CtLoc, cc_occ :: OccName -- The name of this hole diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index b17f3950a4..b39bc85669 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -816,29 +816,34 @@ defaultTyVar the_tv approximateWC :: WantedConstraints -> Cts -- Postcondition: Wanted or Derived Cts +-- See Note [ApproximateWC] approximateWC wc = float_wc emptyVarSet wc where float_wc :: TcTyVarSet -> WantedConstraints -> Cts - float_wc skols (WC { wc_flat = flats, wc_impl = implics }) - = do_bag (float_flat skols) flats `unionBags` - do_bag (float_implic skols) implics - + float_wc trapping_tvs (WC { wc_flat = flats, wc_impl = implics }) + = filterBag is_floatable flats `unionBags` + do_bag (float_implic new_trapping_tvs) implics + where + new_trapping_tvs = fixVarSet grow trapping_tvs + is_floatable ct = tyVarsOfCt ct `disjointVarSet` new_trapping_tvs + + grow tvs = foldrBag grow_one tvs flats + grow_one ct tvs | ct_tvs `intersectsVarSet` tvs = tvs `unionVarSet` ct_tvs + | otherwise = tvs + where + ct_tvs = tyVarsOfCt ct + float_implic :: TcTyVarSet -> Implication -> Cts - float_implic skols imp + float_implic trapping_tvs imp | hasEqualities (ic_given imp) -- Don't float out of equalities = emptyCts -- cf floatEqualities - | otherwise -- See Note [approximateWC] - = float_wc skols' (ic_wanted imp) + | otherwise -- See Note [ApproximateWC] + = float_wc new_trapping_tvs (ic_wanted imp) where - skols' = skols `extendVarSetList` ic_skols imp `extendVarSetList` ic_fsks imp + new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp + `extendVarSetList` ic_fsks imp - float_flat :: TcTyVarSet -> Ct -> Cts - float_flat skols ct - | tyVarsOfCt ct `disjointVarSet` skols - = singleCt ct - | otherwise = emptyCts - do_bag :: (a -> Bag c) -> Bag a -> Bag c do_bag f = foldrBag (unionBags.f) emptyBag \end{code} @@ -849,23 +854,43 @@ approximateWC takes a constraint, typically arising from the RHS of a let-binding whose type we are *inferring*, and extracts from it some *flat* constraints that we might plausibly abstract over. Of course the top-level flat constraints are plausible, but we also float constraints -out from inside, if the are not captured by skolems. - -However we do *not* float anything out if the implication binds equality -constriants, because that defeats the OutsideIn story. Consider - data T a where - TInt :: T Int - MkT :: T a - - f TInt = 3::Int - -We get the implication (a ~ Int => res ~ Int), where so far we've decided - f :: T a -> res -We don't want to float (res~Int) out because then we'll infer - f :: T a -> Int -which is only on of the possible types. (GHC 7.6 accidentally *did* -float out of such implications, which meant it would happily infer -non-principal types.) +out from inside, if they are not captured by skolems. + +The same function is used when doing type-class defaulting (see the call +to applyDefaultingRules) to extract constraints that that might be defaulted. + +There are two caveats: + +1. We do *not* float anything out if the implication binds equality + constraints, because that defeats the OutsideIn story. Consider + data T a where + TInt :: T Int + MkT :: T a + + f TInt = 3::Int + + We get the implication (a ~ Int => res ~ Int), where so far we've decided + f :: T a -> res + We don't want to float (res~Int) out because then we'll infer + f :: T a -> Int + which is only on of the possible types. (GHC 7.6 accidentally *did* + float out of such implications, which meant it would happily infer + non-principal types.) + +2. We do not float out an inner constraint that shares a type variable + (transitively) with one that is trapped by a skolem. Eg + forall a. F a ~ beta, Integral beta + We don't want to float out (Integral beta). Doing so would be bad + when defaulting, because then we'll default beta:=Integer, and that + makes the error message much worse; we'd get + Can't solve F a ~ Integer + rather than + Can't solve Integral (F a) + + Moreover, floating out these "contaminated" constraints doesn't help + when generalising either. If we generalise over (Integral b), we still + can't solve the retained implication (forall a. F a ~ b). Indeed, + arguably that too would be a harder error to understand. Note [DefaultTyVar] ~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 0cd4f2d5a9..70e72f593f 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -2147,8 +2147,8 @@ inaccessibleCoAxBranch tc fi badRoleAnnot :: Name -> Role -> Role -> SDoc badRoleAnnot var annot inferred = hang (ptext (sLit "Role mismatch on variable") <+> ppr var <> colon) - 2 (sep [ ptext (sLit "Annotation says"), ppr annot - , ptext (sLit "but role"), ppr inferred + 2 (sep [ ptext (sLit "Annotation says"), pprFullRole annot + , ptext (sLit "but role"), pprFullRole inferred , ptext (sLit "is required") ]) \end{code} diff --git a/compiler/types/CoAxiom.lhs b/compiler/types/CoAxiom.lhs index e507607cd3..ed1a68432b 100644 --- a/compiler/types/CoAxiom.lhs +++ b/compiler/types/CoAxiom.lhs @@ -26,12 +26,13 @@ module CoAxiom ( coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps, placeHolderIncomps, - Role(..) + Role(..), pprFullRole ) where import {-# SOURCE #-} TypeRep ( Type ) import {-# SOURCE #-} TyCon ( TyCon ) import Outputable +import FastString import Name import Unique import Var @@ -440,6 +441,11 @@ This is defined here to avoid circular dependencies. data Role = Nominal | Representational | Phantom deriving (Eq, Data.Data, Data.Typeable) +pprFullRole :: Role -> SDoc +pprFullRole Nominal = ptext (sLit "Nominal") +pprFullRole Representational = ptext (sLit "Representational") +pprFullRole Phantom = ptext (sLit "Phantom") + instance Outputable Role where ppr Nominal = char 'N' ppr Representational = char 'R' diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 31a1bfb8df..826537db17 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -535,7 +535,7 @@ lookupInstEnv' ie cls tys = find ((item, map (lookup_tv subst) tpl_tvs) : ms) us rest -- Does not match, so next check whether the things unify - -- See Note [Overlapping instances] above + -- See Note [Overlapping instances] and Note [Incoherent Instances] | Incoherent _ <- oflag = find ms us rest @@ -625,12 +625,19 @@ insert_overlapping new_item (item:items) -- Keep new one | old_beats_new = item : items -- Keep old one + | incoherent new_item = item : items -- note [Incoherent instances] + -- Keep old one + | incoherent item = new_item : items + -- Keep new one | otherwise = item : insert_overlapping new_item items -- Keep both where new_beats_old = new_item `beats` item old_beats_new = item `beats` new_item + incoherent (inst, _) = case is_flag inst of Incoherent _ -> True + _ -> False + (instA, _) `beats` (instB, _) = overlap_ok && isJust (tcMatchTys (mkVarSet (is_tvs instB)) (is_tys instB) (is_tys instA)) @@ -646,6 +653,52 @@ insert_overlapping new_item (item:items) _ -> True \end{code} +Note [Incoherent instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For some classes, the choise of a particular instance does not matter, any one +is good. E.g. consider + + class D a b where { opD :: a -> b -> String } + instance D Int b where ... + instance D a Int where ... + + g (x::Int) = opD x x + +For such classes this should work (without having to add an "instance D Int +Int", and using -XOverlappingInstances, which would then work). This is what +-XIncoherentInstances is for: Telling GHC "I don't care which instance you use; +if you can use one, use it." + + +Should this logic only work when all candidates have the incoherent flag, or +even when all but one have it? The right choice is the latter, which can be +justified by comparing the behaviour with how -XIncoherentInstances worked when +it was only about the unify-check (note [Overlapping instances]): + +Example: + class C a b c where foo :: (a,b,c) + instance C [a] b Int + instance [incoherent] [Int] b c + instance [incoherent] C a Int c +Thanks to the incoherent flags, + foo :: ([a],b,Int) +works: Only instance one matches, the others just unify, but are marked +incoherent. + +So I can write + (foo :: ([a],b,Int)) :: ([Int], Int, Int). +but if that works then I really want to be able to write + foo :: ([Int], Int, Int) +as well. Now all three instances from above match. None is more specific than +another, so none is ruled out by the normal overlapping rules. One of them is +not incoherent, but we still want this to compile. Hence the +"all-but-one-logic". + +The implementation is in insert_overlapping, where we remove matching +incoherent instances as long as there are are others. + + %************************************************************************ %* * diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 35f4ef5576..4b5d2ea63d 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -383,19 +383,28 @@ failure. tcUnifyTysFG ("fine-grained") returns one of three results: success, occurs-check failure ("MaybeApart"), or general failure ("SurelyApart"). +See also Trac #8162. + +It's worth noting that unification in the presence of infinite types is not +complete. This means that, sometimes, a closed type family does not reduce +when it should. See test case indexed-types/should_fail/Overlap15 for an +example. + Note [The substitution in MaybeApart] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why? Because consider unifying these: -(a, a, a) ~ (Int, F Bool, Bool) +(a, a, Int) ~ (b, [b], Bool) -If we go left-to-right, we start with [a |-> Int]. Then, on the middle terms, -we apply the subst we have so far and discover that Int is maybeApart from -F Bool. But, we can't stop there! Because if we continue, we discover that -Int is SurelyApart from Bool, and therefore the types are apart. This has -practical consequences for the ability for closed type family applications -to reduce. See test case indexed-types/should_compile/Overlap14. +If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we +apply the subst we have so far and discover that we need [b |-> [b]]. Because +this fails the occurs check, we say that the types are MaybeApart (see above +Note [Fine-grained unification]). But, we can't stop there! Because if we +continue, we discover that Int is SurelyApart from Bool, and therefore the +types are apart. This has practical consequences for the ability for closed +type family applications to reduce. See test case +indexed-types/should_compile/Overlap14. Note [Unifying with skolems] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -405,7 +414,6 @@ may later be instantiated with a unifyable type. So, we return maybeApart in these cases. \begin{code} --- See Note [Unification and apartness] tcUnifyTys :: (TyVar -> BindFlag) -> [Type] -> [Type] -> Maybe TvSubst -- A regular one-shot (idempotent) substitution @@ -419,7 +427,7 @@ tcUnifyTys bind_fn tys1 tys2 = Nothing -- This type does double-duty. It is used in the UM (unifier monad) and to --- return the final result. +-- return the final result. See Note [Fine-grained unification] type UnifyResult = UnifyResultM TvSubst data UnifyResultM a = Unifiable a -- the subst that unifies the types | MaybeApart a -- the subst has as much as we know diff --git a/docs/users_guide/7.8.1-notes.xml b/docs/users_guide/7.8.1-notes.xml index f3fa0e1984..4719403e66 100644 --- a/docs/users_guide/7.8.1-notes.xml +++ b/docs/users_guide/7.8.1-notes.xml @@ -93,10 +93,10 @@ <listitem> <para> - The LLVM backend now supports 128bit SIMD operations. This is - now exploited in both the <literal>vector</literal> and - <literal>dph</literal> packages, exposing a high level - interface. + The LLVM backend now supports 128bit SIMD + operations. This is now exploited in both the + <literal>vector</literal> and <literal>dph</literal> + packages, exposing a high level interface. TODO FIXME: reference. </para> @@ -121,6 +121,17 @@ <listitem> <para> + GHC now has substantially better support for cross + compilation. In particular, GHC now has all the + necessary patches to support cross compilation to + Apple iOS, using the LLVM backend. + + TODO FIXME: reference. + </para> + </listitem> + + <listitem> + <para> PrimOps for comparing unboxed values now return <literal>Int#</literal> instead of <literal>Bool</literal>. New PrimOps' names end with <literal>$#</literal> for operators and @@ -160,11 +171,55 @@ <literal>NullaryTypeClasses</literal>, which allows you to declare a type class without any parameters. + </para> + </listitem> + </itemizedlist> + + <itemizedlist> + <listitem> + <para> + There is a new extension, + <literal>NumDecimals</literal>, which allows you + to specify an integer using compact "floating + literal" syntax. This lets you say things like + <literal>1.2e6 :: Integer</literal> instead of + <literal>1200000</literal> + </para> + </listitem> + </itemizedlist> - TODO FIXME: example? + <itemizedlist> + <listitem> + <para> + There is a new extension, + <literal>NegativeLiterals</literal>, which will + cause GHC to interpret the expression + <literal>-123</literal> as <literal>fromIntegral + (-123)</literal>. Haskell 98 and Haskell 2010 both + specify that it should instead desugar to + <literal>negate (fromIntegral 123)</literal> </para> </listitem> </itemizedlist> + + <itemizedlist> + <listitem> + <para> + The <literal>IncoherentInstances</literal> + extension has seen a behavioral change, and is + now 'liberated' and less conservative during + instance resolution. This allows more programs to + compile than before. + </para> + <para> + Now, <literal>IncoherentInstances</literal> will + always pick an arbitrary matching instance, if + multiple ones exist. + </para> + </listitem> + </itemizedlist> + + </sect3> <sect3> @@ -172,12 +227,38 @@ <itemizedlist> <listitem> <para> + GHC can now build both static and dynamic object + files at the same time in a single compilation + pass, when given the + <literal>-dynamic-too</literal> flag. This will + produce both a statically-linkable + <literal>.o</literal> object file, and a + dynamically-linkable <literal>.dyn_o</literal> + file. The output suffix of the dynamic objects can + be controlled by the flag + <literal>-dyno</literal>. + </para> + + <para> + Note that GHC still builds statically by default. + </para> + </listitem> + <listitem> + <para> GHC now supports a <literal>--show-options</literal> flag, which will dump all of the flags it supports to standard out. </para> </listitem> <listitem> <para> + GHC now supports warning about overflow of integer + literals, enabled by + <literal>-fwarn-overflowed-literals</literal>. It + is enabled by default + </para> + </listitem> + <listitem> + <para> It's now possible to switch the system linker on Linux (between GNU gold and GNU ld) at runtime without problem. </para> @@ -211,6 +292,13 @@ TODO FIXME: reference. </para> </listitem> + <listitem> + <para> + The new <literal>:shows paths</literal> command + shows the current working directory and the + current search path for Haskell modules. + </para> + </listitem> </itemizedlist> </sect3> diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index ba4b0b13b0..648180c184 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -796,6 +796,12 @@ <entry><option>-XNoNegativeLiterals</option></entry> </row> <row> + <entry><option>-XNumDecimals</option></entry> + <entry>Enable support for 'fractional' integer literals</entry> + <entry>dynamic</entry> + <entry><option>-XNoNumDecimals</option></entry> + </row> + <row> <entry><option>-XNoTraditionalRecordSyntax</option></entry> <entry>Disable support for traditional record syntax (as supported by Haskell 98) <literal>C {f = x}</literal></entry> <entry>dynamic</entry> @@ -1495,7 +1501,7 @@ <sect2> <title>Optimisation levels</title> - <para><xref linkend="options-optimise"/></para> + <para>These options are described in more detail in <xref linkend="options-optimise"/></para> <informaltable> <tgroup cols="4" align="left" colsep="1" rowsep="1"> @@ -1525,10 +1531,10 @@ </informaltable> </sect2> - <sect2> + <sect2 id="options-f-compact"> <title>Individual optimisations</title> - <para><xref linkend="options-f"/></para> + <para>These options are described in more detail in <xref linkend="options-f"/>.</para> <informaltable> <tgroup cols="4" align="left" colsep="1" rowsep="1"> @@ -1552,7 +1558,7 @@ <entry><option>-fcse</option></entry> <entry>Turn on common sub-expression elimination. Implied by <option>-O</option>.</entry> <entry>dynamic</entry> - <entry>-fno-cse</entry> + <entry><option>-fno-cse</option></entry> </row> <row> @@ -1628,14 +1634,14 @@ <entry><option>-ffloat-in</option></entry> <entry>Turn on the float-in transformation. Implied by <option>-O</option>.</entry> <entry>dynamic</entry> - <entry>-fno-float-in</entry> + <entry><option>-fno-float-in</option></entry> </row> <row> <entry><option>-ffull-laziness</option></entry> <entry>Turn on full laziness (floating bindings outwards). Implied by <option>-O</option>.</entry> <entry>dynamic</entry> - <entry>-fno-full-laziness</entry> + <entry><option>-fno-full-laziness</option></entry> </row> <row> @@ -1667,14 +1673,21 @@ </row> <row> - <entry><option>-fmax-simplifier-iterations</option></entry> + <entry><option>-fmax-relevant-bindings=N</option></entry> + <entry>Set the maximum number of bindings to display in type error messages (default 6).</entry> + <entry>dynamic</entry> + <entry><option>-fno-max-relevant-bindings</option></entry> + </row> + + <row> + <entry><option>-fmax-simplifier-iterations=N</option></entry> <entry>Set the max iterations for the simplifier</entry> <entry>dynamic</entry> <entry>-</entry> </row> <row> - <entry><option>-fmax-worker-args</option></entry> + <entry><option>-fmax-worker-args=N</option></entry> <entry>If a worker has that many arguments, none will be unpacked anymore (default: 10)</entry> <entry>dynamic</entry> @@ -1738,7 +1751,7 @@ <entry><option>-fspec-constr</option></entry> <entry>Turn on the SpecConstr transformation. Implied by <option>-O2</option>.</entry> <entry>dynamic</entry> - <entry>-fno-spec-constr</entry> + <entry><option>-fno-spec-constr</option></entry> </row> <row> @@ -1761,14 +1774,14 @@ <entry><option>-fspecialise</option></entry> <entry>Turn on specialisation of overloaded functions. Implied by <option>-O</option>.</entry> <entry>dynamic</entry> - <entry>-fno-specialise</entry> + <entry><option>-fno-specialise</option></entry> </row> <row> <entry><option>-fstrictness</option></entry> <entry>Turn on strictness analysis. Implied by <option>-O</option>.</entry> <entry>dynamic</entry> - <entry>-fno-strictness</entry> + <entry><option>-fno-strictness</option></entry> </row> <row> @@ -1783,7 +1796,7 @@ <entry><option>-fstatic-argument-transformation</option></entry> <entry>Turn on the static argument transformation. Implied by <option>-O2</option>.</entry> <entry>dynamic</entry> - <entry>-fno-static-argument-transformation</entry> + <entry><option>-fno-static-argument-transformation</option></entry> </row> <row> @@ -2085,6 +2098,15 @@ <entry>-</entry> </row> <row> + <entry><option>-staticlib</option></entry> + <entry>On Darwin/OS X/iOS only, generate a standalone static library + (as opposed to an executable). + This is the usual way to compile for iOS. + </entry> + <entry>dynamic</entry> + <entry>-</entry> + </row> + <row> <entry><option>-fPIC</option></entry> <entry>Generate position-independent code (where available)</entry> <entry>dynamic</entry> @@ -2097,6 +2119,24 @@ <entry>-</entry> </row> <row> + <entry><option>-dynamic-too</option></entry> + <entry>Build dynamic object files <emphasis>as well as</emphasis> static object files during compilation</entry> + <entry>static</entry> + <entry>-</entry> + </row> + <row> + <entry><option>-dyno</option></entry> + <entry>Set the output path for the <emphasis>dynamically</emphasis> linked objects</entry> + <entry>static</entry> + <entry>-</entry> + </row> + <row> + <entry><option>-dynosuf</option></entry> + <entry>Set the output suffix for dynamic object files</entry> + <entry>static</entry> + <entry>-</entry> + </row> + <row> <entry><option>-dynload</option></entry> <entry>Selects one of a number of modes for finding shared libraries at runtime.</entry> @@ -2105,14 +2145,14 @@ </row> <row> <entry><option>-framework</option> <replaceable>name</replaceable></entry> - <entry>On Darwin/MacOS X only, link in the framework <replaceable>name</replaceable>. + <entry>On Darwin/OS X/iOS only, link in the framework <replaceable>name</replaceable>. This option corresponds to the <option>-framework</option> option for Apple's Linker.</entry> <entry>dynamic</entry> <entry>-</entry> </row> <row> <entry><option>-framework-path</option> <replaceable>name</replaceable></entry> - <entry>On Darwin/MacOS X only, add <replaceable>dir</replaceable> to the list of + <entry>On Darwin/OS X/iOS only, add <replaceable>dir</replaceable> to the list of directories searched for frameworks. This option corresponds to the <option>-F</option> option for Apple's Linker.</entry> <entry>dynamic</entry> @@ -2223,7 +2263,7 @@ <entry>Set the install name (via <literal>-install_name</literal> passed to Apple's linker), specifying the full install path of the library file. Any libraries or executables that link with it later will pick up that path as their - runtime search location for it. (Darwin/MacOS X only)</entry> + runtime search location for it. (Darwin/OS X only)</entry> <entry>dynamic</entry> <entry>-</entry> </row> @@ -2351,6 +2391,13 @@ <entry>dynamic</entry> <entry>-</entry> </row> + <row> + <entry><option>-pgmlibtool</option> <replaceable>cmd</replaceable></entry> + <entry>Use <replaceable>cmd</replaceable> as the command for libtool + (with <option>-staticlib</option> only).</entry> + <entry>dynamic</entry> + <entry>-</entry> + </row> </tbody> </tgroup> </informaltable> diff --git a/docs/users_guide/ghci.xml b/docs/users_guide/ghci.xml index df483e81f3..7792da21e9 100644 --- a/docs/users_guide/ghci.xml +++ b/docs/users_guide/ghci.xml @@ -2154,7 +2154,9 @@ maybe :: b -> (a -> b) -> Maybe a -> b ‘<literal>˜</literal>’ symbol at the beginning of <replaceable>dir</replaceable> will be replaced by the contents of the environment variable - <literal>HOME</literal>.</para> + <literal>HOME</literal>. + See also the <literal>:show paths</literal> command for + showing the current working directory.</para> <para>NOTE: changing directories causes all currently loaded modules to be unloaded. This is because the search path is @@ -2922,6 +2924,19 @@ bar </varlistentry> <varlistentry> + <term> + <literal>:show paths</literal> + <indexterm><primary><literal>:show paths</literal></primary></indexterm> + </term> + <listitem> + <para>Show the current working directory (as set via + <literal>:cd</literal> command), as well as the list of + directories searched for source files (as set by the + <option>-i</option> option).</para> + </listitem> + </varlistentry> + + <varlistentry> <term> <literal>:show language</literal> <indexterm><primary><literal>:show language</literal></primary></indexterm> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 0b16156595..46e4cbdb01 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -446,15 +446,37 @@ Indeed, the bindings can even be recursive. The literal <literal>-123</literal> is, according to Haskell98 and Haskell 2010, desugared as <literal>negate (fromInteger 123)</literal>. + The language extension <option>-XNegativeLiterals</option> + means that it is instead desugared as + <literal>fromInteger (-123)</literal>. </para> <para> - The language extension <option>-XNegativeLiterals</option> - means that it is instead desugared as - <literal>fromInteger (-123)</literal>. + This can make a difference when the positive and negative range of + a numeric data type don't match up. For example, + in 8-bit arithmetic -128 is representable, but +128 is not. + So <literal>negate (fromInteger 128)</literal> will elicit an + unexpected integer-literal-overflow message. </para> </sect2> + <sect2 id="num-decimals"> + <title>Fractional looking integer literals</title> + <para> + Haskell 2010 and Haskell 98 define floating literals with + the syntax <literal>1.2e6</literal>. These literals have the + type <literal>Fractional a => Fractional</literal>. + </para> + + <para> + The language extension <option>-XNumLiterals</option> allows + you to also use the floating literal syntax for instances of + <literal>Integral</literal>, and have values like + <literal>(1.2e6 :: Num a => a)</literal> + </para> + </sect2> + + <!-- ====================== HIERARCHICAL MODULES ======================= --> @@ -4483,21 +4505,33 @@ and <option>-XIncoherentInstances</option> <indexterm><primary>-XIncoherentInstances </primary></indexterm>, as this section discusses. Both these flags are dynamic flags, and can be set on a per-module basis, using -an <literal>OPTIONS_GHC</literal> pragma if desired (<xref linkend="source-file-options"/>).</para> +an <literal>LANGUAGE</literal> pragma if desired (<xref linkend="language-pragma"/>).</para> <para> The <option>-XOverlappingInstances</option> flag instructs GHC to loosen the instance resolution described in <xref linkend="instance-resolution"/>, by -allowing more than one instance to match, <emphasis>provided there is a most specific one</emphasis>. +allowing more than one instance to match, <emphasis>provided there is a most +specific one</emphasis>. The <option>-XIncoherentInstances</option> flag +further loosens the resolution, by allowing more than one instance to match, +irespective of whether there is a most specific one. +</para> + +<para> For example, consider <programlisting> - instance context1 => C Int a where ... -- (A) + instance context1 => C Int b where ... -- (A) instance context2 => C a Bool where ... -- (B) - instance context3 => C Int [a] where ... -- (C) + instance context3 => C a [b] where ... -- (C) instance context4 => C Int [Int] where ... -- (D) </programlisting> -The constraint <literal>C Int [Int]</literal> matches instances (A), -(C) and (D), but the last is more specific, and hence is chosen. If there is no -most-specific match, the program is rejected. +compiled with <option>-XOverlappingInstances</option> enabled. The constraint +<literal>C Int [Int]</literal> matches instances (A), (C) and (D), but the last +is more specific, and hence is chosen. +</para> +<para>If (D) did not exist then (A) and (C) would still be matched, but neither is +most specific. In that case, the program would be rejected even with +<option>-XOverlappingInstances</option>. With +<option>-XIncoherentInstances</option> enabled, it would be accepted and (A) or +(C) would be chosen arbitrarily. </para> <para> An instance declaration is <emphasis>more specific</emphasis> than another iff @@ -4512,15 +4546,15 @@ However, GHC is conservative about committing to an overlapping instance. For e f x = ... </programlisting> Suppose that from the RHS of <literal>f</literal> we get the constraint -<literal>C Int [b]</literal>. But +<literal>C b [b]</literal>. But GHC does not commit to instance (C), because in a particular call of <literal>f</literal>, <literal>b</literal> might be instantiate to <literal>Int</literal>, in which case instance (D) would be more specific still. So GHC rejects the program.</para> <para> -If, however, you add the flag <option>-XIncoherentInstances</option>, -GHC will instead pick (C), without complaining about -the problem of subsequent instantiations. +If, however, you add the flag <option>-XIncoherentInstances</option> when +compiling the module that contians (D), GHC will instead pick (C), without +complaining about the problem of subsequent instantiations. </para> <para> Notice that we gave a type signature to <literal>f</literal>, so GHC had to @@ -4530,7 +4564,7 @@ it instead. In this case, GHC will refrain from simplifying the constraint <literal>C Int [b]</literal> (for the same reason as before) but, rather than rejecting the program, it will infer the type <programlisting> - f :: C Int [b] => [b] -> [b] + f :: C b [b] => [b] -> [b] </programlisting> That postpones the question of which instance to pick to the call site for <literal>f</literal> @@ -4628,6 +4662,10 @@ some other constraint. But if the instance declaration was compiled with <option>-XIncoherentInstances</option>, GHC will skip the "does-it-unify?" check for that declaration. </para></listitem> +<listitem><para> +If two instance declarations are matched and either is compiled with +<option>-XIncoherentInstances</option>, then that declaration is ignored. +</para></listitem> </itemizedlist> These rules make it possible for a library author to design a library that relies on overlapping instances without the library client having to know. diff --git a/docs/users_guide/phases.xml b/docs/users_guide/phases.xml index 90489e84d2..acb53a73d9 100644 --- a/docs/users_guide/phases.xml +++ b/docs/users_guide/phases.xml @@ -137,6 +137,17 @@ linkend="options-linker" />.</para> </listitem> </varlistentry> + + <varlistentry> + <term> + <option>-pgmlibtool</option> <replaceable>cmd</replaceable> + <indexterm><primary><option>-pgmlibtool</option></primary></indexterm> + </term> + <listitem> + <para>Use <replaceable>cmd</replaceable> as the libtool command + (when using <option>-staticlib</option> only).</para> + </listitem> + </varlistentry> </variablelist> </sect2> @@ -721,7 +732,7 @@ $ cat foo.hspp</screen> <indexterm><primary><option>-framework</option></primary></indexterm> </term> <listitem> - <para>On Darwin/MacOS X only, link in the framework <replaceable>name</replaceable>. + <para>On Darwin/OS X/iOS only, link in the framework <replaceable>name</replaceable>. This option corresponds to the <option>-framework</option> option for Apple's Linker. Please note that frameworks and packages are two different things - frameworks don't contain any haskell code. Rather, they are Apple's way of packaging shared libraries. @@ -733,6 +744,21 @@ $ cat foo.hspp</screen> <varlistentry> <term> + <option>-staticlib</option> + <indexterm><primary><option>-staticlib</option></primary></indexterm> + </term> + <listitem> + <para>On Darwin/OS X/iOS only, link all passed files into a static library suitable + for linking into an iOS (when using a cross-compiler) or Mac Xcode project. To control + the name, use the <option>-o</option> <replaceable>name</replaceable> option as usual. + The default name is <literal>liba.a</literal>. + This should nearly always be passed when compiling for iOS with a cross-compiler. + </para> + </listitem> + </varlistentry> + + <varlistentry> + <term> <option>-L</option><replaceable>dir</replaceable> <indexterm><primary><option>-L</option></primary></indexterm> </term> @@ -749,7 +775,7 @@ $ cat foo.hspp</screen> <indexterm><primary><option>-framework-path</option></primary></indexterm> </term> <listitem> - <para>On Darwin/MacOS X only, prepend the directory <replaceable>dir</replaceable> to + <para>On Darwin/OS X/iOS only, prepend the directory <replaceable>dir</replaceable> to the framework directories path. This option corresponds to the <option>-F</option> option for Apple's Linker (<option>-F</option> already means something else for GHC).</para> </listitem> @@ -1189,7 +1215,7 @@ $ cat foo.hspp</screen> </indexterm> </term> <listitem> - <para>On Darwin/MacOS X, dynamic libraries are stamped at build time with an + <para>On Darwin/OS X, dynamic libraries are stamped at build time with an "install name", which is the ultimate install path of the library file. Any libraries or executables that subsequently link against it will pick up that path as their runtime search location for it. By default, ghc sets diff --git a/docs/users_guide/separate_compilation.xml b/docs/users_guide/separate_compilation.xml index 84f6684307..2f8b9d6f33 100644 --- a/docs/users_guide/separate_compilation.xml +++ b/docs/users_guide/separate_compilation.xml @@ -600,23 +600,30 @@ $ ghc -c parse/Foo.hs parse/Bar.hs gurgle/Bumble.hs -odir `uname -m` </listitem> </varlistentry> - <varlistentry> - <term> + <varlistentry> + <term> <option>-ddump-minimal-imports</option> <indexterm><primary><option>-ddump-minimal-imports</option></primary></indexterm> </term> - <listitem> - <para>Dump to the file "M.imports" (where M is the module - being compiled) a "minimal" set of import declarations. - You can safely replace all the import declarations in - "M.hs" with those found in "M.imports". Why would you - want to do that? Because the "minimal" imports (a) import - everything explicitly, by name, and (b) import nothing - that is not required. It can be quite painful to maintain - this property by hand, so this flag is intended to reduce - the labour.</para> - </listitem> - </varlistentry> + <listitem> + <para>Dump to the file + <filename><replaceable>M</replaceable>.imports</filename> + (where <replaceable>M</replaceable> is the name of the + module being compiled) a "minimal" set of import + declarations. The directory where the + <filename>.imports</filename> files are created can be + controlled via the <option>-dumpdir</option> + option.</para> <para>You can safely replace all the import + declarations in + <filename><replaceable>M</replaceable>.hs</filename> with + those found in its respective <filename>.imports</filename> + file. Why would you want to do that? Because the + "minimal" imports (a) import everything explicitly, by + name, and (b) import nothing that is not required. It can + be quite painful to maintain this property by hand, so + this flag is intended to reduce the labour.</para> + </listitem> + </varlistentry> <varlistentry> <term> diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index 7540279504..4440eec7dd 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -1885,12 +1885,59 @@ f "2" = 2 them explicitly (indeed, doing so could lead to unexpected results). A flag <option>-fwombat</option> can be negated by saying <option>-fno-wombat</option>. The flags below are off - by default, except where noted below. + by default, except where noted below. See <xref linkend="options-f-compact"/> + for a compact list. </para> <variablelist> <varlistentry> <term> + <option>-favoid-vect</option> + <indexterm><primary><option></option></primary></indexterm> + </term> + <listitem> + <para>Part of <link linkend="dph">Data Parallel Haskell + (DPH)</link>.</para> + + <para><emphasis>Off by default.</emphasis> Enable the + <emphasis>vectorisation</emphasis> avoidance optimisation. This + optimisation only works when used in combination with the + <option>-fvectorise</option> transformation.</para> + + <para>While vectorisation of code using DPH is often a big win, it + can also produce worse results for some kinds of code. This + optimisation modifies the vectorisation transformation to try to + determine if a function would be better of unvectorised and if + so, do just that.</para> + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fcase-merge</option> + <indexterm><primary><option></option></primary></indexterm> + </term> + <listitem> + <para><emphasis>On by default.</emphasis> + Merge immediately-nested case expressions that scrutinse the same variable. Example +<programlisting> + case x of + Red -> e1 + _ -> case x of + Blue -> e2 + Green -> e3 +==> + case x of + Red -> e1 + Blue -> e2 + Green -> e2 +</programlisting> + </para> + </listitem> + </varlistentry> + + <varlistentry> + <term> <option>-fcse</option> <indexterm><primary><option>-fcse</option></primary></indexterm> </term> @@ -1904,170 +1951,88 @@ f "2" = 2 <varlistentry> <term> - <option>-fstrictness</option> + <option>-fdicts-cheap</option> <indexterm><primary><option></option></primary></indexterm> </term> <listitem> - <para> <emphasis>On by default.</emphasis>. - Switch on the strictness analyser. There is a very old paper about GHC's - strictness analyser, <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/simple-strictnes-analyser.ps.gz"> - Measuring the effectiveness of a simple strictness analyser</ulink>, - but the current one is quite a bit different. - </para> - - <para>The strictness analyser figures out when arguments and - variables in a function can be treated 'strictly' (that is they - are always evaluated in the function at some point). This allow - GHC to apply certain optimisations such as unboxing that - otherwise don't apply as they change the semantics of the program - when applied to lazy arguments. + <para>A very experimental flag that makes dictionary-valued + expressions seem cheap to the optimiser. </para> </listitem> </varlistentry> <varlistentry> <term> - <option>-funbox-strict-fields</option>: - <indexterm><primary><option>-funbox-strict-fields</option></primary></indexterm> - <indexterm><primary>strict constructor fields</primary></indexterm> - <indexterm><primary>constructor fields, strict</primary></indexterm> + <option>-fdo-lambda-eta-expansion</option> + <indexterm><primary><option></option></primary></indexterm> </term> <listitem> - <para>This option causes all constructor fields which are marked - strict (i.e. “!”) to be unpacked if possible. It is - equivalent to adding an <literal>UNPACK</literal> pragma to every - strict constructor field (see <xref linkend="unpack-pragma"/>). + <para><emphasis>On by default.</emphasis> + Eta-expand let-bindings to increase their arity. </para> - - <para>This option is a bit of a sledgehammer: it might sometimes - make things worse. Selectively unboxing fields by using - <literal>UNPACK</literal> pragmas might be better. An alternative - is to use <option>-funbox-strict-fields</option> to turn on - unboxing by default but disable it for certain constructor - fields using the <literal>NOUNPACK</literal> pragma (see - <xref linkend="nounpack-pragma"/>).</para> </listitem> </varlistentry> <varlistentry> <term> - <option>-funbox-small-strict-fields</option>: - <indexterm><primary><option>-funbox-small-strict-fields</option></primary></indexterm> - <indexterm><primary>strict constructor fields</primary></indexterm> - <indexterm><primary>constructor fields, strict</primary></indexterm> + <option>-fdo-eta-reduction</option> + <indexterm><primary><option></option></primary></indexterm> </term> <listitem> - <para><emphasis>On by default.</emphasis>. This option - causes all constructor fields which are marked strict - (i.e. “!”) and which representation is smaller - or equal to the size of a pointer to be unpacked, if - possible. It is equivalent to adding an - <literal>UNPACK</literal> pragma (see <xref - linkend="unpack-pragma"/>) to every strict constructor - field that fulfils the size restriction. - </para> - - <para>For example, the constructor fields in the following - data types -<programlisting> -data A = A !Int -data B = B !A -newtype C = C B -data D = D !C -</programlisting> - would all be represented by a single - <literal>Int#</literal> (see <xref linkend="primitives"/>) - value with - <option>-funbox-small-strict-fields</option> enabled. - </para> - - <para>This option is less of a sledgehammer than - <option>-funbox-strict-fields</option>: it should rarely make things - worse. If you use <option>-funbox-small-strict-fields</option> - to turn on unboxing by default you can disable it for certain - constructor fields using the <literal>NOUNPACK</literal> pragma (see - <xref linkend="nounpack-pragma"/>).</para> - - <para> - Note that for consistency <literal>Double</literal>, - <literal>Word64</literal>, and <literal>Int64</literal> constructor - fields are unpacked on 32-bit platforms, even though they are - technically larger than a pointer on those platforms. + <para><emphasis>On by default.</emphasis> + Eta-reduce lambda expressions, if doing so gets rid of a whole + group of lambdas. </para> </listitem> </varlistentry> <varlistentry> <term> - <option>-fspec-constr</option> - <indexterm><primary><option>-fspec-constr</option></primary></indexterm> + <option>-feager-blackholing</option> + <indexterm><primary><option></option></primary></indexterm> </term> <listitem> - <para><emphasis>Off by default, but enabled by -O2.</emphasis> - Turn on call-pattern specialisation; see - <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/spec-constr/index.htm"> - Call-pattern specialisation for Haskell programs</ulink>. - </para> - - <para>This optimisation specializes recursive functions according to - their argument "shapes". This is best explained by example so - consider: -<programlisting> -last :: [a] -> a -last [] = error "last" -last (x : []) = x -last (x : xs) = last xs -</programlisting> - In this code, once we pass the initial check for an empty list we - know that in the recursive case this pattern match is redundant. As - such <option>-fspec-constr</option> will transform the above code - to: -<programlisting> -last :: [a] -> a -last [] = error "last" -last (x : xs) = last' x xs - where - last' x [] = x - last' x (y : ys) = last' y ys -</programlisting> - </para> - - <para>As well avoid unnecessary pattern matching it also helps avoid - unnecessary allocation. This applies when a argument is strict in - the recursive call to itself but not on the initial entry. As - strict recursive branch of the function is created similar to the - above example. + <para>Usually GHC black-holes a thunk only when it switches + threads. This flag makes it do so as soon as the thunk is + entered. See <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/"> + Haskell on a shared-memory multiprocessor</ulink>. </para> </listitem> </varlistentry> <varlistentry> <term> - <option>-fspecialise</option> - <indexterm><primary><option>-fspecialise</option></primary></indexterm> + <option>-fexcess-precision</option> + <indexterm><primary><option>-fexcess-precision</option></primary></indexterm> </term> <listitem> - <para><emphasis>On by default.</emphasis> - Specialise each type-class-overloaded function defined in this - module for the types at which it is called in this module. Also - specialise imported functions that have an INLINABLE pragma - (<xref linkend="inlinable-pragma"/>) for the types at which they - are called in this module. + <para>When this option is given, intermediate floating + point values can have a <emphasis>greater</emphasis> + precision/range than the final type. Generally this is a + good thing, but some programs may rely on the exact + precision/range of + <literal>Float</literal>/<literal>Double</literal> values + and should not use this option for their compilation.</para> + + <para> + Note that the 32-bit x86 native code generator only + supports excess-precision mode, so neither + <option>-fexcess-precision</option> nor + <option>-fno-excess-precision</option> has any effect. + This is a known bug, see <xref linkend="bugs-ghc" />. </para> </listitem> </varlistentry> <varlistentry> <term> - <option>-fstatic-argument-transformation</option> - <indexterm><primary><option>-fstatic-argument-transformation</option></primary></indexterm> + <option>-fexpose-all-unfoldings</option> + <indexterm><primary><option></option></primary></indexterm> </term> <listitem> - <para>Turn on the static argument transformation, which turns a - recursive function into a non-recursive one with a local - recursive loop. See Chapter 7 of - <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/santos-thesis.ps.gz"> - Andre Santos's PhD thesis</ulink> + <para>An experimental flag to expose all unfoldings, even for very + large or recursive functions. This allows for all functions to be + inlined while usually GHC would avoid inlining larger functions. </para> </listitem> </varlistentry> @@ -2130,50 +2095,45 @@ last (x : xs) = last' x xs <varlistentry> <term> - <option>-fdo-lambda-eta-expansion</option> - <indexterm><primary><option></option></primary></indexterm> + <option>--ffun-to-thunk</option> + <indexterm><primary><option>-fignore-asserts</option></primary></indexterm> </term> <listitem> - <para><emphasis>On by default.</emphasis> - Eta-expand let-bindings to increase their arity. + <para>Worker-wrapper removes unused arguments, but usually we + do not remove them all, lest it turn a function closure into a thunk, + thereby perhaps causing extra allocation (since let-no-escape can't happen) + and/or a space leak. This flag + allows worker/wrapper to remove <emphasis>all</emphasis> value lambdas. + Off by default. </para> </listitem> </varlistentry> <varlistentry> <term> - <option>-fdo-eta-reduction</option> - <indexterm><primary><option></option></primary></indexterm> + <option>-fignore-asserts</option> + <indexterm><primary><option>-fignore-asserts</option></primary></indexterm> </term> <listitem> - <para><emphasis>On by default.</emphasis> - Eta-reduce lambda expressions, if doing so gets rid of a whole - group of lambdas. + <para>Causes GHC to ignore uses of the function + <literal>Exception.assert</literal> in source code (in + other words, rewriting <literal>Exception.assert p + e</literal> to <literal>e</literal> (see <xref + linkend="assertions"/>). This flag is turned on by + <option>-O</option>. </para> </listitem> </varlistentry> <varlistentry> <term> - <option>-fcase-merge</option> - <indexterm><primary><option></option></primary></indexterm> + <option>-fignore-interface-pragmas</option> + <indexterm><primary><option>-fignore-interface-pragmas</option></primary></indexterm> </term> <listitem> - <para><emphasis>On by default.</emphasis> - Merge immediately-nested case expressions that scrutinse the same variable. Example -<programlisting> - case x of - Red -> e1 - _ -> case x of - Blue -> e2 - Green -> e3 -==> - case x of - Red -> e1 - Blue -> e2 - Green -> e2 -</programlisting> - </para> + <para>Tells GHC to ignore all inessential information when reading interface files. + That is, even if <filename>M.hi</filename> contains unfolding or strictness information + for a function, GHC will ignore that information.</para> </listitem> </varlistentry> @@ -2195,26 +2155,25 @@ last (x : xs) = last' x xs <varlistentry> <term> - <option>-fdicts-cheap</option> - <indexterm><primary><option></option></primary></indexterm> + <option>-fliberate-case-threshold=N</option> + <indexterm><primary><option>-fliberate-case-threshold</option></primary></indexterm> </term> <listitem> - <para>A very experimental flag that makes dictionary-valued - expressions seem cheap to the optimiser. + <para>Set the size threshold for the liberate-case transformation. </para> </listitem> </varlistentry> <varlistentry> <term> - <option>-feager-blackholing</option> - <indexterm><primary><option></option></primary></indexterm> + <option>-fmax-relevant-bindings=N</option> + <indexterm><primary><option>-fmax-relevant-bindings</option></primary></indexterm> </term> <listitem> - <para>Usually GHC black-holes a thunk only when it switches - threads. This flag makes it do so as soon as the thunk is - entered. See <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/"> - Haskell on a shared-memory multiprocessor</ulink>. + <para>The type checker sometimes displays a fragment of the type environment + in error messages, but only up to some maximum number, set by this flag. + The default is 6. Turning it off with <option>-fno-max-relevant-bindings</option> + gives an unlimited number. </para> </listitem> </varlistentry> @@ -2236,6 +2195,42 @@ last (x : xs) = last' x xs <varlistentry> <term> + <option>-fomit-interface-pragmas</option> + <indexterm><primary><option>-fomit-interface-pragmas</option></primary></indexterm> + </term> + <listitem> + <para>Tells GHC to omit all inessential information from the + interface file generated for the module being compiled (say M). + This means that a module importing M will see only the + <emphasis>types</emphasis> of the functions that M exports, but + not their unfoldings, strictness info, etc. Hence, for example, + no function exported by M will be inlined into an importing module. + The benefit is that modules that import M will need to be + recompiled less often (only when M's exports change their type, not + when they change their implementation).</para> + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fomit-yields</option> + <indexterm><primary><option>-fomit-yields</option></primary></indexterm> + </term> + <listitem> + <para><emphasis>On by default.</emphasis> Tells GHC to omit + heap checks when no allocation is being performed. While this improves + binary sizes by about 5%, it also means that threads run in + tight non-allocating loops will not get preempted in a timely + fashion. If it is important to always be able to interrupt such + threads, you should turn this optimization off. Consider also + recompiling all libraries with this optimization turned off, if you + need to guarantee interruptibility. + </para> + </listitem> + </varlistentry> + + <varlistentry> + <term> <option>-fpedantic-bottoms</option> <indexterm><primary><option>-fpedantic-bottoms</option></primary></indexterm> </term> @@ -2251,6 +2246,38 @@ last (x : xs) = last' x xs <varlistentry> <term> + <option>-fregs-graph</option> + <indexterm><primary><option></option></primary></indexterm> + </term> + <listitem> + <para><emphasis>Off by default, but enabled by -O2. Only applies in + combination with the native code generator.</emphasis> + Use the graph colouring register allocator for register allocation + in the native code generator. By default, GHC uses a simpler, + faster linear register allocator. The downside being that the + linear register allocator usually generates worse code. + </para> + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fregs-iterative</option> + <indexterm><primary><option></option></primary></indexterm> + </term> + <listitem> + <para><emphasis>Off by default, only applies in combination with + the native code generator.</emphasis> + Use the iterative coalescing graph colouring register allocator for + register allocation in the native code generator. This is the same + register allocator as the <option>-freg-graph</option> one but also + enables iterative coalescing during register allocation. + </para> + </listitem> + </varlistentry> + + <varlistentry> + <term> <option>-fsimpl-tick-factor=<replaceable>n</replaceable></option> <indexterm><primary><option>-fsimpl-tick-factor</option></primary></indexterm> </term> @@ -2332,19 +2359,6 @@ last (x : xs) = last' x xs <varlistentry> <term> - <option>-fexpose-all-unfoldings</option> - <indexterm><primary><option></option></primary></indexterm> - </term> - <listitem> - <para>An experimental flag to expose all unfoldings, even for very - large or recursive functions. This allows for all functions to be - inlined while usually GHC would avoid inlining larger functions. - </para> - </listitem> - </varlistentry> - - <varlistentry> - <term> <option>-fvectorise</option> <indexterm><primary><option></option></primary></indexterm> </term> @@ -2363,142 +2377,170 @@ last (x : xs) = last' x xs <varlistentry> <term> - <option>-favoid-vect</option> - <indexterm><primary><option></option></primary></indexterm> + <option>-fspec-constr</option> + <indexterm><primary><option>-fspec-constr</option></primary></indexterm> </term> <listitem> - <para>Part of <link linkend="dph">Data Parallel Haskell - (DPH)</link>.</para> + <para><emphasis>Off by default, but enabled by -O2.</emphasis> + Turn on call-pattern specialisation; see + <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/spec-constr/index.htm"> + Call-pattern specialisation for Haskell programs</ulink>. + </para> - <para><emphasis>Off by default.</emphasis> Enable the - <emphasis>vectorisation</emphasis> avoidance optimisation. This - optimisation only works when used in combination with the - <option>-fvectorise</option> transformation.</para> + <para>This optimisation specializes recursive functions according to + their argument "shapes". This is best explained by example so + consider: +<programlisting> +last :: [a] -> a +last [] = error "last" +last (x : []) = x +last (x : xs) = last xs +</programlisting> + In this code, once we pass the initial check for an empty list we + know that in the recursive case this pattern match is redundant. As + such <option>-fspec-constr</option> will transform the above code + to: +<programlisting> +last :: [a] -> a +last [] = error "last" +last (x : xs) = last' x xs + where + last' x [] = x + last' x (y : ys) = last' y ys +</programlisting> + </para> - <para>While vectorisation of code using DPH is often a big win, it - can also produce worse results for some kinds of code. This - optimisation modifies the vectorisation transformation to try to - determine if a function would be better of unvectorised and if - so, do just that.</para> + <para>As well avoid unnecessary pattern matching it also helps avoid + unnecessary allocation. This applies when a argument is strict in + the recursive call to itself but not on the initial entry. As + strict recursive branch of the function is created similar to the + above example. + </para> </listitem> </varlistentry> <varlistentry> <term> - <option>-fregs-graph</option> - <indexterm><primary><option></option></primary></indexterm> + <option>-fspecialise</option> + <indexterm><primary><option>-fspecialise</option></primary></indexterm> </term> <listitem> - <para><emphasis>Off by default, but enabled by -O2. Only applies in - combination with the native code generator.</emphasis> - Use the graph colouring register allocator for register allocation - in the native code generator. By default, GHC uses a simpler, - faster linear register allocator. The downside being that the - linear register allocator usually generates worse code. + <para><emphasis>On by default.</emphasis> + Specialise each type-class-overloaded function defined in this + module for the types at which it is called in this module. Also + specialise imported functions that have an INLINABLE pragma + (<xref linkend="inlinable-pragma"/>) for the types at which they + are called in this module. </para> </listitem> </varlistentry> <varlistentry> <term> - <option>-fregs-iterative</option> - <indexterm><primary><option></option></primary></indexterm> + <option>-fstatic-argument-transformation</option> + <indexterm><primary><option>-fstatic-argument-transformation</option></primary></indexterm> </term> <listitem> - <para><emphasis>Off by default, only applies in combination with - the native code generator.</emphasis> - Use the iterative coalescing graph colouring register allocator for - register allocation in the native code generator. This is the same - register allocator as the <option>-freg-graph</option> one but also - enables iterative coalescing during register allocation. + <para>Turn on the static argument transformation, which turns a + recursive function into a non-recursive one with a local + recursive loop. See Chapter 7 of + <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/santos-thesis.ps.gz"> + Andre Santos's PhD thesis</ulink> </para> </listitem> </varlistentry> <varlistentry> <term> - <option>-fexcess-precision</option> - <indexterm><primary><option>-fexcess-precision</option></primary></indexterm> + <option>-fstrictness</option> + <indexterm><primary><option></option></primary></indexterm> </term> <listitem> - <para>When this option is given, intermediate floating - point values can have a <emphasis>greater</emphasis> - precision/range than the final type. Generally this is a - good thing, but some programs may rely on the exact - precision/range of - <literal>Float</literal>/<literal>Double</literal> values - and should not use this option for their compilation.</para> + <para> <emphasis>On by default.</emphasis>. + Switch on the strictness analyser. There is a very old paper about GHC's + strictness analyser, <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/simple-strictnes-analyser.ps.gz"> + Measuring the effectiveness of a simple strictness analyser</ulink>, + but the current one is quite a bit different. + </para> - <para> - Note that the 32-bit x86 native code generator only - supports excess-precision mode, so neither - <option>-fexcess-precision</option> nor - <option>-fno-excess-precision</option> has any effect. - This is a known bug, see <xref linkend="bugs-ghc" />. + <para>The strictness analyser figures out when arguments and + variables in a function can be treated 'strictly' (that is they + are always evaluated in the function at some point). This allow + GHC to apply certain optimisations such as unboxing that + otherwise don't apply as they change the semantics of the program + when applied to lazy arguments. </para> </listitem> </varlistentry> <varlistentry> <term> - <option>-fignore-asserts</option> - <indexterm><primary><option>-fignore-asserts</option></primary></indexterm> + <option>-funbox-strict-fields</option>: + <indexterm><primary><option>-funbox-strict-fields</option></primary></indexterm> + <indexterm><primary>strict constructor fields</primary></indexterm> + <indexterm><primary>constructor fields, strict</primary></indexterm> </term> <listitem> - <para>Causes GHC to ignore uses of the function - <literal>Exception.assert</literal> in source code (in - other words, rewriting <literal>Exception.assert p - e</literal> to <literal>e</literal> (see <xref - linkend="assertions"/>). This flag is turned on by - <option>-O</option>. + <para>This option causes all constructor fields which are marked + strict (i.e. “!”) to be unpacked if possible. It is + equivalent to adding an <literal>UNPACK</literal> pragma to every + strict constructor field (see <xref linkend="unpack-pragma"/>). </para> - </listitem> - </varlistentry> - <varlistentry> - <term> - <option>-fignore-interface-pragmas</option> - <indexterm><primary><option>-fignore-interface-pragmas</option></primary></indexterm> - </term> - <listitem> - <para>Tells GHC to ignore all inessential information when reading interface files. - That is, even if <filename>M.hi</filename> contains unfolding or strictness information - for a function, GHC will ignore that information.</para> + <para>This option is a bit of a sledgehammer: it might sometimes + make things worse. Selectively unboxing fields by using + <literal>UNPACK</literal> pragmas might be better. An alternative + is to use <option>-funbox-strict-fields</option> to turn on + unboxing by default but disable it for certain constructor + fields using the <literal>NOUNPACK</literal> pragma (see + <xref linkend="nounpack-pragma"/>).</para> </listitem> </varlistentry> <varlistentry> <term> - <option>-fomit-interface-pragmas</option> - <indexterm><primary><option>-fomit-interface-pragmas</option></primary></indexterm> + <option>-funbox-small-strict-fields</option>: + <indexterm><primary><option>-funbox-small-strict-fields</option></primary></indexterm> + <indexterm><primary>strict constructor fields</primary></indexterm> + <indexterm><primary>constructor fields, strict</primary></indexterm> </term> <listitem> - <para>Tells GHC to omit all inessential information from the - interface file generated for the module being compiled (say M). - This means that a module importing M will see only the - <emphasis>types</emphasis> of the functions that M exports, but - not their unfoldings, strictness info, etc. Hence, for example, - no function exported by M will be inlined into an importing module. - The benefit is that modules that import M will need to be - recompiled less often (only when M's exports change their type, not - when they change their implementation).</para> - </listitem> - </varlistentry> + <para><emphasis>On by default.</emphasis>. This option + causes all constructor fields which are marked strict + (i.e. “!”) and which representation is smaller + or equal to the size of a pointer to be unpacked, if + possible. It is equivalent to adding an + <literal>UNPACK</literal> pragma (see <xref + linkend="unpack-pragma"/>) to every strict constructor + field that fulfils the size restriction. + </para> - <varlistentry> - <term> - <option>-fomit-yields</option> - <indexterm><primary><option>-fomit-yields</option></primary></indexterm> - </term> - <listitem> - <para><emphasis>On by default.</emphasis> Tells GHC to omit - heap checks when no allocation is being performed. While this improves - binary sizes by about 5%, it also means that threads run in - tight non-allocating loops will not get preempted in a timely - fashion. If it is important to always be able to interrupt such - threads, you should turn this optimization off. Consider also - recompiling all libraries with this optimization turned off, if you - need to guarantee interruptibility. + <para>For example, the constructor fields in the following + data types +<programlisting> +data A = A !Int +data B = B !A +newtype C = C B +data D = D !C +</programlisting> + would all be represented by a single + <literal>Int#</literal> (see <xref linkend="primitives"/>) + value with + <option>-funbox-small-strict-fields</option> enabled. + </para> + + <para>This option is less of a sledgehammer than + <option>-funbox-strict-fields</option>: it should rarely make things + worse. If you use <option>-funbox-small-strict-fields</option> + to turn on unboxing by default you can disable it for certain + constructor fields using the <literal>NOUNPACK</literal> pragma (see + <xref linkend="nounpack-pragma"/>).</para> + + <para> + Note that for consistency <literal>Double</literal>, + <literal>Word64</literal>, and <literal>Int64</literal> constructor + fields are unpacked on 32-bit platforms, even though they are + technically larger than a pointer on those platforms. </para> </listitem> </varlistentry> diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 7b7e0a67d1..b42356fc06 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -246,7 +246,8 @@ defFullHelpText = " :info[!] [<name> ...] display information about the given names\n" ++ " (!: do not filter instances)\n" ++ " :issafe [<mod>] display safe haskell information of module <mod>\n" ++ - " :kind <type> show the kind of <type>\n" ++ + " :kind[!] <type> show the kind of <type>\n" ++ + " (!: also print the normalised type)\n" ++ " :load [*]<module> ... load module(s) and their dependents\n" ++ " :main [<arguments> ...] run the main function with the given arguments\n" ++ " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++ @@ -315,6 +316,7 @@ defFullHelpText = " :show linker show current linker state\n" ++ " :show modules show the currently loaded modules\n" ++ " :show packages show the currently active package flags\n" ++ + " :show paths show the currently active search paths\n" ++ " :show language show the currently active language flags\n" ++ " :show <setting> show value of <setting>, which is one of\n" ++ " [args, prog, prompt, editor, stop]\n" ++ @@ -2166,6 +2168,7 @@ showCmd str = do ["breaks"] -> showBkptTable ["context"] -> showContext ["packages"] -> showPackages + ["paths"] -> showPaths ["languages"] -> showLanguages -- backwards compat ["language"] -> showLanguages ["lang"] -> showLanguages -- useful abbreviation @@ -2273,6 +2276,19 @@ showPackages = do showFlag (TrustPackage p) = text $ " -trust " ++ p showFlag (DistrustPackage p) = text $ " -distrust " ++ p +showPaths :: GHCi () +showPaths = do + dflags <- getDynFlags + liftIO $ do + cwd <- getCurrentDirectory + putStrLn $ showSDoc dflags $ + text "current working directory: " $$ + nest 2 (text cwd) + let ipaths = importPaths dflags + putStrLn $ showSDoc dflags $ + text ("module import search paths:"++if null ipaths then " none" else "") $$ + nest 2 (vcat (map text ipaths)) + showLanguages :: GHCi () showLanguages = getDynFlags >>= liftIO . showLanguages' False @@ -2433,7 +2449,7 @@ completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do return (filter (w `isPrefixOf`) opts) where opts = ["args", "prog", "prompt", "prompt2", "editor", "stop", "modules", "bindings", "linker", "breaks", - "context", "packages", "language", "imports"] + "context", "packages", "paths", "language", "imports"] completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do return (filter (w `isPrefixOf`) ["language"]) diff --git a/libraries/Cabal b/libraries/Cabal -Subproject 85cb83d7d8dbc8e59e20d31323e660608eb5255 +Subproject 9f374ab45e62924506b992db9157c970c7259a0 diff --git a/libraries/binary b/libraries/binary -Subproject 4d890e4465a0494e5fd80fbcf1fb339d8bd5800 +Subproject 2799c25d85b4627200f2e4dcb30d2128488780c diff --git a/libraries/bytestring b/libraries/bytestring -Subproject 9692aaf0bf9b203f9249a1414637328fd31fc04 +Subproject 7d5b516ad0937b7cdc29798db33a37a598123b6 diff --git a/libraries/containers b/libraries/containers -Subproject 41bc140a140143fa517df4c1a08365474cde4d1 +Subproject 154cd539a22e4d82ff56fec2d8ad38855f78513 diff --git a/rts/posix/OSMem.c b/rts/posix/OSMem.c index 26aebc2b44..5486a15616 100644 --- a/rts/posix/OSMem.c +++ b/rts/posix/OSMem.c @@ -112,6 +112,27 @@ my_mmap (void *addr, W_ size) } else { vm_protect(mach_task_self(),(vm_address_t)ret,size,FALSE,VM_PROT_READ|VM_PROT_WRITE); } +#elif linux_HOST_OS + ret = mmap(addr, size, PROT_READ | PROT_WRITE, + MAP_ANON | MAP_PRIVATE, -1, 0); + if (ret == (void *)-1 && errno == EPERM) { + // Linux may return EPERM if it tried to give us + // a chunk of address space below mmap_min_addr, + // See Trac #7500. + if (addr != 0) { + // Try again with no hint address. + // It's not clear that this can ever actually help, + // but since our alternative is to abort, we may as well try. + ret = mmap(0, size, PROT_READ | PROT_WRITE, + MAP_ANON | MAP_PRIVATE, -1, 0); + } + if (ret == (void *)-1 && errno == EPERM) { + // Linux is not willing to give us any mapping, + // so treat this as an out-of-memory condition + // (really out of virtual address space). + errno = ENOMEM; + } + } #else ret = mmap(addr, size, PROT_READ | PROT_WRITE, MAP_ANON | MAP_PRIVATE, -1, 0); diff --git a/settings.in b/settings.in index 25699acc57..9f9654c689 100644 --- a/settings.in +++ b/settings.in @@ -14,6 +14,7 @@ ("touch command", "@SettingsTouchCommand@"), ("dllwrap command", "@SettingsDllWrapCommand@"), ("windres command", "@SettingsWindresCommand@"), + ("libtool command", "@SettingsLibtoolCommand@"), ("perl command", "@SettingsPerlCommand@"), ("target os", "@HaskellTargetOs@"), ("target arch", "@HaskellTargetArch@"), @@ -1008,6 +1008,28 @@ Please remove it (e.g. "rm -r libraries/time"), and then run EOF } + message "== Checking for obsolete Git repo URL"; + my $repo_url = &readgit(".", 'config', '--get', 'remote.origin.url'); + if ($repo_url =~ /^http:\/\/darcs.haskell.org/) { + print <<EOF; +============================ +ATTENTION! + +You seem to be using obsolete Git repository URLs. + +Please run + + ./sync-all -r git://git.haskell.org remote set-url + +or (in case port 9418/tcp is filtered by your firewall) + + ./sync-all -r http://git.haskell.org remote set-url + +to update your local checkout to use the new Git URLs. +============================ +EOF + } + $? = $ec; } |