{-# LANGUAGE GeneralizedNewtypeDeriving #-} module IRTS.CodegenLLVM (codegenLLVM) where import IRTS.CodegenCommon import IRTS.Lang import IRTS.Simplified import qualified Core.TT as TT import Core.TT (ArithTy(..), IntTy(..), NativeTy(..), nativeTyWidth) import Util.System import Paths_idris import LLVM.General.Context import LLVM.General.Diagnostic import LLVM.General.AST import LLVM.General.AST.AddrSpace import LLVM.General.Target ( TargetMachine , withTargetOptions, withTargetMachine, getTargetMachineDataLayout , initializeAllTargets, lookupTarget ) import LLVM.General.AST.DataLayout import qualified LLVM.General.PassManager as PM 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 qualified LLVM.General.Relocation as R import qualified LLVM.General.CodeModel as CM import qualified LLVM.General.CodeGenOpt as CGO import Data.List import Data.Maybe import Data.Word import Data.Set (Set) import qualified Data.Set as S import qualified Data.Map as M import qualified Data.Vector.Unboxed as V import Control.Applicative import Control.Monad.RWS import Control.Monad.Writer import Control.Monad.State import Control.Monad.Error import qualified System.Info as SI (arch, os) import System.IO import System.Directory (removeFile) import System.FilePath (()) import System.Process (rawSystem) import System.Exit (ExitCode(..)) import Debug.Trace data Target = Target { triple :: String, dataLayout :: DataLayout } codegenLLVM :: [(TT.Name, SDecl)] -> String -> -- target triple String -> -- target CPU Word -> -- Optimization degree FilePath -> -- output file name OutputType -> IO () codegenLLVM defs triple cpu optimize file outty = withContext $ \context -> do initializeAllTargets (target, _) <- failInIO $ lookupTarget Nothing triple withTargetOptions $ \options -> withTargetMachine target triple cpu S.empty options R.Default CM.Default CGO.Default $ \tm -> do layout <- getTargetMachineDataLayout tm let ast = codegen (Target triple layout) (map snd defs) result <- runErrorT . M.withModuleFromAST context ast $ \m -> do let opts = PM.defaultCuratedPassSetSpec { PM.optLevel = Just optimize , PM.simplifyLibCalls = Just True , PM.useInlinerWithThreshold = Just 225 } when (optimize /= 0) $ PM.withPassManager opts $ void . flip PM.runPassManager m outputModule tm file outty m case result of Right _ -> return () Left msg -> ierror msg failInIO :: ErrorT String IO a -> IO a failInIO = either fail return <=< runErrorT outputModule :: TargetMachine -> FilePath -> OutputType -> M.Module -> IO () outputModule _ file Raw m = failInIO $ M.writeBitcodeToFile file m outputModule tm file Object m = failInIO $ M.writeObjectToFile tm file m outputModule tm file Executable m = withTmpFile $ \obj -> do outputModule tm 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) [ Do $ simpleCall "GC_init" [] -- Initialize Boehm GC , Do $ simpleCall "__gmp_set_memory_functions" [ ConstantOperand . C.GlobalReference . Name $ "__idris_gmpMalloc" , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpRealloc" , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpFree" ] , UnName 1 := idrCall "{runMain0}" [] ] (Do $ Ret (Just (ConstantOperand (C.Int 32 0))) []) ]} initDefs :: Target -> [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 (tgtWordSize tgt) 21)] , UnName 2 := simpleCall "snprintf" [ LocalReference (UnName 1) , ConstantOperand (C.Int (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 "llvm.llvm.memcpy.p0i8.p0i8.i32" VoidType [ptrI8, ptrI8, IntegerType 32, IntegerType 32, IntegerType 1] False -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i64" VoidType [ptrI8, ptrI8, IntegerType 64, IntegerType 32, IntegerType 1] False , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False , exfun "llvm.invariant.start" (PointerType (StructureType False []) (AddrSpace 0)) [IntegerType 64, ptrI8] False , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False , exfun "strlen" intPtr [ptrI8] False , exfun "GC_init" VoidType [] False , exfun "GC_malloc" ptrI8 [intPtr] False , exfun "GC_malloc_atomic" ptrI8 [intPtr] False , exfun "__gmp_set_memory_functions" VoidType [ PointerType (FunctionType ptrI8 [intPtr] False) (AddrSpace 0) , PointerType (FunctionType ptrI8 [ptrI8, intPtr, intPtr] False) (AddrSpace 0) , PointerType (FunctionType VoidType [ptrI8, intPtr] False) (AddrSpace 0) ] False , exfun "__gmpz_init" VoidType [pmpz] False , exfun "__gmpz_init_set_str" (IntegerType 32) [pmpz, ptrI8, IntegerType 32] False , exfun "__gmpz_get_str" ptrI8 [ptrI8, IntegerType 32, pmpz] False , exfun "__gmpz_get_ui" intPtr [pmpz] False , exfun "__gmpz_cmp" (IntegerType 32) [pmpz, pmpz] False , exfun "__gmpz_fdiv_q_2exp" VoidType [pmpz, pmpz, intPtr] False , exfun "__gmpz_mul_2exp" VoidType [pmpz, pmpz, intPtr] False , exfun "mpz_get_ull" (IntegerType 64) [pmpz] False , exfun "mpz_init_set_ull" VoidType [pmpz, IntegerType 64] False , exfun "mpz_init_set_sll" VoidType [pmpz, IntegerType 64] False , exfun "__idris_strCons" ptrI8 [IntegerType 8, ptrI8] False , exfun "__idris_readStr" ptrI8 [ptrI8] False -- Actually pointer to FILE, but it's opaque anyway , exfun "__idris_gmpMalloc" ptrI8 [intPtr] False , exfun "__idris_gmpRealloc" ptrI8 [ptrI8, intPtr, intPtr] False , exfun "__idris_gmpFree" VoidType [ptrI8, intPtr] False , exfun "__idris_strRev" ptrI8 [ptrI8] False , exfun "strtoll" (IntegerType 64) [ptrI8, PointerType ptrI8 (AddrSpace 0), IntegerType 32] False , exVar (stdinName tgt) ptrI8 , exVar (stdoutName tgt) ptrI8 , exVar (stderrName tgt) ptrI8 , GlobalDefinition mainDef ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"] where intPtr = IntegerType (tgtWordSize tgt) ptrI8 = PointerType (IntegerType 8) (AddrSpace 0) pmpz = PointerType mpzTy (AddrSpace 0) mpzBinFun n = exfun ("__gmpz_" ++ n) VoidType [pmpz, pmpz, pmpz] False rtsFun :: String -> Type -> [Type] -> [BasicBlock] -> Definition rtsFun name rty argtys def = GlobalDefinition $ functionDefaults { G.linkage = L.Internal , G.returnType = rty , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], False) , G.name = Name $ "__idris_" ++ name , G.basicBlocks = def } exfun :: String -> Type -> [Type] -> Bool -> Definition exfun name rty argtys vari = GlobalDefinition $ functionDefaults { G.returnType = rty , G.name = Name name , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], vari) } exVar :: String -> Type -> Definition exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = Name name, G.type' = ty } isApple :: Target -> Bool isApple (Target { triple = t }) = isJust . stripPrefix "-apple" $ dropWhile (/= '-') t stdinName, stdoutName, stderrName :: Target -> String stdinName t | isApple t = "__stdinp" stdinName _ = "stdin" stdoutName t | isApple t = "__stdoutp" stdoutName _ = "stdout" stderrName t | isApple t = "__stderrp" stderrName _ = "stderr" getStdIn, getStdOut, getStdErr :: Codegen Operand getStdIn = ConstantOperand . C.GlobalReference . Name . stdinName <$> asks target getStdOut = ConstantOperand . C.GlobalReference . Name . stdoutName <$> asks target getStdErr = ConstantOperand . C.GlobalReference . Name . stderrName <$> asks target codegen :: Target -> [SDecl] -> Module codegen tgt defs = Module "idris" (Just . dataLayout $ tgt) (Just . triple $ tgt) (initDefs tgt ++ globals ++ gendefs) where (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt 0 valueType :: Type valueType = NamedTypeReference (Name "valTy") nullValue :: C.Constant nullValue = C.Null (PointerType valueType (AddrSpace 0)) primTy :: Type -> Type primTy inner = StructureType False [IntegerType 32, inner] mpzTy :: Type mpzTy = NamedTypeReference (Name "mpz") conType :: Word64 -> Type conType nargs = StructureType False [ IntegerType 32 , ArrayType nargs (PointerType valueType (AddrSpace 0)) ] type Modgen = RWS Target [Definition] Word cgDef :: SDecl -> Modgen Definition cgDef (SFun name argNames _ expr) = do nextGlobal <- get tgt <- ask let (_, CGS { nextGlobalName = nextGlobal' }, (allocas, bbs, globals)) = runRWS (do r <- cgExpr expr case r of Nothing -> terminate $ Unreachable [] Just r' -> terminate $ Ret (Just r') []) (CGR tgt (show name)) (CGS 0 nextGlobal (Name "begin") [] (map (Just . LocalReference . Name . show) argNames) S.empty) entryTerm = case bbs of [] -> Do $ Ret Nothing [] BasicBlock n _ _:_ -> Do $ Br n [] tell globals put nextGlobal' return . GlobalDefinition $ functionDefaults { G.linkage = L.Internal , G.callingConvention = CC.Fast , G.name = Name (show name) , G.returnType = PointerType valueType (AddrSpace 0) , G.parameters = (flip map argNames $ \argName -> Parameter (PointerType valueType (AddrSpace 0)) (Name (show argName)) [] , False) , G.basicBlocks = BasicBlock (Name "entry") (map (\(n, t) -> n := Alloca t Nothing 0 []) allocas) entryTerm : bbs } type CGW = ([(Name, Type)], [BasicBlock], [Definition]) type Env = [Maybe Operand] data CGS = CGS { nextName :: Word , nextGlobalName :: Word , currentBlockName :: Name , instAccum :: [Named Instruction] , lexenv :: Env , foreignSyms :: Set String } data CGR = CGR { target :: Target , funcName :: String } type Codegen = RWS CGR CGW CGS getFuncName :: Codegen String getFuncName = asks funcName getGlobalUnName :: Codegen Name getGlobalUnName = do i <- gets nextGlobalName modify $ \s -> s { nextGlobalName = 1 + i } return (UnName i) getUnName :: Codegen Name getUnName = do i <- gets nextName modify $ \s -> s { nextName = 1 + i } return (UnName i) getName :: String -> Codegen Name getName n = do i <- gets nextName modify $ \s -> s { nextName = 1 + i } return (Name $ n ++ show i) alloca :: Name -> Type -> Codegen () alloca n t = tell ([(n, t)], [], []) terminate :: Terminator -> Codegen () terminate term = do name <- gets currentBlockName insts <- gets instAccum modify $ \s -> s { instAccum = ierror "Not in a block" , currentBlockName = ierror "Not in a block" } tell ([], [BasicBlock name insts (Do term)], []) newBlock :: Name -> Codegen () newBlock name = modify $ \s -> s { instAccum = [] , currentBlockName = name } inst :: Instruction -> Codegen Operand inst i = do n <- getUnName modify $ \s -> s { instAccum = instAccum s ++ [n := i] } return $ LocalReference n ninst :: String -> Instruction -> Codegen Operand ninst name i = do n <- getName name modify $ \s -> s { instAccum = instAccum s ++ [n := i] } return $ LocalReference n inst' :: Instruction -> Codegen () inst' i = modify $ \s -> s { instAccum = instAccum s ++ [Do i] } insts :: [Named Instruction] -> Codegen () insts is = modify $ \s -> s { instAccum = instAccum s ++ is } var :: LVar -> Codegen (Maybe Operand) var (Loc level) = (!! level) <$> gets lexenv var (Glob n) = return . Just . ConstantOperand . C.GlobalReference . Name $ show n binds :: Env -> Codegen (Maybe Operand) -> Codegen (Maybe Operand) binds vals cg = do envLen <- length <$> gets lexenv modify $ \s -> s { lexenv = lexenv s ++ vals } value <- cg modify $ \s -> s { lexenv = take envLen $ lexenv s } return value replaceElt :: Int -> a -> [a] -> [a] replaceElt _ val [] = error "replaceElt: Ran out of list" replaceElt 0 val (x:xs) = val:xs replaceElt n val (x:xs) = x : replaceElt (n-1) val xs alloc' :: Operand -> Codegen Operand alloc' size = inst $ simpleCall "GC_malloc" [size] allocAtomic' :: Operand -> Codegen Operand allocAtomic' size = inst $ simpleCall "GC_malloc_atomic" [size] alloc :: Type -> Codegen Operand alloc ty = do size <- sizeOf ty mem <- alloc' size inst $ BitCast mem (PointerType ty (AddrSpace 0)) [] allocAtomic :: Type -> Codegen Operand allocAtomic ty = do size <- sizeOf ty mem <- allocAtomic' size inst $ BitCast mem (PointerType ty (AddrSpace 0)) [] sizeOf :: Type -> Codegen Operand sizeOf ty = ConstantOperand . C.PtrToInt (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1]) . IntegerType <$> getWordSize loadInv :: Operand -> Instruction loadInv ptr = Load False ptr Nothing 0 [("invariant.load", MetadataNode [])] tgtWordSize :: Target -> Word32 tgtWordSize (Target { dataLayout = DataLayout { pointerLayouts = l } }) = fst . fromJust $ M.lookup (AddrSpace 0) l getWordSize :: Codegen Word32 getWordSize = tgtWordSize <$> asks target cgExpr :: SExp -> Codegen (Maybe Operand) cgExpr (SV v) = var v cgExpr (SApp tailcall fname args) = do argSlots <- mapM var args case sequence argSlots of Nothing -> return Nothing Just argVals -> do fn <- var (Glob fname) Just <$> inst ((idrCall (show fname) argVals) { isTailCall = tailcall }) cgExpr (SLet _ varExpr bodyExpr) = do val <- cgExpr varExpr binds [val] $ cgExpr bodyExpr cgExpr (SUpdate (Loc level) expr) = do val <- cgExpr expr modify $ \s -> s { lexenv = replaceElt level val (lexenv s) } return val cgExpr (SCon tag name args) = do argSlots <- mapM var args case sequence argSlots of Nothing -> return Nothing Just argVals -> do let ty = conType . fromIntegral . length $ argVals con <- alloc ty tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] [] inst' $ Store False tagPtr (ConstantOperand (C.Int 32 (fromIntegral tag))) Nothing 0 [] forM_ (zip argVals [0..]) $ \(arg, i) -> do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0) , ConstantOperand (C.Int 32 1) , ConstantOperand (C.Int 32 i)] [] inst' $ Store False ptr arg Nothing 0 [] ptrI8 <- inst $ BitCast con (PointerType (IntegerType 8) (AddrSpace 0)) [] inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), ptrI8] Just <$> inst (BitCast con (PointerType valueType (AddrSpace 0)) []) cgExpr (SCase inspect alts) = do val <- var inspect case val of Nothing -> return Nothing Just v -> cgCase v alts cgExpr (SChkCase inspect alts) = do mval <- var inspect case mval of Nothing -> return Nothing Just val -> do endBBN <- getName "endChkCase" notNullBBN <- getName "notNull" originBlock <- gets currentBlockName isNull <- inst $ ICmp IPred.EQ val (ConstantOperand nullValue) [] terminate $ CondBr isNull endBBN notNullBBN [] newBlock notNullBBN ptr <- inst $ BitCast val (PointerType (IntegerType 32) (AddrSpace 0)) [] flag <- inst $ loadInv ptr isVal <- inst $ ICmp IPred.EQ flag (ConstantOperand (C.Int 32 (-1))) [] conBBN <- getName "constructor" terminate $ CondBr isVal endBBN conBBN [] newBlock conBBN result <- cgCase val alts caseExitBlock <- gets currentBlockName case result of Nothing -> do terminate $ Unreachable [] newBlock endBBN return $ Just val Just caseVal -> do terminate $ Br endBBN [] newBlock endBBN Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) [(val, originBlock), (val, notNullBBN), (caseVal, caseExitBlock)] []) cgExpr (SProj conVar idx) = do val <- var conVar case val of Nothing -> return Nothing Just v -> do ptr <- inst $ GetElementPtr True v [ ConstantOperand (C.Int 32 0) , ConstantOperand (C.Int 32 1) , ConstantOperand (C.Int 32 (fromIntegral idx)) ] [] Just <$> inst (loadInv ptr) cgExpr (SConst c) = Just <$> cgConst c cgExpr (SForeign LANG_C rty fname args) = do func <- ensureCDecl fname rty (map fst args) argVals <- forM args $ \(fty, v) -> do v' <- var v case v' of Just val -> return $ Just (fty, val) Nothing -> return Nothing case sequence argVals of Nothing -> return Nothing Just argVals' -> do argUVals <- mapM (uncurry unbox) argVals' result <- inst Call { isTailCall = False , callingConvention = CC.C , returnAttributes = [] , function = Right func , arguments = map (\v -> (v, [])) argUVals , functionAttributes = [] , metadata = [] } Just <$> box rty result cgExpr (SOp fn args) = do argVals <- mapM var args case sequence argVals of Just ops -> Just <$> cgOp fn ops Nothing -> return Nothing cgExpr SNothing = return . Just . ConstantOperand $ nullValue cgExpr (SError msg) = do -- TODO: Print message str <- addGlobal' (ArrayType (2 + fromIntegral (length msg)) (IntegerType 8)) (cgConst' (TT.Str (msg ++ "\n"))) inst' $ simpleCall "putStr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0 , C.Int 32 0]] inst' Call { isTailCall = True , callingConvention = CC.C , returnAttributes = [] , function = Right . ConstantOperand . C.GlobalReference . Name $ "llvm.trap" , arguments = [] , functionAttributes = [A.NoReturn] , metadata = [] } return Nothing cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand) cgCase val alts = case find isConstCase alts of Just (SConstCase (TT.BI _) _) -> cgChainCase val defExp constAlts Just (SConstCase (TT.Str _) _) -> cgChainCase val defExp constAlts Just (SConstCase _ _) -> cgPrimCase val defExp constAlts Nothing -> cgConCase val defExp conAlts where defExp = getDefExp =<< find isDefCase alts constAlts = filter isConstCase alts conAlts = filter isConCase alts isConstCase (SConstCase {}) = True isConstCase _ = False isConCase (SConCase {}) = True isConCase _ = False isDefCase (SDefaultCase _) = True isDefCase _ = False getDefExp (SDefaultCase e) = Just e getDefExp _ = Nothing cgPrimCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand) cgPrimCase caseValPtr defExp alts = do let caseTy = case head alts of SConstCase (TT.I _) _ -> IntegerType 32 SConstCase (TT.B8 _) _ -> IntegerType 8 SConstCase (TT.B16 _) _ -> IntegerType 16 SConstCase (TT.B32 _) _ -> IntegerType 32 SConstCase (TT.B64 _) _ -> IntegerType 64 SConstCase (TT.Fl _) _ -> FloatingPointType 64 IEEE SConstCase (TT.Ch _) _ -> IntegerType 32 realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) [] valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] [] caseVal <- inst $ loadInv valPtr defBlockName <- getName "default" exitBlockName <- getName "caseExit" namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts terminate $ Switch caseVal defBlockName (map (\(n, SConstCase c _) -> (cgConst' c, n)) namedAlts) [] initEnv <- gets lexenv defResult <- cgDefaultAlt exitBlockName defBlockName defExp results <- forM namedAlts $ \(name, SConstCase _ exp) -> cgAlt initEnv exitBlockName name Nothing exp finishCase initEnv exitBlockName (defResult:results) cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand) cgConCase con defExp alts = do tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] [] tag <- inst $ loadInv tagPtr defBlockName <- getName "default" exitBlockName <- getName "caseExit" namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts terminate $ Switch tag defBlockName (map (\(n, SConCase _ tag _ _ _) -> (C.Int 32 (fromIntegral tag), n)) namedAlts) [] initEnv <- gets lexenv defResult <- cgDefaultAlt exitBlockName defBlockName defExp results <- forM namedAlts $ \(name, SConCase _ _ _ argns exp) -> cgAlt initEnv exitBlockName name (Just (con, map show argns)) exp finishCase initEnv exitBlockName (defResult:results) cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand) cgChainCase caseValPtr defExp alts = do let (caseTy, comparator) = case head alts of SConstCase (TT.BI _) _ -> (FArith (ATInt ITBig), "__gmpz_cmp") SConstCase (TT.Str _) _ -> (FString, "strcmp") caseVal <- unbox caseTy caseValPtr defBlockName <- getName "default" exitBlockName <- getName "caseExit" namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts initEnv <- gets lexenv results <- forM namedAlts $ \(name, SConstCase c e) -> do const <- unbox caseTy =<< cgConst c cmp <- inst $ simpleCall comparator [const, caseVal] cmpResult <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) [] elseName <- getName "else" terminate $ CondBr cmpResult name elseName [] result <- cgAlt initEnv exitBlockName name Nothing e newBlock elseName return result modify $ \s -> s { lexenv = initEnv } fname <- getFuncName defaultVal <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) defExp) defaultBlock <- gets currentBlockName defaultEnv <- gets lexenv defResult <- case defaultVal of Just v -> do terminate $ Br exitBlockName [] return $ Just (v, defaultBlock, defaultEnv) Nothing -> do terminate $ Unreachable [] return Nothing finishCase initEnv exitBlockName (defResult:results) finishCase :: Env -> Name -> [Maybe (Operand, Name, Env)] -> Codegen (Maybe Operand) finishCase initEnv exitBlockName results = do let definedResults = mapMaybe id results case definedResults of [] -> do modify $ \s -> s { lexenv = initEnv } return Nothing xs -> do newBlock exitBlockName mergeEnvs $ map (\(_, altBlock, altEnv) -> (altBlock, altEnv)) xs Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) (map (\(altVal, altBlock, _) -> (altVal, altBlock)) xs) []) cgDefaultAlt :: Name -> Name -> Maybe SExp -> Codegen (Maybe (Operand, Name, Env)) cgDefaultAlt exitName name exp = do newBlock name fname <- getFuncName val <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) exp) env <- gets lexenv block <- gets currentBlockName case val of Just v -> do terminate $ Br exitName [] return $ Just (v, block, env) Nothing -> do terminate $ Unreachable [] return Nothing cgAlt :: Env -> Name -> Name -> Maybe (Operand, [String]) -> SExp -> Codegen (Maybe (Operand, Name, Env)) cgAlt initEnv exitBlockName name destr exp = do modify $ \s -> s { lexenv = initEnv } newBlock name locals <- case destr of Nothing -> return [] Just (con, argns) -> forM (zip argns [0..]) $ \(argName, i) -> do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0) , ConstantOperand (C.Int 32 1) , ConstantOperand (C.Int 32 i)] [] Just <$> ninst argName (loadInv ptr) altVal <- binds locals $ cgExpr exp altEnv <- gets lexenv altBlock <- gets currentBlockName case altVal of Just v -> do terminate $ Br exitBlockName [] return $ Just (v, altBlock, altEnv) Nothing -> do terminate $ Unreachable [] return Nothing mergeEnvs :: [(Name, Env)] -> Codegen () mergeEnvs es = do let vars = transpose . map (\(block, env) -> map (\x -> (x, block)) env) $ es env <- forM vars $ \var -> case var of [] -> ierror "mergeEnvs: impossible" [(v, _)] -> return v vs@((v, _):_) | all (== v) (map fst vs) -> return v | otherwise -> let valid = map (\(a, b) -> (fromJust a, b)) . filter (isJust . fst) $ vs in Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) valid []) modify $ \s -> s { lexenv = env } nameAlt :: Name -> SAlt -> Codegen Name nameAlt d (SDefaultCase _) = return d nameAlt _ (SConCase _ _ name _ _) = getName (show name) nameAlt _ (SConstCase const _) = getName (show const) isHeapFTy :: FType -> Bool isHeapFTy f = elem f [FString, FPtr, FAny, FArith (ATInt ITBig)] box :: FType -> Operand -> Codegen Operand box FUnit _ = return $ ConstantOperand nullValue box fty fval = do let ty = primTy (ftyToTy fty) val <- if isHeapFTy fty then alloc ty else allocAtomic ty tagptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] [] valptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] [] inst' $ Store False tagptr (ConstantOperand (C.Int 32 (-1))) Nothing 0 [] inst' $ Store False valptr fval Nothing 0 [] ptrI8 <- inst $ BitCast val (PointerType (IntegerType 8) (AddrSpace 0)) [] inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), ptrI8] inst $ BitCast val (PointerType valueType (AddrSpace 0)) [] unbox :: FType -> Operand -> Codegen Operand unbox FUnit x = return x unbox fty bval = do val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) [] fvalptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] [] inst $ loadInv fvalptr cgConst' :: TT.Const -> C.Constant cgConst' (TT.I i) = C.Int 32 (fromIntegral i) cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i) cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i) cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i) cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i) cgConst' (TT.B8V v) = C.Vector (map ((C.Int 8) . fromIntegral) . V.toList $ v) cgConst' (TT.B16V v) = C.Vector (map ((C.Int 16) . fromIntegral) . V.toList $ v) cgConst' (TT.B32V v) = C.Vector (map ((C.Int 32) . fromIntegral) . V.toList $ v) cgConst' (TT.B64V v) = C.Vector (map ((C.Int 64) . fromIntegral) . V.toList $ v) cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0]) cgConst' (TT.Fl f) = C.Float (F.Double f) cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) s ++ [C.Int 8 0]) cgConst' x = ierror $ "Unsupported constant: " ++ show x cgConst :: TT.Const -> Codegen Operand cgConst c@(TT.I _) = box (FArith (ATInt ITNative)) (ConstantOperand $ cgConst' c) cgConst c@(TT.B8 _) = box (FArith (ATInt (ITFixed IT8))) (ConstantOperand $ cgConst' c) cgConst c@(TT.B16 _) = box (FArith (ATInt (ITFixed IT16))) (ConstantOperand $ cgConst' c) cgConst c@(TT.B32 _) = box (FArith (ATInt (ITFixed IT32))) (ConstantOperand $ cgConst' c) cgConst c@(TT.B64 _) = box (FArith (ATInt (ITFixed IT64))) (ConstantOperand $ cgConst' c) cgConst c@(TT.B8V v) = box (FArith (ATInt (ITVec IT8 (V.length v)))) (ConstantOperand $ cgConst' c) cgConst c@(TT.B16V v) = box (FArith (ATInt (ITVec IT16 (V.length v)))) (ConstantOperand $ cgConst' c) cgConst c@(TT.B32V v) = box (FArith (ATInt (ITVec IT32 (V.length v)))) (ConstantOperand $ cgConst' c) cgConst c@(TT.B64V v) = box (FArith (ATInt (ITVec IT64 (V.length v)))) (ConstantOperand $ cgConst' c) cgConst c@(TT.Fl _) = box (FArith ATFloat) (ConstantOperand $ cgConst' c) cgConst c@(TT.Ch _) = box (FArith (ATInt ITChar)) (ConstantOperand $ cgConst' c) cgConst c@(TT.Str s) = do str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c) box FString (ConstantOperand $ C.GetElementPtr True str [C.Int 32 0, C.Int 32 0]) cgConst c@(TT.BI i) = do str <- addGlobal' (ArrayType (1 + fromInteger (numDigits 10 i)) (IntegerType 8)) (cgConst' c) mpz <- alloc mpzTy inst $ simpleCall "__gmpz_init_set_str" [mpz , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0] , ConstantOperand $ C.Int 32 10 ] box (FArith (ATInt ITBig)) mpz cgConst x = return $ ConstantOperand nullValue numDigits :: Integer -> Integer -> Integer numDigits b n = 1 + fst (ilog b n) where ilog b n | n < b = (0, n) | otherwise = let (e, r) = ilog (b*b) n in if r < b then (2*e, r) else (2*e+1, r `div` b) addGlobal :: Global -> Codegen () addGlobal def = tell ([], [], [GlobalDefinition def]) addGlobal' :: Type -> C.Constant -> Codegen C.Constant addGlobal' ty val = do name <- getGlobalUnName addGlobal $ globalVariableDefaults { G.name = name , G.linkage = L.Internal , G.hasUnnamedAddr = True , G.isConstant = True , G.type' = ty , G.initializer = Just val } return . C.GlobalReference $ name ensureCDecl :: String -> FType -> [FType] -> Codegen Operand ensureCDecl name rty argtys = do syms <- gets foreignSyms unless (S.member name syms) $ do addGlobal (ffunDecl name rty argtys) modify $ \s -> s { foreignSyms = S.insert name (foreignSyms s) } return $ ConstantOperand (C.GlobalReference (Name name)) ffunDecl :: String -> FType -> [FType] -> Global ffunDecl name rty argtys = functionDefaults { G.returnType = ftyToTy rty , G.name = Name name , G.parameters = (flip map argtys $ \fty -> Parameter (ftyToTy fty) (UnName 0) [] , False) } ftyToTy :: FType -> Type ftyToTy (FArith (ATInt ITNative)) = IntegerType 32 ftyToTy (FArith (ATInt ITBig)) = PointerType mpzTy (AddrSpace 0) ftyToTy (FArith (ATInt (ITFixed ty))) = IntegerType (fromIntegral $ nativeTyWidth ty) ftyToTy (FArith (ATInt (ITVec e c))) = VectorType (fromIntegral c) (IntegerType (fromIntegral $ nativeTyWidth e)) ftyToTy (FArith (ATInt ITChar)) = IntegerType 32 ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0) ftyToTy FUnit = VoidType ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0) ftyToTy (FArith ATFloat) = FloatingPointType 64 IEEE ftyToTy FAny = valueType -- Only use when known not to be ITBig itWidth :: IntTy -> Word32 itWidth ITNative = 32 itWidth ITChar = 32 itWidth (ITFixed x) = fromIntegral $ nativeTyWidth x itWidth x = ierror $ "itWidth: " ++ show x itConst :: IntTy -> Integer -> C.Constant itConst (ITFixed n) x = C.Int (fromIntegral $ nativeTyWidth n) x itConst ITNative x = itConst (ITFixed IT32) x itConst ITChar x = itConst (ITFixed IT32) x itConst (ITVec elts size) x = C.Vector (replicate size (itConst (ITFixed elts) x)) cgOp :: PrimFn -> [Operand] -> Codegen Operand cgOp (LTrunc ITBig ity) [x] = do nx <- unbox (FArith (ATInt ITBig)) x val <- inst $ simpleCall "mpz_get_ull" [nx] v <- case ity of (ITFixed IT64) -> return val _ -> inst $ Trunc val (ftyToTy (FArith (ATInt ity))) [] box (FArith (ATInt ity)) v cgOp (LZExt from ITBig) [x] = do nx <- unbox (FArith (ATInt from)) x nx' <- case from of (ITFixed IT64) -> return nx _ -> inst $ ZExt nx (IntegerType 64) [] mpz <- alloc mpzTy inst' $ simpleCall "mpz_init_set_ull" [mpz, nx'] box (FArith (ATInt ITBig)) mpz cgOp (LSExt from ITBig) [x] = do nx <- unbox (FArith (ATInt from)) x nx' <- case from of (ITFixed IT64) -> return nx _ -> inst $ SExt nx (IntegerType 64) [] mpz <- alloc mpzTy inst' $ simpleCall "mpz_init_set_sll" [mpz, nx'] box (FArith (ATInt ITBig)) mpz -- ITChar, ITNative, and IT32 all share representation cgOp (LChInt ITNative) [x] = return x cgOp (LIntCh ITNative) [x] = return x cgOp (LSLt (ATInt ITBig)) [x,y] = mpzCmp IPred.SLT x y cgOp (LSLe (ATInt ITBig)) [x,y] = mpzCmp IPred.SLE x y cgOp (LEq (ATInt ITBig)) [x,y] = mpzCmp IPred.EQ x y cgOp (LSGe (ATInt ITBig)) [x,y] = mpzCmp IPred.SGE x y cgOp (LSGt (ATInt ITBig)) [x,y] = mpzCmp IPred.SGT x y cgOp (LPlus (ATInt ITBig)) [x,y] = mpzBin "add" x y cgOp (LMinus (ATInt ITBig)) [x,y] = mpzBin "sub" x y cgOp (LTimes (ATInt ITBig)) [x,y] = mpzBin "mul" x y cgOp (LSDiv (ATInt ITBig)) [x,y] = mpzBin "fdiv_q" x y cgOp (LSRem (ATInt ITBig)) [x,y] = mpzBin "fdiv_r" x y cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y cgOp (LCompl ITBig) [x] = mpzUn "com" x cgOp (LSHL ITBig) [x,y] = mpzBit "mul_2exp" x y cgOp (LASHR ITBig) [x,y] = mpzBit "fdiv_q_2exp" x y cgOp (LTrunc ITNative (ITFixed to)) [x] | 32 >= nativeTyWidth to = iCoerce Trunc IT32 to x cgOp (LZExt ITNative (ITFixed to)) [x] | 32 <= nativeTyWidth to = iCoerce ZExt IT32 to x cgOp (LSExt ITNative (ITFixed to)) [x] | 32 <= nativeTyWidth to = iCoerce SExt IT32 to x cgOp (LTrunc (ITFixed from) ITNative) [x] | nativeTyWidth from >= 32 = iCoerce Trunc from IT32 x cgOp (LZExt (ITFixed from) ITNative) [x] | nativeTyWidth from <= 32 = iCoerce ZExt from IT32 x cgOp (LSExt (ITFixed from) ITNative) [x] | nativeTyWidth from <= 32 = iCoerce SExt from IT32 x cgOp (LTrunc (ITFixed from) (ITFixed to)) [x] | nativeTyWidth from > nativeTyWidth to = iCoerce Trunc from to x cgOp (LZExt (ITFixed from) (ITFixed to)) [x] | nativeTyWidth from < nativeTyWidth to = iCoerce ZExt from to x cgOp (LSExt (ITFixed from) (ITFixed to)) [x] | nativeTyWidth from < nativeTyWidth to = iCoerce SExt from to x cgOp (LSLt (ATInt ity)) [x,y] = iCmp ity IPred.SLT x y cgOp (LSLe (ATInt ity)) [x,y] = iCmp ity IPred.SLE x y cgOp (LLt ity) [x,y] = iCmp ity IPred.ULT x y cgOp (LLe ity) [x,y] = iCmp ity IPred.ULE x y cgOp (LEq (ATInt ity)) [x,y] = iCmp ity IPred.EQ x y cgOp (LSGe (ATInt ity)) [x,y] = iCmp ity IPred.SGE x y cgOp (LSGt (ATInt ity)) [x,y] = iCmp ity IPred.SGT x y cgOp (LGe ity) [x,y] = iCmp ity IPred.UGE x y cgOp (LGt ity) [x,y] = iCmp ity IPred.UGT x y cgOp (LPlus (ATInt ity)) [x,y] = ibin ity x y (Add False False) cgOp (LMinus (ATInt ity)) [x,y] = ibin ity x y (Sub False False) cgOp (LTimes (ATInt ity)) [x,y] = ibin ity x y (Mul False False) cgOp (LSDiv (ATInt ity)) [x,y] = ibin ity x y (SDiv False) cgOp (LSRem (ATInt ity)) [x,y] = ibin ity x y SRem cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv False) cgOp (LURem ity) [x,y] = ibin ity x y URem cgOp (LAnd ity) [x,y] = ibin ity x y And cgOp (LOr ity) [x,y] = ibin ity x y Or cgOp (LXOr ity) [x,y] = ibin ity x y Xor cgOp (LCompl ity) [x] = iun ity x (Xor . ConstantOperand $ itConst ity (-1)) cgOp (LSHL ity) [x,y] = ibin ity x y (Shl False False) cgOp (LLSHR ity) [x,y] = ibin ity x y (LShr False) cgOp (LASHR ity) [x,y] = ibin ity x y (AShr False) cgOp LNoOp xs = return $ last xs cgOp (LMkVec ety c) xs | c == length xs = do nxs <- mapM (unbox (FArith (ATInt (ITFixed ety)))) xs vec <- foldM (\v (e, i) -> inst $ InsertElement v e (ConstantOperand (C.Int 32 i)) []) (ConstantOperand $ C.Vector (replicate c (C.Undef (IntegerType . fromIntegral $ nativeTyWidth ety)))) (zip nxs [0..]) box (FArith (ATInt (ITVec ety c))) vec cgOp (LIdxVec ety c) [v,i] = do nv <- unbox (FArith (ATInt (ITVec ety c))) v ni <- unbox (FArith (ATInt (ITFixed IT32))) i elt <- inst $ ExtractElement nv ni [] box (FArith (ATInt (ITFixed ety))) elt cgOp (LUpdateVec ety c) [v,i,e] = do let fty = FArith (ATInt (ITVec ety c)) nv <- unbox fty v ni <- unbox (FArith (ATInt (ITFixed IT32))) i ne <- unbox (FArith (ATInt (ITFixed ety))) e nv' <- inst $ InsertElement nv ne ni [] box fty nv' cgOp (LBitCast from to) [x] = do nx <- unbox (FArith from) x nx' <- inst $ BitCast nx (ftyToTy (FArith to)) [] box (FArith to) nx' cgOp LStrEq [x,y] = do x' <- unbox FString x y' <- unbox FString y cmp <- inst $ simpleCall "strcmp" [x', y'] flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) [] val <- inst $ ZExt flag (IntegerType 32) [] box (FArith (ATInt (ITFixed IT32))) val cgOp LStrLt [x,y] = do nx <- unbox FString x ny <- unbox FString y cmp <- inst $ simpleCall "strcmp" [nx, ny] flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) [] val <- inst $ ZExt flag (IntegerType 32) [] box (FArith (ATInt (ITFixed IT32))) val cgOp (LIntStr ITBig) [x] = do x' <- unbox (FArith (ATInt ITBig)) x ustr <- inst $ simpleCall "__gmpz_get_str" [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0))) , ConstantOperand (C.Int 32 10) , x' ] box FString ustr cgOp (LIntStr ity) [x] = do x' <- unbox (FArith (ATInt ity)) x x'' <- if itWidth ity < 64 then inst $ SExt x' (IntegerType 64) [] else return x' box FString =<< inst (idrCall "__idris_intStr" [x'']) cgOp (LStrInt ITBig) [s] = do ns <- unbox FString s mpz <- alloc mpzTy inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10] box (FArith (ATInt ITBig)) mpz cgOp (LStrInt ity) [s] = do ns <- unbox FString s nx <- inst $ simpleCall "strtoll" [ns , ConstantOperand $ C.Null (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) , ConstantOperand $ C.Int 32 10 ] nx' <- case ity of (ITFixed IT64) -> return nx _ -> inst $ Trunc nx (IntegerType (itWidth ity)) [] box (FArith (ATInt ity)) nx' cgOp LStrConcat [x,y] = cgStrCat x y cgOp LStrCons [c,s] = do nc <- unbox (FArith (ATInt ITChar)) c ns <- unbox FString s nc' <- inst $ Trunc nc (IntegerType 8) [] r <- inst $ simpleCall "__idris_strCons" [nc', ns] box FString r cgOp LStrHead [c] = do s <- unbox FString c c <- inst $ loadInv s c' <- inst $ ZExt c (IntegerType 32) [] box (FArith (ATInt ITChar)) c' cgOp LStrIndex [s, i] = do ns <- unbox FString s ni <- unbox (FArith (ATInt (ITFixed IT32))) i p <- inst $ GetElementPtr True ns [ni] [] c <- inst $ loadInv p c' <- inst $ ZExt c (IntegerType 32) [] box (FArith (ATInt ITChar)) c' cgOp LStrTail [c] = do s <- unbox FString c c <- inst $ GetElementPtr True s [ConstantOperand $ C.Int 32 1] [] box FString c cgOp LStrLen [s] = do ns <- unbox FString s len <- inst $ simpleCall "strlen" [ns] ws <- getWordSize len' <- case ws of 32 -> return len x | x > 32 -> inst $ Trunc len (IntegerType 32) [] | x < 32 -> inst $ ZExt len (IntegerType 32) [] box (FArith (ATInt (ITFixed IT32))) len' cgOp LStrRev [s] = do ns <- unbox FString s box FString =<< inst (simpleCall "__idris_strRev" [ns]) cgOp LReadStr [p] = do np <- unbox FPtr p s <- inst $ simpleCall "__idris_readStr" [np] box FString s cgOp LStdIn [] = do stdin <- getStdIn ptr <- inst $ loadInv stdin box FPtr ptr cgOp LStdOut [] = do stdout <- getStdOut ptr <- inst $ loadInv stdout box FPtr ptr cgOp LStdErr [] = do stdErr <- getStdErr ptr <- inst $ loadInv stdErr box FPtr ptr cgOp prim args = ierror $ "Unimplemented primitive: <" ++ show prim ++ ">(" ++ intersperse ',' (take (length args) ['a'..]) ++ ")" iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> NativeTy -> NativeTy -> Operand -> Codegen Operand iCoerce _ from to x | from == to = return x iCoerce operator from to x = do x' <- unbox (FArith (ATInt (ITFixed from))) x x'' <- inst $ operator x' (ftyToTy (FArith (ATInt (ITFixed to)))) [] box (FArith (ATInt (ITFixed to))) x'' cgStrCat :: Operand -> Operand -> Codegen Operand cgStrCat x y = do x' <- unbox FString x y' <- unbox FString y xlen <- inst $ simpleCall "strlen" [x'] ylen <- inst $ simpleCall "strlen" [y'] zlen <- inst $ Add False True xlen ylen [] ws <- getWordSize total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) [] mem <- allocAtomic' total inst $ simpleCall "memcpy" [mem, x', xlen] i <- inst $ PtrToInt mem (IntegerType ws) [] offi <- inst $ Add False True i xlen [] offp <- inst $ IntToPtr offi (PointerType (IntegerType 8) (AddrSpace 0)) [] inst $ simpleCall "memcpy" [offp, y', ylen] j <- inst $ PtrToInt offp (IntegerType ws) [] offj <- inst $ Add False True j ylen [] end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) [] inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 [] box FString mem ibin :: IntTy -> Operand -> Operand -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand ibin ity x y instCon = do nx <- unbox (FArith (ATInt ity)) x ny <- unbox (FArith (ATInt ity)) y nr <- inst $ instCon nx ny [] box (FArith (ATInt ity)) nr iun :: IntTy -> Operand -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand iun ity x instCon = do nx <- unbox (FArith (ATInt ity)) x nr <- inst $ instCon nx [] box (FArith (ATInt ity)) nr iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand iCmp ity pred x y = do nx <- unbox (FArith (ATInt ity)) x ny <- unbox (FArith (ATInt ity)) y nr <- inst $ ICmp pred nx ny [] nr' <- inst $ SExt nr (ftyToTy $ cmpResultTy ity) [] box (cmpResultTy ity) nr' cmpResultTy :: IntTy -> FType cmpResultTy v@(ITVec _ _) = FArith (ATInt v) cmpResultTy _ = FArith (ATInt (ITFixed IT32)) mpzBin :: String -> Operand -> Operand -> Codegen Operand mpzBin name x y = do nx <- unbox (FArith (ATInt ITBig)) x ny <- unbox (FArith (ATInt ITBig)) y nz <- alloc mpzTy inst' $ simpleCall "__gmpz_init" [nz] inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny] box (FArith (ATInt ITBig)) nz mpzBit :: String -> Operand -> Operand -> Codegen Operand mpzBit name x y = do nx <- unbox (FArith (ATInt ITBig)) x ny <- unbox (FArith (ATInt ITBig)) y bitcnt <- inst $ simpleCall "__gmpz_get_ui" [ny] nz <- alloc mpzTy inst' $ simpleCall "__gmpz_init" [nz] inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, bitcnt] box (FArith (ATInt ITBig)) nz mpzUn :: String -> Operand -> Codegen Operand mpzUn name x = do nx <- unbox (FArith (ATInt ITBig)) x nz <- alloc mpzTy inst' $ simpleCall "__gmpz_init" [nz] inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx] box (FArith (ATInt ITBig)) nz mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand mpzCmp pred x y = do nx <- unbox (FArith (ATInt ITBig)) x ny <- unbox (FArith (ATInt ITBig)) y cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny] result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) [] i <- inst $ ZExt result (IntegerType 32) [] box (FArith (ATInt (ITFixed IT32))) i simpleCall :: String -> [Operand] -> Instruction simpleCall name args = Call { isTailCall = False , callingConvention = CC.C , returnAttributes = [] , function = Right . ConstantOperand . C.GlobalReference . Name $ name , arguments = map (\x -> (x, [])) args , functionAttributes = [] , metadata = [] } idrCall :: String -> [Operand] -> Instruction idrCall name args = Call { isTailCall = False , callingConvention = CC.Fast , returnAttributes = [] , function = Right . ConstantOperand . C.GlobalReference . Name $ name , arguments = map (\x -> (x, [])) args , functionAttributes = [] , metadata = [] } assert :: Operand -> String -> Codegen () assert condition message = do passed <- getName "assertPassed" failed <- getName "assertFailed" terminate $ CondBr condition passed failed [] newBlock failed cgExpr (SError message) terminate $ Unreachable [] newBlock passed