Change how includes for input file directory works
authorTamar Christina <tamar@zhox.com>
Tue, 20 Feb 2018 03:13:46 +0000 (22:13 -0500)
committerBen Gamari <ben@smart-cactus.org>
Tue, 20 Feb 2018 04:02:10 +0000 (23:02 -0500)
GHC Used to only allow for one include mode, namely `-I`.  The problem
with `-I` includes is that it supercedes all other includes, including
the system include paths.

This is not a problem for paths requested by the user, but it is a
problem for the ones we implicitly derive and add.

In particular we add the source directory of the input file to the
include path. This is problematic because it causes any file with the
name of a system include, to inadvertently loop as the wrong file gets
included.

Since this is an implicitly include, and as far as I can tell, only done
so local includes are found (as the sources given to GCC reside in a
temp folder) then switch from `-I` to `-iquote`.

This requires a submodule update for haddock

Test Plan: ./validate

Reviewers: austin, bgamari, hvr

Reviewed By: bgamari

Subscribers: carter, rwbarton, thomie

GHC Trac Issues: #14312

Differential Revision: https://phabricator.haskell.org/D4080

compiler/deSugar/DsForeign.hs
compiler/iface/FlagChecker.hs
compiler/main/DriverPipeline.hs
compiler/main/DynFlags.hs
docs/users_guide/8.6.1-notes.rst
utils/haddock

index 492d353..a23c51b 100644 (file)
@@ -229,7 +229,8 @@ dsFCall fn_id co fcall mDeclHeader = do
                                       CApiConv safety)
                       c = includes
                        $$ fun_proto <+> braces (cRet <> semi)
-                      includes = vcat [ text "#include <" <> ftext h <> text ">"
+                      includes = vcat [ text "#include \"" <> ftext h
+                                        <> text "\""
                                       | Header _ h <- nub headers ]
                       fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
                       cRet
index f81b265..1fc597b 100644 (file)
@@ -46,7 +46,8 @@ fingerprintDynFlags dflags@DynFlags{..} this_mod nameio =
                 map fromEnum $ EnumSet.toList extensionFlags)
 
         -- -I, -D and -U flags affect CPP
-        cpp = (map normalise includePaths, opt_P dflags ++ picPOpts dflags)
+        cpp = ( map normalise $ flattenIncludes includePaths
+              , opt_P dflags ++ picPOpts dflags)
             -- normalise: eliminate spurious differences due to "./foo" vs "foo"
 
         -- Note [path flags and recompilation]
index c6c9f9e..839f6d0 100644 (file)
@@ -264,7 +264,7 @@ compileOne' m_tc_result mHscMessage
        old_paths   = includePaths dflags1
        prevailing_dflags = hsc_dflags hsc_env0
        dflags =
-          dflags1 { includePaths = current_dir : old_paths
+          dflags1 { includePaths = addQuoteInclude old_paths [current_dir]
                   , log_action = log_action prevailing_dflags
                   , log_finaliser = log_finaliser prevailing_dflags }
                   -- use the prevailing log_action / log_finaliser,
@@ -989,8 +989,9 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
   -- the .hs files resides) to the include path, since this is
   -- what gcc does, and it's probably what you want.
         let current_dir = takeDirectory basename
+            new_includes = addQuoteInclude paths [current_dir]
             paths = includePaths dflags0
-            dflags = dflags0 { includePaths = current_dir : paths }
+            dflags = dflags0 { includePaths = new_includes }
 
         setDynFlags dflags
 
@@ -1157,8 +1158,11 @@ runPhase (RealPhase cc_phase) input_fn dflags
         -- files; this is the Value Add(TM) that using ghc instead of
         -- gcc gives you :)
         pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs
