diff options
| author | David Waern <david.waern@gmail.com> | 2011-06-10 23:56:19 +0000 |
|---|---|---|
| committer | David Waern <david.waern@gmail.com> | 2011-06-10 23:56:19 +0000 |
| commit | def7f873b4a37c67aef34d6f31de39d2a566638b (patch) | |
| tree | 84b75b5d172d228d730ed05d127c6d41a824b606 | |
| parent | a0770aa618f81e04737ba7bf4047ae4e7b644671 (diff) | |
| parent | 0b4324456e472d15a3a124f56387486f71cb765d (diff) | |
| download | haskell-def7f873b4a37c67aef34d6f31de39d2a566638b.tar.gz | |
Merge branch 'master' of http://darcs.haskell.org/ghc
39 files changed, 1180 insertions, 988 deletions
diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index f2ae963891..a2b42a278e 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -480,12 +480,14 @@ ppr_z_occ_name occ = ftext (zEncodeFS (occNameFS occ)) -- 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} %************************************************************************ diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index c8a510f90a..355facd010 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -677,14 +677,16 @@ pprNameProvenance (GRE {gre_name = name, gre_prov = Imported whys}) -- 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} diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index d2cbd7f07c..22ab915b22 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -7,10 +7,11 @@ -- 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 @@ -26,22 +27,21 @@ module SrcLoc ( -- ** 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 @@ -54,7 +54,9 @@ module SrcLoc ( isGoodSrcSpan, isOneLineSpan, -- * Located - Located(..), + Located, + RealLocated, + GenLocated(..), -- ** Constructing Located noLoc, @@ -89,10 +91,13 @@ We keep information about the {\em definition} point for each entity; 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} @@ -104,7 +109,10 @@ data SrcLoc \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 @@ -116,35 +124,26 @@ interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive session>") 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} %************************************************************************ @@ -157,21 +156,31 @@ advanceSrcLoc loc _ = loc -- Better than nothing -- 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 @@ -183,8 +192,16 @@ instance Outputable SrcLoc where 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" @@ -209,7 +226,7 @@ The end position is defined to be the column /after/ the end of the 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, @@ -230,7 +247,15 @@ data SrcSpan 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 @@ -253,13 +278,14 @@ mkGeneralSrcSpan = UnhelpfulSpan -- | 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 @@ -271,12 +297,25 @@ mkSrcSpan loc1 loc2 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 @@ -299,17 +338,14 @@ combineSrcSpans span1 span2 \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} @@ -321,34 +357,26 @@ isOneLineSpan s \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} @@ -362,26 +390,28 @@ srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol" -- | 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} @@ -400,17 +430,31 @@ instance Ord SrcSpan where (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) @@ -420,7 +464,7 @@ pprUserSpan show_path (SrcSpanOneLine src_path line start_col end_col) ] -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 '-' @@ -428,17 +472,13 @@ pprUserSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol) 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} %************************************************************************ @@ -449,13 +489,16 @@ pprDefnLoc loc \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 @@ -483,12 +526,16 @@ eqLocated a b = unLoc a == unLoc b 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} %************************************************************************ @@ -506,11 +553,11 @@ leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b) `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 diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x index 0a1929056a..9a7b43da6c 100644 --- a/compiler/cmm/CmmLex.x +++ b/compiler/cmm/CmmLex.x @@ -173,7 +173,7 @@ data CmmToken -- ----------------------------------------------------------------------------- -- 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 @@ -268,7 +268,7 @@ tok_string str = CmmT_String (read str) 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 @@ -278,7 +278,7 @@ setLine code span buf len = do 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 @@ -289,16 +289,16 @@ setFile code span buf len = do 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" @@ -307,7 +307,7 @@ lexToken = do 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 @@ -315,7 +315,7 @@ lexToken = do -- 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' diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 6d14be23e6..60f3bb5623 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -1062,7 +1062,7 @@ parseCmmFile dflags filename = do 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. diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index c5a6644aba..fa7287d4a2 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -733,7 +733,7 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do 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 @@ -751,7 +751,7 @@ emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code 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 @@ -795,8 +795,8 @@ emitMemmoveCall dst src n live = do 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 diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index 88509f90f3..c130921dbf 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -15,27 +15,28 @@ Taken quite directly from the Peyton Jones/Lester paper. -- | 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" @@ -268,9 +269,9 @@ exprsOrphNames es = foldr (unionNameSets . exprOrphNames) emptyNameSet es \end{code} %************************************************************************ -%* * +%* * \section[freevars-everywhere]{Attaching free variables to every sub-expression} -%* * +%* * %************************************************************************ \begin{code} @@ -278,7 +279,7 @@ exprsOrphNames es = foldr (unionNameSets . exprOrphNames) emptyNameSet es 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 @@ -286,7 +287,7 @@ ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs }) 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 @@ -298,8 +299,8 @@ idRuleRhsVars is_active id 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 @@ -315,19 +316,31 @@ ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args }) = 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 +\end{code} + + %************************************************************************ -%* * +%* * \section[freevars-everywhere]{Attaching free variables to every sub-expression} -%* * +%* * %************************************************************************ The free variable pass annotates every node in the expression with its diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 047e6c337b..acf17e3c12 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -692,16 +692,16 @@ substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule -- - 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. @@ -709,13 +709,22 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args (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)) + +------------------ 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] @@ -766,15 +775,16 @@ simpleOptExprWith :: Subst -> InExpr -> OutExpr 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 diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 37cbc2d5c5..fbe1ab9a45 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -846,26 +846,16 @@ allocBinTickBox boxLabel pos m 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") diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 7b008e9aaf..70679fbf4f 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -116,35 +116,36 @@ deSugar hsc_env ; case mb_res of { Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks) -> do + Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> 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 = combineEvBinds ds_ev_binds final_prs - -- 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#! + -- 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 + -- Lint result if necessary, and print ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $ (vcat [ pprCoreBindings final_pgm , pprRules rules_for_imps ]) - ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps - -- The simpleOptPgm gets rid of type - -- bindings plus any stupid dead code + ; (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 + ; 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, diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index 176182e98b..7b4c904f81 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -15,7 +15,7 @@ import HsDoc ( HsDocString ) import Outputable import FastString -import SrcLoc ( Located(..), noLoc ) +import SrcLoc import Data.Data \end{code} diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs index 39093f2550..ce748ebfab 100644 --- a/compiler/hsSyn/HsSyn.lhs +++ b/compiler/hsSyn/HsSyn.lhs @@ -41,7 +41,7 @@ import HsDoc -- others: import IfaceSyn ( IfaceBinding ) import Outputable -import SrcLoc ( Located(..) ) +import SrcLoc import Module ( Module, ModuleName ) import FastString diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 0ecc09b9d7..5f7139cbf6 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -186,10 +186,10 @@ module GHC ( 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, @@ -197,7 +197,7 @@ module GHC ( srcSpanStartCol, srcSpanEndCol, -- ** Located - Located(..), + GenLocated(..), Located, -- *** Constructing Located noLoc, mkGeneralLocated, @@ -1105,7 +1105,7 @@ getModuleSourceAndFlags mod = 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) @@ -1116,7 +1116,7 @@ getTokenStream mod = do 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) @@ -1124,21 +1124,22 @@ getRichTokenStream mod = do -- | 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 @@ -1146,21 +1147,26 @@ addSourceToTokens loc buf (t@(L span _) : ts) -- 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 @@ -1258,7 +1264,7 @@ parser :: String -- ^ Haskell module source text (full Unicode is suppor 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 diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 24a216a4ab..93ce824964 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -55,7 +55,7 @@ getImports :: DynFlags -> 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 @@ -143,7 +143,7 @@ lazyGetToks dflags filename handle = 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 @@ -160,7 +160,7 @@ lazyGetToks dflags filename handle = 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] @@ -175,12 +175,12 @@ lazyGetToks dflags filename handle = do 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. diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 3e37f5bac6..6542a06147 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -340,7 +340,7 @@ hscParse' mod_summary 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 -> @@ -1186,7 +1186,7 @@ hscParseThingWithLocation source linenumber parser str 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 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index f3e569b645..ea0cd6357b 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -136,7 +136,7 @@ import CoreSyn ( CoreRule, CoreVect ) 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 diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 860464e974..12316713d6 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -260,6 +260,7 @@ maybeHidePackages dflags pkgs 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) @@ -283,29 +284,30 @@ mungePackagePaths top_dir pkgroot pkg = 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 -- ----------------------------------------------------------------------------- diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index ae91b62c25..a5988fc62b 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -132,7 +132,7 @@ The machine-dependent bits break down as follows: -- 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, @@ -759,7 +759,7 @@ apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) genMachCode :: DynFlags - -> (DynFlags -> RawCmmTop -> NatM [NatCmmTop instr]) + -> (RawCmmTop -> NatM [NatCmmTop instr]) -> RawCmmTop -> UniqSM ( [NatCmmTop instr] @@ -768,7 +768,7 @@ genMachCode 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 diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 736d5640c5..0db76416eb 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -1,4 +1,3 @@ -{-# OPTIONS -w #-} ----------------------------------------------------------------------------- -- @@ -13,11 +12,11 @@ -- (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 @@ -29,7 +28,6 @@ where import PPC.Instr import PPC.Cond import PPC.Regs -import PPC.RegInfo import NCGMonad import Instruction import PIC @@ -41,27 +39,23 @@ import Platform -- 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 @@ -71,28 +65,28 @@ import FastString -- 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 @@ -101,14 +95,14 @@ basicBlockCodeGen (BasicBlock id stmts) = do -- instruction stream into basic blocks again. Also, we extract -- LDATAs here too. let - (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs - - mkBlocks (NEWBLOCK id) (instrs,blocks,statics) - = ([], BasicBlock id instrs : blocks, statics) - mkBlocks (LDATA sec dat) (instrs,blocks,statics) - = (instrs, blocks, CmmData sec dat:statics) - mkBlocks instr (instrs,blocks,statics) - = (instr:instrs, blocks, statics) + (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs + + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) -- in return (BasicBlock id top : other_blocks, statics) @@ -118,56 +112,56 @@ stmtsToInstrs stmts 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 @@ -209,17 +203,6 @@ temporary, then do the other computation, and then use the temporary: -} --- | Check whether an integer will fit in 32 bits. --- A CmmInt is intended to be truncated to the appropriate --- number of bits, so here we truncate it to Int64. This is --- important because e.g. -1 as a CmmInt might be either --- -1 or 18446744073709551615. --- -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) @@ -239,7 +222,7 @@ mangleIndexTree (CmmRegOff reg off) 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 @@ -257,27 +240,27 @@ of the VRegUniqueLo form, and the upper-half VReg can be determined 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 @@ -293,21 +276,21 @@ 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 @@ -318,7 +301,7 @@ assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do vcode `snocOL` mov_lo `snocOL` mov_hi ) -assignReg_I64Code lvalue valueTree +assignReg_I64Code _ _ = panic "assignReg_I64Code(powerpc): invalid lvalue" @@ -328,7 +311,7 @@ iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do (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 @@ -337,17 +320,17 @@ 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) @@ -356,12 +339,12 @@ iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do ChildCode64 code2 r2lo <- iselExpr64 e2 (rlo,rhi) <- getNewRegPairNat II32 let - r1hi = getHiVRegFromLo r1lo - r2hi = getHiVRegFromLo r2lo - code = code1 `appOL` - code2 `appOL` - toOL [ 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) @@ -378,46 +361,49 @@ iselExpr64 expr 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 @@ -427,21 +413,21 @@ getRegister (CmmLoad mem pk) 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 @@ -469,25 +455,25 @@ getRegister (CmmMachOp mop [x]) -- unary MachOps 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) @@ -506,7 +492,7 @@ getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps 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 -> @@ -534,16 +520,16 @@ getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps 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 @@ -551,32 +537,32 @@ getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps 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 [ @@ -585,20 +571,23 @@ getRegister (CmmLit lit) ] 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, @@ -650,13 +639,13 @@ getAmode (CmmLit lit) 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 @@ -667,8 +656,8 @@ getAmode 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. @@ -706,9 +695,9 @@ getCondCode (CmmMachOp mop [x, y]) 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)" @@ -723,7 +712,7 @@ condIntCode cond x (CmmLit (CmmInt y rep)) = 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') @@ -731,19 +720,19 @@ condIntCode cond x y = do (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'') @@ -828,7 +817,7 @@ allocator. genCondJump - :: BlockId -- the branch target + :: BlockId -- the branch target -> CmmExpr -- the condition on which to branch -> NatM InstrBlock @@ -844,31 +833,47 @@ genCondJump id bool = do -- Now the biggest nightmare---calls. Most of the nastiness is buried in -- @get_arg@, which moves the arguments to the correct registers/stack -- locations. Apart from that, the code is easy. --- +-- -- (If applicable) Do not fill the delay slots here; you will confuse the -- register allocator. -genCCall - :: CmmCallTarget -- function to call - -> HintedCmmFormals -- where to put the result - -> HintedCmmActuals -- arguments (of mixed type) +genCCall :: CmmCallTarget -- function to call + -> HintedCmmFormals -- where to put the result + -> HintedCmmActuals -- 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 + -> HintedCmmFormals -- where to put the result + -> HintedCmmActuals -- 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). @@ -884,7 +889,7 @@ genCCall 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 @@ -894,10 +899,10 @@ genCCall -} -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 @@ -906,37 +911,38 @@ genCCall target dest_regs argsAndHints 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) + 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 + 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 || @@ -947,25 +953,25 @@ genCCall target dest_regs argsAndHints | otherwise = argsAndHints - args = map hintlessCmm argsAndHints' - argReps = map cmmExprType args + args = map hintlessCmm argsAndHints' + argReps = map cmmExprType args - roundTo a x | x `mod` a == 0 = x - | otherwise = x + a - (x `mod` a) + 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 @@ -974,57 +980,56 @@ genCCall target dest_regs argsAndHints 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 @@ -1036,30 +1041,44 @@ genCCall target dest_regs argsAndHints (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 @@ -1071,7 +1090,8 @@ genCCall target dest_regs argsAndHints | otherwise -> unitOL (MR r_dest r3) where rep = cmmRegType (CmmLocal dest) r_dest = getRegisterReg (CmmLocal dest) - + _ -> panic "genCCall' moveResult: Bad dest_regs" + outOfLineMachOp mop = do dflags <- getDynFlagsNat @@ -1086,32 +1106,32 @@ genCCall target dest_regs argsAndHints 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) @@ -1124,16 +1144,12 @@ genCCall target dest_regs argsAndHints 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 @@ -1182,7 +1198,7 @@ generateJumpTableForInstr _ = Nothing -- 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. @@ -1207,27 +1223,27 @@ condReg getCond = do 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) @@ -1257,38 +1273,38 @@ clobber any fixed registers. * 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 @@ -1296,28 +1312,28 @@ trivialCode rep _ instr x y = do 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) @@ -1345,32 +1361,32 @@ coerceInt2FP fromRep toRep x = do 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') @@ -1380,11 +1396,11 @@ coerceFP2Int _ toRep x = do (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') diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index beb48d6656..a4dbbe8771 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -47,15 +47,13 @@ import Outputable 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 @@ -65,7 +63,7 @@ cmmTopCodeGen _ return tops -cmmTopCodeGen _ (CmmData sec dat) = do +cmmTopCodeGen (CmmData sec dat) = do return [CmmData sec dat] -- no translation, we just use CmmStatic diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 2f3e13936a..39de19c412 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -82,22 +82,22 @@ if_sse2 sse2 x87 = do 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 diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index a55a6310c9..76a02d6c60 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -7,7 +7,8 @@ -- 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. -- ----------------------------------------------------------------------------- @@ -555,7 +556,7 @@ data Token | ITparenEscape -- $( | ITvarQuote -- ' | ITtyQuote -- '' - | ITquasiQuote (FastString,FastString,SrcSpan) -- [:...|...|] + | ITquasiQuote (FastString,FastString,RealSrcSpan) -- [:...|...|] -- Arrow notation extension | ITproc @@ -721,7 +722,7 @@ reservedSymsFM = listToUFM $ -- ----------------------------------------------------------------------------- -- 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) @@ -764,7 +765,7 @@ hopefully_open_brace span buf len 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 @@ -846,7 +847,7 @@ lineCommentToken span buf len = do 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 @@ -887,8 +888,8 @@ nested_doc_comment span buf _len = withLexedDocType (go "") 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 @@ -925,19 +926,19 @@ endPrag span _buf _len = do -- 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 @@ -1012,8 +1013,8 @@ varsym, consym :: Action 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 @@ -1145,7 +1146,7 @@ do_layout_left span _buf _len = 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 @@ -1154,12 +1155,17 @@ setLine code span buf len = do 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. @@ -1170,7 +1176,7 @@ lex_string_prag mkTok span _buf _len 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 @@ -1183,7 +1189,7 @@ lex_string_prag mkTok span _buf _len = 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" -- ----------------------------------------------------------------------------- @@ -1195,7 +1201,7 @@ lex_string_tok :: Action 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 @@ -1256,7 +1262,7 @@ lex_char_tok :: Action -- 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 @@ -1264,7 +1270,7 @@ lex_char_tok span _buf _len = do -- We've seen ' 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 @@ -1290,10 +1296,10 @@ lex_char_tok span _buf _len = do -- We've seen ' -- 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 @@ -1302,11 +1308,11 @@ finish_char_tok loc ch -- We've already seen the closing quote 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 @@ -1441,10 +1447,10 @@ lex_quasiquote_tok span buf len = do 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 @@ -1472,12 +1478,12 @@ 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 -- ----------------------------------------------------------------------------- @@ -1500,22 +1506,22 @@ data PState = PState { 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 @@ -1556,13 +1562,13 @@ thenP :: P a -> (a -> P b) -> P b 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 @@ -1587,19 +1593,19 @@ getExts = P $ \s -> POk s (extsBitmap s) 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} () -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' @@ -1685,7 +1691,7 @@ popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls 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 @@ -1699,10 +1705,10 @@ activeContext = do ([],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] @@ -1719,7 +1725,7 @@ setJustClosedExplicitLetBlock :: Bool -> P () 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 @@ -1729,14 +1735,14 @@ implicitTokenPending [] -> 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) @@ -1844,20 +1850,20 @@ nondecreasingIndentation flags = testBit flags nondecreasingIndentationBit -- 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, @@ -1865,7 +1871,7 @@ mkPState flags buf loc = 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 @@ -1921,7 +1927,7 @@ popContext = P $ \ s@(PState{ buffer = buf, context = ctx, 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' @@ -1960,7 +1966,7 @@ srcParseErr buf len 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. @@ -1978,11 +1984,11 @@ lexer :: (Located Token -> P a) -> P a 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 -> @@ -2004,7 +2010,7 @@ lexTokenAlr = do mPending <- popPendingImplicitToken _ -> return () return t -alternativeLayoutRuleToken :: Located Token -> P (Located Token) +alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token) alternativeLayoutRuleToken t = do context <- getALRContext lastLoc <- getAlrLastLoc @@ -2015,8 +2021,7 @@ alternativeLayoutRuleToken t 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... @@ -2076,7 +2081,7 @@ alternativeLayoutRuleToken t (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 @@ -2088,7 +2093,7 @@ alternativeLayoutRuleToken t (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 @@ -2203,14 +2208,14 @@ topNoLayoutContainsCommas [] = False 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) -> @@ -2220,12 +2225,12 @@ lexToken = do 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 = @@ -2236,7 +2241,7 @@ reportLexError loc1 loc2 buf str 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 diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 25c65d10b3..3651405772 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -41,9 +41,7 @@ import ForeignCall ( Safety(..), CExportSpec(..), CLabelString, ) import OccName ( varName, 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 ) @@ -1262,7 +1260,7 @@ quasiquote :: { Located (HsQuasiQuote RdrName) } : 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) } exp :: { LHsExpr RdrName } : infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 } diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index c4ad95a333..b3333731c1 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -1053,7 +1053,11 @@ unknownNameSuggestErr where_look tried_rdr_name 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)) diff --git a/compiler/rename/RnHsDoc.hs b/compiler/rename/RnHsDoc.hs index beb45bbfbc..9e53f49320 100644 --- a/compiler/rename/RnHsDoc.hs +++ b/compiler/rename/RnHsDoc.hs @@ -3,7 +3,7 @@ module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where import TcRnTypes import HsSyn -import SrcLoc ( Located(..) ) +import SrcLoc rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString) diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs index 478ba32655..bfbcdc515f 100644 --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@ -22,7 +22,7 @@ import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon ) import Name ( Name, getName, isTyVarName ) import NameSet import BasicTypes ( Boxity ) -import SrcLoc ( Located(..), unLoc ) +import SrcLoc \end{code} %************************************************************************ diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 4c269d904d..ee14ad91b3 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -1256,7 +1256,9 @@ warnUnusedImportDecls gbl_env ; 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} diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index ba7d19295b..06133d6bdb 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -53,13 +53,14 @@ import Data.List 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 _ [] diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index ea81317928..23a2472b23 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -358,7 +358,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) = do { -- Occurrence analysis let { tagged_binds = {-# SCC "OccAnal" #-} - occurAnalysePgm active_rule rules binds } ; + occurAnalysePgm active_rule rules [] binds } ; Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" (pprCoreBindings tagged_binds); diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 7e7803d69d..78fc9bc533 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -576,12 +576,13 @@ impSpecErr name , ptext (sLit "(or you compiled its defining module without -O)")]) -------------- -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'] dups = findDupsEq (==) ids ; mapM_ reportVectDups dups + ; traceTcConstraints "End of tcVectDecls" ; return decls' } where @@ -599,7 +600,7 @@ tcVect :: VectDecl Name -> TcM (VectDecl TcId) 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) $ @@ -614,9 +615,10 @@ tcVect (HsVect name@(L loc _) (Just rhs)) ; (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 diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 2cb38a908a..66a37388f1 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -2,7 +2,7 @@ module TcCanonical( mkCanonical, mkCanonicals, mkCanonicalFEV, mkCanonicalFEVs, canWanteds, canGivens, canOccursCheck, canEqToWorkList, - rewriteWithFunDeps + rewriteWithFunDeps, mkCanonicalFDAsDerived, mkCanonicalFDAsWanted ) where #include "HsVersions.h" @@ -23,7 +23,7 @@ import Name 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 ( (<|>) ) @@ -981,60 +981,44 @@ now!). \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 @@ -1044,4 +1028,36 @@ mkEqnMsg (pred1,from1) (pred2,from2) tidy_env 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 diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 3833534f1e..b279c2fc0a 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -163,7 +163,8 @@ instance Outputable InertSet where , 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 @@ -929,71 +930,77 @@ doInteractWithInert :: CanonicalCt -> CanonicalCt -> TcS InteractResult 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. @@ -1284,25 +1291,26 @@ rewriteFrozen (cv1, tv1, xi1) (cv2, fl2) 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 ) @@ -1310,10 +1318,16 @@ solveOneFromTheOther info (ev_term,ifl) workItem 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] @@ -1725,69 +1739,83 @@ doTopReact _inerts (CDictCan { cc_flavor = Given {} }) = 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 }) diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 7e7f117cdf..ce84178e10 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -494,9 +494,10 @@ getSrcSpanM :: TcRn SrcSpan 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 @@ -989,10 +990,10 @@ captureConstraints :: TcM a -> TcM (a, WantedConstraints) -- (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 @@ -1017,14 +1018,21 @@ setLclTypeEnv lcl_env 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} diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 3cc2eb5570..6da5741037 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -897,13 +897,17 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where 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 diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index e4f97bdda7..f3749ca09c 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -1,105 +1,120 @@ -- | 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 - = ArchUnknown - | 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 -defaultTargetArch = ArchUnknown +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 diff --git a/ghc/GhciTags.hs b/ghc/GhciTags.hs index fc5cf00e4b..95bc83e0bb 100644 --- a/ghc/GhciTags.hs +++ b/ghc/GhciTags.hs @@ -91,13 +91,13 @@ listModuleTags m = do 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 @@ -120,7 +120,7 @@ data TagInfo = TagInfo -- 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)) diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 757b634cc1..884059aece 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -687,7 +687,7 @@ checkInputForLayout stmt getStmt = do 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 @@ -2061,12 +2061,15 @@ stepModuleCmd expression = stepCmd expression -- | 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 () @@ -2178,13 +2181,15 @@ breakSwitch (arg1:rest) | 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 @@ -2249,10 +2254,12 @@ findBreakByLine line arr 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) @@ -2269,12 +2276,16 @@ findBreakByCoord mb_file (line, col) arr 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. @@ -2300,9 +2311,9 @@ listCmd' "" = do 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" @@ -2328,17 +2339,18 @@ list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do 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 @@ -2355,8 +2367,8 @@ listModuleLine modl line = do [] -> 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 @@ -2367,7 +2379,7 @@ listModuleLine modl line = do -- 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 @@ -2454,11 +2466,14 @@ mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray 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 @@ -2500,3 +2515,4 @@ setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool setBreakFlag toggle array index | toggle = GHC.setBreakOn array index | otherwise = GHC.setBreakOff array index + diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 4e6b53193a..52b79146b7 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -661,6 +661,7 @@ mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } = -- 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 @@ -678,36 +679,38 @@ mungePackagePaths top_dir pkgroot pkg = 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 -- ----------------------------------------------------------------------------- diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index c86a92a226..4ba8157dcc 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -16,6 +16,7 @@ import Bag 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 ) @@ -49,7 +50,7 @@ type FileName = String 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) @@ -261,8 +262,10 @@ boundValues mod group = 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) |