X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FllvmGen%2FLlvmCodeGen%2FCodeGen.hs;h=2ebd5d9bb8cea705e83642de189c75edab99c4b3;hb=20ea4cf4993aa7b0b19c882fd98503a4b7f307d3;hp=13fe123f48a02b9e2544395ed043029f999ac0d7;hpb=09e6aba8000ccf52943ada4fb9ac76e0d93a202f;p=ghc-hetmet.git diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 13fe123..2ebd5d9 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') @@ -153,10 +156,10 @@ genCall :: LlvmEnv -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do let fname = fsLit "llvm.memory.barrier" let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid - FixedArgs (Left [i1, i1, i1, i1, i1]) llvmFunAlign + FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign let fty = LMFunction funSig - let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing + let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False let tops = case funLookup fname env of Just _ -> [] Nothing -> [CmmData Data [([],[fty])]] @@ -217,7 +220,7 @@ genCall env target res args ret = do -- fun type let ccTy = StdCall -- tail calls should be done through CmmJump let retTy = ret_type res - let argTy = Left $ map arg_type args + let argTy = tysToParams $ map arg_type args let funTy name = LMFunction $ LlvmFunctionDecl name ExternallyVisible lmconv retTy FixedArgs argTy llvmFunAlign @@ -238,14 +241,14 @@ genCall env target res args ret = do Just ty'@(LMFunction sig) -> do -- Function in module in right form let fun = LMGlobalVar name ty' (funcLinkage sig) - Nothing Nothing + Nothing Nothing False return (env1, fun, nilOL, []) Just _ -> do -- label in module but not function pointer, convert let fty@(LMFunction sig) = funTy name let fun = LMGlobalVar name fty (funcLinkage sig) - Nothing Nothing + Nothing Nothing False (v1, s1) <- doExpr (pLift fty) $ Cast LM_Bitcast fun (pLift fty) return (env1, v1, unitOL s1, []) @@ -254,7 +257,7 @@ genCall env target res args ret = do -- label not in module, create external reference let fty@(LMFunction sig) = funTy name let fun = LMGlobalVar name fty (funcLinkage sig) - Nothing Nothing + Nothing Nothing False let top = CmmData Data [([],[fty])] let env' = funInsert name fty env1 return (env', fun, nilOL, [top]) @@ -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 @@ -560,7 +571,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 @@ -638,9 +649,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 @@ -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 -- @@ -827,7 +836,7 @@ genLit env cmm@(CmmLabel l) -- pointer to it. Just ty' -> do let var = LMGlobalVar label (LMPointer ty') - ExternallyVisible Nothing Nothing + ExternallyVisible Nothing Nothing False (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord return (env, v1, unitOL s1, []) @@ -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) @@ -894,26 +915,26 @@ funEpilogue = do -- with foreign functions. getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData getHsFunc env lbl - = let fname = strCLabel_llvm lbl - ty = funLookup fname env + = let fn = strCLabel_llvm lbl + ty = funLookup fn env in case ty of Just ty'@(LMFunction sig) -> do -- Function in module in right form - let fun = LMGlobalVar fname ty' (funcLinkage sig) Nothing Nothing + 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 - let fun = LMGlobalVar fname (pLift ty') ExternallyVisible - Nothing Nothing + 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 let ty' = LMFunction $ llvmFunSig lbl ExternallyVisible - let fun = LMGlobalVar fname ty' ExternallyVisible Nothing Nothing + let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False let top = CmmData Data [([],[ty'])] - let env' = funInsert fname ty' env + let env' = funInsert fn ty' env return (env', fun, nilOL, [top])