X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FllvmGen%2FLlvmCodeGen%2FCodeGen.hs;h=437570f190c0b514f217ade3163d2be41d3093e3;hb=dc1deadaafcb7b4ced8a6a072382b07c39999327;hp=41bc8ee7585d1b23bdac76aca5d99d053e807f97;hpb=4738e101938db94cbe8444bc42f59d29b1b815c6;p=ghc-hetmet.git diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 41bc8ee..437570f 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -244,10 +244,10 @@ genCall env target res args ret = do Nothing Nothing False return (env1, fun, nilOL, []) - Just _ -> do + Just ty' -> do -- label in module but not function pointer, convert let fty@(LMFunction sig) = funTy name - let fun = LMGlobalVar name fty (funcLinkage sig) + let fun = LMGlobalVar name (pLift ty') (funcLinkage sig) Nothing Nothing False (v1, s1) <- doExpr (pLift fty) $ Cast LM_Bitcast fun (pLift fty) @@ -351,11 +351,11 @@ cmmPrimOpFunctions mop = case mop of MO_F32_Exp -> fsLit "expf" MO_F32_Log -> fsLit "logf" - MO_F32_Sqrt -> fsLit "sqrtf" - MO_F32_Pwr -> fsLit "powf" + MO_F32_Sqrt -> fsLit "llvm.sqrt.f32" + MO_F32_Pwr -> fsLit "llvm.pow.f32" - MO_F32_Sin -> fsLit "sinf" - MO_F32_Cos -> fsLit "cosf" + MO_F32_Sin -> fsLit "llvm.sin.f32" + MO_F32_Cos -> fsLit "llvm.cos.f32" MO_F32_Tan -> fsLit "tanf" MO_F32_Asin -> fsLit "asinf" @@ -368,11 +368,11 @@ cmmPrimOpFunctions mop MO_F64_Exp -> fsLit "exp" MO_F64_Log -> fsLit "log" - MO_F64_Sqrt -> fsLit "sqrt" - MO_F64_Pwr -> fsLit "pow" + MO_F64_Sqrt -> fsLit "llvm.sqrt.f64" + MO_F64_Pwr -> fsLit "llvm.pow.f64" - MO_F64_Sin -> fsLit "sin" - MO_F64_Cos -> fsLit "cos" + MO_F64_Sin -> fsLit "llvm.sin.f64" + MO_F64_Cos -> fsLit "llvm.cos.f64" MO_F64_Tan -> fsLit "tan" MO_F64_Asin -> fsLit "asin" @@ -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,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) + in case isPointer grt && rem == 0 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!" @@ -536,14 +618,20 @@ exprToVarOpt env opt e = case e of -> genLit env lit CmmLoad e' ty - -> genCmmLoad env e' ty + -> genLoad env e' ty -- Cmmreg in expression is the value, so must load. If you want actual -- reg pointer, call getCmmReg directly. 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 + (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 @@ -571,7 +659,7 @@ genMachOp env _ op [x] = case op of MO_F_Neg w -> let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w) - in negate (widthToLlvmFloat w) all0 LM_MO_Sub + in negate (widthToLlvmFloat w) all0 LM_MO_FSub MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi @@ -611,9 +699,42 @@ genMachOp env _ op [x] = case op of w | w > toWidth -> sameConv' reduce _w -> return x' +-- handle globalregs pointers +genMachOp env opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast env opt o r (fromInteger n) e + +genMachOp env opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast env opt o r (negate . fromInteger $ n) e + +-- generic case +genMachOp env opt op e = genMachOp_slow env opt op e + + +-- | Handle CmmMachOp expressions +-- This is a specialised method that handles Global register manipulations like +-- 'Sp - 16', using the getelementptr instruction. +genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] + -> UniqSM ExprData +genMachOp_fast env opt op r n e + = let gr = lmGlobalRegVar r + grt = (pLower . getVarType) gr + (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) + in case isPointer grt && rem == 0 of + True -> do + (gv, s1) <- doExpr grt $ Load gr + (ptr, s2) <- doExpr grt $ GetElemPtr gv [ix] + (var, s3) <- doExpr llvmWord $ Cast LM_Ptrtoint ptr llvmWord + return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, []) + + False -> genMachOp_slow env opt op e + + +-- | Handle CmmMachOp expressions +-- This handles all the cases not handle by the specialised genMachOp_fast. +genMachOp_slow :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData -- Binary MachOp -genMachOp env opt op [x, y] = case op of +genMachOp_slow env opt op [x, y] = case op of MO_Eq _ -> genBinComp opt LM_CMP_Eq MO_Ne _ -> genBinComp opt LM_CMP_Ne @@ -649,9 +770,9 @@ genMachOp env opt op [x, y] = case op of MO_F_Lt _ -> genBinComp opt LM_CMP_Flt MO_F_Le _ -> genBinComp opt LM_CMP_Fle - MO_F_Add _ -> genBinMach LM_MO_Add - MO_F_Sub _ -> genBinMach LM_MO_Sub - MO_F_Mul _ -> genBinMach LM_MO_Mul + MO_F_Add _ -> genBinMach LM_MO_FAdd + MO_F_Sub _ -> genBinMach LM_MO_FSub + MO_F_Mul _ -> genBinMach LM_MO_FMul MO_F_Quot _ -> genBinMach LM_MO_FDiv MO_And _ -> genBinMach LM_MO_And @@ -754,14 +875,77 @@ genMachOp env opt op [x, y] = case op of else panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")" - -- More then two expression, invalid! -genMachOp _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" - - --- | Handle CmmLoad expression -genCmmLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData -genCmmLoad env e ty = do +genMachOp_slow _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" + + +-- | Handle CmmLoad expression. +genLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData + +-- 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 +genLoad env e@(CmmReg (CmmGlobal r)) ty + = genLoad_fast env e r 0 ty + +genLoad env e@(CmmRegOff (CmmGlobal r) n) ty + = genLoad_fast env e r n ty + +genLoad env e@(CmmMachOp (MO_Add _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + ty + = genLoad_fast env e r (fromInteger n) ty + +genLoad env e@(CmmMachOp (MO_Sub _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + ty + = genLoad_fast env e r (negate $ fromInteger n) ty + +-- generic case +genLoad env e ty = genLoad_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]. +genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType + -> UniqSM ExprData +genLoad_fast env e r n ty = + let gr = lmGlobalRegVar r + grt = (pLower . getVarType) gr + ty' = cmmToLlvmType ty + (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) + in case isPointer grt && rem == 0 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 -> genLoad_slow env e ty + + +-- | Handle Cmm load expression. +-- Generic case. Uses casts and pointer arithmetic if needed. +genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData +genLoad_slow env e ty = do (env', iptr, stmts, tops) <- exprToVar env e case getVarType iptr of LMPointer _ -> do @@ -832,6 +1016,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 +1067,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 +1075,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 +1091,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'])]