godbolt.hs

{-# LANGUAGE Strict #-}

import Control.Exception
import Data.Char
import Data.List
import Data.Semigroup
import GHC
  ( defaultErrorHandler,
    getSessionDynFlags,
    runGhc,
    setSessionDynFlags,
  )
import GHC.Cmm
import GHC.CmmToC
import GHC.Plugins hiding ((<>))
import GHC.Prelude
import GHC.Types.Unique
import System.Directory
import System.FilePath
import System.Process

myShowSDoc :: DynFlags -> SDoc -> String
myShowSDoc dflags doc = showSDocOneLine (initSDocContext dflags PprCode) doc

argDecl :: DynFlags -> LocalReg -> String
argDecl dflags l@(LocalReg _ rep) =
  intercalate " " $
    map (myShowSDoc dflags) [machRepCType platform rep, pprLocalReg l]
  where
    platform = targetPlatform dflags

funcDecl :: DynFlags -> String -> [LocalReg] -> CmmExpr -> String
funcDecl dflags func_name func_args func_body =
  filter isPrint $
    intercalate " " $
      [ my_show $ machRepCType platform $ cmmExprType platform func_body,
        func_name,
        "("
      ]
        <> intersperse "," [argDecl dflags arg | arg <- func_args]
        <> [")", "{", "return", my_show $ pprExpr platform func_body, ";", "}"]
  where
    platform = targetPlatform dflags

    my_show = myShowSDoc dflags

callishFunDecl ::
  DynFlags -> String -> CallishMachOp -> [LocalReg] -> [LocalReg] -> String
callishFunDecl dflags func_name op ret_regs arg_regs =
  filter isPrint $
    intercalate " " $
      [ret_reg_ty, func_name, "("]
        <> intersperse "," [argDecl dflags arg | arg <- arg_regs]
        <> [ ")",
             "{",
             ret_reg_decl,
             my_show $
               pprStmt platform $
                 CmmUnsafeForeignCall
                   (PrimTarget op)
                   ret_regs
                   [CmmReg $ CmmLocal arg | arg <- arg_regs],
             ret_reg_return,
             "}"
           ]
  where
    platform = targetPlatform dflags

    my_show = myShowSDoc dflags

    (ret_reg_ty, ret_reg_decl, ret_reg_return) = case ret_regs of
      [] -> ("void", "", "")
      [ret_reg] ->
        (reg_ty, reg_ty <> " " <> reg_name <> ";", "return " <> reg_name <> ";")
        where
          reg_ty = my_show $ machRepCType platform $ localRegType ret_reg

          reg_name = my_show $ pprLocalReg ret_reg
      _ -> panic "more than one ret reg"

main :: IO ()
main =
  defaultErrorHandler defaultFatalMessager defaultFlushOut $
    runGhc (Just "/workspace/ghc/_build/stage1/lib") $
      do
        setSessionDynFlags =<< getSessionDynFlags
        dflags <- getSessionDynFlags
        let w0 = W8
            w1 = W32
            x = LocalReg (mkUniqueGrimily 0) (cmmBits w0)
            ptr = LocalReg (mkUniqueGrimily 1) b32
            load_ptr = CmmLoad (CmmReg $ CmmLocal ptr) (cmmBits w0) Unaligned
            hc =
              "#include \"Stg.h\"\n\n"
                <> funcDecl
                  dflags
                  "foo"
                  [arg0, arg1]
                  ( CmmMachOp
                      (MO_S_MulMayOflo W32)
                      [CmmReg $ CmmLocal reg | reg <- [arg0, arg1]]
                  )
            arg0 = LocalReg (mkUniqueGrimily 0) b32
            arg1 = LocalReg (mkUniqueGrimily 1) b32
            ret0 = LocalReg (mkUniqueGrimily 2) b32
            hc_callish =
              "#include \"Stg.h\"\n\n"
                <> callishFunDecl dflags "foo" (undefined) [ret0] [arg0, arg1]
        liftIO $ do
          r <- runClang hc
          putStrLn r

runClang :: String -> IO String
runClang hc = withTmpDir $ \d -> do
  let hc_path = d </> "tmp.hc"
      s_path = d </> "tmp.s"
  writeFile hc_path hc
  callProcess
    "/workspace/.ghc-wasm/wasi-sdk/bin/clang"
    [ "-x",
      "c",
      "-S",
      hc_path,
      "-o",
      s_path,
      "-fno-PIC",
      "-Wimplicit",
      "-fwrapv",
      "-fno-builtin",
      "-fno-strict-aliasing",
      "-include",
      "/workspace/ghc/_build/stage1/lib/wasm32-wasi-ghc-9.5.20221126/rts-1.0.2/include/ghcversion.h",
      "-iquote.",
      "-I/workspace/ghc/_build/stage1/lib/wasm32-wasi-ghc-9.5.20221126/base-4.17.0.0/include",
      "-I/workspace/ghc/_build/stage1/lib/wasm32-wasi-ghc-9.5.20221126/ghc-bignum-1.3/include",
      "-I/workspace/ghc/_build/stage1/lib/wasm32-wasi-ghc-9.5.20221126/rts-1.0.2/include",
      "-DUSE_MINIINTERPRETER",
      "-DNO_REGS",
      "-msign-ext",
      "-mbulk-memory",
      "-mreference-types",
      "-mnontrapping-fptoint",
      "-mmutable-globals",
      "-O1",
      "-Wno-int-conversion",
      "--target=wasm32-unknown-wasi"
    ]
  ls <- lines <$> readFile s_path
  pure $
    unlines $
      takeWhile (not . ("end_function" `isInfixOf`)) $
        dropWhile (not . ("foo:" `isInfixOf`)) $
          ls

withTmpDir :: (FilePath -> IO r) -> IO r
withTmpDir =
  bracket
    (takeWhile (not . isSpace) <$> readProcess "mktemp" ["-d"] "")
    removePathForcibly