LINUX.ORG.RU

История изменений

Исправление MOPKOBKA, (текущая версия) :

Не угадал.

Нет, угадал. Твоя очередь. Что это, и что тут происходит?

ptCreateStaticBinds :: HscEnv -> Module -> CoreProgram
                     -> IO ([SptEntry], CoreProgram)
sptCreateStaticBinds hsc_env this_mod binds
    | not (xopt LangExt.StaticPointers dflags) =
      return ([], binds)
    | otherwise = do
      _ <- lookupGlobal hsc_env unpackCStringName
      (fps, binds') <- evalStateT (go [] [] binds) 0
      return (fps, binds')
  where
    go fps bs xs = case xs of
      []        -> return (reverse fps, reverse bs)
      bnd : xs' -> do
        (fps', bnd') <- replaceStaticBind bnd
        go (reverse fps' ++ fps) (bnd' : bs) xs'

    dflags = hsc_dflags hsc_env


    replaceStaticBind :: CoreBind
                      -> StateT Int IO ([SptEntry], CoreBind)
    replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e
                                        return (maybeToList mfp, NonRec b' e')
    replaceStaticBind (Rec rbs) = do
      (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs
      return (catMaybes mfps, Rec rbs')

    replaceStatic :: Id -> CoreExpr
                  -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr))
    replaceStatic b e@(collectTyBinders -> (tvs, e0)) =
      case collectMakeStaticArgs e0 of
        Nothing      -> return (Nothing, (b, e))
        Just (_, t, info, arg) -> do
          (fp, e') <- mkStaticBind t info arg
          return (Just (SptEntry b fp), (b, foldr Lam e' tvs))

    mkStaticBind :: Type -> CoreExpr -> CoreExpr
                 -> StateT Int IO (Fingerprint, CoreExpr)
    mkStaticBind t srcLoc e = do
      i <- get
      put (i + 1)
      staticPtrInfoDataCon <-
        lift $ lookupDataConHscEnv staticPtrInfoDataConName
      let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i
      info <- mkConApp staticPtrInfoDataCon <$>
            (++[srcLoc]) <$>
            mapM (mkStringExprFSWith (lift . lookupIdHscEnv))
                 [ unitIdFS $ moduleUnitId this_mod
                 , moduleNameFS $ moduleName this_mod
                 ]

      staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName
      return (fp, mkConApp staticPtrDataCon
                               [ Type t
                               , mkWord64LitWordRep dflags w0
                               , mkWord64LitWordRep dflags w1
                               , info
                               , e ])

    mkStaticPtrFingerprint :: Int -> Fingerprint
    mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"
        [ unitIdString $ moduleUnitId this_mod
        , moduleNameString $ moduleName this_mod
        , show n
        ]

    mkWord64LitWordRep dflags
      | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64
      | otherwise = mkWordLit dflags . toInteger

    lookupIdHscEnv :: Name -> IO Id
    lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>=
                         maybe (getError n) (return . tyThingId)

    lookupDataConHscEnv :: Name -> IO DataCon
    lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>=
                              maybe (getError n) (return . tyThingDataCon)

    getError n = pprPanic "sptCreateStaticBinds.get: not found" $
      text "Couldn't find" <+> ppr n

sptModuleInitCode :: Module -> [SptEntry] -> SDoc
sptModuleInitCode _ [] = Outputable.empty
sptModuleInitCode this_mod entries = vcat
    [ text "static void hs_spt_init_" <> ppr this_mod
           <> text "(void) __attribute__((constructor));"
    , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"
    , braces $ vcat $
        [  text "static StgWord64 k" <> int i <> text "[2] = "
           <> pprFingerprint fp <> semi
        $$ text "extern StgPtr "
           <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi
        $$ text "hs_spt_insert" <> parens
             (hcat $ punctuate comma
                [ char 'k' <> int i
                , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n))
                ]
             )
        <> semi
        |  (i, SptEntry n fp) <- zip [0..] entries
        ]
    , text "static void hs_spt_fini_" <> ppr this_mod
           <> text "(void) __attribute__((destructor));"
    , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"
    , braces $ vcat $
        [  text "StgWord64 k" <> int i <> text "[2] = "
           <> pprFingerprint fp <> semi
        $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi
        | (i, (SptEntry _ fp)) <- zip [0..] entries
        ]
    ]
  where
    pprFingerprint :: Fingerprint -> SDoc
    pprFingerprint (Fingerprint w1 w2) =
      braces $ hcat $ punctuate comma
                 [ integer (fromIntegral w1) <> text "ULL"
                 , integer (fromIntegral w2) <> text "ULL"
]

hateyoufeel помогай!

Исправление MOPKOBKA, :

Не угадал.

Нет, угадал. Твоя очередь. Что это, и что тут происходит?

ptCreateStaticBinds :: HscEnv -> Module -> CoreProgram
                     -> IO ([SptEntry], CoreProgram)
sptCreateStaticBinds hsc_env this_mod binds
    | not (xopt LangExt.StaticPointers dflags) =
      return ([], binds)
    | otherwise = do
      _ <- lookupGlobal hsc_env unpackCStringName
      (fps, binds') <- evalStateT (go [] [] binds) 0
      return (fps, binds')
  where
    go fps bs xs = case xs of
      []        -> return (reverse fps, reverse bs)
      bnd : xs' -> do
        (fps', bnd') <- replaceStaticBind bnd
        go (reverse fps' ++ fps) (bnd' : bs) xs'

    dflags = hsc_dflags hsc_env


    replaceStaticBind :: CoreBind
                      -> StateT Int IO ([SptEntry], CoreBind)
    replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e
                                        return (maybeToList mfp, NonRec b' e')
    replaceStaticBind (Rec rbs) = do
      (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs
      return (catMaybes mfps, Rec rbs')

    replaceStatic :: Id -> CoreExpr
                  -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr))
    replaceStatic b e@(collectTyBinders -> (tvs, e0)) =
      case collectMakeStaticArgs e0 of
        Nothing      -> return (Nothing, (b, e))
        Just (_, t, info, arg) -> do
          (fp, e') <- mkStaticBind t info arg
          return (Just (SptEntry b fp), (b, foldr Lam e' tvs))

    mkStaticBind :: Type -> CoreExpr -> CoreExpr
                 -> StateT Int IO (Fingerprint, CoreExpr)
    mkStaticBind t srcLoc e = do
      i <- get
      put (i + 1)
      staticPtrInfoDataCon <-
        lift $ lookupDataConHscEnv staticPtrInfoDataConName
      let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i
      info <- mkConApp staticPtrInfoDataCon <$>
            (++[srcLoc]) <$>
            mapM (mkStringExprFSWith (lift . lookupIdHscEnv))
                 [ unitIdFS $ moduleUnitId this_mod
                 , moduleNameFS $ moduleName this_mod
                 ]

      staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName
      return (fp, mkConApp staticPtrDataCon
                               [ Type t
                               , mkWord64LitWordRep dflags w0
                               , mkWord64LitWordRep dflags w1
                               , info
                               , e ])

    mkStaticPtrFingerprint :: Int -> Fingerprint
    mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"
        [ unitIdString $ moduleUnitId this_mod
        , moduleNameString $ moduleName this_mod
        , show n
        ]

    mkWord64LitWordRep dflags
      | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64
      | otherwise = mkWordLit dflags . toInteger

    lookupIdHscEnv :: Name -> IO Id
    lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>=
                         maybe (getError n) (return . tyThingId)

    lookupDataConHscEnv :: Name -> IO DataCon
    lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>=
                              maybe (getError n) (return . tyThingDataCon)

    getError n = pprPanic "sptCreateStaticBinds.get: not found" $
      text "Couldn't find" <+> ppr n

sptModuleInitCode :: Module -> [SptEntry] -> SDoc
sptModuleInitCode _ [] = Outputable.empty
sptModuleInitCode this_mod entries = vcat
    [ text "static void hs_spt_init_" <> ppr this_mod
           <> text "(void) __attribute__((constructor));"
    , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"
    , braces $ vcat $
        [  text "static StgWord64 k" <> int i <> text "[2] = "
           <> pprFingerprint fp <> semi
        $$ text "extern StgPtr "
           <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi
        $$ text "hs_spt_insert" <> parens
             (hcat $ punctuate comma
                [ char 'k' <> int i
                , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n))
                ]
             )
        <> semi
        |  (i, SptEntry n fp) <- zip [0..] entries
        ]
    , text "static void hs_spt_fini_" <> ppr this_mod
           <> text "(void) __attribute__((destructor));"
    , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"
    , braces $ vcat $
        [  text "StgWord64 k" <> int i <> text "[2] = "
           <> pprFingerprint fp <> semi
        $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi
        | (i, (SptEntry _ fp)) <- zip [0..] entries
        ]
    ]
  where
    pprFingerprint :: Fingerprint -> SDoc
    pprFingerprint (Fingerprint w1 w2) =
      braces $ hcat $ punctuate comma
                 [ integer (fromIntegral w1) <> text "ULL"
                 , integer (fromIntegral w2) <> text "ULL"
]

Исходная версия MOPKOBKA, :

Не угадал.

Угадал. Твоя очередь. Что это, и что тут происходит?

ptCreateStaticBinds :: HscEnv -> Module -> CoreProgram
                     -> IO ([SptEntry], CoreProgram)
sptCreateStaticBinds hsc_env this_mod binds
    | not (xopt LangExt.StaticPointers dflags) =
      return ([], binds)
    | otherwise = do
      _ <- lookupGlobal hsc_env unpackCStringName
      (fps, binds') <- evalStateT (go [] [] binds) 0
      return (fps, binds')
  where
    go fps bs xs = case xs of
      []        -> return (reverse fps, reverse bs)
      bnd : xs' -> do
        (fps', bnd') <- replaceStaticBind bnd
        go (reverse fps' ++ fps) (bnd' : bs) xs'

    dflags = hsc_dflags hsc_env


    replaceStaticBind :: CoreBind
                      -> StateT Int IO ([SptEntry], CoreBind)
    replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e
                                        return (maybeToList mfp, NonRec b' e')
    replaceStaticBind (Rec rbs) = do
      (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs
      return (catMaybes mfps, Rec rbs')

    replaceStatic :: Id -> CoreExpr
                  -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr))
    replaceStatic b e@(collectTyBinders -> (tvs, e0)) =
      case collectMakeStaticArgs e0 of
        Nothing      -> return (Nothing, (b, e))
        Just (_, t, info, arg) -> do
          (fp, e') <- mkStaticBind t info arg
          return (Just (SptEntry b fp), (b, foldr Lam e' tvs))

    mkStaticBind :: Type -> CoreExpr -> CoreExpr
                 -> StateT Int IO (Fingerprint, CoreExpr)
    mkStaticBind t srcLoc e = do
      i <- get
      put (i + 1)
      staticPtrInfoDataCon <-
        lift $ lookupDataConHscEnv staticPtrInfoDataConName
      let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i
      info <- mkConApp staticPtrInfoDataCon <$>
            (++[srcLoc]) <$>
            mapM (mkStringExprFSWith (lift . lookupIdHscEnv))
                 [ unitIdFS $ moduleUnitId this_mod
                 , moduleNameFS $ moduleName this_mod
                 ]

      staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName
      return (fp, mkConApp staticPtrDataCon
                               [ Type t
                               , mkWord64LitWordRep dflags w0
                               , mkWord64LitWordRep dflags w1
                               , info
                               , e ])

    mkStaticPtrFingerprint :: Int -> Fingerprint
    mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"
        [ unitIdString $ moduleUnitId this_mod
        , moduleNameString $ moduleName this_mod
        , show n
        ]

    mkWord64LitWordRep dflags
      | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64
      | otherwise = mkWordLit dflags . toInteger

    lookupIdHscEnv :: Name -> IO Id
    lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>=
                         maybe (getError n) (return . tyThingId)

    lookupDataConHscEnv :: Name -> IO DataCon
    lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>=
                              maybe (getError n) (return . tyThingDataCon)

    getError n = pprPanic "sptCreateStaticBinds.get: not found" $
      text "Couldn't find" <+> ppr n

sptModuleInitCode :: Module -> [SptEntry] -> SDoc
sptModuleInitCode _ [] = Outputable.empty
sptModuleInitCode this_mod entries = vcat
    [ text "static void hs_spt_init_" <> ppr this_mod
           <> text "(void) __attribute__((constructor));"
    , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"
    , braces $ vcat $
        [  text "static StgWord64 k" <> int i <> text "[2] = "
           <> pprFingerprint fp <> semi
        $$ text "extern StgPtr "
           <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi
        $$ text "hs_spt_insert" <> parens
             (hcat $ punctuate comma
                [ char 'k' <> int i
                , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n))
                ]
             )
        <> semi
        |  (i, SptEntry n fp) <- zip [0..] entries
        ]
    , text "static void hs_spt_fini_" <> ppr this_mod
           <> text "(void) __attribute__((destructor));"
    , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"
    , braces $ vcat $
        [  text "StgWord64 k" <> int i <> text "[2] = "
           <> pprFingerprint fp <> semi
        $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi
        | (i, (SptEntry _ fp)) <- zip [0..] entries
        ]
    ]
  where
    pprFingerprint :: Fingerprint -> SDoc
    pprFingerprint (Fingerprint w1 w2) =
      braces $ hcat $ punctuate comma
                 [ integer (fromIntegral w1) <> text "ULL"
                 , integer (fromIntegral w2) <> text "ULL"
]