Add -remap-path-prefix: reproducible .bo/.ba output across build directories

src/comp/BinData.hs

@@ -9,7 +9,7 @@ module BinData ( Byte
                , getN, getB, getI -- , getBytesRead
                , Bin(..)
                , section
-               , encode, decode, decodeWithHash
+               , encode, encodeWith, decode, decodeWithHash
                ) where
 
 {- Routines for converting structures to/from byte strings.
@@ -1482,14 +1482,18 @@ buildHistogram bes = snd (foldl build (["<UNCLAIMED>"], M.empty) bes)
 -- matching (Left value) the first time it is encountered
 -- and (Right idx) each time afterward, updating the cache
 -- to track known values.
-share :: BinElem -> BinCache -> ([BinElem], BinCache)
-share (S s)   bc = share' s s bc
-share (I i)   bc = share' (id_key i) i bc
-share (P p)   bc = share' p p bc
-share (T t)   bc = share' (type_key t) t bc
-share (IT t)  bc = share' (itype_key t) t bc
--- share (ASL l) bc = share' l l bc
-share be      bc = ([be], bc)
+-- The Position transform (-remap-path-prefix) is applied before
+-- sharing, so the cache is keyed on the stored (remapped) value:
+-- positions that remap equal share a single payload, and the reader
+-- (which reconstructs sharing by occurrence) sees a canonical stream.
+share :: (Position -> Position) -> BinElem -> BinCache -> ([BinElem], BinCache)
+share _ (S s)   bc = share' s s bc
+share _ (I i)   bc = share' (id_key i) i bc
+share remapP (P p) bc = let p' = remapP p in share' p' p' bc
+share _ (T t)   bc = share' (type_key t) t bc
+share _ (IT t)  bc = share' (itype_key t) t bc
+-- share _ (ASL l) bc = share' l l bc
+share _ be      bc = ([be], bc)
 
 share' :: (Bin v, Shared k v) => k -> v -> BinCache -> ([BinElem], BinCache)
 share' k x bc =
@@ -1499,13 +1503,13 @@ share' k x bc =
                            addKey k x bc)
 
 
-compress :: [BinElem] -> [BinElem]
-compress bes = compress' (bes, unknownCache)
+compress :: (Position -> Position) -> [BinElem] -> [BinElem]
+compress remapP bes = compress' (bes, unknownCache)
   where compress' ((x@(B _):xs), cache) = x:(compress' (xs, cache))
         compress' ((x@(Start _):xs), cache) = x:(compress' (xs, cache))
         compress' ((x@(End):xs), cache) = x:(compress' (xs, cache))
         compress' ((x:xs), cache) =
