[Git][ghc/ghc][wip/drop-touch] Drop dependence on `touch`

Ben Gamari (@bgamari) gitlab at gitlab.haskell.org
Tue Sep 19 21:31:54 UTC 2023



Ben Gamari pushed to branch wip/drop-touch at Glasgow Haskell Compiler / GHC


Commits:
648d172e by Ben Gamari at 2023-09-19T17:30:50-04:00
Drop dependence on `touch`

This drops GHC's dependence on the `touch` program, instead implementing
it within GHC. This eliminates an external dependency and means that we
have one fewer program to keep track of in the `configure` script

- - - - -


22 changed files:

- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Settings.hs
- compiler/GHC/Settings/IO.hs
- compiler/GHC/SysTools/Tasks.hs
- + compiler/GHC/Utils/Touch.hs
- compiler/ghc.cabal.in
- hadrian/bindist/Makefile
- hadrian/bindist/config.mk.in
- hadrian/cfg/system.config.in
- hadrian/src/Builder.hs
- hadrian/src/Hadrian/Builder.hs
- hadrian/src/Oracles/Setting.hs
- hadrian/src/Packages.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Rules/Program.hs
- hadrian/src/Settings/Default.hs
- m4/fp_settings.m4
- − utils/touchy/Makefile
- − utils/touchy/touchy.c
- − utils/touchy/touchy.cabal


Changes:

=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -257,6 +257,7 @@ import GHC.Utils.Outputable
 import GHC.Utils.Misc
 import GHC.Utils.Logger
 import GHC.Utils.TmpFs
+import GHC.Utils.Touch
 
 import qualified GHC.LanguageExtensions as LangExt
 
@@ -267,7 +268,6 @@ import qualified GHC.Data.Stream as Stream
 import GHC.Data.Stream (Stream)
 import GHC.Data.Maybe
 
-import qualified GHC.SysTools
 import GHC.SysTools (initSysTools)
 import GHC.SysTools.BaseDir (findTopDir)
 
@@ -1262,7 +1262,7 @@ hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do
           -- .hie files.
           let hie_file = ml_hie_file mod_location
           whenM (doesFileExist hie_file) $
-            GHC.SysTools.touch logger dflags "Touching hie file" hie_file
+            GHC.Utils.Touch.touch hie_file
     else
         -- See Note [Strictness in ModIface]
         forceModIface iface


=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -71,6 +71,7 @@ import System.IO
 import GHC.Linker.ExtraObj
 import GHC.Linker.Dynamic
 import GHC.Utils.Panic
+import GHC.Utils.Touch
 import GHC.Unit.Module.Env
 import GHC.Driver.Env.KnotVars
 import GHC.Driver.Config.Finder
@@ -362,14 +363,10 @@ runAsPhase with_cpp pipe_env hsc_env location input_fn = do
 
 -- | Run the JS Backend postHsc phase.
 runJsPhase :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath
-runJsPhase _pipe_env hsc_env _location input_fn = do
-  let dflags     = hsc_dflags   hsc_env
-  let logger     = hsc_logger   hsc_env
-
+runJsPhase _pipe_env _hsc_env _location input_fn = do
   -- The object file is already generated. We only touch it to ensure the
   -- timestamp is refreshed, see Note [JS Backend .o file procedure].
-  touchObjectFile logger dflags input_fn
-
+  touchObjectFile input_fn
   return input_fn
 
 -- | Deal with foreign JS files (embed them into .o files)
@@ -551,7 +548,7 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
 
                    -- In the case of hs-boot files, generate a dummy .o-boot
                    -- stamp file for the benefit of Make
-                   HsBootFile -> touchObjectFile logger dflags o_file
+                   HsBootFile -> touchObjectFile o_file
                    HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile"
 
                  -- MP: I wonder if there are any lurking bugs here because we
@@ -1140,10 +1137,10 @@ linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do
 
 
 
-touchObjectFile :: Logger -> DynFlags -> FilePath -> IO ()
-touchObjectFile logger dflags path = do
+touchObjectFile :: FilePath -> IO ()
+touchObjectFile path = do
   createDirectoryIfMissing True $ takeDirectory path
