<commit_before>{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module IRTS.CodegenLLVM (codegenLLVM) where

import IRTS.CodegenCommon
import IRTS.Lang
import IRTS.Simplified
import qualified Core.TT as TT

import Util.System
import Paths_idris

import LLVM.General.Context
import LLVM.General.Diagnostic
import LLVM.General.AST
import LLVM.General.AST.AddrSpace
import qualified LLVM.General.Module as M
import qualified LLVM.General.AST.IntegerPredicate as IPred
import qualified LLVM.General.AST.Linkage as L
import qualified LLVM.General.AST.Visibility as V
import qualified LLVM.General.AST.CallingConvention as CC
import qualified LLVM.General.AST.Attribute as A
import qualified LLVM.General.AST.Global as G
import qualified LLVM.General.AST.Constant as C
import qualified LLVM.General.AST.Float as F

import Data.List
import Data.Maybe
import Data.Word
import Data.Set (Set)
import qualified Data.Set as S
import Control.Applicative
import Control.Monad.RWS
import Control.Monad.Writer
import Control.Monad.State

import System.Info (arch)
import System.IO
import System.Directory (removeFile)
import System.FilePath ((</>))
import System.Process (rawSystem)
import System.Exit (ExitCode(..))
import Debug.Trace

codegenLLVM :: [(TT.Name, SDecl)] ->
               FilePath -> -- output file name
               OutputType ->
               IO ()
codegenLLVM defs file outty = withContext $ \context -> do
  let ast = codegen arch (map snd defs)
  result <- M.withModuleFromAST context ast (outputModule file outty)
  case result of
    Right _ -> return ()
    Left msg -> ierror msg

itWidth :: IntTy -> Word32
itWidth ITNative = 32
itWidth x = fromIntegral $ intTyWidth x

outputModule :: FilePath -> OutputType -> M.Module -> IO ()
outputModule file Raw    m = M.writeBitcodeToFile file m
outputModule file Object m = withTmpFile $ \bc -> do
  outputModule bc Raw m
  exit <- rawSystem "llc" ["-filetype=obj", "--disable-fp-elim", "-o", file, bc]
  when (exit /= ExitSuccess) $ ierror "FAILURE: Object generation"
outputModule file Executable m = withTmpFile $ \obj -> do
  outputModule obj Object m
  cc <- getCC
  defs <- (</> "llvm" </> "libidris_rts.a") <$> getDataDir
  exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file]
  when (exit /= ExitSuccess) $ ierror "FAILURE: Linking"

withTmpFile :: (FilePath -> IO a) -> IO a
withTmpFile f = do
  (path, handle) <- tempfile
  hClose handle
  result <- f path
  removeFile path
  return result

ierror :: String -> a
ierror msg = error $ "INTERNAL ERROR: IRTS.CodegenLLVM: " ++ msg

mainDef :: Global
mainDef =
    functionDefaults
    { G.returnType = IntegerType 32
    , G.parameters =
        ([ Parameter (IntegerType 32) (Name "argc") []
         , Parameter (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) (Name "argv") []
         ], False)
    , G.name = Name "main"
    , G.basicBlocks =
        [ BasicBlock (UnName 0)
          [ UnName 1 := idrCall "{runMain0}" [] ] -- TODO: Set GMP memory functions
          (Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [])
        ]}

