/utils/runstdtest/runstdtest
/utils/unlit/unlit
+
+/extra-gcc-opts
\ No newline at end of file
])
AC_DEFUN([FP_BINDIST_GHC_PWD],[
- GHC_PWD=utils/ghc-pwd/dist/build/tmp/ghc-pwd
+ GHC_PWD=utils/ghc-pwd/dist-install/build/tmp/ghc-pwd
])
AC_DEFUN([FP_FIND_ROOT],[
if (/^#/) {
# Comment; do nothing
}
- elsif (/^([a-zA-Z0-9\/.-]+) +([^ ]+) +[^ ]+ +[^ ]+ +[^ ]+$/) {
+ elsif (/^([a-zA-Z0-9\/.-]+) +([^ ]+) +[^ ]+ +[^ ]+$/) {
$dir = $1;
$tag = $2;
-- 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
-- Prints (if mod information is available) "Defined at <loc>" or
-- "Defined in <mod>" information for a Name.
pprNameLoc :: Name -> SDoc
-pprNameLoc name
- | isGoodSrcSpan loc = pprDefnLoc loc
- | isInternalName name || isSystemName name
- = ptext (sLit "<no location info>")
- | otherwise = ptext (sLit "Defined in ") <> ppr (nameModule name)
- where loc = nameSrcSpan name
+pprNameLoc name = case nameSrcSpan name of
+ RealSrcSpan s ->
+ pprDefnLoc s
+ UnhelpfulSpan _
+ | isInternalName name || isSystemName name ->
+ ptext (sLit "<no location info>")
+ | otherwise ->
+ ptext (sLit "Defined in ") <> ppr (nameModule name)
\end{code}
%************************************************************************
-- INVARIANT: the list of 'ImportSpec' is non-empty
data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec,
- is_item :: ImpItemSpec }
+ is_item :: ImpItemSpec }
deriving( Eq, Ord )
-- | Describes a particular import declaration and is
-- If we know the exact definition point (which we may do with GHCi)
-- then show that too. But not if it's just "imported from X".
ppr_defn :: SrcLoc -> SDoc
-ppr_defn loc | isGoodSrcLoc loc = parens (ptext (sLit "defined at") <+> ppr loc)
- | otherwise = empty
+ppr_defn (RealSrcLoc loc) = parens (ptext (sLit "defined at") <+> ppr loc)
+ppr_defn (UnhelpfulLoc _) = empty
instance Outputable ImportSpec where
ppr imp_spec
= ptext (sLit "imported from") <+> ppr (importSpecModule imp_spec)
- <+> if isGoodSrcSpan loc then ptext (sLit "at") <+> ppr loc
- else empty
+ <+> pprLoc
where
loc = importSpecLoc imp_spec
+ pprLoc = case loc of
+ RealSrcSpan s -> ptext (sLit "at") <+> ppr s
+ UnhelpfulSpan _ -> empty
\end{code}
%
\begin{code}
+{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
+ -- Workaround for Trac #5252 crashes the bootstrap compiler without -O
+ -- When the earliest compiler we want to boostrap with is
+ -- GHC 7.2, we can make RealSrcLoc properly abstract
+
+
-- | This module contains types that relate to the positions of things
-- in source files, and allow tagging of those things with locations
module SrcLoc (
-- * SrcLoc
- SrcLoc, -- Abstract
+ RealSrcLoc, -- Abstract
+ SrcLoc(..),
-- ** Constructing SrcLoc
- mkSrcLoc, mkGeneralSrcLoc,
+ mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,
noSrcLoc, -- "I'm sorry, I haven't a clue"
generatedSrcLoc, -- Code generated within the compiler
-- ** Misc. operations on SrcLoc
pprDefnLoc,
-
- -- ** Predicates on SrcLoc
- isGoodSrcLoc,
-- * SrcSpan
- SrcSpan, -- Abstract
+ RealSrcSpan, -- Abstract
+ SrcSpan(..),
-- ** Constructing SrcSpan
- mkGeneralSrcSpan, mkSrcSpan,
+ mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
noSrcSpan,
wiredInSrcSpan, -- Something wired into the compiler
- srcLocSpan,
+ srcLocSpan, realSrcLocSpan,
combineSrcSpans,
-- ** Deconstructing SrcSpan
srcSpanStart, srcSpanEnd,
+ realSrcSpanStart, realSrcSpanEnd,
srcSpanFileName_maybe,
-- ** Unsafely deconstructing SrcSpan
isGoodSrcSpan, isOneLineSpan,
-- * Located
- Located(..),
+ Located,
+ RealLocated,
+ GenLocated(..),
-- ** Constructing Located
noLoc,
this is the obvious stuff:
\begin{code}
-- | Represents a single point within a file
-data SrcLoc
+data RealSrcLoc
= SrcLoc FastString -- A precise location (file name)
{-# UNPACK #-} !Int -- line number, begins at 1
{-# UNPACK #-} !Int -- column number, begins at 1
+
+data SrcLoc
+ = RealSrcLoc {-# UNPACK #-}!RealSrcLoc
| UnhelpfulLoc FastString -- Just a general indication
\end{code}
\begin{code}
mkSrcLoc :: FastString -> Int -> Int -> SrcLoc
-mkSrcLoc x line col = SrcLoc x line col
+mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col)
+
+mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc
+mkRealSrcLoc x line col = SrcLoc x line col
-- | Built-in "bad" 'SrcLoc' values for particular locations
noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
mkGeneralSrcLoc :: FastString -> SrcLoc
mkGeneralSrcLoc = UnhelpfulLoc
--- | "Good" 'SrcLoc's have precise information about their location
-isGoodSrcLoc :: SrcLoc -> Bool
-isGoodSrcLoc (SrcLoc _ _ _) = True
-isGoodSrcLoc _other = False
-
--- | Gives the filename of the 'SrcLoc' if it is available, otherwise returns a dummy value
-srcLocFile :: SrcLoc -> FastString
+-- | Gives the filename of the 'RealSrcLoc'
+srcLocFile :: RealSrcLoc -> FastString
srcLocFile (SrcLoc fname _ _) = fname
-srcLocFile _other = (fsLit "<unknown file")
-- | Raises an error when used on a "bad" 'SrcLoc'
-srcLocLine :: SrcLoc -> Int
+srcLocLine :: RealSrcLoc -> Int
srcLocLine (SrcLoc _ l _) = l
-srcLocLine (UnhelpfulLoc s) = pprPanic "srcLocLine" (ftext s)
-- | Raises an error when used on a "bad" 'SrcLoc'
-srcLocCol :: SrcLoc -> Int
+srcLocCol :: RealSrcLoc -> Int
srcLocCol (SrcLoc _ _ c) = c
-srcLocCol (UnhelpfulLoc s) = pprPanic "srcLocCol" (ftext s)
-- | Move the 'SrcLoc' down by one line if the character is a newline,
-- to the next 8-char tabstop if it is a tab, and across by one
-- character in any other case
-advanceSrcLoc :: SrcLoc -> Char -> SrcLoc
+advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1
advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (((((c - 1) `shiftR` 3) + 1)
`shiftL` 3) + 1)
advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1)
-advanceSrcLoc loc _ = loc -- Better than nothing
\end{code}
%************************************************************************
-- SrcLoc is an instance of Ord so that we can sort error messages easily
instance Eq SrcLoc where
loc1 == loc2 = case loc1 `cmpSrcLoc` loc2 of
- EQ -> True
- _other -> False
+ EQ -> True
+ _other -> False
+
+instance Eq RealSrcLoc where
+ loc1 == loc2 = case loc1 `cmpRealSrcLoc` loc2 of
+ EQ -> True
+ _other -> False
instance Ord SrcLoc where
compare = cmpSrcLoc
-
+
+instance Ord RealSrcLoc where
+ compare = cmpRealSrcLoc
+
cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering
cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2
-cmpSrcLoc (UnhelpfulLoc _) (SrcLoc _ _ _) = GT
-cmpSrcLoc (SrcLoc _ _ _) (UnhelpfulLoc _) = LT
+cmpSrcLoc (UnhelpfulLoc _) (RealSrcLoc _) = GT
+cmpSrcLoc (RealSrcLoc _) (UnhelpfulLoc _) = LT
+cmpSrcLoc (RealSrcLoc l1) (RealSrcLoc l2) = (l1 `compare` l2)
-cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2)
+cmpRealSrcLoc :: RealSrcLoc -> RealSrcLoc -> Ordering
+cmpRealSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2)
= (s1 `compare` s2) `thenCmp` (l1 `compare` l2) `thenCmp` (c1 `compare` c2)
-instance Outputable SrcLoc where
+instance Outputable RealSrcLoc where
ppr (SrcLoc src_path src_line src_col)
= getPprStyle $ \ sty ->
if userStyle sty || debugStyle sty then
hcat [text "{-# LINE ", int src_line, space,
char '\"', pprFastFilePath src_path, text " #-}"]
+instance Outputable SrcLoc where
+ ppr (RealSrcLoc l) = ppr l
ppr (UnhelpfulLoc s) = ftext s
+instance Data RealSrcSpan where
+ -- don't traverse?
+ toConstr _ = abstractConstr "RealSrcSpan"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "RealSrcSpan"
+
instance Data SrcSpan where
-- don't traverse?
toConstr _ = abstractConstr "SrcSpan"
span. That is, a span of (1,1)-(1,2) is one character long, and a
span of (1,1)-(1,1) is zero characters long.
-}
-data SrcSpan
+data RealSrcSpan
= SrcSpanOneLine -- a common case: a single line
{ srcSpanFile :: !FastString,
srcSpanLine :: {-# UNPACK #-} !Int,
srcSpanLine :: {-# UNPACK #-} !Int,
srcSpanCol :: {-# UNPACK #-} !Int
}
+#ifdef DEBUG
+ deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, becuase we
+ -- derive Show for Token
+#else
+ deriving (Eq, Typeable)
+#endif
+data SrcSpan =
+ RealSrcSpan !RealSrcSpan
| UnhelpfulSpan !FastString -- Just a general indication
-- also used to indicate an empty span
-- | Create a 'SrcSpan' corresponding to a single point
srcLocSpan :: SrcLoc -> SrcSpan
srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
-srcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col
+srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l)
+
+realSrcLocSpan :: RealSrcLoc -> RealSrcSpan
+realSrcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col
-- | Create a 'SrcSpan' between two points in a file
-mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
-mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
-mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
-mkSrcSpan loc1 loc2
+mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan
+mkRealSrcSpan loc1 loc2
| line1 == line2 = if col1 == col2
then SrcSpanPoint file line1 col1
else SrcSpanOneLine file line1 col1 col2
col2 = srcLocCol loc2
file = srcLocFile loc1
+-- | Create a 'SrcSpan' between two points in a file
+mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
+mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
+mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
+mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2)
+ = RealSrcSpan (mkRealSrcSpan loc1 loc2)
+
-- | Combines two 'SrcSpan' into one that spans at least all the characters
-- within both spans. Assumes the "file" part is the same in both inputs
combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful
combineSrcSpans l (UnhelpfulSpan _) = l
-combineSrcSpans span1 span2
+combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)
+ = RealSrcSpan (combineRealSrcSpans span1 span2)
+
+-- | Combines two 'SrcSpan' into one that spans at least all the characters
+-- within both spans. Assumes the "file" part is the same in both inputs
+combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan
+combineRealSrcSpans span1 span2
= if line_start == line_end
then if col_start == col_end
then SrcSpanPoint file line_start col_start
\begin{code}
-- | Test if a 'SrcSpan' is "good", i.e. has precise location information
isGoodSrcSpan :: SrcSpan -> Bool
-isGoodSrcSpan SrcSpanOneLine{} = True
-isGoodSrcSpan SrcSpanMultiLine{} = True
-isGoodSrcSpan SrcSpanPoint{} = True
-isGoodSrcSpan _ = False
+isGoodSrcSpan (RealSrcSpan _) = True
+isGoodSrcSpan (UnhelpfulSpan _) = False
isOneLineSpan :: SrcSpan -> Bool
-- ^ True if the span is known to straddle only one line.
-- For "bad" 'SrcSpan', it returns False
-isOneLineSpan s
- | isGoodSrcSpan s = srcSpanStartLine s == srcSpanEndLine s
- | otherwise = False
+isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s
+isOneLineSpan (UnhelpfulSpan _) = False
\end{code}
\begin{code}
--- | Raises an error when used on a "bad" 'SrcSpan'
-srcSpanStartLine :: SrcSpan -> Int
--- | Raises an error when used on a "bad" 'SrcSpan'
-srcSpanEndLine :: SrcSpan -> Int
--- | Raises an error when used on a "bad" 'SrcSpan'
-srcSpanStartCol :: SrcSpan -> Int
--- | Raises an error when used on a "bad" 'SrcSpan'
-srcSpanEndCol :: SrcSpan -> Int
+srcSpanStartLine :: RealSrcSpan -> Int
+srcSpanEndLine :: RealSrcSpan -> Int
+srcSpanStartCol :: RealSrcSpan -> Int
+srcSpanEndCol :: RealSrcSpan -> Int
srcSpanStartLine SrcSpanOneLine{ srcSpanLine=l } = l
srcSpanStartLine SrcSpanMultiLine{ srcSpanSLine=l } = l
srcSpanStartLine SrcSpanPoint{ srcSpanLine=l } = l
-srcSpanStartLine _ = panic "SrcLoc.srcSpanStartLine"
srcSpanEndLine SrcSpanOneLine{ srcSpanLine=l } = l
srcSpanEndLine SrcSpanMultiLine{ srcSpanELine=l } = l
srcSpanEndLine SrcSpanPoint{ srcSpanLine=l } = l
-srcSpanEndLine _ = panic "SrcLoc.srcSpanEndLine"
srcSpanStartCol SrcSpanOneLine{ srcSpanSCol=l } = l
srcSpanStartCol SrcSpanMultiLine{ srcSpanSCol=l } = l
srcSpanStartCol SrcSpanPoint{ srcSpanCol=l } = l
-srcSpanStartCol _ = panic "SrcLoc.srcSpanStartCol"
srcSpanEndCol SrcSpanOneLine{ srcSpanECol=c } = c
srcSpanEndCol SrcSpanMultiLine{ srcSpanECol=c } = c
srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c
-srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol"
\end{code}
-- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
srcSpanStart :: SrcSpan -> SrcLoc
+srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str
+srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s)
+
-- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
srcSpanEnd :: SrcSpan -> SrcLoc
+srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
+srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s)
-srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str
-srcSpanStart s = mkSrcLoc (srcSpanFile s)
- (srcSpanStartLine s)
- (srcSpanStartCol s)
+realSrcSpanStart :: RealSrcSpan -> RealSrcLoc
+realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s)
+ (srcSpanStartLine s)
+ (srcSpanStartCol s)
-srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
-srcSpanEnd s =
- mkSrcLoc (srcSpanFile s)
- (srcSpanEndLine s)
- (srcSpanEndCol s)
+realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc
+realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s)
+ (srcSpanEndLine s)
+ (srcSpanEndCol s)
-- | Obtains the filename for a 'SrcSpan' if it is "good"
srcSpanFileName_maybe :: SrcSpan -> Maybe FastString
-srcSpanFileName_maybe (SrcSpanOneLine { srcSpanFile = nm }) = Just nm
-srcSpanFileName_maybe (SrcSpanMultiLine { srcSpanFile = nm }) = Just nm
-srcSpanFileName_maybe (SrcSpanPoint { srcSpanFile = nm}) = Just nm
-srcSpanFileName_maybe _ = Nothing
+srcSpanFileName_maybe (RealSrcSpan s) = Just (srcSpanFile s)
+srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing
\end{code}
(srcSpanEnd a `compare` srcSpanEnd b)
-instance Outputable SrcSpan where
+instance Outputable RealSrcSpan where
ppr span
= getPprStyle $ \ sty ->
if userStyle sty || debugStyle sty then
- pprUserSpan True span
+ pprUserRealSpan True span
else
hcat [text "{-# LINE ", int (srcSpanStartLine span), space,
char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"]
+instance Outputable SrcSpan where
+ ppr span
+ = getPprStyle $ \ sty ->
+ if userStyle sty || debugStyle sty then
+ pprUserSpan True span
+ else
+ case span of
+ UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"
+ RealSrcSpan s -> ppr s
+
pprUserSpan :: Bool -> SrcSpan -> SDoc
-pprUserSpan show_path (SrcSpanOneLine src_path line start_col end_col)
+pprUserSpan _ (UnhelpfulSpan s) = ftext s
+pprUserSpan show_path (RealSrcSpan s) = pprUserRealSpan show_path s
+
+pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc
+pprUserRealSpan show_path (SrcSpanOneLine src_path line start_col end_col)
= hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
, int line, char ':', int start_col
, ppUnless (end_col - start_col <= 1)
]
-pprUserSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol)
+pprUserRealSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol)
= hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
, parens (int sline <> char ',' <> int scol)
, char '-'
if ecol == 0 then int ecol else int (ecol-1))
]
-pprUserSpan show_path (SrcSpanPoint src_path line col)
+pprUserRealSpan show_path (SrcSpanPoint src_path line col)
= hcat [ ppWhen show_path $ (pprFastFilePath src_path <> colon)
, int line, char ':', int col ]
-pprUserSpan _ (UnhelpfulSpan s) = ftext s
-
-pprDefnLoc :: SrcSpan -> SDoc
+pprDefnLoc :: RealSrcSpan -> SDoc
-- ^ Pretty prints information about the 'SrcSpan' in the style "defined at ..."
-pprDefnLoc loc
- | isGoodSrcSpan loc = ptext (sLit "Defined at") <+> ppr loc
- | otherwise = ppr loc
+pprDefnLoc loc = ptext (sLit "Defined at") <+> ppr loc
\end{code}
%************************************************************************
\begin{code}
-- | We attach SrcSpans to lots of things, so let's have a datatype for it.
-data Located e = L SrcSpan e
+data GenLocated l e = L l e
deriving (Eq, Ord, Typeable, Data)
-unLoc :: Located e -> e
+type Located e = GenLocated SrcSpan e
+type RealLocated e = GenLocated RealSrcSpan e
+
+unLoc :: GenLocated l e -> e
unLoc (L _ e) = e
-getLoc :: Located e -> SrcSpan
+getLoc :: GenLocated l e -> l
getLoc (L l _) = l
noLoc :: e -> Located e
cmpLocated :: Ord a => Located a -> Located a -> Ordering
cmpLocated a b = unLoc a `compare` unLoc b
-instance Functor Located where
+instance Functor (GenLocated l) where
fmap f (L l e) = L l (f e)
-instance Outputable e => Outputable (Located e) where
- ppr (L l e) = ifPprDebug (braces (pprUserSpan False l)) $$ ppr e
- -- Print spans without the file name etc
+instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
+ ppr (L l e) = -- TODO: We can't do this since Located was refactored into
+ -- GenLocated:
+ -- Print spans without the file name etc
+ -- ifPprDebug (braces (pprUserSpan False l))
+ ifPprDebug (braces (ppr l))
+ $$ ppr e
\end{code}
%************************************************************************
`thenCmp`
(srcSpanEnd b `compare` srcSpanEnd a)
-
-- | Determines whether a span encloses a given line and column index
spans :: SrcSpan -> (Int, Int) -> Bool
-spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
- where loc = mkSrcLoc (srcSpanFile span) l c
+spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan"
+spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span
+ where loc = mkRealSrcLoc (srcSpanFile span) l c
-- | Determines whether a span is enclosed by another one
isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other
module CmmCallConv (
ParamLocation(..),
- ArgumentFormat,
- assignArguments,
- assignArgumentsPos,
- argumentsSize,
+ assignArgumentsPos
) where
#include "HsVersions.h"
-- 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)]
-
--- Stack parameters are returned as word offsets.
-assignArguments :: (a -> CmmType) -> [a] -> ArgumentFormat a WordOff
-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
where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
regs = case (reps, conv) of
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
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
GenCmm(..), GenCmmTop(..),
CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription,
ProfilingInfo(..), ClosureTypeTag,
- CmmActual, CmmActuals, CmmFormal, CmmFormals, ForeignHint(..),
+ CmmActual, CmmFormal, ForeignHint(..),
CmmStatic(..), Section(..),
) where
type CmmActual = CmmExpr
type CmmFormal = LocalReg
-type CmmActuals = [CmmActual]
-type CmmFormals = [CmmFormal]
data ForeignHint
= NoHint | AddrHint | SignedHint
, 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
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 [_$_]
-----------------------------------------------------------------------------
-- -----------------------------------------------------------------------------
-- Lexer actions
-type Action = SrcSpan -> StringBuffer -> Int -> P (Located CmmToken)
+type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated CmmToken)
begin :: Int -> Action
begin code _span _str _len = do pushLexState code; lexToken
setLine :: Int -> Action
setLine code span buf len = do
let line = parseUnsignedInteger buf len 10 octDecDigit
- setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
+ setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
-- subtract one: the line number refers to the *following* line
-- trace ("setLine " ++ show line) $ do
popLexState
setFile :: Int -> Action
setFile code span buf len = do
let file = lexemeToFastString (stepOn buf) (len-2)
- setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
+ setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
popLexState
pushLexState code
lexToken
cmmlex :: (Located CmmToken -> P a) -> P a
cmmlex cont = do
- tok@(L _ tok__) <- lexToken
- --trace ("token: " ++ show tok__) $ do
- cont tok
+ (L span tok) <- lexToken
+ --trace ("token: " ++ show tok) $ do
+ cont (L (RealSrcSpan span) tok)
-lexToken :: P (Located CmmToken)
+lexToken :: P (RealLocated CmmToken)
lexToken = do
inp@(loc1,buf) <- getInput
sc <- getLexState
case alexScan inp sc of
- AlexEOF -> do let span = mkSrcSpan loc1 loc1
+ AlexEOF -> do let span = mkRealSrcSpan loc1 loc1
setLastToken span 0
return (L span CmmT_EOF)
AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error"
lexToken
AlexToken inp2@(end,buf2) len t -> do
setInput inp2
- let span = mkSrcSpan loc1 end
+ let span = mkRealSrcSpan loc1 end
span `seq` setLastToken span len
t span buf len
-- Monad stuff
-- Stuff that Alex needs to know about our input type:
-type AlexInput = (SrcLoc,StringBuffer)
+type AlexInput = (RealSrcLoc,StringBuffer)
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (_,s) = prevChar s '\n'
| MO_F32_Sqrt
| MO_WriteBarrier
| MO_Touch -- Keep variables live (when using interior pointers)
+
+ -- Note that these three MachOps all take 1 extra parameter than the
+ -- standard C lib versions. The extra (last) parameter contains
+ -- alignment of the pointers. Used for optimisation in backends.
+ | MO_Memcpy
+ | MO_Memset
+ | MO_Memmove
deriving (Eq, Show)
pprCallishMachOp :: CallishMachOp -> SDoc
pprCallishMachOp mo = text (show mo)
+
-- 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
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
-- The mini-inliner
{-
-This pass inlines assignments to temporaries that are used just
-once. It works as follows:
+This pass inlines assignments to temporaries. Temporaries that are
+only used once are unconditionally inlined. Temporaries that are used
+two or more times are only inlined if they are assigned a literal. It
+works as follows:
- count uses of each temporary
- - for each temporary that occurs just once:
+ - for each temporary:
- attempt to push it forward to the statement that uses it
- only push forward past assignments to other temporaries
(assumes that temporaries are single-assignment)
cmmMiniInlineStmts :: UniqFM Int -> [CmmStmt] -> [CmmStmt]
cmmMiniInlineStmts uses [] = []
cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
- -- not used at all: just discard this assignment
+ -- not used: just discard this assignment
| Nothing <- lookupUFM uses u
= cmmMiniInlineStmts uses stmts
- -- used once: try to inline at the use site
+ -- used (literal): try to inline at all the use sites
+ | Just n <- lookupUFM uses u, isLit expr
+ =
+#ifdef NCG_DEBUG
+ trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $
+#endif
+ case lookForInlineLit u expr stmts of
+ (m, stmts')
+ | n == m -> cmmMiniInlineStmts (delFromUFM uses u) stmts'
+ | otherwise ->
+ stmt : cmmMiniInlineStmts (adjustUFM (\x -> x - m) uses u) stmts'
+
+ -- used (foldable to literal): try to inline at all the use sites
+ | Just n <- lookupUFM uses u,
+ CmmMachOp op es <- expr,
+ e@(CmmLit _) <- cmmMachOpFold op es
+ =
+#ifdef NCG_DEBUG
+ trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $
+#endif
+ case lookForInlineLit u e stmts of
+ (m, stmts')
+ | n == m -> cmmMiniInlineStmts (delFromUFM uses u) stmts'
+ | otherwise ->
+ stmt : cmmMiniInlineStmts (adjustUFM (\x -> x - m) uses u) stmts'
+
+ -- used once (non-literal): try to inline at the use site
| Just 1 <- lookupUFM uses u,
Just stmts' <- lookForInline u expr stmts
=
cmmMiniInlineStmts uses (stmt:stmts)
= stmt : cmmMiniInlineStmts uses stmts
+-- | Takes a register, a 'CmmLit' expression assigned to that
+-- register, and a list of statements. Inlines the expression at all
+-- use sites of the register. Returns the number of substituations
+-- made and the, possibly modified, list of statements.
+lookForInlineLit :: Unique -> CmmExpr -> [CmmStmt] -> (Int, [CmmStmt])
+lookForInlineLit _ _ [] = (0, [])
+lookForInlineLit u expr stmts@(stmt : rest)
+ | Just n <- lookupUFM (countUses stmt) u
+ = case lookForInlineLit u expr rest of
+ (m, stmts) -> let z = n + m
+ in z `seq` (z, inlineStmt u expr stmt : stmts)
+
+ | ok_to_skip
+ = case lookForInlineLit u expr rest of
+ (n, stmts) -> (n, stmt : stmts)
+
+ | otherwise
+ = (0, stmts)
+ where
+ -- We skip over assignments to registers, unless the register
+ -- being assigned to is the one we're inlining.
+ ok_to_skip = case stmt of
+ CmmAssign (CmmLocal r@(LocalReg u' _)) _ | u' == u -> False
+ _other -> True
+
lookForInline u expr stmts = lookForInline' u expr regset stmts
where regset = foldRegsUsed extendRegSet emptyRegSet expr
callishMachOps = listToUFM $
map (\(x, y) -> (mkFastString x, y)) [
- ( "write_barrier", MO_WriteBarrier )
+ ( "write_barrier", MO_WriteBarrier ),
+ ( "memcpy", MO_Memcpy ),
+ ( "memset", MO_Memset ),
+ ( "memmove", MO_Memmove )
-- ToDo: the rest, maybe
]
showPass dflags "ParseCmm"
buf <- hGetStringBuffer filename
let
- init_loc = mkSrcLoc (mkFastString filename) 1 1
+ init_loc = mkRealSrcLoc (mkFastString filename) 1 1
init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
-- reset the lex_state: the Lexer monad leaves some stuff
-- in there we don't want.
-- 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 CmmCommonBlockElim
import CmmProcPoint
import CmmSpillReload
+import CmmRewriteAssignments
import CmmStackLayout
+import CmmContFlowOpt
import OptimizationFuel
import DynFlags
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
-- 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]
~~~~~~~~~~~~~~~~~~~~~
-}
-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
--- /dev/null
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
+
+-- 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 OptimizationFuel
+import StgCmmUtils
+
+import Control.Monad
+import UniqFM
+import Unique
+
+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
+ 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 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
+
+-- ToDo: Outputable instance for UsageMap and AssignmentMap
-{-# 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 #-}
-{-# 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 #-}
--, insertSpillsAndReloads --- XXX todo check live-in at entry against formals
, dualLivenessWithInsertion
- , rewriteAssignments
, removeDeadAssignmentsAndReloads
)
where
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
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.
+their reaching definitions, but reloads are dropped immediately after
+we return from a call and will have to be sunk by a later forward
+transformation.
+
+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 }
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)
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
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
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
-- 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]
-copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
- (Int, CmmAGraph)
+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)
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.
-- Factoring out the common parts of the copyout functions yielded something
-- more complicated:
+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.
+--
-- The argument layout function ignores the pointer to the info table, so we slot that
-- in here. When copying-out to a young area, we set the info table for return
-- and adjust the offsets of the other parameters.
-- If this is a call instruction, we adjust the offsets of the other parameters.
-copyOutOflow conv transfer area@(CallArea a) actuals updfr_off =
- foldr co (init_offset, emptyAGraph) args'
- where co (v, RegisterParam r) (n, ms) = (n, mkAssign (CmmGlobal r) v <*> ms)
- co (v, StackParam off) (n, ms) =
- (max n off, mkStore (CmmStackSlot area off) v <*> ms)
- (setRA, init_offset) =
- case a of Young id -> id `seq` -- set RA if making a call
- if transfer == Call then
- ([(CmmLit (CmmBlock id), StackParam init_offset)],
- widthInBytes wordWidth)
- else ([], 0)
- Old -> ([], updfr_off)
- args = assignArgumentsPos conv cmmExprType actuals
- args' = foldl adjust setRA args
- where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
- adjust rst x@(_, RegisterParam _) = x : rst
+copyOutOflow conv transfer area@(CallArea a) actuals updfr_off
+ = foldr co (init_offset, emptyAGraph) args'
+ where
+ co (v, RegisterParam r) (n, ms) = (n, mkAssign (CmmGlobal r) v <*> ms)
+ co (v, StackParam off) (n, ms) = (max n off, mkStore (CmmStackSlot area off) v <*> ms)
+
+ (setRA, init_offset) =
+ case a of Young id -> id `seq` -- Generate a store instruction for
+ -- the return address if making a call
+ if transfer == Call then
+ ([(CmmLit (CmmBlock id), StackParam init_offset)],
+ widthInBytes wordWidth)
+ else ([], 0)
+ Old -> ([], updfr_off)
+
+ args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
+ args = assignArgumentsPos conv cmmExprType actuals
+
+ args' = foldl adjust setRA args
+ where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
+ adjust rst x@(_, RegisterParam _) = x : rst
+
copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
-- Args passed only in registers and stack slots; no overflow space.
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
cmmMapGraphM, cmmTopMapGraphM,
GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
CmmStmt(..), CmmReturnInfo(..), CmmHinted(..),
- HintedCmmFormal, HintedCmmFormals, HintedCmmActual, HintedCmmActuals,
+ HintedCmmFormal, HintedCmmActual,
CmmSafety(..), CmmCallTarget(..),
module CmmDecl,
module CmmExpr,
| 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
-- 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
---------------------------------------------------
loadArgsIntoTemps :: [Unique]
- -> HintedCmmActuals
- -> ([Unique], [CmmStmt], HintedCmmActuals)
+ -> [HintedCmmActual]
+ -> ([Unique], [CmmStmt], [HintedCmmActual])
loadArgsIntoTemps uniques [] = (uniques, [], [])
loadArgsIntoTemps uniques ((CmmHinted e hint):args) =
(uniques'',
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) <>
-- -----------------------------------------------------------------------------
-- Foreign Calls
-pprCall :: SDoc -> CCallConv -> HintedCmmFormals -> HintedCmmActuals -> CmmSafety
+pprCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> CmmSafety
-> SDoc
pprCall ppr_fn cconv results args _
+More notes (June 11)\r
+~~~~~~~~~~~~~~~~~~~~\r
+* Possible refactoring: Nuke AGraph in favour of \r
+ mkIfThenElse :: Expr -> Graph -> Graph -> FCode Graph\r
+ or even\r
+ mkIfThenElse :: HasUniques m => Expr -> Graph -> Graph -> m Graph\r
+ (Remmber that the .cmm file parser must use this function)\r
+\r
+ or parameterise FCode over its envt; the CgState part seem useful for both\r
+\r
+* "Remove redundant reloads" in CmmSpillReload should be redundant; since\r
+ insertLateReloads is now gone, every reload is reloading a live variable.\r
+ Test and nuke.\r
+\r
+* Sink and inline S(RegSlot(x)) = e in precisely the same way that we\r
+ sink and inline x = e\r
+\r
+* Stack layout is very like register assignment: find non-conflicting assigments.\r
+ In particular we can use colouring or linear scan (etc).\r
+\r
+ We'd fine-grain interference (on a word by word basis) to get maximum overlap.\r
+ But that may make very big interference graphs. So linear scan might be\r
+ more attactive.\r
+\r
+ NB: linear scan does on-the-fly live range splitting.\r
+\r
+* When stubbing dead slots be careful not to write into an area that\r
+ overlaps with an area that's in use. So stubbing needs to *follow* \r
+ stack layout.\r
+\r
+\r
More notes (May 11)\r
~~~~~~~~~~~~~~~~~~~\r
In CmmNode, consider spliting CmmCall into two: call and jump\r
CmmOpt.hs Hopefully-redundant optimiser\r
\r
-------- Stuff to keep ------------\r
-CmmCPS.hs Driver for new pipeline\r
+CmmPipeline.hs Driver for new pipeline\r
\r
CmmLive.hs Liveness analysis, dead code elim\r
CmmProcPoint.hs Identifying and splitting out proc-points\r
type RawCmm = GenCmm CmmStatic [CmmStatic] (ListGraph CmmStmt)\r
\r
* HscMain.tryNewCodeGen\r
- - STG->Cmm: StgCmm.codeGen (new codegen)\r
- - Optimise: CmmContFlowOpt (simple optimisations, very self contained)\r
- - Cps convert: CmmCPS.protoCmmCPS \r
- - Optimise: CmmContFlowOpt again\r
- - Convert: CmmCvt.cmmOfZgraph (convert to old rep) very self contained\r
+ - STG->Cmm: StgCmm.codeGen (new codegen)\r
+ - Optimize and CPS: CmmPipeline.cmmPipeline\r
+ - Convert: CmmCvt.cmmOfZgraph (convert to old rep) very self contained\r
\r
* StgCmm.hs The new STG -> Cmm conversion code generator\r
Lots of modules StgCmmXXX\r
\r
\r
----------------------------------------------------\r
- CmmCPS.protoCmmCPS The new pipeline\r
+ CmmPipeline.cmmPipeline The new pipeline\r
----------------------------------------------------\r
\r
-CmmCPS.protoCmmCPS:\r
- 1. Do cpsTop for each procedures separately\r
- 2. Build SRT representation; this spans multiple procedures\r
- (unless split-objs)\r
+CmmPipeline.cmmPipeline:\r
+ 1. Do control flow optimization\r
+ 2. Do cpsTop for each procedures separately\r
+ 3. Build SRT representation; this spans multiple procedures\r
+ (unless split-objs)\r
+ 4. Do control flow optimization on all resulting procedures\r
\r
cpsTop:\r
* CmmCommonBlockElim.elimCommonBlocks:\r
f's keep-alive refs to include h1.\r
\r
* The SRT info is the C_SRT field of Cmm.ClosureTypeInfo in a\r
- CmmInfoTable attached to each CmmProc. CmmCPS.toTops actually does\r
+ CmmInfoTable attached to each CmmProc. CmmPipeline.toTops actually does\r
the attaching, right at the end of the pipeline. The C_SRT part\r
gives offsets within a single, shared table of closure pointers.\r
\r
-- 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
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
-- 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
-- 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
emitInfoTableAndCode
:: CLabel -- Label of entry or ret
-> CmmInfo -- ...the info table
- -> CmmFormals -- ...args
+ -> [CmmFormal] -- ...args
-> [CmmBasicBlock] -- ...and body
-> 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)
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
-- ---------------------------------------------------------------------------
-- 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
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
-- ----------------------------------------------------------------------------
-- 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
emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) live
emitMemsetCall (cmmOffsetExprW dst_p n)
- (CmmLit (CmmInt (toInteger (1 :: Int)) W8))
+ (CmmLit (mkIntCLit 1))
(card_words `cmmMulWord` wordSize)
live
stmtC $ CmmAssign (CmmLocal res_r) arr
emitSetCards dst_start dst_cards_start n live = do
start_card <- assignTemp $ card dst_start
emitMemsetCall (dst_cards_start `cmmAddWord` start_card)
- (CmmLit (CmmInt (toInteger (1 :: Int)) W8))
+ (CmmLit (mkIntCLit 1))
((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card)
`cmmAddWord` CmmLit (mkIntCLit 1))
live
memmove = CmmLit (CmmLabel (mkForeignLabel (fsLit "memmove") Nothing
ForeignLabelInExternalPackage IsFunction))
--- | Emit a call to @memset@. The second argument must be of type
--- 'W8'.
+-- | 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
vols <- getVolatileRegs live
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
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
; 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 ()
import StgCmmEnv
import StgCmmMonad
import StgCmmUtils
+import StgCmmTicky
+import StgCmmHeap
+import StgCmmProf
+import BasicTypes
import MkGraph
import StgSyn
import CmmDecl
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
setInfo :: CmmExpr -> CmmExpr -> CmmAGraph
setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr
+-- ----------------------------------------------------------------------------
+-- 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 = emitMemcpyCall
+
+-- | 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,
+ getCode $ emitMemcpyCall dst_p src_p bytes
+ ]
+ 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)
+
+ emitMemsetCall (cmmOffsetExprW dst_p n)
+ (CmmLit (mkIntCLit 1))
+ (card_words `cmmMulWord` wordSize)
+ 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))
+ 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 -> FCode ()
+emitMemcpyCall dst src n = do
+ emitCCall
+ [ {-no results-} ]
+ memcpy
+ [ (dst, AddrHint)
+ , (src, AddrHint)
+ , (n, NoHint)
+ ]
+ where
+ memcpy = CmmLit (CmmLabel (mkForeignLabel (fsLit "memcpy") Nothing
+ ForeignLabelInExternalPackage IsFunction))
+
+-- | Emit a call to @memmove@.
+emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
+emitMemmoveCall dst src n = do
+ emitCCall
+ [ {- no results -} ]
+ memmove
+ [ (dst, AddrHint)
+ , (src, AddrHint)
+ , (n, NoHint)
+ ]
+ 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 -> FCode ()
+emitMemsetCall dst c n = do
+ emitCCall
+ [ {- no results -} ]
+ memset
+ [ (dst, AddrHint)
+ , (c, NoHint)
+ , (n, NoHint)
+ ]
+ where
+ memset = CmmLit (CmmLabel (mkForeignLabel (fsLit "memset") Nothing
+ ForeignLabelInExternalPackage IsFunction))
+
+-- | 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))
callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
- cmmUGtWord,
+ cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
cmmOffsetExprW, cmmOffsetExprB,
cmmRegOffW, cmmRegOffB,
cmmLabelOffW, cmmLabelOffB,
-----------------------
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]
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)
-------------------------------------------------------------------------
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)
-- | A module concerned with finding the free variables of an expression.
module CoreFVs (
-- * Free variables of expressions and binding groups
- exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
- exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids
- exprsFreeVars, -- [CoreExpr] -> VarSet
- bindFreeVars, -- CoreBind -> VarSet
+ exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
+ exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids
+ exprsFreeVars, -- [CoreExpr] -> VarSet
+ bindFreeVars, -- CoreBind -> VarSet
-- * Selective free variables of expressions
InterestingVarFun,
- exprSomeFreeVars, exprsSomeFreeVars,
+ exprSomeFreeVars, exprsSomeFreeVars,
-- * Free variables of Rules, Vars and Ids
varTypeTyVars, varTypeTcTyVars,
- idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
+ idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
- ruleRhsFreeVars, rulesFreeVars,
- ruleLhsOrphNames, ruleLhsFreeIds,
+ ruleRhsFreeVars, rulesFreeVars,
+ ruleLhsOrphNames, ruleLhsFreeIds,
+ vectsFreeVars,
-- * Core syntax tree annotation with free variables
- CoreExprWithFVs, -- = AnnExpr Id VarSet
- CoreBindWithFVs, -- = AnnBind Id VarSet
- freeVars, -- CoreExpr -> CoreExprWithFVs
- freeVarsOf -- CoreExprWithFVs -> IdSet
+ CoreExprWithFVs, -- = AnnExpr Id VarSet
+ CoreBindWithFVs, -- = AnnBind Id VarSet
+ freeVars, -- CoreExpr -> CoreExprWithFVs
+ freeVarsOf -- CoreExprWithFVs -> IdSet
) where
#include "HsVersions.h"
\end{code}
%************************************************************************
-%* *
+%* *
\section[freevars-everywhere]{Attaching free variables to every sub-expression}
-%* *
+%* *
%************************************************************************
\begin{code}
ruleRhsFreeVars :: CoreRule -> VarSet
ruleRhsFreeVars (BuiltinRule {}) = noFVs
ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs })
- = delFromUFM fvs fn -- Note [Rule free var hack]
+ = delFromUFM fvs fn -- Note [Rule free var hack]
where
fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
ruleFreeVars :: CoreRule -> VarSet
ruleFreeVars (BuiltinRule {}) = noFVs
ruleFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args })
- = delFromUFM fvs fn -- Note [Rule free var hack]
+ = delFromUFM fvs fn -- Note [Rule free var hack]
where
fvs = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet
get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs
, ru_rhs = rhs, ru_act = act })
| is_active act
- -- See Note [Finding rule RHS free vars] in OccAnal.lhs
- = delFromUFM fvs fn -- Note [Rule free var hack]
+ -- See Note [Finding rule RHS free vars] in OccAnal.lhs
+ = delFromUFM fvs fn -- Note [Rule free var hack]
where
fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
get_fvs _ = noFVs
= addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet
\end{code}
+
Note [Rule free var hack]
~~~~~~~~~~~~~~~~~~~~~~~~~
Don't include the Id in its own rhs free-var set.
Otherwise the occurrence analyser makes bindings recursive
that shoudn't be. E.g.
- RULE: f (f x y) z ==> f x (f y z)
+ RULE: f (f x y) z ==> f x (f y z)
Also since rule_fn is a Name, not a Var, we have to use the grungy delUFM.
+
+\begin{code}
+-- |Free variables of a vectorisation declaration
+vectsFreeVars :: [CoreVect] -> VarSet
+vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet
+ where
+ vectFreeVars (Vect _ Nothing) = noFVs
+ vectFreeVars (Vect _ (Just rhs)) = expr_fvs rhs isLocalId emptyVarSet
+ vectFreeVars (NoVect _) = noFVs
+\end{code}
+
+
%************************************************************************
-%* *
+%* *
\section[freevars-everywhere]{Attaching free variables to every sub-expression}
-%* *
+%* *
%************************************************************************
The free variable pass annotates every node in the expression with its
-- - Rules for *imported* Ids never change ru_fn
-- - Rules for *local* Ids are in the IdInfo for that Id,
-- and the ru_fn field is simply replaced by the new name
--- of the Id
+-- of the Id
substRule _ _ rule@(BuiltinRule {}) = rule
substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
, ru_fn = fn_name, ru_rhs = rhs
, ru_local = is_local })
= rule { ru_bndrs = bndrs',
- ru_fn = if is_local
- then subst_ru_fn fn_name
- else fn_name,
- ru_args = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args,
+ ru_fn = if is_local
+ then subst_ru_fn fn_name
+ else fn_name,
+ ru_args = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args,
ru_rhs = simpleOptExprWith subst' rhs }
-- Do simple optimisation on RHS, in case substitution lets
-- you improve it. The real simplifier never gets to look at it.
(subst', bndrs') = substBndrs subst bndrs
------------------
+substVects :: Subst -> [CoreVect] -> [CoreVect]
+substVects subst = map (substVect subst)
+
+------------------
+substVect :: Subst -> CoreVect -> CoreVect
+substVect _subst (Vect v Nothing) = Vect v Nothing
+substVect subst (Vect v (Just rhs)) = Vect v (Just (simpleOptExprWith subst rhs))
+substVect _subst (NoVect v) = NoVect v
+
+------------------
substVarSet :: Subst -> VarSet -> VarSet
substVarSet subst fvs
= foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
where
subst_fv subst fv
- | isId fv = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv)
- | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
+ | isId fv = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv)
+ | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
\end{code}
Note [Worker inlining]
simpleOptExprWith subst expr = simple_opt_expr subst (occurAnalyseExpr expr)
----------------------
-simpleOptPgm :: DynFlags -> [CoreBind] -> [CoreRule] -> IO ([CoreBind], [CoreRule])
-simpleOptPgm dflags binds rules
+simpleOptPgm :: DynFlags -> [CoreBind] -> [CoreRule] -> [CoreVect]
+ -> IO ([CoreBind], [CoreRule], [CoreVect])
+simpleOptPgm dflags binds rules vects
= do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
- (pprCoreBindings occ_anald_binds);
+ (pprCoreBindings occ_anald_binds);
- ; return (reverse binds', substRulesForImportedIds subst' rules) }
+ ; return (reverse binds', substRulesForImportedIds subst' rules, substVects subst' vects) }
where
occ_anald_binds = occurAnalysePgm Nothing {- No rules active -}
- rules binds
+ rules vects binds
(subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds
do_one (subst, binds') bind
'ModGuts').
\begin{code}
-data CoreVect = Vect Id (Maybe CoreExpr)
+data CoreVect = Vect Id (Maybe CoreExpr)
+ | NoVect Id
+
\end{code}
%************************************************************************
-%* *
- Unfoldings
-%* *
+%* *
+ Unfoldings
+%* *
%************************************************************************
The @Unfolding@ type is declared here to avoid numerous loops
go_pap args = all (exprIsCheap' good_app) args
-- Used to be "all exprIsTrivial args" due to concerns about
-- duplicating nested constructor applications, but see #4978.
+ -- The principle here is that
+ -- let x = a +# b in c *# x
+ -- should behave equivalently to
+ -- c *# (a +# b)
+ -- Since lets with cheap RHSs are accepted,
+ -- so should paps with cheap arguments
--------------
go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args
\end{code}
-----------------------------------------------------
--- Rules
+-- Rules
-----------------------------------------------------
\begin{code}
= ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
- ru_bndrs = tpl_vars, ru_args = tpl_args,
- ru_rhs = rhs })
+ ru_bndrs = tpl_vars, ru_args = tpl_args,
+ ru_rhs = rhs })
= hang (doubleQuotes (ftext name) <+> ppr act)
4 (sep [ptext (sLit "forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
- nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
- nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
- ])
+ nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
+ nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
+ ])
+\end{code}
+
+-----------------------------------------------------
+-- Vectorisation declarations
+-----------------------------------------------------
+
+\begin{code}
+instance Outputable CoreVect where
+ ppr (Vect var Nothing) = ptext (sLit "VECTORISE SCALAR") <+> ppr var
+ ppr (Vect var (Just e)) = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=')
+ 4 (pprCoreExpr e)
+ ppr (NoVect var) = ptext (sLit "NOVECTORISE") <+> ppr var
\end{code}
allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
isGoodSrcSpan' :: SrcSpan -> Bool
-isGoodSrcSpan' pos
- | not (isGoodSrcSpan pos) = False
- | start == end = False
- | otherwise = True
- where
- start = srcSpanStart pos
- end = srcSpanEnd pos
+isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
+isGoodSrcSpan' (UnhelpfulSpan _) = False
mkHpcPos :: SrcSpan -> HpcPos
-mkHpcPos pos
- | not (isGoodSrcSpan' pos) = panic "bad source span; expected such spans to be filtered out"
- | otherwise = hpcPos
- where
- start = srcSpanStart pos
- end = srcSpanEnd pos
- hpcPos = toHpcPos ( srcLocLine start
- , srcLocCol start
- , srcLocLine end
- , srcLocCol end - 1
- )
+mkHpcPos pos@(RealSrcSpan s)
+ | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
+ srcSpanStartCol s,
+ srcSpanEndLine s,
+ srcSpanEndCol s)
+mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
hpcSrcSpan :: SrcSpan
hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
- Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks
+ Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks
, hetmet_brak, hetmet_esc
, hetmet_flatten
, hetmet_unflatten
, hetmet_pga_loopr
) -> do
- { -- Add export flags to bindings
- keep_alive <- readIORef keep_var
- ; let (rules_for_locals, rules_for_imps)
+ { -- Add export flags to bindings
+ keep_alive <- readIORef keep_var
+ ; let (rules_for_locals, rules_for_imps)
= partition isLocalRule all_rules
final_prs = addExportFlagsAndRules target
- export_set keep_alive rules_for_locals (fromOL all_prs)
+ export_set keep_alive rules_for_locals (fromOL all_prs)
final_pgm = let comb = combineEvBinds ds_ev_binds final_prs
in if dopt Opt_F_simpleopt_before_flatten dflags
then comb
else simplifyBinds comb
- -- Notice that we put the whole lot in a big Rec, even the foreign binds
- -- When compiling PrelFloat, which defines data Float = F# Float#
- -- we want F# to be in scope in the foreign marshalling code!
- -- You might think it doesn't matter, but the simplifier brings all top-level
- -- things into the in-scope set before simplifying; so we get no unfolding for F#!
-
- -- Lint result if necessary, and print
- ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
- (vcat [ pprCoreBindings final_pgm
- , pprRules rules_for_imps ])
+ -- Notice that we put the whole lot in a big Rec, even the foreign binds
+ -- When compiling PrelFloat, which defines data Float = F# Float#
+ -- we want F# to be in scope in the foreign marshalling code!
+ -- You might think it doesn't matter, but the simplifier brings all top-level
+ -- things into the in-scope set before simplifying; so we get no unfolding for F#!
; (final_pgm', rules_for_imps') <- if dopt Opt_F_simpleopt_before_flatten dflags
then simpleOptPgm dflags final_pgm rules_for_imps
; dumpIfSet_dyn dflags Opt_D_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds')
- ; endPass dflags CoreDesugar ds_binds' ds_rules_for_imps
+ ; (ds_binds, ds_rules_for_imps, ds_vects)
+ <- simpleOptPgm dflags final_pgm rules_for_imps vects0
+ -- The simpleOptPgm gets rid of type
+ -- bindings plus any stupid dead code
+
+ ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
; let used_names = mkUsedNames tcg_env
- ; deps <- mkDependencies tcg_env
+ ; deps <- mkDependencies tcg_env
; let mod_guts = ModGuts {
mg_module = mod,
\begin{code}
dsVect :: LVectDecl Id -> DsM CoreVect
-dsVect (L loc (HsVect v rhs))
+dsVect (L loc (HsVect (L _ v) rhs))
= putSrcSpanDs loc $
do { rhs' <- fmapMaybeM dsLExpr rhs
- ; return $ Vect (unLoc v) rhs'
+ ; return $ Vect v rhs'
}
--- dsVect (L loc (HsVect v Nothing))
--- = return $ Vect v Nothing
--- dsVect (L loc (HsVect v (Just rhs)))
--- = putSrcSpanDs loc $
--- do { rhs' <- dsLExpr rhs
--- ; return $ Vect v (Just rhs')
--- }
+dsVect (L _loc (HsNoVect (L _ v)))
+ = return $ NoVect v
\end{code}
-> 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
import FastString
import ForeignCall
import MonadUtils
+import Util( equalLength )
import Data.Maybe
import Control.Monad
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
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
-- 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 []
-- 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
; z <- repNoBindSt e2
; (ss2,zs) <- repSts ss
; return (ss2, z : zs) }
+repSts [LastStmt e _]
+ = do { e2 <- repLE e
+ ; z <- repNoBindSt e2
+ ; return ([], [z]) }
repSts [] = return ([],[])
repSts other = notHandled "Exotic statement" (ppr other)
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,
CLabel
Cmm
CmmBuildInfoTables
- CmmCPS
+ CmmPipeline
CmmCallConv
CmmCommonBlockElim
CmmContFlowOpt
CmmParse
CmmProcPoint
CmmSpillReload
+ CmmRewriteAssignments
CmmStackLayout
CmmType
CmmUtils
import UniqSupply
import TcType
import GHC
-import InteractiveEval
import Outputable
import PprTyThing
import MonadUtils
collectRuleBndrSigTys,
-- ** @VECTORISE@ declarations
VectDecl(..), LVectDecl,
+ lvectDeclName,
-- ** @default@ declarations
DefaultDecl(..), LDefaultDecl,
-- ** Top-level template haskell splice
%* *
%************************************************************************
-A vectorisation pragma
+A vectorisation pragma, one of
- {-# VECTORISE f = closure1 g (scalar_map g) #-} OR
+ {-# VECTORISE f = closure1 g (scalar_map g) #-}
{-# VECTORISE SCALAR f #-}
+ {-# NOVECTORISE f #-}
Note [Typechecked vectorisation pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
= HsVect
(Located name)
(Maybe (LHsExpr name)) -- 'Nothing' => SCALAR declaration
+ | HsNoVect
+ (Located name)
deriving (Data, Typeable)
-
+
+lvectDeclName :: LVectDecl name -> name
+lvectDeclName (L _ (HsVect (L _ name) _)) = name
+lvectDeclName (L _ (HsNoVect (L _ name))) = name
+
instance OutputableBndr name => Outputable (VectDecl name) where
- ppr (HsVect v rhs)
+ ppr (HsVect v Nothing)
+ = sep [text "{-# VECTORISE SCALAR" <+> ppr v <+> text "#-}" ]
+ ppr (HsVect v (Just rhs))
= sep [text "{-# VECTORISE" <+> ppr v,
- nest 4 (case rhs of
- Nothing -> text "SCALAR #-}"
- Just rhs -> pprExpr (unLoc rhs) <+> text "#-}") ]
+ nest 4 $
+ pprExpr (unLoc rhs) <+> text "#-}" ]
+ ppr (HsNoVect v)
+ = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ]
\end{code}
%************************************************************************
import Outputable
import FastString
-import SrcLoc ( Located(..) )
+import SrcLoc
import Data.Data
\end{code}
ideclAs :: Maybe ModuleName, -- ^ as Module
ideclHiding :: Maybe (Bool, [LIE name]) -- ^ (True => hiding, names)
} deriving (Data, Typeable)
+
+simpleImportDecl :: ModuleName -> ImportDecl name
+simpleImportDecl mn = ImportDecl {
+ ideclName = noLoc mn,
+ ideclPkgQual = Nothing,
+ ideclSource = False,
+ ideclQualified = False,
+ ideclAs = Nothing,
+ ideclHiding = Nothing
+ }
\end{code}
\begin{code}
-- others:
import IfaceSyn ( IfaceBinding )
import Outputable
-import SrcLoc ( Located(..) )
+import SrcLoc
import Module ( Module, ModuleName )
import FastString
hsTyVarKind, hsTyVarNameKind,
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
splitHsInstDeclTy, splitHsFunType,
+ splitHsAppTys, mkHsAppTys,
-- Type place holder
PostTcType, placeHolderType, PostTcKind, placeHolderKind,
\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
return (ModuleTarget a)
instance Binary IfaceVectInfo where
- put_ bh (IfaceVectInfo a1 a2 a3) = do
+ put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do
put_ bh a1
put_ bh a2
put_ bh a3
+ put_ bh a4
+ put_ bh a5
get bh = do
a1 <- get bh
a2 <- get bh
a3 <- get bh
- return (IfaceVectInfo a1 a2 a3)
+ a4 <- get bh
+ a5 <- get bh
+ return (IfaceVectInfo a1 a2 a3 a4 a5)
pprFix (occ,fix) = ppr fix <+> ppr occ
pprVectInfo :: IfaceVectInfo -> SDoc
-pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars
- , ifaceVectInfoTyCon = tycons
- , ifaceVectInfoTyConReuse = tyconsReuse
+pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars
+ , ifaceVectInfoTyCon = tycons
+ , ifaceVectInfoTyConReuse = tyconsReuse
+ , ifaceVectInfoScalarVars = scalarVars
+ , ifaceVectInfoScalarTyCons = scalarTyCons
}) =
vcat
[ ptext (sLit "vectorised variables:") <+> hsep (map ppr vars)
, ptext (sLit "vectorised tycons:") <+> hsep (map ppr tycons)
, ptext (sLit "vectorised reused tycons:") <+> hsep (map ppr tyconsReuse)
+ , ptext (sLit "scalar variables:") <+> hsep (map ppr scalarVars)
+ , ptext (sLit "scalar tycons:") <+> hsep (map ppr scalarTyCons)
]
instance Outputable Warnings where
module MkIface (
mkUsedNames,
mkDependencies,
- mkIface, -- Build a ModIface from a ModGuts,
- -- including computing version information
+ mkIface, -- Build a ModIface from a ModGuts,
+ -- including computing version information
mkIfaceTc,
- writeIfaceFile, -- Write the interface file
+ writeIfaceFile, -- Write the interface file
- checkOldIface, -- See if recompilation is required, by
- -- comparing version information
+ checkOldIface, -- See if recompilation is required, by
+ -- comparing version information
tyThingToIfaceDecl -- Converting things to their Iface equivalents
) where
\end{code}
- -----------------------------------------------
- Recompilation checking
- -----------------------------------------------
+ -----------------------------------------------
+ Recompilation checking
+ -----------------------------------------------
A complete description of how recompilation checking works can be
found in the wiki commentary:
import Finder
import DynFlags
import VarEnv
+import VarSet
import Var
import Name
import RdrName
ifFamInstTcName = ifaceTyConName . ifFamInstTyCon
- flattenVectInfo (VectInfo { vectInfoVar = vVar
- , vectInfoTyCon = vTyCon
+ flattenVectInfo (VectInfo { vectInfoVar = vVar
+ , vectInfoTyCon = vTyCon
+ , vectInfoScalarVars = vScalarVars
+ , vectInfoScalarTyCons = vScalarTyCons
}) =
- IfaceVectInfo {
- ifaceVectInfoVar = [ Var.varName v
- | (v, _) <- varEnvElts vVar],
- ifaceVectInfoTyCon = [ tyConName t
- | (t, t_v) <- nameEnvElts vTyCon
- , t /= t_v],
- ifaceVectInfoTyConReuse = [ tyConName t
- | (t, t_v) <- nameEnvElts vTyCon
- , t == t_v]
+ IfaceVectInfo
+ { ifaceVectInfoVar = [Var.varName v | (v, _ ) <- varEnvElts vVar]
+ , ifaceVectInfoTyCon = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t /= t_v]
+ , ifaceVectInfoTyConReuse = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t == t_v]
+ , ifaceVectInfoScalarVars = [Var.varName v | v <- varSetElems vScalarVars]
+ , ifaceVectInfoScalarTyCons = nameSetToList vScalarTyCons
}
-----------------------------
import TyCon
import DataCon
import TysWiredIn
-import TysPrim ( anyTyConOfKind )
-import BasicTypes ( Arity, nonRuleLoopBreaker )
+import TysPrim ( anyTyConOfKind )
+import BasicTypes ( Arity, nonRuleLoopBreaker )
import qualified Var
import VarEnv
+import VarSet
import Name
import NameEnv
-import OccurAnal ( occurAnalyseExpr )
-import Demand ( isBottomingSig )
+import NameSet
+import OccurAnal ( occurAnalyseExpr )
+import Demand ( isBottomingSig )
import Module
import UniqFM
import UniqSupply
%************************************************************************
-%* *
- Vectorisation information
-%* *
+%* *
+ Vectorisation information
+%* *
%************************************************************************
\begin{code}
tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
tcIfaceVectInfo mod typeEnv (IfaceVectInfo
- { ifaceVectInfoVar = vars
- , ifaceVectInfoTyCon = tycons
- , ifaceVectInfoTyConReuse = tyconsReuse
+ { ifaceVectInfoVar = vars
+ , ifaceVectInfoTyCon = tycons
+ , ifaceVectInfoTyConReuse = tyconsReuse
+ , ifaceVectInfoScalarVars = scalarVars
+ , ifaceVectInfoScalarTyCons = scalarTyCons
})
= do { vVars <- mapM vectVarMapping vars
; tyConRes1 <- mapM vectTyConMapping tycons
; tyConRes2 <- mapM vectTyConReuseMapping tyconsReuse
; let (vTyCons, vDataCons, vPAs, vIsos) = unzip4 (tyConRes1 ++ tyConRes2)
; return $ VectInfo
- { vectInfoVar = mkVarEnv vVars
- , vectInfoTyCon = mkNameEnv vTyCons
- , vectInfoDataCon = mkNameEnv (concat vDataCons)
- , vectInfoPADFun = mkNameEnv vPAs
- , vectInfoIso = mkNameEnv vIsos
+ { vectInfoVar = mkVarEnv vVars
+ , vectInfoTyCon = mkNameEnv vTyCons
+ , vectInfoDataCon = mkNameEnv (concat vDataCons)
+ , vectInfoPADFun = mkNameEnv vPAs
+ , vectInfoIso = mkNameEnv vIsos
+ , vectInfoScalarVars = mkVarSet (map lookupVar scalarVars)
+ , vectInfoScalarTyCons = mkNameSet scalarTyCons
}
}
where
\end{code}
%************************************************************************
-%* *
- Types
-%* *
+%* *
+ Types
+%* *
%************************************************************************
\begin{code}
-}
| Expr LlvmExpression
+ {- |
+ A nop LLVM statement. Useful as its often more efficient to use this
+ then to wrap LLvmStatement in a Just or [].
+ -}
+ | Nop
+
deriving (Show, Eq)
Return result -> ppReturn result
Expr expr -> ppLlvmExpression expr
Unreachable -> text "unreachable"
+ Nop -> empty
-- | Print out an LLVM expression.
import qualified Pretty as Prt
import UniqSupply
import Util
+import SysTools ( figureLlvmVersion )
+import Data.Maybe ( fromMaybe )
import System.IO
-- -----------------------------------------------------------------------------
in do
bufh <- newBufHandle h
Prt.bufLeftRender bufh $ pprLlvmHeader
-
- env' <- cmmDataLlvmGens dflags bufh env cdata []
+ ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
+
+ env' <- cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
cmmProcLlvmGens dflags bufh us env' cmm 1 []
bFlush bufh
LlvmCmmTop, LlvmBasicBlock,
LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
+ LlvmVersion, defaultLlvmVersion,
+
LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert,
- funLookup, funInsert,
+ funLookup, funInsert, getLlvmVer, setLlvmVer,
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
llvmPtrBits :: Int
llvmPtrBits = widthInBits $ typeWidth gcWord
+-- ----------------------------------------------------------------------------
+-- * Llvm Version
+--
+
+-- | LLVM Version Number
+type LlvmVersion = Int
+
+-- | The LLVM Version we assume if we don't know
+defaultLlvmVersion :: LlvmVersion
+defaultLlvmVersion = 28
-- ----------------------------------------------------------------------------
-- * Environment Handling
--
-type LlvmEnvMap = UniqFM LlvmType
-- two maps, one for functions and one for local vars.
-type LlvmEnv = (LlvmEnvMap, LlvmEnvMap)
+newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion)
+type LlvmEnvMap = UniqFM LlvmType
-- | Get initial Llvm environment.
initLlvmEnv :: LlvmEnv
-initLlvmEnv = (emptyUFM, emptyUFM)
+initLlvmEnv = LlvmEnv (emptyUFM, emptyUFM, defaultLlvmVersion)
-- | Clear variables from the environment.
clearVars :: LlvmEnv -> LlvmEnv
-clearVars (e1, _) = (e1, emptyUFM)
+clearVars (LlvmEnv (e1, _, n)) = LlvmEnv (e1, emptyUFM, n)
-- | Insert functions into the environment.
varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
-varInsert s t (e1, e2) = (e1, addToUFM e2 s t)
-funInsert s t (e1, e2) = (addToUFM e1 s t, e2)
+varInsert s t (LlvmEnv (e1, e2, n)) = LlvmEnv (e1, addToUFM e2 s t, n)
+funInsert s t (LlvmEnv (e1, e2, n)) = LlvmEnv (addToUFM e1 s t, e2, n)
-- | Lookup functions in the environment.
varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
-varLookup s (_, e2) = lookupUFM e2 s
-funLookup s (e1, _) = lookupUFM e1 s
+varLookup s (LlvmEnv (_, e2, _)) = lookupUFM e2 s
+funLookup s (LlvmEnv (e1, _, _)) = lookupUFM e1 s
+
+-- | Get the LLVM version we are generating code for
+getLlvmVer :: LlvmEnv -> LlvmVersion
+getLlvmVer (LlvmEnv (_, _, n)) = n
+-- | Set the LLVM version we are generating code for
+setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv
+setLlvmVer n (LlvmEnv (e1, e2, _)) = LlvmEnv (e1, e2, n)
-- ----------------------------------------------------------------------------
-- * Label handling
+{-# OPTIONS -fno-warn-type-defaults #-}
-- ----------------------------------------------------------------------------
-- | Handle conversion of CmmProc to LLVM code.
--
import qualified OldPprCmm as PprCmm
import OrdList
-import BasicTypes
import FastString
import ForeignCall
import Outputable hiding ( panic, pprPanic )
-- | 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
where
lmTrue :: LlvmVar
- lmTrue = LMLitVar $ LMIntLit (-1) i1
+ lmTrue = mkIntLit i1 (-1)
#endif
+-- Handle memcpy function specifically since llvm's intrinsic version takes
+-- some extra parameters.
+genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy ||
+ op == MO_Memset ||
+ op == MO_Memmove = do
+ let (isVolTy, isVolVal) = if getLlvmVer env >= 28
+ then ([i1], [mkIntLit i1 0]) else ([], [])
+ argTy | op == MO_Memset = [i8Ptr, i8, llvmWord, i32] ++ isVolTy
+ | otherwise = [i8Ptr, i8Ptr, llvmWord, i32] ++ isVolTy
+ funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
+ CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
+
+ (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
+ (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t
+ (argVars', stmts3) <- castVars $ zip argVars argTy
+
+ let arguments = argVars' ++ isVolVal
+ call = Expr $ Call StdCall fptr arguments []
+ stmts = stmts1 `appOL` stmts2 `appOL` stmts3
+ `appOL` trashStmts `snocOL` call
+ return (env2, stmts, top1 ++ top2)
+
-- Handle all other foreign calls and prim ops.
genCall env target res args ret = do
let ccTy = StdCall -- tail calls should be done through CmmJump
let retTy = ret_type res
let argTy = tysToParams $ map arg_type args
- let funTy name = LMFunction $ LlvmFunctionDecl name ExternallyVisible
- lmconv retTy FixedArgs argTy llvmFunAlign
+ let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
+ lmconv retTy FixedArgs argTy llvmFunAlign
- -- get parameter values
- (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
- -- get the return register
- let ret_reg ([CmmHinted reg hint]) = (reg, hint)
- ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
- ++ " 1, given " ++ show (length t) ++ "."
-
- -- deal with call types
- let getFunPtr :: CmmCallTarget -> UniqSM ExprData
- getFunPtr targ = case targ of
- CmmCallee (CmmLit (CmmLabel lbl)) _ -> do
- let name = strCLabel_llvm lbl
- case funLookup name env1 of
- Just ty'@(LMFunction sig) -> do
- -- Function in module in right form
- let fun = LMGlobalVar name ty' (funcLinkage sig)
- Nothing Nothing False
- return (env1, fun, nilOL, [])
-
- Just ty' -> do
- -- label in module but not function pointer, convert
- let fty@(LMFunction sig) = funTy name
- let fun = LMGlobalVar name (pLift ty') (funcLinkage sig)
- Nothing Nothing False
- (v1, s1) <- doExpr (pLift fty)
- $ Cast LM_Bitcast fun (pLift fty)
- return (env1, v1, unitOL s1, [])
-
- Nothing -> do
- -- label not in module, create external reference
- let fty@(LMFunction sig) = funTy name
- let fun = LMGlobalVar name fty (funcLinkage sig)
- Nothing Nothing False
- let top = CmmData Data [([],[fty])]
- let env' = funInsert name fty env1
- return (env', fun, nilOL, [top])
-
- CmmCallee expr _ -> do
- (env', v1, stmts, top) <- exprToVar env1 expr
- let fty = funTy $ fsLit "dynamic"
- let cast = case getVarType v1 of
- ty | isPointer ty -> LM_Bitcast
- ty | isInt ty -> LM_Inttoptr
-
- ty -> panic $ "genCall: Expr is of bad type for function"
- ++ " call! (" ++ show (ty) ++ ")"
-
- (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
- return (env', v2, stmts `snocOL` s1, top)
-
- CmmPrim mop -> do
- let name = cmmPrimOpFunctions mop
- let lbl = mkForeignLabel name Nothing
- ForeignLabelInExternalPackage IsFunction
- getFunPtr $ CmmCallee (CmmLit (CmmLabel lbl)) CCallConv
-
- (env2, fptr, stmts2, top2) <- getFunPtr target
+ (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
+ (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy target
let retStmt | ccTy == TailCall = unitOL $ Return Nothing
| ret == CmmNeverReturns = unitOL $ Unreachable
| otherwise = nilOL
- {- In LLVM we pass the STG registers around everywhere in function calls.
- So this means LLVM considers them live across the entire function, when
- in reality they usually aren't. For Caller save registers across C calls
- the saving and restoring of them is done by the Cmm code generator,
- using Cmm local vars. So to stop LLVM saving them as well (and saving
- all of them since it thinks they're always live, we trash them just
- before the call by assigning the 'undef' value to them. The ones we
- need are restored from the Cmm local var and the ones we don't need
- are fine to be trashed.
- -}
- let trashStmts = concatOL $ map trashReg activeStgRegs
- where trashReg r =
- let reg = lmGlobalRegVar r
- ty = (pLower . getVarType) reg
- trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
- in case callerSaves r of
- True -> trash
- False -> nilOL
-
let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts
-- make the actual call
_ -> do
(v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
+ -- get the return register
+ let ret_reg ([CmmHinted reg hint]) = (reg, hint)
+ ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
+ ++ " 1, given " ++ show (length t) ++ "."
let (creg, _) = ret_reg res
let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
let allStmts = stmts `snocOL` s1 `appOL` stmts3
`appOL` retStmt, top1 ++ top2 ++ top3)
+-- | Create a function pointer from a target.
+getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> CmmCallTarget
+ -> UniqSM ExprData
+getFunPtr env funTy targ = case targ of
+ CmmCallee (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm lbl
+
+ CmmCallee expr _ -> do
+ (env', v1, stmts, top) <- exprToVar env expr
+ let fty = funTy $ fsLit "dynamic"
+ cast = case getVarType v1 of
+ ty | isPointer ty -> LM_Bitcast
+ ty | isInt ty -> LM_Inttoptr
+
+ ty -> panic $ "genCall: Expr is of bad type for function"
+ ++ " call! (" ++ show (ty) ++ ")"
+
+ (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
+ return (env', v2, stmts `snocOL` s1, top)
+
+ CmmPrim mop -> litCase $ cmmPrimOpFunctions env mop
+
+ where
+ litCase name = do
+ case funLookup name env of
+ Just ty'@(LMFunction sig) -> do
+ -- Function in module in right form
+ let fun = LMGlobalVar name ty' (funcLinkage sig)
+ Nothing Nothing False
+ return (env, fun, nilOL, [])
+
+ Just ty' -> do
+ -- label in module but not function pointer, convert
+ let fty@(LMFunction sig) = funTy name
+ fun = LMGlobalVar name (pLift ty') (funcLinkage sig)
+ Nothing Nothing False
+ (v1, s1) <- doExpr (pLift fty)
+ $ Cast LM_Bitcast fun (pLift fty)
+ return (env, v1, unitOL s1, [])
+
+ Nothing -> do
+ -- label not in module, create external reference
+ let fty@(LMFunction sig) = funTy name
+ fun = LMGlobalVar name fty (funcLinkage sig)
+ Nothing Nothing False
+ top = [CmmData Data [([],[fty])]]
+ env' = funInsert name fty env
+ return (env', fun, nilOL, top)
+
+
-- | Conversion of call arguments.
arg_vars :: LlvmEnv
- -> HintedCmmActuals
+ -> [HintedCmmActual]
-> ([LlvmVar], LlvmStatements, [LlvmCmmTop])
-> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmTop])
= do (env', v1, stmts', top') <- exprToVar env e
arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
+
+-- | Cast a collection of LLVM variables to specific types.
+castVars :: [(LlvmVar, LlvmType)]
+ -> UniqSM ([LlvmVar], LlvmStatements)
+castVars vars = do
+ done <- mapM (uncurry castVar) vars
+ let (vars', stmts) = unzip done
+ return (vars', toOL stmts)
+
+-- | Cast an LLVM variable to a specific type, panicing if it can't be done.
+castVar :: LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement)
+castVar v t | getVarType v == t
+ = return (v, Nop)
+
+ | otherwise
+ = let op = case (getVarType v, t) of
+ (LMInt n, LMInt m)
+ -> if n < m then LM_Sext else LM_Trunc
+ (vt, _) | isFloat vt && isFloat t
+ -> if llvmWidthInBits vt < llvmWidthInBits t
+ then LM_Fpext else LM_Fptrunc
+ (vt, _) | isInt vt && isFloat t -> LM_Sitofp
+ (vt, _) | isFloat vt && isInt t -> LM_Fptosi
+ (vt, _) | isInt vt && isPointer t -> LM_Inttoptr
+ (vt, _) | isPointer vt && isInt t -> LM_Ptrtoint
+ (vt, _) | isPointer vt && isPointer t -> LM_Bitcast
+
+ (vt, _) -> panic $ "castVars: Can't cast this type ("
+ ++ show vt ++ ") to (" ++ show t ++ ")"
+ in doExpr t $ Cast op v t
+
+
-- | Decide what C function to use to implement a CallishMachOp
-cmmPrimOpFunctions :: CallishMachOp -> FastString
-cmmPrimOpFunctions mop
+cmmPrimOpFunctions :: LlvmEnv -> CallishMachOp -> LMString
+cmmPrimOpFunctions env mop
= case mop of
MO_F32_Exp -> fsLit "expf"
MO_F32_Log -> fsLit "logf"
MO_F64_Cosh -> fsLit "cosh"
MO_F64_Tanh -> fsLit "tanh"
+ MO_Memcpy -> fsLit $ "llvm.memcpy." ++ intrinTy1
+ MO_Memmove -> fsLit $ "llvm.memmove." ++ intrinTy1
+ MO_Memset -> fsLit $ "llvm.memset." ++ intrinTy2
+
a -> panic $ "cmmPrimOpFunctions: Unknown callish op! (" ++ show a ++ ")"
+ where
+ intrinTy1 = (if getLlvmVer env >= 28
+ then "p0i8.p0i8." else "") ++ show llvmWord
+ intrinTy2 = (if getLlvmVer env >= 28
+ then "p0i8." else "") ++ show llvmWord
+
-- | Tail function calls
genJump :: LlvmEnv -> CmmExpr -> UniqSM StmtData
(env', vc, stmts, top) <- exprToVar env cond
let ty = getVarType vc
- let pairs = [ (ix, id) | (ix,Just id) <- zip ([0..]::[Integer]) maybe_ids ]
+ let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ]
let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs
-- out of range is undefied, so lets just branch to first label
let (_, defLbl) = head labels
genMachOp env _ op [x] = case op of
MO_Not w ->
- let all1 = mkIntLit (widthToLlvmInt w) (-1::Int)
+ let all1 = mkIntLit (widthToLlvmInt w) (-1)
in negate (widthToLlvmInt w) all1 LM_MO_Xor
MO_S_Neg w ->
- let all0 = mkIntLit (widthToLlvmInt w) (0::Int)
+ let all0 = mkIntLit (widthToLlvmInt w) 0
in negate (widthToLlvmInt w) all0 LM_MO_Sub
MO_F_Neg w ->
return (vars, concatOL stmts)
+-- | A serries of statements to trash all the STG registers.
+--
+-- In LLVM we pass the STG registers around everywhere in function calls.
+-- So this means LLVM considers them live across the entire function, when
+-- in reality they usually aren't. For Caller save registers across C calls
+-- the saving and restoring of them is done by the Cmm code generator,
+-- using Cmm local vars. So to stop LLVM saving them as well (and saving
+-- all of them since it thinks they're always live, we trash them just
+-- before the call by assigning the 'undef' value to them. The ones we
+-- need are restored from the Cmm local var and the ones we don't need
+-- are fine to be trashed.
+trashStmts :: LlvmStatements
+trashStmts = concatOL $ map trashReg activeStgRegs
+ where trashReg r =
+ let reg = lmGlobalRegVar r
+ ty = (pLower . getVarType) reg
+ trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
+ in case callerSaves r of
+ True -> trash
+ False -> nilOL
+
+
-- | Get a function pointer to the CLabel specified.
--
-- This is for Haskell functions, function type is assumed, so doesn't work
import UniqSupply ( mkSplitUniqSupply )
-#ifdef JAVA
-import JavaGen ( javaGen )
-import qualified PrintJava
-import OccurAnal ( occurAnalyseBinds )
-#endif
-
import Finder ( mkStubPaths )
import PprC ( writeCs )
import CmmLint ( cmmLint )
HscAsm -> outputAsm dflags filenm flat_abstractC;
HscC -> outputC dflags filenm flat_abstractC pkg_deps;
HscLlvm -> outputLlvm dflags filenm flat_abstractC;
- HscJava ->
-#ifdef JAVA
- outputJava dflags filenm mod_name tycons core_binds;
-#else
- panic "Java support not compiled into this ghc";
-#endif
HscNothing -> panic "codeOutput: HscNothing"
}
; return stubs_exist
%************************************************************************
%* *
-\subsection{Java}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef JAVA
-outputJava dflags filenm mod tycons core_binds
- = doOutput filenm (\ f -> printForUser f alwaysQualify pp_java)
- -- User style printing for now to keep indentation
- where
- occ_anal_binds = occurAnalyseBinds core_binds
- -- Make sure we have up to date dead-var information
- java_code = javaGen mod [{- Should be imports-}] tycons occ_anal_binds
- pp_java = PrintJava.compilationUnit java_code
-#endif
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Foreign import/export}
%* *
%************************************************************************
HscLlvm -> LlvmOpt
HscNothing -> StopLn
HscInterpreted -> StopLn
- _other -> StopLn
= HscC -- ^ Generate C code.
| HscAsm -- ^ Generate assembly using the native code generator.
| HscLlvm -- ^ Generate assembly using the llvm code generator.
- | HscJava -- ^ Generate Java bytecode.
| HscInterpreted -- ^ Generate bytecode. (Requires 'LinkInMemory')
| HscNothing -- ^ Don't generate any code. See notes above.
deriving (Eq, Show)
showHscTargetFlag HscC = "-fvia-c"
showHscTargetFlag HscAsm = "-fasm"
showHscTargetFlag HscLlvm = "-fllvm"
-showHscTargetFlag HscJava = panic "No flag for HscJava"
showHscTargetFlag HscInterpreted = "-fbyte-code"
showHscTargetFlag HscNothing = "-fno-code"
= return ()
dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO ()
-dumpIfSet_dyn_or dflags flags hdr doc
- | or [dopt flag dflags | flag <- flags]
- || verbosity dflags >= 4
- = printDump (mkDumpDoc hdr doc)
- | otherwise = return ()
+dumpIfSet_dyn_or _ [] _ _ = return ()
+dumpIfSet_dyn_or dflags (flag : flags) hdr doc
+ = if dopt flag dflags || verbosity dflags >= 4
+ then dumpSDoc dflags flag hdr doc
+ else dumpIfSet_dyn_or dflags flags hdr doc
mkDumpDoc :: String -> SDoc -> SDoc
mkDumpDoc hdr doc
compareFixity,
-- ** Source locations
- SrcLoc, pprDefnLoc,
- mkSrcLoc, isGoodSrcLoc, noSrcLoc,
+ SrcLoc(..), RealSrcLoc, pprDefnLoc,
+ mkSrcLoc, noSrcLoc,
srcLocFile, srcLocLine, srcLocCol,
- SrcSpan,
+ SrcSpan(..), RealSrcSpan,
mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
srcSpanStart, srcSpanEnd,
srcSpanFile,
srcSpanStartCol, srcSpanEndCol,
-- ** Located
- Located(..),
+ GenLocated(..), Located,
-- *** Constructing Located
noLoc, mkGeneralLocated,
#ifdef GHCI
getPackageModuleInfo hsc_env mdl = do
mb_avails <- hscGetModuleExports hsc_env mdl
+ -- This is the only use of hscGetModuleExports. Perhaps we could use
+ -- hscRnImportDecls instead, but that does a lot more than we need
+ -- (building instance environment, checking family instance consistency
+ -- etc.).
case mb_avails of
Nothing -> return Nothing
Just avails -> do
getTokenStream :: GhcMonad m => Module -> m [Located Token]
getTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
- let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
+ let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return ts
PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
getRichTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
- let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
+ let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return $ addSourceToTokens startLoc source ts
PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
-- | Given a source location and a StringBuffer corresponding to this
-- location, return a rich token stream with the source associated to the
-- tokens.
-addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token]
+addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
-> [(Located Token, String)]
addSourceToTokens _ _ [] = []
addSourceToTokens loc buf (t@(L span _) : ts)
- | not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts
- | otherwise = (t,str) : addSourceToTokens newLoc newBuf ts
- where
- (newLoc, newBuf, str) = go "" loc buf
- start = srcSpanStart span
- end = srcSpanEnd span
- go acc loc buf | loc < start = go acc nLoc nBuf
- | start <= loc && loc < end = go (ch:acc) nLoc nBuf
- | otherwise = (loc, buf, reverse acc)
- where (ch, nBuf) = nextChar buf
- nLoc = advanceSrcLoc loc ch
+ = case span of
+ UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
+ RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts
+ where
+ (newLoc, newBuf, str) = go "" loc buf
+ start = realSrcSpanStart s
+ end = realSrcSpanEnd s
+ go acc loc buf | loc < start = go acc nLoc nBuf
+ | start <= loc && loc < end = go (ch:acc) nLoc nBuf
+ | otherwise = (loc, buf, reverse acc)
+ where (ch, nBuf) = nextChar buf
+ nLoc = advanceSrcLoc loc ch
-- | Take a rich token stream such as produced from 'getRichTokenStream' and
-- insignificant whitespace.)
showRichTokenStream :: [(Located Token, String)] -> String
showRichTokenStream ts = go startLoc ts ""
- where sourceFile = srcSpanFile (getLoc . fst . head $ ts)
- startLoc = mkSrcLoc sourceFile 1 1
+ where sourceFile = getFile $ map (getLoc . fst) ts
+ getFile [] = panic "showRichTokenStream: No source file found"
+ getFile (UnhelpfulSpan _ : xs) = getFile xs
+ getFile (RealSrcSpan s : _) = srcSpanFile s
+ startLoc = mkRealSrcLoc sourceFile 1 1
go _ [] = id
go loc ((L span _, str):ts)
- | not (isGoodSrcSpan span) = go loc ts
- | locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++)
- . (str ++)
- . go tokEnd ts
- | otherwise = ((replicate (tokLine - locLine) '\n') ++)
- . ((replicate tokCol ' ') ++)
- . (str ++)
- . go tokEnd ts
- where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
- (tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span)
- tokEnd = srcSpanEnd span
+ = case span of
+ UnhelpfulSpan _ -> go loc ts
+ RealSrcSpan s
+ | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)
+ . (str ++)
+ . go tokEnd ts
+ | otherwise -> ((replicate (tokLine - locLine) '\n') ++)
+ . ((replicate tokCol ' ') ++)
+ . (str ++)
+ . go tokEnd ts
+ where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
+ (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s)
+ tokEnd = realSrcSpanEnd s
-- -----------------------------------------------------------------------------
-- Interactive evaluation
parser str dflags filename =
let
- loc = mkSrcLoc (mkFastString filename) 1 1
+ loc = mkRealSrcLoc (mkFastString filename) 1 1
buf = stringToStringBuffer str
in
case unP Parser.parseModule (mkPState dflags buf loc) of
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)
-> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
-- ^ The source imports, normal imports, and the module name.
getImports dflags buf filename source_filename = do
- let loc = mkSrcLoc (mkFastString filename) 1 1
+ let loc = mkRealSrcLoc (mkFastString filename) 1 1
case unP parseHeader (mkPState dflags buf loc) of
PFailed span err -> parseError span err
POk pst rdr_module -> do
buf <- hGetStringBufferBlock handle blockSize
unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
where
- loc = mkSrcLoc (mkFastString filename) 1 1
+ loc = mkRealSrcLoc (mkFastString filename) 1 1
lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
lazyLexBuf handle state eof = do
_other -> do rest <- lazyLexBuf handle state' eof
return (t : rest)
_ | not eof -> getMore handle state
- | otherwise -> return [L (last_loc state) ITeof]
+ | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof]
-- parser assumes an ITeof sentinel at the end
getMore :: Handle -> PState -> IO [Located Token]
getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
getToks dflags filename buf = lexAll (pragState dflags buf loc)
where
- loc = mkSrcLoc (mkFastString filename) 1 1
+ loc = mkRealSrcLoc (mkFastString filename) 1 1
lexAll state = case unP (lexer return) state of
POk _ t@(L _ ITeof) -> [t]
POk state' t -> t : lexAll state'
- _ -> [L (last_loc state) ITeof]
+ _ -> [L (RealSrcSpan (last_loc state)) ITeof]
-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
import PprCmm ( pprCmms )
import CmmParse ( parseCmmFile )
import CmmBuildInfoTables
-import CmmCPS
+import CmmPipeline
import CmmInfo
import OptimizationFuel ( initOptFuelState )
import CmmCvt
Just b -> return b
Nothing -> liftIO $ hGetStringBuffer src_filename
- let loc = mkSrcLoc (mkFastString src_filename) 1 1
+ let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
case unP parseModule (mkPState dflags buf loc) of
PFailed span err ->
It's the task of the compilation proper to compile Haskell, hs-boot and
-core files to either byte-code, hard-code (C, asm, Java, ect) or to
+core files to either byte-code, hard-code (C, asm, LLVM, ect) or to
nothing at all (the module is still parsed and type-checked. This
feature is mostly used by IDE's and the likes).
Compilation can happen in either 'one-shot', 'batch', 'nothing',
-------------------- 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]
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
liftIO $ showPass dflags "Parser"
let buf = stringToStringBuffer str
- loc = mkSrcLoc (fsLit source) linenumber 1
+ loc = mkRealSrcLoc (fsLit source) linenumber 1
case unP parser (mkPState dflags buf loc) of
#include "HsVersions.h"
#ifdef GHCI
-import ByteCodeAsm ( CompiledByteCode )
+import ByteCodeAsm ( CompiledByteCode )
import {-# SOURCE #-} InteractiveEval ( Resume )
#endif
import RdrName
import Name
import NameEnv
-import NameSet
+import NameSet
import Module
-import InstEnv ( InstEnv, Instance )
-import FamInstEnv ( FamInstEnv, FamInst )
-import Rules ( RuleBase )
-import CoreSyn ( CoreBind )
+import InstEnv ( InstEnv, Instance )
+import FamInstEnv ( FamInstEnv, FamInst )
+import Rules ( RuleBase )
+import CoreSyn ( CoreBind )
import VarEnv
+import VarSet
import Var
import Id
-import Type
+import Type
import Annotations
import Class ( Class, classAllSelIds, classATs, classTyCon )
import Maybes ( orElse, expectJust, catMaybes )
import Outputable
import BreakArray
-import SrcLoc ( SrcSpan, Located(..) )
+import SrcLoc
import UniqFM ( lookupUFM, eltsUFM, emptyUFM )
import UniqSupply ( UniqSupply )
import FastString
%************************************************************************
\begin{code}
--- | Interactive context, recording information relevant to GHCi
+-- | Interactive context, recording information about the state of the
+-- context in which statements are executed in a GHC session.
+--
data InteractiveContext
= InteractiveContext {
- ic_toplev_scope :: [Module] -- ^ The context includes the "top-level" scope of
- -- these modules
-
- , ic_exports :: [(Module, Maybe (ImportDecl RdrName))] -- ^ The context includes just the exported parts of these
- -- modules
-
- , ic_rn_gbl_env :: GlobalRdrEnv -- ^ The contexts' cached 'GlobalRdrEnv', built from
- -- 'ic_toplev_scope' and 'ic_exports'
-
- , ic_tmp_ids :: [Id] -- ^ Names bound during interaction with the user.
- -- Later Ids shadow earlier ones with the same OccName
- -- Expressions are typed with these Ids in the envt
- -- For runtime-debugging, these Ids may have free
- -- TcTyVars of RuntimUnkSkol flavour, but no free TyVars
- -- (because the typechecker doesn't expect that)
+ -- These two fields are only stored here so that the client
+ -- can retrieve them with GHC.getContext. GHC itself doesn't
+ -- use them, but it does reset them to empty sometimes (such
+ -- as before a GHC.load). The context is set with GHC.setContext.
+ ic_toplev_scope :: [Module],
+ -- ^ The context includes the "top-level" scope of
+ -- these modules
+ ic_imports :: [ImportDecl RdrName],
+ -- ^ The context is extended with these import declarations
+
+ ic_rn_gbl_env :: GlobalRdrEnv,
+ -- ^ The contexts' cached 'GlobalRdrEnv', built by
+ -- 'InteractiveEval.setContext'
+
+ ic_tmp_ids :: [Id],
+ -- ^ Names bound during interaction with the user. Later
+ -- Ids shadow earlier ones with the same OccName
+ -- Expressions are typed with these Ids in the envt For
+ -- runtime-debugging, these Ids may have free TcTyVars of
+ -- RuntimUnkSkol flavour, but no free TyVars (because the
+ -- typechecker doesn't expect that)
#ifdef GHCI
- , ic_resume :: [Resume] -- ^ The stack of breakpoint contexts
+ ic_resume :: [Resume],
+ -- ^ The stack of breakpoint contexts
#endif
- , ic_cwd :: Maybe FilePath -- virtual CWD of the program
+ ic_cwd :: Maybe FilePath
+ -- virtual CWD of the program
}
emptyInteractiveContext :: InteractiveContext
emptyInteractiveContext
= InteractiveContext { ic_toplev_scope = [],
- ic_exports = [],
+ ic_imports = [],
ic_rn_gbl_env = emptyGlobalRdrEnv,
ic_tmp_ids = []
#ifdef GHCI
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Vectorisation Support}
-%* *
+%* *
%************************************************************************
The following information is generated and consumed by the vectorisation
on just the OccName easily in a Core pass.
\begin{code}
--- | Vectorisation information for 'ModGuts', 'ModDetails' and 'ExternalPackageState'.
+-- |Vectorisation information for 'ModGuts', 'ModDetails' and 'ExternalPackageState'; see also
+-- documentation at 'Vectorise.Env.GlobalEnv'.
data VectInfo
- = VectInfo {
- vectInfoVar :: VarEnv (Var , Var ), -- ^ @(f, f_v)@ keyed on @f@
- vectInfoTyCon :: NameEnv (TyCon , TyCon), -- ^ @(T, T_v)@ keyed on @T@
- vectInfoDataCon :: NameEnv (DataCon, DataCon), -- ^ @(C, C_v)@ keyed on @C@
- vectInfoPADFun :: NameEnv (TyCon , Var), -- ^ @(T_v, paT)@ keyed on @T_v@
- vectInfoIso :: NameEnv (TyCon , Var) -- ^ @(T, isoT)@ keyed on @T@
+ = VectInfo
+ { vectInfoVar :: VarEnv (Var , Var ) -- ^ @(f, f_v)@ keyed on @f@
+ , vectInfoTyCon :: NameEnv (TyCon , TyCon) -- ^ @(T, T_v)@ keyed on @T@
+ , vectInfoDataCon :: NameEnv (DataCon, DataCon) -- ^ @(C, C_v)@ keyed on @C@
+ , vectInfoPADFun :: NameEnv (TyCon , Var) -- ^ @(T_v, paT)@ keyed on @T_v@
+ , vectInfoIso :: NameEnv (TyCon , Var) -- ^ @(T, isoT)@ keyed on @T@
+ , vectInfoScalarVars :: VarSet -- ^ set of purely scalar variables
+ , vectInfoScalarTyCons :: NameSet -- ^ set of scalar type constructors
}
--- | Vectorisation information for 'ModIface': a slightly less low-level view
+-- |Vectorisation information for 'ModIface'; i.e, the vectorisation information propagated
+-- across module boundaries.
+--
data IfaceVectInfo
- = IfaceVectInfo {
- ifaceVectInfoVar :: [Name],
- -- ^ All variables in here have a vectorised variant
- ifaceVectInfoTyCon :: [Name],
- -- ^ All 'TyCon's in here have a vectorised variant;
- -- the name of the vectorised variant and those of its
- -- data constructors are determined by 'OccName.mkVectTyConOcc'
- -- and 'OccName.mkVectDataConOcc'; the names of
- -- the isomorphisms are determined by 'OccName.mkVectIsoOcc'
- ifaceVectInfoTyConReuse :: [Name]
- -- ^ The vectorised form of all the 'TyCon's in here coincides with
- -- the unconverted form; the name of the isomorphisms is determined
- -- by 'OccName.mkVectIsoOcc'
+ = IfaceVectInfo
+ { ifaceVectInfoVar :: [Name] -- ^ All variables in here have a vectorised variant
+ , ifaceVectInfoTyCon :: [Name] -- ^ All 'TyCon's in here have a vectorised variant;
+ -- the name of the vectorised variant and those of its
+ -- data constructors are determined by
+ -- 'OccName.mkVectTyConOcc' and
+ -- 'OccName.mkVectDataConOcc'; the names of the
+ -- isomorphisms are determined by 'OccName.mkVectIsoOcc'
+ , ifaceVectInfoTyConReuse :: [Name] -- ^ The vectorised form of all the 'TyCon's in here
+ -- coincides with the unconverted form; the name of the
+ -- isomorphisms is determined by 'OccName.mkVectIsoOcc'
+ , ifaceVectInfoScalarVars :: [Name] -- iface version of 'vectInfoScalarVar'
+ , ifaceVectInfoScalarTyCons :: [Name] -- iface version of 'vectInfoScalarTyCon'
}
noVectInfo :: VectInfo
-noVectInfo = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyNameEnv
+noVectInfo
+ = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyVarSet
+ emptyNameSet
plusVectInfo :: VectInfo -> VectInfo -> VectInfo
plusVectInfo vi1 vi2 =
- VectInfo (vectInfoVar vi1 `plusVarEnv` vectInfoVar vi2)
- (vectInfoTyCon vi1 `plusNameEnv` vectInfoTyCon vi2)
- (vectInfoDataCon vi1 `plusNameEnv` vectInfoDataCon vi2)
- (vectInfoPADFun vi1 `plusNameEnv` vectInfoPADFun vi2)
- (vectInfoIso vi1 `plusNameEnv` vectInfoIso vi2)
+ VectInfo (vectInfoVar vi1 `plusVarEnv` vectInfoVar vi2)
+ (vectInfoTyCon vi1 `plusNameEnv` vectInfoTyCon vi2)
+ (vectInfoDataCon vi1 `plusNameEnv` vectInfoDataCon vi2)
+ (vectInfoPADFun vi1 `plusNameEnv` vectInfoPADFun vi2)
+ (vectInfoIso vi1 `plusNameEnv` vectInfoIso vi2)
+ (vectInfoScalarVars vi1 `unionVarSet` vectInfoScalarVars vi2)
+ (vectInfoScalarTyCons vi1 `unionNameSets` vectInfoScalarTyCons vi2)
concatVectInfo :: [VectInfo] -> VectInfo
concatVectInfo = foldr plusVectInfo noVectInfo
noIfaceVectInfo :: IfaceVectInfo
-noIfaceVectInfo = IfaceVectInfo [] [] []
+noIfaceVectInfo = IfaceVectInfo [] [] [] [] []
\end{code}
%************************************************************************
import GhcMonad
import HscMain
-import HsSyn (ImportDecl)
+import HsSyn
import HscTypes
-import TcRnDriver
-import RnNames (gresFromAvails)
+import RnNames (gresFromAvails)
import InstEnv
import Type
import TcType hiding( typeKind )
import SrcLoc
import BreakArray
import RtClosureInspect
-import BasicTypes
import Outputable
import FastString
import MonadUtils
import System.Directory
import Data.Dynamic
-import Data.List (find, partition)
+import Data.List (find)
import Control.Monad
import Foreign hiding (unsafePerformIO)
import Foreign.C
-- module. They always shadow anything in scope in the current context.
setContext :: GhcMonad m =>
[Module] -- ^ entire top level scope of these modules
- -> [(Module, Maybe (ImportDecl RdrName))] -- ^ exports of these modules
+ -> [ImportDecl RdrName] -- ^ these import declarations
-> m ()
-setContext toplev_mods other_mods = do
+setContext toplev_mods import_decls = do
hsc_env <- getSession
let old_ic = hsc_IC hsc_env
hpt = hsc_HPT hsc_env
- (decls,mods) = partition (isJust . snd) other_mods -- time for tracing
- export_mods = map fst mods
- imprt_decls = map noLoc (catMaybes (map snd decls))
+ imprt_decls = map noLoc import_decls
--
- export_env <- liftIO $ mkExportEnv hsc_env export_mods
import_env <-
if null imprt_decls then return emptyGlobalRdrEnv else do
let this_mod | null toplev_mods = pRELUDE
| otherwise = head toplev_mods
liftIO $ hscRnImportDecls hsc_env this_mod imprt_decls
+
toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
- let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs
+
+ let all_env = foldr plusGlobalRdrEnv import_env toplev_envs
modifySession $ \_ ->
hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
- ic_exports = other_mods,
- ic_rn_gbl_env = all_env }}
-
--- Make a GlobalRdrEnv based on the exports of the modules only.
-mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
-mkExportEnv hsc_env mods
- = do { stuff <- mapM (getModuleExports hsc_env) mods
- ; let (_msgs, mb_name_sets) = unzip stuff
- envs = [ availsToGlobalRdrEnv (moduleName mod) avails
- | (Just avails, mod) <- zip mb_name_sets mods ]
- ; return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs }
+ ic_imports = import_decls,
+ ic_rn_gbl_env = all_env }}
availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
availsToGlobalRdrEnv mod_name avails
-- | Get the interactive evaluation context, consisting of a pair of the
-- set of modules from which we take the full top-level scope, and the set
-- of modules from which we take just the exports respectively.
-getContext :: GhcMonad m => m ([Module],[(Module, Maybe (ImportDecl RdrName))])
+getContext :: GhcMonad m => m ([Module],[ImportDecl RdrName])
getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
- return (ic_toplev_scope ic, ic_exports ic)
+ return (ic_toplev_scope ic, ic_imports ic)
-- | Returns @True@ if the specified module is interpreted, and hence has
-- its full top-level scope available.
dynCompileExpr :: GhcMonad m => String -> m Dynamic
dynCompileExpr expr = do
- (full,exports) <- getContext
- setContext full $
- (mkModule
- (stringToPackageId "base") (mkModuleName "Data.Dynamic")
- ,Nothing):exports
let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
Just (ids, hvals) <- withSession $ \hsc_env ->
liftIO $ hscStmt hsc_env stmt
- setContext full exports
vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
case (ids,vals) of
(_:[], v:[]) -> return v
where
hide pkg = pkg{ exposed = False }
+-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
munge_urls = map munge_url
munge_path p
- | Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
- | Just p' <- stripVarPrefix "$topdir" sp = top_dir </> p'
- | otherwise = p
- where
- sp = splitPath p
+ | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
+ | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
+ | otherwise = p
munge_url p
- | Just p' <- stripVarPrefix "${pkgrooturl}" sp = toUrlPath pkgroot p'
- | Just p' <- stripVarPrefix "$httptopdir" sp = toUrlPath top_dir p'
- | otherwise = p
- where
- sp = splitPath p
+ | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
+ | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
+ | otherwise = p
toUrlPath r p = "file:///"
-- URLs always use posix style '/' separators:
- ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
-
- stripVarPrefix var (root:path')
- | Just [sep] <- stripPrefix var root
- , isPathSeparator sep
- = Just (joinPath path')
-
- stripVarPrefix _ _ = Nothing
+ ++ FilePath.Posix.joinPath
+ (r : -- We need to drop a leading "/" or "\\"
+ -- if there is one:
+ dropWhile (all isPathSeparator)
+ (FilePath.splitDirectories p))
+
+ -- We could drop the separator here, and then use </> above. However,
+ -- by leaving it in and using ++ we keep the same path separator
+ -- rather than letting FilePath change it to use \ as the separator
+ stripVarPrefix var path = case stripPrefix var path of
+ Just [] -> Just []
+ Just cs@(c : _) | isPathSeparator c -> Just cs
+ _ -> Nothing
-- -----------------------------------------------------------------------------
runWindres,
runLlvmOpt,
runLlvmLlc,
+ figureLlvmVersion,
readElfSection,
touch, -- String -> String -> IO ()
mb_env <- getGccEnv args1
runSomethingFiltered dflags id "Assembler" p args1 mb_env
+-- | Run the LLVM Optimiser
runLlvmOpt :: DynFlags -> [Option] -> IO ()
runLlvmOpt dflags args = do
let (p,args0) = pgm_lo dflags
runSomething dflags "LLVM Optimiser" p (args0++args)
+-- | Run the LLVM Compiler
runLlvmLlc :: DynFlags -> [Option] -> IO ()
runLlvmLlc dflags args = do
let (p,args0) = pgm_lc dflags
runSomething dflags "LLVM Compiler" p (args0++args)
+-- | Figure out which version of LLVM we are running this session
+figureLlvmVersion :: DynFlags -> IO (Maybe Int)
+figureLlvmVersion dflags = do
+ let (pgm,opts) = pgm_lc dflags
+ args = filter notNull (map showOpt opts)
+ -- we grab the args even though they should be useless just in
+ -- case the user is using a customised 'llc' that requires some
+ -- of the options they've specified. llc doesn't care what other
+ -- options are specified when '-version' is used.
+ args' = args ++ ["-version"]
+ ver <- catchIO (do
+ (pin, pout, perr, _) <- runInteractiveProcess pgm args'
+ Nothing Nothing
+ {- > llc -version
+ Low Level Virtual Machine (http://llvm.org/):
+ llvm version 2.8 (Ubuntu 2.8-0Ubuntu1)
+ ...
+ -}
+ hSetBinaryMode pout False
+ _ <- hGetLine pout
+ vline <- hGetLine pout
+ v <- case filter isDigit vline of
+ [] -> fail "no digits!"
+ [x] -> fail $ "only 1 digit! (" ++ show x ++ ")"
+ (x:y:_) -> return ((read [x,y]) :: Int)
+ hClose pin
+ hClose pout
+ hClose perr
+ return $ Just v
+ )
+ (\err -> do
+ putMsg dflags $ text $ "Warning: " ++ show err
+ return Nothing)
+ return ver
+
+
runLink :: DynFlags -> [Option] -> IO ()
runLink dflags args = do
let (p,args0) = pgm_l dflags
\begin{code}
tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo
-tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars
- , vectInfoPADFun = pas
- , vectInfoIso = isos })
- = info { vectInfoVar = tidy_vars
- , vectInfoPADFun = tidy_pas
- , vectInfoIso = tidy_isos }
+tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars
+ , vectInfoPADFun = pas
+ , vectInfoIso = isos
+ , vectInfoScalarVars = scalarVars
+ })
+ = info { vectInfoVar = tidy_vars
+ , vectInfoPADFun = tidy_pas
+ , vectInfoIso = tidy_isos
+ , vectInfoScalarVars = tidy_scalarVars
+ }
where
tidy_vars = mkVarEnv
$ map tidy_var_mapping
tidy_var_mapping (from, to) = (from', (from', lookup_var to))
where from' = lookup_var from
tidy_snd_var (x, var) = (x, lookup_var var)
+
+ tidy_scalarVars = mkVarSet
+ $ map lookup_var
+ $ varSetElems scalarVars
lookup_var var = lookupWithDefaultVarEnv var_env var var
\end{code}
-- Top-level of the native codegen
data NcgImpl instr jumpDest = NcgImpl {
- cmmTopCodeGen :: DynFlags -> RawCmmTop -> NatM [NatCmmTop instr],
+ cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop instr],
generateJumpTableForInstr :: instr -> Maybe (NatCmmTop instr),
getJumpDestBlockId :: jumpDest -> Maybe BlockId,
canShortcut :: instr -> Maybe jumpDest,
}
ArchPPC_64 ->
panic "nativeCodeGen: No NCG for PPC 64"
+ ArchUnknown ->
+ panic "nativeCodeGen: No NCG for unknown arch"
nativeCodeGen' :: (Instruction instr, Outputable instr)
=> DynFlags
= {-# SCC "RegAlloc" #-}
initUs usLive
$ liftM unzip
- $ mapUs Linear.regAlloc withLiveness
+ $ mapUs (Linear.regAlloc dflags) withLiveness
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
genMachCode
:: DynFlags
- -> (DynFlags -> RawCmmTop -> NatM [NatCmmTop instr])
+ -> (RawCmmTop -> NatM [NatCmmTop instr])
-> RawCmmTop
-> UniqSM
( [NatCmmTop instr]
genMachCode dflags cmmTopCodeGen cmm_top
= do { initial_us <- getUs
; let initial_st = mkNatM_State initial_us 0 dflags
- (new_tops, final_st) = initNat initial_st (cmmTopCodeGen dflags cmm_top)
+ (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
final_delta = natm_delta final_st
final_imports = natm_imports final_st
; if final_delta == 0
#define COMMA ,
-- - - - - - - - - - - - - - - - - - - - - -
-#if alpha_TARGET_ARCH
-# define IF_ARCH_alpha(x,y) x
-#else
-# define IF_ARCH_alpha(x,y) y
-#endif
--- - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
# define IF_ARCH_i386(x,y) x
#else
# define IF_ARCH_i386(x,y) y
#endif
-- - - - - - - - - - - - - - - - - - - - - -
-#if x86_64_TARGET_ARCH
-# define IF_ARCH_x86_64(x,y) x
-#else
-# define IF_ARCH_x86_64(x,y) y
-#endif
--- - - - - - - - - - - - - - - - - - - - - -
-#if freebsd_TARGET_OS
-# define IF_OS_freebsd(x,y) x
-#else
-# define IF_OS_freebsd(x,y) y
-#endif
--- - - - - - - - - - - - - - - - - - - - - -
-#if dragonfly_TARGET_OS
-# define IF_OS_dragonfly(x,y) x
-#else
-# define IF_OS_dragonfly(x,y) y
-#endif
--- - - - - - - - - - - - - - - - - - - - - -
-#if netbsd_TARGET_OS
-# define IF_OS_netbsd(x,y) x
-#else
-# define IF_OS_netbsd(x,y) y
-#endif
--- - - - - - - - - - - - - - - - - - - - - -
-#if openbsd_TARGET_OS
-# define IF_OS_openbsd(x,y) x
-#else
-# define IF_OS_openbsd(x,y) y
-#endif
--- - - - - - - - - - - - - - - - - - - - - -
#if linux_TARGET_OS
# define IF_OS_linux(x,y) x
#else
# define IF_OS_linux(x,y) y
#endif
-- - - - - - - - - - - - - - - - - - - - - -
-#if linuxaout_TARGET_OS
-# define IF_OS_linuxaout(x,y) x
-#else
-# define IF_OS_linuxaout(x,y) y
-#endif
--- - - - - - - - - - - - - - - - - - - - - -
-#if bsdi_TARGET_OS
-# define IF_OS_bsdi(x,y) x
-#else
-# define IF_OS_bsdi(x,y) y
-#endif
--- - - - - - - - - - - - - - - - - - - - - -
-#if cygwin32_TARGET_OS
-# define IF_OS_cygwin32(x,y) x
-#else
-# define IF_OS_cygwin32(x,y) y
-#endif
--- - - - - - - - - - - - - - - - - - - - - -
-#if sparc_TARGET_ARCH
-# define IF_ARCH_sparc(x,y) x
-#else
-# define IF_ARCH_sparc(x,y) y
-#endif
--- - - - - - - - - - - - - - - - - - - - - -
-#if sunos4_TARGET_OS
-# define IF_OS_sunos4(x,y) x
-#else
-# define IF_OS_sunos4(x,y) y
-#endif
--- - - - - - - - - - - - - - - - - - - - - -
--- NB: this will catch i386-*-solaris2, too
-#if solaris2_TARGET_OS
-# define IF_OS_solaris2(x,y) x
-#else
-# define IF_OS_solaris2(x,y) y
-#endif
--- - - - - - - - - - - - - - - - - - - - - -
-#if powerpc_TARGET_ARCH
-# define IF_ARCH_powerpc(x,y) x
-#else
-# define IF_ARCH_powerpc(x,y) y
-#endif
--- - - - - - - - - - - - - - - - - - - - - -
#if darwin_TARGET_OS
# define IF_OS_darwin(x,y) x
#else
-{-# OPTIONS -w #-}
-----------------------------------------------------------------------------
--
-- (c) the #if blah_TARGET_ARCH} things, the
-- structure should not be too overwhelming.
-module PPC.CodeGen (
- cmmTopCodeGen,
- generateJumpTableForInstr,
- InstrBlock
-)
+module PPC.CodeGen (
+ cmmTopCodeGen,
+ generateJumpTableForInstr,
+ InstrBlock
+)
where
import PPC.Instr
import PPC.Cond
import PPC.Regs
-import PPC.RegInfo
import NCGMonad
import Instruction
import PIC
-- Our intermediate code:
import BlockId
-import PprCmm ( pprExpr )
+import PprCmm ( pprExpr )
import OldCmm
import CLabel
-- The rest:
-import StaticFlags ( opt_PIC )
+import StaticFlags ( opt_PIC )
import OrdList
-import qualified Outputable as O
import Outputable
import Unique
import DynFlags
-import Control.Monad ( mapAndUnzipM )
+import Control.Monad ( mapAndUnzipM )
import Data.Bits
-import Data.Int
import Data.Word
-#if darwin_TARGET_OS || linux_TARGET_OS
import BasicTypes
import FastString
-#endif
-- -----------------------------------------------------------------------------
-- Top-level of the instruction selector
-- left-to-right traversal (pre-order?) yields the insns in the correct
-- order.
-cmmTopCodeGen
- :: DynFlags
- -> RawCmmTop
- -> NatM [NatCmmTop Instr]
+cmmTopCodeGen
+ :: RawCmmTop
+ -> NatM [NatCmmTop Instr]
-cmmTopCodeGen dflags (CmmProc info lab (ListGraph blocks)) = do
+cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
picBaseMb <- getPicBaseMaybeNat
+ dflags <- getDynFlagsNat
let proc = CmmProc info lab (ListGraph $ concat nat_blocks)
tops = proc : concat statics
os = platformOS $ targetPlatform dflags
case picBaseMb of
Just picBase -> initializePicBase_ppc ArchPPC os picBase tops
Nothing -> return tops
-
-cmmTopCodeGen dflags (CmmData sec dat) = do
+
+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
-- 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)
return (concatOL instrss)
stmtToInstrs :: CmmStmt -> NatM InstrBlock
-stmtToInstrs stmt = case stmt of
- CmmNop -> return nilOL
+stmtToInstrs stmt = do
+ dflags <- getDynFlagsNat
+ 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
+ | target32Bit (targetPlatform dflags) &&
+ 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
+ | target32Bit (targetPlatform dflags) &&
+ 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 params -> genJump arg
- CmmReturn params ->
+ CmmJump arg _ -> genJump arg
+ CmmReturn _ ->
panic "stmtToInstrs: return statement should have been cps'd away"
--------------------------------------------------------------------------------
-- | '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
-- | 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
-}
--- | 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.
---
-is32BitInteger :: Integer -> Bool
-is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000
- where i64 = fromIntegral i :: Int64
-
-
-- | Convert a BlockId to some CmmStatic data
jumpTableEntry :: Maybe BlockId -> CmmStatic
jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth)
where width = typeWidth (cmmRegType reg)
mangleIndexTree _
- = panic "PPC.CodeGen.mangleIndexTree: no match"
+ = panic "PPC.CodeGen.mangleIndexTree: no match"
-- -----------------------------------------------------------------------------
-- Code gen for 64-bit arithmetic on 32-bit platforms
by applying getHiVRegFromLo to it.
-}
-data ChildCode64 -- a.k.a "Register64"
- = ChildCode64
- InstrBlock -- code
- Reg -- 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
+data ChildCode64 -- a.k.a "Register64"
+ = ChildCode64
+ InstrBlock -- code
+ Reg -- 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
-- | 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)
getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)
getI64Amodes addrTree = do
assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_I64Code addrTree valueTree = do
(hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
- ChildCode64 vcode rlo <- iselExpr64 valueTree
- let
- rhi = getHiVRegFromLo rlo
+ ChildCode64 vcode rlo <- iselExpr64 valueTree
+ let
+ rhi = getHiVRegFromLo rlo
- -- Big-endian store
- mov_hi = ST II32 rhi hi_addr
- mov_lo = ST II32 rlo lo_addr
- -- in
- return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
+ -- Big-endian store
+ mov_hi = ST II32 rhi hi_addr
+ mov_lo = ST II32 rlo lo_addr
+ -- in
+ return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock
-assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
+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
vcode `snocOL` mov_lo `snocOL` mov_hi
)
-assignReg_I64Code lvalue valueTree
+assignReg_I64Code _ _
= panic "assignReg_I64Code(powerpc): invalid lvalue"
(rlo, rhi) <- getNewRegPairNat II32
let mov_hi = LD II32 rhi hi_addr
mov_lo = LD II32 rlo lo_addr
- return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
+ return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
rlo
iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty
iselExpr64 (CmmLit (CmmInt i _)) = do
(rlo,rhi) <- getNewRegPairNat II32
let
- half0 = fromIntegral (fromIntegral i :: Word16)
- half1 = fromIntegral ((fromIntegral i `shiftR` 16) :: Word16)
- half2 = fromIntegral ((fromIntegral i `shiftR` 32) :: Word16)
- half3 = fromIntegral ((fromIntegral i `shiftR` 48) :: Word16)
-
- code = toOL [
- LIS rlo (ImmInt half1),
- OR rlo rlo (RIImm $ ImmInt half0),
- LIS rhi (ImmInt half3),
- OR rlo rlo (RIImm $ ImmInt half2)
- ]
+ half0 = fromIntegral (fromIntegral i :: Word16)
+ half1 = fromIntegral ((fromIntegral i `shiftR` 16) :: Word16)
+ half2 = fromIntegral ((fromIntegral i `shiftR` 32) :: Word16)
+ half3 = fromIntegral ((fromIntegral i `shiftR` 48) :: Word16)
+
+ code = toOL [
+ LIS rlo (ImmInt half1),
+ OR rlo rlo (RIImm $ ImmInt half0),
+ LIS rhi (ImmInt half3),
+ OR rlo rlo (RIImm $ ImmInt half2)
+ ]
-- in
return (ChildCode64 code rlo)
ChildCode64 code2 r2lo <- iselExpr64 e2
(rlo,rhi) <- getNewRegPairNat II32
let
- r1hi = getHiVRegFromLo r1lo
- r2hi = getHiVRegFromLo r2lo
- code = code1 `appOL`
- code2 `appOL`
- toOL [ ADDC rlo r1lo r2lo,
- ADDE rhi r1hi r2hi ]
+ r1hi = getHiVRegFromLo r1lo
+ r2hi = getHiVRegFromLo r2lo
+ code = code1 `appOL`
+ code2 `appOL`
+ toOL [ ADDC rlo r1lo r2lo,
+ ADDE rhi r1hi r2hi ]
-- in
return (ChildCode64 code rlo)
getRegister :: CmmExpr -> NatM Register
+getRegister e = do dflags <- getDynFlagsNat
+ getRegister' dflags e
-getRegister (CmmReg (CmmGlobal PicBaseReg))
+getRegister' :: DynFlags -> CmmExpr -> NatM Register
+
+getRegister' _ (CmmReg (CmmGlobal PicBaseReg))
= do
reg <- getPicBaseNat archWordSize
return (Fixed archWordSize reg nilOL)
-getRegister (CmmReg reg)
- = return (Fixed (cmmTypeSize (cmmRegType reg))
- (getRegisterReg reg) nilOL)
-
-getRegister tree@(CmmRegOff _ _)
- = getRegister (mangleIndexTree tree)
+getRegister' _ (CmmReg reg)
+ = return (Fixed (cmmTypeSize (cmmRegType reg))
+ (getRegisterReg reg) nilOL)
+getRegister' dflags tree@(CmmRegOff _ _)
+ = getRegister' dflags (mangleIndexTree tree)
-#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' dflags (CmmMachOp (MO_UU_Conv W64 W32)
+ [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
+ | target32Bit (targetPlatform dflags) = 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' dflags (CmmMachOp (MO_SS_Conv W64 W32)
+ [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
+ | target32Bit (targetPlatform dflags) = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 (getHiVRegFromLo rlo) code
-getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do
+getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) [x])
+ | target32Bit (targetPlatform dflags) = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 rlo code
-getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do
+getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x])
+ | target32Bit (targetPlatform dflags) = do
ChildCode64 code rlo <- iselExpr64 x
- return $ Fixed II32 rlo code
-
-#endif
-
+ return $ Fixed II32 rlo code
-getRegister (CmmLoad mem pk)
+getRegister' _ (CmmLoad mem pk)
| not (isWord64 pk)
= do
Amode addr addr_code <- getAmode mem
where size = cmmTypeSize pk
-- catch simple cases of zero- or sign-extended load
-getRegister (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do
+getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode mem
return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))
-- Note: there is no Load Byte Arithmetic instruction, so no signed case here
-getRegister (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do
+getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode mem
return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr))
-getRegister (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do
+getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode mem
return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr))
-getRegister (CmmMachOp mop [x]) -- unary MachOps
+getRegister' dflags (CmmMachOp mop [x]) -- unary MachOps
= case mop of
MO_Not rep -> triv_ucode_int rep NOT
MO_UU_Conv W32 to -> conversionNop (intSize to) x
MO_UU_Conv W16 W8 -> conversionNop II8 x
MO_UU_Conv W8 to -> trivialCode to False AND x (CmmLit (CmmInt 255 W32))
- MO_UU_Conv W16 to -> trivialCode to False AND x (CmmLit (CmmInt 65535 W32))
- _ -> panic "PPC.CodeGen.getRegister: no match"
+ MO_UU_Conv W16 to -> trivialCode to False AND x (CmmLit (CmmInt 65535 W32))
+ _ -> panic "PPC.CodeGen.getRegister: no match"
where
- triv_ucode_int width instr = trivialUCode (intSize width) instr x
- triv_ucode_float width instr = trivialUCode (floatSize width) instr x
+ triv_ucode_int width instr = trivialUCode (intSize width) instr x
+ triv_ucode_float width instr = trivialUCode (floatSize width) instr x
conversionNop new_size expr
- = do e_code <- getRegister expr
+ = do e_code <- getRegister' dflags expr
return (swizzleRegisterRep e_code new_size)
-getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps
+getRegister' _ (CmmMachOp mop [x, y]) -- dyadic PrimOps
= case mop of
- MO_F_Eq w -> condFltReg EQQ x y
- MO_F_Ne w -> condFltReg NE x y
- MO_F_Gt w -> condFltReg GTT x y
- MO_F_Ge w -> condFltReg GE x y
- MO_F_Lt w -> condFltReg LTT x y
- MO_F_Le w -> condFltReg LE x y
+ MO_F_Eq _ -> condFltReg EQQ x y
+ MO_F_Ne _ -> condFltReg NE x y
+ MO_F_Gt _ -> condFltReg GTT x y
+ MO_F_Ge _ -> condFltReg GE x y
+ MO_F_Lt _ -> condFltReg LTT x y
+ MO_F_Le _ -> condFltReg LE x y
MO_Eq rep -> condIntReg EQQ (extendUExpr rep x) (extendUExpr rep y)
MO_Ne rep -> condIntReg NE (extendUExpr rep x) (extendUExpr rep y)
MO_F_Sub w -> triv_float w FSUB
MO_F_Mul w -> triv_float w FMUL
MO_F_Quot w -> triv_float w FDIV
-
+
-- optimize addition with 32-bit immediate
-- (needed for PIC)
MO_Add W32 ->
MO_Mul rep -> trivialCode rep True MULLW x y
MO_S_MulMayOflo W32 -> trivialCodeNoImm' II32 MULLW_MayOflo x y
-
- MO_S_MulMayOflo rep -> panic "S_MulMayOflo (rep /= II32): not implemented"
- MO_U_MulMayOflo rep -> panic "U_MulMayOflo: not implemented"
+
+ MO_S_MulMayOflo _ -> panic "S_MulMayOflo (rep /= II32): not implemented"
+ MO_U_MulMayOflo _ -> panic "U_MulMayOflo: not implemented"
MO_S_Quot rep -> trivialCodeNoImm' (intSize rep) DIVW (extendSExpr rep x) (extendSExpr rep y)
MO_U_Quot rep -> trivialCodeNoImm' (intSize rep) DIVWU (extendUExpr rep x) (extendUExpr rep y)
-
+
MO_S_Rem rep -> remainderCode rep DIVW (extendSExpr rep x) (extendSExpr rep y)
MO_U_Rem rep -> remainderCode rep DIVWU (extendUExpr rep x) (extendUExpr rep y)
-
+
MO_And rep -> trivialCode rep False AND x y
MO_Or rep -> trivialCode rep False OR x y
MO_Xor rep -> trivialCode rep False XOR x y
MO_Shl rep -> trivialCode rep False SLW x y
MO_S_Shr rep -> trivialCode rep False SRAW (extendSExpr rep x) y
MO_U_Shr rep -> trivialCode rep False SRW (extendUExpr rep x) y
- _ -> panic "PPC.CodeGen.getRegister: no match"
+ _ -> panic "PPC.CodeGen.getRegister: no match"
where
triv_float :: Width -> (Size -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float width instr = trivialCodeNoImm (floatSize width) instr x y
-getRegister (CmmLit (CmmInt i rep))
+getRegister' _ (CmmLit (CmmInt i rep))
| Just imm <- makeImmediate rep True i
= let
- code dst = unitOL (LI dst imm)
+ code dst = unitOL (LI dst imm)
in
- return (Any (intSize rep) code)
+ return (Any (intSize rep) code)
-getRegister (CmmLit (CmmFloat f frep)) = do
+getRegister' _ (CmmLit (CmmFloat f frep)) = do
lbl <- getNewLabelNat
dflags <- getDynFlagsNat
dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
Amode addr addr_code <- getAmode dynRef
let size = floatSize frep
- code dst =
- LDATA ReadOnlyData [CmmDataLabel lbl,
- CmmStaticLit (CmmFloat f frep)]
+ code dst =
+ LDATA ReadOnlyData [CmmDataLabel lbl,
+ CmmStaticLit (CmmFloat f frep)]
`consOL` (addr_code `snocOL` LD size dst addr)
return (Any size code)
-getRegister (CmmLit lit)
+getRegister' _ (CmmLit lit)
= let rep = cmmLitType lit
imm = litToImm lit
code dst = toOL [
]
in return (Any (cmmTypeSize rep) code)
-getRegister other = pprPanic "getRegister(ppc)" (pprExpr other)
-
+getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other)
+
-- extend?Rep: wrap integer expression of type rep
-- in a conversion to II32
+extendSExpr :: Width -> CmmExpr -> CmmExpr
extendSExpr W32 x = x
extendSExpr rep x = CmmMachOp (MO_SS_Conv rep W32) [x]
+
+extendUExpr :: Width -> CmmExpr -> CmmExpr
extendUExpr W32 x = x
extendUExpr rep x = CmmMachOp (MO_UU_Conv rep W32) [x]
-- -----------------------------------------------------------------------------
-- The 'Amode' type: 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,
let imm = litToImm lit
code = unitOL (LIS tmp (HA imm))
return (Amode (AddrRegImm tmp (LO imm)) code)
-
+
getAmode (CmmMachOp (MO_Add W32) [x, y])
= do
(regX, codeX) <- getSomeReg x
(regY, codeY) <- getSomeReg y
return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
-
+
getAmode other
= do
(reg, code) <- getSomeReg other
-- The 'CondCode' type: Condition codes passed up the tree.
-data CondCode
- = CondCode Bool Cond InstrBlock
+data CondCode
+ = CondCode Bool Cond InstrBlock
-- Set up a condition code for a conditional branch.
MO_U_Lt rep -> condIntCode LU (extendUExpr rep x) (extendUExpr rep y)
MO_U_Le rep -> condIntCode LEU (extendUExpr rep x) (extendUExpr rep y)
- other -> pprPanic "getCondCode(powerpc)" (pprMachOp mop)
+ _ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop)
-getCondCode other = panic "getCondCode(2)(powerpc)"
+getCondCode _ = panic "getCondCode(2)(powerpc)"
= do
(src1, code) <- getSomeReg x
let
- code' = code `snocOL`
+ code' = code `snocOL`
(if condUnsigned cond then CMPL else CMP) II32 src1 (RIImm src2)
return (CondCode False cond code')
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
let
- code' = code1 `appOL` code2 `snocOL`
- (if condUnsigned cond then CMPL else CMP) II32 src1 (RIReg src2)
+ code' = code1 `appOL` code2 `snocOL`
+ (if condUnsigned cond then CMPL else CMP) II32 src1 (RIReg src2)
return (CondCode False cond code')
condFltCode cond x y = do
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
let
- code' = code1 `appOL` code2 `snocOL` FCMP src1 src2
- code'' = case cond of -- twiddle CR to handle unordered case
+ code' = code1 `appOL` code2 `snocOL` FCMP src1 src2
+ code'' = case cond of -- twiddle CR to handle unordered case
GE -> code' `snocOL` CRNOR ltbit eqbit gtbit
- LE -> code' `snocOL` CRNOR gtbit eqbit ltbit
- _ -> code'
+ LE -> code' `snocOL` CRNOR gtbit eqbit ltbit
+ _ -> code'
where
ltbit = 0 ; eqbit = 2 ; gtbit = 1
return (CondCode True cond code'')
genCondJump
- :: BlockId -- the branch target
+ :: BlockId -- the branch target
-> CmmExpr -- the condition on which to branch
-> NatM InstrBlock
-- 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)
+genCCall :: CmmCallTarget -- function to call
+ -> [HintedCmmFormal] -- where to put the result
+ -> [HintedCmmActual] -- arguments (of mixed type)
+ -> NatM InstrBlock
+genCCall target dest_regs argsAndHints
+ = do dflags <- getDynFlagsNat
+ case platformOS (targetPlatform dflags) of
+ OSLinux -> genCCall' GCPLinux target dest_regs argsAndHints
+ OSDarwin -> genCCall' GCPDarwin target dest_regs argsAndHints
+ OSSolaris2 -> panic "PPC.CodeGen.genCCall: not defined for this os"
+ OSMinGW32 -> panic "PPC.CodeGen.genCCall: not defined for this os"
+ OSFreeBSD -> panic "PPC.CodeGen.genCCall: not defined for this os"
+ OSOpenBSD -> panic "PPC.CodeGen.genCCall: not defined for this os"
+ OSUnknown -> panic "PPC.CodeGen.genCCall: not defined for this os"
+
+data GenCCallPlatform = GCPLinux | GCPDarwin
+
+genCCall'
+ :: GenCCallPlatform
+ -> CmmCallTarget -- function to call
+ -> [HintedCmmFormal] -- where to put the result
+ -> [HintedCmmActual] -- arguments (of mixed type)
-> NatM InstrBlock
-
-#if darwin_TARGET_OS || linux_TARGET_OS
{-
The PowerPC calling convention for Darwin/Mac OS X
is described in Apple's document
"Inside Mac OS X - Mach-O Runtime Architecture".
-
+
PowerPC Linux uses the System V Release 4 Calling Convention
for PowerPC. It is described in the
"System V Application Binary Interface PowerPC Processor Supplement".
Both conventions are similar:
Parameters may be passed in general-purpose registers starting at r3, in
- floating point registers starting at f1, or on the stack.
-
+ floating point registers starting at f1, or on the stack.
+
But there are substantial differences:
* The number of registers used for parameter passing and the exact set of
nonvolatile registers differs (see MachRegs.lhs).
4-byte aligned like everything else on Darwin.
* The SysV spec claims that FF32 is represented as FF64 on the stack. GCC on
PowerPC Linux does not agree, so neither do we.
-
+
According to both conventions, The parameter area should be part of the
caller's stack frame, allocated in the caller's prologue code (large enough
to hold the parameter lists for all called routines). The NCG already
-}
-genCCall (CmmPrim MO_WriteBarrier) _ _
+genCCall' _ (CmmPrim MO_WriteBarrier) _ _
= return $ unitOL LWSYNC
-genCCall target dest_regs argsAndHints
+genCCall' gcp target dest_regs argsAndHints
= ASSERT (not $ any (`elem` [II8,II16]) $ map cmmTypeSize argReps)
-- we rely on argument promotion in the codeGen
do
allArgRegs allFPArgRegs
initialStackOffset
(toOL []) []
-
+
(labelOrExpr, reduceToFF32) <- case target of
- CmmCallee (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False)
- CmmCallee expr conv -> return (Right expr, False)
- CmmPrim mop -> outOfLineFloatOp mop
-
+ CmmCallee (CmmLit (CmmLabel lbl)) _ -> return (Left lbl, False)
+ CmmCallee expr _ -> return (Right expr, False)
+ CmmPrim mop -> outOfLineMachOp mop
+
let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode
codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32
case labelOrExpr of
Left lbl -> do
- return ( codeBefore
+ return ( codeBefore
`snocOL` BL lbl usedRegs
- `appOL` codeAfter)
+ `appOL` codeAfter)
Right dyn -> do
- (dynReg, dynCode) <- getSomeReg dyn
- return ( dynCode
- `snocOL` MTCTR dynReg
- `appOL` codeBefore
+ (dynReg, dynCode) <- getSomeReg dyn
+ return ( dynCode
+ `snocOL` MTCTR dynReg
+ `appOL` codeBefore
`snocOL` BCTRL usedRegs
- `appOL` codeAfter)
+ `appOL` codeAfter)
where
-#if darwin_TARGET_OS
- initialStackOffset = 24
- -- size of linkage area + size of arguments, in bytes
- stackDelta _finalStack = roundTo 16 $ (24 +) $ max 32 $ sum $
- map (widthInBytes . typeWidth) argReps
-#elif linux_TARGET_OS
- initialStackOffset = 8
- stackDelta finalStack = roundTo 16 finalStack
-#endif
- args = map hintlessCmm argsAndHints
- argReps = map cmmExprType args
-
- roundTo a x | x `mod` a == 0 = x
- | otherwise = x + a - (x `mod` a)
+ initialStackOffset = case gcp of
+ GCPDarwin -> 24
+ GCPLinux -> 8
+ -- size of linkage area + size of arguments, in bytes
+ stackDelta finalStack = case gcp of
+ GCPDarwin ->
+ roundTo 16 $ (24 +) $ max 32 $ sum $
+ map (widthInBytes . typeWidth) argReps
+ GCPLinux -> roundTo 16 finalStack
+
+ -- need to remove alignment information
+ argsAndHints' | (CmmPrim mop) <- target,
+ (mop == MO_Memcpy ||
+ mop == MO_Memset ||
+ mop == MO_Memmove)
+ = init argsAndHints
+
+ | otherwise
+ = argsAndHints
+
+ args = map hintlessCmm argsAndHints'
+ argReps = map cmmExprType args
+
+ roundTo a x | x `mod` a == 0 = x
+ | otherwise = x + a - (x `mod` a)
move_sp_down finalStack
| delta > 64 =
toOL [STU II32 sp (AddrRegImm sp (ImmInt (-delta))),
- DELTA (-delta)]
- | otherwise = nilOL
- where delta = stackDelta finalStack
- move_sp_up finalStack
- | delta > 64 =
+ DELTA (-delta)]
+ | otherwise = nilOL
+ where delta = stackDelta finalStack
+ move_sp_up finalStack
+ | delta > 64 =
toOL [ADD sp sp (RIImm (ImmInt delta)),
DELTA 0]
- | otherwise = nilOL
- where delta = stackDelta finalStack
-
+ | otherwise = nilOL
+ where delta = stackDelta finalStack
+
passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed)
passArguments ((arg,arg_ty):args) gprs fprs stackOffset
ChildCode64 code vr_lo <- iselExpr64 arg
let vr_hi = getHiVRegFromLo vr_lo
-#if darwin_TARGET_OS
- passArguments args
- (drop 2 gprs)
- fprs
- (stackOffset+8)
- (accumCode `appOL` code
- `snocOL` storeWord vr_hi gprs stackOffset
- `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
- ((take 2 gprs) ++ accumUsed)
- where
- storeWord vr (gpr:_) offset = MR gpr vr
- storeWord vr [] offset = ST II32 vr (AddrRegImm sp (ImmInt offset))
-
-#elif linux_TARGET_OS
- let stackOffset' = roundTo 8 stackOffset
- stackCode = accumCode `appOL` code
- `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset'))
- `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4)))
- regCode hireg loreg =
- accumCode `appOL` code
- `snocOL` MR hireg vr_hi
- `snocOL` MR loreg vr_lo
-
- case gprs of
- hireg : loreg : regs | even (length gprs) ->
- passArguments args regs fprs stackOffset
- (regCode hireg loreg) (hireg : loreg : accumUsed)
- _skipped : hireg : loreg : regs ->
- passArguments args regs fprs stackOffset
- (regCode hireg loreg) (hireg : loreg : accumUsed)
- _ -> -- only one or no regs left
- passArguments args [] fprs (stackOffset'+8)
- stackCode accumUsed
-#endif
-
+ case gcp of
+ GCPDarwin ->
+ do let storeWord vr (gpr:_) _ = MR gpr vr
+ storeWord vr [] offset
+ = ST II32 vr (AddrRegImm sp (ImmInt offset))
+ passArguments args
+ (drop 2 gprs)
+ fprs
+ (stackOffset+8)
+ (accumCode `appOL` code
+ `snocOL` storeWord vr_hi gprs stackOffset
+ `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
+ ((take 2 gprs) ++ accumUsed)
+ GCPLinux ->
+ do let stackOffset' = roundTo 8 stackOffset
+ stackCode = accumCode `appOL` code
+ `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset'))
+ `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4)))
+ regCode hireg loreg =
+ accumCode `appOL` code
+ `snocOL` MR hireg vr_hi
+ `snocOL` MR loreg vr_lo
+
+ case gprs of
+ hireg : loreg : regs | even (length gprs) ->
+ passArguments args regs fprs stackOffset
+ (regCode hireg loreg) (hireg : loreg : accumUsed)
+ _skipped : hireg : loreg : regs ->
+ passArguments args regs fprs stackOffset
+ (regCode hireg loreg) (hireg : loreg : accumUsed)
+ _ -> -- only one or no regs left
+ passArguments args [] fprs (stackOffset'+8)
+ stackCode accumUsed
+
passArguments ((arg,rep):args) gprs fprs stackOffset accumCode accumUsed
| reg : _ <- regs = do
register <- getRegister arg
let code = case register of
Fixed _ freg fcode -> fcode `snocOL` MR reg freg
Any _ acode -> acode reg
+ stackOffsetRes = case gcp of
+ -- The Darwin ABI requires that we reserve
+ -- stack slots for register parameters
+ GCPDarwin -> stackOffset + stackBytes
+ -- ... the SysV ABI doesn't.
+ GCPLinux -> stackOffset
passArguments args
(drop nGprs gprs)
(drop nFprs fprs)
-#if darwin_TARGET_OS
- -- The Darwin ABI requires that we reserve stack slots for register parameters
- (stackOffset + stackBytes)
-#elif linux_TARGET_OS
- -- ... the SysV ABI doesn't.
- stackOffset
-#endif
+ stackOffsetRes
(accumCode `appOL` code)
(reg : accumUsed)
| otherwise = do
(accumCode `appOL` code `snocOL` ST (cmmTypeSize rep) vr stackSlot)
accumUsed
where
-#if darwin_TARGET_OS
- -- stackOffset is at least 4-byte aligned
- -- The Darwin ABI is happy with that.
- stackOffset' = stackOffset
-#else
- -- ... the SysV ABI requires 8-byte alignment for doubles.
- stackOffset' | isFloatType rep && typeWidth rep == W64 =
- roundTo 8 stackOffset
- | otherwise = stackOffset
-#endif
+ stackOffset' = case gcp of
+ GCPDarwin ->
+ -- stackOffset is at least 4-byte aligned
+ -- The Darwin ABI is happy with that.
+ stackOffset
+ GCPLinux
+ -- ... the SysV ABI requires 8-byte
+ -- alignment for doubles.
+ | isFloatType rep && typeWidth rep == W64 ->
+ roundTo 8 stackOffset
+ | otherwise ->
+ stackOffset
stackSlot = AddrRegImm sp (ImmInt stackOffset')
- (nGprs, nFprs, stackBytes, regs) = case cmmTypeSize rep of
- II32 -> (1, 0, 4, gprs)
-#if darwin_TARGET_OS
- -- The Darwin ABI requires that we skip a corresponding number of GPRs when
- -- we use the FPRs.
- FF32 -> (1, 1, 4, fprs)
- FF64 -> (2, 1, 8, fprs)
-#elif linux_TARGET_OS
- -- ... the SysV ABI doesn't.
- FF32 -> (0, 1, 4, fprs)
- FF64 -> (0, 1, 8, fprs)
-#endif
-
+ (nGprs, nFprs, stackBytes, regs)
+ = case gcp of
+ GCPDarwin ->
+ case cmmTypeSize rep of
+ II32 -> (1, 0, 4, gprs)
+ -- The Darwin ABI requires that we skip a
+ -- corresponding number of GPRs when we use
+ -- the FPRs.
+ FF32 -> (1, 1, 4, fprs)
+ FF64 -> (2, 1, 8, fprs)
+ II8 -> panic "genCCall' passArguments II8"
+ II16 -> panic "genCCall' passArguments II16"
+ II64 -> panic "genCCall' passArguments II64"
+ FF80 -> panic "genCCall' passArguments FF80"
+ GCPLinux ->
+ case cmmTypeSize rep of
+ II32 -> (1, 0, 4, gprs)
+ -- ... the SysV ABI doesn't.
+ FF32 -> (0, 1, 4, fprs)
+ FF64 -> (0, 1, 8, fprs)
+ II8 -> panic "genCCall' passArguments II8"
+ II16 -> panic "genCCall' passArguments II16"
+ II64 -> panic "genCCall' passArguments II64"
+ FF80 -> panic "genCCall' passArguments FF80"
+
moveResult reduceToFF32 =
case dest_regs of
[] -> nilOL
| otherwise -> unitOL (MR r_dest r3)
where rep = cmmRegType (CmmLocal dest)
r_dest = getRegisterReg (CmmLocal dest)
-
- outOfLineFloatOp mop =
+ _ -> panic "genCCall' moveResult: Bad dest_regs"
+
+ outOfLineMachOp mop =
do
dflags <- getDynFlagsNat
mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $
MO_F32_Exp -> (fsLit "exp", True)
MO_F32_Log -> (fsLit "log", True)
MO_F32_Sqrt -> (fsLit "sqrt", True)
-
+
MO_F32_Sin -> (fsLit "sin", True)
MO_F32_Cos -> (fsLit "cos", True)
MO_F32_Tan -> (fsLit "tan", True)
-
+
MO_F32_Asin -> (fsLit "asin", True)
MO_F32_Acos -> (fsLit "acos", True)
MO_F32_Atan -> (fsLit "atan", True)
-
+
MO_F32_Sinh -> (fsLit "sinh", True)
MO_F32_Cosh -> (fsLit "cosh", True)
MO_F32_Tanh -> (fsLit "tanh", True)
MO_F32_Pwr -> (fsLit "pow", True)
-
+
MO_F64_Exp -> (fsLit "exp", False)
MO_F64_Log -> (fsLit "log", False)
MO_F64_Sqrt -> (fsLit "sqrt", False)
-
+
MO_F64_Sin -> (fsLit "sin", False)
MO_F64_Cos -> (fsLit "cos", False)
MO_F64_Tan -> (fsLit "tan", False)
-
+
MO_F64_Asin -> (fsLit "asin", False)
MO_F64_Acos -> (fsLit "acos", False)
MO_F64_Atan -> (fsLit "atan", False)
-
+
MO_F64_Sinh -> (fsLit "sinh", False)
MO_F64_Cosh -> (fsLit "cosh", False)
MO_F64_Tanh -> (fsLit "tanh", False)
MO_F64_Pwr -> (fsLit "pow", False)
+
+ MO_Memcpy -> (fsLit "memcpy", False)
+ MO_Memset -> (fsLit "memset", False)
+ MO_Memmove -> (fsLit "memmove", False)
+
other -> pprPanic "genCCall(ppc): unknown callish op"
(pprCallishMachOp other)
-#else /* darwin_TARGET_OS || linux_TARGET_OS */
-genCCall = panic "PPC.CodeGen.genCCall: not defined for this os"
-#endif
-
-- -----------------------------------------------------------------------------
-- Generating a table-branch
genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock
-genSwitch expr ids
+genSwitch expr ids
| opt_PIC
= do
(reg,e_code) <- getSomeReg expr
-- 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.
MFCR dst,
RLWINM dst dst (bit + 1) 31 31
]
-
+
negate_code | do_negate = unitOL (CRNOR bit bit bit)
| otherwise = nilOL
-
+
(bit, do_negate) = case cond of
LTT -> (0, False)
LE -> (1, True)
EQQ -> (2, False)
GE -> (0, True)
GTT -> (1, False)
-
+
NE -> (2, True)
-
+
LU -> (0, False)
LEU -> (1, True)
GEU -> (0, True)
GU -> (1, False)
- _ -> panic "PPC.CodeGen.codeReg: no match"
-
+ _ -> panic "PPC.CodeGen.codeReg: no match"
+
return (Any II32 code)
-
+
condIntReg cond x y = condReg (condIntCode cond x y)
condFltReg cond x y = condReg (condFltCode cond x y)
* The only expression for which getRegister returns Fixed is (CmmReg reg).
* If getRegister returns Any, then the code it generates may modify only:
- (a) fresh temporaries
- (b) the destination register
+ (a) fresh temporaries
+ (b) the destination register
It may *not* modify global registers, unless the global
register happens to be the destination register.
It may not clobber any other registers. In fact, only ccalls clobber any
fixed registers.
Also, it may not modify the counter register (used by genCCall).
-
+
Corollary: If a getRegister for a subexpression returns Fixed, you need
not move it to a fresh temporary before evaluating the next subexpression.
The Fixed register won't be modified.
Therefore, we don't need a counterpart for the x86's getStableReg on PPC.
-
+
* SDM's First Rule is valid for PowerPC, too: subexpressions can depend on
the value of the destination register.
-}
-trivialCode
- :: Width
- -> Bool
- -> (Reg -> Reg -> RI -> Instr)
- -> CmmExpr
- -> CmmExpr
- -> NatM Register
+trivialCode
+ :: Width
+ -> Bool
+ -> (Reg -> Reg -> RI -> Instr)
+ -> CmmExpr
+ -> CmmExpr
+ -> NatM Register
trivialCode rep signed instr x (CmmLit (CmmInt y _))
- | Just imm <- makeImmediate rep signed y
+ | Just imm <- makeImmediate rep signed y
= do
(src1, code1) <- getSomeReg x
let code dst = code1 `snocOL` instr dst src1 (RIImm imm)
return (Any (intSize rep) code)
-
+
trivialCode rep _ instr x y = do
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
return (Any (intSize rep) code)
trivialCodeNoImm' :: Size -> (Reg -> Reg -> Reg -> Instr)
- -> CmmExpr -> CmmExpr -> NatM Register
+ -> CmmExpr -> CmmExpr -> NatM Register
trivialCodeNoImm' size instr x y = do
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2
return (Any size code)
-
+
trivialCodeNoImm :: Size -> (Size -> Reg -> Reg -> Reg -> Instr)
- -> CmmExpr -> CmmExpr -> NatM Register
+ -> CmmExpr -> CmmExpr -> NatM Register
trivialCodeNoImm size instr x y = trivialCodeNoImm' size (instr size) x y
-
-
-trivialUCode
- :: Size
- -> (Reg -> Reg -> Instr)
- -> CmmExpr
- -> NatM Register
+
+
+trivialUCode
+ :: Size
+ -> (Reg -> Reg -> Instr)
+ -> CmmExpr
+ -> NatM Register
trivialUCode rep instr x = do
(src, code) <- getSomeReg x
let code' dst = code `snocOL` instr dst src
return (Any rep code')
-
+
-- There is no "remainder" instruction on the PPC, so we have to do
-- it the hard way.
-- The "div" parameter is the division instruction to use (DIVW or DIVWU)
dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
Amode addr addr_code <- getAmode dynRef
let
- code' dst = code `appOL` maybe_exts `appOL` toOL [
- LDATA ReadOnlyData
- [CmmDataLabel lbl,
- CmmStaticLit (CmmInt 0x43300000 W32),
- CmmStaticLit (CmmInt 0x80000000 W32)],
- XORIS itmp src (ImmInt 0x8000),
- ST II32 itmp (spRel 3),
- LIS itmp (ImmInt 0x4330),
- ST II32 itmp (spRel 2),
- LD FF64 ftmp (spRel 2)
+ code' dst = code `appOL` maybe_exts `appOL` toOL [
+ LDATA ReadOnlyData
+ [CmmDataLabel lbl,
+ CmmStaticLit (CmmInt 0x43300000 W32),
+ CmmStaticLit (CmmInt 0x80000000 W32)],
+ XORIS itmp src (ImmInt 0x8000),
+ ST II32 itmp (spRel 3),
+ LIS itmp (ImmInt 0x4330),
+ ST II32 itmp (spRel 2),
+ LD FF64 ftmp (spRel 2)
] `appOL` addr_code `appOL` toOL [
- LD FF64 dst addr,
- FSUB FF64 dst ftmp dst
- ] `appOL` maybe_frsp dst
-
+ LD FF64 dst addr,
+ FSUB FF64 dst ftmp dst
+ ] `appOL` maybe_frsp dst
+
maybe_exts = case fromRep of
W8 -> unitOL $ EXTS II8 src src
W16 -> unitOL $ EXTS II16 src src
W32 -> nilOL
- _ -> panic "PPC.CodeGen.coerceInt2FP: no match"
+ _ -> panic "PPC.CodeGen.coerceInt2FP: no match"
- maybe_frsp dst
- = case toRep of
+ maybe_frsp dst
+ = case toRep of
W32 -> unitOL $ FRSP dst dst
W64 -> nilOL
- _ -> panic "PPC.CodeGen.coerceInt2FP: no match"
+ _ -> panic "PPC.CodeGen.coerceInt2FP: no match"
return (Any (floatSize toRep) code')
(src, code) <- getSomeReg x
tmp <- getNewRegNat FF64
let
- code' dst = code `appOL` toOL [
- -- convert to int in FP reg
- FCTIWZ tmp src,
- -- store value (64bit) from FP to stack
- ST FF64 tmp (spRel 2),
- -- read low word of value (high word is undefined)
- LD II32 dst (spRel 3)]
+ code' dst = code `appOL` toOL [
+ -- convert to int in FP reg
+ FCTIWZ tmp src,
+ -- store value (64bit) from FP to stack
+ ST FF64 tmp (spRel 2),
+ -- read low word of value (high word is undefined)
+ LD II32 dst (spRel 3)]
return (Any (intSize toRep) code')
pprGloblDecl :: CLabel -> Doc
pprGloblDecl lbl
| not (externallyVisibleCLabel lbl) = empty
- | otherwise = ptext IF_ARCH_sparc((sLit ".global "),
- (sLit ".globl ")) <>
- pprCLabel_asm lbl
+ | otherwise = ptext (sLit ".globl ") <> pprCLabel_asm lbl
pprTypeAndSizeDecl :: CLabel -> Doc
#if linux_TARGET_OS
pprInstr (COMMENT _) = empty -- nuke 'em
{-
pprInstr (COMMENT s)
- = IF_ARCH_alpha( ((<>) (ptext (sLit "\t# ")) (ftext s))
- ,IF_ARCH_sparc( ((<>) (ptext (sLit "# ")) (ftext s))
- ,IF_ARCH_i386( ((<>) (ptext (sLit "# ")) (ftext s))
- ,IF_ARCH_x86_64( ((<>) (ptext (sLit "# ")) (ftext s))
- ,IF_ARCH_powerpc( IF_OS_linux(
+ IF_OS_linux(
((<>) (ptext (sLit "# ")) (ftext s)),
((<>) (ptext (sLit "; ")) (ftext s)))
- ,)))))
-}
pprInstr (DELTA d)
= pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
-{-# OPTIONS -fno-warn-unused-binds #-}
+{-# LANGUAGE BangPatterns #-}
module RegAlloc.Graph.TrivColorable (
- trivColorable,
+ trivColorable,
)
where
import UniqFM
import FastTypes
+import Platform
+import Panic
-- trivColorable ---------------------------------------------------------------
-- trivColorable function for the graph coloring allocator
--
--- This gets hammered by scanGraph during register allocation,
--- so needs to be fairly efficient.
+-- This gets hammered by scanGraph during register allocation,
+-- so needs to be fairly efficient.
--
--- NOTE: This only works for arcitectures with just RcInteger and RcDouble
--- (which are disjoint) ie. x86, x86_64 and ppc
+-- NOTE: This only works for arcitectures with just RcInteger and RcDouble
+-- (which are disjoint) ie. x86, x86_64 and ppc
--
--- The number of allocatable regs is hard coded here so we can do a fast
--- comparision in trivColorable.
+-- The number of allocatable regs is hard coded in here so we can do
+-- a fast comparision in trivColorable.
--
--- It's ok if these numbers are _less_ than the actual number of free regs,
--- but they can't be more or the register conflict graph won't color.
+-- It's ok if these numbers are _less_ than the actual number of free
+-- regs, but they can't be more or the register conflict
+-- graph won't color.
--
--- If the graph doesn't color then the allocator will panic, but it won't
--- generate bad object code or anything nasty like that.
+-- If the graph doesn't color then the allocator will panic, but it won't
+-- generate bad object code or anything nasty like that.
--
--- There is an allocatableRegsInClass :: RegClass -> Int, but doing the unboxing
--- is too slow for us here.
+-- There is an allocatableRegsInClass :: RegClass -> Int, but doing
+-- the unboxing is too slow for us here.
+-- TODO: Is that still true? Could we use allocatableRegsInClass
+-- without losing performance now?
--
--- Look at includes/stg/MachRegs.h to get these numbers.
+-- Look at includes/stg/MachRegs.h to get the numbers.
--
-#if i386_TARGET_ARCH
-#define ALLOCATABLE_REGS_INTEGER (_ILIT(3))
-#define ALLOCATABLE_REGS_DOUBLE (_ILIT(6))
-#define ALLOCATABLE_REGS_FLOAT (_ILIT(0))
-#define ALLOCATABLE_REGS_SSE (_ILIT(8))
-
-
-#elif x86_64_TARGET_ARCH
-#define ALLOCATABLE_REGS_INTEGER (_ILIT(5))
-#define ALLOCATABLE_REGS_DOUBLE (_ILIT(0))
-#define ALLOCATABLE_REGS_FLOAT (_ILIT(0))
-#define ALLOCATABLE_REGS_SSE (_ILIT(10))
-
-#elif powerpc_TARGET_ARCH
-#define ALLOCATABLE_REGS_INTEGER (_ILIT(16))
-#define ALLOCATABLE_REGS_DOUBLE (_ILIT(26))
-#define ALLOCATABLE_REGS_FLOAT (_ILIT(0))
-#define ALLOCATABLE_REGS_SSE (_ILIT(0))
-
-
-#elif sparc_TARGET_ARCH
-#define ALLOCATABLE_REGS_INTEGER (_ILIT(14))
-#define ALLOCATABLE_REGS_DOUBLE (_ILIT(11))
-#define ALLOCATABLE_REGS_FLOAT (_ILIT(22))
-#define ALLOCATABLE_REGS_SSE (_ILIT(0))
-
-
-#else
-#error ToDo: choose which trivColorable function to use for this architecture.
-#endif
-
-
-- Disjoint registers ----------------------------------------------------------
---
--- The definition has been unfolded into individual cases for speed.
--- Each architecture has a different register setup, so we use a
--- different regSqueeze function for each.
--
-accSqueeze
- :: FastInt
- -> FastInt
- -> (reg -> FastInt)
- -> UniqFM reg
- -> FastInt
+-- The definition has been unfolded into individual cases for speed.
+-- Each architecture has a different register setup, so we use a
+-- different regSqueeze function for each.
+--
+accSqueeze
+ :: FastInt
+ -> FastInt
+ -> (reg -> FastInt)
+ -> UniqFM reg
+ -> FastInt
accSqueeze count maxCount squeeze ufm = acc count (eltsUFM ufm)
where acc count [] = count
100.00% 166.23% 94.18% 100.95%
-}
+-- TODO: We shouldn't be using defaultTargetPlatform here.
+-- We should be passing DynFlags in instead, and looking at
+-- its targetPlatform.
+
trivColorable
- :: (RegClass -> VirtualReg -> FastInt)
- -> (RegClass -> RealReg -> FastInt)
- -> Triv VirtualReg RegClass RealReg
+ :: (RegClass -> VirtualReg -> FastInt)
+ -> (RegClass -> RealReg -> FastInt)
+ -> Triv VirtualReg RegClass RealReg
trivColorable virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions
- | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_INTEGER
- (virtualRegSqueeze RcInteger)
- conflicts
-
- , count3 <- accSqueeze count2 ALLOCATABLE_REGS_INTEGER
- (realRegSqueeze RcInteger)
- exclusions
-
- = count3 <# ALLOCATABLE_REGS_INTEGER
+ | let !cALLOCATABLE_REGS_INTEGER
+ = iUnbox (case platformArch defaultTargetPlatform of
+ ArchX86 -> 3
+ ArchX86_64 -> 5
+ ArchPPC -> 16
+ ArchSPARC -> 14
+ ArchPPC_64 -> panic "trivColorable ArchPPC_64"
+ ArchUnknown -> panic "trivColorable ArchUnknown")
+ , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_INTEGER
+ (virtualRegSqueeze RcInteger)
+ conflicts
+
+ , count3 <- accSqueeze count2 cALLOCATABLE_REGS_INTEGER
+ (realRegSqueeze RcInteger)
+ exclusions
+
+ = count3 <# cALLOCATABLE_REGS_INTEGER
trivColorable virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions
- | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_FLOAT
- (virtualRegSqueeze RcFloat)
- conflicts
-
- , count3 <- accSqueeze count2 ALLOCATABLE_REGS_FLOAT
- (realRegSqueeze RcFloat)
- exclusions
-
- = count3 <# ALLOCATABLE_REGS_FLOAT
+ | let !cALLOCATABLE_REGS_FLOAT
+ = iUnbox (case platformArch defaultTargetPlatform of
+ ArchX86 -> 0
+ ArchX86_64 -> 0
+ ArchPPC -> 0
+ ArchSPARC -> 22
+ ArchPPC_64 -> panic "trivColorable ArchPPC_64"
+ ArchUnknown -> panic "trivColorable ArchUnknown")
+ , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_FLOAT
+ (virtualRegSqueeze RcFloat)
+ conflicts
+
+ , count3 <- accSqueeze count2 cALLOCATABLE_REGS_FLOAT
+ (realRegSqueeze RcFloat)
+ exclusions
+
+ = count3 <# cALLOCATABLE_REGS_FLOAT
trivColorable virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions
- | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_DOUBLE
- (virtualRegSqueeze RcDouble)
- conflicts
-
- , count3 <- accSqueeze count2 ALLOCATABLE_REGS_DOUBLE
- (realRegSqueeze RcDouble)
- exclusions
-
- = count3 <# ALLOCATABLE_REGS_DOUBLE
+ | let !cALLOCATABLE_REGS_DOUBLE
+ = iUnbox (case platformArch defaultTargetPlatform of
+ ArchX86 -> 6
+ ArchX86_64 -> 0
+ ArchPPC -> 26
+ ArchSPARC -> 11
+ ArchPPC_64 -> panic "trivColorable ArchPPC_64"
+ ArchUnknown -> panic "trivColorable ArchUnknown")
+ , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_DOUBLE
+ (virtualRegSqueeze RcDouble)
+ conflicts
+
+ , count3 <- accSqueeze count2 cALLOCATABLE_REGS_DOUBLE
+ (realRegSqueeze RcDouble)
+ exclusions
+
+ = count3 <# cALLOCATABLE_REGS_DOUBLE
trivColorable virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions
- | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_SSE
- (virtualRegSqueeze RcDoubleSSE)
- conflicts
-
- , count3 <- accSqueeze count2 ALLOCATABLE_REGS_SSE
- (realRegSqueeze RcDoubleSSE)
- exclusions
+ | let !cALLOCATABLE_REGS_SSE
+ = iUnbox (case platformArch defaultTargetPlatform of
+ ArchX86 -> 8
+ ArchX86_64 -> 10
+ ArchPPC -> 0
+ ArchSPARC -> 0
+ ArchPPC_64 -> panic "trivColorable ArchPPC_64"
+ ArchUnknown -> panic "trivColorable ArchUnknown")
+ , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_SSE
+ (virtualRegSqueeze RcDoubleSSE)
+ conflicts
- = count3 <# ALLOCATABLE_REGS_SSE
+ , count3 <- accSqueeze count2 cALLOCATABLE_REGS_SSE
+ (realRegSqueeze RcDoubleSSE)
+ exclusions
+
+ = count3 <# cALLOCATABLE_REGS_SSE
-- Specification Code ----------------------------------------------------------
--
--- The trivColorable function for each particular architecture should
--- implement the following function, but faster.
+-- The trivColorable function for each particular architecture should
+-- implement the following function, but faster.
--
{-
trivColorable classN conflicts exclusions
= let
- acc :: Reg -> (Int, Int) -> (Int, Int)
- acc r (cd, cf)
- = case regClass r of
- RcInteger -> (cd+1, cf)
- RcFloat -> (cd, cf+1)
- _ -> panic "Regs.trivColorable: reg class not handled"
+ acc :: Reg -> (Int, Int) -> (Int, Int)
+ acc r (cd, cf)
+ = case regClass r of
+ RcInteger -> (cd+1, cf)
+ RcFloat -> (cd, cf+1)
+ _ -> panic "Regs.trivColorable: reg class not handled"
- tmp = foldUniqSet acc (0, 0) conflicts
- (countInt, countFloat) = foldUniqSet acc tmp exclusions
+ tmp = foldUniqSet acc (0, 0) conflicts
+ (countInt, countFloat) = foldUniqSet acc tmp exclusions
- squeese = worst countInt classN RcInteger
- + worst countFloat classN RcFloat
+ squeese = worst countInt classN RcInteger
+ + worst countFloat classN RcFloat
- in squeese < allocatableRegsInClass classN
+ in squeese < allocatableRegsInClass classN
-- | Worst case displacement
--- node N of classN has n neighbors of class C.
+-- node N of classN has n neighbors of class C.
--
--- We currently only have RcInteger and RcDouble, which don't conflict at all.
--- This is a bit boring compared to what's in RegArchX86.
+-- We currently only have RcInteger and RcDouble, which don't conflict at all.
+-- This is a bit boring compared to what's in RegArchX86.
--
worst :: Int -> RegClass -> RegClass -> Int
worst n classN classC
= case classN of
- RcInteger
- -> case classC of
- RcInteger -> min n (allocatableRegsInClass RcInteger)
- RcFloat -> 0
-
- RcDouble
- -> case classC of
- RcFloat -> min n (allocatableRegsInClass RcFloat)
- RcInteger -> 0
+ RcInteger
+ -> case classC of
+ RcInteger -> min n (allocatableRegsInClass RcInteger)
+ RcFloat -> 0
+
+ RcDouble
+ -> case classC of
+ RcFloat -> min n (allocatableRegsInClass RcFloat)
+ RcInteger -> 0
-- allocatableRegs is allMachRegNos with the fixed-use regs removed.
-- i.e., these are the regs for which we are prepared to allow the
-- | The number of regs in each class.
--- We go via top level CAFs to ensure that we're not recomputing
--- the length of these lists each time the fn is called.
+-- We go via top level CAFs to ensure that we're not recomputing
+-- the length of these lists each time the fn is called.
allocatableRegsInClass :: RegClass -> Int
allocatableRegsInClass cls
= case cls of
- RcInteger -> allocatableRegsInteger
- RcFloat -> allocatableRegsDouble
+ RcInteger -> allocatableRegsInteger
+ RcFloat -> allocatableRegsDouble
allocatableRegsInteger :: Int
-allocatableRegsInteger
- = length $ filter (\r -> regClass r == RcInteger)
- $ map RealReg allocatableRegs
+allocatableRegsInteger
+ = length $ filter (\r -> regClass r == RcInteger)
+ $ map RealReg allocatableRegs
allocatableRegsFloat :: Int
allocatableRegsFloat
- = length $ filter (\r -> regClass r == RcFloat
- $ map RealReg allocatableRegs
+ = length $ filter (\r -> regClass r == RcFloat
+ $ map RealReg allocatableRegs
-}
-- | Put common type definitions here to break recursive module dependencies.
module RegAlloc.Linear.Base (
- BlockAssignment,
-
- Loc(..),
- regsOfLoc,
-
- -- for stats
- SpillReason(..),
- RegAllocStats(..),
-
- -- the allocator monad
- RA_State(..),
- RegM(..)
+ BlockAssignment,
+
+ Loc(..),
+ regsOfLoc,
+
+ -- for stats
+ SpillReason(..),
+ RegAllocStats(..),
+
+ -- the allocator monad
+ RA_State(..),
+ RegM(..)
)
where
-import RegAlloc.Linear.FreeRegs
import RegAlloc.Linear.StackMap
import RegAlloc.Liveness
import Reg
-- | Used to store the register assignment on entry to a basic block.
--- We use this to handle join points, where multiple branch instructions
--- target a particular label. We have to insert fixup code to make
--- the register assignments from the different sources match up.
+-- We use this to handle join points, where multiple branch instructions
+-- target a particular label. We have to insert fixup code to make
+-- the register assignments from the different sources match up.
--
-type BlockAssignment
- = BlockMap (FreeRegs, RegMap Loc)
+type BlockAssignment freeRegs
+ = BlockMap (freeRegs, RegMap Loc)
-- | Where a vreg is currently stored
--- A temporary can be marked as living in both a register and memory
--- (InBoth), for example if it was recently loaded from a spill location.
--- This makes it cheap to spill (no save instruction required), but we
--- have to be careful to turn this into InReg if the value in the
--- register is changed.
-
--- This is also useful when a temporary is about to be clobbered. We
--- save it in a spill location, but mark it as InBoth because the current
--- instruction might still want to read it.
+-- A temporary can be marked as living in both a register and memory
+-- (InBoth), for example if it was recently loaded from a spill location.
+-- This makes it cheap to spill (no save instruction required), but we
+-- have to be careful to turn this into InReg if the value in the
+-- register is changed.
+
+-- This is also useful when a temporary is about to be clobbered. We
+-- save it in a spill location, but mark it as InBoth because the current
+-- instruction might still want to read it.
--
-data Loc
- -- | vreg is in a register
- = InReg !RealReg
+data Loc
+ -- | vreg is in a register
+ = InReg !RealReg
- -- | vreg is held in a stack slot
- | InMem {-# UNPACK #-} !StackSlot
+ -- | vreg is held in a stack slot
+ | InMem {-# UNPACK #-} !StackSlot
- -- | vreg is held in both a register and a stack slot
- | InBoth !RealReg
- {-# UNPACK #-} !StackSlot
- deriving (Eq, Show, Ord)
+ -- | vreg is held in both a register and a stack slot
+ | InBoth !RealReg
+ {-# UNPACK #-} !StackSlot
+ deriving (Eq, Show, Ord)
instance Outputable Loc where
- ppr l = text (show l)
+ ppr l = text (show l)
-- | Get the reg numbers stored in this Loc.
-- | Reasons why instructions might be inserted by the spiller.
--- Used when generating stats for -ddrop-asm-stats.
+-- Used when generating stats for -ddrop-asm-stats.
--
data SpillReason
- -- | vreg was spilled to a slot so we could use its
- -- current hreg for another vreg
- = SpillAlloc !Unique
+ -- | vreg was spilled to a slot so we could use its
+ -- current hreg for another vreg
+ = SpillAlloc !Unique
- -- | vreg was moved because its hreg was clobbered
- | SpillClobber !Unique
+ -- | vreg was moved because its hreg was clobbered
+ | SpillClobber !Unique
- -- | vreg was loaded from a spill slot
- | SpillLoad !Unique
+ -- | vreg was loaded from a spill slot
+ | SpillLoad !Unique
- -- | reg-reg move inserted during join to targets
- | SpillJoinRR !Unique
+ -- | reg-reg move inserted during join to targets
+ | SpillJoinRR !Unique
- -- | reg-mem move inserted during join to targets
- | SpillJoinRM !Unique
+ -- | reg-mem move inserted during join to targets
+ | SpillJoinRM !Unique
-- | Used to carry interesting stats out of the register allocator.
data RegAllocStats
- = RegAllocStats
- { ra_spillInstrs :: UniqFM [Int] }
+ = RegAllocStats
+ { ra_spillInstrs :: UniqFM [Int] }
-- | The register alloctor state
-data RA_State
- = RA_State
+data RA_State freeRegs
+ = RA_State
+
+ {
+ -- | the current mapping from basic blocks to
+ -- the register assignments at the beginning of that block.
+ ra_blockassig :: BlockAssignment freeRegs
- {
- -- | the current mapping from basic blocks to
- -- the register assignments at the beginning of that block.
- ra_blockassig :: BlockAssignment
-
- -- | free machine registers
- , ra_freeregs :: {-#UNPACK#-}!FreeRegs
+ -- | free machine registers
+ , ra_freeregs :: !freeRegs
- -- | assignment of temps to locations
- , ra_assig :: RegMap Loc
+ -- | assignment of temps to locations
+ , ra_assig :: RegMap Loc
- -- | current stack delta
- , ra_delta :: Int
+ -- | current stack delta
+ , ra_delta :: Int
- -- | free stack slots for spilling
- , ra_stack :: StackMap
+ -- | free stack slots for spilling
+ , ra_stack :: StackMap
- -- | unique supply for generating names for join point fixup blocks.
- , ra_us :: UniqSupply
+ -- | unique supply for generating names for join point fixup blocks.
+ , ra_us :: UniqSupply
- -- | Record why things were spilled, for -ddrop-asm-stats.
- -- Just keep a list here instead of a map of regs -> reasons.
- -- We don't want to slow down the allocator if we're not going to emit the stats.
- , ra_spills :: [SpillReason] }
+ -- | Record why things were spilled, for -ddrop-asm-stats.
+ -- Just keep a list here instead of a map of regs -> reasons.
+ -- We don't want to slow down the allocator if we're not going to emit the stats.
+ , ra_spills :: [SpillReason] }
-- | The register allocator monad type.
-newtype RegM a
- = RegM { unReg :: RA_State -> (# RA_State, a #) }
+newtype RegM freeRegs a
+ = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) }
module RegAlloc.Linear.FreeRegs (
- FreeRegs(),
- noFreeRegs,
- releaseReg,
- initFreeRegs,
- getFreeRegs,
- allocateReg,
- maxSpillSlots
+ FR(..),
+ maxSpillSlots
)
#include "HsVersions.h"
where
+import Reg
+import RegClass
+
+import Panic
+import Platform
+
-- -----------------------------------------------------------------------------
-- The free register set
-- This needs to be *efficient*
-- getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
-- allocateReg f r = filter (/= r) f
+import qualified RegAlloc.Linear.PPC.FreeRegs as PPC
+import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC
+import qualified RegAlloc.Linear.X86.FreeRegs as X86
+
+import qualified PPC.Instr
+import qualified SPARC.Instr
+import qualified X86.Instr
+
+class Show freeRegs => FR freeRegs where
+ frAllocateReg :: RealReg -> freeRegs -> freeRegs
+ frGetFreeRegs :: RegClass -> freeRegs -> [RealReg]
+ frInitFreeRegs :: freeRegs
+ frReleaseReg :: RealReg -> freeRegs -> freeRegs
-#if defined(powerpc_TARGET_ARCH)
-import RegAlloc.Linear.PPC.FreeRegs
-import PPC.Instr (maxSpillSlots)
+instance FR X86.FreeRegs where
+ frAllocateReg = X86.allocateReg
+ frGetFreeRegs = X86.getFreeRegs
+ frInitFreeRegs = X86.initFreeRegs
+ frReleaseReg = X86.releaseReg
-#elif defined(sparc_TARGET_ARCH)
-import RegAlloc.Linear.SPARC.FreeRegs
-import SPARC.Instr (maxSpillSlots)
+instance FR PPC.FreeRegs where
+ frAllocateReg = PPC.allocateReg
+ frGetFreeRegs = PPC.getFreeRegs
+ frInitFreeRegs = PPC.initFreeRegs
+ frReleaseReg = PPC.releaseReg
-#elif defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH)
-import RegAlloc.Linear.X86.FreeRegs
-import X86.Instr (maxSpillSlots)
+instance FR SPARC.FreeRegs where
+ frAllocateReg = SPARC.allocateReg
+ frGetFreeRegs = SPARC.getFreeRegs
+ frInitFreeRegs = SPARC.initFreeRegs
+ frReleaseReg = SPARC.releaseReg
-#else
-#error "RegAlloc.Linear.FreeRegs not defined for this architecture."
+-- TODO: We shouldn't be using defaultTargetPlatform here.
+-- We should be passing DynFlags in instead, and looking at
+-- its targetPlatform.
-#endif
+maxSpillSlots :: Int
+maxSpillSlots = case platformArch defaultTargetPlatform of
+ ArchX86 -> X86.Instr.maxSpillSlots
+ ArchX86_64 -> X86.Instr.maxSpillSlots
+ ArchPPC -> PPC.Instr.maxSpillSlots
+ ArchSPARC -> SPARC.Instr.maxSpillSlots
+ ArchPPC_64 -> panic "maxSpillSlots ArchPPC_64"
+ ArchUnknown -> panic "maxSpillSlots ArchUnknown"
-{-# OPTIONS -fno-warn-missing-signatures #-}
-
-- | Handles joining of a jump instruction to its targets.
-- vregs are in the correct regs for its destination.
--
joinToTargets
- :: Instruction instr
+ :: (FR freeRegs, Instruction instr)
=> BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs
-- that are known to be live on the entry to each block.
-> BlockId -- ^ id of the current block
-> instr -- ^ branch instr on the end of the source block.
- -> RegM ([NatBasicBlock instr] -- fresh blocks of fixup code.
+ -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code.
, instr) -- the original branch instruction, but maybe patched to jump
-- to a fixup block first.
-----
joinToTargets'
- :: Instruction instr
+ :: (FR freeRegs, Instruction instr)
=> BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs
-- that are known to be live on the entry to each block.
-> [BlockId] -- ^ branch destinations still to consider.
- -> RegM ( [NatBasicBlock instr]
+ -> RegM freeRegs ( [NatBasicBlock instr]
, instr)
-- no more targets to consider. all done.
-- this is the first time we jumped to this block.
+joinToTargets_first :: (FR freeRegs, Instruction instr)
+ => BlockMap RegSet
+ -> [NatBasicBlock instr]
+ -> BlockId
+ -> instr
+ -> BlockId
+ -> [BlockId]
+ -> BlockAssignment freeRegs
+ -> RegMap Loc
+ -> [RealReg]
+ -> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets_first block_live new_blocks block_id instr dest dests
block_assig src_assig
- (to_free :: [RealReg])
+ to_free
= do -- free up the regs that are not live on entry to this block.
freeregs <- getFreeRegsR
- let freeregs' = foldr releaseReg freeregs to_free
+ let freeregs' = foldr frReleaseReg freeregs to_free
-- remember the current assignment on entry to this block.
setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig)
-- we've jumped to this block before
+joinToTargets_again :: (Instruction instr, FR freeRegs)
+ => BlockMap RegSet
+ -> [NatBasicBlock instr]
+ -> BlockId
+ -> instr
+ -> BlockId
+ -> [BlockId]
+ -> UniqFM Loc
+ -> UniqFM Loc
+ -> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets_again
block_live new_blocks block_id instr dest dests
src_assig dest_assig
--
handleComponent
:: Instruction instr
- => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM [instr]
+ => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM freeRegs [instr]
-- If the graph is acyclic then we won't get the swapping problem below.
-- In this case we can just do the moves directly, and avoid having to
-> Unique -- ^ unique of the vreg that we're moving.
-> Loc -- ^ source location.
-> Loc -- ^ destination location.
- -> RegM instr -- ^ move instruction.
+ -> RegM freeRegs instr -- ^ move instruction.
makeMove _ vreg (InReg src) (InReg dst)
= do recordSpill (SpillJoinRR vreg)
-{-# OPTIONS -fno-warn-missing-signatures #-}
-----------------------------------------------------------------------------
--
-- The register allocator
{-
The algorithm is roughly:
-
+
1) Compute strongly connected components of the basic block list.
2) Compute liveness (mapping from pseudo register to
point(s) of death?).
3) Walk instructions in each basic block. We keep track of
- (a) Free real registers (a bitmap?)
- (b) Current assignment of temporaries to machine registers and/or
- spill slots (call this the "assignment").
- (c) Partial mapping from basic block ids to a virt-to-loc mapping.
- When we first encounter a branch to a basic block,
- we fill in its entry in this table with the current mapping.
+ (a) Free real registers (a bitmap?)
+ (b) Current assignment of temporaries to machine registers and/or
+ spill slots (call this the "assignment").
+ (c) Partial mapping from basic block ids to a virt-to-loc mapping.
+ When we first encounter a branch to a basic block,
+ we fill in its entry in this table with the current mapping.
For each instruction:
- (a) For each real register clobbered by this instruction:
- If a temporary resides in it,
- If the temporary is live after this instruction,
- Move the temporary to another (non-clobbered & free) reg,
- or spill it to memory. Mark the temporary as residing
- in both memory and a register if it was spilled (it might
- need to be read by this instruction).
- (ToDo: this is wrong for jump instructions?)
-
- (b) For each temporary *read* by the instruction:
- If the temporary does not have a real register allocation:
- - Allocate a real register from the free list. If
- the list is empty:
- - Find a temporary to spill. Pick one that is
- not used in this instruction (ToDo: not
- used for a while...)
- - generate a spill instruction
- - If the temporary was previously spilled,
- generate an instruction to read the temp from its spill loc.
- (optimisation: if we can see that a real register is going to
+ (a) For each real register clobbered by this instruction:
+ If a temporary resides in it,
+ If the temporary is live after this instruction,
+ Move the temporary to another (non-clobbered & free) reg,
+ or spill it to memory. Mark the temporary as residing
+ in both memory and a register if it was spilled (it might
+ need to be read by this instruction).
+ (ToDo: this is wrong for jump instructions?)
+
+ (b) For each temporary *read* by the instruction:
+ If the temporary does not have a real register allocation:
+ - Allocate a real register from the free list. If
+ the list is empty:
+ - Find a temporary to spill. Pick one that is
+ not used in this instruction (ToDo: not
+ used for a while...)
+ - generate a spill instruction
+ - If the temporary was previously spilled,
+ generate an instruction to read the temp from its spill loc.
+ (optimisation: if we can see that a real register is going to
be used soon, then don't use it for allocation).
- (c) Update the current assignment
+ (c) Update the current assignment
- (d) If the instruction is a branch:
- if the destination block already has a register assignment,
- Generate a new block with fixup code and redirect the
- jump to the new block.
- else,
- Update the block id->assignment mapping with the current
- assignment.
+ (d) If the instruction is a branch:
+ if the destination block already has a register assignment,
+ Generate a new block with fixup code and redirect the
+ jump to the new block.
+ else,
+ Update the block id->assignment mapping with the current
+ assignment.
- (e) Delete all register assignments for temps which are read
- (only) and die here. Update the free register list.
+ (e) Delete all register assignments for temps which are read
+ (only) and die here. Update the free register list.
- (f) Mark all registers clobbered by this instruction as not free,
- and mark temporaries which have been spilled due to clobbering
- as in memory (step (a) marks then as in both mem & reg).
+ (f) Mark all registers clobbered by this instruction as not free,
+ and mark temporaries which have been spilled due to clobbering
+ as in memory (step (a) marks then as in both mem & reg).
- (g) For each temporary *written* by this instruction:
- Allocate a real register as for (b), spilling something
- else if necessary.
- - except when updating the assignment, drop any memory
- locations that the temporary was previously in, since
- they will be no longer valid after this instruction.
+ (g) For each temporary *written* by this instruction:
+ Allocate a real register as for (b), spilling something
+ else if necessary.
+ - except when updating the assignment, drop any memory
+ locations that the temporary was previously in, since
+ they will be no longer valid after this instruction.
- (h) Delete all register assignments for temps which are
- written and die here (there should rarely be any). Update
- the free register list.
+ (h) Delete all register assignments for temps which are
+ written and die here (there should rarely be any). Update
+ the free register list.
- (i) Rewrite the instruction with the new mapping.
+ (i) Rewrite the instruction with the new mapping.
- (j) For each spilled reg known to be now dead, re-add its stack slot
- to the free list.
+ (j) For each spilled reg known to be now dead, re-add its stack slot
+ to the free list.
-}
module RegAlloc.Linear.Main (
- regAlloc,
- module RegAlloc.Linear.Base,
- module RegAlloc.Linear.Stats
+ regAlloc,
+ module RegAlloc.Linear.Base,
+ module RegAlloc.Linear.Stats
) where
#include "HsVersions.h"
import RegAlloc.Linear.FreeRegs
import RegAlloc.Linear.Stats
import RegAlloc.Linear.JoinToTargets
+import qualified RegAlloc.Linear.PPC.FreeRegs as PPC
+import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC
+import qualified RegAlloc.Linear.X86.FreeRegs as X86
import TargetReg
import RegAlloc.Liveness
import Instruction
import OldCmm hiding (RegSet)
import Digraph
+import DynFlags
import Unique
import UniqSet
import UniqFM
import UniqSupply
import Outputable
+import Platform
import Data.Maybe
import Data.List
-- Top level of the register allocator
-- Allocate registers
-regAlloc
- :: (Outputable instr, Instruction instr)
- => LiveCmmTop instr
- -> UniqSM (NatCmmTop instr, Maybe RegAllocStats)
-
-regAlloc (CmmData sec d)
- = return
- ( CmmData sec d
- , Nothing )
-
-regAlloc (CmmProc (LiveInfo info _ _ _) lbl [])
- = return ( CmmProc info lbl (ListGraph [])
- , Nothing )
-
-regAlloc (CmmProc static lbl sccs)
- | LiveInfo info (Just first_id) (Just block_live) _ <- static
- = do
- -- do register allocation on each component.
- (final_blocks, stats)
- <- linearRegAlloc first_id block_live sccs
-
- -- make sure the block that was first in the input list
- -- stays at the front of the output
- let ((first':_), rest')
- = partition ((== first_id) . blockId) final_blocks
-
- return ( CmmProc info lbl (ListGraph (first' : rest'))
- , Just stats)
-
+regAlloc
+ :: (Outputable instr, Instruction instr)
+ => DynFlags
+ -> LiveCmmTop instr
+ -> UniqSM (NatCmmTop instr, Maybe RegAllocStats)
+
+regAlloc _ (CmmData sec d)
+ = return
+ ( CmmData sec d
+ , Nothing )
+
+regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl [])
+ = return ( CmmProc info lbl (ListGraph [])
+ , Nothing )
+
+regAlloc dflags (CmmProc static lbl sccs)
+ | LiveInfo info (Just first_id) (Just block_live) _ <- static
+ = do
+ -- do register allocation on each component.
+ (final_blocks, stats)
+ <- linearRegAlloc dflags first_id block_live sccs
+
+ -- make sure the block that was first in the input list
+ -- stays at the front of the output
+ let ((first':_), rest')
+ = partition ((== first_id) . blockId) final_blocks
+
+ return ( CmmProc info lbl (ListGraph (first' : rest'))
+ , Just stats)
+
-- bogus. to make non-exhaustive match warning go away.
-regAlloc (CmmProc _ _ _)
- = panic "RegAllocLinear.regAlloc: no match"
+regAlloc _ (CmmProc _ _ _)
+ = panic "RegAllocLinear.regAlloc: no match"
-- -----------------------------------------------------------------------------
-- an entry in the block map or it is the first block.
--
linearRegAlloc
- :: (Outputable instr, Instruction instr)
- => BlockId -- ^ the first block
- -> BlockMap RegSet -- ^ live regs on entry to each basic block
- -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
- -> UniqSM ([NatBasicBlock instr], RegAllocStats)
-
-linearRegAlloc first_id block_live sccs
- = do us <- getUs
- let (_, _, stats, blocks) =
- runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us
- $ linearRA_SCCs first_id block_live [] sccs
-
- return (blocks, stats)
+ :: (Outputable instr, Instruction instr)
+ => DynFlags
+ -> BlockId -- ^ the first block
+ -> BlockMap RegSet -- ^ live regs on entry to each basic block
+ -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
+ -> UniqSM ([NatBasicBlock instr], RegAllocStats)
+
+linearRegAlloc dflags first_id block_live sccs
+ = case platformArch $ targetPlatform dflags of
+ ArchX86 -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs
+ ArchX86_64 -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs
+ ArchSPARC -> linearRegAlloc' (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs
+ ArchPPC -> linearRegAlloc' (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs
+ ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64"
+ ArchUnknown -> panic "linearRegAlloc ArchUnknown"
+
+linearRegAlloc'
+ :: (FR freeRegs, Outputable instr, Instruction instr)
+ => freeRegs
+ -> BlockId -- ^ the first block
+ -> BlockMap RegSet -- ^ live regs on entry to each basic block
+ -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
+ -> UniqSM ([NatBasicBlock instr], RegAllocStats)
+
+linearRegAlloc' initFreeRegs first_id block_live sccs
+ = do us <- getUs
+ let (_, _, stats, blocks) =
+ runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us
+ $ linearRA_SCCs first_id block_live [] sccs
+ return (blocks, stats)
+
+
+linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr)
+ => BlockId
+ -> BlockMap RegSet
+ -> [NatBasicBlock instr]
+ -> [SCC (LiveBasicBlock instr)]
+ -> RegM freeRegs [NatBasicBlock instr]
linearRA_SCCs _ _ blocksAcc []
- = return $ reverse blocksAcc
+ = return $ reverse blocksAcc
-linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs)
- = do blocks' <- processBlock block_live block
- linearRA_SCCs first_id block_live
- ((reverse blocks') ++ blocksAcc)
- sccs
+linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs)
+ = do blocks' <- processBlock block_live block
+ linearRA_SCCs first_id block_live
+ ((reverse blocks') ++ blocksAcc)
+ sccs
-linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs)
+linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs)
= do
blockss' <- process first_id block_live blocks [] (return []) False
- linearRA_SCCs first_id block_live
- (reverse (concat blockss') ++ blocksAcc)
- sccs
+ linearRA_SCCs first_id block_live
+ (reverse (concat blockss') ++ blocksAcc)
+ sccs
{- from John Dias's patch 2008/10/16:
The linear-scan allocator sometimes allocates a block
- before allocating one of its predecessors, which could lead to
+ before allocating one of its predecessors, which could lead to
inconsistent allocations. Make it so a block is only allocated
if a predecessor has set the "incoming" assignments for the block, or
if it's the procedure's entry block.
BL 2009/02: Careful. If the assignment for a block doesn't get set for
- some reason then this function will loop. We should probably do some
+ some reason then this function will loop. We should probably do some
more sanity checking to guard against this eventuality.
-}
+process :: (FR freeRegs, Instruction instr, Outputable instr)
+ => BlockId
+ -> BlockMap RegSet
+ -> [GenBasicBlock (LiveInstr instr)]
+ -> [GenBasicBlock (LiveInstr instr)]
+ -> [[NatBasicBlock instr]]
+ -> Bool
+ -> RegM freeRegs [[NatBasicBlock instr]]
+
process _ _ [] [] accum _
- = return $ reverse accum
+ = return $ reverse accum
process first_id block_live [] next_round accum madeProgress
- | not madeProgress
-
- {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.
- pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."
- ( text "Unreachable blocks:"
- $$ vcat (map ppr next_round)) -}
- = return $ reverse accum
-
- | otherwise
- = process first_id block_live
- next_round [] accum False
-
-process first_id block_live (b@(BasicBlock id _) : blocks)
- next_round accum madeProgress
- = do
- block_assig <- getBlockAssigR
-
- if isJust (mapLookup id block_assig)
+ | not madeProgress
+
+ {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.
+ pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."
+ ( text "Unreachable blocks:"
+ $$ vcat (map ppr next_round)) -}
+ = return $ reverse accum
+
+ | otherwise
+ = process first_id block_live
+ next_round [] accum False
+
+process first_id block_live (b@(BasicBlock id _) : blocks)
+ next_round accum madeProgress
+ = do
+ block_assig <- getBlockAssigR
+
+ if isJust (mapLookup id block_assig)
|| id == first_id
- then do
- b' <- processBlock block_live b
- process first_id block_live blocks
- next_round (b' : accum) True
+ then do
+ b' <- processBlock block_live b
+ process first_id block_live blocks
+ next_round (b' : accum) True
- else process first_id block_live blocks
- (b : next_round) accum madeProgress
+ else process first_id block_live blocks
+ (b : next_round) accum madeProgress
-- | Do register allocation on this basic block
--
processBlock
- :: (Outputable instr, Instruction instr)
- => BlockMap RegSet -- ^ live regs on entry to each basic block
- -> LiveBasicBlock instr -- ^ block to do register allocation on
- -> RegM [NatBasicBlock instr] -- ^ block with registers allocated
+ :: (FR freeRegs, Outputable instr, Instruction instr)
+ => BlockMap RegSet -- ^ live regs on entry to each basic block
+ -> LiveBasicBlock instr -- ^ block to do register allocation on
+ -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated
processBlock block_live (BasicBlock id instrs)
- = do initBlock id
- (instrs', fixups)
- <- linearRA block_live [] [] id instrs
- return $ BasicBlock id instrs' : fixups
+ = do initBlock id
+ (instrs', fixups)
+ <- linearRA block_live [] [] id instrs
+ return $ BasicBlock id instrs' : fixups
-- | Load the freeregs and current reg assignment into the RegM state
--- for the basic block with this BlockId.
-initBlock :: BlockId -> RegM ()
+-- for the basic block with this BlockId.
+initBlock :: FR freeRegs => BlockId -> RegM freeRegs ()
initBlock id
- = do block_assig <- getBlockAssigR
- case mapLookup id block_assig of
- -- no prior info about this block: assume everything is
- -- free and the assignment is empty.
- Nothing
- -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
-
- setFreeRegsR initFreeRegs
- setAssigR emptyRegMap
-
- -- load info about register assignments leading into this block.
- Just (freeregs, assig)
- -> do setFreeRegsR freeregs
- setAssigR assig
+ = do block_assig <- getBlockAssigR
+ case mapLookup id block_assig of
+ -- no prior info about this block: assume everything is
+ -- free and the assignment is empty.
+ Nothing
+ -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
+
+ setFreeRegsR frInitFreeRegs
+ setAssigR emptyRegMap
+
+ -- load info about register assignments leading into this block.
+ Just (freeregs, assig)
+ -> do setFreeRegsR freeregs
+ setAssigR assig
-- | Do allocation for a sequence of instructions.
linearRA
- :: (Outputable instr, Instruction instr)
- => BlockMap RegSet -- ^ map of what vregs are live on entry to each block.
- -> [instr] -- ^ accumulator for instructions already processed.
- -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code.
- -> BlockId -- ^ id of the current block, for debugging.
- -> [LiveInstr instr] -- ^ liveness annotated instructions in this block.
+ :: (FR freeRegs, Outputable instr, Instruction instr)
+ => BlockMap RegSet -- ^ map of what vregs are live on entry to each block.
+ -> [instr] -- ^ accumulator for instructions already processed.
+ -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code.
+ -> BlockId -- ^ id of the current block, for debugging.
+ -> [LiveInstr instr] -- ^ liveness annotated instructions in this block.
- -> RegM ( [instr] -- instructions after register allocation
- , [NatBasicBlock instr]) -- fresh blocks of fixup code.
+ -> RegM freeRegs
+ ( [instr] -- instructions after register allocation
+ , [NatBasicBlock instr]) -- fresh blocks of fixup code.
linearRA _ accInstr accFixup _ []
- = return
- ( reverse accInstr -- instrs need to be returned in the correct order.
- , accFixup) -- it doesn't matter what order the fixup blocks are returned in.
+ = return
+ ( reverse accInstr -- instrs need to be returned in the correct order.
+ , accFixup) -- it doesn't matter what order the fixup blocks are returned in.
linearRA block_live accInstr accFixups id (instr:instrs)
= do
- (accInstr', new_fixups)
- <- raInsn block_live accInstr id instr
+ (accInstr', new_fixups)
+ <- raInsn block_live accInstr id instr
- linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs
+ linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs
-- | Do allocation for a single instruction.
-raInsn
- :: (Outputable instr, Instruction instr)
- => BlockMap RegSet -- ^ map of what vregs are love on entry to each block.
- -> [instr] -- ^ accumulator for instructions already processed.
- -> BlockId -- ^ the id of the current block, for debugging
- -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info.
- -> RegM
- ( [instr] -- new instructions
- , [NatBasicBlock instr]) -- extra fixup blocks
-
-raInsn _ new_instrs _ (LiveInstr ii Nothing)
- | Just n <- takeDeltaInstr ii
- = do setDeltaR n
- return (new_instrs, [])
+raInsn
+ :: (FR freeRegs, Outputable instr, Instruction instr)
+ => BlockMap RegSet -- ^ map of what vregs are love on entry to each block.
+ -> [instr] -- ^ accumulator for instructions already processed.
+ -> BlockId -- ^ the id of the current block, for debugging
+ -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info.
+ -> RegM freeRegs
+ ( [instr] -- new instructions
+ , [NatBasicBlock instr]) -- extra fixup blocks
raInsn _ new_instrs _ (LiveInstr ii Nothing)
- | isMetaInstr ii
- = return (new_instrs, [])
+ | Just n <- takeDeltaInstr ii
+ = do setDeltaR n
+ return (new_instrs, [])
+
+raInsn _ new_instrs _ (LiveInstr ii Nothing)
+ | isMetaInstr ii
+ = return (new_instrs, [])
raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
-- (we can't eliminate it if the source register is on the stack, because
-- we do not want to use one spill slot for different virtual registers)
case takeRegRegMoveInstr instr of
- Just (src,dst) | src `elementOfUniqSet` (liveDieRead live),
- isVirtualReg dst,
- not (dst `elemUFM` assig),
- Just (InReg _) <- (lookupUFM assig src) -> do
- case src of
- (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr))
- -- if src is a fixed reg, then we just map dest to this
- -- reg in the assignment. src must be an allocatable reg,
- -- otherwise it wouldn't be in r_dying.
- _virt -> case lookupUFM assig src of
- Nothing -> panic "raInsn"
- Just loc ->
- setAssigR (addToUFM (delFromUFM assig src) dst loc)
-
- -- we have eliminated this instruction
+ Just (src,dst) | src `elementOfUniqSet` (liveDieRead live),
+ isVirtualReg dst,
+ not (dst `elemUFM` assig),
+ Just (InReg _) <- (lookupUFM assig src) -> do
+ case src of
+ (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr))
+ -- if src is a fixed reg, then we just map dest to this
+ -- reg in the assignment. src must be an allocatable reg,
+ -- otherwise it wouldn't be in r_dying.
+ _virt -> case lookupUFM assig src of
+ Nothing -> panic "raInsn"
+ Just loc ->
+ setAssigR (addToUFM (delFromUFM assig src) dst loc)
+
+ -- we have eliminated this instruction
{-
- freeregs <- getFreeRegsR
- assig <- getAssigR
- pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)
- $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
+ freeregs <- getFreeRegsR
+ assig <- getAssigR
+ pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)
+ $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
-}
- return (new_instrs, [])
+ return (new_instrs, [])
- _ -> genRaInsn block_live new_instrs id instr
- (uniqSetToList $ liveDieRead live)
- (uniqSetToList $ liveDieWrite live)
+ _ -> genRaInsn block_live new_instrs id instr
+ (uniqSetToList $ liveDieRead live)
+ (uniqSetToList $ liveDieWrite live)
raInsn _ _ _ instr
- = pprPanic "raInsn" (text "no match for:" <> ppr instr)
-
+ = pprPanic "raInsn" (text "no match for:" <> ppr instr)
+genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr)
+ => BlockMap RegSet
+ -> [instr]
+ -> BlockId
+ -> instr
+ -> [Reg]
+ -> [Reg]
+ -> RegM freeRegs ([instr], [NatBasicBlock instr])
genRaInsn block_live new_instrs block_id instr r_dying w_dying =
case regUsageOfInstr instr of { RU read written ->
do
- let real_written = [ rr | (RegReal rr) <- written ]
- let virt_written = [ vr | (RegVirtual vr) <- written ]
+ let real_written = [ rr | (RegReal rr) <- written ]
+ let virt_written = [ vr | (RegVirtual vr) <- written ]
-- we don't need to do anything with real registers that are
-- only read by this instr. (the list is typically ~2 elements,
-- so using nub isn't a problem).
- let virt_read = nub [ vr | (RegVirtual vr) <- read ]
+ let virt_read = nub [ vr | (RegVirtual vr) <- read ]
-- (a) save any temporaries which will be clobbered by this instruction
- clobber_saves <- saveClobberedTemps real_written r_dying
+ clobber_saves <- saveClobberedTemps real_written r_dying
-- debugging
{- freeregs <- getFreeRegsR
assig <- getAssigR
- pprTrace "genRaInsn"
- (ppr instr
- $$ text "r_dying = " <+> ppr r_dying
- $$ text "w_dying = " <+> ppr w_dying
- $$ text "virt_read = " <+> ppr virt_read
- $$ text "virt_written = " <+> ppr virt_written
- $$ text "freeregs = " <+> text (show freeregs)
- $$ text "assig = " <+> ppr assig)
- $ do
+ pprTrace "genRaInsn"
+ (ppr instr
+ $$ text "r_dying = " <+> ppr r_dying
+ $$ text "w_dying = " <+> ppr w_dying
+ $$ text "virt_read = " <+> ppr virt_read
+ $$ text "virt_written = " <+> ppr virt_written
+ $$ text "freeregs = " <+> text (show freeregs)
+ $$ text "assig = " <+> ppr assig)
+ $ do
-}
-- (b), (c) allocate real regs for all regs read by this instruction.
- (r_spills, r_allocd) <-
- allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
+ (r_spills, r_allocd) <-
+ allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
-- (d) Update block map for new destinations
-- NB. do this before removing dead regs from the assignment, because
-- these dead regs might in fact be live in the jump targets (they're
-- only dead in the code that follows in the current basic block).
(fixup_blocks, adjusted_instr)
- <- joinToTargets block_live block_id instr
+ <- joinToTargets block_live block_id instr
-- (e) Delete all register assignments for temps which are read
-- (only) and die here. Update the free register list.
clobberRegs real_written
-- (g) Allocate registers for temporaries *written* (only)
- (w_spills, w_allocd) <-
- allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
+ (w_spills, w_allocd) <-
+ allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
-- (h) Release registers for temps which are written here and not
-- used again.
releaseRegs w_dying
let
- -- (i) Patch the instruction
- patch_map
- = listToUFM
- [ (t, RegReal r)
- | (t, r) <- zip virt_read r_allocd
- ++ zip virt_written w_allocd ]
+ -- (i) Patch the instruction
+ patch_map
+ = listToUFM
+ [ (t, RegReal r)
+ | (t, r) <- zip virt_read r_allocd
+ ++ zip virt_written w_allocd ]
- patched_instr
- = patchRegsOfInstr adjusted_instr patchLookup
+ patched_instr
+ = patchRegsOfInstr adjusted_instr patchLookup
- patchLookup x
- = case lookupUFM patch_map x of
- Nothing -> x
- Just y -> y
+ patchLookup x
+ = case lookupUFM patch_map x of
+ Nothing -> x
+ Just y -> y
-- (j) free up stack slots for dead spilled regs
-- TODO (can't be bothered right now)
-- erase reg->reg moves where the source and destination are the same.
- -- If the src temp didn't die in this instr but happened to be allocated
- -- to the same real reg as the destination, then we can erase the move anyway.
- let squashed_instr = case takeRegRegMoveInstr patched_instr of
- Just (src, dst)
- | src == dst -> []
- _ -> [patched_instr]
+ -- If the src temp didn't die in this instr but happened to be allocated
+ -- to the same real reg as the destination, then we can erase the move anyway.
+ let squashed_instr = case takeRegRegMoveInstr patched_instr of
+ Just (src, dst)
+ | src == dst -> []
+ _ -> [patched_instr]
let code = squashed_instr ++ w_spills ++ reverse r_spills
- ++ clobber_saves ++ new_instrs
+ ++ clobber_saves ++ new_instrs
-- pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do
-- pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do
-- -----------------------------------------------------------------------------
-- releaseRegs
+releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs ()
releaseRegs regs = do
assig <- getAssigR
free <- getFreeRegsR
- loop assig free regs
+ loop assig free regs
where
loop _ free _ | free `seq` False = undefined
loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
- loop assig free (RegReal rr : rs) = loop assig (releaseReg rr free) rs
- loop assig free (r:rs) =
+ loop assig free (RegReal rr : rs) = loop assig (frReleaseReg rr free) rs
+ loop assig free (r:rs) =
case lookupUFM assig r of
- Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs
- Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs
- _other -> loop (delFromUFM assig r) free rs
+ Just (InBoth real _) -> loop (delFromUFM assig r) (frReleaseReg real free) rs
+ Just (InReg real) -> loop (delFromUFM assig r) (frReleaseReg real free) rs
+ _other -> loop (delFromUFM assig r) free rs
-- -----------------------------------------------------------------------------
-- Clobber real registers
-- For each temp in a register that is going to be clobbered:
--- - if the temp dies after this instruction, do nothing
--- - otherwise, put it somewhere safe (another reg if possible,
--- otherwise spill and record InBoth in the assignment).
--- - for allocateRegs on the temps *read*,
--- - clobbered regs are allocatable.
+-- - if the temp dies after this instruction, do nothing
+-- - otherwise, put it somewhere safe (another reg if possible,
+-- otherwise spill and record InBoth in the assignment).
+-- - for allocateRegs on the temps *read*,
+-- - clobbered regs are allocatable.
--
--- for allocateRegs on the temps *written*,
--- - clobbered regs are not allocatable.
+-- for allocateRegs on the temps *written*,
+-- - clobbered regs are not allocatable.
--
--- TODO: instead of spilling, try to copy clobbered
--- temps to another register if possible.
+-- TODO: instead of spilling, try to copy clobbered
+-- temps to another register if possible.
--
saveClobberedTemps
- :: (Outputable instr, Instruction instr)
- => [RealReg] -- real registers clobbered by this instruction
- -> [Reg] -- registers which are no longer live after this insn
- -> RegM [instr] -- return: instructions to spill any temps that will
- -- be clobbered.
+ :: (Outputable instr, Instruction instr)
+ => [RealReg] -- real registers clobbered by this instruction
+ -> [Reg] -- registers which are no longer live after this insn
+ -> RegM freeRegs [instr] -- return: instructions to spill any temps that will
+ -- be clobbered.
-saveClobberedTemps [] _
- = return []
+saveClobberedTemps [] _
+ = return []
-saveClobberedTemps clobbered dying
+saveClobberedTemps clobbered dying
= do
- assig <- getAssigR
- let to_spill
- = [ (temp,reg)
- | (temp, InReg reg) <- ufmToList assig
- , any (realRegsAlias reg) clobbered
- , temp `notElem` map getUnique dying ]
+ assig <- getAssigR
+ let to_spill
+ = [ (temp,reg)
+ | (temp, InReg reg) <- ufmToList assig
+ , any (realRegsAlias reg) clobbered
+ , temp `notElem` map getUnique dying ]
- (instrs,assig') <- clobber assig [] to_spill
- setAssigR assig'
- return instrs
+ (instrs,assig') <- clobber assig [] to_spill
+ setAssigR assig'
+ return instrs
where
- clobber assig instrs []
- = return (instrs, assig)
+ clobber assig instrs []
+ = return (instrs, assig)
- clobber assig instrs ((temp, reg) : rest)
- = do
- (spill, slot) <- spillR (RegReal reg) temp
+ clobber assig instrs ((temp, reg) : rest)
+ = do
+ (spill, slot) <- spillR (RegReal reg) temp
- -- record why this reg was spilled for profiling
- recordSpill (SpillClobber temp)
+ -- record why this reg was spilled for profiling
+ recordSpill (SpillClobber temp)
- let new_assign = addToUFM assig temp (InBoth reg slot)
+ let new_assign = addToUFM assig temp (InBoth reg slot)
- clobber new_assign (spill : instrs) rest
+ clobber new_assign (spill : instrs) rest
-- | Mark all these real regs as allocated,
--- and kick out their vreg assignments.
+-- and kick out their vreg assignments.
--
-clobberRegs :: [RealReg] -> RegM ()
-clobberRegs []
- = return ()
+clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs ()
+clobberRegs []
+ = return ()
-clobberRegs clobbered
+clobberRegs clobbered
= do
- freeregs <- getFreeRegsR
- setFreeRegsR $! foldr allocateReg freeregs clobbered
+ freeregs <- getFreeRegsR
+ setFreeRegsR $! foldr frAllocateReg freeregs clobbered
- assig <- getAssigR
- setAssigR $! clobber assig (ufmToList assig)
+ assig <- getAssigR
+ setAssigR $! clobber assig (ufmToList assig)
where
- -- if the temp was InReg and clobbered, then we will have
- -- saved it in saveClobberedTemps above. So the only case
- -- we have to worry about here is InBoth. Note that this
- -- also catches temps which were loaded up during allocation
- -- of read registers, not just those saved in saveClobberedTemps.
-
- clobber assig []
- = assig
-
- clobber assig ((temp, InBoth reg slot) : rest)
- | any (realRegsAlias reg) clobbered
- = clobber (addToUFM assig temp (InMem slot)) rest
-
- clobber assig (_:rest)
- = clobber assig rest
+ -- if the temp was InReg and clobbered, then we will have
+ -- saved it in saveClobberedTemps above. So the only case
+ -- we have to worry about here is InBoth. Note that this
+ -- also catches temps which were loaded up during allocation
+ -- of read registers, not just those saved in saveClobberedTemps.
+
+ clobber assig []
+ = assig
+
+ clobber assig ((temp, InBoth reg slot) : rest)
+ | any (realRegsAlias reg) clobbered
+ = clobber (addToUFM assig temp (InMem slot)) rest
+
+ clobber assig (_:rest)
+ = clobber assig rest
-- -----------------------------------------------------------------------------
-- allocateRegsAndSpill
-- the list of free registers and free stack slots.
allocateRegsAndSpill
- :: (Outputable instr, Instruction instr)
- => Bool -- True <=> reading (load up spilled regs)
- -> [VirtualReg] -- don't push these out
- -> [instr] -- spill insns
- -> [RealReg] -- real registers allocated (accum.)
- -> [VirtualReg] -- temps to allocate
- -> RegM ( [instr]
- , [RealReg])
+ :: (FR freeRegs, Outputable instr, Instruction instr)
+ => Bool -- True <=> reading (load up spilled regs)
+ -> [VirtualReg] -- don't push these out
+ -> [instr] -- spill insns
+ -> [RealReg] -- real registers allocated (accum.)
+ -> [VirtualReg] -- temps to allocate
+ -> RegM freeRegs ( [instr] , [RealReg])
allocateRegsAndSpill _ _ spills alloc []
- = return (spills, reverse alloc)
-
-allocateRegsAndSpill reading keep spills alloc (r:rs)
- = do assig <- getAssigR
- let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig
- case lookupUFM assig r of
- -- case (1a): already in a register
- Just (InReg my_reg) ->
- allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
-
- -- case (1b): already in a register (and memory)
- -- NB1. if we're writing this register, update its assignment to be
- -- InReg, because the memory value is no longer valid.
- -- NB2. This is why we must process written registers here, even if they
- -- are also read by the same instruction.
- Just (InBoth my_reg _)
- -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
- allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
-
- -- Not already in a register, so we need to find a free one...
- Just (InMem slot) | reading -> doSpill (ReadMem slot)
- | otherwise -> doSpill WriteMem
+ = return (spills, reverse alloc)
+
+allocateRegsAndSpill reading keep spills alloc (r:rs)
+ = do assig <- getAssigR
+ let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig
+ case lookupUFM assig r of
+ -- case (1a): already in a register
+ Just (InReg my_reg) ->
+ allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
+
+ -- case (1b): already in a register (and memory)
+ -- NB1. if we're writing this register, update its assignment to be
+ -- InReg, because the memory value is no longer valid.
+ -- NB2. This is why we must process written registers here, even if they
+ -- are also read by the same instruction.
+ Just (InBoth my_reg _)
+ -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
+ allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
+
+ -- Not already in a register, so we need to find a free one...
+ Just (InMem slot) | reading -> doSpill (ReadMem slot)
+ | otherwise -> doSpill WriteMem
Nothing | reading ->
-- pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)
-- ToDo: This case should be a panic, but we
-- will start with an empty assignment.
doSpill WriteNew
- | otherwise -> doSpill WriteNew
-
+ | otherwise -> doSpill WriteNew
+
-- reading is redundant with reason, but we keep it around because it's
-- convenient and it maintains the recursive structure of the allocator. -- EZY
+allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr)
+ => Bool
+ -> [VirtualReg]
+ -> [instr]
+ -> [RealReg]
+ -> VirtualReg
+ -> [VirtualReg]
+ -> UniqFM Loc
+ -> SpillLoc
+ -> RegM freeRegs ([instr], [RealReg])
allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
= do
- freeRegs <- getFreeRegsR
- let freeRegs_thisClass = getFreeRegs (classOfVirtualReg r) freeRegs
+ freeRegs <- getFreeRegsR
+ let freeRegs_thisClass = frGetFreeRegs (classOfVirtualReg r) freeRegs
case freeRegs_thisClass of
- -- case (2): we have a free register
- (my_reg : _) ->
- do spills' <- loadTemp r spill_loc my_reg spills
-
- setAssigR (addToUFM assig r $! newLocation spill_loc my_reg)
- setFreeRegsR $ allocateReg my_reg freeRegs
-
- allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs
-
-
- -- case (3): we need to push something out to free up a register
- [] ->
- do let keep' = map getUnique keep
-
- -- the vregs we could kick out that are already in a slot
- let candidates_inBoth
- = [ (temp, reg, mem)
- | (temp, InBoth reg mem) <- ufmToList assig
- , temp `notElem` keep'
- , targetClassOfRealReg reg == classOfVirtualReg r ]
-
- -- the vregs we could kick out that are only in a reg
- -- this would require writing the reg to a new slot before using it.
- let candidates_inReg
- = [ (temp, reg)
- | (temp, InReg reg) <- ufmToList assig
- , temp `notElem` keep'
- , targetClassOfRealReg reg == classOfVirtualReg r ]
-
- let result
-
- -- we have a temporary that is in both register and mem,
- -- just free up its register for use.
- | (temp, my_reg, slot) : _ <- candidates_inBoth
- = do spills' <- loadTemp r spill_loc my_reg spills
- let assig1 = addToUFM assig temp (InMem slot)
- let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
-
- setAssigR assig2
- allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
-
- -- otherwise, we need to spill a temporary that currently
- -- resides in a register.
- | (temp_to_push_out, (my_reg :: RealReg)) : _
- <- candidates_inReg
- = do
- (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out
- let spill_store = (if reading then id else reverse)
- [ -- COMMENT (fsLit "spill alloc")
- spill_insn ]
-
- -- record that this temp was spilled
- recordSpill (SpillAlloc temp_to_push_out)
-
- -- update the register assignment
- let assig1 = addToUFM assig temp_to_push_out (InMem slot)
- let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
- setAssigR assig2
-
- -- if need be, load up a spilled temp into the reg we've just freed up.
- spills' <- loadTemp r spill_loc my_reg spills
-
- allocateRegsAndSpill reading keep
- (spill_store ++ spills')
- (my_reg:alloc) rs
-
-
- -- there wasn't anything to spill, so we're screwed.
- | otherwise
- = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
- $ vcat
- [ text "allocating vreg: " <> text (show r)
- , text "assignment: " <> text (show $ ufmToList assig)
- , text "freeRegs: " <> text (show freeRegs)
- , text "initFreeRegs: " <> text (show initFreeRegs) ]
-
- result
-
+ -- case (2): we have a free register
+ (my_reg : _) ->
+ do spills' <- loadTemp r spill_loc my_reg spills
+
+ setAssigR (addToUFM assig r $! newLocation spill_loc my_reg)
+ setFreeRegsR $ frAllocateReg my_reg freeRegs
+
+ allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs
+
+
+ -- case (3): we need to push something out to free up a register
+ [] ->
+ do let keep' = map getUnique keep
+
+ -- the vregs we could kick out that are already in a slot
+ let candidates_inBoth
+ = [ (temp, reg, mem)
+ | (temp, InBoth reg mem) <- ufmToList assig
+ , temp `notElem` keep'
+ , targetClassOfRealReg reg == classOfVirtualReg r ]
+
+ -- the vregs we could kick out that are only in a reg
+ -- this would require writing the reg to a new slot before using it.
+ let candidates_inReg
+ = [ (temp, reg)
+ | (temp, InReg reg) <- ufmToList assig
+ , temp `notElem` keep'
+ , targetClassOfRealReg reg == classOfVirtualReg r ]
+
+ let result
+
+ -- we have a temporary that is in both register and mem,
+ -- just free up its register for use.
+ | (temp, my_reg, slot) : _ <- candidates_inBoth
+ = do spills' <- loadTemp r spill_loc my_reg spills
+ let assig1 = addToUFM assig temp (InMem slot)
+ let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
+
+ setAssigR assig2
+ allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
+
+ -- otherwise, we need to spill a temporary that currently
+ -- resides in a register.
+ | (temp_to_push_out, (my_reg :: RealReg)) : _
+ <- candidates_inReg
+ = do
+ (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out
+ let spill_store = (if reading then id else reverse)
+ [ -- COMMENT (fsLit "spill alloc")
+ spill_insn ]
+
+ -- record that this temp was spilled
+ recordSpill (SpillAlloc temp_to_push_out)
+
+ -- update the register assignment
+ let assig1 = addToUFM assig temp_to_push_out (InMem slot)
+ let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
+ setAssigR assig2
+
+ -- if need be, load up a spilled temp into the reg we've just freed up.
+ spills' <- loadTemp r spill_loc my_reg spills
+
+ allocateRegsAndSpill reading keep
+ (spill_store ++ spills')
+ (my_reg:alloc) rs
+
+
+ -- there wasn't anything to spill, so we're screwed.
+ | otherwise
+ = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
+ $ vcat
+ [ text "allocating vreg: " <> text (show r)
+ , text "assignment: " <> text (show $ ufmToList assig)
+ , text "freeRegs: " <> text (show freeRegs)
+ , text "initFreeRegs: " <> text (show (frInitFreeRegs `asTypeOf` freeRegs)) ]
+
+ result
+
-- | Calculate a new location after a register has been loaded.
newLocation :: SpillLoc -> RealReg -> Loc
-- | Load up a spilled temporary if we need to (read from memory).
loadTemp
- :: (Outputable instr, Instruction instr)
- => VirtualReg -- the temp being loaded
- -> SpillLoc -- the current location of this temp
- -> RealReg -- the hreg to load the temp into
- -> [instr]
- -> RegM [instr]
+ :: (Outputable instr, Instruction instr)
+ => VirtualReg -- the temp being loaded
+ -> SpillLoc -- the current location of this temp
+ -> RealReg -- the hreg to load the temp into
+ -> [instr]
+ -> RegM freeRegs [instr]
loadTemp vreg (ReadMem slot) hreg spills
= do
- insn <- loadR (RegReal hreg) slot
- recordSpill (SpillLoad $ getUnique vreg)
- return $ {- COMMENT (fsLit "spill load") : -} insn : spills
+ insn <- loadR (RegReal hreg) slot
+ recordSpill (SpillLoad $ getUnique vreg)
+ return $ {- COMMENT (fsLit "spill load") : -} insn : spills
loadTemp _ _ _ spills =
return spills
import RegAlloc.Linear.Stats
import RegAlloc.Linear.StackMap
import RegAlloc.Linear.Base
-import RegAlloc.Linear.FreeRegs
import RegAlloc.Liveness
import Instruction
import Reg
-- | The RegM Monad
-instance Monad RegM where
+instance Monad (RegM freeRegs) where
m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
return a = RegM $ \s -> (# s, a #)
-- | Run a computation in the RegM register allocator monad.
-runR :: BlockAssignment
- -> FreeRegs
+runR :: BlockAssignment freeRegs
+ -> freeRegs
-> RegMap Loc
-> StackMap
-> UniqSupply
- -> RegM a
- -> (BlockAssignment, StackMap, RegAllocStats, a)
+ -> RegM freeRegs a
+ -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)
runR block_assig freeregs assig stack us thing =
case unReg thing
-- | Make register allocator stats from its final state.
-makeRAStats :: RA_State -> RegAllocStats
+makeRAStats :: RA_State freeRegs -> RegAllocStats
makeRAStats state
= RegAllocStats
{ ra_spillInstrs = binSpillReasons (ra_spills state) }
spillR :: Instruction instr
- => Reg -> Unique -> RegM (instr, Int)
+ => Reg -> Unique -> RegM freeRegs (instr, Int)
spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
let (stack',slot) = getStackSlotFor stack temp
loadR :: Instruction instr
- => Reg -> Int -> RegM instr
+ => Reg -> Int -> RegM freeRegs instr
loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
(# s, mkLoadInstr reg delta slot #)
-getFreeRegsR :: RegM FreeRegs
+getFreeRegsR :: RegM freeRegs freeRegs
getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
(# s, freeregs #)
-setFreeRegsR :: FreeRegs -> RegM ()
+setFreeRegsR :: freeRegs -> RegM freeRegs ()
setFreeRegsR regs = RegM $ \ s ->
(# s{ra_freeregs = regs}, () #)
-getAssigR :: RegM (RegMap Loc)
+getAssigR :: RegM freeRegs (RegMap Loc)
getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
(# s, assig #)
-setAssigR :: RegMap Loc -> RegM ()
+setAssigR :: RegMap Loc -> RegM freeRegs ()
setAssigR assig = RegM $ \ s ->
(# s{ra_assig=assig}, () #)
-getBlockAssigR :: RegM BlockAssignment
+getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
(# s, assig #)
-setBlockAssigR :: BlockAssignment -> RegM ()
+setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()
setBlockAssigR assig = RegM $ \ s ->
(# s{ra_blockassig = assig}, () #)
-setDeltaR :: Int -> RegM ()
+setDeltaR :: Int -> RegM freeRegs ()
setDeltaR n = RegM $ \ s ->
(# s{ra_delta = n}, () #)
-getDeltaR :: RegM Int
+getDeltaR :: RegM freeRegs Int
getDeltaR = RegM $ \s -> (# s, ra_delta s #)
-getUniqueR :: RegM Unique
+getUniqueR :: RegM freeRegs Unique
getUniqueR = RegM $ \s ->
case takeUniqFromSupply (ra_us s) of
(uniq, us) -> (# s{ra_us = us}, uniq #)
-- | Record that a spill instruction was inserted, for profiling.
-recordSpill :: SpillReason -> RegM ()
+recordSpill :: SpillReason -> RegM freeRegs ()
recordSpill spill
= RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)
import Unique
import Control.Monad ( mapAndUnzipM )
-import DynFlags
-- | Top level code generation
cmmTopCodeGen
- :: DynFlags
- -> RawCmmTop
+ :: RawCmmTop
-> NatM [NatCmmTop Instr]
-cmmTopCodeGen _
+cmmTopCodeGen
(CmmProc info lab (ListGraph blocks))
= do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
return tops
-cmmTopCodeGen _ (CmmData sec dat) = do
+cmmTopCodeGen (CmmData sec dat) = do
return [CmmData sec dat] -- no translation, we just use CmmStatic
-}
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
genCCall target dest_regs argsAndHints
= do
+ -- need to remove alignment information
+ let argsAndHints' | (CmmPrim mop) <- target,
+ (mop == MO_Memcpy ||
+ mop == MO_Memset ||
+ mop == MO_Memmove)
+ = init argsAndHints
+
+ | otherwise
+ = argsAndHints
+
-- strip hints from the arg regs
let args :: [CmmExpr]
- args = map hintlessCmm argsAndHints
+ args = map hintlessCmm argsAndHints'
-- work out the arguments, and assign them to integer regs
return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
CmmPrim mop
- -> do res <- outOfLineFloatOp mop
+ -> do res <- outOfLineMachOp mop
lblOrMopExpr <- case res of
Left lbl -> do
return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
-- | Generate a call to implement an out-of-line floating point operation
-outOfLineFloatOp
+outOfLineMachOp
:: CallishMachOp
-> NatM (Either CLabel CmmExpr)
-outOfLineFloatOp mop
+outOfLineMachOp mop
= do let functionName
- = outOfLineFloatOp_table mop
+ = outOfLineMachOp_table mop
dflags <- getDynFlagsNat
mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference
-- | Decide what C function to use to implement a CallishMachOp
--
-outOfLineFloatOp_table
+outOfLineMachOp_table
:: CallishMachOp
-> FastString
-outOfLineFloatOp_table mop
+outOfLineMachOp_table mop
= case mop of
MO_F32_Exp -> fsLit "expf"
MO_F32_Log -> fsLit "logf"
MO_F64_Cosh -> fsLit "cosh"
MO_F64_Tanh -> fsLit "tanh"
- _ -> pprPanic "outOfLineFloatOp(sparc): Unknown callish mach op "
+ MO_Memcpy -> fsLit "memcpy"
+ MO_Memset -> fsLit "memset"
+ MO_Memmove -> fsLit "memmove"
+
+ _ -> pprPanic "outOfLineMachOp(sparc): Unknown callish mach op "
(pprCallishMachOp mop)
pprGloblDecl :: CLabel -> Doc
pprGloblDecl lbl
| not (externallyVisibleCLabel lbl) = empty
- | otherwise = ptext IF_ARCH_sparc((sLit ".global "),
- (sLit ".globl ")) <>
- pprCLabel_asm lbl
+ | otherwise = ptext (sLit ".global ") <> pprCLabel_asm lbl
pprTypeAndSizeDecl :: CLabel -> Doc
#if linux_TARGET_OS
import Outputable
import Unique
import FastTypes
+import Platform
+import qualified X86.Regs as X86
+import qualified X86.RegInfo as X86
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-import qualified X86.Regs as X86
-import qualified X86.RegInfo as X86
+import qualified PPC.Regs as PPC
-#elif powerpc_TARGET_ARCH
-import qualified PPC.Regs as PPC
+import qualified SPARC.Regs as SPARC
-#elif sparc_TARGET_ARCH
-import qualified SPARC.Regs as SPARC
-
-#else
-#error "RegAlloc.Graph.TargetReg: not defined"
-#endif
+-- TODO: We shouldn't be using defaultTargetPlatform here.
+-- We should be passing DynFlags in instead, and looking at
+-- its targetPlatform.
targetVirtualRegSqueeze :: RegClass -> VirtualReg -> FastInt
-targetRealRegSqueeze :: RegClass -> RealReg -> FastInt
-targetClassOfRealReg :: RealReg -> RegClass
-targetWordSize :: Size
-targetMkVirtualReg :: Unique -> Size -> VirtualReg
-targetRegDotColor :: RealReg -> SDoc
-
--- x86 -------------------------------------------------------------------------
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-targetVirtualRegSqueeze = X86.virtualRegSqueeze
-targetRealRegSqueeze = X86.realRegSqueeze
-targetClassOfRealReg = X86.classOfRealReg
-targetWordSize = intSize wordWidth
-targetMkVirtualReg = X86.mkVirtualReg
-targetRegDotColor = X86.regDotColor
-
--- ppc -------------------------------------------------------------------------
-#elif powerpc_TARGET_ARCH
-targetVirtualRegSqueeze = PPC.virtualRegSqueeze
-targetRealRegSqueeze = PPC.realRegSqueeze
-targetClassOfRealReg = PPC.classOfRealReg
-targetWordSize = intSize wordWidth
-targetMkVirtualReg = PPC.mkVirtualReg
-targetRegDotColor = PPC.regDotColor
-
--- sparc -----------------------------------------------------------------------
-#elif sparc_TARGET_ARCH
-targetVirtualRegSqueeze = SPARC.virtualRegSqueeze
-targetRealRegSqueeze = SPARC.realRegSqueeze
-targetClassOfRealReg = SPARC.classOfRealReg
-targetWordSize = intSize wordWidth
-targetMkVirtualReg = SPARC.mkVirtualReg
-targetRegDotColor = SPARC.regDotColor
-
---------------------------------------------------------------------------------
-#else
-#error "RegAlloc.Graph.TargetReg: not defined"
-#endif
+targetVirtualRegSqueeze
+ = case platformArch defaultTargetPlatform of
+ ArchX86 -> X86.virtualRegSqueeze
+ ArchX86_64 -> X86.virtualRegSqueeze
+ ArchPPC -> PPC.virtualRegSqueeze
+ ArchSPARC -> SPARC.virtualRegSqueeze
+ ArchPPC_64 -> panic "targetVirtualRegSqueeze ArchPPC_64"
+ ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown"
+
+targetRealRegSqueeze :: RegClass -> RealReg -> FastInt
+targetRealRegSqueeze
+ = case platformArch defaultTargetPlatform of
+ ArchX86 -> X86.realRegSqueeze
+ ArchX86_64 -> X86.realRegSqueeze
+ ArchPPC -> PPC.realRegSqueeze
+ ArchSPARC -> SPARC.realRegSqueeze
+ ArchPPC_64 -> panic "targetRealRegSqueeze ArchPPC_64"
+ ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown"
+
+targetClassOfRealReg :: RealReg -> RegClass
+targetClassOfRealReg
+ = case platformArch defaultTargetPlatform of
+ ArchX86 -> X86.classOfRealReg
+ ArchX86_64 -> X86.classOfRealReg
+ ArchPPC -> PPC.classOfRealReg
+ ArchSPARC -> SPARC.classOfRealReg
+ ArchPPC_64 -> panic "targetClassOfRealReg ArchPPC_64"
+ ArchUnknown -> panic "targetClassOfRealReg ArchUnknown"
+
+-- TODO: This should look at targetPlatform too
+targetWordSize :: Size
+targetWordSize = intSize wordWidth
+
+targetMkVirtualReg :: Unique -> Size -> VirtualReg
+targetMkVirtualReg
+ = case platformArch defaultTargetPlatform of
+ ArchX86 -> X86.mkVirtualReg
+ ArchX86_64 -> X86.mkVirtualReg
+ ArchPPC -> PPC.mkVirtualReg
+ ArchSPARC -> SPARC.mkVirtualReg
+ ArchPPC_64 -> panic "targetMkVirtualReg ArchPPC_64"
+ ArchUnknown -> panic "targetMkVirtualReg ArchUnknown"
+
+targetRegDotColor :: RealReg -> SDoc
+targetRegDotColor
+ = case platformArch defaultTargetPlatform of
+ ArchX86 -> X86.regDotColor
+ ArchX86_64 -> X86.regDotColor
+ ArchPPC -> PPC.regDotColor
+ ArchSPARC -> SPARC.regDotColor
+ ArchPPC_64 -> panic "targetRegDotColor ArchPPC_64"
+ ArchUnknown -> panic "targetRegDotColor ArchUnknown"
targetClassOfReg :: Reg -> RegClass
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
-----------------------------------------------------------------------------
--
-- Generating machine code (instruction selection)
import X86.Cond
import X86.Regs
import X86.RegInfo
-import X86.Ppr
import Instruction
import PIC
import NCGMonad
import Size
import Reg
-import RegClass
import Platform
-- Our intermediate code:
import BasicTypes
import BlockId
-import PprCmm ( pprExpr )
+import PprCmm ()
import OldCmm
-import OldPprCmm
+import OldPprCmm ()
import CLabel
-import ClosureInfo ( C_SRT(..) )
-- The rest:
import StaticFlags ( opt_PIC )
import ForeignCall ( CCallConv(..) )
import OrdList
-import Pretty
-import qualified Outputable as O
import Outputable
import Unique
import FastString
import Constants ( wORD_SIZE )
import DynFlags
-import Debug.Trace ( trace )
+import Control.Monad ( mapAndUnzipM )
+import Data.Maybe ( catMaybes )
+import Data.Int
-import Control.Monad ( mapAndUnzipM )
-import Data.Maybe ( fromJust )
-import Data.Bits
+#if WORD_SIZE_IN_BITS==32
+import Data.Maybe ( fromJust )
import Data.Word
-import Data.Int
+import Data.Bits
+#endif
sse2Enabled :: NatM Bool
#if x86_64_TARGET_ARCH
if b then sse2 else x87
cmmTopCodeGen
- :: DynFlags
- -> RawCmmTop
+ :: RawCmmTop
-> NatM [NatCmmTop Instr]
-cmmTopCodeGen dynflags (CmmProc info lab (ListGraph blocks)) = do
+cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
picBaseMb <- getPicBaseMaybeNat
+ dflags <- getDynFlagsNat
let proc = CmmProc info lab (ListGraph $ concat nat_blocks)
tops = proc : concat statics
- os = platformOS $ targetPlatform dynflags
+ os = platformOS $ targetPlatform dflags
case picBaseMb of
Just picBase -> initializePicBase_x86 ArchX86 os picBase tops
Nothing -> return tops
-cmmTopCodeGen _ (CmmData sec dat) = do
+cmmTopCodeGen (CmmData sec dat) = do
return [CmmData sec dat] -- no translation, we just use CmmStatic
CmmBranch id -> genBranch id
CmmCondBranch arg id -> genCondJump id arg
CmmSwitch arg ids -> genSwitch arg ids
- CmmJump arg params -> genJump arg
- CmmReturn params ->
+ CmmJump arg _ -> genJump arg
+ CmmReturn _ ->
panic "stmtToInstrs: return statement should have been cps'd away"
= 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.
= ChildCode64
InstrBlock
Reg
+#endif
-- | Register's passed up the tree. If the stix code forces the register
-- Expand CmmRegOff. ToDo: should we do it this way around, or convert
-- CmmExprs into CmmRegOff?
-mangleIndexTree :: CmmExpr -> CmmExpr
-mangleIndexTree (CmmRegOff reg off)
+mangleIndexTree :: CmmReg -> Int -> CmmExpr
+mangleIndexTree reg off
= CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
where width = typeWidth (cmmRegType reg)
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
assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock
-assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
+assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do
ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
let
r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32
vcode `snocOL` mov_lo `snocOL` mov_hi
)
-assignReg_I64Code lvalue valueTree
+assignReg_I64Code _ _
= panic "assignReg_I64Code(i386): invalid lvalue"
-
-
iselExpr64 :: CmmExpr -> NatM ChildCode64
iselExpr64 (CmmLit (CmmInt i _)) = do
(rlo,rhi) <- getNewRegPairNat II32
iselExpr64 expr
= pprPanic "iselExpr64(i386)" (ppr expr)
-
+#endif
--------------------------------------------------------------------------------
return (Fixed size (getRegisterReg use_sse2 reg) nilOL)
-getRegister tree@(CmmRegOff _ _)
- = getRegister (mangleIndexTree tree)
+getRegister (CmmRegOff r n)
+ = getRegister $ mangleIndexTree r n
#if WORD_SIZE_IN_BITS==32
MO_FS_Conv from to -> coerceFP2Int from to x
MO_SF_Conv from to -> coerceInt2FP from to x
- other -> pprPanic "getRegister" (pprMachOp mop)
+ _other -> pprPanic "getRegister" (pprMachOp mop)
where
triv_ucode :: (Size -> Operand -> Instr) -> Size -> NatM Register
triv_ucode instr size = trivialUCode size (instr size) x
return (swizzleRegisterRep e_code new_size)
-getRegister e@(CmmMachOp mop [x, y]) = do -- dyadic MachOps
+getRegister (CmmMachOp mop [x, y]) = do -- dyadic MachOps
sse2 <- sse2Enabled
case mop of
- MO_F_Eq w -> condFltReg EQQ x y
- MO_F_Ne w -> condFltReg NE x y
- MO_F_Gt w -> condFltReg GTT x y
- MO_F_Ge w -> condFltReg GE x y
- MO_F_Lt w -> condFltReg LTT x y
- MO_F_Le w -> condFltReg LE x y
-
- MO_Eq rep -> condIntReg EQQ x y
- MO_Ne rep -> condIntReg NE x y
-
- MO_S_Gt rep -> condIntReg GTT x y
- MO_S_Ge rep -> condIntReg GE x y
- MO_S_Lt rep -> condIntReg LTT x y
- MO_S_Le rep -> condIntReg LE x y
-
- MO_U_Gt rep -> condIntReg GU x y
- MO_U_Ge rep -> condIntReg GEU x y
- MO_U_Lt rep -> condIntReg LU x y
- MO_U_Le rep -> condIntReg LEU x y
+ MO_F_Eq _ -> condFltReg EQQ x y
+ MO_F_Ne _ -> condFltReg NE x y
+ MO_F_Gt _ -> condFltReg GTT x y
+ MO_F_Ge _ -> condFltReg GE x y
+ MO_F_Lt _ -> condFltReg LTT x y
+ MO_F_Le _ -> condFltReg LE x y
+
+ MO_Eq _ -> condIntReg EQQ x y
+ MO_Ne _ -> condIntReg NE x y
+
+ MO_S_Gt _ -> condIntReg GTT x y
+ MO_S_Ge _ -> condIntReg GE x y
+ MO_S_Lt _ -> condIntReg LTT x y
+ MO_S_Le _ -> condIntReg LE x y
+
+ MO_U_Gt _ -> condIntReg GU x y
+ MO_U_Ge _ -> condIntReg GEU x y
+ MO_U_Lt _ -> condIntReg LU x y
+ MO_U_Le _ -> condIntReg LEU x y
MO_F_Add w | sse2 -> trivialFCode_sse2 w ADD x y
- | otherwise -> trivialFCode_x87 w GADD x y
+ | otherwise -> trivialFCode_x87 GADD x y
MO_F_Sub w | sse2 -> trivialFCode_sse2 w SUB x y
- | otherwise -> trivialFCode_x87 w GSUB x y
+ | otherwise -> trivialFCode_x87 GSUB x y
MO_F_Quot w | sse2 -> trivialFCode_sse2 w FDIV x y
- | otherwise -> trivialFCode_x87 w GDIV x y
+ | otherwise -> trivialFCode_x87 GDIV x y
MO_F_Mul w | sse2 -> trivialFCode_sse2 w MUL x y
- | otherwise -> trivialFCode_x87 w GMUL x y
+ | otherwise -> trivialFCode_x87 GMUL x y
MO_Add rep -> add_code rep x y
MO_Sub rep -> sub_code rep x y
MO_U_Shr rep -> shift_code rep SHR x y {-False-}
MO_S_Shr rep -> shift_code rep SAR x y {-False-}
- other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)
+ _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)
where
--------------------
triv_op width instr = trivialCode width op (Just op) x y
-> NatM Register
{- Case1: shift length as immediate -}
- shift_code width instr x y@(CmmLit lit) = do
+ shift_code width instr x (CmmLit lit) = do
x_code <- getAnyReg x
let
size = intSize width
size = intSize width
-- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits
- adj_size = case size of II64 -> II32; _ -> size
- size1 = IF_ARCH_i386( size, adj_size )
+ size1 = IF_ARCH_i386( size, case size of II64 -> II32; _ -> size )
code dst
= unitOL (XOR size1 (OpReg dst) (OpReg dst))
in
--------------------------------------------------------------------------------
getAmode :: CmmExpr -> NatM Amode
-getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree)
+getAmode (CmmRegOff r n) = getAmode $ mangleIndexTree r n
#if x86_64_TARGET_ARCH
-- 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
b@(CmmLit _)])
= getAmode (CmmMachOp (MO_Add rep) [b,a])
-getAmode (CmmMachOp (MO_Add rep) [x, CmmMachOp (MO_Shl _)
+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 rep)
+getAmode (CmmMachOp (MO_Add _)
[x, CmmMachOp (MO_Add _)
[CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)],
CmmLit (CmmInt offset _)]])
&& is32BitInteger offset
= x86_complex_amode x y shift offset
-getAmode (CmmMachOp (MO_Add rep) [x,y])
+getAmode (CmmMachOp (MO_Add _) [x,y])
= x86_complex_amode x y 0 0
getAmode (CmmLit lit) | is32BitLit lit
(y_reg, y_code) <- getSomeReg index
let
code = x_code `appOL` y_code
- base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8
+ 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)))
code)
amodeCouldBeClobbered :: AddrMode -> Bool
amodeCouldBeClobbered amode = any regClobbered (addrModeRegs amode)
+regClobbered :: Reg -> Bool
regClobbered (RegReal (RealRegSingle rr)) = isFastTrue (freeReg rr)
regClobbered _ = False
getOperand e = getOperand_generic e
+getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)
getOperand_generic e = do
(reg, code) <- getSomeReg e
return (OpReg reg, code)
-- use it directly from memory. However, if the literal is
-- zero, we're better off generating it into a register using
-- xor.
+isSuitableFloatingPointLit :: CmmLit -> Bool
isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0
isSuitableFloatingPointLit _ = False
(reg, code) <- getNonClobberedReg e
return (OpReg reg, code)
+is32BitLit :: CmmLit -> Bool
#if x86_64_TARGET_ARCH
is32BitLit (CmmInt i W64) = is32BitInteger i
-- assume that labels are in the range 0-2^31-1: this assumes the
-- small memory model (see gcc docs, -mcmodel=small).
#endif
-is32BitLit x = True
+is32BitLit _ = True
MO_F_Lt W64 -> condFltCode LTT x y
MO_F_Le W64 -> condFltCode LE x y
- MO_Eq rep -> condIntCode EQQ x y
- MO_Ne rep -> condIntCode NE x y
+ MO_Eq _ -> condIntCode EQQ x y
+ MO_Ne _ -> condIntCode NE x y
- MO_S_Gt rep -> condIntCode GTT x y
- MO_S_Ge rep -> condIntCode GE x y
- MO_S_Lt rep -> condIntCode LTT x y
- MO_S_Le rep -> condIntCode LE x y
+ MO_S_Gt _ -> condIntCode GTT x y
+ MO_S_Ge _ -> condIntCode GE x y
+ MO_S_Lt _ -> condIntCode LTT x y
+ MO_S_Le _ -> condIntCode LE x y
- MO_U_Gt rep -> condIntCode GU x y
- MO_U_Ge rep -> condIntCode GEU x y
- MO_U_Lt rep -> condIntCode LU x y
- MO_U_Le rep -> condIntCode LEU x y
+ MO_U_Gt _ -> condIntCode GU x y
+ MO_U_Ge _ -> condIntCode GEU x y
+ MO_U_Lt _ -> condIntCode LU x y
+ MO_U_Le _ -> condIntCode LEU x y
- other -> pprPanic "getCondCode(x86,x86_64,sparc)" (ppr (CmmMachOp mop [x,y]))
+ _other -> pprPanic "getCondCode(x86,x86_64,sparc)" (ppr (CmmMachOp mop [x,y]))
getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (ppr other)
-- anything vs zero, using a mask
-- TODO: Add some sanity checking!!!!
-condIntCode cond (CmmMachOp (MO_And rep) [x,o2]) (CmmLit (CmmInt 0 pk))
- | (CmmLit lit@(CmmInt mask pk2)) <- o2, is32BitLit lit
+condIntCode cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk))
+ | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit lit
= do
(x_reg, x_code) <- getSomeReg x
let
= ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) do
(x_reg, x_code) <- getNonClobberedReg x
(y_reg, y_code) <- getSomeReg y
- use_sse2 <- sse2Enabled
let
code = x_code `appOL` y_code `snocOL`
GCMP cond x_reg y_reg
return (load_code (getRegisterReg False{-no sse2-} reg))
-- dst is a reg, but src could be anything
-assignReg_IntCode pk reg src = do
+assignReg_IntCode _ reg src = do
code <- getAnyReg src
return (code (getRegisterReg False{-no sse2-} reg))
return code
-- Floating point assignment to a register/temporary
-assignReg_FltCode pk reg src = do
+assignReg_FltCode _ reg src = do
use_sse2 <- sse2Enabled
src_code <- getAnyReg src
return (src_code (getRegisterReg use_sse2 reg))
genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
-genJump (CmmLoad mem pk) = do
+genJump (CmmLoad mem _) = do
Amode target code <- getAmode mem
return (code `snocOL` JMP (OpAddr target))
-- 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
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-- 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) [CmmHinted r _] args = do
+genCCall (CmmPrim op) [r_hinted@(CmmHinted r _)] args = do
l1 <- getNewLabelNat
l2 <- getNewLabelNat
sse2 <- sse2Enabled
if sse2
then
- outOfLineFloatOp op r args
+ 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_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args
MO_F64_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args
- other_op -> outOfLineFloatOp op r args
+ _other_op -> outOfLineCmmOp op (Just r_hinted) args
where
actuallyInlineFloatOp instr size [CmmHinted x _]
- = do res <- trivialUFCode size (instr size) 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)
-- deal with static vs dynamic call targets
(callinsns,cconv) <-
case target of
- -- CmmPrim -> ...
CmmCallee (CmmLit (CmmLabel lbl)) conv
-> -- ToDo: stdcall arg sizes
return (unitOL (CALL (Left fn_imm) []), 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_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
-- 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
-genCCall (CmmPrim op) [CmmHinted r _] args =
- outOfLineFloatOp op r 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
-- deal with static vs dynamic call targets
(callinsns,cconv) <-
case target of
- -- CmmPrim -> ...
CmmCallee (CmmLit (CmmLabel lbl)) conv
-> -- ToDo: stdcall arg sizes
return (unitOL (CALL (Left fn_imm) arg_regs), conv)
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
where
rep = localRegType dest
r_dest = getRegisterReg True (CmmLocal dest)
- assign_code many = panic "genCCall.assign_code many"
+ assign_code _many = panic "genCCall.assign_code many"
return (load_args_code `appOL`
adjust_rsp `appOL`
return ((CmmHinted arg hint):args', ars, frs, code')
push_args [] code = return code
- push_args ((CmmHinted arg hint):rest) code
+ push_args ((CmmHinted arg _):rest) code
| isFloatType arg_rep = do
(arg_reg, arg_code) <- getSomeReg arg
delta <- getDeltaNat
#endif /* x86_64_TARGET_ARCH */
-
-
-outOfLineFloatOp :: CallishMachOp -> CmmFormal -> HintedCmmActuals -> NatM InstrBlock
-outOfLineFloatOp mop res args
+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 [CmmHinted res NoHint] args CmmUnsafe CmmMayReturn)
+ 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
+ args' = case mop of
+ MO_Memcpy -> init args
+ MO_Memset -> init args
+ MO_Memmove -> init args
+ _ -> args
+
fn = case mop of
MO_F32_Sqrt -> fsLit "sqrtf"
MO_F32_Sin -> fsLit "sinf"
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 ++ ")"
-- -----------------------------------------------------------------------------
-- conjunction with the hack in PprMach.hs/pprDataItem once
-- binutils 2.17 is standard.
code = e_code `appOL` t_code `appOL` toOL [
- MOVSxL II32
- (OpAddr (AddrBaseIndex (EABaseReg tableReg)
- (EAIndex reg wORD_SIZE) (ImmInt 0)))
- (OpReg reg),
+ MOVSxL II32 op (OpReg reg),
ADD (intSize wordWidth) (OpReg reg) (OpReg tableReg),
JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl
]
= do
(reg,e_code) <- getSomeReg expr
lbl <- getNewLabelNat
- let
- op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl))
+ let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl))
code = e_code `appOL` toOL [
JMP_TBL op ids ReadOnlyData lbl
]
generateJumpTableForInstr (JMP_TBL _ ids section lbl) = Just (createJumpTable ids section lbl)
generateJumpTableForInstr _ = Nothing
+createJumpTable :: [Maybe BlockId] -> Section -> CLabel -> GenCmmTop CmmStatic h g
createJumpTable ids section lbl
= let jumpTable
| opt_PIC =
register happens to be the destination register.
-}
-trivialCode width instr (Just revinstr) (CmmLit lit_a) b
+trivialCode :: Width -> (Operand -> Operand -> Instr)
+ -> Maybe (Operand -> Operand -> Instr)
+ -> CmmExpr -> CmmExpr -> NatM Register
+trivialCode width _ (Just revinstr) (CmmLit lit_a) b
| is32BitLit lit_a = do
b_code <- getAnyReg b
let
-- in
return (Any (intSize width) code)
-trivialCode width instr maybe_revinstr a b
+trivialCode width instr _ a b
= genTrivialCode (intSize width) instr a b
-- This is re-used for floating pt instructions too.
+genTrivialCode :: Size -> (Operand -> Operand -> Instr)
+ -> CmmExpr -> CmmExpr -> NatM Register
genTrivialCode rep instr a b = do
(b_op, b_code) <- getNonClobberedOperand b
a_code <- getAnyReg a
-- in
return (Any rep code)
+regClashesWithOp :: Reg -> Operand -> Bool
reg `regClashesWithOp` OpReg reg2 = reg == reg2
reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)
-reg `regClashesWithOp` _ = False
+_ `regClashesWithOp` _ = False
-----------
+trivialUCode :: Size -> (Operand -> Instr)
+ -> CmmExpr -> NatM Register
trivialUCode rep instr x = do
x_code <- getAnyReg x
let
-----------
-trivialFCode_x87 width instr x y = do
+trivialFCode_x87 :: (Size -> Reg -> Reg -> Reg -> Instr)
+ -> CmmExpr -> CmmExpr -> NatM Register
+trivialFCode_x87 instr x y = do
(x_reg, x_code) <- getNonClobberedReg x -- these work for float regs too
(y_reg, y_code) <- getSomeReg y
let
instr size x_reg y_reg dst
return (Any size code)
+trivialFCode_sse2 :: Width -> (Size -> Operand -> Operand -> Instr)
+ -> CmmExpr -> CmmExpr -> NatM Register
trivialFCode_sse2 pk instr x y
= genTrivialCode size (instr size) x y
where size = floatSize pk
+trivialUFCode :: Size -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUFCode size instr x = do
(x_reg, x_code) <- getSomeReg x
let
coerce_x87 = do
(x_reg, x_code) <- getSomeReg x
let
- opc = case to of W32 -> GITOF; W64 -> GITOD
+ opc = case to of W32 -> GITOF; W64 -> GITOD;
+ n -> panic $ "coerceInt2FP.x87: unhandled width ("
+ ++ show n ++ ")"
code dst = x_code `snocOL` opc x_reg dst
-- ToDo: works for non-II32 reps?
return (Any FF80 code)
(x_op, x_code) <- getOperand x -- ToDo: could be a safe operand
let
opc = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD
+ n -> panic $ "coerceInt2FP.sse: unhandled width ("
+ ++ show n ++ ")"
code dst = x_code `snocOL` opc (intSize from) x_op dst
-- in
return (Any (floatSize to) code)
(x_reg, x_code) <- getSomeReg x
let
opc = case from of W32 -> GFTOI; W64 -> GDTOI
+ n -> panic $ "coerceFP2Int.x87: unhandled width ("
+ ++ show n ++ ")"
code dst = x_code `snocOL` opc x_reg dst
-- ToDo: works for non-II32 reps?
-- in
coerceFP2Int_sse2 = do
(x_op, x_code) <- getOperand x -- ToDo: could be a safe operand
let
- opc = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ
+ opc = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ;
+ n -> panic $ "coerceFP2Init.sse: unhandled width ("
+ ++ show n ++ ")"
code dst = x_code `snocOL` opc (intSize to) x_op dst
-- in
return (Any (intSize to) code)
use_sse2 <- sse2Enabled
(x_reg, x_code) <- getSomeReg x
let
- opc | use_sse2 = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD
+ opc | use_sse2 = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;
+ n -> panic $ "coerceFP2FP: unhandled width ("
+ ++ show n ++ ")"
| otherwise = GDTOF
code dst = x_code `snocOL` opc x_reg dst
-- in
pprGloblDecl :: CLabel -> Doc
pprGloblDecl lbl
| not (externallyVisibleCLabel lbl) = empty
- | otherwise = ptext IF_ARCH_sparc((sLit ".global "),
- (sLit ".globl ")) <>
- pprCLabel_asm lbl
+ | otherwise = ptext (sLit ".globl ") <> pprCLabel_asm lbl
pprTypeAndSizeDecl :: CLabel -> Doc
#if elf_OBJ_FORMAT
pprInstr (COMMENT _) = empty -- nuke 'em
{-
-pprInstr (COMMENT s)
- = IF_ARCH_alpha( ((<>) (ptext (sLit "\t# ")) (ftext s))
- ,IF_ARCH_sparc( ((<>) (ptext (sLit "# ")) (ftext s))
- ,IF_ARCH_i386( ((<>) (ptext (sLit "# ")) (ftext s))
- ,IF_ARCH_x86_64( ((<>) (ptext (sLit "# ")) (ftext s))
- ,IF_ARCH_powerpc( IF_OS_linux(
- ((<>) (ptext (sLit "# ")) (ftext s)),
- ((<>) (ptext (sLit "; ")) (ftext s)))
- ,)))))
+pprInstr (COMMENT s) = ptext (sLit "# ") <> ftext s
-}
pprInstr (DELTA d)
= pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
import Reg
import Outputable
+import Platform
import Unique
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
import UniqFM
import X86.Regs
-#endif
mkVirtualReg :: Unique -> Size -> VirtualReg
FF80 -> VirtualRegD u
_other -> VirtualRegI u
-
--- reg colors for x86
-#if i386_TARGET_ARCH
regDotColor :: RealReg -> SDoc
regDotColor reg
= let Just str = lookupUFM regColors reg
in text str
regColors :: UniqFM [Char]
-regColors
- = listToUFM
- $ [ (eax, "#00ff00")
- , (ebx, "#0000ff")
- , (ecx, "#00ffff")
- , (edx, "#0080ff") ]
- ++ fpRegColors
+regColors = listToUFM (normalRegColors ++ fpRegColors)
--- reg colors for x86_64
-#elif x86_64_TARGET_ARCH
-regDotColor :: RealReg -> SDoc
-regDotColor reg
- = let Just str = lookupUFM regColors reg
- in text str
+-- TODO: We shouldn't be using defaultTargetPlatform here.
+-- We should be passing DynFlags in instead, and looking at
+-- its targetPlatform.
-regColors :: UniqFM [Char]
-regColors
- = listToUFM
- $ [ (rax, "#00ff00"), (eax, "#00ff00")
- , (rbx, "#0000ff"), (ebx, "#0000ff")
- , (rcx, "#00ffff"), (ecx, "#00ffff")
- , (rdx, "#0080ff"), (edx, "#00ffff")
- , (r8, "#00ff80")
- , (r9, "#008080")
- , (r10, "#0040ff")
- , (r11, "#00ff40")
- , (r12, "#008040")
- , (r13, "#004080")
- , (r14, "#004040")
- , (r15, "#002080") ]
- ++ fpRegColors
-#else
-regDotColor :: Reg -> SDoc
-regDotColor = panic "not defined"
-#endif
+normalRegColors :: [(Reg,String)]
+normalRegColors = case platformArch defaultTargetPlatform of
+ ArchX86 -> [ (eax, "#00ff00")
+ , (ebx, "#0000ff")
+ , (ecx, "#00ffff")
+ , (edx, "#0080ff") ]
+ ArchX86_64 -> [ (rax, "#00ff00"), (eax, "#00ff00")
+ , (rbx, "#0000ff"), (ebx, "#0000ff")
+ , (rcx, "#00ffff"), (ecx, "#00ffff")
+ , (rdx, "#0080ff"), (edx, "#00ffff")
+ , (r8, "#00ff80")
+ , (r9, "#008080")
+ , (r10, "#0040ff")
+ , (r11, "#00ff40")
+ , (r12, "#008040")
+ , (r13, "#004080")
+ , (r14, "#004040")
+ , (r15, "#002080") ]
+ ArchPPC -> panic "X86 normalRegColors ArchPPC"
+ ArchPPC_64 -> panic "X86 normalRegColors ArchPPC_64"
+ ArchSPARC -> panic "X86 normalRegColors ArchSPARC"
+ ArchUnknown -> panic "X86 normalRegColors ArchUnknown"
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
fpRegColors :: [(Reg,String)]
fpRegColors =
[ (fake0, "#ff00ff")
, (fake5, "#5500ff") ]
++ zip (map regSingle [24..39]) (repeat "red")
-#endif
+
-- definition, with some hand-coded bits.
--
-- Completely accurate information about token-spans within the source
--- file is maintained. Every token has a start and end SrcLoc attached to it.
+-- file is maintained. Every token has a start and end RealSrcLoc
+-- attached to it.
--
-----------------------------------------------------------------------------
| ITlanguage_prag
| ITvect_prag
| ITvect_scalar_prag
+ | ITnovect_prag
| ITdotdot -- reserved symbols
| ITcolon
| ITparenEscape -- $(
| ITvarQuote -- '
| ITtyQuote -- ''
- | ITquasiQuote (FastString,FastString,SrcSpan) -- [:...|...|]
+ | ITquasiQuote (FastString,FastString,RealSrcSpan) -- [:...|...|]
-- Arrow notation extension
| ITproc
-- -----------------------------------------------------------------------------
-- Lexer actions
-type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token)
+type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token)
special :: Token -> Action
special tok span _buf _len = return (L span tok)
Layout prev_off : _ -> prev_off < offset
_ -> True
if isOK then pop_and open_brace span buf len
- else failSpanMsgP span (text "Missing block")
+ else failSpanMsgP (RealSrcSpan span) (text "Missing block")
pop_and :: Action -> Action
pop_and act span buf len = do _ <- popLexState
nested comments require traversing by hand, they can't be parsed
using regular expressions.
-}
-nested_comment :: P (Located Token) -> Action
+nested_comment :: P (RealLocated Token) -> Action
nested_comment cont span _str _len = do
input <- getInput
go "" (1::Int) input
Just (_,_) -> go ('\123':commentAcc) input docType False
Just (c,input) -> go (c:commentAcc) input docType False
-withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (Located Token))
- -> P (Located Token)
+withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token))
+ -> P (RealLocated Token)
withLexedDocType lexDocComment = do
input@(AI _ buf) <- getInput
case prevChar buf ' ' of
-- called afterwards, so it can just update the state.
docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
- SrcSpan -> P (Located Token)
+ RealSrcSpan -> P (RealLocated Token)
docCommentEnd input commentAcc docType buf span = do
setInput input
let (AI loc nextBuf) = input
comment = reverse commentAcc
- span' = mkSrcSpan (srcSpanStart span) loc
+ span' = mkRealSrcSpan (realSrcSpanStart span) loc
last_len = byteDiff buf nextBuf
span `seq` setLastToken span' last_len
return (L span' (docType comment))
-errBrace :: AlexInput -> SrcSpan -> P a
-errBrace (AI end _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
+errBrace :: AlexInput -> RealSrcSpan -> P a
+errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'"
open_brace, close_brace :: Action
open_brace span _str _len = do
varsym = sym ITvarsym
consym = sym ITconsym
-sym :: (FastString -> Token) -> SrcSpan -> StringBuffer -> Int
- -> P (Located Token)
+sym :: (FastString -> Token) -> RealSrcSpan -> StringBuffer -> Int
+ -> P (RealLocated Token)
sym con span buf len =
case lookupUFM reservedSymsFM fs of
Just (keyword,exts) -> do
setLine :: Int -> Action
setLine code span buf len = do
let line = parseUnsignedInteger buf len 10 octDecDigit
- setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
+ setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
-- subtract one: the line number refers to the *following* line
_ <- popLexState
pushLexState code
setFile :: Int -> Action
setFile code span buf len = do
let file = lexemeToFastString (stepOn buf) (len-2)
- setAlrLastLoc noSrcSpan
- setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
+ setAlrLastLoc $ alrInitialLoc file
+ setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
_ <- popLexState
pushLexState code
lexToken
+alrInitialLoc :: FastString -> RealSrcSpan
+alrInitialLoc file = mkRealSrcSpan loc loc
+ where -- This is a hack to ensure that the first line in a file
+ -- looks like it is after the initial location:
+ loc = mkRealSrcLoc file (-1) (-1)
-- -----------------------------------------------------------------------------
-- Options, includes and language pragmas.
start <- getSrcLoc
tok <- go [] input
end <- getSrcLoc
- return (L (mkSrcSpan start end) tok)
+ return (L (mkRealSrcSpan start end) tok)
where go acc input
= if isString input "#-}"
then do setInput input
= case alexGetChar i of
Just (c,i') | c == x -> isString i' xs
_other -> False
- err (AI end _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma"
+ err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma"
-- -----------------------------------------------------------------------------
lex_string_tok span _buf _len = do
tok <- lex_string ""
end <- getSrcLoc
- return (L (mkSrcSpan (srcSpanStart span) end) tok)
+ return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok)
lex_string :: String -> P Token
lex_string s = do
-- see if there's a trailing quote
lex_char_tok span _buf _len = do -- We've seen '
i1 <- getInput -- Look ahead to first character
- let loc = srcSpanStart span
+ let loc = realSrcSpanStart span
case alexGetChar' i1 of
Nothing -> lit_error i1
th_exts <- extension thEnabled
if th_exts then do
setInput i2
- return (L (mkSrcSpan loc end2) ITtyQuote)
+ return (L (mkRealSrcSpan loc end2) ITtyQuote)
else lit_error i1
Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash
-- If TH is on, just parse the quote only
th_exts <- extension thEnabled
let (AI end _) = i1
- if th_exts then return (L (mkSrcSpan loc end) ITvarQuote)
+ if th_exts then return (L (mkRealSrcSpan loc end) ITvarQuote)
else lit_error i2
-finish_char_tok :: SrcLoc -> Char -> P (Located Token)
+finish_char_tok :: RealSrcLoc -> Char -> P (RealLocated Token)
finish_char_tok loc ch -- We've already seen the closing quote
-- Just need to check for trailing #
= do magicHash <- extension magicHashEnabled
case alexGetChar' i of
Just ('#',i@(AI end _)) -> do
setInput i
- return (L (mkSrcSpan loc end) (ITprimchar ch))
+ return (L (mkRealSrcSpan loc end) (ITprimchar ch))
_other ->
- return (L (mkSrcSpan loc end) (ITchar ch))
+ return (L (mkRealSrcSpan loc end) (ITchar ch))
else do
- return (L (mkSrcSpan loc end) (ITchar ch))
+ return (L (mkRealSrcSpan loc end) (ITchar ch))
isAny :: Char -> Bool
isAny c | c > '\x7f' = isPrint c
quoteStart <- getSrcLoc
quote <- lex_quasiquote ""
end <- getSrcLoc
- return (L (mkSrcSpan (srcSpanStart span) end)
+ return (L (mkRealSrcSpan (realSrcSpanStart span) end)
(ITquasiQuote (mkFastString quoter,
mkFastString (reverse quote),
- mkSrcSpan quoteStart end)))
+ mkRealSrcSpan quoteStart end)))
lex_quasiquote :: String -> P String
lex_quasiquote s = do
warn :: DynFlag -> SDoc -> Action
warn option warning srcspan _buf _len = do
- addWarning option srcspan warning
+ addWarning option (RealSrcSpan srcspan) warning
lexToken
warnThen :: DynFlag -> SDoc -> Action -> Action
warnThen option warning action srcspan buf len = do
- addWarning option srcspan warning
+ addWarning option (RealSrcSpan srcspan) warning
action srcspan buf len
-- -----------------------------------------------------------------------------
buffer :: StringBuffer,
dflags :: DynFlags,
messages :: Messages,
- last_loc :: SrcSpan, -- pos of previous token
+ last_loc :: RealSrcSpan, -- pos of previous token
last_len :: !Int, -- len of previous token
- loc :: SrcLoc, -- current loc (end of prev token + 1)
+ loc :: RealSrcLoc, -- current loc (end of prev token + 1)
extsBitmap :: !Int, -- bitmap that determines permitted extensions
context :: [LayoutContext],
lex_state :: [Int],
-- Used in the alternative layout rule:
-- These tokens are the next ones to be sent out. They are
-- just blindly emitted, without the rule looking at them again:
- alr_pending_implicit_tokens :: [Located Token],
+ alr_pending_implicit_tokens :: [RealLocated Token],
-- This is the next token to be considered or, if it is Nothing,
-- we need to get the next token from the input stream:
- alr_next_token :: Maybe (Located Token),
+ alr_next_token :: Maybe (RealLocated Token),
-- This is what we consider to be the locatino of the last token
-- emitted:
- alr_last_loc :: SrcSpan,
+ alr_last_loc :: RealSrcSpan,
-- The stack of layout contexts:
alr_context :: [ALRContext],
-- Are we expecting a '{'? If it's Just, then the ALRLayout tells
PFailed span err -> PFailed span err
failP :: String -> P a
-failP msg = P $ \s -> PFailed (last_loc s) (text msg)
+failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
failMsgP :: String -> P a
-failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg)
+failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
-failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a
-failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str)
+failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
+failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
failSpanMsgP :: SrcSpan -> SDoc -> P a
failSpanMsgP span msg = P $ \_ -> PFailed span msg
setExts :: (Int -> Int) -> P ()
setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } ()
-setSrcLoc :: SrcLoc -> P ()
+setSrcLoc :: RealSrcLoc -> P ()
setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
incrBracketDepth :: P ()
getParserBrakDepth :: P Int
getParserBrakDepth = P $ \s -> POk s (code_type_bracket_depth s)
-getSrcLoc :: P SrcLoc
+getSrcLoc :: P RealSrcLoc
getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
-setLastToken :: SrcSpan -> Int -> P ()
+setLastToken :: RealSrcSpan -> Int -> P ()
setLastToken loc len = P $ \s -> POk s {
last_loc=loc,
last_len=len
} ()
-data AlexInput = AI SrcLoc StringBuffer
+data AlexInput = AI RealSrcLoc StringBuffer
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (AI _ buf) = prevChar buf '\n'
getLexState :: P Int
getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
-popNextToken :: P (Maybe (Located Token))
+popNextToken :: P (Maybe (RealLocated Token))
popNextToken
= P $ \s@PState{ alr_next_token = m } ->
POk (s {alr_next_token = Nothing}) m
([],Nothing) -> return impt
_other -> return True
-setAlrLastLoc :: SrcSpan -> P ()
+setAlrLastLoc :: RealSrcSpan -> P ()
setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()
-getAlrLastLoc :: P SrcSpan
+getAlrLastLoc :: P RealSrcSpan
getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l
getALRContext :: P [ALRContext]
setJustClosedExplicitLetBlock b
= P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()
-setNextToken :: Located Token -> P ()
+setNextToken :: RealLocated Token -> P ()
setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
implicitTokenPending :: P Bool
[] -> POk s False
_ -> POk s True
-popPendingImplicitToken :: P (Maybe (Located Token))
+popPendingImplicitToken :: P (Maybe (RealLocated Token))
popPendingImplicitToken
= P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
case ts of
[] -> POk s Nothing
(t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)
-setPendingImplicitTokens :: [Located Token] -> P ()
+setPendingImplicitTokens :: [RealLocated Token] -> P ()
setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()
getAlrExpectingOCurly :: P (Maybe ALRLayout)
-- PState for parsing options pragmas
--
-pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState
+pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
pragState dynflags buf loc = (mkPState dynflags buf loc) {
lex_state = [bol, option_prags, 0]
}
-- create a parse state
--
-mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
+mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState flags buf loc =
PState {
buffer = buf,
dflags = flags,
messages = emptyMessages,
- last_loc = mkSrcSpan loc loc,
+ last_loc = mkRealSrcSpan loc loc,
last_len = 0,
loc = loc,
extsBitmap = fromIntegral bitmap,
lex_state = [bol, 0],
alr_pending_implicit_tokens = [],
alr_next_token = Nothing,
- alr_last_loc = noSrcSpan,
+ alr_last_loc = alrInitialLoc (fsLit "<no file>"),
alr_context = [],
alr_expecting_ocurly = Nothing,
alr_justClosedExplicitLetBlock = False,
last_len = len, last_loc = last_loc }) ->
case ctx of
(_:tl) -> POk s{ context = tl } ()
- [] -> PFailed last_loc (srcParseErr buf len)
+ [] -> PFailed (RealSrcSpan last_loc) (srcParseErr buf len)
-- Push a new layout context at the indentation of the last token read.
-- This is only used at the outer level of a module when the 'module'
srcParseFail :: P a
srcParseFail = P $ \PState{ buffer = buf, last_len = len,
last_loc = last_loc } ->
- PFailed last_loc (srcParseErr buf len)
+ PFailed (RealSrcSpan last_loc) (srcParseErr buf len)
-- A lexical error is reported at a particular position in the source file,
-- not over a token range.
lexer cont = do
alr <- extension alternativeLayoutRule
let lexTokenFun = if alr then lexTokenAlr else lexToken
- tok@(L _span _tok__) <- lexTokenFun
- --trace ("token: " ++ show _tok__) $ do
- cont tok
+ (L span tok) <- lexTokenFun
+ --trace ("token: " ++ show tok) $ do
+ cont (L (RealSrcSpan span) tok)
-lexTokenAlr :: P (Located Token)
+lexTokenAlr :: P (RealLocated Token)
lexTokenAlr = do mPending <- popPendingImplicitToken
t <- case mPending of
Nothing ->
_ -> return ()
return t
-alternativeLayoutRuleToken :: Located Token -> P (Located Token)
+alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token)
alternativeLayoutRuleToken t
= do context <- getALRContext
lastLoc <- getAlrLastLoc
let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags
thisLoc = getLoc t
thisCol = srcSpanStartCol thisLoc
- newLine = (lastLoc == noSrcSpan)
- || (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc)
+ newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc
case (unLoc t, context, mExpectingOCurly) of
-- This case handles a GHC extension to the original H98
-- layout rule...
(ITwhere, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
do addWarning Opt_WarnAlternativeLayoutRuleTransitional
- thisLoc
+ (RealSrcSpan thisLoc)
(transitionalAlternativeLayoutWarning
"`where' clause at the same depth as implicit layout block")
setALRContext ls
(ITvbar, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
do addWarning Opt_WarnAlternativeLayoutRuleTransitional
- thisLoc
+ (RealSrcSpan thisLoc)
(transitionalAlternativeLayoutWarning
"`|' at the same depth as implicit layout block")
setALRContext ls
topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b
-lexToken :: P (Located Token)
+lexToken :: P (RealLocated Token)
lexToken = do
inp@(AI loc1 buf) <- getInput
sc <- getLexState
exts <- getExts
case alexScanUser exts inp sc of
AlexEOF -> do
- let span = mkSrcSpan loc1 loc1
+ let span = mkRealSrcSpan loc1 loc1
setLastToken span 0
return (L span ITeof)
AlexError (AI loc2 buf) ->
lexToken
AlexToken inp2@(AI end buf2) _ t -> do
setInput inp2
- let span = mkSrcSpan loc1 end
+ let span = mkRealSrcSpan loc1 end
let bytes = byteDiff buf buf2
span `seq` setLastToken span bytes
t span buf bytes
-reportLexError :: SrcLoc -> SrcLoc -> StringBuffer -> [Char] -> P a
+reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
reportLexError loc1 loc2 buf str
| atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
| otherwise =
then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
-lexTokenStream :: StringBuffer -> SrcLoc -> DynFlags -> ParseResult [Located Token]
+lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
lexTokenStream buf loc dflags = unP go initState
where dflags' = dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
initState = mkPState dflags' buf loc
("core", token ITcore_prag),
("unpack", token ITunpack_prag),
("ann", token ITann_prag),
- ("vectorize", token ITvect_prag)])
+ ("vectorize", token ITvect_prag),
+ ("novectorize", token ITnovect_prag)])
twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),
("notinline conlike", token (ITinline_prag NoInline ConLike)),
"noinline" -> "notinline"
"specialise" -> "specialize"
"vectorise" -> "vectorize"
+ "novectorise" -> "novectorize"
"constructorlike" -> "conlike"
_ -> prag'
canon_ws s = unwords (map canonical (words s))
)
import OccName ( varName, varNameDepth, dataName, tcClsName, tvName )
import DataCon ( DataCon, dataConName )
-import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
- SrcSpan, combineLocs, srcLocFile,
- mkSrcLoc, mkSrcSpan )
+import SrcLoc
import Module
import StaticFlags ( opt_SccProfilingOn, opt_Hpc )
import Type ( Kind, liftedTypeKind, unliftedTypeKind )
'by' { L _ ITby } -- for list transform extension
'using' { L _ ITusing } -- for list transform extension
- '{-# INLINE' { L _ (ITinline_prag _ _) }
- '{-# SPECIALISE' { L _ ITspec_prag }
+ '{-# INLINE' { L _ (ITinline_prag _ _) }
+ '{-# SPECIALISE' { L _ ITspec_prag }
'{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) }
- '{-# SOURCE' { L _ ITsource_prag }
- '{-# RULES' { L _ ITrules_prag }
- '{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core
- '{-# SCC' { L _ ITscc_prag }
- '{-# GENERATED' { L _ ITgenerated_prag }
- '{-# DEPRECATED' { L _ ITdeprecated_prag }
- '{-# WARNING' { L _ ITwarning_prag }
- '{-# UNPACK' { L _ ITunpack_prag }
- '{-# ANN' { L _ ITann_prag }
+ '{-# SOURCE' { L _ ITsource_prag }
+ '{-# RULES' { L _ ITrules_prag }
+ '{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core
+ '{-# SCC' { L _ ITscc_prag }
+ '{-# GENERATED' { L _ ITgenerated_prag }
+ '{-# DEPRECATED' { L _ ITdeprecated_prag }
+ '{-# WARNING' { L _ ITwarning_prag }
+ '{-# UNPACK' { L _ ITunpack_prag }
+ '{-# ANN' { L _ ITann_prag }
'{-# VECTORISE' { L _ ITvect_prag }
'{-# VECTORISE_SCALAR' { L _ ITvect_scalar_prag }
- '#-}' { L _ ITclose_prag }
+ '{-# NOVECTORISE' { L _ ITnovect_prag }
+ '#-}' { L _ ITclose_prag }
'..' { L _ ITdotdot } -- reserved symbols
':' { L _ ITcolon }
-- Top-Level Declarations
topdecls :: { OrdList (LHsDecl RdrName) }
- : topdecls ';' topdecl { $1 `appOL` $3 }
- | topdecls ';' { $1 }
- | topdecl { $1 }
+ : topdecls ';' topdecl { $1 `appOL` $3 }
+ | topdecls ';' { $1 }
+ | topdecl { $1 }
topdecl :: { OrdList (LHsDecl RdrName) }
- : cl_decl { unitOL (L1 (TyClD (unLoc $1))) }
- | ty_decl { unitOL (L1 (TyClD (unLoc $1))) }
- | 'instance' inst_type where_inst
- { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
- in
- unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))}
+ : cl_decl { unitOL (L1 (TyClD (unLoc $1))) }
+ | ty_decl { unitOL (L1 (TyClD (unLoc $1))) }
+ | 'instance' inst_type where_inst
+ { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
+ in
+ unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))}
| stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) }
- | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
- | 'foreign' fdecl { unitOL (LL (unLoc $2)) }
+ | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
+ | 'foreign' fdecl { unitOL (LL (unLoc $2)) }
| '{-# DEPRECATED' deprecations '#-}' { $2 }
| '{-# WARNING' warnings '#-}' { $2 }
- | '{-# RULES' rules '#-}' { $2 }
- | '{-# VECTORISE_SCALAR' qvar '#-}' { unitOL $ LL $ VectD (HsVect $2 Nothing) }
- | '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 (Just $4)) }
- | annotation { unitOL $1 }
- | decl { unLoc $1 }
-
- -- Template Haskell Extension
- -- The $(..) form is one possible form of infixexp
- -- but we treat an arbitrary expression just as if
- -- it had a $(..) wrapped around it
- | infixexp { unitOL (LL $ mkTopSpliceDecl $1) }
+ | '{-# RULES' rules '#-}' { $2 }
+ | '{-# VECTORISE_SCALAR' qvar '#-}' { unitOL $ LL $ VectD (HsVect $2 Nothing) }
+ | '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 (Just $4)) }
+ | '{-# NOVECTORISE' qvar '#-}' { unitOL $ LL $ VectD (HsNoVect $2) }
+ | annotation { unitOL $1 }
+ | decl { unLoc $1 }
+
+ -- Template Haskell Extension
+ -- The $(..) form is one possible form of infixexp
+ -- but we treat an arbitrary expression just as if
+ -- it had a $(..) wrapped around it
+ | infixexp { unitOL (LL $ mkTopSpliceDecl $1) }
-- Type classes
--
: TH_QUASIQUOTE { let { loc = getLoc $1
; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1
; quoterId = mkUnqual varName quoter }
- in L1 (mkHsQuasiQuote quoterId quoteSpan quote) }
+ in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
incdepth :: { Located () } : {% do { incrBracketDepth ; return $ noLoc () } }
decdepth :: { Located () } : {% do { decrBracketDepth ; return $ noLoc () } }
gHC_HETMET_PRIVATE,
gHC_HETMET_GARROW,
gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE,
- gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception,
- gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL,
+ gHC_CONC, gHC_IO, gHC_IO_Exception,
+ gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, gENERICS,
dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_GROUP, mONAD_ZIP,
aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
dATA_STRING = mkBaseModule (fsLit "Data.String")
dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable")
dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable")
-gHC_PACK = mkBaseModule (fsLit "GHC.Pack")
gHC_CONC = mkBaseModule (fsLit "GHC.Conc")
gHC_IO = mkBaseModule (fsLit "GHC.IO")
gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception")
gHC_ST = mkBaseModule (fsLit "GHC.ST")
gHC_ARR = mkBaseModule (fsLit "GHC.Arr")
gHC_STABLE = mkBaseModule (fsLit "GHC.Stable")
-gHC_ADDR = mkBaseModule (fsLit "GHC.Addr")
gHC_PTR = mkBaseModule (fsLit "GHC.Ptr")
gHC_ERR = mkBaseModule (fsLit "GHC.Err")
gHC_REAL = mkBaseModule (fsLit "GHC.Real")
-- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName!
-- The latter does pickGREs, but we want to allow 'x'
-- even if only 'M.x' is in scope
- [gre] -> do { addUsedRdrNames (used_rdr_names gre)
+ [gre] -> do { addUsedRdrName gre (used_rdr_name gre)
; return (gre_name gre) }
[] -> do { addErr (unknownSubordinateErr doc rdr_name)
; traceRn (text "RnEnv.lookup_sub_bndr" <+> (ppr rdr_name $$ ppr gres))
gres -> do { addNameClashErrRn rdr_name gres
; return (gre_name (head gres)) } }
where
+ rdr_occ = rdrNameOcc rdr_name
+
pick NoParent gres -- Normal lookup
= pickGREs rdr_name gres
pick (ParentIs p) gres -- Disambiguating lookup
right_parent _ _ = False
-- Note [Usage for sub-bndrs]
- used_rdr_names gre
- | isQual rdr_name = [rdr_name]
+ used_rdr_name gre
+ | isQual rdr_name = rdr_name
| otherwise = case gre_prov gre of
- LocalDef -> [rdr_name]
- Imported is -> map mk_qual_rdr is
- mk_qual_rdr imp_spec = mkRdrQual (is_as (is_decl imp_spec)) rdr_occ
- rdr_occ = rdrNameOcc rdr_name
+ LocalDef -> rdr_name
+ Imported is -> used_rdr_name_from_is is
+
+ used_rdr_name_from_is imp_specs -- rdr_name is unqualified
+ | not (all (is_qual . is_decl) imp_specs)
+ = rdr_name -- An unqualified import is available
+ | otherwise
+ = -- Only qualified imports available, so make up
+ -- a suitable qualifed name from the first imp_spec
+ ASSERT( not (null imp_specs) )
+ mkRdrQual (is_as (is_decl (head imp_specs))) rdr_occ
newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
~~~~~~~~~~~~~~~~~~~~~~~~~~
If you have this
import qualified M( C( f ) )
- intance M.C T where
+ instance M.C T where
f x = x
then is the qualified import M.f used? Obviously yes.
But the RdrName used in the instance decl is unqualified. In effect,
we fill in the qualification by looking for f's whose class is M.C
But when adding to the UsedRdrNames we must make that qualification
-explicit, otherwise we get "Redundant import of M.C".
+explicit (saying "used M.f"), otherwise we get "Redundant import of M.f".
+
+So we make up a suitable (fake) RdrName. But be careful
+ import qualifed M
+ import M( C(f) )
+ instance C T where
+ f x = x
+Here we want to record a use of 'f', not of 'M.f', otherwise
+we'll miss the fact that the qualified import is redundant.
--------------------------------------------------
-- Occurrences
where
pp_item :: (RdrName, HowInScope) -> SDoc
pp_item (rdr, Left loc) = quotes (ppr rdr) <+> -- Locally defined
- parens (ptext (sLit "line") <+> int (srcSpanStartLine loc))
+ parens (ptext (sLit "line") <+> int (srcSpanStartLine loc'))
+ where loc' = case loc of
+ UnhelpfulSpan _ ->
+ panic "unknownNameSuggestErr UnhelpfulSpan"
+ RealSrcSpan l -> l
pp_item (rdr, Right is) = quotes (ppr rdr) <+> -- Imported
parens (ptext (sLit "imported from") <+> ppr (is_mod is))
import TcRnTypes
import HsSyn
-import SrcLoc ( Located(..) )
+import SrcLoc
rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString)
import Name ( Name, getName, isTyVarName )
import NameSet
import BasicTypes ( Boxity )
-import SrcLoc ( Located(..), unLoc )
+import SrcLoc
\end{code}
%************************************************************************
type ExportAccum -- The type of the accumulating parameter of
-- the main worker function in rnExports
= ([LIE Name], -- Export items with Names
- ExportOccMap, -- Tracks exported occurrence names
+ ExportOccMap, -- Tracks exported occurrence names
[AvailInfo]) -- The accumulated exported stuff
-- Not nub'd!
exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum
exports_from_item acc@(ie_names, occs, exports)
- (L loc ie@(IEModuleContents mod))
+ (L loc (IEModuleContents mod))
| let earlier_mods = [ mod | (L _ (IEModuleContents mod)) <- ie_names ]
, mod `elem` earlier_mods -- Duplicate export of M
= do { warn_dup_exports <- doptM Opt_WarnDuplicateExports ;
-- The qualified and unqualified version of all of
-- these names are, in effect, used by this export
- ; occs' <- check_occs ie occs names
+ ; occs' <- check_occs (IEModuleContents mod) occs names
-- This check_occs not only finds conflicts
-- between this item and others, but also
-- internally within this item. That is, if
-------------------------------
check_occs :: IE RdrName -> ExportOccMap -> [Name] -> RnM ExportOccMap
-check_occs ie occs names
+check_occs ie occs names -- 'names' are the entities specifed by 'ie'
= foldlM check occs names
where
check occs name
| name == name' -- Duplicate export
-- But we don't want to warn if the same thing is exported
-- by two different module exports. See ticket #4478.
- -> do unless (diffModules ie ie') $ do
+ -> do unless (dupExport_ok name ie ie') $ do
warn_dup_exports <- doptM Opt_WarnDuplicateExports
warnIf warn_dup_exports (dupExportWarn name_occ ie ie')
return occs
return occs }
where
name_occ = nameOccName name
- -- True if the two IE RdrName are different module exports.
- diffModules (IEModuleContents n1) (IEModuleContents n2) = n1 /= n2
- diffModules _ _ = False
+
+
+dupExport_ok :: Name -> IE RdrName -> IE RdrName -> Bool
+-- The Name is exported by both IEs. Is that ok?
+-- "No" iff the name is mentioned explicitly in both IEs
+-- or one of the IEs mentions the name *alone*
+-- "Yes" otherwise
+--
+-- Examples of "no": module M( f, f )
+-- module M( fmap, Functor(..) )
+-- module M( module Data.List, head )
+--
+-- Example of "yes"
+-- module M( module A, module B ) where
+-- import A( f )
+-- import B( f )
+--
+-- Example of "yes" (Trac #2436)
+-- module M( C(..), T(..) ) where
+-- class C a where { data T a }
+-- instace C Int where { data T Int = TInt }
+--
+-- Example of "yes" (Trac #2436)
+-- module Foo ( T ) where
+-- data family T a
+-- module Bar ( T(..), module Foo ) where
+-- import Foo
+-- data instance T Int = TInt
+
+dupExport_ok n ie1 ie2
+ = not ( single ie1 || single ie2
+ || (explicit_in ie1 && explicit_in ie2) )
+ where
+ explicit_in (IEModuleContents _) = False -- module M
+ explicit_in (IEThingAll r) = nameOccName n == rdrNameOcc r -- T(..)
+ explicit_in _ = True
+
+ single (IEVar {}) = True
+ single (IEThingAbs {}) = True
+ single _ = False
\end{code}
%*********************************************************
; let usage :: [ImportDeclUsage]
usage = findImportUsage imports rdr_env (Set.elems uses)
+ ; traceRn (ptext (sLit "Import usage") <+> ppr usage)
; ifDOptM Opt_WarnUnusedImports $
mapM_ warnUnusedImport usage
; ifDOptM Opt_D_dump_minimal_imports $
printMinimalImports usage }
where
- explicit_import (L loc _) = isGoodSrcSpan loc
+ explicit_import (L loc _) = case loc of
+ UnhelpfulSpan _ -> False
+ RealSrcSpan _ -> True
-- Filter out the implicit Prelude import
-- which we do not want to bleat about
\end{code}
; (rhs', fv_rhs) <- rnLExpr rhs
; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var')
}
+rnHsVectDecl (HsNoVect var)
+ = do { var' <- wrapLocM lookupTopBndrRn var
+ ; return (HsNoVect var', unitFV (unLoc var'))
+ }
\end{code}
%*********************************************************
Here's the externally-callable interface:
\begin{code}
-occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule]
+occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule] -> [CoreVect]
-> [CoreBind] -> [CoreBind]
-occurAnalysePgm active_rule imp_rules binds
+occurAnalysePgm active_rule imp_rules vects binds
= snd (go (initOccEnv active_rule imp_rules) binds)
where
- initial_uds = addIdOccs emptyDetails (rulesFreeVars imp_rules)
- -- The RULES keep things alive!
+ initial_uds = addIdOccs emptyDetails
+ (rulesFreeVars imp_rules `unionVarSet` vectsFreeVars vects)
+ -- The RULES and VECTORISE declarations keep things alive!
go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
go _ []
import FloatOut ( floatOutwards )
import FamInstEnv
import Id
-import BasicTypes ( CompilerPhase, isDefaultInlinePragma )
+import BasicTypes
import VarSet
import VarEnv
import LiberateCase ( liberateCase )
-- space usage, especially with -O. JRS, 000620.
| let sz = coreBindsSize binds in sz == sz
= do {
- -- Occurrence analysis
- let { tagged_binds = {-# SCC "OccAnal" #-}
- occurAnalysePgm active_rule rules binds } ;
- Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
- (pprCoreBindings tagged_binds);
+ -- Occurrence analysis
+ let { -- During the 'InitialPhase' (i.e., before vectorisation), we need to make sure
+ -- that the right-hand sides of vectorisation declarations are taken into
+ -- account during occurence analysis.
+ maybeVects = case sm_phase mode of
+ InitialPhase -> mg_vect_decls guts
+ _ -> []
+ ; tagged_binds = {-# SCC "OccAnal" #-}
+ occurAnalysePgm active_rule rules maybeVects binds
+ } ;
+ Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
+ (pprCoreBindings tagged_binds);
-- Get any new rules, and extend the rule base
-- See Note [Overall plumbing for rules] in Rules.lhs
--------------
tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
+-- SPECIALISE pragamas for imported things
tcImpPrags prags
= do { this_mod <- getModule
- ; mapAndRecoverM (wrapLocM tcImpSpec)
- [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
- , not (nameIsLocalOrFrom this_mod name) ] }
+ ; dflags <- getDOpts
+ ; if (not_specialising dflags) then
+ return []
+ else
+ mapAndRecoverM (wrapLocM tcImpSpec)
+ [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
+ , not (nameIsLocalOrFrom this_mod name) ] }
+ where
+ -- Ignore SPECIALISE pragmas for imported things
+ -- when we aren't specialising, or when we aren't generating
+ -- code. The latter happens when Haddocking the base library;
+ -- we don't wnat complaints about lack of INLINABLE pragmas
+ not_specialising dflags
+ | not (dopt Opt_Specialise dflags) = True
+ | otherwise = case hscTarget dflags of
+ HscNothing -> True
+ HscInterpreted -> True
+ _other -> False
tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag
tcImpSpec (name, prag)
= do { id <- tcLookupId name
- ; checkTc (isAnyInlinePragma (idInlinePragma id))
- (impSpecErr name)
+ ; unless (isAnyInlinePragma (idInlinePragma id))
+ (addWarnTc (impSpecErr name))
; tcSpec id prag }
impSpecErr :: Name -> SDoc
impSpecErr name
= hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
- , ptext (sLit "(or you compiled its defining module without -O)")])
+ , parens $ sep
+ [ ptext (sLit "or its defining module") <+> quotes (ppr mod)
+ , ptext (sLit "was compiled without -O")]])
+ where
+ mod = nameModule name
--------------
-tcVectDecls :: [LVectDecl Name] -> TcM [LVectDecl TcId]
+tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
tcVectDecls decls
= do { decls' <- mapM (wrapLocM tcVect) decls
- ; let ids = [unLoc id | L _ (HsVect id _) <- decls']
+ ; let ids = map lvectDeclName decls'
dups = findDupsEq (==) ids
; mapM_ reportVectDups dups
+ ; traceTcConstraints "End of tcVectDecls"
; return decls'
}
where
tcVect (HsVect name Nothing)
= addErrCtxt (vectCtxt name) $
do { id <- wrapLocM tcLookupId name
- ; return (HsVect id Nothing)
+ ; return $ HsVect id Nothing
}
tcVect (HsVect name@(L loc _) (Just rhs))
= addErrCtxt (vectCtxt name) $
; (binds, [id']) <- tcPolyInfer TopLevel False sigFun pragFun NonRecursive [bind]
; traceTc "tcVect inferred type" $ ppr (varType id')
+ ; traceTc "tcVect bindings" $ ppr binds
- -- add the type variable and dictionary bindings produced by type generalisation to the
- -- right-hand side of the vectorisation declaration
+ -- add all bindings, including the type variable and dictionary bindings produced by type
+ -- generalisation to the right-hand side of the vectorisation declaration
; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
; let [bind'] = bagToList actualBinds
MatchGroup
-- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls
; return $ HsVect (L loc id') (Just rhsWrapped)
}
+tcVect (HsNoVect name)
+ = addErrCtxt (vectCtxt name) $
+ do { id <- wrapLocM tcLookupId name
+ ; return $ HsNoVect id
+ }
vectCtxt :: Located Name -> SDoc
vectCtxt name = ptext (sLit "When checking the vectorisation declaration for") <+> ppr name
module TcCanonical(
mkCanonical, mkCanonicals, mkCanonicalFEV, mkCanonicalFEVs, canWanteds, canGivens,
canOccursCheck, canEqToWorkList,
- rewriteWithFunDeps
+ rewriteWithFunDeps, mkCanonicalFDAsDerived, mkCanonicalFDAsWanted
) where
#include "HsVersions.h"
import Var
import VarEnv ( TidyEnv )
import Outputable
-import Control.Monad ( unless, when, zipWithM, zipWithM_ )
+import Control.Monad ( unless, when, zipWithM, zipWithM_, foldM )
import MonadUtils
import Control.Applicative ( (<|>) )
\begin{code}
rewriteWithFunDeps :: [Equation]
- -> [Xi] -> CtFlavor
- -> TcS (Maybe ([Xi], [Coercion], WorkList))
-rewriteWithFunDeps eqn_pred_locs xis fl
- = do { fd_ev_poss <- mapM (instFunDepEqn fl) eqn_pred_locs
- ; let fd_ev_pos :: [(Int,FlavoredEvVar)]
+ -> [Xi]
+ -> WantedLoc
+ -> TcS (Maybe ([Xi], [Coercion], [(EvVar,WantedLoc)]))
+ -- Not quite a WantedEvVar unfortunately
+ -- Because our intention could be to make
+ -- it derived at the end of the day
+-- NB: The flavor of the returned EvVars will be decided by the caller
+-- Post: returns no trivial equalities (identities)
+rewriteWithFunDeps eqn_pred_locs xis wloc
+ = do { fd_ev_poss <- mapM (instFunDepEqn wloc) eqn_pred_locs
+ ; let fd_ev_pos :: [(Int,(EvVar,WantedLoc))]
fd_ev_pos = concat fd_ev_poss
(rewritten_xis, cos) = unzip (rewriteDictParams fd_ev_pos xis)
- ; fds <- mapM (\(_,fev) -> mkCanonicalFEV fev) fd_ev_pos
- ; let fd_work = unionWorkLists fds
- ; if isEmptyWorkList fd_work
- then return Nothing
- else return (Just (rewritten_xis, cos, fd_work)) }
-
-instFunDepEqn :: CtFlavor -- Precondition: Only Wanted or Derived
- -> Equation
- -> TcS [(Int, FlavoredEvVar)]
+ ; if null fd_ev_pos then return Nothing
+ else return (Just (rewritten_xis, cos, map snd fd_ev_pos)) }
+
+instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,(EvVar,WantedLoc))]
-- Post: Returns the position index as well as the corresponding FunDep equality
-instFunDepEqn fl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs
+instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs
, fd_pred1 = d1, fd_pred2 = d2 })
= do { let tvs = varSetElems qtvs
; tvs' <- mapM instFlexiTcS tvs
; let subst = zipTopTvSubst tvs (mkTyVarTys tvs')
- ; mapM (do_one subst) eqs }
+ ; foldM (do_one subst) [] eqs }
where
- fl' = case fl of
- Given {} -> panic "mkFunDepEqns"
- Wanted loc -> Wanted (push_ctx loc)
- Derived loc -> Derived (push_ctx loc)
-
+ do_one subst ievs (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 })
+ = let sty1 = Type.substTy subst ty1
+ sty2 = Type.substTy subst ty2
+ in if eqType sty1 sty2 then return ievs -- Return no trivial equalities
+ else do { ev <- newCoVar sty1 sty2
+ ; let wl' = push_ctx wl
+ ; return $ (i,(ev,wl')):ievs }
+
+ push_ctx :: WantedLoc -> WantedLoc
push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc
- do_one subst (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 })
- = do { let sty1 = Type.substTy subst ty1
- sty2 = Type.substTy subst ty2
- ; ev <- newCoVar sty1 sty2
- ; return (i, mkEvVarX ev fl') }
-
-rewriteDictParams :: [(Int,FlavoredEvVar)] -- A set of coercions : (pos, ty' ~ ty)
- -> [Type] -- A sequence of types: tys
- -> [(Type,Coercion)] -- Returns : [(ty', co : ty' ~ ty)]
-rewriteDictParams param_eqs tys
- = zipWith do_one tys [0..]
- where
- do_one :: Type -> Int -> (Type,Coercion)
- do_one ty n = case lookup n param_eqs of
- Just wev -> (get_fst_ty wev, mkCoVarCo (evVarOf wev))
- Nothing -> (ty, mkReflCo ty) -- Identity
-
- get_fst_ty wev = case evVarOfPred wev of
- EqPred ty1 _ -> ty1
- _ -> panic "rewriteDictParams: non equality fundep"
-
-mkEqnMsg :: (TcPredType, SDoc) -> (TcPredType, SDoc) -> TidyEnv
- -> TcM (TidyEnv, SDoc)
+mkEqnMsg :: (TcPredType, SDoc)
+ -> (TcPredType, SDoc) -> TidyEnv -> TcM (TidyEnv, SDoc)
mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
= do { zpred1 <- TcM.zonkTcPredType pred1
; zpred2 <- TcM.zonkTcPredType pred2
nest 2 (sep [ppr tpred1 <> comma, nest 2 from1]),
nest 2 (sep [ppr tpred2 <> comma, nest 2 from2])]
; return (tidy_env, msg) }
+
+rewriteDictParams :: [(Int,(EvVar,WantedLoc))] -- A set of coercions : (pos, ty' ~ ty)
+ -> [Type] -- A sequence of types: tys
+ -> [(Type,Coercion)] -- Returns: [(ty', co : ty' ~ ty)]
+rewriteDictParams param_eqs tys
+ = zipWith do_one tys [0..]
+ where
+ do_one :: Type -> Int -> (Type,Coercion)
+ do_one ty n = case lookup n param_eqs of
+ Just wev -> (get_fst_ty wev, mkCoVarCo (fst wev))
+ Nothing -> (ty, mkReflCo ty) -- Identity
+
+ get_fst_ty (wev,_wloc)
+ | EqPred ty1 _ <- evVarPred wev
+ = ty1
+ | otherwise
+ = panic "rewriteDictParams: non equality fundep!?"
+
+mkCanonicalFDAsWanted :: [(EvVar,WantedLoc)] -> TcS WorkList
+mkCanonicalFDAsWanted evlocs
+ = do { ws <- mapM can_as_wanted evlocs
+ ; return (unionWorkLists ws) }
+ where can_as_wanted (ev,loc) = mkCanonicalFEV (EvVarX ev (Wanted loc))
+
+
+mkCanonicalFDAsDerived :: [(EvVar,WantedLoc)] -> TcS WorkList
+mkCanonicalFDAsDerived evlocs
+ = do { ws <- mapM can_as_derived evlocs
+ ; return (unionWorkLists ws) }
+ where can_as_derived (ev,loc) = mkCanonicalFEV (EvVarX ev (Derived loc))
+
+
\end{code}
\ No newline at end of file
; e' <- zonkLExpr env e
; return $ HsVect v' (Just e')
}
+zonkVect env (HsNoVect v)
+ = do { v' <- wrapLocM (zonkIdBndr env) v
+ ; return $ HsNoVect v'
+ }
\end{code}
%************************************************************************
= 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') }
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
-- 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)
-- (2) type check indexed data type declaration
; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
- ; unbox_strict <- doptM Opt_UnboxStrictFields
-- kind check the type indexes and the context
; t_typats <- mapM tcHsKindedType k_typats
; let ex_ok = True -- Existentials ok for type families!
; fixM (\ rep_tycon -> do
{ let orig_res_ty = mkTyConApp fam_tycon t_typats
- ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon
+ ; data_cons <- tcConDecls ex_ok rep_tycon
(t_tvs, orig_res_ty) k_cons
; tc_rhs <-
case new_or_data of
, vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts is)))
, vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_ips is)))
, vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_funeqs is)))
- , vcat (map ppr (Bag.bagToList $ inert_frozen is))
+ , text "Frozen errors =" <+> -- Clearly print frozen errors
+ vcat (map ppr (Bag.bagToList $ inert_frozen is))
]
emptyInert :: InertSet
doInteractWithInert
inertItem@(CDictCan { cc_id = d1, cc_flavor = fl1, cc_class = cls1, cc_tyargs = tys1 })
workItem@(CDictCan { cc_id = d2, cc_flavor = fl2, cc_class = cls2, cc_tyargs = tys2 })
- | cls1 == cls2 && eqTypes tys1 tys2
- = solveOneFromTheOther "Cls/Cls" (EvId d1,fl1) workItem
- | cls1 == cls2 && (not (isGivenOrSolved fl1 && isGivenOrSolved fl2))
- = -- See Note [When improvement happens]
- do { let pty1 = ClassP cls1 tys1
+ | cls1 == cls2
+ = do { let pty1 = ClassP cls1 tys1
pty2 = ClassP cls2 tys2
inert_pred_loc = (pty1, pprFlavorArising fl1)
work_item_pred_loc = (pty2, pprFlavorArising fl2)
- fd_eqns = improveFromAnother
- inert_pred_loc -- the template
- work_item_pred_loc -- the one we aim to rewrite
- -- See Note [Efficient Orientation]
-
- ; m <- rewriteWithFunDeps fd_eqns tys2 fl2
- ; case m of
- Nothing -> noInteraction workItem
- Just (rewritten_tys2, cos2, fd_work)
- | eqTypes tys1 rewritten_tys2
- -> -- Solve him on the spot in this case
- case fl2 of
- Given {} -> pprPanic "Unexpected given" (ppr inertItem $$ ppr workItem)
- Derived {} -> mkIRStopK "Cls/Cls fundep (solved)" fd_work
- Wanted {}
- | isDerived fl1
- -> do { setDictBind d2 (EvCast d1 dict_co)
- ; let inert_w = inertItem { cc_flavor = fl2 }
+
+ ; any_fundeps
+ <- if isGivenOrSolved fl1 && isGivenOrSolved fl2 then return Nothing
+ -- NB: We don't create fds for given (and even solved), have not seen a useful
+ -- situation for these and even if we did we'd have to be very careful to only
+ -- create Derived's and not Wanteds.
+
+ else let fd_eqns = improveFromAnother inert_pred_loc work_item_pred_loc
+ wloc = get_workitem_wloc fl2
+ in rewriteWithFunDeps fd_eqns tys2 wloc
+ -- See Note [Efficient Orientation], [When improvement happens]
+
+ ; case any_fundeps of
+ -- No Functional Dependencies
+ Nothing
+ | eqTypes tys1 tys2 -> solveOneFromTheOther "Cls/Cls" (EvId d1,fl1) workItem
+ | otherwise -> noInteraction workItem
+
+ -- Actual Functional Dependencies
+ Just (rewritten_tys2,cos2,fd_work)
+ | not (eqTypes tys1 rewritten_tys2)
+ -- Standard thing: create derived fds and keep on going. Importantly we don't
+ -- throw workitem back in the worklist because this can cause loops. See #5236.
+ -> do { fd_cans <- mkCanonicalFDAsDerived fd_work
+ ; mkIRContinue "Cls/Cls fundep (not solved)" workItem KeepInert fd_cans }
+
+ -- This WHOLE otherwise branch is an optimization where the fd made the things match
+ | otherwise
+ , let dict_co = mkTyConAppCo (classTyCon cls1) cos2
+ -> case fl2 of
+ Given {}
+ -> pprPanic "Unexpected given!" (ppr inertItem $$ ppr workItem)
+ -- The only way to have created a fundep is if the inert was
+ -- wanted or derived, in which case the workitem can't be given!
+ Derived {}
+ -- The types were made to exactly match so we don't need
+ -- the workitem any longer.
+ -> do { fd_cans <- mkCanonicalFDAsDerived fd_work
+ -- No rewriting really, so let's create deriveds fds
+ ; mkIRStopK "Cls/Cls fundep (solved)" fd_cans }
+ Wanted {}
+ | isDerived fl1
+ -> do { setDictBind d2 (EvCast d1 dict_co)
+ ; let inert_w = inertItem { cc_flavor = fl2 }
-- A bit naughty: we take the inert Derived,
-- turn it into a Wanted, use it to solve the work-item
-- and put it back into the work-list
- -- Maybe rather than starting again, we could *replace* the
- -- inert item, but its safe and simple to restart
- ; mkIRStopD "Cls/Cls fundep (solved)" $
- workListFromNonEq inert_w `unionWorkList` fd_work }
- | otherwise
- -> do { setDictBind d2 (EvCast d1 dict_co)
- ; mkIRStopK "Cls/Cls fundep (solved)" fd_work }
-
- | otherwise
- -> -- We could not quite solve him, but we still rewrite him
- -- Example: class C a b c | a -> b
- -- Given: C Int Bool x, Wanted: C Int beta y
- -- Then rewrite the wanted to C Int Bool y
- -- but note that is still not identical to the given
- -- The important thing is that the rewritten constraint is
- -- inert wrt the given.
- -- However it is not necessarily inert wrt previous inert-set items.
- -- class C a b c d | a -> b, b c -> d
- -- Inert: c1: C b Q R S, c2: C P Q a b
- -- Work: C P alpha R beta
- -- Does not react with c1; reacts with c2, with alpha:=Q
- -- NOW it reacts with c1!
- -- So we must stop, and put the rewritten constraint back in the work list
- do { d2' <- newDictVar cls1 rewritten_tys2
- ; case fl2 of
- Given {} -> pprPanic "Unexpected given" (ppr inertItem $$ ppr workItem)
- Wanted {} -> setDictBind d2 (EvCast d2' dict_co)
- Derived {} -> return ()
- ; let workItem' = workItem { cc_id = d2', cc_tyargs = rewritten_tys2 }
- ; mkIRStopK "Cls/Cls fundep (partial)" $
- workListFromNonEq workItem' `unionWorkList` fd_work }
-
- where
- dict_co = mkTyConAppCo (classTyCon cls1) cos2
- }
+ -- Maybe rather than starting again, we could keep going
+ -- with the rewritten workitem, having dropped the inert, but its
+ -- safe to restart.
+
+ -- Also: we have rewriting so lets create wanted fds
+ ; fd_cans <- mkCanonicalFDAsWanted fd_work
+ ; mkIRStopD "Cls/Cls fundep (solved)" $
+ workListFromNonEq inert_w `unionWorkList` fd_cans }
+ | otherwise
+ -> do { setDictBind d2 (EvCast d1 dict_co)
+ -- Rewriting is happening, so we have to create wanted fds
+ ; fd_cans <- mkCanonicalFDAsWanted fd_work
+ ; mkIRStopK "Cls/Cls fundep (solved)" fd_cans }
+ }
+ where get_workitem_wloc (Wanted wl) = wl
+ get_workitem_wloc (Derived wl) = wl
+ get_workitem_wloc (Given {}) = panic "Unexpected given!"
+
-- Class constraint and given equality: use the equality to rewrite
-- the class constraint.
co2a' = liftCoSubstWith [tv1] [mkCoVarCo cv1] ty2a -- ty2a ~ ty2a[xi1/tv1]
co2b' = liftCoSubstWith [tv1] [mkCoVarCo cv1] ty2b -- ty2b ~ ty2b[xi1/tv1]
-solveOneFromTheOther :: String -> (EvTerm, CtFlavor) -> CanonicalCt -> TcS InteractResult
+solveOneFromTheOther_ExtraWork :: String -> (EvTerm, CtFlavor)
+ -> CanonicalCt -> WorkList -> TcS InteractResult
-- First argument inert, second argument work-item. They both represent
-- wanted/given/derived evidence for the *same* predicate so
-- we can discharge one directly from the other.
--
-- Precondition: value evidence only (implicit parameters, classes)
-- not coercion
-solveOneFromTheOther info (ev_term,ifl) workItem
+solveOneFromTheOther_ExtraWork info (ev_term,ifl) workItem extra_work
| isDerived wfl
- = mkIRStopK ("Solved[DW] " ++ info) emptyWorkList
+ = mkIRStopK ("Solved[DW] " ++ info) extra_work
| isDerived ifl -- The inert item is Derived, we can just throw it away,
-- The workItem is inert wrt earlier inert-set items,
-- so it's safe to continue on from this point
- = mkIRContinue ("Solved[DI] " ++ info) workItem DropInert emptyWorkList
+ = mkIRContinue ("Solved[DI] " ++ info) workItem DropInert extra_work
| Just GivenSolved <- isGiven_maybe ifl, isGivenOrSolved wfl
-- Same if the inert is a GivenSolved -- just get rid of it
- = mkIRContinue ("Solved[SI] " ++ info) workItem DropInert emptyWorkList
+ = mkIRContinue ("Solved[SI] " ++ info) workItem DropInert extra_work
| otherwise
= ASSERT( ifl `canSolve` wfl )
do { when (isWanted wfl) $ setEvBind wid ev_term
-- Overwrite the binding, if one exists
-- If both are Given, we already have evidence; no need to duplicate
- ; mkIRStopK ("Solved " ++ info) emptyWorkList }
+ ; mkIRStopK ("Solved " ++ info) extra_work }
where
wfl = cc_flavor workItem
wid = cc_id workItem
+
+
+solveOneFromTheOther :: String -> (EvTerm, CtFlavor) -> CanonicalCt -> TcS InteractResult
+solveOneFromTheOther str evfl ct
+ = solveOneFromTheOther_ExtraWork str evfl ct emptyWorkList -- extra work is empty
+
\end{code}
Note [Superclasses and recursive dictionaries]
= return NoTopInt -- NB: Superclasses already added since it's canonical
-- Derived dictionary: just look for functional dependencies
-doTopReact _inerts workItem@(CDictCan { cc_flavor = fl@(Derived loc)
+doTopReact _inerts workItem@(CDictCan { cc_flavor = Derived loc
, cc_class = cls, cc_tyargs = xis })
= do { instEnvs <- getInstEnvs
; let fd_eqns = improveFromInstEnv instEnvs
(ClassP cls xis, pprArisingAt loc)
- ; m <- rewriteWithFunDeps fd_eqns xis fl
+ ; m <- rewriteWithFunDeps fd_eqns xis loc
; case m of
Nothing -> return NoTopInt
Just (xis',_,fd_work) ->
let workItem' = workItem { cc_tyargs = xis' }
-- Deriveds are not supposed to have identity (cc_id is unused!)
- in return $ SomeTopInt { tir_new_work = fd_work
- , tir_new_inert = ContinueWith workItem' } }
+ in do { fd_cans <- mkCanonicalFDAsDerived fd_work
+ ; return $ SomeTopInt { tir_new_work = fd_cans
+ , tir_new_inert = ContinueWith workItem' }
+ }
+ }
+
-- Wanted dictionary
-doTopReact inerts workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
+doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc)
, cc_class = cls, cc_tyargs = xis })
- = do { -- See Note [MATCHING-SYNONYMS]
- ; lkp_inst_res <- matchClassInst inerts cls xis loc
- ; case lkp_inst_res of
- NoInstance ->
- do { traceTcS "doTopReact/ no class instance for" (ppr dv)
-
- ; instEnvs <- getInstEnvs
- ; let fd_eqns = improveFromInstEnv instEnvs
- (ClassP cls xis, pprArisingAt loc)
- ; m <- rewriteWithFunDeps fd_eqns xis fl
- ; case m of
- Nothing -> return NoTopInt
- Just (xis',cos,fd_work) ->
- do { let dict_co = mkTyConAppCo (classTyCon cls) cos
- ; dv'<- newDictVar cls xis'
- ; setDictBind dv (EvCast dv' dict_co)
- ; let workItem' = CDictCan { cc_id = dv', cc_flavor = fl,
- cc_class = cls, cc_tyargs = xis' }
- ; return $
- SomeTopInt { tir_new_work = workListFromNonEq workItem' `unionWorkList` fd_work
- , tir_new_inert = Stop } } }
-
- GenInst wtvs ev_term -- Solved
- -- No need to do fundeps stuff here; the instance
- -- matches already so we won't get any more info
- -- from functional dependencies
- | null wtvs
- -> do { traceTcS "doTopReact/found nullary class instance for" (ppr dv)
- ; setDictBind dv ev_term
- -- Solved in one step and no new wanted work produced.
- -- i.e we directly matched a top-level instance
- -- No point in caching this in 'inert'; hence Stop
- ; return $ SomeTopInt { tir_new_work = emptyWorkList
- , tir_new_inert = Stop } }
-
- | otherwise
- -> do { traceTcS "doTopReact/found non-nullary class instance for" (ppr dv)
- ; setDictBind dv ev_term
+ -- See Note [MATCHING-SYNONYMS]
+ = do { traceTcS "doTopReact" (ppr workItem)
+ ; instEnvs <- getInstEnvs
+ ; let fd_eqns = improveFromInstEnv instEnvs $ (ClassP cls xis, pprArisingAt loc)
+
+ ; any_fundeps <- rewriteWithFunDeps fd_eqns xis loc
+ ; case any_fundeps of
+ -- No Functional Dependencies
+ Nothing ->
+ do { lkup_inst_res <- matchClassInst inerts cls xis loc
+ ; case lkup_inst_res of
+ GenInst wtvs ev_term
+ -> doSolveFromInstance wtvs ev_term workItem emptyWorkList
+ NoInstance
+ -> return NoTopInt
+ }
+ -- Actual Functional Dependencies
+ Just (xis',cos,fd_work) ->
+ do { lkup_inst_res <- matchClassInst inerts cls xis' loc
+ ; case lkup_inst_res of
+ NoInstance
+ -> do { fd_cans <- mkCanonicalFDAsDerived fd_work
+ ; return $
+ SomeTopInt { tir_new_work = fd_cans
+ , tir_new_inert = ContinueWith workItem } }
+ -- This WHOLE branch is an optimization: we can immediately discharge the dictionary
+ GenInst wtvs ev_term
+ -> do { let dict_co = mkTyConAppCo (classTyCon cls) cos
+ ; fd_cans <- mkCanonicalFDAsWanted fd_work
+ ; dv' <- newDictVar cls xis'
+ ; setDictBind dv' ev_term
+ ; doSolveFromInstance wtvs (EvCast dv' dict_co) workItem fd_cans }
+ } }
+
+ where doSolveFromInstance :: [WantedEvVar]
+ -> EvTerm
+ -> CanonicalCt
+ -> WorkList -> TcS TopInteractResult
+ -- Precondition: evidence term matches the predicate of cc_id of workItem
+ doSolveFromInstance wtvs ev_term workItem extra_work
+ | null wtvs
+ = do { traceTcS "doTopReact/found nullary instance for" (ppr (cc_id workItem))
+ ; setDictBind (cc_id workItem) ev_term
+ ; return $ SomeTopInt { tir_new_work = extra_work
+ , tir_new_inert = Stop } }
+ | otherwise
+ = do { traceTcS "doTopReact/found non-nullary instance for" (ppr (cc_id workItem))
+ ; setDictBind (cc_id workItem) ev_term
-- Solved and new wanted work produced, you may cache the
-- (tentatively solved) dictionary as Solved given.
- ; let solved = workItem { cc_flavor = solved_fl }
- solved_fl = mkSolvedFlavor fl UnkSkol
- ; inst_work <- canWanteds wtvs
- ; return $ SomeTopInt { tir_new_work = inst_work
- , tir_new_inert = ContinueWith solved } }
- }
+ ; let solved = workItem { cc_flavor = solved_fl }
+ solved_fl = mkSolvedFlavor fl UnkSkol
+ ; inst_work <- canWanteds wtvs
+ ; return $ SomeTopInt { tir_new_work = inst_work `unionWorkList` extra_work
+ , tir_new_inert = ContinueWith solved } }
+
-- Type functions
doTopReact _inerts (CFunEqCan { cc_flavor = fl })
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)
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
-- found.
; loadOrphanModules (imp_orphs imports) False
- -- Check type-familily consistency
+ -- Check type-family consistency
; traceRn (text "rn1: checking family instance consistency")
; let { dir_imp_mods = moduleEnvKeys
. imp_mods
-- could not be found.
getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo])
getModuleExports hsc_env mod
- = let
- ic = hsc_IC hsc_env
- checkMods = ic_toplev_scope ic ++ map fst (ic_exports ic)
- in
- initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods)
+ = initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod)
-- Get the export avail info and also load all orphan and family-instance
-- modules. Finally, check that the family instances of all modules in the
-- interactive context are consistent (these modules are in the second
-- argument).
-tcGetModuleExports :: Module -> [Module] -> TcM [AvailInfo]
-tcGetModuleExports mod directlyImpMods
+tcGetModuleExports :: Module -> TcM [AvailInfo]
+tcGetModuleExports mod
= do { let doc = ptext (sLit "context for compiling statements")
; iface <- initIfaceTcRn $ loadSysInterface doc mod
-- interfaces, so their instances are visible.
; loadOrphanModules (dep_orphs (mi_deps iface)) False
- -- Check that the family instances of all directly loaded
- -- modules are consistent.
- ; checkFamInstConsistency (dep_finsts (mi_deps iface)) directlyImpMods
-
; ifaceExportNames (mi_exports iface)
}
getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
-setSrcSpan loc thing_inside
- | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
- | otherwise = thing_inside -- Don't overwrite useful info with useless
+setSrcSpan loc@(RealSrcSpan _) thing_inside
+ = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
+-- Don't overwrite useful info with useless:
+setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
addLocM :: (a -> TcM b) -> Located a -> TcM b
addLocM fn (L loc a) = setSrcSpan loc $ fn a
-- (captureConstraints m) runs m, and returns the type constraints it generates
captureConstraints thing_inside
= do { lie_var <- newTcRef emptyWC ;
- res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
- thing_inside ;
- lie <- readTcRef lie_var ;
- return (res, lie) }
+ res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
+ thing_inside ;
+ lie <- readTcRef lie_var ;
+ return (res, lie) }
captureUntouchables :: TcM a -> TcM (a, Untouchables)
captureUntouchables thing_inside
= updLclEnv upd thing_inside
where
upd env = env { tcl_env = tcl_env lcl_env,
- tcl_tyvars = tcl_tyvars lcl_env }
+ tcl_tyvars = tcl_tyvars lcl_env }
+
+traceTcConstraints :: String -> TcM ()
+traceTcConstraints msg
+ = do { lie_var <- getConstraintVar
+ ; lie <- readTcRef lie_var
+ ; traceTc (msg ++ "LIE:") (ppr lie)
+ }
\end{code}
%************************************************************************
-%* *
- Template Haskell context
-%* *
+%* *
+ Template Haskell context
+%* *
%************************************************************************
\begin{code}
qReport False msg = addReport (text msg) empty
qLocation = do { m <- getModule
- ; l <- getSrcSpanM
- ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
- , TH.loc_module = moduleNameString (moduleName m)
- , TH.loc_package = packageIdString (modulePackageId m)
- , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
- , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
-
+ ; l <- getSrcSpanM
+ ; r <- case l of
+ UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
+ (ppr l)
+ RealSrcSpan s -> return s
+ ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
+ , TH.loc_module = moduleNameString (moduleName m)
+ , TH.loc_package = packageIdString (modulePackageId m)
+ , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
+ , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
+
qReify v = reify v
qClassInstances = lookupClassInstances
{ extra_tvs <- tcDataKindSig mb_ksig
; let final_tvs = tvs' ++ extra_tvs
; stupid_theta <- tcHsKindedContext ctxt
- ; unbox_strict <- doptM Opt_UnboxStrictFields
; kind_signatures <- xoptM Opt_KindSignatures
; existential_ok <- xoptM Opt_ExistentialQuantification
; gadt_ok <- xoptM Opt_GADTs
; tycon <- fixM (\ tycon -> do
{ let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
- ; data_cons <- tcConDecls unbox_strict ex_ok
- tycon (final_tvs, res_ty) cons
+ ; data_cons <- tcConDecls ex_ok tycon (final_tvs, res_ty) cons
; tc_rhs <-
if null cons && is_boot -- In a hs-boot file, empty cons means
then return AbstractTyCon -- "don't know"; hence Abstract
(emptyConDeclsErr tc_name) }
-----------------------------------
-tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type)
+tcConDecls :: Bool -> TyCon -> ([TyVar], Type)
-> [LConDecl Name] -> TcM [DataCon]
-tcConDecls unbox ex_ok rep_tycon res_tmpl cons
- = mapM (addLocM (tcConDecl unbox ex_ok rep_tycon res_tmpl)) cons
+tcConDecls ex_ok rep_tycon res_tmpl cons
+ = mapM (addLocM (tcConDecl ex_ok rep_tycon res_tmpl)) cons
-tcConDecl :: Bool -- True <=> -funbox-strict_fields
- -> Bool -- True <=> -XExistentialQuantificaton or -XGADTs
+tcConDecl :: Bool -- True <=> -XExistentialQuantificaton or -XGADTs
-> TyCon -- Representation tycon
-> ([TyVar], Type) -- Return type template (with its template tyvars)
-> ConDecl Name
-> TcM DataCon
-tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types
+tcConDecl existential_ok rep_tycon res_tmpl -- Data types
con@(ConDecl {con_name = name, con_qvars = tvs, con_cxt = ctxt
, con_details = details, con_res = res_ty })
= addErrCtxt (dataConCtxt name) $
; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty
; let
tc_datacon is_infix field_lbls btys
- = do { (arg_tys, stricts) <- mapAndUnzipM (tcConArg unbox_strict) btys
+ = do { (arg_tys, stricts) <- mapAndUnzipM tcConArg btys
; buildDataCon (unLoc name) is_infix
stricts field_lbls
univ_tvs ex_tvs eq_preds ctxt' arg_tys
f _ _ = False
-------------------
-tcConArg :: Bool -- True <=> -funbox-strict_fields
- -> LHsType Name
- -> TcM (TcType, HsBang)
-tcConArg unbox_strict bty
+tcConArg :: LHsType Name -> TcM (TcType, HsBang)
+tcConArg bty
= do { arg_ty <- tcHsBangType bty
- ; let bang = getBangStrictness bty
- ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang
+ ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty)
; return (arg_ty, strict_mark) }
-- We attempt to unbox/unpack a strict field when either:
--
-- We have turned off unboxing of newtypes because coercions make unboxing
-- and reboxing more complicated
-chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang
-chooseBoxingStrategy unbox_strict_fields arg_ty bang
+chooseBoxingStrategy :: TcType -> HsBang -> TcM HsBang
+chooseBoxingStrategy arg_ty bang
= case bang of
- HsNoBang -> HsNoBang
- HsUnpack -> can_unbox HsUnpackFailed arg_ty
- HsStrict | unbox_strict_fields -> can_unbox HsStrict arg_ty
- | otherwise -> HsStrict
+ HsNoBang -> return HsNoBang
+ HsStrict -> do { unbox_strict <- doptM Opt_UnboxStrictFields
+ ; if unbox_strict then return (can_unbox HsStrict arg_ty)
+ else return HsStrict }
+ HsUnpack -> do { omit_prags <- doptM Opt_OmitInterfacePragmas
+ -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on
+ -- See Trac #5252: unpacking means we must not conceal the
+ -- representation of the argument type
+ ; if omit_prags then return HsStrict
+ else return (can_unbox HsUnpackFailed arg_ty) }
HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
-- Source code never has shtes
where
-- | A description of the platform we're compiling for.
--- Used by the native code generator.
--- In the future, this module should be the only one that references
--- the evil #defines for each TARGET_ARCH and TARGET_OS
+-- In the future, this module should be the only one that references
+-- the evil #defines for each TARGET_ARCH and TARGET_OS
--
module Platform (
- Platform(..),
- Arch(..),
- OS(..),
+ Platform(..),
+ Arch(..),
+ OS(..),
- defaultTargetPlatform,
- osElfTarget
+ defaultTargetPlatform,
+ target32Bit,
+ osElfTarget
)
where
+import Panic
+
#include "HsVersions.h"
-- | Contains enough information for the native code generator to emit
--- code for this platform.
+-- code for this platform.
data Platform
- = Platform
- { platformArch :: Arch
- , platformOS :: OS }
+ = Platform
+ { platformArch :: Arch
+ , platformOS :: OS }
-- | Architectures that the native code generator knows about.
--- TODO: It might be nice to extend these constructors with information
--- about what instruction set extensions an architecture might support.
+-- TODO: It might be nice to extend these constructors with information
+-- about what instruction set extensions an architecture might support.
--
data Arch
- = ArchX86
- | ArchX86_64
- | ArchPPC
- | ArchPPC_64
- | ArchSPARC
- deriving (Show, Eq)
-
+ = ArchUnknown
+ | ArchX86
+ | ArchX86_64
+ | ArchPPC
+ | ArchPPC_64
+ | ArchSPARC
+ deriving (Show, Eq)
+
-- | Operating systems that the native code generator knows about.
--- Having OSUnknown should produce a sensible default, but no promises.
+-- Having OSUnknown should produce a sensible default, but no promises.
data OS
- = OSUnknown
- | OSLinux
- | OSDarwin
- | OSSolaris2
- | OSMinGW32
- | OSFreeBSD
- | OSOpenBSD
- deriving (Show, Eq)
+ = OSUnknown
+ | OSLinux
+ | OSDarwin
+ | OSSolaris2
+ | OSMinGW32
+ | OSFreeBSD
+ | OSOpenBSD
+ deriving (Show, Eq)
+
+
+target32Bit :: Platform -> Bool
+target32Bit p = case platformArch p of
+ ArchUnknown -> panic "Don't know if ArchUnknown is 32bit"
+ ArchX86 -> True
+ ArchX86_64 -> False
+ ArchPPC -> True
+ ArchPPC_64 -> False
+ ArchSPARC -> True
-- | This predicates tells us whether the OS supports ELF-like shared libraries.
osElfTarget :: OS -> Bool
-osElfTarget OSLinux = True
-osElfTarget OSFreeBSD = True
-osElfTarget OSOpenBSD = True
+osElfTarget OSLinux = True
+osElfTarget OSFreeBSD = True
+osElfTarget OSOpenBSD = True
osElfTarget OSSolaris2 = True
-osElfTarget _ = False
+osElfTarget OSDarwin = False
+osElfTarget OSMinGW32 = False
+osElfTarget OSUnknown = panic "Don't know if OSUnknown is elf"
+
-- | This is the target platform as far as the #ifdefs are concerned.
--- These are set in includes/ghcplatform.h by the autoconf scripts
+-- These are set in includes/ghcplatform.h by the autoconf scripts
defaultTargetPlatform :: Platform
defaultTargetPlatform
- = Platform defaultTargetArch defaultTargetOS
+ = Platform defaultTargetArch defaultTargetOS
-- | Move the evil TARGET_ARCH #ifdefs into Haskell land.
defaultTargetArch :: Arch
#if i386_TARGET_ARCH
-defaultTargetArch = ArchX86
+defaultTargetArch = ArchX86
#elif x86_64_TARGET_ARCH
-defaultTargetArch = ArchX86_64
+defaultTargetArch = ArchX86_64
#elif powerpc_TARGET_ARCH
-defaultTargetArch = ArchPPC
+defaultTargetArch = ArchPPC
#elif powerpc64_TARGET_ARCH
-defaultTargetArch = ArchPPC_64
+defaultTargetArch = ArchPPC_64
#elif sparc_TARGET_ARCH
-defaultTargetArch = ArchSPARC
+defaultTargetArch = ArchSPARC
#else
-#error "Platform.buildArch: undefined"
+defaultTargetArch = ArchUnknown
#endif
-- | Move the evil TARGET_OS #ifdefs into Haskell land.
defaultTargetOS :: OS
#if linux_TARGET_OS
-defaultTargetOS = OSLinux
+defaultTargetOS = OSLinux
#elif darwin_TARGET_OS
-defaultTargetOS = OSDarwin
+defaultTargetOS = OSDarwin
#elif solaris2_TARGET_OS
-defaultTargetOS = OSSolaris2
+defaultTargetOS = OSSolaris2
#elif mingw32_TARGET_OS
-defaultTargetOS = OSMinGW32
+defaultTargetOS = OSMinGW32
#elif freebsd_TARGET_OS
-defaultTargetOS = OSFreeBSD
+defaultTargetOS = OSFreeBSD
#elif openbsd_TARGET_OS
-defaultTargetOS = OSOpenBSD
+defaultTargetOS = OSOpenBSD
#else
-defaultTargetOS = OSUnknown
+defaultTargetOS = OSUnknown
#endif
-{-# OPTIONS -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}
module Vectorise ( vectorise )
where
}
}
--- | Try to vectorise a top-level binding.
--- If it doesn't vectorise then return it unharmed.
+-- |Try to vectorise a top-level binding. If it doesn't vectorise then return it unharmed.
--
--- For example, for the binding
+-- For example, for the binding
--
--- @
--- foo :: Int -> Int
--- foo = \x -> x + x
--- @
---
--- we get
--- @
--- foo :: Int -> Int
--- foo = \x -> vfoo $: x
---
--- v_foo :: Closure void vfoo lfoo
--- v_foo = closure vfoo lfoo void
---
--- vfoo :: Void -> Int -> Int
--- vfoo = ...
+-- @
+-- foo :: Int -> Int
+-- foo = \x -> x + x
+-- @
--
--- lfoo :: PData Void -> PData Int -> PData Int
--- lfoo = ...
--- @
+-- we get
+-- @
+-- foo :: Int -> Int
+-- foo = \x -> vfoo $: x
--
--- @vfoo@ is the "vectorised", or scalar, version that does the same as the original
--- function foo, but takes an explicit environment.
---
--- @lfoo@ is the "lifted" version that works on arrays.
+-- v_foo :: Closure void vfoo lfoo
+-- v_foo = closure vfoo lfoo void
+--
+-- vfoo :: Void -> Int -> Int
+-- vfoo = ...
+--
+-- lfoo :: PData Void -> PData Int -> PData Int
+-- lfoo = ...
+-- @
--
--- @v_foo@ combines both of these into a `Closure` that also contains the
--- environment.
+-- @vfoo@ is the "vectorised", or scalar, version that does the same as the original
+-- function foo, but takes an explicit environment.
--
--- The original binding @foo@ is rewritten to call the vectorised version
--- present in the closure.
+-- @lfoo@ is the "lifted" version that works on arrays.
+--
+-- @v_foo@ combines both of these into a `Closure` that also contains the
+-- environment.
+--
+-- The original binding @foo@ is rewritten to call the vectorised version
+-- present in the closure.
+--
+-- Vectorisation may be surpressed by annotating a binding with a 'NOVECTORISE' pragma. If this
+-- pragma is used in a group of mutually recursive bindings, either all or no binding must have
+-- the pragma. If only some bindings are annotated, a fatal error is being raised.
+-- FIXME: Once we support partial vectorisation, we may be able to vectorise parts of a group, or
+-- we may emit a warning and refrain from vectorising the entire group.
--
vectTopBind :: CoreBind -> VM CoreBind
vectTopBind b@(NonRec var expr)
- = do { -- Vectorise the right-hand side, create an appropriate top-level binding and add it to
- -- the vectorisation map.
- ; (inline, isScalar, expr') <- vectTopRhs [] var expr
- ; var' <- vectTopBinder var inline expr'
- ; when isScalar $
- addGlobalScalar var
-
- -- We replace the original top-level binding by a value projected from the vectorised
- -- closure and add any newly created hoisted top-level bindings.
- ; cexpr <- tryConvert var var' expr
- ; hs <- takeHoisted
- ; return . Rec $ (var, cexpr) : (var', expr') : hs
- }
- `orElseV`
- return b
+ = unlessNoVectDecl $
+ do { -- Vectorise the right-hand side, create an appropriate top-level binding and add it
+ -- to the vectorisation map.
+ ; (inline, isScalar, expr') <- vectTopRhs [] var expr
+ ; var' <- vectTopBinder var inline expr'
+ ; when isScalar $
+ addGlobalScalar var
+
+ -- We replace the original top-level binding by a value projected from the vectorised
+ -- closure and add any newly created hoisted top-level bindings.
+ ; cexpr <- tryConvert var var' expr
+ ; hs <- takeHoisted
+ ; return . Rec $ (var, cexpr) : (var', expr') : hs
+ }
+ `orElseV`
+ return b
+ where
+ unlessNoVectDecl vectorise
+ = do { hasNoVectDecl <- noVectDecl var
+ ; when hasNoVectDecl $
+ traceVt "NOVECTORISE" $ ppr var
+ ; if hasNoVectDecl then return b else vectorise
+ }
vectTopBind b@(Rec bs)
- = let (vars, exprs) = unzip bs
- in
- do { (vars', _, exprs', hs) <- fixV $
- \ ~(_, inlines, rhss, _) ->
- do { -- Vectorise the right-hand sides, create an appropriate top-level bindings and
- -- add them to the vectorisation map.
- ; vars' <- sequence [vectTopBinder var inline rhs
- | (var, ~(inline, rhs)) <- zipLazy vars (zip inlines rhss)]
- ; (inlines, areScalars, exprs') <- mapAndUnzip3M (uncurry $ vectTopRhs vars) bs
- ; hs <- takeHoisted
- ; if and areScalars
- then -- (1) Entire recursive group is scalar
- -- => add all variables to the global set of scalars
- do { mapM addGlobalScalar vars
- ; return (vars', inlines, exprs', hs)
- }
- else -- (2) At least one binding is not scalar
- -- => vectorise again with empty set of local scalars
- do { (inlines, _, exprs') <- mapAndUnzip3M (uncurry $ vectTopRhs []) bs
- ; hs <- takeHoisted
- ; return (vars', inlines, exprs', hs)
- }
- }
-
- -- Replace the original top-level bindings by a values projected from the vectorised
- -- closures and add any newly created hoisted top-level bindings to the group.
- ; cexprs <- sequence $ zipWith3 tryConvert vars vars' exprs
- ; return . Rec $ zip vars cexprs ++ zip vars' exprs' ++ hs
- }
- `orElseV`
- return b
-
+ = unlessSomeNoVectDecl $
+ do { (vars', _, exprs', hs) <- fixV $
+ \ ~(_, inlines, rhss, _) ->
+ do { -- Vectorise the right-hand sides, create an appropriate top-level bindings
+ -- and add them to the vectorisation map.
+ ; vars' <- sequence [vectTopBinder var inline rhs
+ | (var, ~(inline, rhs)) <- zipLazy vars (zip inlines rhss)]
+ ; (inlines, areScalars, exprs') <- mapAndUnzip3M (uncurry $ vectTopRhs vars) bs
+ ; hs <- takeHoisted
+ ; if and areScalars
+ then -- (1) Entire recursive group is scalar
+ -- => add all variables to the global set of scalars
+ do { mapM_ addGlobalScalar vars
+ ; return (vars', inlines, exprs', hs)
+ }
+ else -- (2) At least one binding is not scalar
+ -- => vectorise again with empty set of local scalars
+ do { (inlines, _, exprs') <- mapAndUnzip3M (uncurry $ vectTopRhs []) bs
+ ; hs <- takeHoisted
+ ; return (vars', inlines, exprs', hs)
+ }
+ }
+
+ -- Replace the original top-level bindings by a values projected from the vectorised
+ -- closures and add any newly created hoisted top-level bindings to the group.
+ ; cexprs <- sequence $ zipWith3 tryConvert vars vars' exprs
+ ; return . Rec $ zip vars cexprs ++ zip vars' exprs' ++ hs
+ }
+ `orElseV`
+ return b
+ where
+ (vars, exprs) = unzip bs
+
+ unlessSomeNoVectDecl vectorise
+ = do { hasNoVectDecls <- mapM noVectDecl vars
+ ; when (and hasNoVectDecls) $
+ traceVt "NOVECTORISE" $ ppr vars
+ ; if and hasNoVectDecls
+ then return b -- all bindings have 'NOVECTORISE'
+ else if or hasNoVectDecls
+ then cantVectorise noVectoriseErr (ppr b) -- some (but not all) have 'NOVECTORISE'
+ else vectorise -- no binding has a 'NOVECTORISE' decl
+ }
+ noVectoriseErr = "NOVECTORISE must be used on all or no bindings of a recursive group"
+
-- | Make the vectorised version of this top level binder, and add the mapping
-- between it and the original to the state. For some binder @foo@ the vectorised
-- version is @$v_foo@
--
--- NOTE: vectTopBinder *MUST* be lazy in inline and expr because of how it is
--- used inside of fixV in vectTopBind
+-- NOTE: 'vectTopBinder' *MUST* be lazy in inline and expr because of how it is
+-- used inside of 'fixV' in 'vectTopBind'.
--
vectTopBinder :: Var -- ^ Name of the binding.
-> Inline -- ^ Whether it should be inlined, used to annotate it.
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_Double = dph_Prelude_Double
, dph_Prelude_Bool = dph_Prelude_Bool
})
, 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
+ -- ++ 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' 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"
- ]
-
+ -- 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
module Vectorise.Env (
- Scope(..),
-
- -- * Local Environments
- LocalEnv(..),
- emptyLocalEnv,
-
- -- * Global Environments
- GlobalEnv(..),
- initGlobalEnv,
- extendImportedVarsEnv,
- extendScalars,
- setFamEnv,
- extendFamEnv,
- extendTyConsEnv,
- extendDataConsEnv,
- extendPAFunsEnv,
- setPRFunsEnv,
- setBoxedTyConsEnv,
- updVectInfo
+ Scope(..),
+
+ -- * Local Environments
+ LocalEnv(..),
+ emptyLocalEnv,
+
+ -- * Global Environments
+ GlobalEnv(..),
+ initGlobalEnv,
+ extendImportedVarsEnv,
+ extendScalars,
+ setFamEnv,
+ extendFamEnv,
+ extendTyConsEnv,
+ extendDataConsEnv,
+ extendPAFunsEnv,
+ setPRFunsEnv,
+ setBoxedTyConsEnv,
+ modVectInfo
) where
import HscTypes
import VarEnv
import VarSet
import Var
+import NameSet
import Name
import NameEnv
import FastString
-- | Indicates what scope something (a variable) is in.
data Scope a b
- = Global a
- | Local b
+ = Global a
+ | Local b
-- LocalEnv -------------------------------------------------------------------
-- GlobalEnv ------------------------------------------------------------------
--- | The global environment.
--- These are things the exist at top-level.
-data GlobalEnv
- = GlobalEnv {
- -- | Mapping from global variables to their vectorised versions — aka the /vectorisation
- -- map/.
- global_vars :: VarEnv Var
-
- -- | Mapping from global variables that have a vectorisation declaration to the right-hand
- -- side of that declaration and its type. This mapping only applies to non-scalar
- -- vectorisation declarations. All variables with a scalar vectorisation declaration are
- -- mentioned in 'global_scalars'.
- , global_vect_decls :: VarEnv (Type, CoreExpr)
- -- | Purely scalar variables. Code which mentions only these variables doesn't have to be
- -- lifted. This includes variables from the current module that have a scalar
- -- vectorisation declaration and those that the vectoriser determines to be scalar.
- , global_scalars :: VarSet
-
- -- | Exported variables which have a vectorised version.
- , global_exported_vars :: VarEnv (Var, Var)
+-- |The global environment: entities that exist at top-level.
+--
+data GlobalEnv
+ = GlobalEnv
+ { global_vars :: VarEnv Var
+ -- ^Mapping from global variables to their vectorised versions — aka the /vectorisation
+ -- map/.
- -- | Mapping from TyCons to their vectorised versions.
- -- TyCons which do not have to be vectorised are mapped to themselves.
- , global_tycons :: NameEnv TyCon
+ , global_vect_decls :: VarEnv (Type, CoreExpr)
+ -- ^Mapping from global variables that have a vectorisation declaration to the right-hand
+ -- side of that declaration and its type. This mapping only applies to non-scalar
+ -- vectorisation declarations. All variables with a scalar vectorisation declaration are
+ -- mentioned in 'global_scalars_vars'.
+
+ , global_scalar_vars :: VarSet
+ -- ^Purely scalar variables. Code which mentions only these variables doesn't have to be
+ -- lifted. This includes variables from the current module that have a scalar
+ -- vectorisation declaration and those that the vectoriser determines to be scalar.
+
+ , global_scalar_tycons :: NameSet
+ -- ^Type constructors whose values can only contain scalar data. Scalar code may only
+ -- operate on such data.
+
+ , global_novect_vars :: VarSet
+ -- ^Variables that are not vectorised. (They may be referenced in the right-hand sides
+ -- of vectorisation declarations, though.)
+
+ , global_exported_vars :: VarEnv (Var, Var)
+ -- ^Exported variables which have a vectorised version.
+
+ , global_tycons :: NameEnv TyCon
+ -- ^Mapping from TyCons to their vectorised versions.
+ -- TyCons which do not have to be vectorised are mapped to themselves.
- -- | Mapping from DataCons to their vectorised versions.
, global_datacons :: NameEnv DataCon
+ -- ^Mapping from DataCons to their vectorised versions.
- -- | Mapping from TyCons to their PA dfuns.
, global_pa_funs :: NameEnv Var
+ -- ^Mapping from TyCons to their PA dfuns.
- -- | Mapping from TyCons to their PR dfuns.
- , global_pr_funs :: NameEnv Var
+ , global_pr_funs :: NameEnv Var
+ -- ^Mapping from TyCons to their PR dfuns.
- -- | Mapping from unboxed TyCons to their boxed versions.
- , global_boxed_tycons :: NameEnv TyCon
+ , global_boxed_tycons :: NameEnv TyCon
+ -- ^Mapping from unboxed TyCons to their boxed versions.
- -- | External package inst-env & home-package inst-env for class instances.
- , global_inst_env :: (InstEnv, InstEnv)
+ , global_inst_env :: (InstEnv, InstEnv)
+ -- ^External package inst-env & home-package inst-env for class instances.
- -- | External package inst-env & home-package inst-env for family instances.
- , global_fam_inst_env :: FamInstEnvs
+ , global_fam_inst_env :: FamInstEnvs
+ -- ^External package inst-env & home-package inst-env for family instances.
- -- | Hoisted bindings.
- , global_bindings :: [(Var, CoreExpr)]
+ , global_bindings :: [(Var, CoreExpr)]
+ -- ^Hoisted bindings.
}
--- | Create an initial global environment
+-- |Create an initial global environment.
+--
initGlobalEnv :: VectInfo -> [CoreVect] -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv
initGlobalEnv info vectDecls instEnvs famInstEnvs
= GlobalEnv
{ global_vars = mapVarEnv snd $ vectInfoVar info
, global_vect_decls = mkVarEnv vects
- , global_scalars = mkVarSet scalars
+ , global_scalar_vars = vectInfoScalarVars info `extendVarSetList` scalars
+ , global_scalar_tycons = vectInfoScalarTyCons info
+ , global_novect_vars = mkVarSet novects
, global_exported_vars = emptyVarEnv
, global_tycons = mapNameEnv snd $ vectInfoTyCon info
, global_datacons = mapNameEnv snd $ vectInfoDataCon info
where
vects = [(var, (varType var, exp)) | Vect var (Just exp) <- vectDecls]
scalars = [var | Vect var Nothing <- vectDecls]
+ novects = [var | NoVect var <- vectDecls]
-- Operators on Global Environments -------------------------------------------
--- | Extend the list of global variables in an environment.
+
+-- |Extend the list of global variables in an environment.
+--
extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv
extendImportedVarsEnv ps genv
- = genv { global_vars = extendVarEnvList (global_vars genv) ps }
+ = genv { global_vars = extendVarEnvList (global_vars genv) ps }
--- | Extend the set of scalar variables in an environment.
+-- |Extend the set of scalar variables in an environment.
+--
extendScalars :: [Var] -> GlobalEnv -> GlobalEnv
extendScalars vs genv
- = genv { global_scalars = extendVarSetList (global_scalars genv) vs }
+ = genv { global_scalar_vars = extendVarSetList (global_scalar_vars genv) vs }
--- | Set the list of type family instances in an environment.
+-- |Set the list of type family instances in an environment.
+--
setFamEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv
setFamEnv l_fam_inst genv
= genv { global_fam_inst_env = (g_fam_inst, l_fam_inst) }
where (g_fam_inst, _) = global_fam_inst_env genv
+-- |Extend the list of type family instances.
+--
extendFamEnv :: [FamInst] -> GlobalEnv -> GlobalEnv
extendFamEnv new genv
= genv { global_fam_inst_env = (g_fam_inst, extendFamInstEnvList l_fam_inst new) }
where (g_fam_inst, l_fam_inst) = global_fam_inst_env genv
-
--- | Extend the list of type constructors in an environment.
+-- |Extend the list of type constructors in an environment.
+--
extendTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
extendTyConsEnv ps genv
= genv { global_tycons = extendNameEnvList (global_tycons genv) ps }
-
--- | Extend the list of data constructors in an environment.
+-- |Extend the list of data constructors in an environment.
+--
extendDataConsEnv :: [(Name, DataCon)] -> GlobalEnv -> GlobalEnv
extendDataConsEnv ps genv
= genv { global_datacons = extendNameEnvList (global_datacons genv) ps }
-
--- | Extend the list of PA functions in an environment.
+-- |Extend the list of PA functions in an environment.
+--
extendPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
extendPAFunsEnv ps genv
= genv { global_pa_funs = extendNameEnvList (global_pa_funs genv) ps }
-
--- | Set the list of PR functions in an environment.
+-- |Set the list of PR functions in an environment.
+--
setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
setPRFunsEnv ps genv
= genv { global_pr_funs = mkNameEnv ps }
-
--- | Set the list of boxed type constructor in an environment.
+-- |Set the list of boxed type constructor in an environment.
+--
setBoxedTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
setBoxedTyConsEnv ps genv
= genv { global_boxed_tycons = mkNameEnv ps }
-
--- | TODO: What is this for?
-updVectInfo :: GlobalEnv -> TypeEnv -> VectInfo -> VectInfo
-updVectInfo env tyenv info
+-- |Compute vectorisation information that goes into 'ModGuts' (and is stored in interface files).
+-- The incoming 'vectInfo' is that from the 'HscEnv' and 'EPS'. The outgoing one contains only the
+-- definitions for the currently compiled module.
+--
+modVectInfo :: GlobalEnv -> TypeEnv -> VectInfo -> VectInfo
+modVectInfo env tyenv info
= info
- { vectInfoVar = global_exported_vars env
- , vectInfoTyCon = mk_env typeEnvTyCons global_tycons
- , vectInfoDataCon = mk_env typeEnvDataCons global_datacons
- , vectInfoPADFun = mk_env typeEnvTyCons global_pa_funs
+ { vectInfoVar = global_exported_vars env
+ , vectInfoTyCon = mk_env typeEnvTyCons global_tycons
+ , vectInfoDataCon = mk_env typeEnvDataCons global_datacons
+ , vectInfoPADFun = mk_env typeEnvTyCons global_pa_funs
+ , vectInfoScalarVars = global_scalar_vars env `minusVarSet` vectInfoScalarVars info
+ , vectInfoScalarTyCons = global_scalar_tycons env `minusNameSet` vectInfoScalarTyCons info
}
where
mk_env from_tyenv from_env
- = mkNameEnv [(name, (from,to))
- | from <- from_tyenv tyenv
- , let name = getName from
- , Just to <- [lookupNameEnv (from_env env) name]]
-
+ = mkNameEnv [(name, (from,to))
+ | from <- from_tyenv tyenv
+ , let name = getName from
+ , Just to <- [lookupNameEnv (from_env env) name]]
module Vectorise.Monad (
- module Vectorise.Monad.Base,
- module Vectorise.Monad.Naming,
- module Vectorise.Monad.Local,
- module Vectorise.Monad.Global,
- module Vectorise.Monad.InstEnv,
- initV,
-
- -- * Builtins
- liftBuiltinDs,
- builtin,
- builtins,
-
- -- * Variables
- lookupVar,
- maybeCantVectoriseVarM,
- dumpVar,
- addGlobalScalar,
- deleteGlobalScalar,
+ module Vectorise.Monad.Base,
+ module Vectorise.Monad.Naming,
+ module Vectorise.Monad.Local,
+ module Vectorise.Monad.Global,
+ module Vectorise.Monad.InstEnv,
+ initV,
+
+ -- * Builtins
+ liftBuiltinDs,
+ builtin,
+ builtins,
+
+ -- * Variables
+ lookupVar,
+ maybeCantVectoriseVarM,
+ dumpVar,
+ addGlobalScalar,
- -- * Primitives
- lookupPrimPArray,
- lookupPrimMethod
+ -- * Primitives
+ lookupPrimPArray,
+ lookupPrimMethod
) where
import Vectorise.Monad.Base
; builtin_pas <- initBuiltinPAs builtins instEnvs
-- 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
$ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs
-- perform vectorisation
- ; r <- runVM thing_inside builtins genv emptyLocalEnv
+ ; r <- runVM thing_inside' builtins genv emptyLocalEnv
; case r of
Yes genv _ x -> return $ Just (new_info genv, x)
No -> return Nothing
} }
- new_info genv = updVectInfo genv (mg_types guts) info
+ new_info genv = modVectInfo genv (mg_types guts) info
selectBackendErr = sLit "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq"
-- Var ------------------------------------------------------------------------
-- | Lookup the vectorised and\/or lifted versions of this variable.
--- If it's in the global environment we get the vectorised version.
+-- If it's in the global environment we get the vectorised version.
-- If it's in the local environment we get both the vectorised and lifted version.
lookupVar :: Var -> VM (Scope Var (Var, Var))
lookupVar v
dumpVar :: Var -> a
dumpVar var
- | Just _ <- isClassOpId_maybe var
- = cantVectorise "ClassOpId not vectorised:" (ppr var)
+ | Just _ <- isClassOpId_maybe var
+ = cantVectorise "ClassOpId not vectorised:" (ppr var)
- | otherwise
- = cantVectorise "Variable not vectorised:" (ppr var)
+ | otherwise
+ = cantVectorise "Variable not vectorised:" (ppr var)
--- local scalars --------------------------------------------------------------
+-- Global scalars --------------------------------------------------------------
addGlobalScalar :: Var -> VM ()
addGlobalScalar var
= do { traceVt "addGlobalScalar" (ppr var)
- ; updGEnv $ \env -> env{global_scalars = extendVarSet (global_scalars env) var}
- }
-
-deleteGlobalScalar :: Var -> VM ()
-deleteGlobalScalar var
- = do { traceVt "deleteGlobalScalar" (ppr var)
- ; updGEnv $ \env -> env{global_scalars = delVarSet (global_scalars env) var}
- }
+ ; updGEnv $ \env -> env{global_scalar_vars = extendVarSet (global_scalar_vars env) var}
+ }
-- Primitives -----------------------------------------------------------------
+
lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
lookupPrimPArray = liftBuiltinDs . primPArray
module Vectorise.Monad.Global (
- readGEnv,
- setGEnv,
- updGEnv,
-
+ readGEnv,
+ setGEnv,
+ updGEnv,
+
-- * Vars
defGlobalVar,
-- * Vectorisation declarations
- lookupVectDecl,
+ lookupVectDecl, noVectDecl,
-- * Scalars
globalScalars, isGlobalScalar,
-
- -- * TyCons
- lookupTyCon,
- lookupBoxedTyCon,
- defTyCon,
-
- -- * Datacons
- lookupDataCon,
- defDataCon,
-
- -- * PA Dictionaries
- lookupTyConPA,
- defTyConPA,
- defTyConPAs,
-
- -- * PR Dictionaries
- lookupTyConPR
+
+ -- * TyCons
+ lookupTyCon,
+ lookupBoxedTyCon,
+ defTyCon,
+
+ -- * Datacons
+ lookupDataCon,
+ defDataCon,
+
+ -- * PA Dictionaries
+ lookupTyConPA,
+ defTyConPA,
+ defTyConPAs,
+
+ -- * PR Dictionaries
+ lookupTyConPR
) where
import Vectorise.Monad.Base
-- Global Environment ---------------------------------------------------------
--- | Project something from the global environment.
+
+-- |Project something from the global environment.
+--
readGEnv :: (GlobalEnv -> a) -> VM a
readGEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f genv))
-
--- | Set the value of the global environment.
+-- |Set the value of the global environment.
+--
setGEnv :: GlobalEnv -> VM ()
setGEnv genv = VM $ \_ _ lenv -> return (Yes genv lenv ())
-
--- | Update the global environment using the provided function.
+-- |Update the global environment using the provided function.
+--
updGEnv :: (GlobalEnv -> GlobalEnv) -> VM ()
updGEnv f = VM $ \_ genv lenv -> return (Yes (f genv) lenv ())
-- Vars -----------------------------------------------------------------------
--- | Add a mapping between a global var and its vectorised version to the state.
+
+-- |Add a mapping between a global var and its vectorised version to the state.
+--
defGlobalVar :: Var -> Var -> VM ()
defGlobalVar v v' = updGEnv $ \env ->
env { global_vars = extendVarEnv (global_vars env) v v'
-- Vectorisation declarations -------------------------------------------------
--- | Check whether a variable has a (non-scalar) vectorisation declaration.
+
+-- |Check whether a variable has a (non-scalar) vectorisation declaration.
+--
lookupVectDecl :: Var -> VM (Maybe (Type, CoreExpr))
lookupVectDecl var = readGEnv $ \env -> lookupVarEnv (global_vect_decls env) var
+-- |Check whether a variable has a 'NOVECTORISE' declaration.
+--
+noVectDecl :: Var -> VM Bool
+noVectDecl var = readGEnv $ \env -> elemVarSet var (global_novect_vars env)
+
-- Scalars --------------------------------------------------------------------
--- | Get the set of global scalar variables.
+
+-- |Get the set of global scalar variables.
+--
globalScalars :: VM VarSet
-globalScalars = readGEnv global_scalars
+globalScalars = readGEnv global_scalar_vars
--- | Check whether a given variable is in the set of global scalar variables.
+-- |Check whether a given variable is in the set of global scalar variables.
+--
isGlobalScalar :: Var -> VM Bool
-isGlobalScalar var = readGEnv $ \env -> elemVarSet var (global_scalars env)
+isGlobalScalar var = readGEnv $ \env -> elemVarSet var (global_scalar_vars env)
-- TyCons ---------------------------------------------------------------------
--- | Lookup the vectorised version of a `TyCon` from the global environment.
+
+-- |Lookup the vectorised version of a `TyCon` from the global environment.
+--
lookupTyCon :: TyCon -> VM (Maybe TyCon)
lookupTyCon tc
| isUnLiftedTyCon tc || isTupleTyCon tc
| otherwise
= readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
-
-- | Lookup the vectorised version of a boxed `TyCon` from the global environment.
lookupBoxedTyCon :: TyCon -> VM (Maybe TyCon)
lookupBoxedTyCon tc
= readGEnv $ \env -> lookupNameEnv (global_boxed_tycons env)
(tyConName tc)
-
-- | Add a mapping between plain and vectorised `TyCon`s to the global environment.
defTyCon :: TyCon -> TyCon -> VM ()
defTyCon tc tc' = updGEnv $ \env ->
-- DataCons -------------------------------------------------------------------
+
-- | Lookup the vectorised version of a `DataCon` from the global environment.
lookupDataCon :: DataCon -> VM (Maybe DataCon)
lookupDataCon dc
dnl ** check whether this machine has BFD and liberty installed (used for debugging)
dnl the order of these tests matters: bfd needs liberty
AC_CHECK_LIB(iberty, xmalloc)
-AC_CHECK_LIB(bfd, bfd_init)
+AC_CHECK_LIB(bfd, bfd_uncompress_section_contents)
dnl ################################################################
dnl Check for libraries
<para>
The RTS now exports a function <literal>setKeepCAFs</literal>
which is important when loading Haskell DLLs dynamically, as
- a DLL may refer to CAFs that hae already been GCed.
+ a DLL may refer to CAFs that have already been GCed.
</para>
</listitem>
<sect1 id="vs-Haskell-defn">
<title>Haskell 98 vs. Glasgow Haskell: language non-compliance
</title>
-
+
<indexterm><primary>GHC vs the Haskell 98 language</primary></indexterm>
<indexterm><primary>Haskell 98 language vs GHC</primary></indexterm>
<sect2 id="haskell98-divergence">
<title>Divergence from Haskell 98</title>
-
-
+
+
<sect3 id="infelicities-lexical">
<title>Lexical syntax</title>
-
+
<itemizedlist>
<listitem>
<para>Certain lexical rules regarding qualified identifiers
</listitem>
</itemizedlist>
</sect3>
-
+
<sect3 id="infelicities-syntax">
<title>Context-free syntax</title>
-
+
<itemizedlist>
<listitem>
<para>GHC is a little less strict about the layout rule when used
<option>-XNoMonoPatBinds</option>. See <xref
linkend="options-language" />.</para>
</sect3>
-
+
<sect3 id="infelicities-Modules">
<title>Module system and interface files</title>
-
+
<para>GHC requires the use of <literal>hs-boot</literal>
files to cut the recursive loops among mutually recursive modules
as described in <xref linkend="mutual-recursion"/>. This more of an infelicity
- than a bug: the Haskell Report says
+ than a bug: the Haskell Report says
(<ulink url="http://haskell.org/onlinereport/modules.html#sect5.7">Section 5.7</ulink>) "Depending on the Haskell
implementation used, separate compilation of mutually
recursive modules may require that imported modules contain
</listitem>
</varlistentry>
</variablelist>
-
+
</sect3>
<sect3 id="infelicities-Prelude">
the <literal>Int</literal> type.</para>
<para>The <literal>fromInteger</literal><indexterm><primary><literal>fromInteger</literal></primary>
- </indexterm>function (and hence
+ </indexterm> function (and hence
also <literal>fromIntegral</literal><indexterm><primary><literal>fromIntegral</literal></primary>
</indexterm>) is a special case when
converting to <literal>Int</literal>. The value of
<para>Negative literals, such as <literal>-3</literal>, are
- specified by (a careful reading of) the Haskell Report as
+ specified by (a careful reading of) the Haskell Report as
meaning <literal>Prelude.negate (Prelude.fromInteger 3)</literal>.
So <literal>-2147483648</literal> means <literal>negate (fromInteger 2147483648)</literal>.
Since <literal>fromInteger</literal> takes the lower 32 bits of the representation,
</listitem>
</varlistentry>
</variablelist>
-
+
</sect2>
<sect2 id="ffi-divergence">
<title>Divergence from the FFI specification</title>
-
+
<variablelist>
<varlistentry>
<term><literal>hs_init()</literal> not allowed
</varlistentry>
</variablelist>
</sect2>
-
+
</sect1>
</listitem>
<listitem>
- <para>GHC does not allow you to have a data type with a context
+ <para>GHC does not allow you to have a data type with a context
that mentions type variables that are not data type parameters.
For example:
<programlisting>
using the standard way to encode recursion via a data type:</para>
<programlisting>
data U = MkU (U -> Bool)
-
+
russel :: U -> Bool
russel u@(MkU p) = not $ p u
-
+
x :: Bool
x = russel (MkU russel)
</programlisting>
module (whatever that is).</para>
</listitem>
- <listitem>
+ <listitem>
<para>On Windows, there's a GNU ld/BFD bug
whereby it emits bogus PE object files that have more than
0xffff relocations. When GHCi tries to load a package affected by this
<sect2 id="dumping-output">
<title>Dumping out compiler intermediate structures</title>
-
+
<indexterm><primary>dumping GHC intermediates</primary></indexterm>
<indexterm><primary>intermediate passes, output</primary></indexterm>
-
+
<variablelist>
<varlistentry>
<term>
<indexterm><primary><option>-ddump-rules</option></primary></indexterm>
</term>
<listitem>
- <para>dumps all rewrite rules specified in this module;
+ <para>dumps all rewrite rules specified in this module;
see <xref linkend="controlling-rules"/>.
</para>
</listitem>
</variablelist>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term>
<option>-ddump-simpl-phases</option>:
</term>
<listitem>
<para>Make the interface loader be *real* chatty about what it is
- upto.</para>
+ up to.</para>
</listitem>
</varlistentry>
</term>
<listitem>
<para>Make the type checker be *real* chatty about what it is
- upto.</para>
+ up to.</para>
</listitem>
</varlistentry>
</term>
<listitem>
<para>Make the vectoriser be *real* chatty about what it is
- upto.</para>
+ up to.</para>
</listitem>
</varlistentry>
</term>
<listitem>
<para>Make the renamer be *real* chatty about what it is
- upto.</para>
+ up to.</para>
</listitem>
</varlistentry>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term>
<option>-dshow-passes</option>
<indexterm><primary><option>-dppr-case-as-let</option></primary></indexterm>
</term>
<listitem>
- <para>Print single alternative case expressions as though they were strict
+ <para>Print single alternative case expressions as though they were strict
let expressions. This is helpful when your code does a lot of unboxing.</para>
</listitem>
</varlistentry>
<indexterm><primary><option>-dsuppress-all</option></primary></indexterm>
</term>
<listitem>
- <para>Suppress everything that can be suppressed, except for unique ids as this often
+ <para>Suppress everything that can be suppressed, except for unique ids as this often
makes the printout ambiguous. If you just want to see the overall structure of
the code, then start here.</para>
</listitem>
<indexterm><primary><option>-dsuppress-uniques</option></primary></indexterm>
</term>
<listitem>
- <para>Suppress the printing of uniques. This may make
+ <para>Suppress the printing of uniques. This may make
the printout ambiguous (e.g. unclear where an occurrence of 'x' is bound), but
it makes the output of two compiler runs have many fewer gratuitous differences,
so you can realistically apply <command>diff</command>. Once <command>diff</command>
</term>
<listitem>
<para>Suppress extended information about identifiers where they are bound. This includes
- strictness information and inliner templates. Using this flag can cut the size
+ strictness information and inliner templates. Using this flag can cut the size
of the core dump in half, due to the lack of inliner templates</para>
</listitem>
</varlistentry>
calling arbitrary IO procedures in some part of the program.)
</para>
<para>The Haskell FFI already specifies that arguments and results of
-foreign imports and exports will be automatically unwrapped if they are
+foreign imports and exports will be automatically unwrapped if they are
newtypes (Section 3.2 of the FFI addendum). GHC extends the FFI by automatically unwrapping any newtypes that
wrap the IO monad itself.
More precisely, wherever the FFI specification requires an IO type, GHC will
the time, then the program will not respond to the user
interrupt.
</para>
-
+
<para>
The problem is that it is not possible in general to
interrupt a foreign call safely. However, GHC does provide
of <literal>safe</literal> or <literal>unsafe</literal>:
<programlisting>
-foreign import ccall interruptible
+foreign import ccall interruptible
"sleep" :: CUint -> IO CUint
</programlisting>
- <literal>interruptble</literal> behaves exactly as
+ <literal>interruptible</literal> behaves exactly as
<literal>safe</literal>, except that when
a <literal>throwTo</literal> is directed at a thread in an
interruptible foreign call, an OS-specific mechanism will be
</indexterm>
<para>When GHC compiles a module (say <filename>M.hs</filename>)
- which uses <literal>foreign export</literal> or
+ which uses <literal>foreign export</literal> or
<literal>foreign import "wrapper"</literal>, it generates two
additional files, <filename>M_stub.c</filename> and
<filename>M_stub.h</filename>. GHC will automatically compile
––make</literal>, as GHC will automatically link in the
correct bits).</para>
- <sect3 id="using-own-main">
+ <sect3 id="using-own-main">
<title>Using your own <literal>main()</literal></title>
<para>Normally, GHC's runtime system provides a
</sect3>
</sect2>
-
+
<sect2 id="glasgow-foreign-headers">
<title>Using header files</title>
available when compiling an inlined version of a foreign call,
so the compiler is free to inline foreign calls in any
context.</para>
-
+
<para>The <literal>-#include</literal> option is now
deprecated, and the <literal>include-files</literal> field
in a Cabal package specification is ignored.</para>
</varlistentry>
</variablelist>
</sect2>
-
+
<sect2 id="ffi-threads">
<title>Multi-threading and the FFI</title>
-
+
<para>In order to use the FFI in a multi-threaded setting, you must
use the <option>-threaded</option> option
(see <xref linkend="options-linker" />).</para>
-
+
<sect3>
<title>Foreign imports and multi-threading</title>
-
+
<para>When you call a <literal>foreign import</literal>ed
function that is annotated as <literal>safe</literal> (the
default), and the program was linked
program was linked without <option>-threaded</option>,
then the other Haskell threads will be blocked until the
call returns.</para>
-
+
<para>This means that if you need to make a foreign call to
a function that takes a long time or blocks indefinitely,
then you should mark it <literal>safe</literal> and
<sect3 id="haskell-threads-and-os-threads">
<title>The relationship between Haskell threads and OS
threads</title>
-
+
<para>Normally there is no fixed relationship between Haskell
threads and OS threads. This means that when you make a
foreign call, that call may take place in an unspecified OS
for the <ulink url="&libraryBaseLocation;/Control-Concurrent.html"><literal>Control.Concurrent</literal></ulink>
module.</para>
</sect3>
-
+
<sect3>
<title>Foreign exports and multi-threading</title>
-
+
<para>When the program is linked
with <option>-threaded</option>, then you may
invoke <literal>foreign export</literal>ed functions from
isn't necessary to ensure that the threads have exited first.
(Unofficially, if you want to use this fast and loose version of
<literal>hs_exit()</literal>, then call
- <literal>shutdownHaskellAndExit()</literal> instead).</para>
+ <literal>shutdownHaskellAndExit()</literal> instead).</para>
</sect3>
</sect2>
</sect2>
<sect2>
<title>Which phases to run</title>
-
+
<para><xref linkend="options-order"/></para>
<informaltable>
<sect2>
<title>Alternative modes of operation</title>
-
+
<para><xref linkend="modes"/></para>
<informaltable>
<sect2>
<title>Redirecting output</title>
-
+
<para><xref linkend="options-output"/></para>
<informaltable>
<sect2>
<title>Keeping intermediate files</title>
-
+
<para><xref linkend="keeping-intermediates"/></para>
-
+
<informaltable>
<tgroup cols="4" align="left" colsep="1" rowsep="1">
<thead>
<sect2>
<title>Temporary files</title>
-
+
<para><xref linkend="temp-files"/></para>
<informaltable>
</tgroup>
</informaltable>
</sect2>
-
+
<sect2>
<title>Recompilation checking</title>
<sect2 id="interactive-mode-options">
<title>Interactive-mode options</title>
-
+
<para><xref linkend="ghci-dot-files"/></para>
<informaltable>
<entry><link linkend="breakpoints">Enable usage of Show instances in <literal>:print</literal></link></entry>
<entry>dynamic</entry>
<entry><option>-fno-print-evld-with-show</option></entry>
- </row>
+ </row>
<row>
<entry><option>-fprint-bind-result</option></entry>
<entry><link linkend="ghci-stmts">Turn on printing of binding results in GHCi</link></entry>
<sect2>
<title>Language options</title>
- <para>Language options can be enabled either by a command-line option
+ <para>Language options can be enabled either by a command-line option
<option>-Xblah</option>, or by a <literal>{-# LANGUAGE blah #-}</literal>
pragma in the file itself. See <xref linkend="options-language"/></para>
</row>
<row>
<entry><option>-XIncoherentInstances</option></entry>
- <entry>Enable <link linkend="instance-overlap">incoherent instances</link>.
+ <entry>Enable <link linkend="instance-overlap">incoherent instances</link>.
Implies <option>-XOverlappingInstances</option> </entry>
<entry>dynamic</entry>
<entry><option>-XNoIncoherentInstances</option></entry>
</row>
<row>
<entry><option>-XDisambiguateRecordFields</option></entry>
- <entry>Enable <link linkend="disambiguate-fields">record
+ <entry>Enable <link linkend="disambiguate-fields">record
field disambiguation</link></entry>
<entry>dynamic</entry>
<entry><option>-XNoDisambiguateRecordFields</option></entry>
</row>
<row>
<entry><option>-XTemplateHaskell</option></entry>
- <entry>Enable <link linkend="template-haskell">Template Haskell</link>.
+ <entry>Enable <link linkend="template-haskell">Template Haskell</link>.
No longer implied by <option>-fglasgow-exts</option>.</entry>
<entry>dynamic</entry>
<entry><option>-XNoTemplateHaskell</option></entry>
<entry><option>-XNoMagicHash</option></entry>
</row>
<row>
- <entry><option>-XExplicitForALl</option></entry>
+ <entry><option>-XExplicitForAll</option></entry>
<entry>Enable <link linkend="explicit-foralls">explicit universal quantification</link>.
Implied by <option>-XScopedTypeVariables</option>,
<option>-XLiberalTypeSynonyms</option>,
<sect2>
<title>Warnings</title>
-
+
<para><xref linkend="options-sanity"/></para>
<informaltable>
<row>
<entry><option>-fwarn-missing-import-lists</option></entry>
- <entry>warn when an import declaration does not explicitly
+ <entry>warn when an import declaration does not explicitly
list all the names brought into scope</entry>
<entry>dynamic</entry>
<entry><option>-fnowarn-missing-import-lists</option></entry>
</tbody>
</tgroup>
</informaltable>
-
+
</sect2>
<sect2>
<title>Individual optimisations</title>
<row>
<entry><option>-fspec-constr-count</option>=<replaceable>n</replaceable></entry>
- <entry>Set to <replaceable>n</replaceable> (default: 3) the maximum number of
+ <entry>Set to <replaceable>n</replaceable> (default: 3) the maximum number of
specialisations that will be created for any one function
by the SpecConstr transformation</entry>
<entry>static</entry>
<sect2>
<title>Profiling options</title>
-
+
<para><xref linkend="profiling"/></para>
<informaltable>
<sect2>
<title>Program coverage options</title>
-
+
<para><xref linkend="hpc"/></para>
<informaltable>
<sect2>
<title>Platform-specific options</title>
-
+
<para><xref linkend="options-platform"/></para>
<informaltable>
</informaltable>
</sect2>
-
+
<sect2>
<title>External core file options</title>
</tgroup>
</informaltable>
</sect2>
-
+
<sect2>
<title>Misc compiler options</title>
</row>
<row>
<entry><option>-fno-ghci-sandbox</option></entry>
- <entry>Turn off the GHCi sandbox. Means computations are run in teh main thread, rather than a forked thread.</entry>
+ <entry>Turn off the GHCi sandbox. Means computations are run in the main thread, rather than a forked thread.</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
<indexterm><primary>GHCi</primary></indexterm>
<indexterm><primary>interpreter</primary><see>GHCi</see></indexterm>
<indexterm><primary>interactive</primary><see>GHCi</see></indexterm>
-
+
<para>GHCi<footnote>
<para>The ‘i’ stands for “Interactive”</para>
</footnote>
Loading package integer-gmp ... linking ... done.
Loading package base ... linking ... done.
Loading package ffi-1.0 ... linking ... done.
-Prelude>
+Prelude>
</screen>
<para>There may be a short pause while GHCi loads the prelude and
3
Prelude> let x = 42 in x / 9
4.666666666666667
-Prelude>
+Prelude>
</screen>
<para>GHCi interprets the whole line as an expression to evaluate.
- The expression may not span several lines - as soon as you press enter,
+ The expression may not span several lines - as soon as you press enter,
GHCi will attempt to evaluate it.</para>
- <para>GHCi also has a multiline mode,
+ <para>GHCi also has a multiline mode,
<indexterm><primary><literal>:set +m</literal></primary></indexterm>,
which is terminated by an empty line:</para>
<screen>
Prelude> :set +m
Prelude> let x = 42 in x / 9
-Prelude|
+Prelude|
4.666666666666667
-Prelude>
+Prelude>
</screen>
-
+
<para>In Haskell, a <literal>let</literal> expression is followed
- by <literal>in</literal>. However, in GHCi, since the expression
- can also be interpreted in the <literal>IO</literal> monad,
- a <literal>let</literal> binding with no accompanying
- <literal>in</literal> statement can be signalled by an empty line,
+ by <literal>in</literal>. However, in GHCi, since the expression
+ can also be interpreted in the <literal>IO</literal> monad,
+ a <literal>let</literal> binding with no accompanying
+ <literal>in</literal> statement can be signalled by an empty line,
as in the above example.</para>
- <para>Multiline mode is useful when entering monadic
+ <para>Multiline mode is useful when entering monadic
<literal>do</literal> statements:</para>
<screen>
0
Control.Monad.State>
</screen>
-
+
<para>During a multiline interaction, the user can interrupt and
return to the top-level prompt.</para>
<title>Modules vs. filenames</title>
<indexterm><primary>modules</primary><secondary>and filenames</secondary></indexterm>
<indexterm><primary>filenames</primary><secondary>of modules</secondary></indexterm>
-
+
<para>Question: How does GHC find the filename which contains
module <replaceable>M</replaceable>? Answer: it looks for the
file <literal><replaceable>M</replaceable>.hs</literal>, or
because the source and everything it depends on
is unchanged since the last compilation.</para>
- <para>At any time you can use the command
+ <para>At any time you can use the command
<literal>:show modules</literal>
to get a list of the modules currently loaded
into GHCi:</para>
*Main> :reload
Compiling D ( D.hs, interpreted )
Ok, modules loaded: A, B, C, D.
-*Main>
+*Main>
</screen>
<para>Note that module D was compiled, but in this instance
<title>Using <literal>do-</literal>notation at the prompt</title>
<indexterm><primary>do-notation</primary><secondary>in GHCi</secondary></indexterm>
<indexterm><primary>statements</primary><secondary>in GHCi</secondary></indexterm>
-
+
<para>GHCi actually accepts <firstterm>statements</firstterm>
rather than just expressions at the prompt. This means you can
bind values and functions to names, and use them in future
it as we did above.</para>
<para>If <option>-fprint-bind-result</option> is set then
- GHCi will print the result of a statement if and only if:
+ GHCi will print the result of a statement if and only if:
<itemizedlist>
<listitem>
- <para>The statement is not a binding, or it is a monadic binding
+ <para>The statement is not a binding, or it is a monadic binding
(<literal>p <- e</literal>) that binds exactly one
variable.</para>
</listitem>
3
Prelude>
</screen>
- <para>However, this quickly gets tedious when defining functions
+ <para>However, this quickly gets tedious when defining functions
with multiple clauses, or groups of mutually recursive functions,
- because the complete definition has to be given on a single line,
+ because the complete definition has to be given on a single line,
using explicit braces and semicolons instead of layout:</para>
<screen>
Prelude> let { f op n [] = n ; f op n (h:t) = h `op` f op n t }
</screen>
<para>Such multiline commands can be used with any GHCi command,
and the lines between <literal>:{</literal> and
- <literal>:}</literal> are simply merged into a single line for
+ <literal>:}</literal> are simply merged into a single line for
interpretation. That implies that each such group must form a single
- valid command when merged, and that no layout rule is used.
+ valid command when merged, and that no layout rule is used.
The main purpose of multiline commands is not to replace module
loading but to make definitions in .ghci-files (see <xref
linkend="ghci-dot-files"/>) more readable and maintainable.</para>
</sect2>
<sect2 id="ghci-scope">
- <title>What's really in scope at the prompt?</title>
+ <title>What's really in scope at the prompt?</title>
<para>When you type an expression at the prompt, what
identifiers and types are in scope? GHCi provides a flexible
haskell <literal>import</literal> syntax as
well, but this does not support
<literal>*</literal> forms).
- <literal>:module</literal> can also be shortened to
+ <literal>:module</literal> can also be shortened to
<literal>:m</literal>. The full syntax of the
<literal>:module</literal> command is:</para>
</sect3>
</sect2>
-
+
<sect2>
<title>The <literal>it</literal> variable</title>
<indexterm><primary><literal>it</literal></primary>
</indexterm>
-
+
<para>Whenever an expression (or a non-binding statement, to be
precise) is typed at the prompt, GHCi implicitly binds its value
to the variable <literal>it</literal>. For example:</para>
<para>What actually happens is that GHCi typechecks the
expression, and if it doesn't have an <literal>IO</literal> type,
then it transforms it as follows: an expression
- <replaceable>e</replaceable> turns into
+ <replaceable>e</replaceable> turns into
<screen>
let it = <replaceable>e</replaceable>;
print it
rules (Section 4.3.4 of the Haskell 2010 Report) as follows. The
standard rules take each group of constraints <literal>(C1 a, C2 a, ..., Cn
a)</literal> for each type variable <literal>a</literal>, and defaults the
- type variable if
+ type variable if
<orderedlist>
<listitem>
<para>
<listitem>
<para>The ability to set a <firstterm>breakpoint</firstterm> on a
function definition or expression in the program. When the function
- is called, or the expression evaluated, GHCi suspends
+ is called, or the expression evaluated, GHCi suspends
execution and returns to the prompt, where you can inspect the
values of local variables before continuing with the
execution.</para>
</listitem>
</itemizedlist>
</para>
-
+
<para>There is currently no support for obtaining a “stack
trace”, but the tracing and history features provide a
useful second-best, which will often be enough to establish the
automatically when an exception is thrown, even if it is thrown
from within compiled code (see <xref
linkend="ghci-debugger-exceptions" />).</para>
-
+
<sect2 id="breakpoints">
<title>Breakpoints and inspecting variables</title>
-
+
<para>Let's use quicksort as a running example. Here's the code:</para>
<programlisting>
-qsort [] = []
+qsort [] = []
qsort (a:as) = qsort left ++ [a] ++ qsort right
where (left,right) = (filter (<=a) as, filter (>a) as)
[1 of 1] Compiling Main ( qsort.hs, interpreted )
Ok, modules loaded: Main.
*Main>
- </screen>
+ </screen>
<para>Now, let's set a breakpoint on the right-hand-side of the second
equation of qsort:</para>
Breakpoint 0 activated at qsort.hs:2:15-46
*Main>
</programlisting>
-
+
<para>The command <literal>:break 2</literal> sets a breakpoint on line
2 of the most recently-loaded module, in this case
<literal>qsort.hs</literal>. Specifically, it picks the
leftmost complete subexpression on that line on which to set the
- breakpoint, which in this case is the expression
+ breakpoint, which in this case is the expression
<literal>(qsort left ++ [a] ++ qsort right)</literal>.</para>
<para>Now, we run the program:</para>
location, we can use the <literal>:list</literal> command:</para>
<programlisting>
-[qsort.hs:2:15-46] *Main> :list
-1 qsort [] = []
+[qsort.hs:2:15-46] *Main> :list
+1 qsort [] = []
2 qsort (a:as) = qsort left ++ [a] ++ qsort right
3 where (left,right) = (filter (<=a) as, filter (>a) as)
</programlisting>
<para>The flag <literal>-fprint-evld-with-show</literal> instructs
<literal>:print</literal> to reuse
available <literal>Show</literal> instances when possible. This happens
- only when the contents of the variable being inspected
+ only when the contents of the variable being inspected
are completely evaluated.</para>
[qsort.hs:2:15-46] *Main> a
8
</screen>
-
+
<para>You might find it useful to use Haskell's
<literal>seq</literal> function to evaluate individual thunks rather
than evaluating the whole expression with <literal>:force</literal>.
a :: a
left :: [a]
right :: [a]
-[qsort.hs:2:15-46] *Main>
+[qsort.hs:2:15-46] *Main>
</screen>
<para>The execution continued at the point it previously stopped, and has
:break <replaceable>line</replaceable>
:break <replaceable>line</replaceable> <replaceable>column</replaceable>
:break <replaceable>module</replaceable> <replaceable>line</replaceable>
- :break <replaceable>module</replaceable> <replaceable>line</replaceable> <replaceable>column</replaceable>
+ :break <replaceable>module</replaceable> <replaceable>line</replaceable> <replaceable>column</replaceable>
</screen>
<para>When a breakpoint is set on a particular line, GHCi sets the
breakpoint on the
leftmost subexpression that begins and ends on that line. If two
- complete subexpressions start at the same
+ complete subexpressions start at the same
column, the longest one is picked. If there is no complete
subexpression on the line, then the leftmost expression starting on
the line is picked, and failing that the rightmost expression that
and doesn't match others. The best advice is to avoid tab
characters in your source code altogether (see
<option>-fwarn-tabs</option> in <xref linkend="options-sanity"
- />).</para>
+ />).</para>
<para>If the module is omitted, then the most recently-loaded module is
used.</para>
*Main> :delete 0
*Main> :show breaks
[1] Main qsort.hs:2:15-46
-</screen>
+</screen>
<para>To delete all breakpoints at once, use <literal>:delete *</literal>.</para>
<para>Single-stepping is a great way to visualise the execution of your
program, and it is also a useful tool for identifying the source of a
- bug. GHCi offers two variants of stepping. Use
+ bug. GHCi offers two variants of stepping. Use
<literal>:step</literal> to enable all the
breakpoints in the program, and execute until the next breakpoint is
reached. Use <literal>:steplocal</literal> to limit the set
<replaceable>expr</replaceable></literal> begins the evaluation of
<replaceable>expr</replaceable> in single-stepping mode. If
<replaceable>expr</replaceable> is omitted, then it single-steps from
- the current breakpoint. <literal>:stepover</literal>
+ the current breakpoint. <literal>:stepover</literal>
works similarly.</para>
<para>The <literal>:list</literal> command is particularly useful when
<screen>
[qsort.hs:5:7-47] *Main> :list
-4
+4
5 main = print (qsort [8, 4, 0, 3, 1, 23, 11, 18])
-6
+6
[qsort.hs:5:7-47] *Main>
</screen>
[qsort.hs:5:7-47] *Main> :step
Stopped at qsort.hs:5:14-46
_result :: [Integer]
-4
+4
5 main = print (qsort [8, 4, 0, 3, 1, 23, 11, 18])
-6
+6
[qsort.hs:5:14-46] *Main>
</screen>
</sect2>
<screen>
*Main> :list qsort
-1 qsort [] = []
+1 qsort [] = []
2 qsort (a:as) = qsort left ++ [a] ++ qsort right
3 where (left,right) = (filter (<=a) as, filter (>a) as)
-4
+4
*Main> :b 1
Breakpoint 1 activated at qsort.hs:1:11-12
-*Main>
+*Main>
</screen>
<para>and then run a small <literal>qsort</literal> with
_result :: [a]
as :: [a]
a :: a
-[-1: qsort.hs:3:24-38] *Main>
+[-1: qsort.hs:3:24-38] *Main>
</screen>
<para>Note that the local variables at each step in the history have been
we can't set a breakpoint on it directly. For this reason, GHCi
provides the flags <literal>-fbreak-on-exception</literal> which causes
the evaluator to stop when an exception is thrown, and <literal>
- -fbreak-on-error</literal>, which works similarly but stops only on
- uncaught exceptions. When stopping at an exception, GHCi will act
+ -fbreak-on-error</literal>, which works similarly but stops only on
+ uncaught exceptions. When stopping at an exception, GHCi will act
just as it does when a breakpoint is hit, with the deviation that it
- will not show you any source code location. Due to this, these
+ will not show you any source code location. Due to this, these
commands are only really useful in conjunction with
<literal>:trace</literal>, in order to log the steps leading up to the
exception. For example:</para>
<sect2><title>Example: inspecting functions</title>
<para>
- It is possible to use the debugger to examine function values.
+ It is possible to use the debugger to examine function values.
When we are at a breakpoint and a function is in scope, the debugger
- cannot show
- you the source code for it; however, it is possible to get some
- information by applying it to some arguments and observing the result.
+ cannot show
+ you the source code for it; however, it is possible to get some
+ information by applying it to some arguments and observing the result.
</para>
<para>
- The process is slightly complicated when the binding is polymorphic.
+ The process is slightly complicated when the binding is polymorphic.
We show the process by means of an example.
To keep things simple, we will use the well known <literal>map</literal> function:
<programlisting>
f :: a -> b
xs :: [a]
</screen>
- GHCi tells us that, among other bindings, <literal>f</literal> is in scope.
- However, its type is not fully known yet,
- and thus it is not possible to apply it to any
+ GHCi tells us that, among other bindings, <literal>f</literal> is in scope.
+ However, its type is not fully known yet,
+ and thus it is not possible to apply it to any
arguments. Nevertheless, observe that the type of its first argument is the
same as the type of <literal>x</literal>, and its result type is shared
with <literal>_result</literal>.
<para>
As we demonstrated earlier (<xref linkend="breakpoints" />), the
- debugger has some intelligence built-in to update the type of
- <literal>f</literal> whenever the types of <literal>x</literal> or
+ debugger has some intelligence built-in to update the type of
+ <literal>f</literal> whenever the types of <literal>x</literal> or
<literal>_result</literal> are discovered. So what we do in this
scenario is
- force <literal>x</literal> a bit, in order to recover both its type
- and the argument part of <literal>f</literal>.
+ force <literal>x</literal> a bit, in order to recover both its type
+ and the argument part of <literal>f</literal>.
<screen>
*Main> seq x ()
*Main> :print x
</para>
<para>
We can check now that as expected, the type of <literal>x</literal>
- has been reconstructed, and with it the
+ has been reconstructed, and with it the
type of <literal>f</literal> has been too:</para>
<screen>
*Main> :t x
</screen>
<para>
From here, we can apply f to any argument of type Integer and observe
- the results.
+ the results.
<screen><![CDATA[
*Main> let b = f 10
*Main> :t b
*Main> map f [1..5]
[Just 1, Just 2, Just 3, Just 4, Just 5]
]]></screen>
- In the first application of <literal>f</literal>, we had to do
+ In the first application of <literal>f</literal>, we had to do
some more type reconstruction
- in order to recover the result type of <literal>f</literal>.
- But after that, we are free to use
+ in order to recover the result type of <literal>f</literal>.
+ But after that, we are free to use
<literal>f</literal> normally.
</para>
</sect2>
CAF at the prompt again.</para>
</listitem>
<listitem><para>
- Implicit parameters (see <xref linkend="implicit-parameters"/>) are only available
+ Implicit parameters (see <xref linkend="implicit-parameters"/>) are only available
at the scope of a breakpoint if there is an explicit type signature.
</para>
</listitem>
GHCi, version 6.8.1: http://www.haskell.org/ghc/ :? for help
Loading package base ... linking ... done.
Loading package readline-1.0 ... linking ... done.
-Prelude>
+Prelude>
</screen>
<para>The following command works to load new packages into a
<sect2>
<title>Extra libraries</title>
<indexterm><primary>libraries</primary><secondary>with GHCi</secondary></indexterm>
-
+
<para>Extra libraries may be specified on the command line using
the normal <literal>-l<replaceable>lib</replaceable></literal>
option. (The term <emphasis>library</emphasis> here refers to
modules from packages) only the non-<literal>*</literal>
form of <literal>:browse</literal> is available.
If the <literal>!</literal> symbol is appended to the
- command, data constructors and class methods will be
+ command, data constructors and class methods will be
listed individually, otherwise, they will only be listed
- in the context of their data type or class declaration.
- The <literal>!</literal>-form also annotates the listing
- with comments giving possible imports for each group of
+ in the context of their data type or class declaration.
+ The <literal>!</literal>-form also annotates the listing
+ with comments giving possible imports for each group of
entries.</para>
<screen>
Prelude> :browse! Data.Maybe
<varlistentry>
<term>
- <literal>:continue</literal>
+ <literal>:continue</literal>
<indexterm><primary><literal>:continue</literal></primary></indexterm>
</term>
<listitem><para>Continue the current evaluation, when stopped at a
<varlistentry>
<term>
- <literal>:delete * | <replaceable>num</replaceable> ...</literal>
+ <literal>:delete * | <replaceable>num</replaceable> ...</literal>
<indexterm><primary><literal>:delete</literal></primary></indexterm>
</term>
<listitem>
<varlistentry>
<term>
- <literal>:etags</literal>
+ <literal>:etags</literal>
</term>
<listitem>
<para>See <literal>:ctags</literal>.</para>
the location of its definition in the source.</para>
<para>For types and classes, GHCi also summarises instances that
mention them. To avoid showing irrelevant information, an instance
- is shown only if (a) its head mentions <replaceable>name</replaceable>,
+ is shown only if (a) its head mentions <replaceable>name</replaceable>,
and (b) all the other things mentioned in the instance
- are in scope (either qualified or otherwise) as a result of
+ are in scope (either qualified or otherwise) as a result of
a <literal>:load</literal> or <literal>:module</literal> commands. </para>
</listitem>
</varlistentry>
<varlistentry>
<term>
- <literal>:script</literal> <optional><replaceable>n</replaceable></optional>
+ <literal>:script</literal> <optional><replaceable>n</replaceable></optional>
<literal>filename</literal>
<indexterm><primary><literal>:script</literal></primary></indexterm>
</term>
<varlistentry>
<term>
- <literal>:step [<replaceable>expr</replaceable>]</literal>
+ <literal>:step [<replaceable>expr</replaceable>]</literal>
<indexterm><primary><literal>:step</literal></primary></indexterm>
</term>
<listitem>
top-level expressions to be discarded after each
evaluation (they are still retained
<emphasis>during</emphasis> a single evaluation).</para>
-
+
<para>This option may help if the evaluated top-level
expressions are consuming large amounts of space, or if
you need repeatable performance measurements.</para>
<screen>
Prelude> :set -fglasgow-exts
</screen>
-
+
<para>Any GHC command-line option that is designated as
<firstterm>dynamic</firstterm> (see the table in <xref
linkend="flag-reference"/>), may be set using
defining useful macros. Placing a <filename>.ghci</filename> file
in a directory with a Haskell project is a useful way to set
certain project-wide options so you don't have to type them
- everytime you start GHCi: eg. if your project uses GHC extensions
+ every time you start GHCi: eg. if your project uses GHC extensions
and CPP, and has source files in three subdirectories A, B and C,
you might put the following lines in
<filename>.ghci</filename>:</para>
:def source readFile
</screen>
- <para>With this macro defined in your <filename>.ghci</filename>
+ <para>With this macro defined in your <filename>.ghci</filename>
file, you can use <literal>:source file</literal> to read GHCi
commands from <literal>file</literal>. You can find (and contribute!-)
other suggestions for <filename>.ghci</filename> files on this Haskell
<sect1 id="ghci-faq">
<title>FAQ and Things To Watch Out For</title>
-
+
<variablelist>
<varlistentry>
<term>The interpreter can't load modules with foreign export
because this is normally what you want in an interpreter:
output appears as it is generated.
</para>
- <para>
- If you want line-buffered behaviour, as in GHC, you can
+ <para>
+ If you want line-buffered behaviour, as in GHC, you can
start your program thus:
<programlisting>
main = do { hSetBuffering stdout LineBuffering; ... }
<para>Language options can be controlled in two ways:
<itemizedlist>
- <listitem><para>Every language option can switched on by a command-line flag "<option>-X...</option>"
- (e.g. <option>-XTemplateHaskell</option>), and switched off by the flag "<option>-XNo...</option>";
+ <listitem><para>Every language option can switched on by a command-line flag "<option>-X...</option>"
+ (e.g. <option>-XTemplateHaskell</option>), and switched off by the flag "<option>-XNo...</option>";
(e.g. <option>-XNoTemplateHaskell</option>).</para></listitem>
<listitem><para>
Language options recognised by Cabal can also be enabled using the <literal>LANGUAGE</literal> pragma,
<para>The flag <option>-fglasgow-exts</option>
<indexterm><primary><option>-fglasgow-exts</option></primary></indexterm>
- is equivalent to enabling the following extensions:
+ is equivalent to enabling the following extensions:
&what_glasgow_exts_does;
- Enabling these options is the <emphasis>only</emphasis>
+ Enabling these options is the <emphasis>only</emphasis>
effect of <option>-fglasgow-exts</option>.
- We are trying to move away from this portmanteau flag,
+ We are trying to move away from this portmanteau flag,
and towards enabling features individually.</para>
</sect1>
unboxed version in any case. And if it isn't, we'd like to know
about it.</para>
-<para>All these primitive data types and operations are exported by the
-library <literal>GHC.Prim</literal>, for which there is
+<para>All these primitive data types and operations are exported by the
+library <literal>GHC.Prim</literal>, for which there is
<ulink url="&libraryGhcPrimLocation;/GHC-Prim.html">detailed online documentation</ulink>.
(This documentation is generated from the file <filename>compiler/prelude/primops.txt.pp</filename>.)
</para>
names you need the <option>-XMagicHash</option> extension (<xref linkend="magic-hash"/>).
</para>
-<para>The primops make extensive use of <link linkend="glasgow-unboxed">unboxed types</link>
+<para>The primops make extensive use of <link linkend="glasgow-unboxed">unboxed types</link>
and <link linkend="unboxed-tuples">unboxed tuples</link>, which
we briefly summarise here. </para>
-
+
<sect2 id="glasgow-unboxed">
<title>Unboxed types
</title>
Primitive (unboxed) types cannot be defined in Haskell, and are
therefore built into the language and compiler. Primitive types are
always unlifted; that is, a value of a primitive type cannot be
-bottom. We use the convention (but it is only a convention)
+bottom. We use the convention (but it is only a convention)
that primitive types, values, and
operations have a <literal>#</literal> suffix (see <xref linkend="magic-hash"/>).
For some primitive types we have special syntax for literals, also
f x = let (# p,q #) = h x in ..body..
</programlisting>
If the types of <literal>p</literal> and <literal>q</literal> are not unboxed,
-the resulting binding is lazy like any other Haskell pattern binding. The
+the resulting binding is lazy like any other Haskell pattern binding. The
above example desugars like this:
<programlisting>
f x = let t = case h x o f{ (# p,q #) -> (p,q)
<sect1 id="syntax-extns">
<title>Syntactic extensions</title>
-
+
<sect2 id="unicode-syntax">
<title>Unicode syntax</title>
<para>The language
postfix modifier to identifiers. Thus, "x#" is a valid variable, and "T#" is
a valid type constructor or data constructor.</para>
- <para>The hash sign does not change sematics at all. We tend to use variable
- names ending in "#" for unboxed values or types (e.g. <literal>Int#</literal>),
- but there is no requirement to do so; they are just plain ordinary variables.
+ <para>The hash sign does not change semantics at all. We tend to use variable
+ names ending in "#" for unboxed values or types (e.g. <literal>Int#</literal>),
+ but there is no requirement to do so; they are just plain ordinary variables.
Nor does the <option>-XMagicHash</option> extension bring anything into scope.
- For example, to bring <literal>Int#</literal> into scope you must
- import <literal>GHC.Prim</literal> (see <xref linkend="primitives"/>);
+ For example, to bring <literal>Int#</literal> into scope you must
+ import <literal>GHC.Prim</literal> (see <xref linkend="primitives"/>);
the <option>-XMagicHash</option> extension
then allows you to <emphasis>refer</emphasis> to the <literal>Int#</literal>
that is now in scope.</para>
<para> The <option>-XMagicHash</option> also enables some new forms of literals (see <xref linkend="glasgow-unboxed"/>):
- <itemizedlist>
+ <itemizedlist>
<listitem><para> <literal>'x'#</literal> has type <literal>Char#</literal></para> </listitem>
<listitem><para> <literal>"foo"#</literal> has type <literal>Addr#</literal></para> </listitem>
<listitem><para> <literal>3#</literal> has type <literal>Int#</literal>. In general,
</programlisting>
<para>
-The auxiliary functions are
+The auxiliary functions are
</para>
<programlisting>
of pattern-matching, guarded equations as case expressions; that is
precisely what the compiler does when compiling equations! The reason that
Haskell provides guarded equations is because they allow us to write down
-the cases we want to consider, one at a time, independently of each other.
+the cases we want to consider, one at a time, independently of each other.
This structure is hidden in the case version. Two of the right-hand sides
are really the same (<function>fail</function>), and the whole expression
-tends to become more and more indented.
+tends to become more and more indented.
</para>
<para>
</programlisting>
<para>
-The semantics should be clear enough. The qualifiers are matched in order.
+The semantics should be clear enough. The qualifiers are matched in order.
For a <literal><-</literal> qualifier, which I call a pattern guard, the
-right hand side is evaluated and matched against the pattern on the left.
+right hand side is evaluated and matched against the pattern on the left.
If the match fails then the whole guard fails and the next equation is
tried. If it succeeds, then the appropriate binding takes place, and the
next qualifier is matched, in the augmented environment. Unlike list
<programlisting>
type Typ
-
+
data TypView = Unit
| Arrow Typ Typ
The representation of Typ is held abstract, permitting implementations
to use a fancy representation (e.g., hash-consing to manage sharing).
-Without view patterns, using this signature a little inconvenient:
+Without view patterns, using this signature a little inconvenient:
<programlisting>
size :: Typ -> Integer
size t = case view t of
<para>
View patterns permit calling the view function inside the pattern and
-matching against the result:
+matching against the result:
<programlisting>
size (view -> Unit) = 1
size (view -> Arrow t1 t2) = size t1 + size t2
</para>
<para>
-More precisely, the scoping rules are:
+More precisely, the scoping rules are:
<itemizedlist>
<listitem>
<para>
example f (f -> 4) = True
</programlisting>
That is, the scoping is the same as it would be if the curried arguments
-were collected into a tuple.
+were collected into a tuple.
</para>
</listitem>
(y -> x) = e2 } in x
</programlisting>
-(For some amplification on this design choice see
+(For some amplification on this design choice see
<ulink url="http://hackage.haskell.org/trac/ghc/ticket/4061">Trac #4061</ulink>.)
</para>
<ulink url="http://www.haskell.org/onlinereport/">Haskell 98
Report</ulink>, add the following:
<programlisting>
-case v of { (e -> p) -> e1 ; _ -> e2 }
- =
+case v of { (e -> p) -> e1 ; _ -> e2 }
+ =
case (e v) of { p -> e1 ; _ -> e2 }
</programlisting>
That is, to match a variable <replaceable>v</replaceable> against a pattern
<literal>)</literal>, evaluate <literal>(</literal>
<replaceable>exp</replaceable> <replaceable> v</replaceable>
<literal>)</literal> and match the result against
-<replaceable>pat</replaceable>.
+<replaceable>pat</replaceable>.
</para></listitem>
<listitem><para> Efficiency: When the same view function is applied in
<para>
The do-notation of Haskell 98 does not allow <emphasis>recursive bindings</emphasis>,
-that is, the variables bound in a do-expression are visible only in the textually following
+that is, the variables bound in a do-expression are visible only in the textually following
code block. Compare this to a let-expression, where bound variables are visible in the entire binding
group. It turns out that several applications can benefit from recursive bindings in
the do-notation. The <option>-XDoRec</option> flag provides the necessary syntactic support.
The background and motivation for recursive do-notation is described in
<ulink url="http://sites.google.com/site/leventerkok/">A recursive do for Haskell</ulink>,
by Levent Erkok, John Launchbury,
-Haskell Workshop 2002, pages: 29-37. Pittsburgh, Pennsylvania.
+Haskell Workshop 2002, pages: 29-37. Pittsburgh, Pennsylvania.
The theory behind monadic value recursion is explained further in Erkok's thesis
<ulink url="http://sites.google.com/site/leventerkok/erkok-thesis.pdf">Value Recursion in Monadic Computations</ulink>.
However, note that GHC uses a different syntax than the one described in these documents.
producing a single statement.
</para>
<para>Similar to a <literal>let</literal>
-statement, the variables bound in the <literal>rec</literal> are
+statement, the variables bound in the <literal>rec</literal> are
visible throughout the <literal>rec</literal> group, and below it.
For example, compare
<programlisting>
-do { a <- getChar do { a <- getChar
- ; let { r1 = f a r2 ; rec { r1 <- f a r2
- ; r2 = g r1 } ; r2 <- g r1 }
+do { a <- getChar do { a <- getChar
+ ; let { r1 = f a r2 ; rec { r1 <- f a r2
+ ; r2 = g r1 } ; r2 <- g r1 }
; return (r1 ++ r2) } ; return (r1 ++ r2) }
</programlisting>
-In both cases, <literal>r1</literal> and <literal>r2</literal> are
+In both cases, <literal>r1</literal> and <literal>r2</literal> are
available both throughout the <literal>let</literal> or <literal>rec</literal> block, and
in the statements that follow it. The difference is that <literal>let</literal> is non-monadic,
-while <literal>rec</literal> is monadic. (In Haskell <literal>let</literal> is
+while <literal>rec</literal> is monadic. (In Haskell <literal>let</literal> is
really <literal>letrec</literal>, of course.)
</para>
<para>
-The static and dynamic semantics of <literal>rec</literal> can be described as follows:
+The static and dynamic semantics of <literal>rec</literal> can be described as follows:
<itemizedlist>
<listitem><para>
First,
-similar to let-bindings, the <literal>rec</literal> is broken into
+similar to let-bindings, the <literal>rec</literal> is broken into
minimal recursive groups, a process known as <emphasis>segmentation</emphasis>.
For example:
<programlisting>
rec { a <- getChar ===> a <- getChar
; b <- f a c rec { b <- f a c
; c <- f b a ; c <- f b a }
- ; putChar c } putChar c
+ ; putChar c } putChar c
</programlisting>
The details of segmentation are described in Section 3.2 of
<ulink url="http://sites.google.com/site/leventerkok/">A recursive do for Haskell</ulink>.
-Segmentation improves polymorphism, reduces the size of the recursive "knot", and, as the paper
+Segmentation improves polymorphism, reduces the size of the recursive "knot", and, as the paper
describes, also has a semantic effect (unless the monad satisfies the right-shrinking law).
</para></listitem>
<listitem><para>
</programlisting>
where <replaceable>vs</replaceable> is a tuple of the variables bound by <replaceable>ss</replaceable>.
</para><para>
-The original <literal>rec</literal> typechecks exactly
-when the above desugared version would do so. For example, this means that
+The original <literal>rec</literal> typechecks exactly
+when the above desugared version would do so. For example, this means that
the variables <replaceable>vs</replaceable> are all monomorphic in the statements
following the <literal>rec</literal>, because they are bound by a lambda.
</para>
<para>
-The <literal>mfix</literal> function is defined in the <literal>MonadFix</literal>
+The <literal>mfix</literal> function is defined in the <literal>MonadFix</literal>
class, in <literal>Control.Monad.Fix</literal>, thus:
<programlisting>
class Monad m => MonadFix m where
</para></listitem>
<listitem><para>
-The following instances of <literal>MonadFix</literal> are automatically provided: List, Maybe, IO.
-Furthermore, the Control.Monad.ST and Control.Monad.ST.Lazy modules provide the instances of the MonadFix class
+The following instances of <literal>MonadFix</literal> are automatically provided: List, Maybe, IO.
+Furthermore, the Control.Monad.ST and Control.Monad.ST.Lazy modules provide the instances of the MonadFix class
for Haskell's internal state monad (strict and lazy, respectively).
</para></listitem>
<listitem><para>
Like <literal>let</literal> and <literal>where</literal> bindings,
-name shadowing is not allowed within a <literal>rec</literal>;
+name shadowing is not allowed within a <literal>rec</literal>;
that is, all the names bound in a single <literal>rec</literal> must
be distinct (Section 3.3 of the paper).
</para></listitem>
example, the following zips together two lists:</para>
<programlisting>
- [ (x, y) | x <- xs | y <- ys ]
+ [ (x, y) | x <- xs | y <- ys ]
</programlisting>
<para>The behavior of parallel list comprehensions follows that of
<para>Given a parallel comprehension of the form: </para>
<programlisting>
- [ e | p1 <- e11, p2 <- e12, ...
- | q1 <- e21, q2 <- e22, ...
- ...
- ]
+ [ e | p1 <- e11, p2 <- e12, ...
+ | q1 <- e21, q2 <- e22, ...
+ ...
+ ]
</programlisting>
<para>This will be translated to: </para>
<programlisting>
- [ e | ((p1,p2), (q1,q2), ...) <- zipN [(p1,p2) | p1 <- e11, p2 <- e12, ...]
- [(q1,q2) | q1 <- e21, q2 <- e22, ...]
- ...
- ]
+ [ e | ((p1,p2), (q1,q2), ...) <- zipN [(p1,p2) | p1 <- e11, p2 <- e12, ...]
+ [(q1,q2) | q1 <- e21, q2 <- e22, ...]
+ ...
+ ]
</programlisting>
<para>where `zipN' is the appropriate zip for the given number of
branches.</para>
</sect2>
-
+
<!-- ===================== TRANSFORM LIST COMPREHENSIONS =================== -->
<sect2 id="generalised-list-comprehensions">
Comprehensive comprehensions: comprehensions with "order by" and "group by"</ulink>,
except that the syntax we use differs slightly from the paper.</para>
<para>The extension is enabled with the flag <option>-XTransformListComp</option>.</para>
-<para>Here is an example:
+<para>Here is an example:
<programlisting>
employees = [ ("Simon", "MS", 80)
, ("Erik", "MS", 100)
, then sortWith by (sum salary)
, then take 5 ]
</programlisting>
-In this example, the list <literal>output</literal> would take on
+In this example, the list <literal>output</literal> would take on
the value:
-
+
<programlisting>
[("Yale", 60), ("Ed", 85), ("MS", 180)]
</programlisting>
all introduced by the (existing) keyword <literal>then</literal>:
<itemizedlist>
<listitem>
-
+
<programlisting>
then f
</programlisting>
This statement requires that <literal>f</literal> have the type <literal>
forall a. [a] -> [a]</literal>. You can see an example of its use in the
motivating example, as this form is used to apply <literal>take 5</literal>.
-
+
</listitem>
-
-
+
+
<listitem>
<para>
<programlisting>
</programlisting>
This form is similar to the previous one, but allows you to create a function
- which will be passed as the first argument to f. As a consequence f must have
+ which will be passed as the first argument to f. As a consequence f must have
the type <literal>forall a. (a -> t) -> [a] -> [a]</literal>. As you can see
- from the type, this function lets f "project out" some information
+ from the type, this function lets f "project out" some information
from the elements of the list it is transforming.</para>
- <para>An example is shown in the opening example, where <literal>sortWith</literal>
- is supplied with a function that lets it find out the <literal>sum salary</literal>
+ <para>An example is shown in the opening example, where <literal>sortWith</literal>
+ is supplied with a function that lets it find out the <literal>sum salary</literal>
for any item in the list comprehension it transforms.</para>
</listitem>
at every point after this statement, binders occurring before it in the comprehension
refer to <emphasis>lists</emphasis> of possible values, not single values. To help understand
this, let's look at an example:</para>
-
+
<programlisting>
-- This works similarly to groupWith in GHC.Exts, but doesn't sort its input first
groupRuns :: Eq b => (a -> b) -> [a] -> [[a]]
[(1, [4, 5, 6]), (2, [4, 5, 6]), (3, [4, 5, 6]), (1, [4, 5, 6]), (2, [4, 5, 6])]
</programlisting>
- <para>Note that we have used the <literal>the</literal> function to change the type
- of x from a list to its original numeric type. The variable y, in contrast, is left
+ <para>Note that we have used the <literal>the</literal> function to change the type
+ of x from a list to its original numeric type. The variable y, in contrast, is left
unchanged from the list form introduced by the grouping.</para>
</listitem>
<para>This form of grouping is essentially the same as the one described above. However,
since no function to use for the grouping has been supplied it will fall back on the
- <literal>groupWith</literal> function defined in
+ <literal>groupWith</literal> function defined in
<ulink url="&libraryBaseLocation;/GHC-Exts.html"><literal>GHC.Exts</literal></ulink>. This
is the form of the group statement that we made use of in the opening example.</para>
</listitem>
-
-
+
+
<listitem>
<programlisting>
<para>With this form of the group statement, f is required to simply have the type
<literal>forall a. [a] -> [[a]]</literal>, which will be used to group up the
comprehension so far directly. An example of this form is as follows:</para>
-
+
<programlisting>
output = [ x
| y <- [1..5]
<indexterm><primary>monad comprehensions</primary></indexterm>
<para>
- Monad comprehesions generalise the list comprehension notation,
- including parallel comprehensions
- (<xref linkend="parallel-list-comprehensions"/>) and
- transform comprenensions (<xref linkend="generalised-list-comprehensions"/>)
+ Monad comprehensions generalise the list comprehension notation,
+ including parallel comprehensions
+ (<xref linkend="parallel-list-comprehensions"/>) and
+ transform comprehensions (<xref linkend="generalised-list-comprehensions"/>)
to work for any monad.
</para>
compatible to built-in, transform and parallel list comprehensions.
</para>
<para> More formally, the desugaring is as follows. We write <literal>D[ e | Q]</literal>
-to mean the desugaring of the monad comprehension <literal>[ e | Q]</literal>:
+to mean the desugaring of the monad comprehension <literal>[ e | Q]</literal>:
<programlisting>
Expressions: e
Declarations: d
-Lists of qualifiers: Q,R,S
+Lists of qualifiers: Q,R,S
-- Basic forms
D[ e | ] = return e
D[ e | Q then f by b, R ] = f b D[ Qv | Q ] >>= \Qv -> D[ e | R ]
-D[ e | Q then group using f, R ] = f D[ Qv | Q ] >>= \ys ->
+D[ e | Q then group using f, R ] = f D[ Qv | Q ] >>= \ys ->
case (fmap selQv1 ys, ..., fmap selQvn ys) of
Qv -> D[ e | R ]
-D[ e | Q then group by b using f, R ] = f b D[ Qv | Q ] >>= \ys ->
+D[ e | Q then group by b using f, R ] = f b D[ Qv | Q ] >>= \ys ->
case (fmap selQv1 ys, ..., fmap selQvn ys) of
Qv -> D[ e | R ]
fmap GHC.Base forall a b. (a->b) -> n a -> n b
mgroupWith Control.Monad.Group forall a. (a -> t) -> m1 a -> m2 (n a)
mzip Control.Monad.Zip forall a b. m a -> m b -> m (a,b)
-</programlisting>
-The comprehension should typecheck when its desugaring would typecheck.
+</programlisting>
+The comprehension should typecheck when its desugaring would typecheck.
</para>
<para>
-Monad comprehensions support rebindable syntax (<xref linkend="rebindable-syntax"/>).
+Monad comprehensions support rebindable syntax (<xref linkend="rebindable-syntax"/>).
Without rebindable
syntax, the operators from the "standard binding" module are used; with
rebindable syntax, the operators are looked up in the current lexical scope.
using whatever "<literal>mzip</literal>" is in scope.
</para>
<para>
-The rebindable operators must have the "Expected type" given in the
+The rebindable operators must have the "Expected type" given in the
table above. These types are surprisingly general. For example, you can
use a bind operator with the type
<programlisting>
hierarchy. It completely defeats that purpose if the
literal "1" means "<literal>Prelude.fromInteger
1</literal>", which is what the Haskell Report specifies.
- So the <option>-XRebindableSyntax</option>
+ So the <option>-XRebindableSyntax</option>
flag causes
the following pieces of built-in syntax to refer to
<emphasis>whatever is in scope</emphasis>, not the Prelude
<para>An integer literal <literal>368</literal> means
"<literal>fromInteger (368::Integer)</literal>", rather than
"<literal>Prelude.fromInteger (368::Integer)</literal>".
-</para> </listitem>
+</para> </listitem>
<listitem><para>Fractional literals are handed in just the same way,
- except that the translation is
+ except that the translation is
<literal>fromRational (3.68::Rational)</literal>.
-</para> </listitem>
+</para> </listitem>
<listitem><para>The equality test in an overloaded numeric pattern
uses whatever <literal>(==)</literal> is in scope.
-</para> </listitem>
+</para> </listitem>
<listitem><para>The subtraction operation, and the
greater-than-or-equal test, in <literal>n+k</literal> patterns
</para>
<para>
In all cases (apart from arrow notation), the static semantics should be that of the desugared form,
-even if that is a little unexpected. For example, the
+even if that is a little unexpected. For example, the
static semantics of the literal <literal>368</literal>
is exactly that of <literal>fromInteger (368::Integer)</literal>; it's fine for
<literal>fromInteger</literal> to have any of the types:
fromInteger :: Integer -> Bool -> Bool
</programlisting>
</para>
-
+
<para>Be warned: this is an experimental facility, with
fewer checks than usual. Use <literal>-dcore-lint</literal>
to typecheck the desugared program. If Core Lint is happy
import M
data T = MkT { x :: Int }
-
+
ok1 (MkS { x = n }) = n+1 -- Unambiguous
ok2 n = MkT { x = n+1 } -- Unambiguous
Haskell 98 regards all four as ambiguous, but with the
<option>-XDisambiguateRecordFields</option> flag, GHC will accept
the former two. The rules are precisely the same as those for instance
-declarations in Haskell 98, where the method names on the left-hand side
+declarations in Haskell 98, where the method names on the left-hand side
of the method bindings in an instance declaration refer unambiguously
to the method of that class (provided they are in scope at all), even
if there are other variables in scope with the same name.
Some details:
<itemizedlist>
<listitem><para>
-Field disambiguation can be combined with punning (see <xref linkend="record-puns"/>). For exampe:
+Field disambiguation can be combined with punning (see <xref linkend="record-puns"/>). For example:
<programlisting>
module Foo where
import M
</para></listitem>
<listitem><para>
-With <option>-XDisambiguateRecordFields</option> you can use <emphasis>unqualifed</emphasis>
-field names even if the correponding selector is only in scope <emphasis>qualified</emphasis>
+With <option>-XDisambiguateRecordFields</option> you can use <emphasis>unqualified</emphasis>
+field names even if the corresponding selector is only in scope <emphasis>qualified</emphasis>
For example, assuming the same module <literal>M</literal> as in our earlier example, this is legal:
<programlisting>
module Foo where
ok4 (M.MkS { x = n }) = n+1 -- Unambiguous
</programlisting>
-Since the constructore <literal>MkS</literal> is only in scope qualified, you must
+Since the constructor <literal>MkS</literal> is only in scope qualified, you must
name it <literal>M.MkS</literal>, but the field <literal>x</literal> does not need
to be qualified even though <literal>M.x</literal> is in scope but <literal>x</literal>
is not. (In effect, it is qualified by the constructor.)
to mean the same pattern as above. That is, in a record pattern, the
pattern <literal>a</literal> expands into the pattern <literal>a =
-a</literal> for the same name <literal>a</literal>.
+a</literal> for the same name <literal>a</literal>.
</para>
<para>
<programlisting>
let a = 1 in C {a}
</programlisting>
-instead of
+instead of
<programlisting>
let a = 1 in C {a = a}
</programlisting>
<listitem><para>
Puns can be used wherever record patterns occur (e.g. in
-<literal>let</literal> bindings or at the top-level).
+<literal>let</literal> bindings or at the top-level).
</para></listitem>
<listitem><para>
</para></listitem>
<listitem><para>
-The "<literal>..</literal>" expands to the missing
+The "<literal>..</literal>" expands to the missing
<emphasis>in-scope</emphasis> record fields, where "in scope"
-includes both unqualified and qualified-only.
+includes both unqualified and qualified-only.
Any fields that are not in scope are not filled in. For example
<programlisting>
module M where
<programlisting>
let f = ...
infixr 3 `f`
-in
+in
...
</programlisting>
and the fixity declaration applies wherever the binding is in scope.
<programlisting>
import "network" Network.Socket
</programlisting>
-
+
<para>would import the module <literal>Network.Socket</literal> from
the package <literal>network</literal> (any version). This may
be used to disambiguate an import when the same module is
"stolen" by language extensions.
We use
notation and nonterminal names from the Haskell 98 lexical syntax
- (see the Haskell 98 Report).
+ (see the Haskell 98 Report).
We only list syntax changes here that might affect
existing working programs (i.e. "stolen" syntax). Many of these
extensions will also enable new context-free syntax, but in all
on.</para>
</listitem>
</itemizedlist>
-
+
The following syntax is stolen:
<variablelist>
<varlistentry>
<term>
<replaceable>varid</replaceable>{<literal>#</literal>},
- <replaceable>char</replaceable><literal>#</literal>,
- <replaceable>string</replaceable><literal>#</literal>,
- <replaceable>integer</replaceable><literal>#</literal>,
- <replaceable>float</replaceable><literal>#</literal>,
- <replaceable>float</replaceable><literal>##</literal>,
- <literal>(#</literal>, <literal>#)</literal>,
+ <replaceable>char</replaceable><literal>#</literal>,
+ <replaceable>string</replaceable><literal>#</literal>,
+ <replaceable>integer</replaceable><literal>#</literal>,
+ <replaceable>float</replaceable><literal>#</literal>,
+ <replaceable>float</replaceable><literal>##</literal>,
+ <literal>(#</literal>, <literal>#)</literal>,
</term>
<listitem><para>
Stolen by: <option>-XMagicHash</option>,
data T a -- T :: * -> *
</programlisting>
-<para>Syntactically, the declaration lacks the "= constrs" part. The
+<para>Syntactically, the declaration lacks the "= constrs" part. The
type can be parameterised over types of any kind, but if the kind is
not <literal>*</literal> then an explicit kind annotation must be used
(see <xref linkend="kinding"/>).</para>
type T (+) = Int + Int
f :: T Either
f = Left 3
-
+
liftA2 :: Arrow (~>)
=> (a -> b -> c) -> (e ~> a) -> (e ~> b) -> (e ~> c)
liftA2 = ...
on individual synonym declarations.
With the <option>-XLiberalTypeSynonyms</option> extension,
GHC does validity checking on types <emphasis>only after expanding type synonyms</emphasis>.
-That means that GHC can be very much more liberal about type synonyms than Haskell 98.
+That means that GHC can be very much more liberal about type synonyms than Haskell 98.
<itemizedlist>
<listitem> <para>You can write a <literal>forall</literal> (including overloading)
</listitem>
<listitem><para>
-If you also use <option>-XUnboxedTuples</option>,
+If you also use <option>-XUnboxedTuples</option>,
you can write an unboxed tuple in a type synonym:
<programlisting>
type Pr = (# Int, Int #)
You can apply a type synonym to a forall type:
<programlisting>
type Foo a = a -> a -> Bool
-
+
f :: Foo (forall b. b->b)
</programlisting>
After expanding the synonym, <literal>f</literal> has the legal (in GHC) type:
<programlisting>
type Generic i o = forall x. i x -> o x
type Id x = x
-
+
foo :: Generic Id []
</programlisting>
After expanding the synonym, <literal>foo</literal> has the legal (in GHC) type:
<programlisting>
inc :: Counter a -> Counter a
inc (NewCounter x i d t) = NewCounter
- { _this = i x, _inc = i, _display = d, tag = t }
+ { _this = i x, _inc = i, _display = d, tag = t }
display :: Counter a -> IO ()
display NewCounter{ _this = x, _display = d } = d x
Now we can define counters with different underlying implementations:
<programlisting>
-counterA :: Counter String
+counterA :: Counter String
counterA = NewCounter
{ _this = 0, _inc = (1+), _display = print, tag = "A" }
-counterB :: Counter String
+counterB :: Counter String
counterB = NewCounter
{ _this = "", _inc = ('#':), _display = putStrLn, tag = "B" }
Just :: a -> Maybe a
</programlisting>
The form is called a "GADT-style declaration"
-because Generalised Algebraic Data Types, described in <xref linkend="gadt"/>,
+because Generalised Algebraic Data Types, described in <xref linkend="gadt"/>,
can only be declared using this form.</para>
-<para>Notice that GADT-style syntax generalises existential types (<xref linkend="existential-quantification"/>).
+<para>Notice that GADT-style syntax generalises existential types (<xref linkend="existential-quantification"/>).
For example, these two declarations are equivalent:
<programlisting>
data Foo = forall a. MkFoo a (a -> Bool)
data Foo' where { MKFoo :: a -> (a->Bool) -> Foo' }
</programlisting>
</para>
-<para>Any data type that can be declared in standard Haskell-98 syntax
+<para>Any data type that can be declared in standard Haskell-98 syntax
can also be declared using GADT-style syntax.
The choice is largely stylistic, but GADT-style declarations differ in one important respect:
they treat class constraints on the data constructors differently.
insert a (MkSet as) | a `elem` as = MkSet as
| otherwise = MkSet (a:as)
</programlisting>
-A use of <literal>MkSet</literal> as a constructor (e.g. in the definition of <literal>makeSet</literal>)
+A use of <literal>MkSet</literal> as a constructor (e.g. in the definition of <literal>makeSet</literal>)
gives rise to a <literal>(Eq a)</literal>
constraint, as you would expect. The new feature is that pattern-matching on <literal>MkSet</literal>
(as in the definition of <literal>insert</literal>) makes <emphasis>available</emphasis> an <literal>(Eq a)</literal>
context. In implementation terms, the <literal>MkSet</literal> constructor has a hidden field that stores
the <literal>(Eq a)</literal> dictionary that is passed to <literal>MkSet</literal>; so
when pattern-matching that dictionary becomes available for the right-hand side of the match.
-In the example, the equality dictionary is used to satisfy the equality constraint
+In the example, the equality dictionary is used to satisfy the equality constraint
generated by the call to <literal>elem</literal>, so that the type of
<literal>insert</literal> itself has no <literal>Eq</literal> constraint.
</para>
plus :: NumInst a -> a -> a -> a
plus MkNumInst p q = p + q
</programlisting>
-Here, a value of type <literal>NumInst a</literal> is equivalent
+Here, a value of type <literal>NumInst a</literal> is equivalent
to an explicit <literal>(Num a)</literal> dictionary.
</para>
<para>
All this applies to constructors declared using the syntax of <xref linkend="existential-with-context"/>.
-For example, the <literal>NumInst</literal> data type above could equivalently be declared
+For example, the <literal>NumInst</literal> data type above could equivalently be declared
like this:
<programlisting>
- data NumInst a
+ data NumInst a
= Num a => MkNumInst (NumInst a)
</programlisting>
-Notice that, unlike the situation when declaring an existential, there is
+Notice that, unlike the situation when declaring an existential, there is
no <literal>forall</literal>, because the <literal>Num</literal> constrains the
-data type's universally quantified type variable <literal>a</literal>.
+data type's universally quantified type variable <literal>a</literal>.
A constructor may have both universal and existential type variables: for example,
the following two declarations are equivalent:
<programlisting>
- data T1 a
+ data T1 a
= forall b. (Num a, Eq b) => MkT1 a b
data T2 a where
MkT2 :: (Num a, Eq b) => a -> b -> T2 a
</programlisting>
</para>
-<para>All this behaviour contrasts with Haskell 98's peculiar treatment of
+<para>All this behaviour contrasts with Haskell 98's peculiar treatment of
contexts on a data type declaration (Section 4.2.1 of the Haskell 98 Report).
In Haskell 98 the definition
<programlisting>
data Eq a => Set' a = MkSet' [a]
</programlisting>
-gives <literal>MkSet'</literal> the same type as <literal>MkSet</literal> above. But instead of
+gives <literal>MkSet'</literal> the same type as <literal>MkSet</literal> above. But instead of
<emphasis>making available</emphasis> an <literal>(Eq a)</literal> constraint, pattern-matching
on <literal>MkSet'</literal> <emphasis>requires</emphasis> an <literal>(Eq a)</literal> constraint!
GHC faithfully implements this behaviour, odd though it is. But for GADT-style declarations,
<itemizedlist>
<listitem><para>
The result type of each data constructor must begin with the type constructor being defined.
-If the result type of all constructors
+If the result type of all constructors
has the form <literal>T a1 ... an</literal>, where <literal>a1 ... an</literal>
are distinct type variables, then the data type is <emphasis>ordinary</emphasis>;
otherwise is a <emphasis>generalised</emphasis> data type (<xref linkend="gadt"/>).
<listitem><para>
The type signature of
-each constructor is independent, and is implicitly universally quantified as usual.
-In particular, the type variable(s) in the "<literal>data T a where</literal>" header
+each constructor is independent, and is implicitly universally quantified as usual.
+In particular, the type variable(s) in the "<literal>data T a where</literal>" header
have no scope, and different constructors may have different universally-quantified type variables:
<programlisting>
data T a where -- The 'a' has no scope
T1 :: Eq b => b -> b -> T b
T2 :: (Show c, Ix c) => c -> [c] -> T c
</programlisting>
-When patten matching, these constraints are made available to discharge constraints
+When pattern matching, these constraints are made available to discharge constraints
in the body of the match. For example:
<programlisting>
f :: T a -> String
</para></listitem>
<listitem><para>
-Unlike a Haskell-98-style
-data type declaration, the type variable(s) in the "<literal>data Set a where</literal>" header
+Unlike a Haskell-98-style
+data type declaration, the type variable(s) in the "<literal>data Set a where</literal>" header
have no scope. Indeed, one can write a kind signature instead:
<programlisting>
data Set :: * -> * where ...
Just1 :: a -> Maybe1 a
} deriving( Eq, Ord )
- data Maybe2 a = Nothing2 | Just2 a
+ data Maybe2 a = Nothing2 | Just2 a
deriving( Eq, Ord )
</programlisting>
</para></listitem>
Nil :: Foo
</programlisting>
Here the type variable <literal>a</literal> does not appear in the result type
-of either constructor.
+of either constructor.
Although it is universally quantified in the type of the constructor, such
-a type variable is often called "existential".
-Indeed, the above declaration declares precisely the same type as
+a type variable is often called "existential".
+Indeed, the above declaration declares precisely the same type as
the <literal>data Foo</literal> in <xref linkend="existential-quantification"/>.
</para><para>
The type may contain a class context too, of course:
As usual, for every constructor that has a field <literal>f</literal>, the type of
field <literal>f</literal> must be the same (modulo alpha conversion).
The <literal>Child</literal> constructor above shows that the signature
-may have a context, existentially-quantified variables, and strictness annotations,
+may have a context, existentially-quantified variables, and strictness annotations,
just as in the non-record case. (NB: the "type" that follows the double-colon
is not really a type, because of the record syntax and strictness annotations.
A "type" of this form can appear only in a constructor signature.)
</para></listitem>
-<listitem><para>
-Record updates are allowed with GADT-style declarations,
+<listitem><para>
+Record updates are allowed with GADT-style declarations,
only fields that have the following property: the type of the field
mentions no existential type variables.
</para></listitem>
-<listitem><para>
-As in the case of existentials declared using the Haskell-98-like record syntax
+<listitem><para>
+As in the case of existentials declared using the Haskell-98-like record syntax
(<xref linkend="existential-records"/>),
record-selector functions are generated only for those fields that have well-typed
-selectors.
+selectors.
Here is the example of that section, in GADT-style syntax:
<programlisting>
data Counter a where
<sect2 id="gadt">
<title>Generalised Algebraic Data Types (GADTs)</title>
-<para>Generalised Algebraic Data Types generalise ordinary algebraic data types
+<para>Generalised Algebraic Data Types generalise ordinary algebraic data types
by allowing constructors to have richer return types. Here is an example:
<programlisting>
data Term a where
Lit :: Int -> Term Int
Succ :: Term Int -> Term Int
- IsZero :: Term Int -> Term Bool
+ IsZero :: Term Int -> Term Bool
If :: Term Bool -> Term a -> Term a -> Term a
Pair :: Term a -> Term b -> Term (a,b)
</programlisting>
Notice that the return type of the constructors is not always <literal>Term a</literal>, as is the
-case with ordinary data types. This generality allows us to
+case with ordinary data types. This generality allows us to
write a well-typed <literal>eval</literal> function
for these <literal>Terms</literal>:
<programlisting>
eval (If b e1 e2) = if eval b then eval e1 else eval e2
eval (Pair e1 e2) = (eval e1, eval e2)
</programlisting>
-The key point about GADTs is that <emphasis>pattern matching causes type refinement</emphasis>.
+The key point about GADTs is that <emphasis>pattern matching causes type refinement</emphasis>.
For example, in the right hand side of the equation
<programlisting>
eval :: Term a -> a
eval (Lit i) = ...
</programlisting>
the type <literal>a</literal> is refined to <literal>Int</literal>. That's the whole point!
-A precise specification of the type rules is beyond what this user manual aspires to,
+A precise specification of the type rules is beyond what this user manual aspires to,
but the design closely follows that described in
the paper <ulink
url="http://research.microsoft.com/%7Esimonpj/papers/gadt/">Simple
unification-based type inference for GADTs</ulink>,
(ICFP 2006).
-The general principle is this: <emphasis>type refinement is only carried out
+The general principle is this: <emphasis>type refinement is only carried out
based on user-supplied type annotations</emphasis>.
-So if no type signature is supplied for <literal>eval</literal>, no type refinement happens,
+So if no type signature is supplied for <literal>eval</literal>, no type refinement happens,
and lots of obscure error messages will
occur. However, the refinement is quite general. For example, if we had:
<programlisting>
may use different notation to that implemented in GHC.
</para>
<para>
-The rest of this section outlines the extensions to GHC that support GADTs. The extension is enabled with
+The rest of this section outlines the extensions to GHC that support GADTs. The extension is enabled with
<option>-XGADTs</option>. The <option>-XGADTs</option> flag also sets <option>-XRelaxedPolyRec</option>.
<itemizedlist>
<listitem><para>
-A GADT can only be declared using GADT-style syntax (<xref linkend="gadt-style"/>);
+A GADT can only be declared using GADT-style syntax (<xref linkend="gadt-style"/>);
the old Haskell-98 syntax for data declarations always declares an ordinary data type.
The result type of each constructor must begin with the type constructor being defined,
-but for a GADT the arguments to the type constructor can be arbitrary monotypes.
+but for a GADT the arguments to the type constructor can be arbitrary monotypes.
For example, in the <literal>Term</literal> data
type above, the type of each constructor must end with <literal>Term ty</literal>, but
the <literal>ty</literal> need not be a type variable (e.g. the <literal>Lit</literal>
Lit { val :: Int } :: Term Int
Succ { num :: Term Int } :: Term Int
Pred { num :: Term Int } :: Term Int
- IsZero { arg :: Term Int } :: Term Bool
+ IsZero { arg :: Term Int } :: Term Bool
Pair { arg1 :: Term a
, arg2 :: Term b
} :: Term (a,b)
, fls :: Term a
} :: Term a
</programlisting>
-However, for GADTs there is the following additional constraint:
+However, for GADTs there is the following additional constraint:
every constructor that has a field <literal>f</literal> must have
the same result type (modulo alpha conversion)
-Hence, in the above example, we cannot merge the <literal>num</literal>
-and <literal>arg</literal> fields above into a
+Hence, in the above example, we cannot merge the <literal>num</literal>
+and <literal>arg</literal> fields above into a
single name. Although their field types are both <literal>Term Int</literal>,
their selector functions actually have different types:
</para></listitem>
<listitem><para>
-When pattern-matching against data constructors drawn from a GADT,
+When pattern-matching against data constructors drawn from a GADT,
for example in a <literal>case</literal> expression, the following rules apply:
<itemizedlist>
<listitem><para>The type of the scrutinee must be rigid.</para></listitem>
instance Eq (f a) => Eq (T1 f a) where ...
instance Eq (f (f a)) => Eq (T2 f a) where ...
</programlisting>
-The first of these is obviously fine. The second is still fine, although less obviously.
+The first of these is obviously fine. The second is still fine, although less obviously.
The third is not Haskell 98, and risks losing termination of instances.
</para>
<para>
GHC takes a conservative position: it accepts the first two, but not the third. The rule is this:
-each constraint in the inferred instance context must consist only of type variables,
+each constraint in the inferred instance context must consist only of type variables,
with no repetitions.
</para>
<para>
Note the following points:
<itemizedlist>
<listitem><para>
-You must supply an explicit context (in the example the context is <literal>(Eq a)</literal>),
+You must supply an explicit context (in the example the context is <literal>(Eq a)</literal>),
exactly as you would in an ordinary instance declaration.
-(In contrast, in a <literal>deriving</literal> clause
-attached to a data type declaration, the context is inferred.)
+(In contrast, in a <literal>deriving</literal> clause
+attached to a data type declaration, the context is inferred.)
</para></listitem>
<listitem><para>
<listitem><para>
Unlike a <literal>deriving</literal>
declaration attached to a <literal>data</literal> declaration, the instance can be more specific
-than the data type (assuming you also use
+than the data type (assuming you also use
<literal>-XFlexibleInstances</literal>, <xref linkend="instance-rules"/>). Consider
for example
<programlisting>
<listitem><para>
Unlike a <literal>deriving</literal>
-declaration attached to a <literal>data</literal> declaration,
+declaration attached to a <literal>data</literal> declaration,
GHC does not restrict the form of the data type. Instead, GHC simply generates the appropriate
boilerplate code for the specified class, and typechecks it. If there is a type error, it is
-your problem. (GHC will show you the offending code if it has a type error.)
+your problem. (GHC will show you the offending code if it has a type error.)
The merit of this is that you can derive instances for GADTs and other exotic
data types, providing only that the boilerplate code does indeed typecheck. For example:
<programlisting>
deriving instance Show (T a)
</programlisting>
-In this example, you cannot say <literal>... deriving( Show )</literal> on the
-data type declaration for <literal>T</literal>,
+In this example, you cannot say <literal>... deriving( Show )</literal> on the
+data type declaration for <literal>T</literal>,
because <literal>T</literal> is a GADT, but you <emphasis>can</emphasis> generate
the instance declaration using stand-alone deriving.
</para>
<title>Deriving clause for extra classes (<literal>Typeable</literal>, <literal>Data</literal>, etc)</title>
<para>
-Haskell 98 allows the programmer to add "<literal>deriving( Eq, Ord )</literal>" to a data type
-declaration, to generate a standard instance declaration for classes specified in the <literal>deriving</literal> clause.
+Haskell 98 allows the programmer to add "<literal>deriving( Eq, Ord )</literal>" to a data type
+declaration, to generate a standard instance declaration for classes specified in the <literal>deriving</literal> clause.
In Haskell 98, the only classes that may appear in the <literal>deriving</literal> clause are the standard
-classes <literal>Eq</literal>, <literal>Ord</literal>,
+classes <literal>Eq</literal>, <literal>Ord</literal>,
<literal>Enum</literal>, <literal>Ix</literal>, <literal>Bounded</literal>, <literal>Read</literal>, and <literal>Show</literal>.
</para>
<para>
(Section 7.4 of the paper describes the multiple <literal>Typeable</literal> classes that
are used, and only <literal>Typeable1</literal> up to
<literal>Typeable7</literal> are provided in the library.)
-In other cases, there is nothing to stop the programmer writing a <literal>TypableX</literal>
+In other cases, there is nothing to stop the programmer writing a <literal>TypeableX</literal>
class, whose kind suits that of the data type constructor, and
then writing the data type instance by hand.
</para>
as described in <xref linkend="generic-programming"/>.
</para></listitem>
-<listitem><para> With <option>-XDeriveFunctor</option>, you can derive instances of
+<listitem><para> With <option>-XDeriveFunctor</option>, you can derive instances of
the class <literal>Functor</literal>,
defined in <literal>GHC.Base</literal>.
</para></listitem>
-<listitem><para> With <option>-XDeriveFoldable</option>, you can derive instances of
+<listitem><para> With <option>-XDeriveFoldable</option>, you can derive instances of
the class <literal>Foldable</literal>,
defined in <literal>Data.Foldable</literal>.
</para></listitem>
-<listitem><para> With <option>-XDeriveTraversable</option>, you can derive instances of
+<listitem><para> With <option>-XDeriveTraversable</option>, you can derive instances of
the class <literal>Traversable</literal>,
defined in <literal>Data.Traversable</literal>.
</para></listitem>
</itemizedlist>
-In each case the appropriate class must be in scope before it
+In each case the appropriate class must be in scope before it
can be mentioned in the <literal>deriving</literal> clause.
</para>
</sect2>
example, if you define
<programlisting>
- newtype Dollars = Dollars Int
+ newtype Dollars = Dollars Int
</programlisting>
and you want to use arithmetic on <literal>Dollars</literal>, you have to
<sect3> <title> Generalising the deriving clause </title>
<para>
-GHC now permits such instances to be derived instead,
+GHC now permits such instances to be derived instead,
using the flag <option>-XGeneralizedNewtypeDeriving</option>,
-so one can write
+so one can write
<programlisting>
newtype Dollars = Dollars Int deriving (Eq,Show,Num)
</programlisting>
transformers, such that
<programlisting>
- instance Monad m => Monad (State s m)
+ instance Monad m => Monad (State s m)
instance Monad m => Monad (Failure m)
</programlisting>
-In Haskell 98, we can define a parsing monad by
+In Haskell 98, we can define a parsing monad by
<programlisting>
type Parser tok m a = State [tok] (Failure m) a
</programlisting>
newtype Parser tok m a = Parser (State [tok] (Failure m) a)
deriving Monad
</programlisting>
-In this case the derived instance declaration is of the form
+In this case the derived instance declaration is of the form
<programlisting>
- instance Monad (State [tok] (Failure m)) => Monad (Parser tok m)
+ instance Monad (State [tok] (Failure m)) => Monad (Parser tok m)
</programlisting>
Notice that, since <literal>Monad</literal> is a constructor class, the
clause. For example, given the class
<programlisting>
- class StateMonad s m | m -> s where ...
- instance Monad m => StateMonad s (State s m) where ...
+ class StateMonad s m | m -> s where ...
+ instance Monad m => StateMonad s (State s m) where ...
</programlisting>
-then we can derive an instance of <literal>StateMonad</literal> for <literal>Parser</literal>s by
+then we can derive an instance of <literal>StateMonad</literal> for <literal>Parser</literal>s by
<programlisting>
newtype Parser tok m a = Parser (State [tok] (Failure m) a)
deriving (Monad, StateMonad [tok])
declaration (after expansion of any type synonyms)
<programlisting>
- newtype T v1...vn = T' (t vk+1...vn) deriving (c1...cm)
+ newtype T v1...vn = T' (t vk+1...vn) deriving (c1...cm)
</programlisting>
-where
+where
<itemizedlist>
<listitem><para>
The <literal>ci</literal> are partial applications of
The type <literal>t</literal> is an arbitrary type.
</para></listitem>
<listitem><para>
- The type variables <literal>vk+1...vn</literal> do not occur in <literal>t</literal>,
+ The type variables <literal>vk+1...vn</literal> do not occur in <literal>t</literal>,
nor in the <literal>ci</literal>, and
</para></listitem>
<listitem><para>
- None of the <literal>ci</literal> is <literal>Read</literal>, <literal>Show</literal>,
+ None of the <literal>ci</literal> is <literal>Read</literal>, <literal>Show</literal>,
<literal>Typeable</literal>, or <literal>Data</literal>. These classes
should not "look through" the type or its constructor. You can still
- derive these classes for a newtype, but it happens in the usual way, not
- via this new mechanism.
+ derive these classes for a newtype, but it happens in the usual way, not
+ via this new mechanism.
</para></listitem>
</itemizedlist>
Then, for each <literal>ci</literal>, the derived instance
<programlisting>
instance ci t => ci (T v1...vk)
</programlisting>
-As an example which does <emphasis>not</emphasis> work, consider
+As an example which does <emphasis>not</emphasis> work, consider
<programlisting>
- newtype NonMonad m s = NonMonad (State s m s) deriving Monad
+ newtype NonMonad m s = NonMonad (State s m s) deriving Monad
</programlisting>
-Here we cannot derive the instance
+Here we cannot derive the instance
<programlisting>
- instance Monad (State s m) => Monad (NonMonad m)
+ instance Monad (State s m) => Monad (NonMonad m)
</programlisting>
because the type variable <literal>s</literal> occurs in <literal>State s m</literal>,
<literal>StateMonad</literal> class above were instead defined as
<programlisting>
- class StateMonad m s | m -> s where ...
+ class StateMonad m s | m -> s where ...
</programlisting>
then we would not have been able to derive an instance for the
instances is most interesting.
</para>
<para>Lastly, all of this applies only for classes other than
-<literal>Read</literal>, <literal>Show</literal>, <literal>Typeable</literal>,
+<literal>Read</literal>, <literal>Show</literal>, <literal>Typeable</literal>,
and <literal>Data</literal>, for which the built-in derivation applies (section
4.3.3. of the Haskell Report).
(For the standard classes <literal>Eq</literal>, <literal>Ord</literal>,
<sect3>
<title>Multi-parameter type classes</title>
<para>
-Multi-parameter type classes are permitted, with flag <option>-XMultiParamTypeClasses</option>.
+Multi-parameter type classes are permitted, with flag <option>-XMultiParamTypeClasses</option>.
For example:
<para>
In Haskell 98 the context of a class declaration (which introduces superclasses)
-must be simple; that is, each predicate must consist of a class applied to
-type variables. The flag <option>-XFlexibleContexts</option>
+must be simple; that is, each predicate must consist of a class applied to
+type variables. The flag <option>-XFlexibleContexts</option>
(<xref linkend="flexible-contexts"/>)
lifts this restriction,
-so that the only restriction on the context in a class declaration is
+so that the only restriction on the context in a class declaration is
that the class hierarchy must be acyclic. So these class declarations are OK:
elem :: Eq a => a -> s a -> Bool
</programlisting>
The type of <literal>elem</literal> is illegal in Haskell 98, because it
-contains the constraint <literal>Eq a</literal>, constrains only the
+contains the constraint <literal>Eq a</literal>, constrains only the
class type variable (in this case <literal>a</literal>).
GHC lifts this restriction (flag <option>-XConstrainedClassMethods</option>).
</para>
this is also the type of the default method. You can lift this restriction
and give another type to the default method using the flag
<option>-XDefaultSignatures</option>. For instance, if you have written a
-generic implementation of enumeration in a class <literal>GEnum</literal>
+generic implementation of enumeration in a class <literal>GEnum</literal>
with method <literal>genum</literal> in terms of <literal>GHC.Generics</literal>,
you can specify a default method that uses that generic implementation:
<programlisting>
</para>
<para>
-We use default signatures to simplify generic programming in GHC
+We use default signatures to simplify generic programming in GHC
(<xref linkend="generic-programming"/>).
</para>
</title>
<para> Functional dependencies are implemented as described by Mark Jones
-in “<ulink url="http://citeseer.ist.psu.edu/jones00type.html">Type Classes with Functional Dependencies</ulink>”, Mark P. Jones,
-In Proceedings of the 9th European Symposium on Programming,
+in “<ulink url="http://citeseer.ist.psu.edu/jones00type.html">Type Classes with Functional Dependencies</ulink>”, Mark P. Jones,
+In Proceedings of the 9th European Symposium on Programming,
ESOP 2000, Berlin, Germany, March 2000, Springer-Verlag LNCS 1782,
.
</para>
<para>
-Functional dependencies are introduced by a vertical bar in the syntax of a
-class declaration; e.g.
+Functional dependencies are introduced by a vertical bar in the syntax of a
+class declaration; e.g.
<programlisting>
class (Monad m) => MonadState s m | m -> s where ...
<sect3><title>Rules for functional dependencies </title>
<para>
-In a class declaration, all of the class type variables must be reachable (in the sense
+In a class declaration, all of the class type variables must be reachable (in the sense
mentioned in <xref linkend="flexible-contexts"/>)
from the free variables of each method type.
For example:
from the Hugs user manual, reproduced here (with minor changes) by kind
permission of Mark Jones.
</para>
-<para>
+<para>
Consider the following class, intended as part of a
library for collection types:
<programlisting>
can be used to represent collections of any equality type), bit sets (which can
be used to represent collections of characters), or hash tables (which can be
used to represent any collection whose elements have a hash function). Omitting
-standard implementation details, this would lead to the following declarations:
+standard implementation details, this would lead to the following declarations:
<programlisting>
instance Eq e => Collects e [e] where ...
instance Eq e => Collects e (e -> Bool) where ...
</programlisting>
All this looks quite promising; we have a class and a range of interesting
implementations. Unfortunately, there are some serious problems with the class
-declaration. First, the empty function has an ambiguous type:
+declaration. First, the empty function has an ambiguous type:
<programlisting>
empty :: Collects e ce => ce
</programlisting>
We can sidestep this specific problem by removing the empty member from the
class declaration. However, although the remaining members, insert and member,
do not have ambiguous types, we still run into problems when we try to use
-them. For example, consider the following two functions:
+them. For example, consider the following two functions:
<programlisting>
f x y = insert x . insert y
g = f True 'a'
</programlisting>
-for which GHC infers the following types:
+for which GHC infers the following types:
<programlisting>
f :: (Collects a c, Collects b c) => a -> b -> c -> c
g :: (Collects Bool c, Collects Char c) => c -> c
<para>
Faced with the problems described above, some Haskell programmers might be
-tempted to use something like the following version of the class declaration:
+tempted to use something like the following version of the class declaration:
<programlisting>
class Collects e c where
empty :: c e
used to form the collection type c e, and not over that collection type itself,
represented by ce in the original class declaration. This avoids the immediate
problems that we mentioned above: empty has type <literal>Collects e c => c
-e</literal>, which is not ambiguous.
+e</literal>, which is not ambiguous.
</para>
<para>
-The function f from the previous section has a more accurate type:
+The function f from the previous section has a more accurate type:
<programlisting>
f :: (Collects e c) => e -> e -> c e -> c e
</programlisting>
The function g from the previous section is now rejected with a type error as
we would hope because the type of f does not allow the two arguments to have
-different types.
+different types.
This, then, is an example of a multiple parameter class that does actually work
quite well in practice, without ambiguity problems.
There is, however, a catch. This version of the Collects class is nowhere near
in a manuscript [implparam], where they are identified as one point in a
general design space for systems of implicit parameterization.).
-To start with an abstract example, consider a declaration such as:
+To start with an abstract example, consider a declaration such as:
<programlisting>
class C a b where ...
</programlisting>
which tells us simply that C can be thought of as a binary relation on types
(or type constructors, depending on the kinds of a and b). Extra clauses can be
included in the definition of classes to add information about dependencies
-between parameters, as in the following examples:
+between parameters, as in the following examples:
<programlisting>
class D a b | a -> b where ...
class E a b | a -> b, b -> a where ...
definition of E above. Some dependencies that we can write in this notation are
redundant, and will be rejected because they don't serve any useful
purpose, and may instead indicate an error in the program. Examples of
-dependencies like this include <literal>a -> a </literal>,
-<literal>a -> a a </literal>,
+dependencies like this include <literal>a -> a </literal>,
+<literal>a -> a a </literal>,
<literal>a -> </literal>, etc. There can also be
-some redundancy if multiple dependencies are given, as in
-<literal>a->b</literal>,
+some redundancy if multiple dependencies are given, as in
+<literal>a->b</literal>,
<literal>b->c </literal>, <literal>a->c </literal>, and
in which some subset implies the remaining dependencies. Examples like this are
not treated as errors. Note that dependencies appear only in class
instances that are in scope at any given point in the program is consistent
with any declared dependencies. For example, the following pair of instance
declarations cannot appear together in the same scope because they violate the
-dependency for D, even though either one on its own would be acceptable:
+dependency for D, even though either one on its own would be acceptable:
<programlisting>
instance D Bool Int where ...
instance D Bool Char where ...
</programlisting>
-Note also that the following declaration is not allowed, even by itself:
+Note also that the following declaration is not allowed, even by itself:
<programlisting>
instance D [a] b where ...
</programlisting>
The problem here is that this instance would allow one particular choice of [a]
to be associated with more than one choice for b, which contradicts the
dependency specified in the definition of D. More generally, this means that,
-in any instance of the form:
+in any instance of the form:
<programlisting>
instance D t s where ...
</programlisting>
more general multiple parameter classes, without ambiguity problems, and with
the benefit of more accurate types. To illustrate this, we return to the
collection class example, and annotate the original definition of <literal>Collects</literal>
-with a simple dependency:
+with a simple dependency:
<programlisting>
class Collects e ce | ce -> e where
empty :: ce
Dependencies also help to produce more accurate types for user defined
functions, and hence to provide earlier detection of errors, and less cluttered
types for programmers to work with. Recall the previous definition for a
-function f:
+function f:
<programlisting>
f x y = insert x y = insert x . insert y
</programlisting>
-for which we originally obtained a type:
+for which we originally obtained a type:
<programlisting>
f :: (Collects a c, Collects b c) => a -> b -> c -> c
</programlisting>
Given the dependency information that we have for Collects, however, we can
deduce that a and b must be equal because they both appear as the second
parameter in a Collects constraint with the same first parameter c. Hence we
-can infer a shorter and more accurate type for f:
+can infer a shorter and more accurate type for f:
<programlisting>
f :: (Collects a c) => a -> a -> c -> c
</programlisting>
<replaceable>tvs</replaceable><subscript>left</subscript> <literal>-></literal>
<replaceable>tvs</replaceable><subscript>right</subscript>, of the class,
every type variable in
-S(<replaceable>tvs</replaceable><subscript>right</subscript>) must appear in
+S(<replaceable>tvs</replaceable><subscript>right</subscript>) must appear in
S(<replaceable>tvs</replaceable><subscript>left</subscript>), where S is the
substitution mapping each type variable in the class declaration to the
corresponding type in the instance declaration.
</orderedlist>
These restrictions ensure that context reduction terminates: each reduction
step makes the problem smaller by at least one
-constructor. Both the Paterson Conditions and the Coverage Condition are lifted
-if you give the <option>-XUndecidableInstances</option>
+constructor. Both the Paterson Conditions and the Coverage Condition are lifted
+if you give the <option>-XUndecidableInstances</option>
flag (<xref linkend="undecidable-instances"/>).
You can find lots of background material about the reason for these
restrictions in the paper <ulink
instance Eq (S [a]) -- Structured type in head
-- Repeated type variable in head
- instance C4 a a => C4 [a] [a]
+ instance C4 a a => C4 [a] [a]
instance Stateful (ST s) (MutVar s)
-- Head can consist of type variables only
<programlisting>
-- Context assertion no smaller than head
instance C a => C a where ...
- -- (C b b) has more more occurrences of b than the head
+ -- (C b b) has more occurrences of b than the head
instance C b b => Foo [b] where ...
</programlisting>
</para>
<programlisting>
class HasConverter a b | a -> b where
convert :: a -> b
-
+
data Foo a = MkFoo a
instance (HasConverter a b,Show b) => Show (Foo a) where
<para>
Nevertheless, GHC allows you to experiment with more liberal rules. If you use
the experimental flag <option>-XUndecidableInstances</option>
-<indexterm><primary>-XUndecidableInstances</primary></indexterm>,
+<indexterm><primary>-XUndecidableInstances</primary></indexterm>,
both the Paterson Conditions and the Coverage Condition
(described in <xref linkend="instance-rules"/>) are lifted. Termination is ensured by having a
fixed-depth recursion stack. If you exceed the stack depth you get a
should be used to resolve a type-class constraint</emphasis>. This behaviour
can be modified by two flags: <option>-XOverlappingInstances</option>
<indexterm><primary>-XOverlappingInstances
-</primary></indexterm>
+</primary></indexterm>
and <option>-XIncoherentInstances</option>
<indexterm><primary>-XIncoherentInstances
</primary></indexterm>, as this section discusses. Both these
-flags are dynamic flags, and can be set on a per-module basis, using
+flags are dynamic flags, and can be set on a per-module basis, using
an <literal>OPTIONS_GHC</literal> pragma if desired (<xref linkend="source-file-options"/>).</para>
<para>
When GHC tries to resolve, say, the constraint <literal>C Int Bool</literal>,
instance context3 => C Int [a] where ... -- (C)
instance context4 => C Int [Int] where ... -- (D)
</programlisting>
-The instances (A) and (B) match the constraint <literal>C Int Bool</literal>,
+The instances (A) and (B) match the constraint <literal>C Int Bool</literal>,
but (C) and (D) do not. When matching, GHC takes
no account of the context of the instance declaration
(<literal>context1</literal> etc).
GHC's default behaviour is that <emphasis>exactly one instance must match the
-constraint it is trying to resolve</emphasis>.
+constraint it is trying to resolve</emphasis>.
It is fine for there to be a <emphasis>potential</emphasis> of overlap (by
-including both declarations (A) and (B), say); an error is only reported if a
+including both declarations (A) and (B), say); an error is only reported if a
particular constraint matches more than one.
</para>
Suppose that from the RHS of <literal>f</literal> we get the constraint
<literal>C Int [b]</literal>. But
GHC does not commit to instance (C), because in a particular
-call of <literal>f</literal>, <literal>b</literal> might be instantiate
+call of <literal>f</literal>, <literal>b</literal> might be instantiate
to <literal>Int</literal>, in which case instance (D) would be more specific still.
-So GHC rejects the program.
+So GHC rejects the program.
(If you add the flag <option>-XIncoherentInstances</option>,
-GHC will instead pick (C), without complaining about
+GHC will instead pick (C), without complaining about
the problem of subsequent instantiations.)
</para>
<para>
Notice that we gave a type signature to <literal>f</literal>, so GHC had to
-<emphasis>check</emphasis> that <literal>f</literal> has the specified type.
+<emphasis>check</emphasis> that <literal>f</literal> has the specified type.
Suppose instead we do not give a type signature, asking GHC to <emphasis>infer</emphasis>
it instead. In this case, GHC will refrain from
simplifying the constraint <literal>C Int [b]</literal> (for the same reason
<programlisting>
f :: C Int [b] => [b] -> [b]
</programlisting>
-That postpones the question of which instance to pick to the
+That postpones the question of which instance to pick to the
call site for <literal>f</literal>
by which time more is known about the type <literal>b</literal>.
-You can write this type signature yourself if you use the
+You can write this type signature yourself if you use the
<link linkend="flexible-contexts"><option>-XFlexibleContexts</option></link>
flag.
</para>
(You need <link linkend="instance-rules"><option>-XFlexibleInstances</option></link> to do this.)
</para>
<para>
-Warning: overlapping instances must be used with care. They
+Warning: overlapping instances must be used with care. They
can give rise to incoherence (ie different instance choices are made
in different parts of the program) even without <option>-XIncoherentInstances</option>. Consider:
<programlisting>
instances, and so uses the <literal>MyShow [a]</literal> instance
without complaint. In the call to <literal>myshow</literal> in <literal>main</literal>,
GHC resolves the <literal>MyShow [T]</literal> constraint using the overlapping
-instance declaration in module <literal>Main</literal>. As a result,
+instance declaration in module <literal>Main</literal>. As a result,
the program prints
<programlisting>
"Used more specific instance"
"Used generic instance"
</programlisting>
-(An alternative possible behaviour, not currently implemented,
+(An alternative possible behaviour, not currently implemented,
would be to reject module <literal>Help</literal>
on the grounds that a later instance declaration might overlap the local one.)
</para>
<para>
-The willingness to be overlapped or incoherent is a property of
+The willingness to be overlapped or incoherent is a property of
the <emphasis>instance declaration</emphasis> itself, controlled by the
-presence or otherwise of the <option>-XOverlappingInstances</option>
+presence or otherwise of the <option>-XOverlappingInstances</option>
and <option>-XIncoherentInstances</option> flags when that module is
being defined. Specifically, during the lookup process:
<itemizedlist>
does <emphasis>unify</emphasis> with it, so that it might match when the constraint is further
instantiated. Usually GHC will regard this as a reason for not committing to
some other constraint. But if the instance declaration was compiled with
-<option>-XIncoherentInstances</option>, GHC will skip the "does-it-unify?"
+<option>-XIncoherentInstances</option>, GHC will skip the "does-it-unify?"
check for that declaration.
</para></listitem>
</itemizedlist>
-These rules make it possible for a library author to design a library that relies on
-overlapping instances without the library client having to know.
+These rules make it possible for a library author to design a library that relies on
+overlapping instances without the library client having to know.
</para>
<para>The <option>-XIncoherentInstances</option> flag implies the
<option>-XOverlappingInstances</option> flag, but not vice versa.
Specifically:
<itemizedlist>
<listitem><para>
-Each type in a default declaration must be an
+Each type in a default declaration must be an
instance of <literal>Num</literal> <emphasis>or</emphasis> of <literal>IsString</literal>.
</para></listitem>
<para>
<firstterm>Indexed type families</firstterm> are a new GHC extension to
- facilitate type-level
+ facilitate type-level
programming. Type families are a generalisation of <firstterm>associated
- data types</firstterm>
- (“<ulink url="http://www.cse.unsw.edu.au/~chak/papers/CKPM05.html">Associated
+ data types</firstterm>
+ (“<ulink url="http://www.cse.unsw.edu.au/~chak/papers/CKPM05.html">Associated
Types with Class</ulink>”, M. Chakravarty, G. Keller, S. Peyton Jones,
and S. Marlow. In Proceedings of “The 32nd Annual ACM SIGPLAN-SIGACT
Symposium on Principles of Programming Languages (POPL'05)”, pages
1-13, ACM Press, 2005) and <firstterm>associated type synonyms</firstterm>
- (“<ulink url="http://www.cse.unsw.edu.au/~chak/papers/CKP05.html">Type
+ (“<ulink url="http://www.cse.unsw.edu.au/~chak/papers/CKP05.html">Type
Associated Type Synonyms</ulink>”. M. Chakravarty, G. Keller, and
- S. Peyton Jones.
+ S. Peyton Jones.
In Proceedings of “The Tenth ACM SIGPLAN International Conference on
Functional Programming”, ACM Press, pages 241-253, 2005). Type families
- themselves are described in the paper “<ulink
+ themselves are described in the paper “<ulink
url="http://www.cse.unsw.edu.au/~chak/papers/SPCS08.html">Type
Checking with Open Type Functions</ulink>”, T. Schrijvers,
- S. Peyton-Jones,
+ S. Peyton-Jones,
M. Chakravarty, and M. Sulzmann, in Proceedings of “ICFP 2008: The
13th ACM SIGPLAN International Conference on Functional
Programming”, ACM Press, pages 51-62, 2008. Type families
interfaces as well as interfaces with enhanced static information, much like
dependent types. They might also be regarded as an alternative to functional
dependencies, but provide a more functional style of type-level programming
- than the relational style of functional dependencies.
+ than the relational style of functional dependencies.
</para>
<para>
Indexed type families, or type families for short, are type constructors that
represent sets of types. Set members are denoted by supplying the type family
constructor with type parameters, which are called <firstterm>type
- indices</firstterm>. The
+ indices</firstterm>. The
difference between vanilla parametrised type constructors and family
constructors is much like between parametrically polymorphic functions and
(ad-hoc polymorphic) methods of type classes. Parametric polymorphic functions
behaviour in dependence on the class type parameters. Similarly, vanilla type
constructors imply the same data representation for all type instances, but
family constructors can have varying representation types for varying type
- indices.
+ indices.
</para>
<para>
Indexed type families come in two flavours: <firstterm>data
- families</firstterm> and <firstterm>type synonym
+ families</firstterm> and <firstterm>type synonym
families</firstterm>. They are the indexed family variants of algebraic
data types and type synonyms, respectively. The instances of data families
- can be data types and newtypes.
+ can be data types and newtypes.
</para>
<para>
Type families are enabled by the flag <option>-XTypeFamilies</option>.
<para>
Data families appear in two flavours: (1) they can be defined on the
- toplevel
+ toplevel
or (2) they can appear inside type classes (in which case they are known as
associated types). The former is the more general variant, as it lacks the
requirement for the type-indexes to coincide with the class
and then cover the additional constraints placed on associated types.
</para>
- <sect3 id="data-family-declarations">
+ <sect3 id="data-family-declarations">
<title>Data family declarations</title>
<para>
- Indexed data families are introduced by a signature, such as
+ Indexed data families are introduced by a signature, such as
<programlisting>
data family GMap k :: * -> *
</programlisting>
Just as with
[http://www.haskell.org/ghc/docs/latest/html/users_guide/gadt.html GADT
declarations] named arguments are entirely optional, so that we can
- declare <literal>Array</literal> alternatively with
+ declare <literal>Array</literal> alternatively with
<programlisting>
data family Array :: * -> *
</programlisting>
<para>
When a data family is declared as part of a type class, we drop
the <literal>family</literal> special. The <literal>GMap</literal>
- declaration takes the following form
+ declaration takes the following form
<programlisting>
class GMapKey k where
data GMap k :: * -> *
the argument names must be class parameters. Each class parameter may
only be used at most once per associated type, but some may be omitted
and they may be in an order other than in the class head. Hence, the
- following contrived example is admissible:
+ following contrived example is admissible:
<programlisting>
class C a b c where
data T c a :: *
</sect4>
</sect3>
- <sect3 id="data-instance-declarations">
+ <sect3 id="data-instance-declarations">
<title>Data instance declarations</title>
<para>
they are fully applied and expand to a type that is itself admissible -
exactly as this is required for occurrences of type synonyms in class
instance parameters. For example, the <literal>Either</literal>
- instance for <literal>GMap</literal> is
+ instance for <literal>GMap</literal> is
<programlisting>
data instance GMap (Either a b) v = GMapEither (GMap a v) (GMap b v)
</programlisting>
</para>
<para>
Data and newtype instance declarations are only permitted when an
- appropriate family declaration is in scope - just as a class instance declaratoin
+ appropriate family declaration is in scope - just as a class instance declaration
requires the class declaration to be visible. Moreover, each instance
declaration has to conform to the kind determined by its family
declaration. This implies that the number of parameters of an instance
declaration matches the arity determined by the kind of the family.
</para>
<para>
- A data family instance declaration can use the full exprssiveness of
+ A data family instance declaration can use the full expressiveness of
ordinary <literal>data</literal> or <literal>newtype</literal> declarations:
<itemizedlist>
<listitem><para> Although, a data family is <emphasis>introduced</emphasis> with
- the keyword "<literal>data</literal>", a data family <emphasis>instance</emphasis> can
+ the keyword "<literal>data</literal>", a data family <emphasis>instance</emphasis> can
use either <literal>data</literal> or <literal>newtype</literal>. For example:
<programlisting>
data family T a
Even if type families are defined as toplevel declarations, functions
that perform different computations for different family instances may still
need to be defined as methods of type classes. In particular, the
- following is not possible:
+ following is not possible:
<programlisting>
data family T a
data instance T Int = A
</programlisting>
Instead, you would have to write <literal>foo</literal> as a class operation, thus:
<programlisting>
-class C a where
+class C a where
foo :: T a -> Int
instance Foo Int where
foo A = 1
Types), it might seem as if a definition, such as the above, should be
feasible. However, type families are - in contrast to GADTs - are
<emphasis>open;</emphasis> i.e., new instances can always be added,
- possibly in other
+ possibly in other
modules. Supporting pattern matching across different data instances
would require a form of extensible case construct.)
</para>
When an associated data family instance is declared within a type
class instance, we drop the <literal>instance</literal> keyword in the
family instance. So, the <literal>Either</literal> instance
- for <literal>GMap</literal> becomes:
+ for <literal>GMap</literal> becomes:
<programlisting>
instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where
data GMap (Either a b) v = GMapEither (GMap a v) (GMap b v)
which coincides with the only class parameter. Any parameters to the
family constructor that do not correspond to class parameters, need to
be variables in every instance; here this is the
- variable <literal>v</literal>.
+ variable <literal>v</literal>.
</para>
<para>
Instances for an associated family can only appear as part of
types can be omitted in class instances. If an associated family
instance is omitted, the corresponding instance type is not inhabited;
i.e., only diverging expressions, such
- as <literal>undefined</literal>, can assume the type.
+ as <literal>undefined</literal>, can assume the type.
</para>
</sect4>
In the case of multi-parameter type classes, the visibility of class
parameters in the right-hand side of associated family instances
depends <emphasis>solely</emphasis> on the parameters of the data
- family. As an example, consider the simple class declaration
+ family. As an example, consider the simple class declaration
<programlisting>
class C a b where
data T a
</programlisting>
Only one of the two class parameters is a parameter to the data
- family. Hence, the following instance declaration is invalid:
+ family. Hence, the following instance declaration is invalid:
<programlisting>
instance C [c] d where
data T [c] = MkT (c, d) -- WRONG!! 'd' is not in scope
Here, the right-hand side of the data instance mentions the type
variable <literal>d</literal> that does not occur in its left-hand
side. We cannot admit such data instances as they would compromise
- type safety.
+ type safety.
</para>
</sect4>
<para>
Type class instances of instances of data families can be defined as
usual, and in particular data instance declarations can
- have <literal>deriving</literal> clauses. For example, we can write
+ have <literal>deriving</literal> clauses. For example, we can write
<programlisting>
data GMap () v = GMapUnit (Maybe v)
deriving Show
reasons that we cannot define a toplevel function that performs
pattern matching on the data constructors
of <emphasis>different</emphasis> instances of a single type family.
- It would require a form of extensible case construct.
+ It would require a form of extensible case construct.
</para>
</sect4>
The instance declarations of a data family used in a single program
may not overlap at all, independent of whether they are associated or
not. In contrast to type class instances, this is not only a matter
- of consistency, but one of type safety.
+ of consistency, but one of type safety.
</para>
</sect4>
an export item, these may be either imported or defined in the current
module. The treatment of import and export items that explicitly list
data constructors, such as <literal>GMap(GMapEither)</literal>, is
- analogous.
+ analogous.
</para>
<sect4 id="data-family-impexp-assoc">
type name needs to be prefixed by the keyword <literal>type</literal>.
So for example, when explicitly listing the components of
the <literal>GMapKey</literal> class, we write <literal>GMapKey(type
- GMap, empty, lookup, insert)</literal>.
+ GMap, empty, lookup, insert)</literal>.
</para>
</sect4>
<title>Examples</title>
<para>
Assuming our running <literal>GMapKey</literal> class example, let us
- look at some export lists and their meaning:
+ look at some export lists and their meaning:
<itemizedlist>
<listitem>
<para><literal>module GMap (GMapKey) where...</literal>: Exports
Exports the class, the associated type <literal>GMap</literal>
and the member
functions <literal>empty</literal>, <literal>lookup</literal>,
- and <literal>insert</literal>. None of the data constructors is
+ and <literal>insert</literal>. None of the data constructors is
exported.</para>
- </listitem>
+ </listitem>
<listitem>
<para><literal>module GMap (GMapKey(..), GMap(..))
where...</literal>: As before, but also exports all the data
- constructors <literal>GMapInt</literal>,
- <literal>GMapChar</literal>,
+ constructors <literal>GMapInt</literal>,
+ <literal>GMapChar</literal>,
<literal>GMapUnit</literal>, <literal>GMapPair</literal>,
and <literal>GMapUnit</literal>.</para>
</listitem>
write <literal>GMapKey(type GMap(..))</literal> — i.e.,
sub-component specifications cannot be nested. To
specify <literal>GMap</literal>'s data constructors, you have to list
- it separately.
+ it separately.
</para>
</sect4>
<para>
Family instances are implicitly exported, just like class instances.
However, this applies only to the heads of instances, not to the data
- constructors an instance defines.
+ constructors an instance defines.
</para>
</sect4>
<title>Type family declarations</title>
<para>
- Indexed type families are introduced by a signature, such as
+ Indexed type families are introduced by a signature, such as
<programlisting>
type family Elem c :: *
</programlisting>
The special <literal>family</literal> distinguishes family from standard
type declarations. The result kind annotation is optional and, as
- usual, defaults to <literal>*</literal> if omitted. An example is
+ usual, defaults to <literal>*</literal> if omitted. An example is
<programlisting>
type family Elem c
</programlisting>
and it implies that the kind of a type family is not sufficient to
determine a family's arity, and hence in general, also insufficient to
determine whether a type family application is well formed. As an
- example, consider the following declaration:
+ example, consider the following declaration:
<programlisting>
-type family F a b :: * -> * -- F's arity is 2,
+type family F a b :: * -> * -- F's arity is 2,
-- although its overall kind is * -> * -> * -> *
</programlisting>
Given this declaration the following are examples of well-formed and
- malformed types:
+ malformed types:
<programlisting>
F Char [Int] -- OK! Kind: * -> *
F Char [Int] Bool -- OK! Kind: *
<para>
When a type family is declared as part of a type class, we drop
the <literal>family</literal> special. The <literal>Elem</literal>
- declaration takes the following form
+ declaration takes the following form
<programlisting>
class Collects ce where
type Elem ce :: *
The argument names of the type family must be class parameters. Each
class parameter may only be used at most once per associated type, but
some may be omitted and they may be in an order other than in the
- class head. Hence, the following contrived example is admissible:
+ class head. Hence, the following contrived example is admissible:
<programlisting>
class C a b c where
type T c a :: *
type synonyms are allowed as long as they are fully applied and expand
to a type that is admissible - these are the exact same requirements as
for data instances. For example, the <literal>[e]</literal> instance
- for <literal>Elem</literal> is
+ for <literal>Elem</literal> is
<programlisting>
type instance Elem [e] = e
</programlisting>
monotype (i.e., it may not include foralls) and after the expansion of
all saturated vanilla type synonyms, no synonyms, except family synonyms
may remain. Here are some examples of admissible and illegal type
- instances:
+ instances:
<programlisting>
type family F a :: *
type instance F [Int] = Int -- OK!
When an associated family instance is declared within a type class
instance, we drop the <literal>instance</literal> keyword in the family
instance. So, the <literal>[e]</literal> instance
- for <literal>Elem</literal> becomes:
+ for <literal>Elem</literal> becomes:
<programlisting>
instance (Eq (Elem [e])) => Collects ([e]) where
type Elem [e] = e
The most important point about associated family instances is that the
type indexes corresponding to class parameters must be identical to the
type given in the instance head; here this is <literal>[e]</literal>,
- which coincides with the only class parameter.
+ which coincides with the only class parameter.
</para>
<para>
Instances for an associated family can only appear as part of instances
how methods are handled, declarations of associated types can be omitted
in class instances. If an associated family instance is omitted, the
corresponding instance type is not inhabited; i.e., only diverging
- expressions, such as <literal>undefined</literal>, can assume the type.
+ expressions, such as <literal>undefined</literal>, can assume the type.
</para>
</sect4>
that is the case, the right-hand sides of the instances must also be
syntactically equal under the same substitution. This condition is
independent of whether the type family is associated or not, and it is
- not only a matter of consistency, but one of type safety.
+ not only a matter of consistency, but one of type safety.
</para>
<para>
Here are two example to illustrate the condition under which overlap
- is permitted.
+ is permitted.
<programlisting>
type instance F (a, Int) = [a]
type instance F (Int, b) = [b] -- overlap permitted
In order to guarantee that type inference in the presence of type
families decidable, we need to place a number of additional
restrictions on the formation of type instance declarations (c.f.,
- Definition 5 (Relaxed Conditions) of “<ulink
+ Definition 5 (Relaxed Conditions) of “<ulink
url="http://www.cse.unsw.edu.au/~chak/papers/SPCS08.html">Type
Checking with Open Type Functions</ulink>”). Instance
- declarations have the general form
+ declarations have the general form
<programlisting>
type instance F t1 .. tn = t
</programlisting>
where we require that for every type family application <literal>(G s1
- .. sm)</literal> in <literal>t</literal>,
+ .. sm)</literal> in <literal>t</literal>,
<orderedlist>
<listitem>
<para><literal>s1 .. sm</literal> do not contain any type family
<listitem>
<para>the total number of symbols (data type constructors and type
variables) in <literal>s1 .. sm</literal> is strictly smaller than
- in <literal>t1 .. tn</literal>, and</para>
+ in <literal>t1 .. tn</literal>, and</para>
</listitem>
<listitem>
<para>for every type
of type inference in the presence of, so called, ''loopy equalities'',
such as <literal>a ~ [F a]</literal>, where a recursive occurrence of
a type variable is underneath a family application and data
- constructor application - see the above mentioned paper for details.
+ constructor application - see the above mentioned paper for details.
</para>
<para>
If the option <option>-XUndecidableInstances</option> is passed to the
compiler, the above restrictions are not enforced and it is on the
programmer to ensure termination of the normalisation of type families
- during type inference.
+ during type inference.
</para>
</sect4>
</sect3>
and <literal>t2</literal> need to be the same. In the presence of type
families, whether two types are equal cannot generally be decided
locally. Hence, the contexts of function signatures may include
- equality constraints, as in the following example:
+ equality constraints, as in the following example:
<programlisting>
sumCollects :: (Collects c1, Collects c2, Elem c1 ~ Elem c2) => c1 -> c2 -> c2
</programlisting>
types <literal>t1</literal> and <literal>t2</literal> of an equality
constraint may be arbitrary monotypes; i.e., they may not contain any
quantifiers, independent of whether higher-rank types are otherwise
- enabled.
+ enabled.
</para>
<para>
Equality constraints can also appear in class and instance contexts.
The former enable a simple translation of programs using functional
dependencies into programs using family synonyms instead. The general
- idea is to rewrite a class declaration of the form
+ idea is to rewrite a class declaration of the form
<programlisting>
class C a b | a -> b
</programlisting>
essentially giving a name to the functional dependency. In class
instances, we define the type instances of FD families in accordance
with the class head. Method signatures are not affected by that
- process.
+ process.
</para>
<para>
NB: Equalities in superclass contexts are not fully implemented in
- GHC 6.10.
+ GHC 6.10.
</para>
</sect3>
<sect3 id-="ty-fams-in-instances">
<title>Type families and instance declarations</title>
- <para>Type families require us to extend the rules for
- the form of instance heads, which are given
+ <para>Type families require us to extend the rules for
+ the form of instance heads, which are given
in <xref linkend="flexible-instance-head"/>.
Specifically:
<itemizedlist>
<sect2 id="flexible-contexts"><title>The context of a type signature</title>
<para>
The <option>-XFlexibleContexts</option> flag lifts the Haskell 98 restriction
-that the type-class constraints in a type signature must have the
+that the type-class constraints in a type signature must have the
form <emphasis>(class type-variable)</emphasis> or
-<emphasis>(class (type-variable type-variable ...))</emphasis>.
+<emphasis>(class (type-variable type-variable ...))</emphasis>.
With <option>-XFlexibleContexts</option>
these type signatures are perfectly OK
<programlisting>
A type variable <literal>a</literal> is "reachable" if it appears
in the same constraint as either a type variable free in
-<literal>type</literal>, or another reachable type variable.
-A value with a type that does not obey
+<literal>type</literal>, or another reachable type variable.
+A value with a type that does not obey
this reachability restriction cannot be used without introducing
ambiguity; that is why the type is rejected.
Here, for example, is an illegal type:
<sect2 id="implicit-parameters">
<title>Implicit parameters</title>
-<para> Implicit parameters are implemented as described in
-"Implicit parameters: dynamic scoping with static types",
+<para> Implicit parameters are implemented as described in
+"Implicit parameters: dynamic scoping with static types",
J Lewis, MB Shields, E Meijer, J Launchbury,
27th ACM Symposium on Principles of Programming Languages (POPL'00),
Boston, Jan 2000.
can support dynamic binding. Basically, we express the use of a
dynamically bound variable as a constraint on the type. These
constraints lead to types of the form <literal>(?x::t') => t</literal>, which says "this
-function uses a dynamically-bound variable <literal>?x</literal>
+function uses a dynamically-bound variable <literal>?x</literal>
of type <literal>t'</literal>". For
example, the following expresses the type of a sort function,
implicitly parameterized by a comparison function named <literal>cmp</literal>.
The dynamic binding constraints are just a new form of predicate in the type class system.
</para>
<para>
-An implicit parameter occurs in an expression using the special form <literal>?x</literal>,
+An implicit parameter occurs in an expression using the special form <literal>?x</literal>,
where <literal>x</literal> is
-any valid identifier (e.g. <literal>ord ?x</literal> is a valid expression).
+any valid identifier (e.g. <literal>ord ?x</literal> is a valid expression).
Use of this construct also introduces a new
-dynamic-binding constraint in the type of the expression.
+dynamic-binding constraint in the type of the expression.
For example, the following definition
shows how we can define an implicitly parameterized sort function in
terms of an explicitly parameterized <literal>sortBy</literal> function:
<para>
An implicit-parameter type constraint differs from other type class constraints in the
following way: All uses of a particular implicit parameter must have
-the same type. This means that the type of <literal>(?x, ?x)</literal>
-is <literal>(?x::a) => (a,a)</literal>, and not
+the same type. This means that the type of <literal>(?x, ?x)</literal>
+is <literal>(?x::a) => (a,a)</literal>, and not
<literal>(?x::a, ?x::b) => (a, b)</literal>, as would be the case for type
class constraints.
</para>
g s = show (read s)
</programlisting>
Here, <literal>g</literal> has an ambiguous type, and is rejected, but <literal>f</literal>
-is fine. The binding for <literal>?x</literal> at <literal>f</literal>'s call site is
+is fine. The binding for <literal>?x</literal> at <literal>f</literal>'s call site is
quite unambiguous, and fixes the type <literal>a</literal>.
</para>
</sect3>
</para>
<para>
A group of implicit-parameter bindings may occur anywhere a normal group of Haskell
-bindings can occur, except at top level. That is, they can occur in a <literal>let</literal>
-(including in a list comprehension, or do-notation, or pattern guards),
+bindings can occur, except at top level. That is, they can occur in a <literal>let</literal>
+(including in a list comprehension, or do-notation, or pattern guards),
or a <literal>where</literal> clause.
Note the following points:
<itemizedlist>
An implicit-parameter binding group must be a
collection of simple bindings to implicit-style variables (no
function-style bindings, and no type signatures); these bindings are
-neither polymorphic or recursive.
+neither polymorphic or recursive.
</para></listitem>
<listitem><para>
-You may not mix implicit-parameter bindings with ordinary bindings in a
+You may not mix implicit-parameter bindings with ordinary bindings in a
single <literal>let</literal>
expression; use two nested <literal>let</literal>s instead.
(In the case of <literal>where</literal> you are stuck, since you can't nest <literal>where</literal> clauses.)
Linear implicit parameters are just like ordinary implicit parameters,
except that they are "linear"; that is, they cannot be copied, and
must be explicitly "split" instead. Linear implicit parameters are
-written '<literal>%x</literal>' instead of '<literal>?x</literal>'.
+written '<literal>%x</literal>' instead of '<literal>?x</literal>'.
(The '/' in the '%' suggests the split!)
</para>
<para>
import GHC.Exts( Splittable )
data NameSupply = ...
-
+
splitNS :: NameSupply -> (NameSupply, NameSupply)
newName :: NameSupply -> Name
env' = extend env x x'
...more equations for f...
</programlisting>
-Notice that the implicit parameter %ns is consumed
+Notice that the implicit parameter %ns is consumed
<itemizedlist>
<listitem> <para> once by the call to <literal>newName</literal> </para> </listitem>
<listitem> <para> once by the recursive call to <literal>f</literal> </para></listitem>
<programlisting>
g :: (Splittable a, %ns :: a) => b -> (b,a,a)
</programlisting>
-The <literal>Splittable</literal> class is built into GHC. It's exported by module
+The <literal>Splittable</literal> class is built into GHC. It's exported by module
<literal>GHC.Exts</literal>.
</para>
<para>
Other points:
<itemizedlist>
-<listitem> <para> '<literal>?x</literal>' and '<literal>%x</literal>'
-are entirely distinct implicit parameters: you
+<listitem> <para> '<literal>?x</literal>' and '<literal>%x</literal>'
+are entirely distinct implicit parameters: you
can use them together and they won't interfere with each other. </para>
</listitem>
</programlisting>
But now the name supply is consumed in <emphasis>three</emphasis> places
(the two calls to newName,and the recursive call to f), so
-the result is utterly different. Urk! We don't even have
+the result is utterly different. Urk! We don't even have
the beta rule.
</para>
<para>
Yikes!
</para><para>
You may say that this is a good reason to dislike linear implicit parameters
-and you'd be right. That is why they are an experimental feature.
+and you'd be right. That is why they are an experimental feature.
</para>
</sect3>
<para>
Haskell infers the kind of each type variable. Sometimes it is nice to be able
-to give the kind explicitly as (machine-checked) documentation,
+to give the kind explicitly as (machine-checked) documentation,
just as it is nice to give a type signature for a function. On some occasions,
it is essential to do so. For example, in his paper "Restricted Data Types in Haskell" (Haskell Workshop 1999)
John Hughes had to define the data type:
</title>
<para>
-GHC's type system supports <emphasis>arbitrary-rank</emphasis>
+GHC's type system supports <emphasis>arbitrary-rank</emphasis>
explicit universal quantification in
-types.
+types.
For example, all the following types are legal:
<programlisting>
f1 :: forall a b. a -> b -> a
<programlisting>
a1 :: T Int
a1 = T1 (\xy->x) 3
-
+
a2, a3 :: Swizzle
a2 = MkSwizzle sort
a3 = MkSwizzle reverse
-
+
a4 :: MonadT Maybe
a4 = let r x = Just x
b m k = case m of
that x's type has no foralls in it</emphasis>.
</para>
<para>
-What does it mean to "provide" an explicit type for x? You can do that by
+What does it mean to "provide" an explicit type for x? You can do that by
giving a type signature for x directly, using a pattern type signature
(<xref linkend="scoped-type-variables"/>), thus:
<programlisting>
<title>Implicit quantification</title>
<para>
-GHC performs implicit quantification as follows. <emphasis>At the top level (only) of
+GHC performs implicit quantification as follows. <emphasis>At the top level (only) of
user-written types, if and only if there is no explicit <literal>forall</literal>,
GHC finds all the type variables mentioned in the type that are not already
-in scope, and universally quantifies them.</emphasis> For example, the following pairs are
+in scope, and universally quantifies them.</emphasis> For example, the following pairs are
equivalent:
<programlisting>
f :: a -> a
<sect2 id="impredicative-polymorphism">
<title>Impredicative polymorphism
</title>
-<para>GHC supports <emphasis>impredicative polymorphism</emphasis>,
-enabled with <option>-XImpredicativeTypes</option>.
+<para>GHC supports <emphasis>impredicative polymorphism</emphasis>,
+enabled with <option>-XImpredicativeTypes</option>.
This means
that you can call a polymorphic function at a polymorphic type, and
parameterise data structures over polymorphic types. For example:
<para>The technical details of this extension are described in the paper
<ulink url="http://research.microsoft.com/%7Esimonpj/papers/boxy/">Boxy types:
type inference for higher-rank types and impredicativity</ulink>,
-which appeared at ICFP 2006.
+which appeared at ICFP 2006.
</para>
</sect2>
because of the explicit <literal>forall</literal> (<xref linkend="decl-type-sigs"/>).
The type variables bound by a <literal>forall</literal> scope over
the entire definition of the accompanying value declaration.
-In this example, the type variable <literal>a</literal> scopes over the whole
+In this example, the type variable <literal>a</literal> scopes over the whole
definition of <literal>f</literal>, including over
-the type signature for <varname>ys</varname>.
+the type signature for <varname>ys</varname>.
In Haskell 98 it is not possible to declare
a type for <varname>ys</varname>; a major benefit of scoped type variables is that
it becomes possible to do so.
In Haskell, a programmer-written type signature is implicitly quantified over
its free type variables (<ulink
url="http://www.haskell.org/onlinereport/decls.html#sect4.1.2">Section
-4.1.2</ulink>
+4.1.2</ulink>
of the Haskell Report).
Lexically scoped type variables affect this implicit quantification rules
as follows: any type variable that is in scope is <emphasis>not</emphasis> universally
means "<literal>x::forall a. a</literal>" by Haskell's usual implicit
quantification rules.
</para></listitem>
-<listitem><para> The signature gives a type for a function binding or a bare variable binding,
+<listitem><para> The signature gives a type for a function binding or a bare variable binding,
not a pattern binding.
For example:
<programlisting>
f2 :: forall a. [a] -> [a]
f2 = \(x:xs) -> xs ++ [ x :: a ] -- OK
- f3 :: forall a. [a] -> [a]
+ f3 :: forall a. [a] -> [a]
Just f3 = Just (\(x:xs) -> xs ++ [ x :: a ]) -- Not OK!
</programlisting>
The binding for <literal>f3</literal> is a pattern binding, and so its type signature
<programlisting>
f = runST ( (op >>= \(x :: STRef s Int) -> g x) :: forall s. ST s Bool )
</programlisting>
-Here, the type signature <literal>forall s. ST s Bool</literal> brings the
-type variable <literal>s</literal> into scope, in the annotated expression
+Here, the type signature <literal>forall s. ST s Bool</literal> brings the
+type variable <literal>s</literal> into scope, in the annotated expression
<literal>(op >>= \(x :: STRef s Int) -> g x)</literal>.
</para>
<title>Pattern type signatures</title>
<para>
A type signature may occur in any pattern; this is a <emphasis>pattern type
-signature</emphasis>.
+signature</emphasis>.
For example:
<programlisting>
-- f and g assume that 'a' is already in scope
</programlisting>
Here, the pattern signatures for <literal>ys</literal> and <literal>zs</literal>
are fine, but the one for <literal>v</literal> is not because <literal>b</literal> is
-not in scope.
+not in scope.
</para>
<para>
However, in all patterns <emphasis>other</emphasis> than pattern bindings, a pattern
existentially-bound type variable.
</para>
<para>
-When a pattern type signature binds a type variable in this way, GHC insists that the
+When a pattern type signature binds a type variable in this way, GHC insists that the
type variable is bound to a <emphasis>rigid</emphasis>, or fully-known, type variable.
This means that any user-written type signature always stands for a completely known type.
</para>
could not name existentially-bound type variables in subsequent type signatures.
</para>
<para>
-This is (now) the <emphasis>only</emphasis> situation in which a pattern type
+This is (now) the <emphasis>only</emphasis> situation in which a pattern type
signature is allowed to mention a lexical variable that is not already in
scope.
For example, both <literal>f</literal> and <literal>g</literal> would be
</sect3>
-<!-- ==================== Commented out part about result type signatures
+<!-- ==================== Commented out part about result type signatures
<sect3 id="result-type-sigs">
<title>Result type signatures</title>
h xs = case xs of
(y:ys) :: a -> y
</programlisting>
-The final <literal>:: [a]</literal> after the patterns of <literal>f</literal> gives the type of
+The final <literal>:: [a]</literal> after the patterns of <literal>f</literal> gives the type of
the result of the function. Similarly, the body of the lambda in the RHS of
<literal>g</literal> is <literal>[Int]</literal>, and the RHS of the case
alternative in <literal>h</literal> is <literal>a</literal>.
<literal>let</literal> or <literal>where</literal>) should be sorted into
strongly-connected components, and then type-checked in dependency order
(<ulink url="http://www.haskell.org/onlinereport/decls.html#sect4.5.1">Haskell
-Report, Section 4.5.1</ulink>).
+Report, Section 4.5.1</ulink>).
As each group is type-checked, any binders of the group that
have
an explicit type signature are put in the type environment with the specified
polymorphic type,
-and all others are monomorphic until the group is generalised
+and all others are monomorphic until the group is generalised
(<ulink url="http://www.haskell.org/onlinereport/decls.html#sect4.5.2">Haskell Report, Section 4.5.2</ulink>).
</para>
<programlisting>
f :: Eq a => a -> Bool
f x = (x == x) || g True || g "Yes"
-
+
g y = (y <= y) || f True
</programlisting>
This is rejected by Haskell 98, but under Jones's scheme the definition for
</para>
<para>
-The same refined dependency analysis also allows the type signatures of
+The same refined dependency analysis also allows the type signatures of
mutually-recursive functions to have different contexts, something that is illegal in
Haskell 98 (Section 4.5.2, last sentence). With
<option>-XRelaxedPolyRec</option>
<programlisting>
f :: Eq a => a -> Bool
f x = (x == x) || g True
-
+
g :: Ord a => a -> Bool
g y = (y <= y) || f True
</programlisting>
<title>Monomorphic local bindings</title>
<para>
We are actively thinking of simplifying GHC's type system, by <emphasis>not generalising local bindings</emphasis>.
-The rationale is described in the paper
+The rationale is described in the paper
<ulink url="http://research.microsoft.com/~simonpj/papers/constraints/index.htm">Let should not be generalised</ulink>.
</para>
<para>
</sect1>
<!-- ==================== End of type system extensions ================= -->
-
+
<!-- ====================== TEMPLATE HASKELL ======================= -->
<sect1 id="template-haskell">
<title>Template Haskell</title>
<para>Template Haskell allows you to do compile-time meta-programming in
-Haskell.
+Haskell.
The background to
the main technical innovations is discussed in "<ulink
url="http://research.microsoft.com/~simonpj/papers/meta-haskell/">
Template Haskell at <ulink url="http://www.haskell.org/haskellwiki/Template_Haskell">
http://www.haskell.org/haskellwiki/Template_Haskell</ulink>, and that is the best place to look for
further details.
-You may also
+You may also
consult the <ulink
url="http://www.haskell.org/ghc/docs/latest/html/libraries/index.html">online
-Haskell library reference material</ulink>
+Haskell library reference material</ulink>
(look for module <literal>Language.Haskell.TH</literal>).
-Many changes to the original design are described in
+Many changes to the original design are described in
<ulink url="http://research.microsoft.com/~simonpj/papers/meta-haskell/notes2.ps">
Notes on Template Haskell version 2</ulink>.
Not all of these changes are in GHC, however.
</para>
-<para> The first example from that paper is set out below (<xref linkend="th-example"/>)
-as a worked example to help get you started.
+<para> The first example from that paper is set out below (<xref linkend="th-example"/>)
+as a worked example to help get you started.
</para>
<para>
-The documentation here describes the realisation of Template Haskell in GHC. It is not detailed enough to
+The documentation here describes the realisation of Template Haskell in GHC. It is not detailed enough to
understand Template Haskell; see the <ulink url="http://haskell.org/haskellwiki/Template_Haskell">
Wiki page</ulink>.
</para>
of "$" overrides its meaning as an infix operator, just as "M.x" overrides the meaning
of "." as an infix operator. If you want the infix operator, put spaces around it.
</para>
- <para> A splice can occur in place of
+ <para> A splice can occur in place of
<itemizedlist>
<listitem><para> an expression; the spliced expression must
have type <literal>Q Exp</literal></para></listitem>
<listitem><para> an type; the spliced expression must
have type <literal>Q Typ</literal></para></listitem>
- <listitem><para> a list of top-level declarations; the spliced expression
+ <listitem><para> a list of top-level declarations; the spliced expression
must have type <literal>Q [Dec]</literal></para></listitem>
</itemizedlist>
Note that pattern splices are not supported.
- Inside a splice you can can only call functions defined in imported modules,
+ Inside a splice you can only call functions defined in imported modules,
not functions defined elsewhere in the same module.</para></listitem>
<listitem><para>
A expression quotation is written in Oxford brackets, thus:
<itemizedlist>
- <listitem><para> <literal>[| ... |]</literal>, or <literal>[e| ... |]</literal>,
- where the "..." is an expression;
+ <listitem><para> <literal>[| ... |]</literal>, or <literal>[e| ... |]</literal>,
+ where the "..." is an expression;
the quotation has type <literal>Q Exp</literal>.</para></listitem>
<listitem><para> <literal>[d| ... |]</literal>, where the "..." is a list of top-level declarations;
the quotation has type <literal>Q [Dec]</literal>.</para></listitem>
<listitem><para> <literal>'f</literal> has type <literal>Name</literal>, and names the function <literal>f</literal>.
Similarly <literal>'C</literal> has type <literal>Name</literal> and names the data constructor <literal>C</literal>.
In general <literal>'</literal><replaceable>thing</replaceable> interprets <replaceable>thing</replaceable> in an expression context.
- </para></listitem>
+ </para></listitem>
<listitem><para> <literal>''T</literal> has type <literal>Name</literal>, and names the type constructor <literal>T</literal>.
That is, <literal>''</literal><replaceable>thing</replaceable> interprets <replaceable>thing</replaceable> in a type context.
- </para></listitem>
+ </para></listitem>
</itemizedlist>
These <literal>Names</literal> can be used to construct Template Haskell expressions, patterns, declarations etc. They
may also be given as an argument to the <literal>reify</literal> function.
</para>
</listitem>
- <listitem><para> You may omit the <literal>$(...)</literal> in a top-level declaration splice.
+ <listitem><para> You may omit the <literal>$(...)</literal> in a top-level declaration splice.
Simply writing an expression (rather than a declaration) implies a splice. For example, you can write
<programlisting>
module Foo where
This abbreviation makes top-level declaration slices quieter and less intimidating.
</para></listitem>
-
+
</itemizedlist>
(Compared to the original paper, there are many differences of detail.
The syntax for a declaration splice uses "<literal>$</literal>" not "<literal>splice</literal>".
<listitem><para>
You can only run a function at compile time if it is imported
from another module <emphasis>that is not part of a mutually-recursive group of modules
- that includes the module currently being compiled</emphasis>. Furthermore, all of the modules of
+ that includes the module currently being compiled</emphasis>. Furthermore, all of the modules of
the mutually-recursive group must be reachable by non-SOURCE imports from the module where the
splice is to be run.</para>
<para>
</itemizedlist>
</para>
<para> Template Haskell works in any mode (<literal>--make</literal>, <literal>--interactive</literal>,
- or file-at-a-time). There used to be a restriction to the former two, but that restriction
+ or file-at-a-time). There used to be a restriction to the former two, but that restriction
has been lifted.
</para>
</sect2>
-
+
<sect2 id="th-example"> <title> A Template Haskell Worked Example </title>
<para>To help you get over the confidence barrier, try out this skeletal worked example.
First cut and paste the two modules below into "Main.hs" and "Printf.hs":</para>
<sect2>
<title>Using Template Haskell with Profiling</title>
<indexterm><primary>profiling</primary><secondary>with Template Haskell</secondary></indexterm>
-
+
<para>Template Haskell relies on GHC's built-in bytecode compiler and
interpreter to run the splice expressions. The bytecode interpreter
runs the compiled expression on top of the same runtime on which GHC
<literal>[<replaceable>quoter</replaceable>| <replaceable>string</replaceable> |]</literal>.
<itemizedlist>
<listitem><para>
-The <replaceable>quoter</replaceable> must be the (unqualified) name of an imported
-quoter; it cannot be an arbitrary expression.
+The <replaceable>quoter</replaceable> must be the (unqualified) name of an imported
+quoter; it cannot be an arbitrary expression.
</para></listitem>
<listitem><para>
-The <replaceable>quoter</replaceable> cannot be "<literal>e</literal>",
+The <replaceable>quoter</replaceable> cannot be "<literal>e</literal>",
"<literal>t</literal>", "<literal>d</literal>", or "<literal>p</literal>", since
those overlap with Template Haskell quotations.
</para></listitem>
<literal>[<replaceable>quoter</replaceable>|</literal>.
</para></listitem>
<listitem><para>
-The quoted <replaceable>string</replaceable>
+The quoted <replaceable>string</replaceable>
can be arbitrary, and may contain newlines.
</para></listitem>
</itemizedlist>
</para></listitem>
<listitem><para>
-A quoter is a value of type <literal>Language.Haskell.TH.Quote.QuasiQuoter</literal>,
+A quoter is a value of type <literal>Language.Haskell.TH.Quote.QuasiQuoter</literal>,
which is defined thus:
<programlisting>
data QuasiQuoter = QuasiQuoter { quoteExp :: String -> Q Exp,
| proc <replaceable>apat</replaceable> -> <replaceable>cmd</replaceable>
</screen>
where <literal>proc</literal> is a new keyword.
-The variables of the pattern are bound in the body of the
+The variables of the pattern are bound in the body of the
<literal>proc</literal>-expression,
which is a new sort of thing called a <firstterm>command</firstterm>.
The syntax of commands is as follows:
<para>
Although only GHC implements arrow notation directly,
there is also a preprocessor
-(available from the
+(available from the
<ulink url="http://www.haskell.org/arrows/">arrows web page</ulink>)
that translates arrow notation into Haskell 98
for use with other Haskell systems.
<indexterm><primary>Bang patterns</primary></indexterm>
</title>
<para>GHC supports an extension of pattern matching called <emphasis>bang
-patterns</emphasis>, written <literal>!<replaceable>pat</replaceable></literal>.
+patterns</emphasis>, written <literal>!<replaceable>pat</replaceable></literal>.
Bang patterns are under consideration for Haskell Prime.
The <ulink
url="http://hackage.haskell.org/trac/haskell-prime/wiki/BangPatterns">Haskell
than the material below.
</para>
<para>
-The key change is the addition of a new rule to the
+The key change is the addition of a new rule to the
<ulink url="http://haskell.org/onlinereport/exps.html#sect3.17.2">semantics of pattern matching in the Haskell 98 report</ulink>.
-Add new bullet 10, saying: Matching the pattern <literal>!</literal><replaceable>pat</replaceable>
+Add new bullet 10, saying: Matching the pattern <literal>!</literal><replaceable>pat</replaceable>
against a value <replaceable>v</replaceable> behaves as follows:
<itemizedlist>
<listitem><para>if <replaceable>v</replaceable> is bottom, the match diverges</para></listitem>
f2 (!x, y) = [x,y]
</programlisting>
Here, <literal>f2</literal> is strict in <literal>x</literal> but not in
-<literal>y</literal>.
+<literal>y</literal>.
A bang only really has an effect if it precedes a variable or wild-card pattern:
<programlisting>
f3 !(x,y) = [x,y]
f4 (x,y) = [x,y]
</programlisting>
-Here, <literal>f3</literal> and <literal>f4</literal> are identical;
+Here, <literal>f3</literal> and <literal>f4</literal> are identical;
putting a bang before a pattern that
forces evaluation anyway does nothing.
</para>
g6 x = case f x of { y -> body }
g7 x = case f x of { !y -> body }
</programlisting>
-The functions <literal>g5</literal> and <literal>g6</literal> mean exactly the same thing.
+The functions <literal>g5</literal> and <literal>g6</literal> mean exactly the same thing.
But <literal>g7</literal> evaluates <literal>(f x)</literal>, binds <literal>y</literal> to the
result, and then evaluates <literal>body</literal>.
</para>
</programlisting>
The semantics of Haskell pattern matching is described in <ulink
url="http://www.haskell.org/onlinereport/exps.html#sect3.17.2">
-Section 3.17.2</ulink> of the Haskell Report. To this description add
+Section 3.17.2</ulink> of the Haskell Report. To this description add
one extra item 10, saying:
<itemizedlist><listitem><para>Matching
the pattern <literal>!pat</literal> against a value <literal>v</literal> behaves as follows:
= v `seq` case v of { pat -> e; _ -> e' }
</programlisting>
</para><para>
-That leaves let expressions, whose translation is given in
+That leaves let expressions, whose translation is given in
<ulink url="http://www.haskell.org/onlinereport/exps.html#sect3.12">Section
3.12</ulink>
of the Haskell Report.
-In the translation box, first apply
-the following transformation: for each pattern <literal>pi</literal> that is of
-form <literal>!qi = ei</literal>, transform it to <literal>(xi,!qi) = ((),ei)</literal>, and and replace <literal>e0</literal>
+In the translation box, first apply
+the following transformation: for each pattern <literal>pi</literal> that is of
+form <literal>!qi = ei</literal>, transform it to <literal>(xi,!qi) = ((),ei)</literal>, and replace <literal>e0</literal>
by <literal>(xi `seq` e0)</literal>. Then, when none of the left-hand-side patterns
have a bang at the top, apply the rules in the existing box.
</para>
<para>Pragmas all take the form
-<literal>{-# <replaceable>word</replaceable> ... #-}</literal>
+<literal>{-# <replaceable>word</replaceable> ... #-}</literal>
where <replaceable>word</replaceable> indicates the type of
pragma, and is followed optionally by information specific to that
in the following sections; any pragma encountered with an
unrecognised <replaceable>word</replaceable> is
ignored. The layout rule applies in pragmas, so the closing <literal>#-}</literal>
- should start in a column to the right of the opening <literal>{-#</literal>. </para>
+ should start in a column to the right of the opening <literal>{-#</literal>. </para>
<para>Certain pragmas are <emphasis>file-header pragmas</emphasis>:
<itemizedlist>
</para></listitem>
<listitem><para>
There can be as many file-header pragmas as you please, and they can be
- preceded or followed by comments.
+ preceded or followed by comments.
</para></listitem>
<listitem><para>
File-header pragmas are read once only, before
<indexterm><primary>LANGUAGE</primary><secondary>pragma</secondary></indexterm>
<indexterm><primary>pragma</primary><secondary>LANGUAGE</secondary></indexterm>
- <para>The <literal>LANGUAGE</literal> pragma allows language extensions to be enabled
+ <para>The <literal>LANGUAGE</literal> pragma allows language extensions to be enabled
in a portable way.
It is the intention that all Haskell compilers support the
<literal>LANGUAGE</literal> pragma with the same syntax, although not
(a) uses within the defining module, and
(b) uses in an export list.
The latter reduces spurious complaints within a library
- in which one module gathers together and re-exports
+ in which one module gathers together and re-exports
the exports of several others.
</para>
<para>You can suppress the warnings with the flag
<para>The major effect of an <literal>INLINE</literal> pragma
is to declare a function's “cost” to be very low.
The normal unfolding machinery will then be very keen to
- inline it. However, an <literal>INLINE</literal> pragma for a
+ inline it. However, an <literal>INLINE</literal> pragma for a
function "<literal>f</literal>" has a number of other effects:
<itemizedlist>
<listitem><para>
map (\x -> <replaceable>body</replaceable>) xs
</programlisting>
In general, GHC only inlines the function if there is some reason (no matter
-how slight) to supose that it is useful to do so.
+how slight) to suppose that it is useful to do so.
</para></listitem>
<listitem><para>
-Moreover, GHC will only inline the function if it is <emphasis>fully applied</emphasis>,
+Moreover, GHC will only inline the function if it is <emphasis>fully applied</emphasis>,
where "fully applied"
-means applied to as many arguments as appear (syntactically)
+means applied to as many arguments as appear (syntactically)
on the LHS of the function
definition. For example:
<programlisting>
{-# INLINE comp2 #-}
comp2 f g x = f (g x)
</programlisting>
-The two functions <literal>comp1</literal> and <literal>comp2</literal> have the
+The two functions <literal>comp1</literal> and <literal>comp2</literal> have the
same semantics, but <literal>comp1</literal> will be inlined when applied
to <emphasis>two</emphasis> arguments, while <literal>comp2</literal> requires
<emphasis>three</emphasis>. This might make a big difference if you say
which will optimise better than the corresponding use of `comp2`.
</para></listitem>
-<listitem><para>
+<listitem><para>
It is useful for GHC to optimise the definition of an
-INLINE function <literal>f</literal> just like any other non-INLINE function,
+INLINE function <literal>f</literal> just like any other non-INLINE function,
in case the non-inlined version of <literal>f</literal> is
-ultimately called. But we don't want to inline
+ultimately called. But we don't want to inline
the <emphasis>optimised</emphasis> version
of <literal>f</literal>;
-a major reason for INLINE pragmas is to expose functions
+a major reason for INLINE pragmas is to expose functions
in <literal>f</literal>'s RHS that have
rewrite rules, and it's no good if those functions have been optimised
away.
So <emphasis>GHC guarantees to inline precisely the code that you wrote</emphasis>, no more
and no less. It does this by capturing a copy of the definition of the function to use
for inlining (we call this the "inline-RHS"), which it leaves untouched,
-while optimising the ordinarly RHS as usual. For externally-visible functions
+while optimising the ordinarily RHS as usual. For externally-visible functions
the inline-RHS (not the optimised RHS) is recorded in the interface file.
</para></listitem>
<listitem><para>
{-# INLINE returnUs #-}
</programlisting>
- <para>See also the <literal>NOINLINE</literal> (<xref linkend="inlinable-pragma"/>)
- and <literal>INLINABLE</literal> (<xref linkend="noinline-pragma"/>)
+ <para>See also the <literal>NOINLINE</literal> (<xref linkend="inlinable-pragma"/>)
+ and <literal>INLINABLE</literal> (<xref linkend="noinline-pragma"/>)
pragmas.</para>
<para>Note: the HBC compiler doesn't like <literal>INLINE</literal> pragmas,
so if you want your code to be HBC-compatible you'll have to surround
- the pragma with C pre-processor directives
+ the pragma with C pre-processor directives
<literal>#ifdef __GLASGOW_HASKELL__</literal>...<literal>#endif</literal>.</para>
</sect3>
<sect3 id="noinline-pragma">
<title>NOINLINE pragma</title>
-
+
<indexterm><primary>NOINLINE</primary></indexterm>
<indexterm><primary>NOTINLINE</primary></indexterm>
<sect3 id="conlike-pragma">
<title>CONLIKE modifier</title>
<indexterm><primary>CONLIKE</primary></indexterm>
- <para>An INLINE or NOINLINE pragma may have a CONLIKE modifier,
+ <para>An INLINE or NOINLINE pragma may have a CONLIKE modifier,
which affects matching in RULEs (only). See <xref linkend="conlike"/>.
</para>
</sect3>
<sect2 id="annotation-pragmas">
<title>ANN pragmas</title>
-
+
<para>GHC offers the ability to annotate various code constructs with additional
data by using three pragmas. This data can then be inspected at a later date by
using GHC-as-a-library.</para>
-
+
<sect3 id="ann-pragma">
<title>Annotating values</title>
-
+
<indexterm><primary>ANN</primary></indexterm>
-
+
<para>Any expression that has both <literal>Typeable</literal> and <literal>Data</literal> instances may be attached to a top-level value
binding using an <literal>ANN</literal> pragma. In particular, this means you can use <literal>ANN</literal>
to annotate data constructors (e.g. <literal>Just</literal>) as well as normal values (e.g. <literal>take</literal>).
By way of example, to annotate the function <literal>foo</literal> with the annotation <literal>Just "Hello"</literal>
you would do this:</para>
-
+
<programlisting>
{-# ANN foo (Just "Hello") #-}
foo = ...
</programlisting>
-
+
<para>
A number of restrictions apply to use of annotations:
<itemizedlist>
<listitem><para>The expression you are annotating with must have a type with <literal>Typeable</literal> and <literal>Data</literal> instances</para></listitem>
<listitem><para>The <ulink linkend="using-template-haskell">Template Haskell staging restrictions</ulink> apply to the
expression being annotated with, so for example you cannot run a function from the module being compiled.</para>
-
- <para>To be precise, the annotation <literal>{-# ANN x e #-}</literal> is well staged if and only if <literal>$(e)</literal> would be
+
+ <para>To be precise, the annotation <literal>{-# ANN x e #-}</literal> is well staged if and only if <literal>$(e)</literal> would be
(disregarding the usual type restrictions of the splice syntax, and the usual restriction on splicing inside a splice - <literal>$([|1|])</literal> is fine as an annotation, albeit redundant).</para></listitem>
</itemizedlist>
-
+
If you feel strongly that any of these restrictions are too onerous, <ulink url="http://hackage.haskell.org/trac/ghc/wiki/MailingListsAndIRC">
please give the GHC team a shout</ulink>.
</para>
-
+
<para>However, apart from these restrictions, many things are allowed, including expressions which are not fully evaluated!
Annotation expressions will be evaluated by the compiler just like Template Haskell splices are. So, this annotation is fine:</para>
-
+
<programlisting>
{-# ANN f SillyAnnotation { foo = (id 10) + $([| 20 |]), bar = 'f } #-}
f = ...
</programlisting>
</sect3>
-
+
<sect3 id="typeann-pragma">
<title>Annotating types</title>
-
+
<indexterm><primary>ANN type</primary></indexterm>
<indexterm><primary>ANN</primary></indexterm>
-
+
<para>You can annotate types with the <literal>ANN</literal> pragma by using the <literal>type</literal> keyword. For example:</para>
-
+
<programlisting>
{-# ANN type Foo (Just "A `Maybe String' annotation") #-}
data Foo = ...
</programlisting>
</sect3>
-
+
<sect3 id="modann-pragma">
<title>Annotating modules</title>
-
+
<indexterm><primary>ANN module</primary></indexterm>
<indexterm><primary>ANN</primary></indexterm>
-
+
<para>You can annotate modules with the <literal>ANN</literal> pragma by using the <literal>module</literal> keyword. For example:</para>
-
+
<programlisting>
{-# ANN module (Just "A `Maybe String' annotation") #-}
</programlisting>
h :: Eq a => a -> a -> a
{-# SPECIALISE h :: (Eq a) => [a] -> [a] -> [a] #-}
</programlisting>
-The last of these examples will generate a
+The last of these examples will generate a
RULE with a somewhat-complex left-hand side (try it yourself), so it might not fire very
well. If you use this kind of specialisation, let us know how well it works.
</para>
<title>SPECIALIZE INLINE</title>
<para>A <literal>SPECIALIZE</literal> pragma can optionally be followed with a
-<literal>INLINE</literal> or <literal>NOINLINE</literal> pragma, optionally
+<literal>INLINE</literal> or <literal>NOINLINE</literal> pragma, optionally
followed by a phase, as described in <xref linkend="inline-noinline-pragma"/>.
The <literal>INLINE</literal> pragma affects the specialised version of the
function (only), and applies even if the function is recursive. The motivating
Generally, you can only give a <literal>SPECIALIZE</literal> pragma
for a function defined in the same module.
However if a function <literal>f</literal> is given an <literal>INLINABLE</literal>
-pragma at its definition site, then it can subequently be specialised by
+pragma at its definition site, then it can subsequently be specialised by
importing modules (see <xref linkend="inlinable-pragma"/>).
For example
<programlisting>
</para>
</sect3>
-<sect3><title>Obselete SPECIALIZE syntax</title>
+<sect3><title>Obsolete SPECIALIZE syntax</title>
<para>Note: In earlier versions of GHC, it was possible to provide your own
specialised function for a given type:
Same idea, except for instance declarations. For example:
<programlisting>
-instance (Eq a) => Eq (Foo a) where {
+instance (Eq a) => Eq (Foo a) where {
{-# SPECIALIZE instance Eq (Foo [(Int, Bar)]) #-}
... usual stuff ...
}
<title>UNPACK pragma</title>
<indexterm><primary>UNPACK</primary></indexterm>
-
+
<para>The <literal>UNPACK</literal> indicates to the compiler
that it should unpack the contents of a constructor field into
the constructor itself, removing a level of indirection. For
<para>
The programmer can specify rewrite rules as part of the source program
-(in a pragma).
+(in a pragma).
Here is an example:
<programlisting>
<para>
Inside a RULE "<literal>forall</literal>" is treated as a keyword, regardless of
any other flag settings. Furthermore, inside a RULE, the language extension
-<option>-XScopedTypeVariables</option> is automatically enabled; see
+<option>-XScopedTypeVariables</option> is automatically enabled; see
<xref linkend="scoped-type-variables"/>.
</para>
</listitem>
<para>
Like other pragmas, RULE pragmas are always checked for scope errors, and
-are typechecked. Typechecking means that the LHS and RHS of a rule are typechecked,
+are typechecked. Typechecking means that the LHS and RHS of a rule are typechecked,
and must have the same type. However, rules are only <emphasis>enabled</emphasis>
-if the <option>-fenable-rewrite-rules</option> flag is
+if the <option>-fenable-rewrite-rules</option> flag is
on (see <xref linkend="rule-semantics"/>).
</para>
</listitem>
by the <option>-fenable-rewrite-rules</option> flag.
This flag is implied by <option>-O</option>, and may be switched
off (as usual) by <option>-fno-enable-rewrite-rules</option>.
-(NB: enabling <option>-fenable-rewrite-rules</option> without <option>-O</option>
-may not do what you expect, though, because without <option>-O</option> GHC
+(NB: enabling <option>-fenable-rewrite-rules</option> without <option>-O</option>
+may not do what you expect, though, because without <option>-O</option> GHC
ignores all optimisation information in interface files;
see <option>-fignore-interface-pragmas</option>, <xref linkend="options-f"/>.)
Note that <option>-fenable-rewrite-rules</option> is an <emphasis>optimisation</emphasis> flag, and
g y = y
</programlisting>
Now <literal>g</literal> is inlined into <literal>h</literal>, but <literal>f</literal>'s RULE has
-no chance to fire.
+no chance to fire.
If instead GHC had first inlined <literal>g</literal> into <literal>h</literal> then there
-would have been a better chance that <literal>f</literal>'s RULE might fire.
+would have been a better chance that <literal>f</literal>'s RULE might fire.
</para>
<para>
-The way to get predictable behaviour is to use a NOINLINE
+The way to get predictable behaviour is to use a NOINLINE
pragma, or an INLINE[<replaceable>phase</replaceable>] pragma, on <literal>f</literal>, to ensure
that it is not inlined until its RULEs have had a chance to fire.
</para>
{-# INLINE[1] CONLIKE f #-}
f x = <replaceable>blah</replaceable>
</programlisting>
-CONLIKE is a modifier to an INLINE or NOINLINE pragam. It specifies that an application
+CONLIKE is a modifier to an INLINE or NOINLINE pragma. It specifies that an application
of f to one argument (in general, the number of arguments to the left of the '=' sign)
should be considered cheap enough to duplicate, if such a duplication would make rule
fire. (The name "CONLIKE" is short for "constructor-like", because constructors certainly
have such a property.)
-The CONLIKE pragam is a modifier to INLINE/NOINLINE because it really only makes sense to match
+The CONLIKE pragma is a modifier to INLINE/NOINLINE because it really only makes sense to match
<literal>f</literal> on the LHS of a rule if you are sure that <literal>f</literal> is
not going to be inlined before the rule has a chance to fire.
</para>
Use <option>-ddump-rules</option> to see the rules that are defined
<emphasis>in this module</emphasis>.
This includes rules generated by the specialisation pass, but excludes
-rules imported from other modules.
+rules imported from other modules.
</para>
</listitem>
restrains the strictness analyser.
</para></listitem>
<listitem><para>
-<ulink url="&libraryGhcPrimLocation;/GHC-Prim.html#v%3AunsafeCoerce%23"><literal>unsafeCoerce#</literal></ulink>
+<ulink url="&libraryGhcPrimLocation;/GHC-Prim.html#v%3AunsafeCoerce%23"><literal>unsafeCoerce#</literal></ulink>
allows you to fool the type checker.
</para></listitem>
</itemizedlist>
<itemizedlist>
<listitem>
<para>
-José Pedro Magalhães, Atze Dijkstra, Johan Jeuring, and Andres Löh.
+Jos� Pedro Magalh�es, Atze Dijkstra, Johan Jeuring, and Andres L�h.
<ulink url="http://dreixel.net/research/pdf/gdmh.pdf">
A generic deriving mechanism for Haskell</ulink>.
<citetitle>Proceedings of the third ACM Haskell symposium on Haskell</citetitle>
<programlisting>
-- | Unit: used for constructors without arguments
data U1 p = U1
-
+
-- | Constants, additional parameters and recursion of kind *
newtype K1 i c p = K1 { unK1 :: c }
-
+
-- | Meta-information (constructor names, etc.)
newtype M1 i c f p = M1 { unM1 :: f p }
-
+
-- | Sums: encode choice between constructors
infixr 5 :+:
data (:+:) f g p = L1 (f p) | R1 (g p)
-
+
-- | Products: encode multiple arguments to constructors
infixr 6 :*:
data (:*:) f g p = f p :*: g p
<programlisting>
instance Generic (UserTree a) where
-- Representation type
- type Rep (UserTree a) =
+ type Rep (UserTree a) =
M1 D D1UserTree (
M1 C C1_0UserTree (
M1 S NoSelector (K1 P a)
instance Datatype D1UserTree where
datatypeName _ = "UserTree"
moduleName _ = "Main"
-
+
instance Constructor C1_0UserTree where
conName _ = "Node"
-
+
instance Constructor C1_1UserTree where
conName _ = "Leaf"
</programlisting>
<programlisting>
class Serialize a where
put :: a -> [Bin]
-
+
default put :: (Generic a, GSerialize (Rep a)) => a -> [Bit]
put = gput . from
</programlisting>
<title>Switching off the dreaded Monomorphism Restriction</title>
<indexterm><primary><option>-XNoMonomorphismRestriction</option></primary></indexterm>
-<para>Haskell's monomorphism restriction (see
+<para>Haskell's monomorphism restriction (see
<ulink url="http://www.haskell.org/onlinereport/decls.html#sect4.5.5">Section
4.5.5</ulink>
of the Haskell Report)
<indexterm><primary><option>-XMonoPatBinds</option></primary></indexterm>
<para> As an experimental change, we are exploring the possibility of
- making pattern bindings monomorphic; that is, not generalised at all.
+ making pattern bindings monomorphic; that is, not generalised at all.
A pattern binding is a binding whose LHS has no function arguments,
and is not a simple variable. For example:
<programlisting>
possible while not making too much effort to optimise the generated
code (although GHC probably isn't what you'd describe as a fast
compiler :-).</para>
-
+
<para>GHC's profiling system supports “cost centre
stacks”: a way of seeing the profile of a Haskell program in a
call-graph like structure. See <xref linkend="profiling"/> for more
</varlistentry>
<varlistentry>
- <term>subscribe at:</term>
+ <term>subscribe at:</term>
<listitem>
<para><ulink
url="http://www.haskell.org/mailman/listinfo/glasgow-haskell-users"><literal>http://www.haskell.org/mailman/listinfo/glasgow-haskell-users</literal></ulink>.</para>
</varlistentry>
<varlistentry>
- <term>subscribe at:</term>
+ <term>subscribe at:</term>
<listitem>
<para><ulink
url="http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs"><literal>http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs</literal></ulink>.</para>
</variablelist>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term>cvs-ghc:</term>
<listitem>
other lists for other darcs
repositories (most notably <literal>cvs-libraries</literal>).
</para>
-
+
<variablelist>
<varlistentry>
<term>list email address:</term>
</varlistentry>
<varlistentry>
- <term>subscribe at:</term>
+ <term>subscribe at:</term>
<listitem>
<para><ulink
url="http://www.haskell.org/mailman/listinfo/cvs-ghc"><literal>http://www.haskell.org/mailman/listinfo/cvs-ghc</literal></ulink>.</para>
</indexterm>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term>Stable snapshots</term>
<listitem>
</listitem>
</varlistentry>
</variablelist>
-
+
<para>The version number of your copy of GHC can be found by
invoking <literal>ghc</literal> with the
<literal>––version</literal> flag (see <xref
</listitem>
<listitem>
-<para>
+<para>
Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
</listitem>
<listitem>
-<para>
+<para>
Neither name of the University nor the names of its contributors may be
used to endorse or promote products derived from this software without
specific prior written permission.
The purpose of the package ID is to detect problems caused by
re-installing a package without also recompiling the packages
that depend on it. Recompiling dependencies is necessary,
- because the newly compiled package may have a differnt ABI
+ because the newly compiled package may have a different ABI
(Application Binary Interface) than the previous version, even
if both packages were built from the same source code using the
same compiler. With package IDs, a recompiled
</listitem>
<listitem>
<para>Versions of the Haskell libraries for use with GHCi may also
- abe included: GHCi cannot load <literal>.a</literal> files
+ be included: GHCi cannot load <literal>.a</literal> files
directly, instead it will look for an object file
called <filename>HSfoo.o</filename> and load that. On some
systems, the <literal>ghc-pkg</literal> tool can automatically
<indexterm><primary><literal>maintainer</literal></primary><secondary>package specification</secondary></indexterm>
</term>
<listitem>
- <para>(optinoal freeform) The email address of the package's maintainer.</para>
+ <para>(optional freeform) The email address of the package's maintainer.</para>
</listitem>
</varlistentry>
<indexterm><primary><literal>category</literal></primary><secondary>package specification</secondary></indexterm>
</term>
<listitem>
- <para>(optinoal freeform) Which category the package belongs to. This field
+ <para>(optional freeform) Which category the package belongs to. This field
is for use in conjunction with a future centralised package
distribution framework, tentatively titled Hackage.</para>
</listitem>
<indexterm><primary>parallelism</primary>
</indexterm>
- <para>GHC implements some major extensions to Haskell to support
+ <para>GHC implements some major extensions to Haskell to support
concurrent and parallel programming. Let us first establish terminology:
<itemizedlist>
<listitem><para><emphasis>Parallelism</emphasis> means running
performance. Ideally, this should be done invisibly, and with no
semantic changes.
</para></listitem>
- <listitem><para><emphasis>Concurrency</emphasis> means implementing
+ <listitem><para><emphasis>Concurrency</emphasis> means implementing
a program by using multiple I/O-performing threads. While a
- concurrent Haskell program <emphasis>can</emphasis> run on a
+ concurrent Haskell program <emphasis>can</emphasis> run on a
parallel machine, the primary goal of using concurrency is not to gain
performance, but rather because that is the simplest and most
direct way to write the program. Since the threads perform I/O,
the semantics of the program is necessarily non-deterministic.
</para></listitem>
</itemizedlist>
- GHC supports both concurrency and parallelism.
+ GHC supports both concurrency and parallelism.
</para>
<sect2 id="concurrent-haskell">
<sect2><title>Software Transactional Memory</title>
<para>GHC now supports a new way to coordinate the activities of Concurrent
- Haskell threads, called Software Transactional Memory (STM). The
+ Haskell threads, called Software Transactional Memory (STM). The
<ulink
url="http://research.microsoft.com/%7Esimonpj/papers/stm/index.htm">STM
papers</ulink> are an excellent introduction to what STM is, and how to use
<sect2><title>Parallel Haskell</title>
<para>GHC includes support for running Haskell programs in parallel
- on symmetric, shared-memory multi-processor
+ on symmetric, shared-memory multi-processor
(SMP)<indexterm><primary>SMP</primary></indexterm>.
By default GHC runs your program on one processor; if you
want it to run in parallel you must link your program
<sect2 id="replacing-phases">
<title>Replacing the program for one or more phases</title>
<indexterm><primary>phases, changing</primary></indexterm>
-
+
<para>You may specify that a different program be used for one
of the phases of the compilation system, in place of whatever
the <command>ghc</command> has wired into it. For example, you
for Windows, <literal>solaris</literal>, etc.).</para>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term>
<constant><replaceable>arch</replaceable>_HOST_ARCH=1</constant>
<programlisting>strmod = "\
\ p \
\ "</programlisting>
-
+
<para>don't work with <option>-cpp</option>;
<filename>/usr/bin/cpp</filename> elides the backslash-newline
pairs.</para>
<sect2 id="pre-processor">
<title>Options affecting a Haskell pre-processor</title>
-
+
<indexterm><primary>pre-processing: custom</primary></indexterm>
<indexterm><primary>Pre-processor options</primary></indexterm>
However, if all the modules are otherwise up to date, you may need to force
recompilation both of the module where the new "main" is, and of the
module where the "main" function used to be;
- <literal>ghc</literal> is not clever
+ <literal>ghc</literal> is not clever
enough to figure out that they both need recompiling. You can
force recompilation by removing the object file, or by using the
<option>-fforce-recomp</option> flag.
- </para>
+ </para>
</listitem>
</varlistentry>
<para>The threaded runtime system provides the following
benefits:</para>
- <itemizedlist>
+ <itemizedlist>
<listitem>
<para>Parallelism<indexterm><primary>parallelism</primary></indexterm> on a multiprocessor<indexterm><primary>multiprocessor</primary></indexterm><indexterm><primary>SMP</primary></indexterm> or multicore<indexterm><primary>multicore</primary></indexterm>
machine. See <xref linkend="using-smp" />.</para>
<option>-with-rtsopts="-H128m"</option> sets the default heap size to 128MB.
This will always be the default heap size for this program, unless the user overrides it.
(Depending on the setting of the <option>-rtsopts</option> option, the user might
- not have the ability to change RTS options at run-time, in which case
+ not have the ability to change RTS options at run-time, in which case
<option>-with-rtsopts</option> would be the <emphasis>only</emphasis> way to set
them.)
</para>
<listitem>
<para>On Windows, GHC normally generates a
<firstterm>manifest</firstterm><indexterm><primary>manifest</primary>
- </indexterm>file when linking a binary. The
+ </indexterm> file when linking a binary. The
manifest is placed in the file
<literal><replaceable>prog</replaceable>.exe.manifest</literal>
where <replaceable>prog.exe</replaceable> is the name of the
system using the security control panel, but GHC by default
generates binaries that don't depend on the user having disabled
installer detection.</para>
-
+
<para>The <option>-fno-gen-manifest</option> disables generation of
the manifest file. One reason to do this would be if you had
a manifest file of your own, for example.</para>
<option>-fno-embed-manifest</option>, see below.</para>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term>
<option>-fno-embed-manifest</option>
</indexterm>; to see exactly what GHC does to embed the manifest,
use the <option>-v</option> flag. A GHC installation comes with
its own copy of <literal>windres</literal> for this reason.</para>
-
+
<para>See also <option>-pgmwindres</option> (<xref
- linkend="replacing-phases" />) and
+ linkend="replacing-phases" />) and
<option>-optwindres</option> (<xref
linkend="forcing-options-through"
/>).</para>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term>
<option>-fno-shared-implib</option>
disk-space cost of creating this import library, which can be substantial - it
might require as much space as the code itself, as Haskell DLLs tend to export
lots of symbols.</para>
-
+
<para>As long as you are happy to only be able to link to the DLL using
<literal>GetProcAddress</literal> and friends, you can supply the
<option>-fno-shared-implib</option> flag to disable the creation of the import
<para> Glasgow Haskell comes with a time and space profiling
system. Its purpose is to help you improve your understanding of
your program's execution behaviour, so you can improve it.</para>
-
+
<para> Any comments, suggestions and/or improvements you have are
welcome. Recommended “profiling tricks” would be
especially cool! </para>
<indexterm><primary><option>-p</option></primary><secondary>RTS
option</secondary></indexterm>
</listitem>
-
+
<listitem>
<para> Examine the generated profiling information, using one of
GHC's profiling tools. The tool to use will depend on the kind
of profiling information generated.</para>
</listitem>
-
+
</orderedlist>
-
+
<sect1 id="cost-centres">
<title>Cost centres and cost-centre stacks</title>
-
+
<para>GHC's profiling system assigns <firstterm>costs</firstterm>
to <firstterm>cost centres</firstterm>. A cost is simply the time
or space required to evaluate an expression. Cost centres are
</listitem>
</varlistentry>
</variablelist>
-
+
<para>There are a few other profiling-related compilation options.
Use them <emphasis>in addition to</emphasis>
<option>-prof</option>. These do not have to be used consistently
it manually.</para>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term>
<option>-auto-all</option>:
</varlistentry>
</variablelist>
-
+
</sect1>
<sect1 id="prof-heap">
file,
<filename><replaceable>prog</replaceable>.ps</filename>. The
<command>hp2ps</command> utility is described in detail in
- <xref linkend="hp2ps"/>.</para>
+ <xref linkend="hp2ps"/>.</para>
</listitem>
<listitem>
<para>Display the heap profile using a postscript viewer such
represent an approximation to the actual type.</para>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term>
<option>-hr</option>
to display a profile by type but only for data produced by a
certain module, or a profile by retainer for a certain type of
data. Restrictions are specified as follows:</para>
-
+
<variablelist>
<varlistentry>
<term>
types.</para>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term>
<option>-hr</option><replaceable>cc</replaceable>,...
state in addition to the space allocated for its stack
(stacks normally start small and then grow as
necessary).</para>
-
+
<para>This includes the main thread, so using
<option>-xt</option> is a good way to see how much stack
space the program is using.</para>
</variablelist>
</sect2>
-
+
<sect2 id="retainer-prof">
<title>Retainer Profiling</title>
set <literal>MANY</literal>. The maximum set size defaults to 8
and can be altered with the <option>-R</option> RTS
option:</para>
-
+
<variablelist>
<varlistentry>
<term><option>-R</option><replaceable>size</replaceable></term>
<screen>
<replaceable>prog</replaceable> +RTS -hr -hcB
</screen>
-
+
<para>This trick isn't foolproof, because there might be other
B closures in the heap which aren't the retainers we are
interested in, but we've found this to be a useful technique
<indexterm><primary>heap profiles</primary></indexterm>
<indexterm><primary>postscript, from heap profiles</primary></indexterm>
<indexterm><primary><option>-h<break-down></option></primary></indexterm>
-
+
<para>Usage:</para>
-
+
<screen>
hp2ps [flags] [<file>[.hp]]
</screen>
<para>The flags are:</para>
<variablelist>
-
+
<varlistentry>
<term><option>-d</option></term>
<listitem>
<para>Use a small box for the title.</para>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term><option>-t<float></option></term>
<listitem>
<para>Generate colour output.</para>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term><option>-y</option></term>
<listitem>
<para>Ignore marks.</para>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term><option>-?</option></term>
<listitem>
<sect2 id="manipulating-hp">
<title>Manipulating the hp file</title>
-<para>(Notes kindly offered by Jan-Willhem Maessen.)</para>
+<para>(Notes kindly offered by Jan-Willem Maessen.)</para>
<para>
The <filename>FOO.hp</filename> file produced when you ask for the
heap profile as described in the previous section. Run <command>gv</command> on your
profile:
<screen>
- gv -watch -seascape FOO.ps
+ gv -watch -seascape FOO.ps
</screen>
If you forget the <literal>-watch</literal> flag you can still select
"Watch file" from the "State" menu. Now each time you generate a new
head -`fgrep -n END_SAMPLE FOO.hp | tail -1 | cut -d : -f 1` FOO.hp \
| hp2ps > FOO.ps
kill -HUP $gvpsnum
- done
+ done
</screen>
</para>
</sect2>
a yellow background indicates a part of the program that was
never evaluated; a green background indicates an always-True
expression and a red background indicates an always-False one.
- </para>
+ </para>
<sect2><title>A small example: Reciprocation</title>
</para>
<screen>
-$ ghc -fhpc Recip.hs --make
+$ ghc -fhpc Recip.hs --make
</screen>
- <para>HPC index (.mix) files are placed placed in .hpc subdirectory. These can be considered like
- the .hi files for HPC.
+ <para>HPC index (.mix) files are placed in .hpc subdirectory. These can be considered like
+ the .hi files for HPC.
</para>
<screen>
$ ./Recip
$ hpc report Recip
80% expressions used (81/101)
12% boolean coverage (1/8)
- 14% guards (1/7), 3 always True,
- 1 always False,
+ 14% guards (1/7), 3 always True,
+ 1 always False,
2 unevaluated
0% 'if' conditions (0/1), 1 always False
100% qualifiers (0/0)
hpc_index.html, hpc_index_alt.html, hpc_index_exp.html,
hpc_index_fun.html.
</para>
- </sect2>
+ </sect2>
<sect2><title>Options for instrumenting code for coverage</title>
<para>
- Turning on code coverage is easy, use the -fhpc flag.
+ Turning on code coverage is easy, use the -fhpc flag.
Instrumented and non-instrumented can be freely mixed.
When compiling the Main module GHC automatically detects when there
is an hpc compiled file, and adds the correct initialization code.
<para>
The hpc toolkit uses a cvs/svn/darcs-like interface, where a
- single binary contains many function units.</para>
+ single binary contains many function units.</para>
<screen>
-$ hpc
+$ hpc
Usage: hpc COMMAND ...
Commands:
<para>In general, these options act on .tix file after an
instrumented binary has generated it, which hpc acting as a
conduit between the raw .tix file, and the more detailed reports
- produced.
+ produced.
</para>
-
+
<para>
The hpc tool assumes you are in the top-level directory of
the location where you built your application, and the .tix
--srcdir multiple times to analyse programs compiled from
difference locations, as is typical for packages.
</para>
-
+
<para>
We now explain in more details the major modes of hpc.
</para>
all modules and packages are considered in generating report,
unless include or exclude are used. The report is a summary
unless the --per-module flag is used. The --xml-output option
- allows for tools to use hpc to glean coverage.
- </para>
+ allows for tools to use hpc to glean coverage.
+ </para>
<screen>
$ hpc help report
Usage: hpc report [OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]
</sect3>
<sect3><title>hpc sum</title>
- <para>hpc sum adds together any number of .tix files into a single
- .tix file. hpc sum does not change the original .tix file; it generates a new .tix file.
+ <para>hpc sum adds together any number of .tix files into a single
+ .tix file. hpc sum does not change the original .tix file; it generates a new .tix file.
</para>
<screen>
$ hpc help sum
</screen>
</sect3>
<sect3><title>hpc combine</title>
- <para>hpc combine is the swiss army knife of hpc. It can be
+ <para>hpc combine is the swiss army knife of hpc. It can be
used to take the difference between .tix files, to subtract one
.tix file from another, or to add two .tix files. hpc combine does not
- change the original .tix file; it generates a new .tix file.
+ change the original .tix file; it generates a new .tix file.
</para>
<screen>
$ hpc help combine
</sect3>
<sect3><title>hpc map</title>
<para>hpc map inverts or zeros a .tix file. hpc map does not
- change the original .tix file; it generates a new .tix file.
+ change the original .tix file; it generates a new .tix file.
</para>
<screen>
$ hpc help map
-Usage: hpc map [OPTION] .. <TIX_FILE>
+Usage: hpc map [OPTION] .. <TIX_FILE>
Map a function over a single .tix file
Options:
--hpcdir=DIR sub-directory that contains .mix files
default .hpc [rarely used]
--output=FILE output FILE
-% hpc help draft
+% hpc help draft
Usage: hpc draft [OPTION] .. <TIX_FILE>
Options:
for <option>-debug</option> at link-time). This links in
the debug version of the RTS, which includes the code for
aggregating and reporting the results of ticky-ticky
- profilng.
+ profiling.
</para>
</listitem>
<listitem>
the invocation
<command>foo +RTS -rfoo.ticky</command>.
</para>
-
+
<screen>
foo +RTS -rfoo.ticky
with a message like “<literal>failed to mmap() memory below 2Gb</literal>”. If you need to use this option to get GHCi working
on your machine, please file a bug.
</para>
-
+
<para>
On 64-bit machines, the RTS needs to allocate memory in the
low 2Gb of the address space. Support for this across
generation <replaceable>gen</replaceable> and higher.
Omitting <replaceable>gen</replaceable> turns off the
parallel GC completely, reverting to sequential GC.</para>
-
+
<para>The default parallel GC settings are usually suitable
for parallel programs (i.e. those
using <literal>par</literal>, Strategies, or with multiple
restrict parallel GC to the old generation
with <literal>-qg1</literal>.</para>
</listitem>
- </varlistentry>
+ </varlistentry>
<varlistentry>
<term>
generation <replaceable>gen</replaceable> and higher.
Omitting <replaceable>gen</replaceable> disables
load-balancing entirely.</para>
-
+
<para>
Load-balancing shares out the work of GC between the
available cores. This is a good idea when the heap is
</listitem>
<listitem>
<para>
- The peak memory the RTS has allocated from the OS.
+ The peak memory the RTS has allocated from the OS.
</para>
</listitem>
<listitem>
</listitem>
<listitem>
<para>
- How many page faults occured this garbage collection.
+ How many page faults occurred this garbage collection.
</para>
</listitem>
<listitem>
<para>
- How many page faults occured since the end of the last garbage
+ How many page faults occurred since the end of the last garbage
collection.
</para>
</listitem>
</term>
<listitem>
<para>
- An RTS debugging flag; only availble if the program was
+ An RTS debugging flag; only available if the program was
linked with the <option>-debug</option> option. Various
values of <replaceable>x</replaceable> are provided to
enable debug messages and additional runtime sanity checks
has been specified, then the object filename is
<replaceable>dir</replaceable>/<replaceable>mod</replaceable>.<replaceable>osuf</replaceable>,
where <replaceable>mod</replaceable> is the module name with
- dots replaced by slashes. GHC will silently create the necessary directory
+ dots replaced by slashes. GHC will silently create the necessary directory
structure underneath <replaceable>dir</replaceable>, if it does not
- already exist.</para>
+ already exist.</para>
</listitem>
</itemizedlist>
<para>If you use <command>ghc --make</command> and you don't
use the <option>-o</option>, the name GHC will choose
for the executable will be based on the name of the file
- containing the module <literal>Main</literal>.
+ containing the module <literal>Main</literal>.
Note that with GHC the <literal>Main</literal> module doesn't
have to be put in file <filename>Main.hs</filename>.
Thus both
</varlistentry>
</variablelist>
</sect2>
-
+
<sect2 id="keeping-intermediates">
<title>Keeping Intermediate Files</title>
<indexterm><primary>intermediate files, saving</primary>
This section explains how.</para>
<para>Every cycle in the module import graph must be broken by a <filename>hs-boot</filename> file.
- Suppose that modules <filename>A.hs</filename> and <filename>B.hs</filename> are Haskell source files,
+ Suppose that modules <filename>A.hs</filename> and <filename>B.hs</filename> are Haskell source files,
thus:
<programlisting>
module A where
import B( TB(..) )
-
+
newtype TA = MkTA Int
-
+
f :: TB -> TA
f (MkTB x) = MkTA x
module B where
import {-# SOURCE #-} A( TA(..) )
-
+
data TB = MkTB !Int
-
+
g :: TA -> TB
g (MkTA x) = MkTB x
</programlisting>
<programlisting>
ghc -c A.hs-boot
</programlisting>
-When a hs-boot file <filename>A.hs-boot</filename>
+When a hs-boot file <filename>A.hs-boot</filename>
is compiled, it is checked for scope and type errors.
When its parent module <filename>A.hs</filename> is compiled, the two are compared, and
an error is reported if the two are inconsistent.
</para></listitem>
-
+
<listitem>
<para> Just as compiling <filename>A.hs</filename> produces an
interface file <filename>A.hi</filename>, and an object file
<command>ghc -M</command> will report an error if a cycle is found.
</para></listitem>
- <listitem><para> A module <literal>M</literal> that is
+ <listitem><para> A module <literal>M</literal> that is
<literal>{-# SOURCE #-}</literal>-imported in a program will usually also be
ordinarily imported elsewhere. If not, <command>ghc --make</command>
automatically adds <literal>M</literal> to the set of modules it tries to
<para>A hs-boot file is written in a subset of Haskell:
<itemizedlist>
<listitem><para> The module header (including the export list), and import statements, are exactly as in
-Haskell, and so are the scoping rules.
+Haskell, and so are the scoping rules.
Hence, to mention a non-Prelude type or class, you must import it.</para></listitem>
-
+
<listitem><para> There must be no value declarations, but there can be type signatures for
values. For example:
<programlisting>
</para></listitem>
<listitem><para> Fixity declarations are exactly as in Haskell.</para></listitem>
<listitem><para> Type synonym declarations are exactly as in Haskell.</para></listitem>
-<listitem><para> A data type declaration can either be given in full, exactly as in Haskell, or it
+<listitem><para> A data type declaration can either be given in full, exactly as in Haskell, or it
can be given abstractly, by omitting the '=' sign and everything that follows. For example:
<programlisting>
data T a b
You <emphasis>can</emphasis> also write out the constructors but, if you do so, you must write
it out precisely as in its real definition.</para>
<para>
- If you do not write out the constructors, you may need to give a kind
+ If you do not write out the constructors, you may need to give a kind
annotation (<xref linkend="kinding"/>), to tell
GHC the kind of the type variable, if it is not "*". (In source files, this is worked out
from the way the type variable is used in the constructors.) For example:
brought up to date. To bring it up to date,
<literal>make</literal> looks for a rule to do so; one of the
preceding suffix rules does the job nicely. These dependencies
- can be generated automatically by <command>ghc</command>; see
+ can be generated automatically by <command>ghc</command>; see
<xref linkend="makefile-dependencies"/></para>
</sect2>
<filename>Makefile</filename>.</para>
<para>In general, <command>ghc -M Foo</command> does the following.
- For each module <literal>M</literal> in the set
+ For each module <literal>M</literal> in the set
<literal>Foo</literal> plus all its imports (transitively),
it adds to the Makefile:
<itemizedlist>
(See <xref linkend="mutual-recursion"/> for details of
<literal>hi-boot</literal> style interface files.)
</para></listitem>
- </itemizedlist>
+ </itemizedlist>
If <literal>M</literal> imports multiple modules, then there will
be multiple lines with <filename>M.o</filename> as the
target.</para>
be a disaster in practice, so GHC tries to be clever. </para>
<para>In particular, if an instance declaration is in the same module as the definition
-of any type or class mentioned in the <emphasis>head</emphasis> of the instance declaration
+of any type or class mentioned in the <emphasis>head</emphasis> of the instance declaration
(the part after the “<literal>=></literal>”; see <xref linkend="instance-rules"/>), then
GHC has to visit that interface file anyway. Example:</para>
<programlisting>
least one <emphasis>orphan rule</emphasis>.</para> </listitem>
<listitem><para> An instance declaration in a module M is an <emphasis>orphan instance</emphasis> if
- <indexterm><primary>orphan instance</primary></indexterm>
-<itemizedlist>
+ <indexterm><primary>orphan instance</primary></indexterm>
+<itemizedlist>
<listitem><para>
The class of the instance declaration is not declared in M, and
</para></listitem>
</para></listitem>
</itemizedlist>
</para>
- <para> Only the instance head
+ <para> Only the instance head
counts. In the example above, it is not good enough for C's declaration
to be in module A; it must be the declaration of D or T.</para>
</listitem>
-<para>If you use the flag <option>-fwarn-orphans</option>, GHC will warn you
+<para>If you use the flag <option>-fwarn-orphans</option>, GHC will warn you
if you are creating an orphan module.
-Like any warning, you can switch the warning off with <option>-fno-warn-orphans</option>,
+Like any warning, you can switch the warning off with <option>-fno-warn-orphans</option>,
and <option>-Werror</option>
will make the compilation fail if the warning is issued.
</para>
Building Haskell code into a shared library is a good way to include
Haskell code in a larger mixed-language project. While with static
linking it is recommended to use GHC to perform the final link step,
- with shared libaries a Haskell library can be treated just like any
- other shared libary. The linking can be done using the normal system C
+ with shared libraries a Haskell library can be treated just like any
+ other shared library. The linking can be done using the normal system C
compiler or linker.
</para>
<para>
package. The <literal>-fPIC</literal> flag is required for all code
that will end up in a shared library. The <literal>-shared</literal>
flag specifies to make a shared library rather than a program. To make
- this clearer we can break this down into separate compliation and link
+ this clearer we can break this down into separate compilation and link
steps:
<programlisting>
ghc -dynamic -fPIC -c Foo.hs
is to use a "runtime path" or "rpath" embedded into programs and
libraries themselves. These paths can either be absolute paths or on at
least Linux and Solaris they can be paths relative to the program or
- libary itself. In principle this makes it possible to construct fully
+ library itself. In principle this makes it possible to construct fully
relocatable sets of programs and libraries.
</para>
<para>
<sect1>
<title>Options overview</title>
-
+
<para>GHC's behaviour is controlled by
<firstterm>options</firstterm>, which for historical reasons are
also sometimes referred to as command-line flags or arguments.
<sect2>
<title>Command-line arguments</title>
-
+
<indexterm><primary>structure, command-line</primary></indexterm>
<indexterm><primary>command-line</primary><secondary>arguments</secondary></indexterm>
<indexterm><primary>arguments</primary><secondary>command-line</secondary></indexterm>
-
+
<para>An invocation of GHC takes the following form:</para>
<screen>
<sect2 id="source-file-options">
<title>Command line options in source files</title>
-
+
<indexterm><primary>source-file options</primary></indexterm>
<para>Sometimes it is useful to make the connection between a
module X where
...
</programlisting>
-
+
<para><literal>OPTIONS_GHC</literal> is a <emphasis>file-header pragma</emphasis>
(see <xref linkend="pragmas"/>).</para>
for more details.</para>
</sect2>
</sect1>
-
+
<sect1 id="static-dynamic-flags">
<title>Static, Dynamic, and Mode options</title>
<indexterm><primary>static</primary><secondary>options</secondary>
</listitem>
</varlistentry>
</variablelist>
-
+
<para>The flag reference tables (<xref
linkend="flag-reference"/>) lists the status of each flag.</para>
<para>There are a few flags that are static except that they can
also be used with GHCi's <literal>:set</literal> command; these
are listed as “static/<literal>:set</literal>” in the
- table.</para>
+ table.</para>
</sect1>
<sect1 id="file-suffixes">
compiler.</para>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term><filename>.ll</filename></term>
<listitem>
more detail in <xref linkend="ghci"/>.</para>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term>
<cmdsynopsis><command>ghc ––make</command>
more details.</para>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term>
<cmdsynopsis>
<title>Using <command>ghc</command> <option>––make</option></title>
<indexterm><primary><option>––make</option></primary></indexterm>
<indexterm><primary>separate compilation</primary></indexterm>
-
+
<para>In this mode, GHC will build a multi-module Haskell program by following
dependencies from one or more root modules (usually just
<literal>Main</literal>). For example, if your
source.</para>
</listitem>
</itemizedlist>
-
+
<para>Any of the command-line options described in the rest of
this chapter can be used with
<option>––make</option>, but note that any options
(say, some auxiliary C code), then the object files can be
given on the command line and GHC will include them when linking
the executable.</para>
-
+
<para>Note that GHC can only follow dependencies if it has the
source file available, so if your program includes a module for
which there is no source file, even if you have an object and an
to add directories to the search path (see <xref
linkend="search-path"/>).</para>
</sect2>
-
+
<sect2 id="eval-mode">
<title>Expression evaluation mode</title>
<screen>
ghc -e Main.main Main.hs
</screen>
-
+
<para>or we can just use this mode to evaluate expressions in
the context of the <literal>Prelude</literal>:</para>
<sect2 id="options-order">
<title>Batch compiler mode</title>
-
+
<para>In <emphasis>batch mode</emphasis>, GHC will compile one or more source files
given on the command line.</para>
-
+
<para>The first phase to run is determined by each input-file
suffix, and the last phase is determined by a flag. If no
relevant flag is present, then go all the way through to linking.
This table summarises:</para>
-
+
<informaltable>
<tgroup cols="4">
<colspec align="left"/>
<colspec align="left"/>
<colspec align="left"/>
<colspec align="left"/>
-
+
<thead>
<row>
<entry>Phase of the compilation system</entry>
<entry>-</entry>
<entry><literal>.hs</literal></entry>
</row>
-
+
<row>
<entry>C pre-processor (opt.) </entry>
<entry><literal>.hs</literal> (with
<entry><option>-E</option></entry>
<entry><literal>.hspp</literal></entry>
</row>
-
+
<row>
<entry>Haskell compiler</entry>
<entry><literal>.hs</literal></entry>
<entry><option>-C</option>, <option>-S</option></entry>
<entry><literal>.hc</literal>, <literal>.s</literal></entry>
</row>
-
+
<row>
<entry>C compiler (opt.)</entry>
<entry><literal>.hc</literal> or <literal>.c</literal></entry>
<entry><option>-S</option></entry>
<entry><literal>.s</literal></entry>
</row>
-
+
<row>
<entry>assembler</entry>
<entry><literal>.s</literal></entry>
<entry><option>-c</option></entry>
<entry><literal>.o</literal></entry>
</row>
-
+
<row>
<entry>linker</entry>
<entry><replaceable>other</replaceable></entry>
</tbody>
</tgroup>
</informaltable>
-
+
<indexterm><primary><option>-C</option></primary></indexterm>
<indexterm><primary><option>-E</option></primary></indexterm>
<indexterm><primary><option>-S</option></primary></indexterm>
<indexterm><primary><option>-c</option></primary></indexterm>
-
+
<para>Thus, a common invocation would be: </para>
<screen>
ghc -c Foo.hs</screen>
-
+
<para>to compile the Haskell source file
<filename>Foo.hs</filename> to an object file
<filename>Foo.o</filename>.</para>
<option>-cpp</option><indexterm><primary><option>-cpp</option></primary></indexterm>
flag turns it on. See <xref linkend="c-pre-processor"/> for more
details.</para>
-
+
<para>Note: The option <option>-E</option><indexterm><primary>-E
option</primary></indexterm> runs just the pre-processing passes
of the compiler, dumping the result in a file.</para>
verify.</para>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term>
<option>-v</option><replaceable>n</replaceable>
argument. Specifying <option>-v</option> on its own is
equivalent to <option>-v3</option>, and the other levels
have the following meanings:</para>
-
+
<variablelist>
<varlistentry>
<term><option>-v0</option></term>
</variablelist>
</listitem>
</varlistentry>
-
+
<varlistentry>
<term><option>-ferror-spans</option>
<indexterm><primary><option>-ferror-spans</option></primary>
<term><option>-Werror</option>:</term>
<listitem>
<indexterm><primary><option>-Werror</option></primary></indexterm>
- <para>Makes any warning into a fatal error. Useful so that you don't
+ <para>Makes any warning into a fatal error. Useful so that you don't
miss warnings when doing batch compilation. </para>
</listitem>
</varlistentry>
</varlistentry>
<varlistentry>
- <term><option>-fwarn-incomplete-patterns</option>,
+ <term><option>-fwarn-incomplete-patterns</option>,
<option>-fwarn-incomplete-uni-patterns</option>:
- </term>
+ </term>
<listitem>
<indexterm><primary><option>-fwarn-incomplete-patterns</option></primary></indexterm>
<indexterm><primary><option>-fwarn-incomplete-uni-patterns</option></primary></indexterm>
<indexterm><primary>incomplete patterns, warning</primary></indexterm>
<indexterm><primary>patterns, incomplete</primary></indexterm>
- <para>The option <option>-fwarn-incomplete-patterns</option> warns
+ <para>The option <option>-fwarn-incomplete-patterns</option> warns
about places where
- a pattern-match might fail at runtime.
+ a pattern-match might fail at runtime.
The function
<function>g</function> below will fail when applied to
non-empty lists, so the compiler will emit a warning about
This option isn't enabled by default because it can be
a bit noisy, and it doesn't always indicate a bug in the
program. However, it's generally considered good practice
- to cover all the cases in your functions, and it is switched
+ to cover all the cases in your functions, and it is switched
on by <option>-W</option>.</para>
<para>The flag <option>-fwarn-incomplete-uni-patterns</option> is
</term>
<listitem>
- <para>This flag warns if you use an unqualified
+ <para>This flag warns if you use an unqualified
<literal>import</literal> declaration
- that does not explicitly list the entities brought into scope. For
+ that does not explicitly list the entities brought into scope. For
example
</para>
<programlisting>
complexFn :: a -> a -> String
complexFn x y = ... _simpleFn ...
</programlisting>
- The idea is that: (a) users of the class will only call <literal>complexFn</literal>;
+ The idea is that: (a) users of the class will only call <literal>complexFn</literal>;
never <literal>_simpleFn</literal>; and (b)
instance declarations can define either <literal>complexFn</literal> or <literal>_simpleFn</literal>.
</para>
<listitem>
<indexterm><primary><option>-fwarn-name-shadowing</option></primary></indexterm>
<indexterm><primary>shadowing, warning</primary></indexterm>
-
+
<para>This option causes a warning to be emitted whenever an
inner-scope value has the same name as an outer-scope value,
i.e. the inner value shadows the outer one. This can catch
<indexterm><primary><option>-fwarn-orphans</option></primary></indexterm>
<indexterm><primary>orphan instances, warning</primary></indexterm>
<indexterm><primary>orphan rules, warning</primary></indexterm>
-
- <para>This option causes a warning to be emitted whenever the
+
+ <para>This option causes a warning to be emitted whenever the
module contains an "orphan" instance declaration or rewrite rule.
An instance declaration is an orphan if it appears in a module in
which neither the class nor the type being instanced are declared
orphans is called an orphan module.</para>
<para>The trouble with orphans is that GHC must pro-actively read the interface
files for all orphan modules, just in case their instances or rules
- play a role, whether or not the module's interface would otherwise
+ play a role, whether or not the module's interface would otherwise
be of any use. See <xref linkend="orphan-modules"/> for details.
</para>
</listitem>
which are unused. For top-level functions, the warning is
only given if the binding is not exported.</para>
<para>A definition is regarded as "used" if (a) it is exported, or (b) it is
- mentioned in the right hand side of another definition that is used, or (c) the
- function it defines begins with an underscore. The last case provides a
+ mentioned in the right hand side of another definition that is used, or (c) the
+ function it defines begins with an underscore. The last case provides a
way to suppress unused-binding warnings selectively. </para>
<para> Notice that a variable
is reported as unused even if it appears in the right-hand side of another
<indexterm><primary>unused do binding, warning</primary></indexterm>
<indexterm><primary>do binding, unused</primary></indexterm>
- <para>Report expressions occuring in <literal>do</literal> and <literal>mdo</literal> blocks
+ <para>Report expressions occurring in <literal>do</literal> and <literal>mdo</literal> blocks
that appear to silently throw information away.
For instance <literal>do { mapM popInt xs ; return 10 }</literal> would report
the first statement in the <literal>do</literal> block as suspicious,
<indexterm><primary>apparently erroneous do binding, warning</primary></indexterm>
<indexterm><primary>do binding, apparently erroneous</primary></indexterm>
- <para>Report expressions occuring in <literal>do</literal> and <literal>mdo</literal> blocks
+ <para>Report expressions occurring in <literal>do</literal> and <literal>mdo</literal> blocks
that appear to lack a binding.
For instance <literal>do { return (popInt 10) ; return 10 }</literal> would report
the first statement in the <literal>do</literal> block as suspicious,
<literal>State#</literal> token as argument is considered to be
single-entry, hence it is considered OK to inline things inside
it. This can improve performance of IO and ST monad code, but it
- runs the risk of reducing sharing.</para>
+ runs the risk of reducing sharing.</para>
</listitem>
</varlistentry>
<indexterm><primary>unfolding, controlling</primary></indexterm>
</term>
<listitem>
- <para>(Default: 45) Governs the maximum size that GHC will
+ <para>(Default: 45) Governs the maximum size that GHC will
allow a function unfolding to be. (An unfolding has a
“size” that reflects the cost in terms of
- “code bloat” of expanding that unfolding at
+ “code bloat” of expanding that unfolding
at a call site. A bigger function would be assigned a
bigger cost.) </para>
</variablelist>
</sect2>
-
+
</sect1>
-
- &phases;
+
+ &phases;
&shared_libs;
use GHC to compile and run parallel programs, in <xref
linkend="lang-parallel" /> we describe the language features that affect
parallelism.</para>
-
+
<sect2 id="parallel-compile-options">
<title>Compile-time options for SMP parallelism</title>
linked with the <option>-threaded</option> option (see <xref
linkend="options-linker" />). Additionally, the following
compiler options affect parallelism:</para>
-
+
<variablelist>
<varlistentry>
<term><option>-feager-blackholing</option></term>
results you find.</para></footnote>. For example,
on a dual-core machine we would probably use
<literal>+RTS -N2 -RTS</literal>.</para>
-
+
<para>Omitting <replaceable>x</replaceable>,
i.e. <literal>+RTS -N -RTS</literal>, lets the runtime
choose the value of <replaceable>x</replaceable> itself
</varlistentry>
</variablelist>
</sect2>
-
+
<sect2>
<title>Hints for using SMP parallelism</title>
<indexterm><primary>intermediate code generation</primary></indexterm>
- <para>GHC can dump its optimized intermediate code (said to be in “Core” format)
+ <para>GHC can dump its optimized intermediate code (said to be in “Core” format)
to a file as a side-effect of compilation. Non-GHC back-end tools can read and process Core files; these files have the suffix
<filename>.hcr</filename>. The Core format is described in <ulink url="../../core.pdf">
- <citetitle>An External Representation for the GHC Core Language</citetitle></ulink>,
+ <citetitle>An External Representation for the GHC Core Language</citetitle></ulink>,
and sample tools
for manipulating Core files (in Haskell) are available in the
<ulink url="http://hackage.haskell.org/package/extcore">extcore package on Hackage</ulink>. Note that the format of <literal>.hcr</literal>
- files is <emphasis>different</emphasis> from the Core output format that GHC generates
+ files is <emphasis>different</emphasis> from the Core output format that GHC generates
for debugging purposes (<xref linkend="options-debugging"/>), though the two formats appear somewhat similar.</para>
<para>The Core format natively supports notes which you can add to
<!-- not clear whether there are current editions of Win32 OSes that
doesn't do this by default.
-<para> Solution: don't use "Open With...", avoid spaces in file names,
+<para> Solution: don't use "Open With...", avoid spaces in file names,
or fiddle with the appropriate registry setting:
<programlisting>
HKEY_CLASSES_ROOT\Unknown\shell\openas\command
normal windows program - neither GHC nor the executables it produces
are aware of cygwin's pretended unix hierarchy. GHC will happily
accept either '/' or '\' as path separators, but it won't know where
-to find <filename>/home/joe/Main.hs</filename> or <filename>/bin/bash</filename>
+to find <filename>/home/joe/Main.hs</filename> or <filename>/bin/bash</filename>
or the like. This causes all
kinds of fun when GHC is used from within cygwin's bash, or in
make-sessions running under cygwin.
<sect2><title>Things to do</title>
<itemizedlist>
<listitem>
-<para> Don't use absolute paths in make, configure & co if there is any chance
+<para> Don't use absolute paths in make, configure & co if there is any chance
that those might be passed to GHC (or to GHC-compiled programs). Relative
- paths are fine because cygwin tools are happy with them and GHC accepts
+ paths are fine because cygwin tools are happy with them and GHC accepts
'/' as path-separator. And relative paths don't depend on where cygwin's
root directory is located, or on which partition or network drive your source
tree happens to reside, as long as you 'cd' there first.
<literal>ROOT=`pwd`</literal> in makefile hierarchies or configure scripts), cygwin provides
a tool called <command>cygpath</command> that can convert cygwin's unix-style paths to their
actual windows-style counterparts. Many cygwin tools actually accept
- absolute windows-style paths (remember, though, that you either need
- to escape '\' or convert '\' to '/'), so you should be fine just using those
- everywhere. If you need to use tools that do some kind of path-mangling
- that depends on unix-style paths (one fun example is trying to interpret ':'
- as a separator in path lists..), you can still try to convert paths using
+ absolute windows-style paths (remember, though, that you either need
+ to escape '\' or convert '\' to '/'), so you should be fine just using those
+ everywhere. If you need to use tools that do some kind of path-mangling
+ that depends on unix-style paths (one fun example is trying to interpret ':'
+ as a separator in path lists..), you can still try to convert paths using
<command>cygpath</command> just before they are passed to GHC and friends.
</para></listitem>
-
+
<listitem>
<para> If you don't have <command>cygpath</command>, you probably don't have cygwin and hence
no problems with it... unless you want to write one build process for several
platforms. Again, relative paths are your friend, but if you have to use
absolute paths, and don't want to use different tools on different platforms,
you can simply write a short Haskell program to print the current directory
- (thanks to George Russell for this idea): compiled with GHC, this will give
- you the view of the file system that GHC depends on (which will differ
+ (thanks to George Russell for this idea): compiled with GHC, this will give
+ you the view of the file system that GHC depends on (which will differ
depending on whether GHC is compiled with cygwin's gcc or mingw's
- gcc or on a real unix system..) - that little program can also deal with
- escaping '\' in paths. Apart from the banner and the startup time,
+ gcc or on a real unix system..) - that little program can also deal with
+ escaping '\' in paths. Apart from the banner and the startup time,
something like this would also do:
<programlisting>
$ echo "Directory.getCurrentDirectory >>= putStrLn . init . tail . show " | ghci
The default on Win32 platforms is to link applications in such a way
that the executables will use the Prelude and system libraries DLLs,
rather than contain (large chunks of) them. This is transparent at the
-command-line, so
+command-line, so
</para>
<para>
-rwxr-xr-x 1 544 everyone 4608 May 3 17:11 main.exe*
sh$ ./main
hello, world!
-sh$
+sh$
</screen>
</para>
# package-data.mk is sufficient, as that in turn depends on all the
# libraries
utils/haddock/dist/package-data.mk: compiler/stage2/package-data.mk
-utils/ghc-pwd/dist/package-data.mk: compiler/stage2/package-data.mk
+utils/ghc-pwd/dist-install/package-data.mk: compiler/stage2/package-data.mk
utils/ghc-cabal/dist-install/package-data.mk: compiler/stage2/package-data.mk
utils/ghc-pkg/dist-install/package-data.mk: compiler/stage2/package-data.mk
utils/hsc2hs/dist-install/package-data.mk: compiler/stage2/package-data.mk
-utils/compare_sizes/dist/package-data.mk: compiler/stage2/package-data.mk
-utils/runghc/dist/package-data.mk: compiler/stage2/package-data.mk
+utils/compare_sizes/dist-install/package-data.mk: compiler/stage2/package-data.mk
+utils/runghc/dist-install/package-data.mk: compiler/stage2/package-data.mk
# add the final two package.conf dependencies: ghc-prim depends on RTS,
# and RTS depends on libffi.
mk/config.mk.in \
$(INPLACE_BIN)/mkdirhier \
utils/ghc-cabal/dist-install/build/tmp/ghc-cabal \
- utils/ghc-pwd/dist/build/tmp/ghc-pwd \
+ utils/ghc-pwd/dist-install/build/tmp/ghc-pwd \
$(BINDIST_WRAPPERS) \
$(BINDIST_PERL_SOURCES) \
$(BINDIST_LIBS) \
editor :: String,
stop :: String,
options :: [GHCiOption],
- prelude :: GHC.Module,
+ prelude :: GHC.ModuleName,
line_number :: !Int, -- input line
break_ctr :: !Int,
breaks :: ![(Int, BreakLocation)],
ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
}
-data CtxtCmd -- In each case, the first [String] are the starred modules
+data CtxtCmd -- In each case, the first [String] are the starred modules
-- and the second are the unstarred ones
= SetContext [String] [String]
| AddModules [String] [String]
gunblock = Haskeline.unblock
-- for convenience...
-getPrelude :: GHCi Module
+getPrelude :: GHCi ModuleName
getPrelude = getGHCiState >>= return . prelude
getDynFlags :: GhcMonad m => m DynFlags
let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo
let localNames = filter ((m==) . nameModule) names
mbTyThings <- mapM GHC.lookupName localNames
- return $! [ tagInfo unqual exported kind name loc
+ return $! [ tagInfo unqual exported kind name realLoc
| tyThing <- catMaybes mbTyThings
, let name = getName tyThing
, let exported = GHC.modInfoIsExportedName mInfo name
, let kind = tyThing2TagKind tyThing
, let loc = srcSpanStart (nameSrcSpan name)
- , isGoodSrcLoc loc
+ , RealSrcLoc realLoc <- [loc]
]
where
-- get tag info, for later translation into Vim or Emacs style
-tagInfo :: PrintUnqualified -> Bool -> Char -> Name -> SrcLoc -> TagInfo
+tagInfo :: PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc -> TagInfo
tagInfo unqual exported kind name loc
= TagInfo exported kind
(showSDocForUser unqual $ pprOccName (nameOccName name))
("kind", keepGoing' kindOfType, completeIdentifier),
("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
("list", keepGoing' listCmd, noCompletion),
- ("module", keepGoing setContext, completeSetModule),
+ ("module", keepGoing moduleCmd, completeSetModule),
("main", keepGoing runMain, completeFilename),
("print", keepGoing printCmd, completeExpression),
("quit", quit, noCompletion),
#endif
-- initial context is just the Prelude
- prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
- GHC.setContext [] [(prel_mod, Nothing)]
+ let prel_mn = GHC.mkModuleName "Prelude"
+ GHC.setContext [] [simpleImportDecl prel_mn]
default_editor <- liftIO $ findEditor
editor = default_editor,
-- session = session,
options = [],
- prelude = prel_mod,
+ prelude = prel_mn,
line_number = 1,
break_ctr = 0,
breaks = [],
mkPrompt :: GHCi String
mkPrompt = do
- (toplevs,exports) <- GHC.getContext
+ (toplevs,imports) <- GHC.getContext
resumes <- GHC.getResumeContext
-- st <- getGHCiState
-- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
-- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
- hsep (map (ppr . GHC.moduleName) (nub (map fst exports)))
+ hsep (map ppr (nub (map ideclName imports)))
deflt_prompt = dots <> context_bit <> modules_bit
let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
st <- lift $ getGHCiState
let buf = stringToStringBuffer stmt
- loc = mkSrcLoc (fsLit (progname st)) (line_number st) 1
+ loc = mkRealSrcLoc (fsLit (progname st)) (line_number st) 1
pstate = Lexer.mkPState dflags buf loc
case Lexer.unP goToEnd pstate of
(Lexer.POk _ False) -> return $ Just stmt
else LoadUpTo (GHC.mkModuleName m)
return ()
-doLoad :: Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> LoadHowMuch -> InputT GHCi SuccessFlag
+doLoad :: Bool -> ([Module],[ImportDecl RdrName]) -> LoadHowMuch -> InputT GHCi SuccessFlag
doLoad retain_context prev_context howmuch = do
-- turn off breakpoints before we load: we can't turn them off later, because
-- the ModBreaks will have gone away.
afterLoad ok retain_context prev_context
return ok
-afterLoad :: SuccessFlag -> Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> InputT GHCi ()
+afterLoad :: SuccessFlag -> Bool -> ([Module],[ImportDecl RdrName]) -> InputT GHCi ()
afterLoad ok retain_context prev_context = do
lift revertCAFs -- always revert CAFs on load.
lift discardTickArrays
lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
-setContextAfterLoad :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> Bool -> [GHC.ModSummary] -> GHCi ()
+setContextAfterLoad :: ([Module],[ImportDecl RdrName]) -> Bool -> [GHC.ModSummary] -> GHCi ()
setContextAfterLoad prev keep_ctxt [] = do
prel_mod <- getPrelude
- setContextKeepingPackageModules prev keep_ctxt ([], [(prel_mod, Nothing)])
+ setContextKeepingPackageModules prev keep_ctxt ([], [simpleImportDecl prel_mod])
setContextAfterLoad prev keep_ctxt ms = do
-- load a target if one is available, otherwise load the topmost module.
targets <- GHC.getTargets
if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
else do
prel_mod <- getPrelude
- setContextKeepingPackageModules prev keep_ctxt ([],[(prel_mod,Nothing),(m,Nothing)])
+ setContextKeepingPackageModules prev keep_ctxt
+ ([], [simpleImportDecl prel_mod,
+ simpleImportDecl (GHC.moduleName m)])
-- | Keep any package modules (except Prelude) when changing the context.
setContextKeepingPackageModules
- :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- previous context
+ :: ([Module],[ImportDecl RdrName]) -- previous context
-> Bool -- re-execute :module commands
- -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- new context
+ -> ([Module],[ImportDecl RdrName]) -- new context
-> GHCi ()
setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
- let (_,bs0) = prev_context
+ let (_,imports0) = prev_context
prel_mod <- getPrelude
-- filter everything, not just lefts
- let pkg_modules = filter ((\p -> not (isHomeModule p) && p /= prel_mod) . fst) bs0
- let bs1 = if null as then nubBy sameFst ((prel_mod,Nothing) : bs) else bs
- GHC.setContext as (nubBy sameFst (bs1 ++ pkg_modules))
+
+ let is_pkg_mod i
+ | unLoc (ideclName i) == prel_mod = return False
+ | otherwise = do
+ e <- gtry $ GHC.findModule (unLoc (ideclName i)) (ideclPkgQual i)
+ case e :: Either SomeException Module of
+ Left _ -> return False
+ Right m -> return (not (isHomeModule m))
+
+ pkg_modules <- filterM is_pkg_mod imports0
+
+ let bs1 = if null as
+ then nubBy sameMod (simpleImportDecl prel_mod : bs)
+ else bs
+
+ GHC.setContext as (nubBy sameMod (bs1 ++ pkg_modules))
if keep_ctxt
then do
st <- getGHCiState
- mapM_ (playCtxtCmd False) (remembered_ctx st)
+ playCtxtCmds False (remembered_ctx st)
else do
st <- getGHCiState
setGHCiState st{ remembered_ctx = [] }
isHomeModule :: Module -> Bool
isHomeModule mod = GHC.modulePackageId mod == mainPackageId
-sameFst :: (Module, Maybe (ImportDecl RdrName)) -> (Module, Maybe (ImportDecl RdrName)) -> Bool
-sameFst x y = fst x == fst y
+sameMod :: ImportDecl RdrName -> ImportDecl RdrName -> Bool
+sameMod x y = unLoc (ideclName x) == unLoc (ideclName y)
modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
modulesLoadedMsg ok mods = do
-- recently-added module occurs last, it seems.
case (as,bs) of
(as@(_:_), _) -> browseModule bang (last as) True
- ([], bs@(_:_)) -> browseModule bang (fst (last bs)) True
+ ([], bs@(_:_)) -> do
+ let i = last bs
+ m <- GHC.findModule (unLoc (ideclName i)) (ideclPkgQual i)
+ browseModule bang m True
([], []) -> ghcError (CmdLineError ":browse: no current module")
_ -> ghcError (CmdLineError "syntax: :browse <module>")
-- just so we can get an appropriate PrintUnqualified
(as,bs) <- GHC.getContext
prel_mod <- lift getPrelude
- if exports_only then GHC.setContext [] [(prel_mod,Nothing), (modl,Nothing)]
+ if exports_only then GHC.setContext [] [simpleImportDecl prel_mod,
+ simpleImportDecl (GHC.moduleName modl)]
else GHC.setContext [modl] []
target_unqual <- GHC.getPrintUnqual
GHC.setContext as bs
newContextCmd :: CtxtCmd -> GHCi ()
newContextCmd cmd = do
- playCtxtCmd True cmd
+ playCtxtCmds True [cmd]
st <- getGHCiState
let cmds = remembered_ctx st
setGHCiState st{ remembered_ctx = cmds ++ [cmd] }
-setContext :: String -> GHCi ()
-setContext str
+moduleCmd :: String -> GHCi ()
+moduleCmd str
| all sensible strs = newContextCmd cmd
| otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
where
starred ('*':m) = Left m
starred m = Right m
-playCtxtCmd:: Bool -> CtxtCmd -> GHCi ()
-playCtxtCmd fail cmd = do
- (prev_as,prev_bs) <- GHC.getContext
+type Context = ([GHC.Module], [GHC.ImportDecl GHC.RdrName])
+
+playCtxtCmds :: Bool -> [CtxtCmd] -> GHCi ()
+playCtxtCmds fail cmds = do
+ ctx <- GHC.getContext
+ (as,bs) <- foldM (playCtxtCmd fail) ctx cmds
+ GHC.setContext as bs
+
+playCtxtCmd:: Bool -> Context -> CtxtCmd -> GHCi Context
+playCtxtCmd fail (prev_as, prev_bs) cmd = do
case cmd of
SetContext as bs -> do
(as',bs') <- do_checks as bs
prel_mod <- getPrelude
- let bs'' = if null as && prel_mod `notElem` (map fst bs')
- then (prel_mod,Nothing):bs'
+ let bs'' = if null as && prel_mod `notElem` bs'
+ then prel_mod : bs'
else bs'
- GHC.setContext as' bs''
+ return (as', map simpleImportDecl bs'')
AddModules as bs -> do
(as',bs') <- do_checks as bs
- -- it should replace the old stuff, not the other way around
- -- need deleteAllBy, not deleteFirstsBy for sameFst
- let remaining_as = prev_as \\ (as' ++ map fst bs')
- remaining_bs = deleteAllBy sameFst prev_bs (bs' ++ map contextualize as')
- GHC.setContext (remaining_as ++ as') (remaining_bs ++ bs')
+ let (remaining_as, remaining_bs) =
+ prev_without (map moduleName as' ++ bs')
+ return (remaining_as ++ as', remaining_bs ++ map simpleImportDecl bs')
RemModules as bs -> do
(as',bs') <- do_checks as bs
- let new_as = prev_as \\ (as' ++ map fst bs')
- new_bs = deleteAllBy sameFst prev_bs (map contextualize as' ++ bs')
- GHC.setContext new_as new_bs
+ let (new_as, new_bs) = prev_without (map moduleName as' ++ bs')
+ return (new_as, new_bs)
Import str -> do
m_idecl <- maybe_fail $ GHC.parseImportDecl str
case m_idecl of
- Nothing -> return ()
+ Nothing -> return (prev_as, prev_bs)
Just idecl -> do
m_mdl <- maybe_fail $ loadModuleName idecl
case m_mdl of
- Nothing -> return ()
- Just m -> GHC.setContext prev_as (prev_bs ++ [(m, Just idecl)])
-
+ Nothing -> return (prev_as, prev_bs)
+ Just _ -> return (prev_as, prev_bs ++ [idecl])
+ -- we don't filter the module out of the old declarations,
+ -- because 'import' is supposed to be cumulative.
where
maybe_fail | fail = liftM Just
| otherwise = trymaybe
+ prev_without names = (as',bs')
+ where as' = deleteAllBy sameModName prev_as names
+ bs' = deleteAllBy importsSameMod prev_bs names
+
do_checks as bs = do
as' <- mapM (maybe_fail . wantInterpretedModule) as
- bs' <- mapM (maybe_fail . lookupModule) bs
- return (catMaybes as', map contextualize (catMaybes bs'))
+ bs' <- mapM (maybe_fail . liftM moduleName . lookupModule) bs
+ return (catMaybes as', catMaybes bs')
- contextualize x = (x,Nothing)
- deleteAllBy f a b = filter (\x->(not (any (f x) b))) a
+ sameModName a b = moduleName a == b
+ importsSameMod a b = unLoc (ideclName a) == b
+
+ deleteAllBy :: (a -> b -> Bool) -> [a] -> [b] -> [a]
+ deleteAllBy f as bs = filter (\a-> not (any (f a) bs)) as
trymaybe ::GHCi a -> GHCi (Maybe a)
trymaybe m = do
completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
modules <- case m of
Just '-' -> do
- (toplevs, exports) <- GHC.getContext
- return $ map GHC.moduleName (nub (map fst exports) ++ toplevs)
+ (toplevs, imports) <- GHC.getContext
+ return $ map GHC.moduleName toplevs ++ map (unLoc.ideclName) imports
_ -> do
dflags <- GHC.getSessionDynFlags
let pkg_mods = allExposedModules dflags
-- | Returns the span of the largest tick containing the srcspan given
enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
-enclosingTickSpan mod src = do
+enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
+enclosingTickSpan mod (RealSrcSpan src) = do
ticks <- getTickArray mod
let line = srcSpanStartLine src
ASSERT (inRange (bounds ticks) line) do
- let enclosing_spans = [ span | (_,span) <- ticks ! line
- , srcSpanEnd span >= srcSpanEnd src]
+ let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
+ toRealSrcSpan (RealSrcSpan s) = s
+ enclosing_spans = [ span | (_,span) <- ticks ! line
+ , realSrcSpanEnd (toRealSrcSpan span) >= realSrcSpanEnd src]
return . head . sortBy leftmost_largest $ enclosing_spans
traceCmd :: String -> GHCi ()
| otherwise = do -- try parsing it as an identifier
wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
- if GHC.isGoodSrcLoc loc
- then ASSERT( isExternalName name )
+ case loc of
+ RealSrcLoc l ->
+ ASSERT( isExternalName name )
findBreakAndSet (GHC.nameModule name) $
- findBreakByCoord (Just (GHC.srcLocFile loc))
- (GHC.srcLocLine loc,
- GHC.srcLocCol loc)
- else noCanDo name $ text "can't find its location: " <> ppr loc
+ findBreakByCoord (Just (GHC.srcLocFile l))
+ (GHC.srcLocLine l,
+ GHC.srcLocCol l)
+ UnhelpfulLoc _ ->
+ noCanDo name $ text "can't find its location: " <> ppr loc
where
noCanDo n why = printForUser $
text "cannot set breakpoint on " <> ppr n <> text ": " <> why
ticks = arr ! line
starts_here = [ tick | tick@(_,span) <- ticks,
- GHC.srcSpanStartLine span == line ]
+ GHC.srcSpanStartLine (toRealSpan span) == line ]
(complete,incomplete) = partition ends_here starts_here
- where ends_here (_,span) = GHC.srcSpanEndLine span == line
+ where ends_here (_,span) = GHC.srcSpanEndLine (toRealSpan span) == line
+ toRealSpan (RealSrcSpan span) = span
+ toRealSpan (UnhelpfulSpan _) = panic "findBreakByLine UnhelpfulSpan"
findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
-> Maybe (BreakIndex,SrcSpan)
is_correct_file span ]
is_correct_file span
- | Just f <- mb_file = GHC.srcSpanFile span == f
+ | Just f <- mb_file = GHC.srcSpanFile (toRealSpan span) == f
| otherwise = True
after_here = [ tick | tick@(_,span) <- ticks,
- GHC.srcSpanStartLine span == line,
- GHC.srcSpanStartCol span >= col ]
+ let span' = toRealSpan span,
+ GHC.srcSpanStartLine span' == line,
+ GHC.srcSpanStartCol span' >= col ]
+
+ toRealSpan (RealSrcSpan span) = span
+ toRealSpan (UnhelpfulSpan _) = panic "findBreakByCoord UnhelpfulSpan"
-- For now, use ANSI bold on terminals that we know support it.
-- Otherwise, we add a line of carets under the active expression instead.
case mb_span of
Nothing ->
printForUser $ text "Not stopped at a breakpoint; nothing to list"
- Just span
- | GHC.isGoodSrcSpan span -> listAround span True
- | otherwise ->
+ Just (RealSrcSpan span) ->
+ listAround span True
+ Just span@(UnhelpfulSpan _) ->
do resumes <- GHC.getResumeContext
case resumes of
[] -> panic "No resumes"
list2 [arg] = do
wantNameFromInterpretedModule noCanDo arg $ \name -> do
let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
- if GHC.isGoodSrcLoc loc
- then do
- tickArray <- ASSERT( isExternalName name )
+ case loc of
+ RealSrcLoc l ->
+ do tickArray <- ASSERT( isExternalName name )
lift $ getTickArray (GHC.nameModule name)
- let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
- (GHC.srcLocLine loc, GHC.srcLocCol loc)
+ let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
+ (GHC.srcLocLine l, GHC.srcLocCol l)
tickArray
case mb_span of
- Nothing -> listAround (GHC.srcLocSpan loc) False
- Just (_,span) -> listAround span False
- else
+ Nothing -> listAround (realSrcLocSpan l) False
+ Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan"
+ Just (_, RealSrcSpan span) -> listAround span False
+ UnhelpfulLoc _ ->
noCanDo name $ text "can't find its location: " <>
ppr loc
where
[] -> panic "listModuleLine"
summ:_ -> do
let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
- loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
- listAround (GHC.srcLocSpan loc) False
+ loc = mkRealSrcLoc (mkFastString (filename)) line 0
+ listAround (realSrcLocSpan loc) False
-- | list a section of a source file around a particular SrcSpan.
-- If the highlight flag is True, also highlight the span using
-- 2) convert the BS to String using utf-string, and write it out.
-- It would be better if we could convert directly between UTF-8 and the
-- console encoding, of course.
-listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
+listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()
listAround span do_highlight = do
contents <- liftIO $ BS.readFile (unpackFS file)
let
mkTickArray ticks
= accumArray (flip (:)) [] (1, max_line)
[ (line, (nm,span)) | (nm,span) <- ticks,
- line <- srcSpanLines span ]
+ let span' = toRealSpan span,
+ line <- srcSpanLines span' ]
where
- max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
+ max_line = foldr max 0 (map (GHC.srcSpanEndLine . toRealSpan . snd) ticks)
srcSpanLines span = [ GHC.srcSpanStartLine span ..
GHC.srcSpanEndLine span ]
+ toRealSpan (RealSrcSpan span) = span
+ toRealSpan (UnhelpfulSpan _) = panic "mkTickArray UnhelpfulSpan"
lookupModule :: GHC.GhcMonad m => String -> m Module
lookupModule modName
setBreakFlag toggle array index
| toggle = GHC.setBreakOn array index
| otherwise = GHC.setBreakOff array index
+
i386-unknown-mingw32 \
i386-apple-darwin powerpc-apple-darwin
-ifeq ($(SOLARIS_BROKEN_SHLD), NO)
-SharedLibsPlatformList := $(SharedLibsPlatformList) i386-unknown-solaris2
+ifeq "$(SOLARIS_BROKEN_SHLD)" "NO"
+SharedLibsPlatformList += i386-unknown-solaris2
endif
PlatformSupportsSharedLibs = $(if $(filter $(TARGETPLATFORM),\
CHECK_PACKAGES = YES
# We want to install DPH when validating, so that we can test it
-InstallExtraPackages = YES
+InstallExtraPackages = YES
# dblatex with miktex under msys/mingw can't build the PS and PDF docs,
# and just building the HTML docs is sufficient to check that the
# Despite the name "package", this file contains the master list of
-# the *repositories* that make up GHC. It is parsed by boot and darcs-all.
+# the *repositories* that make up GHC. It is parsed by
+# * boot
+# * sync-all
+# * rules/extra-packages.mk
#
# Some of this information is duplicated elsewhere in the build system:
# See Trac #3896
# - nofib and testsuite are optional helpers
#
# The format of the lines in this file is:
-# localpath tag remotepath VCS upstream
+# localpath tag remotepath VCS
# where
# * 'localpath' is where to put the repository in a checked out tree.
# * 'remotepath' is where the repository is in the central repository.
# deems to have the EXTRA_PACKAGE property: tags 'dph' and 'extra'
# both give this property
#
-# * 'upstream' is the URL of the upstream repo, where there is one, or
-# "-" if there is no upstream.
-#
# Lines that start with a '#' are comments.
-. - ghc.git git -
-ghc-tarballs - ghc-tarballs.git git -
-utils/hsc2hs - hsc2hs.git git -
-# haddock does have an upstream:
-# http://code.haskell.org/haddock/
-# but it stays buildable with the last stable release rather than tracking HEAD,
-# and is resynced with the GHC HEAD branch by David Waern when appropriate
-utils/haddock - haddock2.git git -
-libraries/array - packages/array.git git -
-libraries/base - packages/base.git git -
-libraries/binary - packages/binary.git git http://code.haskell.org/binary/
-libraries/bytestring - packages/bytestring.git git http://darcs.haskell.org/bytestring/
-libraries/Cabal - packages/Cabal.git git http://darcs.haskell.org/cabal/
-libraries/containers - packages/containers.git git -
-libraries/directory - packages/directory.git git -
-libraries/extensible-exceptions - packages/extensible-exceptions.git git -
-libraries/filepath - packages/filepath.git git -
-libraries/ghc-prim - packages/ghc-prim.git git -
-libraries/haskeline - packages/haskeline.git git http://code.haskell.org/haskeline/
-libraries/haskell98 - packages/haskell98.git git -
-libraries/haskell2010 - packages/haskell2010.git git -
-libraries/hoopl - packages/hoopl.git git -
-libraries/hpc - packages/hpc.git git -
-libraries/integer-gmp - packages/integer-gmp.git git -
-libraries/integer-simple - packages/integer-simple.git git -
-libraries/mtl - packages/mtl.git git -
-libraries/old-locale - packages/old-locale.git git -
-libraries/old-time - packages/old-time.git git -
-libraries/pretty - packages/pretty.git git -
-libraries/process - packages/process.git git -
-libraries/random - packages/random.git git -
-libraries/template-haskell - packages/template-haskell.git git -
-libraries/terminfo - packages/terminfo.git git http://code.haskell.org/terminfo/
-libraries/unix - packages/unix.git git -
-libraries/utf8-string - packages/utf8-string.git git http://code.haskell.org/utf8-string/
-libraries/Win32 - packages/Win32.git git -
-libraries/xhtml - packages/xhtml.git git -
-testsuite testsuite testsuite.git git -
-nofib nofib nofib.git git -
-libraries/deepseq extra packages/deepseq.git git -
-libraries/parallel extra packages/parallel.git git -
-libraries/stm extra packages/stm.git git -
-libraries/primitive dph packages/primitive.git git http://code.haskell.org/primitive
-libraries/vector dph packages/vector.git git http://code.haskell.org/vector
-libraries/dph dph packages/dph.git git -
+. - ghc.git git
+ghc-tarballs - ghc-tarballs.git git
+utils/hsc2hs - hsc2hs.git git
+utils/haddock - haddock2.git git
+libraries/array - packages/array.git git
+libraries/base - packages/base.git git
+libraries/binary - packages/binary.git git
+libraries/bytestring - packages/bytestring.git git
+libraries/Cabal - packages/Cabal.git git
+libraries/containers - packages/containers.git git
+libraries/directory - packages/directory.git git
+libraries/extensible-exceptions - packages/extensible-exceptions.git git
+libraries/filepath - packages/filepath.git git
+libraries/ghc-prim - packages/ghc-prim.git git
+libraries/haskeline - packages/haskeline.git git
+libraries/haskell98 - packages/haskell98.git git
+libraries/haskell2010 - packages/haskell2010.git git
+libraries/hoopl - packages/hoopl.git git
+libraries/hpc - packages/hpc.git git
+libraries/integer-gmp - packages/integer-gmp.git git
+libraries/integer-simple - packages/integer-simple.git git
+libraries/mtl - packages/mtl.git git
+libraries/old-locale - packages/old-locale.git git
+libraries/old-time - packages/old-time.git git
+libraries/pretty - packages/pretty.git git
+libraries/process - packages/process.git git
+libraries/random - packages/random.git git
+libraries/template-haskell - packages/template-haskell.git git
+libraries/terminfo - packages/terminfo.git git
+libraries/unix - packages/unix.git git
+libraries/utf8-string - packages/utf8-string.git git
+libraries/Win32 - packages/Win32.git git
+libraries/xhtml - packages/xhtml.git git
+testsuite testsuite testsuite.git git
+nofib nofib nofib.git git
+libraries/deepseq extra packages/deepseq.git git
+libraries/parallel extra packages/parallel.git git
+libraries/stm extra packages/stm.git git
+libraries/primitive dph packages/primitive.git git
+libraries/vector dph packages/vector.git git
+libraries/dph dph packages/dph.git git
void
freeWin32ProgArgv (void)
{
- freeArgv(win32_prog_argc, win32_prog_argv);
-
int i;
if (win32_prog_argv != NULL) {
}
gen_live += gcThreadLiveWords(i,g);
- gen_live += gcThreadLiveWords(i,g);
gen_blocks += gcThreadLiveBlocks(i,g);
}
#ifdef THREADED_RTS
retry:
#endif
- if (bh_info == &stg_BLACKHOLE_info ||
- bh_info == &stg_WHITEHOLE_info)
+ // If the info table is a WHITEHOLE or a BLACKHOLE, then
+ // another thread has claimed it (via the SET_INFO()
+ // below), or is in the process of doing so. In that case
+ // we want to suspend the work that the current thread has
+ // done on this thunk and wait until the other thread has
+ // finished.
+ //
+ // If eager blackholing is taking place, it could be the
+ // case that the blackhole points to the current
+ // TSO. e.g.:
+ //
+ // this thread other thread
+ // --------------------------------------------------------
+ // c->indirectee = other_tso;
+ // c->header.info = EAGER_BH
+ // threadPaused():
+ // c->header.info = WHITEHOLE
+ // c->indirectee = other_tso
+ // c->indirectee = this_tso;
+ // c->header.info = EAGER_BH
+ // c->header.info = BLACKHOLE
+ // threadPaused()
+ // *** c->header.info is now BLACKHOLE,
+ // c->indirectee points to this_tso
+ //
+ // So in this case do *not* suspend the work of the
+ // current thread, because the current thread will become
+ // deadlocked on itself. See #5226 for an instance of
+ // this bug.
+ //
+ if ((bh_info == &stg_WHITEHOLE_info ||
+ bh_info == &stg_BLACKHOLE_info)
+ &&
+ ((StgInd*)bh)->indirectee != (StgClosure*)tso)
{
debugTrace(DEBUG_squeeze,
"suspending duplicate work: %ld words of stack",
tracePreface();
switch (tag) {
case EVENT_CAPSET_CREATE: // (capset, capset_type)
- debugBelch("created capset %d of type %d\n", capset, other);
+ debugBelch("created capset %lu of type %d\n", (lnat)capset, (int)other);
break;
case EVENT_CAPSET_DELETE: // (capset)
- debugBelch("deleted capset %d\n", capset);
+ debugBelch("deleted capset %lu\n", (lnat)capset);
break;
case EVENT_CAPSET_ASSIGN_CAP: // (capset, capno)
- debugBelch("assigned cap %d to capset %d\n", other, capset);
+ debugBelch("assigned cap %lu to capset %lu\n",
+ (lnat)other, (lnat)capset);
break;
case EVENT_CAPSET_REMOVE_CAP: // (capset, capno)
- debugBelch("removed cap %d from capset %d\n", other, capset);
+ debugBelch("removed cap %lu from capset %lu\n",
+ (lnat)other, (lnat)capset);
break;
}
RELEASE_LOCK(&trace_utx);
* ---------------------------------------------------------------------------*/
#include "Rts.h"
+#include "RtsUtils.h"
#include "GetEnv.h"
#include <windows.h>
envc++;
}
- envv = stgMallocBytes(sizeof(char*) * (envc+1));
+ envv = stgMallocBytes(sizeof(char*) * (envc+1), "getProgEnvv");
i = 0;
- for (envp = env; *envp != NULL; envp += strlen(envp) + 1) {
+ for (envp = env; *envp != 0; envp += strlen(envp) + 1) {
envv[i] = envp;
i++;
}
# add P to the list of packages
define extra-packages
-$$(foreach p,$$(patsubst libraries/%,%,$$(wildcard $$(shell grep '^[^ #][^ ]* \+\(dph\|extra\) \+[^ ]\+ \+[^ ]\+ \+[^ ]\+' packages | sed 's/ .*//'))),\
+$$(foreach p,$$(patsubst libraries/%,%,$$(wildcard $$(shell grep '^[^ #][^ ]* \+\(dph\|extra\) \+[^ ]\+ \+[^ ]\+$$$$' packages | sed 's/ .*//'))),\
$$(if $$(wildcard libraries/$$p/ghc-packages),\
$$(eval BUILD_DIRS += libraries/$$p) \
$$(foreach q,$$(shell cat libraries/$$p/ghc-packages2),$$(eval $$(call extra-package,$$p,$$p/$$q))),\
foreach (@repos) {
chomp;
$lineNum++;
- if (/^([^# ]+) +([^ ]+) +([^ ]+) +([^ ]+) +([^ ]+)$/) {
+ if (/^([^# ]+) +([^ ]+) +([^ ]+) +([^ ]+)$/) {
my %line;
$line{"localpath"} = $1;
$line{"tag"} = $2;
$line{"remotepath"} = $3;
$line{"vcs"} = $4;
- $line{"upstream"} = $5;
push @packages, \%line;
}
elsif (! /^(#.*)?$/) {
my $tag;
my $remotepath;
my $scm;
- my $upstream;
my $line;
my $branch_name;
my $subcommand;
$tag = $$line{"tag"};
$remotepath = $$line{"remotepath"};
$scm = $$line{"vcs"};
- $upstream = $$line{"upstream"};
# Check the SCM is OK as early as possible
die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git"));
utils/compare_sizes_USES_CABAL = YES
utils/compare_sizes_PACKAGE = compareSizes
utils/compare_sizes_MODULES = Main
-utils/compare_sizes_dist_PROG = compareSizes$(exeext)
+utils/compare_sizes_dist-install_PROG = compareSizes$(exeext)
-$(eval $(call build-prog,utils/compare_sizes,dist,1))
+$(eval $(call build-prog,utils/compare_sizes,dist-install,1))
-- files and "package.conf.d" dirs) the pkgroot is the parent directory
-- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
+-- TODO: This code is duplicated in compiler/main/Packages.lhs
mungePackagePaths :: FilePath -> FilePath
-> InstalledPackageInfo -> InstalledPackageInfo
-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
libraryDirs = munge_paths (libraryDirs pkg),
frameworkDirs = munge_paths (frameworkDirs pkg),
haddockInterfaces = munge_paths (haddockInterfaces pkg),
- haddockHTMLs = munge_urls (haddockHTMLs pkg)
+ -- haddock-html is allowed to be either a URL or a file
+ haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))
}
where
munge_paths = map munge_path
munge_urls = map munge_url
munge_path p
- | Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
- | Just p' <- stripVarPrefix "$topdir" sp = top_dir </> p'
- | otherwise = p
- where
- sp = splitPath p
+ | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
+ | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
+ | otherwise = p
munge_url p
- | Just p' <- stripVarPrefix "${pkgrooturl}" sp = toUrlPath pkgroot p'
- | Just p' <- stripVarPrefix "$httptopdir" sp = toUrlPath top_dir p'
- | otherwise = p
- where
- sp = splitPath p
+ | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
+ | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
+ | otherwise = p
toUrlPath r p = "file:///"
-- URLs always use posix style '/' separators:
- ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
-
- stripVarPrefix var (root:path')
- | Just [sep] <- stripPrefix var root
- , isPathSeparator sep
- = Just (joinPath path')
-
- stripVarPrefix _ _ = Nothing
+ ++ FilePath.Posix.joinPath
+ (r : -- We need to drop a leading "/" or "\\"
+ -- if there is one:
+ dropWhile (all isPathSeparator)
+ (FilePath.splitDirectories p))
+
+ -- We could drop the separator here, and then use </> above. However,
+ -- by leaving it in and using ++ we keep the same path separator
+ -- rather than letting FilePath change it to use \ as the separator
+ stripVarPrefix var path = case stripPrefix var path of
+ Just [] -> Just []
+ Just cs@(c : _) | isPathSeparator c -> Just cs
+ _ -> Nothing
-- -----------------------------------------------------------------------------
utils/ghc-pwd_USES_CABAL = YES
utils/ghc-pwd_PACKAGE = ghc-pwd
-utils/ghc-pwd_dist_PROG = ghc-pwd$(exeext)
+utils/ghc-pwd_dist-install_PROG = ghc-pwd$(exeext)
-$(eval $(call build-prog,utils/ghc-pwd,dist,1))
+$(eval $(call build-prog,utils/ghc-pwd,dist-install,1))
import Exception
import FastString
import MonadUtils ( liftIO )
+import SrcLoc
-- Every GHC comes with Cabal anyways, so this is not a bad new dependency
import Distribution.Simple.GHC ( ghcOptions )
type ThingName = String -- name of a defined entity in a Haskell program
-- A definition we have found (we know its containing module, name, and location)
-data FoundThing = FoundThing ModuleName ThingName SrcLoc
+data FoundThing = FoundThing ModuleName ThingName RealSrcLoc
-- Data we have obtained from a file (list of things we found)
data FileData = FileData FileName [FoundThing] (Map Int String)
in vals ++ tys ++ fors
where found = foundOfLName mod
-startOfLocated :: Located a -> SrcLoc
-startOfLocated lHs = srcSpanStart $ getLoc lHs
+startOfLocated :: Located a -> RealSrcLoc
+startOfLocated lHs = case getLoc lHs of
+ RealSrcSpan l -> realSrcSpanStart l
+ UnhelpfulSpan _ -> panic "startOfLocated UnhelpfulSpan"
foundOfLName :: ModuleName -> Located Name -> FoundThing
foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
#
# -----------------------------------------------------------------------------
-utils/ghctags_dist_MODULES = Main
-utils/ghctags_dist_HC_OPTS = -package ghc
-utils/ghctags_dist_INSTALL = NO
-utils/ghctags_dist_PROG = ghctags$(exeext)
-$(eval $(call build-prog,utils/ghctags,dist,2))
+utils/ghctags_dist-install_MODULES = Main
+utils/ghctags_dist-install_HC_OPTS = -package ghc
+utils/ghctags_dist-install_INSTALL = NO
+utils/ghctags_dist-install_PROG = ghctags$(exeext)
+$(eval $(call build-prog,utils/ghctags,dist-install,2))
#
# -----------------------------------------------------------------------------
-utils/hpc_dist_MODULES = Main HpcCombine HpcDraft HpcFlags HpcLexer \
+utils/hpc_dist-install_MODULES = Main HpcCombine HpcDraft HpcFlags HpcLexer \
HpcMarkup HpcOverlay HpcParser HpcReport \
HpcShowTix HpcUtils
-utils/hpc_dist_HC_OPTS = -cpp -package hpc
-utils/hpc_dist_INSTALL = YES
-utils/hpc_dist_PROG = hpc$(exeext)
-$(eval $(call build-prog,utils/hpc,dist,1))
+utils/hpc_dist-install_HC_OPTS = -cpp -package hpc
+utils/hpc_dist-install_INSTALL = YES
+utils/hpc_dist-install_PROG = hpc$(exeext)
+$(eval $(call build-prog,utils/hpc,dist-install,1))
# -----------------------------------------------------------------------------
utils/runghc_PACKAGE = runghc
-utils/runghc_dist_USES_CABAL = YES
-utils/runghc_dist_PROG = runghc$(exeext)
-utils/runghc_dist_SHELL_WRAPPER = YES
-utils/runghc_dist_INSTALL_SHELL_WRAPPER = YES
-utils/runghc_dist_EXTRA_HC_OPTS = -cpp -DVERSION="\"$(ProjectVersion)\""
+utils/runghc_dist-install_USES_CABAL = YES
+utils/runghc_dist-install_PROG = runghc$(exeext)
+utils/runghc_dist-install_SHELL_WRAPPER = YES
+utils/runghc_dist-install_INSTALL_SHELL_WRAPPER = YES
+utils/runghc_dist-install_EXTRA_HC_OPTS = -cpp -DVERSION="\"$(ProjectVersion)\""
ifneq "$(BINDIST)" "YES"
# hack: the build system has trouble with Main modules not called Main.hs
-utils/runghc/dist/build/Main.hs : utils/runghc/runghc.hs | $$(dir $$@)/.
+utils/runghc/dist-install/build/Main.hs : utils/runghc/runghc.hs | $$(dir $$@)/.
"$(CP)" $< $@
endif
-$(eval $(call build-prog,utils/runghc,dist,1))
+$(eval $(call build-prog,utils/runghc,dist-install,1))
install: install_runhaskell