diff options
Diffstat (limited to 'compiler/llvmGen/LlvmCodeGen/CodeGen.hs')
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 133 |
1 files changed, 75 insertions, 58 deletions
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index f80a4f2b4c..b8f41f3392 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -55,11 +55,11 @@ basicBlocksCodeGen :: LlvmEnv -> ( [LlvmBasicBlock] , [LlvmCmmDecl] ) -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] ) basicBlocksCodeGen env ([]) (blocks, tops) - = do let platform = targetPlatform $ getDflags env + = do let dflags = getDflags env let (blocks', allocs) = mapAndUnzip dominateAllocs blocks let allocs' = concat allocs let ((BasicBlock id fstmts):rblks) = blocks' - let fblocks = (BasicBlock id $ funPrologue platform ++ allocs' ++ fstmts):rblks + let fblocks = (BasicBlock id $ funPrologue dflags ++ allocs' ++ fstmts):rblks return (env, fblocks, tops) basicBlocksCodeGen env (block:blocks) (lblocks', ltops') @@ -185,7 +185,8 @@ genCall env (CmmPrim MO_WriteBarrier _) _ _ _ -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM -- is strict about types. genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do - let width = widthToLlvmInt w + let dflags = getDflags env + width = widthToLlvmInt w dstTy = cmmToLlvmType $ localRegType dst funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible CC_Ccc width FixedArgs (tysToParams [width]) Nothing @@ -193,9 +194,9 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do (env2, argsV, stmts2, top2) <- arg_vars env1 args ([], nilOL, []) (env3, fptr, stmts3, top3) <- getFunPtr env2 funTy t - (argsV', stmts4) <- castVars $ zip argsV [width] + (argsV', stmts4) <- castVars dflags $ zip argsV [width] (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - ([retV'], stmts5) <- castVars [(retV,dstTy)] + ([retV'], stmts5) <- castVars dflags [(retV,dstTy)] let s2 = Store retV' dstV let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` @@ -208,17 +209,18 @@ genCall env t@(CmmPrim op _) [] args' CmmMayReturn | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = do - let (args, alignVal) = splitAlignVal args' + let dflags = getDflags env + (args, alignVal) = splitAlignVal args' (isVolTy, isVolVal) = if getLlvmVer env >= 28 then ([i1], [mkIntLit i1 0]) else ([], []) - argTy | op == MO_Memset = [i8Ptr, i8, llvmWord, i32] ++ isVolTy - | otherwise = [i8Ptr, i8Ptr, llvmWord, i32] ++ isVolTy + argTy | op == MO_Memset = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy + | otherwise = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, []) (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t - (argVars', stmts3) <- castVars $ zip argVars argTy + (argVars', stmts3) <- castVars dflags $ zip argVars argTy let arguments = argVars' ++ (alignVal:isVolVal) call = Expr $ Call StdCall fptr arguments [] @@ -415,16 +417,17 @@ arg_vars env (CmmHinted e _:rest) (vars, stmts, tops) -- | Cast a collection of LLVM variables to specific types. -castVars :: [(LlvmVar, LlvmType)] +castVars :: DynFlags -> [(LlvmVar, LlvmType)] -> UniqSM ([LlvmVar], LlvmStatements) -castVars vars = do - done <- mapM (uncurry castVar) vars +castVars dflags vars = do + done <- mapM (uncurry (castVar dflags)) vars let (vars', stmts) = unzip done return (vars', toOL stmts) -- | Cast an LLVM variable to a specific type, panicing if it can't be done. -castVar :: LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement) -castVar v t | getVarType v == t +castVar :: DynFlags -> LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement) +castVar dflags v t + | getVarType v == t = return (v, Nop) | otherwise @@ -432,7 +435,7 @@ castVar v t | getVarType v == t (LMInt n, LMInt m) -> if n < m then LM_Sext else LM_Trunc (vt, _) | isFloat vt && isFloat t - -> if llvmWidthInBits vt < llvmWidthInBits t + -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t then LM_Fpext else LM_Fptrunc (vt, _) | isInt vt && isFloat t -> LM_Sitofp (vt, _) | isFloat vt && isInt t -> LM_Fptosi @@ -498,10 +501,11 @@ cmmPrimOpFunctions env mop MO_Touch -> unsupported where + dflags = getDflags env intrinTy1 = (if getLlvmVer env >= 28 - then "p0i8.p0i8." else "") ++ show llvmWord + then "p0i8.p0i8." else "") ++ show (llvmWord dflags) intrinTy2 = (if getLlvmVer env >= 28 - then "p0i8." else "") ++ show llvmWord + then "p0i8." else "") ++ show (llvmWord dflags) unsupported = panic ("cmmPrimOpFunctions: " ++ show mop ++ " not supported here") @@ -543,12 +547,13 @@ genJump env expr live = do -- these with registers when possible. genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData genAssign env reg val = do - let (env1, vreg, stmts1, top1) = getCmmReg env reg + let dflags = getDflags env + (env1, vreg, stmts1, top1) = getCmmReg env reg (env2, vval, stmts2, top2) <- exprToVar env1 val let stmts = stmts1 `appOL` stmts2 let ty = (pLower . getVarType) vreg - case isPointer ty && getVarType vval == llvmWord of + case isPointer ty && getVarType vval == llvmWord dflags of -- Some registers are pointer types, so need to cast value to pointer True -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty @@ -594,10 +599,11 @@ genStore env addr val = genStore_slow env addr val [other] genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr -> UniqSM StmtData genStore_fast env addr r n val - = let gr = lmGlobalRegVar r + = let dflags = getDflags env + gr = lmGlobalRegVar (getDflags env) r meta = [getTBAA r] grt = (pLower . getVarType) gr - (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) + (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do (env', vval, stmts, top) <- exprToVar env val @@ -634,7 +640,7 @@ genStore_slow env addr val meta = do 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 + LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty let s2 = MetaStmt meta $ Store v vaddr return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) @@ -643,7 +649,7 @@ genStore_slow env addr val meta = do let s1 = MetaStmt meta $ Store vval vaddr return (env2, stmts `snocOL` s1, top1 ++ top2) - i@(LMInt _) | i == llvmWord -> do + i@(LMInt _) | i == llvmWord dflags -> do let vty = pLift $ getVarType vval (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty let s2 = MetaStmt meta $ Store vval vptr @@ -653,7 +659,7 @@ genStore_slow env addr val meta = do pprPanic "genStore: ptr not right type!" (PprCmm.pprExpr addr <+> text ( "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ - ", Size of var: " ++ show (llvmWidthInBits other) ++ + ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ ", Var: " ++ show vaddr)) where dflags = getDflags env @@ -723,14 +729,14 @@ data EOption = EOption { i1Option :: EOption i1Option = EOption (Just i1) -wordOption :: EOption -wordOption = EOption (Just llvmWord) +wordOption :: DynFlags -> EOption +wordOption dflags = EOption (Just (llvmWord dflags)) -- | Convert a CmmExpr to a list of LlvmStatements with the result of the -- expression being stored in the returned LlvmVar. exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData -exprToVar env = exprToVarOpt env wordOption +exprToVar env = exprToVarOpt env (wordOption (getDflags env)) exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData exprToVarOpt env opt e = case e of @@ -749,7 +755,7 @@ exprToVarOpt env opt e = case e of case (isPointer . getVarType) v1 of True -> do -- Cmm wants the value, so pointer types must be cast to ints - (v2, s2) <- doExpr llvmWord $ Cast LM_Ptrtoint v1 llvmWord + (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags) return (env', v2, stmts `snocOL` s1 `snocOL` s2, top) False -> return (env', v1, stmts `snocOL` s1, top) @@ -837,6 +843,8 @@ genMachOp env _ op [x] = case op of MO_S_Shr _ -> panicOp where + dflags = getDflags env + negate ty v2 negOp = do (env', vx, stmts, top) <- exprToVar env x (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx @@ -852,7 +860,7 @@ genMachOp env _ op [x] = case op of let sameConv' op = do (v1, s1) <- doExpr ty $ Cast op vx ty return (env', v1, stmts `snocOL` s1, top) - let toWidth = llvmWidthInBits ty + let toWidth = llvmWidthInBits dflags ty -- LLVM doesn't like trying to convert to same width, so -- need to check for that as we do get Cmm code doing it. case widthInBits from of @@ -880,14 +888,15 @@ genMachOp env opt op e = genMachOp_slow env opt op e genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] -> UniqSM ExprData genMachOp_fast env opt op r n e - = let gr = lmGlobalRegVar r + = let dflags = getDflags env + gr = lmGlobalRegVar dflags r grt = (pLower . getVarType) gr - (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) + (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do (gv, s1) <- doExpr grt $ Load gr (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] - (var, s3) <- doExpr llvmWord $ Cast LM_Ptrtoint ptr llvmWord + (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags) return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, []) False -> genMachOp_slow env opt op e @@ -957,6 +966,8 @@ genMachOp_slow env opt op [x, y] = case op of MO_FF_Conv _ _ -> panicOp where + dflags = getDflags env + binLlvmOp ty binOp = do (env1, vx, stmts1, top1) <- exprToVar env x (env2, vy, stmts2, top2) <- exprToVar env1 y @@ -1017,10 +1028,10 @@ genMachOp_slow env opt op [x, y] = case op of (env2, vy, stmts2, top2) <- exprToVar env1 y let word = getVarType vx - let word2 = LMInt $ 2 * (llvmWidthInBits $ getVarType vx) - let shift = llvmWidthInBits word - let shift1 = toIWord (shift - 1) - let shift2 = toIWord shift + let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx) + let shift = llvmWidthInBits dflags word + let shift1 = toIWord dflags (shift - 1) + let shift2 = toIWord dflags shift if isInt word then do @@ -1081,11 +1092,12 @@ genLoad env e ty = genLoad_slow env e ty [other] genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType -> UniqSM ExprData genLoad_fast env e r n ty = - let gr = lmGlobalRegVar r + let dflags = getDflags env + gr = lmGlobalRegVar dflags r meta = [getTBAA r] grt = (pLower . getVarType) gr ty' = cmmToLlvmType ty - (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) + (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do (gv, s1) <- doExpr grt $ Load gr @@ -1122,7 +1134,7 @@ genLoad_slow env e ty meta = do (MetaExpr meta $ Load iptr) return (env', dvar, stmts `snocOL` load, tops) - i@(LMInt _) | i == llvmWord -> do + i@(LMInt _) | i == llvmWord dflags -> do let pty = LMPointer $ cmmToLlvmType ty (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty (dvar, load) <- doExpr (cmmToLlvmType ty) @@ -1132,7 +1144,7 @@ genLoad_slow env e ty meta = do other -> pprPanic "exprToVar: CmmLoad expression is not right type!" (PprCmm.pprExpr e <+> text ( "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ - ", Size of var: " ++ show (llvmWidthInBits other) ++ + ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ ", Var: " ++ show iptr)) where dflags = getDflags env @@ -1150,7 +1162,7 @@ getCmmReg env r@(CmmLocal (LocalReg un _)) Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, []) Nothing -> (nenv, newv, stmts, []) -getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar g, nilOL, []) +getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar (getDflags env) g, nilOL, []) -- | Allocate a CmmReg on the stack @@ -1182,10 +1194,10 @@ genLit env cmm@(CmmLabel l) in case ty of -- Make generic external label definition and then pointer to it Nothing -> do - let glob@(var, _) = genStringLabelRef label + let glob@(var, _) = genStringLabelRef dflags label let ldata = [CmmData Data [([glob], [])]] let env' = funInsert label (pLower $ getVarType var) env - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord + (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) return (env', v1, unitOL s1, ldata) -- Referenced data exists in this module, retrieve type and make @@ -1193,23 +1205,25 @@ genLit env cmm@(CmmLabel l) Just ty' -> do let var = LMGlobalVar label (LMPointer ty') ExternallyVisible Nothing Nothing False - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord + (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) return (env, v1, unitOL s1, []) genLit env (CmmLabelOff label off) = do + let dflags = getDflags env (env', vlbl, stmts, stat) <- genLit env (CmmLabel label) - let voff = toIWord off + let voff = toIWord dflags off (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff return (env', v1, stmts `snocOL` s1, stat) genLit env (CmmLabelDiffOff l1 l2 off) = do + let dflags = getDflags env (env1, vl1, stmts1, stat1) <- genLit env (CmmLabel l1) (env2, vl2, stmts2, stat2) <- genLit env1 (CmmLabel l2) - let voff = toIWord off + let voff = toIWord dflags off let ty1 = getVarType vl1 let ty2 = getVarType vl2 if (isInt ty1) && (isInt ty2) - && (llvmWidthInBits ty1 == llvmWidthInBits ty2) + && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2) then do (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2 @@ -1232,11 +1246,12 @@ genLit _ CmmHighStackMark -- -- | Function prologue. Load STG arguments into variables for function. -funPrologue :: Platform -> [LlvmStatement] -funPrologue platform = concat $ map getReg $ activeStgRegs platform - where getReg rr = - let reg = lmGlobalRegVar rr - arg = lmGlobalRegArg rr +funPrologue :: DynFlags -> [LlvmStatement] +funPrologue dflags = concat $ map getReg $ activeStgRegs platform + where platform = targetPlatform dflags + getReg rr = + let reg = lmGlobalRegVar dflags rr + arg = lmGlobalRegArg dflags rr alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 in [alloc, Store arg reg] @@ -1254,11 +1269,11 @@ funEpilogue env (Just live) | dopt Opt_RegLiveness dflags = do dflags = getDflags env platform = targetPlatform dflags loadExpr r | r `elem` alwaysLive || r `elem` live = do - let reg = lmGlobalRegVar r + let reg = lmGlobalRegVar dflags r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg return (v, unitOL s) loadExpr r = do - let ty = (pLower . getVarType $ lmGlobalRegVar r) + let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) return (LMLitVar $ LMUndefLit ty, unitOL Nop) -- don't do liveness optimisation @@ -1270,7 +1285,7 @@ funEpilogue env _ = do dflags = getDflags env platform = targetPlatform dflags loadExpr r = do - let reg = lmGlobalRegVar r + let reg = lmGlobalRegVar dflags r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg return (v, unitOL s) @@ -1290,7 +1305,7 @@ trashStmts :: DynFlags -> LlvmStatements trashStmts dflags = concatOL $ map trashReg $ activeStgRegs platform where platform = targetPlatform dflags trashReg r = - let reg = lmGlobalRegVar r + let reg = lmGlobalRegVar dflags r ty = (pLower . getVarType) reg trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg in case callerSaves (targetPlatform dflags) r of @@ -1361,9 +1376,11 @@ mkIntLit :: Integral a => LlvmType -> a -> LlvmVar mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty -- | Convert int type to a LLvmVar of word or i32 size -toI32, toIWord :: Integral a => a -> LlvmVar +toI32 :: Integral a => a -> LlvmVar toI32 = mkIntLit i32 -toIWord = mkIntLit llvmWord + +toIWord :: Integral a => DynFlags -> a -> LlvmVar +toIWord dflags = mkIntLit (llvmWord dflags) -- | Error functions |