initDefs :: String -> [Definition]
initDefs tgt =
    [ TypeDefinition (Name "valTy")
      (Just $ StructureType False
                [ IntegerType 32
                , ArrayType 0 (PointerType valueType (AddrSpace 0))
                ])
    , TypeDefinition (Name "mpz")
        (Just $ StructureType False
                  [ IntegerType 32
                  , IntegerType 32
                  , PointerType intPtr (AddrSpace 0)
                  ])
    , GlobalDefinition $ globalVariableDefaults
      { G.name = Name "__idris_intFmtStr"
      , G.linkage = L.Internal
      , G.isConstant = True
      , G.hasUnnamedAddr = True
      , G.type' = ArrayType 5 (IntegerType 8)
      , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%lld" ++ [C.Int 8 0])
      }
    , rtsFun "intStr" ptrI8 [IntegerType 64]
        [ BasicBlock (UnName 0)
          [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 21)]
          , UnName 2 := simpleCall "snprintf"
                       [ LocalReference (UnName 1)
                       , ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 21)
                       , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
                       , LocalReference (UnName 0)
                       ]
          ]
          (Do $ Ret (Just (LocalReference (UnName 1))) [])
        ]
    , exfun "llvm.trap" VoidType [] False
    , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True
    , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False
    , exfun "strlen" intPtr [ptrI8] False
    , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False<commit_msg>Initialize Boehm GC (hopefully fixes OSX)<commit_after>{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module IRTS.CodegenLLVM (codegenLLVM) where

import IRTS.CodegenCommon
import IRTS.Lang
import IRTS.Simplified
import qualified Core.TT as TT

import Util.System
import Paths_idris

import LLVM.General.Context
import LLVM.General.Diagnostic
import LLVM.General.AST
import LLVM.General.AST.AddrSpace
import qualified LLVM.General.Module as M
import qualified LLVM.General.AST.IntegerPredicate as IPred
import qualified LLVM.General.AST.Linkage as L
import qualified LLVM.General.AST.Visibility as V
import qualified LLVM.General.AST.CallingConvention as CC
import qualified LLVM.General.AST.Attribute as A
import qualified LLVM.General.AST.Global as G
import qualified LLVM.General.AST.Constant as C
import qualified LLVM.General.AST.Float as F

import Data.List
import Data.Maybe
import Data.Word
import Data.Set (Set)
import qualified Data.Set as S
import Control.Applicative
import Control.Monad.RWS
import Control.Monad.Writer
import Control.Monad.State

import System.Info (arch)
import System.IO
import System.Directory (removeFile)
import System.FilePath ((</>))
import System.Process (rawSystem)
import System.Exit (ExitCode(..))
import Debug.Trace

codegenLLVM :: [(TT.Name, SDecl)] ->
               FilePath -> -- output file name
               OutputType ->
               IO ()
codegenLLVM defs file outty = withContext $ \context -> do
  let ast = codegen arch (map snd defs)
  result <- M.withModuleFromAST context ast (outputModule file outty)
  case result of
    Right _ -> return ()
    Left msg -> ierror msg

itWidth :: IntTy -> Word32
itWidth ITNative = 32
itWidth x = fromIntegral $ intTyWidth x

outputModule :: FilePath -> OutputType -> M.Module -> IO ()
outputModule file Raw    m = M.writeBitcodeToFile file m
outputModule file Object m = withTmpFile $ \bc -> do
  outputModule bc Raw m
  exit <- rawSystem "llc" ["-filetype=obj", "--disable-fp-elim", "-o", file, bc]
  when (exit /= ExitSuccess) $ ierror "FAILURE: Object generation"
outputModule file Executable m = withTmpFile $ \obj -> do
  outputModule obj Object m
  cc <- getCC
  defs <- (</> "llvm" </> "libidris_rts.a") <$> getDataDir
  exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file]
  when (exit /= ExitSuccess) $ ierror "FAILURE: Linking"

withTmpFile :: (FilePath -> IO a) -> IO a
withTmpFile f = do
  (path, handle) <- tempfile
  hClose handle
  result <- f path
  removeFile path
  return result

ierror :: String -> a
ierror msg = error $ "INTERNAL ERROR: IRTS.CodegenLLVM: " ++ msg

mainDef :: Global
mainDef =
    functionDefaults
    { G.returnType = IntegerType 32
    , G.parameters =
        ([ Parameter (IntegerType 32) (Name "argc") []
         , Parameter (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) (Name "argv") []
         ], False)
    , G.name = Name "main"
    , G.basicBlocks =
        [ BasicBlock (UnName 0)
          [ UnName 1 := simpleCall "GC_init" []
          , UnName 2 := idrCall "{runMain0}" [] ] -- TODO: Set GMP memory functions
          (Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [])
        ]}

initDefs :: String -> [Definition]
initDefs tgt =
    [ TypeDefinition (Name "valTy")
      (Just $ StructureType False
                [ IntegerType 32
                , ArrayType 0 (PointerType valueType (AddrSpace 0))
                ])
    , TypeDefinition (Name "mpz")
        (Just $ StructureType False
                  [ IntegerType 32
                  , IntegerType 32
                  , PointerType intPtr (AddrSpace 0)
                  ])
    , GlobalDefinition $ globalVariableDefaults
      { G.name = Name "__idris_intFmtStr"
      , G.linkage = L.Internal
      , G.isConstant = True
      , G.hasUnnamedAddr = True
      , G.type' = ArrayType 5 (IntegerType 8)
      , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%lld" ++ [C.Int 8 0])
      }
    , rtsFun "intStr" ptrI8 [IntegerType 64]
        [ BasicBlock (UnName 0)
          [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 21)]
          , UnName 2 := simpleCall "snprintf"
                       [ LocalReference (UnName 1)
                       , ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 21)
                       , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
                       , LocalReference (UnName 0)
                       ]
          ]
          (Do $ Ret (Just (LocalReference (UnName 1))) [])
        ]
    , exfun "llvm.trap" VoidType [] False
    , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True
    , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False
    , exfun "strlen" intPtr [ptrI8] False
    , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False
    , exfun "GC_init" VoidType [] False
{'fraction_non_alphanumeric': 0.10984075132707227, 'fraction_numerical': 0.0129644752960392, 'mean_word_length': 2.706772606886114, 'pattern_counts': {'":': 0, '<': 25, '<?xml version=': 0, '>': 43, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4297707', 'n_tokens_mistral': 3171, 'n_tokens_neox': 3029, 'n_words': 934}