git.iko.soy/Idris-dev
on 340beed help sign in
Idris-dev/src/IRTS/CodegenLLVM.hs
1039 lines 41 kB history raw
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2module IRTS.CodegenLLVM (codegenLLVM) where
4import IRTS.CodegenCommon
5import IRTS.Lang
6import IRTS.Simplified
7import qualified Core.TT as TT
9import Util.System
10import Paths_idris
12import LLVM.General.Context
13import LLVM.General.Diagnostic
14import LLVM.General.AST
15import LLVM.General.AST.AddrSpace
16import qualified LLVM.General.Module as M
17import qualified LLVM.General.AST.IntegerPredicate as IPred
18import qualified LLVM.General.AST.Linkage as L
19import qualified LLVM.General.AST.Visibility as V
20import qualified LLVM.General.AST.CallingConvention as CC
21import qualified LLVM.General.AST.Attribute as A
22import qualified LLVM.General.AST.Global as G
23import qualified LLVM.General.AST.Constant as C
24import qualified LLVM.General.AST.Float as F
26import Data.List
27import Data.Maybe
28import Data.Word
29import Data.Set (Set)
30import qualified Data.Set as S
31import Control.Applicative
32import Control.Monad.RWS
33import Control.Monad.Writer
34import Control.Monad.State
35import Control.Monad.Error
37import qualified System.Info as SI (arch, os)
38import System.IO
39import System.Directory (removeFile)
40import System.FilePath ((</>))
41import System.Process (rawSystem)
42import System.Exit (ExitCode(..))
43import Debug.Trace
45data Target = Target { arch :: String, os :: String }
47codegenLLVM :: [(TT.Name, SDecl)] ->
48 FilePath -> -- output file name
49 OutputType ->
50 IO ()
51codegenLLVM defs file outty = withContext $ \context -> do
52 let target = Target { arch = SI.arch, os = SI.os }
53 let ast = codegen target (map snd defs)
54 result <- runErrorT $ M.withModuleFromAST context ast (outputModule file outty)
55 case result of
56 Right _ -> return ()
57 Left msg -> ierror msg
59itWidth :: IntTy -> Word32
60itWidth ITNative = 32
61itWidth x = fromIntegral $ intTyWidth x
63outputModule :: FilePath -> OutputType -> M.Module -> IO ()
64outputModule file Raw m = either fail return <=< runErrorT $ M.writeBitcodeToFile file m
65outputModule file Object m = withTmpFile $ \bc -> do
66 outputModule bc Raw m
67 exit <- rawSystem "llc" ["-filetype=obj", "--disable-fp-elim", "-o", file, bc]
68 when (exit /= ExitSuccess) $ ierror "FAILURE: Object generation"
69outputModule file Executable m = withTmpFile $ \obj -> do
70 outputModule obj Object m
71 cc <- getCC
72 defs <- (</> "llvm" </> "libidris_rts.a") <$> getDataDir
73 exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file]
74 when (exit /= ExitSuccess) $ ierror "FAILURE: Linking"
76withTmpFile :: (FilePath -> IO a) -> IO a
77withTmpFile f = do
78 (path, handle) <- tempfile
79 hClose handle
80 result <- f path
81 removeFile path
82 return result
84ierror :: String -> a
85ierror msg = error $ "INTERNAL ERROR: IRTS.CodegenLLVM: " ++ msg
87mainDef :: Global
88mainDef =
89 functionDefaults
90 { G.returnType = IntegerType 32
91 , G.parameters =
92 ([ Parameter (IntegerType 32) (Name "argc") []
93 , Parameter (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) (Name "argv") []
94 ], False)
95 , G.name = Name "main"
96 , G.basicBlocks =
97 [ BasicBlock (UnName 0)
98 [ Do $ simpleCall "GC_init" [] -- Initialize Boehm GC
99 , Do $ simpleCall "__gmp_set_memory_functions"
100 [ ConstantOperand . C.GlobalReference . Name $ "__idris_gmpMalloc"
101 , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpRealloc"
102 , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpFree"
103 ]
104 , UnName 1 := idrCall "{runMain0}" [] ]
105 (Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [])
106 ]}
108initDefs :: Target -> [Definition]
109initDefs tgt =
110 [ TypeDefinition (Name "valTy")
111 (Just $ StructureType False
112 [ IntegerType 32
113 , ArrayType 0 (PointerType valueType (AddrSpace 0))
114 ])
115 , TypeDefinition (Name "mpz")
116 (Just $ StructureType False
117 [ IntegerType 32
118 , IntegerType 32
119 , PointerType intPtr (AddrSpace 0)
120 ])
121 , GlobalDefinition $ globalVariableDefaults
122 { G.name = Name "__idris_intFmtStr"
123 , G.linkage = L.Internal
124 , G.isConstant = True
125 , G.hasUnnamedAddr = True
126 , G.type' = ArrayType 5 (IntegerType 8)
127 , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%lld" ++ [C.Int 8 0])
128 }
129 , rtsFun "intStr" ptrI8 [IntegerType 64]
130 [ BasicBlock (UnName 0)
131 [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 21)]
132 , UnName 2 := simpleCall "snprintf"
133 [ LocalReference (UnName 1)
134 , ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 21)
135 , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
136 , LocalReference (UnName 0)
137 ]
138 ]
139 (Do $ Ret (Just (LocalReference (UnName 1))) [])
140 ]
141 , exfun "llvm.trap" VoidType [] False
142 , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True
143 , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False
144 , exfun "strlen" intPtr [ptrI8] False
145 , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False
146 , exfun "GC_init" VoidType [] False
147 , exfun "GC_malloc" ptrI8 [intPtr] False
148 , exfun "GC_malloc_atomic" ptrI8 [intPtr] False
149 , exfun "__gmp_set_memory_functions" VoidType
150 [ PointerType (FunctionType ptrI8 [intPtr] False) (AddrSpace 0)
151 , PointerType (FunctionType ptrI8 [ptrI8, intPtr, intPtr] False) (AddrSpace 0)
152 , PointerType (FunctionType VoidType [ptrI8, intPtr] False) (AddrSpace 0)
153 ] False
154 , exfun "__gmpz_init" VoidType [pmpz] False
155 , exfun "__gmpz_init_set_str" (IntegerType 32) [pmpz, ptrI8, IntegerType 32] False
156 , exfun "__gmpz_get_str" ptrI8 [ptrI8, IntegerType 32, pmpz] False
157 , exfun "__gmpz_cmp" (IntegerType 32) [pmpz, pmpz] False
158 , exfun "mpz_get_ull" (IntegerType 64) [pmpz] False
159 , exfun "mpz_init_set_ull" VoidType [pmpz, IntegerType 64] False
160 , exfun "mpz_init_set_sll" VoidType [pmpz, IntegerType 64] False
161 , exfun "__idris_strCons" ptrI8 [IntegerType 8, ptrI8] False
162 , exfun "__idris_readStr" ptrI8 [ptrI8] False -- Actually pointer to FILE, but it's opaque anyway
163 , exfun "__idris_gmpMalloc" ptrI8 [intPtr] False
164 , exfun "__idris_gmpRealloc" ptrI8 [ptrI8, intPtr, intPtr] False
165 , exfun "__idris_gmpFree" VoidType [ptrI8, intPtr] False
166 , exfun "strtoll" (IntegerType 64) [ptrI8, PointerType ptrI8 (AddrSpace 0), IntegerType 32] False
167 , exVar (stdinName tgt) ptrI8
168 , exVar (stdoutName tgt) ptrI8
169 , exVar (stderrName tgt) ptrI8
170 , GlobalDefinition mainDef
171 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
172 where
173 intPtr = IntegerType (fromInteger $ tgtWordSize tgt)
174 ptrI8 = PointerType (IntegerType 8) (AddrSpace 0)
175 pmpz = PointerType mpzTy (AddrSpace 0)
177 mpzBinFun n = exfun ("__gmpz_" ++ n) VoidType [pmpz, pmpz, pmpz] False
179 rtsFun :: String -> Type -> [Type] -> [BasicBlock] -> Definition
180 rtsFun name rty argtys def =
181 GlobalDefinition $ functionDefaults
182 { G.linkage = L.Internal
183 , G.returnType = rty
184 , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], False)
185 , G.name = Name $ "__idris_" ++ name
186 , G.basicBlocks = def
187 }
189 exfun :: String -> Type -> [Type] -> Bool -> Definition
190 exfun name rty argtys vari =
191 GlobalDefinition $ functionDefaults
192 { G.returnType = rty
193 , G.name = Name name
194 , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], vari)
195 }
196 exVar :: String -> Type -> Definition
197 exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = Name name, G.type' = ty }
199 stdinName :: Target -> String
200 stdinName (Target { os = "darwin" }) = "__stdinp"
201 stdinName _ = "stdin"
202 stdoutName :: Target -> String
203 stdoutName (Target { os = "darwin" }) = "__stdoutp"
204 stdoutName _ = "stdout"
205 stderrName :: Target -> String
206 stderrName (Target { os = "darwin" }) = "__stderrp"
207 stderrName _ = "stderr"
209codegen :: Target -> [SDecl] -> Module
210codegen tgt defs = Module "idris" Nothing Nothing (initDefs tgt ++ globals ++ gendefs)
211 where
212 (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt 0
214valueType :: Type
215valueType = NamedTypeReference (Name "valTy")
217nullValue :: C.Constant
218nullValue = C.Null (PointerType valueType (AddrSpace 0))
220primTy :: Type -> Type
221primTy inner = StructureType False [IntegerType 32, inner]
223mpzTy :: Type
224mpzTy = NamedTypeReference (Name "mpz")
226conType :: Word64 -> Type
227conType nargs = StructureType False
228 [ IntegerType 32
229 , ArrayType nargs (PointerType valueType (AddrSpace 0))
230 ]
232type Modgen = RWS Target [Definition] Word
234cgDef :: SDecl -> Modgen Definition
235cgDef (SFun name argNames _ expr) = do
236 nextGlobal <- get
237 tgt <- ask
238 let (_, CGS { nextGlobalName = nextGlobal' }, (allocas, bbs, globals)) =
239 runRWS (do r <- cgExpr expr
240 case r of
241 Nothing -> terminate $ Unreachable []
242 Just r' -> terminate $ Ret (Just r') [])
243 (CGR tgt (show name))
244 (CGS 0 nextGlobal (Name "begin") [] (map (Just . LocalReference . Name . show) argNames) S.empty)
245 entryTerm = case bbs of
246 [] -> Do $ Ret Nothing []
247 BasicBlock n _ _:_ -> Do $ Br n []
248 tell globals
249 put nextGlobal'
250 return . GlobalDefinition $ functionDefaults
251 { G.linkage = L.Internal
252 , G.callingConvention = CC.Fast
253 , G.name = Name (show name)
254 , G.returnType = PointerType valueType (AddrSpace 0)
255 , G.parameters = (flip map argNames $ \argName ->
256 Parameter (PointerType valueType (AddrSpace 0)) (Name (show argName)) []
257 , False)
258 , G.basicBlocks =
259 BasicBlock (Name "entry")
260 (map (\(n, t) -> n := Alloca t Nothing 0 []) allocas)
261 entryTerm
262 : bbs
263 }
265type CGW = ([(Name, Type)], [BasicBlock], [Definition])
267type Env = [Maybe Operand]
269data CGS = CGS { nextName :: Word
270 , nextGlobalName :: Word
271 , currentBlockName :: Name
272 , instAccum :: [Named Instruction]
273 , lexenv :: Env
274 , foreignSyms :: Set String
275 }
277data CGR = CGR { target :: Target
278 , funcName :: String }
280type Codegen = RWS CGR CGW CGS
282getFuncName :: Codegen String
283getFuncName = asks funcName
285getGlobalUnName :: Codegen Name
286getGlobalUnName = do
287 i <- gets nextGlobalName
288 modify $ \s -> s { nextGlobalName = 1 + i }
289 return (UnName i)
291getUnName :: Codegen Name
292getUnName = do
293 i <- gets nextName
294 modify $ \s -> s { nextName = 1 + i }
295 return (UnName i)
297getName :: String -> Codegen Name
298getName n = do
299 i <- gets nextName
300 modify $ \s -> s { nextName = 1 + i }
301 return (Name $ n ++ show i)
303alloca :: Name -> Type -> Codegen ()
304alloca n t = tell ([(n, t)], [], [])
306terminate :: Terminator -> Codegen ()
307terminate term = do
308 name <- gets currentBlockName
309 insts <- gets instAccum
310 modify $ \s -> s { instAccum = ierror "Not in a block"
311 , currentBlockName = ierror "Not in a block" }
312 tell ([], [BasicBlock name insts (Do term)], [])
314newBlock :: Name -> Codegen ()
315newBlock name = modify $ \s -> s { instAccum = []
316 , currentBlockName = name
317 }
319inst :: Instruction -> Codegen Operand
320inst i = do
321 n <- getUnName
322 modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
323 return $ LocalReference n
325ninst :: String -> Instruction -> Codegen Operand
326ninst name i = do
327 n <- getName name
328 modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
329 return $ LocalReference n
331inst' :: Instruction -> Codegen ()
332inst' i = modify $ \s -> s { instAccum = instAccum s ++ [Do i] }
334insts :: [Named Instruction] -> Codegen ()
335insts is = modify $ \s -> s { instAccum = instAccum s ++ is }
337var :: LVar -> Codegen (Maybe Operand)
338var (Loc level) = (!! level) <$> gets lexenv
339var (Glob n) = return . Just . ConstantOperand . C.GlobalReference . Name $ show n
341binds :: Env -> Codegen (Maybe Operand) -> Codegen (Maybe Operand)
342binds vals cg = do
343 envLen <- length <$> gets lexenv
344 modify $ \s -> s { lexenv = lexenv s ++ vals }
345 value <- cg
346 modify $ \s -> s { lexenv = take envLen $ lexenv s }
347 return value
349replaceElt :: Int -> a -> [a] -> [a]
350replaceElt _ val [] = error "replaceElt: Ran out of list"
351replaceElt 0 val (x:xs) = val:xs
352replaceElt n val (x:xs) = x : replaceElt (n-1) val xs
354alloc' :: Operand -> Codegen Operand
355alloc' size = inst $ simpleCall "GC_malloc" [size]
357allocAtomic :: Operand -> Codegen Operand
358allocAtomic size = inst $ simpleCall "GC_malloc_atomic" [size]
360alloc :: Type -> Codegen Operand
361alloc ty = do
362 size <- sizeOf ty
363 mem <- alloc' size
364 inst $ BitCast mem (PointerType ty (AddrSpace 0)) []
366sizeOf :: Type -> Codegen Operand
367sizeOf ty = ConstantOperand . C.PtrToInt
368 (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])
369 . IntegerType . fromIntegral <$> getWordSize
371tgtWordSize :: Target -> Integer
372tgtWordSize (Target { arch = "i386" }) = 32
373tgtWordSize (Target { arch = "x86_64" }) = 64
375getWordSize :: Codegen Integer
376getWordSize = tgtWordSize <$> asks target
378cgExpr :: SExp -> Codegen (Maybe Operand)
379cgExpr (SV v) = var v
380cgExpr (SApp tailcall fname args) = do
381 argSlots <- mapM var args
382 case sequence argSlots of
383 Nothing -> return Nothing
384 Just argVals -> do
385 fn <- var (Glob fname)
386 Just <$> inst ((idrCall (show fname) argVals) { isTailCall = tailcall })
387cgExpr (SLet _ varExpr bodyExpr) = do
388 val <- cgExpr varExpr
389 binds [val] $ cgExpr bodyExpr
390cgExpr (SUpdate (Loc level) expr) = do
391 val <- cgExpr expr
392 modify $ \s -> s { lexenv = replaceElt level val (lexenv s) }
393 return val
394cgExpr (SCon tag name args) = do
395 argSlots <- mapM var args
396 case sequence argSlots of
397 Nothing -> return Nothing
398 Just argVals -> do
399 con <- alloc . conType . fromIntegral . length $ argVals
400 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
401 inst' $ Store False tagPtr (ConstantOperand (C.Int 32 (fromIntegral tag))) Nothing 0 []
402 forM_ (zip argVals [0..]) $ \(arg, i) -> do
403 ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
404 , ConstantOperand (C.Int 32 1)
405 , ConstantOperand (C.Int 32 i)] []
406 inst' $ Store False ptr arg Nothing 0 []
407 Just <$> inst (BitCast con (PointerType valueType (AddrSpace 0)) [])
408cgExpr (SCase inspect alts) = do
409 val <- var inspect
410 case val of
411 Nothing -> return Nothing
412 Just v -> cgCase v alts
413cgExpr (SChkCase inspect alts) = do
414 mval <- var inspect
415 case mval of
416 Nothing -> return Nothing
417 Just val ->
418 do endBBN <- getName "endChkCase"
419 notNullBBN <- getName "notNull"
420 originBlock <- gets currentBlockName
421 isNull <- inst $ ICmp IPred.EQ val (ConstantOperand nullValue) []
422 terminate $ CondBr isNull endBBN notNullBBN []
423 newBlock notNullBBN
424 ptr <- inst $ BitCast val (PointerType (IntegerType 32) (AddrSpace 0)) []
425 flag <- inst $ Load False ptr Nothing 0 []
426 isVal <- inst $ ICmp IPred.EQ flag (ConstantOperand (C.Int 32 (-1))) []
427 conBBN <- getName "constructor"
428 terminate $ CondBr isVal endBBN conBBN []
429 newBlock conBBN
430 result <- cgCase val alts
431 caseExitBlock <- gets currentBlockName
432 case result of
433 Nothing -> do
434 terminate $ Unreachable []
435 newBlock endBBN
436 return $ Just val
437 Just caseVal -> do
438 terminate $ Br endBBN []
439 newBlock endBBN
440 Just <$> inst (Phi (PointerType valueType (AddrSpace 0))
441 [(val, originBlock), (val, notNullBBN), (caseVal, caseExitBlock)] [])
442cgExpr (SProj conVar idx) = do
443 val <- var conVar
444 case val of
445 Nothing -> return Nothing
446 Just v ->
447 do ptr <- inst $ GetElementPtr True v
448 [ ConstantOperand (C.Int 32 0)
449 , ConstantOperand (C.Int 32 1)
450 , ConstantOperand (C.Int 32 (fromIntegral idx))
451 ] []
452 Just <$> inst (Load False ptr Nothing 0 [])
453cgExpr (SConst c) = Just <$> cgConst c
454cgExpr (SForeign LANG_C rty fname args) = do
455 func <- ensureCDecl fname rty (map fst args)
456 argVals <- forM args $ \(fty, v) -> do
457 v' <- var v
458 case v' of
459 Just val -> return $ Just (fty, val)
460 Nothing -> return Nothing
461 case sequence argVals of
462 Nothing -> return Nothing
463 Just argVals' -> do
464 argUVals <- mapM (uncurry unbox) argVals'
465 result <- inst Call { isTailCall = False
466 , callingConvention = CC.C
467 , returnAttributes = []
468 , function = Right func
469 , arguments = map (\v -> (v, [])) argUVals
470 , functionAttributes = []
471 , metadata = []
472 }
473 Just <$> box rty result
474cgExpr (SOp fn args) = do
475 argVals <- mapM var args
476 case sequence argVals of
477 Just ops -> Just <$> cgOp fn ops
478 Nothing -> return Nothing
479cgExpr SNothing = return . Just . ConstantOperand $ nullValue
480cgExpr (SError msg) = do -- TODO: Print message
481 str <- addGlobal' (ArrayType (2 + fromIntegral (length msg)) (IntegerType 8))
482 (cgConst' (TT.Str (msg ++ "\n")))
483 inst' $ simpleCall "putStr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0
484 , C.Int 32 0]]
485 inst' Call { isTailCall = True
486 , callingConvention = CC.C
487 , returnAttributes = []
488 , function = Right . ConstantOperand . C.GlobalReference . Name $ "llvm.trap"
489 , arguments = []
490 , functionAttributes = [A.NoReturn]
491 , metadata = []
492 }
493 return Nothing
495cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand)
496cgCase val alts =
497 case find isConstCase alts of
498 Just (SConstCase (TT.BI _) _) -> cgChainCase val defExp constAlts
499 Just (SConstCase (TT.Str _) _) -> cgChainCase val defExp constAlts
500 Just (SConstCase _ _) -> cgPrimCase val defExp constAlts
501 Nothing -> cgConCase val defExp conAlts
502 where
503 defExp = getDefExp =<< find isDefCase alts
504 constAlts = filter isConstCase alts
505 conAlts = filter isConCase alts
507 isConstCase (SConstCase {}) = True
508 isConstCase _ = False
510 isConCase (SConCase {}) = True
511 isConCase _ = False
513 isDefCase (SDefaultCase _) = True
514 isDefCase _ = False
516 getDefExp (SDefaultCase e) = Just e
517 getDefExp _ = Nothing
519cgPrimCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
520cgPrimCase caseValPtr defExp alts = do
521 let caseTy = case head alts of
522 SConstCase (TT.I _) _ -> IntegerType 32
523 SConstCase (TT.B8 _) _ -> IntegerType 8
524 SConstCase (TT.B16 _) _ -> IntegerType 16
525 SConstCase (TT.B32 _) _ -> IntegerType 32
526 SConstCase (TT.B64 _) _ -> IntegerType 64
527 SConstCase (TT.Fl _) _ -> FloatingPointType 64 IEEE
528 SConstCase (TT.Ch _) _ -> IntegerType 32
529 realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) []
530 valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
531 caseVal <- inst $ Load False valPtr Nothing 0 []
532 defBlockName <- getName "default"
533 exitBlockName <- getName "caseExit"
534 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
535 terminate $ Switch caseVal defBlockName (map (\(n, SConstCase c _) -> (cgConst' c, n)) namedAlts) []
536 initEnv <- gets lexenv
537 defResult <- cgDefaultAlt exitBlockName defBlockName defExp
538 results <- forM namedAlts $ \(name, SConstCase _ exp) -> cgAlt initEnv exitBlockName name Nothing exp
539 finishCase initEnv exitBlockName (defResult:results)
541cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
542cgConCase con defExp alts = do
543 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
544 tag <- inst $ Load False tagPtr Nothing 0 []
545 defBlockName <- getName "default"
546 exitBlockName <- getName "caseExit"
547 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
548 terminate $ Switch tag defBlockName (map (\(n, SConCase _ tag _ _ _) ->
549 (C.Int 32 (fromIntegral tag), n)) namedAlts) []
550 initEnv <- gets lexenv
551 defResult <- cgDefaultAlt exitBlockName defBlockName defExp
552 results <- forM namedAlts $ \(name, SConCase _ _ _ argns exp) ->
553 cgAlt initEnv exitBlockName name (Just (con, map show argns)) exp
554 finishCase initEnv exitBlockName (defResult:results)
556cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
557cgChainCase caseValPtr defExp alts = do
558 let (caseTy, comparator) =
559 case head alts of
560 SConstCase (TT.BI _) _ -> (FInt ITBig, "__gmpz_cmp")
561 SConstCase (TT.Str _) _ -> (FString, "strcmp")
562 caseVal <- unbox caseTy caseValPtr
563 defBlockName <- getName "default"
564 exitBlockName <- getName "caseExit"
565 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
566 initEnv <- gets lexenv
567 results <- forM namedAlts $ \(name, SConstCase c e) ->
568 do const <- unbox caseTy =<< cgConst c
569 cmp <- inst $ simpleCall comparator [const, caseVal]
570 cmpResult <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
571 elseName <- getName "else"
572 terminate $ CondBr cmpResult name elseName []
573 result <- cgAlt initEnv exitBlockName name Nothing e
574 newBlock elseName
575 return result
576 modify $ \s -> s { lexenv = initEnv }
577 fname <- getFuncName
578 defaultVal <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) defExp)
579 defaultBlock <- gets currentBlockName
580 defaultEnv <- gets lexenv
581 defResult <- case defaultVal of
582 Just v -> do
583 terminate $ Br exitBlockName []
584 return $ Just (v, defaultBlock, defaultEnv)
585 Nothing -> do
586 terminate $ Unreachable []
587 return Nothing
588 finishCase initEnv exitBlockName (defResult:results)
590finishCase :: Env -> Name -> [Maybe (Operand, Name, Env)] -> Codegen (Maybe Operand)
591finishCase initEnv exitBlockName results = do
592 let definedResults = mapMaybe id results
593 case definedResults of
594 [] -> do modify $ \s -> s { lexenv = initEnv }
595 return Nothing
596 xs -> do
597 newBlock exitBlockName
598 mergeEnvs $ map (\(_, altBlock, altEnv) -> (altBlock, altEnv)) xs
599 Just <$> inst (Phi (PointerType valueType (AddrSpace 0))
600 (map (\(altVal, altBlock, _) -> (altVal, altBlock)) xs) [])
603cgDefaultAlt :: Name -> Name -> Maybe SExp -> Codegen (Maybe (Operand, Name, Env))
604cgDefaultAlt exitName name exp = do
605 newBlock name
606 fname <- getFuncName
607 val <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) exp)
608 env <- gets lexenv
609 block <- gets currentBlockName
610 case val of
611 Just v ->
612 do terminate $ Br exitName []
613 return $ Just (v, block, env)
614 Nothing ->
615 do terminate $ Unreachable []
616 return Nothing
618cgAlt :: Env -> Name -> Name -> Maybe (Operand, [String]) -> SExp
619 -> Codegen (Maybe (Operand, Name, Env))
620cgAlt initEnv exitBlockName name destr exp = do
621 modify $ \s -> s { lexenv = initEnv }
622 newBlock name
623 locals <- case destr of
624 Nothing -> return []
625 Just (con, argns) ->
626 forM (zip argns [0..]) $ \(argName, i) ->
627 do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
628 , ConstantOperand (C.Int 32 1)
629 , ConstantOperand (C.Int 32 i)] []
630 Just <$> ninst argName (Load False ptr Nothing 0 [])
631 altVal <- binds locals $ cgExpr exp
632 altEnv <- gets lexenv
633 altBlock <- gets currentBlockName
634 case altVal of
635 Just v -> do
636 terminate $ Br exitBlockName []
637 return $ Just (v, altBlock, altEnv)
638 Nothing -> do
639 terminate $ Unreachable []
640 return Nothing
642mergeEnvs :: [(Name, Env)] -> Codegen ()
643mergeEnvs es = do
644 let vars = transpose
645 . map (\(block, env) -> map (\x -> (x, block)) env)
646 $ es
647 env <- forM vars $ \var ->
648 case var of
649 [] -> ierror "mergeEnvs: impossible"
650 [(v, _)] -> return v
651 vs@((v, _):_)
652 | all (== v) (map fst vs) -> return v
653 | otherwise ->
654 let valid = map (\(a, b) -> (fromJust a, b)) . filter (isJust . fst) $ vs in
655 Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) valid [])
656 modify $ \s -> s { lexenv = env }
658nameAlt :: Name -> SAlt -> Codegen Name
659nameAlt d (SDefaultCase _) = return d
660nameAlt _ (SConCase _ _ name _ _) = getName (show name)
661nameAlt _ (SConstCase const _) = getName (show const)
663box :: FType -> Operand -> Codegen Operand
664box FUnit _ = return $ ConstantOperand nullValue
665box fty fval = do
666 val <- alloc (primTy (ftyToTy fty))
667 tagptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
668 valptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
669 inst' $ Store False tagptr (ConstantOperand (C.Int 32 (-1))) Nothing 0 []
670 inst' $ Store False valptr fval Nothing 0 []
671 inst $ BitCast val (PointerType valueType (AddrSpace 0)) []
673unbox :: FType -> Operand -> Codegen Operand
674unbox FUnit x = return x
675unbox fty bval = do
676 val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) []
677 fvalptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
678 inst $ Load False fvalptr Nothing 0 []
680cgConst' :: TT.Const -> C.Constant
681cgConst' (TT.I i) = C.Int 32 (fromIntegral i)
682cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i)
683cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i)
684cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i)
685cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i)
686cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0])
687cgConst' (TT.Fl f) = C.Float (F.Double f)
688cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c
689cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) s ++ [C.Int 8 0])
690cgConst' x = ierror $ "Unsupported constant: " ++ show x
692cgConst :: TT.Const -> Codegen Operand
693cgConst c@(TT.I _) = box (FInt ITNative) (ConstantOperand $ cgConst' c)
694cgConst c@(TT.B8 _) = box (FInt IT8) (ConstantOperand $ cgConst' c)
695cgConst c@(TT.B16 _) = box (FInt IT16) (ConstantOperand $ cgConst' c)
696cgConst c@(TT.B32 _) = box (FInt IT32) (ConstantOperand $ cgConst' c)
697cgConst c@(TT.B64 _) = box (FInt IT64) (ConstantOperand $ cgConst' c)
698cgConst c@(TT.Fl _) = box FDouble (ConstantOperand $ cgConst' c)
699cgConst c@(TT.Ch _) = box FChar (ConstantOperand $ cgConst' c)
700cgConst c@(TT.Str s) = do
701 str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)
702 box FString (ConstantOperand $ C.GetElementPtr True str [C.Int 32 0, C.Int 32 0])
703cgConst c@(TT.BI i) = do
704 str <- addGlobal' (ArrayType (1 + fromInteger (numDigits 10 i)) (IntegerType 8)) (cgConst' c)
705 mpz <- alloc mpzTy
706 inst $ simpleCall "__gmpz_init_set_str" [mpz
707 , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0]
708 , ConstantOperand $ C.Int 32 10
709 ]
710 box (FInt ITBig) mpz
711cgConst x = return $ ConstantOperand nullValue
713numDigits :: Integer -> Integer -> Integer
714numDigits b n = 1 + fst (ilog b n) where
715 ilog b n
716 | n < b = (0, n)
717 | otherwise = let (e, r) = ilog (b*b) n
718 in if r < b then (2*e, r) else (2*e+1, r `div` b)
720addGlobal :: Global -> Codegen ()
721addGlobal def = tell ([], [], [GlobalDefinition def])
723addGlobal' :: Type -> C.Constant -> Codegen C.Constant
724addGlobal' ty val = do
725 name <- getGlobalUnName
726 addGlobal $ globalVariableDefaults
727 { G.name = name
728 , G.linkage = L.Internal
729 , G.hasUnnamedAddr = True
730 , G.isConstant = True
731 , G.type' = ty
732 , G.initializer = Just val
733 }
734 return . C.GlobalReference $ name
737ensureCDecl :: String -> FType -> [FType] -> Codegen Operand
738ensureCDecl name rty argtys = do
739 syms <- gets foreignSyms
740 unless (S.member name syms) $
741 do addGlobal (ffunDecl name rty argtys)
742 modify $ \s -> s { foreignSyms = S.insert name (foreignSyms s) }
743 return $ ConstantOperand (C.GlobalReference (Name name))
745ffunDecl :: String -> FType -> [FType] -> Global
746ffunDecl name rty argtys =
747 functionDefaults
748 { G.returnType = ftyToTy rty
749 , G.name = Name name
750 , G.parameters = (flip map argtys $ \fty ->
751 Parameter (ftyToTy fty) (UnName 0) []
752 , False)
753 }
755ftyToTy :: FType -> Type
756ftyToTy (FInt ITNative) = IntegerType 32
757ftyToTy (FInt ITBig) = PointerType mpzTy (AddrSpace 0)
758ftyToTy (FInt ty) = IntegerType (itWidth ty)
759ftyToTy FChar = IntegerType 32
760ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)
761ftyToTy FUnit = VoidType
762ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)
763ftyToTy FDouble = FloatingPointType 64 IEEE
764ftyToTy FAny = valueType
766cgOp :: PrimFn -> [Operand] -> Codegen Operand
767cgOp (LTrunc ITBig ity) [x] = do
768 nx <- unbox (FInt ITBig) x
769 val <- inst $ simpleCall "mpz_get_ull" [nx]
770 v <- case ity of
771 IT64 -> return val
772 _ -> inst $ Trunc val (IntegerType $ itWidth ity) []
773 box (FInt ity) v
774cgOp (LZExt from ITBig) [x] = do
775 nx <- unbox (FInt from) x
776 nx' <- case from of
777 IT64 -> return nx
778 _ -> inst $ ZExt nx (IntegerType 64) []
779 mpz <- alloc mpzTy
780 inst' $ simpleCall "mpz_init_set_ull" [mpz, nx']
781 box (FInt ITBig) mpz
782cgOp (LSExt from ITBig) [x] = do
783 nx <- unbox (FInt from) x
784 nx' <- case from of
785 IT64 -> return nx
786 _ -> inst $ SExt nx (IntegerType 64) []
787 mpz <- alloc mpzTy
788 inst' $ simpleCall "mpz_init_set_sll" [mpz, nx']
789 box (FInt ITBig) mpz
791cgOp (LLt ITBig) [x,y] = mpzCmp IPred.SLT x y
792cgOp (LLe ITBig) [x,y] = mpzCmp IPred.SLE x y
793cgOp (LEq ITBig) [x,y] = mpzCmp IPred.EQ x y
794cgOp (LGe ITBig) [x,y] = mpzCmp IPred.SGE x y
795cgOp (LGt ITBig) [x,y] = mpzCmp IPred.SGT x y
796cgOp (LPlus ITBig) [x,y] = mpzBin "add" x y
797cgOp (LMinus ITBig) [x,y] = mpzBin "sub" x y
798cgOp (LTimes ITBig) [x,y] = mpzBin "mul" x y
799cgOp (LSDiv ITBig) [x,y] = mpzBin "fdiv_q" x y
800cgOp (LSRem ITBig) [x,y] = mpzBin "fdiv_r" x y
801cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y
802cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y
803cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y
804cgOp (LCompl ITBig) [x] = mpzUn "com" x
806cgOp (LTrunc from to) [x] | itWidth from > itWidth to = iCoerce Trunc from to x
807cgOp (LZExt from to) [x] | itWidth from < itWidth to = iCoerce ZExt from to x
808cgOp (LSExt from to) [x] | itWidth from < itWidth to = iCoerce SExt from to x
810cgOp (LLt ity) [x,y] = iCmp ity IPred.SLT x y
811cgOp (LLe ity) [x,y] = iCmp ity IPred.SLE x y
812cgOp (LEq ity) [x,y] = iCmp ity IPred.EQ x y
813cgOp (LGe ity) [x,y] = iCmp ity IPred.SGE x y
814cgOp (LGt ity) [x,y] = iCmp ity IPred.SGT x y
815cgOp (LPlus ity) [x,y] = ibin ity x y (Add False False)
816cgOp (LMinus ity) [x,y] = ibin ity x y (Sub False False)
817cgOp (LTimes ity) [x,y] = ibin ity x y (Mul False False)
818cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv False)
819cgOp (LURem ity) [x,y] = ibin ity x y URem
820cgOp (LSDiv ity) [x,y] = ibin ity x y (SDiv False)
821cgOp (LSRem ity) [x,y] = ibin ity x y SRem
822cgOp (LAnd ity) [x,y] = ibin ity x y And
823cgOp (LOr ity) [x,y] = ibin ity x y Or
824cgOp (LXOr ity) [x,y] = ibin ity x y Xor
825cgOp (LCompl ity) [x] = iun ity x (Xor (ConstantOperand (C.Int (itWidth ity) (-1))))
826cgOp (LSHL ity) [x,y] = ibin ity x y (Shl False False)
827cgOp (LLSHR ity) [x,y] = ibin ity x y (LShr False)
828cgOp (LASHR ity) [x,y] = ibin ity x y (AShr False)
830cgOp LStrEq [x,y] = do
831 x' <- unbox FString x
832 y' <- unbox FString y
833 cmp <- inst $ simpleCall "strcmp" [x', y']
834 flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
835 val <- inst $ ZExt flag (IntegerType 32) []
836 box (FInt IT32) val
838cgOp LStrLt [x,y] = do
839 nx <- unbox FString x
840 ny <- unbox FString y
841 cmp <- inst $ simpleCall "strcmp" [nx, ny]
842 flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) []
843 val <- inst $ ZExt flag (IntegerType 32) []
844 box (FInt IT32) val
846cgOp (LIntStr ITBig) [x] = do
847 x' <- unbox (FInt ITBig) x
848 ustr <- inst $ simpleCall "__gmpz_get_str"
849 [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))
850 , ConstantOperand (C.Int 32 10)
851 , x'
852 ]
853 box FString ustr
854cgOp (LIntStr ity) [x] = do
855 x' <- unbox (FInt ity) x
856 x'' <- if itWidth ity < 64
857 then inst $ SExt x' (IntegerType 64) []
858 else return x'
859 box FString =<< inst (idrCall "__idris_intStr" [x''])
860cgOp (LStrInt ITBig) [s] = do
861 ns <- unbox FString s
862 mpz <- alloc mpzTy
863 inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10]
864 box (FInt ITBig) mpz
865cgOp (LStrInt ity) [s] = do
866 ns <- unbox FString s
867 nx <- inst $ simpleCall "strtoll"
868 [ns
869 , ConstantOperand $ C.Null (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0))
870 , ConstantOperand $ C.Int 32 10
871 ]
872 nx' <- case ity of
873 IT64 -> return nx
874 _ -> inst $ Trunc nx (IntegerType (itWidth ity)) []
875 box (FInt ity) nx'
877cgOp LStrConcat [x,y] = cgStrCat x y
879cgOp LStrCons [c,s] = do
880 nc <- unbox FChar c
881 ns <- unbox FString s
882 nc' <- inst $ Trunc nc (IntegerType 8) []
883 r <- inst $ simpleCall "__idris_strCons" [nc', ns]
884 box FString r
886cgOp LStrHead [c] = do
887 s <- unbox FString c
888 c <- inst $ Load False s Nothing 0 []
889 c' <- inst $ ZExt c (IntegerType 32) []
890 box FChar c'
892cgOp LStrIndex [s, i] = do
893 ns <- unbox FString s
894 ni <- unbox (FInt IT32) i
895 p <- inst $ GetElementPtr True ns [ni] []
896 c <- inst $ Load False p Nothing 0 []
897 c' <- inst $ ZExt c (IntegerType 32) []
898 box FChar c'
900cgOp LStrTail [c] = do
901 s <- unbox FString c
902 c <- inst $ GetElementPtr True s [ConstantOperand $ C.Int 32 1] []
903 box FString c
905cgOp LStrLen [s] = do
906 ns <- unbox FString s
907 len <- inst $ simpleCall "strlen" [ns]
908 ws <- getWordSize
909 len' <- case ws of
910 32 -> return len
911 x | x > 32 -> inst $ Trunc len (IntegerType $ fromInteger x) []
912 | x < 32 -> inst $ ZExt len (IntegerType $ fromInteger x) []
913 box (FInt IT32) len'
915cgOp LReadStr [p] = do
916 np <- unbox FPtr p
917 s <- inst $ simpleCall "__idris_readStr" [np]
918 box FString s
920cgOp LStdIn [] = do
921 ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stdin") Nothing 0 []
922 box FPtr ptr
923cgOp LStdOut [] = do
924 ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stdout") Nothing 0 []
925 box FPtr ptr
926cgOp LStdErr [] = do
927 ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stderr") Nothing 0 []
928 box FPtr ptr
931cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("
932 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"
934iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> IntTy -> IntTy -> Operand -> Codegen Operand
935iCoerce operator from to x = do
936 x' <- unbox (FInt from) x
937 x'' <- inst $ operator x' (IntegerType $ itWidth to) []
938 box (FInt to) x''
940cgStrCat :: Operand -> Operand -> Codegen Operand
941cgStrCat x y = do
942 x' <- unbox FString x
943 y' <- unbox FString y
944 xlen <- inst $ simpleCall "strlen" [x']
945 ylen <- inst $ simpleCall "strlen" [y']
946 zlen <- inst $ Add False True xlen ylen []
947 ws <- fromIntegral <$> getWordSize
948 total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
949 mem <- allocAtomic total
950 inst $ simpleCall "memcpy" [mem, x', xlen]
951 i <- inst $ PtrToInt mem (IntegerType ws) []
952 offi <- inst $ Add False True i xlen []
953 offp <- inst $ IntToPtr offi (PointerType (IntegerType 8) (AddrSpace 0)) []
954 inst $ simpleCall "memcpy" [offp, y', ylen]
955 j <- inst $ PtrToInt offp (IntegerType ws) []
956 offj <- inst $ Add False True j ylen []
957 end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) []
958 inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 []
959 box FString mem
961ibin :: IntTy -> Operand -> Operand
962 -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
963ibin ity x y instCon = do
964 nx <- unbox (FInt ity) x
965 ny <- unbox (FInt ity) y
966 nr <- inst $ instCon nx ny []
967 box (FInt ity) nr
969iun :: IntTy -> Operand -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
970iun ity x instCon = do
971 nx <- unbox (FInt ity) x
972 nr <- inst $ instCon nx []
973 box (FInt ity) nr
975iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
976iCmp ity pred x y = do
977 nx <- unbox (FInt ity) x
978 ny <- unbox (FInt ity) y
979 nr <- inst $ ICmp pred nx ny []
980 nr' <- inst $ ZExt nr (IntegerType 32) []
981 box (FInt IT32) nr'
983mpzBin :: String -> Operand -> Operand -> Codegen Operand
984mpzBin name x y = do
985 nx <- unbox (FInt ITBig) x
986 ny <- unbox (FInt ITBig) y
987 nz <- alloc mpzTy
988 inst' $ simpleCall "__gmpz_init" [nz]
989 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny]
990 box (FInt ITBig) nz
992mpzUn :: String -> Operand -> Codegen Operand
993mpzUn name x = do
994 nx <- unbox (FInt ITBig) x
995 nz <- alloc mpzTy
996 inst' $ simpleCall "__gmpz_init" [nz]
997 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx]
998 box (FInt ITBig) nz
1000mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
1001mpzCmp pred x y = do
1002 nx <- unbox (FInt ITBig) x
1003 ny <- unbox (FInt ITBig) y
1004 cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny]
1005 result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) []
1006 i <- inst $ ZExt result (IntegerType 32) []
1007 box (FInt IT32) i
1009simpleCall :: String -> [Operand] -> Instruction
1010simpleCall name args =
1011 Call { isTailCall = False
1012 , callingConvention = CC.C
1013 , returnAttributes = []
1014 , function = Right . ConstantOperand . C.GlobalReference . Name $ name
1015 , arguments = map (\x -> (x, [])) args
1016 , functionAttributes = []
1017 , metadata = []
1020idrCall :: String -> [Operand] -> Instruction
1021idrCall name args =
1022 Call { isTailCall = False
1023 , callingConvention = CC.Fast
1024 , returnAttributes = []
1025 , function = Right . ConstantOperand . C.GlobalReference . Name $ name
1026 , arguments = map (\x -> (x, [])) args
1027 , functionAttributes = []
1028 , metadata = []
1031assert :: Operand -> String -> Codegen ()
1032assert condition message = do
1033 passed <- getName "assertPassed"
1034 failed <- getName "assertFailed"
1035 terminate $ CondBr condition passed failed []
1036 newBlock failed
1037 cgExpr (SError message)
1038 terminate $ Unreachable []
1039 newBlock passed