-        let include_paths = foldr (\ x xs -> ("-I" ++ x) : xs) []
-                              (cmdline_include_paths ++ pkg_include_dirs)
+        let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
+              (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
+        let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
+              (includePathsQuote cmdline_include_paths)
+        let include_paths = include_paths_quote ++ include_paths_global
 
         let gcc_extra_viac_flags = extraGccViaCFlags dflags
         let pic_c_flags = picCCOpts dflags
@@ -1321,10 +1325,13 @@ runPhase (RealPhase (As with_cpp)) input_fn dflags
         liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
 
         ccInfo <- liftIO $ getCompilerInfo dflags
+        let global_includes = [ SysTools.Option ("-I" ++ p)
+                              | p <- includePathsGlobal cmdline_include_paths ]
+        let local_includes = [ SysTools.Option ("-iquote" ++ p)
+                             | p <- includePathsQuote cmdline_include_paths ]
         let runAssembler inputFilename outputFilename
                 = liftIO $ as_prog dflags
-                       ([ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
-
+                       (local_includes ++ global_includes
                        -- See Note [-fPIC for assembler]
                        ++ map SysTools.Option pic_c_flags
 
@@ -1995,8 +2002,11 @@ doCpp dflags raw input_fn output_fn = do
     let cmdline_include_paths = includePaths dflags
 
     pkg_include_dirs <- getPackageIncludePath dflags []
-    let include_paths = foldr (\ x xs -> "-I" : x : xs) []
-                          (cmdline_include_paths ++ pkg_include_dirs)
+    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
+          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
+    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
+          (includePathsQuote cmdline_include_paths)
+    let include_paths = include_paths_quote ++ include_paths_global
 
     let verbFlags = getVerbFlags dflags
 
index dc4967d..e6b9cf6 100644 (file)
@@ -164,7 +164,10 @@ module DynFlags (
         CompilerInfo(..),
 
         -- * File cleanup
-        FilesToClean(..), emptyFilesToClean
+        FilesToClean(..), emptyFilesToClean,
+
+        -- * Include specifications
+        IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes
   ) where
 
 #include "HsVersions.h"
@@ -675,6 +678,33 @@ data WarnReason
   | ErrReason !(Maybe WarningFlag)
   deriving Show
 
+-- | Used to differentiate the scope an include needs to apply to.
+-- We have to split the include paths to avoid accidentally forcing recursive
+-- includes since -I overrides the system search paths. See Trac #14312.
+data IncludeSpecs
+  = IncludeSpecs { includePathsQuote  :: [String]
+                 , includePathsGlobal :: [String]
+                 }
+  deriving Show
+
+-- | Append to the list of includes a path that shall be included using `-I`
+-- when the C compiler is called. These paths override system search paths.
+addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs
+addGlobalInclude spec paths  = let f = includePathsGlobal spec
+                               in spec { includePathsGlobal = f ++ paths }
+
+-- | Append to the list of includes a path that shall be included using
+-- `-iquote` when the C compiler is called. These paths only apply when quoted
+-- includes are used. e.g. #include "foo.h"
+addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs
+addQuoteInclude spec paths  = let f = includePathsQuote spec
+                              in spec { includePathsQuote = f ++ paths }
+
+-- | Concatenate and flatten the list of global and quoted includes returning
+-- just a flat list of paths.
+flattenIncludes :: IncludeSpecs -> [String]
+flattenIncludes specs = includePathsQuote specs ++ includePathsGlobal specs
+
 instance Outputable WarnReason where
   ppr = text . show
 
@@ -874,7 +904,7 @@ data DynFlags = DynFlags {
 
   ldInputs              :: [Option],
 
-  includePaths          :: [String],
+  includePaths          :: IncludeSpecs,
   libraryPaths          :: [String],
   frameworkPaths        :: [String],    -- used on darwin only
   cmdlineFrameworks     :: [String],    -- ditto
@@ -1727,7 +1757,7 @@ defaultDynFlags mySettings myLlvmTargets =
         dumpPrefix              = Nothing,
         dumpPrefixForce         = Nothing,
         ldInputs                = [],
-        includePaths            = [],
+        includePaths            = IncludeSpecs [] [],
         libraryPaths            = [],
         frameworkPaths          = [],
         cmdlineFrameworks       = [],
@@ -2308,7 +2338,8 @@ setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce
 
 setObjectDir  f d = d { objectDir  = Just f}
 setHiDir      f d = d { hiDir      = Just f}
-setStubDir    f d = d { stubDir    = Just f, includePaths = f : includePaths d }
+setStubDir    f d = d { stubDir    = Just f
+                      , includePaths = addGlobalInclude (includePaths d) [f] }
   -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
   -- \#included from the .hc file when compiling via C (i.e. unregisterised
   -- builds).
@@ -5052,7 +5083,8 @@ addLibraryPath p =
   upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p})
 
 addIncludePath p =
-  upd (\s -> s{includePaths = includePaths s ++ splitPathList p})
+  upd (\s -> s{includePaths =
+                  addGlobalInclude (includePaths s) (splitPathList p)})
 
 addFrameworkPath p =
   upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p})
index 8f7e961..80beb6c 100644 (file)
@@ -34,6 +34,9 @@ Language
 Compiler
 ~~~~~~~~
 
+- GHC now no longer adds the current file's directory as a general include path
+  calling the C compiler. Instead we use :ghc-flag:`-iquote` to only add it as
+  an include path for `#include ""`. See :ghc-ticket:`14312`.
 
 Runtime system
 ~~~~~~~~~~~~~~
@@ -45,7 +48,7 @@ Runtime system
 
        - The GHC runtime linker now uses ``LIBRARY_PATH`` and the runtime loader now also
          searches ``LD_LIBRARY_PATH``.
-       
+
 Template Haskell
 ~~~~~~~~~~~~~~~~
 
index 06fc493..4804e39 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 06fc4934e96bd2e647496ec0082d6ef362328f64
+Subproject commit 4804e39144dc0ded9b38dbb3442b6016ac719a1a