diff options
127 files changed, 6101 insertions, 3639 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 7ea66e1db2..5c931d9d3a 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -324,38 +324,43 @@ instance Outputable RecFlag where \begin{code} data OverlapFlag - = NoOverlap -- This instance must not overlap another - - | OverlapOk -- Silently ignore this instance if you find a - -- more specific one that matches the constraint - -- you are trying to resolve - -- - -- Example: constraint (Foo [Int]) - -- instances (Foo [Int]) - - -- (Foo [a]) OverlapOk - -- Since the second instance has the OverlapOk flag, - -- the first instance will be chosen (otherwise - -- its ambiguous which to choose) - - | Incoherent -- 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 - -- - -- 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 + -- | This instance must not overlap another + = NoOverlap { isSafeOverlap :: Bool } + + -- | Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- Example: constraint (Foo [Int]) + -- instances (Foo [Int]) + -- (Foo [a]) OverlapOk + -- Since the second instance has the OverlapOk flag, + -- the first instance will be chosen (otherwise + -- 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 + -- + -- 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 + | Incoherent { isSafeOverlap :: Bool } deriving( Eq ) instance Outputable OverlapFlag where - ppr NoOverlap = empty - ppr OverlapOk = ptext (sLit "[overlap ok]") - ppr Incoherent = ptext (sLit "[incoherent]") + ppr (NoOverlap b) = empty <+> pprSafeOverlap b + ppr (OverlapOk b) = ptext (sLit "[overlap ok]") <+> pprSafeOverlap b + ppr (Incoherent b) = ptext (sLit "[incoherent]") <+> pprSafeOverlap b +pprSafeOverlap :: Bool -> SDoc +pprSafeOverlap True = ptext $ sLit "[safe]" +pprSafeOverlap False = empty \end{code} %************************************************************************ diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index c691f62676..b72c4beecf 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -442,7 +442,8 @@ mkDictSelId no_unf name clas -- for the ClassOp info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma - -- See Note [Single-method classes] for why alwaysInlinePragma + -- See Note [Single-method classes] in TcInstDcls + -- for why alwaysInlinePragma | otherwise = base_info `setSpecInfo` mkSpecInfo [rule] `setInlinePragInfo` neverInlinePragma -- Add a magic BuiltinRule, and never inline it diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index 89b3eddfd7..6e566a23ad 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -39,7 +39,8 @@ module Module dphSeqPackageId, dphParPackageId, mainPackageId, - + thisGhcPackageId, + -- * The Module type Module, modulePackageId, moduleName, @@ -342,7 +343,7 @@ packageIdString = unpackFS . packageIdFS integerPackageId, primPackageId, basePackageId, rtsPackageId, thPackageId, dphSeqPackageId, dphParPackageId, - mainPackageId :: PackageId + mainPackageId, thisGhcPackageId :: PackageId primPackageId = fsToPackageId (fsLit "ghc-prim") integerPackageId = fsToPackageId (fsLit cIntegerLibrary) basePackageId = fsToPackageId (fsLit "base") @@ -350,6 +351,7 @@ rtsPackageId = fsToPackageId (fsLit "rts") thPackageId = fsToPackageId (fsLit "template-haskell") dphSeqPackageId = fsToPackageId (fsLit "dph-seq") dphParPackageId = fsToPackageId (fsLit "dph-par") +thisGhcPackageId = fsToPackageId (fsLit ("ghc-" ++ cProjectVersion)) -- | This is the package Id for the current program. It is the default -- package Id if you don't specify a package name. We don't add this prefix diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index a2b42a278e..e88e4a1b02 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -244,7 +244,10 @@ isSystemName _ = False -- | Create a name which is (for now at least) local to the current module and hence -- does not need a 'Module' to disambiguate it from other 'Name's mkInternalName :: Unique -> OccName -> SrcSpan -> Name -mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal, n_occ = occ, n_loc = loc } +mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq + , n_sort = Internal + , n_occ = occ + , n_loc = loc } -- NB: You might worry that after lots of huffing and -- puffing we might end up with two local names with distinct -- uniques, but the same OccName. Indeed we can, but that's ok diff --git a/compiler/basicTypes/UniqSupply.lhs b/compiler/basicTypes/UniqSupply.lhs index 493bfbe6db..f34172f7b2 100644 --- a/compiler/basicTypes/UniqSupply.lhs +++ b/compiler/basicTypes/UniqSupply.lhs @@ -29,9 +29,10 @@ module UniqSupply ( import Unique import FastTypes +import GHC.IO (unsafeDupableInterleaveIO) + import MonadUtils import Control.Monad -import GHC.IO (unsafeDupableInterleaveIO) \end{code} diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index 830c879112..c81b868167 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -1,9 +1,6 @@ module CmmCallConv ( ParamLocation(..), - ArgumentFormat, - assignArguments, - assignArgumentsPos, - argumentsSize, + assignArgumentsPos ) where #include "HsVersions.h" @@ -21,25 +18,19 @@ import Outputable -- Calculate the 'GlobalReg' or stack locations for function call -- parameters as used by the Cmm calling convention. -data ParamLocation a +data ParamLocation = RegisterParam GlobalReg - | StackParam a + | StackParam ByteOff -instance (Outputable a) => Outputable (ParamLocation a) where +instance Outputable ParamLocation where ppr (RegisterParam g) = ppr g ppr (StackParam p) = ppr p -type ArgumentFormat a b = [(a, ParamLocation b)] - -assignArguments :: (a -> CmmType) -> [a] -> ArgumentFormat a WordOff --- Stack parameters are returned as word offsets. -assignArguments _ _ = panic "assignArguments only used in dead codegen" -- assignments - -- | JD: For the new stack story, I want arguments passed on the stack to manifest as -- positive offsets in a CallArea, not negative offsets from the stack pointer. -- Also, I want byte offsets, not word offsets. -assignArgumentsPos :: (Outputable a) => Convention -> (a -> CmmType) -> [a] -> - ArgumentFormat a ByteOff +assignArgumentsPos :: Convention -> (a -> CmmType) -> [a] -> + [(a, ParamLocation)] -- Given a list of arguments, and a function that tells their types, -- return a list showing where each argument is passed assignArgumentsPos conv arg_ty reps = assignments @@ -96,14 +87,6 @@ assignArgumentsPos conv arg_ty reps = assignments where w = typeWidth (arg_ty r) size = (((widthInBytes w - 1) `div` wORD_SIZE) + 1) * wORD_SIZE off' = offset + size - - -argumentsSize :: (a -> CmmType) -> [a] -> WordOff -argumentsSize f reps = maximum (0 : map arg_top args) - where - args = assignArguments f reps - arg_top (_, StackParam offset) = -offset - arg_top (_, RegisterParam _) = 0 ----------------------------------------------------------------------------- -- Local information about the registers available diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 9382d8d1ed..83d72b8f6e 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -83,7 +83,7 @@ toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) = strip_hints :: [Old.CmmHinted a] -> [a] strip_hints = map Old.hintlessCmm -convert_target :: Old.CmmCallTarget -> Old.HintedCmmFormals -> Old.HintedCmmActuals -> ForeignTarget +convert_target :: Old.CmmCallTarget -> [Old.HintedCmmFormal] -> [Old.HintedCmmActual] -> ForeignTarget convert_target (Old.CmmCallee e cc) ress args = ForeignTarget e (ForeignConvention cc (map Old.cmmHint args) (map Old.cmmHint ress)) convert_target (Old.CmmPrim op) _ress _args = PrimTarget op diff --git a/compiler/cmm/CmmDecl.hs b/compiler/cmm/CmmDecl.hs index e2da59beac..38eda2d1ac 100644 --- a/compiler/cmm/CmmDecl.hs +++ b/compiler/cmm/CmmDecl.hs @@ -10,7 +10,7 @@ module CmmDecl ( GenCmm(..), GenCmmTop(..), CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription, ProfilingInfo(..), ClosureTypeTag, - CmmActual, CmmActuals, CmmFormal, CmmFormals, ForeignHint(..), + CmmActual, CmmFormal, ForeignHint(..), CmmStatic(..), Section(..), ) where @@ -114,8 +114,6 @@ type SelectorOffset = StgWord type CmmActual = CmmExpr type CmmFormal = LocalReg -type CmmActuals = [CmmActual] -type CmmFormals = [CmmFormal] data ForeignHint = NoHint | AddrHint | SignedHint diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 869bc1b4ac..b8cd3280e8 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -10,7 +10,7 @@ module CmmExpr , DefinerOfSlots, UserOfSlots, foldSlotsDefd, foldSlotsUsed , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet , plusRegSet, minusRegSet, timesRegSet - , regUsedIn + , regUsedIn, regSlot , Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, isStackSlotOf , module CmmMachOp , module CmmType @@ -267,6 +267,9 @@ isStackSlotOf :: CmmExpr -> LocalReg -> Bool isStackSlotOf (CmmStackSlot (RegSlot r) _) r' = r == r' isStackSlotOf _ _ = False +regSlot :: LocalReg -> CmmExpr +regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r) + ----------------------------------------------------------------------------- -- Stack slot use information for expressions and other types [_$_] ----------------------------------------------------------------------------- diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs index c87a3a9b33..ca3ab095ed 100644 --- a/compiler/cmm/CmmLive.hs +++ b/compiler/cmm/CmmLive.hs @@ -1,11 +1,13 @@ {-# LANGUAGE GADTs #-} + {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module CmmLive ( CmmLive , cmmLiveness , liveLattice - , noLiveOnEntry, xferLive + , noLiveOnEntry, xferLive, gen, kill, gen_kill + , removeDeadAssignments ) where @@ -47,9 +49,6 @@ cmmLiveness graph = where entry = g_entry graph check facts = noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts -gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) => a -> CmmLive -> CmmLive -gen_kill a = gen a . kill a - -- | On entry to the procedure, there had better not be any LocalReg's live-in. noLiveOnEntry :: BlockId -> CmmLive -> a -> a noLiveOnEntry bid in_fact x = @@ -57,19 +56,47 @@ noLiveOnEntry bid in_fact x = else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact) -- | The transfer equations use the traditional 'gen' and 'kill' --- notations, which should be familiar from the dragon book. -gen :: UserOfLocalRegs a => a -> RegSet -> RegSet -gen a live = foldRegsUsed extendRegSet live a +-- notations, which should be familiar from the Dragon Book. +gen :: UserOfLocalRegs a => a -> RegSet -> RegSet +gen a live = foldRegsUsed extendRegSet live a kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet kill a live = foldRegsDefd delOneFromUniqSet live a --- Testing! +gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) => a -> CmmLive -> CmmLive +gen_kill a = gen a . kill a + +-- | The transfer function +-- EZY: Bits of this analysis are duplicated in CmmSpillReload, though +-- it's not really easy to efficiently reuse all of this. Keep in mind +-- if you need to update this analysis. xferLive :: BwdTransfer CmmNode CmmLive xferLive = mkBTransfer3 fst mid lst where fst _ f = f mid :: CmmNode O O -> CmmLive -> CmmLive mid n f = gen_kill n f lst :: CmmNode O C -> FactBase CmmLive -> CmmLive - lst n f = gen_kill n $ case n of CmmCall {} -> emptyRegSet - CmmForeignCall {} -> emptyRegSet - _ -> joinOutFacts liveLattice n f + -- slightly inefficient: kill is unnecessary for emptyRegSet + lst n f = gen_kill n + $ case n of CmmCall{} -> emptyRegSet + CmmForeignCall{} -> emptyRegSet + _ -> joinOutFacts liveLattice n f + +----------------------------------------------------------------------------- +-- Removing assignments to dead variables +----------------------------------------------------------------------------- + +removeDeadAssignments :: CmmGraph -> FuelUniqSM CmmGraph +removeDeadAssignments g = + liftM fst $ dataflowPassBwd g [] $ analRewBwd liveLattice xferLive rewrites + where rewrites = deepBwdRw3 nothing middle nothing + -- Beware: deepBwdRw with one polymorphic function seems more reasonable here, + -- but GHC panics while compiling, see bug #4045. + middle :: CmmNode O O -> Fact O CmmLive -> CmmReplGraph O O + middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` live) = return $ Just emptyGraph + -- XXX maybe this should be somewhere else... + middle (CmmAssign lhs (CmmReg rhs)) _ | lhs == rhs = return $ Just emptyGraph + middle (CmmStore lhs (CmmLoad rhs _)) _ | lhs == rhs = return $ Just emptyGraph + middle _ _ = return Nothing + + nothing :: CmmNode e x -> Fact x CmmLive -> CmmReplGraph e x + nothing _ _ = return Nothing diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs index 7d50d9ae72..f7950423fe 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -11,6 +11,7 @@ module CmmNode ( CmmNode(..) , UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..) , mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf + , mapExpM, mapExpDeepM, wrapRecExpM ) where @@ -22,6 +23,7 @@ import SMRep import Compiler.Hoopl import Data.Maybe +import Data.List (tails) import Prelude hiding (succ) @@ -42,8 +44,8 @@ data CmmNode e x where -- Like a "fat machine instruction"; can occur -- in the middle of a block ForeignTarget -> -- call target - CmmFormals -> -- zero or more results - CmmActuals -> -- zero or more arguments + [CmmFormal] -> -- zero or more results + [CmmActual] -> -- zero or more arguments CmmNode O O -- Semantics: kills only result regs; all other regs (both GlobalReg -- and LocalReg) are preserved. But there is a current @@ -105,8 +107,8 @@ data CmmNode e x where CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls] -- Always the last node of a block tgt :: ForeignTarget, -- call target and convention - res :: CmmFormals, -- zero or more results - args :: CmmActuals, -- zero or more arguments; see Note [Register parameter passing] + res :: [CmmFormal], -- zero or more results + args :: [CmmActual], -- zero or more arguments; see Note [Register parameter passing] succ :: Label, -- Label of continuation updfr :: UpdFrameOffset, -- where the update frame is (for building infotable) intrbl:: Bool -- whether or not the call is interruptible @@ -323,6 +325,54 @@ mapExp f (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapFor mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x mapExpDeep f = mapExp $ wrapRecExp f +------------------------------------------------------------------------ +-- mapping Expr in CmmNode, but not performing allocation if no changes + +mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget +mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e +mapForeignTargetM _ (PrimTarget _) = Nothing + +wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr) +wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es) +wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr) +wrapRecExpM f e = f e + +mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) +mapExpM _ (CmmEntry _) = Nothing +mapExpM _ (CmmComment _) = Nothing +mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e +mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e] +mapExpM _ (CmmBranch _) = Nothing +mapExpM f (CmmCondBranch e ti fi) = (\x -> CmmCondBranch x ti fi) `fmap` f e +mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e +mapExpM f (CmmCall tgt mb_id o i s) = (\x -> CmmCall x mb_id o i s) `fmap` f tgt +mapExpM f (CmmUnsafeForeignCall tgt fs as) + = case mapForeignTargetM f tgt of + Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as)) + Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as +mapExpM f (CmmForeignCall tgt fs as succ updfr intrbl) + = case mapForeignTargetM f tgt of + Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ updfr intrbl) + Nothing -> (\xs -> CmmForeignCall tgt fs xs succ updfr intrbl) `fmap` mapListM f as + +-- share as much as possible +mapListM :: (a -> Maybe a) -> [a] -> Maybe [a] +mapListM f xs = let (b, r) = mapListT f xs + in if b then Just r else Nothing + +mapListJ :: (a -> Maybe a) -> [a] -> [a] +mapListJ f xs = snd (mapListT f xs) + +mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a]) +mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs)) + where g (_, y, Nothing) (True, ys) = (True, y:ys) + g (_, _, Just y) (True, ys) = (True, y:ys) + g (ys', _, Nothing) (False, _) = (False, ys') + g (_, _, Just y) (False, ys) = (True, y:ys) + +mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) +mapExpDeepM f = mapExpM $ wrapRecExpM f + ----------------------------------- -- folding Expr in CmmNode diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 69df4fbff1..dab866e186 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -14,10 +14,11 @@ ----------------------------------------------------------------------------- module CmmOpt ( - cmmEliminateDeadBlocks, - cmmMiniInline, - cmmMachOpFold, - cmmLoopifyForC, + cmmEliminateDeadBlocks, + cmmMiniInline, + cmmMachOpFold, + cmmMachOpFoldM, + cmmLoopifyForC, ) where #include "HsVersions.h" @@ -302,114 +303,123 @@ inlineExpr u a other_expr = other_expr -- been optimized and folded. cmmMachOpFold - :: MachOp -- The operation from an CmmMachOp - -> [CmmExpr] -- The optimized arguments + :: MachOp -- The operation from an CmmMachOp + -> [CmmExpr] -- The optimized arguments -> CmmExpr -cmmMachOpFold op arg@[CmmLit (CmmInt x rep)] - = case op of +cmmMachOpFold op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM op args) + +-- Returns Nothing if no changes, useful for Hoopl, also reduces +-- allocation! +cmmMachOpFoldM + :: MachOp + -> [CmmExpr] + -> Maybe CmmExpr + +cmmMachOpFoldM op arg@[CmmLit (CmmInt x rep)] + = Just $ case op of MO_S_Neg r -> CmmLit (CmmInt (-x) rep) MO_Not r -> CmmLit (CmmInt (complement x) rep) - -- these are interesting: we must first narrow to the - -- "from" type, in order to truncate to the correct size. - -- The final narrow/widen to the destination type - -- is implicit in the CmmLit. + -- these are interesting: we must first narrow to the + -- "from" type, in order to truncate to the correct size. + -- The final narrow/widen to the destination type + -- is implicit in the CmmLit. MO_SF_Conv from to -> CmmLit (CmmFloat (fromInteger x) to) MO_SS_Conv from to -> CmmLit (CmmInt (narrowS from x) to) MO_UU_Conv from to -> CmmLit (CmmInt (narrowU from x) to) - _ -> panic "cmmMachOpFold: unknown unary op" + _ -> panic "cmmMachOpFoldM: unknown unary op" -- Eliminate conversion NOPs -cmmMachOpFold (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = x -cmmMachOpFold (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = x +cmmMachOpFoldM (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x +cmmMachOpFoldM (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x -- Eliminate nested conversions where possible -cmmMachOpFold conv_outer args@[CmmMachOp conv_inner [x]] +cmmMachOpFoldM conv_outer args@[CmmMachOp conv_inner [x]] | Just (rep1,rep2,signed1) <- isIntConversion conv_inner, Just (_, rep3,signed2) <- isIntConversion conv_outer = case () of - -- widen then narrow to the same size is a nop - _ | rep1 < rep2 && rep1 == rep3 -> x - -- Widen then narrow to different size: collapse to single conversion - -- but remember to use the signedness from the widening, just in case - -- the final conversion is a widen. - | rep1 < rep2 && rep2 > rep3 -> - cmmMachOpFold (intconv signed1 rep1 rep3) [x] - -- Nested widenings: collapse if the signedness is the same - | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 -> - cmmMachOpFold (intconv signed1 rep1 rep3) [x] - -- Nested narrowings: collapse - | rep1 > rep2 && rep2 > rep3 -> - cmmMachOpFold (MO_UU_Conv rep1 rep3) [x] - | otherwise -> - CmmMachOp conv_outer args + -- widen then narrow to the same size is a nop + _ | rep1 < rep2 && rep1 == rep3 -> Just x + -- Widen then narrow to different size: collapse to single conversion + -- but remember to use the signedness from the widening, just in case + -- the final conversion is a widen. + | rep1 < rep2 && rep2 > rep3 -> + Just $ cmmMachOpFold (intconv signed1 rep1 rep3) [x] + -- Nested widenings: collapse if the signedness is the same + | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 -> + Just $ cmmMachOpFold (intconv signed1 rep1 rep3) [x] + -- Nested narrowings: collapse + | rep1 > rep2 && rep2 > rep3 -> + Just $ cmmMachOpFold (MO_UU_Conv rep1 rep3) [x] + | otherwise -> + Nothing where - isIntConversion (MO_UU_Conv rep1 rep2) - = Just (rep1,rep2,False) - isIntConversion (MO_SS_Conv rep1 rep2) - = Just (rep1,rep2,True) - isIntConversion _ = Nothing + isIntConversion (MO_UU_Conv rep1 rep2) + = Just (rep1,rep2,False) + isIntConversion (MO_SS_Conv rep1 rep2) + = Just (rep1,rep2,True) + isIntConversion _ = Nothing - intconv True = MO_SS_Conv - intconv False = MO_UU_Conv + intconv True = MO_SS_Conv + intconv False = MO_UU_Conv -- ToDo: a narrow of a load can be collapsed into a narrow load, right? -- but what if the architecture only supports word-sized loads, should -- we do the transformation anyway? -cmmMachOpFold mop args@[CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] +cmmMachOpFoldM mop args@[CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] = case mop of - -- for comparisons: don't forget to narrow the arguments before - -- comparing, since they might be out of range. - MO_Eq r -> CmmLit (CmmInt (if x_u == y_u then 1 else 0) wordWidth) - MO_Ne r -> CmmLit (CmmInt (if x_u /= y_u then 1 else 0) wordWidth) - - MO_U_Gt r -> CmmLit (CmmInt (if x_u > y_u then 1 else 0) wordWidth) - MO_U_Ge r -> CmmLit (CmmInt (if x_u >= y_u then 1 else 0) wordWidth) - MO_U_Lt r -> CmmLit (CmmInt (if x_u < y_u then 1 else 0) wordWidth) - MO_U_Le r -> CmmLit (CmmInt (if x_u <= y_u then 1 else 0) wordWidth) - - MO_S_Gt r -> CmmLit (CmmInt (if x_s > y_s then 1 else 0) wordWidth) - MO_S_Ge r -> CmmLit (CmmInt (if x_s >= y_s then 1 else 0) wordWidth) - MO_S_Lt r -> CmmLit (CmmInt (if x_s < y_s then 1 else 0) wordWidth) - MO_S_Le r -> CmmLit (CmmInt (if x_s <= y_s then 1 else 0) wordWidth) - - MO_Add r -> CmmLit (CmmInt (x + y) r) - MO_Sub r -> CmmLit (CmmInt (x - y) r) - MO_Mul r -> CmmLit (CmmInt (x * y) r) - MO_U_Quot r | y /= 0 -> CmmLit (CmmInt (x_u `quot` y_u) r) - MO_U_Rem r | y /= 0 -> CmmLit (CmmInt (x_u `rem` y_u) r) - MO_S_Quot r | y /= 0 -> CmmLit (CmmInt (x `quot` y) r) - MO_S_Rem r | y /= 0 -> CmmLit (CmmInt (x `rem` y) r) - - MO_And r -> CmmLit (CmmInt (x .&. y) r) - MO_Or r -> CmmLit (CmmInt (x .|. y) r) - MO_Xor r -> CmmLit (CmmInt (x `xor` y) r) - - MO_Shl r -> CmmLit (CmmInt (x `shiftL` fromIntegral y) r) - MO_U_Shr r -> CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r) - MO_S_Shr r -> CmmLit (CmmInt (x `shiftR` fromIntegral y) r) - - other -> CmmMachOp mop args + -- for comparisons: don't forget to narrow the arguments before + -- comparing, since they might be out of range. + MO_Eq r -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) wordWidth) + MO_Ne r -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) wordWidth) + + MO_U_Gt r -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) wordWidth) + MO_U_Ge r -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) wordWidth) + MO_U_Lt r -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) wordWidth) + MO_U_Le r -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) wordWidth) + + MO_S_Gt r -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) wordWidth) + MO_S_Ge r -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) wordWidth) + MO_S_Lt r -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) wordWidth) + MO_S_Le r -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) wordWidth) + + MO_Add r -> Just $ CmmLit (CmmInt (x + y) r) + MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r) + MO_Mul r -> Just $ CmmLit (CmmInt (x * y) r) + MO_U_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `quot` y_u) r) + MO_U_Rem r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `rem` y_u) r) + MO_S_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x `quot` y) r) + MO_S_Rem r | y /= 0 -> Just $ CmmLit (CmmInt (x `rem` y) r) + + MO_And r -> Just $ CmmLit (CmmInt (x .&. y) r) + MO_Or r -> Just $ CmmLit (CmmInt (x .|. y) r) + MO_Xor r -> Just $ CmmLit (CmmInt (x `xor` y) r) + + MO_Shl r -> Just $ CmmLit (CmmInt (x `shiftL` fromIntegral y) r) + MO_U_Shr r -> Just $ CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r) + MO_S_Shr r -> Just $ CmmLit (CmmInt (x `shiftR` fromIntegral y) r) + + other -> Nothing where - x_u = narrowU xrep x - y_u = narrowU xrep y - x_s = narrowS xrep x - y_s = narrowS xrep y - + x_u = narrowU xrep x + y_u = narrowU xrep y + x_s = narrowS xrep x + y_s = narrowS xrep y + -- When possible, shift the constants to the right-hand side, so that we -- can match for strength reductions. Note that the code generator will -- also assume that constants have been shifted to the right when -- possible. -cmmMachOpFold op [x@(CmmLit _), y] - | not (isLit y) && isCommutableMachOp op - = cmmMachOpFold op [y, x] +cmmMachOpFoldM op [x@(CmmLit _), y] + | not (isLit y) && isCommutableMachOp op + = Just (cmmMachOpFold op [y, x]) -- Turn (a+b)+c into a+(b+c) where possible. Because literals are -- moved to the right, it is more likely that we will find @@ -427,38 +437,38 @@ cmmMachOpFold op [x@(CmmLit _), y] -- Also don't do it if arg1 is PicBaseReg, so that we don't separate the -- PicBaseReg from the corresponding label (or label difference). -- -cmmMachOpFold mop1 [CmmMachOp mop2 [arg1,arg2], arg3] +cmmMachOpFoldM mop1 [CmmMachOp mop2 [arg1,arg2], arg3] | mop2 `associates_with` mop1 && not (isLit arg1) && not (isPicReg arg1) - = cmmMachOpFold mop2 [arg1, cmmMachOpFold mop1 [arg2,arg3]] + = Just (cmmMachOpFold mop2 [arg1, cmmMachOpFold mop1 [arg2,arg3]]) where MO_Add{} `associates_with` MO_Sub{} = True mop1 `associates_with` mop2 = mop1 == mop2 && isAssociativeMachOp mop1 -- special case: (a - b) + c ==> a + (c - b) -cmmMachOpFold mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3] +cmmMachOpFoldM mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3] | not (isLit arg1) && not (isPicReg arg1) - = cmmMachOpFold mop1 [arg1, cmmMachOpFold mop2 [arg3,arg2]] + = Just (cmmMachOpFold mop1 [arg1, cmmMachOpFold mop2 [arg3,arg2]]) -- Make a RegOff if we can -cmmMachOpFold (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] - = CmmRegOff reg (fromIntegral (narrowS rep n)) -cmmMachOpFold (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] - = CmmRegOff reg (off + fromIntegral (narrowS rep n)) -cmmMachOpFold (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)] - = CmmRegOff reg (- fromIntegral (narrowS rep n)) -cmmMachOpFold (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] - = CmmRegOff reg (off - fromIntegral (narrowS rep n)) +cmmMachOpFoldM (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] + = Just $ CmmRegOff reg (fromIntegral (narrowS rep n)) +cmmMachOpFoldM (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + = Just $ CmmRegOff reg (off + fromIntegral (narrowS rep n)) +cmmMachOpFoldM (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)] + = Just $ CmmRegOff reg (- fromIntegral (narrowS rep n)) +cmmMachOpFoldM (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + = Just $ CmmRegOff reg (off - fromIntegral (narrowS rep n)) -- Fold label(+/-)offset into a CmmLit where possible -cmmMachOpFold (MO_Add _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)] - = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i))) -cmmMachOpFold (MO_Add _) [CmmLit (CmmInt i rep), CmmLit (CmmLabel lbl)] - = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i))) -cmmMachOpFold (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)] - = CmmLit (CmmLabelOff lbl (fromIntegral (negate (narrowU rep i)))) +cmmMachOpFoldM (MO_Add _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)] + = Just $ CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i))) +cmmMachOpFoldM (MO_Add _) [CmmLit (CmmInt i rep), CmmLit (CmmLabel lbl)] + = Just $ CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i))) +cmmMachOpFoldM (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)] + = Just $ CmmLit (CmmLabelOff lbl (fromIntegral (negate (narrowU rep i)))) -- Comparison of literal with widened operand: perform the comparison @@ -471,7 +481,7 @@ cmmMachOpFold (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)] #if i386_TARGET_ARCH || x86_64_TARGET_ARCH -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try -cmmMachOpFold cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] +cmmMachOpFoldM cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] | -- if the operand is widened: Just (rep, signed, narrow_fn) <- maybe_conversion conv, -- and this is a comparison operation: @@ -479,7 +489,7 @@ cmmMachOpFold cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] -- and the literal fits in the smaller size: i == narrow_fn rep i -- then we can do the comparison at the smaller size - = cmmMachOpFold narrow_cmp [x, CmmLit (CmmInt i rep)] + = Just (cmmMachOpFold narrow_cmp [x, CmmLit (CmmInt i rep)]) where maybe_conversion (MO_UU_Conv from to) | to > from @@ -491,7 +501,7 @@ cmmMachOpFold cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] -- don't attempt to apply this optimisation when the source -- is a float; see #1916 maybe_conversion _ = Nothing - + -- careful (#2080): if the original comparison was signed, but -- we were doing an unsigned widen, then we must do an -- unsigned comparison at the smaller size. @@ -514,94 +524,92 @@ cmmMachOpFold cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] -- We can often do something with constants of 0 and 1 ... -cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 0 _))] +cmmMachOpFoldM mop args@[x, y@(CmmLit (CmmInt 0 _))] = case mop of - MO_Add r -> x - MO_Sub r -> x - MO_Mul r -> y - MO_And r -> y - MO_Or r -> x - MO_Xor r -> x - MO_Shl r -> x - MO_S_Shr r -> x - MO_U_Shr r -> x - MO_Ne r | isComparisonExpr x -> x - MO_Eq r | Just x' <- maybeInvertCmmExpr x -> x' - MO_U_Gt r | isComparisonExpr x -> x - MO_S_Gt r | isComparisonExpr x -> x - MO_U_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordWidth) - MO_S_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordWidth) - MO_U_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordWidth) - MO_S_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordWidth) - MO_U_Le r | Just x' <- maybeInvertCmmExpr x -> x' - MO_S_Le r | Just x' <- maybeInvertCmmExpr x -> x' - other -> CmmMachOp mop args - -cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 1 rep))] + MO_Add r -> Just x + MO_Sub r -> Just x + MO_Mul r -> Just y + MO_And r -> Just y + MO_Or r -> Just x + MO_Xor r -> Just x + MO_Shl r -> Just x + MO_S_Shr r -> Just x + MO_U_Shr r -> Just x + MO_Ne r | isComparisonExpr x -> Just x + MO_Eq r | Just x' <- maybeInvertCmmExpr x -> Just x' + MO_U_Gt r | isComparisonExpr x -> Just x + MO_S_Gt r | isComparisonExpr x -> Just x + MO_U_Lt r | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth) + MO_S_Lt r | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth) + MO_U_Ge r | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth) + MO_S_Ge r | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth) + MO_U_Le r | Just x' <- maybeInvertCmmExpr x -> Just x' + MO_S_Le r | Just x' <- maybeInvertCmmExpr x -> Just x' + other -> Nothing + +cmmMachOpFoldM mop args@[x, y@(CmmLit (CmmInt 1 rep))] = case mop of - MO_Mul r -> x - MO_S_Quot r -> x - MO_U_Quot r -> x - MO_S_Rem r -> CmmLit (CmmInt 0 rep) - MO_U_Rem r -> CmmLit (CmmInt 0 rep) - MO_Ne r | Just x' <- maybeInvertCmmExpr x -> x' - MO_Eq r | isComparisonExpr x -> x - MO_U_Lt r | Just x' <- maybeInvertCmmExpr x -> x' - MO_S_Lt r | Just x' <- maybeInvertCmmExpr x -> x' - MO_U_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordWidth) - MO_S_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordWidth) - MO_U_Le r | isComparisonExpr x -> CmmLit (CmmInt 1 wordWidth) - MO_S_Le r | isComparisonExpr x -> CmmLit (CmmInt 1 wordWidth) - MO_U_Ge r | isComparisonExpr x -> x - MO_S_Ge r | isComparisonExpr x -> x - other -> CmmMachOp mop args + MO_Mul r -> Just x + MO_S_Quot r -> Just x + MO_U_Quot r -> Just x + MO_S_Rem r -> Just $ CmmLit (CmmInt 0 rep) + MO_U_Rem r -> Just $ CmmLit (CmmInt 0 rep) + MO_Ne r | Just x' <- maybeInvertCmmExpr x -> Just x' + MO_Eq r | isComparisonExpr x -> Just x + MO_U_Lt r | Just x' <- maybeInvertCmmExpr x -> Just x' + MO_S_Lt r | Just x' <- maybeInvertCmmExpr x -> Just x' + MO_U_Gt r | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth) + MO_S_Gt r | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth) + MO_U_Le r | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth) + MO_S_Le r | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth) + MO_U_Ge r | isComparisonExpr x -> Just x + MO_S_Ge r | isComparisonExpr x -> Just x + other -> Nothing -- Now look for multiplication/division by powers of 2 (integers). -cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt n _))] +cmmMachOpFoldM mop args@[x, y@(CmmLit (CmmInt n _))] = case mop of - MO_Mul rep - | Just p <- exactLog2 n -> - cmmMachOpFold (MO_Shl rep) [x, CmmLit (CmmInt p rep)] - MO_U_Quot rep - | Just p <- exactLog2 n -> - cmmMachOpFold (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)] - MO_S_Quot rep - | Just p <- exactLog2 n, - CmmReg _ <- x -> -- We duplicate x below, hence require - -- it is a reg. FIXME: remove this restriction. - -- shift right is not the same as quot, because it rounds - -- to minus infinity, whereasq quot rounds toward zero. - -- To fix this up, we add one less than the divisor to the - -- dividend if it is a negative number. - -- - -- to avoid a test/jump, we use the following sequence: - -- x1 = x >> word_size-1 (all 1s if -ve, all 0s if +ve) - -- x2 = y & (divisor-1) - -- result = (x+x2) >>= log2(divisor) - -- this could be done a bit more simply using conditional moves, - -- but we're processor independent here. - -- - -- we optimise the divide by 2 case slightly, generating - -- x1 = x >> word_size-1 (unsigned) - -- return = (x + x1) >>= log2(divisor) - let - bits = fromIntegral (widthInBits rep) - 1 - shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep - x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)] - x2 = if p == 1 then x1 else - CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)] - x3 = CmmMachOp (MO_Add rep) [x, x2] - in - cmmMachOpFold (MO_S_Shr rep) [x3, CmmLit (CmmInt p rep)] - other - -> unchanged - where - unchanged = CmmMachOp mop args + MO_Mul rep + | Just p <- exactLog2 n -> + Just (cmmMachOpFold (MO_Shl rep) [x, CmmLit (CmmInt p rep)]) + MO_U_Quot rep + | Just p <- exactLog2 n -> + Just (cmmMachOpFold (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)]) + MO_S_Quot rep + | Just p <- exactLog2 n, + CmmReg _ <- x -> -- We duplicate x below, hence require + -- it is a reg. FIXME: remove this restriction. + -- shift right is not the same as quot, because it rounds + -- to minus infinity, whereasq quot rounds toward zero. + -- To fix this up, we add one less than the divisor to the + -- dividend if it is a negative number. + -- + -- to avoid a test/jump, we use the following sequence: + -- x1 = x >> word_size-1 (all 1s if -ve, all 0s if +ve) + -- x2 = y & (divisor-1) + -- result = (x+x2) >>= log2(divisor) + -- this could be done a bit more simply using conditional moves, + -- but we're processor independent here. + -- + -- we optimise the divide by 2 case slightly, generating + -- x1 = x >> word_size-1 (unsigned) + -- return = (x + x1) >>= log2(divisor) + let + bits = fromIntegral (widthInBits rep) - 1 + shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep + x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)] + x2 = if p == 1 then x1 else + CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)] + x3 = CmmMachOp (MO_Add rep) [x, x2] + in + Just (cmmMachOpFold (MO_S_Shr rep) [x3, CmmLit (CmmInt p rep)]) + other + -> Nothing -- Anything else is just too hard. -cmmMachOpFold mop args = CmmMachOp mop args +cmmMachOpFoldM _ _ = Nothing -- ----------------------------------------------------------------------------- -- exactLog2 diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmPipeline.hs index 35eabb3317..1e4809d2b2 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -2,21 +2,24 @@ -- Norman likes local bindings -- If this module lives on I'd like to get rid of this flag in due course -module CmmCPS ( - -- | Converts C-- with full proceedures and parameters - -- to a CPS transformed C-- with the stack made manifest. - -- Well, sort of. - protoCmmCPS +module CmmPipeline ( + -- | Converts C-- with an implicit stack and native C-- calls into + -- optimized, CPS converted and native-call-less C--. The latter + -- C-- can be used to generate assembly. + cmmPipeline ) where import CLabel import Cmm import CmmDecl +import CmmLive import CmmBuildInfoTables import CmmCommonBlockElim import CmmProcPoint import CmmSpillReload +import CmmRewriteAssignments import CmmStackLayout +import CmmContFlowOpt import OptimizationFuel import DynFlags @@ -30,7 +33,7 @@ import Outputable import StaticFlags ----------------------------------------------------------------------------- --- |Top level driver for the CPS pass +-- | Top level driver for C-- pipeline ----------------------------------------------------------------------------- -- There are two complications here: -- 1. We need to compile the procedures in two stages because we need @@ -45,20 +48,27 @@ import StaticFlags -- 2. We need to thread the module's SRT around when the SRT tables -- are computed for each procedure. -- The SRT needs to be threaded because it is grown lazily. -protoCmmCPS :: HscEnv -- Compilation env including +-- 3. We run control flow optimizations twice, once before any pipeline +-- work is done, and once again at the very end on all of the +-- resulting C-- blocks. EZY: It's unclear whether or not whether +-- we actually need to do the initial pass. +cmmPipeline :: HscEnv -- Compilation env including -- dynamic flags: -dcmm-lint -ddump-cps-cmm -> (TopSRT, [Cmm]) -- SRT table and accumulating list of compiled procs -> Cmm -- Input C-- with Procedures -> IO (TopSRT, [Cmm]) -- Output CPS transformed C-- -protoCmmCPS hsc_env (topSRT, rst) (Cmm tops) = +cmmPipeline hsc_env (topSRT, rst) prog = do let dflags = hsc_dflags hsc_env + (Cmm tops) = runCmmContFlowOpts prog showPass dflags "CPSZ" (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops let topCAFEnv = mkTopCAFInfo (concat cafEnvs) (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops let cmms = Cmm (reverse (concat tops)) dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms) - return (topSRT, cmms : rst) + -- SRT is not affected by control flow optimization pass + let prog' = map runCmmContFlowOpts (cmms : rst) + return (topSRT, prog') {- [Note global fuel] ~~~~~~~~~~~~~~~~~~~~~ @@ -98,9 +108,8 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g ----------- Eliminate dead assignments ------------------- - -- Remove redundant reloads (and any other redundant asst) - g <- runOptimization $ removeDeadAssignmentsAndReloads procPoints g - dump Opt_D_dump_cmmz_dead "Post Dead Assignment Elimination" g + g <- runOptimization $ removeDeadAssignments g + dump Opt_D_dump_cmmz_dead "Post remove dead assignments" g ----------- Zero dead stack slots (Debug only) --------------- -- Debugging: stubbing slots on death can cause crashes early diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index fbe979b9ab..0527b6eea0 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -234,7 +234,7 @@ algorithm would be just as good, so that's what we do. -} -data Protocol = Protocol Convention CmmFormals Area +data Protocol = Protocol Convention [CmmFormal] Area deriving Eq instance Outputable Protocol where ppr (Protocol c fs a) = text "Protocol" <+> ppr c <+> ppr fs <+> ppr a diff --git a/compiler/cmm/CmmRewriteAssignments.hs b/compiler/cmm/CmmRewriteAssignments.hs new file mode 100644 index 0000000000..c0b7510349 --- /dev/null +++ b/compiler/cmm/CmmRewriteAssignments.hs @@ -0,0 +1,628 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} + +-- TODO: Get rid of this flag: +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +-- This module implements generalized code motion for assignments to +-- local registers, inlining and sinking when possible. It also does +-- some amount of rewriting for stores to register slots, which are +-- effectively equivalent to local registers. +module CmmRewriteAssignments + ( rewriteAssignments + ) where + +import Cmm +import CmmExpr +import CmmOpt +import OptimizationFuel +import StgCmmUtils + +import Control.Monad +import UniqFM +import Unique +import BlockId + +import Compiler.Hoopl hiding (Unique) +import Data.Maybe +import Prelude hiding (succ, zip) + +---------------------------------------------------------------- +--- Main function + +rewriteAssignments :: CmmGraph -> FuelUniqSM CmmGraph +rewriteAssignments g = do + -- Because we need to act on forwards and backwards information, we + -- first perform usage analysis and bake this information into the + -- graph (backwards transform), and then do a forwards transform + -- to actually perform inlining and sinking. + g' <- annotateUsage g + g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $ + analRewFwd assignmentLattice + assignmentTransfer + (assignmentRewrite `thenFwdRw` machOpFoldRewrite) + return (modifyGraph eraseRegUsage g'') + +---------------------------------------------------------------- +--- Usage information + +-- We decorate all register assignments with approximate usage +-- information, that is, the maximum number of times the register is +-- referenced while it is live along all outgoing control paths. +-- This analysis provides a precise upper bound for usage, so if a +-- register is never referenced, we can remove it, as that assignment is +-- dead. +-- +-- This analysis is very similar to liveness analysis; we just keep a +-- little extra info. (Maybe we should move it to CmmLive, and subsume +-- the old liveness analysis.) +-- +-- There are a few subtleties here: +-- +-- - If a register goes dead, and then becomes live again, the usages +-- of the disjoint live range don't count towards the original range. +-- +-- a = 1; // used once +-- b = a; +-- a = 2; // used once +-- c = a; +-- +-- - A register may be used multiple times, but these all reside in +-- different control paths, such that any given execution only uses +-- it once. In that case, the usage count may still be 1. +-- +-- a = 1; // used once +-- if (b) { +-- c = a + 3; +-- } else { +-- c = a + 1; +-- } +-- +-- This policy corresponds to an inlining strategy that does not +-- duplicate computation but may increase binary size. +-- +-- - If we naively implement a usage count, we have a counting to +-- infinity problem across joins. Furthermore, knowing that +-- something is used 2 or more times in one runtime execution isn't +-- particularly useful for optimizations (inlining may be beneficial, +-- but there's no way of knowing that without register pressure +-- information.) +-- +-- while (...) { +-- // first iteration, b used once +-- // second iteration, b used twice +-- // third iteration ... +-- a = b; +-- } +-- // b used zero times +-- +-- There is an orthogonal question, which is that for every runtime +-- execution, the register may be used only once, but if we inline it +-- in every conditional path, the binary size might increase a lot. +-- But tracking this information would be tricky, because it violates +-- the finite lattice restriction Hoopl requires for termination; +-- we'd thus need to supply an alternate proof, which is probably +-- something we should defer until we actually have an optimization +-- that would take advantage of this. (This might also interact +-- strangely with liveness information.) +-- +-- a = ...; +-- // a is used one time, but in X different paths +-- case (b) of +-- 1 -> ... a ... +-- 2 -> ... a ... +-- 3 -> ... a ... +-- ... +-- +-- - Memory stores to local register slots (CmmStore (CmmStackSlot +-- (LocalReg _) 0) _) have similar behavior to local registers, +-- in that these locations are all disjoint from each other. Thus, +-- we attempt to inline them too. Note that because these are only +-- generated as part of the spilling process, most of the time this +-- will refer to a local register and the assignment will immediately +-- die on the subsequent call. However, if we manage to replace that +-- local register with a memory location, it means that we've managed +-- to preserve a value on the stack without having to move it to +-- another memory location again! We collect usage information just +-- to be safe in case extra computation is involved. + +data RegUsage = SingleUse | ManyUse + deriving (Ord, Eq, Show) +-- Absence in map = ZeroUse + +{- +-- minBound is bottom, maxBound is top, least-upper-bound is max +-- ToDo: Put this in Hoopl. Note that this isn't as useful as I +-- originally hoped, because you usually want to leave out the bottom +-- element when you have things like this put in maps. Maybe f is +-- useful on its own as a combining function. +boundedOrdLattice :: (Bounded a, Ord a) => String -> DataflowLattice a +boundedOrdLattice n = DataflowLattice n minBound f + where f _ (OldFact x) (NewFact y) + | x >= y = (NoChange, x) + | otherwise = (SomeChange, y) +-} + +-- Custom node type we'll rewrite to. CmmAssign nodes to local +-- registers are replaced with AssignLocal nodes. +data WithRegUsage n e x where + -- Plain will not contain CmmAssign nodes immediately after + -- transformation, but as we rewrite assignments, we may have + -- assignments here: these are assignments that should not be + -- rewritten! + Plain :: n e x -> WithRegUsage n e x + AssignLocal :: LocalReg -> CmmExpr -> RegUsage -> WithRegUsage n O O + +instance UserOfLocalRegs (n e x) => UserOfLocalRegs (WithRegUsage n e x) where + foldRegsUsed f z (Plain n) = foldRegsUsed f z n + foldRegsUsed f z (AssignLocal _ e _) = foldRegsUsed f z e + +instance DefinerOfLocalRegs (n e x) => DefinerOfLocalRegs (WithRegUsage n e x) where + foldRegsDefd f z (Plain n) = foldRegsDefd f z n + foldRegsDefd f z (AssignLocal r _ _) = foldRegsDefd f z r + +instance NonLocal n => NonLocal (WithRegUsage n) where + entryLabel (Plain n) = entryLabel n + successors (Plain n) = successors n + +liftRegUsage :: Graph n e x -> Graph (WithRegUsage n) e x +liftRegUsage = mapGraph Plain + +eraseRegUsage :: Graph (WithRegUsage CmmNode) e x -> Graph CmmNode e x +eraseRegUsage = mapGraph f + where f :: WithRegUsage CmmNode e x -> CmmNode e x + f (AssignLocal l e _) = CmmAssign (CmmLocal l) e + f (Plain n) = n + +type UsageMap = UniqFM RegUsage + +usageLattice :: DataflowLattice UsageMap +usageLattice = DataflowLattice "usage counts for registers" emptyUFM (joinUFM f) + where f _ (OldFact x) (NewFact y) + | x >= y = (NoChange, x) + | otherwise = (SomeChange, y) + +-- We reuse the names 'gen' and 'kill', although we're doing something +-- slightly different from the Dragon Book +usageTransfer :: BwdTransfer (WithRegUsage CmmNode) UsageMap +usageTransfer = mkBTransfer3 first middle last + where first _ f = f + middle :: WithRegUsage CmmNode O O -> UsageMap -> UsageMap + middle n f = gen_kill n f + last :: WithRegUsage CmmNode O C -> FactBase UsageMap -> UsageMap + -- Checking for CmmCall/CmmForeignCall is unnecessary, because + -- spills/reloads have already occurred by the time we do this + -- analysis. + -- XXX Deprecated warning is puzzling: what label are we + -- supposed to use? + -- ToDo: With a bit more cleverness here, we can avoid + -- disappointment and heartbreak associated with the inability + -- to inline into CmmCall and CmmForeignCall by + -- over-estimating the usage to be ManyUse. + last n f = gen_kill n (joinOutFacts usageLattice n f) + gen_kill :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap + gen_kill a = gen a . kill a + gen :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap + gen a f = foldRegsUsed increaseUsage f a + kill :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap + kill a f = foldRegsDefd delFromUFM f a + increaseUsage f r = addToUFM_C combine f r SingleUse + where combine _ _ = ManyUse + +usageRewrite :: BwdRewrite FuelUniqSM (WithRegUsage CmmNode) UsageMap +usageRewrite = mkBRewrite3 first middle last + where first _ _ = return Nothing + middle :: Monad m => WithRegUsage CmmNode O O -> UsageMap -> m (Maybe (Graph (WithRegUsage CmmNode) O O)) + middle (Plain (CmmAssign (CmmLocal l) e)) f + = return . Just + $ case lookupUFM f l of + Nothing -> emptyGraph + Just usage -> mkMiddle (AssignLocal l e usage) + middle _ _ = return Nothing + last _ _ = return Nothing + +type CmmGraphWithRegUsage = GenCmmGraph (WithRegUsage CmmNode) +annotateUsage :: CmmGraph -> FuelUniqSM (CmmGraphWithRegUsage) +annotateUsage vanilla_g = + let g = modifyGraph liftRegUsage vanilla_g + in liftM fst $ dataflowPassBwd g [(g_entry g, fact_bot usageLattice)] $ + analRewBwd usageLattice usageTransfer usageRewrite + +---------------------------------------------------------------- +--- Assignment tracking + +-- The idea is to maintain a map of local registers do expressions, +-- such that the value of that register is the same as the value of that +-- expression at any given time. We can then do several things, +-- as described by Assignment. + +-- Assignment describes the various optimizations that are valid +-- at a given point in the program. +data Assignment = +-- This assignment can always be inlined. It is cheap or single-use. + AlwaysInline CmmExpr +-- This assignment should be sunk down to its first use. (This will +-- increase code size if the register is used in multiple control flow +-- paths, but won't increase execution time, and the reduction of +-- register pressure is worth it, I think.) + | AlwaysSink CmmExpr +-- We cannot safely optimize occurrences of this local register. (This +-- corresponds to top in the lattice structure.) + | NeverOptimize + +-- Extract the expression that is being assigned to +xassign :: Assignment -> Maybe CmmExpr +xassign (AlwaysInline e) = Just e +xassign (AlwaysSink e) = Just e +xassign NeverOptimize = Nothing + +-- Extracts the expression, but only if they're the same constructor +xassign2 :: (Assignment, Assignment) -> Maybe (CmmExpr, CmmExpr) +xassign2 (AlwaysInline e, AlwaysInline e') = Just (e, e') +xassign2 (AlwaysSink e, AlwaysSink e') = Just (e, e') +xassign2 _ = Nothing + +-- Note: We'd like to make decisions about "not optimizing" as soon as +-- possible, because this will make running the transfer function more +-- efficient. +type AssignmentMap = UniqFM Assignment + +assignmentLattice :: DataflowLattice AssignmentMap +assignmentLattice = DataflowLattice "assignments for registers" emptyUFM (joinUFM add) + where add _ (OldFact old) (NewFact new) + = case (old, new) of + (NeverOptimize, _) -> (NoChange, NeverOptimize) + (_, NeverOptimize) -> (SomeChange, NeverOptimize) + (xassign2 -> Just (e, e')) + | e == e' -> (NoChange, old) + | otherwise -> (SomeChange, NeverOptimize) + _ -> (SomeChange, NeverOptimize) + +-- Deletes sinks from assignment map, because /this/ is the place +-- where it will be sunk to. +deleteSinks :: UserOfLocalRegs n => n -> AssignmentMap -> AssignmentMap +deleteSinks n m = foldRegsUsed (adjustUFM f) m n + where f (AlwaysSink _) = NeverOptimize + f old = old + +-- Invalidates any expressions that use a register. +invalidateUsersOf :: CmmReg -> AssignmentMap -> AssignmentMap +-- foldUFM_Directly :: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a +invalidateUsersOf reg m = foldUFM_Directly f m m -- [foldUFM performance] + where f u (xassign -> Just e) m | reg `regUsedIn` e = addToUFM_Directly m u NeverOptimize + f _ _ m = m +{- This requires the entire spine of the map to be continually rebuilt, + - which causes crazy memory usage! +invalidateUsersOf reg = mapUFM (invalidateUsers' reg) + where invalidateUsers' reg (xassign -> Just e) | reg `regUsedIn` e = NeverOptimize + invalidateUsers' _ old = old +-} + +-- Note [foldUFM performance] +-- These calls to fold UFM no longer leak memory, but they do cause +-- pretty killer amounts of allocation. So they'll be something to +-- optimize; we need an algorithmic change to prevent us from having to +-- traverse the /entire/ map continually. + +middleAssignment :: WithRegUsage CmmNode O O -> AssignmentMap -> AssignmentMap + +-- Algorithm for annotated assignments: +-- 1. Delete any sinking assignments that were used by this instruction +-- 2. Add the assignment to our list of valid local assignments with +-- the correct optimization policy. +-- 3. Look for all assignments that reference that register and +-- invalidate them. +middleAssignment n@(AssignLocal r e usage) assign + = invalidateUsersOf (CmmLocal r) . add . deleteSinks n $ assign + where add m = addToUFM m r + $ case usage of + SingleUse -> AlwaysInline e + ManyUse -> decide e + decide CmmLit{} = AlwaysInline e + decide CmmReg{} = AlwaysInline e + decide CmmLoad{} = AlwaysSink e + decide CmmStackSlot{} = AlwaysSink e + decide CmmMachOp{} = AlwaysSink e + -- We'll always inline simple operations on the global + -- registers, to reduce register pressure: Sp - 4 or Hp - 8 + -- EZY: Justify this optimization more carefully. + decide CmmRegOff{} = AlwaysInline e + +-- Algorithm for unannotated assignments of global registers: +-- 1. Delete any sinking assignments that were used by this instruction +-- 2. Look for all assignments that reference this register and +-- invalidate them. +middleAssignment (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign + = invalidateUsersOf reg . deleteSinks n $ assign + +-- Algorithm for unannotated assignments of *local* registers: do +-- nothing (it's a reload, so no state should have changed) +middleAssignment (Plain (CmmAssign (CmmLocal _) _)) assign = assign + +-- Algorithm for stores: +-- 1. Delete any sinking assignments that were used by this instruction +-- 2. Look for all assignments that load from memory locations that +-- were clobbered by this store and invalidate them. +middleAssignment (Plain n@(CmmStore lhs rhs)) assign + = let m = deleteSinks n assign + in foldUFM_Directly f m m -- [foldUFM performance] + where f u (xassign -> Just x) m | (lhs, rhs) `clobbers` (u, x) = addToUFM_Directly m u NeverOptimize + f _ _ m = m +{- Also leaky + = mapUFM_Directly p . deleteSinks n $ assign + -- ToDo: There's a missed opportunity here: even if a memory + -- access we're attempting to sink gets clobbered at some + -- location, it's still /better/ to sink it to right before the + -- point where it gets clobbered. How might we do this? + -- Unfortunately, it's too late to change the assignment... + where p r (xassign -> Just x) | (lhs, rhs) `clobbers` (r, x) = NeverOptimize + p _ old = old +-} + +-- Assumption: Unsafe foreign calls don't clobber memory +-- Since foreign calls clobber caller saved registers, we need +-- invalidate any assignments that reference those global registers. +-- This is kind of expensive. (One way to optimize this might be to +-- store extra information about expressions that allow this and other +-- checks to be done cheaply.) +middleAssignment (Plain n@(CmmUnsafeForeignCall{})) assign + = deleteCallerSaves (foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n) + where deleteCallerSaves m = foldUFM_Directly f m m + f u (xassign -> Just x) m | wrapRecExpf g x False = addToUFM_Directly m u NeverOptimize + f _ _ m = m + g (CmmReg (CmmGlobal r)) _ | callerSaves r = True + g (CmmRegOff (CmmGlobal r) _) _ | callerSaves r = True + g _ b = b + +middleAssignment (Plain (CmmComment {})) assign + = assign + +-- Assumptions: +-- * Writes using Hp do not overlap with any other memory locations +-- (An important invariant being relied on here is that we only ever +-- use Hp to allocate values on the heap, which appears to be the +-- case given hpReg usage, and that our heap writing code doesn't +-- do anything stupid like overlapping writes.) +-- * Stack slots do not overlap with any other memory locations +-- * Stack slots for different areas do not overlap +-- * Stack slots within the same area and different offsets may +-- overlap; we need to do a size check (see 'overlaps'). +-- * Register slots only overlap with themselves. (But this shouldn't +-- happen in practice, because we'll fail to inline a reload across +-- the next spill.) +-- * Non stack-slot stores always conflict with each other. (This is +-- not always the case; we could probably do something special for Hp) +clobbers :: (CmmExpr, CmmExpr) -- (lhs, rhs) of clobbering CmmStore + -> (Unique, CmmExpr) -- (register, expression) that may be clobbered + -> Bool +clobbers (CmmRegOff (CmmGlobal Hp) _, _) (_, _) = False +clobbers (CmmReg (CmmGlobal Hp), _) (_, _) = False +-- ToDo: Also catch MachOp case +clobbers (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _) + | getUnique r == u, ss == ss' = False -- No-op on the stack slot (XXX: Do we need this special case?) +clobbers (CmmStackSlot (CallArea a) o, rhs) (_, expr) = f expr + where f (CmmLoad (CmmStackSlot (CallArea a') o') t) + = (a, o, widthInBytes (cmmExprWidth rhs)) `overlaps` (a', o', widthInBytes (typeWidth t)) + f (CmmLoad e _) = containsStackSlot e + f (CmmMachOp _ es) = or (map f es) + f _ = False + -- Maybe there's an invariant broken if this actually ever + -- returns True + containsStackSlot (CmmLoad{}) = True -- load of a load, all bets off + containsStackSlot (CmmMachOp _ es) = or (map containsStackSlot es) + containsStackSlot (CmmStackSlot{}) = True + containsStackSlot _ = False +clobbers (CmmStackSlot (RegSlot l) _, _) (_, expr) = f expr + where f (CmmLoad (CmmStackSlot (RegSlot l') _) _) = l == l' + f _ = False +clobbers _ (_, e) = f e + where f (CmmLoad (CmmStackSlot _ _) _) = False + f (CmmLoad{}) = True -- conservative + f (CmmMachOp _ es) = or (map f es) + f _ = False + +-- Check for memory overlapping. +-- Diagram: +-- 4 8 12 +-- s -w- o +-- [ I32 ] +-- [ F64 ] +-- s' -w'- o' +type CallSubArea = (AreaId, Int, Int) -- area, offset, width +overlaps :: CallSubArea -> CallSubArea -> Bool +overlaps (a, _, _) (a', _, _) | a /= a' = False +overlaps (_, o, w) (_, o', w') = + let s = o - w + s' = o' - w' + in (s' < o) && (s < o) -- Not LTE, because [ I32 ][ I32 ] is OK + +lastAssignment :: WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)] +lastAssignment (Plain (CmmCall _ (Just k) _ _ _)) assign = [(k, invalidateVolatile k assign)] +lastAssignment (Plain (CmmForeignCall {succ=k})) assign = [(k, invalidateVolatile k assign)] +lastAssignment l assign = map (\id -> (id, deleteSinks l assign)) $ successors l + +-- Invalidates any expressions that have volatile contents: essentially, +-- all terminals volatile except for literals and loads of stack slots +-- that do not correspond to the call area for 'k' (the current call +-- area is volatile because overflow return parameters may be written +-- there.) +-- Note: mapUFM could be expensive, but hopefully block boundaries +-- aren't too common. If it is a problem, replace with something more +-- clever. +invalidateVolatile :: BlockId -> AssignmentMap -> AssignmentMap +invalidateVolatile k m = mapUFM p m + where p (AlwaysInline e) = if exp e then AlwaysInline e else NeverOptimize + where exp CmmLit{} = True + exp (CmmLoad (CmmStackSlot (CallArea (Young k')) _) _) + | k' == k = False + exp (CmmLoad (CmmStackSlot _ _) _) = True + exp (CmmMachOp _ es) = and (map exp es) + exp _ = False + p _ = NeverOptimize -- probably shouldn't happen with AlwaysSink + +assignmentTransfer :: FwdTransfer (WithRegUsage CmmNode) AssignmentMap +assignmentTransfer = mkFTransfer3 (flip const) middleAssignment ((mkFactBase assignmentLattice .) . lastAssignment) + +-- Note [Soundness of inlining] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In the Hoopl paper, the soundness condition on rewrite functions is +-- described as follows: +-- +-- "If it replaces a node n by a replacement graph g, then g must +-- be observationally equivalent to n under the assumptions +-- expressed by the incoming dataflow fact f. Moreover, analysis of +-- g must produce output fact(s) that are at least as informative +-- as the fact(s) produced by applying the transfer function to n." +-- +-- We consider the second condition in more detail here. It says given +-- the rewrite R(n, f) = g, then for any incoming fact f' consistent +-- with f (f' >= f), then running the transfer function T(f', n) <= T(f', g). +-- For inlining this is not necessarily the case: +-- +-- n = "x = a + 2" +-- f = f' = {a = y} +-- g = "x = y + 2" +-- T(f', n) = {x = a + 2, a = y} +-- T(f', g) = {x = y + 2, a = y} +-- +-- y + 2 and a + 2 are not obviously comparable, and a naive +-- implementation of the lattice would say they are incomparable. +-- At best, this means we may be over-conservative, at worst, it means +-- we may not terminate. +-- +-- However, in the original Lerner-Grove-Chambers paper, soundness and +-- termination are separated, and only equivalence of facts is required +-- for soundness. Monotonicity of the transfer function is not required +-- for termination (as the calculation of least-upper-bound prevents +-- this from being a problem), but it means we won't necessarily find +-- the least-fixed point. + +-- Note [Coherency of annotations] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Is it possible for our usage annotations to become invalid after we +-- start performing transformations? As the usage info only provides +-- an upper bound, we only need to consider cases where the usages of +-- a register may increase due to transformations--e.g. any reference +-- to a local register in an AlwaysInline or AlwaysSink instruction, whose +-- originating assignment was single use (we don't care about the +-- many use case, because it is the top of the lattice). But such a +-- case is not possible, because we always inline any single use +-- register. QED. +-- +-- TODO: A useful lint option would be to check this invariant that +-- there is never a local register in the assignment map that is +-- single-use. + +-- Note [Soundness of store rewriting] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Its soundness depends on the invariant that no assignment is made to +-- the local register before its store is accessed. This is clearly +-- true with unoptimized spill-reload code, and as the store will always +-- be rewritten first (if possible), there is no chance of it being +-- propagated down before getting written (possibly with incorrect +-- values from the assignment map, due to reassignment of the local +-- register.) This is probably not locally sound. + +assignmentRewrite :: FwdRewrite FuelUniqSM (WithRegUsage CmmNode) AssignmentMap +assignmentRewrite = mkFRewrite3 first middle last + where + first _ _ = return Nothing + middle :: WithRegUsage CmmNode O O -> AssignmentMap -> GenCmmReplGraph (WithRegUsage CmmNode) O O + middle (Plain m) assign = return $ rewrite assign (precompute assign m) mkMiddle m + middle (AssignLocal l e u) assign = return $ rewriteLocal assign (precompute assign (CmmAssign (CmmLocal l) e)) l e u + last (Plain l) assign = return $ rewrite assign (precompute assign l) mkLast l + -- Tuple is (inline?, reloads for sinks) + precompute :: AssignmentMap -> CmmNode O x -> (Bool, [WithRegUsage CmmNode O O]) + precompute assign n = foldRegsUsed f (False, []) n -- duplicates are harmless + where f (i, l) r = case lookupUFM assign r of + Just (AlwaysSink e) -> (i, (Plain (CmmAssign (CmmLocal r) e)):l) + Just (AlwaysInline _) -> (True, l) + Just NeverOptimize -> (i, l) + -- This case can show up when we have + -- limited optimization fuel. + Nothing -> (i, l) + rewrite :: AssignmentMap + -> (Bool, [WithRegUsage CmmNode O O]) + -> (WithRegUsage CmmNode O x -> Graph (WithRegUsage CmmNode) O x) + -> CmmNode O x + -> Maybe (Graph (WithRegUsage CmmNode) O x) + rewrite _ (False, []) _ _ = Nothing + -- Note [CmmCall Inline Hack] + -- Conservative hack: don't do any inlining on what will + -- be translated into an OldCmm CmmCalls, since the code + -- produced here tends to be unproblematic and I need to write + -- lint passes to ensure that we don't put anything in the + -- arguments that could be construed as a global register by + -- some later translation pass. (For example, slots will turn + -- into dereferences of Sp). See [Register parameter passing]. + -- ToDo: Fix this up to only bug out if all inlines were for + -- CmmExprs with global registers (we can't use the + -- straightforward mapExpDeep call, in this case.) ToDo: We miss + -- an opportunity here, where all possible inlinings should + -- instead be sunk. + rewrite _ (True, []) _ n | not (inlinable n) = Nothing -- see [CmmCall Inline Hack] + rewrite assign (i, xs) mk n = Just $ mkMiddles xs <*> mk (Plain (inline i assign n)) + + rewriteLocal :: AssignmentMap + -> (Bool, [WithRegUsage CmmNode O O]) + -> LocalReg -> CmmExpr -> RegUsage + -> Maybe (Graph (WithRegUsage CmmNode) O O) + rewriteLocal _ (False, []) _ _ _ = Nothing + rewriteLocal assign (i, xs) l e u = Just $ mkMiddles xs <*> mkMiddle n' + where n' = AssignLocal l e' u + e' = if i then wrapRecExp (inlineExp assign) e else e + -- inlinable check omitted, since we can always inline into + -- assignments. + + inline :: Bool -> AssignmentMap -> CmmNode e x -> CmmNode e x + inline False _ n = n + inline True _ n | not (inlinable n) = n -- see [CmmCall Inline Hack] + inline True assign n = mapExpDeep (inlineExp assign) n + + inlineExp assign old@(CmmReg (CmmLocal r)) + = case lookupUFM assign r of + Just (AlwaysInline x) -> x + _ -> old + inlineExp assign old@(CmmRegOff (CmmLocal r) i) + = case lookupUFM assign r of + Just (AlwaysInline x) -> + case x of + (CmmRegOff r' i') -> CmmRegOff r' (i + i') + _ -> CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)] + where rep = typeWidth (localRegType r) + _ -> old + -- See Note [Soundness of store rewriting] + inlineExp assign old@(CmmLoad (CmmStackSlot (RegSlot r) _) _) + = case lookupUFM assign r of + Just (AlwaysInline x) -> x + _ -> old + inlineExp _ old = old + + inlinable :: CmmNode e x -> Bool + inlinable (CmmCall{}) = False + inlinable (CmmForeignCall{}) = False + inlinable (CmmUnsafeForeignCall{}) = False + inlinable _ = True + +-- Need to interleave this with inlining, because machop folding results +-- in literals, which we can inline more aggressively, and inlining +-- gives us opportunities for more folding. However, we don't need any +-- facts to do MachOp folding. +machOpFoldRewrite :: FwdRewrite FuelUniqSM (WithRegUsage CmmNode) a +machOpFoldRewrite = mkFRewrite3 first middle last + where first _ _ = return Nothing + middle :: WithRegUsage CmmNode O O -> a -> GenCmmReplGraph (WithRegUsage CmmNode) O O + middle (Plain m) _ = return (fmap (mkMiddle . Plain) (foldNode m)) + middle (AssignLocal l e r) _ = return (fmap f (wrapRecExpM foldExp e)) + where f e' = mkMiddle (AssignLocal l e' r) + last :: WithRegUsage CmmNode O C -> a -> GenCmmReplGraph (WithRegUsage CmmNode) O C + last (Plain l) _ = return (fmap (mkLast . Plain) (foldNode l)) + foldNode :: CmmNode e x -> Maybe (CmmNode e x) + foldNode n = mapExpDeepM foldExp n + foldExp (CmmMachOp op args) = cmmMachOpFoldM op args + foldExp _ = Nothing + +-- ToDo: Outputable instance for UsageMap and AssignmentMap diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index 2dcfb027a3..3033e7b421 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -1,22 +1,14 @@ -{-# LANGUAGE GADTs, NoMonoLocalBinds, FlexibleContexts, ViewPatterns #-} +{-# LANGUAGE GADTs, NoMonoLocalBinds, FlexibleContexts #-} -- Norman likes local bindings -- If this module lives on I'd like to get rid of this flag in due course {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} + +-- TODO: Get rid of this flag: {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -#if __GLASGOW_HASKELL__ >= 701 --- GHC 7.0.1 improved incomplete pattern warnings with GADTs -{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} -#endif module CmmSpillReload - ( DualLive(..) - , dualLiveLattice, dualLiveTransfers, dualLiveness - --, insertSpillsAndReloads --- XXX todo check live-in at entry against formals - , dualLivenessWithInsertion - - , rewriteAssignments - , removeDeadAssignmentsAndReloads + ( dualLivenessWithInsertion ) where @@ -25,14 +17,11 @@ import Cmm import CmmExpr import CmmLive import OptimizationFuel -import StgCmmUtils import Control.Monad import Outputable hiding (empty) import qualified Outputable as PP import UniqSet -import UniqFM -import Unique import Compiler.Hoopl hiding (Unique) import Data.Maybe @@ -40,38 +29,36 @@ import Prelude hiding (succ, zip) {- Note [Overview of spill/reload] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The point of this module is to insert spills and reloads to -establish the invariant that at a call (or at any proc point with -an established protocol) all live variables not expected in -registers are sitting on the stack. We use a backward analysis to -insert spills and reloads. It should be followed by a -forward transformation to sink reloads as deeply as possible, so as -to reduce register pressure. +The point of this module is to insert spills and reloads to establish +the invariant that at a call or any proc point with an established +protocol all live variables not expected in registers are sitting on the +stack. We use a backward dual liveness analysis (both traditional +register liveness as well as register slot liveness on the stack) to +insert spills and reloads. It should be followed by a forward +transformation to sink reloads as deeply as possible, so as to reduce +register pressure: this transformation is performed by +CmmRewriteAssignments. A variable can be expected to be live in a register, live on the stack, or both. This analysis ensures that spills and reloads are inserted as needed to make sure that every live variable needed -after a call is available on the stack. Spills are pushed back to -their reaching definitions, but reloads are dropped wherever needed -and will have to be sunk by a later forward transformation. +after a call is available on the stack. Spills are placed immediately +after their reaching definitions, but reloads are placed immediately +after a return from a call (the entry point.) + +Note that we offer no guarantees about the consistency of the value +in memory and the value in the register, except that they are +equal across calls/procpoints. If the variable is changed, this +mapping breaks: but as the original value of the register may still +be useful in a different context, the memory location is not updated. -} data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet } -dualUnion :: DualLive -> DualLive -> DualLive -dualUnion (DualLive s r) (DualLive s' r') = - DualLive (s `unionUniqSets` s') (r `unionUniqSets` r') - -dualUnionList :: [DualLive] -> DualLive -dualUnionList ls = DualLive ss rs - where ss = unionManyUniqSets $ map on_stack ls - rs = unionManyUniqSets $ map in_regs ls - changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive changeStack f live = live { on_stack = f (on_stack live) } changeRegs f live = live { in_regs = f (in_regs live) } - dualLiveLattice :: DataflowLattice DualLive dualLiveLattice = DataflowLattice "variables live in registers and on stack" empty add where empty = DualLive emptyRegSet emptyRegSet @@ -85,21 +72,24 @@ dualLivenessWithInsertion :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph dualLivenessWithInsertion procPoints g = liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice (dualLiveTransfers (g_entry g) procPoints) - (insertSpillAndReloadRewrites g procPoints) - -dualLiveness :: BlockSet -> CmmGraph -> FuelUniqSM (BlockEnv DualLive) -dualLiveness procPoints g = - liftM snd $ dataflowPassBwd g [] $ analBwd dualLiveLattice $ dualLiveTransfers (g_entry g) procPoints + (insertSpillsAndReloads g procPoints) + +-- Note [Live registers on entry to procpoints] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Remember that the transfer function is only ever run on the rewritten +-- version of a graph, and the rewrite function for spills and reloads +-- enforces the invariant that no local registers are live on entry to +-- a procpoint. Accordingly, we check for this invariant here. An old +-- version of this code incorrectly claimed that any live registers were +-- live on the stack before entering the function: this is wrong, but +-- didn't cause bugs because it never actually was invoked. dualLiveTransfers :: BlockId -> BlockSet -> (BwdTransfer CmmNode DualLive) dualLiveTransfers entry procPoints = mkBTransfer3 first middle last where first :: CmmNode C O -> DualLive -> DualLive - first (CmmEntry id) live = check live id $ -- live at procPoint => spill - if id /= entry && setMember id procPoints - then DualLive { on_stack = on_stack live `plusRegSet` in_regs live - , in_regs = emptyRegSet } - else live - where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x + first (CmmEntry id) live -- See Note [Live registers on entry to procpoints] + | id == entry || setMember id procPoints = noLiveOnEntry id (in_regs live) live + | otherwise = live middle :: CmmNode O O -> DualLive -> DualLive middle m = changeStack updSlots @@ -112,548 +102,52 @@ dualLiveTransfers entry procPoints = mkBTransfer3 first middle last spill live _ = live reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r reload live _ = live + -- Ensure the assignment refers to the entirety of the + -- register slot (and not just a slice). check (RegSlot (LocalReg _ ty), o, w) x | o == w && w == widthInBytes (typeWidth ty) = x - check _ _ = panic "middleDualLiveness unsupported: slices" + check _ _ = panic "dualLiveTransfers: slices unsupported" + + -- Register analysis is identical to liveness analysis from CmmLive. last :: CmmNode O C -> FactBase DualLive -> DualLive - last l fb = case l of - CmmBranch id -> lkp id - l@(CmmCall {cml_cont=Nothing}) -> changeRegs (gen l . kill l) empty - l@(CmmCall {cml_cont=Just k}) -> call l k - l@(CmmForeignCall {succ=k}) -> call l k - l@(CmmCondBranch _ t f) -> changeRegs (gen l . kill l) $ dualUnion (lkp t) (lkp f) - l@(CmmSwitch _ tbl) -> changeRegs (gen l . kill l) $ dualUnionList $ map lkp (catMaybes tbl) + last l fb = changeRegs (gen_kill l) $ case l of + CmmCall {cml_cont=Nothing} -> empty + CmmCall {cml_cont=Just k} -> keep_stack_only k + CmmForeignCall {succ=k} -> keep_stack_only k + _ -> joinOutFacts dualLiveLattice l fb where empty = fact_bot dualLiveLattice - lkp id = empty `fromMaybe` lookupFact id fb - call l k = DualLive (on_stack (lkp k)) (gen l emptyRegSet) - -gen :: UserOfLocalRegs a => a -> RegSet -> RegSet -gen a live = foldRegsUsed extendRegSet live a -kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet -kill a live = foldRegsDefd deleteFromRegSet live a + lkp k = fromMaybe empty (lookupFact k fb) + keep_stack_only k = DualLive (on_stack (lkp k)) emptyRegSet -insertSpillAndReloadRewrites :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive -insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing +insertSpillsAndReloads :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive +insertSpillsAndReloads graph procPoints = deepBwdRw3 first middle nothing -- Beware: deepBwdRw with one polymorphic function seems more reasonable here, -- but GHC miscompiles it, see bug #4044. where first :: CmmNode C O -> Fact O DualLive -> CmmReplGraph C O first e@(CmmEntry id) live = return $ if id /= (g_entry graph) && setMember id procPoints then - case map reload (uniqSetToList spill_regs) of + case map reload (uniqSetToList (in_regs live)) of [] -> Nothing is -> Just $ mkFirst e <*> mkMiddles is else Nothing - where - -- If we are splitting procedures, we need the LastForeignCall - -- to spill its results to the stack because they will only - -- be used by a separate procedure (so they can't stay in LocalRegs). - splitting = True - spill_regs = if splitting then in_regs live - else in_regs live `minusRegSet` defs - defs = case mapLookup id firstDefs of - Just defs -> defs - Nothing -> emptyRegSet - -- A LastForeignCall may contain some definitions, which take place - -- on return from the function call. Therefore, we build a map (firstDefs) - -- from BlockId to the set of variables defined on return to the BlockId. - firstDefs = mapFold addLive emptyBlockMap (toBlockMap graph) - addLive :: CmmBlock -> BlockEnv RegSet -> BlockEnv RegSet - addLive b env = case lastNode b of - CmmForeignCall {succ=k, res=defs} -> add k (mkRegSet defs) env - _ -> env - add bid defs env = mapInsert bid defs'' env - where defs'' = case mapLookup bid env of - Just defs' -> timesRegSet defs defs' - Nothing -> defs + -- EZY: There was some dead code for handling the case where + -- we were not splitting procedures. Check Git history if + -- you're interested (circa e26ea0f41). middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O + -- Don't add spills next to reloads. middle (CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) _ | reg == reg' = return Nothing - middle m@(CmmAssign (CmmLocal reg) _) live = return $ - if reg `elemRegSet` on_stack live then -- must spill - my_trace "Spilling" (f4sep [text "spill" <+> ppr reg, - text "after"{-, ppr m-}]) $ - Just $ mkMiddles $ [m, spill reg] - else Nothing + -- Spill if register is live on stack. + middle m@(CmmAssign (CmmLocal reg) _) live + | reg `elemRegSet` on_stack live = return (Just (mkMiddles [m, spill reg])) middle _ _ = return Nothing nothing _ _ = return Nothing -regSlot :: LocalReg -> CmmExpr -regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r) - spill, reload :: LocalReg -> CmmNode O O spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r) reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r) -removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph -removeDeadAssignmentsAndReloads procPoints g = - liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice - (dualLiveTransfers (g_entry g) procPoints) - rewrites - where rewrites = deepBwdRw3 nothing middle nothing - -- Beware: deepBwdRw with one polymorphic function seems more reasonable here, - -- but GHC panics while compiling, see bug #4045. - middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O - middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph - -- XXX maybe this should be somewhere else... - middle (CmmAssign lhs (CmmReg rhs)) _ | lhs == rhs = return $ Just emptyGraph - middle (CmmStore lhs (CmmLoad rhs _)) _ | lhs == rhs = return $ Just emptyGraph - middle _ _ = return Nothing - - nothing _ _ = return Nothing - ----------------------------------------------------------------- ---- Usage information - --- We decorate all register assignments with usage information, --- that is, the maximum number of times the register is referenced --- while it is live along all outgoing control paths. There are a few --- subtleties here: --- --- - If a register goes dead, and then becomes live again, the usages --- of the disjoint live range don't count towards the original range. --- --- a = 1; // used once --- b = a; --- a = 2; // used once --- c = a; --- --- - A register may be used multiple times, but these all reside in --- different control paths, such that any given execution only uses --- it once. In that case, the usage count may still be 1. --- --- a = 1; // used once --- if (b) { --- c = a + 3; --- } else { --- c = a + 1; --- } --- --- This policy corresponds to an inlining strategy that does not --- duplicate computation but may increase binary size. --- --- - If we naively implement a usage count, we have a counting to --- infinity problem across joins. Furthermore, knowing that --- something is used 2 or more times in one runtime execution isn't --- particularly useful for optimizations (inlining may be beneficial, --- but there's no way of knowing that without register pressure --- information.) --- --- while (...) { --- // first iteration, b used once --- // second iteration, b used twice --- // third iteration ... --- a = b; --- } --- // b used zero times --- --- There is an orthogonal question, which is that for every runtime --- execution, the register may be used only once, but if we inline it --- in every conditional path, the binary size might increase a lot. --- But tracking this information would be tricky, because it violates --- the finite lattice restriction Hoopl requires for termination; --- we'd thus need to supply an alternate proof, which is probably --- something we should defer until we actually have an optimization --- that would take advantage of this. (This might also interact --- strangely with liveness information.) --- --- a = ...; --- // a is used one time, but in X different paths --- case (b) of --- 1 -> ... a ... --- 2 -> ... a ... --- 3 -> ... a ... --- ... --- --- This analysis is very similar to liveness analysis; we just keep a --- little extra info. (Maybe we should move it to CmmLive, and subsume --- the old liveness analysis.) - -data RegUsage = SingleUse | ManyUse - deriving (Ord, Eq, Show) --- Absence in map = ZeroUse - -{- --- minBound is bottom, maxBound is top, least-upper-bound is max --- ToDo: Put this in Hoopl. Note that this isn't as useful as I --- originally hoped, because you usually want to leave out the bottom --- element when you have things like this put in maps. Maybe f is --- useful on its own as a combining function. -boundedOrdLattice :: (Bounded a, Ord a) => String -> DataflowLattice a -boundedOrdLattice n = DataflowLattice n minBound f - where f _ (OldFact x) (NewFact y) - | x >= y = (NoChange, x) - | otherwise = (SomeChange, y) --} - --- Custom node type we'll rewrite to. CmmAssign nodes to local --- registers are replaced with AssignLocal nodes. -data WithRegUsage n e x where - Plain :: n e x -> WithRegUsage n e x - AssignLocal :: LocalReg -> CmmExpr -> RegUsage -> WithRegUsage n O O - -instance UserOfLocalRegs (n e x) => UserOfLocalRegs (WithRegUsage n e x) where - foldRegsUsed f z (Plain n) = foldRegsUsed f z n - foldRegsUsed f z (AssignLocal _ e _) = foldRegsUsed f z e - -instance DefinerOfLocalRegs (n e x) => DefinerOfLocalRegs (WithRegUsage n e x) where - foldRegsDefd f z (Plain n) = foldRegsDefd f z n - foldRegsDefd f z (AssignLocal r _ _) = foldRegsDefd f z r - -instance NonLocal n => NonLocal (WithRegUsage n) where - entryLabel (Plain n) = entryLabel n - successors (Plain n) = successors n - -liftRegUsage :: Graph n e x -> Graph (WithRegUsage n) e x -liftRegUsage = mapGraph Plain - -eraseRegUsage :: Graph (WithRegUsage CmmNode) e x -> Graph CmmNode e x -eraseRegUsage = mapGraph f - where f :: WithRegUsage CmmNode e x -> CmmNode e x - f (AssignLocal l e _) = CmmAssign (CmmLocal l) e - f (Plain n) = n - -type UsageMap = UniqFM RegUsage - -usageLattice :: DataflowLattice UsageMap -usageLattice = DataflowLattice "usage counts for registers" emptyUFM (joinUFM f) - where f _ (OldFact x) (NewFact y) - | x >= y = (NoChange, x) - | otherwise = (SomeChange, y) - --- We reuse the names 'gen' and 'kill', although we're doing something --- slightly different from the Dragon Book -usageTransfer :: BwdTransfer (WithRegUsage CmmNode) UsageMap -usageTransfer = mkBTransfer3 first middle last - where first _ f = f - middle :: WithRegUsage CmmNode O O -> UsageMap -> UsageMap - middle n f = gen_kill n f - last :: WithRegUsage CmmNode O C -> FactBase UsageMap -> UsageMap - -- Checking for CmmCall/CmmForeignCall is unnecessary, because - -- spills/reloads have already occurred by the time we do this - -- analysis. - -- XXX Deprecated warning is puzzling: what label are we - -- supposed to use? - -- ToDo: With a bit more cleverness here, we can avoid - -- disappointment and heartbreak associated with the inability - -- to inline into CmmCall and CmmForeignCall by - -- over-estimating the usage to be ManyUse. - last n f = gen_kill n (joinOutFacts usageLattice n f) - gen_kill a = gen a . kill a - gen a f = foldRegsUsed increaseUsage f a - kill a f = foldRegsDefd delFromUFM f a - increaseUsage f r = addToUFM_C combine f r SingleUse - where combine _ _ = ManyUse - -usageRewrite :: BwdRewrite FuelUniqSM (WithRegUsage CmmNode) UsageMap -usageRewrite = mkBRewrite3 first middle last - where first _ _ = return Nothing - middle :: Monad m => WithRegUsage CmmNode O O -> UsageMap -> m (Maybe (Graph (WithRegUsage CmmNode) O O)) - middle (Plain (CmmAssign (CmmLocal l) e)) f - = return . Just - $ case lookupUFM f l of - Nothing -> emptyGraph - Just usage -> mkMiddle (AssignLocal l e usage) - middle _ _ = return Nothing - last _ _ = return Nothing - -type CmmGraphWithRegUsage = GenCmmGraph (WithRegUsage CmmNode) -annotateUsage :: CmmGraph -> FuelUniqSM (CmmGraphWithRegUsage) -annotateUsage vanilla_g = - let g = modifyGraph liftRegUsage vanilla_g - in liftM fst $ dataflowPassBwd g [(g_entry g, fact_bot usageLattice)] $ - analRewBwd usageLattice usageTransfer usageRewrite - ----------------------------------------------------------------- ---- Assignment tracking - --- The idea is to maintain a map of local registers do expressions, --- such that the value of that register is the same as the value of that --- expression at any given time. We can then do several things, --- as described by Assignment. - --- Assignment describes the various optimizations that are valid --- at a given point in the program. -data Assignment = --- This assignment can always be inlined. It is cheap or single-use. - AlwaysInline CmmExpr --- This assignment should be sunk down to its first use. (This will --- increase code size if the register is used in multiple control flow --- paths, but won't increase execution time, and the reduction of --- register pressure is worth it.) - | AlwaysSink CmmExpr --- We cannot safely optimize occurrences of this local register. (This --- corresponds to top in the lattice structure.) - | NeverOptimize - --- Extract the expression that is being assigned to -xassign :: Assignment -> Maybe CmmExpr -xassign (AlwaysInline e) = Just e -xassign (AlwaysSink e) = Just e -xassign NeverOptimize = Nothing - --- Extracts the expression, but only if they're the same constructor -xassign2 :: (Assignment, Assignment) -> Maybe (CmmExpr, CmmExpr) -xassign2 (AlwaysInline e, AlwaysInline e') = Just (e, e') -xassign2 (AlwaysSink e, AlwaysSink e') = Just (e, e') -xassign2 _ = Nothing - --- Note: We'd like to make decisions about "not optimizing" as soon as --- possible, because this will make running the transfer function more --- efficient. -type AssignmentMap = UniqFM Assignment - -assignmentLattice :: DataflowLattice AssignmentMap -assignmentLattice = DataflowLattice "assignments for registers" emptyUFM (joinUFM add) - where add _ (OldFact old) (NewFact new) - = case (old, new) of - (NeverOptimize, _) -> (NoChange, NeverOptimize) - (_, NeverOptimize) -> (SomeChange, NeverOptimize) - (xassign2 -> Just (e, e')) - | e == e' -> (NoChange, old) - | otherwise -> (SomeChange, NeverOptimize) - _ -> (SomeChange, NeverOptimize) - --- Deletes sinks from assignment map, because /this/ is the place --- where it will be sunk to. -deleteSinks :: UserOfLocalRegs n => n -> AssignmentMap -> AssignmentMap -deleteSinks n m = foldRegsUsed (adjustUFM f) m n - where f (AlwaysSink _) = NeverOptimize - f old = old - --- Invalidates any expressions that use a register. -invalidateUsersOf :: CmmReg -> AssignmentMap -> AssignmentMap --- foldUFM_Directly :: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a -invalidateUsersOf reg m = foldUFM_Directly f m m -- [foldUFM performance] - where f u (xassign -> Just e) m | reg `regUsedIn` e = addToUFM_Directly m u NeverOptimize - f _ _ m = m -{- This requires the entire spine of the map to be continually rebuilt, - - which causes crazy memory usage! -invalidateUsersOf reg = mapUFM (invalidateUsers' reg) - where invalidateUsers' reg (xassign -> Just e) | reg `regUsedIn` e = NeverOptimize - invalidateUsers' _ old = old --} - --- Note [foldUFM performance] --- These calls to fold UFM no longer leak memory, but they do cause --- pretty killer amounts of allocation. So they'll be something to --- optimize; we need an algorithmic change to prevent us from having to --- traverse the /entire/ map continually. - -middleAssignment :: WithRegUsage CmmNode O O -> AssignmentMap -> AssignmentMap - --- Algorithm for annotated assignments: --- 1. Delete any sinking assignments that were used by this instruction --- 2. Add the assignment to our list of valid local assignments with --- the correct optimization policy. --- 3. Look for all assignments that reference that register and --- invalidate them. -middleAssignment n@(AssignLocal r e usage) assign - = invalidateUsersOf (CmmLocal r) . add . deleteSinks n $ assign - where add m = addToUFM m r - $ case usage of - SingleUse -> AlwaysInline e - ManyUse -> decide e - decide CmmLit{} = AlwaysInline e - decide CmmReg{} = AlwaysInline e - decide CmmLoad{} = AlwaysSink e - decide CmmStackSlot{} = AlwaysSink e - decide CmmMachOp{} = AlwaysSink e - -- We'll always inline simple operations on the global - -- registers, to reduce register pressure: Sp - 4 or Hp - 8 - -- EZY: Justify this optimization more carefully. - decide CmmRegOff{} = AlwaysInline e - --- Algorithm for unannotated assignments of global registers: --- 1. Delete any sinking assignments that were used by this instruction --- 2. Look for all assignments that reference this register and --- invalidate them. -middleAssignment (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign - = invalidateUsersOf reg . deleteSinks n $ assign - --- Algorithm for unannotated assignments of *local* registers: do --- nothing (it's a reload, so no state should have changed) -middleAssignment (Plain (CmmAssign (CmmLocal _) _)) assign = assign - --- Algorithm for stores: --- 1. Delete any sinking assignments that were used by this instruction --- 2. Look for all assignments that load from memory locations that --- were clobbered by this store and invalidate them. -middleAssignment (Plain n@(CmmStore lhs rhs)) assign - = let m = deleteSinks n assign - in foldUFM_Directly f m m -- [foldUFM performance] - where f u (xassign -> Just x) m | (lhs, rhs) `clobbers` (u, x) = addToUFM_Directly m u NeverOptimize - f _ _ m = m -{- Also leaky - = mapUFM_Directly p . deleteSinks n $ assign - -- ToDo: There's a missed opportunity here: even if a memory - -- access we're attempting to sink gets clobbered at some - -- location, it's still /better/ to sink it to right before the - -- point where it gets clobbered. How might we do this? - -- Unfortunately, it's too late to change the assignment... - where p r (xassign -> Just x) | (lhs, rhs) `clobbers` (r, x) = NeverOptimize - p _ old = old --} - --- Assumption: Unsafe foreign calls don't clobber memory --- Since foreign calls clobber caller saved registers, we need --- invalidate any assignments that reference those global registers. --- This is kind of expensive. (One way to optimize this might be to --- store extra information about expressions that allow this and other --- checks to be done cheaply.) -middleAssignment (Plain n@(CmmUnsafeForeignCall{})) assign - = deleteCallerSaves (foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n) - where deleteCallerSaves m = foldUFM_Directly f m m - f u (xassign -> Just x) m | wrapRecExpf g x False = addToUFM_Directly m u NeverOptimize - f _ _ m = m - g (CmmReg (CmmGlobal r)) _ | callerSaves r = True - g (CmmRegOff (CmmGlobal r) _) _ | callerSaves r = True - g _ b = b - -middleAssignment (Plain (CmmComment {})) assign - = assign - --- Assumptions: --- * Writes using Hp do not overlap with any other memory locations --- (An important invariant being relied on here is that we only ever --- use Hp to allocate values on the heap, which appears to be the --- case given hpReg usage, and that our heap writing code doesn't --- do anything stupid like overlapping writes.) --- * Stack slots do not overlap with any other memory locations --- * Stack slots for different areas do not overlap --- * Stack slots within the same area and different offsets may --- overlap; we need to do a size check (see 'overlaps'). --- * Register slots only overlap with themselves. (But this shouldn't --- happen in practice, because we'll fail to inline a reload across --- the next spill.) --- * Non stack-slot stores always conflict with each other. (This is --- not always the case; we could probably do something special for Hp) -clobbers :: (CmmExpr, CmmExpr) -- (lhs, rhs) of clobbering CmmStore - -> (Unique, CmmExpr) -- (register, expression) that may be clobbered - -> Bool -clobbers (CmmRegOff (CmmGlobal Hp) _, _) (_, _) = False -clobbers (CmmReg (CmmGlobal Hp), _) (_, _) = False --- ToDo: Also catch MachOp case -clobbers (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _) - | getUnique r == u, ss == ss' = False -- No-op on the stack slot (XXX: Do we need this special case?) -clobbers (CmmStackSlot (CallArea a) o, rhs) (_, expr) = f expr - where f (CmmLoad (CmmStackSlot (CallArea a') o') t) - = (a, o, widthInBytes (cmmExprWidth rhs)) `overlaps` (a', o', widthInBytes (typeWidth t)) - f (CmmLoad e _) = containsStackSlot e - f (CmmMachOp _ es) = or (map f es) - f _ = False - -- Maybe there's an invariant broken if this actually ever - -- returns True - containsStackSlot (CmmLoad{}) = True -- load of a load, all bets off - containsStackSlot (CmmMachOp _ es) = or (map containsStackSlot es) - containsStackSlot (CmmStackSlot{}) = True - containsStackSlot _ = False -clobbers (CmmStackSlot (RegSlot l) _, _) (_, expr) = f expr - where f (CmmLoad (CmmStackSlot (RegSlot l') _) _) = l == l' - f _ = False -clobbers _ (_, e) = f e - where f (CmmLoad (CmmStackSlot _ _) _) = False - f (CmmLoad{}) = True -- conservative - f (CmmMachOp _ es) = or (map f es) - f _ = False - --- Check for memory overlapping. --- Diagram: --- 4 8 12 --- s -w- o --- [ I32 ] --- [ F64 ] --- s' -w'- o' -type CallSubArea = (AreaId, Int, Int) -- area, offset, width -overlaps :: CallSubArea -> CallSubArea -> Bool -overlaps (a, _, _) (a', _, _) | a /= a' = False -overlaps (_, o, w) (_, o', w') = - let s = o - w - s' = o' - w' - in (s' < o) && (s < o) -- Not LTE, because [ I32 ][ I32 ] is OK - -lastAssignment :: WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)] --- Variables are dead across calls, so invalidating all mappings is justified -lastAssignment (Plain (CmmCall _ (Just k) _ _ _)) assign = [(k, mapUFM (const NeverOptimize) assign)] -lastAssignment (Plain (CmmForeignCall {succ=k})) assign = [(k, mapUFM (const NeverOptimize) assign)] -lastAssignment l assign = map (\id -> (id, deleteSinks l assign)) $ successors l - -assignmentTransfer :: FwdTransfer (WithRegUsage CmmNode) AssignmentMap -assignmentTransfer = mkFTransfer3 (flip const) middleAssignment ((mkFactBase assignmentLattice .) . lastAssignment) - -assignmentRewrite :: FwdRewrite FuelUniqSM (WithRegUsage CmmNode) AssignmentMap -assignmentRewrite = mkFRewrite3 first middle last - where - first _ _ = return Nothing - middle :: WithRegUsage CmmNode O O -> AssignmentMap -> GenCmmReplGraph (WithRegUsage CmmNode) O O - middle (Plain m) assign = return $ rewrite assign (precompute assign m) mkMiddle m - middle (AssignLocal l e u) assign = return $ rewriteLocal assign (precompute assign (CmmAssign (CmmLocal l) e)) mkMiddle l e u - last (Plain l) assign = return $ rewrite assign (precompute assign l) mkLast l - -- Tuple is (inline?, reloads) - precompute assign n = foldRegsUsed f (False, []) n -- duplicates are harmless - where f (i, l) r = case lookupUFM assign r of - Just (AlwaysSink e) -> (i, (Plain (CmmAssign (CmmLocal r) e)):l) - Just (AlwaysInline _) -> (True, l) - Just NeverOptimize -> (i, l) - -- This case can show up when we have - -- limited optimization fuel. - Nothing -> (i, l) - rewrite _ (False, []) _ _ = Nothing - -- Note [CmmCall Inline Hack] - -- Conservative hack: don't do any inlining on what will - -- be translated into an OldCmm CmmCalls, since the code - -- produced here tends to be unproblematic and I need to write - -- lint passes to ensure that we don't put anything in the - -- arguments that could be construed as a global register by - -- some later translation pass. (For example, slots will turn - -- into dereferences of Sp). See [Register parameter passing]. - -- ToDo: Fix this up to only bug out if all inlines were for - -- CmmExprs with global registers (we can't use the - -- straightforward mapExpDeep call, in this case.) ToDo: We miss - -- an opportunity here, where all possible inlinings should - -- instead be sunk. - rewrite _ (True, []) _ n | not (inlinable n) = Nothing -- see [CmmCall Inline Hack] - rewrite assign (i, xs) mk n = Just $ mkMiddles xs <*> mk (Plain (inline i assign n)) - - rewriteLocal _ (False, []) _ _ _ _ = Nothing - rewriteLocal assign (i, xs) mk l e u = Just $ mkMiddles xs <*> mk n' - where n' = AssignLocal l e' u - e' = if i then wrapRecExp (inlineExp assign) e else e - -- inlinable check omitted, since we can always inline into - -- assignments. - - inline :: Bool -> AssignmentMap -> CmmNode e x -> CmmNode e x - inline False _ n = n - inline True _ n | not (inlinable n) = n -- see [CmmCall Inline Hack] - inline True assign n = mapExpDeep (inlineExp assign) n - - inlineExp assign old@(CmmReg (CmmLocal r)) - = case lookupUFM assign r of - Just (AlwaysInline x) -> x - _ -> old - inlineExp assign old@(CmmRegOff (CmmLocal r) i) - = case lookupUFM assign r of - Just (AlwaysInline x) -> - case x of - (CmmRegOff r' i') -> CmmRegOff r' (i + i') - _ -> CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)] - where rep = typeWidth (localRegType r) - _ -> old - inlineExp _ old = old - - inlinable :: CmmNode e x -> Bool - inlinable (CmmCall{}) = False - inlinable (CmmForeignCall{}) = False - inlinable (CmmUnsafeForeignCall{}) = False - inlinable _ = True - -rewriteAssignments :: CmmGraph -> FuelUniqSM CmmGraph -rewriteAssignments g = do - g' <- annotateUsage g - g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $ - analRewFwd assignmentLattice assignmentTransfer assignmentRewrite - return (modifyGraph eraseRegUsage g'') - --------------------- -- prettyprinting @@ -670,12 +164,3 @@ instance Outputable DualLive where else (ppr_regs "live in regs =" regs), if isEmptyUniqSet stack then PP.empty else (ppr_regs "live on stack =" stack)] - --- ToDo: Outputable instance for UsageMap and AssignmentMap - -my_trace :: String -> SDoc -> a -> a -my_trace = if False then pprTrace else \_ _ a -> a - -f4sep :: [SDoc] -> SDoc -f4sep [] = fsep [] -f4sep (d:ds) = fsep (d : map (nest 4) ds) diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 1e3f17b5a8..d1ac5712ab 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -119,25 +119,25 @@ mkAssign :: CmmReg -> CmmExpr -> CmmAGraph mkStore :: CmmExpr -> CmmExpr -> CmmAGraph ---------- Calls -mkCall :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals -> +mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset -> CmmAGraph -mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals -> +mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset -> CmmAGraph -- Native C-- calling convention -mkSafeCall :: ForeignTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> Bool -> CmmAGraph -mkUnsafeCall :: ForeignTarget -> CmmFormals -> CmmActuals -> CmmAGraph -mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph +mkSafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset -> Bool -> CmmAGraph +mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph +mkFinalCall :: CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset -> CmmAGraph -- Never returns; like exit() or barf() ---------- Control transfer -mkJump :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph -mkDirectJump :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph -mkJumpGC :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph -mkForeignJump :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph +mkJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph +mkDirectJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph +mkJumpGC :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph +mkForeignJump :: Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph -mkReturn :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph -mkReturnSimple :: CmmActuals -> UpdFrameOffset -> CmmAGraph +mkReturn :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph +mkReturnSimple :: [CmmActual] -> UpdFrameOffset -> CmmAGraph mkBranch :: BlockId -> CmmAGraph mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph @@ -288,8 +288,8 @@ stackStubExpr w = CmmLit (CmmInt 0 w) -- the variables in their spill slots. -- Therefore, for copying arguments and results, we provide different -- functions to pass the arguments in an overflow area and to pass them in spill slots. -copyInOflow :: Convention -> Area -> CmmFormals -> (Int, CmmAGraph) -copyInSlot :: Convention -> CmmFormals -> [CmmNode O O] +copyInOflow :: Convention -> Area -> [CmmFormal] -> (Int, CmmAGraph) +copyInSlot :: Convention -> [CmmFormal] -> [CmmNode O O] copyOutSlot :: Convention -> [LocalReg] -> [CmmNode O O] copyInOflow conv area formals = (offset, catAGraphs $ map mkMiddle nodes) @@ -298,7 +298,7 @@ copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slot type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) -> (ByteOff, [CmmNode O O]) -type CopyIn = SlotCopier -> Convention -> Area -> CmmFormals -> (ByteOff, [CmmNode O O]) +type CopyIn = SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O]) -- Return the number of bytes used for copying arguments, as well as the -- instructions to copy the arguments. @@ -331,7 +331,7 @@ oneCopySlotI _ (reg, _) (n, ms) = -- Factoring out the common parts of the copyout functions yielded something -- more complicated: -copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset -> +copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual] -> UpdFrameOffset -> (Int, CmmAGraph) -- Generate code to move the actual parameters into the locations -- required by the calling convention. This includes a store for the return address. @@ -355,7 +355,7 @@ copyOutOflow conv transfer area@(CallArea a) actuals updfr_off else ([], 0) Old -> ([], updfr_off) - args :: [(CmmExpr, ParamLocation ByteOff)] -- The argument and where to put it + args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it args = assignArgumentsPos conv cmmExprType actuals args' = foldl adjust setRA args @@ -372,10 +372,10 @@ copyOutSlot conv actuals = foldr co [] args toExp r = CmmReg (CmmLocal r) args = assignArgumentsPos conv localRegType actuals -mkCallEntry :: Convention -> CmmFormals -> (Int, CmmAGraph) +mkCallEntry :: Convention -> [CmmFormal] -> (Int, CmmAGraph) mkCallEntry conv formals = copyInOflow conv (CallArea Old) formals -lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset -> +lastWithArgs :: Transfer -> Area -> Convention -> [CmmActual] -> UpdFrameOffset -> (ByteOff -> CmmAGraph) -> CmmAGraph lastWithArgs transfer area conv actuals updfr_off last = let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs index f5c08172d7..de1a8e0dcb 100644 --- a/compiler/cmm/OldCmm.hs +++ b/compiler/cmm/OldCmm.hs @@ -14,7 +14,7 @@ module OldCmm ( cmmMapGraphM, cmmTopMapGraphM, GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, CmmStmt(..), CmmReturnInfo(..), CmmHinted(..), - HintedCmmFormal, HintedCmmFormals, HintedCmmActual, HintedCmmActuals, + HintedCmmFormal, HintedCmmActual, CmmSafety(..), CmmCallTarget(..), module CmmDecl, module CmmExpr, @@ -146,8 +146,8 @@ data CmmStmt -- Old-style | CmmCall -- A call (foreign, native or primitive), with CmmCallTarget - HintedCmmFormals -- zero or more results - HintedCmmActuals -- zero or more arguments + [HintedCmmFormal] -- zero or more results + [HintedCmmActual] -- zero or more arguments CmmSafety -- whether to build a continuation CmmReturnInfo -- Some care is necessary when handling the arguments of these, see @@ -164,22 +164,20 @@ data CmmStmt -- Old-style -- Undefined outside range, and when there's a Nothing | CmmJump CmmExpr -- Jump to another C-- function, - HintedCmmActuals -- with these parameters. (parameters never used) + [HintedCmmActual] -- with these parameters. (parameters never used) | CmmReturn -- Return from a native C-- function, - HintedCmmActuals -- with these return values. (parameters never used) + [HintedCmmActual] -- with these return values. (parameters never used) data CmmHinted a = CmmHinted { hintlessCmm :: a, cmmHint :: ForeignHint } deriving( Eq ) -type HintedCmmActuals = [HintedCmmActual] -type HintedCmmFormals = [HintedCmmFormal] type HintedCmmFormal = CmmHinted CmmFormal type HintedCmmActual = CmmHinted CmmActual data CmmSafety = CmmUnsafe | CmmSafe C_SRT | CmmInterruptible --- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals' +-- | enable us to fold used registers over '[CmmActual]' and '[CmmFormal]' instance UserOfLocalRegs CmmStmt where foldRegsUsed f (set::b) s = stmt s set where diff --git a/compiler/cmm/OldCmmUtils.hs b/compiler/cmm/OldCmmUtils.hs index ea9ef8a54a..14a17d7946 100644 --- a/compiler/cmm/OldCmmUtils.hs +++ b/compiler/cmm/OldCmmUtils.hs @@ -78,8 +78,8 @@ cheapEqReg _ _ = False --------------------------------------------------- loadArgsIntoTemps :: [Unique] - -> HintedCmmActuals - -> ([Unique], [CmmStmt], HintedCmmActuals) + -> [HintedCmmActual] + -> ([Unique], [CmmStmt], [HintedCmmActual]) loadArgsIntoTemps uniques [] = (uniques, [], []) loadArgsIntoTemps uniques ((CmmHinted e hint):args) = (uniques'', diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index aa7d914253..1e11c0c55b 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -266,7 +266,7 @@ pprStmt stmt = case stmt of CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi CmmSwitch arg ids -> pprSwitch arg ids -pprCFunType :: SDoc -> CCallConv -> HintedCmmFormals -> HintedCmmActuals -> SDoc +pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc pprCFunType ppr_fn cconv ress args = res_type ress <+> parens (text (ccallConvAttribute cconv) <> ppr_fn) <> @@ -807,7 +807,7 @@ pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq -- ----------------------------------------------------------------------------- -- Foreign Calls -pprCall :: SDoc -> CCallConv -> HintedCmmFormals -> HintedCmmActuals -> CmmSafety +pprCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> CmmSafety -> SDoc pprCall ppr_fn cconv results args _ diff --git a/compiler/cmm/cmm-notes b/compiler/cmm/cmm-notes index 98c2e83699..f35e72d36c 100644 --- a/compiler/cmm/cmm-notes +++ b/compiler/cmm/cmm-notes @@ -1,9 +1,5 @@ More notes (June 11)
~~~~~~~~~~~~~~~~~~~~
-* Kill dead code assignArguments, argumentsSize in CmmCallConv.
- Bake in ByteOff to ParamLocation and ArgumentFormat
- CmmActuals -> [CmmActual] similary CmmFormals
-
* Possible refactoring: Nuke AGraph in favour of
mkIfThenElse :: Expr -> Graph -> Graph -> FCode Graph
or even
@@ -12,16 +8,10 @@ More notes (June 11) or parameterise FCode over its envt; the CgState part seem useful for both
-* Move top and tail calls to runCmmContFlowOpts from HscMain to CmmCps.cpsTop
- (and rename the latter!)
-
* "Remove redundant reloads" in CmmSpillReload should be redundant; since
insertLateReloads is now gone, every reload is reloading a live variable.
Test and nuke.
-* Sink and inline S(RegSlot(x)) = e in precisely the same way that we
- sink and inline x = e
-
* Stack layout is very like register assignment: find non-conflicting assigments.
In particular we can use colouring or linear scan (etc).
@@ -110,6 +100,8 @@ Things to do: dichotomy. Mostly this means global replace, but we also need to make
Label an instance of Outputable (probably in the Outputable module).
+ EZY: We should use Label, since that's the terminology Hoopl uses.
+
- NB that CmmProcPoint line 283 has a hack that works around a GADT-related
bug in 6.10.
@@ -255,7 +247,7 @@ CmmCvt.hs Conversion between old and new Cmm reps CmmOpt.hs Hopefully-redundant optimiser
-------- Stuff to keep ------------
-CmmCPS.hs Driver for new pipeline
+CmmPipeline.hs Driver for new pipeline
CmmLive.hs Liveness analysis, dead code elim
CmmProcPoint.hs Identifying and splitting out proc-points
@@ -302,24 +294,24 @@ BlockId.hs BlockId, BlockEnv, BlockSet type RawCmm = GenCmm CmmStatic [CmmStatic] (ListGraph CmmStmt)
* HscMain.tryNewCodeGen
- - STG->Cmm: StgCmm.codeGen (new codegen)
- - Optimise: CmmContFlowOpt (simple optimisations, very self contained)
- - Cps convert: CmmCPS.protoCmmCPS
- - Optimise: CmmContFlowOpt again
- - Convert: CmmCvt.cmmOfZgraph (convert to old rep) very self contained
+ - STG->Cmm: StgCmm.codeGen (new codegen)
+ - Optimize and CPS: CmmPipeline.cmmPipeline
+ - Convert: CmmCvt.cmmOfZgraph (convert to old rep) very self contained
* StgCmm.hs The new STG -> Cmm conversion code generator
Lots of modules StgCmmXXX
----------------------------------------------------
- CmmCPS.protoCmmCPS The new pipeline
+ CmmPipeline.cmmPipeline The new pipeline
----------------------------------------------------
-CmmCPS.protoCmmCPS:
- 1. Do cpsTop for each procedures separately
- 2. Build SRT representation; this spans multiple procedures
- (unless split-objs)
+CmmPipeline.cmmPipeline:
+ 1. Do control flow optimization
+ 2. Do cpsTop for each procedures separately
+ 3. Build SRT representation; this spans multiple procedures
+ (unless split-objs)
+ 4. Do control flow optimization on all resulting procedures
cpsTop:
* CmmCommonBlockElim.elimCommonBlocks:
@@ -457,7 +449,7 @@ a dominator analysis, using the Dataflow Engine. f's keep-alive refs to include h1.
* The SRT info is the C_SRT field of Cmm.ClosureTypeInfo in a
- CmmInfoTable attached to each CmmProc. CmmCPS.toTops actually does
+ CmmInfoTable attached to each CmmProc. CmmPipeline.toTops actually does
the attaching, right at the end of the pipeline. The C_SRT part
gives offsets within a single, shared table of closure pointers.
diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index ec16946318..fff21af8cb 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -43,7 +43,7 @@ import Control.Monad -- Code generation for Foreign Calls cgForeignCall - :: HintedCmmFormals -- where to put the results + :: [HintedCmmFormal] -- where to put the results -> ForeignCall -- the op -> [StgArg] -- arguments -> StgLiveVars -- live vars, in case we need to save them @@ -64,7 +64,7 @@ cgForeignCall results fcall stg_args live emitForeignCall - :: HintedCmmFormals -- where to put the results + :: [HintedCmmFormal] -- where to put the results -> ForeignCall -- the op -> [CmmHinted CmmExpr] -- arguments -> StgLiveVars -- live vars, in case we need to save them @@ -109,9 +109,12 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live -- alternative entry point, used by CmmParse +-- the new code generator has utility function emitCCall and emitPrimCall +-- which should be used instead of this (the equivalent emitForeignCall +-- is not presently exported.) emitForeignCall' :: Safety - -> HintedCmmFormals -- where to put the results + -> [HintedCmmFormal] -- where to put the results -> CmmCallTarget -- the op -> [CmmHinted CmmExpr] -- arguments -> Maybe [GlobalReg] -- live vars, in case we need to save them diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index e04079d666..2745832227 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -53,7 +53,7 @@ import Outputable -- representation as a list of 'CmmAddr' is handled later -- in the pipeline by 'cmmToRawCmm'. -emitClosureCodeAndInfoTable :: ClosureInfo -> CmmFormals -> CgStmts -> Code +emitClosureCodeAndInfoTable :: ClosureInfo -> [CmmFormal] -> CgStmts -> Code emitClosureCodeAndInfoTable cl_info args body = do { blks <- cgStmtsToBlocks body ; info <- mkCmmInfo cl_info @@ -412,7 +412,7 @@ funInfoTable info_ptr emitInfoTableAndCode :: CLabel -- Label of entry or ret -> CmmInfo -- ...the info table - -> CmmFormals -- ...args + -> [CmmFormal] -- ...args -> [CmmBasicBlock] -- ...and body -> Code diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 8a3b664fc1..9b195bfab2 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -701,6 +701,8 @@ whenC :: Bool -> Code -> Code whenC True code = code whenC False _ = nopC +-- Corresponds to 'emit' in new code generator with a smart constructor +-- from cmm/MkGraph.hs stmtC :: CmmStmt -> Code stmtC stmt = emitCgStmt (CgStmt stmt) @@ -741,7 +743,7 @@ emitData sect lits where data_block = CmmData sect lits -emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code +emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code emitProc info lbl [] blocks = do { let proc_block = CmmProc info lbl (ListGraph blocks) ; state <- getState diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index fa7287d4a2..87ed25c041 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -35,7 +35,7 @@ import FastString -- --------------------------------------------------------------------------- -- Code generation for PrimOps -cgPrimOp :: CmmFormals -- where to put the results +cgPrimOp :: [CmmFormal] -- where to put the results -> PrimOp -- the op -> [StgArg] -- arguments -> StgLiveVars -- live vars, in case we need to save them @@ -47,7 +47,7 @@ cgPrimOp results op args live emitPrimOp results op non_void_args live -emitPrimOp :: CmmFormals -- where to put the results +emitPrimOp :: [CmmFormal] -- where to put the results -> PrimOp -- the op -> [CmmExpr] -- arguments -> StgLiveVars -- live vars, in case we need to save them @@ -347,6 +347,13 @@ emitPrimOp res WriteByteArrayOp_Word16 args _ = doWriteByteArrayOp (Just mo_W emitPrimOp res WriteByteArrayOp_Word32 args _ = doWriteByteArrayOp (Just mo_WordTo32) b32 res args emitPrimOp res WriteByteArrayOp_Word64 args _ = doWriteByteArrayOp Nothing b64 res args +-- Copying byte arrays + +emitPrimOp [] CopyByteArrayOp [src,src_off,dst,dst_off,n] live = + doCopyByteArrayOp src src_off dst dst_off n live +emitPrimOp [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] live = + doCopyMutableByteArrayOp src src_off dst dst_off n live + -- The rest just translate straightforwardly emitPrimOp [res] op [arg] _ @@ -636,8 +643,58 @@ setInfo :: CmmExpr -> CmmExpr -> CmmStmt setInfo closure_ptr info_ptr = CmmStore closure_ptr info_ptr -- ---------------------------------------------------------------------------- +-- Copying byte arrays + +-- | Takes a source 'ByteArray#', an offset in the source array, a +-- destination 'MutableByteArray#', an offset into the destination +-- array, and the number of bytes to copy. Copies the given number of +-- bytes from the source array to the destination array. +doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars -> Code +doCopyByteArrayOp = emitCopyByteArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes live = + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live + +-- | Takes a source 'MutableByteArray#', an offset in the source +-- array, a destination 'MutableByteArray#', an offset into the +-- destination array, and the number of bytes to copy. Copies the +-- given number of bytes from the source array to the destination +-- array. +doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars -> Code +doCopyMutableByteArrayOp = emitCopyByteArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes live = + emitIfThenElse (cmmEqWord src dst) + (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live) + (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live) + +emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars -> Code) + -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars + -> Code +emitCopyByteArray copy src src_off dst dst_off n live = do + dst_p <- assignTemp $ cmmOffsetExpr (cmmOffsetB dst arrWordsHdrSize) dst_off + src_p <- assignTemp $ cmmOffsetExpr (cmmOffsetB src arrWordsHdrSize) src_off + copy src dst dst_p src_p n live + +-- ---------------------------------------------------------------------------- -- Copying pointer arrays +-- EZY: This code has an unusually high amount of assignTemp calls, seen +-- nowhere else in the code generator. This is mostly because these +-- "primitive" ops result in a surprisingly large amount of code. It +-- will likely be worthwhile to optimize what is emitted here, so that +-- our optimization passes don't waste time repeatedly optimizing the +-- same bits of code. + -- | Takes a source 'Array#', an offset in the source array, a -- destination 'MutableArray#', an offset into the destination array, -- and the number of elements to copy. Copies the given number of @@ -648,7 +705,8 @@ doCopyArrayOp = emitCopyArray copy where -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) - copy _src _dst = emitMemcpyCall + copy _src _dst dst_p src_p bytes live = + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live -- | Takes a source 'MutableArray#', an offset in the source array, a -- destination 'MutableArray#', an offset into the destination array, @@ -663,8 +721,8 @@ doCopyMutableArrayOp = emitCopyArray copy -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes live = emitIfThenElse (cmmEqWord src dst) - (emitMemmoveCall dst_p src_p bytes live) - (emitMemcpyCall dst_p src_p bytes live) + (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live) + (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live) emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code) @@ -730,11 +788,13 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off - emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) live + emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) + (CmmLit (mkIntCLit wORD_SIZE)) live emitMemsetCall (cmmOffsetExprW dst_p n) (CmmLit (mkIntCLit 1)) (card_words `cmmMulWord` wordSize) + (CmmLit (mkIntCLit wORD_SIZE)) live stmtC $ CmmAssign (CmmLocal res_r) arr where @@ -754,65 +814,63 @@ emitSetCards dst_start dst_cards_start n live = do (CmmLit (mkIntCLit 1)) ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card) `cmmAddWord` CmmLit (mkIntCLit 1)) + (CmmLit (mkIntCLit wORD_SIZE)) live where -- Convert an element index to a card index card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)) -- | Emit a call to @memcpy@. -emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code -emitMemcpyCall dst src n live = do +emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars + -> Code +emitMemcpyCall dst src n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmCallee memcpy CCallConv) + (CmmPrim MO_Memcpy) [ (CmmHinted dst AddrHint) , (CmmHinted src AddrHint) , (CmmHinted n NoHint) + , (CmmHinted align NoHint) ] (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn - where - memcpy = CmmLit (CmmLabel (mkForeignLabel (fsLit "memcpy") Nothing - ForeignLabelInExternalPackage IsFunction)) -- | Emit a call to @memmove@. -emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code -emitMemmoveCall dst src n live = do +emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars + -> Code +emitMemmoveCall dst src n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmCallee memmove CCallConv) + (CmmPrim MO_Memmove) [ (CmmHinted dst AddrHint) , (CmmHinted src AddrHint) , (CmmHinted n NoHint) + , (CmmHinted align NoHint) ] (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn - where - memmove = CmmLit (CmmLabel (mkForeignLabel (fsLit "memmove") Nothing - ForeignLabelInExternalPackage IsFunction)) --- | Emit a call to @memset@. The second argument must fit inside an --- unsigned char. -emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code -emitMemsetCall dst c n live = do +-- | Emit a call to @memset@. The second argument must be a word but +-- its value must fit inside an unsigned char. +emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars + -> Code +emitMemsetCall dst c n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmCallee memset CCallConv) + (CmmPrim MO_Memset) [ (CmmHinted dst AddrHint) , (CmmHinted c NoHint) , (CmmHinted n NoHint) + , (CmmHinted align NoHint) ] (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn - where - memset = CmmLit (CmmLabel (mkForeignLabel (fsLit "memset") Nothing - ForeignLabelInExternalPackage IsFunction)) -- | Emit a call to @allocate@. emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> StgLiveVars -> Code diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 9a15cf0d06..b9e9224fd5 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -104,20 +104,20 @@ emitCCall hinted_results fn hinted_args fc = ForeignConvention CCallConv arg_hints result_hints -emitPrimCall :: CmmFormals -> CallishMachOp -> CmmActuals -> FCode () +emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode () emitPrimCall res op args = emitForeignCall PlayRisky res (PrimTarget op) args NoC_SRT CmmMayReturn -- alternative entry point, used by CmmParse emitForeignCall - :: Safety - -> CmmFormals -- where to put the results - -> ForeignTarget -- the op - -> CmmActuals -- arguments + :: Safety + -> [CmmFormal] -- where to put the results + -> ForeignTarget -- the op + -> [CmmActual] -- arguments -> C_SRT -- the SRT of the calls continuation - -> CmmReturnInfo -- This can say "never returns" - -- only RTS procedures do this - -> FCode () + -> CmmReturnInfo -- This can say "never returns" + -- only RTS procedures do this + -> FCode () emitForeignCall safety results target args _srt _ret | not (playSafe safety) = do let (caller_save, caller_load) = callerSaveVolatileRegs diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 919a5d0eee..f92b3cde27 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -600,7 +600,7 @@ emitData sect lits where data_block = CmmData sect lits -emitProcWithConvention :: Convention -> CmmInfoTable -> CLabel -> CmmFormals -> +emitProcWithConvention :: Convention -> CmmInfoTable -> CLabel -> [CmmFormal] -> CmmAGraph -> FCode () emitProcWithConvention conv info lbl args blocks = do { us <- newUniqSupply @@ -611,7 +611,7 @@ emitProcWithConvention conv info lbl args blocks ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } -emitProc :: CmmInfoTable -> CLabel -> CmmFormals -> CmmAGraph -> FCode () +emitProc :: CmmInfoTable -> CLabel -> [CmmFormal] -> CmmAGraph -> FCode () emitProc = emitProcWithConvention NativeNodeCall emitSimpleProc :: CLabel -> CmmAGraph -> FCode () diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index afe0c39d98..1a6d05e6e6 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -17,7 +17,11 @@ import StgCmmForeign import StgCmmEnv import StgCmmMonad import StgCmmUtils +import StgCmmTicky +import StgCmmHeap +import StgCmmProf +import BasicTypes import MkGraph import StgSyn import CmmDecl @@ -281,6 +285,21 @@ emitPrimOp [res] UnsafeFreezeArrayOp [arg] emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] = emit (mkAssign (CmmLocal res) arg) +-- Copying pointer arrays + +emitPrimOp [] CopyArrayOp [src,src_off,dst,dst_off,n] = + doCopyArrayOp src src_off dst dst_off n +emitPrimOp [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] = + doCopyMutableArrayOp src src_off dst dst_off n +emitPrimOp [res] CloneArrayOp [src,src_off,n] = + emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n +emitPrimOp [res] CloneMutableArrayOp [src,src_off,n] = + emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n +emitPrimOp [res] FreezeArrayOp [src,src_off,n] = + emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n +emitPrimOp [res] ThawArrayOp [src,src_off,n] = + emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n + -- Reading/writing pointer arrays emitPrimOp [r] ReadArrayOp [obj,ix] = doReadPtrArrayOp r obj ix @@ -406,6 +425,11 @@ emitPrimOp res WriteByteArrayOp_Word16 args = doWriteByteArrayOp (Just mo_Wor emitPrimOp res WriteByteArrayOp_Word32 args = doWriteByteArrayOp (Just mo_WordTo32) res args emitPrimOp res WriteByteArrayOp_Word64 args = doWriteByteArrayOp Nothing res args +-- Copying byte arrays +emitPrimOp [] CopyByteArrayOp [src,src_off,dst,dst_off,n] = + doCopyByteArrayOp src src_off dst dst_off n +emitPrimOp [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] = + doCopyMutableByteArrayOp src src_off dst dst_off n -- The rest just translate straightforwardly emitPrimOp [res] op [arg] @@ -684,3 +708,223 @@ cmmLoadIndexOffExpr off ty base idx setInfo :: CmmExpr -> CmmExpr -> CmmAGraph setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr +-- ---------------------------------------------------------------------------- +-- Copying byte arrays + +-- | Takes a source 'ByteArray#', an offset in the source array, a +-- destination 'MutableByteArray#', an offset into the destination +-- array, and the number of bytes to copy. Copies the given number of +-- bytes from the source array to the destination array. +doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyByteArrayOp = emitCopyByteArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes = + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) + +-- | Takes a source 'MutableByteArray#', an offset in the source +-- array, a destination 'MutableByteArray#', an offset into the +-- destination array, and the number of bytes to copy. Copies the +-- given number of bytes from the source array to the destination +-- array. +doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyMutableByteArrayOp = emitCopyByteArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes = do + [moveCall, cpyCall] <- forkAlts [ + getCode $ emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit 1)), + getCode $ emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) + ] + emit $ mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall + +emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode ()) + -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +emitCopyByteArray copy src src_off dst dst_off n = do + dst_p <- assignTempE $ cmmOffsetExpr (cmmOffsetB dst arrWordsHdrSize) dst_off + src_p <- assignTempE $ cmmOffsetExpr (cmmOffsetB src arrWordsHdrSize) src_off + copy src dst dst_p src_p n + +-- ---------------------------------------------------------------------------- +-- Copying pointer arrays + +-- EZY: This code has an unusually high amount of assignTemp calls, seen +-- nowhere else in the code generator. This is mostly because these +-- "primitive" ops result in a surprisingly large amount of code. It +-- will likely be worthwhile to optimize what is emitted here, so that +-- our optimization passes don't waste time repeatedly optimizing the +-- same bits of code. + +-- More closely imitates 'assignTemp' from the old code generator, which +-- returns a CmmExpr rather than a LocalReg. +assignTempE :: CmmExpr -> FCode CmmExpr +assignTempE e = do + t <- assignTemp e + return (CmmReg (CmmLocal t)) + +-- | Takes a source 'Array#', an offset in the source array, a +-- destination 'MutableArray#', an offset into the destination array, +-- and the number of elements to copy. Copies the given number of +-- elements from the source array to the destination array. +doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyArrayOp = emitCopyArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes = + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) + + +-- | Takes a source 'MutableArray#', an offset in the source array, a +-- destination 'MutableArray#', an offset into the destination array, +-- and the number of elements to copy. Copies the given number of +-- elements from the source array to the destination array. +doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyMutableArrayOp = emitCopyArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes = do + [moveCall, cpyCall] <- forkAlts [ + getCode $ emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)), + getCode $ emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) + ] + emit $ mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall + +emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode ()) + -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do + -- Passed as arguments (be careful) + src <- assignTempE src0 + src_off <- assignTempE src_off0 + dst <- assignTempE dst0 + dst_off <- assignTempE dst_off0 + n <- assignTempE n0 + + -- Set the dirty bit in the header. + emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) + + dst_elems_p <- assignTempE $ cmmOffsetB dst arrPtrsHdrSize + dst_p <- assignTempE $ cmmOffsetExprW dst_elems_p dst_off + src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off + bytes <- assignTempE $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE)) + + copy src dst dst_p src_p bytes + + -- The base address of the destination card table + dst_cards_p <- assignTempE $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dst) + + emitSetCards dst_off dst_cards_p n + +-- | Takes an info table label, a register to return the newly +-- allocated array in, a source array, an offset in the source array, +-- and the number of elements to copy. Allocates a new array and +-- initializes it form the source array. +emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +emitCloneArray info_p res_r src0 src_off0 n0 = do + -- Passed as arguments (be careful) + src <- assignTempE src0 + src_off <- assignTempE src_off0 + n <- assignTempE n0 + + card_words <- assignTempE $ (n `cmmUShrWord` + (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))) + `cmmAddWord` CmmLit (mkIntCLit 1) + size <- assignTempE $ n `cmmAddWord` card_words + words <- assignTempE $ arrPtrsHdrSizeW `cmmAddWord` size + + arr_r <- newTemp bWord + emitAllocateCall arr_r myCapability words + tickyAllocPrim (CmmLit (mkIntCLit arrPtrsHdrSize)) (n `cmmMulWord` wordSize) + (CmmLit $ mkIntCLit 0) + + let arr = CmmReg (CmmLocal arr_r) + emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCSAddr + emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE + + oFFSET_StgMutArrPtrs_ptrs)) n + emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE + + oFFSET_StgMutArrPtrs_size)) size + + dst_p <- assignTempE $ cmmOffsetB arr arrPtrsHdrSize + src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) + src_off + + emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) (CmmLit (mkIntCLit wORD_SIZE)) + + emitMemsetCall (cmmOffsetExprW dst_p n) + (CmmLit (mkIntCLit 1)) + (card_words `cmmMulWord` wordSize) + (CmmLit (mkIntCLit wORD_SIZE)) + emit $ mkAssign (CmmLocal res_r) arr + where + arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize + + (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) + wordSize = CmmLit (mkIntCLit wORD_SIZE) + myCapability = CmmReg baseReg `cmmSubWord` + CmmLit (mkIntCLit oFFSET_Capability_r) + +-- | Takes and offset in the destination array, the base address of +-- the card table, and the number of elements affected (*not* the +-- number of cards). Marks the relevant cards as dirty. +emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitSetCards dst_start dst_cards_start n = do + start_card <- assignTempE $ card dst_start + emitMemsetCall (dst_cards_start `cmmAddWord` start_card) + (CmmLit (mkIntCLit 1)) + ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card) + `cmmAddWord` CmmLit (mkIntCLit 1)) + (CmmLit (mkIntCLit wORD_SIZE)) + where + -- Convert an element index to a card index + card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)) + +-- | Emit a call to @memcpy@. +emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitMemcpyCall dst src n align = do + emitPrimCall + [ {-no results-} ] + MO_Memcpy + [ dst, src, n, align ] + +-- | Emit a call to @memmove@. +emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitMemmoveCall dst src n align = do + emitPrimCall + [ {- no results -} ] + MO_Memmove + [ dst, src, n, align ] + +-- | Emit a call to @memset@. The second argument must fit inside an +-- unsigned char. +emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitMemsetCall dst c n align = do + emitPrimCall + [ {- no results -} ] + MO_Memset + [ dst, c, n, align ] + +-- | Emit a call to @allocate@. +emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> FCode () +emitAllocateCall res cap n = do + emitCCall + [ (res, AddrHint) ] + allocate + [ (cap, AddrHint) + , (n, NoHint) + ] + where + allocate = CmmLit (CmmLabel (mkForeignLabel (fsLit "allocate") Nothing + ForeignLabelInExternalPackage IsFunction)) diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index d917811684..558b7fdeaa 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -23,7 +23,7 @@ module StgCmmUtils ( callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr, cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, - cmmUGtWord, + cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord, cmmOffsetExprW, cmmOffsetExprB, cmmRegOffW, cmmRegOffB, cmmLabelOffW, cmmLabelOffB, @@ -160,7 +160,8 @@ cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty ----------------------- cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord, - cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord + cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord, + cmmUShrWord, cmmAddWord, cmmMulWord :: CmmExpr -> CmmExpr -> CmmExpr cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2] cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2] @@ -170,8 +171,10 @@ cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2] cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2] cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2] --cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2] ---cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2] +cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2] +cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2] cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2] +cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2] cmmNegate :: CmmExpr -> CmmExpr cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) @@ -550,7 +553,13 @@ mkByteStringCLit bytes ------------------------------------------------------------------------- assignTemp :: CmmExpr -> FCode LocalReg --- Make sure the argument is in a local register +-- Make sure the argument is in a local register. +-- We don't bother being particularly aggressive with avoiding +-- unnecessary local registers, since we can rely on a later +-- optimization pass to inline as necessary (and skipping out +-- on things like global registers can be a little dangerous +-- due to them being trashed on foreign calls--though it means +-- the optimization pass doesn't have to do as much work) assignTemp (CmmReg (CmmLocal reg)) = return reg assignTemp e = do { uniq <- newUnique ; let reg = LocalReg uniq (cmmExprType e) diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 65cb8157da..39e7e298ab 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -493,6 +493,15 @@ dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding -> Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) + | isJust (isClassOpId_maybe poly_id) + = putSrcSpanDs loc $ + do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector") + <+> quotes (ppr poly_id)) + ; return Nothing } -- There is no point in trying to specialise a class op + -- Moreover, classops don't (currently) have an inl_sat arity set + -- (it would be Just 0) and that in turn makes makeCorePair bleat + + | otherwise = putSrcSpanDs loc $ do { let poly_name = idName poly_id ; spec_name <- newLocalName poly_name diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index a5cbdd361d..3988105e90 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -57,6 +57,7 @@ import Bag import FastString import ForeignCall import MonadUtils +import Util( equalLength ) import Data.Maybe import Control.Monad @@ -173,7 +174,7 @@ repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, do { cxt1 <- repLContext cxt ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 - ; cons1 <- mapM repC cons + ; cons1 <- mapM (repC (hsLTyVarNames tvs)) cons ; cons2 <- coreList conQTyConName cons1 ; derivs1 <- repDerivs mb_derivs ; bndrs1 <- coreList tyVarBndrTyConName bndrs @@ -190,7 +191,7 @@ repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, do { cxt1 <- repLContext cxt ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 - ; con1 <- repC con + ; con1 <- repC (hsLTyVarNames tvs) con ; derivs1 <- repDerivs mb_derivs ; bndrs1 <- coreList tyVarBndrTyConName bndrs ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1 @@ -360,23 +361,73 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") -- Constructors ------------------------------------------------------- -repC :: LConDecl Name -> DsM (Core TH.ConQ) -repC (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ [] - , con_details = details, con_res = ResTyH98 })) +repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ) +repC _ (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ [] + , con_details = details, con_res = ResTyH98 })) = do { con1 <- lookupLOcc con -- See note [Binders and occurrences] - ; repConstr con1 details - } -repC (L loc con_decl@(ConDecl { con_qvars = tvs, con_cxt = L cloc ctxt, con_res = ResTyH98 })) - = addTyVarBinds tvs $ \bndrs -> - do { c' <- repC (L loc (con_decl { con_qvars = [], con_cxt = L cloc [] })) - ; ctxt' <- repContext ctxt - ; bndrs' <- coreList tyVarBndrTyConName bndrs - ; rep2 forallCName [unC bndrs', unC ctxt', unC c'] - } -repC (L loc con_decl) -- GADTs - = putSrcSpanDs loc $ - notHandled "GADT declaration" (ppr con_decl) - + ; repConstr con1 details } +repC tvs (L _ (ConDecl { con_name = con + , con_qvars = con_tvs, con_cxt = L _ ctxt + , con_details = details + , con_res = res_ty })) + = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty + ; let ex_tvs = [ tv | tv <- con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)] + ; binds <- mapM dupBinder con_tv_subst + ; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs + addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs + do { con1 <- lookupLOcc con -- See note [Binders and occurrences] + ; c' <- repConstr con1 details + ; ctxt' <- repContext (eq_ctxt ++ ctxt) + ; ex_bndrs' <- coreList tyVarBndrTyConName ex_bndrs + ; rep2 forallCName [unC ex_bndrs', unC ctxt', unC c'] } } + +in_subst :: Name -> [(Name,Name)] -> Bool +in_subst _ [] = False +in_subst n ((n',_):ns) = n==n' || in_subst n ns + +mkGadtCtxt :: [Name] -- Tyvars of the data type + -> ResType Name + -> DsM (HsContext Name, [(Name,Name)]) +-- Given a data type in GADT syntax, figure out the equality +-- context, so that we can represent it with an explicit +-- equality context, because that is the only way to express +-- the GADT in TH syntax +-- +-- Example: +-- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e +-- mkGadtCtxt [a,b,c] [d,e] (T d [e] e) +-- returns +-- (b~[e], c~e), [d->a] +-- +-- This function is fiddly, but not really hard +mkGadtCtxt _ ResTyH98 + = return ([], []) +mkGadtCtxt data_tvs (ResTyGADT res_ty) + | let (head_ty, tys) = splitHsAppTys res_ty [] + , Just _ <- is_hs_tyvar head_ty + , data_tvs `equalLength` tys + = return (go [] [] (data_tvs `zip` tys)) + + | otherwise + = failWithDs (ptext (sLit "Malformed constructor result type") <+> ppr res_ty) + where + go cxt subst [] = (cxt, subst) + go cxt subst ((data_tv, ty) : rest) + | Just con_tv <- is_hs_tyvar ty + , isTyVarName con_tv + , not (in_subst con_tv subst) + = go cxt ((con_tv, data_tv) : subst) rest + | otherwise + = go (eq_pred : cxt) subst rest + where + loc = getLoc ty + eq_pred = L loc (HsEqualP (L loc (HsTyVar data_tv)) ty) + + is_hs_tyvar (L _ (HsTyVar n)) = Just n -- Type variables *and* tycons + is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty + is_hs_tyvar _ = Nothing + + repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ)) repBangTy ty= do MkC s <- rep2 str [] @@ -419,7 +470,7 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Singleton => Ok -- Empty => Too hard, signature ignored -rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc +rep_sig (L loc (TypeSig nms ty)) = rep_proto nms ty loc rep_sig (L _ (GenericSig nm _)) = failWithDs msg where msg = vcat [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm) , ptext (sLit "Default signatures are not supported by Template Haskell") ] @@ -428,14 +479,16 @@ rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc rep_sig _ = return [] -rep_proto :: Located Name -> LHsType Name -> SrcSpan +rep_proto :: [Located Name] -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] -rep_proto nm ty loc - = do { nm1 <- lookupLOcc nm - ; ty1 <- repLTy ty - ; sig <- repProto nm1 ty1 - ; return [(loc, sig)] - } +rep_proto nms ty loc + = mapM f nms + where + f nm = do { nm1 <- lookupLOcc nm + ; ty1 <- repLTy ty + ; sig <- repProto nm1 ty1 + ; return (loc, sig) + } rep_inline :: Located Name -> InlinePragma -- Never defaultInlinePragma @@ -506,16 +559,14 @@ type ProcessTyVarBinds a = -- meta environment and gets the *new* names on Core-level as an argument -- addTyVarBinds :: ProcessTyVarBinds a -addTyVarBinds tvs m = - do - let names = hsLTyVarNames tvs - mkWithKinds = map repTyVarBndrWithKind tvs - freshNames <- mkGenSyms names - term <- addBinds freshNames $ do - bndrs <- mapM lookupBinder names - kindedBndrs <- zipWithM ($) mkWithKinds bndrs - m kindedBndrs - wrapGenSyms freshNames term +addTyVarBinds tvs m + = do { freshNames <- mkGenSyms (hsLTyVarNames tvs) + ; term <- addBinds freshNames $ + do { kindedBndrs <- mapM mk_tv_bndr (tvs `zip` freshNames) + ; m kindedBndrs } + ; wrapGenSyms freshNames term } + where + mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) -- Look up a list of type variables; the computations passed as the second -- argument gets the *new* names on Core-level as an argument @@ -1112,6 +1163,13 @@ lookupBinder n where msg = ptext (sLit "DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n +dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal) +dupBinder (new, old) + = do { mb_val <- dsLookupMetaEnv old + ; case mb_val of + Just val -> return (new, val) + Nothing -> pprPanic "dupBinder" (ppr old) } + -- Look up a name that is either locally bound or a global name -- -- * If it is a global name, generate the "original name" representation (ie, diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index b3d9f0cd2a..2711c1b20e 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -182,7 +182,7 @@ Library CLabel Cmm CmmBuildInfoTables - CmmCPS + CmmPipeline CmmCallConv CmmCommonBlockElim CmmContFlowOpt @@ -199,6 +199,7 @@ Library CmmParse CmmProcPoint CmmSpillReload + CmmRewriteAssignments CmmStackLayout CmmType CmmUtils @@ -313,6 +314,8 @@ Library Finder GHC GhcMake + GhcPlugins + DynamicLoading HeaderInfo HscMain HscStats @@ -455,7 +458,6 @@ Library Vectorise.Builtins.Base Vectorise.Builtins.Initialise Vectorise.Builtins.Modules - Vectorise.Builtins.Prelude Vectorise.Builtins Vectorise.Monad.Base Vectorise.Monad.Naming diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index 696ed0f564..943c9e9992 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -36,7 +36,7 @@ import Foreign.C.String import Data.Bits ( Bits(..), shiftR ) import GHC.Exts ( Int(I#), addr2Int# ) -import GHC.Ptr ( Ptr(..) ) +import GHC.Ptr ( Ptr(..) ) import Debug.Trace import Text.Printf diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index b1f7e39aed..d4ddcc4ba2 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -38,19 +38,18 @@ import Panic import Outputable -- Standard libraries -import GHC.Word ( Word(..) ) import Data.Array.Base -import GHC.Arr ( STArray(..) ) import Control.Monad ( zipWithM ) import Control.Monad.ST ( stToIO ) -import GHC.Exts -import GHC.Arr ( Array(..) ) +import GHC.Arr ( Array(..), STArray(..) ) +import GHC.Base ( writeArray#, RealWorld, Int(..), Word# ) import GHC.IOBase ( IO(..) ) +import GHC.Exts import GHC.Ptr ( Ptr(..), castPtr ) -import GHC.Base ( writeArray#, RealWorld, Int(..), Word# ) +import GHC.Word ( Word(..) ) import Data.Word \end{code} diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index eaf452199e..90ec0b3a1f 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -15,8 +15,8 @@ module Linker ( HValue, getHValue, showLinkerState, linkExpr, unload, withExtendedLinkEnv, extendLinkEnv, deleteFromLinkEnv, extendLoadedPkgs, - linkPackages,initDynLinker, - dataConInfoPtrToName + linkPackages,initDynLinker,linkModule, + dataConInfoPtrToName, lessUnsafeCoerce ) where #include "HsVersions.h" @@ -55,6 +55,8 @@ import Constants import FastString import Config +import GHC.Exts (unsafeCoerce#) + -- Standard libraries import Control.Monad @@ -264,6 +266,7 @@ dataConInfoPtrToName x = do -- Throws a 'ProgramError' if loading fails or the name cannot be found. getHValue :: HscEnv -> Name -> IO HValue getHValue hsc_env name = do + initDynLinker (hsc_dflags hsc_env) pls <- modifyMVar v_PersistentLinkerState $ \pls -> do if (isExternalName name) then do (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name] @@ -277,6 +280,7 @@ linkDependencies :: HscEnv -> PersistentLinkerState -> SrcSpan -> [Module] -> IO (PersistentLinkerState, SuccessFlag) linkDependencies hsc_env pls span needed_mods = do +-- initDynLinker (hsc_dflags hsc_env) let hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env -- The interpreter and dynamic linker can only handle object code built @@ -633,7 +637,7 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps) - acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps + acc_pkgs' = addListToUniqSet acc_pkgs $ map fst pkg_deps -- if pkg /= this_pkg then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg) @@ -696,6 +700,38 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods adjust_ul _ _ = panic "adjust_ul" \end{code} +%************************************************************************ +%* * + Loading a single module +%* * +%************************************************************************ +\begin{code} + +-- | Link a single module +linkModule :: HscEnv -> Module -> IO () +linkModule hsc_env mod = do + initDynLinker (hsc_dflags hsc_env) + modifyMVar v_PersistentLinkerState $ \pls -> do + (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod] + if (failed ok) then ghcError (ProgramError "could not link module") + else return (pls',()) + +-- | Coerce a value as usual, but: +-- +-- 1) Evaluate it immediately to get a segfault early if the coercion was wrong +-- +-- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened +-- if it /does/ segfault +lessUnsafeCoerce :: DynFlags -> String -> a -> IO b +lessUnsafeCoerce dflags context what = do + debugTraceMsg dflags 3 $ (ptext $ sLit "Coercing a value in") <+> (text context) <> (ptext $ sLit "...") + output <- evaluate (unsafeCoerce# what) + debugTraceMsg dflags 3 $ ptext $ sLit "Successfully evaluated coercion" + return output + + + +\end{code} %************************************************************************ %* * @@ -997,6 +1033,7 @@ linkPackages :: DynFlags -> [PackageId] -> IO () linkPackages dflags new_pkgs = do -- It's probably not safe to try to load packages concurrently, so we take -- a lock. + initDynLinker dflags modifyMVar_ v_PersistentLinkerState $ \pls -> do linkPackages' dflags new_pkgs pls diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index b6c97c38aa..97485281e1 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -66,7 +66,7 @@ import Data.List import qualified Data.Sequence as Seq import Data.Monoid import Data.Sequence (viewl, ViewL(..)) -import Foreign hiding (unsafePerformIO) +import Foreign.Safe import System.IO.Unsafe --------------------------------------------- diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 492f2552cd..7b0d8c4f0d 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -143,7 +143,7 @@ cvtDec (TH.FunD nm cls) cvtDec (TH.SigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ - ; returnL $ Hs.SigD (TypeSig nm' ty') } + ; returnL $ Hs.SigD (TypeSig [nm'] ty') } cvtDec (PragmaD prag) = do { prag' <- cvtPragmaD prag @@ -831,13 +831,17 @@ thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName -- which will give confusing error messages later -- -- The strict applications ensure that any buried exceptions get forced -thRdrName _ occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod -thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan) -thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ) -thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq) -thRdrName ctxt_ns occ TH.NameS - | Just name <- isBuiltInOcc ctxt_ns occ = nameRdrName $! name - | otherwise = mkRdrUnqual $! (mk_occ ctxt_ns occ) +thRdrName ctxt_ns th_occ th_name + = case th_name of + TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod + TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ + TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) noSrcSpan) + TH.NameU uniq -> nameRdrName $! (((Name.mkSystemName $! mk_uniq uniq) $! occ)) + TH.NameS | Just name <- isBuiltInOcc ctxt_ns th_occ -> nameRdrName $! name + | otherwise -> mkRdrUnqual $! occ + where + occ :: OccName.OccName + occ = mk_occ ctxt_ns th_occ thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ) @@ -873,14 +877,9 @@ isBuiltInOcc ctxt_ns occ | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n) | otherwise = Name.getName (tupleCon Boxed n) -mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName -mk_uniq_occ ns occ uniq - = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]") - -- See Note [Unique OccNames from Template Haskell] - -- The packing and unpacking is rather turgid :-( mk_occ :: OccName.NameSpace -> String -> OccName.OccName -mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ) +mk_occ ns occ = OccName.mkOccName ns occ mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace mk_ghc_ns TH.DataName = OccName.dataName @@ -897,17 +896,64 @@ mk_uniq :: Int# -> Unique mk_uniq u = mkUniqueGrimily (I# u) \end{code} -Note [Unique OccNames from Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The idea here is to make a name that - a) the user could not possibly write (it has a "[" - and letters or digits from the unique) - b) cannot clash with another NameU -Previously I generated an Exact RdrName with mkInternalName. This -works fine for local binders, but does not work at all for top-level -binders, which must have External Names, since they are rapidly baked -into data constructors and the like. Baling out and generating an -unqualified RdrName here is the simple solution - -See also Note [Suppressing uniques in OccNames] in OccName, which -suppresses the unique when opt_SuppressUniques is on. +Note [Binders in Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this TH term construction: + do { x1 <- TH.newName "x" -- newName :: String -> Q TH.Name + ; x2 <- TH.newName "x" -- Builds a NameU + ; x3 <- TH.newName "x" + + ; let x = mkName "x" -- mkName :: String -> TH.Name + -- Builds a NameL + + ; return (LamE (..pattern [x1,x2]..) $ + LamE (VarPat x3) $ + ..tuple (x1,x2,x3,x)) } + +It represents the term \[x1,x2]. \x3. (x1,x2,x3,x) + +a) We don't want to complain about "x" being bound twice in + the pattern [x1,x2] +b) We don't want x3 to shadow the x1,x2 +c) We *do* want 'x' (dynamically bound with mkName) to bind + to the innermost binding of "x", namely x3.. (In this +d) When pretty printing, we want to print a unique with x1,x2 + etc, else they'll all print as "x" which isn't very helpful + +When we convert all this to HsSyn, the TH.Names are converted with +thRdrName. To achieve (b) we want the binders to be Exact RdrNames. +Achieving (a) is a bit awkward, because + - We must check for duplicate and shadowed names on Names, + not RdrNames, *after* renaming. + See Note [Collect binders only after renaming] in HsUtils + + - But to achieve (a) we must distinguish between the Exact + RdrNames arising from TH and the Unqual RdrNames that would + come from a user writing \[x,x] -> blah + +So in Convert (here) we translate + TH Name RdrName + -------------------------------------------------------- + NameU (arising from newName) --> Exact (Name{ System }) + NameS (arising from mkName) --> Unqual + +Notice that the NameUs generate *System* Names. Then, when +figuring out shadowing and duplicates, we can filter out +System Names. + +This use of System Names fits with other uses of System Names, eg for +temporary variables "a". Since there are lots of things called "a" we +usually want to print the name with the unique, and that is indeed +the way System Names are printed. + +There's a small complication of course. For data types and +classes we'll now have system Names in the binding positions +for constructors, TyCons etc. For example + [d| data T = MkT Int |] +when we splice in and Convert to HsSyn RdrName, we'll get + data (Exact (system Name "T")) = (Exact (system Name "MkT")) ... +So RnEnv.newGlobalBinder we spot Exact RdrNames that wrap a +non-External Name, and make an External name for. (Remember, +constructors and the like need External Names.) Oddly, the +*occurrences* will continue to be that (non-External) System Name, +but that will come out in the wash. diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 5871914ad8..52ed14b9f2 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -252,7 +252,7 @@ getTypeSigNames :: HsValBinds a -> NameSet getTypeSigNames (ValBindsIn {}) = panic "getTypeSigNames" getTypeSigNames (ValBindsOut _ sigs) - = mkNameSet [unLoc n | L _ (TypeSig n _) <- sigs] + = mkNameSet [unLoc n | L _ (TypeSig names _) <- sigs, n <- names] \end{code} What AbsBinds means @@ -595,11 +595,11 @@ type LSig name = Located (Sig name) data Sig name -- Signatures and pragmas = -- An ordinary type signature -- f :: Num a => a -> a - TypeSig (Located name) (LHsType name) + 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 - | GenericSig (Located name) (LHsType name) + | GenericSig [Located name] (LHsType name) -- A type signature in generated code, notably the code -- generated for record selectors. We simply record @@ -685,18 +685,6 @@ okInstDclSig (GenericSig _ _) = False okInstDclSig (FixSig _) = False okInstDclSig _ = True -sigName :: LSig name -> Maybe name --- Used only in Haddock -sigName (L _ sig) = sigNameNoLoc sig - -sigNameNoLoc :: Sig name -> Maybe name --- Used only in Haddock -sigNameNoLoc (TypeSig n _) = Just (unLoc n) -sigNameNoLoc (SpecSig n _ _) = Just (unLoc n) -sigNameNoLoc (InlineSig n _) = Just (unLoc n) -sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n) -sigNameNoLoc _ = Nothing - isFixityLSig :: LSig name -> Bool isFixityLSig (L _ (FixSig {})) = True isFixityLSig _ = False @@ -748,8 +736,8 @@ Signature equality is used when checking for duplicate signatures eqHsSig :: Eq a => LSig a -> LSig a -> Bool eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2 eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2 -eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2 -eqHsSig (L _ (GenericSig n1 _)) (L _ (GenericSig n2 _)) = unLoc n1 == unLoc n2 +eqHsSig (L _ (TypeSig ns1 _)) (L _ (TypeSig ns2 _)) = map unLoc ns1 == map unLoc ns2 +eqHsSig (L _ (GenericSig ns1 _)) (L _ (GenericSig ns2 _)) = map unLoc ns1 == map unLoc ns2 eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2 -- For specialisations, we don't have equality over -- HsType, so it's not convenient to spot duplicate @@ -762,9 +750,9 @@ instance (OutputableBndr name) => Outputable (Sig name) where ppr sig = ppr_sig sig ppr_sig :: OutputableBndr name => Sig name -> SDoc -ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty) -ppr_sig (GenericSig var ty) = ptext (sLit "default") <+> pprVarSig (unLoc var) (ppr ty) -ppr_sig (IdSig id) = pprVarSig id (ppr (varType id)) +ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (GenericSig vars ty) = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id)) ppr_sig (FixSig fix_sig) = ppr fix_sig ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl) ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var) @@ -776,11 +764,13 @@ instance Outputable name => Outputable (FixitySig name) where pragBrackets :: SDoc -> SDoc pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}") -pprVarSig :: (Outputable id) => id -> SDoc -> SDoc -pprVarSig var pp_ty = sep [ppr var <+> dcolon, nest 2 pp_ty] +pprVarSig :: (Outputable id) => [id] -> SDoc -> SDoc +pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] + where + pprvars = hsep $ punctuate comma (map ppr vars) pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc -pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var pp_ty +pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig [var] pp_ty where pp_inl | isDefaultInlinePragma inl = empty | otherwise = ppr inl diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index 7b4c904f81..9dbb4417ae 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -36,6 +36,7 @@ data ImportDecl name ideclName :: Located ModuleName, -- ^ Module name. ideclPkgQual :: Maybe FastString, -- ^ Package qualifier. ideclSource :: Bool, -- ^ True <=> {-# SOURCE #-} import + ideclSafe :: Bool, -- ^ True => safe import ideclQualified :: Bool, -- ^ True => qualified ideclAs :: Maybe ModuleName, -- ^ as Module ideclHiding :: Maybe (Bool, [LIE name]) -- ^ (True => hiding, names) @@ -46,6 +47,7 @@ simpleImportDecl mn = ImportDecl { ideclName = noLoc mn, ideclPkgQual = Nothing, ideclSource = False, + ideclSafe = True, ideclQualified = False, ideclAs = Nothing, ideclHiding = Nothing @@ -54,9 +56,9 @@ simpleImportDecl mn = ImportDecl { \begin{code} instance (Outputable name) => Outputable (ImportDecl name) where - ppr (ImportDecl mod pkg from qual as spec) - = hang (hsep [ptext (sLit "import"), ppr_imp from, - pp_qual qual, pp_pkg pkg, ppr mod, pp_as as]) + ppr (ImportDecl mod' pkg from safe qual as spec) + = hang (hsep [ptext (sLit "import"), ppr_imp from, pp_safe safe, + pp_qual qual, pp_pkg pkg, ppr mod', pp_as as]) 4 (pp_spec spec) where pp_pkg Nothing = empty @@ -65,6 +67,9 @@ instance (Outputable name) => Outputable (ImportDecl name) where pp_qual False = empty pp_qual True = ptext (sLit "qualified") + pp_safe False = empty + pp_safe True = ptext (sLit "safe") + pp_as Nothing = empty pp_as (Just a) = ptext (sLit "as") <+> ppr a diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 7dbb16df64..d565c96d29 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -26,6 +26,7 @@ module HsTypes ( hsTyVarKind, hsTyVarNameKind, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, splitHsInstDeclTy, splitHsFunType, + splitHsAppTys, mkHsAppTys, -- Type place holder PostTcType, placeHolderType, PostTcKind, placeHolderKind, @@ -292,6 +293,19 @@ replaceTyVarName (KindedTyVar _ k) n' = KindedTyVar n' k \begin{code} +splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n]) +splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as) +splitHsAppTys f as = (f,as) + +mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n +mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty) +mkHsAppTys fun_ty (arg_ty:arg_tys) + = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys + where + mk_app fun arg = HsAppTy (noLoc fun) arg + -- Add noLocs for inner nodes of the application; + -- they are never used + splitHsInstDeclTy :: OutputableBndr name => HsType name diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index cc57e05441..6ddbd99bd4 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -606,7 +606,7 @@ hsTyClDeclBinders (L _ (ForeignType {tcdLName = name})) = [name] hsTyClDeclBinders (L _ (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})) = cls_name : - concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig n _) <- sigs] + concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns] hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons})) = tc_name : hsConDeclsBinders cons diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 502eefa578..0fab2d28c8 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -390,7 +390,8 @@ instance Binary ModIface where mi_rules = rules, mi_orphan_hash = orphan_hash, mi_vect_info = vect_info, - mi_hpc = hpc_info }) = do + mi_hpc = hpc_info, + mi_trust = trust }) = do put_ bh mod put_ bh is_boot put_ bh iface_hash @@ -411,6 +412,7 @@ instance Binary ModIface where put_ bh orphan_hash put_ bh vect_info put_ bh hpc_info + put_ bh trust get bh = do mod_name <- get bh @@ -433,6 +435,7 @@ instance Binary ModIface where orphan_hash <- get bh vect_info <- get bh hpc_info <- get bh + trust <- get bh return (ModIface { mi_module = mod_name, mi_boot = is_boot, @@ -455,6 +458,7 @@ instance Binary ModIface where mi_orphan_hash = orphan_hash, mi_vect_info = vect_info, mi_hpc = hpc_info, + mi_trust = trust, -- And build the cached values mi_warn_fn = mkIfaceWarnCache warns, mi_fix_fn = mkIfaceFixCache fixities, @@ -507,12 +511,14 @@ instance Binary Usage where putByte bh 0 put_ bh (usg_mod usg) put_ bh (usg_mod_hash usg) + put_ bh (usg_safe usg) put_ bh usg@UsageHomeModule{} = do putByte bh 1 put_ bh (usg_mod_name usg) put_ bh (usg_mod_hash usg) put_ bh (usg_exports usg) put_ bh (usg_entities usg) + put_ bh (usg_safe usg) get bh = do h <- getByte bh @@ -520,14 +526,16 @@ instance Binary Usage where 0 -> do nm <- get bh mod <- get bh - return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod } + safe <- get bh + return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } _ -> do nm <- get bh mod <- get bh exps <- get bh ents <- get bh + safe <- get bh return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, - usg_exports = exps, usg_entities = ents } + usg_exports = exps, usg_entities = ents, usg_safe = safe } instance Binary Warnings where put_ bh NoWarnings = putByte bh 0 @@ -1399,14 +1407,15 @@ instance Binary IfaceFamInst where return (IfaceFamInst fam tys tycon) instance Binary OverlapFlag where - put_ bh NoOverlap = putByte bh 0 - put_ bh OverlapOk = putByte bh 1 - put_ bh Incoherent = putByte bh 2 + put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b + put_ bh (OverlapOk b) = putByte bh 1 >> put_ bh b + put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b get bh = do h <- getByte bh + b <- get bh case h of - 0 -> return NoOverlap - 1 -> return OverlapOk - 2 -> return Incoherent + 0 -> return $ NoOverlap b + 1 -> return $ OverlapOk b + 2 -> return $ Incoherent b _ -> panic ("get OverlapFlag " ++ show h) instance Binary IfaceConDecls where @@ -1522,4 +1531,7 @@ instance Binary IfaceVectInfo where a5 <- get bh return (IfaceVectInfo a1 a2 a3 a4 a5) +instance Binary IfaceTrustInfo where + put_ bh iftrust = putByte bh $ trustInfoToNum iftrust + get bh = getByte bh >>= (return . numToTrustInfo) diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index 0e30f31280..36024ebb91 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -13,7 +13,7 @@ module IfaceEnv ( ifaceExportNames, -- Name-cache stuff - allocateGlobalBinder, initNameCache, + allocateGlobalBinder, initNameCache, updNameCache, getNameCache, mkNameCacheUpdater, NameCacheUpdater ) where diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 49fded9a59..21783813f8 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -341,7 +341,7 @@ and suppose we are compiling module X: data T = ... instance C S T where ... -If we base the instance verion on T, I'm worried that changing S to S' +If we base the instance version on T, I'm worried that changing S to S' would change T's version, but not S or S'. But an importing module might not depend on T, and so might not be recompiled even though the new instance (C S' T) might be relevant. I have not been able to make a concrete example, diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 97acc5226a..daa0bb0284 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -666,7 +666,9 @@ pprModIface iface , vcat (map ppr (mi_fam_insts iface)) , vcat (map ppr (mi_rules iface)) , pprVectInfo (mi_vect_info iface) + , pprVectInfo (mi_vect_info iface) , ppr (mi_warns iface) + , pprTrustInfo (mi_trust iface) ] where pp_boot | mi_boot iface = ptext (sLit "[boot]") @@ -695,26 +697,34 @@ pprExport (mod, items) pprUsage :: Usage -> SDoc pprUsage usage@UsagePackageModule{} - = hsep [ptext (sLit "import"), ppr (usg_mod usage), - ppr (usg_mod_hash usage)] + = pprUsageImport usage usg_mod pprUsage usage@UsageHomeModule{} - = hsep [ptext (sLit "import"), ppr (usg_mod_name usage), - ppr (usg_mod_hash usage)] $$ + = pprUsageImport usage usg_mod_name $$ nest 2 ( maybe empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$ vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ] ) +pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc +pprUsageImport usage usg_mod' + = hsep [ptext (sLit "import"), safe, ppr (usg_mod' usage), + ppr (usg_mod_hash usage)] + where + safe | usg_safe usage = ptext $ sLit "safe" + | otherwise = ptext $ sLit " -/ " + pprDeps :: Dependencies -> SDoc pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, dep_finsts = finsts }) = vcat [ptext (sLit "module dependencies:") <+> fsep (map ppr_mod mods), - ptext (sLit "package dependencies:") <+> fsep (map ppr pkgs), + ptext (sLit "package dependencies:") <+> fsep (map ppr_pkg pkgs), ptext (sLit "orphans:") <+> fsep (map ppr orphs), ptext (sLit "family instance modules:") <+> fsep (map ppr finsts) ] where ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot + ppr_pkg (pkg,trust_req) = ppr pkg <> + (if trust_req then text "*" else empty) ppr_boot True = text "[boot]" ppr_boot False = empty @@ -743,6 +753,9 @@ pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars , ptext (sLit "scalar tycons:") <+> hsep (map ppr scalarTyCons) ] +pprTrustInfo :: IfaceTrustInfo -> SDoc +pprTrustInfo trust = ptext (sLit "trusted:") <+> ppr trust + instance Outputable Warnings where ppr = pprWarns diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 0bce56bd14..2ec14e48cb 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -106,24 +106,24 @@ import System.FilePath %************************************************************************ -%* * +%* * \subsection{Completing an interface} -%* * +%* * %************************************************************************ \begin{code} mkIface :: HscEnv - -> Maybe Fingerprint -- The old fingerprint, if we have it - -> ModDetails -- The trimmed, tidied interface - -> ModGuts -- Usages, deprecations, etc - -> IO (Messages, + -> Maybe Fingerprint -- The old fingerprint, if we have it + -> ModDetails -- The trimmed, tidied interface + -> ModGuts -- Usages, deprecations, etc + -> IO (Messages, Maybe (ModIface, -- The new one - Bool)) -- True <=> there was an old Iface, and the + Bool)) -- True <=> there was an old Iface, and the -- new one is identical, so no need -- to write it mkIface hsc_env maybe_old_fingerprint mod_details - ModGuts{ mg_module = this_mod, + ModGuts{ mg_module = this_mod, mg_boot = is_boot, mg_used_names = used_names, mg_deps = deps, @@ -185,8 +185,13 @@ mkDependencies pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports) | otherwise = imp_dep_pkgs imports + -- add in safe haskell 'package needs to be safe' bool + sorted_pkgs = sortBy stablePackageIdCmp pkgs + trust_pkgs = imp_trust_pkgs imports + dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs + return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods, - dep_pkgs = sortBy stablePackageIdCmp pkgs, + dep_pkgs = dep_pkgs', dep_orphs = sortBy stableModuleCmp (imp_orphs imports), dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } -- sort to get into canonical order @@ -232,6 +237,7 @@ mkIface_ hsc_env maybe_old_fingerprint ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts ; iface_vect_info = flattenVectInfo vect_info + ; trust_info = (setSafeMode . safeHaskell) dflags ; intermediate_iface = ModIface { mi_module = this_mod, @@ -264,6 +270,7 @@ mkIface_ hsc_env maybe_old_fingerprint mi_decls = deliberatelyOmitted "decls", mi_hash_fn = deliberatelyOmitted "hash_fn", mi_hpc = isHpcUsed hpc_info, + mi_trust = trust_info, -- And build the cached values mi_warn_fn = mkIfaceWarnCache warns, @@ -296,8 +303,6 @@ mkIface_ hsc_env maybe_old_fingerprint then return ( errs_and_warns, Nothing ) else do { --- XXX ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs) - -- Debug printing ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" (pprModIface new_iface) @@ -518,9 +523,13 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls (mi_exports iface0, orphan_hash, dep_orphan_hashes, - dep_pkgs (mi_deps iface0)) + dep_pkgs (mi_deps iface0), -- dep_pkgs: see "Package Version Changes" on -- wiki/Commentary/Compiler/RecompilationAvoidance + mi_trust iface0) + -- TODO: Can probably make more fine grained. Only + -- really need to have recompilation for overlapping + -- instances. -- put the declarations in a canonical order, sorted by OccName let sorted_decls = Map.elems $ Map.fromList $ @@ -594,7 +603,7 @@ getOrphanHashes hsc_env mods = do sortDependencies :: Dependencies -> Dependencies sortDependencies d = Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d), - dep_pkgs = sortBy (compare `on` packageIdFS) (dep_pkgs d), + dep_pkgs = sortBy (stablePackageIdCmp `on` fst) (dep_pkgs d), dep_orphs = sortBy stableModuleCmp (dep_orphs d), dep_finsts = sortBy stableModuleCmp (dep_finsts d) } \end{code} @@ -871,7 +880,8 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names | modulePackageId mod /= this_pkg = Just UsagePackageModule{ usg_mod = mod, - usg_mod_hash = mod_hash } + usg_mod_hash = mod_hash, + usg_safe = imp_safe } -- for package modules, we record the module hash only | (null used_occs @@ -886,22 +896,29 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names | otherwise = Just UsageHomeModule { usg_mod_name = moduleName mod, - usg_mod_hash = mod_hash, - usg_exports = export_hash, - usg_entities = Map.toList ent_hashs } + usg_mod_hash = mod_hash, + usg_exports = export_hash, + usg_entities = Map.toList ent_hashs, + usg_safe = imp_safe } where - maybe_iface = lookupIfaceByModule dflags hpt pit mod - -- In one-shot mode, the interfaces for home-package - -- modules accumulate in the PIT not HPT. Sigh. - - is_direct_import = mod `elemModuleEnv` direct_imports + maybe_iface = lookupIfaceByModule dflags hpt pit mod + -- In one-shot mode, the interfaces for home-package + -- modules accumulate in the PIT not HPT. Sigh. Just iface = maybe_iface finsts_mod = mi_finsts iface hash_env = mi_hash_fn iface mod_hash = mi_mod_hash iface export_hash | depend_on_exports = Just (mi_exp_hash iface) - | otherwise = Nothing + | otherwise = Nothing + + (is_direct_import, imp_safe) + = case lookupModuleEnv direct_imports mod of + Just ((_,_,_,safe):_xs) -> (True, safe) + Just _ -> pprPanic "mkUsage: empty direct import" empty + Nothing -> (False, safeImplicitImpsReq dflags) + -- Nothing case is for implicit imports like 'System.IO' when 'putStrLn' + -- is used in the source code. We require them to be safe in SafeHaskell used_occs = lookupModuleEnv ent_map mod `orElse` [] @@ -1029,53 +1046,50 @@ checkOldIface :: HscEnv -> IO (RecompileRequired, Maybe ModIface) checkOldIface hsc_env mod_summary source_unchanged maybe_iface - = do { showPass (hsc_dflags hsc_env) - ("Checking old interface for " ++ - showSDoc (ppr (ms_mod mod_summary))) ; - - ; initIfaceCheck hsc_env $ - check_old_iface hsc_env mod_summary source_unchanged maybe_iface - } + = do showPass (hsc_dflags hsc_env) $ + "Checking old interface for " ++ (showSDoc $ ppr $ ms_mod mod_summary) + initIfaceCheck hsc_env $ + check_old_iface hsc_env mod_summary source_unchanged maybe_iface check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface -> IfG (Bool, Maybe ModIface) -check_old_iface hsc_env mod_summary source_unchanged maybe_iface - = do -- CHECK WHETHER THE SOURCE HAS CHANGED - { when (not source_unchanged) - (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) - - -- If the source has changed and we're in interactive mode, avoid reading - -- an interface; just return the one we might have been supplied with. - ; let dflags = hsc_dflags hsc_env - ; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then - return (outOfDate, maybe_iface) - else - case maybe_iface of { - Just old_iface -> do -- Use the one we already have - { traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary)) - ; recomp <- checkVersions hsc_env source_unchanged mod_summary old_iface - ; return (recomp, Just old_iface) } - - ; Nothing -> do - - -- Try and read the old interface for the current module - -- from the .hi file left from the last time we compiled it - { let iface_path = msHiFilePath mod_summary - ; read_result <- readIface (ms_mod mod_summary) iface_path False - ; case read_result of { - Failed err -> do -- Old interface file not found, or garbled; give up - { traceIf (text "FYI: cannot read old interface file:" - $$ nest 4 err) - ; return (outOfDate, Nothing) } - - ; Succeeded iface -> do - - -- We have got the old iface; check its versions - { traceIf (text "Read the interface file" <+> text iface_path) - ; recomp <- checkVersions hsc_env source_unchanged mod_summary iface - ; return (recomp, Just iface) - }}}}} - +check_old_iface hsc_env mod_summary src_unchanged maybe_iface + = let src_changed = not src_unchanged + dflags = hsc_dflags hsc_env + getIface = + case maybe_iface of + Just _ -> do + traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary)) + return maybe_iface + Nothing -> do + let iface_path = msHiFilePath mod_summary + read_result <- readIface (ms_mod mod_summary) iface_path False + case read_result of + Failed err -> do + traceIf (text "FYI: cannont read old interface file:" $$ nest 4 err) + return Nothing + Succeeded iface -> do + traceIf (text "Read the interface file" <+> text iface_path) + return $ Just iface + + in do + when src_changed + (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) + + -- If the source has changed and we're in interactive mode, avoid reading + -- an interface; just return the one we might have been supplied with. + if not (isObjectTarget $ hscTarget dflags) && src_changed + then return (outOfDate, maybe_iface) + else do + -- Try and read the old interface for the current module + -- from the .hi file left from the last time we compiled it + maybe_iface' <- getIface + case maybe_iface' of + Nothing -> return (outOfDate, maybe_iface') + Just iface -> do + -- We have got the old iface; check its versions + recomp <- checkVersions hsc_env src_unchanged mod_summary iface + return recomp \end{code} @recompileRequired@ is called from the HscMain. It checks whether @@ -1089,41 +1103,51 @@ upToDate, outOfDate :: Bool upToDate = False -- Recompile not required outOfDate = True -- Recompile required +-- | Check the safe haskell flags haven't changed +-- (e.g different flag on command line now) +safeHsChanged :: HscEnv -> ModIface -> Bool +safeHsChanged hsc_env iface + = (getSafeMode $ mi_trust iface) /= (safeHaskell $ hsc_dflags hsc_env) + checkVersions :: HscEnv -> Bool -- True <=> source unchanged -> ModSummary -> ModIface -- Old interface - -> IfG RecompileRequired + -> IfG (RecompileRequired, Maybe ModIface) checkVersions hsc_env source_unchanged mod_summary iface | not source_unchanged - = return outOfDate + = let iface' = if safeHsChanged hsc_env iface then Nothing else Just iface + in return (outOfDate, iface') + | otherwise - = do { traceHiDiffs (text "Considering whether compilation is required for" <+> - ppr (mi_module iface) <> colon) - - ; recomp <- checkDependencies hsc_env mod_summary iface - ; if recomp then return outOfDate else do { - - -- Source code unchanged and no errors yet... carry on - -- - -- First put the dependent-module info, read from the old - -- interface, into the envt, so that when we look for - -- interfaces we look for the right one (.hi or .hi-boot) - -- - -- It's just temporary because either the usage check will succeed - -- (in which case we are done with this module) or it'll fail (in which - -- case we'll compile the module from scratch anyhow). - -- - -- We do this regardless of compilation mode, although in --make mode - -- all the dependent modules should be in the HPT already, so it's - -- quite redundant - updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } - - ; let this_pkg = thisPackage (hsc_dflags hsc_env) - ; checkList [checkModUsage this_pkg u | u <- mi_usages iface] - }} + = do { traceHiDiffs (text "Considering whether compilation is required for" <+> + ppr (mi_module iface) <> colon) + + ; recomp <- checkDependencies hsc_env mod_summary iface + ; if recomp then return (outOfDate, Just iface) else do { + ; if trust_dif then return (outOfDate, Nothing) else do { + + -- Source code unchanged and no errors yet... carry on + -- + -- First put the dependent-module info, read from the old + -- interface, into the envt, so that when we look for + -- interfaces we look for the right one (.hi or .hi-boot) + -- + -- It's just temporary because either the usage check will succeed + -- (in which case we are done with this module) or it'll fail (in which + -- case we'll compile the module from scratch anyhow). + -- + -- We do this regardless of compilation mode, although in --make mode + -- all the dependent modules should be in the HPT already, so it's + -- quite redundant + ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } + ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface] + ; return (recomp, Just iface) + }}} where - -- This is a bit of a hack really + this_pkg = thisPackage (hsc_dflags hsc_env) + trust_dif = safeHsChanged hsc_env iface + -- This is a bit of a hack really mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface) mod_deps = mkModDeps (dep_mods (mi_deps iface)) @@ -1150,7 +1174,7 @@ checkDependencies hsc_env summary iface orM = foldr f (return False) where f m rest = do b <- m; if b then return True else rest - dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _)) = do + dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _ _)) = do find_res <- liftIO $ findImportedModule hsc_env mod pkg case find_res of Found _ mod @@ -1163,7 +1187,7 @@ checkDependencies hsc_env summary iface else return upToDate | otherwise - -> if pkg `notElem` prev_dep_pkgs + -> if pkg `notElem` (map fst prev_dep_pkgs) then do traceHiDiffs $ text "imported module " <> quotes (ppr mod) <> text " is from package " <> quotes (ppr pkg) <> diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 5bfb406c02..ab28615c80 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -265,10 +265,10 @@ typecheckIface iface ; writeMutVar tc_env_var type_env -- Now do those rules, instances and annotations - ; insts <- mapM tcIfaceInst (mi_insts iface) + ; insts <- mapM tcIfaceInst (mi_insts iface) ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; rules <- tcIfaceRules ignore_prags (mi_rules iface) - ; anns <- tcIfaceAnnotations (mi_anns iface) + ; anns <- tcIfaceAnnotations (mi_anns iface) -- Vectorisation information ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env @@ -590,11 +590,11 @@ look at it. \begin{code} tcIfaceInst :: IfaceInst -> IfL Instance tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, - ifInstCls = cls, ifInstTys = mb_tcs }) - = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $ - tcIfaceExtId dfun_occ - ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs - ; return (mkImportedInstance cls mb_tcs' dfun oflag) } + ifInstCls = cls, ifInstTys = mb_tcs }) + = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $ + tcIfaceExtId dfun_occ + ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedInstance cls mb_tcs' dfun oflag) } tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, diff --git a/compiler/iface/TcIface.lhs-boot b/compiler/iface/TcIface.lhs-boot index c8ad717918..a9684a6a91 100644 --- a/compiler/iface/TcIface.lhs-boot +++ b/compiler/iface/TcIface.lhs-boot @@ -1,20 +1,21 @@ \begin{code} module TcIface where -import IfaceSyn ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule, IfaceAnnotation ) -import TypeRep ( TyThing ) -import TcRnTypes ( IfL ) -import InstEnv ( Instance ) -import FamInstEnv ( FamInst ) -import CoreSyn ( CoreRule ) -import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo ) -import Module ( Module ) + +import IfaceSyn ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule, IfaceAnnotation ) +import TypeRep ( TyThing ) +import TcRnTypes ( IfL ) +import InstEnv ( Instance ) +import FamInstEnv ( FamInst ) +import CoreSyn ( CoreRule ) +import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo ) +import Module ( Module ) import Annotations ( Annotation ) -tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing -tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] -tcIfaceVectInfo:: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo -tcIfaceInst :: IfaceInst -> IfL Instance -tcIfaceFamInst :: IfaceFamInst -> IfL FamInst +tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing +tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] +tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo +tcIfaceInst :: IfaceInst -> IfL Instance +tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] \end{code} diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index c55da14b16..eb002742e1 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -147,7 +147,7 @@ stmtToInstrs env stmt = case stmt of -- | Foreign Calls -genCall :: LlvmEnv -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals +genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual] -> CmmReturnInfo -> UniqSM StmtData -- Write barrier needs to be handled specially as it is implemented as an LLVM @@ -347,7 +347,7 @@ getFunPtr env funTy targ = case targ of -- | Conversion of call arguments. arg_vars :: LlvmEnv - -> HintedCmmActuals + -> [HintedCmmActual] -> ([LlvmVar], LlvmStatements, [LlvmCmmTop]) -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmTop]) diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index 372bd3507e..3ff75e1043 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -12,8 +12,8 @@ module CmdLineParser ( processArgs, OptKind(..), CmdLineP(..), getCmdLineState, putCmdLineState, - Flag(..), - errorsToGhcException, + Flag(..), FlagSafety(..), flagA, flagR, flagC, flagN, + errorsToGhcException, determineSafeLevel, EwM, addErr, addWarn, getArg, liftEwM, deprecate ) where @@ -34,9 +34,36 @@ import Data.List data Flag m = Flag { flagName :: String, -- Flag, without the leading "-" + flagSafety :: FlagSafety, -- Flag safety level (SafeHaskell) flagOptKind :: OptKind m -- What to do if we see it } +-- | This determines how a flag should behave when SafeHaskell +-- mode is on. +data FlagSafety + = EnablesSafe -- ^ This flag is a little bit of a hack. We give + -- the safe haskell flags (-XSafe and -XSafeLanguage) + -- this safety type so we can easily detect when safe + -- haskell mode has been enable in a module pragma + -- as this changes how the rest of the parsing should + -- happen. + + | AlwaysAllowed -- ^ Flag is always allowed + | RestrictedFunction -- ^ Flag is allowed but functions in a reduced way + | CmdLineOnly -- ^ Flag is only allowed on command line, not in pragma + | NeverAllowed -- ^ Flag isn't allowed at all + deriving ( Eq, Ord ) + +determineSafeLevel :: Bool -> FlagSafety +determineSafeLevel False = RestrictedFunction +determineSafeLevel True = CmdLineOnly + +flagA, flagR, flagC, flagN :: String -> OptKind m -> Flag m +flagA n o = Flag n AlwaysAllowed o +flagR n o = Flag n RestrictedFunction o +flagC n o = Flag n CmdLineOnly o +flagN n o = Flag n NeverAllowed o + ------------------------------- data OptKind m -- Suppose the flag is -f = NoArg (EwM m ()) -- -f all by itself @@ -64,22 +91,32 @@ type Warns = Bag Warn -- EwM (short for "errors and warnings monad") is a -- monad transformer for m that adds an (err, warn) state newtype EwM m a = EwM { unEwM :: Located String -- Current arg + -> FlagSafety -- arg safety level + -> FlagSafety -- global safety level -> Errs -> Warns -> m (Errs, Warns, a) } instance Monad m => Monad (EwM m) where - (EwM f) >>= k = EwM (\l e w -> do { (e', w', r) <- f l e w - ; unEwM (k r) l e' w' }) - return v = EwM (\_ e w -> return (e, w, v)) - -setArg :: Located String -> EwM m a -> EwM m a -setArg l (EwM f) = EwM (\_ es ws -> f l es ws) + (EwM f) >>= k = EwM (\l s c e w -> do { (e', w', r) <- f l s c e w + ; unEwM (k r) l s c e' w' }) + return v = EwM (\_ _ _ e w -> return (e, w, v)) + +setArg :: Monad m => Located String -> FlagSafety -> EwM m () -> EwM m () +setArg l s (EwM f) = EwM (\_ _ c es ws -> + let check | s <= c = f l s c es ws + | otherwise = err l es ws + err (L loc ('-' : arg)) es ws = + let msg = "Warning: " ++ arg ++ " is not allowed in " + ++ "SafeHaskell; ignoring " ++ arg + in return (es, ws `snocBag` L loc msg, ()) + err _ _ _ = error "Bad pattern match in setArg" + in check) addErr :: Monad m => String -> EwM m () -addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ())) +addErr e = EwM (\(L loc _) _ _ es ws -> return (es `snocBag` L loc e, ws, ())) addWarn :: Monad m => String -> EwM m () -addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc w, ())) +addWarn msg = EwM (\(L loc _) _ _ es ws -> return (es, ws `snocBag` L loc w, ())) where w = "Warning: " ++ msg @@ -89,10 +126,10 @@ deprecate s ; addWarn (arg ++ " is deprecated: " ++ s) } getArg :: Monad m => EwM m String -getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) +getArg = EwM (\(L _ arg) _ _ es ws -> return (es, ws, arg)) liftEwM :: Monad m => m a -> EwM m a -liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) +liftEwM action = EwM (\_ _ _ es ws -> do { r <- action; return (es, ws, r) }) -- ----------------------------------------------------------------------------- -- A state monad for use in the command-line parser @@ -119,31 +156,41 @@ putCmdLineState s = CmdLineP $ \_ -> ((),s) processArgs :: Monad m => [Flag m] -- cmdline parser spec -> [Located String] -- args + -> FlagSafety -- flag clearance lvl + -> Bool -> m ( [Located String], -- spare args [Located String], -- errors [Located String] -- warnings ) -processArgs spec args - = do { (errs, warns, spare) <- unEwM (process args []) - (panic "processArgs: no arg yet") - emptyBag emptyBag - ; return (spare, bagToList errs, bagToList warns) } +processArgs spec args clvl0 cmdline + = let (clvl1, action) = process clvl0 args [] + in do { (errs, warns, spare) <- unEwM action (panic "processArgs: no arg yet") + AlwaysAllowed clvl1 emptyBag emptyBag + ; return (spare, bagToList errs, bagToList warns) } where - -- process :: [Located String] -> [Located String] -> EwM m [Located String] - process [] spare = return (reverse spare) + -- process :: FlagSafety -> [Located String] -> [Located String] -> (FlagSafety, EwM m [Located String]) + -- + process clvl [] spare = (clvl, return (reverse spare)) - process (locArg@(L _ ('-' : arg)) : args) spare = + process clvl (locArg@(L _ ('-' : arg)) : args) spare = case findArg spec arg of - Just (rest, opt_kind) -> - case processOneArg opt_kind rest arg args of - Left err -> do { setArg locArg $ addErr err - ; process args spare } - Right (action,rest) -> do { setArg locArg $ action - ; process rest spare } - Nothing -> process args (locArg : spare) + Just (rest, opt_kind, fsafe) -> + let clvl1 = if fsafe == EnablesSafe then determineSafeLevel cmdline else clvl + in case processOneArg opt_kind rest arg args of + Left err -> + let (clvl2,b) = process clvl1 args spare + clvl3 = min clvl1 clvl2 + in (clvl3, (setArg locArg fsafe $ addErr err) >> b) + + Right (action,rest) -> + let (clvl2,b) = process clvl1 rest spare + clvl3 = min clvl1 clvl2 + in (clvl3, (setArg locArg fsafe $ action) >> b) + + Nothing -> process clvl args (locArg : spare) - process (arg : args) spare = process args (arg : spare) + process clvl (arg : args) spare = process clvl args (arg : spare) processOneArg :: OptKind m -> String -> String -> [Located String] @@ -184,11 +231,12 @@ processOneArg opt_kind rest arg args AnySuffixPred _ f -> Right (f dash_arg, args) -findArg :: [Flag m] -> String -> Maybe (String, OptKind m) +findArg :: [Flag m] -> String -> Maybe (String, OptKind m, FlagSafety) findArg spec arg - = case [ (removeSpaces rest, optKind) + = case [ (removeSpaces rest, optKind, flagSafe) | flag <- spec, - let optKind = flagOptKind flag, + let optKind = flagOptKind flag, + let flagSafe = flagSafety flag, Just rest <- [stripPrefix (flagName flag) arg], arg_ok optKind rest arg ] of diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index afbd03e2c7..c7bc823823 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -299,7 +299,7 @@ link' dflags batch_attempt_linking hpt home_mod_infos = eltsUFM hpt -- the packages we depend on - pkg_deps = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos + pkg_deps = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos -- the linkables to link linkables = map (expectJust "link".hm_linkable) home_mod_infos @@ -754,7 +754,7 @@ runPhase (Cpp sf) input_fn dflags0 = do src_opts <- io $ getOptionsFromFile dflags0 input_fn (dflags1, unhandled_flags, warns) - <- io $ parseDynamicNoPackageFlags dflags0 src_opts + <- io $ parseDynamicFilePragma dflags0 src_opts setDynFlags dflags1 io $ checkProcessArgsResult unhandled_flags @@ -772,7 +772,7 @@ runPhase (Cpp sf) input_fn dflags0 -- See #2464,#3457 src_opts <- io $ getOptionsFromFile dflags0 output_fn (dflags2, unhandled_flags, warns) - <- io $ parseDynamicNoPackageFlags dflags0 src_opts + <- io $ parseDynamicFilePragma dflags0 src_opts io $ checkProcessArgsResult unhandled_flags unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns -- the HsPp pass below will emit warnings @@ -806,7 +806,7 @@ runPhase (HsPp sf) input_fn dflags -- re-read pragmas now that we've parsed the file (see #3674) src_opts <- io $ getOptionsFromFile dflags output_fn (dflags1, unhandled_flags, warns) - <- io $ parseDynamicNoPackageFlags dflags src_opts + <- io $ parseDynamicFilePragma dflags src_opts setDynFlags dflags1 io $ checkProcessArgsResult unhandled_flags io $ handleFlagWarnings dflags1 warns diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index b49b860a9b..fb2bd4f42e 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -32,6 +32,11 @@ module DynFlags ( DPHBackend(..), dphPackageMaybe, wayNames, + -- ** SafeHaskell + SafeHaskellMode(..), + safeHaskellOn, safeLanguageOn, + safeDirectImpsReq, safeImplicitImpsReq, + Settings(..), ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, extraGccViaCFlags, systemPackageConfig, @@ -53,8 +58,8 @@ module DynFlags ( doingTickyProfiling, -- ** Parsing DynFlags - parseDynamicFlags, - parseDynamicNoPackageFlags, + parseDynamicFlagsCmdLine, + parseDynamicFilePragma, allFlags, supportedLanguagesAndExtensions, @@ -163,6 +168,7 @@ data DynFlag | Opt_D_dump_occur_anal | Opt_D_dump_parsed | Opt_D_dump_rn + | Opt_D_dump_core_pipeline -- TODO FIXME: dump after simplifier stats | Opt_D_dump_simpl | Opt_D_dump_simpl_iterations | Opt_D_dump_simpl_phases @@ -281,6 +287,7 @@ data DynFlag | Opt_SplitObjs | Opt_StgStats | Opt_HideAllPackages + | Opt_DistrustAllPackages | Opt_PrintBindResult | Opt_Haddock | Opt_HaddockOptions @@ -318,6 +325,24 @@ data DynFlag data Language = Haskell98 | Haskell2010 +-- | The various SafeHaskell modes +data SafeHaskellMode + = Sf_None + | Sf_SafeImports + | Sf_SafeLanguage + | Sf_Trustworthy + | Sf_TrustworthyWithSafeLanguage + | Sf_Safe + deriving (Eq) + +instance Outputable SafeHaskellMode where + ppr Sf_None = ptext $ sLit "None" + ppr Sf_SafeImports = ptext $ sLit "SafeImports" + ppr Sf_SafeLanguage = ptext $ sLit "SafeLanguage" + ppr Sf_Trustworthy = ptext $ sLit "Trustworthy" + ppr Sf_TrustworthyWithSafeLanguage = ptext $ sLit "Trustworthy + SafeLanguage" + ppr Sf_Safe = ptext $ sLit "Safe" + data ExtensionFlag = Opt_Cpp | Opt_OverlappingInstances @@ -469,6 +494,10 @@ data DynFlags = DynFlags { hpcDir :: String, -- ^ Path to store the .mix files + -- Plugins + pluginModNames :: [ModuleName], + pluginModNameOpts :: [(ModuleName,String)], + settings :: Settings, -- For ghc -M @@ -506,6 +535,8 @@ data DynFlags = DynFlags { flags :: [DynFlag], -- Don't change this without updating extensionFlags: language :: Maybe Language, + -- | Safe Haskell mode + safeHaskell :: SafeHaskellMode, -- Don't change this without updating extensionFlags: extensions :: [OnOff ExtensionFlag], -- extensionFlags should always be equal to @@ -704,10 +735,12 @@ doingTickyProfiling _ = opt_Ticky -- static. If the way flags were made dynamic, we could fix this. data PackageFlag - = ExposePackage String + = ExposePackage String | ExposePackageId String - | HidePackage String - | IgnorePackage String + | HidePackage String + | IgnorePackage String + | TrustPackage String + | DistrustPackage String deriving Eq defaultHscTarget :: HscTarget @@ -788,6 +821,9 @@ defaultDynFlags mySettings = hcSuf = phaseInputExt HCc, hiSuf = "hi", + pluginModNames = [], + pluginModNameOpts = [], + outputFile = Nothing, outputHi = Nothing, dynLibLoader = SystemDependent, @@ -823,6 +859,7 @@ defaultDynFlags mySettings = haddockOptions = Nothing, flags = defaultFlags, language = Nothing, + safeHaskell = Sf_None, extensions = [], extensionFlags = flattenExtensionFlags Nothing [], @@ -932,6 +969,7 @@ xopt_unset dfs f in dfs { extensions = onoffs, extensionFlags = flattenExtensionFlags (language dfs) onoffs } +-- | Set the Haskell language standard to use setLanguage :: Language -> DynP () setLanguage l = upd f where f dfs = let mLang = Just l @@ -941,6 +979,69 @@ setLanguage l = upd f extensionFlags = flattenExtensionFlags mLang oneoffs } +safeLanguageOn :: DynFlags -> Bool +safeLanguageOn dflags = s == Sf_SafeLanguage + || s == Sf_TrustworthyWithSafeLanguage + || s == Sf_Safe + where s = safeHaskell dflags + +-- | Test if SafeHaskell is on in some form +safeHaskellOn :: DynFlags -> Bool +safeHaskellOn dflags = safeHaskell dflags /= Sf_None + +-- | Set a 'SafeHaskell' flag +setSafeHaskell :: SafeHaskellMode -> DynP () +setSafeHaskell s = updM f + where f dfs = do + let sf = safeHaskell dfs + safeM <- combineSafeFlags sf s + return $ dfs { safeHaskell = safeM } + +-- | Are all direct imports required to be safe for this SafeHaskell mode? +-- Direct imports are when the code explicitly imports a module +safeDirectImpsReq :: DynFlags -> Bool +safeDirectImpsReq = safeLanguageOn + +-- | Are all implicit imports required to be safe for this SafeHaskell mode? +-- Implicit imports are things in the prelude. e.g System.IO when print is used. +safeImplicitImpsReq :: DynFlags -> Bool +safeImplicitImpsReq = safeLanguageOn + +-- | Combine two SafeHaskell modes correctly. Used for dealing with multiple flags. +-- This makes SafeHaskell very much a monoid but for now I prefer this as I don't +-- want to export this functionality from the module but do want to export the +-- type constructors. +combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode +combineSafeFlags a b = + case (a,b) of + (Sf_None, sf) -> return sf + (sf, Sf_None) -> return sf + + (Sf_SafeImports, sf) -> return sf + (sf, Sf_SafeImports) -> return sf + + (Sf_SafeLanguage, Sf_Safe) -> err + (Sf_Safe, Sf_SafeLanguage) -> err + + (Sf_SafeLanguage, Sf_Trustworthy) -> return Sf_TrustworthyWithSafeLanguage + (Sf_Trustworthy, Sf_SafeLanguage) -> return Sf_TrustworthyWithSafeLanguage + + (Sf_TrustworthyWithSafeLanguage, Sf_Trustworthy) -> return Sf_TrustworthyWithSafeLanguage + (Sf_TrustworthyWithSafeLanguage, Sf_SafeLanguage) -> return Sf_TrustworthyWithSafeLanguage + (Sf_Trustworthy, Sf_TrustworthyWithSafeLanguage) -> return Sf_TrustworthyWithSafeLanguage + (Sf_SafeLanguage, Sf_TrustworthyWithSafeLanguage) -> return Sf_TrustworthyWithSafeLanguage + + (Sf_Trustworthy, Sf_Safe) -> err + (Sf_Safe, Sf_Trustworthy) -> err + + (a,b) | a == b -> return a + | otherwise -> err + + where err = do + let s = "Incompatible SafeHaskell flags! (" ++ showPpr a ++ ", " ++ showPpr b ++ ")" + addErr s + return $ panic s -- Just for saftey instead of returning say, a + -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from -> (DynFlags -> [a]) -- ^ Relevant record accessor: one of the @opt_*@ accessors @@ -979,6 +1080,16 @@ setHcSuf f d = d{ hcSuf = f} setOutputFile f d = d{ outputFile = f} setOutputHi f d = d{ outputHi = f} +addPluginModuleName :: String -> DynFlags -> DynFlags +addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } + +addPluginModuleNameOption :: String -> DynFlags -> DynFlags +addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) } + where (m, rest) = break (== ':') optflag + option = case rest of + [] -> "" -- should probably signal an error + (_:plug_opt) -> plug_opt -- ignore the ':' from break + parseDynLibLoaderMode f d = case splitAt 8 f of ("deploy", "") -> d{ dynLibLoader = Deployable } @@ -1034,6 +1145,7 @@ data Option -- transformed (e.g., "/out=") String -- the filepath/filename portion | Option String + deriving ( Eq ) showOpt :: Option -> String showOpt (FileOption pre f) = pre ++ f @@ -1089,26 +1201,27 @@ getStgToDo dflags -- the parsed 'DynFlags', the left-over arguments, and a list of warnings. -- Throws a 'UsageError' if errors occurred during parsing (such as unknown -- flags or missing arguments). -parseDynamicFlags :: Monad m => +parseDynamicFlagsCmdLine :: Monad m => DynFlags -> [Located String] -> m (DynFlags, [Located String], [Located String]) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. -parseDynamicFlags dflags args = parseDynamicFlags_ dflags args True +parseDynamicFlagsCmdLine dflags args = parseDynamicFlags dflags args True --- | Like 'parseDynamicFlags' but does not allow the package flags (-package, --- -hide-package, -ignore-package, -hide-all-packages, -package-conf). -parseDynamicNoPackageFlags :: Monad m => +-- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags +-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-conf). +-- Used to parse flags set in a modules pragma. +parseDynamicFilePragma :: Monad m => DynFlags -> [Located String] -> m (DynFlags, [Located String], [Located String]) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. -parseDynamicNoPackageFlags dflags args = parseDynamicFlags_ dflags args False +parseDynamicFilePragma dflags args = parseDynamicFlags dflags args False -parseDynamicFlags_ :: Monad m => +parseDynamicFlags :: Monad m => DynFlags -> [Located String] -> Bool -> m (DynFlags, [Located String], [Located String]) -parseDynamicFlags_ dflags0 args pkg_flags = do +parseDynamicFlags dflags0 args cmdline = do -- XXX Legacy support code -- We used to accept things like -- optdep-f -optdepdepend @@ -1122,14 +1235,43 @@ parseDynamicFlags_ dflags0 args pkg_flags = do args' = f args -- Note: -ignore-package (package_flags) must precede -i* (dynamic_flags) - flag_spec | pkg_flags = package_flags ++ dynamic_flags + flag_spec | cmdline = package_flags ++ dynamic_flags | otherwise = dynamic_flags + let safeLevel = if safeLanguageOn dflags0 + then determineSafeLevel cmdline else NeverAllowed let ((leftover, errs, warns), dflags1) - = runCmdLine (processArgs flag_spec args') dflags0 + = runCmdLine (processArgs flag_spec args' safeLevel cmdline) dflags0 when (not (null errs)) $ ghcError $ errorsToGhcException errs - return (dflags1, leftover, warns) + -- check for disabled flags in safe haskell + -- Hack: unfortunately flags that are completely disabled can't be stopped from being + -- enabled on the command line before a -XSafe or -XSafeLanguage flag is encountered. + -- the easiest way to fix this is to just check that they aren't enabled now. The down + -- side is that flags marked as NeverAllowed must also be checked here placing a sync + -- burden on the ghc hacker. + let (dflags2, sh_warns) = if (safeLanguageOn dflags1) + then shFlagsDisallowed dflags1 + else (dflags1, []) + + return (dflags2, leftover, sh_warns ++ warns) + +-- | Extensions that can't be enabled at all when compiling in Safe mode +-- checkSafeHaskellFlags :: MonadIO m => DynFlags -> m () +shFlagsDisallowed :: DynFlags -> (DynFlags, [Located String]) +shFlagsDisallowed dflags = foldl check_method (dflags, []) bad_flags + where + check_method (df, warns) (test,str,fix) + | test df = (fix df, warns ++ safeFailure str) + | otherwise = (df, warns) + + bad_flags = [(xopt Opt_GeneralizedNewtypeDeriving, "-XGeneralizedNewtypeDeriving", + flip xopt_unset Opt_GeneralizedNewtypeDeriving), + (xopt Opt_TemplateHaskell, "-XTemplateHaskell", + flip xopt_unset Opt_TemplateHaskell)] + + safeFailure str = [L noSrcSpan $ "Warning: " ++ str ++ " is not allowed in" + ++ " SafeHaskell; ignoring " ++ str] {- ********************************************************************** @@ -1146,296 +1288,301 @@ allFlags = map ('-':) $ map ("f"++) flags' ++ map ("X"++) supportedExtensions where ok (PrefixPred _ _) = False - ok _ = True - flags = [ name | (name, _, _) <- fFlags ] - flags' = [ name | (name, _, _) <- fLangFlags ] + ok _ = True + flags = [ name | (name, _, _, _) <- fFlags ] + flags' = [ name | (name, _, _, _) <- fLangFlags ] --------------- The main flags themselves ------------------ dynamic_flags :: [Flag (CmdLineP DynFlags)] dynamic_flags = [ - Flag "n" (NoArg (addWarn "The -n flag is deprecated and no longer has any effect")) - , Flag "cpp" (NoArg (setExtensionFlag Opt_Cpp)) - , Flag "F" (NoArg (setDynFlag Opt_Pp)) - , Flag "#include" + flagA "n" (NoArg (addWarn "The -n flag is deprecated and no longer has any effect")) + , flagA "cpp" (NoArg (setExtensionFlag Opt_Cpp)) + , flagA "F" (NoArg (setDynFlag Opt_Pp)) + , flagA "#include" (HasArg (\s -> do { addCmdlineHCInclude s ; addWarn "-#include and INCLUDE pragmas are deprecated: They no longer have any effect" })) - , Flag "v" (OptIntSuffix setVerbosity) + , flagA "v" (OptIntSuffix setVerbosity) ------- Specific phases -------------------------------------------- -- need to appear before -pgmL to be parsed as LLVM flags. - , Flag "pgmlo" (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) - , Flag "pgmlc" (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])}))) - , Flag "pgmL" (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f}))) - , Flag "pgmP" (hasArg setPgmP) - , Flag "pgmF" (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) - , Flag "pgmc" (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) - , Flag "pgmm" (HasArg (\_ -> addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) - , Flag "pgms" (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) - , Flag "pgma" (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) - , 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}))) + , flagA "pgmlo" (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) + , flagA "pgmlc" (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])}))) + , flagA "pgmL" (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f}))) + , flagA "pgmP" (hasArg setPgmP) + , flagA "pgmF" (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) + , flagA "pgmc" (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) + , flagA "pgmm" (HasArg (\_ -> addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) + , flagA "pgms" (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) + , flagA "pgma" (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) + , flagA "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) + , flagA "pgmdll" (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])}))) + , flagA "pgmwindres" (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = 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}))) - , Flag "optlc" (hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s}))) - , Flag "optL" (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) - , Flag "optP" (hasArg addOptP) - , Flag "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) - , Flag "optc" (hasArg (\f -> alterSettings (\s -> s { sOpt_c = f : sOpt_c s}))) - , Flag "optm" (hasArg (\f -> alterSettings (\s -> s { sOpt_m = f : sOpt_m s}))) - , Flag "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) - , Flag "optl" (hasArg addOptl) - , Flag "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) - - , Flag "split-objs" + , flagA "optlo" (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s}))) + , flagA "optlc" (hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s}))) + , flagA "optL" (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) + , flagA "optP" (hasArg addOptP) + , flagA "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) + , flagA "optc" (hasArg (\f -> alterSettings (\s -> s { sOpt_c = f : sOpt_c s}))) + , flagA "optm" (hasArg (\f -> alterSettings (\s -> s { sOpt_m = f : sOpt_m s}))) + , flagA "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) + , flagA "optl" (hasArg addOptl) + , flagA "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) + + , flagA "split-objs" (NoArg (if can_split then setDynFlag Opt_SplitObjs else addWarn "ignoring -fsplit-objs")) -------- ghc -M ----------------------------------------------------- - , Flag "dep-suffix" (hasArg addDepSuffix) - , Flag "optdep-s" (hasArgDF addDepSuffix "Use -dep-suffix instead") - , Flag "dep-makefile" (hasArg setDepMakefile) - , Flag "optdep-f" (hasArgDF setDepMakefile "Use -dep-makefile instead") - , Flag "optdep-w" (NoArg (deprecate "doesn't do anything")) - , Flag "include-pkg-deps" (noArg (setDepIncludePkgDeps True)) - , Flag "optdep--include-prelude" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") - , Flag "optdep--include-pkg-deps" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") - , Flag "exclude-module" (hasArg addDepExcludeMod) - , Flag "optdep--exclude-module" (hasArgDF addDepExcludeMod "Use -exclude-module instead") - , Flag "optdep-x" (hasArgDF addDepExcludeMod "Use -exclude-module instead") + , flagA "dep-suffix" (hasArg addDepSuffix) + , flagA "optdep-s" (hasArgDF addDepSuffix "Use -dep-suffix instead") + , flagA "dep-makefile" (hasArg setDepMakefile) + , flagA "optdep-f" (hasArgDF setDepMakefile "Use -dep-makefile instead") + , flagA "optdep-w" (NoArg (deprecate "doesn't do anything")) + , flagA "include-pkg-deps" (noArg (setDepIncludePkgDeps True)) + , flagA "optdep--include-prelude" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") + , flagA "optdep--include-pkg-deps" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") + , flagA "exclude-module" (hasArg addDepExcludeMod) + , flagA "optdep--exclude-module" (hasArgDF addDepExcludeMod "Use -exclude-module instead") + , flagA "optdep-x" (hasArgDF addDepExcludeMod "Use -exclude-module instead") -------- Linking ---------------------------------------------------- - , Flag "no-link" (noArg (\d -> d{ ghcLink=NoLink })) - , Flag "shared" (noArg (\d -> d{ ghcLink=LinkDynLib })) - , Flag "dynload" (hasArg parseDynLibLoaderMode) - , Flag "dylib-install-name" (hasArg setDylibInstallName) + , flagA "no-link" (noArg (\d -> d{ ghcLink=NoLink })) + , flagA "shared" (noArg (\d -> d{ ghcLink=LinkDynLib })) + , flagA "dynload" (hasArg parseDynLibLoaderMode) + , flagA "dylib-install-name" (hasArg setDylibInstallName) ------- Libraries --------------------------------------------------- - , Flag "L" (Prefix addLibraryPath) - , Flag "l" (hasArg (addOptl . ("-l" ++))) + , flagA "L" (Prefix addLibraryPath) + , flagA "l" (hasArg (addOptl . ("-l" ++))) ------- Frameworks -------------------------------------------------- -- -framework-path should really be -F ... - , Flag "framework-path" (HasArg addFrameworkPath) - , Flag "framework" (hasArg addCmdlineFramework) + , flagA "framework-path" (HasArg addFrameworkPath) + , flagA "framework" (hasArg addCmdlineFramework) ------- Output Redirection ------------------------------------------ - , Flag "odir" (hasArg setObjectDir) - , Flag "o" (SepArg (upd . setOutputFile . Just)) - , Flag "ohi" (hasArg (setOutputHi . Just )) - , Flag "osuf" (hasArg setObjectSuf) - , Flag "hcsuf" (hasArg setHcSuf) - , Flag "hisuf" (hasArg setHiSuf) - , Flag "hidir" (hasArg setHiDir) - , Flag "tmpdir" (hasArg setTmpDir) - , Flag "stubdir" (hasArg setStubDir) - , Flag "outputdir" (hasArg setOutputDir) - , Flag "ddump-file-prefix" (hasArg (setDumpPrefixForce . Just)) + , flagA "odir" (hasArg setObjectDir) + , flagA "o" (SepArg (upd . setOutputFile . Just)) + , flagA "ohi" (hasArg (setOutputHi . Just )) + , flagA "osuf" (hasArg setObjectSuf) + , flagA "hcsuf" (hasArg setHcSuf) + , flagA "hisuf" (hasArg setHiSuf) + , flagA "hidir" (hasArg setHiDir) + , flagA "tmpdir" (hasArg setTmpDir) + , flagA "stubdir" (hasArg setStubDir) + , flagA "outputdir" (hasArg setOutputDir) + , flagA "ddump-file-prefix" (hasArg (setDumpPrefixForce . Just)) ------- Keeping temporary files ------------------------------------- -- These can be singular (think ghc -c) or plural (think ghc --make) - , Flag "keep-hc-file" (NoArg (setDynFlag Opt_KeepHcFiles)) - , Flag "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles)) - , Flag "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles)) - , Flag "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles)) - , Flag "keep-raw-s-file" (NoArg (addWarn "The -keep-raw-s-file flag does nothing; it will be removed in a future GHC release")) - , Flag "keep-raw-s-files" (NoArg (addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) - , Flag "keep-llvm-file" (NoArg (setDynFlag Opt_KeepLlvmFiles)) - , Flag "keep-llvm-files" (NoArg (setDynFlag Opt_KeepLlvmFiles)) + , flagA "keep-hc-file" (NoArg (setDynFlag Opt_KeepHcFiles)) + , flagA "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles)) + , flagA "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles)) + , flagA "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles)) + , flagA "keep-raw-s-file" (NoArg (addWarn "The -keep-raw-s-file flag does nothing; it will be removed in a future GHC release")) + , flagA "keep-raw-s-files" (NoArg (addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) + , flagA "keep-llvm-file" (NoArg (setDynFlag Opt_KeepLlvmFiles)) + , flagA "keep-llvm-files" (NoArg (setDynFlag Opt_KeepLlvmFiles)) -- This only makes sense as plural - , Flag "keep-tmp-files" (NoArg (setDynFlag Opt_KeepTmpFiles)) + , flagA "keep-tmp-files" (NoArg (setDynFlag Opt_KeepTmpFiles)) ------- Miscellaneous ---------------------------------------------- - , Flag "no-auto-link-packages" (NoArg (unSetDynFlag Opt_AutoLinkPackages)) - , Flag "no-hs-main" (NoArg (setDynFlag Opt_NoHsMain)) - , Flag "with-rtsopts" (HasArg setRtsOpts) - , Flag "rtsopts" (NoArg (setRtsOptsEnabled RtsOptsAll)) - , Flag "rtsopts=all" (NoArg (setRtsOptsEnabled RtsOptsAll)) - , Flag "rtsopts=some" (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) - , Flag "rtsopts=none" (NoArg (setRtsOptsEnabled RtsOptsNone)) - , Flag "no-rtsopts" (NoArg (setRtsOptsEnabled RtsOptsNone)) - , Flag "main-is" (SepArg setMainIs) - , Flag "haddock" (NoArg (setDynFlag Opt_Haddock)) - , Flag "haddock-opts" (hasArg addHaddockOpts) - , Flag "hpcdir" (SepArg setOptHpcDir) + , flagA "no-auto-link-packages" (NoArg (unSetDynFlag Opt_AutoLinkPackages)) + , flagA "no-hs-main" (NoArg (setDynFlag Opt_NoHsMain)) + , flagA "with-rtsopts" (HasArg setRtsOpts) + , flagA "rtsopts" (NoArg (setRtsOptsEnabled RtsOptsAll)) + , flagA "rtsopts=all" (NoArg (setRtsOptsEnabled RtsOptsAll)) + , flagA "rtsopts=some" (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) + , flagA "rtsopts=none" (NoArg (setRtsOptsEnabled RtsOptsNone)) + , flagA "no-rtsopts" (NoArg (setRtsOptsEnabled RtsOptsNone)) + , flagA "main-is" (SepArg setMainIs) + , flagA "haddock" (NoArg (setDynFlag Opt_Haddock)) + , flagA "haddock-opts" (hasArg addHaddockOpts) + , flagA "hpcdir" (SepArg setOptHpcDir) ------- recompilation checker -------------------------------------- - , Flag "recomp" (NoArg (do { unSetDynFlag Opt_ForceRecomp + , flagA "recomp" (NoArg (do { unSetDynFlag Opt_ForceRecomp ; deprecate "Use -fno-force-recomp instead" })) - , Flag "no-recomp" (NoArg (do { setDynFlag Opt_ForceRecomp + , flagA "no-recomp" (NoArg (do { setDynFlag Opt_ForceRecomp ; deprecate "Use -fforce-recomp instead" })) ------ HsCpp opts --------------------------------------------------- - , Flag "D" (AnySuffix (upd . addOptP)) - , Flag "U" (AnySuffix (upd . addOptP)) + , flagA "D" (AnySuffix (upd . addOptP)) + , flagA "U" (AnySuffix (upd . addOptP)) ------- Include/Import Paths ---------------------------------------- - , Flag "I" (Prefix addIncludePath) - , Flag "i" (OptPrefix addImportPath) + , flagA "I" (Prefix addIncludePath) + , flagA "i" (OptPrefix addImportPath) ------ Debugging ---------------------------------------------------- - , Flag "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) - - , Flag "ddump-cmm" (setDumpFlag Opt_D_dump_cmm) - , Flag "ddump-raw-cmm" (setDumpFlag Opt_D_dump_raw_cmm) - , Flag "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz) - , Flag "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty) - , Flag "ddump-cmmz-cbe" (setDumpFlag Opt_D_dump_cmmz_cbe) - , Flag "ddump-cmmz-spills" (setDumpFlag Opt_D_dump_cmmz_spills) - , Flag "ddump-cmmz-proc" (setDumpFlag Opt_D_dump_cmmz_proc) - , Flag "ddump-cmmz-rewrite" (setDumpFlag Opt_D_dump_cmmz_rewrite) - , Flag "ddump-cmmz-dead" (setDumpFlag Opt_D_dump_cmmz_dead) - , Flag "ddump-cmmz-stub" (setDumpFlag Opt_D_dump_cmmz_stub) - , Flag "ddump-cmmz-sp" (setDumpFlag Opt_D_dump_cmmz_sp) - , Flag "ddump-cmmz-procmap" (setDumpFlag Opt_D_dump_cmmz_procmap) - , Flag "ddump-cmmz-split" (setDumpFlag Opt_D_dump_cmmz_split) - , Flag "ddump-cmmz-lower" (setDumpFlag Opt_D_dump_cmmz_lower) - , Flag "ddump-cmmz-info" (setDumpFlag Opt_D_dump_cmmz_info) - , Flag "ddump-cmmz-cafs" (setDumpFlag Opt_D_dump_cmmz_cafs) - , Flag "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats) - , Flag "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm) - , Flag "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm) - , Flag "ddump-asm" (setDumpFlag Opt_D_dump_asm) - , Flag "ddump-asm-native" (setDumpFlag Opt_D_dump_asm_native) - , Flag "ddump-asm-liveness" (setDumpFlag Opt_D_dump_asm_liveness) - , Flag "ddump-asm-coalesce" (setDumpFlag Opt_D_dump_asm_coalesce) - , Flag "ddump-asm-regalloc" (setDumpFlag Opt_D_dump_asm_regalloc) - , Flag "ddump-asm-conflicts" (setDumpFlag Opt_D_dump_asm_conflicts) - , Flag "ddump-asm-regalloc-stages" (setDumpFlag Opt_D_dump_asm_regalloc_stages) - , Flag "ddump-asm-stats" (setDumpFlag Opt_D_dump_asm_stats) - , Flag "ddump-asm-expanded" (setDumpFlag Opt_D_dump_asm_expanded) - , Flag "ddump-llvm" (NoArg (do { setObjTarget HscLlvm - ; setDumpFlag' Opt_D_dump_llvm})) - , Flag "ddump-cpranal" (setDumpFlag Opt_D_dump_cpranal) - , Flag "ddump-deriv" (setDumpFlag Opt_D_dump_deriv) - , Flag "ddump-ds" (setDumpFlag Opt_D_dump_ds) - , Flag "ddump-flatC" (setDumpFlag Opt_D_dump_flatC) - , Flag "ddump-foreign" (setDumpFlag Opt_D_dump_foreign) - , Flag "ddump-inlinings" (setDumpFlag Opt_D_dump_inlinings) - , Flag "ddump-rule-firings" (setDumpFlag Opt_D_dump_rule_firings) - , Flag "ddump-rule-rewrites" (setDumpFlag Opt_D_dump_rule_rewrites) - , Flag "ddump-occur-anal" (setDumpFlag Opt_D_dump_occur_anal) - , Flag "ddump-parsed" (setDumpFlag Opt_D_dump_parsed) - , Flag "ddump-rn" (setDumpFlag Opt_D_dump_rn) - , Flag "ddump-simpl" (setDumpFlag Opt_D_dump_simpl) - , Flag "ddump-simpl-iterations" (setDumpFlag Opt_D_dump_simpl_iterations) - , Flag "ddump-simpl-phases" (OptPrefix setDumpSimplPhases) - , Flag "ddump-spec" (setDumpFlag Opt_D_dump_spec) - , Flag "ddump-prep" (setDumpFlag Opt_D_dump_prep) - , Flag "ddump-stg" (setDumpFlag Opt_D_dump_stg) - , Flag "ddump-stranal" (setDumpFlag Opt_D_dump_stranal) - , Flag "ddump-tc" (setDumpFlag Opt_D_dump_tc) - , Flag "ddump-types" (setDumpFlag Opt_D_dump_types) - , Flag "ddump-rules" (setDumpFlag Opt_D_dump_rules) - , Flag "ddump-cse" (setDumpFlag Opt_D_dump_cse) - , Flag "ddump-worker-wrapper" (setDumpFlag Opt_D_dump_worker_wrapper) - , Flag "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) - , Flag "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) - , Flag "ddump-cs-trace" (setDumpFlag Opt_D_dump_cs_trace) - , Flag "ddump-tc-trace" (setDumpFlag Opt_D_dump_tc_trace) - , Flag "ddump-vt-trace" (setDumpFlag Opt_D_dump_vt_trace) - , Flag "ddump-splices" (setDumpFlag Opt_D_dump_splices) - , Flag "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats) - , Flag "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm) - , Flag "ddump-simpl-stats" (setDumpFlag Opt_D_dump_simpl_stats) - , Flag "ddump-bcos" (setDumpFlag Opt_D_dump_BCOs) - , Flag "dsource-stats" (setDumpFlag Opt_D_source_stats) - , Flag "dverbose-core2core" (NoArg (do { setVerbosity (Just 2) - ; setVerboseCore2Core })) - , Flag "dverbose-stg2stg" (setDumpFlag Opt_D_verbose_stg2stg) - , Flag "ddump-hi" (setDumpFlag Opt_D_dump_hi) - , Flag "ddump-minimal-imports" (setDumpFlag Opt_D_dump_minimal_imports) - , Flag "ddump-vect" (setDumpFlag Opt_D_dump_vect) - , Flag "ddump-hpc" (setDumpFlag Opt_D_dump_hpc) - , Flag "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) - , Flag "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) - , Flag "ddump-to-file" (setDumpFlag Opt_DumpToFile) - , Flag "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs) - , Flag "ddump-rtti" (setDumpFlag Opt_D_dump_rtti) - , Flag "dcore-lint" (NoArg (setDynFlag Opt_DoCoreLinting)) - , Flag "dstg-lint" (NoArg (setDynFlag Opt_DoStgLinting)) - , Flag "dcmm-lint" (NoArg (setDynFlag Opt_DoCmmLinting)) - , Flag "dasm-lint" (NoArg (setDynFlag Opt_DoAsmLinting)) - , Flag "dshow-passes" (NoArg (do forceRecompile - setVerbosity (Just 2))) - , Flag "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats)) + , flagA "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) + + , flagA "ddump-cmm" (setDumpFlag Opt_D_dump_cmm) + , flagA "ddump-raw-cmm" (setDumpFlag Opt_D_dump_raw_cmm) + , flagA "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz) + , flagA "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty) + , flagA "ddump-cmmz-cbe" (setDumpFlag Opt_D_dump_cmmz_cbe) + , flagA "ddump-cmmz-spills" (setDumpFlag Opt_D_dump_cmmz_spills) + , flagA "ddump-cmmz-proc" (setDumpFlag Opt_D_dump_cmmz_proc) + , flagA "ddump-cmmz-rewrite" (setDumpFlag Opt_D_dump_cmmz_rewrite) + , flagA "ddump-cmmz-dead" (setDumpFlag Opt_D_dump_cmmz_dead) + , flagA "ddump-cmmz-stub" (setDumpFlag Opt_D_dump_cmmz_stub) + , flagA "ddump-cmmz-sp" (setDumpFlag Opt_D_dump_cmmz_sp) + , flagA "ddump-cmmz-procmap" (setDumpFlag Opt_D_dump_cmmz_procmap) + , flagA "ddump-cmmz-split" (setDumpFlag Opt_D_dump_cmmz_split) + , flagA "ddump-cmmz-lower" (setDumpFlag Opt_D_dump_cmmz_lower) + , flagA "ddump-cmmz-info" (setDumpFlag Opt_D_dump_cmmz_info) + , flagA "ddump-cmmz-cafs" (setDumpFlag Opt_D_dump_cmmz_cafs) + , flagA "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats) + , flagA "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm) + , flagA "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm) + , flagA "ddump-asm" (setDumpFlag Opt_D_dump_asm) + , flagA "ddump-asm-native" (setDumpFlag Opt_D_dump_asm_native) + , flagA "ddump-asm-liveness" (setDumpFlag Opt_D_dump_asm_liveness) + , flagA "ddump-asm-coalesce" (setDumpFlag Opt_D_dump_asm_coalesce) + , flagA "ddump-asm-regalloc" (setDumpFlag Opt_D_dump_asm_regalloc) + , flagA "ddump-asm-conflicts" (setDumpFlag Opt_D_dump_asm_conflicts) + , flagA "ddump-asm-regalloc-stages" (setDumpFlag Opt_D_dump_asm_regalloc_stages) + , flagA "ddump-asm-stats" (setDumpFlag Opt_D_dump_asm_stats) + , flagA "ddump-asm-expanded" (setDumpFlag Opt_D_dump_asm_expanded) + , flagA "ddump-llvm" (NoArg (do { setObjTarget HscLlvm + ; setDumpFlag' Opt_D_dump_llvm})) + , flagA "ddump-cpranal" (setDumpFlag Opt_D_dump_cpranal) + , flagA "ddump-deriv" (setDumpFlag Opt_D_dump_deriv) + , flagA "ddump-ds" (setDumpFlag Opt_D_dump_ds) + , flagA "ddump-flatC" (setDumpFlag Opt_D_dump_flatC) + , flagA "ddump-foreign" (setDumpFlag Opt_D_dump_foreign) + , flagA "ddump-inlinings" (setDumpFlag Opt_D_dump_inlinings) + , flagA "ddump-rule-firings" (setDumpFlag Opt_D_dump_rule_firings) + , flagA "ddump-rule-rewrites" (setDumpFlag Opt_D_dump_rule_rewrites) + , flagA "ddump-occur-anal" (setDumpFlag Opt_D_dump_occur_anal) + , flagA "ddump-parsed" (setDumpFlag Opt_D_dump_parsed) + , flagA "ddump-rn" (setDumpFlag Opt_D_dump_rn) + , flagA "ddump-core-pipeline" (setDumpFlag Opt_D_dump_core_pipeline) + , flagA "ddump-simpl" (setDumpFlag Opt_D_dump_simpl) + , flagA "ddump-simpl-iterations" (setDumpFlag Opt_D_dump_simpl_iterations) + , flagA "ddump-simpl-phases" (OptPrefix setDumpSimplPhases) + , flagA "ddump-spec" (setDumpFlag Opt_D_dump_spec) + , flagA "ddump-prep" (setDumpFlag Opt_D_dump_prep) + , flagA "ddump-stg" (setDumpFlag Opt_D_dump_stg) + , flagA "ddump-stranal" (setDumpFlag Opt_D_dump_stranal) + , flagA "ddump-tc" (setDumpFlag Opt_D_dump_tc) + , flagA "ddump-types" (setDumpFlag Opt_D_dump_types) + , flagA "ddump-rules" (setDumpFlag Opt_D_dump_rules) + , flagA "ddump-cse" (setDumpFlag Opt_D_dump_cse) + , flagA "ddump-worker-wrapper" (setDumpFlag Opt_D_dump_worker_wrapper) + , flagA "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) + , flagA "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) + , flagA "ddump-cs-trace" (setDumpFlag Opt_D_dump_cs_trace) + , flagA "ddump-tc-trace" (setDumpFlag Opt_D_dump_tc_trace) + , flagA "ddump-vt-trace" (setDumpFlag Opt_D_dump_vt_trace) + , flagA "ddump-splices" (setDumpFlag Opt_D_dump_splices) + , flagA "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats) + , flagA "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm) + , flagA "ddump-simpl-stats" (setDumpFlag Opt_D_dump_simpl_stats) + , flagA "ddump-bcos" (setDumpFlag Opt_D_dump_BCOs) + , flagA "dsource-stats" (setDumpFlag Opt_D_source_stats) + , flagA "dverbose-core2core" (NoArg (do { setVerbosity (Just 2) + ; setVerboseCore2Core })) + , flagA "dverbose-stg2stg" (setDumpFlag Opt_D_verbose_stg2stg) + , flagA "ddump-hi" (setDumpFlag Opt_D_dump_hi) + , flagA "ddump-minimal-imports" (setDumpFlag Opt_D_dump_minimal_imports) + , flagA "ddump-vect" (setDumpFlag Opt_D_dump_vect) + , flagA "ddump-hpc" (setDumpFlag Opt_D_dump_hpc) + , flagA "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) + , flagA "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) + , flagA "ddump-to-file" (setDumpFlag Opt_DumpToFile) + , flagA "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs) + , flagA "ddump-rtti" (setDumpFlag Opt_D_dump_rtti) + , flagA "dcore-lint" (NoArg (setDynFlag Opt_DoCoreLinting)) + , flagA "dstg-lint" (NoArg (setDynFlag Opt_DoStgLinting)) + , flagA "dcmm-lint" (NoArg (setDynFlag Opt_DoCmmLinting)) + , flagA "dasm-lint" (NoArg (setDynFlag Opt_DoAsmLinting)) + , flagA "dshow-passes" (NoArg (do forceRecompile + setVerbosity (Just 2))) + , flagA "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats)) ------ Machine dependant (-m<blah>) stuff --------------------------- - , Flag "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release")) - , Flag "monly-3-regs" (NoArg (addWarn "The -monly-3-regs flag does nothing; it will be removed in a future GHC release")) - , Flag "monly-4-regs" (NoArg (addWarn "The -monly-4-regs flag does nothing; it will be removed in a future GHC release")) - , Flag "msse2" (NoArg (setDynFlag Opt_SSE2)) + , flagA "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release")) + , flagA "monly-3-regs" (NoArg (addWarn "The -monly-3-regs flag does nothing; it will be removed in a future GHC release")) + , flagA "monly-4-regs" (NoArg (addWarn "The -monly-4-regs flag does nothing; it will be removed in a future GHC release")) + , flagA "msse2" (NoArg (setDynFlag Opt_SSE2)) ------ Warning opts ------------------------------------------------- - , Flag "W" (NoArg (mapM_ setDynFlag minusWOpts)) - , Flag "Werror" (NoArg (setDynFlag Opt_WarnIsError)) - , Flag "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) - , Flag "Wall" (NoArg (mapM_ setDynFlag minusWallOpts)) - , Flag "Wnot" (NoArg (do { mapM_ unSetDynFlag minusWallOpts + , flagA "W" (NoArg (mapM_ setDynFlag minusWOpts)) + , flagA "Werror" (NoArg (setDynFlag Opt_WarnIsError)) + , flagA "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) + , flagA "Wall" (NoArg (mapM_ setDynFlag minusWallOpts)) + , flagA "Wnot" (NoArg (do { mapM_ unSetDynFlag minusWallOpts ; deprecate "Use -w instead" })) - , Flag "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts)) - + , flagA "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts)) + + ------ Plugin flags ------------------------------------------------ + , flagA "fplugin" (hasArg addPluginModuleName) + , flagA "fplugin-opt" (hasArg addPluginModuleNameOption) + ------ Optimisation flags ------------------------------------------ - , Flag "O" (noArgM (setOptLevel 1)) - , Flag "Onot" (noArgM (\dflags -> do deprecate "Use -O0 instead" - setOptLevel 0 dflags)) - , Flag "Odph" (noArgM setDPHOpt) - , Flag "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1))) + , flagA "O" (noArgM (setOptLevel 1)) + , flagA "Onot" (noArgM (\dflags -> do deprecate "Use -O0 instead" + setOptLevel 0 dflags)) + , flagA "Odph" (noArgM setDPHOpt) + , flagA "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1))) -- If the number is missing, use 1 - , Flag "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n })) - , Flag "fmax-simplifier-iterations" (intSuffix (\n d -> d{ maxSimplIterations = n })) - , Flag "fspec-constr-threshold" (intSuffix (\n d -> d{ specConstrThreshold = Just n })) - , Flag "fno-spec-constr-threshold" (noArg (\d -> d{ specConstrThreshold = Nothing })) - , Flag "fspec-constr-count" (intSuffix (\n d -> d{ specConstrCount = Just n })) - , Flag "fno-spec-constr-count" (noArg (\d -> d{ specConstrCount = Nothing })) - , Flag "fliberate-case-threshold" (intSuffix (\n d -> d{ liberateCaseThreshold = Just n })) - , Flag "fno-liberate-case-threshold" (noArg (\d -> d{ liberateCaseThreshold = Nothing })) - , Flag "frule-check" (SepArg (\s -> upd (\d -> d{ ruleCheck = Just s }))) - , Flag "fcontext-stack" (intSuffix (\n d -> d{ ctxtStkDepth = n })) - , 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 })) + , flagA "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n })) + , flagA "fmax-simplifier-iterations" (intSuffix (\n d -> d{ maxSimplIterations = n })) + , flagA "fspec-constr-threshold" (intSuffix (\n d -> d{ specConstrThreshold = Just n })) + , flagA "fno-spec-constr-threshold" (noArg (\d -> d{ specConstrThreshold = Nothing })) + , flagA "fspec-constr-count" (intSuffix (\n d -> d{ specConstrCount = Just n })) + , flagA "fno-spec-constr-count" (noArg (\d -> d{ specConstrCount = Nothing })) + , flagA "fliberate-case-threshold" (intSuffix (\n d -> d{ liberateCaseThreshold = Just n })) + , flagA "fno-liberate-case-threshold" (noArg (\d -> d{ liberateCaseThreshold = Nothing })) + , flagA "frule-check" (SepArg (\s -> upd (\d -> d{ ruleCheck = Just s }))) + , flagA "fcontext-stack" (intSuffix (\n d -> d{ ctxtStkDepth = n })) + , flagA "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) + , flagA "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) + , flagA "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) ------ Profiling ---------------------------------------------------- -- XXX Should the -f* flags be deprecated? -- They don't seem to be documented - , Flag "fauto-sccs-on-all-toplevs" (NoArg (setDynFlag Opt_AutoSccsOnAllToplevs)) - , Flag "auto-all" (NoArg (setDynFlag Opt_AutoSccsOnAllToplevs)) - , Flag "no-auto-all" (NoArg (unSetDynFlag Opt_AutoSccsOnAllToplevs)) - , Flag "fauto-sccs-on-exported-toplevs" (NoArg (setDynFlag Opt_AutoSccsOnExportedToplevs)) - , Flag "auto" (NoArg (setDynFlag Opt_AutoSccsOnExportedToplevs)) - , Flag "no-auto" (NoArg (unSetDynFlag Opt_AutoSccsOnExportedToplevs)) - , Flag "fauto-sccs-on-individual-cafs" (NoArg (setDynFlag Opt_AutoSccsOnIndividualCafs)) - , Flag "caf-all" (NoArg (setDynFlag Opt_AutoSccsOnIndividualCafs)) - , Flag "no-caf-all" (NoArg (unSetDynFlag Opt_AutoSccsOnIndividualCafs)) + , flagA "fauto-sccs-on-all-toplevs" (NoArg (setDynFlag Opt_AutoSccsOnAllToplevs)) + , flagA "auto-all" (NoArg (setDynFlag Opt_AutoSccsOnAllToplevs)) + , flagA "no-auto-all" (NoArg (unSetDynFlag Opt_AutoSccsOnAllToplevs)) + , flagA "fauto-sccs-on-exported-toplevs" (NoArg (setDynFlag Opt_AutoSccsOnExportedToplevs)) + , flagA "auto" (NoArg (setDynFlag Opt_AutoSccsOnExportedToplevs)) + , flagA "no-auto" (NoArg (unSetDynFlag Opt_AutoSccsOnExportedToplevs)) + , flagA "fauto-sccs-on-individual-cafs" (NoArg (setDynFlag Opt_AutoSccsOnIndividualCafs)) + , flagA "caf-all" (NoArg (setDynFlag Opt_AutoSccsOnIndividualCafs)) + , flagA "no-caf-all" (NoArg (unSetDynFlag Opt_AutoSccsOnIndividualCafs)) ------ DPH flags ---------------------------------------------------- - , Flag "fdph-seq" (NoArg (setDPHBackend DPHSeq)) - , Flag "fdph-par" (NoArg (setDPHBackend DPHPar)) - , Flag "fdph-this" (NoArg (setDPHBackend DPHThis)) - , Flag "fdph-none" (NoArg (setDPHBackend DPHNone)) + , flagA "fdph-seq" (NoArg (setDPHBackend DPHSeq)) + , flagA "fdph-par" (NoArg (setDPHBackend DPHPar)) + , flagA "fdph-this" (NoArg (setDPHBackend DPHThis)) + , flagA "fdph-none" (NoArg (setDPHBackend DPHNone)) ------ Compiler flags ----------------------------------------------- - , Flag "fasm" (NoArg (setObjTarget HscAsm)) - , Flag "fvia-c" (NoArg + , flagA "fasm" (NoArg (setObjTarget HscAsm)) + , flagA "fvia-c" (NoArg (addWarn "The -fvia-c flag does nothing; it will be removed in a future GHC release")) - , Flag "fvia-C" (NoArg + , flagA "fvia-C" (NoArg (addWarn "The -fvia-C flag does nothing; it will be removed in a future GHC release")) - , Flag "fllvm" (NoArg (setObjTarget HscLlvm)) - - , Flag "fno-code" (NoArg (do upd $ \d -> d{ ghcLink=NoLink } - setTarget HscNothing)) - , Flag "fbyte-code" (NoArg (setTarget HscInterpreted)) - , Flag "fobject-code" (NoArg (setTarget defaultHscTarget)) - , Flag "fglasgow-exts" (NoArg (enableGlasgowExts >> deprecate "Use individual extensions instead")) - , Flag "fno-glasgow-exts" (NoArg (disableGlasgowExts >> deprecate "Use individual extensions instead")) + , flagA "fllvm" (NoArg (setObjTarget HscLlvm)) + + , flagA "fno-code" (NoArg (do { upd $ \d -> d{ ghcLink=NoLink } + ; setTarget HscNothing })) + , flagA "fbyte-code" (NoArg (setTarget HscInterpreted)) + , flagA "fobject-code" (NoArg (setTarget defaultHscTarget)) + , flagA "fglasgow-exts" (NoArg (enableGlasgowExts >> deprecate "Use individual extensions instead")) + , flagA "fno-glasgow-exts" (NoArg (disableGlasgowExts >> deprecate "Use individual extensions instead")) ] ++ map (mkFlag turnOn "f" setDynFlag ) fFlags ++ map (mkFlag turnOff "fno-" unSetDynFlag) fFlags @@ -1444,20 +1591,26 @@ dynamic_flags = [ ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlags ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlags ++ map (mkFlag turnOn "X" setLanguage) languageFlags + ++ map (mkFlag turnOn "X" setSafeHaskell) safeHaskellFlags package_flags :: [Flag (CmdLineP DynFlags)] package_flags = [ ------- Packages ---------------------------------------------------- - Flag "package-conf" (HasArg extraPkgConf_) - , Flag "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) - , Flag "package-name" (hasArg setPackageName) - , Flag "package-id" (HasArg exposePackageId) - , Flag "package" (HasArg exposePackage) - , Flag "hide-package" (HasArg hidePackage) - , Flag "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages)) - , Flag "ignore-package" (HasArg ignorePackage) - , Flag "syslib" (HasArg (\s -> do { exposePackage s - ; deprecate "Use -package instead" })) + -- specifying these to be flagC is redundant since they are actually + -- static flags, but best to do this anyway. + flagC "package-conf" (HasArg extraPkgConf_) + , flagC "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) + , flagC "package-name" (hasArg setPackageName) + , flagC "package-id" (HasArg exposePackageId) + , flagC "package" (HasArg exposePackage) + , flagC "hide-package" (HasArg hidePackage) + , flagC "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages)) + , flagC "ignore-package" (HasArg ignorePackage) + , flagC "syslib" (HasArg (\s -> do { exposePackage s + ; deprecate "Use -package instead" })) + , flagC "trust" (HasArg trustPackage) + , flagC "distrust" (HasArg distrustPackage) + , flagC "distrust-all-packages" (NoArg (setDynFlag Opt_DistrustAllPackages)) ] type TurnOnFlag = Bool -- True <=> we are turning the flag on @@ -1467,6 +1620,7 @@ turnOff :: TurnOnFlag; turnOff = False type FlagSpec flag = ( String -- Flag in string form + , FlagSafety , flag -- Flag in internal form , TurnOnFlag -> DynP ()) -- Extra action to run when the flag is found -- Typically, emit a warning or error @@ -1476,8 +1630,8 @@ mkFlag :: TurnOnFlag -- ^ True <=> it should be turned on -> (flag -> DynP ()) -- ^ What to do when the flag is found -> FlagSpec flag -- ^ Specification of this particular flag -> Flag (CmdLineP DynFlags) -mkFlag turn_on flagPrefix f (name, flag, extra_action) - = Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) +mkFlag turn_on flagPrefix f (name, fsafe, flag, extra_action) + = Flag (flagPrefix ++ name) fsafe (NoArg (f flag >> extra_action turn_on)) deprecatedForExtension :: String -> TurnOnFlag -> DynP () deprecatedForExtension lang turn_on @@ -1498,230 +1652,244 @@ nop _ = return () -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ fFlags :: [FlagSpec DynFlag] fFlags = [ - ( "warn-dodgy-foreign-imports", Opt_WarnDodgyForeignImports, nop ), - ( "warn-dodgy-exports", Opt_WarnDodgyExports, nop ), - ( "warn-dodgy-imports", Opt_WarnDodgyImports, nop ), - ( "warn-duplicate-exports", Opt_WarnDuplicateExports, nop ), - ( "warn-hi-shadowing", Opt_WarnHiShadows, nop ), - ( "warn-implicit-prelude", Opt_WarnImplicitPrelude, nop ), - ( "warn-incomplete-patterns", Opt_WarnIncompletePatterns, nop ), - ( "warn-incomplete-uni-patterns", Opt_WarnIncompleteUniPatterns, nop ), - ( "warn-incomplete-record-updates", Opt_WarnIncompletePatternsRecUpd, nop ), - ( "warn-missing-fields", Opt_WarnMissingFields, nop ), - ( "warn-missing-import-lists", Opt_WarnMissingImportList, nop ), - ( "warn-missing-methods", Opt_WarnMissingMethods, nop ), - ( "warn-missing-signatures", Opt_WarnMissingSigs, nop ), - ( "warn-missing-local-sigs", Opt_WarnMissingLocalSigs, nop ), - ( "warn-name-shadowing", Opt_WarnNameShadowing, nop ), - ( "warn-overlapping-patterns", Opt_WarnOverlappingPatterns, nop ), - ( "warn-type-defaults", Opt_WarnTypeDefaults, nop ), - ( "warn-monomorphism-restriction", Opt_WarnMonomorphism, nop ), - ( "warn-unused-binds", Opt_WarnUnusedBinds, nop ), - ( "warn-unused-imports", Opt_WarnUnusedImports, nop ), - ( "warn-unused-matches", Opt_WarnUnusedMatches, nop ), - ( "warn-warnings-deprecations", Opt_WarnWarningsDeprecations, nop ), - ( "warn-deprecations", Opt_WarnWarningsDeprecations, nop ), - ( "warn-deprecated-flags", Opt_WarnDeprecatedFlags, nop ), - ( "warn-orphans", Opt_WarnOrphans, nop ), - ( "warn-identities", Opt_WarnIdentities, nop ), - ( "warn-auto-orphans", Opt_WarnAutoOrphans, nop ), - ( "warn-tabs", Opt_WarnTabs, nop ), - ( "warn-unrecognised-pragmas", Opt_WarnUnrecognisedPragmas, nop ), - ( "warn-lazy-unlifted-bindings", Opt_WarnLazyUnliftedBindings, nop), - ( "warn-unused-do-bind", Opt_WarnUnusedDoBind, nop ), - ( "warn-wrong-do-bind", Opt_WarnWrongDoBind, nop ), - ( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, nop ), - ( "print-explicit-foralls", Opt_PrintExplicitForalls, nop ), - ( "strictness", Opt_Strictness, nop ), - ( "specialise", Opt_Specialise, nop ), - ( "float-in", Opt_FloatIn, nop ), - ( "static-argument-transformation", Opt_StaticArgumentTransformation, nop ), - ( "full-laziness", Opt_FullLaziness, nop ), - ( "liberate-case", Opt_LiberateCase, nop ), - ( "spec-constr", Opt_SpecConstr, nop ), - ( "cse", Opt_CSE, nop ), - ( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas, nop ), - ( "omit-interface-pragmas", Opt_OmitInterfacePragmas, nop ), - ( "expose-all-unfoldings", Opt_ExposeAllUnfoldings, nop ), - ( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion, nop ), - ( "ignore-asserts", Opt_IgnoreAsserts, nop ), - ( "do-eta-reduction", Opt_DoEtaReduction, nop ), - ( "case-merge", Opt_CaseMerge, nop ), - ( "unbox-strict-fields", Opt_UnboxStrictFields, nop ), - ( "method-sharing", Opt_MethodSharing, + ( "warn-dodgy-foreign-imports", AlwaysAllowed, Opt_WarnDodgyForeignImports, nop ), + ( "warn-dodgy-exports", AlwaysAllowed, Opt_WarnDodgyExports, nop ), + ( "warn-dodgy-imports", AlwaysAllowed, Opt_WarnDodgyImports, nop ), + ( "warn-duplicate-exports", AlwaysAllowed, Opt_WarnDuplicateExports, nop ), + ( "warn-hi-shadowing", AlwaysAllowed, Opt_WarnHiShadows, nop ), + ( "warn-implicit-prelude", AlwaysAllowed, Opt_WarnImplicitPrelude, nop ), + ( "warn-incomplete-patterns", AlwaysAllowed, Opt_WarnIncompletePatterns, nop ), + ( "warn-incomplete-uni-patterns", AlwaysAllowed, Opt_WarnIncompleteUniPatterns, nop ), + ( "warn-incomplete-record-updates", AlwaysAllowed, Opt_WarnIncompletePatternsRecUpd, nop ), + ( "warn-missing-fields", AlwaysAllowed, Opt_WarnMissingFields, nop ), + ( "warn-missing-import-lists", AlwaysAllowed, Opt_WarnMissingImportList, nop ), + ( "warn-missing-methods", AlwaysAllowed, Opt_WarnMissingMethods, nop ), + ( "warn-missing-signatures", AlwaysAllowed, Opt_WarnMissingSigs, nop ), + ( "warn-missing-local-sigs", AlwaysAllowed, Opt_WarnMissingLocalSigs, nop ), + ( "warn-name-shadowing", AlwaysAllowed, Opt_WarnNameShadowing, nop ), + ( "warn-overlapping-patterns", AlwaysAllowed, Opt_WarnOverlappingPatterns, nop ), + ( "warn-type-defaults", AlwaysAllowed, Opt_WarnTypeDefaults, nop ), + ( "warn-monomorphism-restriction", AlwaysAllowed, Opt_WarnMonomorphism, nop ), + ( "warn-unused-binds", AlwaysAllowed, Opt_WarnUnusedBinds, nop ), + ( "warn-unused-imports", AlwaysAllowed, Opt_WarnUnusedImports, nop ), + ( "warn-unused-matches", AlwaysAllowed, Opt_WarnUnusedMatches, nop ), + ( "warn-warnings-deprecations", AlwaysAllowed, Opt_WarnWarningsDeprecations, nop ), + ( "warn-deprecations", AlwaysAllowed, Opt_WarnWarningsDeprecations, nop ), + ( "warn-deprecated-flags", AlwaysAllowed, Opt_WarnDeprecatedFlags, nop ), + ( "warn-orphans", AlwaysAllowed, Opt_WarnOrphans, nop ), + ( "warn-identities", AlwaysAllowed, Opt_WarnIdentities, nop ), + ( "warn-auto-orphans", AlwaysAllowed, Opt_WarnAutoOrphans, nop ), + ( "warn-tabs", AlwaysAllowed, Opt_WarnTabs, nop ), + ( "warn-unrecognised-pragmas", AlwaysAllowed, Opt_WarnUnrecognisedPragmas, nop ), + ( "warn-lazy-unlifted-bindings", AlwaysAllowed, Opt_WarnLazyUnliftedBindings, nop), + ( "warn-unused-do-bind", AlwaysAllowed, Opt_WarnUnusedDoBind, nop ), + ( "warn-wrong-do-bind", AlwaysAllowed, Opt_WarnWrongDoBind, nop ), + ( "warn-alternative-layout-rule-transitional", AlwaysAllowed, Opt_WarnAlternativeLayoutRuleTransitional, nop ), + ( "print-explicit-foralls", AlwaysAllowed, Opt_PrintExplicitForalls, nop ), + ( "strictness", AlwaysAllowed, Opt_Strictness, nop ), + ( "specialise", AlwaysAllowed, Opt_Specialise, nop ), + ( "float-in", AlwaysAllowed, Opt_FloatIn, nop ), + ( "static-argument-transformation", AlwaysAllowed, Opt_StaticArgumentTransformation, nop ), + ( "full-laziness", AlwaysAllowed, Opt_FullLaziness, nop ), + ( "liberate-case", AlwaysAllowed, Opt_LiberateCase, nop ), + ( "spec-constr", AlwaysAllowed, Opt_SpecConstr, nop ), + ( "cse", AlwaysAllowed, Opt_CSE, nop ), + ( "ignore-interface-pragmas", AlwaysAllowed, Opt_IgnoreInterfacePragmas, nop ), + ( "omit-interface-pragmas", AlwaysAllowed, Opt_OmitInterfacePragmas, nop ), + ( "expose-all-unfoldings", AlwaysAllowed, Opt_ExposeAllUnfoldings, nop ), + ( "do-lambda-eta-expansion", AlwaysAllowed, Opt_DoLambdaEtaExpansion, nop ), + ( "ignore-asserts", AlwaysAllowed, Opt_IgnoreAsserts, nop ), + ( "do-eta-reduction", AlwaysAllowed, Opt_DoEtaReduction, nop ), + ( "case-merge", AlwaysAllowed, Opt_CaseMerge, nop ), + ( "unbox-strict-fields", AlwaysAllowed, Opt_UnboxStrictFields, nop ), + ( "method-sharing", AlwaysAllowed, Opt_MethodSharing, \_ -> deprecate "doesn't do anything any more"), -- Remove altogether in GHC 7.2 - ( "dicts-cheap", Opt_DictsCheap, nop ), - ( "excess-precision", Opt_ExcessPrecision, nop ), - ( "eager-blackholing", Opt_EagerBlackHoling, nop ), - ( "print-bind-result", Opt_PrintBindResult, nop ), - ( "force-recomp", Opt_ForceRecomp, nop ), - ( "hpc-no-auto", Opt_Hpc_No_Auto, nop ), - ( "rewrite-rules", Opt_EnableRewriteRules, useInstead "enable-rewrite-rules" ), - ( "enable-rewrite-rules", Opt_EnableRewriteRules, nop ), - ( "break-on-exception", Opt_BreakOnException, nop ), - ( "break-on-error", Opt_BreakOnError, nop ), - ( "print-evld-with-show", Opt_PrintEvldWithShow, nop ), - ( "print-bind-contents", Opt_PrintBindContents, nop ), - ( "run-cps", Opt_RunCPS, nop ), - ( "run-cpsz", Opt_RunCPSZ, nop ), - ( "new-codegen", Opt_TryNewCodeGen, nop ), - ( "convert-to-zipper-and-back", Opt_ConvertToZipCfgAndBack, nop ), - ( "vectorise", Opt_Vectorise, nop ), - ( "regs-graph", Opt_RegsGraph, nop ), - ( "regs-iterative", Opt_RegsIterative, nop ), - ( "gen-manifest", Opt_GenManifest, nop ), - ( "embed-manifest", Opt_EmbedManifest, nop ), - ( "ext-core", Opt_EmitExternalCore, nop ), - ( "shared-implib", Opt_SharedImplib, nop ), - ( "ghci-sandbox", Opt_GhciSandbox, nop ), - ( "helpful-errors", Opt_HelpfulErrors, nop ), - ( "building-cabal-package", Opt_BuildingCabalPackage, nop ), - ( "implicit-import-qualified", Opt_ImplicitImportQualified, nop ) + ( "dicts-cheap", AlwaysAllowed, Opt_DictsCheap, nop ), + ( "excess-precision", AlwaysAllowed, Opt_ExcessPrecision, nop ), + ( "eager-blackholing", AlwaysAllowed, Opt_EagerBlackHoling, nop ), + ( "print-bind-result", AlwaysAllowed, Opt_PrintBindResult, nop ), + ( "force-recomp", AlwaysAllowed, Opt_ForceRecomp, nop ), + ( "hpc-no-auto", AlwaysAllowed, Opt_Hpc_No_Auto, nop ), + ( "rewrite-rules", AlwaysAllowed, Opt_EnableRewriteRules, useInstead "enable-rewrite-rules" ), + ( "enable-rewrite-rules", AlwaysAllowed, Opt_EnableRewriteRules, nop ), + ( "break-on-exception", AlwaysAllowed, Opt_BreakOnException, nop ), + ( "break-on-error", AlwaysAllowed, Opt_BreakOnError, nop ), + ( "print-evld-with-show", AlwaysAllowed, Opt_PrintEvldWithShow, nop ), + ( "print-bind-contents", AlwaysAllowed, Opt_PrintBindContents, nop ), + ( "run-cps", AlwaysAllowed, Opt_RunCPS, nop ), + ( "run-cpsz", AlwaysAllowed, Opt_RunCPSZ, nop ), + ( "new-codegen", AlwaysAllowed, Opt_TryNewCodeGen, nop ), + ( "convert-to-zipper-and-back", AlwaysAllowed, Opt_ConvertToZipCfgAndBack, nop ), + ( "vectorise", AlwaysAllowed, Opt_Vectorise, nop ), + ( "regs-graph", AlwaysAllowed, Opt_RegsGraph, nop ), + ( "regs-iterative", AlwaysAllowed, Opt_RegsIterative, nop ), + ( "gen-manifest", AlwaysAllowed, Opt_GenManifest, nop ), + ( "embed-manifest", AlwaysAllowed, Opt_EmbedManifest, nop ), + ( "ext-core", AlwaysAllowed, Opt_EmitExternalCore, nop ), + ( "shared-implib", AlwaysAllowed, Opt_SharedImplib, nop ), + ( "ghci-sandbox", AlwaysAllowed, Opt_GhciSandbox, nop ), + ( "helpful-errors", AlwaysAllowed, Opt_HelpfulErrors, nop ), + ( "building-cabal-package", AlwaysAllowed, Opt_BuildingCabalPackage, nop ), + ( "implicit-import-qualified", AlwaysAllowed, Opt_ImplicitImportQualified, nop ) ] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ fLangFlags :: [FlagSpec ExtensionFlag] fLangFlags = [ - ( "th", Opt_TemplateHaskell, + ( "th", NeverAllowed, Opt_TemplateHaskell, deprecatedForExtension "TemplateHaskell" >> checkTemplateHaskellOk ), - ( "fi", Opt_ForeignFunctionInterface, + ( "fi", RestrictedFunction, Opt_ForeignFunctionInterface, deprecatedForExtension "ForeignFunctionInterface" ), - ( "ffi", Opt_ForeignFunctionInterface, + ( "ffi", RestrictedFunction, Opt_ForeignFunctionInterface, deprecatedForExtension "ForeignFunctionInterface" ), - ( "arrows", Opt_Arrows, + ( "arrows", AlwaysAllowed, Opt_Arrows, deprecatedForExtension "Arrows" ), - ( "generics", Opt_Generics, + ( "generics", AlwaysAllowed, Opt_Generics, deprecatedForExtension "Generics" ), - ( "implicit-prelude", Opt_ImplicitPrelude, + ( "implicit-prelude", AlwaysAllowed, Opt_ImplicitPrelude, deprecatedForExtension "ImplicitPrelude" ), - ( "bang-patterns", Opt_BangPatterns, + ( "bang-patterns", AlwaysAllowed, Opt_BangPatterns, deprecatedForExtension "BangPatterns" ), - ( "monomorphism-restriction", Opt_MonomorphismRestriction, + ( "monomorphism-restriction", AlwaysAllowed, Opt_MonomorphismRestriction, deprecatedForExtension "MonomorphismRestriction" ), - ( "mono-pat-binds", Opt_MonoPatBinds, + ( "mono-pat-binds", AlwaysAllowed, Opt_MonoPatBinds, deprecatedForExtension "MonoPatBinds" ), - ( "extended-default-rules", Opt_ExtendedDefaultRules, + ( "extended-default-rules", AlwaysAllowed, Opt_ExtendedDefaultRules, deprecatedForExtension "ExtendedDefaultRules" ), - ( "implicit-params", Opt_ImplicitParams, + ( "implicit-params", AlwaysAllowed, Opt_ImplicitParams, deprecatedForExtension "ImplicitParams" ), - ( "scoped-type-variables", Opt_ScopedTypeVariables, + ( "scoped-type-variables", AlwaysAllowed, Opt_ScopedTypeVariables, deprecatedForExtension "ScopedTypeVariables" ), - ( "parr", Opt_ParallelArrays, + ( "parr", AlwaysAllowed, Opt_ParallelArrays, deprecatedForExtension "ParallelArrays" ), - ( "PArr", Opt_ParallelArrays, + ( "PArr", AlwaysAllowed, Opt_ParallelArrays, deprecatedForExtension "ParallelArrays" ), - ( "allow-overlapping-instances", Opt_OverlappingInstances, + ( "allow-overlapping-instances", RestrictedFunction, Opt_OverlappingInstances, deprecatedForExtension "OverlappingInstances" ), - ( "allow-undecidable-instances", Opt_UndecidableInstances, + ( "allow-undecidable-instances", AlwaysAllowed, Opt_UndecidableInstances, deprecatedForExtension "UndecidableInstances" ), - ( "allow-incoherent-instances", Opt_IncoherentInstances, + ( "allow-incoherent-instances", AlwaysAllowed, Opt_IncoherentInstances, deprecatedForExtension "IncoherentInstances" ) ] supportedLanguages :: [String] -supportedLanguages = [ name | (name, _, _) <- languageFlags ] +supportedLanguages = [ name | (name, _, _, _) <- languageFlags ] + +supportedLanguageOverlays :: [String] +supportedLanguageOverlays = [ name | (name, _, _, _) <- safeHaskellFlags ] supportedExtensions :: [String] -supportedExtensions = [ name' | (name, _, _) <- xFlags, name' <- [name, "No" ++ name] ] +supportedExtensions = [ name' | (name, _, _, _) <- xFlags, name' <- [name, "No" ++ name] ] supportedLanguagesAndExtensions :: [String] -supportedLanguagesAndExtensions = supportedLanguages ++ supportedExtensions +supportedLanguagesAndExtensions = + supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions -- | These -X<blah> flags cannot be reversed with -XNo<blah> languageFlags :: [FlagSpec Language] languageFlags = [ - ( "Haskell98", Haskell98, nop ), - ( "Haskell2010", Haskell2010, nop ) + ( "Haskell98", AlwaysAllowed, Haskell98, nop ), + ( "Haskell2010", AlwaysAllowed, Haskell2010, nop ) ] +-- | These -X<blah> flags cannot be reversed with -XNo<blah> +-- They are used to place hard requirements on what GHC Haskell language +-- features can be used. +safeHaskellFlags :: [FlagSpec SafeHaskellMode] +safeHaskellFlags = [mkF Sf_SafeImports, mkF' Sf_SafeLanguage, + mkF Sf_Trustworthy, mkF' Sf_Safe] + where mkF flag = (showPpr flag, AlwaysAllowed, flag, nop) + mkF' flag = (showPpr flag, EnablesSafe, flag, nop) + -- | These -X<blah> flags can all be reversed with -XNo<blah> xFlags :: [FlagSpec ExtensionFlag] xFlags = [ - ( "CPP", Opt_Cpp, nop ), - ( "PostfixOperators", Opt_PostfixOperators, nop ), - ( "TupleSections", Opt_TupleSections, nop ), - ( "PatternGuards", Opt_PatternGuards, nop ), - ( "UnicodeSyntax", Opt_UnicodeSyntax, nop ), - ( "MagicHash", Opt_MagicHash, nop ), - ( "PolymorphicComponents", Opt_PolymorphicComponents, nop ), - ( "ExistentialQuantification", Opt_ExistentialQuantification, nop ), - ( "KindSignatures", Opt_KindSignatures, nop ), - ( "EmptyDataDecls", Opt_EmptyDataDecls, nop ), - ( "ParallelListComp", Opt_ParallelListComp, nop ), - ( "TransformListComp", Opt_TransformListComp, nop ), - ( "MonadComprehensions", Opt_MonadComprehensions, nop), - ( "ForeignFunctionInterface", Opt_ForeignFunctionInterface, nop ), - ( "UnliftedFFITypes", Opt_UnliftedFFITypes, nop ), - ( "GHCForeignImportPrim", Opt_GHCForeignImportPrim, nop ), - ( "LiberalTypeSynonyms", Opt_LiberalTypeSynonyms, nop ), - ( "Rank2Types", Opt_Rank2Types, nop ), - ( "RankNTypes", Opt_RankNTypes, nop ), - ( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop), - ( "TypeOperators", Opt_TypeOperators, nop ), - ( "RecursiveDo", Opt_RecursiveDo, -- Enables 'mdo' + ( "CPP", AlwaysAllowed, Opt_Cpp, nop ), + ( "PostfixOperators", AlwaysAllowed, Opt_PostfixOperators, nop ), + ( "TupleSections", AlwaysAllowed, Opt_TupleSections, nop ), + ( "PatternGuards", AlwaysAllowed, Opt_PatternGuards, nop ), + ( "UnicodeSyntax", AlwaysAllowed, Opt_UnicodeSyntax, nop ), + ( "MagicHash", AlwaysAllowed, Opt_MagicHash, nop ), + ( "PolymorphicComponents", AlwaysAllowed, Opt_PolymorphicComponents, nop ), + ( "ExistentialQuantification", AlwaysAllowed, Opt_ExistentialQuantification, nop ), + ( "KindSignatures", AlwaysAllowed, Opt_KindSignatures, nop ), + ( "EmptyDataDecls", AlwaysAllowed, Opt_EmptyDataDecls, nop ), + ( "ParallelListComp", AlwaysAllowed, Opt_ParallelListComp, nop ), + ( "TransformListComp", AlwaysAllowed, Opt_TransformListComp, nop ), + ( "MonadComprehensions", AlwaysAllowed, Opt_MonadComprehensions, nop), + ( "ForeignFunctionInterface", RestrictedFunction, Opt_ForeignFunctionInterface, nop ), + ( "UnliftedFFITypes", AlwaysAllowed, Opt_UnliftedFFITypes, nop ), + ( "GHCForeignImportPrim", AlwaysAllowed, Opt_GHCForeignImportPrim, nop ), + ( "LiberalTypeSynonyms", AlwaysAllowed, Opt_LiberalTypeSynonyms, nop ), + ( "Rank2Types", AlwaysAllowed, Opt_Rank2Types, nop ), + ( "RankNTypes", AlwaysAllowed, Opt_RankNTypes, nop ), + ( "ImpredicativeTypes", AlwaysAllowed, Opt_ImpredicativeTypes, nop), + ( "TypeOperators", AlwaysAllowed, Opt_TypeOperators, nop ), + ( "RecursiveDo", AlwaysAllowed, Opt_RecursiveDo, -- Enables 'mdo' deprecatedForExtension "DoRec"), - ( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword - ( "Arrows", Opt_Arrows, nop ), - ( "ParallelArrays", Opt_ParallelArrays, nop ), - ( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ), - ( "QuasiQuotes", Opt_QuasiQuotes, nop ), - ( "Generics", Opt_Generics, + ( "DoRec", AlwaysAllowed, Opt_DoRec, nop ), -- Enables 'rec' keyword + ( "Arrows", AlwaysAllowed, Opt_Arrows, nop ), + ( "ParallelArrays", AlwaysAllowed, Opt_ParallelArrays, nop ), + ( "TemplateHaskell", NeverAllowed, Opt_TemplateHaskell, checkTemplateHaskellOk ), + ( "QuasiQuotes", AlwaysAllowed, Opt_QuasiQuotes, nop ), + ( "Generics", AlwaysAllowed, Opt_Generics, \ _ -> deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support." ), - ( "ImplicitPrelude", Opt_ImplicitPrelude, nop ), - ( "RecordWildCards", Opt_RecordWildCards, nop ), - ( "NamedFieldPuns", Opt_RecordPuns, nop ), - ( "RecordPuns", Opt_RecordPuns, + ( "ImplicitPrelude", AlwaysAllowed, Opt_ImplicitPrelude, nop ), + ( "RecordWildCards", AlwaysAllowed, Opt_RecordWildCards, nop ), + ( "NamedFieldPuns", AlwaysAllowed, Opt_RecordPuns, nop ), + ( "RecordPuns", AlwaysAllowed, Opt_RecordPuns, deprecatedForExtension "NamedFieldPuns" ), - ( "DisambiguateRecordFields", Opt_DisambiguateRecordFields, nop ), - ( "OverloadedStrings", Opt_OverloadedStrings, nop ), - ( "GADTs", Opt_GADTs, nop ), - ( "GADTSyntax", Opt_GADTSyntax, nop ), - ( "ViewPatterns", Opt_ViewPatterns, nop ), - ( "TypeFamilies", Opt_TypeFamilies, nop ), - ( "BangPatterns", Opt_BangPatterns, nop ), - ( "MonomorphismRestriction", Opt_MonomorphismRestriction, nop ), - ( "NPlusKPatterns", Opt_NPlusKPatterns, nop ), - ( "DoAndIfThenElse", Opt_DoAndIfThenElse, nop ), - ( "RebindableSyntax", Opt_RebindableSyntax, nop ), - ( "MonoPatBinds", Opt_MonoPatBinds, nop ), - ( "ExplicitForAll", Opt_ExplicitForAll, nop ), - ( "AlternativeLayoutRule", Opt_AlternativeLayoutRule, nop ), - ( "AlternativeLayoutRuleTransitional",Opt_AlternativeLayoutRuleTransitional, nop ), - ( "DatatypeContexts", Opt_DatatypeContexts, nop ), - ( "NondecreasingIndentation", Opt_NondecreasingIndentation, nop ), - ( "RelaxedLayout", Opt_RelaxedLayout, nop ), - ( "MonoLocalBinds", Opt_MonoLocalBinds, nop ), - ( "RelaxedPolyRec", Opt_RelaxedPolyRec, + ( "DisambiguateRecordFields", AlwaysAllowed, Opt_DisambiguateRecordFields, nop ), + ( "OverloadedStrings", AlwaysAllowed, Opt_OverloadedStrings, nop ), + ( "GADTs", AlwaysAllowed, Opt_GADTs, nop ), + ( "GADTSyntax", AlwaysAllowed, Opt_GADTSyntax, nop ), + ( "ViewPatterns", AlwaysAllowed, Opt_ViewPatterns, nop ), + ( "TypeFamilies", AlwaysAllowed, Opt_TypeFamilies, nop ), + ( "BangPatterns", AlwaysAllowed, Opt_BangPatterns, nop ), + ( "MonomorphismRestriction", AlwaysAllowed, Opt_MonomorphismRestriction, nop ), + ( "NPlusKPatterns", AlwaysAllowed, Opt_NPlusKPatterns, nop ), + ( "DoAndIfThenElse", AlwaysAllowed, Opt_DoAndIfThenElse, nop ), + ( "RebindableSyntax", AlwaysAllowed, Opt_RebindableSyntax, nop ), + ( "MonoPatBinds", AlwaysAllowed, Opt_MonoPatBinds, nop ), + ( "ExplicitForAll", AlwaysAllowed, Opt_ExplicitForAll, nop ), + ( "AlternativeLayoutRule", AlwaysAllowed, Opt_AlternativeLayoutRule, nop ), + ( "AlternativeLayoutRuleTransitional",AlwaysAllowed, Opt_AlternativeLayoutRuleTransitional, nop ), + ( "DatatypeContexts", AlwaysAllowed, Opt_DatatypeContexts, + \ turn_on -> when turn_on $ deprecate "It was widely considered a misfeature, and has been removed from the Haskell language." ), + ( "NondecreasingIndentation", AlwaysAllowed, Opt_NondecreasingIndentation, nop ), + ( "RelaxedLayout", AlwaysAllowed, Opt_RelaxedLayout, nop ), + ( "MonoLocalBinds", AlwaysAllowed, Opt_MonoLocalBinds, nop ), + ( "RelaxedPolyRec", AlwaysAllowed, Opt_RelaxedPolyRec, \ turn_on -> if not turn_on then deprecate "You can't turn off RelaxedPolyRec any more" else return () ), - ( "ExtendedDefaultRules", Opt_ExtendedDefaultRules, nop ), - ( "ImplicitParams", Opt_ImplicitParams, nop ), - ( "ScopedTypeVariables", Opt_ScopedTypeVariables, nop ), + ( "ExtendedDefaultRules", AlwaysAllowed, Opt_ExtendedDefaultRules, nop ), + ( "ImplicitParams", AlwaysAllowed, Opt_ImplicitParams, nop ), + ( "ScopedTypeVariables", AlwaysAllowed, Opt_ScopedTypeVariables, nop ), - ( "PatternSignatures", Opt_ScopedTypeVariables, + ( "PatternSignatures", AlwaysAllowed, Opt_ScopedTypeVariables, deprecatedForExtension "ScopedTypeVariables" ), - ( "UnboxedTuples", Opt_UnboxedTuples, nop ), - ( "StandaloneDeriving", Opt_StandaloneDeriving, nop ), - ( "DeriveDataTypeable", Opt_DeriveDataTypeable, nop ), - ( "DeriveFunctor", Opt_DeriveFunctor, nop ), - ( "DeriveTraversable", Opt_DeriveTraversable, nop ), - ( "DeriveFoldable", Opt_DeriveFoldable, nop ), - ( "DeriveGeneric", Opt_DeriveGeneric, nop ), - ( "DefaultSignatures", Opt_DefaultSignatures, nop ), - ( "TypeSynonymInstances", Opt_TypeSynonymInstances, nop ), - ( "FlexibleContexts", Opt_FlexibleContexts, nop ), - ( "FlexibleInstances", Opt_FlexibleInstances, nop ), - ( "ConstrainedClassMethods", Opt_ConstrainedClassMethods, nop ), - ( "MultiParamTypeClasses", Opt_MultiParamTypeClasses, nop ), - ( "FunctionalDependencies", Opt_FunctionalDependencies, nop ), - ( "GeneralizedNewtypeDeriving", Opt_GeneralizedNewtypeDeriving, nop ), - ( "OverlappingInstances", Opt_OverlappingInstances, nop ), - ( "UndecidableInstances", Opt_UndecidableInstances, nop ), - ( "IncoherentInstances", Opt_IncoherentInstances, nop ), - ( "PackageImports", Opt_PackageImports, nop ) + ( "UnboxedTuples", AlwaysAllowed, Opt_UnboxedTuples, nop ), + ( "StandaloneDeriving", AlwaysAllowed, Opt_StandaloneDeriving, nop ), + ( "DeriveDataTypeable", AlwaysAllowed, Opt_DeriveDataTypeable, nop ), + ( "DeriveFunctor", AlwaysAllowed, Opt_DeriveFunctor, nop ), + ( "DeriveTraversable", AlwaysAllowed, Opt_DeriveTraversable, nop ), + ( "DeriveFoldable", AlwaysAllowed, Opt_DeriveFoldable, nop ), + ( "DeriveGeneric", AlwaysAllowed, Opt_DeriveGeneric, nop ), + ( "DefaultSignatures", AlwaysAllowed, Opt_DefaultSignatures, nop ), + ( "TypeSynonymInstances", AlwaysAllowed, Opt_TypeSynonymInstances, nop ), + ( "FlexibleContexts", AlwaysAllowed, Opt_FlexibleContexts, nop ), + ( "FlexibleInstances", AlwaysAllowed, Opt_FlexibleInstances, nop ), + ( "ConstrainedClassMethods", AlwaysAllowed, Opt_ConstrainedClassMethods, nop ), + ( "MultiParamTypeClasses", AlwaysAllowed, Opt_MultiParamTypeClasses, nop ), + ( "FunctionalDependencies", AlwaysAllowed, Opt_FunctionalDependencies, nop ), + ( "GeneralizedNewtypeDeriving", AlwaysAllowed, Opt_GeneralizedNewtypeDeriving, nop ), + ( "OverlappingInstances", RestrictedFunction, Opt_OverlappingInstances, nop ), + ( "UndecidableInstances", AlwaysAllowed, Opt_UndecidableInstances, nop ), + ( "IncoherentInstances", AlwaysAllowed, Opt_IncoherentInstances, nop ), + ( "PackageImports", AlwaysAllowed, Opt_PackageImports, nop ) ] defaultFlags :: [DynFlag] @@ -2046,7 +2214,8 @@ addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes extraPkgConf_ :: FilePath -> DynP () extraPkgConf_ p = upd (\s -> s{ extraPkgConfs = p : extraPkgConfs s }) -exposePackage, exposePackageId, hidePackage, ignorePackage :: String -> DynP () +exposePackage, exposePackageId, hidePackage, ignorePackage, + trustPackage, distrustPackage :: String -> DynP () exposePackage p = upd (\s -> s{ packageFlags = ExposePackage p : packageFlags s }) exposePackageId p = @@ -2055,6 +2224,10 @@ hidePackage p = upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) ignorePackage p = upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s }) +trustPackage p = exposePackage p >> -- both trust and distrust also expose a package + upd (\s -> s{ packageFlags = TrustPackage p : packageFlags s }) +distrustPackage p = exposePackage p >> + upd (\s -> s{ packageFlags = DistrustPackage p : packageFlags s }) setPackageName :: String -> DynFlags -> DynFlags setPackageName p s = s{ thisPackage = stringToPackageId p } diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs new file mode 100644 index 0000000000..5c7f6c7f0a --- /dev/null +++ b/compiler/main/DynamicLoading.hs @@ -0,0 +1,150 @@ +-- | Dynamically lookup up values from modules and loading them. +module DynamicLoading ( +#ifdef GHCI + -- * Force loading information + forceLoadModuleInterfaces, + forceLoadNameModuleInterface, + forceLoadTyCon, + + -- * Finding names + lookupRdrNameInModule, + + -- * Loading values + getValueSafely, + lessUnsafeCoerce +#endif + ) where + +#ifdef GHCI +import Linker ( linkModule, getHValue, lessUnsafeCoerce ) +import OccName ( occNameSpace ) +import Name ( nameOccName ) +import SrcLoc ( noSrcSpan ) +import Finder ( findImportedModule, cannotFindModule ) +import DriverPhases ( HscSource(HsSrcFile) ) +import TcRnDriver ( getModuleExports ) +import TcRnMonad ( initTc, initIfaceTcRn ) +import LoadIface ( loadUserInterface ) +import RdrName ( RdrName, Provenance(..), ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), + mkGlobalRdrEnv, lookupGRE_RdrName, gre_name, rdrNameSpace ) +import RnNames ( gresFromAvails ) +import PrelNames ( iNTERACTIVE ) + +import HscTypes ( HscEnv(..), FindResult(..), lookupTypeHscEnv ) +import TypeRep ( TyThing(..), pprTyThingCategory ) +import Type ( Type, eqType ) +import TyCon ( TyCon ) +import Name ( Name, nameModule_maybe ) +import Id ( idType ) +import Module ( Module, ModuleName ) +import Panic ( GhcException(..), throwGhcException ) +import FastString +import Outputable + +import Data.Maybe ( mapMaybe ) + + +-- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used +-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. +forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO () +forceLoadModuleInterfaces hsc_env doc modules + = (initTc hsc_env HsSrcFile False iNTERACTIVE $ initIfaceTcRn $ mapM_ (loadUserInterface False doc) modules) >> return () + +-- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used +-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. +forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO () +forceLoadNameModuleInterface hsc_env reason name = do + let name_modules = mapMaybe nameModule_maybe [name] + forceLoadModuleInterfaces hsc_env reason name_modules + +-- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if: +-- +-- * The interface could not be loaded +-- * The name is not that of a 'TyCon' +-- * The name did not exist in the loaded module +forceLoadTyCon :: HscEnv -> Name -> IO TyCon +forceLoadTyCon hsc_env con_name = do + forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of loadTyConTy")) con_name + + mb_con_thing <- lookupTypeHscEnv hsc_env con_name + case mb_con_thing of + Nothing -> throwCmdLineErrorS $ missingTyThingError con_name + Just (ATyCon tycon) -> return tycon + Just con_thing -> throwCmdLineErrorS $ wrongTyThingError con_name con_thing + +-- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety +-- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at! +-- +-- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception: +-- +-- * If we could not load the names module +-- * If the thing being loaded is not a value +-- * If the Name does not exist in the module +-- * If the link failed + +getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a) +getValueSafely hsc_env val_name expected_type = do + forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of getValueSafely")) val_name + + -- Now look up the names for the value and type constructor in the type environment + mb_val_thing <- lookupTypeHscEnv hsc_env val_name + case mb_val_thing of + Nothing -> throwCmdLineErrorS $ missingTyThingError val_name + Just (AnId id) -> do + -- Check the value type in the interface against the type recovered from the type constructor + -- before finally casting the value to the type we assume corresponds to that constructor + if expected_type `eqType` idType id + then do + -- Link in the module that contains the value, if it has such a module + case nameModule_maybe val_name of + Just mod -> do linkModule hsc_env mod + return () + Nothing -> return () + -- Find the value that we just linked in and cast it given that we have proved it's type + hval <- getHValue hsc_env val_name + value <- lessUnsafeCoerce (hsc_dflags hsc_env) "getValueSafely" hval + return $ Just value + else return Nothing + Just val_thing -> throwCmdLineErrorS $ wrongTyThingError val_name val_thing + +-- | Finds the 'Name' corresponding to the given 'RdrName' in the context of the 'ModuleName'. Returns @Nothing@ if no +-- such 'Name' could be found. Any other condition results in an exception: +-- +-- * If the module could not be found +-- * If we could not determine the imports of the module +lookupRdrNameInModule :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name) +lookupRdrNameInModule hsc_env mod_name rdr_name = do + -- First find the package the module resides in by searching exposed packages and home modules + found_module <- findImportedModule hsc_env mod_name Nothing + case found_module of + Found _ mod -> do + -- Find the exports of the module + (_, mb_avail_info) <- getModuleExports hsc_env mod + case mb_avail_info of + Just avail_info -> do + -- Try and find the required name in the exports + let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, is_qual = False, is_dloc = noSrcSpan } + provenance = Imported [ImpSpec decl_spec ImpAll] + env = mkGlobalRdrEnv (gresFromAvails provenance avail_info) + case [name | gre <- lookupGRE_RdrName rdr_name env, let name = gre_name gre, rdrNameSpace rdr_name == occNameSpace (nameOccName name)] of + [name] -> return (Just name) + [] -> return Nothing + _ -> panic "lookupRdrNameInModule" + Nothing -> throwCmdLineErrorS $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name] + err -> throwCmdLineErrorS $ cannotFindModule dflags mod_name err + where + dflags = hsc_dflags hsc_env + + +wrongTyThingError :: Name -> TyThing -> SDoc +wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing] + +missingTyThingError :: Name -> SDoc +missingTyThingError name = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")] + +throwCmdLineErrorS :: SDoc -> IO a +throwCmdLineErrorS = throwCmdLineError . showSDoc + +throwCmdLineError :: String -> IO a +throwCmdLineError = throwGhcException . CmdLineError +#endif diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 5f7139cbf6..c8ca482784 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -67,9 +67,11 @@ module GHC ( modInfoInstances, modInfoIsExportedName, modInfoLookupName, + modInfoIface, lookupGlobalName, findGlobalAnns, mkPrintUnqualifiedForModule, + ModIface(..), -- * Querying the environment packageDbModules, @@ -460,6 +462,11 @@ setSessionDynFlags dflags = do return preload +parseDynamicFlags :: Monad m => + DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Located String]) +parseDynamicFlags = parseDynamicFlagsCmdLine + -- %************************************************************************ -- %* * @@ -598,7 +605,7 @@ instance ParsedMod TypecheckedModule where instance TypecheckedMod TypecheckedModule where renamedSource m = tm_renamed_source m typecheckedSource m = tm_typechecked_source m - moduleInfo m = tm_checked_module_info m + moduleInfo m = tm_checked_module_info m tm_internals m = tm_internals_ m -- | The result of successful desugaring (i.e., translation to core). Also @@ -686,9 +693,10 @@ typecheckModule pmod = do minf_type_env = md_types details, minf_exports = availsToNameSet $ md_exports details, minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), - minf_instances = md_insts details + minf_instances = md_insts details, + minf_iface = Nothing #ifdef GHCI - ,minf_modBreaks = emptyModBreaks + ,minf_modBreaks = emptyModBreaks #endif }} @@ -905,11 +913,11 @@ data ModuleInfo = ModuleInfo { minf_type_env :: TypeEnv, minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod - minf_instances :: [Instance] + minf_instances :: [Instance], + minf_iface :: Maybe ModIface #ifdef GHCI - ,minf_modBreaks :: ModBreaks + ,minf_modBreaks :: ModBreaks #endif - -- ToDo: this should really contain the ModIface too } -- We don't want HomeModInfo here, because a ModuleInfo applies -- to package modules too. @@ -919,7 +927,7 @@ getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X getModuleInfo mdl = withSession $ \hsc_env -> do let mg = hsc_mod_graph hsc_env if mdl `elem` map ms_mod mg - then liftIO $ getHomeModuleInfo hsc_env (moduleName mdl) + then liftIO $ getHomeModuleInfo hsc_env mdl else do {- if isHomeModule (hsc_dflags hsc_env) mdl then return Nothing @@ -940,7 +948,8 @@ getPackageModuleInfo hsc_env mdl = do case mb_avails of Nothing -> return Nothing Just avails -> do - eps <- readIORef (hsc_EPS hsc_env) + eps <- hscEPS hsc_env + iface <- lookupModuleIface hsc_env mdl let names = availsToNameSet avails pte = eps_PTE eps @@ -952,30 +961,42 @@ getPackageModuleInfo hsc_env mdl = do minf_exports = names, minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, minf_instances = error "getModuleInfo: instances for package module unimplemented", + minf_iface = iface, minf_modBreaks = emptyModBreaks })) #else +-- bogusly different for non-GHCI (ToDo) getPackageModuleInfo _hsc_env _mdl = do - -- bogusly different for non-GHCI (ToDo) return Nothing #endif -getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo) +getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl = - case lookupUFM (hsc_HPT hsc_env) mdl of + case lookupUFM (hsc_HPT hsc_env) (moduleName mdl) of Nothing -> return Nothing Just hmi -> do let details = hm_details hmi + iface <- lookupModuleIface hsc_env mdl return (Just (ModuleInfo { minf_type_env = md_types details, minf_exports = availsToNameSet (md_exports details), minf_rdr_env = mi_globals $! hm_iface hmi, - minf_instances = md_insts details + minf_instances = md_insts details, + minf_iface = iface #ifdef GHCI ,minf_modBreaks = getModBreaks hmi #endif })) +lookupModuleIface :: HscEnv -> Module -> IO (Maybe ModIface) +lookupModuleIface env m = do + eps <- hscEPS env + let dflags = hsc_dflags env + pkgIfaceT = eps_PIT eps + homePkgT = hsc_HPT env + iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m + return iface + -- | The list of top-level entities defined in a module modInfoTyThings :: ModuleInfo -> [TyThing] modInfoTyThings minf = typeEnvElts (minf_type_env minf) @@ -1012,6 +1033,9 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do return $! lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name +modInfoIface :: ModuleInfo -> Maybe ModIface +modInfoIface = minf_iface + #ifdef GHCI modInfoModBreaks :: ModuleInfo -> ModBreaks modInfoModBreaks = minf_modBreaks diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index ab658942ac..8ccf0a5a81 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1408,7 +1408,7 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) let local_opts = getOptions dflags buf src_fn (dflags', leftovers, warns) - <- parseDynamicNoPackageFlags dflags local_opts + <- parseDynamicFilePragma dflags local_opts checkProcessArgsResult leftovers handleFlagWarnings dflags' warns @@ -1456,20 +1456,53 @@ multiRootsErr summs@(summ1:_) files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs cyclicModuleErr :: [ModSummary] -> SDoc +-- From a strongly connected component we find +-- a single cycle to report cyclicModuleErr ms - = hang (ptext (sLit "Module imports form a cycle for modules:")) - 2 (vcat (map show_one ms)) + = ASSERT( not (null ms) ) + hang (ptext (sLit "Module imports form a cycle:")) + 2 (show_path (shortest [] root_mod)) where - mods_in_cycle = map ms_mod_name ms - imp_modname = unLoc . ideclName . unLoc - just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname) - - show_one ms = - vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+> - maybe empty (parens . text) (ml_hs_file (ms_location ms)), - nest 2 $ ptext (sLit "imports:") <+> vcat [ - pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms), - pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ] - ] - show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src) - pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps) + deps :: [(ModuleName, [ModuleName])] + deps = [ (moduleName (ms_mod m), get_deps m) | m <- ms ] + + get_deps :: ModSummary -> [ModuleName] + get_deps m = filter (\k -> Map.member k dep_env) (map unLoc (ms_home_imps m)) + + dep_env :: Map.Map ModuleName [ModuleName] + dep_env = Map.fromList deps + + -- Find the module with fewest imports among the SCC modules + -- This is just a heuristic to find some plausible root module + root_mod :: ModuleName + root_mod = fst (minWith (length . snd) deps) + + shortest :: [ModuleName] -> ModuleName -> [ModuleName] + -- (shortest [v1,v2,..,vn] m) assumes that + -- m is imported by v1 + -- which is imported by v2 + -- ... + -- which is imported by vn + -- It retuns an import chain [w1, w2, ..wm] + -- where w1 imports w2 imports .... imports wm imports w1 + shortest visited m + | m `elem` visited + = m : reverse (takeWhile (/= m) visited) + | otherwise + = minWith length (map (shortest (m:visited)) deps) + where + Just deps = Map.lookup m dep_env + + show_path [] = panic "show_path" + show_path [m] = ptext (sLit "module") <+> quotes (ppr m) + <+> ptext (sLit "imports itself") + show_path (m1:m2:ms) = ptext (sLit "module") <+> quotes (ppr m1) + <+> sep ( nest 6 (ptext (sLit "imports") <+> quotes (ppr m2)) + : go ms) + where + go [] = [ptext (sLit "which imports") <+> quotes (ppr m1)] + go (m:ms) = (ptext (sLit "which imports") <+> quotes (ppr m)) : go ms + +minWith :: Ord b => (a -> b) -> [a] -> a +minWith get_key xs = ASSERT( not (null xs) ) + head (sortWith get_key xs) diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs new file mode 100644 index 0000000000..0fc87f0fd0 --- /dev/null +++ b/compiler/main/GhcPlugins.hs @@ -0,0 +1,83 @@ +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} + +-- | This module is not used by GHC itself. Rather, it exports all of +-- the functions and types you are likely to need when writing a +-- plugin for GHC. So authors of plugins can probably get away simply +-- with saying "import GhcPlugins". +-- +-- Particularly interesting modules for plugin writers include +-- "CoreSyn" and "CoreMonad". +module GhcPlugins( + module CoreMonad, + module RdrName, module OccName, module Name, module Var, module Id, module IdInfo, + module CoreSyn, module Literal, module DataCon, + module CoreUtils, module MkCore, module CoreFVs, module CoreSubst, + module Rules, module Annotations, + module DynFlags, module Packages, + module Module, module Type, module TyCon, module Coercion, + module TysWiredIn, module HscTypes, module BasicTypes, + module VarSet, module VarEnv, module NameSet, module NameEnv, + module UniqSet, module UniqFM, module FiniteMap, + module Util, module Serialized, module SrcLoc, module Outputable, + module UniqSupply, module Unique, module FastString, module FastTypes + ) where + +-- Plugin stuff itself +import CoreMonad + +-- Variable naming +import RdrName +import OccName hiding ( varName {- conflicts with Var.varName -} ) +import Name hiding ( varName {- reexport from OccName, conflicts with Var.varName -} ) +import Var +import Id hiding ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} ) +import IdInfo + +-- Core +import CoreSyn +import Literal +import DataCon +import CoreUtils +import MkCore +import CoreFVs +import CoreSubst + +-- Core "extras" +import Rules +import Annotations + +-- Pipeline-related stuff +import DynFlags +import Packages + +-- Important GHC types +import Module +import Type hiding {- conflict with CoreSubst -} + ( substTy, extendTvSubst, extendTvSubstList, isInScope ) +import Coercion hiding {- conflict with CoreSubst -} + ( substTy, extendTvSubst, substCo, substTyVarBndr, lookupTyVar ) +import TyCon +import TysWiredIn +import HscTypes +import BasicTypes hiding ( Version {- conflicts with Packages.Version -} ) + +-- Collections and maps +import VarSet +import VarEnv +import NameSet +import NameEnv +import UniqSet +import UniqFM +-- Conflicts with UniqFM: +--import LazyUniqFM +import FiniteMap + +-- Common utilities +import Util +import Serialized +import SrcLoc +import Outputable +import UniqSupply +import Unique ( Unique, Uniquable(..) ) +import FastString +import FastTypes diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 93ce824964..b07601bc0f 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -98,18 +98,19 @@ mkPrelImports this_mod implicit_prelude import_decls | otherwise = [preludeImportDecl] where explicit_prelude_import - = notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _) <- import_decls, + = notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _ _) <- import_decls, unLoc mod == pRELUDE_NAME ] preludeImportDecl :: LImportDecl RdrName preludeImportDecl = L loc $ - ImportDecl (L loc pRELUDE_NAME) - Nothing {- no specific package -} - False {- Not a boot interface -} - False {- Not qualified -} - Nothing {- No "as" -} - Nothing {- No import list -} + ImportDecl (L loc pRELUDE_NAME) + Nothing {- No specific package -} + False {- Not a boot interface -} + False {- Not a safe import -} + False {- Not qualified -} + Nothing {- No "as" -} + Nothing {- No import list -} loc = mkGeneralSrcSpan (fsLit "Implicit import declaration") diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 6542a06147..a8bb18d510 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -86,7 +86,8 @@ import Panic #endif import Id ( Id ) -import Module ( emptyModuleEnv, ModLocation(..), Module ) +import Module +import Packages import RdrName import HsSyn import CoreSyn @@ -118,7 +119,7 @@ import OldCmm ( Cmm ) import PprCmm ( pprCmms ) import CmmParse ( parseCmmFile ) import CmmBuildInfoTables -import CmmCPS +import CmmPipeline import CmmInfo import OptimizationFuel ( initOptFuelState ) import CmmCvt @@ -143,10 +144,9 @@ import UniqFM ( emptyUFM ) import UniqSupply ( initUs_ ) import Bag import Exception --- import MonadUtils import Control.Monad --- import System.IO +import Data.Maybe ( catMaybes ) import Data.IORef \end{code} #include "HsVersions.h" @@ -770,13 +770,170 @@ batchMsg hsc_env mb_mod_index recomp mod_summary -------------------------------------------------------------- hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv -hscFileFrontEnd mod_summary = - do rdr_module <- hscParse' mod_summary - hsc_env <- getHscEnv - {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ - tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module +hscFileFrontEnd mod_summary = do + rdr_module <- hscParse' mod_summary + hsc_env <- getHscEnv + tcg_env <- + {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ + tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module + dflags <- getDynFlags + -- XXX: See Note [SafeHaskell API] + if safeHaskellOn dflags + then do + tcg_env1 <- checkSafeImports dflags hsc_env tcg_env + if safeLanguageOn dflags + then do + -- we also nuke user written RULES. + logWarnings $ warns (tcg_rules tcg_env1) + return tcg_env1 { tcg_rules = [] } + else do + -- Wipe out trust required packages if the module isn't + -- trusted. Not doing this doesn't cause any problems + -- but means the hi file will say some pkgs should be + -- trusted when they don't need to be (since its an + -- untrusted module) and we don't force them to be. + let imps = tcg_imports tcg_env1 + imps' = imps { imp_trust_pkgs = [] } + return tcg_env1 { tcg_imports = imps' } + + else + return tcg_env + + where + warns rules = listToBag $ map warnRules rules + warnRules (L loc (HsRule n _ _ _ _ _ _)) = + mkPlainWarnMsg loc $ + text "Rule \"" <> ftext n <> text "\" ignored" $+$ + text "User defined rules are disabled under SafeHaskell" + +-------------------------------------------------------------- +-- SafeHaskell +-------------------------------------------------------------- +-- | Validate that safe imported modules are actually safe. +-- For modules in the HomePackage (the package the module we +-- are compiling in resides) this just involves checking its +-- trust type is 'Safe' or 'Trustworthy'. For modules that +-- reside in another package we also must check that the +-- external pacakge is trusted. +-- +-- Note [SafeHaskell API] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- XXX: We only call this in hscFileFrontend and don't expose +-- it to the GHC API. External users of GHC can't properly use +-- the GHC API and SafeHaskell. +checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv +checkSafeImports dflags hsc_env tcg_env + = do + imps <- mapM condense imports' + pkgs <- mapM checkSafe imps + checkPkgTrust pkg_reqs + + -- add in trusted package requirements for this module + let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs } + return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust } + + where + imp_info = tcg_imports tcg_env -- ImportAvails + imports = imp_mods imp_info -- ImportedMods + imports' = moduleEnvToList imports -- (Module, [ImportedModsVal]) + pkg_reqs = imp_trust_pkgs imp_info -- [PackageId] + + condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) + condense (_, []) = panic "HscMain.condense: Pattern match failure!" + condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs + return (m, l, s) + + -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) + cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal + cond' v1@(m1,_,l1,s1) (_,_,_,s2) + | s1 /= s2 + = liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l1 + (text "Module" <+> ppr m1 <+> (text $ "is imported" + ++ " both as a safe and unsafe import!")) + | otherwise + = return v1 + + lookup' :: Module -> Hsc (Maybe ModIface) + lookup' m = do + hsc_eps <- liftIO $ hscEPS hsc_env + let pkgIfaceT = eps_PIT hsc_eps + homePkgT = hsc_HPT hsc_env + iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m + return iface + + isHomePkg :: Module -> Bool + isHomePkg m + | thisPackage dflags == modulePackageId m = True + | otherwise = False + + -- | Check the package a module resides in is trusted. + -- Safe compiled modules are trusted without requiring + -- that their package is trusted. For trustworthy modules, + -- modules in the home package are trusted but otherwise + -- we check the package trust flag. + packageTrusted :: SafeHaskellMode -> Module -> Bool + packageTrusted Sf_Safe _ = True + packageTrusted _ m + | isHomePkg m = True + | otherwise = trusted $ getPackageDetails (pkgState dflags) + (modulePackageId m) + + -- Is a module trusted? Return Nothing if True, or a String + -- if it isn't, containing the reason it isn't + isModSafe :: Module -> SrcSpan -> Hsc (Maybe SDoc) + isModSafe m l = do + iface <- lookup' m + case iface of + -- can't load iface to check trust! + Nothing -> liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l + $ text "Can't load the interface file for" <+> ppr m <> + text ", to check that it can be safely imported" + + -- got iface, check trust + Just iface' -> do + let trust = getSafeMode $ mi_trust iface' + -- check module is trusted + safeM = trust `elem` [Sf_Safe, Sf_Trustworthy, + Sf_TrustworthyWithSafeLanguage] + -- check package is trusted + safeP = packageTrusted trust m + if safeM && safeP + then return Nothing + else return $ Just $ if safeM + then text "The package (" <> ppr (modulePackageId m) <> + text ") the module resides in isn't trusted." + else text "The module itself isn't safe." + + -- Here we check the transitive package trust requirements are OK still. + checkPkgTrust :: [PackageId] -> Hsc () + checkPkgTrust pkgs = do + case errors of + [] -> return () + _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors + where + errors = catMaybes $ map go pkgs + go pkg + | trusted $ getPackageDetails (pkgState dflags) pkg + = Nothing + | otherwise + = Just $ mkPlainErrMsg noSrcSpan + $ text "The package (" <> ppr pkg <> text ") is required" + <> text " to be trusted but it isn't!" + + checkSafe :: (Module, SrcSpan, IsSafeImport) -> Hsc (Maybe PackageId) + checkSafe (_, _, False) = return Nothing + checkSafe (m, l, True ) = do + module_safe <- isModSafe m l + case module_safe of + Nothing -> return pkg + Just s -> liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l + $ ppr m <+> text "can't be safely imported!" + <+> s + where pkg | isHomePkg m = Nothing + | otherwise = Just (modulePackageId m) + -------------------------------------------------------------- -- Simplifiers -------------------------------------------------------------- @@ -967,34 +1124,27 @@ hscCompileCmmFile hsc_env filename -------------------- Stuff for new code gen --------------------- tryNewCodeGen :: HscEnv -> Module -> [TyCon] - -> CollectedCCs - -> [(StgBinding,[(Id,[Id])])] - -> HpcInfo - -> IO [Cmm] + -> CollectedCCs + -> [(StgBinding,[(Id,[Id])])] + -> HpcInfo + -> IO [Cmm] tryNewCodeGen hsc_env this_mod data_tycons - cost_centre_info stg_binds hpc_info = - do { let dflags = hsc_dflags hsc_env + cost_centre_info stg_binds hpc_info = + do { let dflags = hsc_dflags hsc_env ; prog <- StgCmm.codeGen dflags this_mod data_tycons - cost_centre_info stg_binds hpc_info - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" - (pprCmms prog) - - ; prog <- return $ map runCmmContFlowOpts prog - -- Control flow optimisation + cost_centre_info stg_binds hpc_info + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" + (pprCmms prog) -- We are building a single SRT for the entire module, so -- we must thread it through all the procedures as we cps-convert them. ; us <- mkSplitUniqSupply 'S' - ; let topSRT = initUs_ us emptySRT - ; (topSRT, prog) <- foldM (protoCmmCPS hsc_env) (topSRT, []) prog - -- The main CPS conversion - - ; prog <- return $ map runCmmContFlowOpts (srtToData topSRT : prog) - -- Control flow optimisation, again + ; let initTopSRT = initUs_ us emptySRT + ; (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog - ; let prog' = map cmmOfZgraph prog - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog') - ; return prog' } + ; let prog' = map cmmOfZgraph (srtToData topSRT : prog) + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog') + ; return prog' } optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm] @@ -1014,15 +1164,17 @@ testCmmConversion hsc_env cmm = dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm) --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm us <- mkSplitUniqSupply 'C' - let cvtm = runCmmContFlowOpts `liftM` cmmToZgraph cmm - let zgraph = initUs_ us cvtm - us <- mkSplitUniqSupply 'S' - let topSRT = initUs_ us emptySRT - (_, [cps_zgraph]) <- protoCmmCPS hsc_env (topSRT, []) zgraph - let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph + let zgraph = initUs_ us (cmmToZgraph cmm) + chosen_graph <- + if dopt Opt_RunCPSZ dflags + then do us <- mkSplitUniqSupply 'S' + let topSRT = initUs_ us emptySRT + (_, [zgraph]) <- cmmPipeline hsc_env (topSRT, []) zgraph + return zgraph + else return (runCmmContFlowOpts zgraph) dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph) showPass dflags "Convert from Z back to Cmm" - let cvt = cmmOfZgraph $ runCmmContFlowOpts $ chosen_graph + let cvt = cmmOfZgraph chosen_graph dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt) return cvt diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs index d90262633c..76699a5f85 100644 --- a/compiler/main/HscStats.lhs +++ b/compiler/main/HscStats.lhs @@ -32,12 +32,13 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) [("ExportAll ", export_all), -- 1 if no export list ("ExportDecls ", export_ds), ("ExportModules ", export_ms), - ("Imports ", import_no), - (" ImpQual ", import_qual), - (" ImpAs ", import_as), - (" ImpAll ", import_all), - (" ImpPartial ", import_partial), - (" ImpHiding ", import_hiding), + ("Imports ", imp_no), + (" ImpSafe ", imp_safe), + (" ImpQual ", imp_qual), + (" ImpAs ", imp_as), + (" ImpAll ", imp_all), + (" ImpPartial ", imp_partial), + (" ImpHiding ", imp_hiding), ("FixityDecls ", fixity_sigs), ("DefaultDecls ", default_ds), ("TypeDecls ", type_ds), @@ -99,8 +100,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (val_bind_ds, fn_bind_ds) = foldr add2 (0,0) (map count_bind val_decls) - (import_no, import_qual, import_as, import_all, import_partial, import_hiding) - = foldr add6 (0,0,0,0,0,0) (map import_info imports) + (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding) + = foldr add7 (0,0,0,0,0,0,0) (map import_info imports) (data_constrs, data_derivs) = foldr add2 (0,0) (map data_info tycl_decls) (class_method_ds, default_method_ds) @@ -122,15 +123,16 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) sig_info (GenericSig _ _) = (0,0,0,0,1) sig_info _ = (0,0,0,0,0) - import_info (L _ (ImportDecl _ _ _ qual as spec)) - = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec) + import_info (L _ (ImportDecl _ _ _ safe qual as spec)) + = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) + safe_info = qual_info qual_info False = 0 qual_info True = 1 as_info Nothing = 0 as_info (Just _) = 1 - spec_info Nothing = (0,0,0,1,0,0) - spec_info (Just (False, _)) = (0,0,0,0,1,0) - spec_info (Just (True, _)) = (0,0,0,0,0,1) + spec_info Nothing = (0,0,0,0,1,0,0) + spec_info (Just (False, _)) = (0,0,0,0,0,1,0) + spec_info (Just (True, _)) = (0,0,0,0,0,0,1) data_info (TyData {tcdCons = cs, tcdDerivs = derivs}) = (length cs, case derivs of Nothing -> 0 @@ -160,12 +162,12 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) addpr :: (Int,Int) -> Int add2 :: (Int,Int) -> (Int,Int) -> (Int, Int) add5 :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int) - add6 :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int) + add7 :: (Int,Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int, Int) addpr (x,y) = x+y add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) - add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6) + add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7) \end{code} diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index ea0cd6357b..1edce70d08 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -15,7 +15,7 @@ module HscTypes ( -- * Information about modules ModDetails(..), emptyModDetails, ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, - ImportedMods, + ImportedMods, ImportedModsVal, ModSummary(..), ms_mod_name, showModMsg, isBootSummary, msHsFilePath, msHiFilePath, msObjFilePath, @@ -91,6 +91,10 @@ module HscTypes ( VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo, noIfaceVectInfo, + -- * Safe Haskell information + IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo, + trustInfoToNum, numToTrustInfo, IsSafeImport, + -- * Compilation errors and warnings SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, throwOneError, handleSourceError, @@ -127,7 +131,7 @@ import DataCon ( DataCon, dataConImplicitIds, dataConWrapId ) import PrelNames ( gHC_PRIM ) import Packages hiding ( Version(..) ) import DynFlags ( DynFlags(..), isOneShot, HscTarget (..), dopt, - DynFlag(..) ) + DynFlag(..), SafeHaskellMode(..) ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( IPName, defaultFixity, WarningTxt(..) ) import OptimizationFuel ( OptFuelState ) @@ -154,6 +158,7 @@ import Data.IORef import Data.Array ( Array, array ) import Data.List import Data.Map (Map) +import Data.Word import Control.Monad ( mplus, guard, liftM, when ) import Exception @@ -680,8 +685,10 @@ data ModIface -- isn't in decls. It's useful to know that when -- seeing if we are up to date wrt. the old interface. -- The 'OccName' is the parent of the name, if it has one. - mi_hpc :: !AnyHpcUsage + mi_hpc :: !AnyHpcUsage, -- ^ True if this program uses Hpc at any point in the program. + mi_trust :: !IfaceTrustInfo + -- ^ Safe Haskell Trust information for this module. } -- | The 'ModDetails' is essentially a cache for information in the 'ModIface' @@ -711,7 +718,9 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv, } -- | Records the modules directly imported by a module for extracting e.g. usage information -type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)] +type ImportedMods = ModuleEnv [ImportedModsVal] +type ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) + -- TODO: we are not actually using the codomain of this type at all, so it can be -- replaced with ModuleEnv () @@ -852,7 +861,8 @@ emptyModIface mod mi_warn_fn = emptyIfaceWarnCache, mi_fix_fn = emptyIfaceFixCache, mi_hash_fn = emptyIfaceHashCache, - mi_hpc = False + mi_hpc = False, + mi_trust = noIfaceTrustInfo } \end{code} @@ -1425,7 +1435,7 @@ type IsBootInterface = Bool data Dependencies = Deps { dep_mods :: [(ModuleName, IsBootInterface)] -- ^ Home-package module dependencies - , dep_pkgs :: [PackageId] + , dep_pkgs :: [(PackageId, Bool)] -- ^ External package dependencies , dep_orphs :: [Module] -- ^ Orphan modules (whether home or external pkg), @@ -1448,7 +1458,10 @@ data Usage = UsagePackageModule { usg_mod :: Module, -- ^ External package module depended on - usg_mod_hash :: Fingerprint + usg_mod_hash :: Fingerprint, + -- ^ Cached module fingerprint + usg_safe :: IsSafeImport + -- ^ Was this module imported as a safe import } -- ^ Module from another package | UsageHomeModule { usg_mod_name :: ModuleName, @@ -1459,9 +1472,11 @@ data Usage -- ^ Entities we depend on, sorted by occurrence name and fingerprinted. -- NB: usages are for parent names only, e.g. type constructors -- but not the associated data constructors. - usg_exports :: Maybe Fingerprint + usg_exports :: Maybe Fingerprint, -- ^ Fingerprint for the export list we used to depend on this module, -- if we depend on the export list + usg_safe :: IsSafeImport + -- ^ Was this module imported as a safe import } -- ^ Module from the current package deriving( Eq ) -- The export list field is (Just v) if we depend on the export list: @@ -1794,6 +1809,61 @@ noIfaceVectInfo = IfaceVectInfo [] [] [] [] [] %************************************************************************ %* * +\subsection{Safe Haskell Support} +%* * +%************************************************************************ + +This stuff here is related to supporting the Safe Haskell extension, +primarily about storing under what trust type a module has been compiled. + +\begin{code} +-- | Is an import a safe import? +type IsSafeImport = Bool + +-- | Safe Haskell information for 'ModIface' +-- Simply a wrapper around SafeHaskellMode to sepperate iface and flags +newtype IfaceTrustInfo = TrustInfo SafeHaskellMode + +getSafeMode :: IfaceTrustInfo -> SafeHaskellMode +getSafeMode (TrustInfo x) = x + +setSafeMode :: SafeHaskellMode -> IfaceTrustInfo +setSafeMode = TrustInfo + +noIfaceTrustInfo :: IfaceTrustInfo +noIfaceTrustInfo = setSafeMode Sf_None + +trustInfoToNum :: IfaceTrustInfo -> Word8 +trustInfoToNum it + = case getSafeMode it of + Sf_None -> 0 + Sf_SafeImports -> 1 + Sf_SafeLanguage -> 2 + Sf_Trustworthy -> 3 + Sf_TrustworthyWithSafeLanguage -> 4 + Sf_Safe -> 5 + +numToTrustInfo :: Word8 -> IfaceTrustInfo +numToTrustInfo 0 = setSafeMode Sf_None +numToTrustInfo 1 = setSafeMode Sf_SafeImports +numToTrustInfo 2 = setSafeMode Sf_SafeLanguage +numToTrustInfo 3 = setSafeMode Sf_Trustworthy +numToTrustInfo 4 = setSafeMode Sf_TrustworthyWithSafeLanguage +numToTrustInfo 5 = setSafeMode Sf_Safe +numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" + +instance Outputable IfaceTrustInfo where + ppr (TrustInfo Sf_None) = ptext $ sLit "none" + ppr (TrustInfo Sf_SafeImports) = ptext $ sLit "safe-imports" + ppr (TrustInfo Sf_SafeLanguage) = ptext $ sLit "safe-language" + ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy" + ppr (TrustInfo Sf_TrustworthyWithSafeLanguage) + = ptext $ sLit "trustworthy + safe-language" + ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe" +\end{code} + +%************************************************************************ +%* * \subsection{Linkable stuff} %* * %************************************************************************ diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index bb5fab6b9f..1df5255dbe 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -75,13 +75,16 @@ import System.Directory import Data.Dynamic import Data.List (find) import Control.Monad +#if __GLASGOW_HASKELL__ >= 701 +import Foreign.Safe +#else import Foreign hiding (unsafePerformIO) +#endif import Foreign.C import GHC.Exts import Data.Array import Exception import Control.Concurrent --- import Foreign.StablePtr import System.IO import System.IO.Unsafe diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 12316713d6..33858be1ff 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -171,7 +171,7 @@ initPackages :: DynFlags -> IO (DynFlags, [PackageId]) initPackages dflags = do pkg_db <- case pkgDatabase dflags of Nothing -> readPackageConfigs dflags - Just db -> return $ maybeHidePackages dflags db + Just db -> return $ setBatchPackageFlags dflags db (pkg_state, preload, this_pkg) <- mkPackageState dflags pkg_db [] (thisPackage dflags) return (dflags{ pkgDatabase = Just pkg_db, @@ -249,16 +249,23 @@ readPackageConfig dflags conf_file = do top_dir = topDir dflags pkgroot = takeDirectory conf_file pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs - pkg_configs2 = maybeHidePackages dflags pkg_configs1 + pkg_configs2 = setBatchPackageFlags dflags pkg_configs1 -- return pkg_configs2 -maybeHidePackages :: DynFlags -> [PackageConfig] -> [PackageConfig] -maybeHidePackages dflags pkgs - | dopt Opt_HideAllPackages dflags = map hide pkgs - | otherwise = pkgs +setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig] +setBatchPackageFlags dflags pkgs = (maybeDistrustAll . maybeHideAll) pkgs where + maybeHideAll pkgs' + | dopt Opt_HideAllPackages dflags = map hide pkgs' + | otherwise = pkgs' + + maybeDistrustAll pkgs' + | dopt Opt_DistrustAllPackages dflags = map distrust pkgs' + | otherwise = pkgs' + hide pkg = pkg{ exposed = False } + distrust pkg = pkg{ exposed = False } -- TODO: This code is duplicated in utils/ghc-pkg/Main.hs mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig @@ -344,6 +351,20 @@ applyPackageFlag unusable pkgs flag = Right (ps,qs) -> return (map hide ps ++ qs) where hide p = p {exposed=False} + -- we trust all matching packages. Maybe should only trust first one? + -- and leave others the same or set them untrusted + TrustPackage str -> + case selectPackages (matchingStr str) pkgs unusable of + Left ps -> packageFlagErr flag ps + Right (ps,qs) -> return (map trust ps ++ qs) + where trust p = p {trusted=True} + + DistrustPackage str -> + case selectPackages (matchingStr str) pkgs unusable of + Left ps -> packageFlagErr flag ps + Right (ps,qs) -> return (map distrust ps ++ qs) + where distrust p = p {trusted=False} + _ -> panic "applyPackageFlag" where @@ -407,6 +428,8 @@ packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err)) HidePackage p -> text "-hide-package " <> text p ExposePackage p -> text "-package " <> text p ExposePackageId p -> text "-package-id " <> text p + TrustPackage p -> text "-trust " <> text p + DistrustPackage p -> text "-distrust " <> text p ppr_reasons = vcat (map ppr_reason reasons) ppr_reason (p, reason) = pprReason (pprIPkg p <+> text "is") reason diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 5767a52552..c63f070608 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -50,7 +50,7 @@ parseStaticFlags args = do ready <- readIORef v_opt_C_ready when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession") - (leftover, errs, warns1) <- processArgs static_flags args + (leftover, errs, warns1) <- processArgs static_flags args CmdLineOnly True when (not (null errs)) $ ghcError $ errorsToGhcException errs -- deal with the way flags: the way (eg. prof) gives rise to @@ -62,7 +62,8 @@ parseStaticFlags args = do let unreg_flags | cGhcUnregisterised == "YES" = unregFlags | otherwise = [] - (more_leftover, errs, warns2) <- processArgs static_flags (unreg_flags ++ way_flags') + (more_leftover, errs, warns2) <- + processArgs static_flags (unreg_flags ++ way_flags') CmdLineOnly True -- see sanity code in staticOpts writeIORef v_opt_C_ready True @@ -103,65 +104,65 @@ static_flags :: [Flag IO] static_flags = [ ------- GHCi ------------------------------------------------------- - Flag "ignore-dot-ghci" (PassFlag addOpt) - , Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci")) + flagC "ignore-dot-ghci" (PassFlag addOpt) + , flagC "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci")) ------- ways -------------------------------------------------------- - , Flag "prof" (NoArg (addWay WayProf)) - , Flag "eventlog" (NoArg (addWay WayEventLog)) - , Flag "parallel" (NoArg (addWay WayPar)) - , Flag "gransim" (NoArg (addWay WayGran)) - , Flag "smp" (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead")) - , Flag "debug" (NoArg (addWay WayDebug)) - , Flag "ndp" (NoArg (addWay WayNDP)) - , Flag "threaded" (NoArg (addWay WayThreaded)) - - , Flag "ticky" (PassFlag (\f -> do addOpt f; addWay WayDebug)) + , flagC "prof" (NoArg (addWay WayProf)) + , flagC "eventlog" (NoArg (addWay WayEventLog)) + , flagC "parallel" (NoArg (addWay WayPar)) + , flagC "gransim" (NoArg (addWay WayGran)) + , flagC "smp" (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead")) + , flagC "debug" (NoArg (addWay WayDebug)) + , flagC "ndp" (NoArg (addWay WayNDP)) + , flagC "threaded" (NoArg (addWay WayThreaded)) + + , flagC "ticky" (PassFlag (\f -> do addOpt f; addWay WayDebug)) -- -ticky enables ticky-ticky code generation, and also implies -debug which -- is required to get the RTS ticky support. ------ Debugging ---------------------------------------------------- - , Flag "dppr-debug" (PassFlag addOpt) - , Flag "dppr-cols" (AnySuffix addOpt) - , Flag "dppr-user-length" (AnySuffix addOpt) - , Flag "dppr-case-as-let" (PassFlag addOpt) - , Flag "dsuppress-all" (PassFlag addOpt) - , Flag "dsuppress-uniques" (PassFlag addOpt) - , Flag "dsuppress-coercions" (PassFlag addOpt) - , Flag "dsuppress-module-prefixes" (PassFlag addOpt) - , Flag "dsuppress-type-applications" (PassFlag addOpt) - , Flag "dsuppress-idinfo" (PassFlag addOpt) - , Flag "dsuppress-type-signatures" (PassFlag addOpt) - , Flag "dopt-fuel" (AnySuffix addOpt) - , Flag "dtrace-level" (AnySuffix addOpt) - , Flag "dno-debug-output" (PassFlag addOpt) - , Flag "dstub-dead-values" (PassFlag addOpt) + , flagC "dppr-debug" (PassFlag addOpt) + , flagC "dppr-cols" (AnySuffix addOpt) + , flagC "dppr-user-length" (AnySuffix addOpt) + , flagC "dppr-case-as-let" (PassFlag addOpt) + , flagC "dsuppress-all" (PassFlag addOpt) + , flagC "dsuppress-uniques" (PassFlag addOpt) + , flagC "dsuppress-coercions" (PassFlag addOpt) + , flagC "dsuppress-module-prefixes" (PassFlag addOpt) + , flagC "dsuppress-type-applications" (PassFlag addOpt) + , flagC "dsuppress-idinfo" (PassFlag addOpt) + , flagC "dsuppress-type-signatures" (PassFlag addOpt) + , flagC "dopt-fuel" (AnySuffix addOpt) + , flagC "dtrace-level" (AnySuffix addOpt) + , flagC "dno-debug-output" (PassFlag addOpt) + , flagC "dstub-dead-values" (PassFlag addOpt) -- rest of the debugging flags are dynamic ----- Linker -------------------------------------------------------- - , Flag "static" (PassFlag addOpt) - , Flag "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn)) + , flagC "static" (PassFlag addOpt) + , flagC "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn)) -- ignored for compat w/ gcc: - , Flag "rdynamic" (NoArg (return ())) + , flagC "rdynamic" (NoArg (return ())) ----- RTS opts ------------------------------------------------------ - , Flag "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s))))) + , flagC "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s))))) - , Flag "Rghc-timing" (NoArg (liftEwM enableTimingStats)) + , flagC "Rghc-timing" (NoArg (liftEwM enableTimingStats)) ------ Compiler flags ----------------------------------------------- -- -fPIC requires extra checking: only the NCG supports it. -- See also DynFlags.parseDynamicFlags. - , Flag "fPIC" (PassFlag setPIC) + , flagC "fPIC" (PassFlag setPIC) -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline - , Flag "fno-" + , flagC "fno-" (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s))) -- Pass all remaining "-f<blah>" options to hsc - , Flag "f" (AnySuffixPred isStaticFlag addOpt) + , flagC "f" (AnySuffixPred isStaticFlag addOpt) ] setPIC :: String -> StaticP () diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index b3f1a06227..c3be64b60a 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -366,8 +366,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, cg_tycons = alg_tycons, cg_binds = all_tidy_binds, cg_foreign = foreign_stubs, - cg_dep_pkgs = dep_pkgs deps, - cg_hpc_info = hpc_info, + cg_dep_pkgs = map fst $ dep_pkgs deps, + cg_hpc_info = hpc_info, cg_modBreaks = modBreaks }, ModDetails { md_types = tidy_type_env, diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index a5988fc62b..1ea83e8e88 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -789,8 +789,13 @@ Here we do: (i) introduce the appropriate indirections and position independent refs (ii) compile a list of imported symbols + (d) Some arch-specific optimizations -Ideas for other things we could do: +(a) and (b) will be moving to the new Hoopl pipeline, however, (c) and +(d) are only needed by the native backend and will continue to live +here. + +Ideas for other things we could do (put these in Hoopl please!): - shortcut jumps-to-jumps - simple CSE: if an expr is assigned to a temp, then replace later occs of @@ -830,6 +835,15 @@ cmmBlockConFold (BasicBlock id stmts) = do stmts' <- mapM cmmStmtConFold stmts return $ BasicBlock id stmts' +-- This does three optimizations, but they're very quick to check, so we don't +-- bother turning them off even when the Hoopl code is active. Since +-- this is on the old Cmm representation, we can't reuse the code either: +-- * reg = reg --> nop +-- * if 0 then jump --> nop +-- * if 1 then jump --> jump +-- We might be tempted to skip this step entirely of not opt_PIC, but +-- there is some PowerPC code for the non-PIC case, which would also +-- have to be separated. cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt cmmStmtConFold stmt = case stmt of @@ -876,28 +890,43 @@ cmmStmtConFold stmt other -> return other - cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr cmmExprConFold referenceKind expr = do + dflags <- getDynFlagsCmmOpt + -- Skip constant folding if new code generator is running + -- (this optimization is done in Hoopl) + let expr' = if dopt Opt_TryNewCodeGen dflags + then expr + else cmmExprCon expr + cmmExprNative referenceKind expr' + +cmmExprCon :: CmmExpr -> CmmExpr +cmmExprCon (CmmLoad addr rep) = CmmLoad (cmmExprCon addr) rep +cmmExprCon (CmmMachOp mop args) = cmmMachOpFold mop (map cmmExprCon args) +cmmExprCon other = other + +-- handles both PIC and non-PIC cases... a very strange mixture +-- of things to do. +cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr +cmmExprNative referenceKind expr = do dflags <- getDynFlagsCmmOpt let arch = platformArch (targetPlatform dflags) case expr of CmmLoad addr rep - -> do addr' <- cmmExprConFold DataReference addr + -> do addr' <- cmmExprNative DataReference addr return $ CmmLoad addr' rep CmmMachOp mop args - -- For MachOps, we first optimize the children, and then we try - -- our hand at some constant-folding. - -> do args' <- mapM (cmmExprConFold DataReference) args - return $ cmmMachOpFold mop args' + -> do args' <- mapM (cmmExprNative DataReference) args + return $ CmmMachOp mop args' CmmLit (CmmLabel lbl) -> do - cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl + cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl CmmLit (CmmLabelOff lbl off) -> do - dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl + dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl + -- need to optimize here, since it's late return $ cmmMachOpFold (MO_Add wordWidth) [ dynRef, (CmmLit $ CmmInt (fromIntegral off) wordWidth) @@ -908,15 +937,15 @@ cmmExprConFold referenceKind expr = do -- with the corresponding labels: CmmReg (CmmGlobal EagerBlackholeInfo) | arch == ArchPPC && not opt_PIC - -> cmmExprConFold referenceKind $ + -> cmmExprNative referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info"))) CmmReg (CmmGlobal GCEnter1) | arch == ArchPPC && not opt_PIC - -> cmmExprConFold referenceKind $ + -> cmmExprNative referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) CmmReg (CmmGlobal GCFun) | arch == ArchPPC && not opt_PIC - -> cmmExprConFold referenceKind $ + -> cmmExprNative referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun"))) other diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 0db76416eb..f4c972e4b0 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -838,8 +838,8 @@ genCondJump id bool = do -- register allocator. genCCall :: CmmCallTarget -- function to call - -> HintedCmmFormals -- where to put the result - -> HintedCmmActuals -- arguments (of mixed type) + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) -> NatM InstrBlock genCCall target dest_regs argsAndHints = do dflags <- getDynFlagsNat @@ -857,8 +857,8 @@ data GenCCallPlatform = GCPLinux | GCPDarwin genCCall' :: GenCCallPlatform -> CmmCallTarget -- function to call - -> HintedCmmFormals -- where to put the result - -> HintedCmmActuals -- arguments (of mixed type) + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) -> NatM InstrBlock {- diff --git a/compiler/nativeGen/SPARC/CodeGen/CCall.hs b/compiler/nativeGen/SPARC/CodeGen/CCall.hs index 0a26c232ba..7445f7168e 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CCall.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CCall.hs @@ -62,9 +62,9 @@ import Outputable -} genCCall - :: CmmCallTarget -- function to call - -> HintedCmmFormals -- where to put the result - -> HintedCmmActuals -- arguments (of mixed type) + :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) -> NatM InstrBlock diff --git a/compiler/nativeGen/Size.hs b/compiler/nativeGen/Size.hs index 6b5b1aff59..5d939d7d98 100644 --- a/compiler/nativeGen/Size.hs +++ b/compiler/nativeGen/Size.hs @@ -12,12 +12,13 @@ -- properly. eg SPARC doesn't care about FF80. -- module Size ( - Size(..), - intSize, - floatSize, - isFloatSize, - cmmTypeSize, - sizeToWidth + Size(..), + intSize, + floatSize, + isFloatSize, + cmmTypeSize, + sizeToWidth, + sizeInBytes ) where @@ -99,5 +100,6 @@ sizeToWidth size FF32 -> W32 FF64 -> W64 FF80 -> W80 - +sizeInBytes :: Size -> Int +sizeInBytes = widthInBytes . sizeToWidth diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 39de19c412..a667c51532 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -11,11 +11,11 @@ -- (c) the #if blah_TARGET_ARCH} things, the -- structure should not be too overwhelming. -module X86.CodeGen ( - cmmTopCodeGen, - generateJumpTableForInstr, - InstrBlock -) +module X86.CodeGen ( + cmmTopCodeGen, + generateJumpTableForInstr, + InstrBlock +) where @@ -38,52 +38,49 @@ import Platform -- Our intermediate code: import BasicTypes import BlockId -import PprCmm () +import PprCmm () import OldCmm import OldPprCmm () import CLabel -- The rest: -import StaticFlags ( opt_PIC ) -import ForeignCall ( CCallConv(..) ) +import StaticFlags ( opt_PIC ) +import ForeignCall ( CCallConv(..) ) import OrdList import Outputable import Unique import FastString -import FastBool ( isFastTrue ) -import Constants ( wORD_SIZE ) +import FastBool ( isFastTrue ) +import Constants ( wORD_SIZE ) import DynFlags -import Control.Monad ( mapAndUnzipM ) -import Data.Maybe ( catMaybes ) +import Control.Monad +import Data.Bits import Data.Int - -#if WORD_SIZE_IN_BITS==32 -import Data.Maybe ( fromJust ) +import Data.Maybe import Data.Word -import Data.Bits -#endif sse2Enabled :: NatM Bool -#if x86_64_TARGET_ARCH --- SSE2 is fixed on for x86_64. It would be possible to make it optional, --- but we'd need to fix at least the foreign call code where the calling --- convention specifies the use of xmm regs, and possibly other places. -sse2Enabled = return True -#else sse2Enabled = do dflags <- getDynFlagsNat - return (dopt Opt_SSE2 dflags) -#endif + case platformArch (targetPlatform dflags) of + ArchX86_64 -> -- SSE2 is fixed on for x86_64. It would be + -- possible to make it optional, but we'd need to + -- fix at least the foreign call code where the + -- calling convention specifies the use of xmm regs, + -- and possibly other places. + return True + ArchX86 -> return (dopt Opt_SSE2 dflags) + _ -> panic "sse2Enabled: Not an X86* arch" if_sse2 :: NatM a -> NatM a -> NatM a if_sse2 sse2 x87 = do b <- sse2Enabled if b then sse2 else x87 -cmmTopCodeGen - :: RawCmmTop - -> NatM [NatCmmTop Instr] +cmmTopCodeGen + :: RawCmmTop + -> NatM [NatCmmTop Instr] cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks @@ -96,15 +93,15 @@ cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do case picBaseMb of Just picBase -> initializePicBase_x86 ArchX86 os picBase tops Nothing -> return tops - + cmmTopCodeGen (CmmData sec dat) = do return [CmmData sec dat] -- no translation, we just use CmmStatic -basicBlockCodeGen - :: CmmBasicBlock - -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) +basicBlockCodeGen + :: CmmBasicBlock + -> NatM ( [NatBasicBlock Instr] + , [NatCmmTop Instr]) basicBlockCodeGen (BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts @@ -113,14 +110,14 @@ basicBlockCodeGen (BasicBlock id stmts) = do -- instruction stream into basic blocks again. Also, we extract -- LDATAs here too. let - (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs - - mkBlocks (NEWBLOCK id) (instrs,blocks,statics) - = ([], BasicBlock id instrs : blocks, statics) - mkBlocks (LDATA sec dat) (instrs,blocks,statics) - = (instrs, blocks, CmmData sec dat:statics) - mkBlocks instr (instrs,blocks,statics) - = (instr:instrs, blocks, statics) + (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs + + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) -- in return (BasicBlock id top : other_blocks, statics) @@ -132,32 +129,31 @@ stmtsToInstrs stmts stmtToInstrs :: CmmStmt -> NatM InstrBlock -stmtToInstrs stmt = case stmt of - CmmNop -> return nilOL +stmtToInstrs stmt = do + dflags <- getDynFlagsNat + let is32Bit = target32Bit (targetPlatform dflags) + case stmt of + CmmNop -> return nilOL CmmComment s -> return (unitOL (COMMENT s)) CmmAssign reg src - | isFloatType ty -> assignReg_FltCode size reg src -#if WORD_SIZE_IN_BITS==32 - | isWord64 ty -> assignReg_I64Code reg src -#endif - | otherwise -> assignReg_IntCode size reg src - where ty = cmmRegType reg - size = cmmTypeSize ty + | isFloatType ty -> assignReg_FltCode size reg src + | is32Bit && isWord64 ty -> assignReg_I64Code reg src + | otherwise -> assignReg_IntCode size reg src + where ty = cmmRegType reg + size = cmmTypeSize ty CmmStore addr src - | isFloatType ty -> assignMem_FltCode size addr src -#if WORD_SIZE_IN_BITS==32 - | isWord64 ty -> assignMem_I64Code addr src -#endif - | otherwise -> assignMem_IntCode size addr src - where ty = cmmExprType src - size = cmmTypeSize ty + | isFloatType ty -> assignMem_FltCode size addr src + | is32Bit && isWord64 ty -> assignMem_I64Code addr src + | otherwise -> assignMem_IntCode size addr src + where ty = cmmExprType src + size = cmmTypeSize ty CmmCall target result_regs args _ _ -> genCCall target result_regs args - CmmBranch id -> genBranch id + CmmBranch id -> genBranch id CmmCondBranch arg id -> genCondJump id arg CmmSwitch arg ids -> genSwitch arg ids CmmJump arg _ -> genJump arg @@ -167,42 +163,40 @@ stmtToInstrs stmt = case stmt of -------------------------------------------------------------------------------- -- | 'InstrBlock's are the insn sequences generated by the insn selectors. --- They are really trees of insns to facilitate fast appending, where a --- left-to-right traversal yields the insns in the correct order. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. -- -type InstrBlock - = OrdList Instr +type InstrBlock + = OrdList Instr -- | Condition codes passed up the tree. -- -data CondCode - = CondCode Bool Cond InstrBlock +data CondCode + = CondCode Bool Cond InstrBlock -#if WORD_SIZE_IN_BITS==32 -- | a.k.a "Register64" --- Reg is the lower 32-bit temporary which contains the result. --- Use getHiVRegFromLo to find the other VRegUnique. +-- Reg is the lower 32-bit temporary which contains the result. +-- Use getHiVRegFromLo to find the other VRegUnique. -- --- Rules of this simplified insn selection game are therefore that --- the returned Reg may be modified +-- Rules of this simplified insn selection game are therefore that +-- the returned Reg may be modified -- -data ChildCode64 - = ChildCode64 +data ChildCode64 + = ChildCode64 InstrBlock - Reg -#endif + Reg -- | Register's passed up the tree. If the stix code forces the register --- to live in a pre-decided machine register, it comes out as @Fixed@; --- otherwise, it comes out as @Any@, and the parent can decide which --- register to put it in. +-- to live in a pre-decided machine register, it comes out as @Fixed@; +-- otherwise, it comes out as @Any@, and the parent can decide which +-- register to put it in. -- data Register - = Fixed Size Reg InstrBlock - | Any Size (Reg -> InstrBlock) + = Fixed Size Reg InstrBlock + | Any Size (Reg -> InstrBlock) swizzleRegisterRep :: Register -> Size -> Register @@ -229,8 +223,8 @@ getRegisterReg _ (CmmGlobal mid) -- | Memory addressing modes passed up the tree. -data Amode - = Amode AddrMode InstrBlock +data Amode + = Amode AddrMode InstrBlock {- Now, given a tree (the argument to an CmmLoad) that references memory, @@ -252,10 +246,10 @@ temporary, then do the other computation, and then use the temporary: -- | Check whether an integer will fit in 32 bits. --- A CmmInt is intended to be truncated to the appropriate --- number of bits, so here we truncate it to Int64. This is --- important because e.g. -1 as a CmmInt might be either --- -1 or 18446744073709551615. +-- A CmmInt is intended to be truncated to the appropriate +-- number of bits, so here we truncate it to Int64. This is +-- important because e.g. -1 as a CmmInt might be either +-- -1 or 18446744073709551615. -- is32BitInteger :: Integer -> Bool is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 @@ -280,24 +274,23 @@ mangleIndexTree reg off where width = typeWidth (cmmRegType reg) -- | The dual to getAnyReg: compute an expression into a register, but --- we don't mind which one it is. +-- we don't mind which one it is. getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) getSomeReg expr = do r <- getRegister expr case r of Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed _ reg code -> - return (reg, code) + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed _ reg code -> + return (reg, code) -#if WORD_SIZE_IN_BITS==32 assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock assignMem_I64Code addrTree valueTree = do Amode addr addr_code <- getAmode addrTree ChildCode64 vcode rlo <- iselExpr64 valueTree - let + let rhi = getHiVRegFromLo rlo -- Little-endian store @@ -310,7 +303,7 @@ assignMem_I64Code addrTree valueTree = do assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do ChildCode64 vcode r_src_lo <- iselExpr64 valueTree - let + let r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32 r_dst_hi = getHiVRegFromLo r_dst_lo r_src_hi = getHiVRegFromLo r_src_lo @@ -329,43 +322,43 @@ iselExpr64 :: CmmExpr -> NatM ChildCode64 iselExpr64 (CmmLit (CmmInt i _)) = do (rlo,rhi) <- getNewRegPairNat II32 let - r = fromIntegral (fromIntegral i :: Word32) - q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32) - code = toOL [ - MOV II32 (OpImm (ImmInteger r)) (OpReg rlo), - MOV II32 (OpImm (ImmInteger q)) (OpReg rhi) - ] + r = fromIntegral (fromIntegral i :: Word32) + q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32) + code = toOL [ + MOV II32 (OpImm (ImmInteger r)) (OpReg rlo), + MOV II32 (OpImm (ImmInteger q)) (OpReg rhi) + ] -- in return (ChildCode64 code rlo) iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do Amode addr addr_code <- getAmode addrTree (rlo,rhi) <- getNewRegPairNat II32 - let + let mov_lo = MOV II32 (OpAddr addr) (OpReg rlo) mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi) -- in return ( - ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) + ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rlo ) iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32)) - + -- we handle addition, but rather badly iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do ChildCode64 code1 r1lo <- iselExpr64 e1 (rlo,rhi) <- getNewRegPairNat II32 let - r = fromIntegral (fromIntegral i :: Word32) - q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32) - r1hi = getHiVRegFromLo r1lo - code = code1 `appOL` - toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), - ADD II32 (OpImm (ImmInteger r)) (OpReg rlo), - MOV II32 (OpReg r1hi) (OpReg rhi), - ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ] + r = fromIntegral (fromIntegral i :: Word32) + q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32) + r1hi = getHiVRegFromLo r1lo + code = code1 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + ADD II32 (OpImm (ImmInteger r)) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ] -- in return (ChildCode64 code rlo) @@ -374,14 +367,14 @@ iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do ChildCode64 code2 r2lo <- iselExpr64 e2 (rlo,rhi) <- getNewRegPairNat II32 let - r1hi = getHiVRegFromLo r1lo - r2hi = getHiVRegFromLo r2lo - code = code1 `appOL` - code2 `appOL` - toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), - ADD II32 (OpReg r2lo) (OpReg rlo), - MOV II32 (OpReg r1hi) (OpReg rhi), - ADC II32 (OpReg r2hi) (OpReg rhi) ] + r1hi = getHiVRegFromLo r1lo + r2hi = getHiVRegFromLo r2lo + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + ADD II32 (OpReg r2lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + ADC II32 (OpReg r2hi) (OpReg rhi) ] -- in return (ChildCode64 code rlo) @@ -391,68 +384,70 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do let r_dst_hi = getHiVRegFromLo r_dst_lo code = fn r_dst_lo return ( - ChildCode64 (code `snocOL` + ChildCode64 (code `snocOL` MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi)) r_dst_lo ) iselExpr64 expr = pprPanic "iselExpr64(i386)" (ppr expr) -#endif -------------------------------------------------------------------------------- getRegister :: CmmExpr -> NatM Register - -#if !x86_64_TARGET_ARCH - -- on x86_64, we have %rip for PicBaseReg, but it's not a full-featured - -- register, it can only be used for rip-relative addressing. -getRegister (CmmReg (CmmGlobal PicBaseReg)) - = do - reg <- getPicBaseNat archWordSize - return (Fixed archWordSize reg nilOL) -#endif - -getRegister (CmmReg reg) - = do use_sse2 <- sse2Enabled - let - sz = cmmTypeSize (cmmRegType reg) - size | not use_sse2 && isFloatSize sz = FF80 - | otherwise = sz - -- - return (Fixed size (getRegisterReg use_sse2 reg) nilOL) - - -getRegister (CmmRegOff r n) - = getRegister $ mangleIndexTree r n - - -#if WORD_SIZE_IN_BITS==32 - -- for 32-bit architectuers, support some 64 -> 32 bit conversions: - -- TO_W_(x), TO_W_(x >> 32) - -getRegister (CmmMachOp (MO_UU_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do +getRegister e = do dflags <- getDynFlagsNat + getRegister' (target32Bit (targetPlatform dflags)) e + +getRegister' :: Bool -> CmmExpr -> NatM Register + +getRegister' is32Bit (CmmReg reg) + = case reg of + CmmGlobal PicBaseReg + | is32Bit -> + -- on x86_64, we have %rip for PicBaseReg, but it's not + -- a full-featured register, it can only be used for + -- rip-relative addressing. + do reg' <- getPicBaseNat archWordSize + return (Fixed archWordSize reg' nilOL) + _ -> + do use_sse2 <- sse2Enabled + let + sz = cmmTypeSize (cmmRegType reg) + size | not use_sse2 && isFloatSize sz = FF80 + | otherwise = sz + -- + return (Fixed size (getRegisterReg use_sse2 reg) nilOL) + + +getRegister' is32Bit (CmmRegOff r n) + = getRegister' is32Bit $ mangleIndexTree r n + +-- for 32-bit architectuers, support some 64 -> 32 bit conversions: +-- TO_W_(x), TO_W_(x >> 32) + +getRegister' is32Bit (CmmMachOp (MO_UU_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | is32Bit = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 (getHiVRegFromLo rlo) code -getRegister (CmmMachOp (MO_SS_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do +getRegister' is32Bit (CmmMachOp (MO_SS_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | is32Bit = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 (getHiVRegFromLo rlo) code -getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do +getRegister' is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x]) + | is32Bit = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 rlo code -getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do +getRegister' is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x]) + | is32Bit = do ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -#endif - + return $ Fixed II32 rlo code -getRegister (CmmLit lit@(CmmFloat f w)) = +getRegister' _ (CmmLit lit@(CmmFloat f w)) = if_sse2 float_const_sse2 float_const_x87 where float_const_sse2 @@ -460,8 +455,8 @@ getRegister (CmmLit lit@(CmmFloat f w)) = let size = floatSize w code dst = unitOL (XOR size (OpReg dst) (OpReg dst)) - -- I don't know why there are xorpd, xorps, and pxor instructions. - -- They all appear to do the same thing --SDM + -- I don't know why there are xorpd, xorps, and pxor instructions. + -- They all appear to do the same thing --SDM return (Any size code) | otherwise = do @@ -473,72 +468,70 @@ getRegister (CmmLit lit@(CmmFloat f w)) = | f == 0.0 -> let code dst = unitOL (GLDZ dst) in return (Any FF80 code) - + | f == 1.0 -> let code dst = unitOL (GLD1 dst) in return (Any FF80 code) - + _otherwise -> do Amode addr code <- memConstant (widthInBytes w) lit loadFloatAmode False w addr code -- catch simple cases of zero- or sign-extended load -getRegister (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do +getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do code <- intLoadCode (MOVZxL II8) addr return (Any II32 code) -getRegister (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do +getRegister' _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do code <- intLoadCode (MOVSxL II8) addr return (Any II32 code) -getRegister (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do +getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do code <- intLoadCode (MOVZxL II16) addr return (Any II32 code) -getRegister (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do +getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do code <- intLoadCode (MOVSxL II16) addr return (Any II32 code) - -#if x86_64_TARGET_ARCH - -- catch simple cases of zero- or sign-extended load -getRegister (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _]) = do +getRegister' is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _]) + | not is32Bit = do code <- intLoadCode (MOVZxL II8) addr return (Any II64 code) -getRegister (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _]) = do +getRegister' is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _]) + | not is32Bit = do code <- intLoadCode (MOVSxL II8) addr return (Any II64 code) -getRegister (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _]) = do +getRegister' is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _]) + | not is32Bit = do code <- intLoadCode (MOVZxL II16) addr return (Any II64 code) -getRegister (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _]) = do +getRegister' is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _]) + | not is32Bit = do code <- intLoadCode (MOVSxL II16) addr return (Any II64 code) -getRegister (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _]) = do +getRegister' is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _]) + | not is32Bit = do code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend return (Any II64 code) -getRegister (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _]) = do +getRegister' is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _]) + | not is32Bit = do code <- intLoadCode (MOVSxL II32) addr return (Any II64 code) -getRegister (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), +getRegister' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement]) - = return $ Any II64 (\dst -> unitOL $ + | not is32Bit = do + return $ Any II64 (\dst -> unitOL $ LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst)) -#endif /* x86_64_TARGET_ARCH */ - - - - - -getRegister (CmmMachOp mop [x]) = do -- unary MachOps +getRegister' is32Bit (CmmMachOp mop [x]) = do -- unary MachOps sse2 <- sse2Enabled case mop of MO_F_Neg w @@ -556,14 +549,12 @@ getRegister (CmmMachOp mop [x]) = do -- unary MachOps MO_UU_Conv W32 W16 -> toI16Reg W32 x MO_SS_Conv W32 W16 -> toI16Reg W32 x -#if x86_64_TARGET_ARCH - MO_UU_Conv W64 W32 -> conversionNop II64 x - MO_SS_Conv W64 W32 -> conversionNop II64 x - MO_UU_Conv W64 W16 -> toI16Reg W64 x - MO_SS_Conv W64 W16 -> toI16Reg W64 x - MO_UU_Conv W64 W8 -> toI8Reg W64 x - MO_SS_Conv W64 W8 -> toI8Reg W64 x -#endif + MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x + MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x + MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x + MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x + MO_UU_Conv W64 W8 | not is32Bit -> toI8Reg W64 x + MO_SS_Conv W64 W8 | not is32Bit -> toI8Reg W64 x MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intSize rep1) x MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intSize rep1) x @@ -577,22 +568,20 @@ getRegister (CmmMachOp mop [x]) = do -- unary MachOps MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x MO_SS_Conv W8 W16 -> integerExtend W8 W16 MOVSxL x -#if x86_64_TARGET_ARCH - MO_UU_Conv W8 W64 -> integerExtend W8 W64 MOVZxL x - MO_UU_Conv W16 W64 -> integerExtend W16 W64 MOVZxL x - MO_UU_Conv W32 W64 -> integerExtend W32 W64 MOVZxL x - MO_SS_Conv W8 W64 -> integerExtend W8 W64 MOVSxL x - MO_SS_Conv W16 W64 -> integerExtend W16 W64 MOVSxL x - MO_SS_Conv W32 W64 -> integerExtend W32 W64 MOVSxL x - -- for 32-to-64 bit zero extension, amd64 uses an ordinary movl. - -- However, we don't want the register allocator to throw it - -- away as an unnecessary reg-to-reg move, so we keep it in - -- the form of a movzl and print it as a movl later. -#endif + MO_UU_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVZxL x + MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x + MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x + MO_SS_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVSxL x + MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x + MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x + -- for 32-to-64 bit zero extension, amd64 uses an ordinary movl. + -- However, we don't want the register allocator to throw it + -- away as an unnecessary reg-to-reg move, so we keep it in + -- the form of a movzl and print it as a movl later. MO_FF_Conv W32 W64 | sse2 -> coerceFP2FP W64 x - | otherwise -> conversionNop FF80 x + | otherwise -> conversionNop FF80 x MO_FF_Conv W64 W32 -> coerceFP2FP W32 x @@ -601,42 +590,42 @@ getRegister (CmmMachOp mop [x]) = do -- unary MachOps _other -> pprPanic "getRegister" (pprMachOp mop) where - triv_ucode :: (Size -> Operand -> Instr) -> Size -> NatM Register - triv_ucode instr size = trivialUCode size (instr size) x - - -- signed or unsigned extension. - integerExtend :: Width -> Width - -> (Size -> Operand -> Operand -> Instr) - -> CmmExpr -> NatM Register - integerExtend from to instr expr = do - (reg,e_code) <- if from == W8 then getByteReg expr - else getSomeReg expr - let - code dst = - e_code `snocOL` - instr (intSize from) (OpReg reg) (OpReg dst) - return (Any (intSize to) code) - - toI8Reg :: Width -> CmmExpr -> NatM Register - toI8Reg new_rep expr + triv_ucode :: (Size -> Operand -> Instr) -> Size -> NatM Register + triv_ucode instr size = trivialUCode size (instr size) x + + -- signed or unsigned extension. + integerExtend :: Width -> Width + -> (Size -> Operand -> Operand -> Instr) + -> CmmExpr -> NatM Register + integerExtend from to instr expr = do + (reg,e_code) <- if from == W8 then getByteReg expr + else getSomeReg expr + let + code dst = + e_code `snocOL` + instr (intSize from) (OpReg reg) (OpReg dst) + return (Any (intSize to) code) + + toI8Reg :: Width -> CmmExpr -> NatM Register + toI8Reg new_rep expr = do codefn <- getAnyReg expr - return (Any (intSize new_rep) codefn) - -- HACK: use getAnyReg to get a byte-addressable register. - -- If the source was a Fixed register, this will add the - -- mov instruction to put it into the desired destination. - -- We're assuming that the destination won't be a fixed - -- non-byte-addressable register; it won't be, because all - -- fixed registers are word-sized. + return (Any (intSize new_rep) codefn) + -- HACK: use getAnyReg to get a byte-addressable register. + -- If the source was a Fixed register, this will add the + -- mov instruction to put it into the desired destination. + -- We're assuming that the destination won't be a fixed + -- non-byte-addressable register; it won't be, because all + -- fixed registers are word-sized. - toI16Reg = toI8Reg -- for now + toI16Reg = toI8Reg -- for now - conversionNop :: Size -> CmmExpr -> NatM Register + conversionNop :: Size -> CmmExpr -> NatM Register conversionNop new_size expr - = do e_code <- getRegister expr + = do e_code <- getRegister' is32Bit expr return (swizzleRegisterRep e_code new_size) -getRegister (CmmMachOp mop [x, y]) = do -- dyadic MachOps +getRegister' _ (CmmMachOp mop [x, y]) = do -- dyadic MachOps sse2 <- sse2Enabled case mop of MO_F_Eq _ -> condFltReg EQQ x y @@ -683,10 +672,10 @@ getRegister (CmmMachOp mop [x, y]) = do -- dyadic MachOps MO_Or rep -> triv_op rep OR MO_Xor rep -> triv_op rep XOR - {- Shift ops on x86s have constraints on their source, it - either has to be Imm, CL or 1 - => trivialCode is not restrictive enough (sigh.) - -} + {- Shift ops on x86s have constraints on their source, it + either has to be Imm, CL or 1 + => trivialCode is not restrictive enough (sigh.) + -} MO_Shl rep -> shift_code rep SHL x y {-False-} MO_U_Shr rep -> shift_code rep SHR x y {-False-} MO_S_Shr rep -> shift_code rep SAR x y {-False-} @@ -695,54 +684,54 @@ getRegister (CmmMachOp mop [x, y]) = do -- dyadic MachOps where -------------------- triv_op width instr = trivialCode width op (Just op) x y - where op = instr (intSize width) + where op = instr (intSize width) imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register imulMayOflo rep a b = do (a_reg, a_code) <- getNonClobberedReg a b_code <- getAnyReg b - let - shift_amt = case rep of - W32 -> 31 - W64 -> 63 - _ -> panic "shift_amt" + let + shift_amt = case rep of + W32 -> 31 + W64 -> 63 + _ -> panic "shift_amt" - size = intSize rep + size = intSize rep code = a_code `appOL` b_code eax `appOL` toOL [ - IMUL2 size (OpReg a_reg), -- result in %edx:%eax + IMUL2 size (OpReg a_reg), -- result in %edx:%eax SAR size (OpImm (ImmInt shift_amt)) (OpReg eax), - -- sign extend lower part + -- sign extend lower part SUB size (OpReg edx) (OpReg eax) - -- compare against upper + -- compare against upper -- eax==0 if high part == sign extended low part ] -- in - return (Fixed size eax code) + return (Fixed size eax code) -------------------- shift_code :: Width - -> (Size -> Operand -> Operand -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register + -> (Size -> Operand -> Operand -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register {- Case1: shift length as immediate -} shift_code width instr x (CmmLit lit) = do - x_code <- getAnyReg x - let - size = intSize width - code dst - = x_code dst `snocOL` - instr size (OpImm (litToImm lit)) (OpReg dst) - -- in - return (Any size code) - + x_code <- getAnyReg x + let + size = intSize width + code dst + = x_code dst `snocOL` + instr size (OpImm (litToImm lit)) (OpReg dst) + -- in + return (Any size code) + {- Case2: shift length is complex (non-immediate) * y must go in %ecx. * we cannot do y first *and* put its result in %ecx, because %ecx might be clobbered by x. - * if we do y second, then x cannot be + * if we do y second, then x cannot be in a clobbered reg. Also, we cannot clobber x's reg with the instruction itself. * so we can either: @@ -754,142 +743,137 @@ getRegister (CmmMachOp mop [x, y]) = do -- dyadic MachOps -} shift_code width instr x y{-amount-} = do x_code <- getAnyReg x - let size = intSize width - tmp <- getNewRegNat size + let size = intSize width + tmp <- getNewRegNat size y_code <- getAnyReg y - let - code = x_code tmp `appOL` - y_code ecx `snocOL` - instr size (OpReg ecx) (OpReg tmp) + let + code = x_code tmp `appOL` + y_code ecx `snocOL` + instr size (OpReg ecx) (OpReg tmp) -- in return (Fixed size tmp code) -------------------- add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register add_code rep x (CmmLit (CmmInt y _)) - | is32BitInteger y = add_int rep x y + | is32BitInteger y = add_int rep x y add_code rep x y = trivialCode rep (ADD size) (Just (ADD size)) x y where size = intSize rep -------------------- sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register sub_code rep x (CmmLit (CmmInt y _)) - | is32BitInteger (-y) = add_int rep x (-y) + | is32BitInteger (-y) = add_int rep x (-y) sub_code rep x y = trivialCode rep (SUB (intSize rep)) Nothing x y -- our three-operand add instruction: add_int width x y = do - (x_reg, x_code) <- getSomeReg x - let - size = intSize width - imm = ImmInt (fromInteger y) - code dst + (x_reg, x_code) <- getSomeReg x + let + size = intSize width + imm = ImmInt (fromInteger y) + code dst = x_code `snocOL` - LEA size - (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm)) + LEA size + (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm)) (OpReg dst) - -- - return (Any size code) + -- + return (Any size code) ---------------------- div_code width signed quotient x y = do - (y_op, y_code) <- getRegOrMem y -- cannot be clobbered - x_code <- getAnyReg x - let - size = intSize width - widen | signed = CLTD size - | otherwise = XOR size (OpReg edx) (OpReg edx) + (y_op, y_code) <- getRegOrMem y -- cannot be clobbered + x_code <- getAnyReg x + let + size = intSize width + widen | signed = CLTD size + | otherwise = XOR size (OpReg edx) (OpReg edx) - instr | signed = IDIV - | otherwise = DIV + instr | signed = IDIV + | otherwise = DIV - code = y_code `appOL` - x_code eax `appOL` - toOL [widen, instr size y_op] + code = y_code `appOL` + x_code eax `appOL` + toOL [widen, instr size y_op] - result | quotient = eax - | otherwise = edx + result | quotient = eax + | otherwise = edx - -- in + -- in return (Fixed size result code) -getRegister (CmmLoad mem pk) +getRegister' _ (CmmLoad mem pk) | isFloatType pk = do Amode addr mem_code <- getAmode mem use_sse2 <- sse2Enabled loadFloatAmode use_sse2 (typeWidth pk) addr mem_code -#if i386_TARGET_ARCH -getRegister (CmmLoad mem pk) - | not (isWord64 pk) - = do +getRegister' is32Bit (CmmLoad mem pk) + | is32Bit && not (isWord64 pk) + = do code <- intLoadCode instr mem return (Any size code) where width = typeWidth pk size = intSize width instr = case width of - W8 -> MOVZxL II8 - _other -> MOV size - -- We always zero-extend 8-bit loads, if we - -- can't think of anything better. This is because - -- we can't guarantee access to an 8-bit variant of every register - -- (esi and edi don't have 8-bit variants), so to make things - -- simpler we do our 8-bit arithmetic with full 32-bit registers. -#endif + W8 -> MOVZxL II8 + _other -> MOV size + -- We always zero-extend 8-bit loads, if we + -- can't think of anything better. This is because + -- we can't guarantee access to an 8-bit variant of every register + -- (esi and edi don't have 8-bit variants), so to make things + -- simpler we do our 8-bit arithmetic with full 32-bit registers. -#if x86_64_TARGET_ARCH -- Simpler memory load code on x86_64 -getRegister (CmmLoad mem pk) - = do +getRegister' is32Bit (CmmLoad mem pk) + | not is32Bit + = do code <- intLoadCode (MOV size) mem return (Any size code) where size = intSize $ typeWidth pk -#endif -getRegister (CmmLit (CmmInt 0 width)) +getRegister' _ (CmmLit (CmmInt 0 width)) = let - size = intSize width + size = intSize width - -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits - size1 = IF_ARCH_i386( size, case size of II64 -> II32; _ -> size ) - code dst + -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits + size1 = IF_ARCH_i386( size, case size of II64 -> II32; _ -> size ) + code dst = unitOL (XOR size1 (OpReg dst) (OpReg dst)) in - return (Any size code) + return (Any size code) -#if x86_64_TARGET_ARCH -- optimisation for loading small literals on x86_64: take advantage -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit -- instruction forms are shorter. -getRegister (CmmLit lit) - | isWord64 (cmmLitType lit), not (isBigLit lit) - = let - imm = litToImm lit - code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst)) +getRegister' is32Bit (CmmLit lit) + | not is32Bit, isWord64 (cmmLitType lit), not (isBigLit lit) + = let + imm = litToImm lit + code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst)) in - return (Any II64 code) + return (Any II64 code) where isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff isBigLit _ = False - -- note1: not the same as (not.is32BitLit), because that checks for - -- signed literals that fit in 32 bits, but we want unsigned - -- literals here. - -- note2: all labels are small, because we're assuming the - -- small memory model (see gcc docs, -mcmodel=small). -#endif + -- note1: not the same as (not.is32BitLit), because that checks for + -- signed literals that fit in 32 bits, but we want unsigned + -- literals here. + -- note2: all labels are small, because we're assuming the + -- small memory model (see gcc docs, -mcmodel=small). -getRegister (CmmLit lit) - = let - size = cmmTypeSize (cmmLitType lit) - imm = litToImm lit - code dst = unitOL (MOV size (OpImm imm) (OpReg dst)) +getRegister' _ (CmmLit lit) + = let + size = cmmTypeSize (cmmLitType lit) + imm = litToImm lit + code dst = unitOL (MOV size (OpImm imm) (OpReg dst)) in - return (Any size code) + return (Any size code) -getRegister other = pprPanic "getRegister(x86)" (ppr other) +getRegister' _ other = pprPanic "getRegister(x86)" (ppr other) intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr @@ -913,23 +897,23 @@ anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg ds -- Fixed registers might not be byte-addressable, so we make sure we've -- got a temporary, inserting an extra reg copy if necessary. getByteReg :: CmmExpr -> NatM (Reg, InstrBlock) -#if x86_64_TARGET_ARCH -getByteReg = getSomeReg -- all regs are byte-addressable on x86_64 -#else getByteReg expr = do - r <- getRegister expr - case r of - Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed rep reg code - | isVirtualReg reg -> return (reg,code) - | otherwise -> do - tmp <- getNewRegNat rep - return (tmp, code `snocOL` reg2reg rep reg tmp) - -- ToDo: could optimise slightly by checking for byte-addressable - -- real registers, but that will happen very rarely if at all. -#endif + dflags <- getDynFlagsNat + if target32Bit (targetPlatform dflags) + then do r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed rep reg code + | isVirtualReg reg -> return (reg,code) + | otherwise -> do + tmp <- getNewRegNat rep + return (tmp, code `snocOL` reg2reg rep reg tmp) + -- ToDo: could optimise slightly by checking for + -- byte-addressable real registers, but that will + -- happen very rarely if at all. + else getSomeReg expr -- all regs are byte-addressable on x86_64 -- Another variant: this time we want the result in a register that cannot -- be modified by code to evaluate an arbitrary expression. @@ -938,65 +922,66 @@ getNonClobberedReg expr = do r <- getRegister expr case r of Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) + tmp <- getNewRegNat rep + return (tmp, code tmp) Fixed rep reg code - -- only free regs can be clobbered - | RegReal (RealRegSingle rr) <- reg - , isFastTrue (freeReg rr) - -> do - tmp <- getNewRegNat rep - return (tmp, code `snocOL` reg2reg rep reg tmp) - | otherwise -> - return (reg, code) + -- only free regs can be clobbered + | RegReal (RealRegSingle rr) <- reg + , isFastTrue (freeReg rr) + -> do + tmp <- getNewRegNat rep + return (tmp, code `snocOL` reg2reg rep reg tmp) + | otherwise -> + return (reg, code) reg2reg :: Size -> Reg -> Reg -> Instr -reg2reg size src dst +reg2reg size src dst | size == FF80 = GMOV src dst - | otherwise = MOV size (OpReg src) (OpReg dst) + | otherwise = MOV size (OpReg src) (OpReg dst) -------------------------------------------------------------------------------- getAmode :: CmmExpr -> NatM Amode -getAmode (CmmRegOff r n) = getAmode $ mangleIndexTree r n +getAmode e = do dflags <- getDynFlagsNat + getAmode' (target32Bit (targetPlatform dflags)) e -#if x86_64_TARGET_ARCH +getAmode' :: Bool -> CmmExpr -> NatM Amode +getAmode' _ (CmmRegOff r n) = getAmode $ mangleIndexTree r n -getAmode (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), - CmmLit displacement]) +getAmode' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), + CmmLit displacement]) + | not is32Bit = return $ Amode (ripRel (litToImm displacement)) nilOL -#endif - --- This is all just ridiculous, since it carefully undoes +-- This is all just ridiculous, since it carefully undoes -- what mangleIndexTree has just done. -getAmode (CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]) +getAmode' _ (CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]) | is32BitLit lit -- ASSERT(rep == II32)??? = do (x_reg, x_code) <- getSomeReg x let off = ImmInt (-(fromInteger i)) return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) - -getAmode (CmmMachOp (MO_Add _rep) [x, CmmLit lit]) + +getAmode' _ (CmmMachOp (MO_Add _rep) [x, CmmLit lit]) | is32BitLit lit -- ASSERT(rep == II32)??? = do (x_reg, x_code) <- getSomeReg x let off = litToImm lit return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) --- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be +-- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be -- recognised by the next rule. -getAmode (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), - b@(CmmLit _)]) - = getAmode (CmmMachOp (MO_Add rep) [b,a]) +getAmode' is32Bit (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), + b@(CmmLit _)]) + = getAmode' is32Bit (CmmMachOp (MO_Add rep) [b,a]) -getAmode (CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) - [y, CmmLit (CmmInt shift _)]]) +getAmode' _ (CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) + [y, CmmLit (CmmInt shift _)]]) | shift == 0 || shift == 1 || shift == 2 || shift == 3 = x86_complex_amode x y shift 0 -getAmode (CmmMachOp (MO_Add _) +getAmode' _ (CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Add _) [CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)], CmmLit (CmmInt offset _)]]) @@ -1004,13 +989,13 @@ getAmode (CmmMachOp (MO_Add _) && is32BitInteger offset = x86_complex_amode x y shift offset -getAmode (CmmMachOp (MO_Add _) [x,y]) +getAmode' _ (CmmMachOp (MO_Add _) [x,y]) = x86_complex_amode x y 0 0 -getAmode (CmmLit lit) | is32BitLit lit +getAmode' _ (CmmLit lit) | is32BitLit lit = return (Amode (ImmAddr (litToImm lit) 0) nilOL) -getAmode expr = do +getAmode' _ expr = do (reg,code) <- getSomeReg expr return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code) @@ -1018,11 +1003,11 @@ getAmode expr = do x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode x86_complex_amode base index shift offset = do (x_reg, x_code) <- getNonClobberedReg base - -- x must be in a temp, because it has to stay live over y_code - -- we could compre x_reg and y_reg and do something better here... + -- x must be in a temp, because it has to stay live over y_code + -- we could compre x_reg and y_reg and do something better here... (y_reg, y_code) <- getSomeReg index let - code = x_code `appOL` y_code + code = x_code `appOL` y_code base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8; n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")" return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset))) @@ -1059,14 +1044,14 @@ getNonClobberedOperand (CmmLoad mem pk) = do && IF_ARCH_i386(not (isWord64 pk), True) then do Amode src mem_code <- getAmode mem - (src',save_code) <- - if (amodeCouldBeClobbered src) - then do - tmp <- getNewRegNat archWordSize - return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0), - unitOL (LEA II32 (OpAddr src) (OpReg tmp))) - else - return (src, nilOL) + (src',save_code) <- + if (amodeCouldBeClobbered src) + then do + tmp <- getNewRegNat archWordSize + return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0), + unitOL (LEA II32 (OpAddr src) (OpReg tmp))) + else + return (src, nilOL) return (OpAddr src', save_code `appOL` mem_code) else do getNonClobberedOperand_generic (CmmLoad mem pk) @@ -1121,26 +1106,27 @@ getOperand_generic e = do isOperand :: CmmExpr -> Bool isOperand (CmmLoad _ _) = True isOperand (CmmLit lit) = is32BitLit lit - || isSuitableFloatingPointLit lit + || isSuitableFloatingPointLit lit isOperand _ = False memConstant :: Int -> CmmLit -> NatM Amode memConstant align lit = do -#ifdef x86_64_TARGET_ARCH - lbl <- getNewLabelNat - let addr = ripRel (ImmCLbl lbl) - addr_code = nilOL -#else lbl <- getNewLabelNat dflags <- getDynFlagsNat - dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl - Amode addr addr_code <- getAmode dynRef -#endif + (addr, addr_code) <- if target32Bit (targetPlatform dflags) + then do dynRef <- cmmMakeDynamicReference + dflags + addImportNat + DataReference + lbl + Amode addr addr_code <- getAmode dynRef + return (addr, addr_code) + else return (ripRel (ImmCLbl lbl), nilOL) let code = LDATA ReadOnlyData - [CmmAlign align, + [CmmAlign align, CmmDataLabel lbl, - CmmStaticLit lit] + CmmStaticLit lit] `consOL` addr_code return (Amode addr code) @@ -1196,7 +1182,7 @@ getCondCode :: CmmExpr -> NatM CondCode -- yes, they really do seem to want exactly the same! getCondCode (CmmMachOp mop [x, y]) - = + = case mop of MO_F_Eq W32 -> condFltCode EQQ x y MO_F_Ne W32 -> condFltCode NE x y @@ -1241,9 +1227,9 @@ condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode condIntCode cond (CmmLoad x pk) (CmmLit lit) | is32BitLit lit = do Amode x_addr x_code <- getAmode x let - imm = litToImm lit - code = x_code `snocOL` - CMP (cmmTypeSize pk) (OpImm imm) (OpAddr x_addr) + imm = litToImm lit + code = x_code `snocOL` + CMP (cmmTypeSize pk) (OpImm imm) (OpAddr x_addr) -- return (CondCode False cond code) @@ -1263,17 +1249,17 @@ condIntCode cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk)) condIntCode cond x (CmmLit (CmmInt 0 pk)) = do (x_reg, x_code) <- getSomeReg x let - code = x_code `snocOL` - TEST (intSize pk) (OpReg x_reg) (OpReg x_reg) + code = x_code `snocOL` + TEST (intSize pk) (OpReg x_reg) (OpReg x_reg) -- return (CondCode False cond code) -- anything vs operand condIntCode cond x y | isOperand y = do (x_reg, x_code) <- getNonClobberedReg x - (y_op, y_code) <- getOperand y + (y_op, y_code) <- getOperand y let - code = x_code `appOL` y_code `snocOL` + code = x_code `appOL` y_code `snocOL` CMP (cmmTypeSize (cmmExprType x)) y_op (OpReg x_reg) -- in return (CondCode False cond code) @@ -1283,9 +1269,9 @@ condIntCode cond x y = do (y_reg, y_code) <- getNonClobberedReg y (x_op, x_code) <- getRegOrMem x let - code = y_code `appOL` - x_code `snocOL` - CMP (cmmTypeSize (cmmExprType x)) (OpReg y_reg) x_op + code = y_code `appOL` + x_code `snocOL` + CMP (cmmTypeSize (cmmExprType x)) (OpReg y_reg) x_op -- in return (CondCode False cond code) @@ -1294,7 +1280,7 @@ condIntCode cond x y = do -------------------------------------------------------------------------------- condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode -condFltCode cond x y +condFltCode cond x y = if_sse2 condFltCode_sse2 condFltCode_x87 where @@ -1303,12 +1289,12 @@ condFltCode cond x y (x_reg, x_code) <- getNonClobberedReg x (y_reg, y_code) <- getSomeReg y let - code = x_code `appOL` y_code `snocOL` - GCMP cond x_reg y_reg + code = x_code `appOL` y_code `snocOL` + GCMP cond x_reg y_reg -- The GCMP insn does the test and sets the zero flag if comparable -- and true. Hence we always supply EQQ as the condition to test. return (CondCode True EQQ code) - + -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be -- an operand, but the right must be a reg. We can probably do better -- than this general case... @@ -1316,11 +1302,11 @@ condFltCode cond x y (x_reg, x_code) <- getNonClobberedReg x (y_op, y_code) <- getOperand y let - code = x_code `appOL` - y_code `snocOL` - CMP (floatSize $ cmmExprWidth x) y_op (OpReg x_reg) - -- NB(1): we need to use the unsigned comparison operators on the - -- result of this comparison. + code = x_code `appOL` + y_code `snocOL` + CMP (floatSize $ cmmExprWidth x) y_op (OpReg x_reg) + -- NB(1): we need to use the unsigned comparison operators on the + -- result of this comparison. -- in return (CondCode True (condToUnsigned cond) code) @@ -1346,7 +1332,7 @@ assignReg_FltCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock -- integer assignment to memory -- specific case of adding/subtracting an integer to a particular address. --- ToDo: catch other cases where we can use an operation directly on a memory +-- ToDo: catch other cases where we can use an operation directly on a memory -- address. assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _, CmmLit (CmmInt i _)]) @@ -1367,22 +1353,22 @@ assignMem_IntCode pk addr src = do Amode addr code_addr <- getAmode addr (code_src, op_src) <- get_op_RI src let - code = code_src `appOL` - code_addr `snocOL` + code = code_src `appOL` + code_addr `snocOL` MOV pk op_src (OpAddr addr) - -- NOTE: op_src is stable, so it will still be valid - -- after code_addr. This may involve the introduction - -- of an extra MOV to a temporary register, but we hope - -- the register allocator will get rid of it. + -- NOTE: op_src is stable, so it will still be valid + -- after code_addr. This may involve the introduction + -- of an extra MOV to a temporary register, but we hope + -- the register allocator will get rid of it. -- return code where - get_op_RI :: CmmExpr -> NatM (InstrBlock,Operand) -- code, operator + get_op_RI :: CmmExpr -> NatM (InstrBlock,Operand) -- code, operator get_op_RI (CmmLit lit) | is32BitLit lit = return (nilOL, OpImm (litToImm lit)) get_op_RI op = do (reg,code) <- getNonClobberedReg op - return (code, OpReg reg) + return (code, OpReg reg) -- Assign; dst is a reg, rhs is mem @@ -1402,8 +1388,8 @@ assignMem_FltCode pk addr src = do Amode addr addr_code <- getAmode addr use_sse2 <- sse2Enabled let - code = src_code `appOL` - addr_code `snocOL` + code = src_code `appOL` + addr_code `snocOL` if use_sse2 then MOV pk (OpReg src_reg) (OpAddr addr) else GST pk src_reg addr return code @@ -1450,7 +1436,7 @@ codes are set according to the supplied comparison operation. -} genCondJump - :: BlockId -- the branch target + :: BlockId -- the branch target -> CmmExpr -- the condition on which to branch -> NatM InstrBlock @@ -1459,31 +1445,31 @@ genCondJump id bool = do use_sse2 <- sse2Enabled if not is_float || not use_sse2 then - return (cond_code `snocOL` JXX cond id) + return (cond_code `snocOL` JXX cond id) else do - lbl <- getBlockIdNat - - -- see comment with condFltReg - let code = case cond of - NE -> or_unordered - GU -> plain_test - GEU -> plain_test - _ -> and_ordered - - plain_test = unitOL ( - JXX cond id - ) - or_unordered = toOL [ - JXX cond id, - JXX PARITY id - ] - and_ordered = toOL [ - JXX PARITY lbl, - JXX cond id, - JXX ALWAYS lbl, - NEWBLOCK lbl - ] - return (cond_code `appOL` code) + lbl <- getBlockIdNat + + -- see comment with condFltReg + let code = case cond of + NE -> or_unordered + GU -> plain_test + GEU -> plain_test + _ -> and_ordered + + plain_test = unitOL ( + JXX cond id + ) + or_unordered = toOL [ + JXX cond id, + JXX PARITY id + ] + and_ordered = toOL [ + JXX PARITY lbl, + JXX cond id, + JXX ALWAYS lbl, + NEWBLOCK lbl + ] + return (cond_code `appOL` code) -- ----------------------------------------------------------------------------- @@ -1492,402 +1478,468 @@ genCondJump id bool = do -- Now the biggest nightmare---calls. Most of the nastiness is buried in -- @get_arg@, which moves the arguments to the correct registers/stack -- locations. Apart from that, the code is easy. --- +-- -- (If applicable) Do not fill the delay slots here; you will confuse the -- register allocator. genCCall - :: CmmCallTarget -- function to call - -> HintedCmmFormals -- where to put the result - -> HintedCmmActuals -- arguments (of mixed type) + :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) -> NatM InstrBlock -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if i386_TARGET_ARCH - -genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL - -- write barrier compiles to no code on x86/x86-64; - -- we keep it this long in order to prevent earlier optimisations. - --- void return type prim op -genCCall (CmmPrim op) [] args = - outOfLineCmmOp op Nothing args - --- we only cope with a single result for foreign calls -genCCall (CmmPrim op) [r_hinted@(CmmHinted r _)] args = do - l1 <- getNewLabelNat - l2 <- getNewLabelNat - sse2 <- sse2Enabled - if sse2 - then - outOfLineCmmOp op (Just r_hinted) args - else case op of - MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args - MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args - - MO_F32_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args - MO_F64_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args - - MO_F32_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args - MO_F64_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args - - MO_F32_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args - MO_F64_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args - - _other_op -> outOfLineCmmOp op (Just r_hinted) args - - where - actuallyInlineFloatOp instr size [CmmHinted x _] - = do res <- trivialUFCode size (instr size) x - any <- anyReg res - return (any (getRegisterReg False (CmmLocal r))) - - actuallyInlineFloatOp _ _ args - = panic $ "genCCall.actuallyInlineFloatOp: bad number of arguments! (" - ++ show (length args) ++ ")" - -genCCall target dest_regs args = do - let - sizes = map (arg_size . cmmExprType . hintlessCmm) (reverse args) -#if !darwin_TARGET_OS - tot_arg_size = sum sizes -#else - raw_arg_size = sum sizes - tot_arg_size = roundTo 16 raw_arg_size - arg_pad_size = tot_arg_size - raw_arg_size - delta0 <- getDeltaNat - setDeltaNat (delta0 - arg_pad_size) -#endif - - use_sse2 <- sse2Enabled - push_codes <- mapM (push_arg use_sse2) (reverse args) - delta <- getDeltaNat - - -- in - -- deal with static vs dynamic call targets - (callinsns,cconv) <- - case target of - CmmCallee (CmmLit (CmmLabel lbl)) conv - -> -- ToDo: stdcall arg sizes - return (unitOL (CALL (Left fn_imm) []), conv) - where fn_imm = ImmCLbl lbl - CmmCallee expr conv - -> do { (dyn_r, dyn_c) <- getSomeReg expr - ; ASSERT( isWord32 (cmmExprType expr) ) - return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } - CmmPrim _ - -> panic $ "genCCall: Can't handle CmmPrim call type here, error " - ++ "probably because too many return values." - - let push_code -#if darwin_TARGET_OS - | arg_pad_size /= 0 - = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp), - DELTA (delta0 - arg_pad_size)] - `appOL` concatOL push_codes - | otherwise -#endif - = concatOL push_codes - - -- Deallocate parameters after call for ccall; - -- but not for stdcall (callee does it) - -- - -- We have to pop any stack padding we added - -- on Darwin even if we are doing stdcall, though (#5052) - pop_size | cconv /= StdCallConv = tot_arg_size - | otherwise -#if darwin_TARGET_OS - = arg_pad_size -#else - = 0 -#endif - - call = callinsns `appOL` - toOL ( - (if pop_size==0 then [] else - [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)]) - ++ - [DELTA (delta + tot_arg_size)] - ) - -- in - setDeltaNat (delta + tot_arg_size) - - let - -- assign the results, if necessary - assign_code [] = nilOL - assign_code [CmmHinted dest _hint] - | isFloatType ty = - if use_sse2 - then let tmp_amode = AddrBaseIndex (EABaseReg esp) - EAIndexNone - (ImmInt 0) - sz = floatSize w - in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp), - GST sz fake0 tmp_amode, - MOV sz (OpAddr tmp_amode) (OpReg r_dest), - ADD II32 (OpImm (ImmInt b)) (OpReg esp)] - else unitOL (GMOV fake0 r_dest) - | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest), - MOV II32 (OpReg edx) (OpReg r_dest_hi)] - | otherwise = unitOL (MOV (intSize w) (OpReg eax) (OpReg r_dest)) - where - ty = localRegType dest - w = typeWidth ty - b = widthInBytes w - r_dest_hi = getHiVRegFromLo r_dest - r_dest = getRegisterReg use_sse2 (CmmLocal dest) - assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many) - - return (push_code `appOL` - call `appOL` - assign_code dest_regs) - +-- Unroll memcpy calls if the source and destination pointers are at +-- least DWORD aligned and the number of bytes to copy isn't too +-- large. Otherwise, call C's memcpy. +genCCall (CmmPrim MO_Memcpy) _ [CmmHinted dst _, CmmHinted src _, + CmmHinted (CmmLit (CmmInt n _)) _, + CmmHinted (CmmLit (CmmInt align _)) _] + | n <= maxInlineSizeThreshold && align .&. 3 == 0 = do + code_dst <- getAnyReg dst + dst_r <- getNewRegNat size + code_src <- getAnyReg src + src_r <- getNewRegNat size + tmp_r <- getNewRegNat size + return $ code_dst dst_r `appOL` code_src src_r `appOL` + go dst_r src_r tmp_r n where - arg_size :: CmmType -> Int -- Width in bytes - arg_size ty = widthInBytes (typeWidth ty) - -#if darwin_TARGET_OS - roundTo a x | x `mod` a == 0 = x - | otherwise = x + a - (x `mod` a) -#endif - - push_arg :: Bool -> HintedCmmActual {-current argument-} - -> NatM InstrBlock -- code - - push_arg use_sse2 (CmmHinted arg _hint) -- we don't need the hints on x86 - | isWord64 arg_ty = do - ChildCode64 code r_lo <- iselExpr64 arg - delta <- getDeltaNat - setDeltaNat (delta - 8) - let - r_hi = getHiVRegFromLo r_lo - -- in - return ( code `appOL` - toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4), - PUSH II32 (OpReg r_lo), DELTA (delta - 8), - DELTA (delta-8)] - ) - - | isFloatType arg_ty = do - (reg, code) <- getSomeReg arg - delta <- getDeltaNat - setDeltaNat (delta-size) - return (code `appOL` - toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp), - DELTA (delta-size), - let addr = AddrBaseIndex (EABaseReg esp) - EAIndexNone - (ImmInt 0) - size = floatSize (typeWidth arg_ty) - in - if use_sse2 - then MOV size (OpReg reg) (OpAddr addr) - else GST size reg addr - ] - ) - - | otherwise = do - (operand, code) <- getOperand arg - delta <- getDeltaNat - setDeltaNat (delta-size) - return (code `snocOL` - PUSH II32 operand `snocOL` - DELTA (delta-size)) - + size = if align .&. 4 /= 0 then II32 else archWordSize + + sizeBytes = fromIntegral (sizeInBytes size) + + go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr + go dst src tmp i + | i >= sizeBytes = + unitOL (MOV size (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV size (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - sizeBytes) + -- Deal with remaining bytes. + | i >= 4 = -- Will never happen on 32-bit + unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 4) + | i >= 2 = + unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 2) + | i >= 1 = + unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 1) + | otherwise = nilOL where - arg_ty = cmmExprType arg - size = arg_size arg_ty -- Byte size - -#elif x86_64_TARGET_ARCH + src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone + (ImmInteger (n - i)) + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone + (ImmInteger (n - i)) + +genCCall (CmmPrim MO_Memset) _ [CmmHinted dst _, + CmmHinted (CmmLit (CmmInt c _)) _, + CmmHinted (CmmLit (CmmInt n _)) _, + CmmHinted (CmmLit (CmmInt align _)) _] + | n <= maxInlineSizeThreshold && align .&. 3 == 0 = do + code_dst <- getAnyReg dst + dst_r <- getNewRegNat size + return $ code_dst dst_r `appOL` go dst_r n + where + (size, val) = case align .&. 3 of + 2 -> (II16, c2) + 0 -> (II32, c4) + _ -> (II8, c) + c2 = c `shiftL` 8 .|. c + c4 = c2 `shiftL` 16 .|. c2 + + sizeBytes = fromIntegral (sizeInBytes size) + + go :: Reg -> Integer -> OrdList Instr + go dst i + -- TODO: Add movabs instruction and support 64-bit sets. + | i >= sizeBytes = -- This might be smaller than the below sizes + unitOL (MOV size (OpImm (ImmInteger val)) (OpAddr dst_addr)) `appOL` + go dst (i - sizeBytes) + | i >= 4 = -- Will never happen on 32-bit + unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr dst_addr)) `appOL` + go dst (i - 4) + | i >= 2 = + unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr dst_addr)) `appOL` + go dst (i - 2) + | i >= 1 = + unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr dst_addr)) `appOL` + go dst (i - 1) + | otherwise = nilOL + where + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone + (ImmInteger (n - i)) genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL - -- write barrier compiles to no code on x86/x86-64; - -- we keep it this long in order to prevent earlier optimisations. - --- void return type prim op -genCCall (CmmPrim op) [] args = - outOfLineCmmOp op Nothing args - --- we only cope with a single result for foreign calls -genCCall (CmmPrim op) [res] args = - outOfLineCmmOp op (Just res) args - -genCCall target dest_regs args = do - - -- load up the register arguments - (stack_args, aregs, fregs, load_args_code) - <- load_args args allArgRegs allFPArgRegs nilOL - - let - fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) - int_regs_used = reverse (drop (length aregs) (reverse allArgRegs)) - arg_regs = [eax] ++ int_regs_used ++ fp_regs_used - -- for annotating the call instruction with - - sse_regs = length fp_regs_used - - tot_arg_size = arg_size * length stack_args - - -- On entry to the called function, %rsp should be aligned - -- on a 16-byte boundary +8 (i.e. the first stack arg after - -- the return address is 16-byte aligned). In STG land - -- %rsp is kept 16-byte aligned (see StgCRun.c), so we just - -- need to make sure we push a multiple of 16-bytes of args, - -- plus the return address, to get the correct alignment. - -- Urg, this is hard. We need to feed the delta back into - -- the arg pushing code. - (real_size, adjust_rsp) <- - if tot_arg_size `rem` 16 == 0 - then return (tot_arg_size, nilOL) - else do -- we need to adjust... - delta <- getDeltaNat - setDeltaNat (delta-8) - return (tot_arg_size+8, toOL [ - SUB II64 (OpImm (ImmInt 8)) (OpReg rsp), - DELTA (delta-8) - ]) - - -- push the stack args, right to left - push_code <- push_args (reverse stack_args) nilOL - delta <- getDeltaNat - - -- deal with static vs dynamic call targets - (callinsns,cconv) <- - case target of - CmmCallee (CmmLit (CmmLabel lbl)) conv - -> -- ToDo: stdcall arg sizes - return (unitOL (CALL (Left fn_imm) arg_regs), conv) - where fn_imm = ImmCLbl lbl - CmmCallee expr conv - -> do (dyn_r, dyn_c) <- getSomeReg expr - return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) - CmmPrim _ - -> panic $ "genCCall: Can't handle CmmPrim call type here, error " - ++ "probably because too many return values." - - let - -- The x86_64 ABI requires us to set %al to the number of SSE2 - -- registers that contain arguments, if the called routine - -- is a varargs function. We don't know whether it's a - -- varargs function or not, so we have to assume it is. - -- - -- It's not safe to omit this assignment, even if the number - -- of SSE2 regs in use is zero. If %al is larger than 8 - -- on entry to a varargs function, seg faults ensue. - assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax)) - - let call = callinsns `appOL` - toOL ( - -- Deallocate parameters after call for ccall; - -- but not for stdcall (callee does it) - (if cconv == StdCallConv || real_size==0 then [] else - [ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)]) - ++ - [DELTA (delta + real_size)] - ) - -- in - setDeltaNat (delta + real_size) - - let - -- assign the results, if necessary - assign_code [] = nilOL - assign_code [CmmHinted dest _hint] = - case typeWidth rep of - W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest)) - W64 | isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest)) - _ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest)) - where - rep = localRegType dest - r_dest = getRegisterReg True (CmmLocal dest) - assign_code _many = panic "genCCall.assign_code many" - - return (load_args_code `appOL` - adjust_rsp `appOL` - push_code `appOL` - assign_eax sse_regs `appOL` - call `appOL` - assign_code dest_regs) - - where - arg_size = 8 -- always, at the mo - - load_args :: [CmmHinted CmmExpr] - -> [Reg] -- int regs avail for args - -> [Reg] -- FP regs avail for args - -> InstrBlock - -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock) - load_args args [] [] code = return (args, [], [], code) - -- no more regs to use - load_args [] aregs fregs code = return ([], aregs, fregs, code) - -- no more args to push - load_args ((CmmHinted arg hint) : rest) aregs fregs code - | isFloatType arg_rep = - case fregs of - [] -> push_this_arg - (r:rs) -> do - arg_code <- getAnyReg arg - load_args rest aregs rs (code `appOL` arg_code r) - | otherwise = - case aregs of - [] -> push_this_arg - (r:rs) -> do - arg_code <- getAnyReg arg - load_args rest rs fregs (code `appOL` arg_code r) - where - arg_rep = cmmExprType arg - - push_this_arg = do - (args',ars,frs,code') <- load_args rest aregs fregs code - return ((CmmHinted arg hint):args', ars, frs, code') - - push_args [] code = return code - push_args ((CmmHinted arg _):rest) code - | isFloatType arg_rep = do - (arg_reg, arg_code) <- getSomeReg arg - delta <- getDeltaNat - setDeltaNat (delta-arg_size) - let code' = code `appOL` arg_code `appOL` toOL [ - SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) , - DELTA (delta-arg_size), - MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel 0))] - push_args rest code' - - | otherwise = do - -- we only ever generate word-sized function arguments. Promotion - -- has already happened: our Int8# type is kept sign-extended - -- in an Int#, for example. - ASSERT(width == W64) return () - (arg_op, arg_code) <- getOperand arg - delta <- getDeltaNat - setDeltaNat (delta-arg_size) - let code' = code `appOL` arg_code `appOL` toOL [ - PUSH II64 arg_op, - DELTA (delta-arg_size)] - push_args rest code' - where - arg_rep = cmmExprType arg - width = typeWidth arg_rep - -#else -genCCall = panic "X86.genCCAll: not defined" - -#endif /* x86_64_TARGET_ARCH */ - - -outOfLineCmmOp :: CallishMachOp -> Maybe HintedCmmFormal -> HintedCmmActuals -> NatM InstrBlock + -- write barrier compiles to no code on x86/x86-64; + -- we keep it this long in order to prevent earlier optimisations. + +genCCall target dest_regs args = + do dflags <- getDynFlagsNat + if target32Bit (targetPlatform dflags) + then case (target, dest_regs) of + -- void return type prim op + (CmmPrim op, []) -> + outOfLineCmmOp op Nothing args + -- we only cope with a single result for foreign calls + (CmmPrim op, [r_hinted@(CmmHinted r _)]) -> do + l1 <- getNewLabelNat + l2 <- getNewLabelNat + sse2 <- sse2Enabled + if sse2 + then + outOfLineCmmOp op (Just r_hinted) args + else case op of + MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args + MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args + + MO_F32_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args + MO_F64_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args + + MO_F32_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args + MO_F64_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args + + MO_F32_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args + MO_F64_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args + + _other_op -> outOfLineCmmOp op (Just r_hinted) args + + where + actuallyInlineFloatOp instr size [CmmHinted x _] + = do res <- trivialUFCode size (instr size) x + any <- anyReg res + return (any (getRegisterReg False (CmmLocal r))) + + actuallyInlineFloatOp _ _ args + = panic $ "genCCall.actuallyInlineFloatOp: bad number of arguments! (" + ++ show (length args) ++ ")" + _ -> do + let + sizes = map (arg_size . cmmExprType . hintlessCmm) (reverse args) + raw_arg_size = sum sizes + tot_arg_size = if isDarwin then roundTo 16 raw_arg_size else raw_arg_size + arg_pad_size = tot_arg_size - raw_arg_size + delta0 <- getDeltaNat + when isDarwin $ setDeltaNat (delta0 - arg_pad_size) + + use_sse2 <- sse2Enabled + push_codes <- mapM (push_arg use_sse2) (reverse args) + delta <- getDeltaNat + + -- in + -- deal with static vs dynamic call targets + (callinsns,cconv) <- + case target of + CmmCallee (CmmLit (CmmLabel lbl)) conv + -> -- ToDo: stdcall arg sizes + return (unitOL (CALL (Left fn_imm) []), conv) + where fn_imm = ImmCLbl lbl + CmmCallee expr conv + -> do { (dyn_r, dyn_c) <- getSomeReg expr + ; ASSERT( isWord32 (cmmExprType expr) ) + return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } + CmmPrim _ + -> panic $ "genCCall: Can't handle CmmPrim call type here, error " + ++ "probably because too many return values." + + let push_code + | isDarwin && (arg_pad_size /= 0) + = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp), + DELTA (delta0 - arg_pad_size)] + `appOL` concatOL push_codes + | otherwise + = concatOL push_codes + + -- Deallocate parameters after call for ccall; + -- but not for stdcall (callee does it) + -- + -- We have to pop any stack padding we added + -- on Darwin even if we are doing stdcall, though (#5052) + pop_size | cconv /= StdCallConv = tot_arg_size + | isDarwin = arg_pad_size + | otherwise = 0 + + call = callinsns `appOL` + toOL ( + (if pop_size==0 then [] else + [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)]) + ++ + [DELTA (delta + tot_arg_size)] + ) + -- in + setDeltaNat (delta + tot_arg_size) + + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [CmmHinted dest _hint] + | isFloatType ty = + if use_sse2 + then let tmp_amode = AddrBaseIndex (EABaseReg esp) + EAIndexNone + (ImmInt 0) + sz = floatSize w + in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp), + GST sz fake0 tmp_amode, + MOV sz (OpAddr tmp_amode) (OpReg r_dest), + ADD II32 (OpImm (ImmInt b)) (OpReg esp)] + else unitOL (GMOV fake0 r_dest) + | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest), + MOV II32 (OpReg edx) (OpReg r_dest_hi)] + | otherwise = unitOL (MOV (intSize w) (OpReg eax) (OpReg r_dest)) + where + ty = localRegType dest + w = typeWidth ty + b = widthInBytes w + r_dest_hi = getHiVRegFromLo r_dest + r_dest = getRegisterReg use_sse2 (CmmLocal dest) + assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many) + + return (push_code `appOL` + call `appOL` + assign_code dest_regs) + + where + isDarwin = case platformOS (targetPlatform dflags) of + OSDarwin -> True + _ -> False + + arg_size :: CmmType -> Int -- Width in bytes + arg_size ty = widthInBytes (typeWidth ty) + + roundTo a x | x `mod` a == 0 = x + | otherwise = x + a - (x `mod` a) + + push_arg :: Bool -> HintedCmmActual {-current argument-} + -> NatM InstrBlock -- code + + push_arg use_sse2 (CmmHinted arg _hint) -- we don't need the hints on x86 + | isWord64 arg_ty = do + ChildCode64 code r_lo <- iselExpr64 arg + delta <- getDeltaNat + setDeltaNat (delta - 8) + let + r_hi = getHiVRegFromLo r_lo + -- in + return ( code `appOL` + toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4), + PUSH II32 (OpReg r_lo), DELTA (delta - 8), + DELTA (delta-8)] + ) + + | isFloatType arg_ty = do + (reg, code) <- getSomeReg arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `appOL` + toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp), + DELTA (delta-size), + let addr = AddrBaseIndex (EABaseReg esp) + EAIndexNone + (ImmInt 0) + size = floatSize (typeWidth arg_ty) + in + if use_sse2 + then MOV size (OpReg reg) (OpAddr addr) + else GST size reg addr + ] + ) + + | otherwise = do + (operand, code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `snocOL` + PUSH II32 operand `snocOL` + DELTA (delta-size)) + + where + arg_ty = cmmExprType arg + size = arg_size arg_ty -- Byte size + else case (target, dest_regs) of + (CmmPrim op, []) -> + -- void return type prim op + outOfLineCmmOp op Nothing args + (CmmPrim op, [res]) -> + -- we only cope with a single result for foreign calls + outOfLineCmmOp op (Just res) args + _ -> do + -- load up the register arguments + (stack_args, aregs, fregs, load_args_code) + <- load_args args allArgRegs allFPArgRegs nilOL + + let + fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) + int_regs_used = reverse (drop (length aregs) (reverse allArgRegs)) + arg_regs = [eax] ++ int_regs_used ++ fp_regs_used + -- for annotating the call instruction with + + sse_regs = length fp_regs_used + + tot_arg_size = arg_size * length stack_args + + -- On entry to the called function, %rsp should be aligned + -- on a 16-byte boundary +8 (i.e. the first stack arg after + -- the return address is 16-byte aligned). In STG land + -- %rsp is kept 16-byte aligned (see StgCRun.c), so we just + -- need to make sure we push a multiple of 16-bytes of args, + -- plus the return address, to get the correct alignment. + -- Urg, this is hard. We need to feed the delta back into + -- the arg pushing code. + (real_size, adjust_rsp) <- + if tot_arg_size `rem` 16 == 0 + then return (tot_arg_size, nilOL) + else do -- we need to adjust... + delta <- getDeltaNat + setDeltaNat (delta-8) + return (tot_arg_size+8, toOL [ + SUB II64 (OpImm (ImmInt 8)) (OpReg rsp), + DELTA (delta-8) + ]) + + -- push the stack args, right to left + push_code <- push_args (reverse stack_args) nilOL + delta <- getDeltaNat + + -- deal with static vs dynamic call targets + (callinsns,cconv) <- + case target of + CmmCallee (CmmLit (CmmLabel lbl)) conv + -> -- ToDo: stdcall arg sizes + return (unitOL (CALL (Left fn_imm) arg_regs), conv) + where fn_imm = ImmCLbl lbl + CmmCallee expr conv + -> do (dyn_r, dyn_c) <- getSomeReg expr + return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) + CmmPrim _ + -> panic $ "genCCall: Can't handle CmmPrim call type here, error " + ++ "probably because too many return values." + + let + -- The x86_64 ABI requires us to set %al to the number of SSE2 + -- registers that contain arguments, if the called routine + -- is a varargs function. We don't know whether it's a + -- varargs function or not, so we have to assume it is. + -- + -- It's not safe to omit this assignment, even if the number + -- of SSE2 regs in use is zero. If %al is larger than 8 + -- on entry to a varargs function, seg faults ensue. + assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax)) + + let call = callinsns `appOL` + toOL ( + -- Deallocate parameters after call for ccall; + -- but not for stdcall (callee does it) + (if cconv == StdCallConv || real_size==0 then [] else + [ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)]) + ++ + [DELTA (delta + real_size)] + ) + -- in + setDeltaNat (delta + real_size) + + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [CmmHinted dest _hint] = + case typeWidth rep of + W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest)) + W64 | isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest)) + _ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest)) + where + rep = localRegType dest + r_dest = getRegisterReg True (CmmLocal dest) + assign_code _many = panic "genCCall.assign_code many" + + return (load_args_code `appOL` + adjust_rsp `appOL` + push_code `appOL` + assign_eax sse_regs `appOL` + call `appOL` + assign_code dest_regs) + + where + arg_size = 8 -- always, at the mo + + load_args :: [CmmHinted CmmExpr] + -> [Reg] -- int regs avail for args + -> [Reg] -- FP regs avail for args + -> InstrBlock + -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock) + load_args args [] [] code = return (args, [], [], code) + -- no more regs to use + load_args [] aregs fregs code = return ([], aregs, fregs, code) + -- no more args to push + load_args ((CmmHinted arg hint) : rest) aregs fregs code + | isFloatType arg_rep = + case fregs of + [] -> push_this_arg + (r:rs) -> do + arg_code <- getAnyReg arg + load_args rest aregs rs (code `appOL` arg_code r) + | otherwise = + case aregs of + [] -> push_this_arg + (r:rs) -> do + arg_code <- getAnyReg arg + load_args rest rs fregs (code `appOL` arg_code r) + where + arg_rep = cmmExprType arg + + push_this_arg = do + (args',ars,frs,code') <- load_args rest aregs fregs code + return ((CmmHinted arg hint):args', ars, frs, code') + + push_args [] code = return code + push_args ((CmmHinted arg _):rest) code + | isFloatType arg_rep = do + (arg_reg, arg_code) <- getSomeReg arg + delta <- getDeltaNat + setDeltaNat (delta-arg_size) + let code' = code `appOL` arg_code `appOL` toOL [ + SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) , + DELTA (delta-arg_size), + MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel 0))] + push_args rest code' + + | otherwise = do + -- we only ever generate word-sized function arguments. Promotion + -- has already happened: our Int8# type is kept sign-extended + -- in an Int#, for example. + ASSERT(width == W64) return () + (arg_op, arg_code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-arg_size) + let code' = code `appOL` arg_code `appOL` toOL [ + PUSH II64 arg_op, + DELTA (delta-arg_size)] + push_args rest code' + where + arg_rep = cmmExprType arg + width = typeWidth arg_rep + +-- | We're willing to inline and unroll memcpy/memset calls that touch +-- at most these many bytes. This threshold is the same as the one +-- used by GCC and LLVM. +maxInlineSizeThreshold :: Integer +maxInlineSizeThreshold = 128 + +outOfLineCmmOp :: CallishMachOp -> Maybe HintedCmmFormal -> [HintedCmmActual] -> NatM InstrBlock outOfLineCmmOp mop res args = do dflags <- getDynFlagsNat targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl let target = CmmCallee targetExpr CCallConv - + stmtToInstrs (CmmCall target (catMaybes [res]) args' CmmUnsafe CmmMayReturn) where - -- Assume we can call these functions directly, and that they're not in a dynamic library. - -- TODO: Why is this ok? Under linux this code will be in libm.so - -- Is is because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31 - lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction + -- Assume we can call these functions directly, and that they're not in a dynamic library. + -- TODO: Why is this ok? Under linux this code will be in libm.so + -- Is is because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31 + lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction args' = case mop of MO_Memcpy -> init args @@ -1895,42 +1947,42 @@ outOfLineCmmOp mop res args MO_Memmove -> init args _ -> args - fn = case mop of - MO_F32_Sqrt -> fsLit "sqrtf" - MO_F32_Sin -> fsLit "sinf" - MO_F32_Cos -> fsLit "cosf" - MO_F32_Tan -> fsLit "tanf" - MO_F32_Exp -> fsLit "expf" - MO_F32_Log -> fsLit "logf" - - MO_F32_Asin -> fsLit "asinf" - MO_F32_Acos -> fsLit "acosf" - MO_F32_Atan -> fsLit "atanf" - - MO_F32_Sinh -> fsLit "sinhf" - MO_F32_Cosh -> fsLit "coshf" - MO_F32_Tanh -> fsLit "tanhf" - MO_F32_Pwr -> fsLit "powf" - - MO_F64_Sqrt -> fsLit "sqrt" - MO_F64_Sin -> fsLit "sin" - MO_F64_Cos -> fsLit "cos" - MO_F64_Tan -> fsLit "tan" - MO_F64_Exp -> fsLit "exp" - MO_F64_Log -> fsLit "log" - - MO_F64_Asin -> fsLit "asin" - MO_F64_Acos -> fsLit "acos" - MO_F64_Atan -> fsLit "atan" - - MO_F64_Sinh -> fsLit "sinh" - MO_F64_Cosh -> fsLit "cosh" - MO_F64_Tanh -> fsLit "tanh" - MO_F64_Pwr -> fsLit "pow" - - MO_Memcpy -> fsLit "memcpy" - MO_Memset -> fsLit "memset" - MO_Memmove -> fsLit "memmove" + fn = case mop of + MO_F32_Sqrt -> fsLit "sqrtf" + MO_F32_Sin -> fsLit "sinf" + MO_F32_Cos -> fsLit "cosf" + MO_F32_Tan -> fsLit "tanf" + MO_F32_Exp -> fsLit "expf" + MO_F32_Log -> fsLit "logf" + + MO_F32_Asin -> fsLit "asinf" + MO_F32_Acos -> fsLit "acosf" + MO_F32_Atan -> fsLit "atanf" + + MO_F32_Sinh -> fsLit "sinhf" + MO_F32_Cosh -> fsLit "coshf" + MO_F32_Tanh -> fsLit "tanhf" + MO_F32_Pwr -> fsLit "powf" + + MO_F64_Sqrt -> fsLit "sqrt" + MO_F64_Sin -> fsLit "sin" + MO_F64_Cos -> fsLit "cos" + MO_F64_Tan -> fsLit "tan" + MO_F64_Exp -> fsLit "exp" + MO_F64_Log -> fsLit "log" + + MO_F64_Asin -> fsLit "asin" + MO_F64_Acos -> fsLit "acos" + MO_F64_Atan -> fsLit "atan" + + MO_F64_Sinh -> fsLit "sinh" + MO_F64_Cosh -> fsLit "cosh" + MO_F64_Tanh -> fsLit "tanh" + MO_F64_Pwr -> fsLit "pow" + + MO_Memcpy -> fsLit "memcpy" + MO_Memset -> fsLit "memset" + MO_Memmove -> fsLit "memmove" other -> panic $ "outOfLineCmmOp: unmatched op! (" ++ show other ++ ")" @@ -1951,38 +2003,38 @@ genSwitch expr ids let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg wORD_SIZE) (ImmInt 0)) -#if x86_64_TARGET_ARCH -#if darwin_TARGET_OS - -- on Mac OS X/x86_64, put the jump table in the text section - -- to work around a limitation of the linker. - -- ld64 is unable to handle the relocations for - -- .quad L1 - L0 - -- if L0 is not preceded by a non-anonymous label in its section. - - code = e_code `appOL` t_code `appOL` toOL [ - ADD (intSize wordWidth) op (OpReg tableReg), - JMP_TBL (OpReg tableReg) ids Text lbl - ] -#else - -- HACK: On x86_64 binutils<2.17 is only able to generate PC32 - -- relocations, hence we only get 32-bit offsets in the jump - -- table. As these offsets are always negative we need to properly - -- sign extend them to 64-bit. This hack should be removed in - -- conjunction with the hack in PprMach.hs/pprDataItem once - -- binutils 2.17 is standard. - code = e_code `appOL` t_code `appOL` toOL [ - MOVSxL II32 op (OpReg reg), - ADD (intSize wordWidth) (OpReg reg) (OpReg tableReg), - JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl - ] -#endif -#else - code = e_code `appOL` t_code `appOL` toOL [ - ADD (intSize wordWidth) op (OpReg tableReg), - JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl - ] -#endif - return code + return $ if target32Bit (targetPlatform dflags) + then e_code `appOL` t_code `appOL` toOL [ + ADD (intSize wordWidth) op (OpReg tableReg), + JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl + ] + else case platformOS (targetPlatform dflags) of + OSDarwin -> + -- on Mac OS X/x86_64, put the jump table + -- in the text section to work around a + -- limitation of the linker. + -- ld64 is unable to handle the relocations for + -- .quad L1 - L0 + -- if L0 is not preceded by a non-anonymous + -- label in its section. + e_code `appOL` t_code `appOL` toOL [ + ADD (intSize wordWidth) op (OpReg tableReg), + JMP_TBL (OpReg tableReg) ids Text lbl + ] + _ -> + -- HACK: On x86_64 binutils<2.17 is only able + -- to generate PC32 relocations, hence we only + -- get 32-bit offsets in the jump table. As + -- these offsets are always negative we need + -- to properly sign extend them to 64-bit. + -- This hack should be removed in conjunction + -- with the hack in PprMach.hs/pprDataItem + -- once binutils 2.17 is standard. + e_code `appOL` t_code `appOL` toOL [ + MOVSxL II32 op (OpReg reg), + ADD (intSize wordWidth) (OpReg reg) (OpReg tableReg), + JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl + ] | otherwise = do (reg,e_code) <- getSomeReg expr @@ -2016,7 +2068,7 @@ createJumpTable ids section lbl -- Turn those condition codes into integers now (when they appear on -- the right hand side of an assignment). --- +-- -- (If applicable) Do not fill the delay slots here; you will confuse the -- register allocator. @@ -2025,11 +2077,11 @@ condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register condIntReg cond x y = do CondCode _ cond cond_code <- condIntCode cond x y tmp <- getNewRegNat II8 - let - code dst = cond_code `appOL` toOL [ - SETCC cond (OpReg tmp), - MOVZxL II8 (OpReg tmp) (OpReg dst) - ] + let + code dst = cond_code `appOL` toOL [ + SETCC cond (OpReg tmp), + MOVZxL II8 (OpReg tmp) (OpReg dst) + ] -- in return (Any II32 code) @@ -2041,57 +2093,57 @@ condFltReg cond x y = if_sse2 condFltReg_sse2 condFltReg_x87 condFltReg_x87 = do CondCode _ cond cond_code <- condFltCode cond x y tmp <- getNewRegNat II8 - let - code dst = cond_code `appOL` toOL [ - SETCC cond (OpReg tmp), - MOVZxL II8 (OpReg tmp) (OpReg dst) - ] + let + code dst = cond_code `appOL` toOL [ + SETCC cond (OpReg tmp), + MOVZxL II8 (OpReg tmp) (OpReg dst) + ] -- in return (Any II32 code) - + condFltReg_sse2 = do CondCode _ cond cond_code <- condFltCode cond x y tmp1 <- getNewRegNat archWordSize tmp2 <- getNewRegNat archWordSize - let - -- We have to worry about unordered operands (eg. comparisons - -- against NaN). If the operands are unordered, the comparison - -- sets the parity flag, carry flag and zero flag. - -- All comparisons are supposed to return false for unordered - -- operands except for !=, which returns true. - -- - -- Optimisation: we don't have to test the parity flag if we - -- know the test has already excluded the unordered case: eg > - -- and >= test for a zero carry flag, which can only occur for - -- ordered operands. - -- - -- ToDo: by reversing comparisons we could avoid testing the - -- parity flag in more cases. - - code dst = - cond_code `appOL` - (case cond of - NE -> or_unordered dst - GU -> plain_test dst - GEU -> plain_test dst - _ -> and_ordered dst) - - plain_test dst = toOL [ - SETCC cond (OpReg tmp1), - MOVZxL II8 (OpReg tmp1) (OpReg dst) - ] - or_unordered dst = toOL [ - SETCC cond (OpReg tmp1), - SETCC PARITY (OpReg tmp2), - OR II8 (OpReg tmp1) (OpReg tmp2), - MOVZxL II8 (OpReg tmp2) (OpReg dst) - ] - and_ordered dst = toOL [ - SETCC cond (OpReg tmp1), - SETCC NOTPARITY (OpReg tmp2), - AND II8 (OpReg tmp1) (OpReg tmp2), - MOVZxL II8 (OpReg tmp2) (OpReg dst) - ] + let + -- We have to worry about unordered operands (eg. comparisons + -- against NaN). If the operands are unordered, the comparison + -- sets the parity flag, carry flag and zero flag. + -- All comparisons are supposed to return false for unordered + -- operands except for !=, which returns true. + -- + -- Optimisation: we don't have to test the parity flag if we + -- know the test has already excluded the unordered case: eg > + -- and >= test for a zero carry flag, which can only occur for + -- ordered operands. + -- + -- ToDo: by reversing comparisons we could avoid testing the + -- parity flag in more cases. + + code dst = + cond_code `appOL` + (case cond of + NE -> or_unordered dst + GU -> plain_test dst + GEU -> plain_test dst + _ -> and_ordered dst) + + plain_test dst = toOL [ + SETCC cond (OpReg tmp1), + MOVZxL II8 (OpReg tmp1) (OpReg dst) + ] + or_unordered dst = toOL [ + SETCC cond (OpReg tmp1), + SETCC PARITY (OpReg tmp2), + OR II8 (OpReg tmp1) (OpReg tmp2), + MOVZxL II8 (OpReg tmp2) (OpReg dst) + ] + and_ordered dst = toOL [ + SETCC cond (OpReg tmp1), + SETCC NOTPARITY (OpReg tmp2), + AND II8 (OpReg tmp1) (OpReg tmp2), + MOVZxL II8 (OpReg tmp2) (OpReg dst) + ] -- in return (Any II32 code) @@ -2115,7 +2167,7 @@ The Rules of the Game are: * You cannot assume anything about the destination register dst; it may be anything, including a fixed reg. -* You may compute an operand into a fixed reg, but you may not +* You may compute an operand into a fixed reg, but you may not subsequently change the contents of that fixed reg. If you want to do so, first copy the value either to a temporary or into dst. You are free to modify dst even if it happens @@ -2124,8 +2176,8 @@ The Rules of the Game are: * You cannot assume that a fixed reg will stay live over an arbitrary computation. The same applies to the dst reg. -* Temporary regs obtained from getNewRegNat are distinct from - each other and from all other regs, and stay live over +* Temporary regs obtained from getNewRegNat are distinct from + each other and from all other regs, and stay live over arbitrary computations. -------------------- @@ -2147,9 +2199,9 @@ SDM's version of The Rules: therefore not read by any of the sub-computations). * If getRegister returns Any, then the code it generates may modify only: - (a) fresh temporaries - (b) the destination register - (c) known registers (eg. %ecx is used by shifts) + (a) fresh temporaries + (b) the destination register + (c) known registers (eg. %ecx is used by shifts) In particular, it may *not* modify global registers, unless the global register happens to be the destination register. -} @@ -2161,8 +2213,8 @@ trivialCode width _ (Just revinstr) (CmmLit lit_a) b | is32BitLit lit_a = do b_code <- getAnyReg b let - code dst - = b_code dst `snocOL` + code dst + = b_code dst `snocOL` revinstr (OpImm (litToImm lit_a)) (OpReg dst) -- in return (Any (intSize width) code) @@ -2185,15 +2237,15 @@ genTrivialCode rep instr a b = do -- as the destination reg. In this case, we have to save b in a -- new temporary across the computation of a. code dst - | dst `regClashesWithOp` b_op = - b_code `appOL` - unitOL (MOV rep b_op (OpReg tmp)) `appOL` - a_code dst `snocOL` - instr (OpReg tmp) (OpReg dst) - | otherwise = - b_code `appOL` - a_code dst `snocOL` - instr b_op (OpReg dst) + | dst `regClashesWithOp` b_op = + b_code `appOL` + unitOL (MOV rep b_op (OpReg tmp)) `appOL` + a_code dst `snocOL` + instr (OpReg tmp) (OpReg dst) + | otherwise = + b_code `appOL` + a_code dst `snocOL` + instr b_op (OpReg dst) -- in return (Any rep code) @@ -2210,8 +2262,8 @@ trivialUCode rep instr x = do x_code <- getAnyReg x let code dst = - x_code dst `snocOL` - instr (OpReg dst) + x_code dst `snocOL` + instr (OpReg dst) return (Any rep code) ----------- @@ -2224,9 +2276,9 @@ trivialFCode_x87 instr x y = do let size = FF80 -- always, on x87 code dst = - x_code `appOL` - y_code `snocOL` - instr size x_reg y_reg dst + x_code `appOL` + y_code `snocOL` + instr size x_reg y_reg dst return (Any size code) trivialFCode_sse2 :: Width -> (Size -> Operand -> Operand -> Instr) @@ -2241,8 +2293,8 @@ trivialUFCode size instr x = do (x_reg, x_code) <- getSomeReg x let code dst = - x_code `snocOL` - instr x_reg dst + x_code `snocOL` + instr x_reg dst -- in return (Any size code) @@ -2258,9 +2310,9 @@ coerceInt2FP from to x = if_sse2 coerce_sse2 coerce_x87 n -> panic $ "coerceInt2FP.x87: unhandled width (" ++ show n ++ ")" code dst = x_code `snocOL` opc x_reg dst - -- ToDo: works for non-II32 reps? + -- ToDo: works for non-II32 reps? return (Any FF80 code) - + coerce_sse2 = do (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand let @@ -2283,10 +2335,10 @@ coerceFP2Int from to x = if_sse2 coerceFP2Int_sse2 coerceFP2Int_x87 n -> panic $ "coerceFP2Int.x87: unhandled width (" ++ show n ++ ")" code dst = x_code `snocOL` opc x_reg dst - -- ToDo: works for non-II32 reps? + -- ToDo: works for non-II32 reps? -- in return (Any (intSize to) code) - + coerceFP2Int_sse2 = do (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand let @@ -2328,7 +2380,7 @@ sse2NegCode w x = do let code dst = x_code dst `appOL` amode_code `appOL` toOL [ MOV sz (OpAddr amode) (OpReg tmp), - XOR sz (OpReg tmp) (OpReg dst) - ] + XOR sz (OpReg tmp) (OpReg dst) + ] -- return (Any sz code) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 43a400471e..736ab0967b 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -661,7 +661,7 @@ reservedWordsFM = listToUFM $ ( "export", ITexport, bit ffiBit), ( "label", ITlabel, bit ffiBit), ( "dynamic", ITdynamic, bit ffiBit), - ( "safe", ITsafe, bit ffiBit), + ( "safe", ITsafe, bit ffiBit .|. bit safeHaskellBit), ( "threadsafe", ITthreadsafe, bit ffiBit), -- ToDo: remove ( "interruptible", ITinterruptible, bit ffiBit), ( "unsafe", ITunsafe, bit ffiBit), @@ -1807,6 +1807,8 @@ relaxedLayoutBit :: Int relaxedLayoutBit = 24 nondecreasingIndentationBit :: Int nondecreasingIndentationBit = 25 +safeHaskellBit :: Int +safeHaskellBit = 26 always :: Int -> Bool always _ = True @@ -1902,6 +1904,7 @@ mkPState flags buf loc = .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags + .|. safeHaskellBit `setBitIf` safeHaskellOn flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index b663ac2aba..bb82aaa2d1 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -500,13 +500,17 @@ importdecls :: { [LImportDecl RdrName] } | {- empty -} { [] } importdecl :: { LImportDecl RdrName } - : 'import' maybe_src optqualified maybe_pkg modid maybeas maybeimpspec - { L (comb4 $1 $5 $6 $7) (ImportDecl $5 $4 $2 $3 (unLoc $6) (unLoc $7)) } + : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec + { L (comb4 $1 $6 $7 $8) (ImportDecl $6 $5 $2 $3 $4 (unLoc $7) (unLoc $8)) } maybe_src :: { IsBootInterface } : '{-# SOURCE' '#-}' { True } | {- empty -} { False } +maybe_safe :: { Bool } + : 'safe' { True } + | {- empty -} { False } + maybe_pkg :: { Maybe FastString } : STRING { Just (getSTRING $1) } | {- empty -} { Nothing } @@ -1241,7 +1245,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } {% do s <- checkValSig $1 $3 ; return (LL $ unitOL (LL $ SigD s)) } | var ',' sig_vars '::' sigtypedoc - { LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] } + { LL $ toOL [ LL $ SigD (TypeSig ($1 : unLoc $3) $5) ] } | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) | n <- unLoc $3 ] } | '{-# INLINE' activation qvar '#-}' diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index a9433441e8..10274e1823 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -774,7 +774,7 @@ checkValSig -> P (Sig RdrName) checkValSig (L l (HsVar v)) ty | isUnqual v && not (isDataOcc (rdrNameOcc v)) - = return (TypeSig (L l v) ty) + = return (TypeSig [L l v] ty) checkValSig lhs@(L l _) ty = parseErrorSDoc l ((text "Invalid type signature:" <+> ppr lhs <+> text "::" <+> ppr ty) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index d226cbebdc..4fd23ee712 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -219,6 +219,9 @@ basicKnownKeyNames -- The Either type , eitherTyConName, leftDataConName, rightDataConName + -- Plugins + , pluginTyConName + -- dotnet interop , objectTyConName, marshalObjectName, unmarshalObjectName , marshalStringName, unmarshalStringName, checkDotnetResName @@ -371,6 +374,12 @@ mkBaseModule m = mkModule basePackageId (mkModuleNameFS m) mkBaseModule_ :: ModuleName -> Module mkBaseModule_ m = mkModule basePackageId m +mkThisGhcModule :: FastString -> Module +mkThisGhcModule m = mkModule thisGhcPackageId (mkModuleNameFS m) + +mkThisGhcModule_ :: ModuleName -> Module +mkThisGhcModule_ m = mkModule thisGhcPackageId m + mkMainModule :: FastString -> Module mkMainModule m = mkModule mainPackageId (mkModuleNameFS m) @@ -973,6 +982,12 @@ marshalObjectName = varQual dOTNET (fsLit "marshalObject") marshalObjectIdKey marshalStringName = varQual dOTNET (fsLit "marshalString") marshalStringIdKey unmarshalStringName = varQual dOTNET (fsLit "unmarshalString") unmarshalStringIdKey checkDotnetResName = varQual dOTNET (fsLit "checkResult") checkDotnetResNameIdKey + +-- plugins +cORE_MONAD :: Module +cORE_MONAD = mkThisGhcModule (fsLit "CoreMonad") +pluginTyConName :: Name +pluginTyConName = tcQual cORE_MONAD (fsLit "Plugin") pluginTyConKey \end{code} %************************************************************************ @@ -1193,6 +1208,9 @@ csel1CoercionTyConKey = mkPreludeTyConUnique 99 csel2CoercionTyConKey = mkPreludeTyConUnique 100 cselRCoercionTyConKey = mkPreludeTyConUnique 101 +pluginTyConKey :: Unique +pluginTyConKey = mkPreludeTyConUnique 102 + unknownTyConKey, unknown1TyConKey, unknown2TyConKey, unknown3TyConKey, opaqueTyConKey :: Unique unknownTyConKey = mkPreludeTyConUnique 129 diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 5a80067160..8759157f4e 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -521,9 +521,9 @@ unitTy = mkTupleTy Boxed [] \end{code} %************************************************************************ -%* * +%* * \subsection[TysWiredIn-PArr]{The @[::]@ type} -%* * +%* * %************************************************************************ Special syntax for parallel arrays needs some wired in definitions. @@ -546,13 +546,13 @@ parrTyCon = pcNonRecDataTyCon parrTyConName alpha_tyvar [parrDataCon] parrDataCon :: DataCon parrDataCon = pcDataCon - parrDataConName - alpha_tyvar -- forall'ed type variables - [intPrimTy, -- 1st argument: Int# - mkTyConApp -- 2nd argument: Array# a - arrayPrimTyCon - alpha_ty] - parrTyCon + parrDataConName + alpha_tyvar -- forall'ed type variables + [intTy, -- 1st argument: Int + mkTyConApp -- 2nd argument: Array# a + arrayPrimTyCon + alpha_ty] + parrTyCon -- | Check whether a type constructor is the constructor for parallel arrays isPArrTyCon :: TyCon -> Bool @@ -566,27 +566,27 @@ isPArrTyCon tc = tyConName tc == parrTyConName -- yet another constructor pattern -- parrFakeCon :: Arity -> DataCon -parrFakeCon i | i > mAX_TUPLE_SIZE = mkPArrFakeCon i -- build one specially +parrFakeCon i | i > mAX_TUPLE_SIZE = mkPArrFakeCon i -- build one specially parrFakeCon i = parrFakeConArr!i -- pre-defined set of constructors -- parrFakeConArr :: Array Int DataCon parrFakeConArr = array (0, mAX_TUPLE_SIZE) [(i, mkPArrFakeCon i) - | i <- [0..mAX_TUPLE_SIZE]] + | i <- [0..mAX_TUPLE_SIZE]] -- build a fake parallel array constructor for the given arity -- mkPArrFakeCon :: Int -> DataCon mkPArrFakeCon arity = data_con where - data_con = pcDataCon name [tyvar] tyvarTys parrTyCon - tyvar = head alphaTyVars - tyvarTys = replicate arity $ mkTyVarTy tyvar + data_con = pcDataCon name [tyvar] tyvarTys parrTyCon + tyvar = head alphaTyVars + tyvarTys = replicate arity $ mkTyVarTy tyvar nameStr = mkFastString ("MkPArr" ++ show arity) - name = mkWiredInName gHC_PARR' (mkDataOccFS nameStr) unique - (ADataCon data_con) UserSyntax - unique = mkPArrDataConUnique arity + name = mkWiredInName gHC_PARR' (mkDataOccFS nameStr) unique + (ADataCon data_con) UserSyntax + unique = mkPArrDataConUnique arity -- | Checks whether a data constructor is a fake constructor for parallel arrays isPArrFakeCon :: DataCon -> Bool diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 4dfe0195a9..ce2462c99f 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -947,6 +947,23 @@ primop WriteByteArrayOp_Word64 "writeWord64Array#" GenPrimOp MutableByteArray# s -> Int# -> WORD64 -> State# s -> State# s with has_side_effects = True +primop CopyByteArrayOp "copyByteArray#" GenPrimOp + ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + {Copy a range of the ByteArray# to the specified region in the MutableByteArray#. + Both arrays must fully contain the specified ranges, but this is not checked. + The two arrays must not be the same array in different states, but this is not checked either.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall } + +primop CopyMutableByteArrayOp "copyMutableByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + {Copy a range of the first MutableByteArray# to the specified region in the second MutableByteArray#. + Both arrays must fully contain the specified ranges, but this is not checked.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall } + ------------------------------------------------------------------------ section "Addr#" ------------------------------------------------------------------------ diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 80a47a4ff6..86acfa46b0 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -251,7 +251,13 @@ rnLocalValBindsLHS :: MiniFixityEnv -> HsValBinds RdrName -> RnM ([Name], HsValBindsLR Name RdrName) rnLocalValBindsLHS fix_env binds - = do { -- Do error checking: we need to check for dups here because we + = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds + + -- Check for duplicates and shadowing + -- Must do this *after* renaming the patterns + -- See Note [Collect binders only after renaming] in HsUtils + + -- We need to check for dups here because we -- don't don't bind all of the variables from the ValBinds at once -- with bindLocatedLocals any more. -- @@ -265,10 +271,10 @@ rnLocalValBindsLHS fix_env binds -- import A(f) -- g = let f = ... in f -- should. - ; binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds ; let bound_names = collectHsValBinders binds' ; envs <- getRdrEnvs ; checkDupAndShadowedNames envs bound_names + ; return (bound_names, binds') } -- renames the left-hand sides @@ -560,8 +566,9 @@ mkSigTvFn sigs where env :: NameEnv [Name] env = mkNameEnv [ (name, map hsLTyVarName ltvs) - | L _ (TypeSig (L _ name) - (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs] + | L _ (TypeSig names + (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs + , (L _ name) <- names] -- Note the pattern-match on "Explicit"; we only bind -- type variables from signatures with an explicit top-level for-all \end{code} @@ -693,16 +700,16 @@ renameSig :: Maybe NameSet -> Sig RdrName -> RnM (Sig Name) -- FixitySig is renamed elsewhere. renameSig _ (IdSig x) = return (IdSig x) -- Actually this never occurs -renameSig mb_names sig@(TypeSig v ty) - = do { new_v <- lookupSigOccRn mb_names sig v - ; new_ty <- rnHsSigType (quotes (ppr v)) ty - ; return (TypeSig new_v new_ty) } +renameSig mb_names sig@(TypeSig vs ty) + = do { new_vs <- mapM (lookupSigOccRn mb_names sig) vs + ; new_ty <- rnHsSigType (quotes (ppr vs)) ty + ; return (TypeSig new_vs new_ty) } -renameSig mb_names sig@(GenericSig v ty) +renameSig mb_names sig@(GenericSig vs ty) = do { defaultSigs_on <- xoptM Opt_DefaultSignatures ; unless defaultSigs_on (addErr (defaultSigErr sig)) - ; new_v <- lookupSigOccRn mb_names sig v - ; new_ty <- rnHsSigType (quotes (ppr v)) ty + ; new_v <- mapM (lookupSigOccRn mb_names sig) vs + ; new_ty <- rnHsSigType (quotes (ppr vs)) ty ; return (GenericSig new_v new_ty) } renameSig _ (SpecInstSig ty) diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 4492b52a60..58df462532 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -35,11 +35,11 @@ module RnEnv ( #include "HsVersions.h" import LoadIface ( loadInterfaceForName, loadSrcInterface ) -import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) +import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName, updNameCache, extendNameCache ) import HsSyn import RdrHsSyn ( extractHsTyRdrTyVars ) import RdrName -import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity) +import HscTypes ( NameCache(..), availNames, ModIface(..), FixItem(..), lookupFixity) import TcEnv ( tcLookupDataCon, tcLookupField, isBrackStage ) import TcRnMonad import Id ( isRecordSelector ) @@ -90,12 +90,19 @@ newTopSrcBinder (L loc rdr_name) -- very confused indeed. This test rejects code like -- data T = (,) Int Int -- unless we are in GHC.Tup - ASSERT2( isExternalName name, ppr name ) - do { this_mod <- getModule - ; unless (this_mod == nameModule name) - (addErrAt loc (badOrigBinding rdr_name)) - ; return name } - + if isExternalName name then + do { this_mod <- getModule + ; unless (this_mod == nameModule name) + (addErrAt loc (badOrigBinding rdr_name)) + ; return name } + else -- See Note [Binders in Template Haskell] in Convert.hs + do { let occ = nameOccName name + ; occ `seq` return () -- c.f. seq in newGlobalBinder + ; this_mod <- getModule + ; updNameCache $ \ ns -> + let name' = mkExternalName (nameUnique name) this_mod occ loc + ns' = ns { nsNames = extendNameCache (nsNames ns) this_mod occ name' } + in (ns', name') } | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name = do { this_mod <- getModule @@ -939,18 +946,20 @@ extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside ------------------------------------- checkDupRdrNames :: [Located RdrName] -> RnM () +-- Check for duplicated names in a binding group checkDupRdrNames rdr_names_w_loc - = -- Check for duplicated names in a binding group - mapM_ (dupNamesErr getLoc) dups + = mapM_ (dupNamesErr getLoc) dups where (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc checkDupNames :: [Name] -> RnM () +-- Check for duplicated names in a binding group checkDupNames names - = -- Check for duplicated names in a binding group - mapM_ (dupNamesErr nameSrcSpan) dups + = mapM_ (dupNamesErr nameSrcSpan) dups where - (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names + (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) $ + filterOut isSystemName names + -- See Note [Binders in Template Haskell] in Convert --------------------- checkDupAndShadowedRdrNames :: [Located RdrName] -> RnM () diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 71d134dabb..d841ad8b1f 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -53,6 +53,34 @@ import qualified Data.Map as Map %* * %************************************************************************ +Note [Trust Transitive Property] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +So there is an interesting design question in regards to transitive trust +checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch +of modules and packages, some packages it requires to be trusted as its using +-XTrustworthy modules from them. Now if I have a module A that doesn't use safe +haskell at all and simply imports B, should A inherit all the the trust +requirements from B? Should A now also require that a package p is trusted since +B required it? + +We currently say no but I saying yes also makes sense. The difference is, if a +module M that doesn't use SafeHaskell imports a module N that does, should all +the trusted package requirements be dropped since M didn't declare that it cares +about Safe Haskell (so -XSafe is more strongly associated with the module doing +the importing) or should it be done still since the author of the module N that +uses Safe Haskell said they cared (so -XSafe is more strongly associated with +the module that was compiled that used it). + +Going with yes is a simpler semantics we think and harder for the user to stuff +up but it does mean that SafeHaskell will affect users who don't care about +SafeHaskell as they might grab a package from Cabal which uses safe haskell (say +network) and that packages imports -XTrustworthy modules from another package +(say bytestring), so requires that package is trusted. The user may now get +compilation errors in code that doesn't do anything with Safe Haskell simply +because they are using the network package. They will have to call 'ghc-pkg +trust network' to get everything working. Due to this invasive nature of going +with yes we have gone with no for now. + \begin{code} rnImports :: [LImportDecl RdrName] -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails,AnyHpcUsage) @@ -65,7 +93,7 @@ rnImports imports implicit_prelude <- xoptM Opt_ImplicitPrelude let prel_imports = mkPrelImports (moduleName this_mod) implicit_prelude imports (source, ordinary) = partition is_source_import imports - is_source_import (L _ (ImportDecl _ _ is_boot _ _ _)) = is_boot + is_source_import (L _ (ImportDecl _ _ is_boot _ _ _ _)) = is_boot ifDOptM Opt_WarnImplicitPrelude ( when (notNull prel_imports) $ addWarn (implicitPreludeWarn) @@ -94,7 +122,8 @@ rnImportDecl :: Module -> Bool rnImportDecl this_mod implicit_prelude (L loc (ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg - , ideclSource = want_boot, ideclQualified = qual_only + , ideclSource = want_boot, ideclSafe = mod_safe + , ideclQualified = qual_only , ideclAs = as_mod, ideclHiding = imp_details })) = setSrcSpan loc $ do @@ -210,20 +239,32 @@ rnImportDecl this_mod implicit_prelude -- Imported module is from another package -- Dump the dependent modules -- Add the package imp_mod comes from to the dependent packages - ASSERT2( not (pkg `elem` dep_pkgs deps), ppr pkg <+> ppr (dep_pkgs deps) ) - ([], pkg : dep_pkgs deps) + ASSERT2( not (pkg `elem` (map fst $ dep_pkgs deps)), ppr pkg <+> ppr (dep_pkgs deps) ) + ([], (pkg, False) : dep_pkgs deps) -- True <=> import M () import_all = case imp_details of Just (is_hiding, ls) -> not is_hiding && null ls _ -> False + -- should the import be safe? + mod_safe' = mod_safe + || (not implicit_prelude && safeDirectImpsReq dflags) + || (implicit_prelude && safeImplicitImpsReq dflags) + imports = ImportAvails { - imp_mods = unitModuleEnv imp_mod [(qual_mod_name, import_all, loc)], - imp_orphs = orphans, - imp_finsts = finsts, - imp_dep_mods = mkModDeps dependent_mods, - imp_dep_pkgs = dependent_pkgs + imp_mods = unitModuleEnv imp_mod [(qual_mod_name, import_all, loc, mod_safe')], + imp_orphs = orphans, + imp_finsts = finsts, + imp_dep_mods = mkModDeps dependent_mods, + imp_dep_pkgs = map fst $ dependent_pkgs, + -- Add in the imported modules trusted package + -- requirements. ONLY do this though if we import the + -- module as a safe import. + -- see Note [Trust Transitive Property] + imp_trust_pkgs = if mod_safe' + then map fst $ filter snd dependent_pkgs + else [] } -- Complain if we import a deprecated module @@ -233,7 +274,7 @@ rnImportDecl this_mod implicit_prelude _ -> return () ) - let new_imp_decl = L loc (ImportDecl loc_imp_mod_name mb_pkg want_boot + let new_imp_decl = L loc (ImportDecl loc_imp_mod_name mb_pkg want_boot mod_safe' qual_only as_mod new_imp_details) return (new_imp_decl, gbl_env, imports, mi_hpc iface) @@ -472,7 +513,7 @@ get_local_binders gbl_env (HsGroup {hs_valds = ValBindsIn _ val_sigs, -- In a hs-boot file, the value binders come from the -- *signatures*, and there should be no foreign binders val_bndrs :: [Located RdrName] - val_bndrs | is_hs_boot = [nm | L _ (TypeSig nm _) <- val_sigs] + val_bndrs | is_hs_boot = [n | L _ (TypeSig ns _) <- val_sigs, n <- ns] | otherwise = for_hs_bndrs new_simple :: Located RdrName -> RnM (GenAvailInfo Name) @@ -908,7 +949,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod imported_modules = [ qual_name | xs <- moduleEnvElts $ imp_mods imports, - (qual_name, _, _) <- xs ] + (qual_name, _, _, _) <- xs ] exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum exports_from_item acc@(ie_names, occs, exports) diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 844a1f90c2..3a60066342 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -229,12 +229,15 @@ rnPats ctxt pats thing_inside ; bindPatSigTyVarsFV (collectSigTysFromPats pats) $ unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do { -- Check for duplicated and shadowed names - -- 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) = ... - ; let names = collectPatsBinders pats' - ; addErrCtxt doc_pat $ checkDupAndShadowedNames envs_before names + -- 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) = ... + ; addErrCtxt doc_pat $ + checkDupAndShadowedNames envs_before $ + collectPatsBinders pats' ; thing_inside pats' } } where doc_pat = ptext (sLit "In") <+> pprMatchContext ctxt diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 6b8e5c09ba..12d4375606 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -803,7 +803,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). - ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs] + ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _) <- sigs, op <- ops] ; checkDupRdrNames sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 6ddcff2b26..8e6ec5c870 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -8,10 +8,16 @@ module CoreMonad ( -- * Configuration of the core-to-core passes - CoreToDo(..), + CoreToDo(..), runWhen, runMaybe, SimplifierMode(..), FloatOutSwitches(..), - getCoreToDo, dumpSimplPhase, + dumpSimplPhase, + + defaultGentleSimplToDo, + + -- * Plugins + PluginPass, Plugin(..), CommandLineOption, + defaultPlugin, bindsOnlyPass, -- * Counting SimplCount, doSimplTick, doFreeSimplTick, simplCountN, @@ -198,6 +204,7 @@ showLintWarnings _ = True %************************************************************************ \begin{code} + data CoreToDo -- These are diff core-to-core passes, -- which may be invoked in any order, -- as many times as you like. @@ -205,7 +212,7 @@ data CoreToDo -- These are diff core-to-core passes, = CoreDoSimplify -- The core-to-core simplifier. Int -- Max iterations SimplifierMode - + | CoreDoPluginPass String PluginPass | CoreDoFloatInwards | CoreDoFloatOutwards FloatOutSwitches | CoreLiberateCase @@ -229,8 +236,12 @@ data CoreToDo -- These are diff core-to-core passes, | CoreTidy | CorePrep +\end{code} + +\begin{code} coreDumpFlag :: CoreToDo -> Maybe DynFlag coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases +coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_dump_core_pipeline coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core @@ -255,6 +266,7 @@ instance Outputable CoreToDo where ppr (CoreDoSimplify n md) = ptext (sLit "Simplifier") <+> ppr md <+> ptext (sLit "max-iterations=") <> int n + ppr (CoreDoPluginPass s _) = ptext (sLit "Core plugin: ") <+> text s ppr CoreDoFloatInwards = ptext (sLit "Float inwards") ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f) ppr CoreLiberateCase = ptext (sLit "Liberate case") @@ -327,200 +339,17 @@ pprFloatOutSwitches sw [ ptext (sLit "Lam =") <+> ppr (floatOutLambdas sw) , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw) , ptext (sLit "PAPs =") <+> ppr (floatOutPartialApplications sw) ]) -\end{code} - -%************************************************************************ -%* * - Generating the main optimisation pipeline -%* * -%************************************************************************ - -\begin{code} -getCoreToDo :: DynFlags -> [CoreToDo] -getCoreToDo dflags - = core_todo - where - opt_level = optLevel dflags - phases = simplPhases dflags - max_iter = maxSimplIterations dflags - rule_check = ruleCheck dflags - strictness = dopt Opt_Strictness dflags - full_laziness = dopt Opt_FullLaziness dflags - do_specialise = dopt Opt_Specialise dflags - do_float_in = dopt Opt_FloatIn dflags - cse = dopt Opt_CSE dflags - spec_constr = dopt Opt_SpecConstr dflags - liberate_case = dopt Opt_LiberateCase dflags - static_args = dopt Opt_StaticArgumentTransformation dflags - rules_on = dopt Opt_EnableRewriteRules dflags - eta_expand_on = dopt Opt_DoLambdaEtaExpansion dflags - - maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) - - maybe_strictness_before phase - = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness - - base_mode = SimplMode { sm_phase = panic "base_mode" - , sm_names = [] - , sm_rules = rules_on - , sm_eta_expand = eta_expand_on - , sm_inline = True - , sm_case_case = True } - - simpl_phase phase names iter - = CoreDoPasses - $ [ maybe_strictness_before phase - , CoreDoSimplify iter - (base_mode { sm_phase = Phase phase - , sm_names = names }) - - , maybe_rule_check (Phase phase) ] - - -- Vectorisation can introduce a fair few common sub expressions involving - -- DPH primitives. For example, see the Reverse test from dph-examples. - -- We need to eliminate these common sub expressions before their definitions - -- are inlined in phase 2. The CSE introduces lots of v1 = v2 bindings, - -- so we also run simpl_gently to inline them. - ++ (if dopt Opt_Vectorise dflags && phase == 3 - then [CoreCSE, simpl_gently] - else []) - - vectorisation - = runWhen (dopt Opt_Vectorise dflags) $ - CoreDoPasses [ simpl_gently, CoreDoVectorisation ] - - -- By default, we have 2 phases before phase 0. - - -- Want to run with inline phase 2 after the specialiser to give - -- maximum chance for fusion to work before we inline build/augment - -- in phase 1. This made a difference in 'ansi' where an - -- overloaded function wasn't inlined till too late. - - -- Need phase 1 so that build/augment get - -- inlined. I found that spectral/hartel/genfft lost some useful - -- strictness in the function sumcode' if augment is not inlined - -- before strictness analysis runs - simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter - | phase <- [phases, phases-1 .. 1] ] - - - -- initial simplify: mk specialiser happy: minimum effort please - simpl_gently = CoreDoSimplify max_iter - (base_mode { sm_phase = InitialPhase +-- | A reasonably gentle simplification pass for doing "obvious" simplifications +defaultGentleSimplToDo :: CoreToDo +defaultGentleSimplToDo = CoreDoSimplify 4 -- 4 is the default maxSimpleIterations + (SimplMode { sm_phase = InitialPhase , sm_names = ["Gentle"] - , sm_rules = rules_on -- Note [RULEs enabled in SimplGently] + , sm_rules = True -- Note [RULEs enabled in SimplGently] , sm_inline = False - , sm_case_case = False }) - -- Don't do case-of-case transformations. - -- This makes full laziness work better - - core_todo = - if opt_level == 0 then - [vectorisation, - simpl_phase 0 ["final"] max_iter] - else {- opt_level >= 1 -} [ - - -- We want to do the static argument transform before full laziness as it - -- may expose extra opportunities to float things outwards. However, to fix - -- up the output of the transformation we need at do at least one simplify - -- after this before anything else - runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]), - - -- We run vectorisation here for now, but we might also try to run - -- it later - vectorisation, - - -- initial simplify: mk specialiser happy: minimum effort please - simpl_gently, - - -- Specialisation is best done before full laziness - -- so that overloaded functions have all their dictionary lambdas manifest - runWhen do_specialise CoreDoSpecialising, - - runWhen full_laziness $ - CoreDoFloatOutwards FloatOutSwitches { - floatOutLambdas = Just 0, - floatOutConstants = True, - floatOutPartialApplications = False }, - -- Was: gentleFloatOutSwitches - -- - -- I have no idea why, but not floating constants to - -- top level is very bad in some cases. - -- - -- Notably: p_ident in spectral/rewrite - -- Changing from "gentle" to "constantsOnly" - -- improved rewrite's allocation by 19%, and - -- made 0.0% difference to any other nofib - -- benchmark - -- - -- Not doing floatOutPartialApplications yet, we'll do - -- that later on when we've had a chance to get more - -- accurate arity information. In fact it makes no - -- difference at all to performance if we do it here, - -- but maybe we save some unnecessary to-and-fro in - -- the simplifier. - - runWhen do_float_in CoreDoFloatInwards, - - simpl_phases, - - -- Phase 0: allow all Ids to be inlined now - -- This gets foldr inlined before strictness analysis - - -- At least 3 iterations because otherwise we land up with - -- huge dead expressions because of an infelicity in the - -- simpifier. - -- let k = BIG in foldr k z xs - -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs - -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs - -- Don't stop now! - simpl_phase 0 ["main"] (max max_iter 3), - - runWhen strictness (CoreDoPasses [ - CoreDoStrictness, - CoreDoWorkerWrapper, - CoreDoGlomBinds, - simpl_phase 0 ["post-worker-wrapper"] max_iter - ]), - - runWhen full_laziness $ - CoreDoFloatOutwards FloatOutSwitches { - floatOutLambdas = floatLamArgs dflags, - floatOutConstants = True, - floatOutPartialApplications = True }, - -- nofib/spectral/hartel/wang doubles in speed if you - -- do full laziness late in the day. It only happens - -- after fusion and other stuff, so the early pass doesn't - -- catch it. For the record, the redex is - -- f_el22 (f_el21 r_midblock) - - - runWhen cse CoreCSE, - -- We want CSE to follow the final full-laziness pass, because it may - -- succeed in commoning up things floated out by full laziness. - -- CSE used to rely on the no-shadowing invariant, but it doesn't any more - - runWhen do_float_in CoreDoFloatInwards, - - maybe_rule_check (Phase 0), - - -- Case-liberation for -O2. This should be after - -- strictness analysis and the simplification which follows it. - runWhen liberate_case (CoreDoPasses [ - CoreLiberateCase, - simpl_phase 0 ["post-liberate-case"] max_iter - ]), -- Run the simplifier after LiberateCase to vastly - -- reduce the possiblility of shadowing - -- Reason: see Note [Shadowing] in SpecConstr.lhs - - runWhen spec_constr CoreDoSpecConstr, - - maybe_rule_check (Phase 0), - - -- Final clean-up simplification: - simpl_phase 0 ["final"] max_iter - ] + , sm_eta_expand = False + , sm_case_case = False + }) -- The core-to-core pass ordering is derived from the DynFlags: runWhen :: Bool -> CoreToDo -> CoreToDo @@ -531,6 +360,7 @@ runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo runMaybe (Just x) f = f x runMaybe Nothing _ = CoreDoNothing + dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool dumpSimplPhase dflags mode | Just spec_string <- shouldDumpSimplPhase dflags @@ -579,6 +409,47 @@ to switch off those rules until after floating. %************************************************************************ %* * + Types for Plugins +%* * +%************************************************************************ + +\begin{code} +-- | Command line options gathered from the -PModule.Name:stuff syntax are given to you as this type +type CommandLineOption = String + +-- | 'Plugin' is the core compiler plugin data type. Try to avoid +-- constructing one of these directly, and just modify some fields of +-- 'defaultPlugin' instead: this is to try and preserve source-code +-- compatability when we add fields to this. +-- +-- Nonetheless, this API is preliminary and highly likely to change in the future. +data Plugin = Plugin { + installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] + -- ^ Modify the Core pipeline that will be used for compilation. + -- This is called as the Core pipeline is built for every module + -- being compiled, and plugins get the opportunity to modify + -- the pipeline in a nondeterministic order. + } + +-- | Default plugin: does nothing at all! For compatability reasons you should base all your +-- plugin definitions on this default value. +defaultPlugin :: Plugin +defaultPlugin = Plugin { + installCoreToDos = const return + } + +-- | A description of the plugin pass itself +type PluginPass = ModGuts -> CoreM ModGuts + +bindsOnlyPass :: ([CoreBind] -> CoreM [CoreBind]) -> ModGuts -> CoreM ModGuts +bindsOnlyPass pass guts + = do { binds' <- pass (mg_binds guts) + ; return (guts { mg_binds = binds' }) } +\end{code} + + +%************************************************************************ +%* * Counting and logging %* * %************************************************************************ @@ -955,7 +826,6 @@ liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> re %************************************************************************ \begin{code} - getHscEnv :: CoreM HscEnv getHscEnv = read cr_hsc_env @@ -979,7 +849,6 @@ getOrigNameCache :: CoreM OrigNameCache getOrigNameCache = do nameCacheRef <- fmap hsc_NC getHscEnv liftIO $ fmap nsNames $ readIORef nameCacheRef - \end{code} diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 59aba4b030..34ffacb208 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -8,7 +8,7 @@ module SimplCore ( core2core, simplifyExpr ) where #include "HsVersions.h" -import DynFlags ( DynFlags, DynFlag(..), dopt ) +import DynFlags import CoreSyn import CoreSubst import HscTypes @@ -29,7 +29,7 @@ import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FamInstEnv import Id -import BasicTypes +import BasicTypes ( CompilerPhase(..), isDefaultInlinePragma ) import VarSet import VarEnv import LiberateCase ( liberateCase ) @@ -45,6 +45,16 @@ import Util import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import Outputable import Control.Monad + +#ifdef GHCI +import Type ( mkTyConTy ) +import RdrName ( mkRdrQual ) +import OccName ( mkVarOcc ) +import PrelNames ( pluginTyConName ) +import DynamicLoading ( forceLoadTyCon, lookupRdrNameInModule, getValueSafely ) +import Module ( ModuleName ) +import Panic +#endif \end{code} %************************************************************************ @@ -57,9 +67,18 @@ import Control.Monad core2core :: HscEnv -> ModGuts -> IO ModGuts core2core hsc_env guts = do { us <- mkSplitUniqSupply 's' - ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $ - doCorePasses (getCoreToDo dflags) guts - + -- make sure all plugins are loaded + + ; let builtin_passes = getCoreToDo dflags + ; + ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $ + do { all_passes <- addPluginPasses dflags builtin_passes + ; runCorePasses all_passes guts } + +{-- + ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_pipeline + "Plugin information" "" -- TODO FIXME: dump plugin info +--} ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Grand total simplifier statistics" (pprSimplCount stats) @@ -75,16 +94,262 @@ core2core hsc_env guts -- consume the ModGuts to find the module) but somewhat ugly because mg_module may -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which -- would mean our cached value would go out of date. +\end{code} + + +%************************************************************************ +%* * + Generating the main optimisation pipeline +%* * +%************************************************************************ + +\begin{code} +getCoreToDo :: DynFlags -> [CoreToDo] +getCoreToDo dflags + = core_todo + where + opt_level = optLevel dflags + phases = simplPhases dflags + max_iter = maxSimplIterations dflags + rule_check = ruleCheck dflags + strictness = dopt Opt_Strictness dflags + full_laziness = dopt Opt_FullLaziness dflags + do_specialise = dopt Opt_Specialise dflags + do_float_in = dopt Opt_FloatIn dflags + cse = dopt Opt_CSE dflags + spec_constr = dopt Opt_SpecConstr dflags + liberate_case = dopt Opt_LiberateCase dflags + static_args = dopt Opt_StaticArgumentTransformation dflags + rules_on = dopt Opt_EnableRewriteRules dflags + eta_expand_on = dopt Opt_DoLambdaEtaExpansion dflags + + maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) + + maybe_strictness_before phase + = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness + + base_mode = SimplMode { sm_phase = panic "base_mode" + , sm_names = [] + , sm_rules = rules_on + , sm_eta_expand = eta_expand_on + , sm_inline = True + , sm_case_case = True } + + simpl_phase phase names iter + = CoreDoPasses + $ [ maybe_strictness_before phase + , CoreDoSimplify iter + (base_mode { sm_phase = Phase phase + , sm_names = names }) + + , maybe_rule_check (Phase phase) ] + + -- Vectorisation can introduce a fair few common sub expressions involving + -- DPH primitives. For example, see the Reverse test from dph-examples. + -- We need to eliminate these common sub expressions before their definitions + -- are inlined in phase 2. The CSE introduces lots of v1 = v2 bindings, + -- so we also run simpl_gently to inline them. + ++ (if dopt Opt_Vectorise dflags && phase == 3 + then [CoreCSE, simpl_gently] + else []) + + vectorisation + = runWhen (dopt Opt_Vectorise dflags) $ + CoreDoPasses [ simpl_gently, CoreDoVectorisation ] + + -- By default, we have 2 phases before phase 0. + + -- Want to run with inline phase 2 after the specialiser to give + -- maximum chance for fusion to work before we inline build/augment + -- in phase 1. This made a difference in 'ansi' where an + -- overloaded function wasn't inlined till too late. + + -- Need phase 1 so that build/augment get + -- inlined. I found that spectral/hartel/genfft lost some useful + -- strictness in the function sumcode' if augment is not inlined + -- before strictness analysis runs + simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter + | phase <- [phases, phases-1 .. 1] ] + + + -- initial simplify: mk specialiser happy: minimum effort please + simpl_gently = CoreDoSimplify max_iter + (base_mode { sm_phase = InitialPhase + , sm_names = ["Gentle"] + , sm_rules = rules_on -- Note [RULEs enabled in SimplGently] + , sm_inline = False + , sm_case_case = False }) + -- Don't do case-of-case transformations. + -- This makes full laziness work better + + core_todo = + if opt_level == 0 then + [vectorisation, + simpl_phase 0 ["final"] max_iter] + else {- opt_level >= 1 -} [ + + -- We want to do the static argument transform before full laziness as it + -- may expose extra opportunities to float things outwards. However, to fix + -- up the output of the transformation we need at do at least one simplify + -- after this before anything else + runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]), + + -- We run vectorisation here for now, but we might also try to run + -- it later + vectorisation, + + -- initial simplify: mk specialiser happy: minimum effort please + simpl_gently, + + -- Specialisation is best done before full laziness + -- so that overloaded functions have all their dictionary lambdas manifest + runWhen do_specialise CoreDoSpecialising, + + runWhen full_laziness $ + CoreDoFloatOutwards FloatOutSwitches { + floatOutLambdas = Just 0, + floatOutConstants = True, + floatOutPartialApplications = False }, + -- Was: gentleFloatOutSwitches + -- + -- I have no idea why, but not floating constants to + -- top level is very bad in some cases. + -- + -- Notably: p_ident in spectral/rewrite + -- Changing from "gentle" to "constantsOnly" + -- improved rewrite's allocation by 19%, and + -- made 0.0% difference to any other nofib + -- benchmark + -- + -- Not doing floatOutPartialApplications yet, we'll do + -- that later on when we've had a chance to get more + -- accurate arity information. In fact it makes no + -- difference at all to performance if we do it here, + -- but maybe we save some unnecessary to-and-fro in + -- the simplifier. + + runWhen do_float_in CoreDoFloatInwards, + + simpl_phases, + + -- Phase 0: allow all Ids to be inlined now + -- This gets foldr inlined before strictness analysis + + -- At least 3 iterations because otherwise we land up with + -- huge dead expressions because of an infelicity in the + -- simpifier. + -- let k = BIG in foldr k z xs + -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs + -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs + -- Don't stop now! + simpl_phase 0 ["main"] (max max_iter 3), + + runWhen strictness (CoreDoPasses [ + CoreDoStrictness, + CoreDoWorkerWrapper, + CoreDoGlomBinds, + simpl_phase 0 ["post-worker-wrapper"] max_iter + ]), + + runWhen full_laziness $ + CoreDoFloatOutwards FloatOutSwitches { + floatOutLambdas = floatLamArgs dflags, + floatOutConstants = True, + floatOutPartialApplications = True }, + -- nofib/spectral/hartel/wang doubles in speed if you + -- do full laziness late in the day. It only happens + -- after fusion and other stuff, so the early pass doesn't + -- catch it. For the record, the redex is + -- f_el22 (f_el21 r_midblock) + + + runWhen cse CoreCSE, + -- We want CSE to follow the final full-laziness pass, because it may + -- succeed in commoning up things floated out by full laziness. + -- CSE used to rely on the no-shadowing invariant, but it doesn't any more + + runWhen do_float_in CoreDoFloatInwards, + + maybe_rule_check (Phase 0), + + -- Case-liberation for -O2. This should be after + -- strictness analysis and the simplification which follows it. + runWhen liberate_case (CoreDoPasses [ + CoreLiberateCase, + simpl_phase 0 ["post-liberate-case"] max_iter + ]), -- Run the simplifier after LiberateCase to vastly + -- reduce the possiblility of shadowing + -- Reason: see Note [Shadowing] in SpecConstr.lhs + + runWhen spec_constr CoreDoSpecConstr, + + maybe_rule_check (Phase 0), + + -- Final clean-up simplification: + simpl_phase 0 ["final"] max_iter + ] +\end{code} -type CorePass = CoreToDo +Loading plugins -doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts -doCorePasses passes guts +\begin{code} +addPluginPasses :: DynFlags -> [CoreToDo] -> CoreM [CoreToDo] +#ifndef GHCI +addPluginPasses _ builtin_passes = return builtin_passes +#else +addPluginPasses dflags builtin_passes + = do { hsc_env <- getHscEnv + ; named_plugins <- liftIO (loadPlugins hsc_env) + ; foldM query_plug builtin_passes named_plugins } + where + query_plug todos (mod_nm, plug) + = installCoreToDos plug options todos + where + options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags + , opt_mod_nm == mod_nm ] + +loadPlugins :: HscEnv -> IO [(ModuleName, Plugin)] +loadPlugins hsc_env + = do { let to_load = pluginModNames (hsc_dflags hsc_env) + ; plugins <- mapM (loadPlugin hsc_env) to_load + ; return $ to_load `zip` plugins } + +loadPlugin :: HscEnv -> ModuleName -> IO Plugin +loadPlugin hsc_env mod_name + = do { let plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "plugin") + ; mb_name <- lookupRdrNameInModule hsc_env mod_name plugin_rdr_name + ; case mb_name of { + Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep + [ ptext (sLit "The module"), ppr mod_name + , ptext (sLit "did not export the plugin name") + , ppr plugin_rdr_name ]) ; + Just name -> + + do { plugin_tycon <- forceLoadTyCon hsc_env pluginTyConName + ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) + ; case mb_plugin of + Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep + [ ptext (sLit "The value"), ppr name + , ptext (sLit "did not have the type") + , ppr pluginTyConName, ptext (sLit "as required")]) + Just plugin -> return plugin } } } +#endif +\end{code} + +%************************************************************************ +%* * + The CoreToDo interpreter +%* * +%************************************************************************ + +\begin{code} +runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts +runCorePasses passes guts = foldM do_pass guts passes where do_pass guts CoreDoNothing = return guts - do_pass guts (CoreDoPasses ps) = doCorePasses ps guts + do_pass guts (CoreDoPasses ps) = runCorePasses ps guts do_pass guts pass = do { dflags <- getDynFlags ; liftIO $ showPass dflags pass @@ -92,7 +357,7 @@ doCorePasses passes guts ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts') ; return guts' } -doCorePass :: CorePass -> ModGuts -> CoreM ModGuts +doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} simplifyPgm pass @@ -128,9 +393,14 @@ doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-} doCorePass CoreDoGlomBinds = doPassDM glomBinds doCorePass CoreDoPrintCore = observe printCore -doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat +doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat doCorePass CoreDoNothing = return -doCorePass (CoreDoPasses passes) = doCorePasses passes +doCorePass (CoreDoPasses passes) = runCorePasses passes + +#ifdef GHCI +doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass +#endif + doCorePass pass = pprPanic "doCorePass" (ppr pass) \end{code} @@ -144,8 +414,8 @@ doCorePass pass = pprPanic "doCorePass" (ppr pass) printCore :: a -> [CoreBind] -> IO () printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds) -ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts -ruleCheck current_phase pat guts = do +ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts +ruleCheckPass current_phase pat guts = do rb <- getRuleBase dflags <- getDynFlags liftIO $ Err.showPass dflags "RuleCheck" diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 378bbd607d..028f339c88 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -13,8 +13,8 @@ module Inst ( newOverloadedLit, mkOverLit, - tcGetInstEnvs, getOverlapFlag, tcExtendLocalInstEnv, - instCallConstraints, newMethodFromName, + tcGetInstEnvs, getOverlapFlag, + tcExtendLocalInstEnv, instCallConstraints, newMethodFromName, tcSyntaxName, -- Simple functions over evidence variables @@ -368,14 +368,15 @@ syntaxNameCtxt name orig ty tidy_env = do \begin{code} getOverlapFlag :: TcM OverlapFlag getOverlapFlag - = do { dflags <- getDOpts - ; let overlap_ok = xopt Opt_OverlappingInstances dflags - incoherent_ok = xopt Opt_IncoherentInstances dflags - overlap_flag | incoherent_ok = Incoherent - | overlap_ok = OverlapOk - | otherwise = NoOverlap - - ; return overlap_flag } + = do { dflags <- getDOpts + ; let overlap_ok = xopt Opt_OverlappingInstances dflags + incoherent_ok = xopt Opt_IncoherentInstances dflags + safeOverlap = safeLanguageOn dflags + overlap_flag | incoherent_ok = Incoherent safeOverlap + | overlap_ok = OverlapOk safeOverlap + | otherwise = NoOverlap safeOverlap + + ; return overlap_flag } tcGetInstEnvs :: TcM (InstEnv, InstEnv) -- Gets both the external-package inst-env @@ -429,7 +430,7 @@ addLocalInst home_ie ispec Nothing -> return () -- Check for duplicate instance decls - ; let { (matches, _) = lookupInstEnv inst_envs cls tys' + ; let { (matches, _, _) = lookupInstEnv inst_envs cls tys' ; dup_ispecs = [ dup_ispec | (dup_ispec, _) <- matches , let (_,_,_,dup_tys) = instanceHead dup_ispec diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index b5bbeb1940..33254c1b5a 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -102,11 +102,12 @@ tcHsBootSigs :: HsValBinds Name -> TcM [Id] -- signatures in it. The renamer checked all this tcHsBootSigs (ValBindsOut binds sigs) = do { checkTc (null binds) badBootDeclErr - ; mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } + ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } where - tc_boot_sig (TypeSig (L _ name) ty) - = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty - ; return (mkVanillaGlobal name sigma_ty) } + tc_boot_sig (TypeSig lnames ty) = mapM f lnames + where + f (L _ name) = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty + ; return (mkVanillaGlobal name sigma_ty) } -- Notice that we make GlobalIds, not LocalIds tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups) @@ -177,7 +178,7 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside ; ty_sigs = filter isTypeLSig sigs ; sig_fn = mkSigFun ty_sigs } - ; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs) + ; poly_ids <- concat <$> checkNoErrs (mapAndRecoverM tcTySig ty_sigs) -- No recovery from bad signatures, because the type sigs -- may bind type variables, so proceeding without them -- can lead to a cascade of errors @@ -1080,10 +1081,12 @@ mkSigFun :: [LSig Name] -> SigFun -- Precondition: no duplicates mkSigFun sigs = lookupNameEnv env where - env = mkNameEnv (mapCatMaybes mk_pair sigs) - mk_pair (L loc (TypeSig (L _ name) lhs_ty)) = Just (name, (hsExplicitTvs lhs_ty, loc)) - mk_pair (L loc (IdSig id)) = Just (idName id, ([], loc)) - mk_pair _ = Nothing + env = mkNameEnv (concatMap mk_pair sigs) + mk_pair (L loc (IdSig id)) = [(idName id, ([], loc))] + mk_pair (L loc (TypeSig lnames lhs_ty)) = map f lnames + where + f (L _ name) = (name, (hsExplicitTvs lhs_ty, loc)) + mk_pair _ = [] -- The scoped names are the ones explicitly mentioned -- in the HsForAll. (There may be more in sigma_ty, because -- of nested type synonyms. See Note [More instantiated than scoped].) @@ -1091,13 +1094,14 @@ mkSigFun sigs = lookupNameEnv env \end{code} \begin{code} -tcTySig :: LSig Name -> TcM TcId -tcTySig (L span (TypeSig (L _ name) ty)) - = setSrcSpan span $ - do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty - ; return (mkLocalId name sigma_ty) } +tcTySig :: LSig Name -> TcM [TcId] +tcTySig (L span (TypeSig names ty)) + = setSrcSpan span $ mapM f names + where + f (L _ name) = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty + ; return (mkLocalId name sigma_ty) } tcTySig (L _ (IdSig id)) - = return id + = return [id] tcTySig s = pprPanic "tcTySig" (ppr s) ------------------- diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 66a37388f1..07ada2bd04 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -475,7 +475,9 @@ canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2) -- See Note [Equality between type applications] -- Note [Care with type applications] in TcUnify canEq fl cv ty1 ty2 - | Just (s1,t1) <- tcSplitAppTy_maybe ty1 + | Nothing <- tcView ty1 -- Naked applications ONLY + , Nothing <- tcView ty2 -- See Note [Naked given applications] + , Just (s1,t1) <- tcSplitAppTy_maybe ty1 , Just (s2,t2) <- tcSplitAppTy_maybe ty2 = if isWanted fl then do { cv1 <- newCoVar s1 s2 @@ -493,8 +495,12 @@ canEq fl cv ty1 ty2 ; cc2 <- canEq fl cv2 t1 t2 ; return (cc1 `andCCan` cc2) } - else return emptyCCan -- We cannot decompose given applications - -- because we no longer have 'left' and 'right' + else do { traceTcS "canEq/(app case)" $ + text "Ommitting decomposition of given equality between: " + <+> ppr ty1 <+> text "and" <+> ppr ty2 + ; return emptyCCan -- We cannot decompose given applications + -- because we no longer have 'left' and 'right' + } canEq fl cv s1@(ForAllTy {}) s2@(ForAllTy {}) | tcIsForAllTy s1, tcIsForAllTy s2, @@ -513,6 +519,25 @@ canEqFailure :: CtFlavor -> EvVar -> TcS CanonicalCts canEqFailure fl cv = return (singleCCan (mkFrozenError fl cv)) \end{code} +Note [Naked given applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + data A a + type T a = A a +and the given equality: + [G] A a ~ T Int +We will reach the case canEq where we do a tcSplitAppTy_maybe, but if +we dont have the guards (Nothing <- tcView ty1) (Nothing <- tcView +ty2) then the given equation is going to fall through and get +completely forgotten! + +What we want instead is this clause to apply only when there is no +immediate top-level synonym; if there is one it will be later on +unfolded by the later stages of canEq. + +Test-case is in typecheck/should_compile/GivenTypeSynonym.hs + + Note [Equality between type applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we see an equality of the form s1 t1 ~ s2 t2 we can always split diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 8fc8a24e7a..2663895443 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -89,10 +89,10 @@ tcClassSigs :: Name -- Name of the class -> TcM ([TcMethInfo], -- Exactly one for each method NameEnv Type) -- Types of the generic-default methods tcClassSigs clas sigs def_methods - = do { gen_dm_prs <- mapM (addLocM tc_gen_sig) gen_sigs + = do { gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs ; let gen_dm_env = mkNameEnv gen_dm_prs - ; op_info <- mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs + ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ] ; sequence_ [ failWithTc (badMethodErr clas n) @@ -110,16 +110,17 @@ tcClassSigs clas sigs def_methods dm_bind_names :: [Name] -- These ones have a value binding in the class decl dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] - tc_sig genop_env (L _ op_name, op_hs_ty) + tc_sig genop_env (op_names, op_hs_ty) = do { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope - ; let dm | op_name `elemNameEnv` genop_env = GenericDM - | op_name `elem` dm_bind_names = VanillaDM - | otherwise = NoDM - ; return (op_name, dm, op_ty) } + ; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] } + where + f nm | nm `elemNameEnv` genop_env = GenericDM + | nm `elem` dm_bind_names = VanillaDM + | otherwise = NoDM - tc_gen_sig (L _ op_name, gen_hs_ty) + tc_gen_sig (op_names, gen_hs_ty) = do { gen_op_ty <- tcHsKindedType gen_hs_ty - ; return (op_name, gen_op_ty) } + ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] } \end{code} diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index fab7c61ff0..45d54123ef 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -1073,7 +1073,7 @@ checkFlag flag (dflags, _) where why = ptext (sLit "You need -X") <> text flag_str <+> ptext (sLit "to derive an instance for this class") - flag_str = case [ s | (s, f, _) <- xFlags, f==flag ] of + flag_str = case [ s | (s, _, f, _) <- xFlags, f==flag ] of [s] -> s other -> pprPanic "checkFlag" (ppr other) @@ -1490,8 +1490,8 @@ the renamer. What a great hack! -- Representation tycons differ from the tycon in the instance signature in -- case of instances for indexed families. -- -genInst :: Bool -- True <=> standalone deriving - -> OverlapFlag +genInst :: Bool -- True <=> standalone deriving + -> OverlapFlag -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds) genInst standalone_deriv oflag spec@(DS { ds_tc = rep_tycon, ds_tc_args = rep_tc_args @@ -1641,7 +1641,8 @@ genGenericAll tc = -} genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)] genDtMeta (tc,metaDts) = - do dClas <- tcLookupClass datatypeClassName + do dflags <- getDOpts + dClas <- tcLookupClass datatypeClassName d_dfun_name <- new_dfun_name dClas tc cClas <- tcLookupClass constructorClassName c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ] @@ -1652,11 +1653,12 @@ genDtMeta (tc,metaDts) = fix_env <- getFixityEnv let + safeOverlap = safeLanguageOn dflags (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc -- Datatype d_metaTycon = metaD metaDts - d_inst = mkLocalInstance d_dfun NoOverlap + d_inst = mkLocalInstance d_dfun $ NoOverlap safeOverlap d_binds = VanillaInst dBinds [] False d_dfun = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas [ mkTyConTy d_metaTycon ] @@ -1664,7 +1666,7 @@ genDtMeta (tc,metaDts) = -- Constructor c_metaTycons = metaC metaDts - c_insts = [ mkLocalInstance (c_dfun c ds) NoOverlap + c_insts = [ mkLocalInstance (c_dfun c ds) $ NoOverlap safeOverlap | (c, ds) <- myZip1 c_metaTycons c_dfun_names ] c_binds = [ VanillaInst c [] False | c <- cBinds ] c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas @@ -1674,7 +1676,8 @@ genDtMeta (tc,metaDts) = -- Selector s_metaTycons = metaS metaDts - s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) NoOverlap)) + s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) $ + NoOverlap safeOverlap)) (myZip2 s_metaTycons s_dfun_names) s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ] s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index b199053ac2..d43ba774e8 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -562,16 +562,17 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) -- Note [Flattening in error message generation] ; case lookupInstEnv inst_envs clas tys_flat of - ([], _) -> return (Just pred) -- No match + ([], _, _) -> return (Just pred) -- No match -- The case of exactly one match and no unifiers means a -- successful lookup. That can't happen here, because dicts -- only end up here if they didn't match in Inst.lookupInst - ([_],[]) + ([_],[], _) | debugIsOn -> pprPanic "check_overlap" (ppr pred) res -> do { addErrorReport ctxt (mk_overlap_msg res) ; return Nothing } } where - mk_overlap_msg (matches, unifiers) + -- Normal overlap error + mk_overlap_msg (matches, unifiers, False) = ASSERT( not (null matches) ) vcat [ addArising orig (ptext (sLit "Overlapping instances for") <+> pprPredTy pred) @@ -600,33 +601,50 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"), ptext (sLit "when compiling the other instance declarations")] else empty])] - where - ispecs = [ispec | (ispec, _) <- matches] - - givens = getUserGivens ctxt - overlapping_givens = unifiable_givens givens - - unifiable_givens [] = [] - unifiable_givens (gg:ggs) - | Just ggdoc <- matchable gg - = ggdoc : unifiable_givens ggs - | otherwise - = unifiable_givens ggs - - matchable (evvars,gloc) - = case ev_vars_matching of - [] -> Nothing - _ -> Just $ hang (pprTheta ev_vars_matching) - 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc) - , ptext (sLit "at") <+> ppr (ctLocSpan gloc)]) - where ev_vars_matching = filter ev_var_matches (map evVarPred evvars) - ev_var_matches (ClassP clas' tys') - | clas' == clas - , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys' - = True - ev_var_matches (ClassP clas' tys') = - any ev_var_matches (immSuperClasses clas' tys') - ev_var_matches _ = False + where + ispecs = [ispec | (ispec, _) <- matches] + + givens = getUserGivens ctxt + overlapping_givens = unifiable_givens givens + + unifiable_givens [] = [] + unifiable_givens (gg:ggs) + | Just ggdoc <- matchable gg + = ggdoc : unifiable_givens ggs + | otherwise + = unifiable_givens ggs + + matchable (evvars,gloc) + = case ev_vars_matching of + [] -> Nothing + _ -> Just $ hang (pprTheta ev_vars_matching) + 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc) + , ptext (sLit "at") <+> ppr (ctLocSpan gloc)]) + where ev_vars_matching = filter ev_var_matches (map evVarPred evvars) + ev_var_matches (ClassP clas' tys') + | clas' == clas + , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys' + = True + ev_var_matches (ClassP clas' tys') = + any ev_var_matches (immSuperClasses clas' tys') + ev_var_matches _ = False + + -- Overlap error because of SafeHaskell (first match should be the most + -- specific match) + mk_overlap_msg (matches, _unifiers, True) + = ASSERT( length matches > 1 ) + vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") + <+> pprPredTy pred) + , sep [ptext (sLit "The matching instance is") <> colon, + nest 2 (pprInstance $ head ispecs)] + , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only" + , ptext $ sLit "overlap instances from the same module, however it" + , ptext $ sLit "overlaps the following instances from different modules:" + , nest 2 (vcat [pprInstances $ tail ispecs]) + ] + ] + where + ispecs = [ispec | (ispec, _) <- matches] reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 8f53d6e7b8..a24eb47b9d 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -107,8 +107,8 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do checkSafety safety case arg_tys of [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys - checkForeignRes nonIOok isFFIExportResultTy res1_ty - checkForeignRes mustBeIO isFFIDynResultTy res_ty + checkForeignRes nonIOok False isFFIExportResultTy res1_ty + checkForeignRes mustBeIO False isFFIDynResultTy res_ty where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty _ -> addErrTc (illegalForeignTyErr empty sig_ty) @@ -128,7 +128,9 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar check (isFFIDynArgumentTy arg1_ty) (illegalForeignTyErr argument arg1_ty) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys - checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty + let safe_on = safeLanguageOn dflags + ioOK = if safe_on then mustBeIO else nonIOok + checkForeignRes ioOK safe_on (isFFIImportResultTy dflags) res_ty return idecl | cconv == PrimCallConv = do dflags <- getDOpts @@ -140,7 +142,9 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar (text "The safe/unsafe annotation should not be used with `foreign import prim'.") checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys -- prim import result is more liberal, allows (#,,#) - checkForeignRes nonIOok (isFFIPrimResultTy dflags) res_ty + let safe_on = safeLanguageOn dflags + ioOK = if safe_on then mustBeIO else nonIOok + checkForeignRes ioOK safe_on (isFFIPrimResultTy dflags) res_ty return idecl | otherwise = do -- Normal foreign import checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp) @@ -149,7 +153,9 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar checkCTarget target dflags <- getDOpts checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys - checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty + let safe_on = safeLanguageOn dflags + ioOK = if safe_on then mustBeIO else nonIOok + checkForeignRes ioOK safe_on (isFFIImportResultTy dflags) res_ty checkMissingAmpersand dflags arg_tys res_ty return idecl @@ -221,7 +227,7 @@ tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do check (isCLabelString str) (badCName str) checkCConv cconv checkForeignArgs isFFIExternalTy arg_tys - checkForeignRes nonIOok isFFIExportResultTy res_ty + checkForeignRes nonIOok False isFFIExportResultTy res_ty where -- Drop the foralls before inspecting n -- the structure of the foreign type. @@ -249,13 +255,13 @@ checkForeignArgs pred tys -- Check that the type has the form -- (IO t) or (t) , and that t satisfies the given predicate. -- -checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM () +checkForeignRes :: Bool -> Bool -> (Type -> Bool) -> Type -> TcM () nonIOok, mustBeIO :: Bool nonIOok = True mustBeIO = False -checkForeignRes non_io_result_ok pred_res_ty ty +checkForeignRes non_io_result_ok safehs_check pred_res_ty ty -- (IO t) is ok, and so is any newtype wrapping thereof | Just (_, res_ty, _) <- tcSplitIOType_maybe ty, pred_res_ty res_ty @@ -263,7 +269,7 @@ checkForeignRes non_io_result_ok pred_res_ty ty | otherwise = check (non_io_result_ok && pred_res_ty ty) - (illegalForeignTyErr result ty) + (illegalForeignTyErr result ty $+$ safeHsErr safehs_check) \end{code} \begin{code} @@ -338,6 +344,10 @@ illegalForeignTyErr arg_or_res ty ptext (sLit "type in foreign declaration:")]) 2 (hsep [ppr ty]) +safeHsErr :: Bool -> SDoc +safeHsErr False = empty +safeHsErr True = ptext $ sLit "Safe Haskell is on, all FFI imports must be in the IO monad" + -- Used for 'arg_or_res' argument to illegalForeignTyErr argument, result :: SDoc argument = text "argument" diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index ad640efec8..e4129103fe 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -1670,7 +1670,7 @@ fiddling around. genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName) genAuxBind loc (GenCon2Tag tycon) = (mk_FunBind loc rdr_name eqns, - L loc (TypeSig (L loc rdr_name) (L loc sig_ty))) + L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) where rdr_name = con2tag_RDR tycon @@ -1695,7 +1695,7 @@ genAuxBind loc (GenTag2Con tycon) = (mk_FunBind loc rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], - L loc (TypeSig (L loc rdr_name) (L loc sig_ty))) + L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) where sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $ intTy `mkFunTy` mkParentType tycon @@ -1704,7 +1704,7 @@ genAuxBind loc (GenTag2Con tycon) genAuxBind loc (GenMaxTag tycon) = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig (L loc rdr_name) (L loc sig_ty))) + L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) where rdr_name = maxtag_RDR tycon sig_ty = HsCoreTy intTy @@ -1714,7 +1714,7 @@ genAuxBind loc (GenMaxTag tycon) genAuxBind loc (MkTyCon tycon) -- $dT = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig (L loc rdr_name) sig_ty)) + L loc (TypeSig [L loc rdr_name] sig_ty)) where rdr_name = mk_data_type_name tycon sig_ty = nlHsTyVar dataType_RDR @@ -1725,7 +1725,7 @@ genAuxBind loc (MkTyCon tycon) -- $dT genAuxBind loc (MkDataCon dc) -- $cT1 etc = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig (L loc rdr_name) sig_ty)) + L loc (TypeSig [L loc rdr_name] sig_ty)) where rdr_name = mk_constr_name dc sig_ty = nlHsTyVar constr_RDR diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 65f16c56d2..7d9f93c1d3 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -299,7 +299,7 @@ kc_check_hs_type (HsParTy ty) exp_kind = do { ty' <- kc_check_lhs_type ty exp_kind; return (HsParTy ty') } kc_check_hs_type ty@(HsAppTy ty1 ty2) exp_kind - = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 ty2 + = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] ; (fun_ty', fun_kind) <- kc_lhs_type fun_ty ; arg_tys' <- kcCheckApps fun_ty fun_kind arg_tys ty exp_kind ; return (mkHsAppTys fun_ty' arg_tys') } @@ -387,11 +387,10 @@ kc_hs_type (HsOpTy ty1 op ty2) = do return (HsOpTy ty1' op ty2', res_kind) kc_hs_type (HsAppTy ty1 ty2) = do + let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] (fun_ty', fun_kind) <- kc_lhs_type fun_ty (arg_tys', res_kind) <- kcApps fun_ty fun_kind arg_tys return (mkHsAppTys fun_ty' arg_tys', res_kind) - where - (fun_ty, arg_tys) = splitHsAppTys ty1 ty2 kc_hs_type (HsPredTy pred) = wrongPredErr pred @@ -458,20 +457,6 @@ kcCheckApps the_fun fun_kind args ty exp_kind -- This improves error message; Trac #2994 ; kc_check_lhs_types args_w_kinds } -splitHsAppTys :: LHsType Name -> LHsType Name -> (LHsType Name, [LHsType Name]) -splitHsAppTys fun_ty arg_ty = split fun_ty [arg_ty] - where - split (L _ (HsAppTy f a)) as = split f (a:as) - split f as = (f,as) - -mkHsAppTys :: LHsType Name -> [LHsType Name] -> HsType Name -mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty) -mkHsAppTys fun_ty (arg_ty:arg_tys) - = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys - where - mk_app fun arg = HsAppTy (noLoc fun) arg -- Add noLocs for inner nodes of - -- the application; they are - -- never used --------------------------- splitFunKind :: SDoc -> Int -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind) diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 2c01d2300a..6423a830a9 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -1162,7 +1162,8 @@ check_pred_ty dflags ctxt pred@(ClassP cls tys) check_pred_ty dflags ctxt pred@(EqPred ty1 ty2) = do { -- Equational constraints are valid in all contexts if type -- families are permitted - ; checkTc (xopt Opt_TypeFamilies dflags) (eqPredTyErr pred) + ; checkTc (xopt Opt_TypeFamilies dflags || xopt Opt_GADTs dflags) + (eqPredTyErr pred) ; checkTc (case ctxt of ClassSCCtxt {} -> False; _ -> True) (eqSuperClassErr pred) @@ -1330,7 +1331,7 @@ badPredTyErr, eqPredTyErr, predTyVarErr :: PredType -> SDoc badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPredTy pred eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprPredTy pred $$ - parens (ptext (sLit "Use -XTypeFamilies to permit this")) + parens (ptext (sLit "Use -XGADTs or -XTypeFamilies to permit this")) predTyVarErr pred = sep [ptext (sLit "Non type-variable argument"), nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)] dupPredWarn :: [[PredType]] -> SDoc diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index ce84178e10..bd5cf8d0f5 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -84,8 +84,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this maybe_rn_syntax :: forall a. a -> Maybe a ; maybe_rn_syntax empty_val | keep_rn_syntax = Just empty_val - | otherwise = Nothing ; - + | otherwise = Nothing ; + gbl_env = TcGblEnv { tcg_mod = mod, tcg_src = hsc_src, diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 17e5dcbb94..46a322a93f 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -571,7 +571,8 @@ type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, Message)) -- data ImportAvails = ImportAvails { - imp_mods :: ModuleEnv [(ModuleName, Bool, SrcSpan)], + imp_mods :: ImportedMods, + -- = ModuleEnv [(ModuleName, Bool, SrcSpan, Bool)], -- ^ Domain is all directly-imported modules -- The 'ModuleName' is what the module was imported as, e.g. in -- @ @@ -612,6 +613,16 @@ data ImportAvails -- ^ Packages needed by the module being compiled, whether directly, -- or via other modules in this package, or via modules imported -- from other packages. + + imp_trust_pkgs :: [PackageId], + -- ^ This is strictly a subset of imp_dep_pkgs and records the + -- packages the current module needs to trust for Safe Haskell + -- compilation to succeed. A package is required to be trusted if + -- we are dependent on a trustworthy module in that package. + -- While perhaps making imp_dep_pkgs a tuple of (PackageId, Bool) + -- where True for the bool indicates the package is required to be + -- trusted is the more logical design, doing so complicates a lot + -- of code not concerned with Safe Haskell. imp_orphs :: [Module], -- ^ Orphan modules below us in the import tree (and maybe including @@ -629,25 +640,29 @@ mkModDeps deps = foldl add emptyUFM deps add env elt@(m,_) = addToUFM env m elt emptyImportAvails :: ImportAvails -emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, - imp_dep_mods = emptyUFM, - imp_dep_pkgs = [], - imp_orphs = [], - imp_finsts = [] } +emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, + imp_dep_mods = emptyUFM, + imp_dep_pkgs = [], + imp_trust_pkgs = [], + imp_orphs = [], + imp_finsts = [] } plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails plusImportAvails (ImportAvails { imp_mods = mods1, - imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, + imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, + imp_trust_pkgs = tpkgs1, imp_orphs = orphs1, imp_finsts = finsts1 }) (ImportAvails { imp_mods = mods2, imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, + imp_trust_pkgs = tpkgs2, imp_orphs = orphs2, imp_finsts = finsts2 }) - = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, - imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, - imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, - imp_orphs = orphs1 `unionLists` orphs2, - imp_finsts = finsts1 `unionLists` finsts2 } + = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, + imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, + imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, + imp_trust_pkgs = tpkgs1 `unionLists` tpkgs2, + imp_orphs = orphs1 `unionLists` orphs2, + imp_finsts = finsts1 `unionLists` finsts2 } where plus_mod_dep (m1, boot1) (m2, boot2) = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 0992fb971e..39f3c4b216 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -916,13 +916,13 @@ matchClass clas tys = do { let pred = mkClassPred clas tys ; instEnvs <- getInstEnvs ; case lookupInstEnv instEnvs clas tys of { - ([], unifs) -- Nothing matches + ([], unifs, _) -- Nothing matches -> do { traceTcS "matchClass not matching" (vcat [ text "dict" <+> ppr pred, text "unifs" <+> ppr unifs ]) ; return MatchInstNo } ; - ([(ispec, inst_tys)], []) -- A single match + ([(ispec, inst_tys)], [], _) -- A single match -> do { let dfun_id = is_dfun ispec ; traceTcS "matchClass success" (vcat [text "dict" <+> ppr pred, @@ -931,7 +931,7 @@ matchClass clas tys -- Record that this dfun is needed ; return $ MatchInstSingle (dfun_id, inst_tys) } ; - (matches, unifs) -- More than one matches + (matches, unifs, _) -- More than one matches -> do { traceTcS "matchClass multiple matches, deferring choice" (vcat [text "dict" <+> ppr pred, text "matches" <+> ppr matches, diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 6da5741037..97ad485e6a 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -970,7 +970,7 @@ lookupClassInstances c ts -- Now look up instances ; inst_envs <- tcGetInstEnvs - ; let (matches, unifies) = lookupInstEnv inst_envs cls tys + ; let (matches, unifies, _) = lookupInstEnv inst_envs cls tys ; mapM reifyClassInstance (map fst matches ++ unifies) } } } where doc = ptext (sLit "TcSplice.classInstances") diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 7a2a65e06b..89e526b8e2 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -46,21 +46,21 @@ import Data.Maybe ( isJust, isNothing ) \begin{code} data Instance - = Instance { is_cls :: Name -- Class name - - -- Used for "rough matching"; see Note [Rough-match field] - -- INVARIANT: is_tcs = roughMatchTcs is_tys - , is_tcs :: [Maybe Name] -- Top of type args - - -- Used for "proper matching"; see Note [Proper-match fields] - , is_tvs :: TyVarSet -- Template tyvars for full match - , is_tys :: [Type] -- Full arg types - -- INVARIANT: is_dfun Id has type - -- forall is_tvs. (...) => is_cls is_tys - - , is_dfun :: DFunId -- See Note [Haddock assumptions] - , is_flag :: OverlapFlag -- See detailed comments with - -- the decl of BasicTypes.OverlapFlag + = Instance { is_cls :: Name -- Class name + + -- Used for "rough matching"; see Note [Rough-match field] + -- INVARIANT: is_tcs = roughMatchTcs is_tys + , is_tcs :: [Maybe Name] -- Top of type args + + -- Used for "proper matching"; see Note [Proper-match fields] + , is_tvs :: TyVarSet -- Template tyvars for full match + , is_tys :: [Type] -- Full arg types + -- INVARIANT: is_dfun Id has type + -- forall is_tvs. (...) => is_cls is_tys + + , is_dfun :: DFunId -- See Note [Haddock assumptions] + , is_flag :: OverlapFlag -- See detailed comments with + -- the decl of BasicTypes.OverlapFlag } \end{code} @@ -437,7 +437,9 @@ where the Nothing indicates that 'b' can be freely instantiated. lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env -> Class -> [Type] -- What we are looking for -> ([InstMatch], -- Successful matches - [Instance]) -- These don't match but do unify + [Instance], -- These don't match but do unify + Bool) -- True if error condition caused by + -- SafeHaskell condition. -- The second component of the result pair happens when we look up -- Foo [a] @@ -450,7 +452,7 @@ lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env -- giving a suitable error messagen lookupInstEnv (pkg_ie, home_ie) cls tys - = (pruned_matches, all_unifs) + = (safe_matches, all_unifs, safe_fail) where rough_tcs = roughMatchTcs tys all_tvs = all isNothing rough_tcs @@ -459,11 +461,43 @@ lookupInstEnv (pkg_ie, home_ie) cls tys all_matches = home_matches ++ pkg_matches all_unifs = home_unifs ++ pkg_unifs pruned_matches = foldr insert_overlapping [] all_matches + (safe_matches, safe_fail) = if length pruned_matches == 1 + then check_safe (head pruned_matches) all_matches + else (pruned_matches, False) -- Even if the unifs is non-empty (an error situation) -- we still prune the matches, so that the error message isn't -- misleading (complaining of multiple matches when some should be -- overlapped away) + -- SafeHaskell: We restrict code compiled in 'Safe' mode from + -- overriding code compiled in any other mode. The rational is + -- that code compiled in 'Safe' mode is code that is untrusted + -- by the ghc user. So we shouldn't let that code change the + -- behaviour of code the user didn't compile in 'Safe' mode + -- since thats the code they trust. So 'Safe' instances can only + -- overlap instances from the same module. A same instance origin + -- policy for safe compiled instances. + check_safe match@(inst,_) others + = case isSafeOverlap (is_flag inst) of + -- most specific isn't from a Safe module so OK + False -> ([match], False) + -- otherwise we make sure it only overlaps instances from + -- the same module + True -> (go [] others, True) + where + go bad [] = match:bad + go bad (i@(x,_):unchecked) = + if inSameMod x + then go bad unchecked + else go (i:bad) unchecked + + inSameMod b = + let na = getName $ getName inst + la = isInternalName na + nb = getName $ getName b + lb = isInternalName nb + in (la && lb) || (nameModule na == nameModule nb) + -------------- lookup env = case lookupUFM env cls of Nothing -> ([],[]) -- No instances for this class @@ -500,7 +534,7 @@ lookupInstEnv (pkg_ie, home_ie) cls tys -- Does not match, so next check whether the things unify -- See Note [Overlapping instances] above - | Incoherent <- oflag + | Incoherent _ <- oflag = find ms us rest | otherwise @@ -543,8 +577,8 @@ insert_overlapping new_item (item:items) -- This is a change (Trac #3877, Dec 10). It used to -- require that instB (the less specific one) permitted overlap. overlap_ok = case (is_flag instA, is_flag instB) of - (NoOverlap, NoOverlap) -> False - _ -> True + (NoOverlap _, NoOverlap _) -> False + _ -> True \end{code} diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 3785957966..c5a2c8f4fd 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -81,6 +81,7 @@ import System.IO.Error ( mkIOError, eofErrorType ) import GHC.Real ( Ratio(..) ) import GHC.Exts import GHC.Word ( Word8(..) ) + import GHC.IO ( IO(..) ) type BinArray = ForeignPtr Word8 @@ -435,6 +436,15 @@ instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where d <- get bh return (a,b,c,d) +instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where + put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + return (a,b,c,d,e) + instance Binary a => Binary (Maybe a) where put_ bh Nothing = putByte bh 0 put_ bh (Just a) = do putByte bh 1; put_ bh a diff --git a/compiler/utils/Encoding.hs b/compiler/utils/Encoding.hs index 84b4e092f1..6467377a1a 100644 --- a/compiler/utils/Encoding.hs +++ b/compiler/utils/Encoding.hs @@ -32,7 +32,7 @@ module Encoding ( import Foreign import Data.Char import Numeric -import GHC.Ptr ( Ptr(..) ) +import GHC.Ptr ( Ptr(..) ) import GHC.Base -- ----------------------------------------------------------------------------- diff --git a/compiler/utils/FastFunctions.lhs b/compiler/utils/FastFunctions.lhs index 5496ed051c..b1dacdcd9b 100644 --- a/compiler/utils/FastFunctions.lhs +++ b/compiler/utils/FastFunctions.lhs @@ -22,9 +22,10 @@ import System.IO.Unsafe import GHC.Exts import GHC.Word -import GHC.IO (IO(..), unsafeDupableInterleaveIO) import GHC.Base (unsafeChr) +import GHC.IO (IO(..), unsafeDupableInterleaveIO) + -- Just like unsafePerformIO, but we inline it. {-# INLINE inlinePerformIO #-} inlinePerformIO :: IO a -> a diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index c6dac8ff42..35d4387dd3 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -96,7 +96,6 @@ import FastFunctions import Panic import Util -import Foreign hiding ( unsafePerformIO ) import Foreign.C import GHC.Exts import System.IO @@ -106,9 +105,15 @@ import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) import Data.Maybe ( isJust ) import Data.Char ( ord ) -import GHC.IO ( IO(..) ) - +import GHC.IO ( IO(..) ) import GHC.Ptr ( Ptr(..) ) + +#if __GLASGOW_HASKELL__ >= 701 +import Foreign.Safe +#else +import Foreign hiding ( unsafePerformIO ) +#endif + #if defined(__GLASGOW_HASKELL__) import GHC.Base ( unpackCString# ) #endif diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs index f0ca69cbb9..0493daabee 100644 --- a/compiler/utils/Pretty.lhs +++ b/compiler/utils/Pretty.lhs @@ -188,7 +188,6 @@ import Panic import StaticFlags import Numeric (fromRat) import System.IO ---import Foreign.Ptr (castPtr) #if defined(__GLASGOW_HASKELL__) --for a RULES @@ -562,8 +561,7 @@ text s = case iUnbox (length s) of {sl -> textBeside_ (Str s) sl Empty} ftext :: FastString -> Doc ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty} ptext :: LitString -> Doc -ptext s_= case iUnbox (lengthLS s) of {sl -> textBeside_ (LStr s sl) sl Empty} - where s = {-castPtr-} s_ +ptext s = case iUnbox (lengthLS s) of {sl -> textBeside_ (LStr s sl) sl Empty} zeroWidthText s = textBeside_ (Str s) (_ILIT(0)) Empty #if defined(__GLASGOW_HASKELL__) diff --git a/compiler/utils/StringBuffer.lhs b/compiler/utils/StringBuffer.lhs index 5d1bfa6086..3eb2f1f5bd 100644 --- a/compiler/utils/StringBuffer.lhs +++ b/compiler/utils/StringBuffer.lhs @@ -48,13 +48,17 @@ import FastString hiding ( buf ) import FastTypes import FastFunctions -import Foreign import System.IO ( hGetBuf, hFileSize,IOMode(ReadMode), hClose - , Handle, hTell ) + , Handle, hTell, openBinaryFile ) +import System.IO.Unsafe ( unsafePerformIO ) import GHC.Exts -import System.IO ( openBinaryFile ) +#if __GLASGOW_HASKELL__ >= 701 +import Foreign.Safe +#else +import Foreign hiding ( unsafePerformIO ) +#endif -- ----------------------------------------------------------------------------- -- The StringBuffer type diff --git a/compiler/vectorise/Vectorise/Builtins.hs b/compiler/vectorise/Vectorise/Builtins.hs index 3647a7f875..125d26482e 100644 --- a/compiler/vectorise/Vectorise/Builtins.hs +++ b/compiler/vectorise/Vectorise/Builtins.hs @@ -8,32 +8,33 @@ -- civilized panic message if the specified thing cannot be found. -- module Vectorise.Builtins ( - -- * Builtins - Builtins(..), - indexBuiltin, - - -- * Wrapped selectors - selTy, - selReplicate, - selPick, - selTags, - selElements, - sumTyCon, - prodTyCon, - prodDataCon, - combinePDVar, - scalarZip, - closureCtrFun, + -- * Builtins + Builtins(..), + indexBuiltin, + + -- * Wrapped selectors + selTy, + selReplicate, + selPick, + selTags, + selElements, + sumTyCon, + prodTyCon, + prodDataCon, + combinePDVar, + scalarZip, + closureCtrFun, - -- * Initialisation - initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, - initBuiltinPAs, initBuiltinPRs, - initBuiltinBoxedTyCons, initBuiltinScalars, - - -- * Lookup - primMethod, - primPArray + -- * Initialisation + initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, + initBuiltinPAs, initBuiltinPRs, + initBuiltinBoxedTyCons, + + -- * Lookup + primMethod, + primPArray ) where + import Vectorise.Builtins.Base import Vectorise.Builtins.Modules import Vectorise.Builtins.Initialise @@ -48,7 +49,8 @@ import Var import Control.Monad --- | Lookup a method function given its name and instance type. +-- |Lookup a method function given its name and instance type. +-- primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var) primMethod tycon method (Builtins { dphModules = mods }) | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon) @@ -58,7 +60,8 @@ primMethod tycon method (Builtins { dphModules = mods }) | otherwise = return Nothing --- | Lookup the representation type we use for PArrays that contain a given element type. +-- |Lookup the representation type we use for PArrays that contain a given element type. +-- primPArray :: TyCon -> Builtins -> DsM (Maybe TyCon) primPArray tycon (Builtins { dphModules = mods }) | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon) diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs index 5a6cf88272..9fdf3ba8f5 100644 --- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs +++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs @@ -1,14 +1,13 @@ - module Vectorise.Builtins.Initialise ( - -- * Initialisation - initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, - initBuiltinPAs, initBuiltinPRs, - initBuiltinBoxedTyCons, initBuiltinScalars, + -- * Initialisation + initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, + initBuiltinPAs, initBuiltinPRs, + initBuiltinBoxedTyCons ) where + import Vectorise.Builtins.Base import Vectorise.Builtins.Modules -import Vectorise.Builtins.Prelude import BasicTypes import PrelNames @@ -30,20 +29,18 @@ import Outputable import Control.Monad import Data.Array -import Data.List - --- | Create the initial map of builtin types and functions. -initBuiltins - :: PackageId -- ^ package id the builtins are in, eg dph-common - -> DsM Builtins +-- |Create the initial map of builtin types and functions. +-- +initBuiltins :: PackageId -- ^ package id the builtins are in, eg dph-common + -> DsM Builtins initBuiltins pkg = do mapM_ load dph_Orphans -- From dph-common:Data.Array.Parallel.PArray.PData -- PData is a type family that maps an element type onto the type -- we use to hold an array of those elements. - pdataTyCon <- externalTyCon dph_PArray_PData (fsLit "PData") + pdataTyCon <- externalTyCon dph_PArray_PData (fsLit "PData") -- PR is a type class that holds the primitive operators we can -- apply to array data. Its functions take arrays in terms of PData types. @@ -53,7 +50,7 @@ initBuiltins pkg -- From dph-common:Data.Array.Parallel.PArray.PRepr - preprTyCon <- externalTyCon dph_PArray_PRepr (fsLit "PRepr") + preprTyCon <- externalTyCon dph_PArray_PRepr (fsLit "PRepr") paClass <- externalClass dph_PArray_PRepr (fsLit "PA") let paTyCon = classTyCon paClass [paDataCon] = tyConDataCons paTyCon @@ -62,9 +59,9 @@ initBuiltins pkg replicatePDVar <- externalVar dph_PArray_PRepr (fsLit "replicatePD") emptyPDVar <- externalVar dph_PArray_PRepr (fsLit "emptyPD") packByTagPDVar <- externalVar dph_PArray_PRepr (fsLit "packByTagPD") - combines <- mapM (externalVar dph_PArray_PRepr) - [mkFastString ("combine" ++ show i ++ "PD") - | i <- [2..mAX_DPH_COMBINE]] + combines <- mapM (externalVar dph_PArray_PRepr) + [mkFastString ("combine" ++ show i ++ "PD") + | i <- [2..mAX_DPH_COMBINE]] let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines @@ -73,45 +70,45 @@ initBuiltins pkg -- Scalar is the class of scalar values. -- The dictionary contains functions to coerce U.Arrays of scalars -- to and from the PData representation. - scalarClass <- externalClass dph_PArray_Scalar (fsLit "Scalar") + scalarClass <- externalClass dph_PArray_Scalar (fsLit "Scalar") -- From dph-common:Data.Array.Parallel.Lifted.PArray -- A PArray (Parallel Array) holds the array length and some array elements -- represented by the PData type family. - parrayTyCon <- externalTyCon dph_PArray_Base (fsLit "PArray") + parrayTyCon <- externalTyCon dph_PArray_Base (fsLit "PArray") let [parrayDataCon] = tyConDataCons parrayTyCon -- From dph-common:Data.Array.Parallel.PArray.Types - voidTyCon <- externalTyCon dph_PArray_Types (fsLit "Void") + voidTyCon <- externalTyCon dph_PArray_Types (fsLit "Void") voidVar <- externalVar dph_PArray_Types (fsLit "void") fromVoidVar <- externalVar dph_PArray_Types (fsLit "fromVoid") - wrapTyCon <- externalTyCon dph_PArray_Types (fsLit "Wrap") - sum_tcs <- mapM (externalTyCon dph_PArray_Types) (numbered "Sum" 2 mAX_DPH_SUM) + wrapTyCon <- externalTyCon dph_PArray_Types (fsLit "Wrap") + sum_tcs <- mapM (externalTyCon dph_PArray_Types) (numbered "Sum" 2 mAX_DPH_SUM) -- from dph-common:Data.Array.Parallel.PArray.PDataInstances pvoidVar <- externalVar dph_PArray_PDataInstances (fsLit "pvoid") punitVar <- externalVar dph_PArray_PDataInstances (fsLit "punit") - closureTyCon <- externalTyCon dph_Closure (fsLit ":->") + closureTyCon <- externalTyCon dph_Closure (fsLit ":->") -- From dph-common:Data.Array.Parallel.Lifted.Unboxed - sel_tys <- mapM (externalType dph_Unboxed) - (numbered "Sel" 2 mAX_DPH_SUM) + sel_tys <- mapM (externalType dph_Unboxed) + (numbered "Sel" 2 mAX_DPH_SUM) - sel_replicates <- mapM (externalFun dph_Unboxed) - (numbered_hash "replicateSel" 2 mAX_DPH_SUM) + sel_replicates <- mapM (externalFun dph_Unboxed) + (numbered_hash "replicateSel" 2 mAX_DPH_SUM) - sel_picks <- mapM (externalFun dph_Unboxed) - (numbered_hash "pickSel" 2 mAX_DPH_SUM) + sel_picks <- mapM (externalFun dph_Unboxed) + (numbered_hash "pickSel" 2 mAX_DPH_SUM) - sel_tags <- mapM (externalFun dph_Unboxed) - (numbered "tagsSel" 2 mAX_DPH_SUM) + sel_tags <- mapM (externalFun dph_Unboxed) + (numbered "tagsSel" 2 mAX_DPH_SUM) - sel_els <- mapM mk_elements - [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]] + sel_els <- mapM mk_elements + [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]] let selTys = listArray (2, mAX_DPH_SUM) sel_tys @@ -123,26 +120,26 @@ initBuiltins pkg - closureVar <- externalVar dph_Closure (fsLit "closure") - applyVar <- externalVar dph_Closure (fsLit "$:") - liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure") - liftedApplyVar <- externalVar dph_Closure (fsLit "liftedApply") + closureVar <- externalVar dph_Closure (fsLit "closure") + applyVar <- externalVar dph_Closure (fsLit "$:") + liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure") + liftedApplyVar <- externalVar dph_Closure (fsLit "liftedApply") - scalar_map <- externalVar dph_Scalar (fsLit "scalar_map") - scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith") - scalar_zips <- mapM (externalVar dph_Scalar) - (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS) + scalar_map <- externalVar dph_Scalar (fsLit "scalar_map") + scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith") + scalar_zips <- mapM (externalVar dph_Scalar) + (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS) - let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) + let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) (scalar_map : scalar_zip2 : scalar_zips) - closures <- mapM (externalVar dph_Closure) - (numbered "closure" 1 mAX_DPH_SCALAR_ARGS) + closures <- mapM (externalVar dph_Closure) + (numbered "closure" 1 mAX_DPH_SCALAR_ARGS) let closureCtrFuns = listArray (1, mAX_DPH_COMBINE) closures - liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy) - newUnique + liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy) + newUnique return $ Builtins { dphModules = mods @@ -221,32 +218,26 @@ initBuiltins pkg -- | Get the mapping of names in the Prelude to names in the DPH library. -- -initBuiltinVars :: Bool -- FIXME - -> Builtins -> DsM [(Var, Var)] -initBuiltinVars compilingDPH (Builtins { dphModules = mods }) +initBuiltinVars :: Builtins -> DsM [(Var, Var)] +initBuiltinVars (Builtins { dphModules = mods }) = do - uvars <- zipWithM externalVar umods ufs - vvars <- zipWithM externalVar vmods vfs cvars <- zipWithM externalVar cmods cfs return $ [(v,v) | v <- map dataConWorkId defaultDataConWorkers] ++ zip (map dataConWorkId cons) cvars - ++ zip uvars vvars where - (umods, ufs, vmods, vfs) = if compilingDPH then ([], [], [], []) else unzip4 (preludeVars mods) - (cons, cmods, cfs) = unzip3 (preludeDataCons mods) + (cons, cmods, cfs) = unzip3 (preludeDataCons mods) defaultDataConWorkers :: [DataCon] defaultDataConWorkers = [trueDataCon, falseDataCon, unitDataCon] + preludeDataCons :: Modules -> [(DataCon, Module, FastString)] + preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple }) + = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]] + where + mk_tup n mod name = (tupleCon Boxed n, mod, name) -preludeDataCons :: Modules -> [(DataCon, Module, FastString)] -preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple }) - = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]] - where - mk_tup n mod name = (tupleCon Boxed n, mod, name) - - --- | Get a list of names to `TyCon`s in the mock prelude. +-- |Get a list of names to `TyCon`s in the mock prelude. +-- initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)] initBuiltinTyCons bi = do @@ -260,83 +251,82 @@ initBuiltinTyCons bi : [(tyConName tc, tc) | tc <- dft_tcs] - where defaultTyCons :: DsM [TyCon] - defaultTyCons - = do word8 <- dsLookupTyCon word8TyConName - return [intTyCon, boolTyCon, doubleTyCon, word8] - + where + defaultTyCons :: DsM [TyCon] + defaultTyCons + = do word8 <- dsLookupTyCon word8TyConName + return [intTyCon, boolTyCon, floatTyCon, doubleTyCon, word8] --- | Get a list of names to `DataCon`s in the mock prelude. +-- |Get a list of names to `DataCon`s in the mock prelude. +-- initBuiltinDataCons :: Builtins -> [(Name, DataCon)] initBuiltinDataCons _ = [(dataConName dc, dc)| dc <- defaultDataCons] - where defaultDataCons :: [DataCon] - defaultDataCons = [trueDataCon, falseDataCon, unitDataCon] - + where + defaultDataCons :: [DataCon] + defaultDataCons = [trueDataCon, falseDataCon, unitDataCon] --- | Get the names of all buildin instance functions for the PA class. +-- |Get the names of all buildin instance functions for the PA class. +-- initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)] initBuiltinPAs (Builtins { dphModules = mods }) insts = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PRepr mods) (fsLit "PA")) - --- | Get the names of all builtin instance functions for the PR class. +-- |Get the names of all builtin instance functions for the PR class. +-- initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)] initBuiltinPRs (Builtins { dphModules = mods }) insts = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PData mods) (fsLit "PR")) - --- | Get the names of all DPH instance functions for this class. +-- |Get the names of all DPH instance functions for this class. +-- initBuiltinDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)] initBuiltinDicts insts cls = map find $ classInstances insts cls where - find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i) - | otherwise = pprPanic "Invalid DPH instance" (ppr i) - + find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i) + | otherwise = pprPanic "Invalid DPH instance" (ppr i) --- | Get a list of boxed `TyCons` in the mock prelude. This is Int only. +-- |Get a list of boxed `TyCons` in the mock prelude. This is Int only. +-- initBuiltinBoxedTyCons :: Builtins -> DsM [(Name, TyCon)] initBuiltinBoxedTyCons = return . builtinBoxedTyCons - where builtinBoxedTyCons :: Builtins -> [(Name, TyCon)] - builtinBoxedTyCons _ - = [(tyConName intPrimTyCon, intTyCon)] + where + builtinBoxedTyCons :: Builtins -> [(Name, TyCon)] + builtinBoxedTyCons _ + = [(tyConName intPrimTyCon, intTyCon)] --- | Get a list of all scalar functions in the mock prelude. --- -initBuiltinScalars :: Bool - -> Builtins -> DsM [Var] -initBuiltinScalars True _bi = return [] -initBuiltinScalars False bi = mapM (uncurry externalVar) (preludeScalars $ dphModules bi) --- | Lookup some variable given its name and the module that contains it. +-- Auxilliary look up functions ---------------- + +-- Lookup some variable given its name and the module that contains it. +-- externalVar :: Module -> FastString -> DsM Var externalVar mod fs = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs) - --- | Like `externalVar` but wrap the `Var` in a `CoreExpr` +-- Like `externalVar` but wrap the `Var` in a `CoreExpr`. +-- externalFun :: Module -> FastString -> DsM CoreExpr externalFun mod fs = do var <- externalVar mod fs return $ Var var - --- | Lookup some `TyCon` given its name and the module that contains it. +-- Lookup some `TyCon` given its name and the module that contains it. +-- externalTyCon :: Module -> FastString -> DsM TyCon externalTyCon mod fs = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs) - --- | Lookup some `Type` given its name and the module that contains it. +-- Lookup some `Type` given its name and the module that contains it. +-- externalType :: Module -> FastString -> DsM Type externalType mod fs = do tycon <- externalTyCon mod fs return $ mkTyConApp tycon [] - --- | Lookup some `Class` given its name and the module that contains it. +-- Lookup some `Class` given its name and the module that contains it. +-- externalClass :: Module -> FastString -> DsM Class externalClass mod fs = dsLookupClass =<< lookupOrig mod (mkClsOccFS fs) - diff --git a/compiler/vectorise/Vectorise/Builtins/Modules.hs b/compiler/vectorise/Vectorise/Builtins/Modules.hs index 6ea3595d53..af74f803bc 100644 --- a/compiler/vectorise/Vectorise/Builtins/Modules.hs +++ b/compiler/vectorise/Vectorise/Builtins/Modules.hs @@ -22,13 +22,8 @@ data Modules , dph_Closure :: Module , dph_Unboxed :: Module - , dph_Combinators :: Module , dph_Scalar :: Module - , dph_Prelude_Int :: Module - , dph_Prelude_Word8 :: Module - , dph_Prelude_Double :: Module - , dph_Prelude_Bool :: Module , dph_Prelude_Tuple :: Module } @@ -48,14 +43,9 @@ dph_Modules pkg , dph_Closure = mk (fsLit "Data.Array.Parallel.Lifted.Closure") , dph_Unboxed = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed") - , dph_Combinators = mk (fsLit "Data.Array.Parallel.Lifted.Combinators") , dph_Scalar = mk (fsLit "Data.Array.Parallel.Lifted.Scalar") - , dph_Prelude_Int = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int") - , dph_Prelude_Word8 = mk (fsLit "Data.Array.Parallel.Prelude.Base.Word8") - , dph_Prelude_Double = mk (fsLit "Data.Array.Parallel.Prelude.Base.Double") - , dph_Prelude_Bool = mk (fsLit "Data.Array.Parallel.Prelude.Base.Bool") - , dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple") + , dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Tuple") } where mk = mkModule pkg . mkModuleNameFS diff --git a/compiler/vectorise/Vectorise/Builtins/Prelude.hs b/compiler/vectorise/Vectorise/Builtins/Prelude.hs deleted file mode 100644 index a59f9369aa..0000000000 --- a/compiler/vectorise/Vectorise/Builtins/Prelude.hs +++ /dev/null @@ -1,209 +0,0 @@ - --- WARNING: This module is a temporary kludge. It will soon go away entirely (once --- VECTORISE SCALAR pragmas are fully implemented.) - --- | Mapping of prelude functions to vectorised versions. --- Functions like filterP currently have a working but naive version in GHC.PArr --- During vectorisation we replace these by calls to filterPA, which are --- defined in dph-common Data.Array.Parallel.Lifted.Combinators --- --- As renamer only sees the GHC.PArr functions, if you want to add a new function --- to the vectoriser there has to be a definition for it in GHC.PArr, even though --- it will never be used at runtime. --- -module Vectorise.Builtins.Prelude - ( preludeVars - , preludeScalars) -where -import Vectorise.Builtins.Modules -import PrelNames -import Module -import FastString - - -preludeVars :: Modules - -> [( Module, FastString -- Maps the original variable to the one in the DPH - , Module, FastString)] -- packages that it should be rewritten to. -preludeVars (Modules { dph_Combinators = _dph_Combinators - , dph_Prelude_Int = dph_Prelude_Int - , dph_Prelude_Word8 = dph_Prelude_Word8 - -- , dph_Prelude_Double = dph_Prelude_Double - , dph_Prelude_Bool = dph_Prelude_Bool - }) - - = [ - -- Map scalar functions to versions using closures. - mk' dph_Prelude_Int "div" "divV" - , mk' dph_Prelude_Int "mod" "modV" - , mk' dph_Prelude_Int "sqrt" "sqrtV" - , mk' dph_Prelude_Int "enumFromToP" "enumFromToPA" - ] - ++ vars_Ord dph_Prelude_Int - ++ vars_Num dph_Prelude_Int - - ++ vars_Ord dph_Prelude_Word8 - ++ vars_Num dph_Prelude_Word8 - ++ - [ mk' dph_Prelude_Word8 "div" "divV" - , mk' dph_Prelude_Word8 "mod" "modV" - , mk' dph_Prelude_Word8 "fromInt" "fromIntV" - , mk' dph_Prelude_Word8 "toInt" "toIntV" - ] - - -- ++ vars_Ord dph_Prelude_Double - -- ++ vars_Num dph_Prelude_Double - -- ++ vars_Fractional dph_Prelude_Double - -- ++ vars_Floating dph_Prelude_Double - -- ++ vars_RealFrac dph_Prelude_Double - ++ - [ mk dph_Prelude_Bool (fsLit "andP") dph_Prelude_Bool (fsLit "andPA") - , mk dph_Prelude_Bool (fsLit "orP") dph_Prelude_Bool (fsLit "orPA") - - , mk gHC_CLASSES (fsLit "not") dph_Prelude_Bool (fsLit "notV") - , mk gHC_CLASSES (fsLit "&&") dph_Prelude_Bool (fsLit "andV") - , mk gHC_CLASSES (fsLit "||") dph_Prelude_Bool (fsLit "orV") - ] - where - mk = (,,,) - mk' mod v v' = mk mod (fsLit v) mod (fsLit v') - - vars_Ord mod - = [ mk' mod "==" "eqV" - , mk' mod "/=" "neqV" - , mk' mod "<=" "leV" - , mk' mod "<" "ltV" - , mk' mod ">=" "geV" - , mk' mod ">" "gtV" - , mk' mod "min" "minV" - , mk' mod "max" "maxV" - , mk' mod "minimumP" "minimumPA" - , mk' mod "maximumP" "maximumPA" - , mk' mod "minIndexP" "minIndexPA" - , mk' mod "maxIndexP" "maxIndexPA" - ] - - vars_Num mod - = [ mk' mod "+" "plusV" - , mk' mod "-" "minusV" - , mk' mod "*" "multV" - , mk' mod "negate" "negateV" - , mk' mod "abs" "absV" - , mk' mod "sumP" "sumPA" - , mk' mod "productP" "productPA" - ] - - -- vars_Fractional mod - -- = [ mk' mod "/" "divideV" - -- , mk' mod "recip" "recipV" - -- ] - -- - -- vars_Floating mod - -- = [ mk' mod "pi" "pi" - -- , mk' mod "exp" "expV" - -- , mk' mod "sqrt" "sqrtV" - -- , mk' mod "log" "logV" - -- , mk' mod "sin" "sinV" - -- , mk' mod "tan" "tanV" - -- , mk' mod "cos" "cosV" - -- , mk' mod "asin" "asinV" - -- , mk' mod "atan" "atanV" - -- , mk' mod "acos" "acosV" - -- , mk' mod "sinh" "sinhV" - -- , mk' mod "tanh" "tanhV" - -- , mk' mod "cosh" "coshV" - -- , mk' mod "asinh" "asinhV" - -- , mk' mod "atanh" "atanhV" - -- , mk' mod "acosh" "acoshV" - -- , mk' mod "**" "powV" - -- , mk' mod "logBase" "logBaseV" - -- ] - -- - -- vars_RealFrac mod - -- = [ mk' mod "fromInt" "fromIntV" - -- , mk' mod "truncate" "truncateV" - -- , mk' mod "round" "roundV" - -- , mk' mod "ceiling" "ceilingV" - -- , mk' mod "floor" "floorV" - -- ] - -- -preludeScalars :: Modules -> [(Module, FastString)] -preludeScalars (Modules { dph_Prelude_Int = dph_Prelude_Int - , dph_Prelude_Word8 = dph_Prelude_Word8 - , dph_Prelude_Double = dph_Prelude_Double - }) - = [ mk dph_Prelude_Int "div" - , mk dph_Prelude_Int "mod" - , mk dph_Prelude_Int "sqrt" - ] - ++ scalars_Ord dph_Prelude_Int - ++ scalars_Num dph_Prelude_Int - - ++ scalars_Ord dph_Prelude_Word8 - ++ scalars_Num dph_Prelude_Word8 - ++ - [ mk dph_Prelude_Word8 "div" - , mk dph_Prelude_Word8 "mod" - , mk dph_Prelude_Word8 "fromInt" - , mk dph_Prelude_Word8 "toInt" - ] - - ++ scalars_Ord dph_Prelude_Double - ++ scalars_Num dph_Prelude_Double - ++ scalars_Fractional dph_Prelude_Double - ++ scalars_Floating dph_Prelude_Double - ++ scalars_RealFrac dph_Prelude_Double - where - mk mod s = (mod, fsLit s) - - scalars_Ord mod - = [ mk mod "==" - , mk mod "/=" - , mk mod "<=" - , mk mod "<" - , mk mod ">=" - , mk mod ">" - , mk mod "min" - , mk mod "max" - ] - - scalars_Num mod - = [ mk mod "+" - , mk mod "-" - , mk mod "*" - , mk mod "negate" - , mk mod "abs" - ] - - scalars_Fractional mod - = [ mk mod "/" - , mk mod "recip" - ] - - scalars_Floating mod - = [ mk mod "pi" - , mk mod "exp" - , mk mod "sqrt" - , mk mod "log" - , mk mod "sin" - , mk mod "tan" - , mk mod "cos" - , mk mod "asin" - , mk mod "atan" - , mk mod "acos" - , mk mod "sinh" - , mk mod "tanh" - , mk mod "cosh" - , mk mod "asinh" - , mk mod "atanh" - , mk mod "acosh" - , mk mod "**" - , mk mod "logBase" - ] - - scalars_RealFrac mod - = [ mk mod "fromInt" - , mk mod "truncate" - , mk mod "round" - , mk mod "ceiling" - , mk mod "floor" - ] diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs index 97bb5aef69..d70f09affd 100644 --- a/compiler/vectorise/Vectorise/Env.hs +++ b/compiler/vectorise/Vectorise/Env.hs @@ -10,7 +10,6 @@ module Vectorise.Env ( GlobalEnv(..), initGlobalEnv, extendImportedVarsEnv, - extendScalars, setFamEnv, extendFamEnv, extendTyConsEnv, @@ -46,18 +45,18 @@ data Scope a b -- LocalEnv ------------------------------------------------------------------- -- | The local environment. data LocalEnv - = LocalEnv { + = LocalEnv { -- Mapping from local variables to their vectorised and lifted versions. - local_vars :: VarEnv (Var, Var) + local_vars :: VarEnv (Var, Var) -- In-scope type variables. - , local_tyvars :: [TyVar] + , local_tyvars :: [TyVar] -- Mapping from tyvars to their PA dictionaries. - , local_tyvar_pa :: VarEnv CoreExpr + , local_tyvar_pa :: VarEnv CoreExpr -- Local binding name. - , local_bind_name :: FastString + , local_bind_name :: FastString } @@ -163,12 +162,6 @@ extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv extendImportedVarsEnv ps genv = genv { global_vars = extendVarEnvList (global_vars genv) ps } --- |Extend the set of scalar variables in an environment. --- -extendScalars :: [Var] -> GlobalEnv -> GlobalEnv -extendScalars vs genv - = genv { global_scalar_vars = extendVarSetList (global_scalar_vars genv) vs } - -- |Set the list of type family instances in an environment. -- setFamEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 4676e182a9..98271900f0 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -62,7 +62,8 @@ vectPolyExpr loop_breaker recFns expr (tvs, mono) = collectAnnTypeBinders expr --- | Vectorise an expression. +-- |Vectorise an expression. +-- vectExpr :: CoreExprWithFVs -> VM VExpr vectExpr (_, AnnType ty) = liftM vType (vectType ty) @@ -76,6 +77,17 @@ vectExpr (_, AnnLit lit) vectExpr (_, AnnNote note expr) = liftM (vNote note) (vectExpr expr) +-- SPECIAL CASE: Vectorise/lift 'patError @ ty err' by only vectorising/lifting the type 'ty'; +-- its only purpose is to abort the program, but we need to adjust the type to keep CoreLint +-- happy. +vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err) + | v == pAT_ERROR_ID + = do { (vty, lty) <- vectAndLiftType ty + ; return (mkCoreApps (Var v) [Type vty, err'], mkCoreApps (Var v) [Type lty, err']) + } + where + err' = deAnnotate err + vectExpr e@(_, AnnApp _ arg) | isAnnTypeArg arg = vectTyAppExpr fn tys diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index 73cba88a3b..e690077192 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -65,13 +65,11 @@ initV hsc_env guts info thing_inside Just pkg -> do { -- set up tables of builtin entities - ; let compilingDPH = dphBackend dflags == DPHThis -- FIXME: temporary kludge support ; builtins <- initBuiltins pkg - ; builtin_vars <- initBuiltinVars compilingDPH builtins + ; builtin_vars <- initBuiltinVars builtins ; builtin_tycons <- initBuiltinTyCons builtins ; let builtin_datacons = initBuiltinDataCons builtins ; builtin_boxed <- initBuiltinBoxedTyCons builtins - ; builtin_scalars <- initBuiltinScalars compilingDPH builtins -- set up class and type family envrionments ; eps <- liftIO $ hscEPS hsc_env @@ -83,7 +81,6 @@ initV hsc_env guts info thing_inside -- construct the initial global environment ; let thing_inside' = traceVt "VectDecls" (ppr (mg_vect_decls guts)) >> thing_inside ; let genv = extendImportedVarsEnv builtin_vars - . extendScalars builtin_scalars . extendTyConsEnv builtin_tycons . extendDataConsEnv builtin_datacons . extendPAFunsEnv builtin_pas diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs index 2fc94d8f4a..9492f1010f 100644 --- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs +++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs @@ -38,7 +38,7 @@ lookupInst :: Class -> [Type] -> VM (DFunId, [Type]) lookupInst cls tys = do { instEnv <- getInstEnv ; case lookupInstEnv instEnv cls tys of - ([(inst, inst_tys)], _) + ([(inst, inst_tys)], _, _) | noFlexiVar -> return (instanceDFunId inst, inst_tys') | otherwise -> pprPanic "VectMonad.lookupInst: flexi var: " (ppr $ mkTyConApp (classTyCon cls) tys) diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 3e70be999b..43c713e119 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -599,6 +599,26 @@ <entry>dynamic</entry> <entry>-</entry> </row> + <row> + <entry><option>-trust</option> <replaceable>P</replaceable></entry> + <entry>Expose package <replaceable>P</replaceable> and set it to be + trusted</entry> + <entry>static/<literal>:set</literal></entry> + <entry>-</entry> + </row> + <row> + <entry><option>-distrust</option> <replaceable>P</replaceable></entry> + <entry>Expose package <replaceable>P</replaceable> and set it to be + distrusted</entry> + <entry>static/<literal>:set</literal></entry> + <entry>-</entry> + </row> + <row> + <entry><option>-distrust-all</option> </entry> + <entry>Distrust all packages by default</entry> + <entry>static/<literal>:set</literal></entry> + <entry>-</entry> + </row> </tbody> </tgroup> </informaltable> @@ -1033,6 +1053,30 @@ <entry>dynamic</entry> <entry><option>-XNoPackageImports</option></entry> </row> + <row> + <entry><option>-XSafe</option></entry> + <entry>Enable the <link linkend="safe-haskell">Safe Haskell</link> Safe mode.</entry> + <entry>dynamic</entry> + <entry><option>-</option></entry> + </row> + <row> + <entry><option>-XTrustworthy</option></entry> + <entry>Enable the <link linkend="safe-haskell">Safe Haskell</link> Trustworthy mode.</entry> + <entry>dynamic</entry> + <entry><option>-</option></entry> + </row> + <row> + <entry><option>-XSafeLanguage</option></entry> + <entry>Enable the <link linkend="safe-haskell">Safe Haskell</link> Safe Language.</entry> + <entry>dynamic</entry> + <entry><option>-</option></entry> + </row> + <row> + <entry><option>-XSafeImports</option></entry> + <entry>Enable <link linkend="safe-imports-ext">Safe Imports</link>.</entry> + <entry>dynamic</entry> + <entry><option>-</option></entry> + </row> </tbody> </tgroup> </informaltable> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index e1795f2b28..09a9062ffc 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -1897,6 +1897,25 @@ import "network" Network.Socket another, rendering any package-qualified imports broken.</para> </sect2> +<sect2 id="safe-imports-ext"> + <title>Safe imports</title> + + <para>With the <option>-XSafeImports</option> flag, GHC extends + the import declaration syntax to take an optional <literal>safe</literal> + keyword after the <literal>import</literal> keyword. This feature + is part of the Safe Haskell GHC extension. For example:</para> + +<programlisting> +import safe qualified Network.Socket as NS +</programlisting> + + <para>would import the module <literal>Network.Socket</literal> + with compilation only succeeding if Network.Socket can be + safely imported. For a description of when a import is + considered safe see <xref linkend="safe-haskell"/></para> + +</sect2> + <sect2 id="syntax-stolen"> <title>Summary of stolen syntax</title> @@ -9411,7 +9430,6 @@ standard behaviour. </sect1> - <!-- Emacs stuff: ;;; Local Variables: *** ;;; sgml-parent-document: ("users_guide.xml" "book" "chapter" "sect1") *** diff --git a/docs/users_guide/lang.xml b/docs/users_guide/lang.xml index 3870dd72a3..95f70894d2 100644 --- a/docs/users_guide/lang.xml +++ b/docs/users_guide/lang.xml @@ -4,6 +4,7 @@ &glasgowexts; ∥ +&safehaskell; </chapter> diff --git a/docs/users_guide/packages.xml b/docs/users_guide/packages.xml index 0a8412bbd2..3076a2aa2f 100644 --- a/docs/users_guide/packages.xml +++ b/docs/users_guide/packages.xml @@ -101,6 +101,13 @@ $ ghc-pkg list directly. </para> + <para>Similar to a package's hidden status is a package's trusted + status. A package can be either trusted or not trusted (distrusted). + By default packages are distrusted. This property of a package only + plays a role when compiling code using GHC's Safe Haskell feature + (see <xref linkend="safe-haskell"/>). + </para> + <para>To see which modules are provided by a package use the <literal>ghc-pkg</literal> command (see <xref linkend="package-management"/>):</para> @@ -265,6 +272,53 @@ exposed-modules: Network.BSD, <literal>-package mypkg-1.2</literal>.</para> </listitem> </varlistentry> + + <varlistentry> + <term><option>-trust</option> <replaceable>P</replaceable> + <indexterm><primary><option>-trust</option></primary> + </indexterm></term> + <listitem> + <para>This option causes the install package <replaceable>P + </replaceable> to be both exposed and trusted by GHC. This + command functions in the in a very similar way to the <option> + -package</option> command but in addition sets the selected + packaged to be trusted by GHC, regardless of the contents of + the package database. (see <xref linkend="safe-haskell"/>). + </para> + </listitem> + </varlistentry> + + <varlistentry> + <term><option>-distrust</option> <replaceable>P</replaceable> + <indexterm><primary><option>-distrust</option></primary> + </indexterm></term> + <listitem> + <para>This option causes the install package <replaceable>P + </replaceable> to be both exposed and distrusted by GHC. This + command functions in the in a very similar way to the <option> + -package</option> command but in addition sets the selected + packaged to be distrusted by GHC, regardless of the contents of + the package database. (see <xref linkend="safe-haskell"/>). + </para> + </listitem> + </varlistentry> + + <varlistentry> + <term><option>-distrust-all</option> + <indexterm><primary><option>-distrust-all</option></primary> + </indexterm></term> + <listitem> + <para>Ignore the trusted flag on installed packages, and distrust + them by default. If you use this flag and Safe Haskell then any + packages you require to be trusted (including <literal>base + </literal>) need to be explicitly trusted using <option>-trust + </option> options. This option does not change the exposed/hidden + status of a package, so it isn't equivalent to applying <option> + -distrust</option> to all packages on the system. (see + <xref linkend="safe-haskell"/>). + </para> + </listitem> + </varlistentry> </variablelist> </sect2> @@ -624,6 +678,15 @@ haskell98-1.0.1.0 </varlistentry> <varlistentry> + <term><literal>ghc-pkg check</literal></term> + <listitem> + <para>Check consistency of dependencies in the package + database, and report packages that have missing + dependencies.</para> + </listitem> + </varlistentry> + + <varlistentry> <term><literal>ghc-pkg expose <replaceable>P</replaceable></literal></term> <listitem> <para>Sets the <literal>exposed</literal> flag for package @@ -632,18 +695,25 @@ haskell98-1.0.1.0 </varlistentry> <varlistentry> - <term><literal>ghc-pkg check</literal></term> + <term><literal>ghc-pkg hide <replaceable>P</replaceable></literal></term> <listitem> - <para>Check consistency of dependencies in the package - database, and report packages that have missing - dependencies.</para> + <para>Sets the <literal>exposed</literal> flag for package + <replaceable>P</replaceable> to <literal>False</literal>.</para> </listitem> </varlistentry> <varlistentry> - <term><literal>ghc-pkg hide <replaceable>P</replaceable></literal></term> + <term><literal>ghc-pkg trust <replaceable>P</replaceable></literal></term> <listitem> - <para>Sets the <literal>exposed</literal> flag for package + <para>Sets the <literal>trusted</literal> flag for package + <replaceable>P</replaceable> to <literal>True</literal>.</para> + </listitem> + </varlistentry> + + <varlistentry> + <term><literal>ghc-pkg distrust <replaceable>P</replaceable></literal></term> + <listitem> + <para>Sets the <literal>trusted</literal> flag for package <replaceable>P</replaceable> to <literal>False</literal>.</para> </listitem> </varlistentry> @@ -1093,6 +1163,7 @@ exposed-modules: System.Posix System.Posix.DynamicLinker.Module System.Posix.Signals.Exts System.Posix.Semaphore System.Posix.SharedMem hidden-modules: +trusted: False import-dirs: /usr/lib/ghc-6.12.1/unix-2.3.1.0 library-dirs: /usr/lib/ghc-6.12.1/unix-2.3.1.0 hs-libraries: HSunix-2.3.1.0 @@ -1325,6 +1396,16 @@ haddock-html: /usr/share/doc/ghc/html/libraries/unix <varlistentry> <term> + <literal>trusted</literal> + <indexterm><primary><literal>trusted</literal></primary><secondary>package specification</secondary></indexterm> + </term> + <listitem> + <para>(bool) Whether the package is trusted or not.</para> + </listitem> + </varlistentry> + + <varlistentry> + <term> <literal>import-dirs</literal> <indexterm><primary><literal>import-dirs</literal></primary><secondary>package specification</secondary></indexterm> </term> diff --git a/docs/users_guide/safe_haskell.xml b/docs/users_guide/safe_haskell.xml new file mode 100644 index 0000000000..c2f42c000c --- /dev/null +++ b/docs/users_guide/safe_haskell.xml @@ -0,0 +1,493 @@ +<?xml version="1.0" encoding="iso-8859-1"?> +<sect1 id="safe-haskell"> + <title>Safe Haskell</title> + + Safe Haskell is an extension to the Haskell language supported by GHC, that + provides certain safety guarantees about Haskell code compiled using this + extension. It allows people to build more advance security mechanisms on top + of Haskell and for the safe execution of untrusted Haskell code. Its purpose + isn't to provide a complete secure execution environment for Haskell code but + to give users enough guarantees about the Haskell language to be able to + build such systems. Its design is similar to the safe and unsafe module + system supported by the Modula-3 language. + + The design of Safe Haskell covers the following aspects: + <itemizedlist> + <listitem>A <link linkend="safe-language-overview">safe language</link> + dialect of Haskell that provides guarantees about the code. Mainly it + allows the types and module boundaries to be trusted. + </listitem> + <listitem>A new <emphasis>safe import</emphasis> extension that specifies + the module being imported must be trusted. + </listitem> + <listitem>A definition of <emphasis>trust</emphasis> (or safety) and how it + operates, along with ways of defining and changing the trust of modules + and packages. + </listitem> + </itemizedlist> + + <sect2 id="safe-language-overview"> + <title>Safe Language Overview</title> + + The Safe Haskell <emphasis>Safe language</emphasis> guarantees the + following properties: + <itemizedlist> + <listitem><emphasis>Referential transparency.</emphasis> Functions + in the Safe language are deterministic, evaluating them will not + cause any side effects. Functions in the <emphasis>IO</emphasis> + monad are still allowed and behave as usual but any pure function + as according to the functions type is guaranteed to indeed be + pure. This property allows a user of the Safe language to trust + the types of functions. + </listitem> + <listitem><emphasis>Module boundary control.</emphasis> Haskell code + compiled using the Safe language is guaranteed to only access + symbols that are publicly available to it through other modules + export lists. An import part of this is that safe compiled code + is not able to examine or create data values using data constructors + that the module cannot import. If a module M establishes some + invariants through careful use of its export list then code + compiled using the Safe language that imports M is guaranteed to + respect those invariants. + </listitem> + <listitem><emphasis>Semantic consistency.</emphasis> The Safe language + is strictly a subset of Haskell as implemented by GHC. Any expression + that compiles in the safe language has the same meaning as it does + when compiled in normal Haskell. In addition, in any module that imports + a Safe language module, expressions that compile both with and without + the safe import have the same meaning in both cases. That is, importing + a module using the Safe language cannot change the meaning of existing + code that isn't dependent on that module. + </listitem> + </itemizedlist> + + Put simply, these three properties guarantee that you can trust the types + in the Safe language, can trust that module export lists are respected + in the Safe language and can trust that code which successfully compiles + in the Safe language has the same meaning as it normally would. Please see + <xref linkend="safe-language"/> for a more detailed view of the safe + language. + </sect2> + + <sect2 id="safe-imports"> + <title>Safe Imports</title> + + Safe Haskell enables a small extension to the usual import syntax of + Haskell, adding a <emphasis>safe</emphasis> keyword: + + <programlisting> + impdecl -> import [safe] [qualified] modid [as modid] [impspec] + </programlisting> + + When used, the module being imported with the safe keyword must be a trusted + module, otherwise a compilation error will occur. The safe import extension + is enabled by either of the <emphasis>-XSafe</emphasis>, + <emphasis>-XTrustworthy</emphasis>, <emphasis>-XSafeLanguage</emphasis> or + <emphasis>-XSafeImports</emphasis> flags and corresponding PRAGMA's. When + either the <emphasis>-XSafe</emphasis> or + <emphasis>-XSafeLanguage</emphasis> flag is used, the safe keyword is + allowed but meaningless -- all imports are safe regardless. + </sect2> + + <sect2 id="safe-trust"> + <title>Trust</title> + + The Safe Haskell extension introduces the following two new language flags: + <itemizedlist> + <listitem><emphasis>-XSafe:</emphasis> Enables the Safe language dialect, + asking GHC to guarantee trust. The safe language dialect requires that + all imports be trusted or a compile error will occur.</listitem> + <listitem><emphasis>-XTrustworthy:</emphasis> Means that while this module + may invoke unsafe functions internally, the module's author claims that + it exports an API that can't be used in an unsafe way. This doesn't enable + the Safe language or place any restrictions on the allowed Haskell code. + The trust guarantee is provided by the module author, not GHC. An import + statement with the safe keyword results in a compilation error if the + imported module is not trussted. An import statement without the keyword + behaves as usual and can import any module whether trusted or + not.</listitem> + </itemizedlist> + + Whether or not a module is trusted depends on a notion of trust for + packages, which is determined by the client C invoking GHC (i.e., you). A + package <emphasis>P</emphasis> is trusted when either C's package database + records that <emphasis>P</emphasis> is trusted (and no command-line + arguments override this), or C's command-line flags say to trust it + regardless of what is recorded in the package database. In either case, C + is the only authority on package trust. It is up to the client to decide + which packages they trust. + + Now a <emphasis>module M in a package P is trusted by a client C</emphasis> + if and only if: + <itemizedlist> + <listitem>Both of these hold: + <itemizedlist> + <listitem> The module was compiled with <emphasis>-XSafe</emphasis></listitem> + <listitem> All of M's direct imports are trusted by C</listitem> + </itemizedlist> + </listitem> + <listitem><emphasis>OR</emphasis> all of these hold: + <itemizedlist> + <listitem>The module was compiled with <emphasis>-XTrustworthy</emphasis></listitem> + <listitem>All of M's direct safe imports are trusted by C</listitem> + <listitem>Package P is trusted by C</listitem> + </itemizedlist> + </listitem> + </itemizedlist> + + For the first trust definition the trust guarantee is provided by GHC + through the restrictions imposed by the Safe language. For the second + definition of trust, the guarantee is provided initially by the + module author. The client C then establishes that they trust the + module author by indicating they trust the package the module resides + in. This trust chain is required as GHC provides no guarantee for + <emphasis>-XTrustworthy</emphasis> compiled modules. + + <sect3 id="safe-trust-example"> + <title>Example</title> + + <programlisting> + Package Wuggle: + {-# LANGUAGE Safe #-} + module Buggle where + import Prelude + f x = ...blah... + + Package P: + {-# LANGUAGE Trustworthy #-} + module M where + import System.IO.Unsafe + import safe Buggle + </programlisting> + + Suppose a client C decides to trust package P. Then does C trust module M? + To decide, GHC must check M's imports: M imports System.IO.Unsafe. M was + compiled with -XTrustworthy, so P's author takes responsibility for that + import. C trusts P's author, so C trusts M to only use its unsafe + imports (System.IO.Unsafe in this example)in a safe and consistent + manner with respect the API M exposes. M also has a safe import of + Buggle, so for this import P's author takes no responsibility for the + safety or otherwise. So GHC must check whether Buggle is trusted by C. + Is it? Well, it is compiled with -XSafe, so the code in Buggle itself is + machine-checked to be OK, but again under the assumption that all of + Buggle's imports are trusted by C. Prelude comes from base, which C + trusts, and is compiled with -XTrustworthy (While Prelude is typically + imported implicitly, it still obeys the same rules outlined here). So + Buggle is considered trusted. + + Notice that C didn't need to trust package Wuggle; the machine checking + is enough. C only needs to trust packages that have -XTrustworthy + modules in them. + </sect3> + + <sect3 id="safe-no-trust"> + <title>Safe Language & Imports without Trust</title> + + Safe Haskell also allows the new language extensions -- the Safe language + dialect and safe imports -- to be used independtly of any trust + assertions for the code. + + <itemizedlist> + <listitem><emphasis>-XSafeImports</emphasis>: enables the safe import + extension. The module using this feature is left untrusted + though.</listitem> + <listitem><emphasis>-XSafeLanguage</emphasis>: + enables the safe language extension. The module using this feature + is left untrusted though.</listitem> + </itemizedlist> + + These are extensions are useful for encouraging good programming style and + also for flexibility during development when using Safe Haskell. The Safe + language encourages users to avoid liberal use of unsafe Haskell language + features. There are also situations where a module may only use the Safe + language subset but exposes some internal API's that code using + <emphasis>-XSafe</emphasis> shouldn't be allowed to access for security + reasons. Please see <link linkend="safe-use-cases">Safe Haskell use + cases</link> for a more detailed explanation. + </sect3> + + <sect3 id="safe-flag-summary"> + <title>Safe Haskell Flag Summary</title> + + In summary, Safe Haskell consists of the following language flags: + + <itemizedlist> + <listitem> + <emphasis>-XSafe</emphasis> + <itemizedlist> + <listitem>To be trusted, all of the module's direct imports must be + trusted, but the module itself need not reside in a trusted + package, because the compiler vouches for its trustworthiness. The + "safe" keyword is allowed but meaningless in import statements -- + conceptually every import is safe whether or not so + tagged.</listitem> + <listitem><emphasis>Module Trusted:</emphasis> Yes</listitem> + <listitem><emphasis>Haskell Language:</emphasis> Restricted to Safe + Language</listitem> + <listitem><emphasis>Imported Modules:</emphasis> All forced to be + safe imports, all must be trusted.</listitem> + </itemizedlist> + </listitem> + <listitem> + <emphasis>-XSafeLanguage:</emphasis> + <itemizedlist> + <listitem>The module is never trusted, because the author does not + claim it is trustworthy. As long as the module compiles both ways, + the result is identical whether or not the -XSafeLanguage flag is + supplied. As with -XSafe, the "safe" import keyword is allowed but + meaningless -- all imports must be safe.</listitem> + <listitem><emphasis>Module Trusted:</emphasis> No</listitem> + <listitem><emphasis>Haskell Language:</emphasis> Restricted to Safe + Language</listitem> + <listitem><emphasis>Imported Modules:</emphasis> All forced to be + safe imports, all must be trusted.</listitem> + </itemizedlist> + </listitem> + <listitem> + <emphasis>-XTrustworthy:</emphasis> + <itemizedlist> + <listitem>This establishes that the module is trusted, but the + guarantee is provided by the module's author. A client of this + module then specifies that they trust the module author by + specifying they trust the package containing the module. + '-XTrustworthy' has no effect on the accepted range of Haskell + programs or their semantics, except that they allow the safe + import keyword.</listitem> + <listitem><emphasis>Module Trusted:</emphasis> Yes but only if + Package the module resides in is also trusted.</listitem> + <listitem><emphasis>Haskell Language:</emphasis> Unrestricted + </listitem> + <listitem><emphasis>Imported Modules:</emphasis> Under control + of module author which ones must be trusted.</listitem> + </itemizedlist> + </listitem> + <listitem> + <emphasis>-XSafeLanguage -XTrustworthy:</emphasis> + <itemizedlist> + <listitem>For the trust property this has the same effect as + '-XTrustworthy' by itself. However unlike -XTrustworthy it also + restricts the range of acceptable Haskell programs to the Safe + language. The difference from this and using -XSafe is the + different trust type and that not all imports are forced to be + safe imports, they are instead optionally specified by the module + author.</listitem> + <listitem><emphasis>Module Trusted:</emphasis> Yes but only if Package + the module resides in is also trusted.</listitem> + <listitem><emphasis>Haskell Language:</emphasis> Restricted to Safe + Language</listitem> + <listitem><emphasis>Imported Modules:</emphasis> Under control of + module author which ones must be trusted.</listitem> + </itemizedlist> + </listitem> + <listitem> + <emphasis>-XSafeImport:</emphasis> + <itemizedlist> + <listitem>Enable the Safe Import extension so that a module can + require a dependency to be trusted without asserting any trust + about itself.</listitem> + <listitem><emphasis>Module Trusted:</emphasis> No</listitem> + <listitem><emphasis>Haskell Language:</emphasis> + Unrestricted</listitem> + <listitem><emphasis>Imported Modules:</emphasis> Under control of + module author which ones must be trusted.</listitem> + </itemizedlist> + </listitem> + </itemizedlist> + </sect3> + + <sect3 id="safe-package-trust"> + <title>Package Trust</title> + + Safe Haskell gives packages a new boolean property, that of trust. Several new options are available + at the GHC command-line to specify the trust property of packages: + + <itemizedlist> + <listitem><emphasis>-trust P</emphasis>: Exposes package P if it was + hidden and considers it a trusted package regardless of the package + database.</listitem> + <listitem><emphasis>-distrust P</emphasis>: Exposes package P if it was + hidden and considers it an untrusted package regardless of the + package database.</listitem> + <listitem><emphasis>-distrust-all-packages</emphasis>: Considers all + packages distrusted unless they are explicitly set to be trusted by + subsequent command-line options.</listitem> + </itemizedlist> + + To set a package's trust property in the package database please refer to <xref linkend="packages"/>. + </sect3> + + </sect2> + + <sect2 id="safe-language"> + <title>Safe Language Details</title> + + In the Safe language dialect we disable completely the following Haskell language features: + <itemizedlist> + <listitem><emphasis>GeneralizedNewtypeDeriving:</emphasis> It can be used + to violate constructor access control, by allowing untrusted code to + manipulate protected data types in ways the data type author did not + intend. For example can be used to break invariants of data + structures.</listitem> + <listitem><emphasis>TemplateHaskell:</emphasis> Is particularly + dangerous, as it can cause side effects even at compilation time and + can be used to access abstract data types. It is very easy to break + module boundaries with TH.</listitem> + </itemizedlist> + + In the Safe language dialect we restrict the following Haskell language features: + <itemizedlist> + <listitem><emphasis>ForeignFunctionInterface:</emphasis> This is mostly + safe, but foreign import declarations that import a function with a + non-IO type are disallowed. All FFI imports must reside in the IO + Monad.</listitem> + <listitem><emphasis>RULES:</emphasis> As they can change the behaviour of + trusted code in unanticipated ways, violating semantic consistency they + are restricted in function. Specifically any RULES defined in a module + M compiled with -XSafe or -XSafeLanguage are dropped. RULES defined in + trustworthy modules that M imports are still valid and will fire as + usual.</listitem> + <listitem><emphasis>OverlappingInstances:</emphasis> This extension + can be used to violate semantic consistency, because malicious code + could redefine a type instance (by containing a more specific + instance definition) in a way that changes the behaviour of code + importing the untrusted module. The extension is not disabled for a + module M compiled with -XSafe or -XSafeLanguage but restricted. + While M can define overlapping instance declarations, they can + only overlap other instance declaration defined in M. If in a module N + that imports M, at a call site that uses type-class function there is + a choice of which instance to use (i.e. overlapping) and the most + specific instances is from M, then all the other choices must also be + from M. If not, a compilation error will occur. A simple way to think + of this is a <emphasis>same origin policy</emphasis> for overlapping + instances defined in Safe compiled modules.</listitem> + </itemizedlist> + </sect2> + + <sect2 id="safe-use-cases"> + <title>Use Cases</title> + + Safe Haskell has been designed with the following use cases in mind. + + <sect3> + <title>Enforcing Good Programming Style</title> + + Over-reliance on magic functions such as unsafePerformIO or magic symbols + such as realWorld# can lead to less elegant Haskell code. The Safe dialect + formalizes this notion of magic and prohibits its use. Thus, people may + encourage their collaborators to use the Safe dialect, except when truly + necessary, so as to promote better programming style. It can be thought + of as an addition to using <option>-Wall -Werror</option>. + </sect3> + + <sect3> + <title>Building Secure Systems (restricted IO Monads)</title> + + The original use case that Safe Haskell was designed for was to allow + secure systems to be built on top of the Haskell programming language. + Many researchers have done great work with Haskell, building such systems + as information flow control security systems, capability based security + system, languages for working with encrypted data... etc. These systems + all rely on properties of the Haskell language that aren't true in the + general case where uses of functions like + <emphasis>unsafePerformIO</emphasis> are allowed. Safe Haskell however + gives enough guarantees about the compiled Haskell code to be able to + successfully build secure systems on top of. + + As an example lets define an interface for a plugin system where the + plugin authors are untrusted, possibly malicious third-parties. We do + this by restricting the interface to pure functions or to a restricted IO + monad that we have defined that only allows a safe subset of IO actions + to be executed. We define the plugin interface here so that it requires + the plugin module, <emphasis>Danger</emphasis>, to export a single + computation, <emphasis>Danger.runMe</emphasis>, of type <emphasis>RIO + ()</emphasis>, where <emphasis>RIO</emphasis> is a new monad defined as + follows: + + <programlisting> + -- Either of the following pragmas would do + {-# LANGUAGE Trustworthy #-} + {-# LANGUAGE Safe #-} + + module RIO (RIO(), runRIO, rioReadFile, rioWriteFile) where + + -- Notice that symbol UnsafeRIO is not exported from this module! + + newtype RIO a = UnsafeRIO { runRIO :: IO a } + + instance Monad RIO where + return = UnsafeRIO . return + (UnsafeRIO m) >>= k = UnsafeRIO $ m >>= runRIO . k + + -- Returns True iff access is allowed to file name + pathOK :: FilePath -> IO Bool + pathOK file = {- Implement some policy based on file name -} + + rioReadFile :: FilePath -> RIO String + rioReadFile file = UnsafeRIO $ do + ok <- pathOK file + if ok then readFile file else return "" + + rioWriteFile :: FilePath -> String -> RIO () + rioWriteFile file contents = UnsafeRIO $ do + ok <- pathOK file + if ok then writeFile file contents else return () + </programlisting> + + We compile Danger using the -XSafe flag. Danger can import module RIO + because RIO is marked Trustworthy. Thus, Danger can make use of the + rioReadFile and rioWriteFile functions to access permitted file names. + + The main application then imports both RIO and Danger. To run the + plugin, it calls RIO.runRIO Danger.runMe within the IO monad. The + application is safe in the knowledge that the only IO to ensue will be + to files whose paths were approved by the pathOK test. We are relying on + the fact that the type system and constructor privacy prevent RIO + computations from executing IO actions directly. Only functions with + access to privileged symbol UnsafeRIO can lift IO computations into the + RIO monad. + </sect3> + + <sect3> + <title>Uses of -XSafeImports</title> + + If you are writing a module and want to import a module from an untrusted + author, then you would use the following syntax: + + <programlisting> + import safe Untrusted.Module + </programlisting> + + As the safe import keyword is a feature of Safe Haskell and not Haskell98 + this would fail though unless you enabled Safe imports through on the of + the Safe Haskell language flags. Three flags enable safe imports, + <emphasis>-XSafe, -XTrustworthy</emphasis> and + <emphasis>-XSafeImports</emphasis>. However <emphasis>-XSafe and + -XTrustworthy</emphasis> do more then just enable the keyword which may + be undesirable. Using the <emphasis>-XSafeImports</emphasis> language flag + allows you to enable safe imports and nothing more. + </sect3> + + <sect3> + <title>Uses of -XSafeLanguage</title> + + The <emphasis>-XSafeLanguage</emphasis> flag has two use cases. Firstly + as stated above it can be used to enforce good programming style. + Secondly, in the <emphasis>RIO</emphasis> restricted IO monad example + above there is no reason that it can't be implemented in the Safe + Language as its code isn't reliant on any unsafe features of Haskell. + However we may also wish to export the <emphasis>UnsafeRIO</emphasis> + action in the defining module or <emphasis>RIO</emphasis> and then define + a new module that only exports a safe subset of the original definition + of <emphasis>RIO</emphasis>. The defining module can use the + <emphasis>-XSafeLanguage</emphasis> flag and be assured that the + untrusted <emphasis>Danger</emphasis> module can't import it. + </sect3> + </sect2> + +</sect1> + +<!-- Emacs stuff: + ;;; Local Variables: *** + ;;; sgml-parent-document: ("users_guide.xml" "book" "chapter" "sect1") *** + ;;; End: *** + --> diff --git a/docs/users_guide/ug-ent.xml.in b/docs/users_guide/ug-ent.xml.in index 040c25267b..2d19d97688 100644 --- a/docs/users_guide/ug-ent.xml.in +++ b/docs/users_guide/ug-ent.xml.in @@ -13,6 +13,7 @@ <!ENTITY glasgowexts SYSTEM "glasgow_exts.xml" > <!ENTITY packages SYSTEM "packages.xml" > <!ENTITY parallel SYSTEM "parallel.xml" > +<!ENTITY safehaskell SYSTEM "safe_haskell.xml" > <!ENTITY phases SYSTEM "phases.xml" > <!ENTITY separate SYSTEM "separate_compilation.xml" > <!ENTITY bugs SYSTEM "bugs.xml" > diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 884059aece..1869040a80 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -34,7 +34,7 @@ import Packages -- import PackageConfig import UniqFM -import HscTypes ( handleFlagWarnings ) +import HscTypes ( handleFlagWarnings, getSafeMode ) import HsImpExp import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? import RdrName (RdrName) @@ -82,12 +82,13 @@ import System.Environment import System.Exit ( exitWith, ExitCode(..) ) import System.Directory import System.IO +import System.IO.Unsafe ( unsafePerformIO ) import System.IO.Error import Data.Char import Data.Array import Control.Monad as Monad import Text.Printf -import Foreign +import Foreign.Safe import GHC.Exts ( unsafeCoerce# ) import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) @@ -134,6 +135,7 @@ builtin_commands = [ ("help", keepGoing help, noCompletion), ("history", keepGoing historyCmd, noCompletion), ("info", keepGoing' info, completeIdentifier), + ("issafe", keepGoing' isSafeCmd, completeModule), ("kind", keepGoing' kindOfType, completeIdentifier), ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), ("list", keepGoing' listCmd, noCompletion), @@ -211,6 +213,7 @@ helpText = " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++ " :help, :? display this list of commands\n" ++ " :info [<name> ...] display information about the given names\n" ++ + " :issafe [<mod>] display safe haskell information of module <mod>\n" ++ " :kind <type> show the kind of <type>\n" ++ " :load [*]<module> ... load module(s) and their dependents\n" ++ " :main [<arguments> ...] run the main function with the given arguments\n" ++ @@ -1318,6 +1321,54 @@ runScript filename = do else return () ----------------------------------------------------------------------------- +-- Displaying SafeHaskell properties of a module + +isSafeCmd :: String -> InputT GHCi () +isSafeCmd m = + case words m of + [s] | looksLikeModuleName s -> do + m <- lift $ lookupModule s + isSafeModule m + [] -> do + (as,bs) <- GHC.getContext + -- Guess which module the user wants to browse. Pick + -- modules that are interpreted first. The most + -- recently-added module occurs last, it seems. + case (as,bs) of + (as@(_:_), _) -> isSafeModule $ last as + ([], bs@(_:_)) -> do + let i = last bs + m <- GHC.findModule (unLoc (ideclName i)) (ideclPkgQual i) + isSafeModule m + ([], []) -> ghcError (CmdLineError ":issafe: no current module") + _ -> ghcError (CmdLineError "syntax: :issafe <module>") + +isSafeModule :: Module -> InputT GHCi () +isSafeModule m = do + mb_mod_info <- GHC.getModuleInfo m + case mb_mod_info of + Nothing -> ghcError $ CmdLineError ("unknown module: " ++ + GHC.moduleNameString (GHC.moduleName m)) + Just mi -> do + dflags <- getDynFlags + let iface = GHC.modInfoIface mi + case iface of + Just iface' -> do + let trust = showPpr $ getSafeMode $ GHC.mi_trust iface' + pkg = if packageTrusted dflags m then "trusted" else "untrusted" + liftIO $ putStrLn $ "Trust type is (Module: " ++ trust + ++ ", Package: " ++ pkg ++ ")" + Nothing -> ghcError $ CmdLineError ("can't load interface file for module: " ++ + GHC.moduleNameString (GHC.moduleName m)) + where + packageTrusted :: DynFlags -> Module -> Bool + packageTrusted dflags m + | thisPackage dflags == modulePackageId m = True + | otherwise = trusted $ getPackageDetails (pkgState dflags) + (modulePackageId m) + + +----------------------------------------------------------------------------- -- Browsing a module's contents browseCmd :: Bool -> String -> InputT GHCi () @@ -1556,10 +1607,10 @@ setCmd "" vcat (text "other dynamic, non-language, flag settings:" :map (flagSetting dflags) others) )) - where flagSetting dflags (str, f, _) + where flagSetting dflags (str, _, f, _) | dopt f dflags = text " " <> text "-f" <> text str | otherwise = text " " <> text "-fno-" <> text str - (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags) + (ghciFlags,others) = partition (\(_, _, f, _) -> f `elem` flags) DynFlags.fFlags flags = [Opt_PrintExplicitForalls ,Opt_PrintBindResult @@ -1794,17 +1845,19 @@ showPackages = do liftIO $ putStrLn $ showSDoc $ vcat $ text ("active package flags:"++if null pkg_flags then " none" else "") : map showFlag pkg_flags - where showFlag (ExposePackage p) = text $ " -package " ++ p - showFlag (HidePackage p) = text $ " -hide-package " ++ p - showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p + where showFlag (ExposePackage p) = text $ " -package " ++ p + showFlag (HidePackage p) = text $ " -hide-package " ++ p + showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p showFlag (ExposePackageId p) = text $ " -package-id " ++ p + showFlag (TrustPackage p) = text $ " -trust " ++ p + showFlag (DistrustPackage p) = text $ " -distrust " ++ p showLanguages :: GHCi () showLanguages = do dflags <- getDynFlags liftIO $ putStrLn $ showSDoc $ vcat $ text "active language flags:" : - [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, xopt f dflags] + [text (" -X" ++ str) | (str, _, f, _) <- DynFlags.xFlags, xopt f dflags] -- ----------------------------------------------------------------------------- -- Completion diff --git a/ghc/Main.hs b/ghc/Main.hs index 12d8dd202b..71a45f8a9a 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -479,7 +479,7 @@ parseModeFlags :: [Located String] [Located String]) parseModeFlags args = do let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) = - runCmdLine (processArgs mode_flags args) + runCmdLine (processArgs mode_flags args CmdLineOnly True) (Nothing, [], []) mode = case mModeFlag of Nothing -> doMakeMode @@ -495,16 +495,16 @@ type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String]) mode_flags :: [Flag ModeM] mode_flags = [ ------- help / version ---------------------------------------------- - Flag "?" (PassFlag (setMode showGhcUsageMode)) - , Flag "-help" (PassFlag (setMode showGhcUsageMode)) - , Flag "V" (PassFlag (setMode showVersionMode)) - , Flag "-version" (PassFlag (setMode showVersionMode)) - , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode)) - , Flag "-info" (PassFlag (setMode showInfoMode)) - , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) - , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) + flagC "?" (PassFlag (setMode showGhcUsageMode)) + , flagC "-help" (PassFlag (setMode showGhcUsageMode)) + , flagC "V" (PassFlag (setMode showVersionMode)) + , flagC "-version" (PassFlag (setMode showVersionMode)) + , flagC "-numeric-version" (PassFlag (setMode showNumVersionMode)) + , flagC "-info" (PassFlag (setMode showInfoMode)) + , flagC "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) + , flagC "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) ] ++ - [ Flag k' (PassFlag (setMode (printSetting k))) + [ flagC k' (PassFlag (setMode (printSetting k))) | k <- ["Project version", "Booter version", "Stage", @@ -530,21 +530,21 @@ mode_flags = replaceSpace c = c ] ++ ------- interfaces ---------------------------------------------------- - [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) + [ flagC "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) "--show-iface")) ------- primary modes ------------------------------------------------ - , Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f - addFlag "-no-link" f)) - , Flag "M" (PassFlag (setMode doMkDependHSMode)) - , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc))) - , Flag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f - addFlag "-fvia-C" f)) - , Flag "S" (PassFlag (setMode (stopBeforeMode As))) - , Flag "-make" (PassFlag (setMode doMakeMode)) - , Flag "-interactive" (PassFlag (setMode doInteractiveMode)) - , Flag "-abi-hash" (PassFlag (setMode doAbiHashMode)) - , Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e")) + , flagC "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f + addFlag "-no-link" f)) + , flagC "M" (PassFlag (setMode doMkDependHSMode)) + , flagC "E" (PassFlag (setMode (stopBeforeMode anyHsc))) + , flagC "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f + addFlag "-fvia-C" f)) + , flagC "S" (PassFlag (setMode (stopBeforeMode As))) + , flagC "-make" (PassFlag (setMode doMakeMode)) + , flagC "-interactive" (PassFlag (setMode doInteractiveMode)) + , flagC "-abi-hash" (PassFlag (setMode doAbiHashMode)) + , flagC "e" (SepArg (\s -> setMode (doEvalMode s) "-e")) ] setMode :: Mode -> String -> EwM ModeM () @@ -773,3 +773,4 @@ abiHash strs = do unknownFlagsErr :: [String] -> a unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs)) + diff --git a/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs b/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs index 47bb8f4690..15f7e8e957 100644 --- a/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs +++ b/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs @@ -65,6 +65,7 @@ putInstalledPackageInfo ipi = do put (exposed ipi) put (exposedModules ipi) put (hiddenModules ipi) + put (trusted ipi) put (importDirs ipi) put (libraryDirs ipi) put (hsLibraries ipi) @@ -98,6 +99,7 @@ getInstalledPackageInfo = do exposed <- get exposedModules <- get hiddenModules <- get + trusted <- get importDirs <- get libraryDirs <- get hsLibraries <- get diff --git a/libraries/tarballs/time-1.2.0.4.tar.gz b/libraries/tarballs/time-1.2.0.4.tar.gz Binary files differdeleted file mode 100644 index 6bbbd75703..0000000000 --- a/libraries/tarballs/time-1.2.0.4.tar.gz +++ /dev/null diff --git a/libraries/tarballs/time-1.2.0.5.tar.gz b/libraries/tarballs/time-1.2.0.5.tar.gz Binary files differnew file mode 100644 index 0000000000..b0fb2d994b --- /dev/null +++ b/libraries/tarballs/time-1.2.0.5.tar.gz diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk index e250fa6fb4..184dfe2ff7 100644 --- a/mk/validate-settings.mk +++ b/mk/validate-settings.mk @@ -7,6 +7,9 @@ HADDOCK_DOCS = YES SRC_CC_OPTS += -Wall $(WERROR) SRC_HC_OPTS += -Wall $(WERROR) -H64m -O0 +# Safe by default +#SRC_HC_OPTS += -Dsh_SAFE_DEFAULT + GhcStage1HcOpts += -O GhcStage2HcOpts += -O @@ -83,6 +86,10 @@ libraries/dph/dph-prim-par_dist-install_EXTRA_HC_OPTS += -Wwarn libraries/dph/dph-seq_dist-install_EXTRA_HC_OPTS += -Wwarn libraries/dph/dph-par_dist-install_EXTRA_HC_OPTS += -Wwarn +# We need to turn of deprecated warnings for SafeHaskell transition +libraries/array_dist-install_EXTRA_HC_OPTS += -fno-warn-warnings-deprecations +libraries/binary_dist-install_EXTRA_HC_OPTS += -fno-warn-warnings-deprecations + # We need -fno-warn-deprecated-flags to avoid failure with -Werror GhcLibHcOpts += -fno-warn-deprecated-flags GhcBootLibHcOpts += -fno-warn-deprecated-flags @@ -41,7 +41,7 @@ . - ghc.git git ghc-tarballs - ghc-tarballs.git git utils/hsc2hs - hsc2hs.git git -utils/haddock - haddock2.git git +utils/haddock - haddock.git git libraries/array - packages/array.git git libraries/base - packages/base.git git libraries/binary - packages/binary.git git @@ -519,5 +519,48 @@ sub main { } } +END { + my $ec = $?; + my $pwd = getcwd(); + + message "== Checking for old haddock repo"; + if (-d "utils/haddock/.git") { + chdir("utils/haddock"); + if ((system "git log -1 87e2ca11c3d1b1bc49900fba0b5c5c6f85650718 > /dev/null 2> /dev/null") == 0) { + print <<EOF; +============================ +ATTENTION! + +You have an old haddock repository in your GHC tree! + +Please remove it (e.g. "rm -r utils/haddock"), and then run +"./syncs-all get" to get the new repository. +============================ +EOF + } + chdir($pwd); + } + + message "== Checking for old binary repo"; + if (-d "libraries/binary/.git") { + chdir("libraries/binary"); + if ((system "git log -1 749ac0efbde3b14901417364a872796598747aaf > /dev/null 2> /dev/null") == 0) { + print <<EOF; +============================ +ATTENTION! + +You have an old binary repository in your GHC tree! + +Please remove it (e.g. "rm -r libraries/binary"), and then run +"./syncs-all get" to get the new repository. +============================ +EOF + } + chdir($pwd); + } + + $? = $ec; +} + main(@ARGV); diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 52b79146b7..14664a8ada 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -198,6 +198,12 @@ usageHeader prog = substProg prog $ " $p hide {pkg-id}\n" ++ " Hide the specified package.\n" ++ "\n" ++ + " $p trust {pkg-id}\n" ++ + " Trust the specified package.\n" ++ + "\n" ++ + " $p distrust {pkg-id}\n" ++ + " Distrust the specified package.\n" ++ + "\n" ++ " $p list [pkg]\n" ++ " List registered packages in the global database, and also the\n" ++ " user database if --user is given. If a package name is given\n" ++ @@ -344,6 +350,12 @@ runit verbosity cli nonopts = do ["hide", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str hidePackage pkgid verbosity cli force + ["trust", pkgid_str] -> do + pkgid <- readGlobPkgId pkgid_str + trustPackage pkgid verbosity cli force + ["distrust", pkgid_str] -> do + pkgid <- readGlobPkgId pkgid_str + distrustPackage pkgid verbosity cli force ["list"] -> do listPackages verbosity cli Nothing Nothing ["list", pkgid_str] -> @@ -413,7 +425,7 @@ globVersion = Version{ versionBranch=[], versionTags=["*"] } -- Package databases -- Some commands operate on a single database: --- register, unregister, expose, hide +-- register, unregister, expose, hide, trust, distrust -- however these commands also check the union of the available databases -- in order to check consistency. For example, register will check that -- dependencies exist before registering a package. @@ -859,7 +871,7 @@ updateDBCache verbosity db = do else ioError e -- ----------------------------------------------------------------------------- --- Exposing, Hiding, Unregistering are all similar +-- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True}) @@ -867,6 +879,12 @@ exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True}) hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False}) +trustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True}) + +distrustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False}) + unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () unregisterPackage = modifyPackage RemovePackage @@ -1075,7 +1093,7 @@ doDump expand_pkgroot pkgs = do else showInstalledPackageInfo pkg ++ pkgrootField | (pkg, pkgloc) <- pkgs , let pkgroot = takeDirectory pkgloc - pkgrootField = "pkgroot: " ++ pkgroot ++ "\n" ] + pkgrootField = "pkgroot: " ++ show pkgroot ++ "\n" ] -- PackageId is can have globVersion for the version findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo] @@ -96,10 +96,13 @@ $make test_bindist TEST_PREP=YES # bindistdir="bindisttest/install dir" cd libraries/mtl -"$thisdir/$bindistdir/bin/runhaskell" Setup.hs configure --with-ghc="$thisdir/$bindistdir/bin/ghc" --global --builddir=dist-bindist --prefix="$thisdir/$bindistdir" -"$thisdir/$bindistdir/bin/runhaskell" Setup.hs build --builddir=dist-bindist -"$thisdir/$bindistdir/bin/runhaskell" Setup.hs install --builddir=dist-bindist -"$thisdir/$bindistdir/bin/runhaskell" Setup.hs clean --builddir=dist-bindist +"$thisdir/$bindistdir/bin/ghc" --make Setup +./Setup configure --with-ghc="$thisdir/$bindistdir/bin/ghc" --with-haddock="$thisdir/$bindistdir/bin/haddock" --global --builddir=dist-bindist --prefix="$thisdir/$bindistdir" +./Setup build --builddir=dist-bindist +./Setup haddock --builddir=dist-bindist +./Setup install --builddir=dist-bindist +./Setup clean --builddir=dist-bindist +rm -f Setup Setup.exe Setup.hi Setup.o cd $thisdir fi # testsuite-only |