From 4738e101938db94cbe8444bc42f59d29b1b815c6 Mon Sep 17 00:00:00 2001 From: David Terei Date: Mon, 21 Jun 2010 17:58:39 +0000 Subject: [PATCH] Allow for stg registers to have pointer type in llvm BE. Before all the stg registers were simply a bit type or floating point type but now they can be declared to have a pointer type to one of these. This will allow various optimisations in the future in llvm since the type is more accurate. --- compiler/llvmGen/Llvm/PpLlvm.hs | 3 ++ compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 65 ++++++++++++++++++++----------- compiler/llvmGen/LlvmCodeGen/Regs.hs | 24 +++++++----- 3 files changed, 60 insertions(+), 32 deletions(-) diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index 9afb76e..2227fb6 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -230,9 +230,12 @@ ppCmpOp op left right = let cmpOp | isInt (getVarType left) && isInt (getVarType right) = text "icmp" | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp" + | otherwise = text "icmp" -- Just continue as its much easier to debug + {- | otherwise = error ("can't compare different types, left = " ++ (show $ getVarType left) ++ ", right = " ++ (show $ getVarType right)) + -} in cmpOp <+> texts op <+> texts (getVarType left) <+> (text $ getName left) <> comma <+> (text $ getName right) diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index c945f97..41bc8ee 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -26,6 +26,8 @@ import UniqSupply import Unique import Util +import Control.Monad ( liftM ) + type LlvmStatements = OrdList LlvmStatement -- ----------------------------------------------------------------------------- @@ -61,7 +63,8 @@ basicBlocksCodeGen env ([]) (blocks, tops) = do let (blocks', allocs) = mapAndUnzip dominateAllocs blocks let allocs' = concat allocs let ((BasicBlock id fstmts):rblocks) = blocks' - let fblocks = (BasicBlock id (funPrologue ++ allocs' ++ fstmts)):rblocks + fplog <- funPrologue + let fblocks = (BasicBlock id (fplog ++ allocs' ++ fstmts)):rblocks return (env, fblocks, tops) basicBlocksCodeGen env (block:blocks) (lblocks', ltops') @@ -432,16 +435,24 @@ genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData genStore env addr val = do (env1, vaddr, stmts1, top1) <- exprToVar env addr (env2, vval, stmts2, top2) <- exprToVar env1 val - if getVarType vaddr == llvmWord - then do + case getVarType vaddr of + LMPointer _ -> do + let s1 = Store vval vaddr + return (env2, stmts1 `appOL` stmts2 `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) - else - panic $ "genStore: ptr not of word size! (" ++ show vaddr ++ ")" + other -> + pprPanic "genStore: ptr not right type!" + (PprCmm.pprExpr addr <+> text ( + "Size of Ptr: " ++ show llvmPtrBits ++ + ", Size of var: " ++ show (llvmWidthInBits other) ++ + ", Var: " ++ show vaddr)) -- | Unconditional branch @@ -752,25 +763,23 @@ genMachOp _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" genCmmLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData genCmmLoad env e ty = do (env', iptr, stmts, tops) <- exprToVar env e - let ety = getVarType iptr - case (isInt ety) of - True | llvmPtrBits == llvmWidthInBits ety -> do + case getVarType iptr of + LMPointer _ -> do + (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load iptr + return (env', dvar, stmts `snocOL` load, tops) + + i@(LMInt _) | i == llvmWord -> do let pty = LMPointer $ cmmToLlvmType ty (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load ptr return (env', dvar, stmts `snocOL` cast `snocOL` load, tops) - | otherwise - -> pprPanic - ("exprToVar: can't cast to pointer as int not of " - ++ "pointer size!") + other -> pprPanic "exprToVar: CmmLoad expression is not right type!" (PprCmm.pprExpr e <+> text ( "Size of Ptr: " ++ show llvmPtrBits ++ - ", Size of var: " ++ show (llvmWidthInBits ety) ++ + ", Size of var: " ++ show (llvmWidthInBits other) ++ ", Var: " ++ show iptr)) - False -> panic "exprToVar: CmmLoad expression is not of type int!" - -- | Handle CmmReg expression -- @@ -867,23 +876,35 @@ genLit _ CmmHighStackMark -- -- | Function prologue. Load STG arguments into variables for function. -funPrologue :: [LlvmStatement] -funPrologue = concat $ map getReg activeStgRegs +funPrologue :: UniqSM [LlvmStatement] +funPrologue = liftM concat $ mapM getReg activeStgRegs where getReg rr = let reg = lmGlobalRegVar rr arg = lmGlobalRegArg rr alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 - store = Store arg reg - in [alloc, store] + 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] -- | Function epilogue. Load STG variables to use as argument for call. funEpilogue :: UniqSM ([LlvmVar], LlvmStatements) funEpilogue = do let loadExpr r = do - (v,s) <- doExpr (pLower $ getVarType r) $ Load r - return (v, unitOL s) - loads <- mapM (loadExpr . lmGlobalRegVar) activeStgRegs + 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) + loads <- mapM loadExpr activeStgRegs let (vars, stmts) = unzip loads return (vars, concatOL stmts) diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index b731a86..cc961cc 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -1,5 +1,4 @@ --- ---------------------------------------------------------------------------- --- | Deal with Cmm registers +-- ---------------------------------------------------------------------------- -- | Deal with Cmm registers -- module LlvmCodeGen.Regs ( @@ -16,11 +15,15 @@ import FastString -- | Get the LlvmVar function variable storing the real register lmGlobalRegVar :: GlobalReg -> LlvmVar -lmGlobalRegVar = lmGlobalReg "_Var" +lmGlobalRegVar reg + = let reg' = lmGlobalReg "_Var" reg + in if (isPointer . getVarType) reg' + then reg' + else pVarLift reg' -- | Get the LlvmVar function argument storing the real register lmGlobalRegArg :: GlobalReg -> LlvmVar -lmGlobalRegArg = (pVarLower . lmGlobalReg "_Arg") +lmGlobalRegArg = lmGlobalReg "_Arg" {- Need to make sure the names here can't conflict with the unique generated names. Uniques generated names containing only base62 chars. So using say @@ -29,9 +32,9 @@ lmGlobalRegArg = (pVarLower . lmGlobalReg "_Arg") lmGlobalReg :: String -> GlobalReg -> LlvmVar lmGlobalReg suf reg = case reg of - BaseReg -> wordGlobal $ "Base" ++ suf - Sp -> wordGlobal $ "Sp" ++ suf - Hp -> wordGlobal $ "Hp" ++ suf + BaseReg -> ptrGlobal $ "Base" ++ suf + Sp -> ptrGlobal $ "Sp" ++ suf + Hp -> ptrGlobal $ "Hp" ++ suf VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf @@ -48,7 +51,8 @@ lmGlobalReg suf reg _other -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg) ++ ") not supported!" where - wordGlobal name = LMNLocalVar (fsLit name) llvmWordPtr - floatGlobal name = LMNLocalVar (fsLit name) $ pLift LMFloat - doubleGlobal name = LMNLocalVar (fsLit name) $ pLift LMDouble + wordGlobal name = LMNLocalVar (fsLit name) llvmWord + ptrGlobal name = LMNLocalVar (fsLit name) llvmWordPtr + floatGlobal name = LMNLocalVar (fsLit name) LMFloat + doubleGlobal name = LMNLocalVar (fsLit name) LMDouble -- 1.7.10.4