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