Merge branch 'master' of http://darcs.haskell.org/ghc
authorDavid Waern <david.waern@gmail.com>
Fri, 10 Jun 2011 23:56:19 +0000 (23:56 +0000)
committerDavid Waern <david.waern@gmail.com>
Fri, 10 Jun 2011 23:56:19 +0000 (23:56 +0000)
39 files changed:
compiler/basicTypes/Name.lhs
compiler/basicTypes/RdrName.lhs
compiler/basicTypes/SrcLoc.lhs
compiler/cmm/CmmLex.x
compiler/cmm/CmmParse.y
compiler/codeGen/CgPrimOp.hs
compiler/coreSyn/CoreFVs.lhs
compiler/coreSyn/CoreSubst.lhs
compiler/deSugar/Coverage.lhs
compiler/deSugar/Desugar.lhs
compiler/hsSyn/HsImpExp.lhs
compiler/hsSyn/HsSyn.lhs
compiler/main/GHC.hs
compiler/main/HeaderInfo.hs
compiler/main/HscMain.lhs
compiler/main/HscTypes.lhs
compiler/main/Packages.lhs
compiler/nativeGen/AsmCodeGen.lhs
compiler/nativeGen/PPC/CodeGen.hs
compiler/nativeGen/SPARC/CodeGen.hs
compiler/nativeGen/X86/CodeGen.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/rename/RnEnv.lhs
compiler/rename/RnHsDoc.hs
compiler/rename/RnHsSyn.lhs
compiler/rename/RnNames.lhs
compiler/simplCore/OccurAnal.lhs
compiler/simplCore/SimplCore.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcCanonical.lhs
compiler/typecheck/TcInteract.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcSplice.lhs
compiler/utils/Platform.hs
ghc/GhciTags.hs
ghc/InteractiveUI.hs
utils/ghc-pkg/Main.hs
utils/ghctags/Main.hs

index f2ae963..a2b42a2 100644 (file)
@@ -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}
 
 %************************************************************************
index c8a510f..355facd 100644 (file)
@@ -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}
index d2cbd7f..22ab915 100644 (file)
@@ -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
index 0a19290..9a7b43d 100644 (file)
@@ -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'
index 6d14be2..60f3bb5 100644 (file)
@@ -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.
index c5a6644..fa7287d 100644 (file)
@@ -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
index 88509f9..c130921 100644 (file)
@@ -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
index 047e6c3..acf17e3 100644 (file)
@@ -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 
index 37cbc2d..fbe1ab9 100644 (file)
@@ -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")
index 7b008e9..70679fb 100644 (file)
@@ -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,
index 176182e..7b4c904 100644 (file)
@@ -15,7 +15,7 @@ import HsDoc          ( HsDocString )
 
 import Outputable
 import FastString
-import SrcLoc           ( Located(..), noLoc )
+import SrcLoc
 
 import Data.Data
 \end{code}
index 39093f2..ce748eb 100644 (file)
@@ -41,7 +41,7 @@ import HsDoc
 -- others:
 import IfaceSyn                ( IfaceBinding )
 import Outputable
-import SrcLoc          ( Located(..) )
+import SrcLoc
 import Module          ( Module, ModuleName )
 import FastString
 
index 0ecc09b..5f7139c 100644 (file)
@@ -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
index 24a216a..93ce824 100644 (file)
@@ -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.
index 3e37f5b..6542a06 100644 (file)
@@ -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
 
index f3e569b..ea0cd63 100644 (file)
@@ -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
index 860464e..1231671 100644 (file)
@@ -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
 
 
 -- -----------------------------------------------------------------------------
index ae91b62..a5988fc 100644 (file)
@@ -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
index 736d564..0db7641 100644 (file)
@@ -1,4 +1,3 @@
-{-# OPTIONS -w #-}
 
 -----------------------------------------------------------------------------
 --
 -- (c) the #if blah_TARGET_ARCH} things, the
 -- structure should not be too overwhelming.
 
-module PPC.CodeGen ( 
-       cmmTopCodeGen, 
-       generateJumpTableForInstr,
-       InstrBlock 
-) 
+module PPC.CodeGen (
+        cmmTopCodeGen,
+        generateJumpTableForInstr,
+        InstrBlock
+)
 
 where
 
@@ -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')
index beb48d6..a4dbbe8 100644 (file)
@@ -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
 
 
index 2f3e139..39de19c 100644 (file)
@@ -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
 
 
index a55a631..76a02d6 100644 (file)
@@ -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
index 25c65d1..3651405 100644 (file)
@@ -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 }
index c4ad95a..b333373 100644 (file)
@@ -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))
 
index beb45bb..9e53f49 100644 (file)
@@ -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)
index 478ba32..bfbcdc5 100644 (file)
@@ -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}
 
 %************************************************************************
index 4c269d9..ee14ad9 100644 (file)
@@ -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}
index ba7d192..06133d6 100644 (file)
@@ -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 _ []
index ea81317..23a2472 100644 (file)
@@ -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);
 
index 7e7803d..78fc9bc 100644 (file)
@@ -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 
index 2cb38a9..66a3738 100644 (file)
@@ -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
index 3833534..b279c2f 100644 (file)
@@ -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 })
index 7e7f117..ce84178 100644 (file)
@@ -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}
index 3cc2eb5..6da5741 100644 (file)
@@ -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
 
index e4f97bd..f3749ca 100644 (file)
 
 -- | 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
 
index fc5cf00..95bc83e 100644 (file)
@@ -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))
index 757b634..884059a 100644 (file)
@@ -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
+
index 4e6b531..52b7914 100644 (file)
@@ -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
 
 
 -- -----------------------------------------------------------------------------
index c86a92a..4ba8157 100644 (file)
@@ -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)