-          let (bes, cache') = share x cache
+          let (bes, cache') = share remapP x cache
           in -- trace ((show x) ++ " -> " ++ (show bes)) $
              compress' (bes ++ xs, cache')
         compress' ([], _) = []
@@ -1514,18 +1518,24 @@ compress bes = compress' (bes, unknownCache)
 -- byte stream is generated lazily through the monad and preserves
 -- sharing.
 
-runOut :: Out () -> [Byte]
-runOut (Out xs _) = let bes   = compress $ toList xs
-                        bytes = concat [ bs | B bs <- bes ]
-                    in -- trace ("xs = " ++ (show xs)) $
-                       -- trace ("bytes = " ++ (show bytes)) $
-                       if trace_bindata
-                       then trace (showHist (buildHistogram bes)) $ bytes
-                       else bytes
+runOutWith :: (Position -> Position) -> Out () -> [Byte]
+runOutWith remapP (Out xs _) =
+    let bes   = compress remapP $ toList xs
+        bytes = concat [ bs | B bs <- bes ]
+    in -- trace ("xs = " ++ (show xs)) $
+       -- trace ("bytes = " ++ (show bytes)) $
+       if trace_bindata
+       then trace (showHist (buildHistogram bes)) $ bytes
+       else bytes
 
 -- Convenience function for encoding structures in the Bin typeclass
 encode :: (Bin a) => a -> [Byte]
-encode x = runOut (toBin x)
+encode = encodeWith id
+
+-- encode with a Position transform applied to stored positions
+-- (-remap-path-prefix; see share)
+encodeWith :: (Bin a) => (Position -> Position) -> a -> [Byte]
+encodeWith remapP x = runOutWith remapP (toBin x)
 
 runIn :: In a -> BS.ByteString -> Bool -> (a, Int, String)
 runIn (In f) bs do_hash =

src/comp/FileNameUtil.hs

@@ -10,6 +10,7 @@ module FileNameUtil where
 -- ==================================================
 
 import System.Directory
+import Data.List(isInfixOf)
 import Numeric(showInt)
 
 import Util(rTake)
@@ -202,6 +203,35 @@ getRelativeFilePathInternal path =
        then drop 3 rest
        else getRelativeFilePathInternal (drop 1 rest)
 
+-- Apply a path-prefix remapping (-remap-path-prefix) to a stored file
+-- path.  The longest matching FROM prefix wins, independent of the
+-- order the mappings were given.  The encoded /// pwd marker is
+-- decoded before matching, so a match also normalizes away the
+-- difference between relative and absolute invocation; the result is
+-- stored plain (marker-free).  If no prefix matches, the path is
+-- returned untouched, marker and all.
+remapPath :: [(String, String)] -> FilePath -> FilePath
+remapPath prefixes path = maybe path id (remapPathMaybe prefixes path)
+
+-- Nothing when no prefix matches, so callers can keep the original
+-- (already-interned) value without rebuilding it.  On duplicate FROMs
+-- of equal length, the lexicographically largest result wins --
+-- deterministic, though arbitrary; don't pass duplicate FROMs.
+remapPathMaybe :: [(String, String)] -> FilePath -> Maybe FilePath
+remapPathMaybe [] _ = Nothing
+remapPathMaybe prefixes path =
+    -- Only marker-encoded paths go through getFullFilePath: on a
+    -- marker-free path its recursion invents a trailing '/' on the
+    -- last component, corrupting stored file names (e.g. "a/Foo.bsv"
+    -- would become "a/Foo.bsv/").
+    let full = if "///" `isInfixOf` path then getFullFilePath path else path
+        matches = [ (length from, to ++ drop (length from) full)
+                  | (from, to) <- prefixes
+                  , from == take (length from) full ]
+    in  case matches of
+          [] -> Nothing
+          _  -> Just (snd (maximum matches))
+
 -- =====
 
 -- When we create a name with mkVName (as an example), we pass it vdir

src/comp/Flags.hs

@@ -1,5 +1,6 @@
 module Flags(
              Flags(..),
+             remapFlagsPaths,
              redSteps,
              ResourceFlag(..), SATFlag(..), MsgListFlag(..),
 
@@ -44,6 +45,11 @@ data Flags = Flags {
         doICheck :: Bool,
         dumpAll :: Maybe (Maybe FilePath), -- maybe dump to file or stdout
         dumps :: [(DumpFlag, Maybe FilePath)], -- dump to file or stdout
+        -- prefix remappings applied to file paths stored in .bo/.ba
+        -- files (source positions, the .ba module path fields, and the
+        -- path-valued fields of this record as stored in .ba), so that
+        -- outputs do not depend on the build machine's directory layout
+        remapPathPrefix :: [(String, String)],
         enablePoisonPills :: Bool,
         entry :: Maybe String,
         expandATSlimit :: Int,
@@ -326,3 +332,37 @@ dumpInfo :: Flags -> DumpFlag -> Maybe (Maybe FilePath)
 dumpInfo f d = lookup d (dumps f) <|> dumpAll f
 
 -- -------------------------
+
+-- Apply the -remap-path-prefix mappings to the path-valued fields of
+-- the record itself.  Used on the copy of Flags stored in .ba files
+-- (which is consumed only by bluetcl introspection), so that .ba
+-- bytes do not depend on the build machine's directory layout.  The
+-- remapping helper lives in FileNameUtil; it is passed in here to
+-- avoid an import cycle.
+remapFlagsPaths :: ([(String, String)] -> FilePath -> FilePath) -> Flags -> Flags
+remapFlagsPaths remap flags =
+    let ps = remapPathPrefix flags
+        r = remap ps
+        rM = fmap r
+        rL = map r
+    in  if null ps then flags else flags {
+            -- the stored flags describe the remapped world: no further
+            -- remapping applies (and the FROM prefixes are themselves
+            -- machine-specific, which is the very thing being scrubbed)
+            remapPathPrefix = [],
+            bdir = rM (bdir flags),
+            bluespecDir = r (bluespecDir flags),
+            cIncPath = rL (cIncPath flags),
+            cLibPath = rL (cLibPath flags),
+            cdir = rM (cdir flags),
+            fdir = rM (fdir flags),
+            ifcPathRaw = rL (ifcPathRaw flags),
+            ifcPath = rL (ifcPath flags),
+            infoDir = rM (infoDir flags),
+            oFile = r (oFile flags),
+            vdir = rM (vdir flags),
+            vPathRaw = rL (vPathRaw flags),
+            vPath = rL (vPath flags),
+            dumps = [ (d, rM mf) | (d, mf) <- dumps flags ],
+            dumpAll = fmap rM (dumpAll flags)
+        }

src/comp/FlagsDecode.hs

@@ -512,6 +512,7 @@ traceflags = [
 defaultFlags :: String -> Flags
 defaultFlags bluespecdir = Flags {
         aggImpConds = True,
+        remapPathPrefix = [],
         allowIncoherentMatches = False,
         backend = Nothing,
         bdir = Nothing,
@@ -1431,6 +1432,20 @@ externalFlags = [
          (Resource RFsimple,
           "reschedule on insufficient resources", Visible)),
 
+        ("remap-path-prefix",
+         (Arg "from=to"
+              (\f s -> case break (== '=') s of
+                         (from@(_:_), '=':to) ->
+                             Left (f { remapPathPrefix =
+                                           remapPathPrefix f ++ [(from, to)] })
+                         _ -> Right (cmdPosition,
+                                     EBadArgFlag "-remap-path-prefix" s
+                                         ["FROM=TO"]))
+              (Just (FRTListString (map (\(from, to) -> from ++ "=" ++ to)
+                                       . remapPathPrefix))),
+          "remap FROM path prefixes to TO in paths stored in generated" ++
+          " .bo and .ba files (for reproducible builds)", Visible)),
+
         ("remove-dollar",
          (Toggle (\f x -> f { removeVerilogDollar = x }) (showIfTrue removeVerilogDollar),
           "remove dollar signs from Verilog identifiers", Visible)),
@@ -1901,6 +1916,7 @@ showFlagsRaw flags =
           ("redStepsMaxIntervals", show (redStepsMaxIntervals flags)),
           ("redStepsWarnInterval", show (redStepsWarnInterval flags)),
           ("relaxMethodEarliness", show (relaxMethodEarliness flags)),
+          ("remapPathPrefix", show (remapPathPrefix flags)),
           ("removeCReg", show (removeCReg flags)),
           ("removeCross", show (removeCross flags)),
           ("removeEmptyRules", show (removeEmptyRules flags)),