-  GHC.SysTools.touch logger dflags "Touching object file" path
+  GHC.Utils.Touch.touch path
 
 -- Note [-fPIC for assembler]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~


=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -102,7 +102,6 @@ module GHC.Driver.Session (
         sPgm_a,
         sPgm_l,
         sPgm_lm,
-        sPgm_T,
         sPgm_windres,
         sPgm_ar,
         sPgm_ranlib,
@@ -135,7 +134,7 @@ module GHC.Driver.Session (
         versionedAppDir, versionedFilePath,
         extraGccViaCFlags, globalPackageDatabasePath,
         pgm_L, pgm_P, pgm_F, pgm_c, pgm_cxx, pgm_cpp, pgm_a, pgm_l, pgm_lm,
-        pgm_T, pgm_windres, pgm_ar,
+        pgm_windres, pgm_ar,
         pgm_ranlib, pgm_lo, pgm_lc, pgm_i,
         opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i,
         opt_P_signature,
@@ -404,8 +403,6 @@ pgm_l                 :: DynFlags -> (String,[Option])
 pgm_l dflags = toolSettings_pgm_l $ toolSettings dflags
 pgm_lm                 :: DynFlags -> Maybe (String,[Option])
 pgm_lm dflags = toolSettings_pgm_lm $ toolSettings dflags
-pgm_T                 :: DynFlags -> String
-pgm_T dflags = toolSettings_pgm_T $ toolSettings dflags
 pgm_windres           :: DynFlags -> String
 pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags
 pgm_ar                :: DynFlags -> String


=====================================
compiler/GHC/Settings.hs
=====================================
@@ -33,7 +33,6 @@ module GHC.Settings
   , sPgm_a
   , sPgm_l
   , sPgm_lm
-  , sPgm_T
   , sPgm_windres
   , sPgm_ar
   , sPgm_otool
@@ -107,7 +106,6 @@ data ToolSettings = ToolSettings
     -- ^ N.B. On Windows we don't have a linker which supports object
     -- merging, hence the 'Maybe'. See Note [Object merging] in
     -- "GHC.Driver.Pipeline.Execute" for details.
-  , toolSettings_pgm_T       :: String
   , toolSettings_pgm_windres :: String
   , toolSettings_pgm_ar      :: String
   , toolSettings_pgm_otool   :: String
@@ -216,8 +214,6 @@ sPgm_l :: Settings -> (String, [Option])
 sPgm_l = toolSettings_pgm_l . sToolSettings
 sPgm_lm :: Settings -> Maybe (String, [Option])
 sPgm_lm = toolSettings_pgm_lm . sToolSettings
-sPgm_T :: Settings -> String
-sPgm_T = toolSettings_pgm_T . sToolSettings
 sPgm_windres :: Settings -> String
 sPgm_windres = toolSettings_pgm_windres . sToolSettings
 sPgm_ar :: Settings -> String


=====================================
compiler/GHC/Settings/IO.hs
=====================================
@@ -125,8 +125,6 @@ initSettings top_dir = do
   install_name_tool_path <- getToolSetting "install_name_tool command"
   ranlib_path <- getToolSetting "ranlib command"
 
-  touch_path <- getToolSetting "touch command"
-
   -- HACK, see setPgmP below. We keep 'words' here to remember to fix
   -- Config.hs one day.
 
@@ -186,7 +184,6 @@ initSettings top_dir = do
       , toolSettings_pgm_a   = (as_prog, as_args)
       , toolSettings_pgm_l   = (ld_prog, ld_args)
       , toolSettings_pgm_lm  = ld_r
-      , toolSettings_pgm_T   = touch_path
       , toolSettings_pgm_windres = windres_path
       , toolSettings_pgm_ar = ar_path
       , toolSettings_pgm_otool = otool_path


=====================================
compiler/GHC/SysTools/Tasks.hs
=====================================
@@ -372,6 +372,3 @@ runWindres logger dflags args = traceSystoolCommand logger "windres" $ do
   mb_env <- getGccEnv cc_args
   runSomethingFiltered logger id "Windres" windres (opts ++ args) Nothing mb_env
 
-touch :: Logger -> DynFlags -> String -> String -> IO ()
-touch logger dflags purpose arg = traceSystoolCommand logger "touch" $
-  runSomething logger purpose (pgm_T dflags) [FileOption "" arg]


=====================================
compiler/GHC/Utils/Touch.hs
=====================================
@@ -0,0 +1,34 @@
+{-# LANGUAGE CPP #-}
+
+module GHC.Utils.Touch (touch) where
+
+import GHC.Prelude
+
+#if defined(mingw32_HOST_OS)
+import System.Win32.File
+import System.Win32.Time
+#else
+import System.Posix.Files
+import System.Posix.IO
+#endif
+
+-- | Set the mtime of the given file to the current time.
+touch :: FilePath -> IO ()
+touch file = do
+#if defined(mingw32_HOST_OS)
+    hdl <- createFile file gENERIC_WRITE fILE_SHARE_NONE Nothing oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL Nothing
+    t <- getSystemTimeAsFileTime
+    setFileTime hdl Nothing Nothing (Just t)
+    closeHandle hdl
+#else
+#if MIN_VERSION_unix(2,8,0)
+  let oflags = defaultFileFlags { noctty = True, creat = Just 0o666 }
+  fd <- openFd file WriteOnly oflags
+#else
+  let oflags = defaultFileFlags { noctty = True }
+  fd <- openFd file WriteOnly (Just 0o666) oflags
+#endif
+  touchFd fd
+  closeFd fd
+#endif
+


=====================================
compiler/ghc.cabal.in
=====================================
@@ -915,6 +915,7 @@ Library
         GHC.Utils.Ppr
         GHC.Utils.Ppr.Colour
         GHC.Utils.TmpFs
+        GHC.Utils.Touch
         GHC.Utils.Trace
         GHC.Utils.Unique
         GHC.Utils.Word64


=====================================
hadrian/bindist/Makefile
=====================================
@@ -114,7 +114,6 @@ lib/settings : config.mk
 	@echo ',("ranlib command", "$(SettingsRanlibCommand)")' >> $@
 	@echo ',("otool command", "$(SettingsOtoolCommand)")' >> $@
 	@echo ',("install_name_tool command", "$(SettingsInstallNameToolCommand)")' >> $@
-	@echo ',("touch command", "$(SettingsTouchCommand)")' >> $@
 	@echo ',("windres command", "$(SettingsWindresCommand)")' >> $@
 	@echo ',("unlit command", "$$topdir/bin/$(CrossCompilePrefix)unlit")' >> $@
 	@echo ',("cross compiling", "$(CrossCompiling)")' >> $@


=====================================
hadrian/bindist/config.mk.in
=====================================
@@ -226,7 +226,6 @@ SettingsInstallNameToolCommand = @SettingsInstallNameToolCommand@
 SettingsRanlibCommand = @SettingsRanlibCommand@
 SettingsWindresCommand = @SettingsWindresCommand@
 SettingsLibtoolCommand = @SettingsLibtoolCommand@
-SettingsTouchCommand = @SettingsTouchCommand@
 SettingsLlcCommand = @SettingsLlcCommand@
 SettingsOptCommand = @SettingsOptCommand@
 SettingsUseDistroMINGW = @SettingsUseDistroMINGW@


=====================================
hadrian/cfg/system.config.in
=====================================
@@ -79,7 +79,6 @@ project-git-commit-id  = @ProjectGitCommitId@
 
 settings-otool-command = @SettingsOtoolCommand@
 settings-install_name_tool-command = @SettingsInstallNameToolCommand@
-settings-touch-command = @SettingsTouchCommand@
 settings-llc-command = @SettingsLlcCommand@
 settings-opt-command = @SettingsOptCommand@
 settings-use-distro-mingw = @SettingsUseDistroMINGW@


=====================================
hadrian/src/Builder.hs
=====================================
@@ -240,7 +240,6 @@ instance H.Builder Builder where
           pure []
         Ghc _ stage -> do
             root <- buildRoot
-            touchyPath <- programPath (vanillaContext (Stage0 InTreeLibs) touchy)
             unlitPath  <- builderPath Unlit
 
             -- GHC from the previous stage is used to build artifacts in the
@@ -249,7 +248,6 @@ instance H.Builder Builder where
 
             return $ [ unlitPath ]
                   ++ ghcdeps
-                  ++ [ touchyPath          | windowsHost ]
                   ++ [ root -/- mingwStamp | windowsHost ]
                      -- proxy for the entire mingw toolchain that
                      -- we have in inplace/mingw initially, and then at


=====================================
hadrian/src/Hadrian/Builder.hs
=====================================
@@ -49,8 +49,8 @@ class ShakeValue b => Builder b where
     -- capture the @stdout@ result and return it.
     askBuilderWith :: b -> BuildInfo -> Action String
 
-    -- | Runtime dependencies of a builder. For example, on Windows GHC requires
-    -- the utility @touchy.exe@ to be available on a specific path.
+    -- | Runtime dependencies of a builder. For example, GHC requires the
+    -- utility @unlit@ to be available on a specific path.
     runtimeDependencies :: b -> Action [FilePath]
     runtimeDependencies _ = return []
 


=====================================
hadrian/src/Oracles/Setting.hs
=====================================
@@ -84,7 +84,6 @@ data Setting = CursesIncludeDir
 data ToolchainSetting
     = ToolchainSetting_OtoolCommand
     | ToolchainSetting_InstallNameToolCommand
-    | ToolchainSetting_TouchCommand
     | ToolchainSetting_LlcCommand
     | ToolchainSetting_OptCommand
     | ToolchainSetting_DistroMinGW
@@ -133,7 +132,6 @@ settingsFileSetting :: ToolchainSetting -> Action String
 settingsFileSetting key = lookupSystemConfig $ case key of
     ToolchainSetting_OtoolCommand           -> "settings-otool-command"
     ToolchainSetting_InstallNameToolCommand -> "settings-install_name_tool-command"
-    ToolchainSetting_TouchCommand           -> "settings-touch-command"
     ToolchainSetting_LlcCommand             -> "settings-llc-command"
     ToolchainSetting_OptCommand             -> "settings-opt-command"
     ToolchainSetting_DistroMinGW            -> "settings-use-distro-mingw" -- ROMES:TODO: This option doesn't seem to be in ghc-toolchain yet. It corresponds to EnableDistroToolchain


=====================================
hadrian/src/Packages.hs
=====================================
@@ -9,7 +9,7 @@ module Packages (
     ghcToolchain, ghcToolchainBin, haddock, haskeline,
     hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy,
     libffi, mtl, parsec, pretty, primitive, process, remoteIserv, rts,
-    runGhc, semaphoreCompat, stm, templateHaskell, terminfo, text, time, timeout, touchy,
+    runGhc, semaphoreCompat, stm, templateHaskell, terminfo, text, time, timeout,
     transformers, unlit, unix, win32, xhtml,
     lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace,
     ghcPackages, isGhcPackage,
@@ -42,7 +42,7 @@ ghcPackages =
     , ghcToolchain, ghcToolchainBin, haddock, haskeline, hsc2hs
     , hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, libffi, mtl
     , parsec, pretty, process, rts, runGhc, stm, semaphoreCompat, templateHaskell
-    , terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml
+    , terminfo, text, time, transformers, unlit, unix, win32, xhtml
     , timeout
     , lintersCommon
     , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ]
@@ -59,7 +59,7 @@ array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, count
   ghcToolchain, ghcToolchainBin, haddock, haskeline, hsc2hs,
   hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy, remoteIserv, libffi, mtl,
   parsec, pretty, primitive, process, rts, runGhc, semaphoreCompat, stm, templateHaskell,
-  terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml,
+  terminfo, text, time, transformers, unlit, unix, win32, xhtml,
   timeout,
   lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace
     :: Package
@@ -126,7 +126,6 @@ terminfo            = lib  "terminfo"
 text                = lib  "text"
 time                = lib  "time"
 timeout             = util "timeout"         `setPath` "testsuite/timeout"
-touchy              = util "touchy"
 transformers        = lib  "transformers"
 unlit               = util "unlit"
 unix                = lib  "unix"
@@ -202,12 +201,12 @@ programName Context {..} = do
 -- | The 'FilePath' to a program executable in a given 'Context'.
 programPath :: Context -> Action FilePath
 programPath context at Context {..} = do
-    -- TODO: The @touchy@ utility lives in the @lib/bin@ directory instead of
-    -- @bin@, which is likely just a historical accident that should be fixed.
-    -- See: https://github.com/snowleopard/hadrian/issues/570
-    -- Likewise for @iserv@ and @unlit at .
+    -- TODO: The @iserv@ and @unlit@ utilities live in the @lib/bin@ directory
+    -- instead of @bin@, which is likely just a historical accident that should
+    -- be fixed. See:
+    -- https://github.com/snowleopard/hadrian/issues/570
     name <- programName context
-    path <- if package `elem` [iserv, touchy, unlit]
+    path <- if package `elem` [iserv, unlit]
               then stageLibPath stage <&> (-/- "bin")
               else stageBinPath stage
     return $ path -/- name <.> exe
@@ -220,7 +219,7 @@ timeoutPath = "testsuite/timeout/install-inplace/bin/timeout" <.> exe
 -- TODO: Can we extract this information from Cabal files?
 -- | Some program packages should not be linked with Haskell main function.
 nonHsMainPackage :: Package -> Bool
-nonHsMainPackage = (`elem` [hp2ps, iserv, touchy, unlit, ghciWrapper])
+nonHsMainPackage = (`elem` [hp2ps, iserv, unlit, ghciWrapper])
 
 -- TODO: Combine this with 'programName'.
 -- | Path to the @autogen@ directory generated by 'buildAutogenFiles'.


=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -452,7 +452,6 @@ generateSettings = do
         , ("ranlib command", queryTarget ranlibPath)
         , ("otool command", expr $ settingsFileSetting ToolchainSetting_OtoolCommand)
         , ("install_name_tool command", expr $ settingsFileSetting ToolchainSetting_InstallNameToolCommand)
-        , ("touch command", expr $ settingsFileSetting ToolchainSetting_TouchCommand)
         , ("windres command", queryTarget (maybe "/bin/false" prgPath . tgtWindres)) -- TODO: /bin/false is not available on many distributions by default, but we keep it as it were before the ghc-toolchain patch. Fix-me.
         , ("unlit command", ("$topdir/bin/" <>) <$> expr (programName (ctx { Context.package = unlit })))
         , ("cross compiling", expr $ yesNo <$> flag CrossCompiling)


=====================================
hadrian/src/Rules/Program.hs
=====================================
@@ -105,7 +105,7 @@ buildProgram bin ctx@(Context{..}) rs = do
     (True, s) | s > stage0InTree -> do
         srcDir <- buildRoot <&> (-/- (stageString stage0InTree -/- "bin"))
         copyFile (srcDir -/- takeFileName bin) bin
-    (False, s) | s > stage0InTree && (package `elem` [touchy, unlit]) -> do
+    (False, s) | s > stage0InTree && (package `elem` [unlit]) -> do
         srcDir <- stageLibPath stage0InTree <&> (-/- "bin")
         copyFile (srcDir -/- takeFileName bin) bin
     _ -> buildBinary rs bin ctx


=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -115,7 +115,6 @@ stage0Packages = do
              ]
           ++ [ terminfo | not windowsHost, not cross ]
           ++ [ timeout  | windowsHost                ]
-          ++ [ touchy   | windowsHost                ]
 
 -- | Packages built in 'Stage1' by default. You can change this in "UserSettings".
 stage1Packages :: Action [Package]
@@ -168,9 +167,8 @@ stage1Packages = do
         , ghcToolchainBin
         ]
       , when (winTarget && not cross)
-        [ touchy
-         -- See Note [Hadrian's ghci-wrapper package]
-        , ghciWrapper
+        [ -- See Note [Hadrian's ghci-wrapper package]
+          ghciWrapper
         ]
       ]
 


=====================================
m4/fp_settings.m4
=====================================
@@ -74,12 +74,6 @@ AC_DEFUN([FP_SETTINGS],
         SettingsWindresCommand="$WindresCmd"
     fi
 
-    if test "$HostOS" = "mingw32"; then
-        SettingsTouchCommand='$$topdir/bin/touchy.exe'
-    else
-        SettingsTouchCommand='touch'
-    fi
-
     if test "$EnableDistroToolchain" = "YES"; then
         # If the user specified --enable-distro-toolchain then we just use the
         # executable names, not paths.
@@ -109,7 +103,6 @@ AC_DEFUN([FP_SETTINGS],
         SUBST_TOOLDIR([SettingsArCommand])
         SUBST_TOOLDIR([SettingsRanlibCommand])
         SUBST_TOOLDIR([SettingsWindresCommand])
-        SettingsTouchCommand='$$topdir/bin/touchy.exe'
     fi
 
     # LLVM backend tools
@@ -153,7 +146,6 @@ AC_DEFUN([FP_SETTINGS],
     AC_SUBST(SettingsOtoolCommand)
     AC_SUBST(SettingsInstallNameToolCommand)
     AC_SUBST(SettingsWindresCommand)
-    AC_SUBST(SettingsTouchCommand)
     AC_SUBST(SettingsLlcCommand)
     AC_SUBST(SettingsOptCommand)
     AC_SUBST(SettingsUseDistroMINGW)


=====================================
utils/touchy/Makefile deleted
=====================================
@@ -1,37 +0,0 @@
-# -----------------------------------------------------------------------------
-#
-# (c) 2009 The University of Glasgow
-#
-# This file is part of the GHC build system.
-#
-# To understand how the build system works and how to modify it, see
-#      https://gitlab.haskell.org/ghc/ghc/wikis/building/architecture
-#      https://gitlab.haskell.org/ghc/ghc/wikis/building/modifying
-#
-# -----------------------------------------------------------------------------
-
-#
-# Substitute for 'touch' on win32 platforms (without an Unix toolset installed).
-#
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-C_SRCS=touchy.c
-C_PROG=touchy
-SRC_CC_OPTS += -O
-
-#
-# Install touchy in lib/.*
-#
-INSTALL_LIBEXECS += $(C_PROG)
-
-include $(TOP)/mk/target.mk
-
-# Get it over with!
-boot :: all
-
-binary-dist:
-	$(INSTALL_DIR)               $(BIN_DIST_DIR)/utils/touchy
-	$(INSTALL_DATA)    Makefile  $(BIN_DIST_DIR)/utils/touchy/
-	$(INSTALL_PROGRAM) $(C_PROG) $(BIN_DIST_DIR)/utils/touchy/
-


=====================================
utils/touchy/touchy.c deleted
=====================================
@@ -1,123 +0,0 @@
-/*
- * Simple 'touch' program for Windows
- *
- */
-#if !defined(_WIN32)
-#error "Win32-only, the platform you're using is supposed to have 'touch' already."
-#else
-#include <stdio.h>
-#include <sys/stat.h>
-#include <sys/types.h>
-#include <fcntl.h>
-#include <errno.h>
-#include <utime.h>
-#include <windows.h>
-
-/*
-touch is used by GHC both during building and during compilation of
-Haskell files. Unfortunately this means we need a 'touch' like program
-in the GHC bindist. Since touch is not standard on Windows and msys2
-doesn't include a mingw-w64 build of coreutils we need touchy for now.
-
-With Windows 7 in a virtual box VM on OS X, some very odd things happen
-with dates and time stamps when SSHing into cygwin. e.g. here the
-"Change" time is in the past:
-
-$ date; touch foo; stat foo
-Fri Dec  2 16:58:07 GMTST 2011
-  File: `foo'
-  Size: 0               Blocks: 0          IO Block: 65536  regular
-empty file
-Device: 540aba0bh/1409989131d   Inode: 562949953592977  Links: 1
-Access: (0644/-rw-r--r--)  Uid: ( 1000/     ian)   Gid: (  513/    None)
-Access: 2011-12-02 16:58:07.414457900 +0000
-Modify: 2011-12-02 16:58:07.414457900 +0000
-Change: 2011-12-02 16:58:03.495141800 +0000
- Birth: 2011-12-02 16:57:57.731469900 +0000
-
-And if we copy such a file, then the copy is older (as determined by the
-"Modify" time) than the original:
-
-$ date; touch foo; stat foo; cp foo bar; stat bar
-Fri Dec  2 16:59:10 GMTST 2011
-  File: `foo'
-  Size: 0               Blocks: 0          IO Block: 65536  regular
-empty file
-Device: 540aba0bh/1409989131d   Inode: 1407374883725128  Links: 1
-Access: (0644/-rw-r--r--)  Uid: ( 1000/     ian)   Gid: (  513/    None)
-Access: 2011-12-02 16:59:10.118457900 +0000
-Modify: 2011-12-02 16:59:10.118457900 +0000
-Change: 2011-12-02 16:59:06.189477700 +0000
- Birth: 2011-12-02 16:57:57.731469900 +0000
-  File: `bar'
-  Size: 0               Blocks: 0          IO Block: 65536  regular
-empty file
-Device: 540aba0bh/1409989131d   Inode: 281474976882512  Links: 1
-Access: (0644/-rw-r--r--)  Uid: ( 1000/     ian)   Gid: (  513/    None)
-Access: 2011-12-02 16:59:06.394555800 +0000
-Modify: 2011-12-02 16:59:06.394555800 +0000
-Change: 2011-12-02 16:59:06.395532400 +0000
- Birth: 2011-12-02 16:58:40.921899600 +0000
-
-This means that make thinks that things are out of date when it
-shouldn't, so reinvokes itself repeatedly until the MAKE_RESTARTS
-infinite-recursion test triggers.
-
-The touchy program, like most other programs, creates files with both
-Modify and Change in the past, which is still a little odd, but is
-consistent, so doesn't break make.
-
-We used to use _utime(argv[i],NULL)) to set the file modification times,
-but after a BST -> GMT change this started giving files a modification
-time an hour in the future:
-
-$ date; utils/touchy/dist/build/tmp/touchy testfile; stat testfile
-Tue, Oct 30, 2012 11:33:06 PM
-  File: `testfile'
-  Size: 0               Blocks: 0          IO Block: 65536  regular empty file
-Device: 540aba0bh/1409989131d   Inode: 9851624184986293  Links: 1
-Access: (0755/-rwxr-xr-x)  Uid: ( 1000/     ian)   Gid: (  513/    None)
-Access: 2012-10-31 00:33:06.000000000 +0000
-Modify: 2012-10-31 00:33:06.000000000 +0000
-Change: 2012-10-30 23:33:06.769118900 +0000
- Birth: 2012-10-30 23:33:06.769118900 +0000
-
-so now we use the Win32 functions GetSystemTimeAsFileTime and SetFileTime.
-*/
-
-int
-main(int argc, char** argv)
-{
-    int i;
-    FILETIME ft;
-    BOOL b;
-    HANDLE hFile;
-
-    if (argc == 1) {
-        fprintf(stderr, "Usage: %s <files>\n", argv[0]);
-        return 1;
-    }
-
-    for (i = 1; i < argc; i++) {
-        hFile = CreateFile(argv[i], GENERIC_WRITE, 0, NULL, OPEN_ALWAYS,
-                           FILE_ATTRIBUTE_NORMAL, NULL);
-        if (hFile == INVALID_HANDLE_VALUE) {
-            fprintf(stderr, "Unable to open %s\n", argv[i]);
-            exit(1);
-        }
-        GetSystemTimeAsFileTime(&ft);
-        b = SetFileTime(hFile, (LPFILETIME) NULL, (LPFILETIME) NULL, &ft);
-        if (b == 0) {
-            fprintf(stderr, "Unable to change mod. time for %s\n", argv[i]);
-            exit(1);
-        }
-        b = CloseHandle(hFile);
-        if (b == 0) {
-            fprintf(stderr, "Closing failed for %s\n", argv[i]);
-            exit(1);
-        }
-    }
-
-    return 0;
-}
-#endif


=====================================
utils/touchy/touchy.cabal deleted
=====================================
@@ -1,15 +0,0 @@
-cabal-version: 2.2
-Name: touchy
-Version: 0.1
-Copyright: XXX
-License: BSD-3-Clause
-Author: XXX
-Maintainer: XXX
-Synopsis: @touch@ for windows
-Description: XXX
-Category: Development
-build-type: Simple
-
-Executable touchy
-    Default-Language: Haskell2010
-    Main-Is: touchy.c



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/648d172e38163caf73836efbf43adc36fbfbf219

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/648d172e38163caf73836efbf43adc36fbfbf219
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230919/45abf4a9/attachment-0001.html>


More information about the ghc-commits mailing list