From: David Terei Date: Wed, 30 Jun 2010 18:11:57 +0000 (+0000) Subject: LLVM: Use getelementptr instruction for a lot of situations X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=a42400e6c9074cf22d0c2dac791345840e3d9419 LLVM: Use getelementptr instruction for a lot of situations LLVM supports creating pointers in two ways, firstly through pointer arithmetic (by casting between pointers and ints) and secondly using the getelementptr instruction. The second way is preferable as it gives LLVM more information to work with. This patch changes a lot of pointer related code from the first method to the getelementptr method. --- diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 359d492..8d970cd 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -426,26 +426,108 @@ genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData genAssign env reg val = do let (env1, vreg, stmts1, top1) = getCmmReg env reg (env2, vval, stmts2, top2) <- exprToVar env1 val - let s1 = Store vval vreg - return (env2, stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2) + let stmts = stmts1 `appOL` stmts2 + + let ty = (pLower . getVarType) vreg + case isPointer ty && getVarType vval == llvmWord of + -- Some registers are pointer types, so need to cast value to pointer + True -> do + (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty + let s2 = Store v vreg + return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + + False -> do + let s1 = Store vval vreg + return (env2, stmts `snocOL` s1, top1 ++ top2) -- | CmmStore operation genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData -genStore env addr val = do + +-- First we try to detect a few common cases and produce better code for +-- these then the default case. We are mostly trying to detect Cmm code +-- like I32[Sp + n] and use 'getelementptr' operations instead of the +-- generic case that uses casts and pointer arithmetic +genStore env addr@(CmmReg (CmmGlobal r)) val + = genStore_fast env addr r 0 val + +genStore env addr@(CmmRegOff (CmmGlobal r) n) val + = genStore_fast env addr r n val + +genStore env addr@(CmmMachOp (MO_Add _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + val + = genStore_fast env addr r (fromInteger n) val + +genStore env addr@(CmmMachOp (MO_Sub _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + val + = genStore_fast env addr r (negate $ fromInteger n) val + +-- generic case +genStore env addr val = genStore_slow env addr val + +-- | CmmStore operation +-- This is a special case for storing to a global register pointer +-- offset such as I32[Sp+8]. +genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr + -> UniqSM StmtData +genStore_fast env addr r n val + = let gr = lmGlobalRegVar r + grt = (pLower . getVarType) gr + ix = n `div` ((llvmWidthInBits . pLower) grt `div` 8) + in case isPointer grt of + True -> do + (env', vval, stmts, top) <- exprToVar env val + (gv, s1) <- doExpr grt $ Load gr + (ptr, s2) <- doExpr grt $ GetElemPtr gv [ix] + -- We might need a different pointer type, so check + case pLower grt == getVarType vval of + -- were fine + True -> do + let s3 = Store vval ptr + return (env', stmts `snocOL` s1 `snocOL` s2 + `snocOL` s3, top) + + -- cast to pointer type needed + False -> do + let ty = (pLift . getVarType) vval + (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty + let s4 = Store vval ptr' + return (env', stmts `snocOL` s1 `snocOL` s2 + `snocOL` s3 `snocOL` s4, top) + + -- If its a bit type then we use the slow method since + -- we can't avoid casting anyway. + False -> genStore_slow env addr val + + +-- | CmmStore operation +-- Generic case. Uses casts and pointer arithmetic if needed. +genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData +genStore_slow env addr val = do (env1, vaddr, stmts1, top1) <- exprToVar env addr (env2, vval, stmts2, top2) <- exprToVar env1 val + + let stmts = stmts1 `appOL` stmts2 case getVarType vaddr of + -- sometimes we need to cast an int to a pointer before storing + LMPointer ty@(LMPointer _) | getVarType vval == llvmWord -> do + (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty + let s2 = Store v vaddr + return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + LMPointer _ -> do let s1 = Store vval vaddr - return (env2, stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2) + return (env2, stmts `snocOL` s1, top1 ++ top2) i@(LMInt _) | i == llvmWord -> do let vty = pLift $ getVarType vval (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty let s2 = Store vval vptr - return (env2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2, - top1 ++ top2) + return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) other -> pprPanic "genStore: ptr not right type!" @@ -543,7 +625,14 @@ exprToVarOpt env opt e = case e of CmmReg r -> do let (env', vreg, stmts, top) = getCmmReg env r (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg - return (env', v1, stmts `snocOL` s1 , top) + case (isPointer . getVarType) v1 of + True -> do + -- Cmm wants the value, so pointer types must be cast to ints + -- TODO: Remove, keep as pointers as much as possible + (v2, s2) <- doExpr llvmWord $ Cast LM_Ptrtoint v1 llvmWord + return (env', v2, stmts `snocOL` s1 `snocOL` s2, top) + + False -> return (env', v1, stmts `snocOL` s1, top) CmmMachOp op exprs -> genMachOp env opt op exprs @@ -759,9 +848,73 @@ genMachOp env opt op [x, y] = case op of genMachOp _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" --- | Handle CmmLoad expression +-- | Handle CmmLoad expression. genCmmLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData -genCmmLoad env e ty = do + +-- First we try to detect a few common cases and produce better code for +-- these then the default case. We are mostly trying to detect Cmm code +-- like I32[Sp + n] and use 'getelementptr' operations instead of the +-- generic case that uses casts and pointer arithmetic +genCmmLoad env e@(CmmReg (CmmGlobal r)) ty + = genCmmLoad_fast env e r 0 ty + +genCmmLoad env e@(CmmRegOff (CmmGlobal r) n) ty + = genCmmLoad_fast env e r n ty + +genCmmLoad env e@(CmmMachOp (MO_Add _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + ty + = genCmmLoad_fast env e r (fromInteger n) ty + +genCmmLoad env e@(CmmMachOp (MO_Sub _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + ty + = genCmmLoad_fast env e r (negate $ fromInteger n) ty + +-- generic case +genCmmLoad env e ty = genCmmLoad_slow env e ty + +-- | Handle CmmLoad expression. +-- This is a special case for loading from a global register pointer +-- offset such as I32[Sp+8]. +genCmmLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType + -> UniqSM ExprData +genCmmLoad_fast env e r n ty = + let gr = lmGlobalRegVar r + grt = (pLower . getVarType) gr + ix = n `div` ((llvmWidthInBits . pLower) grt `div` 8) + ty' = cmmToLlvmType ty + in case isPointer grt of + True -> do + (gv, s1) <- doExpr grt $ Load gr + (ptr, s2) <- doExpr grt $ GetElemPtr gv [ix] + -- We might need a different pointer type, so check + case grt == ty' of + -- were fine + True -> do + (var, s3) <- doExpr ty' $ Load ptr + return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, + []) + + -- cast to pointer type needed + False -> do + let pty = pLift ty' + (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty + (var, s4) <- doExpr ty' $ Load ptr' + return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3 + `snocOL` s4, []) + + -- If its a bit type then we use the slow method since + -- we can't avoid casting anyway. + False -> genCmmLoad_slow env e ty + + +-- | Handle Cmm load expression. +-- Generic case. Uses casts and pointer arithmetic if needed. +genCmmLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData +genCmmLoad_slow env e ty = do (env', iptr, stmts, tops) <- exprToVar env e case getVarType iptr of LMPointer _ -> do @@ -832,6 +985,7 @@ genLit env cmm@(CmmLabel l) let env' = funInsert label (pLower $ getVarType var) env (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord return (env', v1, unitOL s1, ldata) + -- Referenced data exists in this module, retrieve type and make -- pointer to it. Just ty' -> do @@ -882,14 +1036,7 @@ funPrologue = liftM concat $ mapM getReg activeStgRegs let reg = lmGlobalRegVar rr arg = lmGlobalRegArg rr alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 - in if (isPointer . getVarType) arg - then do - (v, c) <- doExpr llvmWord (Cast LM_Ptrtoint arg llvmWord) - let store = Store v reg - return [alloc, c, store] - else do - let store = Store arg reg - return [alloc, store] + in return [alloc, Store arg reg] -- | Function epilogue. Load STG variables to use as argument for call. @@ -897,13 +1044,8 @@ funEpilogue :: UniqSM ([LlvmVar], LlvmStatements) funEpilogue = do let loadExpr r = do let reg = lmGlobalRegVar r - let arg = lmGlobalRegArg r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg - case (isPointer . getVarType) arg of - True -> do - (v2, s2) <- doExpr llvmWordPtr $ Cast LM_Inttoptr v llvmWordPtr - return (v2, unitOL s `snocOL` s2) - False -> return (v, unitOL s) + return (v, unitOL s) loads <- mapM loadExpr activeStgRegs let (vars, stmts) = unzip loads return (vars, concatOL stmts) @@ -918,19 +1060,21 @@ getHsFunc env lbl = let fn = strCLabel_llvm lbl ty = funLookup fn env in case ty of - Just ty'@(LMFunction sig) -> do -- Function in module in right form + Just ty'@(LMFunction sig) -> do let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing False return (env, fun, nilOL, []) - Just ty' -> do + -- label in module but not function pointer, convert + Just ty' -> do let fun = LMGlobalVar fn (pLift ty') ExternallyVisible Nothing Nothing False (v1, s1) <- doExpr (pLift llvmFunTy) $ Cast LM_Bitcast fun (pLift llvmFunTy) return (env, v1, unitOL s1, []) - Nothing -> do + -- label not in module, create external reference + Nothing -> do let ty' = LMFunction $ llvmFunSig lbl ExternallyVisible let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False let top = CmmData Data [([],[ty'])] diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index fd3bc77..661dc9a 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -16,11 +16,7 @@ import FastString -- | Get the LlvmVar function variable storing the real register lmGlobalRegVar :: GlobalReg -> LlvmVar -lmGlobalRegVar reg - = let reg' = lmGlobalReg "_Var" reg - in if (isPointer . getVarType) reg' - then reg' - else pVarLift reg' +lmGlobalRegVar = (pVarLift . lmGlobalReg "_Var") -- | Get the LlvmVar function argument storing the real register lmGlobalRegArg :: GlobalReg -> LlvmVar