@@ -0,0 +1,773 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+module IRTS.CodegenLLVM (codegenLLVM) where
3+
4+import IRTS.CodegenCommon
5+import IRTS.Lang
6+import IRTS.Simplified
7+import qualified Core.TT as TT
8+
9+import LLVM.General.Context
10+import LLVM.General.Diagnostic
11+import LLVM.General.AST
12+import LLVM.General.AST.AddrSpace
13+import qualified LLVM.General.Module as M
14+import qualified LLVM.General.AST.IntegerPredicate as IPred
15+import qualified LLVM.General.AST.Linkage as L
16+import qualified LLVM.General.AST.Visibility as V
17+import qualified LLVM.General.AST.CallingConvention as CC
18+import qualified LLVM.General.AST.Attribute as A
19+import qualified LLVM.General.AST.Global as G
20+import qualified LLVM.General.AST.Constant as C
21+import qualified LLVM.General.AST.Float as F
22+
23+import Data.List
24+import Data.Maybe
25+import Data.Word
26+import Data.Set (Set)
27+import qualified Data.Set as S
28+import Control.Applicative
29+import Control.Monad.RWS
30+import Control.Monad.Writer
31+import Control.Monad.State
32+
33+import System.Info (arch)
34+import Debug.Trace
35+
36+codegenLLVM :: [(TT.Name, SDecl)] ->
37+ FilePath -> -- output file name
38+ OutputType ->
39+ IO ()
40+codegenLLVM defs file outty = withContext $ \context -> do
41+ let ast = codegen arch (map snd defs)
42+ result <- traceShow ast $ M.withModuleFromAST context ast (M.writeBitcodeToFile file)
43+ case result of
44+ Right _ -> return ()
45+ Left msg -> ierror msg
46+
47+ierror :: String -> a
48+ierror msg = error $ "INTERNAL ERROR: IRTS.CodegenLLVM: " ++ msg
49+
50+codegen :: String -> [SDecl] -> Module
51+codegen tgt defs =
52+ Module "idris" Nothing Nothing
53+ ([ TypeDefinition (Name "valTy") (
54+ Just $ StructureType False
55+ [ IntegerType 32
56+ , ArrayType 0 (PointerType valueType (AddrSpace 0))
57+ ])
58+ , TypeDefinition (Name "mpz") (
59+ Just $ StructureType False
60+ [ IntegerType 32
61+ , IntegerType 32
62+ , PointerType (IntegerType 8) (AddrSpace 0) -- Not actually i8, but we don't care
63+ ])
64+ , GlobalDefinition $ globalVariableDefaults
65+ { G.name = Name "__idris_intFmtStr"
66+ , G.isConstant = True
67+ , G.hasUnnamedAddr = True
68+ , G.type' = ArrayType 5 (IntegerType 8)
69+ , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%lld" ++ [C.Int 8 0])
70+ }
71+ , rtsFun "intStr" ptrI8 [IntegerType 64]
72+ [ BasicBlock (UnName 0)
73+ [ UnName 1 := simpleCall "GC_malloc_atomic"
74+ [ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 12)]
75+ , UnName 2 := simpleCall "snprintf"
76+ [ LocalReference (UnName 1)
77+ , ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 12)
78+ , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
79+ , LocalReference (UnName 0)
80+ ]
81+ ]
82+ (Do $ Ret (Just (LocalReference (UnName 1))) [])
83+ ]
84+ , exfun "llvm.trap" VoidType [] False
85+ , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True
86+ , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False
87+ , exfun "strlen" intPtr [ptrI8] False
88+ , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False
89+ , exfun "GC_malloc" ptrI8 [intPtr] False
90+ , exfun "GC_malloc_atomic" ptrI8 [intPtr] False
91+ , exfun "__gmpz_init" VoidType [pmpz] False
92+ ]
93+ ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
94+ ++ globals
95+ ++ gendefs)
96+ where
97+ ((gendefs, globals), _) = (runState . runWriterT) (mapM cgDef defs) 0
98+ intPtr = IntegerType (fromInteger $ tgtWordSize tgt)
99+ ptrI8 = PointerType (IntegerType 8) (AddrSpace 0)
100+ pmpz = PointerType mpzTy (AddrSpace 0)
101+
102+ mpzBinFun n = exfun ("__gmpz_" ++ n) VoidType [pmpz, pmpz, pmpz] False
103+
104+ rtsFun :: String -> Type -> [Type] -> [BasicBlock] -> Definition
105+ rtsFun name rty argtys def =
106+ GlobalDefinition $ functionDefaults
107+ { G.linkage = L.Internal
108+ , G.returnType = rty
109+ , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], False)
110+ , G.name = Name $ "__idris_" ++ name
111+ , G.basicBlocks = def
112+ }
113+
114+ exfun :: String -> Type -> [Type] -> Bool -> Definition
115+ exfun name rty argtys vari =
116+ GlobalDefinition $ functionDefaults
117+ { G.returnType = rty
118+ , G.name = Name name
119+ , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], vari)
120+ }
121+
122+valueType :: Type
123+valueType = NamedTypeReference (Name "valTy")
124+
125+nullValue :: C.Constant
126+nullValue = C.Null (PointerType valueType (AddrSpace 0))
127+
128+primTy :: Type -> Type
129+primTy inner = StructureType False [IntegerType 8, inner]
130+
131+mpzTy :: Type
132+mpzTy = NamedTypeReference (Name "mpz")
133+
134+conType :: Word64 -> Type
135+conType nargs = StructureType False
136+ [ IntegerType 32
137+ , ArrayType nargs (PointerType valueType (AddrSpace 0))
138+ ]
139+
140+type Modgen = WriterT [Definition] (State Word)
141+
142+cgDef :: SDecl -> Modgen Definition
143+cgDef (SFun name argNames _ expr) = do
144+ nextGlobal <- get
145+ let (_, CGS { nextGlobalName = nextGlobal' }, (allocas, bbs, globals)) =
146+ runRWS (do r <- cgExpr expr
147+ case r of
148+ Nothing -> terminate $ Unreachable []
149+ Just r' -> terminate $ Ret (Just r') [])
150+ (CGR arch (Name . show $ name))
151+ (CGS 0 nextGlobal (Name "begin") [] (map (Just . LocalReference . Name . show) argNames) S.empty)
152+ entryTerm = case bbs of
153+ [] -> Do $ Ret Nothing []
154+ (BasicBlock n _ _):_ -> Do $ Br n []
155+ tell globals
156+ put nextGlobal'
157+ return . GlobalDefinition $ functionDefaults
158+ { G.linkage = L.Internal
159+ , G.callingConvention = CC.Fast
160+ , G.name = Name (show name)
161+ , G.returnType = PointerType valueType (AddrSpace 0)
162+ , G.parameters = (flip map argNames $ \argName ->
163+ Parameter (PointerType valueType (AddrSpace 0)) (Name (show argName)) []
164+ , False)
165+ , G.basicBlocks =
166+ [ BasicBlock (Name "entry")
167+ (map (\(n, t) -> n := Alloca t Nothing 0 []) allocas)
168+ entryTerm
169+ ] ++ bbs
170+ }
171+
172+type CGW = ([(Name, Type)], [BasicBlock], [Definition])
173+
174+type Env = [Maybe Operand]
175+
176+data CGS = CGS { nextName :: Word
177+ , nextGlobalName :: Word
178+ , currentBlockName :: Name
179+ , instAccum :: [Named Instruction]
180+ , lexenv :: Env
181+ , foreignSyms :: Set String
182+ }
183+
184+data CGR = CGR { target :: String
185+ , funcName :: Name }
186+
187+type Codegen = RWS CGR CGW CGS
188+
189+getGlobalUnName :: Codegen Name
190+getGlobalUnName = do
191+ i <- gets nextGlobalName
192+ modify $ \s -> s { nextGlobalName = 1 + i }
193+ return (UnName i)
194+
195+getUnName :: Codegen Name
196+getUnName = do
197+ i <- gets nextName
198+ modify $ \s -> s { nextName = 1 + i }
199+ return (UnName i)
200+
201+getName :: String -> Codegen Name
202+getName n = do
203+ i <- gets nextName
204+ modify $ \s -> s { nextName = 1 + i }
205+ return (Name $ n ++ show i)
206+
207+alloca :: Name -> Type -> Codegen ()
208+alloca n t = tell ([(n, t)], [], [])
209+
210+terminate :: Terminator -> Codegen ()
211+terminate term = do
212+ name <- gets currentBlockName
213+ insts <- gets instAccum
214+ modify $ \s -> s { instAccum = ierror "Not in a block"
215+ , currentBlockName = ierror "Not in a block" }
216+ tell ([], [BasicBlock name insts (Do term)], [])
217+
218+newBlock :: Name -> Codegen ()
219+newBlock name = modify $ \s -> s { instAccum = []
220+ , currentBlockName = name
221+ }
222+
223+inst :: Instruction -> Codegen Operand
224+inst i = do
225+ n <- getUnName
226+ modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
227+ return $ LocalReference n
228+
229+ninst :: String -> Instruction -> Codegen Operand
230+ninst name i = do
231+ n <- getName name
232+ modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
233+ return $ LocalReference n
234+
235+inst' :: Instruction -> Codegen ()
236+inst' i = modify $ \s -> s { instAccum = instAccum s ++ [Do i] }
237+
238+insts :: [Named Instruction] -> Codegen ()
239+insts is = modify $ \s -> s { instAccum = instAccum s ++ is }
240+
241+var :: LVar -> Codegen (Maybe Operand)
242+var (Loc level) = (!! level) <$> gets lexenv
243+var (Glob n) = return . Just . ConstantOperand . C.GlobalReference . Name $ show n
244+
245+binds :: Env -> Codegen (Maybe Operand) -> Codegen (Maybe Operand)
246+binds vals cg = do
247+ envLen <- length <$> gets lexenv
248+ modify $ \s -> s { lexenv = lexenv s ++ vals }
249+ value <- cg
250+ modify $ \s -> s { lexenv = take envLen $ lexenv s }
251+ return value
252+
253+replaceElt :: Int -> a -> [a] -> [a]
254+replaceElt _ val [] = error "replaceElt: Ran out of list"
255+replaceElt 0 val (x:xs) = val:xs
256+replaceElt n val (x:xs) = x : replaceElt (n-1) val xs
257+
258+alloc' :: Operand -> Codegen Operand
259+alloc' size = do
260+ inst $ simpleCall "GC_malloc" [size]
261+
262+allocAtomic :: Operand -> Codegen Operand
263+allocAtomic size = do
264+ inst $ simpleCall "GC_malloc_atomic" [size]
265+
266+alloc :: Type -> Codegen Operand
267+alloc ty = do
268+ size <- sizeOf ty
269+ mem <- alloc' size
270+ inst $ BitCast mem (PointerType ty (AddrSpace 0)) []
271+
272+sizeOf :: Type -> Codegen Operand
273+sizeOf ty = ConstantOperand . C.PtrToInt
274+ (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])
275+ . IntegerType . fromIntegral <$> wordSize
276+
277+tgtWordSize :: String -> Integer
278+tgtWordSize tgt = case tgt of
279+ "x86_64" -> 64
280+ "i386" -> 32
281+
282+wordSize :: Codegen Integer
283+wordSize = tgtWordSize <$> asks target
284+
285+cgExpr :: SExp -> Codegen (Maybe Operand)
286+cgExpr (SV v) = var v
287+cgExpr (SApp tailcall fname args) = do
288+ argSlots <- mapM var args
289+ case sequence argSlots of
290+ Nothing -> return Nothing
291+ Just argVals -> do
292+ fn <- var (Glob fname)
293+ Just <$> (inst $
294+ Call { isTailCall = tailcall
295+ , callingConvention = CC.Fast
296+ , returnAttributes = []
297+ , function = Right . ConstantOperand . C.GlobalReference . Name $ show fname
298+ , arguments = map (\v -> (v, [])) argVals
299+ , functionAttributes = []
300+ , metadata = []
301+ })
302+cgExpr (SLet _ varExpr bodyExpr) = do
303+ val <- cgExpr varExpr
304+ binds [val] $ cgExpr bodyExpr
305+cgExpr (SUpdate (Loc level) expr) = do
306+ val <- cgExpr expr
307+ modify $ \s -> s { lexenv = replaceElt level val (lexenv s) }
308+ return val
309+cgExpr (SCon tag name args) = do
310+ argSlots <- mapM var args
311+ case sequence argSlots of
312+ Nothing -> return Nothing
313+ Just argVals -> do
314+ con <- alloc . conType . fromIntegral . length $ argVals
315+ tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
316+ inst' $ Store False tagPtr (ConstantOperand (C.Int 32 (fromIntegral tag))) Nothing 0 []
317+ forM_ (zip argVals [0..]) $ \(arg, i) -> do
318+ ptr <- inst $ GetElementPtr True arg [ ConstantOperand (C.Int 32 0)
319+ , ConstantOperand (C.Int 32 1)
320+ , ConstantOperand (C.Int 32 i)] []
321+ inst' $ Store False ptr arg Nothing 0 []
322+ Just <$> (inst $ BitCast con (PointerType valueType (AddrSpace 0)) [])
323+cgExpr (SCase inspect alts) = do
324+ val <- var inspect
325+ case val of
326+ Nothing -> return Nothing
327+ Just v -> cgCase v alts
328+cgExpr (SChkCase inspect alts) = do
329+ mval <- var inspect
330+ case mval of
331+ Nothing -> return Nothing
332+ Just val ->
333+ do ptr <- inst $ BitCast val (PointerType (IntegerType 8) (AddrSpace 0)) []
334+ flag <- inst $ Load False ptr Nothing 0 []
335+ isVal <- inst $ ICmp IPred.EQ flag (ConstantOperand (C.Int 8 (-1))) []
336+ conBBN <- getName "constructor"
337+ valBBN <- getName "value"
338+ originBlock <- gets currentBlockName
339+ terminate $ CondBr isVal valBBN conBBN []
340+ newBlock conBBN
341+ result <- cgCase val alts
342+ case result of
343+ Nothing -> do
344+ terminate $ Unreachable []
345+ newBlock valBBN
346+ return $ Just val
347+ Just r -> do
348+ terminate $ Br valBBN []
349+ newBlock valBBN
350+ Just <$> (inst $ Phi (PointerType valueType (AddrSpace 0))
351+ [(val, originBlock), (r, conBBN)] [])
352+cgExpr (SProj conVar idx) = do
353+ val <- var conVar
354+ case val of
355+ Nothing -> return Nothing
356+ Just v ->
357+ do ptr <- inst $ GetElementPtr True v
358+ [ ConstantOperand (C.Int 32 0)
359+ , ConstantOperand (C.Int 32 1)
360+ , ConstantOperand (C.Int 32 (fromIntegral idx))
361+ ] []
362+ Just <$> (inst $ Load False ptr Nothing 0 [])
363+cgExpr (SConst c) = Just <$> cgConst c
364+cgExpr (SForeign LANG_C rty fname args) = do
365+ func <- ensureCDecl fname rty (map fst args)
366+ argVals <- forM args $ \(fty, v) -> do
367+ v' <- var v
368+ case v' of
369+ Just val -> return $ Just (fty, val)
370+ Nothing -> return Nothing
371+ case sequence argVals of
372+ Nothing -> return Nothing
373+ Just argVals' -> do
374+ argUVals <- mapM (uncurry unbox) argVals'
375+ result <- inst $ Call { isTailCall = False
376+ , callingConvention = CC.C
377+ , returnAttributes = []
378+ , function = Right func
379+ , arguments = map (\v -> (v, [])) argUVals
380+ , functionAttributes = []
381+ , metadata = []
382+ }
383+ Just <$> box rty result
384+cgExpr (SOp fn args) = do
385+ argVals <- mapM var args
386+ case sequence argVals of
387+ Just ops -> Just <$> cgOp fn ops
388+ Nothing -> return Nothing
389+cgExpr SNothing = return . Just . ConstantOperand $ nullValue
390+cgExpr (SError msg) = do -- TODO: Print message
391+ inst' $ Call { isTailCall = True
392+ , callingConvention = CC.C
393+ , returnAttributes = []
394+ , function = Right . ConstantOperand . C.GlobalReference . Name $ "llvm.trap"
395+ , arguments = []
396+ , functionAttributes = [A.NoReturn]
397+ , metadata = []
398+ }
399+ return Nothing
400+
401+cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand)
402+cgCase val alts =
403+ case find isConstCase alts of
404+ Just (SConstCase (TT.BI _) _) -> cgChainCase val defExp constAlts
405+ Just (SConstCase (TT.Str _) _) -> cgChainCase val defExp constAlts
406+ Just (SConstCase _ _) -> cgPrimCase val defExp constAlts
407+ Nothing -> cgConCase val defExp conAlts
408+ where
409+ defExp = getDefExp =<< find isDefCase alts
410+ constAlts = filter isConstCase alts
411+ conAlts = filter isConCase alts
412+
413+ isConstCase (SConstCase _ _) = True
414+ isConstCase _ = False
415+
416+ isConCase (SConCase _ _ _ _ _) = True
417+ isConCase _ = False
418+
419+ isDefCase (SDefaultCase _) = True
420+ isDefCase _ = False
421+
422+ getDefExp (SDefaultCase e) = Just e
423+ getDefExp _ = Nothing
424+
425+cgPrimCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
426+cgPrimCase caseValPtr defExp alts = do
427+ let caseTy = case head alts of
428+ SConstCase (TT.I _) _ -> IntegerType 32
429+ SConstCase (TT.B8 _) _ -> IntegerType 8
430+ SConstCase (TT.B16 _) _ -> IntegerType 16
431+ SConstCase (TT.B32 _) _ -> IntegerType 32
432+ SConstCase (TT.B64 _) _ -> IntegerType 64
433+ SConstCase (TT.Fl _) _ -> FloatingPointType 64 IEEE
434+ SConstCase (TT.Ch _) _ -> IntegerType 32
435+ realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) []
436+ valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
437+ caseVal <- inst $ Load False valPtr Nothing 0 []
438+ defBlockName <- getName "default"
439+ exitBlockName <- getName "caseExit"
440+ namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
441+ terminate $ Switch caseVal defBlockName (map (\(n, SConstCase c _) -> (cgConst' c, n)) namedAlts) []
442+ initEnv <- gets lexenv
443+ defResult <- cgDefaultAlt exitBlockName defBlockName defExp
444+ results <- forM namedAlts $ \(name, SConstCase _ exp) -> cgAlt initEnv exitBlockName name Nothing exp
445+ finishCase initEnv exitBlockName (defResult:results)
446+
447+cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
448+cgConCase con defExp alts = do
449+ tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
450+ tag <- inst $ Load False tagPtr Nothing 0 []
451+ defBlockName <- getName "default"
452+ exitBlockName <- getName "caseExit"
453+ namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
454+ terminate $ Switch tag defBlockName (map (\(n, SConCase _ tag _ _ _) ->
455+ (C.Int 32 (fromIntegral tag), n)) namedAlts) []
456+ initEnv <- gets lexenv
457+ defResult <- cgDefaultAlt exitBlockName defBlockName defExp
458+ results <- forM namedAlts $ \(name, SConCase _ _ _ argns exp) ->
459+ cgAlt initEnv exitBlockName name (Just (con, (map show argns))) exp
460+ finishCase initEnv exitBlockName (defResult:results)
461+
462+cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
463+cgChainCase caseValPtr defExp alts = do
464+ (caseTy, comparator, caseVal) <-
465+ case head alts of
466+ SConstCase (TT.BI _) _ -> do
467+ realPtr <- inst $ BitCast caseValPtr (PointerType (primTy mpzTy) (AddrSpace 0)) []
468+ valPtr <- inst $ GetElementPtr True realPtr [ ConstantOperand (C.Int 32 0)
469+ , ConstantOperand (C.Int 32 1)] []
470+ return (mpzTy, "__gmpz_cmp", valPtr)
471+ SConstCase (TT.Str _) _ -> do
472+ let caseTy = PointerType (IntegerType 8) (AddrSpace 0)
473+ realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) []
474+ valPtr <- inst $ GetElementPtr True realPtr [ ConstantOperand (C.Int 32 0)
475+ , ConstantOperand (C.Int 32 1)] []
476+ strPtr <- inst $ Load False valPtr Nothing 0 []
477+ return (caseTy, "strcmp", strPtr)
478+ defBlockName <- getName "default"
479+ exitBlockName <- getName "caseExit"
480+ namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
481+ initEnv <- gets lexenv
482+ results <- forM namedAlts $ \(name, SConstCase c e) ->
483+ do const <- cgConst c
484+ cmp <- inst $ simpleCall comparator [const, caseVal]
485+ cmpResult <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
486+ elseName <- getName "else"
487+ terminate $ CondBr cmpResult name elseName []
488+ result <- cgAlt initEnv exitBlockName name Nothing e
489+ newBlock elseName
490+ return result
491+ modify $ \s -> s { lexenv = initEnv }
492+ defaultVal <- cgExpr (fromMaybe (SError "Inexhaustive case failure") defExp)
493+ defaultBlock <- gets currentBlockName
494+ defaultEnv <- gets lexenv
495+ defResult <- case defaultVal of
496+ Just v -> do
497+ terminate $ Br exitBlockName []
498+ return $ Just (v, defaultBlock, defaultEnv)
499+ Nothing -> do
500+ terminate $ Unreachable []
501+ return Nothing
502+ finishCase initEnv exitBlockName (defResult:results)
503+
504+finishCase :: Env -> Name -> [Maybe (Operand, Name, Env)] -> Codegen (Maybe Operand)
505+finishCase initEnv exitBlockName results = do
506+ let definedResults = mapMaybe id results
507+ case definedResults of
508+ [] -> do modify $ \s -> s { lexenv = initEnv }
509+ return Nothing
510+ xs -> do
511+ newBlock exitBlockName
512+ mergeEnvs $ map (\(_, altBlock, altEnv) -> (altBlock, altEnv)) xs
513+ Just <$> (inst $ Phi (PointerType valueType (AddrSpace 0))
514+ (map (\(altVal, altBlock, _) -> (altVal, altBlock)) xs) [])
515+
516+
517+cgDefaultAlt :: Name -> Name -> Maybe SExp -> Codegen (Maybe (Operand, Name, Env))
518+cgDefaultAlt exitName name exp = do
519+ newBlock name
520+ val <- cgExpr (fromMaybe (SError "Inexhaustive case failure") exp)
521+ env <- gets lexenv
522+ block <- gets currentBlockName
523+ case val of
524+ Just v ->
525+ do terminate $ Br exitName []
526+ return $ Just (v, block, env)
527+ Nothing ->
528+ do terminate $ Unreachable []
529+ return Nothing
530+
531+cgAlt :: Env -> Name -> Name -> Maybe (Operand, [String]) -> SExp
532+ -> Codegen (Maybe (Operand, Name, Env))
533+cgAlt initEnv exitBlockName name destr exp = do
534+ modify $ \s -> s { lexenv = initEnv }
535+ newBlock name
536+ locals <- case destr of
537+ Nothing -> return []
538+ Just (con, argns) ->
539+ forM (zip argns [0..]) $ \(argName, i) ->
540+ do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
541+ , ConstantOperand (C.Int 32 1)
542+ , ConstantOperand (C.Int 32 i)] []
543+ Just <$> (ninst argName $ Load False ptr Nothing 0 [])
544+ altVal <- binds locals $ cgExpr exp
545+ altEnv <- gets lexenv
546+ altBlock <- gets currentBlockName
547+ case altVal of
548+ Just v -> do
549+ terminate $ Br exitBlockName []
550+ return $ Just (v, altBlock, altEnv)
551+ Nothing -> do
552+ terminate $ Unreachable []
553+ return Nothing
554+
555+mergeEnvs :: [(Name, Env)] -> Codegen ()
556+mergeEnvs es = do
557+ let vars = transpose
558+ . map (\(block, env) -> map (\x -> (x, block)) env)
559+ $ es
560+ env <- forM vars $ \var ->
561+ case var of
562+ [] -> ierror "mergeEnvs: impossible"
563+ [(v, _)] -> return v
564+ vs@((v, _):_)
565+ | all (== v) (map fst vs) -> return v
566+ | otherwise ->
567+ let valid = map (\(a, b) -> (fromJust a, b)) . filter (isJust . fst) $ vs in
568+ Just <$> (inst $ Phi (PointerType valueType (AddrSpace 0)) valid [])
569+ modify $ \s -> s { lexenv = env }
570+
571+nameAlt :: Name -> SAlt -> Codegen Name
572+nameAlt d (SDefaultCase _) = return d
573+nameAlt _ (SConCase _ _ name _ _) = getName (show name)
574+nameAlt _ (SConstCase const _) = getName (show const)
575+
576+box :: FType -> Operand -> Codegen Operand
577+box FUnit _ = return $ ConstantOperand nullValue
578+box fty fval = do
579+ val <- alloc (primTy (ftyToTy fty))
580+ tagptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
581+ valptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
582+ inst' $ Store False tagptr (ConstantOperand (C.Int 8 (-1))) Nothing 0 []
583+ inst' $ Store False valptr fval Nothing 0 []
584+ inst $ BitCast val (PointerType valueType (AddrSpace 0)) []
585+
586+unbox :: FType -> Operand -> Codegen Operand
587+unbox FUnit x = return x
588+unbox fty bval = do
589+ val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) []
590+ fvalptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
591+ inst $ Load False fvalptr Nothing 0 []
592+
593+cgConst' :: TT.Const -> C.Constant
594+cgConst' (TT.I i) = C.Int 32 (fromIntegral i)
595+cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i)
596+cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i)
597+cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i)
598+cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i)
599+cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0])
600+cgConst' (TT.Fl f) = C.Float (F.Double f)
601+cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c
602+cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) s ++ [C.Int 8 0])
603+cgConst' x = ierror $ "Unsupported constant: " ++ show x
604+
605+cgConst :: TT.Const -> Codegen Operand
606+cgConst c@(TT.I _) = box (FInt ITNative) (ConstantOperand $ cgConst' c)
607+cgConst c@(TT.B8 _) = box (FInt IT8) (ConstantOperand $ cgConst' c)
608+cgConst c@(TT.B16 _) = box (FInt IT16) (ConstantOperand $ cgConst' c)
609+cgConst c@(TT.B32 _) = box (FInt IT32) (ConstantOperand $ cgConst' c)
610+cgConst c@(TT.B64 _) = box (FInt IT64) (ConstantOperand $ cgConst' c)
611+cgConst c@(TT.Fl _) = box FDouble (ConstantOperand $ cgConst' c)
612+cgConst c@(TT.Ch _) = box FChar (ConstantOperand $ cgConst' c)
613+cgConst c@(TT.Str s) = do
614+ str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)
615+ box FString (ConstantOperand $ C.GetElementPtr True str [C.Int 32 0, C.Int 32 0])
616+cgConst c@(TT.BI i) = do
617+ str <- addGlobal' (ArrayType (1 + fromInteger (numDigits 10 i)) (IntegerType 8)) (cgConst' c)
618+ mpz <- alloc mpzTy
619+ inst $ simpleCall "__gmpz_init_set_str" [mpz, ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0
620+ , C.Int 32 0]]
621+ box (FInt ITBig) mpz
622+cgConst x = return $ ConstantOperand nullValue
623+
624+numDigits :: Integer -> Integer -> Integer
625+numDigits b n = 1 + fst (ilog b n) where
626+ ilog b n
627+ | n < b = (0, n)
628+ | otherwise = let (e, r) = ilog (b*b) n
629+ in if r < b then (2*e, r) else (2*e+1, r `div` b)
630+
631+addGlobal :: Global -> Codegen ()
632+addGlobal def = tell ([], [], [GlobalDefinition def])
633+
634+addGlobal' :: Type -> C.Constant -> Codegen C.Constant
635+addGlobal' ty val = do
636+ name <- getGlobalUnName
637+ addGlobal $ globalVariableDefaults
638+ { G.name = name
639+ , G.linkage = L.Internal
640+ , G.hasUnnamedAddr = True
641+ , G.isConstant = True
642+ , G.type' = ty
643+ , G.initializer = Just val
644+ }
645+ return . C.GlobalReference $ name
646+
647+
648+ensureCDecl :: String -> FType -> [FType] -> Codegen Operand
649+ensureCDecl name rty argtys = do
650+ syms <- gets foreignSyms
651+ unless (S.member name syms) $
652+ do addGlobal (ffunDecl name rty argtys)
653+ modify $ \s -> s { foreignSyms = S.insert name (foreignSyms s) }
654+ return $ ConstantOperand (C.GlobalReference (Name name))
655+
656+ffunDecl :: String -> FType -> [FType] -> Global
657+ffunDecl name rty argtys =
658+ functionDefaults
659+ { G.returnType = ftyToTy rty
660+ , G.name = Name name
661+ , G.parameters = (flip map argtys $ \fty ->
662+ Parameter (ftyToTy fty) (UnName 0) []
663+ , False)
664+ }
665+
666+ftyToTy :: FType -> Type
667+ftyToTy (FInt ITNative) = IntegerType 32
668+ftyToTy (FInt ITBig) = PointerType mpzTy (AddrSpace 0)
669+ftyToTy (FInt ty) = IntegerType (fromIntegral (intTyWidth ty))
670+ftyToTy FChar = IntegerType 32
671+ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)
672+ftyToTy FUnit = VoidType
673+ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)
674+ftyToTy FDouble = FloatingPointType 64 IEEE
675+ftyToTy FAny = valueType
676+
677+cgOp :: PrimFn -> [Operand] -> Codegen Operand
678+cgOp (LPlus ITBig) [x,y] = mpzBin "__gmpz_add" x y
679+cgOp (LMinus ITBig) [x,y] = mpzBin "__gmpz_sub" x y
680+cgOp (LTimes ITBig) [x,y] = mpzBin "__gmpz_mul" x y
681+cgOp (LSDiv ITBig) [x,y] = mpzBin "__gmpz_fdiv_q" x y
682+cgOp (LSRem ITBig) [x,y] = mpzBin "__gmpz_fdiv_r" x y
683+cgOp (LAnd ITBig) [x,y] = mpzBin "__gmpz_and" x y
684+cgOp (LOr ITBig) [x,y] = mpzBin "__gmpz_ior" x y
685+cgOp (LXOr ITBig) [x,y] = mpzBin "__gmpz_xor" x y
686+
687+cgOp (LPlus ity) [x,y] = ibin ity x y (Add False False)
688+cgOp (LMinus ity) [x,y] = ibin ity x y (Sub False False)
689+cgOp (LTimes ity) [x,y] = ibin ity x y (Mul False False)
690+cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv True)
691+cgOp (LURem ity) [x,y] = ibin ity x y URem
692+cgOp (LSDiv ity) [x,y] = ibin ity x y (SDiv True)
693+cgOp (LSRem ity) [x,y] = ibin ity x y SRem
694+cgOp (LAnd ity) [x,y] = ibin ity x y And
695+cgOp (LOr ity) [x,y] = ibin ity x y Or
696+cgOp (LXOr ity) [x,y] = ibin ity x y Xor
697+
698+cgOp (LIntStr ITBig) [x] = do
699+ x' <- unbox (FInt ITBig) x
700+ ustr <- inst $ simpleCall "__gmpz_get_str"
701+ [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))
702+ , ConstantOperand (C.Int 32 10), x']
703+ box FString ustr
704+cgOp (LIntStr ity) [x] = do
705+ x' <- unbox (FInt ity) x
706+ x'' <- if ity == ITNative || intTyWidth ity < 64
707+ then inst $ SExt x' (IntegerType 64) []
708+ else return x'
709+ box FString =<< inst (rtsCall "intStr" [x''])
710+
711+cgOp LStrConcat [x,y] = cgStrCat x y
712+cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("
713+ ++ (intersperse ',' $ take (length args) ['a'..]) ++ ")"
714+
715+cgStrCat :: Operand -> Operand -> Codegen Operand
716+cgStrCat x y = do
717+ x' <- unbox FString x
718+ y' <- unbox FString y
719+ xlen <- inst $ simpleCall "strlen" [x']
720+ ylen <- inst $ simpleCall "strlen" [y']
721+ zlen <- inst $ Add False True xlen ylen []
722+ ws <- fromIntegral <$> wordSize
723+ total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
724+ mem <- allocAtomic total
725+ inst $ simpleCall "memcpy" [mem, x', xlen]
726+ i <- inst $ PtrToInt mem (IntegerType ws) []
727+ offi <- inst $ Add False True i xlen []
728+ offp <- inst $ IntToPtr offi (PointerType (IntegerType 8) (AddrSpace 0)) []
729+ inst $ simpleCall "memcpy" [offp, y', ylen]
730+ j <- inst $ PtrToInt offp (IntegerType ws) []
731+ offj <- inst $ Add False True j ylen []
732+ end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) []
733+ inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 []
734+ box FString mem
735+
736+ibin :: IntTy -> Operand -> Operand
737+ -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
738+ibin ity x y instCon = do
739+ nx <- unbox (FInt ity) x
740+ ny <- unbox (FInt ity) y
741+ nr <- inst $ instCon nx ny []
742+ box (FInt ity) nr
743+
744+mpzBin :: String -> Operand -> Operand -> Codegen Operand
745+mpzBin name x y = do
746+ nx <- unbox (FInt ITBig) x
747+ ny <- unbox (FInt ITBig) y
748+ nz <- alloc mpzTy
749+ inst' $ simpleCall "__gmpz_init" [nz]
750+ inst' $ simpleCall name [nz, nx, ny]
751+ box (FInt ITBig) nz
752+
753+simpleCall :: String -> [Operand] -> Instruction
754+simpleCall name args =
755+ Call { isTailCall = False
756+ , callingConvention = CC.C
757+ , returnAttributes = []
758+ , function = Right . ConstantOperand . C.GlobalReference . Name $ name
759+ , arguments = map (\x -> (x, [])) args
760+ , functionAttributes = []
761+ , metadata = []
762+ }
763+
764+rtsCall :: String -> [Operand] -> Instruction
765+rtsCall name args =
766+ Call { isTailCall = False
767+ , callingConvention = CC.Fast
768+ , returnAttributes = []
769+ , function = Right . ConstantOperand . C.GlobalReference . Name $ "__idris_" ++ name
770+ , arguments = map (\x -> (x, [])) args
771+ , functionAttributes = []
772+ , metadata = []
773+ }