{-# LANGUAGE
             ScopedTypeVariables,
             TupleSections,
             OverloadedStrings
  #-}

{-
  The compactor does link-time optimization. It is much simpler
  than the Optimizer, no fancy dataflow analysis here.

  Optimizations:
  - rewrite all variables starting with h$$ to shorter names,
       these are internal names
  - write all function metadata compactly
 -}

module Gen2.Compactor where

import           DynFlags
import           Util
import           Panic


import           Control.Applicative
import           Control.Lens hiding ((#))
import           Control.Monad.State.Strict
import Prelude

import           Data.Array
import qualified Data.Binary.Get as DB
import qualified Data.Binary.Put as DB
import qualified Data.Bits as Bits
import           Data.Bits (shiftL, shiftR)
import qualified Data.ByteString.Lazy as BL
import           Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Builder as BB
import           Data.Char (chr)
import           Data.Function (on)
import qualified Data.Graph as G
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import qualified Data.Map.Strict as M
import           Data.Map (Map)
import           Data.Int
import           Data.List
import           Data.List.Split
import           Data.Maybe
import qualified Data.Set as S
import           Data.Set (Set)
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as TE

import           Compiler.JMacro
import           Compiler.JMacro.Combinators
import           Compiler.Settings

import           Gen2.Base
import           Gen2.ClosureInfo
import           Gen2.Utils (buildingProf, buildingDebug)
import           Gen2.Printer             (pretty)
import qualified Gen2.Utils as U
import           Text.PrettyPrint.Leijen.Text (renderPretty, displayT)
import qualified Crypto.Hash.SHA256 as SHA256

-- import qualified Debug.Trace

type LinkedUnit = (JStat, [ClosureInfo], [StaticInfo])

-- | collect global objects (data / CAFs). rename them and add them to the table
collectGlobals :: [StaticInfo]
               -> State CompactorState ()
collectGlobals = mapM_ (\(StaticInfo i _ _) -> renameObj i)

debugShowStat :: (JStat, [ClosureInfo], [StaticInfo]) -> String
debugShowStat (_s, cis, sis) =
  "closures:\n" ++
  unlines (map show cis) ++
  "\nstatics:" ++
  unlines (map show sis) ++
  "\n\n"

{- create a single string initializer for all StaticUnboxedString references
   in the code, and rewrite all references to point to it

   if incremental linking is used, each increment gets its own packed string
   blob. if a string value already exists in an earlier blob it is not added
   again
 -}
packStrings :: HasDebugCallStack
            => GhcjsSettings
            -> DynFlags
            -> CompactorState
            -> [LinkedUnit]
            -> (CompactorState, [LinkedUnit])
packStrings _settings _dflags cstate code =
  let allStatics :: [StaticInfo]
      allStatics = concatMap (\(_,_,x) -> x) code

      origStringTable :: StringTable
      origStringTable = cstate ^. stringTable

      allStrings :: Set ByteString
      allStrings = S.fromList $
                   filter (not . isExisting)
                          (mapMaybe (staticString . siVal) allStatics)
        where
          isExisting bs = isJust (HM.lookup bs $ stOffsets origStringTable)

      staticString :: StaticVal -> Maybe ByteString
      staticString (StaticUnboxed (StaticUnboxedString bs)) = Just bs
      staticString (StaticUnboxed (StaticUnboxedStringOffset bs)) = Just bs
      staticString _ = Nothing

      allStringsList :: [ByteString]
      allStringsList = S.toList allStrings

      -- we may see two kinds of null characters
      --   - string separator, packed as \0
      --   - within a string, packed as \cz\0
      -- we transform the strings to
      transformPackedLiteral :: Text -> Text
      transformPackedLiteral = T.concatMap f
        where
          f :: Char -> Text
          f '\0'  = "\^Z\0"
          f '\^Z' = "\^Z\^Z"
          f x     = T.singleton x

      allStringsPacked :: Text
      allStringsPacked = T.intercalate "\0" $
        map (\str -> maybe (packBase64 str)
                     transformPackedLiteral
                     (U.decodeModifiedUTF8 str))
            allStringsList

      packBase64 :: ByteString -> Text
      packBase64 bs
        | BS.null bs = mempty
        | otherwise =
          let (h,t) = BS.splitAt 128 bs
              esc   = T.singleton '\^Z' <>
                      T.singleton (chr . fromIntegral $ BS.length h + 0x1f)
              b64   = esc <> fromJust (U.decodeModifiedUTF8 (B64.encode h))
          in  maybe b64 transformPackedLiteral (U.decodeModifiedUTF8 h) <>
              packBase64 t

      allStringsWithOffset :: [(ByteString, Int)]
      allStringsWithOffset = snd $
        mapAccumL (\o b -> let o' = o + fromIntegral (BS.length b) + 1
                           in  o' `seq` (o', (b, o)))
                  0
                  allStringsList

      -- the offset of each of the strings in the big blob
      offsetIndex :: HashMap ByteString Int
      offsetIndex = HM.fromList allStringsWithOffset

      stringSymbol :: Ident
      stringSymbol = head $ cstate ^. identSupply

      stringSymbolT :: Text
      stringSymbolT = let (TxtI t) = stringSymbol in t

      stringSymbolIdx :: Int
      stringSymbolIdx = snd (bounds $ stTableIdents origStringTable) + 1

      -- append the new string symbol
      newTableIdents :: Array Int Text
      newTableIdents =
        listArray (0, stringSymbolIdx)
                  (elems (stTableIdents origStringTable) ++ [stringSymbolT])

      newOffsetsMap :: HashMap ByteString (Int, Int)
      newOffsetsMap = HM.union (stOffsets origStringTable)
                               (fmap (stringSymbolIdx,) offsetIndex)

      newIdentsMap :: HashMap Text (Either Int Int)
      newIdentsMap =
        let f (StaticInfo s (StaticUnboxed (StaticUnboxedString bs)) _)
              = Just (s, Left . fst $ newOffsetsMap HM.! bs)
            f (StaticInfo s (StaticUnboxed (StaticUnboxedStringOffset bs)) _)
              = Just (s, Right . snd $ newOffsetsMap HM.! bs)
            f _ = Nothing
        in HM.union (stIdents origStringTable)
                    (HM.fromList $ mapMaybe f allStatics)

      newStringTable :: StringTable
      newStringTable = StringTable newTableIdents newOffsetsMap newIdentsMap

      newOffsetsInverted :: HashMap (Int, Int) ByteString
      newOffsetsInverted = HM.fromList .
                           map (\(x,y) -> (y,x)) .
                           HM.toList $
                           newOffsetsMap

      replaceSymbol :: Text -> Maybe JVal
      replaceSymbol t =
        let f (Left i)  = JVar (TxtI $ newTableIdents ! i)
            f (Right o) = JInt (fromIntegral o)
        in  fmap f (HM.lookup t newIdentsMap)

      cstate0 :: CompactorState
      cstate0 = cstate & identSupply %~ tail
                       & stringTable .~ newStringTable

      initStr :: JStat
      initStr =
        DeclStat stringSymbol <>
        AssignStat (ValExpr $ JVar stringSymbol)
          (ApplExpr (ApplExpr (ValExpr $ JVar (TxtI "h$pstr"))
                              [ValExpr (JStr allStringsPacked)])
                    [])

      rewriteValsE :: JExpr -> JExpr
      rewriteValsE (ApplExpr e xs)
        | Just t <- appMatchStringLit e xs = ValExpr (JStr t)
      rewriteValsE (ValExpr v) = ValExpr (rewriteVals v)
      rewriteValsE e = e & exprsE %~ rewriteValsE

      rewriteVals :: JVal -> JVal
      rewriteVals (JVar (TxtI t))
        | Just v <- replaceSymbol t = v
      rewriteVals (JList es) = JList (map rewriteValsE es)
      rewriteVals (JHash m) = JHash (fmap rewriteValsE m)
      rewriteVals (JFunc args body) = JFunc args (body & exprsS %~ rewriteValsE)
      rewriteVals v = v

      rewriteStat :: JStat -> JStat
      rewriteStat st = st & exprsS %~ rewriteValsE

      appMatchStringLit :: JExpr -> [JExpr] -> Maybe Text
      appMatchStringLit (ValExpr (JVar (TxtI "h$decodeUtf8z")))
                        [ValExpr (JVar (TxtI x)), ValExpr (JVar (TxtI y))]
       | Just (Left i)  <- HM.lookup x newIdentsMap
       , Just (Right j) <- HM.lookup y newIdentsMap
       , Just bs        <- HM.lookup (i,j) newOffsetsInverted =
         U.decodeModifiedUTF8 bs
      appMatchStringLit _ _ = Nothing

      rewriteStatic :: StaticInfo -> Maybe StaticInfo
      rewriteStatic (StaticInfo _i
                                (StaticUnboxed StaticUnboxedString{})
                                _cc) =
        Nothing
      rewriteStatic (StaticInfo _i
                                (StaticUnboxed StaticUnboxedStringOffset {})
                                _cc) =
        Nothing
      rewriteStatic si = Just (si & staticInfoArgs %~ rewriteStaticArg)

      rewriteStaticArg :: StaticArg -> StaticArg
      rewriteStaticArg a@(StaticObjArg t) =
        case HM.lookup t newIdentsMap of
          Just (Right v)       -> StaticLitArg (IntLit $ fromIntegral v)
          Just (Left idx)      -> StaticObjArg (newTableIdents ! idx)
          _                    -> a
      rewriteStaticArg (StaticConArg v es)
        = StaticConArg v (map rewriteStaticArg es)
      rewriteStaticArg x = x

      initStatic :: LinkedUnit
      initStatic =
        let (TxtI ss) = stringSymbol
        in  (initStr, [], [StaticInfo ss (StaticThunk Nothing) Nothing])

      rewriteBlock :: LinkedUnit -> LinkedUnit
      rewriteBlock (stat, ci, si)
        = (rewriteStat stat, ci, mapMaybe rewriteStatic si)

    in (cstate0, initStatic : map rewriteBlock code)

renameInternals :: HasDebugCallStack
                => GhcjsSettings
                -> DynFlags
                -> CompactorState
                -> [Text]
                -> [LinkedUnit]
                -> (CompactorState, [JStat], JStat)
renameInternals settings dflags cs0 rtsDeps stats0a = (cs, stats, meta)
  where
    (stbs, stats0) = (if gsDedupe settings
                      then dedupeBodies rtsDeps . dedupe rtsDeps
                      else (mempty,)) stats0a
    ((stats, meta), cs) = runState renamed cs0
    renamed :: State CompactorState ([JStat], JStat)
    renamed
      | buildingDebug dflags || buildingProf dflags = do
        cs <- get
        let renamedStats = map (\(s,_,_) -> s & identsS %~ lookupRenamed cs)
                               stats0
            statics      = map (renameStaticInfo cs)  $
                               concatMap (\(_,_,x) -> x) stats0
            infos        = map (renameClosureInfo cs) $
                               concatMap (\(_,x,_) -> x) stats0
            -- render metadata as individual statements
            meta = mconcat (map staticDeclStat statics) <>
                   (stbs & identsS %~ lookupRenamed cs) <>
                   mconcat (map (staticInitStat $ buildingProf dflags) statics) <>
                   mconcat (map (closureInfoStat True) infos)
        return (renamedStats, meta)
      | otherwise = do
        -- collect all global objects and entries, add them to the renaming table
        mapM_ (\(_, cis, sis) -> do
               mapM_ (renameEntry . TxtI . ciVar) cis
               mapM_ (renameObj . siVar) sis
               mapM_ collectLabels sis) stats0

        -- sort our entries, store the results
        -- propagate all renamings throughtout the code
        cs <- get
        let -- Safari on iOS 10 (64 bit only?) crashes on very long arrays
            safariCrashWorkaround :: [Ident] -> JExpr
            safariCrashWorkaround xs =
              case chunksOf 10000 xs of
                (y:ys) | not (null ys)
                  -> ApplExpr (SelExpr (toJExpr y) (TxtI "concat"))
                              (map toJExpr ys)
                _ -> toJExpr xs
        let renamedStats = map (\(s,_,_) -> s & identsS %~ lookupRenamed cs)
                               stats0
            sortedInfo   = concatMap (\(_,xs,_) -> map (renameClosureInfo cs)
                                                       xs)
                                     stats0
            entryArr     = safariCrashWorkaround $
                           map (TxtI . fst) .
                           sortBy (compare `on` snd) .
                           HM.toList $
                           cs ^. entries
            lblArr       = map (TxtI . fst) .
                           sortBy (compare `on` snd) .
                           HM.toList $
                           cs ^. labels
            ss           = concatMap (\(_,_,xs) -> map (renameStaticInfo cs) xs)
                                     stats0
            infoBlock    = encodeStr (concatMap (encodeInfo cs) sortedInfo)
            staticBlock  = encodeStr (concatMap (encodeStatic cs) ss)
            stbs'        = stbs & identsS %~ lookupRenamed cs
            staticDecls  = mconcat (map staticDeclStat ss) <> stbs'
            meta = staticDecls #
                   appS "h$scheduleInit" [ entryArr
                                         , var "h$staticDelayed"
                                         , e lblArr
                                         , e infoBlock
                                         , e staticBlock
                                         ]
                   -- error "scheduleInit" 
                   {-
                   [j| h$scheduleInit( `entryArr`
                                     , h$staticDelayed
                                     , `lblArr`
                                     , `infoBlock`
                                     , `staticBlock`);
                       h$staticDelayed = [];
                     |] -}
        return (renamedStats, meta)


-- | rename a heap object, which means adding it to the
--  static init table in addition to the renamer
renameObj :: Text
          -> State CompactorState Text
renameObj xs = do
  (TxtI xs') <- renameVar (TxtI xs)
  addItem statics statics numStatics numStatics parentStatics xs'
  return xs'

renameEntry :: Ident
            -> State CompactorState Ident
renameEntry i = do
  i'@(TxtI i'') <- renameVar i
  addItem entries entries numEntries numEntries parentEntries i''
  return i'

addItem :: HasDebugCallStack
        => Getting (HashMap Text Int) CompactorState (HashMap Text Int)
        -> Setting (->)
                   CompactorState
                   CompactorState
                   (HashMap Text Int)
                   (HashMap Text Int)
        -> Getting Int CompactorState Int
        -> ASetter' CompactorState Int
        -> Getting (HashMap Text Int) CompactorState (HashMap Text Int)
        -> Text
        -> State CompactorState ()
addItem items items' numItems numItems' parentItems i = do
  s <- use items
  case HM.lookup i s of
    Just _ -> return ()
    Nothing -> do
      sp <- use parentItems
      case HM.lookup i sp of
        Just _  -> return ()
        Nothing -> do
          ni <- use numItems
          items' %= HM.insert i ni
          numItems' += 1

collectLabels :: StaticInfo -> State CompactorState ()
collectLabels si = mapM_ (addItem labels labels numLabels numLabels parentLabels)
                         (labelsV . siVal $ si)
  where
    labelsV (StaticData _ args) = concatMap labelsA args
    labelsV (StaticList args _) = concatMap labelsA args
    labelsV _                   = []
    labelsA (StaticLitArg l) = labelsL l
    labelsA _                = []
    labelsL (LabelLit _ lbl) = [lbl]
    labelsL _                = []

lookupRenamed :: CompactorState -> Ident -> Ident
lookupRenamed cs i@(TxtI t) =
  case HM.lookup t (cs ^. nameMap) of
    Nothing -> i
    Just i' -> i'

renameVar :: Ident                      -- ^ text identifier to rename
          -> State CompactorState Ident -- ^ the updated renamer state and the new ident
renameVar i@(TxtI t)
  | "h$$" `T.isPrefixOf` t = do
      m <- use nameMap
      case HM.lookup t m of
        Just r  -> return r
        Nothing -> do
          y <- newIdent
          nameMap %= HM.insert t y
          return y
  | otherwise = return i

newIdent :: State CompactorState Ident
newIdent = do
  yys <- use identSupply
  case yys of
    (y:ys) -> do
      identSupply .= ys
      return y
    _ -> error "newIdent: empty list"

-- | rename a compactor info entry according to the compactor state (no new renamings are added)
renameClosureInfo :: CompactorState
                  -> ClosureInfo
                  -> ClosureInfo
renameClosureInfo cs (ClosureInfo v rs n l t s)  =
  (ClosureInfo (renameV v) rs n l t (f s))
    where
      renameV t = maybe t (\(TxtI t') -> t') (HM.lookup t m)
      m                   = cs ^. nameMap
      f (CIStaticRefs rs) = CIStaticRefs (map renameV rs)

-- | rename a static info entry according to the compactor state (no new renamings are added)
renameStaticInfo :: CompactorState
                 -> StaticInfo
                 -> StaticInfo
renameStaticInfo cs si = si & staticIdents %~ renameIdent
  where
    renameIdent t = maybe t (\(TxtI t') -> t') (HM.lookup t $ cs ^. nameMap)

staticIdents :: Traversal' StaticInfo Text
staticIdents f (StaticInfo i v cc) =
  StaticInfo <$> f i <*> staticIdentsV f v <*> pure cc

staticIdentsV :: Traversal' StaticVal Text
staticIdentsV f (StaticFun i args) =
  StaticFun <$> f i <*> traverse (staticIdentsA f) args
staticIdentsV f (StaticThunk (Just (i, args))) =
  StaticThunk . Just <$> liftA2 (,) (f i) (traverse (staticIdentsA f) args)
staticIdentsV f (StaticData con args) =
  StaticData <$> f con <*> traverse (staticIdentsA f) args
staticIdentsV f (StaticList xs t) =
  StaticList <$> traverse (staticIdentsA f) xs <*> traverse f t
staticIdentsV _ x =
  pure x

staticIdentsA :: Traversal' StaticArg Text
staticIdentsA f (StaticObjArg t) = StaticObjArg <$> f t
staticIdentsA _ x                = pure x


{-
   simple encoding of naturals using only printable low char points,
   rely on gzip to compress repeating sequences,
   most significant bits first
      1 byte: ascii code 32-123  (0-89), \ and " unused
      2 byte: 124 a b            (90-8189)
      3 byte: 125 a b c          (8190-737189)
-}
encodeStr :: HasDebugCallStack => [Int] -> String
encodeStr = concatMap encodeChr
  where
    c :: HasDebugCallStack => Int -> Char
    c i | i > 90 || i < 0 = error ("encodeStr: c " ++ show i)
        | i >= 59   = chr (34+i)
        | i >= 2    = chr (33+i)
        | otherwise = chr (32+i)
    encodeChr :: HasDebugCallStack => Int -> String
    encodeChr i
      | i < 0       = panic "encodeStr: negative"
      | i <= 89     = [c i]
      | i <= 8189   = let (c1, c2)  = (i - 90) `divMod` 90 in [chr 124, c c1, c c2]
      | i <= 737189 = let (c2a, c3) = (i - 8190) `divMod` 90
                          (c1, c2)  = c2a `divMod` 90
                      in [chr 125, c c1, c c2, c c3]
      | otherwise = panic "encodeStr: overflow"

entryIdx :: HasDebugCallStack
         => String
         -> CompactorState
         -> Text
         -> Int
entryIdx msg cs i = fromMaybe lookupParent (HM.lookup i' (cs ^. entries))
  where
    (TxtI i')    = lookupRenamed cs (TxtI i)
    lookupParent = maybe err
                         (+ cs ^. numEntries)
                         (HM.lookup i' (cs ^. parentEntries))
    err = panic (msg ++ ": invalid entry: " ++ T.unpack i')

objectIdx :: HasDebugCallStack
          => String
          -> CompactorState
          -> Text
          -> Int
objectIdx msg cs i = fromMaybe lookupParent (HM.lookup i' (cs ^. statics))
  where
    (TxtI i')    = lookupRenamed cs (TxtI i)
    lookupParent = maybe err
                         (+ cs ^. numStatics)
                         (HM.lookup i' (cs ^. parentStatics))
    err          = panic (msg ++ ": invalid static: " ++ T.unpack i')

labelIdx :: HasDebugCallStack
         => String
         -> CompactorState
         -> Text
         -> Int
labelIdx msg cs l = fromMaybe lookupParent (HM.lookup l (cs ^. labels))
  where
    lookupParent = maybe err
                         (+ cs ^. numLabels)
                         (HM.lookup l (cs ^. parentLabels))
    err          = panic (msg ++ ": invalid label: " ++ T.unpack l)

encodeInfo :: HasDebugCallStack
           => CompactorState
           -> ClosureInfo  -- ^ information to encode
           -> [Int]
encodeInfo cs (ClosureInfo _var regs name layout typ static)
  | CIThunk              <- typ = [0] ++ ls
  | (CIFun _arity regs0) <- typ, regs0 /= argSize regs
     = panic ("encodeInfo: inconsistent register metadata for " ++ T.unpack name)
  | (CIFun arity _regs0) <- typ = [1, arity, encodeRegs regs] ++ ls
  | (CICon tag)          <- typ = [2, tag] ++ ls
  | CIStackFrame         <- typ = [3, encodeRegs regs] ++ ls
-- (CIPap ar)         <- typ = [4, ar] ++ ls  -- these should only appear during runtime
  | otherwise                  = panic $
      "encodeInfo, unexpected closure type: " ++ show typ
  where
    ls         = encodeLayout layout ++ encodeSrt static
    encodeLayout CILayoutVariable      = [0]
    encodeLayout (CILayoutUnknown s)   = [s+1]
    encodeLayout (CILayoutFixed s _vs) = [s+1]
    encodeSrt (CIStaticRefs rs) = length rs : map (objectIdx "encodeInfo" cs) rs
    encodeRegs CIRegsUnknown = 0
    encodeRegs (CIRegs skip regTypes) = let nregs = sum (map varSize regTypes)
                                        in  encodeRegsTag skip nregs
    encodeRegsTag skip nregs
      | skip < 0 || skip > 1 = panic "encodeRegsTag: unexpected skip"
      | otherwise            = 1 + (nregs `shiftL` 1) + skip
    argSize (CIRegs skip regTypes) = sum (map varSize regTypes) - 1 + skip
    argSize _ = 0

encodeStatic :: HasDebugCallStack
             => CompactorState
             -> StaticInfo
             -> [Int]
encodeStatic cs si =
  U.trace' ("encodeStatic: " ++ show si)
           (encodeStatic0 cs si)

encodeStatic0 :: HasDebugCallStack
             => CompactorState
             -> StaticInfo
             -> [Int]
encodeStatic0 cs (StaticInfo _to sv _)
    | StaticFun f args <- sv =
      [1, entry f, length args] ++ concatMap encodeArg args
    | StaticThunk (Just (t, args)) <- sv =
      [2, entry t, length args] ++ concatMap encodeArg args
    | StaticThunk Nothing <- sv =
      [0]
    | StaticUnboxed (StaticUnboxedBool b) <- sv =
      [3 + fromEnum b]
    | StaticUnboxed (StaticUnboxedInt _i) <- sv =
      [5] -- ++ encodeInt i
    | StaticUnboxed (StaticUnboxedDouble _d) <- sv =
      [6] -- ++ encodeDouble d
    | (StaticUnboxed _) <- sv = [] -- unboxed strings have their own table
--    | StaticString t <- sv         = [7, T.length t] ++ map encodeChar (T.unpack t)
--    | StaticBin bs <- sv           = [8, BS.length bs] ++ map fromIntegral (BS.unpack bs)
    | StaticList [] Nothing <- sv =
      [8]
    | StaticList args t <- sv =
      [9, length args] ++
      maybe [0] (\t' -> [1, obj t']) t ++
      concatMap encodeArg (reverse args)
    | StaticData con args <- sv =
      (if length args <= 6
        then [11+length args]
        else [10,length args]) ++
      [entry con] ++
      concatMap encodeArg args
  where
    obj   = objectIdx "encodeStatic" cs
    entry = entryIdx  "encodeStatic" cs
    lbl   = labelIdx  "encodeStatic" cs
    -- | an argument is either a reference to a heap object or a primitive value
    encodeArg (StaticLitArg (BoolLit b)) =
      [0 + fromEnum b]
    encodeArg (StaticLitArg (IntLit 0)) =
      [2]
    encodeArg (StaticLitArg (IntLit 1)) =
      [3]
    encodeArg (StaticLitArg (IntLit i)) =
      [4] ++ encodeInt i
    encodeArg (StaticLitArg NullLit) =
      [5]
    encodeArg (StaticLitArg (DoubleLit d)) =
      [6] ++ encodeDouble d
    encodeArg (StaticLitArg (StringLit s)) =
      [7] ++ encodeString s
    encodeArg (StaticLitArg (BinLit b)) =
      [8] ++ encodeBinary b
    encodeArg (StaticLitArg (LabelLit b l)) =
      [9, fromEnum b, lbl l]
    encodeArg (StaticConArg con args) =
      [10, entry con, length args] ++ concatMap encodeArg args
    encodeArg (StaticObjArg t) =
      [11 + obj t]
    -- encodeArg x                             = panic ("encodeArg: unexpected: " ++ show x)
    -- encodeChar = ord -- fixme make characters more readable

encodeString :: Text -> [Int]
encodeString xs = encodeBinary (TE.encodeUtf8 xs)

-- ByteString is prefixed with length, then blocks of 4 numbers encoding 3 bytes
encodeBinary :: BS.ByteString -> [Int]
encodeBinary bs = BS.length bs : go bs
  where
    go b | BS.null b = []
         | l == 1    = let b0 = b `BS.index` 0
                       in  map fromIntegral [ b0 `shiftR` 2, (b0 Bits..&. 3) `shiftL` 4 ]
         | l == 2    = let b0 = b `BS.index` 0
                           b1 = b `BS.index` 1
                       in  map fromIntegral [ b0 `shiftR` 2
                                            , ((b0 Bits..&. 3) `shiftL` 4) Bits..|. (b1 `shiftR` 4)
                                            , (b1 Bits..&. 15) `shiftL` 2
                                            ]
         | otherwise = let b0 = b `BS.index` 0
                           b1 = b `BS.index` 1
                           b2 = b `BS.index` 2
                       in  map fromIntegral [ b0 `shiftR` 2
                                            , ((b0 Bits..&. 3)  `shiftL` 4) Bits..|. (b1 `shiftR` 4)
                                            , ((b1 Bits..&. 15) `shiftL` 2) Bits..|. (b2 `shiftR` 6)
                                            , b2 Bits..&. 63
                                            ] ++ go (BS.drop 3 b)
      where l = BS.length b

encodeInt :: Integer -> [Int]
encodeInt i
  | i >= -10 && i < encodeMax - 11 = [fromIntegral i + 12]
  | i > 2^(31::Int)-1 || i < -2^(31::Int)
    = panic "encodeInt: integer outside 32 bit range"
  | otherwise = let i' :: Int32 = fromIntegral i
                in [ 0
                   , fromIntegral ((i' `shiftR` 16) Bits..&. 0xffff)
                   , fromIntegral (i' Bits..&. 0xffff)
                   ]

-- encode a possibly 53 bit int
encodeSignificand :: Integer -> [Int]
encodeSignificand i
  | i >= -10 && i < encodeMax - 11      = [fromIntegral i + 12]
  | i > 2^(53::Int) || i < -2^(53::Int)
    = panic ("encodeInt: integer outside 53 bit range: " ++ show i)
  | otherwise = let i' = abs i
                in  [if i < 0 then 0 else 1] ++
                    map (\r -> fromIntegral ((i' `shiftR` r) Bits..&. 0xffff))
                        [48,32,16,0]

encodeDouble :: SaneDouble -> [Int]
encodeDouble (SaneDouble d)
  | isNegativeZero d      = [0]
  | d == 0                = [1]
  | isInfinite d && d > 0 = [2]
  | isInfinite d          = [3]
  | isNaN d               = [4]
  | abs exponent <= 30
    = [6 + fromIntegral exponent + 30] ++ encodeSignificand significand
  | otherwise
    = [5] ++ encodeInt (fromIntegral exponent) ++ encodeSignificand significand
    where
      (significand, exponent) = decodeFloat d

encodeMax :: Integer
encodeMax = 737189

{- |
  The Base data structure contains the information we need
  to do incremental linking against a base bundle.

  base file format:
  GHCJSBASE
  [renamer state]
  [linkedPackages]
  [packages]
  [modules]
  [symbols]
 -}

renderBase :: Base                                   -- ^ base metadata
           -> BL.ByteString                          -- ^ rendered result
renderBase = DB.runPut . putBase

loadBase :: FilePath -> IO Base
loadBase file = DB.runGet (getBase file) <$> BL.readFile file

----------------------------

{-# INLINE identsS #-}
identsS :: Traversal' JStat Ident
identsS f (DeclStat i)         = DeclStat       <$> f i
identsS f (ReturnStat e)       = ReturnStat     <$> identsE f e
identsS f (IfStat e s1 s2)     = IfStat         <$> identsE f e <*> identsS f s1 <*> identsS f s2
identsS f (WhileStat b e s)    = WhileStat b    <$> identsE f e <*> identsS f s
identsS f (ForInStat b i e s)  = ForInStat b    <$> f i <*> identsE f e <*> identsS f s
identsS f (SwitchStat e xs s)  = SwitchStat     <$> identsE f e <*> (traverse . traverseCase) f xs <*> identsS f s
  where traverseCase g (e,s) = (,) <$> identsE g e <*> identsS g s
identsS f (TryStat s1 i s2 s3) = TryStat        <$> identsS f s1 <*> f i <*> identsS f s2 <*> identsS f s3
identsS f (BlockStat xs)       = BlockStat   <$> (traverse . identsS) f xs
identsS f (ApplStat e es)      = ApplStat    <$> identsE f e <*> (traverse . identsE) f es
identsS f (UOpStat op e)       = UOpStat op  <$> identsE f e
identsS f (AssignStat e1 e2)   = AssignStat  <$> identsE f e1 <*> identsE f e2
identsS _ UnsatBlock{}         = error "identsS: UnsatBlock"
identsS f (LabelStat l s)      = LabelStat l <$> identsS f s
identsS _ b@BreakStat{}        = pure b
identsS _ c@ContinueStat{}     = pure c

{-# INLINE identsE #-}
identsE :: Traversal' JExpr Ident
identsE f (ValExpr v)         = ValExpr     <$> identsV f v
identsE f (SelExpr e i)       = SelExpr     <$> identsE f e <*> pure i -- do not rename properties
identsE f (IdxExpr e1 e2)     = IdxExpr     <$> identsE f e1 <*> identsE f e2
identsE f (InfixExpr s e1 e2) = InfixExpr s <$> identsE f e1 <*> identsE f e2
identsE f (UOpExpr o e)       = UOpExpr o   <$> identsE f e
identsE f (IfExpr e1 e2 e3)   = IfExpr      <$> identsE f e1 <*> identsE f e2 <*> identsE f e3
identsE f (ApplExpr e es)     = ApplExpr    <$> identsE f e <*> (traverse . identsE) f es
identsE _ UnsatExpr{}         = error "identsE: UnsatExpr"

{-# INLINE identsV #-}
identsV :: Traversal' JVal Ident
identsV f (JVar i)       = JVar  <$> f i
identsV f (JList xs)     = JList <$> (traverse . identsE) f xs
identsV _ d@JDouble{}    = pure d
identsV _ i@JInt{}       = pure i
identsV _ s@JStr{}       = pure s
identsV _ r@JRegEx{}     = pure r
identsV f (JHash m)      = JHash <$> (traverse . identsE) f m
identsV f (JFunc args s) = JFunc <$> traverse f args <*> identsS f s
identsV _ UnsatVal{}     = error "identsV: UnsatVal"

----------------------------

{-# INLINE valsS #-}
valsS :: Traversal' JStat JVal
valsS _ d@(DeclStat _i)      = pure d -- DeclStat       <$> f i
valsS f (ReturnStat e)       = ReturnStat     <$> valsE f e
valsS f (IfStat e s1 s2)     = IfStat         <$> valsE f e <*> valsS f s1 <*> valsS f s2
valsS f (WhileStat b e s)    = WhileStat b    <$> valsE f e <*> valsS f s
valsS f (ForInStat b i e s)  = ForInStat b    <$> pure i <*> valsE f e <*> valsS f s
valsS f (SwitchStat e xs s)  = SwitchStat     <$> valsE f e <*> (traverse . traverseCase) f xs <*> valsS f s
  where traverseCase g (e,s) = (,) <$> valsE g e <*> valsS g s
valsS f (TryStat s1 i s2 s3) = TryStat        <$> valsS f s1 <*> pure i <*> valsS f s2 <*> valsS f s3
valsS f (BlockStat xs)       = BlockStat   <$> (traverse . valsS) f xs
valsS f (ApplStat e es)      = ApplStat    <$> valsE f e <*> (traverse . valsE) f es
valsS f (UOpStat op e)       = UOpStat op  <$> valsE f e
valsS f (AssignStat e1 e2)   = AssignStat  <$> valsE f e1 <*> valsE f e2
valsS _ UnsatBlock{}         = panic "valsS: UnsatBlock"
valsS f (LabelStat l s)      = LabelStat l <$> valsS f s
valsS _ b@BreakStat{}        = pure b
valsS _ c@ContinueStat{}     = pure c

{-# INLINE valsE #-}
valsE :: Traversal' JExpr JVal
valsE f (ValExpr v)         = ValExpr     <$> f v
valsE f (SelExpr e i)       = SelExpr     <$> valsE f e <*> pure i
valsE f (IdxExpr e1 e2)     = IdxExpr     <$> valsE f e1 <*> valsE f e2
valsE f (InfixExpr s e1 e2) = InfixExpr s <$> valsE f e1 <*> valsE f e2
valsE f (UOpExpr o e)       = UOpExpr o   <$> valsE f e
valsE f (IfExpr e1 e2 e3)   = IfExpr      <$> valsE f e1 <*> valsE f e2 <*> valsE f e3
valsE f (ApplExpr e es)     = ApplExpr    <$> valsE f e <*> (traverse . valsE) f es
valsE _ UnsatExpr{}         = panic "valsE: UnsatExpr"

{-# INLINE exprsS #-}
exprsS :: Traversal' JStat JExpr
exprsS _ d@(DeclStat _i)      = pure d -- DeclStat       <$> f i
exprsS f (ReturnStat e)       = ReturnStat     <$> f e
exprsS f (IfStat e s1 s2)     = IfStat         <$> f e <*> exprsS f s1 <*> exprsS f s2
exprsS f (WhileStat b e s)    = WhileStat b    <$> f e <*> exprsS f s
exprsS f (ForInStat b i e s)  = ForInStat b    <$> pure i <*> f e <*> exprsS f s
exprsS f (SwitchStat e xs s)  = SwitchStat     <$> f e <*> (traverse . traverseCase) f xs <*> exprsS f s
  where traverseCase g (e,s) = (,) <$> g e <*> exprsS g s
exprsS f (TryStat s1 i s2 s3) = TryStat        <$> exprsS f s1 <*> pure i <*> exprsS f s2 <*> exprsS f s3
exprsS f (BlockStat xs)       = BlockStat   <$> (traverse . exprsS) f xs
exprsS f (ApplStat e es)      = ApplStat    <$> f e <*> traverse f es
exprsS f (UOpStat op e)       = UOpStat op  <$> f e
exprsS f (AssignStat e1 e2)   = AssignStat  <$> f e1 <*> f e2
exprsS _ UnsatBlock{}         = panic "exprsS: UnsatBlock"
exprsS f (LabelStat l s)      = LabelStat l <$> exprsS f s
exprsS _ b@BreakStat{}        = pure b
exprsS _ c@ContinueStat{}     = pure c

-- doesn't traverse through values
{-# INLINE exprsE #-}
exprsE :: Traversal' JExpr JExpr
exprsE _ ve@(ValExpr _)      = pure ve
exprsE f (SelExpr e i)       = SelExpr     <$> f e <*> pure i
exprsE f (IdxExpr e1 e2)     = IdxExpr     <$> f e1 <*> f e2
exprsE f (InfixExpr s e1 e2) = InfixExpr s <$> f e1 <*> f e2
exprsE f (UOpExpr o e)       = UOpExpr o   <$> f e
exprsE f (IfExpr e1 e2 e3)   = IfExpr      <$> f e1 <*> f e2 <*> f e3
exprsE f (ApplExpr e es)     = ApplExpr    <$> f e <*> traverse f es
exprsE _ UnsatExpr{}         = panic "exprsE: UnsatExpr"

staticInfoArgs :: Traversal' StaticInfo StaticArg
staticInfoArgs f (StaticInfo si sv sa) =
  StaticInfo <$> pure si <*> staticValArgs f sv <*> pure sa

staticValArgs :: Traversal' StaticVal StaticArg
staticValArgs f (StaticFun fn as)
  = StaticFun fn <$> traverse f as
staticValArgs f (StaticThunk (Just (t, as)))
  = StaticThunk . Just . (t,) <$> traverse f as
staticValArgs f (StaticData c as) = StaticData c <$> traverse f as
staticValArgs f (StaticList as mt) = StaticList <$> traverse f as <*> pure mt
staticValArgs _ x = pure x

compact :: GhcjsSettings
        -> DynFlags
        -> CompactorState
        -> [Text]
        -> [LinkedUnit]
        -> (CompactorState, [JStat], JStat)
compact settings dflags cs0 rtsDeps0 input0
--  | dumpHashes' input
  =
  let rtsDeps1 = rtsDeps0 ++
                 map (<> "_e") rtsDeps0 ++
                 map (<> "_con_e") rtsDeps0
      (cs1, input1) = packStrings settings dflags cs0 input0
  in  renameInternals settings dflags cs1 rtsDeps1 input1

  -- renameInternals settings dflags cs1 rtsDeps' input


-- hash compactification

dedupeBodies :: [Text]
             -> [(JStat, [ClosureInfo], [StaticInfo])]
             -> (JStat, [(JStat, [ClosureInfo], [StaticInfo])])
dedupeBodies rtsDeps input = (renderBuildFunctions bfN bfCB, input')
  where
    (bfN, bfCB, input') = rewriteBodies globals hdefsR hdefs input
    hdefs   = M.fromListWith (\(s,ks1) (_,ks2) -> (s, ks1++ks2))
                             (map (\(k, s, bs) -> (bs, (s, [k]))) hdefs0)
    hdefsR  = M.fromList $ map (\(k, _, bs) -> (k, bs)) hdefs0
    hdefs0 :: [(Text, Int, BS.ByteString)]
    hdefs0  = concatMap (\(b,_,_) ->
                          (map (\(k,h) ->
                            let (s,fh, _deps) = finalizeHash' h
                            in (k, s, fh))
                        . hashDefinitions globals) b
                        )
                        input
    globals = foldl' (flip S.delete) (findAllGlobals input) rtsDeps

renderBuildFunctions :: [BuildFunction] -> [BuildFunction] -> JStat
renderBuildFunctions normalBfs cycleBreakerBfs =
  cycleBr1 <> mconcat (map renderBuildFunction normalBfs) <> cycleBr2
  where
    renderCbr f = mconcat (zipWith f cycleBreakerBfs [1..])
    cbName :: Int -> Text
    cbName = T.pack . ("h$$$cb"++) . show
    cycleBr1 = renderCbr $ \bf n ->
      let args = map (TxtI . T.pack . ('a':) . show) [1..bfArgs bf]
          body = ReturnStat $ ApplExpr (ValExpr (JVar (TxtI $ cbName n)))
                                       (map (ValExpr . JVar) args)
      in  DeclStat (TxtI (bfName bf)) <>
          AssignStat (ValExpr (JVar (TxtI (bfName bf))))
                     (ValExpr (JFunc args body))
    cycleBr2 = renderCbr $ \bf n -> renderBuildFunction (bf { bfName = cbName n })

data BuildFunction = BuildFunction
  { bfName    :: !Text
  , bfBuilder :: !Ident
  , bfDeps    :: [Text]
  , bfArgs    :: !Int
  } deriving (Eq, Ord, Show)

{-
  Stack frame initialization order is important when code is reused:
    all dependencies have to be ready when the closure is built.

  This function sorts the initializers and returns an additional list
    of cycle breakers, which are built in a two-step fashion
 -}
sortBuildFunctions :: [BuildFunction] -> ([BuildFunction], [BuildFunction])
sortBuildFunctions bfs = (map snd normBFs, map snd cbBFs)
  where
    (normBFs, cbBFs) = partition (not.fst) . concatMap fromSCC $ sccs bfs
    bfm :: Map Text BuildFunction
    bfm = M.fromList (map (\x -> (bfName x, x)) bfs)
    fromSCC :: G.SCC Text -> [(Bool, BuildFunction)]
    fromSCC (G.AcyclicSCC x) = [(False, bfm M.! x)]
    fromSCC (G.CyclicSCC xs) = breakCycles xs
    sccs :: [BuildFunction] -> [G.SCC Text]
    sccs b = G.stronglyConnComp $
      map (\bf -> let n = bfName bf in (n, n, bfDeps bf)) b
    {-
       finding the maximum acyclic subgraph is the Minimum Feedback Arc Set problem,
       which is NP-complete. We use an approximation here.
     -}
    breakCycles :: [Text] -> [(Bool, BuildFunction)]
    breakCycles nodes =
      (True, bfm M.! selected)
      : concatMap fromSCC (sccs $ (map (bfm M.!) $ filter (/=selected) nodes))
      where
        outDeg, inDeg :: Map Text Int
        outDeg = M.fromList $ map (\n -> (n, length (bfDeps (bfm M.! n)))) nodes
        inDeg  = M.fromListWith (+) (map (,1) . concatMap (bfDeps . (bfm M.!)) $ nodes)
        -- ELS heuristic (Eades et. al.)
        selected :: Text
        selected = maximumBy (compare `on` (\x -> outDeg M.! x - inDeg M.! x)) nodes

rewriteBodies :: Set Text
              -> Map Text BS.ByteString
              -> Map BS.ByteString (Int, [Text])
              -> [LinkedUnit]
              -> ([BuildFunction], [BuildFunction], [LinkedUnit])
rewriteBodies globals idx1 idx2 input = (bfsNormal, bfsCycleBreaker, input')
  where
    (bfs1, input')               = unzip (map rewriteBlock input)
    (bfsNormal, bfsCycleBreaker) = sortBuildFunctions (concat bfs1)

    -- this index only contains the entries we actually want to dedupe
    idx2' :: Map BS.ByteString (Int, [Text])
    idx2' = M.filter (\(s, xs) -> dedupeBody (length xs) s) idx2

    rewriteBlock :: (JStat, [ClosureInfo], [StaticInfo])
                 -> ([BuildFunction], LinkedUnit)
    rewriteBlock (st, cis, sis) =
      let (bfs, st') = rewriteFunctions st
      -- remove the declarations for things that we just deduped
          st''       = removeDecls (S.fromList $ map bfName bfs) st'
      in  (bfs, (st'', cis, sis))

    removeDecls :: Set Text -> JStat -> JStat
    removeDecls t (BlockStat ss) = BlockStat (map (removeDecls t) ss)
    removeDecls t (DeclStat (TxtI i))
      | i `S.member` t = mempty
    removeDecls _ s = s

    rewriteFunctions :: JStat -> ([BuildFunction], JStat)
    rewriteFunctions (BlockStat ss) =
      let (bfs, ss') = unzip (map rewriteFunctions ss)
      in  (concat bfs, BlockStat ss')
    rewriteFunctions (AssignStat (ValExpr (JVar (TxtI i)))
                                 (ValExpr (JFunc args st)))
      | Just h         <- M.lookup i idx1
      , Just (_s, his) <- M.lookup h idx2' =
          let (bf, st') = rewriteFunction i h his args st in ([bf], st')
    rewriteFunctions x = ([], x)

    rewriteFunction :: Text
                    -> BS.ByteString
                    -> [Text]
                    -> [Ident]
                    -> JStat
                    -> (BuildFunction, JStat)
    rewriteFunction i h his args body
      | i == iFirst = (bf, createFunction i idx g args body)
      | otherwise   = (bf, mempty)
       where
          bf :: BuildFunction
          bf       = BuildFunction i (buildFunId idx) g (length args)
          g :: [Text]
          g        = findGlobals globals body
          iFirst   = head his
          Just idx = M.lookupIndex h idx2'

    createFunction :: Text
                   -> Int
                   -> [Text]
                   -> [Ident]
                   -> JStat
                   -> JStat
    createFunction _i idx g args body =
      DeclStat bi <>
      AssignStat (ValExpr (JVar bi))
                 (ValExpr (JFunc bargs bbody))
      where
        ng    = length g
        bi    = buildFunId idx
        bargs :: [Ident]
        bargs = map (TxtI . T.pack . ("h$$$g"++) . show) [1..ng]
        bgm :: Map Text Ident
        bgm   = M.fromList (zip g bargs)
        bbody :: JStat
        bbody = ReturnStat (ValExpr $ JFunc args ibody)
        ibody :: JStat
        ibody = body & identsS %~ \ti@(TxtI i) -> fromMaybe ti (M.lookup i bgm)

renderBuildFunction :: BuildFunction -> JStat
renderBuildFunction (BuildFunction i bfid deps _nargs) =
  DeclStat (TxtI i) <>
  AssignStat (ValExpr (JVar (TxtI i)))
             (ApplExpr (ValExpr (JVar bfid)) (map (ValExpr . JVar . TxtI) deps))

dedupeBody :: Int -> Int -> Bool
dedupeBody n size
  | n < 2          = False
  | size * n > 200 = True
  | n > 6          = True
  | otherwise      = False

buildFunId :: Int -> Ident
buildFunId i = TxtI (T.pack $ "h$$$f" ++ show i)

-- result is ordered, does not contain duplicates
findGlobals :: Set Text -> JStat -> [Text]
findGlobals globals stat = nub'
  (filter isGlobal . map (\(TxtI i) -> i) $ stat ^.. identsS)
  where
    locals     = S.fromList (findLocals stat)
    isGlobal i = i `S.member` globals && i `S.notMember` locals

findLocals :: JStat -> [Text]
findLocals (BlockStat ss)      = concatMap findLocals ss
findLocals (DeclStat (TxtI i)) = [i]
findLocals _                   = []

nub' :: Ord a => [a] -> [a]
nub' = go S.empty
  where
    go _ []            = []
    go s (x:xs)
      | x `S.member` s = go s xs
      | otherwise      = x : go (S.insert x s) xs

data HashIdx = HashIdx (Map Text Hash) (Map Hash Text)

dedupe :: [Text]
       -> [(JStat, [ClosureInfo], [StaticInfo])]
       -> [(JStat, [ClosureInfo], [StaticInfo])]
dedupe rtsDeps input
--  | dumpHashIdx idx
  =
  map (\(st,cis,sis) -> dedupeBlock idx st cis sis) input
  where
    idx    = HashIdx hashes hr
    hashes0 = buildHashes rtsDeps input
    hashes  = foldl' (flip M.delete) hashes0 rtsDeps
    hr     = fmap pickShortest
             (M.fromListWith (++) $
             map (\(i, h) -> (h, [i])) (M.toList hashes))
    pickShortest :: [Text] -> Text
    pickShortest = minimumBy (compare `on` T.length)

dedupeBlock :: HashIdx
            -> JStat
            -> [ClosureInfo]
            -> [StaticInfo]
            -> LinkedUnit
dedupeBlock hi st ci si =
  ( dedupeStat hi st
  , mapMaybe (dedupeClosureInfo hi) ci
  , mapMaybe (dedupeStaticInfo hi) si
  )

dedupeStat :: HashIdx -> JStat -> JStat
dedupeStat hi st = go st
  where
    go (BlockStat ss) = BlockStat (map go ss)
    go s@(DeclStat (TxtI i))
      | not (isCanon hi i) = mempty
      | otherwise          = s
    go (AssignStat v@(ValExpr (JVar (TxtI i))) e)
      | not (isCanon hi i) = mempty
      | otherwise          = AssignStat v (e & identsE %~ toCanonI hi)
    -- rewrite identifiers in e
    go s = s & identsS %~ toCanonI hi

dedupeClosureInfo :: HashIdx -> ClosureInfo -> Maybe ClosureInfo
dedupeClosureInfo hi (ClosureInfo i rs n l ty st)
  | isCanon hi i = Just (ClosureInfo i rs n l ty (dedupeCIStatic hi st))
dedupeClosureInfo _ _ = Nothing

dedupeStaticInfo :: HashIdx -> StaticInfo -> Maybe StaticInfo
dedupeStaticInfo hi (StaticInfo i val ccs)
  | isCanon hi i = Just (StaticInfo i (dedupeStaticVal hi val) ccs)
dedupeStaticInfo _ _ = Nothing

dedupeCIStatic :: HashIdx -> CIStatic -> CIStatic
dedupeCIStatic hi (CIStaticRefs refs) = CIStaticRefs (nub $ map (toCanon hi) refs)

dedupeStaticVal :: HashIdx -> StaticVal -> StaticVal
dedupeStaticVal hi (StaticFun t args) =
  StaticFun (toCanon hi t) (map (dedupeStaticArg hi) args)
dedupeStaticVal hi (StaticThunk (Just (o, args))) =
  StaticThunk (Just (toCanon hi o, map (dedupeStaticArg hi) args))
dedupeStaticVal hi (StaticData dcon args) =
  StaticData (toCanon hi dcon) (map (dedupeStaticArg hi) args)
dedupeStaticVal hi (StaticList args lt) =
  StaticList (map (dedupeStaticArg hi) args) (fmap (toCanon hi) lt)
dedupeStaticVal _ v = v -- unboxed value or thunk with alt init, no rewrite needed

dedupeStaticArg :: HashIdx -> StaticArg -> StaticArg
dedupeStaticArg hi (StaticObjArg o)
  = StaticObjArg (toCanon hi o)
dedupeStaticArg hi (StaticConArg c args)
  = StaticConArg (toCanon hi c)
                 (map (dedupeStaticArg hi) args)
dedupeStaticArg _hi a@StaticLitArg{}    = a

isCanon :: HashIdx -> Text -> Bool
isCanon (HashIdx a b) t
  | Nothing <- la = True
  | Just h  <- la
  , Just t' <- M.lookup h b = t == t'
  | otherwise = False
  where la = M.lookup t a

toCanon :: HashIdx -> Text -> Text
toCanon (HashIdx a b) t
  | Just h  <- M.lookup t a
  , Just t' <- M.lookup h b = t'
  | otherwise = t

toCanonI :: HashIdx -> Ident -> Ident
toCanonI hi (TxtI x) = TxtI (toCanon hi x)

type Hash = (BS.ByteString, [Text])

data HashBuilder = HashBuilder !BB.Builder ![Text]

instance Monoid HashBuilder where
  mempty = HashBuilder mempty mempty

instance Semigroup HashBuilder where
  (<>) (HashBuilder b1 l1) (HashBuilder b2 l2) =
    HashBuilder (b1 <> b2) (l1 <> l2)

{-
dumpHashIdx :: HashIdx -> Bool
dumpHashIdx hi@(HashIdx ma mb) =
  let ks = M.keys ma
      difCanon i = let i' = toCanon hi i
                   in if i == i' then Nothing else Just i'
      writeHashIdx = do
        putStrLn "writing hash idx"
        T.writeFile "hashidx.txt"
          (T.unlines . sort $ mapMaybe (\i -> fmap ((i <> " -> ") <>) (difCanon i)) ks)
        putStrLn "writing full hash idx"
        T.writeFile "hashIdxFull.txt"
          (T.unlines . sort $ M.keys ma)
  in unsafePerformIO writeHashIdx `seq` True
-}
-- debug thing
{-
dumpHashes' :: [(JStat, [ClosureInfo], [StaticInfo])] -> Bool
dumpHashes' input =
  let hashes      = buildHashes input
      writeHashes = do
        putStrLn "writing hashes"
        BL.writeFile "hashes.json" (Aeson.encode $ dumpHashes hashes)
  in unsafePerformIO writeHashes `seq` True
-}
buildHashes :: [Text] -> [LinkedUnit] -> Map Text Hash
buildHashes rtsDeps xss
  -- - | dumpHashes0 hashes0
  = fixHashes (fmap finalizeHash hashes0)
  where
    globals = foldl' (flip S.delete) (findAllGlobals xss) rtsDeps
    hashes0 = (M.unions (map buildHashesBlock xss))
    buildHashesBlock (st, cis, sis) =
      let hdefs = hashDefinitions globals st
          hcis  = map hashClosureInfo cis
          hsis  = map hashStaticInfo (filter (not . ignoreStatic) sis)
      in  M.fromList (combineHashes hdefs hcis ++ hsis)

findAllGlobals :: [LinkedUnit] -> Set Text
findAllGlobals xss = S.fromList $ concatMap f xss
  where
    f (_, cis, sis) =
      map (\(ClosureInfo i _ _ _ _ _) -> i) cis ++
      map (\(StaticInfo i _ _) -> i) sis

fixHashes :: Map Text Hash -> Map Text Hash
fixHashes hashes = fmap (\(bs,h) -> (bs, map replaceHash h)) hashes
  where
    replaceHash h = fromMaybe h (M.lookup h finalHashes)
    hashText  bs = "h$$$" <> TE.decodeUtf8 (B16.encode bs)
    sccs :: [[Text]]
    sccs         = map fromSCC $
                   G.stronglyConnComp (map (\(k, (_bs, deps)) -> (k, k, deps)) (M.toList hashes))
    ks           = M.keys hashes
    invDeps      = M.fromListWith (++) (concatMap mkInvDeps $ M.toList hashes)
    mkInvDeps (k, (_, ds)) = map (,[k]) ds
    finalHashes  = fmap hashText (fixHashesIter 500 invDeps ks ks sccs hashes mempty)

fromSCC :: G.SCC a -> [a]
fromSCC (G.AcyclicSCC x) = [x]
fromSCC (G.CyclicSCC xs) = xs

fixHashesIter :: Int
              -> Map Text [Text]
              -> [Text]
              -> [Text]
              -> [[Text]]
              -> Map Text Hash
              -> Map Text BS.ByteString
              -> Map Text BS.ByteString
fixHashesIter n invDeps allKeys checkKeys sccs hashes finalHashes
  -- - | unsafePerformIO (putStrLn ("fixHashesIter: " ++ show n)) `seq` False = undefined
  | n < 0                = finalHashes
  | not (null newHashes) = fixHashesIter (n-1) invDeps allKeys checkKeys' sccs hashes
      (M.union finalHashes $ M.fromList newHashes)
  -- - | unsafePerformIO (putStrLn ("fixHashesIter killing cycles:\n" ++ show rootSCCs)) `seq` False = undefined
  | not (null rootSCCs)  = fixHashesIter n {- -1 -} invDeps allKeys allKeys sccs hashes
      (M.union finalHashes (M.fromList $ concatMap hashRootSCC rootSCCs))
  | otherwise            = finalHashes
  where
    checkKeys' | length newHashes > (M.size hashes `div` 10) = allKeys
               | otherwise = S.toList . S.fromList $ concatMap newHashDeps newHashes
    newHashDeps (k, _) = fromMaybe [] (M.lookup k invDeps)
    mkNewHash k | M.notMember k finalHashes
                , Just (hb, htxt) <- M.lookup k hashes
                , Just bs <- mapM (`M.lookup` finalHashes) htxt =
                  Just (k, makeFinalHash hb bs)
                | otherwise = Nothing
    newHashes :: [(Text, BS.ByteString)]
    newHashes = mapMaybe mkNewHash checkKeys
    rootSCCs :: [[Text]]
    rootSCCs = filter isRootSCC sccs
    isRootSCC :: [Text] -> Bool
    isRootSCC scc = not (all (`M.member` finalHashes) scc) && all check scc
      where
        check n = let Just (_bs, out) = M.lookup n hashes
                  in  all checkEdge out
        checkEdge e = e `S.member` s || e `M.member` finalHashes
        s = S.fromList scc
    hashRootSCC :: [Text] -> [(Text,BS.ByteString)]
    hashRootSCC scc
      | any (`M.member` finalHashes) scc = Panic.panic "Gen2.Compactor.hashRootSCC: has finalized nodes"
      | otherwise = map makeHash toHash
      where
        makeHash k = let Just (bs,deps) = M.lookup k hashes
                         luds           = map lookupDep deps
                     in (k, makeFinalHash bs luds)
        lookupDep :: Text -> BS.ByteString
        lookupDep d
          | Just b <- M.lookup d finalHashes = b
          | Just i <- M.lookup d toHashIdx
              = grpHash <> (TE.encodeUtf8 . T.pack . show $ i)
          | otherwise
              = Panic.panic $ "Gen2.Compactor.hashRootSCC: unknown key: " ++
                              T.unpack d
        toHashIdx :: M.Map Text Integer
        toHashIdx = M.fromList $ zip toHash [1..]
        grpHash :: BS.ByteString
        grpHash = BL.toStrict
                . BB.toLazyByteString
                $ mconcat (map (mkGrpHash . (hashes M.!)) toHash)
        mkGrpHash (h, deps) =
          let deps' = mapMaybe (`M.lookup` finalHashes) deps
          in  BB.byteString h <>
              BB.int64LE (fromIntegral $ length deps') <>
              mconcat (map BB.byteString deps')
        toHash :: [Text]
        toHash = sortBy (compare `on` (fst . (hashes M.!))) scc

makeFinalHash :: BS.ByteString -> [BS.ByteString] -> BS.ByteString
makeFinalHash b bs = SHA256.hash (mconcat (b:bs))

-- do not deduplicate thunks
ignoreStatic :: StaticInfo -> Bool
ignoreStatic (StaticInfo _ StaticThunk {} _) = True
ignoreStatic _                               = False

-- combine hashes from x and y, leaving only those which have an entry in both
combineHashes :: [(Text, HashBuilder)]
              -> [(Text, HashBuilder)]
              -> [(Text, HashBuilder)]
combineHashes x y = M.toList $ M.intersectionWith (<>)
                                                  (M.fromList x)
                                                  (M.fromList y)

{-
dumpHashes0 :: Map Text HashBuilder -> Bool
dumpHashes0 hashes = unsafePerformIO writeHashes `seq` True
  where
    hashLine (n, HashBuilder bb txt) =
      n <> " ->\n    " <>
      escapeBS (BB.toLazyByteString bb) <> "\n    [" <> T.intercalate " " txt <> "]\n"
    escapeBS :: BL.ByteString -> T.Text
    escapeBS = T.pack . concatMap escapeCH . BL.unpack
    escapeCH c | c < 32 || c > 127 = '\\' : show c
               | c == 92           = "\\\\"
               | otherwise         = [chr (fromIntegral c)]

    writeHashes = do
      putStrLn "writing hashes0"
      T.writeFile "hashes0.dump" (T.unlines $ map hashLine (M.toList hashes))

dumpHashes :: Map Text Hash -> Value
dumpHashes idx = toJSON iidx
   where
       iidx :: Map Text [(Text, [Text])]
       iidx = M.fromListWith (++) $
         map (\(t, (b, deps)) -> (TE.decodeUtf8 (B16.encode b), [(t,deps)])) (M.toList idx)
-}

ht :: Int8 -> HashBuilder
ht x = HashBuilder (BB.int8 x) []

hi :: Int -> HashBuilder
hi x = HashBuilder (BB.int64LE $ fromIntegral x) []

hi' :: (Show a, Integral a) => a -> HashBuilder
hi' x | x' > toInteger (maxBound :: Int64) || x' < toInteger (minBound :: Int64) =
        Panic.panic $ "Gen2.Compactor.hi': integer out of range: " ++ show x
      | otherwise = HashBuilder (BB.int64LE $ fromInteger x') []
  where
    x' = toInteger x

hd :: Double -> HashBuilder
hd d = HashBuilder (BB.doubleLE d) []

htxt :: Text -> HashBuilder
htxt x = HashBuilder (BB.int64LE (fromIntegral $ BS.length bs) <> BB.byteString bs) []
  where
    bs = TE.encodeUtf8 x

hobj :: Text -> HashBuilder
hobj x = HashBuilder (BB.int8 127) [x]

hb :: BS.ByteString -> HashBuilder
hb x = HashBuilder (BB.int64LE (fromIntegral $ BS.length x) <> BB.byteString x) []

hashDefinitions :: Set Text -> JStat -> [(Text, HashBuilder)]
hashDefinitions globals st =
  let defs = findDefinitions st
  in  map (uncurry (hashSingleDefinition globals)) defs

findDefinitions :: JStat -> [(Ident, JExpr)]
findDefinitions (BlockStat ss)                    = concatMap findDefinitions ss
findDefinitions (AssignStat (ValExpr (JVar i)) e) = [(i,e)]
findDefinitions _                                 = []

hashSingleDefinition :: Set Text -> Ident -> JExpr -> (Text, HashBuilder)
hashSingleDefinition globals (TxtI i) expr = (i, ht 0 <> render st <> mconcat (map hobj globalRefs))
  where
    globalRefs = nub $ filter (`S.member` globals) (map (\(TxtI i) -> i) (expr ^.. identsE))
    globalMap  = M.fromList $ zip globalRefs (map (T.pack . ("h$$$global_"++) . show) [(1::Int)..])
    expr'      = expr & identsE %~ (\i@(TxtI t) -> maybe i TxtI (M.lookup t globalMap))
    st         = AssignStat (ValExpr (JVar (TxtI "dummy"))) expr'
    render     = htxt . TL.toStrict . displayT . renderPretty 0.8 150 . pretty

hashClosureInfo :: ClosureInfo -> (Text, HashBuilder)
hashClosureInfo (ClosureInfo civ cir _cin cil cit cis) =
  (civ, ht 1 <> hashCIRegs cir <> hashCILayout cil <> hashCIType cit <> hashCIStatic cis)

hashStaticInfo :: StaticInfo -> (Text, HashBuilder)
hashStaticInfo (StaticInfo sivr sivl _sicc) =
  (sivr, ht 2 <> hashStaticVal sivl)

hashCIType :: CIType -> HashBuilder
hashCIType (CIFun a r)  = ht 1 <> hi a <> hi r
hashCIType CIThunk      = ht 2
hashCIType (CICon c)    = ht 3 <> hi c
hashCIType CIPap        = ht 4
hashCIType CIBlackhole  = ht 5
hashCIType CIStackFrame = ht 6


hashCIRegs :: CIRegs -> HashBuilder
hashCIRegs CIRegsUnknown   = ht 1
hashCIRegs (CIRegs sk tys) = ht 2 <> hi sk <> hashList hashVT tys

hashCILayout :: CILayout -> HashBuilder
hashCILayout CILayoutVariable       = ht 1
hashCILayout (CILayoutUnknown size) = ht 2 <> hi size
hashCILayout (CILayoutFixed n l)    = ht 3 <> hi n <> hashList hashVT l

hashCIStatic :: CIStatic -> HashBuilder
hashCIStatic CIStaticRefs{} = mempty -- hashList hobj xs -- we get these from the code

hashList :: (a -> HashBuilder) -> [a] -> HashBuilder
hashList f xs = hi (length xs) <> mconcat (map f xs)

hashVT :: VarType -> HashBuilder
hashVT = hi . fromEnum

hashStaticVal :: StaticVal -> HashBuilder
hashStaticVal (StaticFun t args)      = ht 1 <> hobj t <> hashList hashStaticArg args
hashStaticVal (StaticThunk mtn)       = ht 2 <> hashMaybe htobj mtn
  where
    htobj (o, args) = hobj o <> hashList hashStaticArg args
hashStaticVal (StaticUnboxed su)      = ht 3 <> hashStaticUnboxed su
hashStaticVal (StaticData dcon args)  = ht 4 <> hobj dcon <> hashList hashStaticArg args
hashStaticVal (StaticList args lt)    = ht 5 <> hashList hashStaticArg args <> hashMaybe hobj lt

hashMaybe :: (a -> HashBuilder) -> Maybe a -> HashBuilder
hashMaybe _ Nothing  = ht 1
hashMaybe f (Just x) = ht 2 <> f x

hashStaticUnboxed :: StaticUnboxed -> HashBuilder
hashStaticUnboxed (StaticUnboxedBool b)           = ht 1 <> hi (fromEnum b)
hashStaticUnboxed (StaticUnboxedInt iv)           = ht 2 <> hi' iv
hashStaticUnboxed (StaticUnboxedDouble sd)        = ht 3 <> hashSaneDouble sd
hashStaticUnboxed (StaticUnboxedString str)       = ht 4 <> hb str
hashStaticUnboxed (StaticUnboxedStringOffset str) = ht 5 <> hb str


hashStaticArg :: StaticArg -> HashBuilder
hashStaticArg (StaticObjArg t)       = ht 1 <> hobj t
hashStaticArg (StaticLitArg sl)      = ht 2 <> hashStaticLit sl
hashStaticArg (StaticConArg cn args) = ht 3 <> hobj cn <> hashList hashStaticArg args

hashStaticLit :: StaticLit -> HashBuilder
hashStaticLit (BoolLit b)       = ht 1 <> hi (fromEnum b)
hashStaticLit (IntLit iv)       = ht 2 <> hi (fromIntegral iv)
hashStaticLit  NullLit          = ht 3
hashStaticLit (DoubleLit d)     = ht 4 <> hashSaneDouble d
hashStaticLit (StringLit tt)    = ht 5 <> htxt tt
hashStaticLit (BinLit bs)       = ht 6 <> hb bs
hashStaticLit (LabelLit bb ln)  = ht 7 <> hi (fromEnum bb) <> htxt ln

hashSaneDouble :: SaneDouble -> HashBuilder
hashSaneDouble (SaneDouble sd) = hd sd

finalizeHash :: HashBuilder -> Hash
finalizeHash (HashBuilder hb tt) =
  let h = SHA256.hash (BL.toStrict $ BB.toLazyByteString hb)
  in  h `seq` (h, tt)

finalizeHash' :: HashBuilder -> (Int, BS.ByteString, [Text])
finalizeHash' (HashBuilder hb tt) =
  let b  = BL.toStrict (BB.toLazyByteString hb)
      bl = BS.length b
      h  = SHA256.hash b
  in  h `seq` bl `seq` (bl, h, tt)
