├── .gitignore ├── README.md ├── external-stg-compiler ├── LICENSE ├── app │ ├── dce-fullpak.hs │ ├── gen-exe.hs │ ├── gen-exe2.hs │ ├── gen-obj.hs │ ├── gen-obj2.hs │ └── show-ghc-stg.hs ├── cbits │ └── ext-stg-liveness.cpp ├── datalog │ └── ext-stg-liveness.dl ├── external-stg-compiler.cabal └── lib │ └── Stg │ ├── DeadFunctionElimination │ ├── Analysis.hs │ ├── Facts.hs │ └── StripModule.hs │ └── GHC │ ├── Backend.hs │ ├── Convert_9_2.hs │ ├── Convert_9_4.hs │ ├── Convert_9_6.hs │ └── ToStg.hs ├── external-stg-interpreter ├── LICENSE ├── README.md ├── Setup.hs ├── app │ ├── ExtStgInterpreter.hs │ └── RunStgiTestsuite.hs ├── data │ ├── cbits.so-script │ │ ├── c │ │ ├── c-src │ │ │ ├── fake_rts.c │ │ │ ├── hack.c │ │ │ └── hschooks.c │ │ └── cbits-rts.dyn_o │ │ │ ├── StgPrimFloat.dyn_o │ │ │ └── TTY.dyn_o │ ├── ghc-rts-base.fullpak │ └── minigame-strict.fullpak ├── datalog │ ├── README │ ├── debugger │ │ ├── DataSize.dl │ │ ├── GCRoot.dl │ │ ├── RetainedSize.dl │ │ ├── StgState.dl │ │ ├── stat01.dl │ │ └── stat02.dl │ ├── ext-stg-gc.cpp │ └── ext-stg-gc.dl ├── ext-stg-interpreter-notes ├── external-stg-interpreter.cabal ├── lib │ ├── Foreign │ │ └── LibFFI │ │ │ └── Closure.hsc │ └── Stg │ │ ├── Interpreter.hs │ │ ├── Interpreter │ │ ├── Base.hs │ │ ├── Debug.hs │ │ ├── Debugger.hs │ │ ├── Debugger │ │ │ ├── Datalog.hs │ │ │ ├── Internal.hs │ │ │ ├── Region.hs │ │ │ ├── Retainer.hs │ │ │ ├── TraverseState.hs │ │ │ └── UI.hs │ │ ├── EmulatedLibFFI.hs │ │ ├── FFI.hs │ │ ├── GC.hs │ │ ├── GC │ │ │ ├── DeadlockAnalysis.hs │ │ │ ├── GCRef.hs │ │ │ ├── LiveDataAnalysis.hs │ │ │ └── RetainerAnalysis.hs │ │ ├── IOManager.hs │ │ ├── PrimCall.hs │ │ ├── PrimOp │ │ │ ├── Addr.hs │ │ │ ├── Array.hs │ │ │ ├── ArrayArray.hs │ │ │ ├── ByteArray.hs │ │ │ ├── Char.hs │ │ │ ├── Compact.hs │ │ │ ├── Concurrency.hs │ │ │ ├── DelayWait.hs │ │ │ ├── Double.hs │ │ │ ├── Exceptions.hs │ │ │ ├── Float.hs │ │ │ ├── GHCiBytecode.hs │ │ │ ├── InfoTableOrigin.hs │ │ │ ├── Int.hs │ │ │ ├── Int16.hs │ │ │ ├── Int32.hs │ │ │ ├── Int64.hs │ │ │ ├── Int8.hs │ │ │ ├── MVar.hs │ │ │ ├── MiscEtc.hs │ │ │ ├── MutVar.hs │ │ │ ├── Narrowings.hs │ │ │ ├── ObjectLifetime.hs │ │ │ ├── Parallelism.hs │ │ │ ├── Prefetch.hs │ │ │ ├── STM.hs │ │ │ ├── SmallArray.hs │ │ │ ├── StablePointer.hs │ │ │ ├── TagToEnum.hs │ │ │ ├── Unsafe.hs │ │ │ ├── WeakPointer.hs │ │ │ ├── Word.hs │ │ │ ├── Word16.hs │ │ │ ├── Word32.hs │ │ │ ├── Word64.hs │ │ │ └── Word8.hs │ │ ├── Rts.hs │ │ ├── RtsFFI.hs │ │ └── ThreadScheduler.hs │ │ ├── rm-tests.py │ │ └── run-tests.py └── test │ ├── PrimOp │ ├── AddrSpec.hs │ ├── CharSpec.hs │ ├── DoubleSpec.hs │ ├── FloatSpec.hs │ ├── Int16Spec.hs │ ├── Int8Spec.hs │ ├── IntSpec.hs │ ├── NarrowingsSpec.hs │ ├── Word16Spec.hs │ ├── Word8Spec.hs │ └── WordSpec.hs │ └── Spec.hs ├── external-stg-syntax ├── LICENSE ├── README.md ├── Setup.hs ├── external-stg-syntax.cabal └── lib │ └── Stg │ └── Syntax.hs ├── external-stg ├── LICENSE ├── Setup.hs ├── app │ ├── ext-stg.hs │ ├── mkfullpak.hs │ └── stgapp.hs ├── external-stg.cabal └── lib │ └── Stg │ ├── Analysis │ ├── Closure.hs │ ├── ForeignInfo.hs │ └── LiveVariable.hs │ ├── Deconstruct.hs │ ├── Foreign │ ├── Linker.hs │ └── Stubs.hs │ ├── Fullpak.hs │ ├── GHC │ └── Symbols.hs │ ├── IO.hs │ ├── IRLocation.hs │ ├── JSON.hs │ ├── Pretty.hs │ ├── Program.hs │ ├── Reconstruct.hs │ └── Tickish.hs ├── ghc-wpc-testsuite-ci ├── ghc-9.2.7-testsuite.patch ├── hello │ ├── LICENSE │ ├── Main.hs │ └── hello.cabal ├── setup-test-env.sh └── stack.yaml ├── lambda ├── LICENSE ├── app │ ├── catlambda.hs │ ├── mkfacts.hs │ ├── mklampak.hs │ └── strip-fullpak.hs ├── datalog │ ├── AST.dl │ ├── CBy.dl │ ├── CFA.dl │ ├── Check.dl │ ├── Escape-CFA.dl │ ├── Escape-PrimOp-Arrays.dl │ ├── Escape-PrimOp-MVar.dl │ ├── Escape-PrimOp-MutVar.dl │ ├── Escape-PrimOp-STM.dl │ ├── Escape-PrimOp-StablePtr.dl │ ├── Escape-PrimOp-WeakPtr.dl │ ├── Escape.dl │ ├── LVA.dl │ ├── PointsTo.dl │ ├── PrimOp-Arrays.dl │ ├── PrimOp-Bytecode.dl │ ├── PrimOp-CCS.dl │ ├── PrimOp-Compact.dl │ ├── PrimOp-Concurrency.dl │ ├── PrimOp-Exception.dl │ ├── PrimOp-MVar.dl │ ├── PrimOp-MutVar.dl │ ├── PrimOp-Parallelism.dl │ ├── PrimOp-STM.dl │ ├── PrimOp-StablePtr.dl │ ├── PrimOp-TagToEnum.dl │ ├── PrimOp-WeakPtr.dl │ ├── TODO │ ├── c.sh │ ├── called-by-outer.dl │ ├── lambda-datalog2.todo │ ├── main.dl │ ├── non-special-primops │ │ ├── PrimOp-Addr.dl │ │ ├── PrimOp-ByteArray.dl │ │ ├── PrimOp-DelayWait.dl │ │ ├── PrimOp-Etc.dl │ │ ├── PrimOp-Prefetch.dl │ │ └── PrimOp-Unsafe.dl │ └── outer-c.sh ├── lambda.cabal ├── preprocess-ghc-primops │ ├── GHCPrimOps.hs │ ├── Gen.hs │ ├── genprimopcode │ │ ├── Lexer.hs │ │ ├── Parser.hs │ │ ├── ParserM.hs │ │ └── Syntax.hs │ └── ghc-primop-gen.cabal ├── src │ ├── Lambda │ │ ├── Analysis │ │ │ └── ControlFlowAnalysisM.hs │ │ ├── Datalog │ │ │ └── ToDatalog.hs │ │ ├── GHC │ │ │ └── RtsAbstractModel.hs │ │ ├── Lint.hs │ │ ├── Name.hs │ │ ├── Parse.hs │ │ ├── Pretty.hs │ │ ├── Stg │ │ │ ├── FromStg.hs │ │ │ ├── GHCPrimOps.hs │ │ │ └── StripDeadCode.hs │ │ ├── Syntax.hs │ │ ├── TH.hs │ │ ├── Transformation │ │ │ ├── ClosureConversion.hs │ │ │ └── StaticSingleAssignment.hs │ │ └── Util.hs │ └── Transformations │ │ ├── Names.hs │ │ └── Util.hs └── test │ ├── CBySpec.hs │ ├── CFASpec.hs │ ├── ParserSpec.hs │ ├── PrimOpArraySpec.hs │ ├── PrimOpCCSSpec.hs │ ├── PrimOpExceptionSpec.hs │ ├── PrimOpMVarSpec.hs │ ├── PrimOpMutVarSpec.hs │ ├── PrimOpSTMSpec.hs │ ├── PrimOpStablePtrSpec.hs │ ├── PrimOpWeakPtrSpec.hs │ └── Spec.hs ├── stack.yaml └── wpc-plugin ├── CHANGELOG.md ├── external-stg-syntax ├── src └── WPC │ ├── Foreign.hs │ ├── ForeignStubDecls.hs │ ├── GhcStgApp.hs │ ├── GlobalEnv.hs │ ├── Modpak.hs │ ├── Plugin.hs │ ├── StgToExtStg.hs │ ├── Stubs.hs │ └── Yaml.hs ├── stack.yaml └── wpc-plugin.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | **/.stack-work/ 2 | -------------------------------------------------------------------------------- /external-stg-compiler/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020, Csaba Hruska 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Csaba Hruska nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /external-stg-compiler/app/dce-fullpak.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Main where 3 | 4 | import Control.Monad.IO.Class 5 | import Control.Monad 6 | import Control.Concurrent.Async.Pool 7 | 8 | import System.FilePath 9 | import System.Directory 10 | import System.Environment 11 | 12 | import Codec.Archive.Zip 13 | import Codec.Archive.Zip.Unix 14 | 15 | import Stg.IO 16 | import Stg.Syntax 17 | import Stg.Program 18 | import Stg.Reconstruct 19 | import Stg.Deconstruct 20 | 21 | import Stg.DeadFunctionElimination.Facts 22 | import Stg.DeadFunctionElimination.Analysis 23 | import Stg.DeadFunctionElimination.StripModule 24 | 25 | import Data.Maybe 26 | import Data.Binary 27 | 28 | import qualified Data.ByteString.Char8 as BS8 29 | import qualified Data.ByteString.Lazy as BSL 30 | 31 | genProgramDfeFacts :: FilePath -> FilePath -> [String] -> IO () 32 | genProgramDfeFacts dceFactPath fullpakPath modNameList = timeItNamed "fact collection run time" $ do 33 | putStrLn "generate datalog facts for whole stg program dead function elimination" 34 | withTaskGroup 4 $ \g -> do 35 | mapTasks g [ readModpakL fullpakPath (modName modpakStgbinPath) decodeStgbin >>= writeDfeFacts (dceFactPath modName ++ ".stgbin") 36 | | modName <- modNameList 37 | ] 38 | pure () 39 | 40 | main :: IO () 41 | main = do 42 | [fullpakPath] <- getArgs 43 | 44 | appInfo <- readModpakS fullpakPath "app.info" id 45 | let content = lines . BS8.unpack $ appInfo 46 | mods = parseSection content "modules:" 47 | dceFactPath = fullpakPath -<.> "simple-dce-facts" 48 | 49 | -- HINT: cleanup old content 50 | removePathForcibly dceFactPath 51 | createDirectoryIfMissing True dceFactPath 52 | 53 | -- geneate facts 54 | genProgramDfeFacts dceFactPath fullpakPath mods 55 | 56 | -- run analysis 57 | livenessAnalysisLogM [dceFactPath m ++ ".stgbin" | m <- mods] 58 | 59 | let dcefullpakName = fullpakPath -<.> ".dce.fullpak" 60 | putStrLn $ "creating " ++ dcefullpakName 61 | putStrLn "modules:" 62 | 63 | createArchive dcefullpakName $ do 64 | 65 | liveMods <- forM mods $ \modName -> do 66 | strippedMod <- liftIO $ do 67 | putStrLn $ " " ++ modName 68 | let modStgbinName = modName modpakStgbinPath 69 | stgMod <- readModpakL fullpakPath modStgbinName decodeStgbin 70 | 71 | tryStripDeadParts {-modpakName-}"." stgMod -- TODO: fix liveness input name 72 | 73 | case isEmptyModule strippedMod of 74 | True -> pure Nothing 75 | False -> do 76 | let stgBin = BSL.toStrict . encode . deconModule . reconModule . deconModule $ strippedMod 77 | addZstdEntry (modName "module.stgbin") stgBin 78 | pure $ Just modName 79 | 80 | -- top level info 81 | let content = BS8.pack $ unlines 82 | [ "modules:", printSection $ catMaybes liveMods 83 | ] 84 | 85 | addZstdEntry "app.info" content 86 | 87 | addZstdEntry :: FilePath -> BS8.ByteString -> ZipArchive () 88 | addZstdEntry path content = do 89 | e <- mkEntrySelector path 90 | addEntry Zstd content e 91 | setExternalFileAttrs (fromFileMode 0o0644) e 92 | 93 | isEmptyModule :: Module -> Bool 94 | isEmptyModule Module{..} = 95 | null [tc | (u, ml) <- moduleTyCons, u == moduleUnitId, (m, tcl) <- ml, m == moduleName, tc <- tcl] && 96 | null moduleTopBindings && 97 | null moduleForeignFiles && 98 | NoStubs /= moduleForeignStubs 99 | -------------------------------------------------------------------------------- /external-stg-compiler/app/gen-exe2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Main where 3 | 4 | import Data.List.Split 5 | import Control.Monad 6 | import Control.Concurrent.Async.Pool 7 | 8 | import System.FilePath 9 | import System.Directory 10 | import System.Environment 11 | import System.Process 12 | 13 | import Stg.DeadFunctionElimination.Analysis (timeItNamed) 14 | 15 | import Stg.GHC.Backend 16 | import Stg.IO 17 | import Stg.Program 18 | 19 | import qualified GHC.Driver.Types as GHC 20 | import qualified GHC.Utils.Outputable as GHC 21 | 22 | import qualified Data.ByteString.Char8 as BS8 23 | 24 | main :: IO () 25 | main = do 26 | [fullpakPath] <- getArgs 27 | 28 | appInfo <- readModpakS fullpakPath "app.info" id 29 | let content = lines . BS8.unpack $ appInfo 30 | mods = parseSection content "modules:" 31 | objectOutputPath = fullpakPath -<.> ".o" 32 | 33 | removePathForcibly objectOutputPath 34 | createDirectoryIfMissing True objectOutputPath 35 | 36 | putStrLn "compile STG modules" 37 | 38 | let oStg = [objectOutputPath m ++ ".o" | m <- mods] 39 | 40 | timeItNamed "program objects codegen time" $ do 41 | withTaskGroup 4 $ \g -> do 42 | mapTasks g [callProcess "gen-obj2" (fullpakPath : f) | f <- chunksOf 40 mods] 43 | 44 | putStrLn $ "linking exe" 45 | 46 | {- 47 | = StgAppInfo 48 | { appIncludePaths :: [String] 49 | , appLibPaths :: [String] 50 | , appLdOptions :: [String] 51 | , appCLikeObjFiles :: [String] 52 | , appNoHsMain :: Bool 53 | } 54 | -} 55 | -- HINT: `readModpakS` reads from zip files, so it works for .fullpak also 56 | ghcstgappContent <- readModpakS fullpakPath "app.ghc_stgapp" BS8.unpack 57 | let getAppInfoFromString = undefined :: String -> IO StgAppInfo 58 | StgAppInfo{..} <- getAppInfoFromString ghcstgappContent 59 | 60 | putStrLn $ unlines $ "appIncludePaths:" : _appIncludePaths 61 | putStrLn $ unlines $ "appLibPaths:" : _appLibPaths 62 | putStrLn $ unlines $ "appLdOptions:" : _appLdOptions 63 | 64 | let cg = NCG 65 | 66 | print $ "appCLikeObjFiles: " ++ show _appCLikeObjFiles 67 | appCLikeObjFiles' <- forM _appCLikeObjFiles $ \fname -> do 68 | o <- BS8.readFile fname 69 | let newObjName = fname ++ ".o" 70 | BS8.writeFile newObjName o 71 | pure newObjName 72 | print $ "appCLikeObjFiles: " ++ show appCLikeObjFiles' 73 | 74 | compileProgram cg _appNoHsMain _appIncludePaths _appLibPaths _appLdOptions (appCLikeObjFiles' ++ oStg) GHC.NoStubs [] [] 75 | -------------------------------------------------------------------------------- /external-stg-compiler/app/gen-obj.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Main where 3 | 4 | import Control.Monad 5 | import Control.Monad.IO.Class 6 | 7 | import System.Environment 8 | 9 | import Stg.IO 10 | import Stg.GHC.ToStg 11 | import Stg.GHC.Backend 12 | import Stg.DeadFunctionElimination.StripModule 13 | 14 | import qualified GHC.Driver.Types as GHC 15 | 16 | import GHC 17 | import GHC.Paths ( libdir ) 18 | 19 | {- 20 | = StgModule 21 | { stgUnitId :: UnitId 22 | , stgModuleName :: ModuleName 23 | , stgModuleTyCons :: [TyCon] 24 | , stgTopBindings :: [StgTopBinding] 25 | , stgForeignStubs :: ForeignStubs 26 | , stgForeignFiles :: [(ForeignSrcLang, FilePath)] 27 | } 28 | -} 29 | 30 | main :: IO () 31 | main = runGhc (Just libdir) $ do 32 | let cg = NCG 33 | 34 | modpaks <- liftIO getArgs 35 | forM_ modpaks $ \modpakName -> do 36 | extStgModule <- liftIO $ do 37 | putStrLn $ modpakName 38 | readModpakL modpakName modpakStgbinPath decodeStgbin 39 | 40 | strippedExtModule <- liftIO $ tryStripDeadParts {-modpakName-}"." extStgModule -- TODO: fix liveness input name 41 | 42 | let StgModule{..} = toStg strippedExtModule 43 | oName = modpakName ++ ".o" 44 | --liftIO $ putStrLn $ "compiling " ++ oName 45 | --putStrLn $ unlines $ map show stgIdUniqueMap 46 | 47 | -- HINT: the stubs are compiled at link time 48 | compileToObjectM cg stgUnitId stgModuleName GHC.NoStubs stgModuleTyCons stgTopBindings oName 49 | 50 | -- TODO: simplify API to: compileToObject cg stgModule oName 51 | -------------------------------------------------------------------------------- /external-stg-compiler/app/gen-obj2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Main where 3 | 4 | import Control.Monad 5 | import Control.Monad.IO.Class 6 | 7 | import System.Environment 8 | import System.Directory 9 | import System.FilePath 10 | import qualified Data.ByteString.Char8 as BS8 11 | 12 | import Stg.IO 13 | import Stg.GHC.ToStg 14 | import Stg.GHC.Backend 15 | 16 | import qualified GHC.Driver.Types as GHC 17 | 18 | import GHC 19 | import GHC.Paths ( libdir ) 20 | 21 | {- 22 | = StgModule 23 | { stgUnitId :: UnitId 24 | , stgModuleName :: ModuleName 25 | , stgModuleTyCons :: [TyCon] 26 | , stgTopBindings :: [StgTopBinding] 27 | , stgForeignStubs :: ForeignStubs 28 | , stgForeignFiles :: [(ForeignSrcLang, FilePath)] 29 | } 30 | -} 31 | 32 | main :: IO () 33 | main = do 34 | 35 | fullpakPath : mods <- getArgs 36 | 37 | let objectOutputPath = fullpakPath -<.> ".o" 38 | cg = NCG 39 | 40 | runGhc (Just libdir) $ do 41 | forM_ mods $ \modName -> do 42 | let modStgbinName = modName modpakStgbinPath 43 | stgMod <- liftIO $ do 44 | putStrLn $ " " ++ modName 45 | readModpakL fullpakPath modStgbinName decodeStgbin 46 | 47 | let StgModule{..} = toStg stgMod 48 | oName = objectOutputPath modName ++ ".o" 49 | 50 | -- HINT: the stubs are compiled at link time 51 | compileToObjectM cg stgUnitId stgModuleName GHC.NoStubs stgModuleTyCons stgTopBindings oName 52 | -------------------------------------------------------------------------------- /external-stg-compiler/app/show-ghc-stg.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Main where 3 | 4 | import Control.Monad 5 | import Control.Monad.IO.Class 6 | 7 | import System.Environment 8 | 9 | import Stg.IO 10 | import Stg.GHC.ToStg 11 | 12 | import qualified GHC.Stg.Syntax as GHC 13 | import qualified GHC.Utils.Outputable as GHC 14 | import qualified GHC.Driver.Session as GHC 15 | 16 | import GHC.Paths ( libdir ) 17 | import GHC 18 | 19 | showSDoc :: GHC.SDoc -> String 20 | showSDoc = GHC.showSDoc GHC.unsafeGlobalDynFlags 21 | 22 | main :: IO () 23 | main = runGhc (Just libdir) . liftIO $ do 24 | 25 | modpaks <- getArgs 26 | forM_ modpaks $ \modpakName -> do 27 | putStrLn $ "reading " ++ modpakName 28 | extStgModule <- readModpakL modpakName modpakStgbinPath decodeStgbin 29 | let StgModule{..} = toStg extStgModule 30 | putStrLn . showSDoc $ GHC.pprStgTopBindings GHC.panicStgPprOpts stgTopBindings 31 | -------------------------------------------------------------------------------- /external-stg-compiler/datalog/ext-stg-liveness.dl: -------------------------------------------------------------------------------- 1 | .pragma "legacy" 2 | 3 | .symbol_type Name 4 | 5 | // input fatcs 6 | .decl TyCon(tycon:Name, datacon:Name) 7 | .input TyCon 8 | 9 | .decl TyConReference(fun:Name, tycon:Name) 10 | .input TyConReference 11 | 12 | .decl DataConReference(fun:Name, datacon:Name) 13 | .input DataConReference 14 | 15 | .decl FunReference(fun:Name, funref:Name) 16 | .input FunReference 17 | 18 | .decl LiveSource(fun:Name) 19 | .input LiveSource 20 | 21 | // output fatcs 22 | .decl LiveFunName(fun:Name) 23 | .output LiveFunName 24 | 25 | .decl LiveTyConName(tycon:Name) 26 | .output LiveTyConName 27 | 28 | .decl LiveDataConName(datacon:Name) 29 | .output LiveDataConName 30 | 31 | // calculate live functions 32 | LiveFunName(fun) :- 33 | LiveSource(fun). 34 | 35 | LiveFunName(ref) :- 36 | LiveFunName(fun), 37 | FunReference(fun, ref). 38 | 39 | // calculate live data cons 40 | LiveDataConName(fun) :- 41 | LiveSource(fun). 42 | 43 | LiveDataConName(datacon) :- 44 | LiveFunName(fun), 45 | DataConReference(fun, datacon). 46 | 47 | // calculate live type cons 48 | LiveTyConName(tycon) :- 49 | LiveDataConName(datacon), 50 | TyCon(tycon, datacon). 51 | 52 | LiveTyConName(tycon) :- 53 | LiveFunName(fun), 54 | TyConReference(fun, tycon). 55 | 56 | 57 | 58 | // temp hack: keep all datacons live 59 | LiveDataConName(datacon) :- 60 | TyCon(_, datacon). 61 | -------------------------------------------------------------------------------- /external-stg-compiler/lib/Stg/DeadFunctionElimination/StripModule.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, TupleSections, OverloadedStrings #-} 2 | module Stg.DeadFunctionElimination.StripModule where 3 | 4 | import Data.Maybe 5 | import Data.Set (Set) 6 | import qualified Data.Set as Set 7 | import qualified Data.ByteString.Char8 as BS8 8 | 9 | import System.FilePath 10 | import System.Directory 11 | 12 | import Stg.Syntax 13 | 14 | stripDeadParts :: FilePath -> Module -> IO Module 15 | stripDeadParts stgappName mod = do 16 | let liveFunFname = {-stgappName -<.> -}"LiveFunName.csv" 17 | liveDataConFname = {-stgappName -<.> -}"LiveDataConName.csv" 18 | liveFunSet0 <- Set.fromList . BS8.lines <$> BS8.readFile liveFunFname 19 | liveDataConSet <- Set.fromList . BS8.lines <$> BS8.readFile liveDataConFname 20 | let liveFunSet = Set.union liveFunSet0 liveDataConSet 21 | 22 | putStrLn "stripDeadParts" 23 | 24 | let dropDeadBinding :: TopBinding -> Maybe TopBinding 25 | dropDeadBinding tb = case tb of 26 | StgTopLifted (StgNonRec b _) 27 | | Set.member (binderUniqueName b) liveFunSet -> Just tb 28 | | otherwise -> Nothing 29 | 30 | StgTopLifted (StgRec bs) 31 | | lives <- [a | a@(b,_) <- bs, Set.member (binderUniqueName b) liveFunSet] 32 | , not $ null lives 33 | -> Just $ StgTopLifted (StgRec lives) 34 | | otherwise -> Nothing 35 | 36 | StgTopStringLit b l 37 | | Set.member (binderUniqueName b) liveFunSet -> Just tb 38 | | otherwise -> Nothing 39 | 40 | -- TODO: strip stgModuleTyCons 41 | pure mod {moduleTopBindings = catMaybes $ map dropDeadBinding $ moduleTopBindings mod} 42 | 43 | tryStripDeadParts :: FilePath -> Module -> IO Module 44 | tryStripDeadParts stgappName mod = do 45 | let liveFunFname = {-stgappName -<.> -}"LiveFunName.csv" 46 | hasLivenessInfo <- doesFileExist liveFunFname 47 | if hasLivenessInfo 48 | then stripDeadParts stgappName mod 49 | else pure mod 50 | -------------------------------------------------------------------------------- /external-stg-interpreter/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020, Csaba Hruska 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Csaba Hruska nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /external-stg-interpreter/README.md: -------------------------------------------------------------------------------- 1 | # External STG interpreter 2 | 3 | The external STG interpreter is independent from GHC and GHC-WPC, but still can run real Haskell programs. 4 | It is an excellent laboratory to study the runtime behaviour of Haskell programs in detail. 5 | It is like a programmable debugger with good UX/DX. 6 | 7 | ## Setup & Build 8 | 9 | The interpreter was tested only on Linux. 10 | 11 | 1. Clone the project's git mega repository. 12 | ``` 13 | git clone git@github.com:grin-compiler/ghc-whole-program-compiler-project.git 14 | ``` 15 | 2. Build from the interpreter's folder 16 | ``` 17 | cd ghc-whole-program-compiler-project/external-stg-interpreter 18 | 19 | stack install 20 | ``` 21 | 22 | ## Example Usage 23 | 24 | Run the sample hello world program: `ghc-rts-base.fullpak` 25 | The `.fullpak` is a zip file (using Zstd compression) that contains the IR for the whole Haskell program, i.e. *haskell source, core, stg, cmm, asm* 26 | 27 | ``` 28 | cd ghc-whole-program-compiler-project/external-stg-interpreter/data 29 | 30 | ext-stg-interpreter ghc-rts-base.fullpak 31 | hello 32 | hello 33 | ``` 34 | 35 | Check the content of the content of the `ghc-rts-base.fullpak`. 36 | 37 | ### Run in the debugger 38 | 39 | ``` 40 | cd ghc-whole-program-compiler-project/external-stg-interpreter/data 41 | 42 | ext-stg-interpreter -d ghc-rts-base.fullpak 43 | ``` 44 | 45 | Check the list of debugger commands. 46 | 47 | Use the `e` command to do step-by-step evaluation. 48 | 49 | ## Presentation video 50 | - [Why and How the External STG Interpreter is Useful](https://www.youtube.com/watch?v=wt6iCgYmVGA) *([slides](https://docs.google.com/presentation/d/1Lmfpwtx_7TbIAGYnSE0HqkawRu75y2GGwbObuu0xYPY/edit#slide=id.p))* *([demo code](https://github.com/grin-compiler/ext-stg-interpreter-presentation-demos))* 51 | 52 | ## Readings 53 | - [External STG Interpreter](https://www.patreon.com/posts/external-stg-49857800) 54 | 55 | ## UnZip with Zstd support 56 | The `.modpak` and `.fullpak` files use Zstd compression method that was introduced in the Zip 6.3.8 standard in 2020. 57 | The GHC-WPC tooling can handle Zstd zip files out of the box. 58 | But if you'd like to unpack the `.modpak` and `.fullpak` files manually then you'll need an `unzip` version with Zstd support. 59 | https://github.com/csabahruska/unzip-zstd 60 | -------------------------------------------------------------------------------- /external-stg-interpreter/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /external-stg-interpreter/app/ExtStgInterpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, RecordWildCards #-} 2 | 3 | import qualified Control.Concurrent.Chan.Unagi.Bounded as Unagi 4 | import Control.Concurrent.MVar 5 | 6 | import Options.Applicative 7 | import Data.Semigroup ((<>)) 8 | import qualified ShellWords 9 | 10 | import Stg.Interpreter.Debugger.UI 11 | import Stg.Interpreter.Base 12 | import Stg.Interpreter 13 | 14 | data StgIOpts 15 | = StgIOpts 16 | { switchCWD :: Bool 17 | , runDebugger :: Bool 18 | , doTracing :: Bool 19 | , isQuiet :: Bool 20 | , ignoreRtsArgs :: Bool 21 | , dbgScript :: Maybe FilePath 22 | , appArgsFile :: Maybe FilePath 23 | , appArgs1 :: String 24 | , appArgs2 :: [String] 25 | , appPath :: FilePath 26 | , appArgs3 :: [String] 27 | , keepGCFacts :: Bool 28 | } 29 | 30 | stgi :: Parser StgIOpts 31 | stgi = StgIOpts 32 | <$> switch (long "cwd" <> help "Changes the working directory to where the APPFILE is located") 33 | <*> switch (short 'd' <> long "debug" <> help "Enable simple debugger") 34 | <*> switch (short 't' <> long "trace" <> help "Enable tracing") 35 | <*> switch (short 'q' <> long "quiet" <> help "disable debug messages") 36 | <*> switch (long "ignore-rts-args" <> help "ignore arguments between +RTS and -RTS") 37 | <*> (optional $ strOption (long "debug-script" <> metavar "FILENAME" <> help "Run debug commands from file")) 38 | <*> (optional $ strOption (long "args-file" <> metavar "FILENAME" <> help "Get app arguments from file")) 39 | <*> strOption (long "args" <> value "" <> help "Space separated APPARGS") 40 | <*> many (strOption (short 'a' <> help "Single APPARG")) 41 | <*> argument str (metavar "APPFILE" <> help "The .ghc_stgapp or .fullpak file to run") 42 | <*> many (argument str (metavar "APPARG...")) 43 | <*> switch (long "keep-gc-facts" <> help "Keep GC datalog facts in separate folder for each GC cycle") 44 | 45 | main :: IO () 46 | main = do 47 | let opts = info (stgi <**> helper) mempty 48 | StgIOpts{..} <- execParser opts 49 | 50 | argsFromFile <- case appArgsFile of 51 | Nothing -> pure [] 52 | Just fname -> do 53 | str <- readFile fname 54 | case ShellWords.parse str of 55 | Left err -> error err 56 | Right l -> pure l 57 | let appArgs0 = argsFromFile ++ words appArgs1 ++ appArgs2 ++ appArgs3 58 | appArgs = if ignoreRtsArgs then dropRtsOpts appArgs0 else appArgs0 59 | 60 | debugSettings = defaultDebugSettings 61 | { dsKeepGCFacts = keepGCFacts 62 | } 63 | 64 | (dbgAsyncI, dbgAsyncO) <- Unagi.newChan 100 65 | dbgRequestMVar <- newEmptyMVar 66 | dbgResponseMVar <- newEmptyMVar 67 | let dbgChan = DebuggerChan 68 | { dbgSyncRequest = dbgRequestMVar 69 | , dbgSyncResponse = dbgResponseMVar 70 | , dbgAsyncEventIn = dbgAsyncI 71 | , dbgAsyncEventOut = dbgAsyncO 72 | } 73 | 74 | case runDebugger of 75 | True -> debugProgram switchCWD appPath appArgs dbgChan dbgScript debugSettings 76 | False -> loadAndRunProgram isQuiet switchCWD appPath appArgs dbgChan DbgRunProgram doTracing debugSettings 77 | 78 | dropRtsOpts :: [String] -> [String] 79 | dropRtsOpts [] = [] 80 | dropRtsOpts ("+RTS" : args) = dropRtsOpts $ dropWhile (/= "-RTS") args 81 | dropRtsOpts ("-RTS" : args) = dropRtsOpts args 82 | dropRtsOpts (a : args) = a : dropRtsOpts args 83 | -------------------------------------------------------------------------------- /external-stg-interpreter/data/cbits.so-script/c: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -x -e 4 | 5 | gcc -o libHSbase-4.14.0.0.cbits.so -shared \ 6 | -Wl,--whole-archive `ls ar/*.a` -Wl,--no-whole-archive \ 7 | `ls stub-*.dyn_o/*` \ 8 | `ls cbits-rts.dyn_o/*` \ 9 | -fPIC `ls c-src/*` \ 10 | -lm -lgmp -ltinfo \ 11 | -lGL -lX11 -lXi -lXrandr -lXxf86vm -lXcursor -lXinerama -lpthread 12 | -------------------------------------------------------------------------------- /external-stg-interpreter/data/cbits.so-script/c-src/fake_rts.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | unsigned int n_capabilities = 1; 5 | int rts_isDynamic(void) { 6 | return 1; 7 | } 8 | 9 | int rts_isProfiled(void) { 10 | return 0; 11 | } 12 | 13 | void blockUserSignals(void) { 14 | } 15 | 16 | void unblockUserSignals(void) { 17 | } 18 | 19 | void startTimer(void) { 20 | } 21 | 22 | void stopTimer(void) { 23 | } 24 | 25 | void debugBelch() { 26 | } 27 | 28 | typedef struct _RTS_FLAGS { 29 | } RTS_FLAGS; 30 | 31 | RTS_FLAGS RtsFlags; 32 | 33 | int keepCAFs; 34 | 35 | void performGC(void) { 36 | } 37 | 38 | void performMajorGC(void) { 39 | } 40 | 41 | int getRTSStatsEnabled( void ) { 42 | return 0;//RtsFlags.GcFlags.giveStats != NO_GC_STATS; 43 | } 44 | 45 | uint32_t enabled_capabilities = 1; 46 | 47 | int *stable_ptr_table = NULL; 48 | 49 | void base_GHCziTopHandler_runIO_closure(){} 50 | 51 | void stg_interp_constr1_entry() {} 52 | void stg_interp_constr2_entry() {} 53 | void stg_interp_constr3_entry() {} 54 | void stg_interp_constr4_entry() {} 55 | void stg_interp_constr5_entry() {} 56 | void stg_interp_constr6_entry() {} 57 | void stg_interp_constr7_entry() {} 58 | -------------------------------------------------------------------------------- /external-stg-interpreter/data/cbits.so-script/c-src/hack.c: -------------------------------------------------------------------------------- 1 | extern void *set_curterm(void *nterm); 2 | 3 | void totally_hack_1324rewewjrkewhrk() { 4 | 5 | set_curterm((void*)0); 6 | } 7 | 8 | #include 9 | 10 | void totally_hack_1324rewewjrkewhrk_2(double x) { 11 | double d = log1p(x); 12 | } 13 | -------------------------------------------------------------------------------- /external-stg-interpreter/data/cbits.so-script/c-src/hschooks.c: -------------------------------------------------------------------------------- 1 | 2 | void 3 | initGCStatistics(void) 4 | { 5 | } 6 | -------------------------------------------------------------------------------- /external-stg-interpreter/data/cbits.so-script/cbits-rts.dyn_o/StgPrimFloat.dyn_o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/grin-compiler/ghc-whole-program-compiler-project/f4d589b83a236fe118b0ed1872d144ba5a8ac32f/external-stg-interpreter/data/cbits.so-script/cbits-rts.dyn_o/StgPrimFloat.dyn_o -------------------------------------------------------------------------------- /external-stg-interpreter/data/cbits.so-script/cbits-rts.dyn_o/TTY.dyn_o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/grin-compiler/ghc-whole-program-compiler-project/f4d589b83a236fe118b0ed1872d144ba5a8ac32f/external-stg-interpreter/data/cbits.so-script/cbits-rts.dyn_o/TTY.dyn_o -------------------------------------------------------------------------------- /external-stg-interpreter/data/ghc-rts-base.fullpak: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/grin-compiler/ghc-whole-program-compiler-project/f4d589b83a236fe118b0ed1872d144ba5a8ac32f/external-stg-interpreter/data/ghc-rts-base.fullpak -------------------------------------------------------------------------------- /external-stg-interpreter/data/minigame-strict.fullpak: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/grin-compiler/ghc-whole-program-compiler-project/f4d589b83a236fe118b0ed1872d144ba5a8ac32f/external-stg-interpreter/data/minigame-strict.fullpak -------------------------------------------------------------------------------- /external-stg-interpreter/datalog/README: -------------------------------------------------------------------------------- 1 | compile: 2 | souffle -g ext-stg-gc.cpp ext-stg-gc.dl -j 8 3 | -------------------------------------------------------------------------------- /external-stg-interpreter/datalog/debugger/DataSize.dl: -------------------------------------------------------------------------------- 1 | // one data element size 2 | 3 | .decl RefDataSize(r : RefTy, size : unsigned) 4 | 5 | // resources 6 | 7 | // NOTE: size = tag + arity/arg-size 8 | 9 | RefDataSize([r, $R_Array], 1 + size) :- 10 | Array(r, size). 11 | 12 | RefDataSize([r, $R_MutableArray], 1 + size) :- 13 | MutableArray(r, size). 14 | 15 | RefDataSize([r, $R_SmallArray], 1 + size) :- 16 | SmallArray(r, size). 17 | 18 | RefDataSize([r, $R_SmallMutableArray], 1 + size) :- 19 | SmallMutableArray(r, size). 20 | 21 | RefDataSize([r, $R_ArrayArray], 1 + size) :- 22 | ArrayArray(r, size). 23 | 24 | RefDataSize([r, $R_MutableArrayArray], 1 + size) :- 25 | MutableArrayArray(r, size). 26 | 27 | RefDataSize([r, $R_MutVar], 2) :- 28 | MutVar(r, _). 29 | 30 | RefDataSize([r, $R_StablePointer], 2) :- 31 | StablePointer(r, _). 32 | 33 | RefDataSize([r, $R_StableName], 2) :- 34 | StableName(r, _). 35 | 36 | RefDataSize([r, $R_MutableByteArray], 1 + size) :- 37 | MutableByteArray(r, _, _, size). 38 | 39 | RefDataSize([r, $R_MVar], 1 + value_count + queue_size) :- 40 | MVar(r, value_count, queue_size, _). 41 | 42 | RefDataSize([r, $R_WeakPointer], 2 + value_count + finalizer_count + cfinalizer_count) :- 43 | WeakPointer(r, _, value_count, finalizer_count, cfinalizer_count, _). 44 | 45 | // heap 46 | 47 | RefDataSize([r, $R_HeapPtr], 1 + arg_count) :- 48 | Heap_Con(r, _, _, arg_count). 49 | 50 | RefDataSize([r, $R_HeapPtr], 1 + env_count + arg_count) :- 51 | Heap_Closure(r, _, _, env_count, arg_count, _). 52 | 53 | RefDataSize([r, $R_HeapPtr], 2) :- 54 | Heap_BlackHole(r, _). 55 | 56 | RefDataSize([r, $R_HeapPtr], 1 + result_count + stack_count) :- 57 | Heap_ApStack(r, result_count, stack_count). 58 | 59 | RefDataSize([r, $R_HeapPtr], 2) :- 60 | Heap_RaiseException(r, _). 61 | 62 | // thread-id ; NOTE: this is not the thread just its ID, so we calcualte the ID's size not the thread's size 63 | RefDataSize([r, $R_ThreadId], 1) :- 64 | ThreadState(r, _, _, _). 65 | -------------------------------------------------------------------------------- /external-stg-interpreter/datalog/debugger/GCRoot.dl: -------------------------------------------------------------------------------- 1 | 2 | /* 3 | active thread's 4 | stack 5 | current result 6 | 7 | current closure 8 | stable pointers 9 | 10 | static env? 11 | */ 12 | .decl GCRootRef(r : RefTy) 13 | .printsize GCRootRef 14 | 15 | GCRootRef([addr, ns]) :- 16 | StablePointer(_, a), 17 | AtomToRef(a, ns, addr). 18 | 19 | GCRootRef([addr, $R_HeapPtr]) :- 20 | CurrentClosureAddr(addr). 21 | 22 | GCRootRef([addr, ns]) :- 23 | ThreadState(tid, status, _, stackId), 24 | status != "ThreadFinished", 25 | status != "ThreadDied", 26 | ( Stack_ApplyArg(stackId, _, _, a) 27 | ; Stack_CaseOfEnv(stackId, _, _, _, a) 28 | ; Thread_CurrentResult(tid, _, a) 29 | ), 30 | AtomToRef(a, ns, addr). 31 | 32 | /* 33 | GCRootRef([addr, $R_HeapPtr]) :- 34 | HeapStartAddress(addr_heap_start), 35 | AtomToRef(_, $R_HeapPtr, addr), 36 | addr < addr_heap_start. 37 | */ -------------------------------------------------------------------------------- /external-stg-interpreter/datalog/debugger/RetainedSize.dl: -------------------------------------------------------------------------------- 1 | /* 2 | - calculate the spanning tree for the Selected objects + Ref 3 | - calculate ref flows in the spanning tree 4 | - sum size 5 | */ 6 | 7 | .decl RefSpanningTree(parent : RefTy, child : RefTy) choice-domain child // NOTE: a tree-node has only one parent 8 | 9 | RefSpanningTree(nil, x) :- SelectedRoot(x). 10 | RefSpanningTree(v, u) :- RefSpanningTree(_, v), Ref(v, u). 11 | .output RefSpanningTree 12 | 13 | // retained size 14 | 15 | .decl RefRetainedSize(r : RefTy, size : unsigned) choice-domain r 16 | .output RefRetainedSize 17 | 18 | .decl RefRetainedSize2(size : unsigned, r : RefTy) choice-domain r 19 | .output RefRetainedSize2 20 | 21 | RefRetainedSize2(s, r) :- RefRetainedSize(r, s). 22 | 23 | //////////////////// 24 | 25 | // calculate tree size (fast) 26 | 27 | // utility relations to simulate recursive aggregation 28 | 29 | // child ordering 30 | .decl next(parent : RefTy, a : RefTy, b : RefTy) choice-domain (parent, a), (parent, b) 31 | 32 | next(parent, [0, $Analysis], [1, $Analysis]) :- 33 | RefSpanningTree(parent, _). 34 | 35 | next(parent, p, n) :- 36 | next(parent, _, p), 37 | RefSpanningTree(parent, n). 38 | 39 | .decl last(parent : RefTy, a : RefTy) choice-domain parent 40 | 41 | last(parent, n) :- 42 | RefSpanningTree(parent, n), 43 | ! next(parent, n, _). 44 | 45 | .output next, last 46 | 47 | // recursive aggregation using a specific visit order (like a for loop) 48 | 49 | .decl size_accumulator(n : RefTy, v : unsigned) choice-domain n // loop variable 50 | .output size_accumulator 51 | 52 | size_accumulator(n, s) :- 53 | next(_, [1, $Analysis], n), 54 | RefRetainedSize(n, s). 55 | 56 | size_accumulator(n, prev_size + s) :- 57 | next(_, prev, n), 58 | size_accumulator(prev, prev_size), 59 | RefRetainedSize(n, s). 60 | 61 | // inductive case: parent size = parent data size + children size 62 | RefRetainedSize(parent, size + s) :- 63 | last(parent, n), 64 | size_accumulator(n, s), 65 | RefDataSize(parent, size). 66 | 67 | // base case: leaf size = data size 68 | RefRetainedSize(n, size) :- 69 | RefSpanningTree(_, n), 70 | ! RefSpanningTree(n, _), 71 | RefDataSize(n, size). 72 | -------------------------------------------------------------------------------- /external-stg-interpreter/datalog/debugger/stat02.dl: -------------------------------------------------------------------------------- 1 | #include "stat01.dl" 2 | 3 | /* 4 | 4622146 False ghc_GHC.Driver.Types.HscEnv 11 5 | 5130682 False ghc_GHC.Driver.Types.HscEnv 11 6 | 6100443 False ghc_GHC.Driver.Types.HscEnv 11 7 | 7498243 False ghc_GHC.Driver.Types.HscEnv 11 8 | 7983438 False ghc_GHC.Driver.Types.HscEnv 11 9 | 8759092 False ghc_GHC.Driver.Types.HscEnv 11 10 | 9246327 False ghc_GHC.Driver.Types.HscEnv 11 11 | 9741277 False ghc_GHC.Driver.Types.HscEnv 11 12 | 9951760 False ghc_GHC.Driver.Types.HscEnv 11 13 | 9983620 False ghc_GHC.Driver.Types.HscEnv 11 14 | 11551146 False ghc_GHC.Driver.Types.HscEnv 11 15 | 11730042 False ghc_GHC.Driver.Types.HscEnv 11 16 | 12773542 False ghc_GHC.Driver.Types.HscEnv 11 17 | 14819074 False ghc_GHC.Driver.Types.HscEnv 11 18 | 15171636 False ghc_GHC.Driver.Types.HscEnv 11 19 | 15940933 False ghc_GHC.Driver.Types.HscEnv 11 20 | 16431667 False ghc_GHC.Driver.Types.HscEnv 11 21 | 16681033 False ghc_GHC.Driver.Types.HscEnv 11 22 | 16824590 False ghc_GHC.Driver.Types.HscEnv 11 23 | 16900997 False ghc_GHC.Driver.Types.HscEnv 11 24 | 17493360 False ghc_GHC.Driver.Types.HscEnv 11 25 | 19449635 False ghc_GHC.Driver.Types.HscEnv 11 26 | 20044540 False ghc_GHC.Driver.Types.HscEnv 11 27 | 20472383 False ghc_GHC.Driver.Types.HscEnv 11 28 | 21262802 False ghc_GHC.Driver.Types.HscEnv 11 29 | 23050231 False ghc_GHC.Driver.Types.HscEnv 11 30 | 24848801 False ghc_GHC.Driver.Types.HscEnv 11 31 | 24850821 False ghc_GHC.Driver.Types.HscEnv 11 32 | */ 33 | 34 | .decl HscEnv(r : RefTy) 35 | .input HscEnv 36 | .output Selected, SelectedRoot 37 | 38 | SelectedRoot([r, ns]) :- 39 | HscEnv([con, _]), // HscEnv 40 | Heap_ConArg(con, 6, a), 41 | AtomToRef(a, ns, r). 42 | 43 | //SelectedRoot([4622146, $R_HeapPtr]). 44 | Selected(x) :- SelectedTo(x). 45 | 46 | -------------------------------------------------------------------------------- /external-stg-interpreter/datalog/ext-stg-gc.dl: -------------------------------------------------------------------------------- 1 | 2 | // input model 3 | 4 | .decl Reference(from : symbol, to : symbol) 5 | .input Reference 6 | 7 | .decl GCRoot(val : symbol) 8 | .input GCRoot 9 | 10 | // output 11 | 12 | .decl Live(val : symbol) 13 | .output Live 14 | 15 | /* 16 | liveness is detected in two steps to support thread deadlock detection: 17 | step 0: reachability from gc roots, to detect deadlocked threads ; partial liveness result 18 | step 1: mark deadlocked threads as live, because they will be woken up with an exception ; complete liveness result 19 | */ 20 | 21 | // traversal 22 | .decl LiveStep0(val : symbol) 23 | 24 | LiveStep0(ref) :- GCRoot(ref). 25 | 26 | LiveStep0(to) :- 27 | LiveStep0(from), 28 | Reference(from, to). 29 | 30 | // support for deadlock detection: BlockedIndefinitelyOnMVar or BlockedIndefinitelyOnSTM 31 | 32 | .decl MaybeDeadlockingThread(threadId : symbol) 33 | .input MaybeDeadlockingThread 34 | 35 | .decl DeadlockingThread(threadId : symbol) 36 | .output DeadlockingThread 37 | 38 | DeadlockingThread(tid) :- 39 | MaybeDeadlockingThread(tid), 40 | !LiveStep0(tid). 41 | 42 | Live(tid) :- DeadlockingThread(tid). 43 | Live(ref) :- LiveStep0(ref). 44 | Live(to) :- 45 | Live(from), 46 | Reference(from, to). 47 | 48 | 49 | /* 50 | .decl All(val : symbol) 51 | 52 | All(from), 53 | All(to) :- 54 | Reference(from, to). 55 | 56 | All(val) :- 57 | GCRoot(val). 58 | 59 | .decl Dead(val : symbol) 60 | .output Dead 61 | 62 | Dead(val) :- 63 | All(val), 64 | !Live(val). 65 | 66 | 67 | // the inverse of the reference relation, but only for live values 68 | .decl LiveReferredBy(to : symbol, from : symbol) 69 | .output LiveReferredBy 70 | 71 | LiveReferredBy(to, from) :- 72 | Reference(from, to), 73 | Live(from), 74 | Live(to). 75 | */ 76 | 77 | /* 78 | // debug output 79 | .output Reference 80 | .output GCRoot 81 | .output MaybeDeadlockingThread 82 | */ -------------------------------------------------------------------------------- /external-stg-interpreter/ext-stg-interpreter-notes: -------------------------------------------------------------------------------- 1 | stg interpreter state: 2 | stack 3 | unboxed tuples 4 | stack frame = local binders 5 | let no escape?? 6 | heap 7 | stg heap objects? 8 | data constructor 9 | closure object 10 | app node 11 | 12 | NOTE: 13 | only the heap objects are tagged at run-time, atom type observation is not allowed during evaluation! ; use the reptype instead. 14 | 15 | READ: 16 | - Apply.cmm 17 | - StgStdThunks.cmm 18 | 19 | Q: only case forces heap objects?? what about apply? it must progress PAPS and thunks 20 | A: App can force also 21 | 22 | Q: what is the semantic of StgApp? 23 | A: (zero arg = StgVar) 24 | forces saturated closures, stores args otherwise 25 | 26 | Q: are all thunks created at compile time, can a thunk be created at runtime? 27 | A: StgLet is the only source of thunks 28 | 29 | Q: can any heap object turn into a thunk? 30 | A: no, apply always forces if the closure gets saturated 31 | 32 | 33 | TODO: 34 | - refresh unique values to generate globally unique ones 35 | - compile dynlib version of package .cbits 36 | 37 | IDEA: 38 | Implementation method: 39 | first: pure and simple haskell 40 | then: gradually optimize if necessary 41 | 42 | ffi libs: 43 | https://hackage.haskell.org/package/unix-2.7.2.2/docs/System-Posix-DynamicLinker.html 44 | https://hackage.haskell.org/package/rtld 45 | https://www.stackage.org/lts-16.16/package/libffi-0.1 46 | https://wiki.haskell.org/Library/libffi 47 | 48 | Q: what is coercionToken# ? 49 | A: it has VoidRep, it is compiled from coercions. disappears at runtime, 50 | needed to model arity correctly and prevent early closure saturation 51 | 52 | use cases: 53 | use the interpreter as: 54 | debugger 55 | heap visualizer in the browser ; send the state as a json 56 | concolic execution ; concrete and abstract checking strictness or liveness or lifetime, or validate the analysis 57 | check new memory management methods 58 | create ghc typed runtime system model ; synthetize a native implementation in a strictly typed system such as ATS 59 | interpreter as jit compiler ; either typed x86 jit EDSL or luajit or javascript jit or llvmjit 60 | on the fly origin tracking ; stop program and check everything on the source code 61 | maybe the native backend should be automatically calculated from interpreter and not written from scratch at all?? 62 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Foreign/LibFFI/Closure.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving #-} 2 | {- | The internals of the C library libffi -} 3 | module Foreign.LibFFI.Closure where 4 | 5 | #include 6 | 7 | -- low level API import 8 | import Foreign.LibFFI.Internal 9 | import Foreign.Storable 10 | import Foreign.Ptr 11 | import Data.Word 12 | 13 | -- high level API import 14 | import Control.Monad 15 | import Foreign.Marshal.Alloc 16 | import Foreign.Marshal.Array 17 | import Data.List (genericLength) 18 | 19 | -- low level API 20 | 21 | sizeOf_closure :: Int 22 | sizeOf_closure = #size ffi_closure 23 | 24 | type FFI_Impl = Ptr CIF -> Ptr CValue -> Ptr (Ptr CValue) -> Ptr Word8 -> IO () -- cif -> ret storage -> arg value array -> user data -> IO () 25 | 26 | foreign import ccall "wrapper" wrap_FFI_Impl :: FFI_Impl -> IO (FunPtr FFI_Impl) 27 | 28 | foreign import ccall ffi_prep_closure_loc :: Closure -> Ptr CIF -> FunPtr FFI_Impl -> Ptr Word8 -> Entry -> IO C_ffi_status 29 | 30 | newtype Closure = Closure (Ptr Closure) 31 | newtype Entry = Entry (FunPtr Entry) deriving (Eq, Ord, Show, Storable) 32 | 33 | foreign import ccall ffi_closure_alloc :: Int -> Ptr Entry -> IO Closure 34 | foreign import ccall ffi_closure_free :: Closure -> IO () 35 | 36 | -- high level API 37 | 38 | wrapper :: Ptr CType -> [Ptr CType] -> FFI_Impl -> IO (FunPtr a, IO ()) 39 | wrapper cRetType args ffiImpl = do 40 | 41 | {- 42 | TODO: 43 | done - allocate cif 44 | done - setup cif with ffi_prep_cif 45 | done - malloc cif 46 | done - newArray arg types 47 | -} 48 | cTypesPtr <- newArray args 49 | 50 | cif <- mallocBytes sizeOf_cif 51 | statusCif <- ffi_prep_cif cif ffi_default_abi (genericLength args) cRetType cTypesPtr 52 | unless (statusCif == ffi_ok) $ 53 | error "ffi wrapper: ffi_prep_cif failed" 54 | 55 | (Entry p, clo) <- alloca $ \entryPtr -> do 56 | closure <- ffi_closure_alloc sizeOf_closure entryPtr 57 | entry <- peek entryPtr 58 | impl <- wrap_FFI_Impl ffiImpl 59 | statusClo <- ffi_prep_closure_loc closure cif impl nullPtr entry 60 | unless (statusClo == ffi_ok) $ 61 | error "ffi wrapper: ffi_prep_closure_loc failed" 62 | pure (entry, closure) 63 | 64 | let freeFFICall = do 65 | ffi_closure_free clo 66 | free cif 67 | free cTypesPtr 68 | pure () 69 | 70 | pure (castFunPtr p, freeFFICall) 71 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/EmulatedLibFFI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} 2 | module Stg.Interpreter.EmulatedLibFFI where 3 | 4 | ----- FFI experimental 5 | import qualified GHC.Exts as Exts 6 | import qualified Data.ByteString as BS 7 | import qualified Data.ByteString.Internal as BS 8 | 9 | import Foreign.Storable 10 | import Foreign.Ptr 11 | import Foreign.C.Types 12 | import Foreign.C.String 13 | import Data.Word 14 | import Data.Int 15 | import Data.Maybe 16 | import Foreign.Marshal.Alloc 17 | import Foreign.Marshal.Array 18 | import qualified Data.Primitive.ByteArray as BA 19 | ----- 20 | import System.Exit 21 | import System.IO 22 | import System.FilePath 23 | import Text.Printf 24 | 25 | import Data.Time.Clock 26 | 27 | import qualified Data.Text as Text 28 | import qualified Data.Text.Encoding as Text 29 | 30 | import Data.Set (Set) 31 | import qualified Data.Set as Set 32 | import qualified Data.Map as Map 33 | import Data.IntMap (IntMap) 34 | import qualified Data.IntMap as IntMap 35 | 36 | import GHC.Stack 37 | import Control.Monad.State.Strict 38 | import Control.Concurrent.MVar 39 | 40 | import Stg.Syntax 41 | import Stg.Interpreter.Base 42 | import Stg.Interpreter.Debug 43 | 44 | pattern CharV c = Literal (LitChar c) 45 | pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) 46 | pattern Int8V i = IntAtom i -- Literal (LitNumber LitNumInt i) 47 | pattern Int16V i = IntAtom i -- Literal (LitNumber LitNumInt i) 48 | pattern Int32V i = IntAtom i -- Literal (LitNumber LitNumInt i) 49 | pattern Int64V i = IntAtom i -- Literal (LitNumber LitNumInt i) 50 | pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) 51 | pattern Word8V i = WordAtom i -- Literal (LitNumber LitNumWord i) 52 | pattern Word16V i = WordAtom i -- Literal (LitNumber LitNumWord i) 53 | pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) 54 | pattern Word64V i = WordAtom i -- Literal (LitNumber LitNumWord i) 55 | pattern FloatV f = FloatAtom f 56 | pattern DoubleV d = DoubleAtom d 57 | 58 | {-# NOINLINE evalFCallOp #-} 59 | evalFCallOp :: EvalOnNewThread -> ForeignCall -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 60 | evalFCallOp evalOnNewThread fCall@ForeignCall{..} args t _tc = do 61 | --liftIO $ putStrLn $ "[evalFCallOp] " ++ show foreignCTarget ++ " " ++ show args 62 | case foreignCTarget of 63 | 64 | StaticTarget _ "debugBelch2" _ _ 65 | | [PtrAtom (ByteArrayPtr bai1) _, PtrAtom (ByteArrayPtr bai2) _, Void] <- args 66 | -> do 67 | let 68 | showByteArray b = do 69 | ByteArrayDescriptor{..} <- lookupByteArrayDescriptorI b 70 | Text.unpack . Text.decodeUtf8 . BS.pack . filter (/=0) . Exts.toList <$> BA.unsafeFreezeByteArray baaMutableByteArray 71 | formatStr <- showByteArray bai1 72 | value <- showByteArray bai2 73 | liftIO $ do 74 | hPutStr stderr $ printf formatStr value 75 | hFlush stderr 76 | pure [] 77 | 78 | 79 | StaticTarget _ "errorBelch2" _ _ 80 | | [PtrAtom (ByteArrayPtr bai1) _, PtrAtom (ByteArrayPtr bai2) _, Void] <- args 81 | -> do 82 | let 83 | showByteArray b = do 84 | ByteArrayDescriptor{..} <- lookupByteArrayDescriptorI b 85 | Text.unpack . Text.decodeUtf8 . BS.pack . filter (/=0) . Exts.toList <$> BA.unsafeFreezeByteArray baaMutableByteArray 86 | formatStr <- showByteArray bai1 87 | value <- showByteArray bai2 88 | Rts{..} <- gets ssRtsSupport 89 | liftIO $ hPutStrLn stderr $ takeBaseName rtsProgName ++ ": " ++ printf formatStr value 90 | pure [] 91 | StaticTarget _ "errorBelch2" _ _ 92 | -> stgErrorM $ "unsupported StgFCallOp: " ++ show fCall ++ " :: " ++ show t ++ "\n args: " ++ show args 93 | 94 | _ -> stgErrorM $ "unsupported emulation of user StgFCallOp: " ++ show fCall ++ " :: " ++ show t ++ "\n args: " ++ show args 95 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/GC/DeadlockAnalysis.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase #-} 2 | module Stg.Interpreter.GC.DeadlockAnalysis where 3 | 4 | import Control.Monad 5 | import Control.Monad.State 6 | import Data.IntSet (IntSet) 7 | import qualified Data.IntSet as IntSet 8 | import qualified Data.IntMap as IntMap 9 | 10 | import Stg.Interpreter.Base 11 | import qualified Stg.Interpreter.PrimOp.Concurrency as PrimConcurrency 12 | 13 | validateGCThreadResult :: RefSet -> IntSet -> M () 14 | validateGCThreadResult RefSet{..} deadlockedThreadIds = do 15 | 16 | let assertLiveThread tid = when (IntSet.notMember tid rsThreads) $ do 17 | reportThread tid 18 | error $ "internal error - thread should be live: " ++ show tid 19 | 20 | assertLiveOrDeadlocked tid = when (IntSet.notMember tid rsThreads && IntSet.notMember tid deadlockedThreadIds) $ do 21 | reportThread tid 22 | error $ "internal error - thread should be live or deadlocked: " ++ show tid 23 | 24 | stgState <- get 25 | forM_ (IntMap.toList $ ssThreads stgState) $ \(tid, ts) -> case tsStatus ts of 26 | ThreadFinished -> pure () 27 | ThreadDied -> pure () 28 | ThreadRunning -> assertLiveThread tid 29 | ThreadBlocked r -> case r of 30 | BlockedOnMVar{} -> assertLiveOrDeadlocked tid 31 | BlockedOnMVarRead{} -> assertLiveOrDeadlocked tid 32 | BlockedOnBlackHole{} -> assertLiveOrDeadlocked tid 33 | BlockedOnThrowAsyncEx{} -> assertLiveOrDeadlocked tid 34 | BlockedOnSTM{} -> assertLiveOrDeadlocked tid 35 | BlockedOnForeignCall{} -> error "not implemented yet" 36 | BlockedOnRead{} -> assertLiveThread tid 37 | BlockedOnWrite{} -> assertLiveThread tid 38 | BlockedOnDelay{} -> assertLiveThread tid 39 | pure () 40 | 41 | -- the analysis is done in datalog, this code just uses the analysis result 42 | 43 | handleDeadlockedThreads :: IntSet -> M () 44 | handleDeadlockedThreads deadlockedThreadIds = do 45 | Rts{..} <- gets ssRtsSupport 46 | let raiseEx targetTid exception = do 47 | PrimConcurrency.removeFromQueues targetTid 48 | targetTS <- getThreadState targetTid 49 | PrimConcurrency.raiseAsyncEx (tsCurrentResult targetTS) targetTid exception 50 | tsMap <- gets ssThreads 51 | forM_ (reverse $ IntSet.toList deadlockedThreadIds) $ \tid -> do 52 | ts <- getThreadState tid 53 | case tsStatus ts of 54 | ThreadRunning 55 | -- HINT: during async excepion stack unwind, Update frames can wake up threads that were blocking on blackholes 56 | | Just originalTS <- IntMap.lookup tid tsMap 57 | , ThreadBlocked BlockedOnBlackHole{} <- tsStatus originalTS 58 | -> pure () 59 | ThreadBlocked r -> case r of 60 | BlockedOnMVar{} -> raiseEx tid rtsBlockedIndefinitelyOnMVar 61 | BlockedOnMVarRead{} -> raiseEx tid rtsBlockedIndefinitelyOnMVar 62 | BlockedOnBlackHole{} -> raiseEx tid rtsNonTermination 63 | BlockedOnThrowAsyncEx{} -> pure () -- HINT: it might be blocked on other deadlocked thread 64 | BlockedOnSTM{} -> raiseEx tid rtsBlockedIndefinitelyOnSTM 65 | BlockedOnForeignCall{} -> error "not implemented yet" 66 | s -> error $ "internal error - invalid thread state: " ++ show s 67 | s -> error $ "internal error - invalid thread state: " ++ show s 68 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/GC/RetainerAnalysis.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-} 2 | module Stg.Interpreter.GC.RetainerAnalysis where 3 | 4 | import Control.Monad.State 5 | import Data.Set (Set) 6 | import qualified Data.Set as Set 7 | import Data.Map (Map) 8 | import qualified Data.Map as Map 9 | 10 | import System.Directory 11 | import System.FilePath 12 | import Text.Printf 13 | import qualified Data.ByteString.Char8 as BS8 14 | 15 | import Stg.Interpreter.Base 16 | 17 | loadMap :: String -> IO (Map GCSymbol (Set GCSymbol)) 18 | loadMap factPath = do 19 | absFactPath <- makeAbsolute factPath 20 | putStrLn $ "loading: " ++ show absFactPath 21 | refs <- map BS8.words . BS8.lines <$> BS8.readFile absFactPath 22 | pure $ Map.fromListWith Set.union [(GCSymbol to, Set.singleton $ GCSymbol from) | [to, from] <- refs] 23 | 24 | 25 | loadStringSet :: Bool -> String -> IO (Set GCSymbol) 26 | loadStringSet isQuiet factPath = do 27 | absFactPath <- makeAbsolute factPath 28 | unless isQuiet $ do 29 | putStrLn $ "loading: " ++ show absFactPath 30 | Set.fromList . map GCSymbol . BS8.lines <$> BS8.readFile absFactPath 31 | 32 | loadRetainerDb :: M () 33 | loadRetainerDb = pure () 34 | 35 | loadRetainerDb2 :: M () 36 | loadRetainerDb2 = do 37 | gcCycle <- gets ssGCCounter 38 | let factDir = "./.gc-datalog-facts" printf "gc-cycle-%03i" gcCycle 39 | refMap <- liftIO $ loadMap $ factDir "Reference.csv" 40 | retMap <- liftIO $ loadMap $ factDir "LiveReferredBy.csv" 41 | isQuiet <- gets ssIsQuiet 42 | gcRootSet <- liftIO $ loadStringSet isQuiet $ factDir "GCRoot.csv" 43 | modify' $ \s -> s { 44 | ssReferenceMap = refMap 45 | , ssRetainerMap = retMap 46 | , ssGCRootSet = gcRootSet 47 | } 48 | 49 | clearRetanerDb :: M () 50 | clearRetanerDb = do 51 | modify' $ \s -> s { 52 | ssReferenceMap = mempty 53 | , ssRetainerMap = mempty 54 | , ssGCRootSet = Set.empty 55 | } 56 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimCall.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} 2 | module Stg.Interpreter.PrimCall where 3 | 4 | import Control.Monad.State.Strict 5 | import Foreign 6 | 7 | import Stg.Syntax 8 | import Stg.Interpreter.Base 9 | import Stg.Interpreter.PrimOp.Exceptions 10 | 11 | pattern WordV i = WordAtom i 12 | pattern FloatV f = FloatAtom f 13 | pattern DoubleV d = DoubleAtom d 14 | 15 | -- HINT: prim call emulation of .cmm code, because the interpreter FFI does not support Cmm 16 | -- the Cmm code operates on the native memory layout 17 | -- the interpreter uses Haskell data structures for value representation 18 | 19 | -- NOTE: the WordV should contain a 64 bit wide value 20 | 21 | evalPrimCallOp :: PrimCall -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 22 | evalPrimCallOp pCall@(PrimCall primCallTarget primCallUnitId) args t _tc = do 23 | case primCallTarget of 24 | -- stg_raiseDivZZerozh :: State# RealWorld -> (# State# RealWorld, Void# #) 25 | "stg_raiseDivZZerozh" 26 | | [Void] <- args 27 | -> do 28 | Rts{..} <- gets ssRtsSupport 29 | raiseEx rtsDivZeroException 30 | 31 | -- stg_raiseUnderflowzh :: State# RealWorld -> (# State# RealWorld, Void# #) 32 | "stg_raiseUnderflowzh" 33 | | [Void] <- args 34 | -> do 35 | Rts{..} <- gets ssRtsSupport 36 | raiseEx rtsUnderflowException 37 | 38 | -- stg_raiseOverflowzh :: State# RealWorld -> (# State# RealWorld, Void# #) 39 | "stg_raiseOverflowzh" 40 | | [Void] <- args 41 | -> do 42 | Rts{..} <- gets ssRtsSupport 43 | raiseEx rtsOverflowException 44 | 45 | -- stg_getThreadAllocationCounterzh :: State# RealWorld -> (# State# RealWorld, INT64 #) 46 | "stg_getThreadAllocationCounterzh" 47 | | [Void] <- args 48 | -> do 49 | i <- gets ssNextHeapAddr 50 | pure [IntAtom (-i)] 51 | 52 | -- stg_doubleToWord64zh :: Double# -> Word# 53 | "stg_doubleToWord64zh" 54 | | [DoubleV a] <- args 55 | -> do 56 | -- HINT: bit-conversion 57 | w <- liftIO $ with a $ \p -> peek (castPtr p :: Ptr Word64) 58 | pure [WordV $ fromIntegral w] 59 | 60 | -- stg_floatToWord32zh :: Float# -> Word# 61 | "stg_floatToWord32zh" 62 | | [FloatV a] <- args 63 | -> do 64 | -- HINT: bit-conversion 65 | w <- liftIO $ with a $ \p -> peek (castPtr p :: Ptr Word32) 66 | pure [WordV $ fromIntegral w] 67 | 68 | -- stg_word32ToFloatzh :: Word# -> Float# 69 | "stg_word32ToFloatzh" 70 | | [WordV a] <- args 71 | -> do 72 | -- HINT: bit-conversion 73 | f <- liftIO $ with (fromIntegral a :: Word32) $ \p -> peek (castPtr p :: Ptr Float) 74 | pure [FloatV f] 75 | 76 | -- stg_word64ToDoublezh :: Word# -> Double# 77 | "stg_word64ToDoublezh" 78 | | [WordV a] <- args 79 | -> do 80 | -- HINT: bit-conversion 81 | d <- liftIO $ with (fromIntegral a :: Word64) $ \p -> peek (castPtr p :: Ptr Double) 82 | pure [DoubleV d] 83 | 84 | 85 | _ -> stgErrorM $ "unsupported StgPrimCallOp: " ++ show pCall ++ " :: " ++ show t ++ "\n args: " ++ show args 86 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Char.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} 2 | module Stg.Interpreter.PrimOp.Char where 3 | 4 | import Data.Char 5 | 6 | import Stg.Syntax 7 | import Stg.Interpreter.Base 8 | 9 | pattern CharV c = Literal (LitChar c) 10 | pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) 11 | pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) 12 | pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) 13 | 14 | evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 15 | evalPrimOp fallback op args t tc = case (op, args) of 16 | 17 | -- gtChar# :: Char# -> Char# -> Int# 18 | ( "gtChar#", [CharV a, CharV b]) -> pure [IntV $ if a > b then 1 else 0] 19 | 20 | -- geChar# :: Char# -> Char# -> Int# 21 | ( "geChar#", [CharV a, CharV b]) -> pure [IntV $ if a >= b then 1 else 0] 22 | 23 | -- eqChar# :: Char# -> Char# -> Int# 24 | ( "eqChar#", [CharV a, CharV b]) -> pure [IntV $ if a == b then 1 else 0] 25 | 26 | -- neChar# :: Char# -> Char# -> Int# 27 | ( "neChar#", [CharV a, CharV b]) -> pure [IntV $ if a /= b then 1 else 0] 28 | 29 | -- ltChar# :: Char# -> Char# -> Int# 30 | ( "ltChar#", [CharV a, CharV b]) -> pure [IntV $ if a < b then 1 else 0] 31 | 32 | -- leChar# :: Char# -> Char# -> Int# 33 | ( "leChar#", [CharV a, CharV b]) -> pure [IntV $ if a <= b then 1 else 0] 34 | 35 | -- ord# :: Char# -> Int# 36 | ( "ord#", [CharV c]) -> pure [IntV . fromIntegral $ ord c] 37 | 38 | _ -> fallback op args t tc 39 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimOp/DelayWait.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} 2 | module Stg.Interpreter.PrimOp.DelayWait where 3 | 4 | import Control.Monad.State 5 | import Data.Time.Clock 6 | import Data.Fixed 7 | 8 | import Stg.Syntax 9 | import Stg.Interpreter.Base 10 | 11 | pattern IntV i = IntAtom i 12 | 13 | {- 14 | NOTE: 15 | these primops are only used by programs that are linked with the non-concurrent RTS 16 | in the multithreded RTS mode they are not used / invalid (in the GHC implementation) 17 | this is an ugly design, needs to be fixed in the future! 18 | -} 19 | 20 | evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 21 | evalPrimOp fallback op args t tc = case (op, args) of 22 | 23 | -- delay# :: Int# -> State# s -> State# s 24 | ( "delay#", [IntV usDelay, _s]) -> do 25 | -- safety check 26 | ts@ThreadState{..} <- getCurrentThreadState 27 | unless (tsStatus == ThreadRunning) $ 28 | error $ "expected running thread status, but got: " ++ show tsStatus 29 | 30 | -- calculate target time 31 | t0 <- liftIO getCurrentTime 32 | let delayTime = secondsToNominalDiffTime $ (fromIntegral usDelay :: Pico) / 1000000 33 | targetTime = addUTCTime delayTime t0 34 | 35 | -- set blocked reason 36 | tid <- gets ssCurrentThreadId 37 | updateThreadState tid (ts {tsStatus = ThreadBlocked $ BlockedOnDelay targetTime}) 38 | --liftIO $ putStrLn $ show tid ++ " (blocked) delay# " ++ show args 39 | 40 | -- reschedule threads 41 | stackPush $ RunScheduler SR_ThreadBlocked 42 | pure [] 43 | 44 | -- waitRead# :: Int# -> State# s -> State# s 45 | ( "waitRead#", [IntV fd, _s]) -> do 46 | -- safety check 47 | ts@ThreadState{..} <- getCurrentThreadState 48 | unless (tsStatus == ThreadRunning) $ 49 | error $ "expected running thread status, but got: " ++ show tsStatus 50 | 51 | -- set blocked reason 52 | tid <- gets ssCurrentThreadId 53 | updateThreadState tid (ts {tsStatus = ThreadBlocked $ BlockedOnRead fd}) 54 | --liftIO $ putStrLn $ show tid ++ " (blocked) waitRead# " ++ show args 55 | 56 | -- reschedule threads 57 | stackPush $ RunScheduler SR_ThreadBlocked 58 | pure [] 59 | 60 | -- waitWrite# :: Int# -> State# s -> State# s 61 | ( "waitWrite#", [IntV fd, _s]) -> do 62 | -- safety check 63 | ts@ThreadState{..} <- getCurrentThreadState 64 | unless (tsStatus == ThreadRunning) $ 65 | error $ "expected running thread status, but got: " ++ show tsStatus 66 | 67 | -- set blocked reason 68 | tid <- gets ssCurrentThreadId 69 | updateThreadState tid (ts {tsStatus = ThreadBlocked $ BlockedOnWrite fd}) 70 | --liftIO $ putStrLn $ show tid ++ " (blocked) waitWrite# " ++ show args 71 | 72 | -- reschedule threads 73 | stackPush $ RunScheduler SR_ThreadBlocked 74 | pure [] 75 | 76 | _ -> fallback op args t tc 77 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimOp/GHCiBytecode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-} 2 | module Stg.Interpreter.PrimOp.GHCiBytecode where 3 | 4 | import Stg.Syntax 5 | import Stg.Interpreter.Base 6 | 7 | evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 8 | evalPrimOp fallback op args t tc = case (op, args) of 9 | 10 | _ -> fallback op args t tc 11 | 12 | {- 13 | ------------------------------------------------------------------------ 14 | section "Bytecode operations" 15 | {Support for manipulating bytecode objects used by the interpreter and 16 | linker. 17 | 18 | Bytecode objects are heap objects which represent top-level bindings and 19 | contain a list of instructions and data needed by these instructions.} 20 | ------------------------------------------------------------------------ 21 | 22 | primtype BCO 23 | { Primitive bytecode type. } 24 | 25 | primop AddrToAnyOp "addrToAny#" GenPrimOp 26 | Addr# -> (# a #) 27 | { Convert an {\tt Addr\#} to a followable Any type. } 28 | with 29 | code_size = 0 30 | 31 | primop AnyToAddrOp "anyToAddr#" GenPrimOp 32 | a -> State# RealWorld -> (# State# RealWorld, Addr# #) 33 | { Retrieve the address of any Haskell value. This is 34 | essentially an {\texttt unsafeCoerce\#}, but if implemented as such 35 | the core lint pass complains and fails to compile. 36 | As a primop, it is opaque to core/stg, and only appears 37 | in cmm (where the copy propagation pass will get rid of it). 38 | Note that "a" must be a value, not a thunk! It's too late 39 | for strictness analysis to enforce this, so you're on your 40 | own to guarantee this. Also note that {\texttt Addr\#} is not a GC 41 | pointer - up to you to guarantee that it does not become 42 | a dangling pointer immediately after you get it.} 43 | with 44 | code_size = 0 45 | 46 | primop MkApUpd0_Op "mkApUpd0#" GenPrimOp 47 | BCO -> (# a #) 48 | { Wrap a BCO in a {\tt AP_UPD} thunk which will be updated with the value of 49 | the BCO when evaluated. } 50 | with 51 | out_of_line = True 52 | 53 | primop NewBCOOp "newBCO#" GenPrimOp 54 | ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) 55 | { {\tt newBCO\# instrs lits ptrs arity bitmap} creates a new bytecode object. The 56 | resulting object encodes a function of the given arity with the instructions 57 | encoded in {\tt instrs}, and a static reference table usage bitmap given by 58 | {\tt bitmap}. } 59 | with 60 | has_side_effects = True 61 | out_of_line = True 62 | 63 | primop UnpackClosureOp "unpackClosure#" GenPrimOp 64 | a -> (# Addr#, ByteArray#, Array# b #) 65 | { {\tt unpackClosure\# closure} copies the closure and pointers in the 66 | payload of the given closure into two new arrays, and returns a pointer to 67 | the first word of the closure's info table, a non-pointer array for the raw 68 | bytes of the closure, and a pointer array for the pointers in the payload. } 69 | with 70 | out_of_line = True 71 | 72 | primop ClosureSizeOp "closureSize#" GenPrimOp 73 | a -> Int# 74 | { {\tt closureSize\# closure} returns the size of the given closure in 75 | machine words. } 76 | with 77 | out_of_line = True 78 | 79 | primop GetApStackValOp "getApStackVal#" GenPrimOp 80 | a -> Int# -> (# Int#, b #) 81 | with 82 | out_of_line = True 83 | -} -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimOp/InfoTableOrigin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} 2 | module Stg.Interpreter.PrimOp.InfoTableOrigin where 3 | 4 | import Foreign.Ptr 5 | 6 | import Stg.Syntax 7 | import Stg.Interpreter.Base 8 | 9 | evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 10 | evalPrimOp fallback op args t tc = case (op, args) of 11 | 12 | -- whereFrom# :: a -> State# s -> (# State# s, Addr# #) 13 | ( "whereFrom#", [_a, _s]) -> pure [PtrAtom InfoTablePtr nullPtr] 14 | 15 | _ -> fallback op args t tc 16 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int32.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} 2 | module Stg.Interpreter.PrimOp.Int32 where 3 | 4 | import Stg.Syntax 5 | import Stg.Interpreter.Base 6 | 7 | import Data.Int 8 | import Data.Word 9 | import Data.Bits 10 | 11 | pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) 12 | pattern Int32V i = IntAtom i -- Literal (LitNumber LitNumInt i) 13 | pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) 14 | pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) 15 | 16 | evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 17 | evalPrimOp fallback op args t tc = do 18 | let 19 | i32 = fromIntegral :: Int -> Int32 20 | i = fromIntegral :: Int32 -> Int 21 | case (op, args) of 22 | 23 | -- int32ToInt# :: Int32# -> Int# 24 | ( "int32ToInt#", [Int32V a]) -> pure [IntV a] 25 | 26 | -- intToInt32# :: Int# -> Int32# 27 | ( "intToInt32#", [IntV a]) -> pure [Int32V . i $ i32 a] 28 | 29 | -- negateInt32# :: Int32# -> Int32# 30 | ( "negateInt32#", [Int32V a]) -> pure [Int32V . i . negate $ i32 a] 31 | 32 | -- plusInt32# :: Int32# -> Int32# -> Int32# 33 | ( "plusInt32#", [Int32V a, Int32V b]) -> pure [Int32V . i $ i32 a + i32 b] 34 | 35 | -- subInt32# :: Int32# -> Int32# -> Int32# 36 | ( "subInt32#", [Int32V a, Int32V b]) -> pure [Int32V . i $ i32 a - i32 b] 37 | 38 | -- timesInt32# :: Int32# -> Int32# -> Int32# 39 | ( "timesInt32#", [Int32V a, Int32V b]) -> pure [Int32V . i $ i32 a * i32 b] 40 | 41 | -- quotInt32# :: Int32# -> Int32# -> Int32# 42 | ( "quotInt32#", [Int32V a, Int32V b]) -> pure [Int32V . i $ i32 a `quot` i32 b] -- NOTE: int32 / int32 in C 43 | 44 | -- remInt32# :: Int32# -> Int32# -> Int32# 45 | ( "remInt32#", [Int32V a, Int32V b]) -> pure [Int32V . i $ i32 a `rem` i32 b] -- NOTE: int32 % int32 in C 46 | 47 | -- quotRemInt32# :: Int32# -> Int32# -> (# Int32#, Int32# #) 48 | ( "quotRemInt32#", [Int32V a, Int32V b]) -> pure [Int32V . i $ i32 a `quot` i32 b, Int32V . i $ i32 a `rem` i32 b] 49 | 50 | -- uncheckedShiftLInt32# :: Int32# -> Int# -> Int32# 51 | ( "uncheckedShiftLInt32#", [Int32V a, IntV b]) -> pure [Int32V . i $ unsafeShiftL (i32 a) b] 52 | 53 | -- uncheckedShiftRAInt32# :: Int32# -> Int# -> Int32# 54 | ( "uncheckedShiftRAInt32#", [Int32V a, IntV b]) -> pure [Int32V . i $ unsafeShiftR (i32 a) b] -- Shift right arithmetic 55 | 56 | -- uncheckedShiftRLInt32# :: Int32# -> Int# -> Int32# 57 | ( "uncheckedShiftRLInt32#", [Int32V a, IntV b]) -> pure [Int32V $ fromIntegral $ unsafeShiftR (fromIntegral a :: Word32) b] -- Shift right logical 58 | 59 | -- int32ToWord32# :: Int32# -> Word32# 60 | ( "int32ToWord32#", [Int32V a]) -> pure [Word32V $ fromIntegral a] 61 | 62 | -- eqInt32# :: Int32# -> Int32# -> Int# 63 | ( "eqInt32#", [Int32V a, Int32V b]) -> pure [IntV $ if a == b then 1 else 0] 64 | 65 | -- geInt32# :: Int32# -> Int32# -> Int# 66 | ( "geInt32#", [Int32V a, Int32V b]) -> pure [IntV $ if a >= b then 1 else 0] 67 | 68 | -- gtInt32# :: Int32# -> Int32# -> Int# 69 | ( "gtInt32#", [Int32V a, Int32V b]) -> pure [IntV $ if a > b then 1 else 0] 70 | 71 | -- leInt32# :: Int32# -> Int32# -> Int# 72 | ( "leInt32#", [Int32V a, Int32V b]) -> pure [IntV $ if a <= b then 1 else 0] 73 | 74 | -- ltInt32# :: Int32# -> Int32# -> Int# 75 | ( "ltInt32#", [Int32V a, Int32V b]) -> pure [IntV $ if a < b then 1 else 0] 76 | 77 | -- neInt32# :: Int32# -> Int32# -> Int# 78 | ( "neInt32#", [Int32V a, Int32V b]) -> pure [IntV $ if a /= b then 1 else 0] 79 | 80 | _ -> fallback op args t tc 81 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int64.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} 2 | module Stg.Interpreter.PrimOp.Int64 where 3 | 4 | import Stg.Syntax 5 | import Stg.Interpreter.Base 6 | 7 | import Data.Int 8 | import Data.Word 9 | import Data.Bits 10 | 11 | pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) 12 | pattern Int64V i = IntAtom i -- Literal (LitNumber LitNumInt i) 13 | pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) 14 | pattern Word64V i = WordAtom i -- Literal (LitNumber LitNumWord i) 15 | 16 | evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 17 | evalPrimOp fallback op args t tc = do 18 | let 19 | i64 = fromIntegral :: Int -> Int64 20 | i = fromIntegral :: Int64 -> Int 21 | case (op, args) of 22 | 23 | -- int64ToInt# :: Int64# -> Int# 24 | ( "int64ToInt#", [Int64V a]) -> pure [IntV a] 25 | 26 | -- intToInt64# :: Int# -> Int64# 27 | ( "intToInt64#", [IntV a]) -> pure [Int64V . i $ i64 a] 28 | 29 | -- negateInt64# :: Int64# -> Int64# 30 | ( "negateInt64#", [Int64V a]) -> pure [Int64V . i . negate $ i64 a] 31 | 32 | -- plusInt64# :: Int64# -> Int64# -> Int64# 33 | ( "plusInt64#", [Int64V a, Int64V b]) -> pure [Int64V . i $ i64 a + i64 b] 34 | 35 | -- subInt64# :: Int64# -> Int64# -> Int64# 36 | ( "subInt64#", [Int64V a, Int64V b]) -> pure [Int64V . i $ i64 a - i64 b] 37 | 38 | -- timesInt64# :: Int64# -> Int64# -> Int64# 39 | ( "timesInt64#", [Int64V a, Int64V b]) -> pure [Int64V . i $ i64 a * i64 b] 40 | 41 | -- quotInt64# :: Int64# -> Int64# -> Int64# 42 | ( "quotInt64#", [Int64V a, Int64V b]) -> pure [Int64V . i $ i64 a `quot` i64 b] -- NOTE: int64 / int64 in C 43 | 44 | -- remInt64# :: Int64# -> Int64# -> Int64# 45 | ( "remInt64#", [Int64V a, Int64V b]) -> pure [Int64V . i $ i64 a `rem` i64 b] -- NOTE: int64 % int64 in C 46 | 47 | -- uncheckedIShiftL64# :: Int64# -> Int# -> Int64# 48 | ( "uncheckedIShiftL64#", [Int64V a, IntV b]) -> pure [Int64V . i $ unsafeShiftL (i64 a) b] 49 | 50 | -- uncheckedIShiftRA64# :: Int64# -> Int# -> Int64# 51 | ( "uncheckedIShiftRA64#", [Int64V a, IntV b]) -> pure [Int64V . i $ unsafeShiftR (i64 a) b] -- Shift right arithmetic 52 | 53 | -- uncheckedIShiftRL64# :: Int64# -> Int# -> Int64# 54 | ( "uncheckedIShiftRL64#", [Int64V a, IntV b]) -> pure [Int64V $ fromIntegral $ unsafeShiftR (fromIntegral a :: Word64) b] -- Shift right logical 55 | 56 | -- int64ToWord64# :: Int64# -> Word64# 57 | ( "int64ToWord64#", [Int64V a]) -> pure [Word64V $ fromIntegral a] 58 | 59 | -- eqInt64# :: Int64# -> Int64# -> Int# 60 | ( "eqInt64#", [Int64V a, Int64V b]) -> pure [IntV $ if a == b then 1 else 0] 61 | 62 | -- geInt64# :: Int64# -> Int64# -> Int# 63 | ( "geInt64#", [Int64V a, Int64V b]) -> pure [IntV $ if a >= b then 1 else 0] 64 | 65 | -- gtInt64# :: Int64# -> Int64# -> Int# 66 | ( "gtInt64#", [Int64V a, Int64V b]) -> pure [IntV $ if a > b then 1 else 0] 67 | 68 | -- leInt64# :: Int64# -> Int64# -> Int# 69 | ( "leInt64#", [Int64V a, Int64V b]) -> pure [IntV $ if a <= b then 1 else 0] 70 | 71 | -- ltInt64# :: Int64# -> Int64# -> Int# 72 | ( "ltInt64#", [Int64V a, Int64V b]) -> pure [IntV $ if a < b then 1 else 0] 73 | 74 | -- neInt64# :: Int64# -> Int64# -> Int# 75 | ( "neInt64#", [Int64V a, Int64V b]) -> pure [IntV $ if a /= b then 1 else 0] 76 | 77 | _ -> fallback op args t tc 78 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Int8.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} 2 | module Stg.Interpreter.PrimOp.Int8 where 3 | 4 | import Stg.Syntax 5 | import Stg.Interpreter.Base 6 | 7 | import Data.Int 8 | import Data.Word 9 | import Data.Bits 10 | 11 | pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) 12 | pattern Int8V i = IntAtom i -- Literal (LitNumber LitNumInt i) 13 | pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) 14 | pattern Word8V i = WordAtom i -- Literal (LitNumber LitNumWord i) 15 | 16 | evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 17 | evalPrimOp fallback op args t tc = do 18 | let 19 | i8 = fromIntegral :: Int -> Int8 20 | i = fromIntegral :: Int8 -> Int 21 | case (op, args) of 22 | 23 | -- int8ToInt# :: Int8# -> Int# 24 | ( "int8ToInt#", [Int8V a]) -> pure [IntV a] 25 | 26 | -- intToInt8# :: Int# -> Int8# 27 | ( "intToInt8#", [IntV a]) -> pure [Int8V . i $ i8 a] 28 | 29 | -- negateInt8# :: Int8# -> Int8# 30 | ( "negateInt8#", [Int8V a]) -> pure [Int8V . i . negate $ i8 a] 31 | 32 | -- plusInt8# :: Int8# -> Int8# -> Int8# 33 | ( "plusInt8#", [Int8V a, Int8V b]) -> pure [Int8V . i $ i8 a + i8 b] 34 | 35 | -- subInt8# :: Int8# -> Int8# -> Int8# 36 | ( "subInt8#", [Int8V a, Int8V b]) -> pure [Int8V . i $ i8 a - i8 b] 37 | 38 | -- timesInt8# :: Int8# -> Int8# -> Int8# 39 | ( "timesInt8#", [Int8V a, Int8V b]) -> pure [Int8V . i $ i8 a * i8 b] 40 | 41 | -- quotInt8# :: Int8# -> Int8# -> Int8# 42 | ( "quotInt8#", [Int8V a, Int8V b]) -> pure [Int8V . i $ i8 a `quot` i8 b] -- NOTE: int8 / int8 in C 43 | 44 | -- remInt8# :: Int8# -> Int8# -> Int8# 45 | ( "remInt8#", [Int8V a, Int8V b]) -> pure [Int8V . i $ i8 a `rem` i8 b] -- NOTE: int8 % int8 in C 46 | 47 | -- quotRemInt8# :: Int8# -> Int8# -> (# Int8#, Int8# #) 48 | ( "quotRemInt8#", [Int8V a, Int8V b]) -> pure [Int8V . i $ i8 a `quot` i8 b, Int8V . i $ i8 a `rem` i8 b] 49 | 50 | -- uncheckedShiftLInt8# :: Int8# -> Int# -> Int8# 51 | ( "uncheckedShiftLInt8#", [Int8V a, IntV b]) -> pure [Int8V . i $ unsafeShiftL (i8 a) b] 52 | 53 | -- uncheckedShiftRAInt8# :: Int8# -> Int# -> Int8# 54 | ( "uncheckedShiftRAInt8#", [Int8V a, IntV b]) -> pure [Int8V . i $ unsafeShiftR (i8 a) b] -- Shift right arithmetic 55 | 56 | -- uncheckedShiftRLInt8# :: Int8# -> Int# -> Int8# 57 | ( "uncheckedShiftRLInt8#", [Int8V a, IntV b]) -> pure [Int8V . fromIntegral $ unsafeShiftR (fromIntegral a :: Word8) b] -- Shift right logical 58 | 59 | -- int8ToWord8# :: Int8# -> Word8# 60 | ( "int8ToWord8#", [Int8V a]) -> pure [Word8V $ fromIntegral a] 61 | 62 | -- eqInt8# :: Int8# -> Int8# -> Int# 63 | ( "eqInt8#", [Int8V a, Int8V b]) -> pure [IntV $ if a == b then 1 else 0] 64 | 65 | -- geInt8# :: Int8# -> Int8# -> Int# 66 | ( "geInt8#", [Int8V a, Int8V b]) -> pure [IntV $ if a >= b then 1 else 0] 67 | 68 | -- gtInt8# :: Int8# -> Int8# -> Int# 69 | ( "gtInt8#", [Int8V a, Int8V b]) -> pure [IntV $ if a > b then 1 else 0] 70 | 71 | -- leInt8# :: Int8# -> Int8# -> Int# 72 | ( "leInt8#", [Int8V a, Int8V b]) -> pure [IntV $ if a <= b then 1 else 0] 73 | 74 | -- ltInt8# :: Int8# -> Int8# -> Int# 75 | ( "ltInt8#", [Int8V a, Int8V b]) -> pure [IntV $ if a < b then 1 else 0] 76 | 77 | -- neInt8# :: Int8# -> Int8# -> Int# 78 | ( "neInt8#", [Int8V a, Int8V b]) -> pure [IntV $ if a /= b then 1 else 0] 79 | 80 | -- OBSOLETE from GHC 9.2 81 | -- extendInt8# :: Int8# -> Int# 82 | ( "extendInt8#", [Int8V a]) -> pure [IntV a] 83 | 84 | -- OBSOLETE from GHC 9.2 85 | -- narrowInt8# :: Int# -> Int8# 86 | ( "narrowInt8#", [IntV a]) -> pure [Int8V . i $ i8 a] 87 | 88 | _ -> fallback op args t tc 89 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimOp/MutVar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} 2 | module Stg.Interpreter.PrimOp.MutVar where 3 | 4 | import Control.Monad.State 5 | import qualified Data.IntMap as IntMap 6 | 7 | import Stg.Syntax 8 | import Stg.Interpreter.Base 9 | 10 | pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) 11 | pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) 12 | pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) 13 | 14 | evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 15 | evalPrimOp fallback op args t tc = case (op, args) of 16 | 17 | -- newMutVar# :: a -> State# s -> (# State# s, MutVar# s a #) 18 | ( "newMutVar#", [a, _s]) -> do 19 | mutVars <- gets ssMutVars 20 | next <- gets ssNextMutVar 21 | modify' $ \s -> s {ssMutVars = IntMap.insert next a mutVars, ssNextMutVar = succ next} 22 | pure [MutVar next] 23 | 24 | -- readMutVar# :: MutVar# s a -> State# s -> (# State# s, a #) 25 | ( "readMutVar#", [MutVar m, _s]) -> do 26 | a <- lookupMutVar m 27 | pure [a] 28 | 29 | -- writeMutVar# :: MutVar# s a -> a -> State# s -> State# s 30 | ( "writeMutVar#", [MutVar m, a, _s]) -> do 31 | _ <- lookupMutVar m -- check existence 32 | modify' $ \s@StgState{..} -> s {ssMutVars = IntMap.insert m a ssMutVars} 33 | pure [] 34 | 35 | -- atomicModifyMutVar2# :: MutVar# s a -> (a -> c) -> State# s -> (# State# s, a, c #) 36 | ( "atomicModifyMutVar2#", [MutVar m, fun, _s]) -> do 37 | Rts{..} <- gets ssRtsSupport 38 | -- NOTE: CPU atomic 39 | old <- lookupMutVar m 40 | 41 | -- transform through fun, get a pair result 42 | apFun <- readHeapClosure rtsApplyFun1Arg 43 | lazyNewTup2Value <- HeapPtr <$> allocAndStore (apFun {hoCloArgs = [fun, old], hoCloMissing = 0}) 44 | 45 | -- get the first value of the pair 46 | tup2Prj0 <- readHeapClosure rtsTuple2Proj0 47 | lazyNewMutVarValue <- HeapPtr <$> allocAndStore (tup2Prj0 {hoCloArgs = [lazyNewTup2Value], hoCloMissing = 0}) 48 | 49 | -- update mutvar 50 | modify' $ \s@StgState{..} -> s {ssMutVars = IntMap.insert m lazyNewMutVarValue ssMutVars} 51 | pure [old, lazyNewTup2Value] 52 | 53 | -- atomicModifyMutVar_# :: MutVar# s a -> (a -> a) -> State# s -> (# State# s, a, a #) 54 | ( "atomicModifyMutVar_#", [MutVar m, fun, _s]) -> do 55 | Rts{..} <- gets ssRtsSupport 56 | -- NOTE: CPU atomic 57 | old <- lookupMutVar m 58 | 59 | -- transform through fun, get the new value 60 | apFun <- readHeapClosure rtsApplyFun1Arg 61 | lazyNewMutVarValue <- HeapPtr <$> allocAndStore (apFun {hoCloArgs = [fun, old], hoCloMissing = 0}) 62 | 63 | -- update mutvar 64 | modify' $ \s@StgState{..} -> s {ssMutVars = IntMap.insert m lazyNewMutVarValue ssMutVars} 65 | pure [old, lazyNewMutVarValue] 66 | 67 | -- casMutVar# :: MutVar# s a -> a -> a -> State# s -> (# State# s, Int#, a #) 68 | ( "casMutVar#", [MutVar m, old, new, _s]) -> do 69 | -- NOTE: CPU atomic 70 | current <- lookupMutVar m 71 | if current == old 72 | then do 73 | modify' $ \s@StgState{..} -> s {ssMutVars = IntMap.insert m new ssMutVars} 74 | pure [IntV 0, new] 75 | else do 76 | pure [IntV 1, current] 77 | 78 | -- OBSOLETE from GHC 9.4 79 | -- sameMutVar# :: MutVar# s a -> MutVar# s a -> Int# 80 | ( "sameMutVar#", [MutVar a, MutVar b]) -> do 81 | pure [IntV $ if a == b then 1 else 0] 82 | 83 | _ -> fallback op args t tc 84 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Narrowings.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} 2 | module Stg.Interpreter.PrimOp.Narrowings where 3 | 4 | import Data.Int 5 | import Data.Word 6 | 7 | import Stg.Syntax 8 | import Stg.Interpreter.Base 9 | 10 | pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) 11 | pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) 12 | pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) 13 | 14 | evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 15 | evalPrimOp fallback op args t tc = case (op, args) of 16 | 17 | -- narrow8Int# :: Int# -> Int# 18 | ( "narrow8Int#", [IntV a]) -> pure [IntV $ fromIntegral (fromIntegral a :: Int8)] 19 | 20 | -- narrow16Int# :: Int# -> Int# 21 | ( "narrow16Int#", [IntV a]) -> pure [IntV $ fromIntegral (fromIntegral a :: Int16)] 22 | 23 | -- narrow32Int# :: Int# -> Int# 24 | ( "narrow32Int#", [IntV a]) -> pure [IntV $ fromIntegral (fromIntegral a :: Int32)] 25 | 26 | -- narrow8Word# :: Word# -> Word# 27 | ( "narrow8Word#", [WordV a]) -> pure [WordV $ fromIntegral (fromIntegral a :: Word8)] 28 | 29 | -- narrow16Word# :: Word# -> Word# 30 | ( "narrow16Word#", [WordV a]) -> pure [WordV $ fromIntegral (fromIntegral a :: Word16)] 31 | 32 | -- narrow32Word# :: Word# -> Word# 33 | ( "narrow32Word#", [WordV a]) -> pure [WordV $ fromIntegral (fromIntegral a :: Word32)] 34 | 35 | _ -> fallback op args t tc 36 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimOp/ObjectLifetime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} 2 | module Stg.Interpreter.PrimOp.ObjectLifetime where 3 | 4 | import Stg.Syntax 5 | import Stg.Interpreter.Base 6 | 7 | evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 8 | evalPrimOp fallback op args t tc = case (op, args) of 9 | 10 | -- keepAlive# :: v -> State# RealWorld -> (State# RealWorld -> p) -> p 11 | ( "keepAlive#", [managedObject, s, ioAction@HeapPtr{}]) -> do 12 | stackPush $ KeepAlive managedObject 13 | stackPush $ Apply [s] 14 | pure [ioAction] 15 | 16 | _ -> fallback op args t tc 17 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Parallelism.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} 2 | module Stg.Interpreter.PrimOp.Parallelism where 3 | 4 | import Stg.Syntax 5 | import Stg.Interpreter.Base 6 | 7 | {- 8 | NOTE: 9 | - these primops are for multi core evaluation 10 | - on single core evaluation they do nothing 11 | - the ext-stg interpreter is a single core evaluator 12 | -} 13 | 14 | pattern IntV i = IntAtom i 15 | 16 | evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 17 | evalPrimOp fallback op args t tc = case (op, args) of 18 | 19 | -- par# :: a -> Int# 20 | -- DEPRECATED: Use 'spark#' instead 21 | ( "par#", [_a]) -> do 22 | pure [IntV 1] 23 | 24 | -- spark# :: a -> State# s -> (# State# s, a #) 25 | ( "spark#", [a, _s]) -> do 26 | pure [a] 27 | 28 | -- seq# :: a -> State# s -> (# State# s, a #) 29 | ( "seq#", [a, _s]) -> do 30 | stackPush $ Apply [] 31 | pure [a] 32 | 33 | -- getSpark# :: State# s -> (# State# s, Int#, a #) 34 | ( "getSpark#", [_s]) -> do 35 | pure [IntV 0, LiftedUndefined] 36 | 37 | -- numSparks# :: State# s -> (# State# s, Int# #) 38 | ( "numSparks#", [_s]) -> do 39 | pure [IntV 0] 40 | 41 | _ -> fallback op args t tc 42 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Prefetch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-} 2 | module Stg.Interpreter.PrimOp.Prefetch where 3 | 4 | import Stg.Syntax 5 | import Stg.Interpreter.Base 6 | 7 | evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 8 | evalPrimOp fallback op args t tc = case (op, args) of 9 | 10 | -- level 3 11 | 12 | -- prefetchByteArray3# :: ByteArray# -> Int# -> State# s -> State# s 13 | ( "prefetchByteArray3#", [_ba, _i, _s]) -> pure [] 14 | 15 | -- prefetchMutableByteArray3# :: MutableByteArray# s -> Int# -> State# s -> State# s 16 | ( "prefetchMutableByteArray3#", [_ba, _i, _s]) -> pure [] 17 | 18 | -- prefetchAddr3# :: Addr# -> Int# -> State# s -> State# s 19 | ( "prefetchAddr3#", [_a, _i, _s]) -> pure [] 20 | 21 | -- prefetchValue3# :: a -> State# s -> State# s 22 | ( "prefetchValue3#", [_v, _s]) -> pure [] 23 | 24 | -- level 2 25 | 26 | -- prefetchByteArray2# :: ByteArray# -> Int# -> State# s -> State# s 27 | ( "prefetchByteArray2#", [_ba, _i, _s]) -> pure [] 28 | 29 | -- prefetchMutableByteArray2# :: MutableByteArray# s -> Int# -> State# s -> State# s 30 | ( "prefetchMutableByteArray2#", [_ba, _i, _s]) -> pure [] 31 | 32 | -- prefetchAddr2# :: Addr# -> Int# -> State# s -> State# s 33 | ( "prefetchAddr2#", [_a, _i, _s]) -> pure [] 34 | 35 | -- prefetchValue2# :: a -> State# s -> State# s 36 | ( "prefetchValue2#", [_v, _s]) -> pure [] 37 | 38 | -- level 1 39 | 40 | -- prefetchByteArray1# :: ByteArray# -> Int# -> State# s -> State# s 41 | ( "prefetchByteArray1#", [_ba, _i, _s]) -> pure [] 42 | 43 | -- prefetchMutableByteArray1# :: MutableByteArray# s -> Int# -> State# s -> State# s 44 | ( "prefetchMutableByteArray1#", [_ba, _i, _s]) -> pure [] 45 | 46 | -- prefetchAddr1# :: Addr# -> Int# -> State# s -> State# s 47 | ( "prefetchAddr1#", [_a, _i, _s]) -> pure [] 48 | 49 | -- prefetchValue1# :: a -> State# s -> State# s 50 | ( "prefetchValue1#", [_v, _s]) -> pure [] 51 | 52 | -- level 0 53 | 54 | -- prefetchByteArray0# :: ByteArray# -> Int# -> State# s -> State# s 55 | ( "prefetchByteArray0#", [_ba, _i, _s]) -> pure [] 56 | 57 | -- prefetchMutableByteArray0# :: MutableByteArray# s -> Int# -> State# s -> State# s 58 | ( "prefetchMutableByteArray0#", [_ba, _i, _s]) -> pure [] 59 | 60 | -- prefetchAddr0# :: Addr# -> Int# -> State# s -> State# s 61 | ( "prefetchAddr0#", [_a, _i, _s]) -> pure [] 62 | 63 | -- prefetchValue0# :: a -> State# s -> State# s 64 | ( "prefetchValue0#", [_v, _s]) -> pure [] 65 | 66 | _ -> fallback op args t tc 67 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimOp/StablePointer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} 2 | module Stg.Interpreter.PrimOp.StablePointer where 3 | 4 | import Foreign.Ptr 5 | import Control.Monad.State 6 | import qualified Data.IntMap as IntMap 7 | import qualified Data.Map as Map 8 | 9 | import Stg.Syntax 10 | import Stg.Interpreter.Base 11 | 12 | pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) 13 | 14 | evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 15 | evalPrimOp fallback op args t tc = case (op, args) of 16 | 17 | -- Stable Pointer 18 | 19 | -- makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) 20 | ( "makeStablePtr#", [a, _s]) -> do 21 | stablePtrs <- gets ssStablePointers 22 | next <- gets ssNextStablePointer 23 | modify' $ \s -> s {ssStablePointers = IntMap.insert next a stablePtrs, ssNextStablePointer = succ next} 24 | pure [PtrAtom (StablePtr next) . intPtrToPtr $ IntPtr next] 25 | 26 | -- deRefStablePtr# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) 27 | ( "deRefStablePtr#", [PtrAtom (StablePtr _index) p, _s]) -> do 28 | pure <$> lookupStablePointerPtr p 29 | -- TODO: handle this in a better and more uniform way 30 | ( "deRefStablePtr#", [PtrAtom RawPtr p, _s]) -> do 31 | pure <$> lookupStablePointerPtr p 32 | 33 | -- eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int# 34 | ( "eqStablePtr#", [PtrAtom _ a, PtrAtom _ b]) -> do 35 | pure [IntV $ if a == b then 1 else 0] 36 | 37 | 38 | -- Stable Name 39 | 40 | -- makeStableName# :: a -> State# RealWorld -> (# State# RealWorld, StableName# a #) 41 | ( "makeStableName#", [a, _s]) -> do 42 | snMap <- gets ssStableNameMap 43 | case Map.lookup a snMap of 44 | Just snId -> pure [StableName snId] 45 | Nothing -> do 46 | snId <- gets ssNextStableName 47 | modify' $ \s -> s {ssStableNameMap = Map.insert a snId snMap, ssNextStableName = succ snId} 48 | pure [StableName snId] 49 | 50 | -- stableNameToInt# :: StableName# a -> Int# 51 | ( "stableNameToInt#", [StableName snId]) -> do 52 | pure [IntV snId] 53 | 54 | -- OBSOLETE from GHC 9.4 55 | -- eqStableName# :: StableName# a -> StableName# b -> Int# 56 | ( "eqStableName#", [StableName a, StableName b]) -> do 57 | pure [IntV $ if a == b then 1 else 0] 58 | 59 | _ -> fallback op args t tc 60 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimOp/TagToEnum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} 2 | module Stg.Interpreter.PrimOp.TagToEnum where 3 | 4 | import Data.List (findIndex) 5 | import Stg.Syntax 6 | import Stg.Interpreter.Base 7 | 8 | pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) 9 | pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) 10 | pattern Word32V i = WordAtom i -- Literal (LitNumber LitNumWord i) 11 | 12 | dataToTagOp :: [Atom] -> M [Atom] 13 | dataToTagOp [whnf@HeapPtr{}] = do 14 | -- NOTE: the GHC dataToTag# primop works for any Data Con regardless its arity 15 | (Con _ dataCon _) <- readHeapCon whnf 16 | 17 | case findIndex (\d -> dcId d == dcId (unDC dataCon)) (tcDataCons (uncutTyCon $ dcTyCon $ unDC dataCon)) of 18 | Nothing -> stgErrorM $ "Data constructor tag is not found for " ++ show (dcUniqueName $ unDC dataCon) 19 | Just i -> pure [IntV i] 20 | dataToTagOp result = stgErrorM $ "dataToTagOp expected [HeapPtr], got: " ++ show result 21 | 22 | evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 23 | evalPrimOp fallback op args t tc = case (op, args) of 24 | 25 | -- dataToTag# :: a -> Int# -- Zero-indexed; the first constructor has tag zero 26 | ( "dataToTag#", [ho@HeapPtr{}]) -> do 27 | {- 28 | Q: how should it behave when the heap object is not a constructor? 29 | A: is should evaluate it to WHNF 30 | 31 | Q: should it raise exception when the heap object is an exception value? 32 | A: it should raise exception usin the normal eval sematics. 33 | 34 | PROBLEM: 35 | When an exception is raise during the eval, but the interpreted and native stack must be unwinded somehow 36 | Q: how to implement this? 37 | A: implement dataToTag# returning part as a stack continuation, this seems to be the simplest solution to this problem. 38 | -} 39 | 40 | -- HINT: do the work after getting the WHNF result back 41 | stackPush DataToTagOp 42 | 43 | -- HINT: force thunks 44 | stackPush $ Apply [] 45 | pure [ho] 46 | 47 | -- tagToEnum# :: Int# -> a 48 | ( "tagToEnum#", [IntV i]) -> do 49 | Just tyc <- pure tc 50 | let dc = tcDataCons tyc !! i 51 | loc <- allocAndStore (Con False (DC dc) []) 52 | pure [HeapPtr loc] 53 | 54 | _ -> fallback op args t tc 55 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Unsafe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms #-} 2 | module Stg.Interpreter.PrimOp.Unsafe where 3 | 4 | import Stg.Syntax 5 | import Stg.Interpreter.Base 6 | 7 | pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) 8 | 9 | evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 10 | evalPrimOp fallback op args t tc = case (op, args) of 11 | -- reallyUnsafePtrEquality# :: a -> b -> Int# 12 | ( "reallyUnsafePtrEquality#", [a, b]) -> do 13 | pure [IntV $ if a == b then 1 else 0] 14 | 15 | _ -> fallback op args t tc 16 | 17 | {- 18 | ------------------------------------------------------------------------ 19 | section "Unsafe pointer equality" 20 | -- (#1 Bad Guy: Alastair Reid :) 21 | ------------------------------------------------------------------------ 22 | 23 | primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp 24 | a -> a -> Int# 25 | { Returns {\texttt 1\#} if the given pointers are equal and {\texttt 0\#} otherwise. } 26 | with 27 | can_fail = True -- See Note [reallyUnsafePtrEquality#] 28 | 29 | 30 | -- Note [reallyUnsafePtrEquality#] 31 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 32 | -- 33 | -- reallyUnsafePtrEquality# can't actually fail, per se, but we mark it can_fail 34 | -- anyway. Until 5a9a1738023a, GHC considered primops okay for speculation only 35 | -- when their arguments were known to be forced. This was unnecessarily 36 | -- conservative, but it prevented reallyUnsafePtrEquality# from floating out of 37 | -- places where its arguments were known to be forced. Unfortunately, GHC could 38 | -- sometimes lose track of whether those arguments were forced, leading to let/app 39 | -- invariant failures (see #13027 and the discussion in #11444). Now that 40 | -- ok_for_speculation skips over lifted arguments, we need to explicitly prevent 41 | -- reallyUnsafePtrEquality# from floating out. Imagine if we had 42 | -- 43 | -- \x y . case x of x' 44 | -- DEFAULT -> 45 | -- case y of y' 46 | -- DEFAULT -> 47 | -- let eq = reallyUnsafePtrEquality# x' y' 48 | -- in ... 49 | -- 50 | -- If the let floats out, we'll get 51 | -- 52 | -- \x y . let eq = reallyUnsafePtrEquality# x y 53 | -- in case x of ... 54 | -- 55 | -- The trouble is that pointer equality between thunks is very different 56 | -- from pointer equality between the values those thunks reduce to, and the latter 57 | -- is typically much more precise. 58 | -} -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Word64.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings, PatternSynonyms, Strict #-} 2 | module Stg.Interpreter.PrimOp.Word64 where 3 | 4 | import Stg.Syntax 5 | import Stg.Interpreter.Base 6 | 7 | import Data.Word 8 | import Data.Bits 9 | 10 | pattern IntV i = IntAtom i -- Literal (LitNumber LitNumInt i) 11 | pattern Int64V i = IntAtom i -- Literal (LitNumber LitNumInt i) 12 | pattern WordV i = WordAtom i -- Literal (LitNumber LitNumWord i) 13 | pattern Word64V i = WordAtom i -- Literal (LitNumber LitNumWord i) 14 | 15 | evalPrimOp :: PrimOpEval -> Name -> [Atom] -> Type -> Maybe TyCon -> M [Atom] 16 | evalPrimOp fallback op args t tc = do 17 | let 18 | w64 = fromIntegral :: Word -> Word64 19 | w = fromIntegral :: Word64 -> Word 20 | case (op, args) of 21 | 22 | -- word64ToWord# :: Word64# -> Word# 23 | ( "word64ToWord#", [Word64V a]) -> pure [WordV a] 24 | 25 | -- wordToWord64# :: Word# -> Word64# 26 | ( "wordToWord64#", [WordV a]) -> pure [Word64V . w . w64 $ a] 27 | 28 | -- plusWord64# :: Word64# -> Word64# -> Word64# 29 | ( "plusWord64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a + w64 b] 30 | 31 | -- subWord64# :: Word64# -> Word64# -> Word64# 32 | ( "subWord64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a - w64 b] 33 | 34 | -- timesWord64# :: Word64# -> Word64# -> Word64# 35 | ( "timesWord64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a * w64 b] 36 | 37 | -- quotWord64# :: Word64# -> Word64# -> Word64# 38 | ( "quotWord64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a `quot` w64 b] -- NOTE: uint64 / uint64 in C 39 | 40 | -- remWord64# :: Word64# -> Word64# -> Word64# 41 | ( "remWord64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a `rem` w64 b] -- NOTE: uint64 % uint64 in C 42 | 43 | -- and64# :: Word64# -> Word64# -> Word64# 44 | ( "and64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a .&. w64 b] -- NOTE: uint64 & uint64 in C 45 | 46 | -- or64# :: Word64# -> Word64# -> Word64# 47 | ( "or64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a .|. w64 b] -- NOTE: uint64 | uint64 in C 48 | 49 | -- xor64# :: Word64# -> Word64# -> Word64# 50 | ( "xor64#", [Word64V a, Word64V b]) -> pure [Word64V . w $ w64 a `xor` w64 b] -- NOTE: uint64 ^ uint64 in C 51 | 52 | -- not64# :: Word64# -> Word64# 53 | ( "not64#", [Word64V a]) -> pure [Word64V . w . complement $ w64 a] 54 | 55 | -- uncheckedShiftL64# :: Word64# -> Int# -> Word64# 56 | ( "uncheckedShiftL64#", [Word64V a, IntV b]) -> pure [Word64V . w $ unsafeShiftL (w64 a) b] 57 | 58 | -- uncheckedShiftRL64# :: Word64# -> Int# -> Word64# 59 | ( "uncheckedShiftRL64#", [Word64V a, IntV b]) -> pure [Word64V . w $ unsafeShiftR (w64 a) b] -- Shift right logical 60 | 61 | -- word64ToInt64# :: Word64# -> Int64# 62 | ( "word64ToInt64#", [Word64V a]) -> pure [Int64V $ fromIntegral a] 63 | 64 | -- eqWord64# :: Word64# -> Word64# -> Int# 65 | ( "eqWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a == b then 1 else 0] 66 | 67 | -- geWord64# :: Word64# -> Word64# -> Int# 68 | ( "geWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a >= b then 1 else 0] 69 | 70 | -- gtWord64# :: Word64# -> Word64# -> Int# 71 | ( "gtWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a > b then 1 else 0] 72 | 73 | -- leWord64# :: Word64# -> Word64# -> Int# 74 | ( "leWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a <= b then 1 else 0] 75 | 76 | -- ltWord64# :: Word64# -> Word64# -> Int# 77 | ( "ltWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a < b then 1 else 0] 78 | 79 | -- neWord64# :: Word64# -> Word64# -> Int# 80 | ( "neWord64#", [Word64V a, Word64V b]) -> pure [IntV $ if a /= b then 1 else 0] 81 | 82 | _ -> fallback op args t tc 83 | -------------------------------------------------------------------------------- /external-stg-interpreter/lib/Stg/rm-tests.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | 3 | import glob, os, os.path 4 | import subprocess 5 | 6 | test_path = '/home/csaba/haskell/grin-compiler/ghc-whole-program-compiler-project/ghc-wpc/testsuite/tests/' 7 | 8 | print('Scanning:', test_path) 9 | 10 | test_list = list(sorted(glob.glob(test_path + "**/*.run", recursive=True))) 11 | 12 | print('Found:', len(test_list), 'tests\n') 13 | 14 | for test_path in test_list: 15 | print("delete", test_path) 16 | subprocess.run(['rm', '-fr', test_path]) 17 | -------------------------------------------------------------------------------- /external-stg-interpreter/test/PrimOp/CharSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, PatternSynonyms, MagicHash, UnboxedTuples, BangPatterns, Strict #-} 2 | 3 | module PrimOp.CharSpec where 4 | 5 | import Control.Monad.State.Strict 6 | 7 | import Test.Hspec 8 | import Test.QuickCheck 9 | import Test.QuickCheck.Modifiers 10 | import Test.QuickCheck.Monadic 11 | 12 | import Stg.Syntax (Name, Type(..)) 13 | import Stg.Interpreter.Base 14 | import Stg.Interpreter.PrimOp.Char 15 | 16 | import GHC.Exts 17 | 18 | runTests :: IO () 19 | runTests = hspec spec 20 | 21 | evalOp :: Name -> [Atom] -> PropertyM IO [Atom] 22 | evalOp op args = run $ do 23 | let dummyType = PolymorphicRep 24 | dummyTyCon = Nothing 25 | dummyFun = \_ _ _ _ -> pure [] 26 | value = evalPrimOp dummyFun op args dummyType dummyTyCon 27 | evalStateT value fakeStgStateForPrimopTests 28 | 29 | unboxChar :: Char -> Char# 30 | unboxChar (C# x) = x 31 | 32 | spec :: Spec 33 | spec = do 34 | 35 | describe "Char" $ do 36 | 37 | it "gtChar#" $ 38 | property $ forAll (arbitrary :: Gen (Char, Char)) $ \(a, b) -> monadicIO $ do 39 | [IntV stgVal] <- evalOp "gtChar#" [CharV a, CharV b] 40 | assert $ stgVal == (I# (gtChar# (unboxChar a) (unboxChar b))) 41 | 42 | it "geChar#" $ 43 | property $ forAll (arbitrary :: Gen (Char, Char)) $ \(a, b) -> monadicIO $ do 44 | [IntV stgVal] <- evalOp "geChar#" [CharV a, CharV b] 45 | assert $ stgVal == (I# (geChar# (unboxChar a) (unboxChar b))) 46 | 47 | it "eqChar#" $ 48 | property $ forAll (arbitrary :: Gen (Char, Char)) $ \(a, b) -> monadicIO $ do 49 | [IntV stgVal] <- evalOp "eqChar#" [CharV a, CharV b] 50 | assert $ stgVal == (I# (eqChar# (unboxChar a) (unboxChar b))) 51 | 52 | it "neChar#" $ 53 | property $ forAll (arbitrary :: Gen (Char, Char)) $ \(a, b) -> monadicIO $ do 54 | [IntV stgVal] <- evalOp "neChar#" [CharV a, CharV b] 55 | assert $ stgVal == (I# (neChar# (unboxChar a) (unboxChar b))) 56 | 57 | it "ltChar#" $ 58 | property $ forAll (arbitrary :: Gen (Char, Char)) $ \(a, b) -> monadicIO $ do 59 | [IntV stgVal] <- evalOp "ltChar#" [CharV a, CharV b] 60 | assert $ stgVal == (I# (ltChar# (unboxChar a) (unboxChar b))) 61 | 62 | it "leChar#" $ 63 | property $ forAll (arbitrary :: Gen (Char, Char)) $ \(a, b) -> monadicIO $ do 64 | [IntV stgVal] <- evalOp "leChar#" [CharV a, CharV b] 65 | assert $ stgVal == (I# (leChar# (unboxChar a) (unboxChar b))) 66 | 67 | it "ord#" $ 68 | property $ forAll (arbitrary :: Gen Char) $ \a -> monadicIO $ do 69 | [IntV stgVal] <- evalOp "ord#" [CharV a] 70 | assert $ stgVal == (I# (ord# (unboxChar a))) 71 | -------------------------------------------------------------------------------- /external-stg-interpreter/test/PrimOp/NarrowingsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, PatternSynonyms, MagicHash, UnboxedTuples, BangPatterns #-} 2 | 3 | module PrimOp.NarrowingsSpec where 4 | 5 | import Control.Monad.State.Strict 6 | 7 | import Test.Hspec 8 | import Test.QuickCheck 9 | import Test.QuickCheck.Modifiers 10 | import Test.QuickCheck.Monadic 11 | 12 | import Stg.Syntax (Name, Type(..)) 13 | import Stg.Interpreter.Base 14 | import Stg.Interpreter.PrimOp.Narrowings 15 | 16 | import GHC.Exts 17 | 18 | runTests :: IO () 19 | runTests = hspec spec 20 | 21 | evalOp :: Name -> [Atom] -> PropertyM IO [Atom] 22 | evalOp op args = run $ do 23 | let dummyType = PolymorphicRep 24 | dummyTyCon = Nothing 25 | dummyFun = \_ _ _ _ -> pure [] 26 | value = evalPrimOp dummyFun op args dummyType dummyTyCon 27 | evalStateT value fakeStgStateForPrimopTests 28 | 29 | unboxInt :: Int -> Int# 30 | unboxInt (I# x) = x 31 | 32 | unboxWord :: Word -> Word# 33 | unboxWord (W# x) = x 34 | 35 | spec :: Spec 36 | spec = do 37 | 38 | describe "Narrowings" $ do 39 | 40 | it "narrow8Int#" $ 41 | property $ forAll (arbitrary :: Gen Int) $ \a -> monadicIO $ do 42 | [IntV stgVal] <- evalOp "narrow8Int#" [IntV a] 43 | assert $ stgVal == (I# (narrow8Int# (unboxInt a))) 44 | 45 | it "narrow16Int#" $ 46 | property $ forAll (arbitrary :: Gen Int) $ \a -> monadicIO $ do 47 | [IntV stgVal] <- evalOp "narrow16Int#" [IntV a] 48 | assert $ stgVal == (I# (narrow16Int# (unboxInt a))) 49 | 50 | it "narrow32Int#" $ 51 | property $ forAll (arbitrary :: Gen Int) $ \a -> monadicIO $ do 52 | [IntV stgVal] <- evalOp "narrow32Int#" [IntV a] 53 | assert $ stgVal == (I# (narrow32Int# (unboxInt a))) 54 | 55 | it "narrow8Word#" $ 56 | property $ forAll (arbitrary :: Gen Word) $ \a -> monadicIO $ do 57 | [WordV stgVal] <- evalOp "narrow8Word#" [WordV a] 58 | assert $ stgVal == (W# (narrow8Word# (unboxWord a))) 59 | 60 | it "narrow16Word#" $ 61 | property $ forAll (arbitrary :: Gen Word) $ \a -> monadicIO $ do 62 | [WordV stgVal] <- evalOp "narrow16Word#" [WordV a] 63 | assert $ stgVal == (W# (narrow16Word# (unboxWord a))) 64 | 65 | it "narrow32Word#" $ 66 | property $ forAll (arbitrary :: Gen Word) $ \a -> monadicIO $ do 67 | [WordV stgVal] <- evalOp "narrow32Word#" [WordV a] 68 | assert $ stgVal == (W# (narrow32Word# (unboxWord a))) 69 | -------------------------------------------------------------------------------- /external-stg-interpreter/test/Spec.hs: -------------------------------------------------------------------------------- 1 | -- file test/Spec.hs 2 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 3 | -------------------------------------------------------------------------------- /external-stg-syntax/LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2022, Csaba Hruska 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its 16 | contributors may be used to endorse or promote products derived from 17 | this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /external-stg-syntax/README.md: -------------------------------------------------------------------------------- 1 | # external-stg-syntax 2 | GHC independent STG IR definition 3 | -------------------------------------------------------------------------------- /external-stg-syntax/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /external-stg-syntax/external-stg-syntax.cabal: -------------------------------------------------------------------------------- 1 | name: external-stg-syntax 2 | version: 1.0.2 3 | synopsis: GHC independent STG IR definition 4 | 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Csaba Hruska 8 | maintainer: csaba.hruska@gmail.com 9 | copyright: (c) 2022 Csaba Hruska 10 | category: Development 11 | build-type: Simple 12 | tested-with: GHC==9.2.4 13 | cabal-version: >=1.10 14 | 15 | library 16 | exposed-modules: Stg.Syntax 17 | hs-source-dirs: lib 18 | ghc-options: -Wall 19 | build-depends: base, 20 | bytestring, 21 | binary 22 | default-language: Haskell2010 23 | -------------------------------------------------------------------------------- /external-stg/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020, Csaba Hruska 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Ben Gamari nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /external-stg/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /external-stg/app/ext-stg.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import Data.List 3 | 4 | import Options.Applicative 5 | import qualified Data.ByteString.Lazy as BSL 6 | import qualified Data.Text.IO as T 7 | 8 | import Stg.Pretty 9 | import Stg.IO 10 | 11 | modes :: Parser (IO ()) 12 | modes = subparser 13 | ( mode "show" showMode (progDesc "print Stg") 14 | ) 15 | where 16 | mode :: String -> Parser a -> InfoMod a -> Mod CommandFields a 17 | mode name f opts = command name (info (helper <*> f) opts) 18 | 19 | modpakFile :: Parser FilePath 20 | modpakFile = argument str (metavar "MODPAK_OR_STGBIN" <> help "pretty prints external stg from .modpak or .stgbin file") 21 | 22 | showMode :: Parser (IO ()) 23 | showMode = 24 | run <$> modpakFile <*> switch (long "hide-tickish" <> help "do not print STG IR Tickish annotation") 25 | where 26 | run fname hideTickish = do 27 | dump <- case () of 28 | _ | isSuffixOf "modpak" fname -> Stg.IO.readModpakL fname modpakStgbinPath decodeStgbin 29 | _ | isSuffixOf "stgbin" fname -> decodeStgbin <$> BSL.readFile fname 30 | _ -> fail "unknown file format" 31 | let cfg = Config 32 | { cfgPrintTickish = not hideTickish 33 | } 34 | T.putStrLn . fst . pShowWithConfig cfg $ pprModule dump 35 | 36 | main :: IO () 37 | main = join $ execParser $ info (helper <*> modes) mempty 38 | -------------------------------------------------------------------------------- /external-stg/app/mkfullpak.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | import System.FilePath 3 | import Options.Applicative 4 | import Data.Semigroup ((<>)) 5 | 6 | import Stg.Fullpak 7 | 8 | data FullpakOptions 9 | = FullpakOptions 10 | { ghcstgappPath :: FilePath 11 | , stgbinsOnly :: Bool 12 | , includeAll :: Bool 13 | } 14 | 15 | fullpak :: Parser FullpakOptions 16 | fullpak = FullpakOptions 17 | <$> argument str (metavar "FILE" <> help "The .ghc_stgapp file that will be packed") 18 | <*> switch (short 's' <> long "stgbins-only" <> help "Packs the module.stgbin files only") 19 | <*> switch (short 'a' <> long "include-all" <> help "Includes all progam and library modules (without dead module elimination)") 20 | 21 | main :: IO () 22 | main = do 23 | let opts = info (fullpak <**> helper) mempty 24 | FullpakOptions{..} <- execParser opts 25 | let fullpakName = ghcstgappPath -<.> ".fullpak" 26 | 27 | mkFullpak ghcstgappPath stgbinsOnly includeAll fullpakName 28 | -------------------------------------------------------------------------------- /external-stg/external-stg.cabal: -------------------------------------------------------------------------------- 1 | name: external-stg 2 | version: 0.1.0.1 3 | synopsis: A library to dump GHC's STG representation. 4 | 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Csaba Hruska 8 | maintainer: csaba.hruska@gmail.com 9 | copyright: (c) 2018 Csaba Hruska 10 | category: Development 11 | build-type: Simple 12 | tested-with: GHC==8.8.3 13 | cabal-version: >=1.10 14 | 15 | library 16 | exposed-modules: 17 | Stg.Pretty 18 | Stg.IRLocation 19 | Stg.Tickish 20 | Stg.Reconstruct 21 | Stg.Deconstruct 22 | Stg.Fullpak 23 | Stg.Program 24 | Stg.IO 25 | Stg.GHC.Symbols 26 | Stg.JSON 27 | Stg.Analysis.Closure 28 | Stg.Analysis.ForeignInfo 29 | Stg.Analysis.LiveVariable 30 | Stg.Foreign.Linker 31 | Stg.Foreign.Stubs 32 | hs-source-dirs: lib 33 | ghc-options: -Wall 34 | cpp-options: -DEXTERNAL_STG_PACKAGE 35 | other-extensions: GeneralizedNewtypeDeriving 36 | build-depends: base, 37 | bytestring, 38 | filemanip, 39 | filepath, 40 | directory, 41 | process, 42 | binary, 43 | containers, 44 | transformers, 45 | mtl, 46 | unordered-containers, 47 | hashable, 48 | ansi-wl-pprint, 49 | final-pretty-printer, 50 | zip, 51 | text, 52 | aeson, 53 | yaml, 54 | external-stg-syntax 55 | default-language: Haskell2010 56 | 57 | executable ext-stg 58 | hs-source-dirs: app 59 | main-is: ext-stg.hs 60 | build-depends: base < 5.0, 61 | external-stg, 62 | external-stg-syntax, 63 | ansi-wl-pprint, 64 | bytestring, 65 | text, 66 | optparse-applicative 67 | default-language: Haskell2010 68 | 69 | executable stgapp 70 | hs-source-dirs: app 71 | main-is: stgapp.hs 72 | build-depends: base < 5.0, 73 | containers, 74 | filepath, 75 | directory, 76 | yaml, 77 | unix, 78 | process, 79 | bytestring, 80 | external-stg, 81 | external-stg-syntax, 82 | optparse-applicative 83 | default-language: Haskell2010 84 | 85 | executable mkfullpak 86 | hs-source-dirs: app 87 | main-is: mkfullpak.hs 88 | build-depends: base 89 | , filepath 90 | , optparse-applicative 91 | , external-stg 92 | default-language: Haskell2010 93 | -------------------------------------------------------------------------------- /external-stg/lib/Stg/Analysis/Closure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase #-} 2 | module Stg.Analysis.Closure (getAllClosures) where 3 | 4 | import Stg.Syntax 5 | 6 | getAllClosures :: Module -> [(Id, Rhs)] 7 | getAllClosures = visitModule 8 | 9 | visitAlt :: Alt -> [(Id, Rhs)] 10 | visitAlt Alt{..} = visitExpr altRHS 11 | 12 | visitModule :: Module -> [(Id, Rhs)] 13 | visitModule Module{..} = concatMap visitTopBinding moduleTopBindings 14 | 15 | visitTopBinding :: TopBinding -> [(Id, Rhs)] 16 | visitTopBinding = \case 17 | StgTopStringLit{} -> [] 18 | StgTopLifted b -> visitBinding b 19 | 20 | visitBinding :: Binding -> [(Id, Rhs)] 21 | visitBinding = \case 22 | StgNonRec b rhs -> visitRhs b rhs 23 | StgRec l -> concatMap (uncurry visitRhs) l 24 | 25 | visitExpr :: Expr -> [(Id, Rhs)] 26 | visitExpr = \case 27 | StgLet b expr -> visitBinding b ++ visitExpr expr 28 | StgLetNoEscape b expr -> visitBinding b ++ visitExpr expr 29 | StgCase expr _ _ alts -> visitExpr expr ++ concatMap visitAlt alts 30 | StgTick _ expr -> visitExpr expr 31 | _ -> [] 32 | 33 | visitRhs :: Binder -> Rhs -> [(Id, Rhs)] 34 | visitRhs b rhs = case rhs of 35 | StgRhsClosure _ _ _ expr -> (Id b, rhs) : visitExpr expr 36 | _ -> [] 37 | -------------------------------------------------------------------------------- /external-stg/lib/Stg/Analysis/LiveVariable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase #-} 2 | module Stg.Analysis.LiveVariable (annotateWithLiveVariables) where 3 | 4 | import Data.Set (Set) 5 | import qualified Data.Set as Set 6 | 7 | import Stg.Syntax 8 | 9 | type UsedLocal = Set Id 10 | 11 | annotateWithLiveVariables :: Module -> Module 12 | annotateWithLiveVariables = visitModule 13 | 14 | -- HINT: used local bindings 15 | mkUsedLocal :: [Binder] -> UsedLocal 16 | mkUsedLocal l = Set.fromList [Id b | b <- l, binderTopLevel b == False] 17 | 18 | remove :: [Binder] -> UsedLocal -> UsedLocal 19 | remove l u = foldr (\b -> Set.delete (Id b)) u l 20 | 21 | visitAlt :: Alt -> (UsedLocal, Alt) 22 | visitAlt a@Alt{..} = (remove altBinders u, a {altRHS = expr}) 23 | where (u, expr) = visitExpr altRHS 24 | 25 | visitModule :: Module -> Module 26 | visitModule m@Module{..} = m {moduleTopBindings = map visitTopBinding moduleTopBindings} 27 | 28 | visitTopBinding :: TopBinding -> TopBinding 29 | visitTopBinding t = case t of 30 | StgTopStringLit{} -> t 31 | StgTopLifted b 32 | | (u, b') <- visitBinding b 33 | -> if Set.null u 34 | then StgTopLifted b' 35 | else error $ "scope error in: " ++ show b ++ "\n" ++ show u 36 | 37 | visitBinding :: Binding -> (UsedLocal, Binding) 38 | visitBinding = \case 39 | StgNonRec b rhs -> (remove [b] u, StgNonRec b rhs') where (u, rhs') = visitRhs rhs 40 | StgRec l -> (u1, StgRec l') 41 | where 42 | (l', u1) = foldr go ([], Set.empty) l 43 | go (b, rhs) (xs, u0) = 44 | let (u, rhs') = visitRhs rhs 45 | in ((b, rhs'):xs, remove [b] $ Set.union u0 u) 46 | 47 | visitRhs :: Rhs -> (UsedLocal, Rhs) 48 | visitRhs = \case 49 | StgRhsClosure _ update args expr -> 50 | let (u, expr') = visitExpr expr 51 | u' = remove args u 52 | freeVars = map unId $ Set.toList u' 53 | in (u', StgRhsClosure freeVars update args expr') 54 | 55 | StgRhsCon dc args -> (u, StgRhsCon dc args) where u = mkUsedLocal [b | StgVarArg b <- args] 56 | 57 | visitExpr :: Expr -> (UsedLocal, Expr) 58 | visitExpr e = case e of 59 | StgApp f args -> (mkUsedLocal $ f : [b | StgVarArg b <- args], e) 60 | 61 | StgLit{} -> (Set.empty, e) 62 | 63 | StgConApp _ args _ -> (mkUsedLocal [b | StgVarArg b <- args], e) 64 | 65 | StgOpApp _ args _ _ -> (mkUsedLocal [b | StgVarArg b <- args], e) 66 | 67 | StgCase expr b aty alts -> 68 | let (u0, expr') = visitExpr expr 69 | (uA, alts') = unzip $ map visitAlt alts 70 | u = remove [b] $ Set.unions $ u0 : uA 71 | in (u, StgCase expr' b aty alts') 72 | 73 | StgLet b expr -> 74 | let (uE, expr') = visitExpr expr 75 | (uB, b') = visitBinding b 76 | u = remove (getBindingBinders b) $ Set.union uE uB 77 | in (u, StgLet b' expr') 78 | 79 | StgLetNoEscape b expr -> 80 | let (uE, expr') = visitExpr expr 81 | (uB, b') = visitBinding b 82 | u = remove (getBindingBinders b) $ Set.union uE uB 83 | in (u, StgLetNoEscape b' expr') 84 | 85 | StgTick t expr -> 86 | let (u, expr') = visitExpr expr 87 | in (u, StgTick t expr') 88 | 89 | getBindingBinders :: Binding -> [Binder] 90 | getBindingBinders = \case 91 | StgNonRec b _ -> [b] 92 | StgRec l -> map fst l 93 | -------------------------------------------------------------------------------- /external-stg/lib/Stg/Foreign/Linker.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Stg.Foreign.Linker where 3 | 4 | import Data.List 5 | import System.Directory 6 | import System.FilePath 7 | import System.Process 8 | import Text.Printf 9 | 10 | import Stg.Program 11 | import Stg.Syntax 12 | import Stg.Foreign.Stubs 13 | 14 | getExtStgWorkDirectory :: FilePath -> IO FilePath 15 | getExtStgWorkDirectory ghcstgappFname = do 16 | absFname <- makeAbsolute ghcstgappFname 17 | pure $ takeDirectory absFname ".ext-stg-work" takeBaseName ghcstgappFname 18 | 19 | linkForeignCbitsSharedLib :: FilePath -> IO () 20 | linkForeignCbitsSharedLib ghcstgappFname = do 21 | 22 | workDir <- getExtStgWorkDirectory ghcstgappFname 23 | createDirectoryIfMissing True workDir 24 | 25 | let stubFname = workDir "stub.c" 26 | genStubs ghcstgappFname >>= writeFile stubFname 27 | 28 | (StgAppLinkerInfo{..}, linkerInfoList') <- getAppLinkerInfo ghcstgappFname 29 | let linkerInfoList = filter (\StgLibLinkerInfo{..} -> stglibName /= "rts") linkerInfoList' 30 | 31 | cbitsOpts = 32 | [ unwords $ concat 33 | [ [ "-L" ++ dir | dir <- stglibExtraLibDirs] 34 | , stglibLdOptions 35 | , [ "-l" ++ lib | lib <- stglibExtraLibs] 36 | ] 37 | | StgLibLinkerInfo{..} <- linkerInfoList 38 | ] 39 | 40 | cbitsArs = concatMap stglibCbitsPaths linkerInfoList 41 | 42 | stubArs = concatMap stglibCapiStubsPaths linkerInfoList 43 | 44 | arList = cbitsArs ++ stubArs 45 | {- 46 | arList = case cbitsArs ++ stubArs of 47 | [] -> [] 48 | l -> case stgappPlatformOS of 49 | "darwin" -> ["-Wl,-all_load"] ++ l 50 | _ -> ["-Wl,--whole-archive"] ++ l ++ ["-Wl,--no-whole-archive"] 51 | -} 52 | 53 | stubOpts = 54 | [ "-fPIC" 55 | , "stub.c" 56 | ] 57 | 58 | appOpts = unwords $ concat 59 | [ [ "-L" ++ dir | dir <- stgappExtraLibDirs] 60 | , stgappLdOptions 61 | , [ "-l" ++ lib | lib <- stgappExtraLibs] 62 | ] 63 | 64 | linkScript = 65 | unlines 66 | [ "#!/usr/bin/env bash" 67 | , "set -e" 68 | , case stgappPlatformOS of 69 | "darwin" -> "gcc -o cbits.so -shared \\" 70 | _ -> "gcc -o cbits.so -shared -Wl,--no-as-needed \\" 71 | ] ++ 72 | intercalate " \\\n" (map (" " ++) . filter (/= "") $ arList ++ cbitsOpts ++ stgappCObjects ++ [appOpts] ++ stubOpts) ++ "\n" 73 | 74 | let scriptFname = workDir "cbits.so.sh" 75 | writeFile scriptFname linkScript 76 | callCommand $ printf "(cd %s; bash cbits.so.sh)" (show workDir) 77 | -------------------------------------------------------------------------------- /external-stg/lib/Stg/Foreign/Stubs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Stg.Foreign.Stubs where 3 | 4 | import qualified Data.ByteString.Char8 as BS8 5 | 6 | import Stg.Program 7 | import Stg.Syntax 8 | import Stg.GHC.Symbols 9 | 10 | genStubs :: FilePath -> IO String 11 | genStubs ghcstgappFname = do 12 | mods <- getGhcStgAppModules ghcstgappFname 13 | let stubs = concat $ [map genStubCode l | ForeignStubs _ _ _ _ l <- map moduleForeignStubs $ mods] 14 | fileIncludes = [ "#include " 15 | , "#include " 16 | -- , "#include \"HsFFI.h\"" 17 | ] 18 | code = unlines $ filter (not . null) $ fileIncludes ++ stubs ++ rtsSymbolTraps 19 | rtsSymbolTraps = 20 | -- data symbols 21 | [ "// data RTS symbols"] ++ 22 | [ "char " ++ getSymbolName s ++ ";" 23 | | s <- rtsSymbols 24 | , not (isCode s) 25 | ] ++ 26 | -- code symbols 27 | [ "\n// code RTS symbols"] ++ 28 | [ "void reportCalledRtsSymbol(const char *msg) { printf(\"trap for: %s\\n\", msg); }\n"] ++ 29 | [ "void " ++ funName ++ "() { reportCalledRtsSymbol(" ++ show funName ++ "); }" 30 | | s <- rtsSymbols 31 | , let funName = getSymbolName s 32 | , isCode s 33 | ] 34 | isCode = \case 35 | CFun{} -> True 36 | CmmFun{} -> True 37 | _ -> False 38 | 39 | pure code 40 | 41 | -- gen code + collect include headers 42 | genStubCode :: StubDecl -> String 43 | genStubCode = \case 44 | {- 45 | StubDeclImport fi (Just impl) 46 | | CImport _ _ mHeader spec _ <- fi 47 | , StubImplImportCApi wrapperName ctys@(ret : args) <- impl 48 | , CFunction target <- spec 49 | , StaticTarget _ cName _ isFun <- target 50 | -> let 51 | (_, retCType, retHsType) = ret 52 | (cParams, cArgs) = unzip 53 | [ (BS8.unpack t ++ " " ++ name, name) 54 | | (i, (_, t, _)) <- zip [1..] args 55 | , let name = "a" ++ show i 56 | ] 57 | returnCommand = case retHsType of 58 | 'v' -> "" 59 | _ -> "return" 60 | callCommand = if isFun 61 | then BS8.unpack cName ++ "(" ++ intercalate ", " cArgs ++ ")" 62 | else BS8.unpack cName 63 | cCode = BS8.unpack retCType ++ " " ++ BS8.unpack wrapperName ++ "(" ++ intercalate ", " cParams ++ "){" ++ returnCommand ++ " " ++ callCommand ++ ";}" 64 | cIncludes = ["#include " ++ show h | Header _ h <- nub $ catMaybes $ mHeader : [h | (h, _, _) <- ctys]] 65 | 66 | in unlines $ cIncludes ++ [cCode] 67 | StubDeclImport _ (Just StubImplImportCWrapper{}) -> "" 68 | StubDeclImport _ Nothing -> "" 69 | -} 70 | StubDeclImport{} -> "" 71 | d@(StubDeclExport (CExport (CExportStatic _ name _) _) _ _) -> unlines 72 | [ "// not implemented: " ++ show d 73 | , "char " ++ BS8.unpack name ++ ";" -- FIXME: temporary hack 74 | , "" 75 | ] 76 | -------------------------------------------------------------------------------- /external-stg/lib/Stg/IO.hs: -------------------------------------------------------------------------------- 1 | module Stg.IO 2 | ( -- * Convenient Modpak IO 3 | readModpakS 4 | , readModpakL 5 | , doesModpakEntryExist 6 | -- * Convenient Decoding 7 | , decodeStgbin 8 | , decodeStgbin' 9 | , decodeStgbinInfo 10 | , decodeStgbinStubs 11 | , decodeStgbinModuleName 12 | -- .fullpak and .modpak content structure 13 | , fullpakAppInfoPath 14 | , modpakHaskellSourcePath 15 | , modpakStgbinPath 16 | ) where 17 | 18 | import Prelude hiding (readFile) 19 | 20 | import Control.Monad.IO.Class 21 | import qualified Data.ByteString as BS 22 | import qualified Data.ByteString.Char8 as BS8 23 | import qualified Data.ByteString.Lazy as BSL 24 | import Data.Binary 25 | import Data.Binary.Get 26 | import Codec.Archive.Zip 27 | import System.FilePath 28 | 29 | import Stg.Syntax 30 | import Stg.Reconstruct 31 | 32 | -- from .modpak file 33 | 34 | readModpakS :: FilePath -> String -> (BS.ByteString -> a) -> IO a 35 | readModpakS modpakPath fname f = do 36 | s <- mkEntrySelector fname 37 | f <$> withArchive modpakPath (getEntry s) 38 | 39 | readModpakL :: FilePath -> String -> (BSL.ByteString -> a) -> IO a 40 | readModpakL modpakPath fname f = do 41 | s <- mkEntrySelector fname 42 | f . BSL.fromStrict <$> withArchive modpakPath (getEntry s) 43 | 44 | doesModpakEntryExist :: FilePath -> String -> IO Bool 45 | doesModpakEntryExist modpakPath fname = do 46 | s <- mkEntrySelector fname 47 | withArchive modpakPath $ doesEntryExist s 48 | 49 | -- from bytestring 50 | 51 | decodeStgbin' :: BSL.ByteString -> SModule 52 | decodeStgbin' = decode 53 | 54 | decodeStgbin :: BSL.ByteString -> Module 55 | decodeStgbin = reconModule . decodeStgbin' 56 | 57 | decodeStgbinInfo :: BSL.ByteString -> (Name, UnitId, ModuleName, Maybe Name, SForeignStubs, Bool, [(UnitId, [ModuleName])]) 58 | decodeStgbinInfo = decode 59 | 60 | decodeStgbinStubs :: BSL.ByteString -> (Name, UnitId, ModuleName, Maybe Name, SForeignStubs) 61 | decodeStgbinStubs = decode 62 | 63 | decodeStgbinModuleName :: BSL.ByteString -> (Name, UnitId, ModuleName, Maybe Name) 64 | decodeStgbinModuleName = decode 65 | 66 | -- .modpak and .fullpak structure 67 | 68 | modpakStgbinPath :: FilePath 69 | modpakStgbinPath = "module.stgbin" 70 | 71 | modpakHaskellSourcePath :: FilePath 72 | modpakHaskellSourcePath = "module.hs" 73 | 74 | fullpakAppInfoPath :: FilePath 75 | fullpakAppInfoPath = "app.info" 76 | -------------------------------------------------------------------------------- /external-stg/lib/Stg/Tickish.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Stg.Tickish where 3 | 4 | import Control.Monad.RWS hiding (Alt) 5 | 6 | import Stg.Syntax 7 | import Stg.IRLocation 8 | 9 | type M = RWS (Maybe StgPoint) [(StgPoint, Tickish)] () 10 | 11 | withStgPoint :: StgPoint -> M () -> M () 12 | withStgPoint sp = local (const $ Just sp) 13 | 14 | getStgPoint :: M StgPoint 15 | getStgPoint = ask >>= \case 16 | Nothing -> error "missing stg point" 17 | Just sp -> pure sp 18 | 19 | visitTopBinding :: TopBinding -> M () 20 | visitTopBinding = \case 21 | StgTopLifted b -> visitBinding b 22 | StgTopStringLit{} -> pure () 23 | 24 | visitBinding :: Binding -> M () 25 | visitBinding = \case 26 | StgNonRec b r -> visitRhs b r 27 | StgRec bs -> mapM_ (uncurry visitRhs) bs 28 | 29 | visitRhs :: Binder -> Rhs -> M () 30 | visitRhs rhsBinder = \case 31 | StgRhsClosure _ _ _ e -> withStgPoint (SP_RhsClosureExpr $ binderToStgId rhsBinder) $ visitExpr e 32 | StgRhsCon{} -> pure () 33 | 34 | visitExpr :: Expr -> M () 35 | visitExpr expr = do 36 | stgPoint <- getStgPoint 37 | case expr of 38 | StgLit{} -> pure () 39 | StgApp{} -> pure () 40 | StgOpApp{} -> pure () 41 | StgConApp{} -> pure () 42 | StgCase x b _ alts -> do 43 | withStgPoint (SP_CaseScrutineeExpr $ binderToStgId b) $ visitExpr x 44 | sequence_ [visitAlt (Id b) idx a | (idx, a) <- zip [0..] alts] 45 | StgLet b e -> do 46 | visitBinding b 47 | withStgPoint (SP_LetExpr stgPoint) $ visitExpr e 48 | StgLetNoEscape b e -> do 49 | visitBinding b 50 | withStgPoint (SP_LetNoEscapeExpr stgPoint) $ visitExpr e 51 | StgTick tickish e -> do 52 | tell [(stgPoint, tickish)] 53 | visitExpr e 54 | 55 | visitAlt :: Id -> Int -> Alt -> M () 56 | visitAlt (Id scrutBinder) idx (Alt _con _bndrs rhs) = do 57 | withStgPoint (SP_AltExpr (binderToStgId scrutBinder) idx) $ visitExpr rhs 58 | 59 | collectTickish :: Module -> [(StgPoint, Tickish)] 60 | collectTickish m = snd $ evalRWS (mapM_ visitTopBinding $ moduleTopBindings m) Nothing () 61 | -------------------------------------------------------------------------------- /ghc-wpc-testsuite-ci/ghc-9.2.7-testsuite.patch: -------------------------------------------------------------------------------- 1 | diff --git a/testsuite/driver/testglobals.py b/testsuite/driver/testglobals.py 2 | index 81885ac6fb..17cd446607 100644 3 | --- a/testsuite/driver/testglobals.py 4 | +++ b/testsuite/driver/testglobals.py 5 | @@ -27,6 +27,9 @@ class TestConfig: 6 | # Directories below which to look for test description files (foo.T) 7 | self.rootdirs = [] 8 | 9 | + # Run only the runnable tests 10 | + self.runnable_only = False 11 | + 12 | # Run these tests only (run all tests if empty) 13 | self.run_only_some_tests = False 14 | self.only = set() 15 | diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py 16 | index 8b58084921..188a31971b 100644 17 | --- a/testsuite/driver/testlib.py 18 | +++ b/testsuite/driver/testlib.py 19 | @@ -935,6 +935,11 @@ def test(name: TestName, 20 | if not re.match('^[0-9]*[a-zA-Z][a-zA-Z0-9._-]*$', name): 21 | framework_fail(name, None, 'This test has an invalid name') 22 | 23 | + # NOTE: ExtStg special!, run only the 'compile_and_run' like tests 24 | + if config.runnable_only: 25 | + if func not in [compile_and_run, multi_compile_and_run, multimod_compile_and_run]: 26 | + return 27 | + 28 | if config.run_only_some_tests: 29 | if name not in config.only: 30 | return 31 | @@ -1708,6 +1713,11 @@ def simple_run(name: TestName, way: WayName, prog: str, extra_run_opts: str) -> 32 | else: 33 | stdin_arg = None 34 | 35 | + if stdin_arg and stdin_arg.is_file(): 36 | + in_testdir(name, 'run.stdin').write_bytes(stdin_arg.read_bytes()) 37 | + if extra_run_opts: 38 | + in_testdir(name, 'run.args').write_text(extra_run_opts) 39 | + 40 | stdout_arg = in_testdir(name, 'run.stdout') 41 | if opts.combined_output: 42 | stderr_arg = subprocess.STDOUT # type: Union[int, Path] 43 | @@ -1739,6 +1749,13 @@ def simple_run(name: TestName, way: WayName, prog: str, extra_run_opts: str) -> 44 | # run the command 45 | exit_code = runCmd(cmd, stdin_arg, stdout_arg, stderr_arg, opts.run_timeout_multiplier) 46 | 47 | + # save test opts 48 | + in_testdir(name, 'run.opts').write_text(f'[("ignore_stdout",{opts.ignore_stdout}),("ignore_stderr",{opts.ignore_stderr})]') 49 | + 50 | + # save exit code 51 | + in_testdir(name, 'run.exitcode').write_text(str(exit_code)) 52 | + in_testdir(name, 'expected.exitcode').write_text(str(opts.exit_code)) 53 | + 54 | # check the exit code 55 | if exit_code != opts.exit_code: 56 | if config.verbose >= 1 and _expect_pass(way): 57 | diff --git a/testsuite/mk/test.mk b/testsuite/mk/test.mk 58 | index bf0785116d..1fd9657b30 100644 59 | --- a/testsuite/mk/test.mk 60 | +++ b/testsuite/mk/test.mk 61 | @@ -234,6 +234,14 @@ ifneq "$(TEST_ENV)" "" 62 | RUNTEST_OPTS += --test-env="$(TEST_ENV)" 63 | endif 64 | 65 | +ifeq "$(RUNNABLE_ONLY)" "1" 66 | +RUNTEST_OPTS += -e config.runnable_only=True 67 | +else ifeq "$(RUNNABLE_ONLY)" "YES" 68 | +RUNTEST_OPTS += -e config.runnable_only=True 69 | +else 70 | +RUNTEST_OPTS += -e config.runnable_only=False 71 | +endif 72 | + 73 | ifeq "$(CLEANUP)" "0" 74 | RUNTEST_OPTS += -e config.cleanup=False 75 | else ifeq "$(CLEANUP)" "NO" 76 | diff --git a/testsuite/tests/Makefile b/testsuite/tests/Makefile 77 | index 3b2ce49a3d..7cc19339ad 100644 78 | --- a/testsuite/tests/Makefile 79 | +++ b/testsuite/tests/Makefile 80 | @@ -11,6 +11,12 @@ ifeq "$(findstring base,$(LIBRARIES))" "" 81 | $(error base library does not seem to be installed) 82 | endif 83 | 84 | +ifneq "$(LIBRARIES_TO_TEST)" "" 85 | +LIBRARIES := $(LIBRARIES_TO_TEST) 86 | +endif 87 | + 88 | +$(info LIBRARIES is $(value LIBRARIES) ) 89 | + 90 | # Now find the "tests" directories of those libraries, where they exist 91 | LIBRARY_TEST_PATHS := $(wildcard $(patsubst %, $(TOP)/../libraries/%/tests, $(LIBRARIES))) \ 92 | $(wildcard $(patsubst %, $(TOP)/../libraries/%/tests-ghc, $(LIBRARIES))) 93 | -------------------------------------------------------------------------------- /ghc-wpc-testsuite-ci/hello/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2023, Csaba Hruska 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Csaba Hruska nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /ghc-wpc-testsuite-ci/hello/Main.hs: -------------------------------------------------------------------------------- 1 | main = putStrLn "Hello Haskell Debugger!" 2 | -------------------------------------------------------------------------------- /ghc-wpc-testsuite-ci/hello/hello.cabal: -------------------------------------------------------------------------------- 1 | -- Initial minigame.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: hello 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Csaba Hruska 11 | maintainer: csaba.hruska@gmail.com 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | executable hello 19 | main-is: Main.hs 20 | build-depends: base, vector, random 21 | -- hs-source-dirs: 22 | default-language: Haskell2010 23 | -------------------------------------------------------------------------------- /ghc-wpc-testsuite-ci/setup-test-env.sh: -------------------------------------------------------------------------------- 1 | reset 2 | set -e -x 3 | 4 | # TODO: abstarct away ghc version 5 | # TODO: abstarct away the test directory we'd like to run 6 | 7 | 8 | # stage 1: setup and run ghc tests unmodified 9 | # download ghc testsuite 10 | curl -L https://downloads.haskell.org/~ghc/9.2.7/ghc-9.2.7-testsuite.tar.xz -o ghc-9.2.7-testsuite.tar.xz 11 | tar xf ghc-9.2.7-testsuite.tar.xz 12 | 13 | # boot library tests are included in ghc source 14 | curl -L https://downloads.haskell.org/~ghc/9.2.7/ghc-9.2.7-src.tar.xz -o ghc-9.2.7-src.tar.xz 15 | tar xf ghc-9.2.7-src.tar.xz 16 | 17 | # patch to save the detailed test output 18 | patch -d ./ghc-9.2.7 -s -p1 < ghc-9.2.7-testsuite.patch 19 | 20 | stack build 21 | cd ghc-9.2.7/testsuite/TEST_DIR_TO_RUN 22 | 23 | # ghc testsuite make fails at the first run 24 | set +e 25 | stack exec make -- boot 26 | set -e 27 | 28 | # LIBRARIES_TO_TEST control which package's tests to run ; "" means all available 29 | stack exec make -- CLEANUP=0 THREADS=`nproc` RUNNABLE_ONLY=1 PACKAGE_DB=`stack path --snapshot-pkg-db` LIBRARIES_TO_TEST="" 30 | 31 | # stage 2: run estgi test driver ; it will pick up previously compiled tests 32 | 33 | # TODO: compile estgi test driver 34 | run-stgi-testsuite * 35 | -------------------------------------------------------------------------------- /ghc-wpc-testsuite-ci/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.24 2 | 3 | packages: 4 | - 'hello' 5 | 6 | extra-deps: 7 | - random-1.2.1.1 8 | - vector-0.12.3.1 9 | 10 | # use custom ext-stg whole program compiler GHC 11 | compiler: ghc-9.2.7 12 | compiler-check: match-exact 13 | ghc-variant: wpc 14 | setup-info: 15 | ghc: 16 | linux64-custom-wpc: 17 | 9.2.7: 18 | url: "https://github.com/grin-compiler/foundation-pak/releases/download/ghc-9.2.7/ghc-9.2.7-x86_64-unknown-linux.tar.xz" 19 | linux64-custom-wpc-tinfo6: 20 | 9.2.7: 21 | url: "https://github.com/grin-compiler/foundation-pak/releases/download/ghc-9.2.7/ghc-9.2.7-x86_64-unknown-linux.tar.xz" 22 | macosx-custom-wpc: 23 | 9.2.7: 24 | url: "https://github.com/grin-compiler/foundation-pak/releases/download/ghc-9.2.7/ghc-9.2.7-x86_64-apple-darwin.tar.xz" 25 | macosx-aarch64-custom-wpc: 26 | 9.2.7: 27 | url: "https://github.com/grin-compiler/foundation-pak/releases/download/ghc-9.2.7/ghc-9.2.7-aarch64-apple-darwin.tar.xz" 28 | -------------------------------------------------------------------------------- /lambda/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2021, Csaba Hruska, Andor Pénzes 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Csaba Hruska, Andor Pénzes nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /lambda/app/catlambda.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, RecordWildCards, OverloadedStrings #-} 2 | 3 | import Control.Monad.IO.Class 4 | import Control.Monad 5 | import Options.Applicative 6 | import Data.Semigroup ((<>)) 7 | 8 | import Data.List (isPrefixOf) 9 | import qualified Data.Set as Set 10 | import qualified Data.Map as Map 11 | 12 | import System.Directory 13 | import System.FilePath 14 | 15 | import qualified Data.ByteString.Char8 as BS8 16 | 17 | import Codec.Archive.Zip 18 | 19 | import qualified Stg.Program as Stg 20 | 21 | data CatLambdaOpts 22 | = CatLambdaOpts 23 | { lampakPath :: FilePath 24 | } 25 | 26 | appOpts :: Parser CatLambdaOpts 27 | appOpts = CatLambdaOpts 28 | <$> argument str (metavar "LAMPAKFILE" <> help "The .lampak file to collect .lambda IR from") 29 | 30 | main :: IO () 31 | main = do 32 | let opts = info (appOpts <**> helper) mempty 33 | CatLambdaOpts{..} <- execParser opts 34 | 35 | let lambdaPath0 = lampakPath -<.> ".lambda" 36 | lambdaPath <- makeAbsolute lambdaPath0 37 | 38 | putStrLn $ "linking lambda IR to: " ++ lambdaPath 39 | BS8.writeFile lambdaPath "" 40 | 41 | withArchive lampakPath $ do 42 | -- get list of modules 43 | appInfoEntry <- mkEntrySelector "app.info" 44 | content <- lines . BS8.unpack <$> getEntry appInfoEntry 45 | let mods = Stg.parseSection content "modules:" 46 | 47 | forM_ mods $ \m -> do 48 | e <- mkEntrySelector $ m "module.lambda" 49 | src <- getEntry e 50 | liftIO $ BS8.appendFile lambdaPath $ BS8.pack ("\nmodule " ++ m ++ "\n\n") <> src 51 | -------------------------------------------------------------------------------- /lambda/app/mkfacts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, RecordWildCards #-} 2 | 3 | import Control.Monad.IO.Class 4 | import Control.Monad 5 | import Options.Applicative 6 | import Data.Semigroup ((<>)) 7 | 8 | import Data.List (isPrefixOf) 9 | import qualified Data.Set as Set 10 | import qualified Data.Map as Map 11 | 12 | import System.Directory 13 | import System.FilePath 14 | 15 | import qualified Data.ByteString.Char8 as BS8 16 | 17 | import Codec.Archive.Zip 18 | 19 | import qualified Stg.Program as Stg 20 | 21 | data MkFactsOpts 22 | = MkFactsOpts 23 | { lampakPath :: FilePath 24 | , clusterPath :: Maybe FilePath 25 | } 26 | 27 | appOpts :: Parser MkFactsOpts 28 | appOpts = MkFactsOpts 29 | <$> argument str (metavar "LAMPAKFILE" <> help "The .lampak file to collect IR datalog facts from") 30 | <*> optional (strOption (short 'c' <> long "cluster" <> metavar "FILENAME" <> help "List of modules that defines the code cluster of the exported IR")) 31 | 32 | main :: IO () 33 | main = do 34 | let opts = info (appOpts <**> helper) mempty 35 | MkFactsOpts{..} <- execParser opts 36 | 37 | let irFactsPath0 = lampakPath -<.> ".ir-datalog-facts" 38 | outerFactsPath0 = lampakPath -<.> ".outer-ir-datalog-facts" 39 | irFactsPath <- makeAbsolute irFactsPath0 40 | outerFactsPath <- makeAbsolute outerFactsPath0 41 | 42 | putStrLn "linking lambda IR datalog facts into:" 43 | putStrLn irFactsPath 44 | putStrLn outerFactsPath 45 | 46 | -- HINT: cleanup old content 47 | removePathForcibly irFactsPath 48 | createDirectoryIfMissing True irFactsPath 49 | 50 | removePathForcibly outerFactsPath 51 | createDirectoryIfMissing True outerFactsPath 52 | 53 | withArchive lampakPath $ do 54 | -- get list of modules 55 | appInfoEntry <- mkEntrySelector "app.info" 56 | content <- lines . BS8.unpack <$> getEntry appInfoEntry 57 | let mods = Stg.parseSection content "modules:" 58 | dlDirSet = Set.fromList [m "datalog" | m <- mods] 59 | 60 | clusterDirSet <- case clusterPath of 61 | Nothing -> pure dlDirSet -- HINT: cluster = whole program 62 | Just fn -> do 63 | content <- lines . BS8.unpack <$> liftIO (BS8.readFile fn) 64 | let mods = Stg.parseSection content "cluster-modules:" 65 | dlDirSet = Set.fromList [m "datalog" | m <- mods] 66 | pure dlDirSet 67 | 68 | entries <- Map.keys <$> getEntries 69 | forM_ entries $ \e -> do 70 | let entryPath = unEntrySelector e 71 | entryDir = takeDirectory entryPath 72 | when (Set.member entryDir dlDirSet) $ do 73 | factData <- getEntry e 74 | let entryFileName = takeFileName entryPath 75 | factsPath = if Set.member entryDir clusterDirSet 76 | then irFactsPath 77 | else outerFactsPath 78 | liftIO $ BS8.appendFile (factsPath entryFileName) factData 79 | 80 | -- InitialReachable.facts 81 | -- HINT: the ghc_rts_abstract_model is in the Main modules 82 | writeFile (irFactsPath "InitialReachable.facts") $ "ghc_rts_abstract_model\n" 83 | 84 | {- 85 | TODO: 86 | when cluster is specified then: 87 | export the clusre outer code into a separate folder 88 | -} 89 | -------------------------------------------------------------------------------- /lambda/datalog/Check.dl: -------------------------------------------------------------------------------- 1 | ///// VALIDATION 2 | .decl Error(v:symbol, msg:symbol) 3 | .output Error 4 | 5 | // there is no lazy operation beside con and closure 6 | Error(v, "not closure or node") :- 7 | EvalMode(v, "lazy"), 8 | !(Node(v, _) ; IsClosure(v)). 9 | 10 | // there is no strict closure 11 | Error(v, "strict closure") :- 12 | EvalMode(v, "strict"), 13 | IsClosure(v). 14 | 15 | Error(v, "lazy app") :- 16 | EvalMode(v, "lazy"), 17 | Call(v,_,_). 18 | 19 | // SECTION: check for unknown names 20 | 21 | .decl DefName(n:symbol) 22 | 23 | DefName(n) :- // parameters 24 | ( AltParameter(_, _, n) 25 | ; FunctionParameter(_, _, n) 26 | ; ClosureParameter(_, _, n) 27 | ). 28 | 29 | DefName(n) :- // instructions 30 | ( EvalMode(n, _) 31 | ; Alt(_, n, _) 32 | ). 33 | 34 | DefName(n) :- // top level functions 35 | ( IsFunction(n) 36 | ; ExternalFunction(n, _, _, _) 37 | ; IsStaticData(n) 38 | ). 39 | 40 | .decl UseName(n:symbol) 41 | 42 | UseName(n) :- // instructions 43 | ( Move(_,n) 44 | ; Call(_, n, _) 45 | ; Case(_, n) 46 | ; ReturnValue(_, n) 47 | ). 48 | 49 | UseName(n) :- // arguments 50 | ( (NodeArgument(r, _, n), NodeRole(r, "node")) // exclude literals 51 | ; CallArgument(_, _, n) 52 | ; ClosureVariable(_, _, n) 53 | ). 54 | 55 | 56 | Error(n, "unknown name") :- UseName(n), !DefName(n). 57 | 58 | // SECTION: debug 59 | 60 | .decl MissingValue(v:Variable) 61 | .output MissingValue 62 | 63 | MissingValue(v) :- 64 | HasInst(f, v), 65 | !DeadCode(f), 66 | !IsClosure(v), // if closure is always used fully saturated then it will not have a PNode nor an origin, because only nodes and external functions are value origins 67 | !(NodeOrigin(v, _) ; ExternalOrigin(v, _, _) ; PNode(v, _, _, _) ; OuterOrigin(v)). 68 | 69 | MissingValue(v) :- 70 | (FunctionParameter(f, _, v) ; AltParameter(f, _, v) ; ClosureParameter(f, _, v)), 71 | !DeadCode(f), 72 | !(NodeOrigin(v, _) ; ExternalOrigin(v, _, _); PNode(v, _, _, _) ; OuterOrigin(v)). 73 | 74 | // rule coverage 75 | .decl Used(rule_name:symbol) 76 | .output Used 77 | 78 | // SECTION: unmatching but reachable case expressions 79 | 80 | Error(case_result, "unmatching live case expression") :- 81 | REACHABLE(case_result) 82 | Case(case_result, scrut), 83 | !MatchedAlt(case_result, _), 84 | !MissingValue(scrut). 85 | 86 | Error(case_result, "live case expression with dead scrutinee") :- 87 | REACHABLE(case_result) 88 | Case(case_result, scrut), 89 | !MatchedAlt(case_result, _), 90 | MissingValue(scrut). 91 | 92 | // tagToEnum# 93 | Error(alt, "reachable but unhandled alt due to tagToEnum#") :- 94 | REACHABLE(case_result) 95 | Case(case_result, scrut), 96 | ExternalOrigin(scrut, ext_result, _), 97 | Call(ext_result, "tagToEnum#", _), 98 | Alt(case_result, alt, _), 99 | !MatchedAlt(_, alt). 100 | -------------------------------------------------------------------------------- /lambda/datalog/Escape-PrimOp-MVar.dl: -------------------------------------------------------------------------------- 1 | /* 2 | HINT: is interpreted -/+ 3 | 4 | primop effectful 5 | - "newMVar#" :: {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" {"MVar#" %s %a}} 6 | + "takeMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 7 | + "tryTakeMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 %a} 8 | + "putMVar#" :: {"MVar#" %s %a} -> %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.(##)"} 9 | + "tryPutMVar#" :: {"MVar#" %s %a} -> %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" T_Int64} 10 | + "readMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 11 | + "tryReadMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 %a} 12 | 13 | primop pure 14 | - "sameMVar#" :: {"MVar#" %s %a} -> {"MVar#" %s %a} -> T_Int64 15 | 16 | primop effectful 17 | - "isEmptyMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" T_Int64} 18 | */ 19 | 20 | // "takeMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 21 | // "readMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 22 | USED("Escape-PrimOp-MVar-02") 23 | Called(r, op), 24 | TypeVarPointsTo(r, ty_node, "outer-origin") :- 25 | ( op = "takeMVar#" 26 | ; op = "readMVar#" 27 | ), 28 | REACHABLE(r) 29 | Call(r, op, _), 30 | // lookup mvar items 31 | CallArgument(r, 0, arr), 32 | OuterOrigin(arr), 33 | // lookup result node 34 | RetTup1Node0(op, ty_node). 35 | 36 | 37 | // "tryTakeMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 %a} 38 | // "tryReadMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 %a} 39 | USED("Escape-PrimOp-MVar-03") 40 | Called(r, op), 41 | TypeVarPointsTo(r, ty_node, "outer-origin") :- 42 | ( op = "tryTakeMVar#" 43 | ; op = "tryReadMVar#" 44 | ), 45 | REACHABLE(r) 46 | Call(r, op, _), 47 | // lookup mvar items 48 | CallArgument(r, 0, arr), 49 | OuterOrigin(arr), 50 | // lookup result node 51 | RetTup(op, "ghc-prim_GHC.Prim.(#,#)", 1, ty_node). 52 | 53 | 54 | // "putMVar#" :: {"MVar#" %s %a} -> %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.(##)"} 55 | // "tryPutMVar#" :: {"MVar#" %s %a} -> %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" T_Int64} 56 | // mark item with outer origin 57 | // Q: should we backpropagate the outer-origin property on the points-to chain? (TODO) 58 | USED("Escape-PrimOp-MVar-04") 59 | Called(r, op), 60 | Escaped(item) :- 61 | ( op = "putMVar#" 62 | ; op = "tryPutMVar#" 63 | ), 64 | REACHABLE(r) 65 | Call(r, op, _), 66 | // item to write 67 | CallArgument(r, 1, item), 68 | // lookup mvar 69 | CallArgument(r, 0, arr), 70 | OuterOrigin(arr). 71 | -------------------------------------------------------------------------------- /lambda/datalog/Escape-PrimOp-STM.dl: -------------------------------------------------------------------------------- 1 | /* 2 | HINT: is interpreted -/+ 3 | 4 | primop effectful 5 | + "atomically#" :: ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a}) -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 6 | - "retry#" :: {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 7 | + "catchRetry#" :: ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a}) -> ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a}) -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 8 | + "catchSTM#" :: ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a}) -> (%b -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a}) -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 9 | + "newTVar#" :: %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" {"TVar#" %s %a}} 10 | + "readTVar#" :: {"TVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 11 | + "readTVarIO#" :: {"TVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 12 | + "writeTVar#" :: {"TVar#" %s %a} -> %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.(##)"} 13 | 14 | primop pure 15 | - "sameTVar#" :: {"TVar#" %s %a} -> {"TVar#" %s %a} -> T_Int64 16 | */ 17 | 18 | 19 | // "readTVar#" :: {"TVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 20 | // "readTVarIO#" :: {"TVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 21 | USED("Escape-PrimOp-STM-06") 22 | Called(r, op), 23 | TypeVarPointsTo(r, ty_node, "outer-origin") :- 24 | ( op = "readTVar#" 25 | ; op = "readTVarIO#" 26 | ), 27 | REACHABLE(r) 28 | Call(r, op, _), 29 | // lookup tvar items 30 | CallArgument(r, 0, tvar), 31 | OuterOrigin(tvar), 32 | // lookup result node 33 | RetTup1Node0(op, ty_node). 34 | 35 | 36 | // "writeTVar#" :: {"TVar#" %s %a} -> %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.(##)"} 37 | // extend tvar 38 | USED("Escape-PrimOp-STM-07") 39 | Called(r, op), 40 | Escaped(item) :- 41 | op = "writeTVar#", 42 | REACHABLE(r) 43 | Call(r, op, _), 44 | // item to write 45 | CallArgument(r, 1, item), 46 | // lookup tvar 47 | CallArgument(r, 0, tvar), 48 | OuterOrigin(tvar). 49 | -------------------------------------------------------------------------------- /lambda/datalog/Escape-PrimOp-StablePtr.dl: -------------------------------------------------------------------------------- 1 | /* 2 | HINT: is interpreted -/+ 3 | 4 | primop effectful 5 | + "makeStablePtr#" :: %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"StablePtr#" %a}} 6 | + "deRefStablePtr#" :: {"StablePtr#" %a} -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 7 | - "eqStablePtr#" :: {"StablePtr#" %a} -> {"StablePtr#" %a} -> T_Int64 8 | - "makeStableName#" :: %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"StableName#" %a}} 9 | 10 | primop pure 11 | - "eqStableName#" :: {"StableName#" %a} -> {"StableName#" %b} -> T_Int64 12 | - "stableNameToInt#" :: {"StableName#" %a} -> T_Int64 13 | 14 | */ 15 | 16 | 17 | // "deRefStablePtr#" :: {"StablePtr#" %a} -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 18 | USED("Escape-PrimOp-StablePtr-02") 19 | Called(r, op), 20 | TypeVarPointsTo(r, ty_node, "outer-origin") :- 21 | op = "deRefStablePtr#", 22 | REACHABLE(r) 23 | Call(r, op, _), 24 | // lookup stable pointer 25 | CallArgument(r, 0, sp), 26 | OuterOrigin(sp), 27 | // lookup result node 28 | RetTup1Node0(op, ty_node). 29 | 30 | -------------------------------------------------------------------------------- /lambda/datalog/Escape-PrimOp-WeakPtr.dl: -------------------------------------------------------------------------------- 1 | /* 2 | HINT: is interpreted -/+ 3 | 4 | primop effectful 5 | + "mkWeak#" :: %o -> %b -> ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %c}) -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"Weak#" %b}} 6 | + "mkWeakNoFinalizer#" :: %o -> %b -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"Weak#" %b}} 7 | - "addCFinalizerToWeak#" :: T_Addr -> T_Addr -> T_Int64 -> T_Addr -> {"Weak#" %b} -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" T_Int64} 8 | + "deRefWeak#" :: {"Weak#" %a} -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 %a} 9 | + "finalizeWeak#" :: {"Weak#" %a} -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %b})} 10 | - "touch#" :: %o -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(##)"} 11 | */ 12 | 13 | 14 | // "deRefWeak#" :: {"Weak#" %a} -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 %a} 15 | USED("Escape-PrimOp-WeakPtr-03") 16 | Called(r, op), 17 | TypeVarPointsTo(r, ty_node, "outer-origin") :- 18 | op = "deRefWeak#", 19 | REACHABLE(r) 20 | Call(r, op, _), 21 | // lookup weak ptr items 22 | CallArgument(r, 0, wp), 23 | OuterOrigin(wp), 24 | // lookup result node 25 | RetTup(op, "ghc-prim_GHC.Prim.(#,#)", 1, ty_node). 26 | 27 | 28 | // "finalizeWeak#" :: {"Weak#" %a} 29 | // -> {"State#" {RealWorld}} 30 | // -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %b})} 31 | USED("Escape-PrimOp-WeakPtr-04") 32 | Called(r, op), 33 | TypeVarPointsTo(r, ty_node, "outer-origin") :- 34 | op = "finalizeWeak#", 35 | REACHABLE(r) 36 | Call(r, op, _), 37 | // lookup weak ptr items 38 | CallArgument(r, 0, wp), 39 | OuterOrigin(wp), 40 | // lookup result node 41 | RetTup(op, "ghc-prim_GHC.Prim.(#,#)", 1, ty_node). 42 | -------------------------------------------------------------------------------- /lambda/datalog/PointsTo.dl: -------------------------------------------------------------------------------- 1 | // propagates inferred properties 2 | 3 | .decl PointsTo(src:Variable, dst:Variable) 4 | .output PointsTo 5 | 6 | USED("PointsTo-01") 7 | NodeOrigin(src, value) :- 8 | PointsTo(src, dst), 9 | NodeOrigin(dst, value). 10 | // CHECKED 11 | 12 | USED("PointsTo-02") 13 | ExternalOrigin(src, value, tn) :- 14 | PointsTo(src, dst), 15 | ExternalOrigin(dst, value, tn). 16 | // CHECKED 17 | 18 | USED("PointsTo-03") 19 | PNode(src, pap_f, pap_ar, pap_rem) :- 20 | PointsTo(src, dst), 21 | PNode(dst, pap_f, pap_ar, pap_rem). 22 | // CHECKED 23 | 24 | USED("PointsTo-04") 25 | PNodeArgument(src, pap_f, pap_i, pap_value) :- 26 | PointsTo(src, dst), 27 | PNodeArgument(dst, pap_f, pap_i, pap_value). 28 | // CHECKED 29 | 30 | // handling of external sub structure result & external sub structure pattern match 31 | 32 | .decl TypeVarPointsTo(result:Variable, ty_var:Variable, dst:Variable) 33 | .output TypeVarPointsTo 34 | 35 | USED("PointsTo-05") 36 | PointsTo(src, dst) :- 37 | ExternalOrigin(src, r, t), 38 | TypeVarPointsTo(r, t, dst). 39 | // CHECKED 40 | 41 | /* 42 | points-to propagates: 43 | NodeOrigin 44 | ExternalOrigin 45 | PNode 46 | PNodeArgument 47 | */ -------------------------------------------------------------------------------- /lambda/datalog/PrimOp-Bytecode.dl: -------------------------------------------------------------------------------- 1 | /* 2 | primop pure 3 | "addrToAny#" :: T_Addr -> {"ghc-prim_GHC.Prim.Solo#" %a} 4 | "anyToAddr#" :: %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" T_Addr} 5 | "mkApUpd0#" :: {"BCO#"} -> {"ghc-prim_GHC.Prim.Solo#" %a} 6 | 7 | primop effectful 8 | "newBCO#" :: {"ByteArray#"} -> {"ByteArray#"} -> {"Array#" %a} -> T_Int64 -> {"ByteArray#"} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" {"BCO#"}} 9 | 10 | primop pure 11 | "unpackClosure#" :: %a -> {"ghc-prim_GHC.Prim.(#,,#)" T_Addr {"ByteArray#"} {"Array#" %b}} 12 | "closureSize#" :: %a_100 -> (T_Int64) @ t_1945 13 | "getApStackVal#" :: %a -> T_Int64 -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 %b} 14 | */ 15 | 16 | // Future work 17 | 18 | Error(r, "Unsupported (reachable) bytecode related primop") :- 19 | ( op = "addrToAny#" 20 | ; op = "anyToAddr#" 21 | ; op = "mkApUpd0#" 22 | ; op = "newBCO#" 23 | ; op = "unpackClosure#" 24 | ; op = "getApStackVal#" 25 | ), 26 | Call(r, op, _), 27 | HasInst(f, r), 28 | ReachableCode(f). 29 | -------------------------------------------------------------------------------- /lambda/datalog/PrimOp-CCS.dl: -------------------------------------------------------------------------------- 1 | /* 2 | HINT: is interpreted -/+ 3 | 4 | primop pure 5 | - "getCCSOf#" :: %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" T_Addr} 6 | - "getCurrentCCS#" :: %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" T_Addr} 7 | + "clearCCS#" :: ({"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a}) -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 8 | */ 9 | 10 | // "clearCCS#" :: ({"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a}) -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 11 | USED("PrimOp-CCS-01") 12 | Called(r, op), 13 | CallPNode1("clearCCS#-wrapped", r, v0, v1_state) :- 14 | op = "clearCCS#", 15 | REACHABLE(r) 16 | Call(r, op, _), 17 | // pass argument to the wrapped function 18 | CallArgument(r, 0, v0), 19 | CallArgument(r, 1, v1_state). 20 | // CHECKED 21 | -------------------------------------------------------------------------------- /lambda/datalog/PrimOp-Compact.dl: -------------------------------------------------------------------------------- 1 | /* 2 | HINT: is interpreted -/+ 3 | 4 | primop effectful 5 | - "compactNew#" :: T_Word64 -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"Compact#"}} 6 | - "compactResize#" :: {"Compact#"} -> T_Word64 -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(##)"} 7 | 8 | primop pure 9 | - "compactContains#" :: {"Compact#"} -> %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" T_Int64} 10 | - "compactContainsAny#" :: %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" T_Int64} 11 | - "compactGetFirstBlock#" :: {"Compact#"} -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(#,#)" T_Addr T_Word64} 12 | - "compactGetNextBlock#" :: {"Compact#"} -> T_Addr -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(#,#)" T_Addr T_Word64} 13 | 14 | primop effectful 15 | - "compactAllocateBlock#" :: T_Word64 -> T_Addr -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" T_Addr} 16 | - "compactFixupPointers#" :: T_Addr -> T_Addr -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(#,#)" {"Compact#"} T_Addr} 17 | + "compactAdd#" :: {"Compact#"} -> %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 18 | + "compactAddWithSharing#" :: {"Compact#"} -> %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 19 | - "compactSize#" :: {"Compact#"} -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" T_Word64} 20 | */ 21 | 22 | // "compactAdd#" :: {"Compact#"} -> %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 23 | // "compactAddWithSharing#" :: {"Compact#"} -> %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 24 | // FIXME: should transitively evaluate the thunks 25 | // probably we should disable this primop (future work) 26 | /* 27 | USED("PrimOp-Compact-01") 28 | Called(r, op), 29 | TypeVarPointsTo(r, ty_node, item) :- 30 | ( op = "compactAdd#" 31 | ; op = "compactAddWithSharing#" 32 | ), 33 | REACHABLE(r) 34 | Call(r, op, _), 35 | // item to bypass 36 | CallArgument(r, 1, item), 37 | // lookup result node 38 | RetTup1Node0(op, ty_node). 39 | */ 40 | // ISSUE: should transitively evaluate the thunks 41 | Error(r, cat("Unsupported (reachable) primop: ", op)) :- 42 | ( op = "compactAdd#" 43 | ; op = "compactAddWithSharing#" 44 | ), 45 | REACHABLE(r) 46 | Call(r, op, _). 47 | -------------------------------------------------------------------------------- /lambda/datalog/PrimOp-Concurrency.dl: -------------------------------------------------------------------------------- 1 | /* 2 | HINT: is interpreted -/+ 3 | 4 | primop effectful 5 | + "fork#" :: %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"ThreadId#"}} 6 | + "forkOn#" :: T_Int64 -> %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"ThreadId#"}} 7 | + "killThread#" :: {"ThreadId#"} -> %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(##)"} 8 | - "yield#" :: {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(##)"} 9 | - "myThreadId#" :: {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"ThreadId#"}} 10 | - "labelThread#" :: {"ThreadId#"} -> T_Addr -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(##)"} 11 | - "isCurrentThreadBound#" :: {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" T_Int64} 12 | - "noDuplicate#" :: {"State#" %s} -> {"ghc-prim_GHC.Prim.(##)"} 13 | - "threadStatus#" :: {"ThreadId#"} -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(#,,#)" T_Int64 T_Int64 T_Int64} 14 | */ 15 | 16 | 17 | // "killThread#" :: {"ThreadId#"} -> %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(##)"} 18 | // collect raised exceptions 19 | USED("PrimOp-Concurrency-01") 20 | Called(r, "killThread#"), 21 | RaisedEx(ex) :- 22 | REACHABLE(r) 23 | Call(r, "killThread#", _), 24 | CallArgument(r, 1, ex). 25 | 26 | // "fork#" :: %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"ThreadId#"}} 27 | USED("PrimOp-Concurrency-02") 28 | Called(r, "fork#"), 29 | HasInst("fork#", "fork#-action-ignored-result"), // fix & workaround - TODO: come up with a better and simpler design, NOTE: this is needed to make CalledCode work 30 | CallPNode1(r, "fork#-action-ignored-result", v0_io_action, v1_realworld) :- 31 | REACHABLE(r) 32 | Call(r, "fork#", _), 33 | CallArgument(r, 0, v0_io_action), 34 | CallArgument(r, 1, v1_realworld). 35 | 36 | // "forkOn#" :: T_Int64 -> %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"ThreadId#"}} 37 | USED("PrimOp-Concurrency-03") 38 | Called(r, "forkOn#"), 39 | HasInst("forkOn#", "forkOn#-action-ignored-result"), // fix & workaround - TODO: come up with a better and simpler design, NOTE: this is needed to make CalledCode work 40 | CallPNode1(r, "forkOn#-action-ignored-result", v1_io_action, v2_realworld) :- 41 | REACHABLE(r) 42 | Call(r, "forkOn#", _), 43 | CallArgument(r, 1, v1_io_action), 44 | CallArgument(r, 2, v2_realworld). 45 | -------------------------------------------------------------------------------- /lambda/datalog/PrimOp-Exception.dl: -------------------------------------------------------------------------------- 1 | /* 2 | HINT: is interpreted -/+ 3 | 4 | primop effectful 5 | + "catch#" :: ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a}) -> (%b -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a}) -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 6 | + "raise#" :: %b -> %o 7 | - "raiseDivZero#" :: {"Void#"} @ t_1649 -> %o_1 8 | - "raiseUnderflow#" :: {"Void#"} @ t_1650 -> %o_2 9 | - "raiseOverflow#" :: {"Void#"} @ t_1651 -> %o_3 10 | + "raiseIO#" :: %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %b} 11 | + "maskAsyncExceptions#" :: ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a}) -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 12 | + "maskUninterruptible#" :: ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a}) -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 13 | + "unmaskAsyncExceptions#" :: ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a}) -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 14 | - "getMaskingState#" :: {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" T_Int64} 15 | */ 16 | 17 | /* 18 | NOTES for higher order primop support: 19 | the higher order primops execute function calls and also pass the arguments 20 | this mean that they have to collect the arguments somewhere, maybe from an accompaning other primop provides it, 21 | i.e. raise provides the arguments for catch 22 | 23 | */ 24 | // SECTION: higher order primop evaluator 25 | 26 | .decl RaisedEx(f:Variable) 27 | .output RaisedEx 28 | 29 | // "raise#" :: %b -> %o 30 | // "raiseIO#" :: %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %b} 31 | // collect raised exceptions 32 | USED("PrimOp-Exception-01") 33 | Called(r, op), 34 | RaisedEx(ex) :- 35 | REACHABLE(r) 36 | ( op = "raise#" 37 | ; op = "raiseIO#" 38 | ), 39 | Call(r, op, _), 40 | CallArgument(r, 0, ex). 41 | // CHECKED 42 | 43 | // "catch#" :: ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a}) 44 | // -> (%b -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a}) 45 | // -> {"State#" {RealWorld}} 46 | // -> {"ghc-prim_GHC.Prim.Solo#" %a} 47 | // handle the wrapped function 48 | USED("PrimOp-Exception-02") 49 | Called(r, op), 50 | CallPNode1("catch#-wrapped", r, v0, v2_state) :- 51 | op = "catch#", 52 | REACHABLE(r) 53 | Call(r, op, _), 54 | // wrapped fun 55 | CallArgument(r, 0, v0), 56 | // state 57 | CallArgument(r, 2, v2_state). 58 | // CHECKED 59 | 60 | // NOTE: the handler has its own rule, because it fires only when there are exceptions, while the wrapped function is always called 61 | // handle ex-handler 62 | USED("PrimOp-Exception-03") 63 | Called(r, op), 64 | CallPNode2("catch#-handler", r, v1, ex, v2_state) :- 65 | op = "catch#", 66 | REACHABLE(r) 67 | Call(r, op, _), 68 | // handler 69 | CallArgument(r, 1, v1), 70 | // state 71 | CallArgument(r, 2, v2_state), 72 | // exceptions 73 | RaisedEx(ex). 74 | // CHECKED 75 | 76 | // "maskAsyncExceptions#" :: ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a}) -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 77 | // "maskUninterruptible#" :: ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a}) -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 78 | // "unmaskAsyncExceptions#" :: ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a}) -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 79 | USED("PrimOp-Exception-04") 80 | Called(r, op), 81 | CallPNode1("mask", r, v0, v1_state) :- 82 | REACHABLE(r) 83 | ( op = "maskAsyncExceptions#" 84 | ; op = "maskUninterruptible#" 85 | ; op = "unmaskAsyncExceptions#" 86 | ), 87 | Call(r, op, _), 88 | // pass argument to the wrapped function 89 | CallArgument(r, 0, v0), 90 | CallArgument(r, 1, v1_state). 91 | // CHECKED 92 | -------------------------------------------------------------------------------- /lambda/datalog/PrimOp-MVar.dl: -------------------------------------------------------------------------------- 1 | /* 2 | HINT: is interpreted -/+ 3 | 4 | primop effectful 5 | + "newMVar#" :: {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" {"MVar#" %s %a}} 6 | + "takeMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 7 | + "tryTakeMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 %a} 8 | + "putMVar#" :: {"MVar#" %s %a} -> %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.(##)"} 9 | + "tryPutMVar#" :: {"MVar#" %s %a} -> %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" T_Int64} 10 | + "readMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 11 | + "tryReadMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 %a} 12 | 13 | primop pure 14 | - "sameMVar#" :: {"MVar#" %s %a} -> {"MVar#" %s %a} -> T_Int64 15 | 16 | primop effectful 17 | - "isEmptyMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" T_Int64} 18 | */ 19 | 20 | .decl MVar(ext_result:Variable, ty_node:Variable, item:Variable) 21 | .output MVar 22 | 23 | .decl MVarDef(ext_result:Variable, ty_node:Variable) 24 | .output MVarDef 25 | 26 | // "newMVar#" :: {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" {"MVar#" %s %a}} 27 | // new mvar 28 | USED("PrimOp-MVar-01") 29 | Called(r, op), 30 | MVarDef(r, ty_node) :- 31 | op = "newMVar#", 32 | REACHABLE(r) 33 | Call(r, op, _), 34 | // extract result node 35 | RetTup1Node0(op, ty_node). 36 | // CHECKED 37 | 38 | // "takeMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 39 | // "readMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 40 | USED("PrimOp-MVar-02") 41 | Called(r, op), 42 | TypeVarPointsTo(r, ty_node, item) :- 43 | ( op = "takeMVar#" 44 | ; op = "readMVar#" 45 | ), 46 | REACHABLE(r) 47 | Call(r, op, _), 48 | // lookup mvar items 49 | CallArgument(r, 0, arr), 50 | ExternalOrigin(arr, ext_result, arr_node), 51 | MVarDef(ext_result, arr_node), 52 | MVar(ext_result, arr_node, item), 53 | // lookup result node 54 | RetTup1Node0(op, ty_node). 55 | // CHECKED 56 | 57 | // "tryTakeMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 %a} 58 | // "tryReadMVar#" :: {"MVar#" %s %a} -> {"State#" %s} -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 %a} 59 | USED("PrimOp-MVar-03") 60 | Called(r, op), 61 | TypeVarPointsTo(r, ty_node, item) :- 62 | ( op = "tryTakeMVar#" 63 | ; op = "tryReadMVar#" 64 | ), 65 | REACHABLE(r) 66 | Call(r, op, _), 67 | // lookup mvar items 68 | CallArgument(r, 0, arr), 69 | ExternalOrigin(arr, ext_result, arr_node), 70 | MVarDef(ext_result, arr_node), 71 | MVar(ext_result, arr_node, item), 72 | // lookup result node 73 | RetTup(op, "ghc-prim_GHC.Prim.(#,#)", 1, ty_node). 74 | // CHECKED 75 | 76 | // "putMVar#" :: {"MVar#" %s %a} -> %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.(##)"} 77 | // "tryPutMVar#" :: {"MVar#" %s %a} -> %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" T_Int64} 78 | // extend mvar 79 | USED("PrimOp-MVar-04") 80 | Called(r, op), 81 | MVar(ext_result, ty_node, item) :- 82 | ( op = "putMVar#" 83 | ; op = "tryPutMVar#" 84 | ), 85 | REACHABLE(r) 86 | Call(r, op, _), 87 | // item to write 88 | CallArgument(r, 1, item), 89 | // lookup mvar 90 | CallArgument(r, 0, arr), 91 | ExternalOrigin(arr, ext_result, ty_node), 92 | // validation 93 | MVarDef(ext_result, ty_node). 94 | // CHECKED 95 | -------------------------------------------------------------------------------- /lambda/datalog/PrimOp-Parallelism.dl: -------------------------------------------------------------------------------- 1 | /* 2 | HINT: is interpreted -/+ 3 | 4 | primop effectful 5 | + "par#" :: %a -> T_Int64 6 | + "spark#" :: %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 7 | 8 | primop pure 9 | + "seq#" :: %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 10 | 11 | primop effectful 12 | + "getSpark#" :: {"State#" %s} -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 %a} 13 | - "numSparks#" :: {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" T_Int64} 14 | */ 15 | 16 | .decl Spark(item:Variable) 17 | .output Spark 18 | 19 | // "par#" :: %a -> T_Int64 20 | USED("PrimOp-Parallelism-01") 21 | Called(r, "par#"), 22 | Spark(item) :- 23 | REACHABLE(r) 24 | Call(r, "par#", _), 25 | // value 26 | CallArgument(r, 0, item). 27 | 28 | // "spark#" :: %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 29 | USED("PrimOp-Parallelism-02") 30 | Called(r, op), 31 | TypeVarPointsTo(r, ty_node, item), 32 | Spark(item) :- 33 | REACHABLE(r) 34 | op = "spark#", 35 | Call(r, op, _), 36 | // value 37 | CallArgument(r, 0, item), 38 | // extract result node 39 | RetTup1Node0(op, ty_node). 40 | 41 | /* 42 | // "seq#" :: %a -> {"State#" %s} -> {"ghc-prim_GHC.Prim.Solo#" %a} 43 | // TODO: ExecCall should support to emit TypeVarPointsTo relations 44 | // ExecCall result can be: none, PointsTo, TypeVarPointsTo 45 | TypeVarPointsTo(r, ty_node, item), 46 | ExecCall("seq#-thunk", r, item, 0) :- 47 | op = "seq#", 48 | Call(r, op, _), 49 | // value 50 | CallArgument(r, 0, item), 51 | // extract result node 52 | RetTup1Node0(op, ty_node). 53 | */ 54 | 55 | // "getSpark#" :: {"State#" %s} -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 %a} 56 | USED("PrimOp-Parallelism-03") 57 | Called(r, op), 58 | TypeVarPointsTo(r, ty_node, item) :- 59 | op = "getSpark#", 60 | REACHABLE(r) 61 | Call(r, op, _), 62 | // lookup items 63 | Spark(item), 64 | // lookup result node 65 | RetTup(op, "ghc-prim_GHC.Prim.(#,#)", 1, ty_node). 66 | 67 | // TODO: future work 68 | Error(r, cat("Unsupported (reachable) primop: ", op)) :- 69 | ( op = "seq#" 70 | ), 71 | REACHABLE(r) 72 | Call(r, op, _). 73 | -------------------------------------------------------------------------------- /lambda/datalog/PrimOp-StablePtr.dl: -------------------------------------------------------------------------------- 1 | /* 2 | HINT: is interpreted -/+ 3 | 4 | primop effectful 5 | + "makeStablePtr#" :: %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"StablePtr#" %a}} 6 | + "deRefStablePtr#" :: {"StablePtr#" %a} -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 7 | - "eqStablePtr#" :: {"StablePtr#" %a} -> {"StablePtr#" %a} -> T_Int64 8 | - "makeStableName#" :: %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"StableName#" %a}} 9 | 10 | primop pure 11 | - "eqStableName#" :: {"StableName#" %a} -> {"StableName#" %b} -> T_Int64 12 | - "stableNameToInt#" :: {"StableName#" %a} -> T_Int64 13 | 14 | */ 15 | 16 | .decl StablePtr(item:Variable) 17 | .output StablePtr 18 | 19 | // "makeStablePtr#" :: %a -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"StablePtr#" %a}} 20 | // new stable ptr 21 | USED("PrimOp-StablePtr-01") 22 | Called(r, op), 23 | StablePtr(item) :- 24 | op = "makeStablePtr#", 25 | REACHABLE(r) 26 | Call(r, op, _), 27 | // initial item 28 | CallArgument(r, 0, item). 29 | // CHECKED 30 | 31 | // "deRefStablePtr#" :: {"StablePtr#" %a} -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %a} 32 | USED("PrimOp-StablePtr-02") 33 | Called(r, op), 34 | TypeVarPointsTo(r, ty_node, item) :- 35 | op = "deRefStablePtr#", 36 | REACHABLE(r) 37 | Call(r, op, _), 38 | // lookup stable ptr items 39 | StablePtr(item), 40 | // lookup result node 41 | RetTup1Node0(op, ty_node). 42 | // CHECKED 43 | -------------------------------------------------------------------------------- /lambda/datalog/PrimOp-TagToEnum.dl: -------------------------------------------------------------------------------- 1 | /* 2 | {- 3 | Tag to enum stuff 4 | -} 5 | primop pure 6 | - "dataToTag#" :: %a_93 -> (T_Int64) @ t_1923 7 | - "tagToEnum#" :: (T_Int64) @ t_1924 -> %a_94 8 | 9 | NOTE: currently tagToEnum# is lowered to actial case expression during Stg to Lambda conversion, so it is not present in Lambda and does not need support from CFA. 10 | */ 11 | 12 | Error(r, "Unsupported (reachable) tagToEnum# primop") :- 13 | ( op = "tagToEnum#" 14 | ), 15 | Call(r, op, _), 16 | HasInst(f, r), 17 | ReachableCode(f). 18 | -------------------------------------------------------------------------------- /lambda/datalog/PrimOp-WeakPtr.dl: -------------------------------------------------------------------------------- 1 | /* 2 | HINT: is interpreted -/+ 3 | 4 | primop effectful 5 | + "mkWeak#" :: %o -> %b -> ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %c}) -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"Weak#" %b}} 6 | + "mkWeakNoFinalizer#" :: %o -> %b -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"Weak#" %b}} 7 | - "addCFinalizerToWeak#" :: T_Addr -> T_Addr -> T_Int64 -> T_Addr -> {"Weak#" %b} -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" T_Int64} 8 | + "deRefWeak#" :: {"Weak#" %a} -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 %a} 9 | + "finalizeWeak#" :: {"Weak#" %a} -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %b})} 10 | - "touch#" :: %o -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(##)"} 11 | */ 12 | 13 | .decl WeakPtr(ext_result:Variable, ty_node:Variable, item:Variable) 14 | .output WeakPtr 15 | 16 | .decl WeakFinalizer(ext_result:Variable, finalizer:Variable) 17 | .output WeakFinalizer 18 | 19 | // "mkWeak#" :: %o -> %b -> ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %c}) -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"Weak#" %b}} 20 | // new weak ptr 21 | USED("PrimOp-WeakPtr-01") 22 | Called(r, op), 23 | CallPNode1(r, "mkWeak#-finalizer-ignored-result", finalizer, v3_state), // TRICK: swap name space and result var in order to ignore the result value 24 | HasInst("mkWeak#", "mkWeak#-finalizer-ignored-result"), // fix & workaround - TODO: come up with a better and simpler design, NOTE: this is needed to make CalledCode work 25 | WeakFinalizer(r, finalizer), 26 | WeakPtr(r, ty_node, item) :- 27 | op = "mkWeak#", 28 | REACHABLE(r) 29 | Call(r, op, _), 30 | // value 31 | CallArgument(r, 1, item), 32 | // finalizer 33 | CallArgument(r, 2, finalizer), 34 | // state 35 | CallArgument(r, 3, v3_state), 36 | // extract result node 37 | RetTup1Node0(op, ty_node). 38 | // CHECKED 39 | 40 | // "mkWeakNoFinalizer#" :: %o -> %b -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" {"Weak#" %b}} 41 | // new weak ptr 42 | USED("PrimOp-WeakPtr-02") 43 | Called(r, op), 44 | WeakPtr(r, ty_node, item) :- 45 | op = "mkWeakNoFinalizer#", 46 | REACHABLE(r) 47 | Call(r, op, _), 48 | // value 49 | CallArgument(r, 1, item), 50 | // extract result node 51 | RetTup1Node0(op, ty_node). 52 | // CHECKED 53 | 54 | // "deRefWeak#" :: {"Weak#" %a} -> {"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 %a} 55 | USED("PrimOp-WeakPtr-03") 56 | Called(r, op), 57 | TypeVarPointsTo(r, ty_node, item) :- 58 | op = "deRefWeak#", 59 | REACHABLE(r) 60 | Call(r, op, _), 61 | // lookup weak ptr items 62 | CallArgument(r, 0, arr), 63 | ExternalOrigin(arr, ext_result, arr_node), 64 | WeakPtr(ext_result, arr_node, item), 65 | // lookup result node 66 | RetTup(op, "ghc-prim_GHC.Prim.(#,#)", 1, ty_node). 67 | // CHECKED 68 | 69 | // "finalizeWeak#" :: {"Weak#" %a} 70 | // -> {"State#" {RealWorld}} 71 | // -> {"ghc-prim_GHC.Prim.(#,#)" T_Int64 ({"State#" {RealWorld}} -> {"ghc-prim_GHC.Prim.Solo#" %b})} 72 | USED("PrimOp-WeakPtr-04") 73 | Called(r, op), 74 | TypeVarPointsTo(r, ty_node, finalizer) :- 75 | op = "finalizeWeak#", 76 | REACHABLE(r) 77 | Call(r, op, _), 78 | // lookup weak ptr items 79 | CallArgument(r, 0, arr), 80 | ExternalOrigin(arr, ext_result, _), 81 | WeakFinalizer(ext_result, finalizer), 82 | // lookup result node 83 | RetTup(op, "ghc-prim_GHC.Prim.(#,#)", 1, ty_node). 84 | // CHECKED 85 | -------------------------------------------------------------------------------- /lambda/datalog/TODO: -------------------------------------------------------------------------------- 1 | tagToEnum# 2 | 3 | new primops to add to CFA: 4 | {- 5 | Arrays of arrays 6 | -} 7 | primop effectful 8 | "newArrayArray#" :: (T_Int64) @ t_1304 -> {"State#" %s_113} @ t_1305 -> {"ghc-prim_GHC.Prim.Unit#" {"MutableArrayArray#" %s_113} @ t_1306} @ t_1307 9 | 10 | primop pure 11 | "sameMutableArrayArray#" :: {"MutableArrayArray#" %s_114} @ t_1308 -> {"MutableArrayArray#" %s_114} @ t_1309 -> (T_Int64) @ t_1310 12 | 13 | primop effectful 14 | "unsafeFreezeArrayArray#" :: {"MutableArrayArray#" %s_115} @ t_1311 -> {"State#" %s_115} @ t_1312 -> {"ghc-prim_GHC.Prim.Unit#" {"ArrayArray#"} @ t_1313} @ t_1314 15 | 16 | primop pure 17 | "sizeofArrayArray#" :: {"ArrayArray#"} @ t_1315 -> (T_Int64) @ t_1316 18 | "sizeofMutableArrayArray#" :: {"MutableArrayArray#" %s_116} @ t_1317 -> (T_Int64) @ t_1318 19 | "indexByteArrayArray#" :: {"ArrayArray#"} @ t_1319 -> (T_Int64) @ t_1320 -> {"ByteArray#"} @ t_1321 20 | "indexArrayArrayArray#" :: {"ArrayArray#"} @ t_1322 -> (T_Int64) @ t_1323 -> {"ArrayArray#"} @ t_1324 21 | 22 | primop effectful 23 | "readByteArrayArray#" :: {"MutableArrayArray#" %s_117} @ t_1325 -> (T_Int64) @ t_1326 -> {"State#" %s_117} @ t_1327 -> {"ghc-prim_GHC.Prim.Unit#" {"ByteArray#"} @ t_1328} @ t_1329 24 | "readMutableByteArrayArray#" :: {"MutableArrayArray#" %s_118} @ t_1330 -> (T_Int64) @ t_1331 -> {"State#" %s_118} @ t_1332 -> {"ghc-prim_GHC.Prim.Unit#" {"MutableByteArray#" %s_118} @ t_1333} @ t_1334 25 | "readArrayArrayArray#" :: {"MutableArrayArray#" %s_119} @ t_1335 -> (T_Int64) @ t_1336 -> {"State#" %s_119} @ t_1337 -> {"ghc-prim_GHC.Prim.Unit#" {"ArrayArray#"} @ t_1338} @ t_1339 26 | "readMutableArrayArrayArray#" :: {"MutableArrayArray#" %s_120} @ t_1340 -> (T_Int64) @ t_1341 -> {"State#" %s_120} @ t_1342 -> {"ghc-prim_GHC.Prim.Unit#" {"MutableArrayArray#" %s_120} @ t_1343} @ t_1344 27 | "writeByteArrayArray#" :: {"MutableArrayArray#" %s_121} @ t_1345 -> (T_Int64) @ t_1346 -> {"ByteArray#"} @ t_1347 -> {"State#" %s_121} @ t_1348 -> {"ghc-prim_GHC.Prim.(##)"} @ t_1349 28 | "writeMutableByteArrayArray#" :: {"MutableArrayArray#" %s_122} @ t_1350 -> (T_Int64) @ t_1351 -> {"MutableByteArray#" %s_122} @ t_1352 -> {"State#" %s_122} @ t_1353 -> {"ghc-prim_GHC.Prim.(##)"} @ t_1354 29 | "writeArrayArrayArray#" :: {"MutableArrayArray#" %s_123} @ t_1355 -> (T_Int64) @ t_1356 -> {"ArrayArray#"} @ t_1357 -> {"State#" %s_123} @ t_1358 -> {"ghc-prim_GHC.Prim.(##)"} @ t_1359 30 | "writeMutableArrayArrayArray#" :: {"MutableArrayArray#" %s_124} @ t_1360 -> (T_Int64) @ t_1361 -> {"MutableArrayArray#" %s_124} @ t_1362 -> {"State#" %s_124} @ t_1363 -> {"ghc-prim_GHC.Prim.(##)"} @ t_1364 31 | "copyArrayArray#" :: {"ArrayArray#"} @ t_1365 -> (T_Int64) @ t_1366 -> {"MutableArrayArray#" %s_125} @ t_1367 -> (T_Int64) @ t_1368 -> (T_Int64) @ t_1369 -> {"State#" %s_125} @ t_1370 -> {"ghc-prim_GHC.Prim.(##)"} @ t_1371 32 | "copyMutableArrayArray#" :: {"MutableArrayArray#" %s_126} @ t_1372 -> (T_Int64) @ t_1373 -> {"MutableArrayArray#" %s_126} @ t_1374 -> (T_Int64) @ t_1375 -> (T_Int64) @ t_1376 -> {"State#" %s_126} @ t_1377 -> {"ghc-prim_GHC.Prim.(##)"} @ t_1378 33 | 34 | dead code elimination ideas: 35 | find dead/unused: 36 | constructors = never pattern matched 37 | closure = never called 38 | 39 | Q: 40 | how are these related to dead code / dead data: 41 | - reachable code 42 | - referred value 43 | - called code 44 | -------------------------------------------------------------------------------- /lambda/datalog/c.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -x -e 4 | 5 | souffle -c -j`nproc --all` -o lambda-cfa main.dl 6 | -------------------------------------------------------------------------------- /lambda/datalog/called-by-outer.dl: -------------------------------------------------------------------------------- 1 | 2 | #include "AST.dl" 3 | 4 | .decl CalledByOuterCode(v:symbol) 5 | .output CalledByOuterCode 6 | 7 | CalledByOuterCode(v) :- 8 | UsedName(v), 9 | !DefinedName(v). 10 | -------------------------------------------------------------------------------- /lambda/datalog/lambda-datalog2.todo: -------------------------------------------------------------------------------- 1 | BUGFIX: 2 | done - make utility/reusable application relation as a helper for wrapper operations ; i.e. apply the last argument of a function or PNode or actually call the staurated PNode 3 | done - fix higher order primop's function call parameter passing ; pass all parameters 4 | done - calculate dead alernative ; based on tag, not node origin with the specific tag ; NOT THIS: all pattern binders are dead/missing 5 | - fix applychain bug in: basic04_opt.2.lambda 6 | ds3.s15353.0 = after.s15339.0 $ ipv3.s15348.0 val.6518 7 | problem: ipv3.s15348.0 is not applied as argument 8 | - calcualte only the reachable code 9 | - some primop forces evaluation of thunks? 10 | 11 | ADVANCEMENT: 12 | done - remove dead alternatives 13 | done - remove dead closures ; may require dummy code insertion 14 | 15 | IMPROVE PERFORMANCE: 16 | - add Strict(x) and Lazy(x) deriving from EvalMode 17 | - reintroduce Origin ; keep PNode and others at their birth place ; do not propagate them instead calculate Origin for each variable 18 | - minimize value propagation 19 | - minimize joins 20 | done - simplify array operations ; merge commmon rules 21 | - simplify CFA rules 22 | - more accurate exception tracking 23 | - track node tags ; calcualte dead alternatives 24 | - calcualate dead fields 25 | - test 26 | 27 | BIG: 28 | - context sensitive analysis? 29 | - unification based analysis? 30 | 31 | IDEA: 32 | calculate tags and nodes and origins on demand 33 | for each reachable case expressions we'd emit a new Request value to calculate the tag of the scrutinee and 34 | then the matching alts body expression would request the elaboration further 35 | 36 | TODO: 37 | refactor / rewrite CFA to be much more performant 38 | 39 | PAPERS: 40 | A Flow-Sensitive Approach for Steensgaard’s Pointer Analysis 41 | http://www.novoscursos.ufv.br/graduacao/caf/ccp/www/wp-content/uploads/2019/02/POC-II-2018-2-Jos%C3%A9-Wesley-de-Souza-Magalh%C3%A3es.pdf 42 | 43 | Making Context-sensitive Points-to Analysis with Heap Cloning Practical For The Real World 44 | https://llvm.org/pubs/2007-06-10-PLDI-DSA.pdf 45 | 46 | Fast Equivalence Relations in Datalog 47 | https://souffle-lang.github.io/pdf/patrickthesis.pdf 48 | 49 | Demand-Driven Points-to Analysis for Java 50 | https://manu.sridharan.net/files/oopsla05.pdf 51 | 52 | An Efficient Data Structure for Must-Alias Analysis 53 | https://gkastrinis.github.io/pdf/must-alias-cc18.pdf 54 | NOTE: this looks well suited for ASAP memory management implementation 55 | 56 | Context-, Flow-, and Field-Sensitive Data-Flow Analysis using Synchronized Pushdown Systems 57 | https://johspaeth.github.io/publications/boomerangPDS.pdf 58 | 59 | IDEAS FOR BETTER PERFORMANCE: 60 | utilise static information: 61 | + use deconstruction for unboxed tuples instead of tag matching case/alt pairs 62 | + use separate relations for each constructor arities, this would reduce the search space 63 | 64 | improvement areas: 65 | - better IR schema 66 | - better rules 67 | - track heap (boxed) values only, do not track literals 68 | - distinct heap allocated nodes from stack/register (non-escaping) nodes 69 | + heap allocated nodes = heap context sensitivity 70 | + stack allocated nodes = call context sensitivity 71 | - filter according concrete types 72 | 73 | IDEA: combine type inference with CFA => track the constructor or closure names that can produce the currently inferred typed value 74 | -------------------------------------------------------------------------------- /lambda/datalog/main.dl: -------------------------------------------------------------------------------- 1 | #define LOG_USED 2 | #define REACHABLE_ONLY 3 | 4 | #ifdef REACHABLE_ONLY 5 | # define REACHABLE(x) Reachable(x), 6 | #else 7 | # define REACHABLE(x) 8 | #endif 9 | 10 | #ifdef LOG_USED 11 | # define USED(x) Used(x), 12 | #else 13 | # define USED(x) 14 | #endif 15 | 16 | #include "AST.dl" 17 | #include "CBy.dl" 18 | #include "CFA.dl" 19 | #include "Check.dl" 20 | #include "LVA.dl" 21 | #include "PointsTo.dl" 22 | #include "PrimOp-Arrays.dl" 23 | #include "PrimOp-Bytecode.dl" 24 | #include "PrimOp-CCS.dl" 25 | #include "PrimOp-Compact.dl" 26 | #include "PrimOp-Concurrency.dl" 27 | #include "PrimOp-Exception.dl" 28 | #include "PrimOp-MVar.dl" 29 | #include "PrimOp-MutVar.dl" 30 | #include "PrimOp-Parallelism.dl" 31 | #include "PrimOp-STM.dl" 32 | #include "PrimOp-StablePtr.dl" 33 | #include "PrimOp-TagToEnum.dl" 34 | #include "PrimOp-WeakPtr.dl" 35 | 36 | #include "Escape.dl" 37 | #include "Escape-CFA.dl" 38 | #include "Escape-PrimOp-Arrays.dl" 39 | #include "Escape-PrimOp-MVar.dl" 40 | #include "Escape-PrimOp-MutVar.dl" 41 | #include "Escape-PrimOp-WeakPtr.dl" 42 | #include "Escape-PrimOp-STM.dl" 43 | #include "Escape-PrimOp-StablePtr.dl" 44 | -------------------------------------------------------------------------------- /lambda/datalog/non-special-primops/PrimOp-DelayWait.dl: -------------------------------------------------------------------------------- 1 | /* 2 | primop effectful 3 | - "delay#" :: (T_Int64) @ t_1750 -> {"State#" %s_180} @ t_1751 -> {"ghc-prim_GHC.Prim.(##)"} @ t_1752 4 | - "waitRead#" :: (T_Int64) @ t_1753 -> {"State#" %s_181} @ t_1754 -> {"ghc-prim_GHC.Prim.(##)"} @ t_1755 5 | - "waitWrite#" :: (T_Int64) @ t_1756 -> {"State#" %s_182} @ t_1757 -> {"ghc-prim_GHC.Prim.(##)"} @ t_1758 6 | */ 7 | -------------------------------------------------------------------------------- /lambda/datalog/non-special-primops/PrimOp-Etc.dl: -------------------------------------------------------------------------------- 1 | /* 2 | {- 3 | Etc 4 | -} 5 | primop effectful 6 | "traceEvent#" :: (T_Addr) @ t_1959 -> {"State#" %s_192} @ t_1960 -> {"ghc-prim_GHC.Prim.(##)"} @ t_1961 7 | "traceBinaryEvent#" :: (T_Addr) @ t_1962 -> (T_Int64) @ t_1963 -> {"State#" %s_193} @ t_1964 -> {"ghc-prim_GHC.Prim.(##)"} @ t_1965 8 | "traceMarker#" :: (T_Addr) @ t_1966 -> {"State#" %s_194} @ t_1967 -> {"ghc-prim_GHC.Prim.(##)"} @ t_1968 9 | "setThreadAllocationCounter#" :: (T_Int64) @ t_1969 -> {"State#" {RealWorld} @ t_1970} @ t_1971 -> {"ghc-prim_GHC.Prim.(##)"} @ t_1972 10 | */ 11 | -------------------------------------------------------------------------------- /lambda/datalog/non-special-primops/PrimOp-Prefetch.dl: -------------------------------------------------------------------------------- 1 | /* 2 | {- 3 | Prefetch 4 | -} 5 | primop effectful 6 | "prefetchByteArray3#" :: {"ByteArray#"} @ t_2001 -> (T_Int64) @ t_2002 -> {"State#" %s_201} @ t_2003 -> {"ghc-prim_GHC.Prim.(##)"} @ t_2004 7 | "prefetchMutableByteArray3#" :: {"MutableByteArray#" %s_202} @ t_2005 -> (T_Int64) @ t_2006 -> {"State#" %s_202} @ t_2007 -> {"ghc-prim_GHC.Prim.(##)"} @ t_2008 8 | "prefetchAddr3#" :: (T_Addr) @ t_2009 -> (T_Int64) @ t_2010 -> {"State#" %s_203} @ t_2011 -> {"ghc-prim_GHC.Prim.(##)"} @ t_2012 9 | "prefetchValue3#" :: %a_105 -> {"State#" %s_204} @ t_2013 -> {"ghc-prim_GHC.Prim.(##)"} @ t_2014 10 | "prefetchByteArray2#" :: {"ByteArray#"} @ t_2015 -> (T_Int64) @ t_2016 -> {"State#" %s_205} @ t_2017 -> {"ghc-prim_GHC.Prim.(##)"} @ t_2018 11 | "prefetchMutableByteArray2#" :: {"MutableByteArray#" %s_206} @ t_2019 -> (T_Int64) @ t_2020 -> {"State#" %s_206} @ t_2021 -> {"ghc-prim_GHC.Prim.(##)"} @ t_2022 12 | "prefetchAddr2#" :: (T_Addr) @ t_2023 -> (T_Int64) @ t_2024 -> {"State#" %s_207} @ t_2025 -> {"ghc-prim_GHC.Prim.(##)"} @ t_2026 13 | "prefetchValue2#" :: %a_106 -> {"State#" %s_208} @ t_2027 -> {"ghc-prim_GHC.Prim.(##)"} @ t_2028 14 | "prefetchByteArray1#" :: {"ByteArray#"} @ t_2029 -> (T_Int64) @ t_2030 -> {"State#" %s_209} @ t_2031 -> {"ghc-prim_GHC.Prim.(##)"} @ t_2032 15 | "prefetchMutableByteArray1#" :: {"MutableByteArray#" %s_210} @ t_2033 -> (T_Int64) @ t_2034 -> {"State#" %s_210} @ t_2035 -> {"ghc-prim_GHC.Prim.(##)"} @ t_2036 16 | "prefetchAddr1#" :: (T_Addr) @ t_2037 -> (T_Int64) @ t_2038 -> {"State#" %s_211} @ t_2039 -> {"ghc-prim_GHC.Prim.(##)"} @ t_2040 17 | "prefetchValue1#" :: %a_107 -> {"State#" %s_212} @ t_2041 -> {"ghc-prim_GHC.Prim.(##)"} @ t_2042 18 | "prefetchByteArray0#" :: {"ByteArray#"} @ t_2043 -> (T_Int64) @ t_2044 -> {"State#" %s_213} @ t_2045 -> {"ghc-prim_GHC.Prim.(##)"} @ t_2046 19 | "prefetchMutableByteArray0#" :: {"MutableByteArray#" %s_214} @ t_2047 -> (T_Int64) @ t_2048 -> {"State#" %s_214} @ t_2049 -> {"ghc-prim_GHC.Prim.(##)"} @ t_2050 20 | "prefetchAddr0#" :: (T_Addr) @ t_2051 -> (T_Int64) @ t_2052 -> {"State#" %s_215} @ t_2053 -> {"ghc-prim_GHC.Prim.(##)"} @ t_2054 21 | "prefetchValue0#" :: %a_108 -> {"State#" %s_216} @ t_2055 -> {"ghc-prim_GHC.Prim.(##)"} @ t_2056 22 | */ 23 | -------------------------------------------------------------------------------- /lambda/datalog/non-special-primops/PrimOp-Unsafe.dl: -------------------------------------------------------------------------------- 1 | /* 2 | {- 3 | Unsafe pointer equality 4 | -} 5 | primop pure 6 | - "reallyUnsafePtrEquality#" :: %a_88 -> %a_88 -> (T_Int64) @ t_1911 7 | 8 | */ 9 | -------------------------------------------------------------------------------- /lambda/datalog/outer-c.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -x -e 4 | 5 | souffle -c -j`nproc --all` -o called-by-outer called-by-outer.dl 6 | -------------------------------------------------------------------------------- /lambda/preprocess-ghc-primops/ghc-primop-gen.cabal: -------------------------------------------------------------------------------- 1 | Name: ghc-primop-gen 2 | Version: 0.1 3 | Copyright: XXX 4 | License: BSD3 5 | -- XXX License-File: LICENSE 6 | Author: XXX 7 | Maintainer: XXX 8 | Synopsis: Generates various files implementing GHC's primitive operations. 9 | Description: 10 | This utility reads a textual description of GHC's primitive operations 11 | (@primops.txt.pp@) and produces a number of outputs. These include, 12 | . 13 | * the @GHC.Prim@ module included in the @ghc-prim@ package. 14 | * the @GHC.PrimopWrappers@ module included in the @ghc-prim@ package. 15 | * an LaTeX document describing the primitive operations. 16 | Category: Development 17 | build-type: Simple 18 | cabal-version: >=1.10 19 | 20 | library 21 | hs-source-dirs: . genprimopcode 22 | 23 | exposed-modules: Lexer 24 | Parser 25 | ParserM 26 | Syntax 27 | Gen 28 | ghc-options: -Wall 29 | build-depends: base, 30 | array, 31 | containers, 32 | mtl, 33 | ansi-wl-pprint, 34 | pretty-show, 35 | lambda 36 | 37 | default-language: Haskell2010 38 | -------------------------------------------------------------------------------- /lambda/src/Lambda/Analysis/ControlFlowAnalysisM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, TupleSections, OverloadedStrings #-} 2 | module Lambda.Analysis.ControlFlowAnalysisM where 3 | 4 | -- NOTE: only when the whole program is available 5 | 6 | import Control.Monad 7 | import Data.Text (Text) 8 | import qualified Data.Text as Text 9 | import qualified Data.Text.IO as Text 10 | import Data.Map (Map) 11 | import qualified Data.Map as Map 12 | 13 | import System.Directory 14 | import System.FilePath 15 | import System.Process 16 | import System.IO 17 | import System.IO.Temp 18 | 19 | import Lambda.Syntax 20 | import Lambda.Datalog.ToDatalog 21 | 22 | controlFlowAnalysisM :: [String] -> [String] -> Program -> IO (Map String [[Text]]) 23 | controlFlowAnalysisM = controlFlowAnalysisImplM False 24 | 25 | controlFlowAnalysisLogM :: [String] -> [String] -> Program -> IO (Map String [[Text]]) 26 | controlFlowAnalysisLogM = controlFlowAnalysisImplM True 27 | 28 | controlFlowAnalysisImplM :: Bool -> [String] -> [String] -> Program -> IO (Map String [[Text]]) 29 | controlFlowAnalysisImplM log calledByOuterCode initialReachable prg = do 30 | 31 | tmpSys <- getCanonicalTemporaryDirectory 32 | tmpCfa <- createTempDirectory tmpSys "lambda-cfa" 33 | 34 | when log $ do 35 | putStrLn "controlFlowAnalysisM:" 36 | putStrLn $ "export facts to:" 37 | putStrLn tmpCfa 38 | 39 | programToFactsM log tmpCfa prg 40 | 41 | -- HINT: main function, that does not take closures or constructors as arguments, only C-land values 42 | let srcFile = tmpCfa "InitialReachable.facts" 43 | when log $ putStrLn srcFile 44 | writeFile srcFile $ unlines initialReachable 45 | 46 | -- HINT: these functions can receive closures and constructors as arguments 47 | let outerFile = tmpCfa "CalledByOuterCode.facts" 48 | when log $ putStrLn outerFile 49 | writeFile outerFile $ unlines calledByOuterCode 50 | 51 | when log $ putStrLn "run: lambda-cfa" 52 | callProcess "lambda-cfa" ["--output=" ++ tmpCfa, "--facts=" ++ tmpCfa, "--jobs=4"] 53 | 54 | when log $ putStrLn "read back result" 55 | result <- filter (\n -> takeExtension n == ".csv") <$> listDirectory tmpCfa 56 | Map.fromList <$> forM result 57 | (\fname -> do 58 | row <- map (Text.splitOn "\t") . Text.lines <$> Text.readFile (tmpCfa fname) 59 | pure (takeBaseName fname, row) 60 | ) 61 | -------------------------------------------------------------------------------- /lambda/src/Lambda/Lint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, RecordWildCards, OverloadedStrings #-} 2 | module Lambda.Lint where 3 | 4 | import Text.Printf 5 | 6 | import Data.Monoid 7 | import Data.Set (Set) 8 | import qualified Data.Set as Set 9 | import Data.Map (Map) 10 | import qualified Data.Map as Map 11 | import qualified Data.ByteString.Char8 as BS8 12 | 13 | import Data.Functor.Foldable 14 | import qualified Data.Foldable 15 | 16 | import Lambda.Syntax 17 | import Transformations.Util 18 | import Lambda.Util 19 | 20 | lintLambda :: Program -> IO () 21 | lintLambda prg@Program{..} = do 22 | let Env{..} = test prg 23 | tab = (" "++) . unpackName 24 | known = Set.unions 25 | [ Map.keysSet envDef 26 | , Set.fromList [eName | External{..} <- pExternals] 27 | , Set.fromList [sName | StaticData{..} <- pStaticData] 28 | ] 29 | unknown = Set.difference envUse known 30 | --printf "node pats:\n%s" . unlines . map tab $ Set.toList envCon 31 | 32 | printf "unknown:\n%s" . unlines . map tab $ Set.toList unknown 33 | printf "errors:\n%s" . unlines . map tab $ Set.toList envErr 34 | --printf "unused:\n%s" . unlines . map show $ Set.toList (Set.difference envDef envUse) 35 | let duplicates = [n | (n,i) <- Map.toList envDef, i > 1] 36 | printf "duplicates:\n%s" . unlines . map tab $ duplicates 37 | 38 | data Env 39 | = Env 40 | { envDef :: Map Name Int 41 | , envUse :: Set Name 42 | , envCon :: Set Name 43 | , envErr :: Set Name 44 | } 45 | 46 | instance Semigroup Env where (Env a1 b1 c1 d1) <> (Env a2 b2 c2 d2) = Env (Map.unionWith (+) a1 a2) (b1 <> b2) (c1 <> c2) (d1 <> d2) 47 | instance Monoid Env where mempty = env 48 | 49 | env = Env 50 | { envDef = mempty 51 | , envUse = mempty 52 | , envCon = mempty 53 | , envErr = mempty 54 | } 55 | 56 | addDef n = Map.singleton n 1 57 | addDefs ns = Map.unionsWith (+) $ map addDef ns 58 | 59 | addNames ns = Set.fromList ns 60 | 61 | test = cata folder where 62 | folder = \case 63 | -- use 64 | VarF name -> env {envUse = Set.singleton name} 65 | AppF name args -> env {envUse = addNames $ name : args} 66 | -- def 67 | DefF name args e -> env {envDef = addDefs $ name : map fst args} <> e 68 | LetRecF binds e -> mconcat [env {envDef = addDef name} <> a | (name, _, a) <- binds] <> e 69 | LetSF binds e -> mconcat [env {envDef = addDef name} <> a | (name, _, a) <- binds] <> e 70 | LetF binds e -> mconcat [env {envDef = addDef name} <> a | (name, _, a) <- binds] <> e 71 | ClosureF v p e -> env {envUse = addNames v, envDef = addDefs (map fst p)} <> e 72 | AltF a (NodePat con args) e -> env {envDef = addDefs (a : args), envCon = Set.singleton $ showTS (length args) <> "-" <> con} <> e 73 | -- err 74 | LitF (LError err) -> env {envErr = Set.singleton $ packName $ BS8.unpack err} 75 | e -> Data.Foldable.fold e 76 | 77 | expSize :: Exp -> Int 78 | expSize = cata folder where 79 | folder = \case 80 | VarF {} -> 1 81 | LitF {} -> 1 82 | e -> succ $ Data.Foldable.sum e 83 | 84 | programHistogram :: Program -> Map Int (Int, Name) 85 | programHistogram Program{..} = Map.unionsWith (\(i1,n1) (i2,n2) -> (i1 + i2, n1)) [Map.singleton (expSize d) (1, n) | d@(Def n _ _) <- pDefinitions] 86 | -------------------------------------------------------------------------------- /lambda/src/Lambda/Name.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, DeriveGeneric, DeriveAnyClass, StandaloneDeriving, LambdaCase, OverloadedStrings #-} 2 | module Lambda.Name where 3 | 4 | import GHC.Generics (Generic) 5 | import Data.Data 6 | import Data.String 7 | import Text.Printf 8 | import Data.Text (Text, pack, unpack, replace) 9 | 10 | -- Names are stored in NM form when we do program generation. NI is only used 11 | -- when we seralize the Exp 12 | data Name 13 | = NM { unNM :: !Text } 14 | | NI !Int 15 | deriving (Generic, Data, Eq, Ord, Show) 16 | 17 | nMap :: (Text -> Text) -> Name -> Name 18 | nMap f (NM n) = NM (f n) 19 | 20 | instance Semigroup Name where 21 | (NM n1) <> (NM n2) = NM (n1 <> n2) 22 | 23 | instance Monoid Name where 24 | mempty = NM mempty 25 | 26 | instance IsString Name where 27 | fromString = NM . fromString 28 | 29 | instance PrintfArg Name where 30 | formatArg = formatString . unpack . unNM 31 | 32 | -- utils 33 | unpackName :: Name -> String 34 | unpackName (NM name) = unpack name 35 | 36 | packName :: String -> Name 37 | packName = NM . pack 38 | 39 | showTS :: Show a => a -> Name 40 | showTS = packName . show 41 | 42 | -- module name handling 43 | -- Qualified Name = PACKAGE_ID + '_' + MODULE_NAME_THAT_CAN_CONTAIN_DOTS + '.' + DOT_ENCODED_NAME 44 | mkPackageQualifiedName :: String -> String -> String -> Name 45 | mkPackageQualifiedName pkg mod name = encodeUnderscore (packName pkg) <> "_" <> packName mod <> "." <> encodeDot (packName name) 46 | 47 | decodePackageQualifiedName :: Name -> Maybe (String, String, String) 48 | decodePackageQualifiedName n = do 49 | (pkg, mod_and_name) <- decodeUntil '_' $ unpackName n 50 | (rev_name, rev_mod) <- decodeUntil '.' $ reverse mod_and_name 51 | pure (pkg, reverse rev_mod, reverse rev_name) 52 | 53 | decodeUntil :: Char -> String -> Maybe (String, String) 54 | decodeUntil key = go [] where 55 | go locName (a : b : xs) 56 | | a == key 57 | , b == key 58 | = go (key : locName) xs 59 | go locName (a : xs) 60 | | a == key 61 | = Just (reverse locName, xs) 62 | go locName (x : xs) = go (x : locName) xs 63 | go locName [] = Nothing 64 | 65 | -- dot mangling 66 | encodeDot :: Name -> Name 67 | encodeDot = nMap $ replace "." ".." 68 | 69 | decodeDot :: Name -> Name 70 | decodeDot = nMap $ replace ".." "." 71 | 72 | -- underscore mangling 73 | encodeUnderscore :: Name -> Name 74 | encodeUnderscore = nMap $ replace "_" "__" 75 | 76 | decodeUnderscore :: Name -> Name 77 | decodeUnderscore = nMap $ replace "__" "_" 78 | -------------------------------------------------------------------------------- /lambda/src/Lambda/Stg/GHCPrimOps.hs: -------------------------------------------------------------------------------- 1 | ../../../preprocess-ghc-primops/GHCPrimOps.hs -------------------------------------------------------------------------------- /lambda/src/Lambda/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Lambda.TH 3 | ( progConst 4 | , prog 5 | ) where 6 | 7 | import Data.List (sort) 8 | import Data.Char 9 | import Data.Data 10 | import Data.Maybe 11 | import Text.Megaparsec 12 | import NeatInterpolation 13 | 14 | import qualified Lambda.Parse as P 15 | import qualified Data.Text as T 16 | 17 | import Language.Haskell.TH 18 | import Language.Haskell.TH.Syntax 19 | import Language.Haskell.TH.Quote 20 | 21 | prog :: QuasiQuoter 22 | prog = text { quoteExp = applyParseProg . quoteExp text } 23 | 24 | applyParseProg :: Q Exp -> Q Exp 25 | applyParseProg q = appE [|P.parseProg|] q 26 | 27 | liftText :: T.Text -> Q Exp 28 | liftText txt = AppE (VarE 'T.pack) <$> lift (T.unpack txt) 29 | 30 | liftDataWithText :: Data a => a -> Q Exp 31 | liftDataWithText = dataToExpQ (\a -> liftText <$> cast a) 32 | 33 | -- NOTE: does not support metavariables 34 | 35 | progConst :: QuasiQuoter 36 | progConst = QuasiQuoter 37 | { quoteExp = \input -> do 38 | let src = T.pack $ normalizeQQInput input 39 | case P.parseLambda "" src of 40 | Left e -> fail $ errorBundlePretty e 41 | Right p -> liftDataWithText p 42 | , quotePat = undefined 43 | , quoteType = undefined 44 | , quoteDec = undefined 45 | } 46 | 47 | -- 48 | -- NOTE: copy-paste utility from NeatInterpolation.String hidden module 49 | -- 50 | normalizeQQInput :: [Char] -> [Char] 51 | normalizeQQInput = trim . unindent' . tabsToSpaces 52 | where 53 | unindent' :: [Char] -> [Char] 54 | unindent' s = 55 | case lines s of 56 | head:tail -> 57 | let 58 | unindentedHead = dropWhile (== ' ') head 59 | minimumTailIndent = minimumIndent . unlines $ tail 60 | unindentedTail = case minimumTailIndent of 61 | Just indent -> map (drop indent) tail 62 | Nothing -> tail 63 | in unlines $ unindentedHead : unindentedTail 64 | [] -> [] 65 | 66 | trim :: [Char] -> [Char] 67 | trim = dropWhileRev isSpace . dropWhile isSpace 68 | 69 | dropWhileRev :: (a -> Bool) -> [a] -> [a] 70 | dropWhileRev p = foldr (\x xs -> if p x && null xs then [] else x:xs) [] 71 | 72 | unindent :: [Char] -> [Char] 73 | unindent s = 74 | case minimumIndent s of 75 | Just indent -> unlines . map (drop indent) . lines $ s 76 | Nothing -> s 77 | 78 | tabsToSpaces :: [Char] -> [Char] 79 | tabsToSpaces ('\t':tail) = " " ++ tabsToSpaces tail 80 | tabsToSpaces (head:tail) = head : tabsToSpaces tail 81 | tabsToSpaces [] = [] 82 | 83 | minimumIndent :: [Char] -> Maybe Int 84 | minimumIndent = 85 | listToMaybe . sort . map lineIndent 86 | . filter (not . null . dropWhile isSpace) . lines 87 | 88 | -- | Amount of preceding spaces on first line 89 | lineIndent :: [Char] -> Int 90 | lineIndent = length . takeWhile (== ' ') 91 | -------------------------------------------------------------------------------- /lambda/src/Lambda/Transformation/ClosureConversion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, OverloadedStrings, RecordWildCards #-} 2 | module Lambda.Transformation.ClosureConversion where 3 | 4 | import Control.Monad.State 5 | import Data.Functor.Foldable as Foldable 6 | import qualified Data.Foldable 7 | 8 | import Data.Set (Set) 9 | import qualified Data.Set as Set 10 | 11 | import Transformations.Util 12 | import Transformations.Names hiding (mkNameEnv) 13 | 14 | import Lambda.Syntax 15 | import Lambda.Util 16 | 17 | {- 18 | without :: Eq a => [a] -> [a] -> [a] 19 | without = foldr (filter . (/=)) -- Like \\ but removes all occurrences 20 | 21 | applyTo :: Exp -> [Name] -> Exp 22 | applyTo e [] = e 23 | applyTo (Var n) args = App n (map Var args) 24 | applyTo e args = AppExp e (map Var args) 25 | 26 | freeVars :: Exp -> [Name] -- Grab all the unbound variables in an expression 27 | freeVars = cata folder where 28 | folder = \case 29 | VarF v -> [v] 30 | AppF n e -> n : mconcat e 31 | LamF vs e -> e `without` vs 32 | e -> Data.Foldable.fold e 33 | 34 | closConv :: [Name] -> Exp -> Exp 35 | closConv globals = cata folder where 36 | folder (LamF vs e) = let vars = freeVars e `without` (globals ++ vs) 37 | in Lam (vars ++ vs) e `applyTo` vars 38 | folder e = embed e 39 | -} 40 | 41 | data Env 42 | = Env 43 | { envClosures :: [Def] 44 | , envCurrentDefName :: Name 45 | } 46 | 47 | type ClosM = StateT Env NameM 48 | 49 | setDefName :: Name -> ClosM () 50 | setDefName n = modify' $ \env -> env {envCurrentDefName = n} 51 | 52 | addDef :: Def -> ClosM () 53 | addDef def = modify' $ \env@Env{..} -> env {envClosures = def : envClosures} 54 | 55 | liftLam :: Exp -> ClosM Exp 56 | liftLam = hyloM folder builder where 57 | 58 | builder = \case 59 | e@(Def n _ _) -> do 60 | setDefName n 61 | pure $ project e 62 | e -> pure $ project e 63 | 64 | folder = \case 65 | {- 66 | LamF vs e -> do 67 | defName <- gets envCurrentDefName 68 | fresh <- lift $ deriveNewName $ defName <> ".closure" 69 | addDef $ Def fresh vs e 70 | pure $ Var False fresh 71 | -} 72 | -- smash 73 | {- 74 | AppExpF (Var _ n) args 75 | | all isAtom args -> pure $ App n args 76 | -} 77 | LetF l1 (Let l2 e) -> pure $ Let (l1 ++ l2) e 78 | LetSF l1 (LetS l2 e) -> pure $ LetS (l1 ++ l2) e 79 | e -> pure $ embed e 80 | {- 81 | smash :: Exp -> Exp 82 | smash = cata folder where 83 | folder = \case 84 | LamF vs (Lam vs' e) -> Lam (vs ++ vs') e 85 | AppExpF (Var n) args 86 | | all isAtom args -> App n args 87 | e -> embed e 88 | -} 89 | eliminateLams :: [Name] -> Program -> Program 90 | eliminateLams globals prg = resultPrg { pDefinitions = pDefinitions resultPrg ++ envClosures } where 91 | (resultPrg, Env{..}) = evalState (runStateT (liftLam{- . smash . closConv (defNames ++ globals)-} $ prg) emptyEnv) (mkNameEnv prg) 92 | --defNames = [n | Def n _ _ <- defs] 93 | emptyEnv = Env [] "" 94 | -------------------------------------------------------------------------------- /lambda/src/Lambda/Transformation/StaticSingleAssignment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, TupleSections, RecordWildCards #-} 2 | module Lambda.Transformation.StaticSingleAssignment where 3 | 4 | import Control.Monad.State 5 | import Data.Functor.Foldable 6 | import Data.Set (Set) 7 | import qualified Data.Set as Set 8 | import Data.Map (Map) 9 | import qualified Data.Map as Map 10 | import qualified Data.Foldable 11 | 12 | import Transformations.Names hiding (mkNameEnv) 13 | import Transformations.Util hiding (foldNameDefExpF) 14 | import Lambda.Syntax 15 | import Lambda.Util 16 | 17 | type Env = Map Name Name 18 | 19 | ssaExternal :: External -> NameM External 20 | ssaExternal ext@External{..} = do 21 | let names = Set.toList $ Set.unions [cata (foldNameTyF Set.singleton) t | t <- eRetType : eArgsType] 22 | env <- forM names $ \n -> do 23 | newN <- deriveNewName n 24 | pure (n, newN) 25 | let substFun :: Ty -> Ty 26 | substFun t = ana (project . mapNameTy (subst $ Map.fromList env)) t 27 | pure ext 28 | { eRetType = substFun eRetType 29 | , eArgsType = map substFun eArgsType 30 | } 31 | 32 | singleStaticAssignment :: Exp -> Exp 33 | singleStaticAssignment e = evalState (anaM build (mempty, e)) (mkNameEnv e) where 34 | 35 | mkName :: (Env, [(Name, RepType, (Env, Exp))]) -> (Name, RepType, Exp) -> NameM (Env, [(Name, RepType, (Env, Exp))]) 36 | mkName (env', l) (n, t, b) = do 37 | n' <- deriveNewName n 38 | pure (Map.insert n n' env', l ++ [(n', t, (env', b))]) 39 | 40 | add :: Env -> (Name, Name) -> Env 41 | add env (k,v) = Map.insert k v env 42 | 43 | addMany :: Env -> [(Name, Name)] -> Env 44 | addMany = foldl add 45 | 46 | build :: (Env, Exp) -> NameM (ExpF (Env, Exp)) 47 | build (env, e) = case e of 48 | 49 | Program{..} -> do 50 | newExts <- mapM ssaExternal pExternals 51 | pure $ ProgramF 52 | { pExternalsF = newExts 53 | , pConstructorsF = pConstructors 54 | , pPublicNamesF = pPublicNames 55 | , pForeignExportedNamesF = pForeignExportedNames 56 | , pStaticDataF = pStaticData 57 | , pDefinitionsF = map (env,) pDefinitions 58 | } 59 | 60 | -- name shadowing in the bind sequence 61 | 62 | Let bs e -> do 63 | (newEnv, bs') <- foldM mkName (env,[]) bs 64 | pure $ LetF bs' (newEnv, e) 65 | 66 | LetS bs e -> do 67 | (newEnv, bs') <- foldM mkName (env,[]) bs 68 | pure $ LetSF bs' (newEnv, e) 69 | 70 | LetRec bs e -> do 71 | let ns = map fst3 bs 72 | newNs <- mapM deriveNewName ns 73 | let newEnv = addMany env $ zip ns newNs 74 | pure $ LetRecF [(n, t, (newEnv, b)) | (n, (_, t, b)) <- zip newNs bs] (newEnv, e) 75 | 76 | Closure vs args e -> do 77 | let (argNames, argTypes) = unzip args 78 | newNs <- mapM deriveNewName argNames 79 | pure $ ClosureF (map (subst env) vs) (zip newNs argTypes) (addMany env $ zip argNames newNs, e) 80 | 81 | Def n args e -> do 82 | let (argNames, argTypes) = unzip args 83 | newNs <- mapM deriveNewName argNames 84 | pure $ DefF n (zip newNs argTypes) (addMany env $ zip argNames newNs, e) 85 | 86 | Alt a (NodePat n ns) e -> do 87 | newA <- deriveNewName a 88 | newNs <- mapM deriveNewName ns 89 | pure $ AltF newA (NodePat n newNs) (addMany env $ zip ns newNs, e) 90 | 91 | -- no name shadowing 92 | 93 | _ -> do 94 | newEnv <- foldM (\m n -> Map.insert n <$> deriveNewName n <*> pure m) env $ (foldLocalNameDefExp (:[]) e :: [Name]) 95 | pure $ (newEnv,) <$> (project $ mapLocalNameExp (subst newEnv) e) 96 | -------------------------------------------------------------------------------- /lambda/src/Transformations/Names.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, RecordWildCards, FlexibleInstances #-} 2 | module Transformations.Names where 3 | 4 | import Text.Printf 5 | import Data.Map (Map) 6 | import qualified Data.Map as Map 7 | import Data.Set (Set) 8 | import qualified Data.Set as Set 9 | 10 | import Control.Monad.State 11 | 12 | import Lambda.Name 13 | 14 | -- name monad 15 | 16 | data NameEnv 17 | = NameEnv 18 | { namePool :: Map Name Int 19 | , nameSet :: Set Name 20 | } 21 | 22 | type NameM = State NameEnv 23 | 24 | deriveNewName :: Name -> NameM Name 25 | deriveNewName name = do 26 | (newName, conflict) <- state $ \env@NameEnv{..} -> 27 | let idx = Map.findWithDefault 0 name namePool 28 | new = packName $ printf "%s_%d" name idx 29 | in ( (new, Set.member new nameSet) 30 | , env {namePool = Map.insert name (succ idx) namePool, nameSet = Set.insert new nameSet} 31 | ) 32 | if conflict 33 | then deriveNewName name 34 | else pure newName 35 | -------------------------------------------------------------------------------- /lambda/src/Transformations/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, FlexibleContexts, RecordWildCards #-} 2 | module Transformations.Util where 3 | 4 | import Control.Monad 5 | import Control.Comonad 6 | import Control.Comonad.Cofree 7 | import Data.Functor.Foldable as Foldable 8 | 9 | import Data.Map (Map) 10 | import qualified Data.Map as Map 11 | 12 | subst :: Ord a => Map a a -> a -> a 13 | subst env x = Map.findWithDefault x x env 14 | 15 | -- monadic recursion schemes 16 | -- see: https://jtobin.io/monadic-recursion-schemes 17 | 18 | cataM 19 | :: (Monad m, Traversable (Base t), Recursive t) 20 | => (Base t a -> m a) -> t -> m a 21 | cataM alg = c where 22 | c = alg <=< traverse c . project 23 | 24 | anaM 25 | :: (Monad m, Traversable (Base t), Corecursive t) 26 | => (a -> m (Base t a)) -> a -> m t 27 | anaM coalg = a where 28 | a = (pure . embed) <=< traverse a <=< coalg 29 | 30 | paraM 31 | :: (Monad m, Traversable (Base t), Recursive t) 32 | => (Base t (t, a) -> m a) -> t -> m a 33 | paraM alg = p where 34 | p = alg <=< traverse f . project 35 | f t = liftM2 (,) (pure t) (p t) 36 | 37 | apoM 38 | :: (Monad m, Traversable (Base t), Corecursive t) 39 | => (a -> m (Base t (Either t a))) -> a -> m t 40 | apoM coalg = a where 41 | a = (pure . embed) <=< traverse f <=< coalg 42 | f = either pure a 43 | 44 | hyloM 45 | :: (Monad m, Traversable t) 46 | => (t b -> m b) -> (a -> m (t a)) -> a -> m b 47 | hyloM alg coalg = h 48 | where h = alg <=< traverse h <=< coalg 49 | 50 | histoM 51 | :: (Monad m, Traversable (Base t), Recursive t) 52 | => (Base t (Cofree (Base t) a) -> m a) -> t -> m a 53 | histoM h = pure . extract <=< worker where 54 | worker = f <=< traverse worker . project 55 | f x = (:<) <$> h x <*> pure x 56 | 57 | -------------------------------------------------------------------------------- /lambda/test/ParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, QuasiQuotes, OverloadedStrings #-} 2 | module ParserSpec where 3 | 4 | import qualified Data.Text as Text 5 | import Test.Hspec 6 | import Test.QuickCheck 7 | 8 | import Lambda.TH 9 | import Lambda.Pretty 10 | import Lambda.Parse 11 | import Lambda.Syntax 12 | import Lambda.Pretty (PP(..)) 13 | 14 | runTests :: IO () 15 | runTests = hspec spec 16 | 17 | spec :: Spec 18 | spec = do 19 | describe "simple" $ do 20 | it "case" $ do 21 | let before = [prog| 22 | test p = 23 | letS 24 | x = case p of 25 | _ @ alt.1 -> 26 | letS 27 | r = #T_Int64 1 28 | r 29 | x 30 | |] 31 | let after = Program [] [] [] [] [] 32 | [ Def "test" [("p", Auto)] 33 | ( LetS 34 | [ ("x", Auto, Case "p" 35 | [ Alt "alt.1" DefaultPat 36 | ( LetS [("r", Auto, Lit (LInt64 1)) ] (Var "r")) 37 | ] 38 | ) 39 | ] (Var "x") 40 | ) 41 | ] 42 | (PP before) `shouldBe` (PP after) 43 | -------------------------------------------------------------------------------- /lambda/test/PrimOpCCSSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, QuasiQuotes, OverloadedStrings #-} 2 | module PrimOpCCSSpec where 3 | 4 | import qualified Data.Text as Text 5 | import qualified Data.Map as Map 6 | import qualified Data.Set as Set 7 | import Data.List (sort) 8 | import Data.IORef 9 | import Test.Hspec 10 | import Test.QuickCheck 11 | import System.IO 12 | import Text.Show.Pretty (pPrint, ppShow) 13 | import Text.PrettyPrint.ANSI.Leijen 14 | 15 | import Lambda.TH 16 | import Lambda.Analysis.ControlFlowAnalysisM 17 | import Lambda.Pretty (PP(..)) 18 | 19 | runTests :: IO () 20 | runTests = hspec spec 21 | 22 | spec :: Spec 23 | spec = do 24 | ---------------------------- 25 | usedRules <- runIO $ newIORef (Set.empty :: Set.Set [Text.Text]) 26 | 27 | let filterAndSort keys m = fmap sort $ Map.restrictKeys m (Set.fromList keys) 28 | 29 | sameAs :: Show a => a -> a -> IO () 30 | sameAs a b = (PP (ppShow a)) `shouldBe` (PP (ppShow b)) 31 | 32 | toCCSOp = filterAndSort ["NodeOrigin", "ExternalOrigin", "TagValue"] 33 | addUsedM a = modifyIORef usedRules (\x -> mappend x . Set.fromList . head . Map.elems . filterAndSort ["Used"] $ a) 34 | printUsedM = readIORef usedRules >>= pPrint 35 | 36 | ---------------------------- 37 | 38 | describe "GHC CCS PrimOps" $ do 39 | 40 | it "clearCCS#" $ do 41 | cfa <- controlFlowAnalysisM [] ["main"] [prog| 42 | primop effectful 43 | "clearCCS#" :: (tf.4 : {"State#" {RealWorld} @ t.14} @ t.13 -> {"ghc-prim_GHC.Prim.Unit#" %a.1} @ t.15) -> {"State#" {RealWorld} @ t.17} @ t.16 -> {"ghc-prim_GHC.Prim.Unit#" %a.1} @ t.18 44 | 45 | main = 46 | letS 47 | v00 = #T_Token "RealWorld" 48 | v01 = "clearCCS#" $ fun1 v00 49 | v02 = case v01 of 50 | ("ghc-prim_GHC.Prim.Unit#" v03) @ a00 -> 51 | v03 52 | v02 53 | fun1 p10 = 54 | letS 55 | v10 = #T_Int64 0 56 | v11 = ["ghc-prim_GHC.Prim.Unit#" v10] 57 | v11 58 | |] 59 | addUsedM cfa 60 | toCCSOp cfa `sameAs` Map.fromList 61 | [ ( "ExternalOrigin" 62 | , [ [ "a00" , "v01" , "t.18" ] 63 | , [ "v01" , "v01" , "t.18" ] 64 | , [ "v02" , "v01" , "a.1" ] 65 | , [ "v03" , "v01" , "a.1" ] 66 | ] 67 | ) 68 | , ( "NodeOrigin" 69 | , [ [ "a00" , "v11" ] 70 | , [ "p10" , "v00" ] 71 | , [ "v00" , "v00" ] 72 | , [ "v01" , "v11" ] 73 | , [ "v02" , "v10" ] 74 | , [ "v03" , "v10" ] 75 | , [ "v10" , "v10" ] 76 | , [ "v11" , "v11" ] 77 | ] 78 | ) 79 | , ( "TagValue" 80 | , [ [ "a00" , "ghc-prim_GHC.Prim.Unit#" ] 81 | , [ "p10" , "lit:T_Token \"RealWorld\"" ] 82 | , [ "v00" , "lit:T_Token \"RealWorld\"" ] 83 | , [ "v01" , "ghc-prim_GHC.Prim.Unit#" ] 84 | , [ "v02" , "lit:T_Int64" ] 85 | , [ "v03" , "lit:T_Int64" ] 86 | , [ "v10" , "lit:T_Int64" ] 87 | , [ "v11" , "ghc-prim_GHC.Prim.Unit#" ] 88 | ] 89 | ) 90 | ] 91 | 92 | describe "Coverage" $ do 93 | it "Used Rules" $ do 94 | printUsedM 95 | -------------------------------------------------------------------------------- /lambda/test/Spec.hs: -------------------------------------------------------------------------------- 1 | -- file test/Spec.hs 2 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.18 2 | 3 | packages: 4 | - 'external-stg-syntax' 5 | - 'external-stg' 6 | - 'external-stg-interpreter' 7 | # - 'lambda' 8 | # - 'external-stg-compiler' 9 | 10 | extra-deps: 11 | - dom-lt-0.2.3 12 | - souffle-haskell-3.5.1 13 | - type-errors-pretty-0.0.1.2@sha256:9042b64d1ac2f69aa55690576504a2397ebea8a6a55332242c88f54027c7eb57,2781 14 | - github: csabahruska/final-pretty-printer 15 | commit: 5444974a2e0ee76abb790c85738a38f96696c908 16 | 17 | allow-newer: true 18 | -------------------------------------------------------------------------------- /wpc-plugin/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for wpc-plugin 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /wpc-plugin/external-stg-syntax: -------------------------------------------------------------------------------- 1 | ../external-stg-syntax -------------------------------------------------------------------------------- /wpc-plugin/src/WPC/ForeignStubDecls.hs: -------------------------------------------------------------------------------- 1 | module WPC.ForeignStubDecls where 2 | 3 | import GHC.Plugins 4 | import GHC.Types.ForeignStubs 5 | import GHC.Types.ForeignCall 6 | import GHC.Hs.Extension 7 | import Language.Haskell.Syntax.Decls 8 | 9 | -- | Foreign export stub detailed declarations 10 | newtype ForeignStubDecls = ForeignStubDecls [(ForeignStubs, StubDecl)] 11 | 12 | data StubImpl 13 | = StubImplImportCWrapper 14 | { siCWrapperLabel :: FastString 15 | , siStdCallArgSize :: (Maybe Int) -- arg list size for std call mangling 16 | , siIsIOCall :: Bool 17 | , siReturnType :: String 18 | , siArgTypes :: [String] 19 | } 20 | 21 | data StubDecl 22 | = StubDeclImport (ForeignImport GhcTc) (Maybe StubImpl) 23 | | StubDeclExport (ForeignExport GhcTc) Id -- HINT: exported HsId 24 | 25 | mergeForeignStubs :: [ForeignStubs] -> ForeignStubs 26 | mergeForeignStubs stubs = case [(h, c) | ForeignStubs h c <- stubs] of 27 | [] -> NoStubs 28 | l -> ForeignStubs h c where (h, c) = mconcat l 29 | 30 | -------------------------------------------------------------------------------- /wpc-plugin/src/WPC/GlobalEnv.hs: -------------------------------------------------------------------------------- 1 | module WPC.GlobalEnv where 2 | 3 | import Data.IORef 4 | import System.IO.Unsafe 5 | 6 | import GHC.Plugins 7 | import GHC.Stg.Syntax 8 | import GHC.Types.ForeignStubs 9 | 10 | import WPC.ForeignStubDecls 11 | 12 | data GlobalEnv 13 | = GlobalEnv 14 | { geModSummary :: Maybe ModSummary 15 | , geModGuts :: Maybe ModGuts 16 | , geStgBinds :: Maybe [CgStgTopBinding] 17 | , geHscEnv :: Maybe HscEnv 18 | , geStubDecls :: Maybe [(ForeignStubs, StubDecl)] 19 | } 20 | 21 | emptyGlobalEnv :: GlobalEnv 22 | emptyGlobalEnv 23 | = GlobalEnv 24 | { geModSummary = Nothing 25 | , geModGuts = Nothing 26 | , geStgBinds = Nothing 27 | , geHscEnv = Nothing 28 | , geStubDecls = Nothing 29 | } 30 | 31 | {-# NOINLINE globalEnvIORef #-} 32 | globalEnvIORef :: IORef GlobalEnv 33 | globalEnvIORef = unsafePerformIO $ newIORef emptyGlobalEnv 34 | -------------------------------------------------------------------------------- /wpc-plugin/src/WPC/Stubs.hs: -------------------------------------------------------------------------------- 1 | module WPC.Stubs where 2 | 3 | import GHC.Plugins 4 | import GHC.Types.ForeignStubs 5 | import GHC.Types.ForeignCall 6 | import GHC.Driver.CodeOutput 7 | import GHC.Driver.Pipeline.Execute 8 | import Language.Haskell.Syntax.Decls 9 | import WPC.ForeignStubDecls 10 | 11 | import System.Directory 12 | import System.FilePath 13 | 14 | import Data.Maybe 15 | 16 | outputCapiStubs :: HscEnv -> Module -> ModLocation -> [(ForeignStubs, StubDecl)] -> IO () 17 | outputCapiStubs hscEnv cg_module modLocation stubDecls = do 18 | let dflags = hsc_dflags hscEnv 19 | tmpfs = hsc_tmpfs hscEnv 20 | logger = hsc_logger hscEnv 21 | modName = moduleName cg_module 22 | 23 | capiStubs = mergeForeignStubs [s | (s, StubDeclImport (CImport _srcText(L _ CApiConv) _safety _mHeader _spec) _) <- stubDecls] 24 | 25 | (_has_h, maybe_capi_stub_c) <- outputForeignStubs logger tmpfs dflags (hsc_units hscEnv) cg_module modLocation capiStubs 26 | mapM_ (compileCapiStubs hscEnv modName) maybe_capi_stub_c 27 | 28 | compileCapiStubs :: HscEnv -> ModuleName -> FilePath -> IO () 29 | compileCapiStubs hscEnv modName capi_stub_c = do 30 | capi_stub_o <- compileStub hscEnv capi_stub_c 31 | let dflags = hsc_dflags hscEnv 32 | odir = fromMaybe "." (objectDir dflags) 33 | 34 | pp :: Outputable a => a -> String 35 | pp = showSDoc dflags . ppr 36 | 37 | stubPath = foldr1 () . split '.' $ pp modName 38 | wpcCapiStub = odir "extra-compilation-artifacts" "wpc-plugin" "capi-stubs" stubPath "capi_stub" ++ takeExtension capi_stub_o 39 | 40 | putStrLn $ "compileCapiStubs odir - " ++ odir 41 | putStrLn $ "compileCapiStubs capi_stub_o - " ++ capi_stub_o 42 | putStrLn $ "compileCapiStubs wpcCapiStub - " ++ wpcCapiStub 43 | createDirectoryIfMissing True (takeDirectory wpcCapiStub) 44 | copyFile capi_stub_o wpcCapiStub 45 | -------------------------------------------------------------------------------- /wpc-plugin/src/WPC/Yaml.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | module WPC.Yaml where 4 | 5 | import GHC.Prelude 6 | import GHC.Utils.Json 7 | import GHC.Utils.Outputable 8 | 9 | renderYAML :: JsonDoc -> SDoc 10 | renderYAML d = 11 | case d of 12 | JSNull -> text "null" 13 | JSBool b -> text $ if b then "true" else "false" 14 | JSInt n -> ppr n 15 | JSString s -> doubleQuotes $ text $ escapeJsonString s 16 | JSArray l -> vcat [ if isContainer value 17 | then text "-" $+$ nest 2 (renderYAML value) 18 | else text "-" <+> renderYAML value 19 | | value <- l 20 | ] 21 | JSObject l -> vcat [ if isContainer value 22 | then text key <> colon $+$ nest 2 (renderYAML value) 23 | else text key <> colon <+> renderYAML value 24 | | (key, value) <- l 25 | ] 26 | where 27 | isContainer = \case 28 | JSArray{} -> True 29 | JSObject{} -> True 30 | _ -> False 31 | -------------------------------------------------------------------------------- /wpc-plugin/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2023-01-02 2 | allow-newer: true 3 | 4 | packages: 5 | - . 6 | - external-stg-syntax 7 | 8 | # HINT: wpc-plugin relies on GHC 9.6 plugin API 9 | compiler: ghc-9.6.1 10 | compiler-check: match-exact 11 | -------------------------------------------------------------------------------- /wpc-plugin/wpc-plugin.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: wpc-plugin 3 | version: 1.1.0 4 | 5 | -- A short (one-line) description of the package. 6 | synopsis: WPC plugin for GHC 9.10.1 7 | 8 | -- A longer description of the package. 9 | -- description: 10 | 11 | -- A URL where users can report bugs. 12 | -- bug-reports: 13 | 14 | -- The license under which the package is released. 15 | -- license: 16 | author: Csaba Hruska 17 | maintainer: csaba.hruska@gmail.com 18 | 19 | -- A copyright notice. 20 | -- copyright: 21 | -- category: 22 | extra-source-files: CHANGELOG.md 23 | 24 | library 25 | exposed-modules: WPC.Plugin 26 | WPC.Modpak 27 | WPC.StgToExtStg 28 | WPC.GhcStgApp 29 | WPC.Stubs 30 | WPC.Foreign 31 | WPC.ForeignStubDecls 32 | WPC.Yaml 33 | WPC.GlobalEnv 34 | 35 | -- Modules included in this library but not exported. 36 | -- other-modules: 37 | 38 | -- LANGUAGE extensions used by modules in this package. 39 | -- other-extensions: 40 | build-depends: base, 41 | binary, 42 | bytestring, 43 | containers, 44 | deepseq, 45 | directory, 46 | external-stg-syntax, 47 | filepath, 48 | ghc, 49 | ghc-boot, 50 | mtl 51 | hs-source-dirs: src 52 | default-language: Haskell2010 53 | 54 | foreign-library wpc-plugin 55 | type: native-shared 56 | default-language: Haskell2010 57 | hs-source-dirs: src 58 | 59 | ghc-options: -this-unit-id wpc-plugin-unit 60 | -fno-link-rts 61 | 62 | build-depends: base, 63 | binary, 64 | bytestring, 65 | containers, 66 | deepseq, 67 | directory, 68 | external-stg-syntax, 69 | filepath, 70 | ghc, 71 | ghc-boot, 72 | mtl 73 | 74 | other-modules: WPC.Plugin 75 | WPC.Modpak 76 | WPC.StgToExtStg 77 | WPC.GhcStgApp 78 | WPC.Stubs 79 | WPC.Foreign 80 | WPC.ForeignStubDecls 81 | WPC.Yaml 82 | WPC.GlobalEnv 83 | --------------------------------------------------------------------------------