История изменений
Исправление 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"
]