update hetmet submodule pointer
[ghc-hetmet.git] / compiler / llvmGen / LlvmCodeGen / CodeGen.hs
1 -- ----------------------------------------------------------------------------
2 -- | Handle conversion of CmmProc to LLVM code.
3 --
4
5 module LlvmCodeGen.CodeGen ( genLlvmProc ) where
6
7 #include "HsVersions.h"
8
9 import Llvm
10 import LlvmCodeGen.Base
11 import LlvmCodeGen.Regs
12
13 import BlockId
14 import CgUtils ( activeStgRegs, callerSaves )
15 import CLabel
16 import OldCmm
17 import qualified OldPprCmm as PprCmm
18 import OrdList
19
20 import BasicTypes
21 import FastString
22 import ForeignCall
23 import Outputable hiding ( panic, pprPanic )
24 import qualified Outputable
25 import UniqSupply
26 import Unique
27 import Util
28
29 import Data.List ( partition )
30 import Control.Monad ( liftM )
31
32 type LlvmStatements = OrdList LlvmStatement
33
34
35 -- -----------------------------------------------------------------------------
36 -- | Top-level of the LLVM proc Code generator
37 --
38 genLlvmProc :: LlvmEnv -> RawCmmTop -> UniqSM (LlvmEnv, [LlvmCmmTop])
39 genLlvmProc env (CmmData _ _)
40   = return (env, [])
41
42 genLlvmProc env (CmmProc _ _ (ListGraph []))
43   = return (env, [])
44
45 genLlvmProc env (CmmProc info lbl (ListGraph blocks))
46   = do
47         (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], [])
48
49         let proc    = CmmProc info lbl (ListGraph lmblocks)
50         let tops    = lmdata ++ [proc]
51
52         return (env', tops)
53
54
55 -- -----------------------------------------------------------------------------
56 -- * Block code generation
57 --
58
59 -- | Generate code for a list of blocks that make up a complete procedure.
60 basicBlocksCodeGen :: LlvmEnv
61                    -> [CmmBasicBlock]
62                    -> ( [LlvmBasicBlock] , [LlvmCmmTop] )
63                    -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmTop] )
64 basicBlocksCodeGen env ([]) (blocks, tops)
65   = do let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
66        let allocs' = concat allocs
67        let ((BasicBlock id fstmts):rblks) = blocks'
68        fplog <- funPrologue
69        let fblocks = (BasicBlock id (fplog ++  allocs' ++ fstmts)):rblks
70        return (env, fblocks, tops)
71
72 basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
73   = do (env', lb, lt) <- basicBlockCodeGen env block
74        let lblocks = lblocks' ++ lb
75        let ltops   = ltops' ++ lt
76        basicBlocksCodeGen env' blocks (lblocks, ltops)
77
78
79 -- | Allocations need to be extracted so they can be moved to the entry
80 -- of a function to make sure they dominate all possible paths in the CFG.
81 dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement])
82 dominateAllocs (BasicBlock id stmts)
83   = let (allocs, stmts') = partition isAlloc stmts
84         isAlloc (Assignment _ (Alloca _ _)) = True
85         isAlloc _other                      = False
86     in (BasicBlock id stmts', allocs)
87
88
89 -- | Generate code for one block
90 basicBlockCodeGen ::  LlvmEnv
91                   -> CmmBasicBlock
92                   -> UniqSM ( LlvmEnv, [LlvmBasicBlock], [LlvmCmmTop] )
93 basicBlockCodeGen env (BasicBlock id stmts)
94   = do (env', instrs, top) <- stmtsToInstrs env stmts (nilOL, [])
95        return (env', [BasicBlock id (fromOL instrs)], top)
96
97
98 -- -----------------------------------------------------------------------------
99 -- * CmmStmt code generation
100 --
101
102 -- A statement conversion return data.
103 --   * LlvmEnv: The new environment
104 --   * LlvmStatements: The compiled LLVM statements.
105 --   * LlvmCmmTop: Any global data needed.
106 type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmTop])
107
108
109 -- | Convert a list of CmmStmt's to LlvmStatement's
110 stmtsToInstrs :: LlvmEnv -> [CmmStmt] -> (LlvmStatements, [LlvmCmmTop])
111               -> UniqSM StmtData
112 stmtsToInstrs env [] (llvm, top)
113   = return (env, llvm, top)
114
115 stmtsToInstrs env (stmt : stmts) (llvm, top)
116    = do (env', instrs, tops) <- stmtToInstrs env stmt
117         stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops)
118
119
120 -- | Convert a CmmStmt to a list of LlvmStatement's
121 stmtToInstrs :: LlvmEnv -> CmmStmt
122              -> UniqSM StmtData
123 stmtToInstrs env stmt = case stmt of
124
125     CmmNop               -> return (env, nilOL, [])
126     CmmComment _         -> return (env, nilOL, []) -- nuke comments
127
128     CmmAssign reg src    -> genAssign env reg src
129     CmmStore addr src    -> genStore env addr src
130
131     CmmBranch id         -> genBranch env id
132     CmmCondBranch arg id -> genCondBranch env arg id
133     CmmSwitch arg ids    -> genSwitch env arg ids
134
135     -- Foreign Call
136     CmmCall target res args _ ret
137         -> genCall env target res args ret
138
139     -- Tail call
140     CmmJump arg _ -> genJump env arg
141
142     -- CPS, only tail calls, no return's
143     -- Actually, there are a few return statements that occur because of hand
144     -- written Cmm code.
145     CmmReturn _
146         -> return (env, unitOL $ Return Nothing, [])
147
148
149 -- | Foreign Calls
150 genCall :: LlvmEnv -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals
151               -> CmmReturnInfo -> UniqSM StmtData
152
153 -- Write barrier needs to be handled specially as it is implemented as an LLVM
154 -- intrinsic function.
155 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
156 genCall env (CmmPrim MO_WriteBarrier) _ _ _ = return (env, nilOL, [])
157
158 #else
159 genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do
160     let fname = fsLit "llvm.memory.barrier"
161     let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid
162                     FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign
163     let fty = LMFunction funSig
164
165     let fv   = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False
166     let tops = case funLookup fname env of
167                     Just _  -> []
168                     Nothing -> [CmmData Data [([],[fty])]]
169
170     let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue]
171     let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs
172     let env' = funInsert fname fty env
173
174     return (env', unitOL s1, tops)
175
176     where
177         lmTrue :: LlvmVar
178         lmTrue  = LMLitVar $ LMIntLit (-1) i1
179 #endif
180
181 -- Handle all other foreign calls and prim ops.
182 genCall env target res args ret = do
183
184     -- parameter types
185     let arg_type (CmmHinted _ AddrHint) = i8Ptr
186         -- cast pointers to i8*. Llvm equivalent of void*
187         arg_type (CmmHinted expr _    ) = cmmToLlvmType $ cmmExprType expr
188
189     -- ret type
190     let ret_type ([]) = LMVoid
191         ret_type ([CmmHinted _ AddrHint]) = i8Ptr
192         ret_type ([CmmHinted reg _])      = cmmToLlvmType $ localRegType reg
193         ret_type t = panic $ "genCall: Too many return values! Can only handle"
194                         ++ " 0 or 1, given " ++ show (length t) ++ "."
195
196     -- extract Cmm call convention
197     let cconv = case target of
198             CmmCallee _ conv -> conv
199             CmmPrim   _      -> PrimCallConv
200
201     -- translate to LLVM call convention
202     let lmconv = case cconv of
203 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
204             StdCallConv  -> CC_X86_Stdcc
205 #else
206             StdCallConv  -> CC_Ccc
207 #endif
208             CCallConv    -> CC_Ccc
209             PrimCallConv -> CC_Ccc
210             CmmCallConv  -> panic "CmmCallConv not supported here!"
211
212     {-
213         Some of the possibilities here are a worry with the use of a custom
214         calling convention for passing STG args. In practice the more
215         dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.
216
217         The native code generator only handles StdCall and CCallConv.
218     -}
219
220     -- call attributes
221     let fnAttrs | ret == CmmNeverReturns = NoReturn : llvmStdFunAttrs
222                 | otherwise              = llvmStdFunAttrs
223
224     -- fun type
225     let ccTy  = StdCall -- tail calls should be done through CmmJump
226     let retTy = ret_type res
227     let argTy = tysToParams $ map arg_type args
228     let funTy name = LMFunction $ LlvmFunctionDecl name ExternallyVisible
229                         lmconv retTy FixedArgs argTy llvmFunAlign
230
231     -- get parameter values
232     (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
233
234     -- get the return register
235     let ret_reg ([CmmHinted reg hint]) = (reg, hint)
236         ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
237                         ++ " 1, given " ++ show (length t) ++ "."
238
239     -- deal with call types
240     let getFunPtr :: CmmCallTarget -> UniqSM ExprData
241         getFunPtr targ = case targ of
242             CmmCallee (CmmLit (CmmLabel lbl)) _ -> do
243                 let name = strCLabel_llvm lbl
244                 case funLookup name env1 of
245                     Just ty'@(LMFunction sig) -> do
246                         -- Function in module in right form
247                         let fun = LMGlobalVar name ty' (funcLinkage sig)
248                                         Nothing Nothing False
249                         return (env1, fun, nilOL, [])
250
251                     Just ty' -> do
252                         -- label in module but not function pointer, convert
253                         let fty@(LMFunction sig) = funTy name
254                         let fun = LMGlobalVar name (pLift ty') (funcLinkage sig)
255                                         Nothing Nothing False
256                         (v1, s1) <- doExpr (pLift fty)
257                                         $ Cast LM_Bitcast fun (pLift fty)
258                         return  (env1, v1, unitOL s1, [])
259
260                     Nothing -> do
261                         -- label not in module, create external reference
262                         let fty@(LMFunction sig) = funTy name
263                         let fun = LMGlobalVar name fty (funcLinkage sig)
264                                         Nothing Nothing False
265                         let top = CmmData Data [([],[fty])]
266                         let env' = funInsert name fty env1
267                         return (env', fun, nilOL, [top])
268
269             CmmCallee expr _ -> do
270                 (env', v1, stmts, top) <- exprToVar env1 expr
271                 let fty = funTy $ fsLit "dynamic"
272                 let cast = case getVarType v1 of
273                      ty | isPointer ty -> LM_Bitcast
274                      ty | isInt ty     -> LM_Inttoptr
275
276                      ty -> panic $ "genCall: Expr is of bad type for function"
277                                 ++ " call! (" ++ show (ty) ++ ")"
278
279                 (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
280                 return (env', v2, stmts `snocOL` s1, top)
281
282             CmmPrim mop -> do
283                 let name = cmmPrimOpFunctions mop
284                 let lbl  = mkForeignLabel name Nothing
285                                     ForeignLabelInExternalPackage IsFunction
286                 getFunPtr $ CmmCallee (CmmLit (CmmLabel lbl)) CCallConv
287
288     (env2, fptr, stmts2, top2) <- getFunPtr target
289
290     let retStmt | ccTy == TailCall       = unitOL $ Return Nothing
291                 | ret == CmmNeverReturns = unitOL $ Unreachable
292                 | otherwise              = nilOL
293
294     {- In LLVM we pass the STG registers around everywhere in function calls.
295        So this means LLVM considers them live across the entire function, when
296        in reality they usually aren't. For Caller save registers across C calls
297        the saving and restoring of them is done by the Cmm code generator,
298        using Cmm local vars. So to stop LLVM saving them as well (and saving
299        all of them since it thinks they're always live, we trash them just
300        before the call by assigning the 'undef' value to them. The ones we
301        need are restored from the Cmm local var and the ones we don't need
302        are fine to be trashed.
303     -}
304     let trashStmts = concatOL $ map trashReg activeStgRegs
305             where trashReg r =
306                     let reg   = lmGlobalRegVar r
307                         ty    = (pLower . getVarType) reg
308                         trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
309                     in case callerSaves r of
310                               True  -> trash
311                               False -> nilOL
312
313     let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts
314
315     -- make the actual call
316     case retTy of
317         LMVoid -> do
318             let s1 = Expr $ Call ccTy fptr argVars fnAttrs
319             let allStmts = stmts `snocOL` s1 `appOL` retStmt
320             return (env2, allStmts, top1 ++ top2)
321
322         _ -> do
323             (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
324             let (creg, _) = ret_reg res
325             let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
326             let allStmts = stmts `snocOL` s1 `appOL` stmts3
327             if retTy == pLower (getVarType vreg)
328                 then do
329                     let s2 = Store v1 vreg
330                     return (env3, allStmts `snocOL` s2 `appOL` retStmt,
331                                 top1 ++ top2 ++ top3)
332                 else do
333                     let ty = pLower $ getVarType vreg
334                     let op = case ty of
335                             vt | isPointer vt -> LM_Bitcast
336                                | isInt     vt -> LM_Ptrtoint
337                                | otherwise    ->
338                                    panic $ "genCall: CmmReg bad match for"
339                                         ++ " returned type!"
340
341                     (v2, s2) <- doExpr ty $ Cast op v1 ty
342                     let s3 = Store v2 vreg
343                     return (env3, allStmts `snocOL` s2 `snocOL` s3
344                                 `appOL` retStmt, top1 ++ top2 ++ top3)
345
346
347 -- | Conversion of call arguments.
348 arg_vars :: LlvmEnv
349          -> HintedCmmActuals
350          -> ([LlvmVar], LlvmStatements, [LlvmCmmTop])
351          -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmTop])
352
353 arg_vars env [] (vars, stmts, tops)
354   = return (env, vars, stmts, tops)
355
356 arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops)
357   = do (env', v1, stmts', top') <- exprToVar env e
358        let op = case getVarType v1 of
359                ty | isPointer ty -> LM_Bitcast
360                ty | isInt ty     -> LM_Inttoptr
361
362                a  -> panic $ "genCall: Can't cast llvmType to i8*! ("
363                            ++ show a ++ ")"
364
365        (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
366        arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
367                                tops ++ top')
368
369 arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
370   = do (env', v1, stmts', top') <- exprToVar env e
371        arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
372
373 -- | Decide what C function to use to implement a CallishMachOp
374 cmmPrimOpFunctions :: CallishMachOp -> FastString
375 cmmPrimOpFunctions mop
376  = case mop of
377     MO_F32_Exp    -> fsLit "expf"
378     MO_F32_Log    -> fsLit "logf"
379     MO_F32_Sqrt   -> fsLit "llvm.sqrt.f32"
380     MO_F32_Pwr    -> fsLit "llvm.pow.f32"
381
382     MO_F32_Sin    -> fsLit "llvm.sin.f32"
383     MO_F32_Cos    -> fsLit "llvm.cos.f32"
384     MO_F32_Tan    -> fsLit "tanf"
385
386     MO_F32_Asin   -> fsLit "asinf"
387     MO_F32_Acos   -> fsLit "acosf"
388     MO_F32_Atan   -> fsLit "atanf"
389
390     MO_F32_Sinh   -> fsLit "sinhf"
391     MO_F32_Cosh   -> fsLit "coshf"
392     MO_F32_Tanh   -> fsLit "tanhf"
393
394     MO_F64_Exp    -> fsLit "exp"
395     MO_F64_Log    -> fsLit "log"
396     MO_F64_Sqrt   -> fsLit "llvm.sqrt.f64"
397     MO_F64_Pwr    -> fsLit "llvm.pow.f64"
398
399     MO_F64_Sin    -> fsLit "llvm.sin.f64"
400     MO_F64_Cos    -> fsLit "llvm.cos.f64"
401     MO_F64_Tan    -> fsLit "tan"
402
403     MO_F64_Asin   -> fsLit "asin"
404     MO_F64_Acos   -> fsLit "acos"
405     MO_F64_Atan   -> fsLit "atan"
406
407     MO_F64_Sinh   -> fsLit "sinh"
408     MO_F64_Cosh   -> fsLit "cosh"
409     MO_F64_Tanh   -> fsLit "tanh"
410
411     a -> panic $ "cmmPrimOpFunctions: Unknown callish op! (" ++ show a ++ ")"
412
413
414 -- | Tail function calls
415 genJump :: LlvmEnv -> CmmExpr -> UniqSM StmtData
416
417 -- Call to known function
418 genJump env (CmmLit (CmmLabel lbl)) = do
419     (env', vf, stmts, top) <- getHsFunc env lbl
420     (stgRegs, stgStmts) <- funEpilogue
421     let s1  = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
422     let s2  = Return Nothing
423     return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
424
425
426 -- Call to unknown function / address
427 genJump env expr = do
428     let fty = llvmFunTy
429     (env', vf, stmts, top) <- exprToVar env expr
430
431     let cast = case getVarType vf of
432          ty | isPointer ty -> LM_Bitcast
433          ty | isInt ty     -> LM_Inttoptr
434
435          ty -> panic $ "genJump: Expr is of bad type for function call! ("
436                      ++ show (ty) ++ ")"
437
438     (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
439     (stgRegs, stgStmts) <- funEpilogue
440     let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
441     let s3 = Return Nothing
442     return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
443             top)
444
445
446 -- | CmmAssign operation
447 --
448 -- We use stack allocated variables for CmmReg. The optimiser will replace
449 -- these with registers when possible.
450 genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData
451 genAssign env reg val = do
452     let (env1, vreg, stmts1, top1) = getCmmReg env reg
453     (env2, vval, stmts2, top2) <- exprToVar env1 val
454     let stmts = stmts1 `appOL` stmts2
455
456     let ty = (pLower . getVarType) vreg
457     case isPointer ty && getVarType vval == llvmWord of
458          -- Some registers are pointer types, so need to cast value to pointer
459          True -> do
460              (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
461              let s2 = Store v vreg
462              return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
463
464          False -> do
465              let s1 = Store vval vreg
466              return (env2, stmts `snocOL` s1, top1 ++ top2)
467
468
469 -- | CmmStore operation
470 genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
471
472 -- First we try to detect a few common cases and produce better code for
473 -- these then the default case. We are mostly trying to detect Cmm code
474 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
475 -- generic case that uses casts and pointer arithmetic
476 genStore env addr@(CmmReg (CmmGlobal r)) val
477     = genStore_fast env addr r 0 val
478
479 genStore env addr@(CmmRegOff (CmmGlobal r) n) val
480     = genStore_fast env addr r n val
481
482 genStore env addr@(CmmMachOp (MO_Add _) [
483                             (CmmReg (CmmGlobal r)),
484                             (CmmLit (CmmInt n _))])
485                 val
486     = genStore_fast env addr r (fromInteger n) val
487
488 genStore env addr@(CmmMachOp (MO_Sub _) [
489                             (CmmReg (CmmGlobal r)),
490                             (CmmLit (CmmInt n _))])
491                 val
492     = genStore_fast env addr r (negate $ fromInteger n) val
493
494 -- generic case
495 genStore env addr val = genStore_slow env addr val
496
497 -- | CmmStore operation
498 -- This is a special case for storing to a global register pointer
499 -- offset such as I32[Sp+8].
500 genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr
501               -> UniqSM StmtData
502 genStore_fast env addr r n val
503   = let gr  = lmGlobalRegVar r
504         grt = (pLower . getVarType) gr
505         (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt  `div` 8)
506     in case isPointer grt && rem == 0 of
507             True -> do
508                 (env', vval,  stmts, top) <- exprToVar env val
509                 (gv,  s1) <- doExpr grt $ Load gr
510                 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
511                 -- We might need a different pointer type, so check
512                 case pLower grt == getVarType vval of
513                      -- were fine
514                      True  -> do
515                          let s3 = Store vval ptr
516                          return (env',  stmts `snocOL` s1 `snocOL` s2
517                                  `snocOL` s3, top)
518
519                      -- cast to pointer type needed
520                      False -> do
521                          let ty = (pLift . getVarType) vval
522                          (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
523                          let s4 = Store vval ptr'
524                          return (env',  stmts `snocOL` s1 `snocOL` s2
525                                  `snocOL` s3 `snocOL` s4, top)
526
527             -- If its a bit type then we use the slow method since
528             -- we can't avoid casting anyway.
529             False -> genStore_slow env addr val
530
531
532 -- | CmmStore operation
533 -- Generic case. Uses casts and pointer arithmetic if needed.
534 genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
535 genStore_slow env addr val = do
536     (env1, vaddr, stmts1, top1) <- exprToVar env addr
537     (env2, vval,  stmts2, top2) <- exprToVar env1 val
538
539     let stmts = stmts1 `appOL` stmts2
540     case getVarType vaddr of
541         -- sometimes we need to cast an int to a pointer before storing
542         LMPointer ty@(LMPointer _) | getVarType vval == llvmWord -> do
543             (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
544             let s2 = Store v vaddr
545             return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
546
547         LMPointer _ -> do
548             let s1 = Store vval vaddr
549             return (env2, stmts `snocOL` s1, top1 ++ top2)
550
551         i@(LMInt _) | i == llvmWord -> do
552             let vty = pLift $ getVarType vval
553             (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
554             let s2 = Store vval vptr
555             return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
556
557         other ->
558             pprPanic "genStore: ptr not right type!"
559                     (PprCmm.pprExpr addr <+> text (
560                         "Size of Ptr: " ++ show llvmPtrBits ++
561                         ", Size of var: " ++ show (llvmWidthInBits other) ++
562                         ", Var: " ++ show vaddr))
563
564
565 -- | Unconditional branch
566 genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData
567 genBranch env id =
568     let label = blockIdToLlvm id
569     in return (env, unitOL $ Branch label, [])
570
571
572 -- | Conditional branch
573 genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> UniqSM StmtData
574 genCondBranch env cond idT = do
575     idF <- getUniqueUs
576     let labelT = blockIdToLlvm idT
577     let labelF = LMLocalVar idF LMLabel
578     (env', vc, stmts, top) <- exprToVarOpt env i1Option cond
579     if getVarType vc == i1
580         then do
581             let s1 = BranchIf vc labelT labelF
582             let s2 = MkLabel idF
583             return $ (env', stmts `snocOL` s1 `snocOL` s2, top)
584         else
585             panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"
586
587
588 -- | Switch branch
589 --
590 -- N.B. We remove Nothing's from the list of branches, as they are 'undefined'.
591 -- However, they may be defined one day, so we better document this behaviour.
592 genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData
593 genSwitch env cond maybe_ids = do
594     (env', vc, stmts, top) <- exprToVar env cond
595     let ty = getVarType vc
596
597     let pairs = [ (ix, id) | (ix,Just id) <- zip ([0..]::[Integer]) maybe_ids ]
598     let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs
599     -- out of range is undefied, so lets just branch to first label
600     let (_, defLbl) = head labels
601
602     let s1 = Switch vc defLbl labels
603     return $ (env', stmts `snocOL` s1, top)
604
605
606 -- -----------------------------------------------------------------------------
607 -- * CmmExpr code generation
608 --
609
610 -- | An expression conversion return data:
611 --   * LlvmEnv: The new enviornment
612 --   * LlvmVar: The var holding the result of the expression
613 --   * LlvmStatements: Any statements needed to evaluate the expression
614 --   * LlvmCmmTop: Any global data needed for this expression
615 type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmTop])
616
617 -- | Values which can be passed to 'exprToVar' to configure its
618 -- behaviour in certain circumstances.
619 data EOption = EOption {
620         -- | The expected LlvmType for the returned variable.
621         --
622         -- Currently just used for determining if a comparison should return
623         -- a boolean (i1) or a int (i32/i64).
624         eoExpectedType :: Maybe LlvmType
625   }
626
627 i1Option :: EOption
628 i1Option = EOption (Just i1)
629
630 wordOption :: EOption
631 wordOption = EOption (Just llvmWord)
632
633
634 -- | Convert a CmmExpr to a list of LlvmStatements with the result of the
635 -- expression being stored in the returned LlvmVar.
636 exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData
637 exprToVar env = exprToVarOpt env wordOption
638
639 exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData
640 exprToVarOpt env opt e = case e of
641
642     CmmLit lit
643         -> genLit env lit
644
645     CmmLoad e' ty
646         -> genLoad env e' ty
647
648     -- Cmmreg in expression is the value, so must load. If you want actual
649     -- reg pointer, call getCmmReg directly.
650     CmmReg r -> do
651         let (env', vreg, stmts, top) = getCmmReg env r
652         (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg
653         case (isPointer . getVarType) v1 of
654              True  -> do
655                  -- Cmm wants the value, so pointer types must be cast to ints
656                  (v2, s2) <- doExpr llvmWord $ Cast LM_Ptrtoint v1 llvmWord
657                  return (env', v2, stmts `snocOL` s1 `snocOL` s2, top)
658
659              False -> return (env', v1, stmts `snocOL` s1, top)
660
661     CmmMachOp op exprs
662         -> genMachOp env opt op exprs
663
664     CmmRegOff r i
665         -> exprToVar env $ expandCmmReg (r, i)
666
667     CmmStackSlot _ _
668         -> panic "exprToVar: CmmStackSlot not supported!"
669
670
671 -- | Handle CmmMachOp expressions
672 genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
673
674 -- Unary Machop
675 genMachOp env _ op [x] = case op of
676
677     MO_Not w ->
678         let all1 = mkIntLit (widthToLlvmInt w) (-1::Int)
679         in negate (widthToLlvmInt w) all1 LM_MO_Xor
680
681     MO_S_Neg w ->
682         let all0 = mkIntLit (widthToLlvmInt w) (0::Int)
683         in negate (widthToLlvmInt w) all0 LM_MO_Sub
684
685     MO_F_Neg w ->
686         let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
687         in negate (widthToLlvmFloat w) all0 LM_MO_FSub
688
689     MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
690     MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
691
692     MO_SS_Conv from to
693         -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
694
695     MO_UU_Conv from to
696         -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
697
698     MO_FF_Conv from to
699         -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
700
701     a -> panic $ "genMachOp: unmatched unary CmmMachOp! (" ++ show a ++ ")"
702
703     where
704         negate ty v2 negOp = do
705             (env', vx, stmts, top) <- exprToVar env x
706             (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
707             return (env', v1, stmts `snocOL` s1, top)
708
709         fiConv ty convOp = do
710             (env', vx, stmts, top) <- exprToVar env x
711             (v1, s1) <- doExpr ty $ Cast convOp vx ty
712             return (env', v1, stmts `snocOL` s1, top)
713
714         sameConv from ty reduce expand = do
715             x'@(env', vx, stmts, top) <- exprToVar env x
716             let sameConv' op = do
717                 (v1, s1) <- doExpr ty $ Cast op vx ty
718                 return (env', v1, stmts `snocOL` s1, top)
719             let toWidth = llvmWidthInBits ty
720             -- LLVM doesn't like trying to convert to same width, so
721             -- need to check for that as we do get Cmm code doing it.
722             case widthInBits from  of
723                  w | w < toWidth -> sameConv' expand
724                  w | w > toWidth -> sameConv' reduce
725                  _w              -> return x'
726
727 -- Handle GlobalRegs pointers
728 genMachOp env opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
729     = genMachOp_fast env opt o r (fromInteger n) e
730
731 genMachOp env opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
732     = genMachOp_fast env opt o r (negate . fromInteger $ n) e
733
734 -- Generic case
735 genMachOp env opt op e = genMachOp_slow env opt op e
736
737
738 -- | Handle CmmMachOp expressions
739 -- This is a specialised method that handles Global register manipulations like
740 -- 'Sp - 16', using the getelementptr instruction.
741 genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
742                -> UniqSM ExprData
743 genMachOp_fast env opt op r n e
744   = let gr  = lmGlobalRegVar r
745         grt = (pLower . getVarType) gr
746         (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt  `div` 8)
747     in case isPointer grt && rem == 0 of
748             True -> do
749                 (gv,  s1) <- doExpr grt $ Load gr
750                 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
751                 (var, s3) <- doExpr llvmWord $ Cast LM_Ptrtoint ptr llvmWord
752                 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, [])
753
754             False -> genMachOp_slow env opt op e
755
756
757 -- | Handle CmmMachOp expressions
758 -- This handles all the cases not handle by the specialised genMachOp_fast.
759 genMachOp_slow :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
760
761 -- Binary MachOp
762 genMachOp_slow env opt op [x, y] = case op of
763
764     MO_Eq _   -> genBinComp opt LM_CMP_Eq
765     MO_Ne _   -> genBinComp opt LM_CMP_Ne
766
767     MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
768     MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
769     MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
770     MO_S_Le _ -> genBinComp opt LM_CMP_Sle
771
772     MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
773     MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
774     MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
775     MO_U_Le _ -> genBinComp opt LM_CMP_Ule
776
777     MO_Add _ -> genBinMach LM_MO_Add
778     MO_Sub _ -> genBinMach LM_MO_Sub
779     MO_Mul _ -> genBinMach LM_MO_Mul
780
781     MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"
782
783     MO_S_MulMayOflo w -> isSMulOK w x y
784
785     MO_S_Quot _ -> genBinMach LM_MO_SDiv
786     MO_S_Rem  _ -> genBinMach LM_MO_SRem
787
788     MO_U_Quot _ -> genBinMach LM_MO_UDiv
789     MO_U_Rem  _ -> genBinMach LM_MO_URem
790
791     MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
792     MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
793     MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
794     MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
795     MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
796     MO_F_Le _ -> genBinComp opt LM_CMP_Fle
797
798     MO_F_Add  _ -> genBinMach LM_MO_FAdd
799     MO_F_Sub  _ -> genBinMach LM_MO_FSub
800     MO_F_Mul  _ -> genBinMach LM_MO_FMul
801     MO_F_Quot _ -> genBinMach LM_MO_FDiv
802
803     MO_And _   -> genBinMach LM_MO_And
804     MO_Or  _   -> genBinMach LM_MO_Or
805     MO_Xor _   -> genBinMach LM_MO_Xor
806     MO_Shl _   -> genBinMach LM_MO_Shl
807     MO_U_Shr _ -> genBinMach LM_MO_LShr
808     MO_S_Shr _ -> genBinMach LM_MO_AShr
809
810     a -> panic $ "genMachOp: unmatched binary CmmMachOp! (" ++ show a ++ ")"
811
812     where
813         binLlvmOp ty binOp = do
814             (env1, vx, stmts1, top1) <- exprToVar env x
815             (env2, vy, stmts2, top2) <- exprToVar env1 y
816             if getVarType vx == getVarType vy
817                 then do
818                     (v1, s1) <- doExpr (ty vx) $ binOp vx vy
819                     return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1,
820                             top1 ++ top2)
821
822                 else do
823                     -- XXX: Error. Continue anyway so we can debug the generated
824                     -- ll file.
825                     let cmmToStr = (lines . show . llvmSDoc . PprCmm.pprExpr)
826                     let dx = Comment $ map fsLit $ cmmToStr x
827                     let dy = Comment $ map fsLit $ cmmToStr y
828                     (v1, s1) <- doExpr (ty vx) $ binOp vx vy
829                     let allStmts = stmts1 `appOL` stmts2 `snocOL` dx
830                                     `snocOL` dy `snocOL` s1
831                     return (env2, v1, allStmts, top1 ++ top2)
832
833                     -- let o = case binOp vx vy of
834                     --         Compare op _ _ -> show op
835                     --         LlvmOp  op _ _ -> show op
836                     --         _              -> "unknown"
837                     -- panic $ "genMachOp: comparison between different types ("
838                     --         ++ o ++ " "++ show vx ++ ", " ++ show vy ++ ")"
839                     --         ++ "\ne1: " ++ (show.llvmSDoc.PprCmm.pprExpr $ x)
840                     --         ++ "\ne2: " ++ (show.llvmSDoc.PprCmm.pprExpr $ y)
841
842         -- | Need to use EOption here as Cmm expects word size results from
843         -- comparisons while LLVM return i1. Need to extend to llvmWord type
844         -- if expected
845         genBinComp opt cmp = do
846             ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) $ Compare cmp
847
848             if getVarType v1 == i1
849                 then
850                     case eoExpectedType opt of
851                          Nothing ->
852                              return ed
853
854                          Just t | t == i1 ->
855                                     return ed
856
857                                 | isInt t -> do
858                                     (v2, s1) <- doExpr t $ Cast LM_Zext v1 t
859                                     return (env', v2, stmts `snocOL` s1, top)
860
861                                 | otherwise ->
862                                     panic $ "genBinComp: Can't case i1 compare"
863                                         ++ "res to non int type " ++ show (t)
864                 else
865                     panic $ "genBinComp: Compare returned type other then i1! "
866                         ++ (show $ getVarType v1)
867
868         genBinMach op = binLlvmOp getVarType (LlvmOp op)
869
870         -- | Detect if overflow will occur in signed multiply of the two
871         -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
872         -- implementation. Its much longer due to type information/safety.
873         -- This should actually compile to only about 3 asm instructions.
874         isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData
875         isSMulOK _ x y = do
876             (env1, vx, stmts1, top1) <- exprToVar env x
877             (env2, vy, stmts2, top2) <- exprToVar env1 y
878
879             let word  = getVarType vx
880             let word2 = LMInt $ 2 * (llvmWidthInBits $ getVarType vx)
881             let shift = llvmWidthInBits word
882             let shift1 = toIWord (shift - 1)
883             let shift2 = toIWord shift
884
885             if isInt word
886                 then do
887                     (x1, s1)     <- doExpr word2 $ Cast LM_Sext vx word2
888                     (y1, s2)     <- doExpr word2 $ Cast LM_Sext vy word2
889                     (r1, s3)     <- doExpr word2 $ LlvmOp LM_MO_Mul x1 y1
890                     (rlow1, s4)  <- doExpr word $ Cast LM_Trunc r1 word
891                     (rlow2, s5)  <- doExpr word $ LlvmOp LM_MO_AShr rlow1 shift1
892                     (rhigh1, s6) <- doExpr word2 $ LlvmOp LM_MO_AShr r1 shift2
893                     (rhigh2, s7) <- doExpr word $ Cast LM_Trunc rhigh1 word
894                     (dst, s8)    <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2
895                     let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4
896                             `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8
897                     return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts,
898                         top1 ++ top2)
899
900                 else
901                     panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")"
902
903 -- More then two expression, invalid!
904 genMachOp_slow _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
905
906
907 -- | Handle CmmLoad expression.
908 genLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
909
910 -- First we try to detect a few common cases and produce better code for
911 -- these then the default case. We are mostly trying to detect Cmm code
912 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
913 -- generic case that uses casts and pointer arithmetic
914 genLoad env e@(CmmReg (CmmGlobal r)) ty
915     = genLoad_fast env e r 0 ty
916
917 genLoad env e@(CmmRegOff (CmmGlobal r) n) ty
918     = genLoad_fast env e r n ty
919
920 genLoad env e@(CmmMachOp (MO_Add _) [
921                             (CmmReg (CmmGlobal r)),
922                             (CmmLit (CmmInt n _))])
923                 ty
924     = genLoad_fast env e r (fromInteger n) ty
925
926 genLoad env e@(CmmMachOp (MO_Sub _) [
927                             (CmmReg (CmmGlobal r)),
928                             (CmmLit (CmmInt n _))])
929                 ty
930     = genLoad_fast env e r (negate $ fromInteger n) ty
931
932 -- generic case
933 genLoad env e ty = genLoad_slow env e ty
934
935 -- | Handle CmmLoad expression.
936 -- This is a special case for loading from a global register pointer
937 -- offset such as I32[Sp+8].
938 genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType
939                 -> UniqSM ExprData
940 genLoad_fast env e r n ty =
941     let gr  = lmGlobalRegVar r
942         grt = (pLower . getVarType) gr
943         ty' = cmmToLlvmType ty
944         (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt  `div` 8)
945     in case isPointer grt && rem == 0 of
946             True  -> do
947                 (gv,  s1) <- doExpr grt $ Load gr
948                 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
949                 -- We might need a different pointer type, so check
950                 case grt == ty' of
951                      -- were fine
952                      True -> do
953                          (var, s3) <- doExpr ty' $ Load ptr
954                          return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3,
955                                      [])
956
957                      -- cast to pointer type needed
958                      False -> do
959                          let pty = pLift ty'
960                          (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
961                          (var, s4) <- doExpr ty' $ Load ptr'
962                          return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3
963                                     `snocOL` s4, [])
964
965             -- If its a bit type then we use the slow method since
966             -- we can't avoid casting anyway.
967             False -> genLoad_slow env e ty
968
969
970 -- | Handle Cmm load expression.
971 -- Generic case. Uses casts and pointer arithmetic if needed.
972 genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
973 genLoad_slow env e ty = do
974     (env', iptr, stmts, tops) <- exprToVar env e
975     case getVarType iptr of
976          LMPointer _ -> do
977                     (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load iptr
978                     return (env', dvar, stmts `snocOL` load, tops)
979
980          i@(LMInt _) | i == llvmWord -> do
981                     let pty = LMPointer $ cmmToLlvmType ty
982                     (ptr, cast)  <- doExpr pty $ Cast LM_Inttoptr iptr pty
983                     (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load ptr
984                     return (env', dvar, stmts `snocOL` cast `snocOL` load, tops)
985
986          other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
987                         (PprCmm.pprExpr e <+> text (
988                             "Size of Ptr: " ++ show llvmPtrBits ++
989                             ", Size of var: " ++ show (llvmWidthInBits other) ++
990                             ", Var: " ++ show iptr))
991
992
993 -- | Handle CmmReg expression
994 --
995 -- We allocate CmmReg on the stack. This avoids having to map a CmmReg to an
996 -- equivalent SSA form and avoids having to deal with Phi node insertion.
997 -- This is also the approach recommended by LLVM developers.
998 getCmmReg :: LlvmEnv -> CmmReg -> ExprData
999 getCmmReg env r@(CmmLocal (LocalReg un _))
1000   = let exists = varLookup un env
1001
1002         (newv, stmts) = allocReg r
1003         nenv = varInsert un (pLower $ getVarType newv) env
1004     in case exists of
1005             Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, [])
1006             Nothing  -> (nenv, newv, stmts, [])
1007
1008 getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar g, nilOL, [])
1009
1010
1011 -- | Allocate a CmmReg on the stack
1012 allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
1013 allocReg (CmmLocal (LocalReg un ty))
1014   = let ty' = cmmToLlvmType ty
1015         var = LMLocalVar un (LMPointer ty')
1016         alc = Alloca ty' 1
1017     in (var, unitOL $ Assignment var alc)
1018
1019 allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
1020                     ++ " have been handled elsewhere!"
1021
1022
1023 -- | Generate code for a literal
1024 genLit :: LlvmEnv -> CmmLit -> UniqSM ExprData
1025 genLit env (CmmInt i w)
1026   = return (env, mkIntLit (LMInt $ widthInBits w) i, nilOL, [])
1027
1028 genLit env (CmmFloat r w)
1029   = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
1030               nilOL, [])
1031
1032 genLit env cmm@(CmmLabel l)
1033   = let label = strCLabel_llvm l
1034         ty = funLookup label env
1035         lmty = cmmToLlvmType $ cmmLitType cmm
1036     in case ty of
1037             -- Make generic external label definition and then pointer to it
1038             Nothing -> do
1039                 let glob@(var, _) = genStringLabelRef label
1040                 let ldata = [CmmData Data [([glob], [])]]
1041                 let env' = funInsert label (pLower $ getVarType var) env
1042                 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
1043                 return (env', v1, unitOL s1, ldata)
1044
1045             -- Referenced data exists in this module, retrieve type and make
1046             -- pointer to it.
1047             Just ty' -> do
1048                 let var = LMGlobalVar label (LMPointer ty')
1049                             ExternallyVisible Nothing Nothing False
1050                 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
1051                 return (env, v1, unitOL s1, [])
1052
1053 genLit env (CmmLabelOff label off) = do
1054     (env', vlbl, stmts, stat) <- genLit env (CmmLabel label)
1055     let voff = toIWord off
1056     (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
1057     return (env', v1, stmts `snocOL` s1, stat)
1058
1059 genLit env (CmmLabelDiffOff l1 l2 off) = do
1060     (env1, vl1, stmts1, stat1) <- genLit env (CmmLabel l1)
1061     (env2, vl2, stmts2, stat2) <- genLit env1 (CmmLabel l2)
1062     let voff = toIWord off
1063     let ty1 = getVarType vl1
1064     let ty2 = getVarType vl2
1065     if (isInt ty1) && (isInt ty2)
1066        && (llvmWidthInBits ty1 == llvmWidthInBits ty2)
1067
1068        then do
1069             (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
1070             (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
1071             return (env2, v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
1072                         stat1 ++ stat2)
1073
1074         else
1075             panic "genLit: CmmLabelDiffOff encountered with different label ty!"
1076
1077 genLit env (CmmBlock b)
1078   = genLit env (CmmLabel $ infoTblLbl b)
1079
1080 genLit _ CmmHighStackMark
1081   = panic "genStaticLit - CmmHighStackMark unsupported!"
1082
1083
1084 -- -----------------------------------------------------------------------------
1085 -- * Misc
1086 --
1087
1088 -- | Function prologue. Load STG arguments into variables for function.
1089 funPrologue :: UniqSM [LlvmStatement]
1090 funPrologue = liftM concat $ mapM getReg activeStgRegs
1091     where getReg rr =
1092             let reg = lmGlobalRegVar rr
1093                 arg = lmGlobalRegArg rr
1094                 alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
1095             in return [alloc, Store arg reg]
1096
1097
1098 -- | Function epilogue. Load STG variables to use as argument for call.
1099 funEpilogue :: UniqSM ([LlvmVar], LlvmStatements)
1100 funEpilogue = do
1101     let loadExpr r = do
1102         let reg = lmGlobalRegVar r
1103         (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
1104         return (v, unitOL s)
1105     loads <- mapM loadExpr activeStgRegs
1106     let (vars, stmts) = unzip loads
1107     return (vars, concatOL stmts)
1108
1109
1110 -- | Get a function pointer to the CLabel specified.
1111 --
1112 -- This is for Haskell functions, function type is assumed, so doesn't work
1113 -- with foreign functions.
1114 getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData
1115 getHsFunc env lbl
1116   = let fn = strCLabel_llvm lbl
1117         ty    = funLookup fn env
1118     in case ty of
1119         -- Function in module in right form
1120         Just ty'@(LMFunction sig) -> do
1121             let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing False
1122             return (env, fun, nilOL, [])
1123
1124         -- label in module but not function pointer, convert
1125         Just ty' -> do
1126             let fun = LMGlobalVar fn (pLift ty') ExternallyVisible
1127                             Nothing Nothing False
1128             (v1, s1) <- doExpr (pLift llvmFunTy) $
1129                             Cast LM_Bitcast fun (pLift llvmFunTy)
1130             return (env, v1, unitOL s1, [])
1131
1132         -- label not in module, create external reference
1133         Nothing  -> do
1134             let ty' = LMFunction $ llvmFunSig lbl ExternallyVisible
1135             let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False
1136             let top = CmmData Data [([],[ty'])]
1137             let env' = funInsert fn ty' env
1138             return (env', fun, nilOL, [top])
1139
1140
1141 -- | Create a new local var
1142 mkLocalVar :: LlvmType -> UniqSM LlvmVar
1143 mkLocalVar ty = do
1144     un <- getUniqueUs
1145     return $ LMLocalVar un ty
1146
1147
1148 -- | Execute an expression, assigning result to a var
1149 doExpr :: LlvmType -> LlvmExpression -> UniqSM (LlvmVar, LlvmStatement)
1150 doExpr ty expr = do
1151     v <- mkLocalVar ty
1152     return (v, Assignment v expr)
1153
1154
1155 -- | Expand CmmRegOff
1156 expandCmmReg :: (CmmReg, Int) -> CmmExpr
1157 expandCmmReg (reg, off)
1158   = let width = typeWidth (cmmRegType reg)
1159         voff  = CmmLit $ CmmInt (fromIntegral off) width
1160     in CmmMachOp (MO_Add width) [CmmReg reg, voff]
1161
1162
1163 -- | Convert a block id into a appropriate Llvm label
1164 blockIdToLlvm :: BlockId -> LlvmVar
1165 blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
1166
1167 -- | Create Llvm int Literal
1168 mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
1169 mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
1170
1171 -- | Convert int type to a LLvmVar of word or i32 size
1172 toI32, toIWord :: Integral a => a -> LlvmVar
1173 toI32 = mkIntLit i32
1174 toIWord = mkIntLit llvmWord
1175
1176
1177 -- | Error functions
1178 panic :: String -> a
1179 panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s
1180
1181 pprPanic :: String -> SDoc -> a
1182 pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d
1183