import Unique
import Util
+import Control.Monad ( liftM )
+
type LlvmStatements = OrdList LlvmStatement
-- -----------------------------------------------------------------------------
= 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')
CmmNop -> return (env, nilOL, [])
CmmComment _ -> return (env, nilOL, []) -- nuke comments
--- CmmComment s -> return (env, unitOL $ Comment (lines $ unpackFS s),
--- [])
CmmAssign reg src -> genAssign env reg src
CmmStore addr src -> genStore env addr src
-- intrinsic function.
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])
+ let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid
+ FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign
let fty = LMFunction funSig
- let fv = LMGlobalVar fname fty (funcLinkage funSig)
+ let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False
let tops = case funLookup fname env of
Just _ -> []
Nothing -> [CmmData Data [([],[fty])]]
genCall env target res args ret = do
-- paramater types
- let arg_type (CmmHinted _ AddrHint) = pLift i8
+ let arg_type (CmmHinted _ AddrHint) = i8Ptr
-- cast pointers to i8*. Llvm equivalent of void*
arg_type (CmmHinted expr _ ) = cmmToLlvmType $ cmmExprType expr
-- ret type
let ret_type ([]) = LMVoid
- ret_type ([CmmHinted _ AddrHint]) = pLift i8
- ret_type ([CmmHinted reg _]) = cmmToLlvmType $ localRegType reg
+ ret_type ([CmmHinted _ AddrHint]) = i8Ptr
+ ret_type ([CmmHinted reg _]) = cmmToLlvmType $ localRegType reg
ret_type t = panic $ "genCall: Too many return values! Can only handle"
++ " 0 or 1, given " ++ show (length t) ++ "."
-- 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 funTy name = LMFunction $
- LlvmFunctionDecl name ExternallyVisible lmconv retTy FixedArgs argTy
+ let argTy = tysToParams $ map arg_type args
+ let funTy name = LMFunction $ LlvmFunctionDecl name ExternallyVisible
+ lmconv retTy FixedArgs argTy llvmFunAlign
-- get paramter values
(env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
Just ty'@(LMFunction sig) -> do
-- Function in module in right form
let fun = LMGlobalVar name ty' (funcLinkage sig)
+ 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)
return (env1, v1, unitOL s1, [])
-- label not in module, create external reference
let fty@(LMFunction sig) = funTy name
let fun = LMGlobalVar name fty (funcLinkage sig)
+ Nothing Nothing False
let top = CmmData Data [([],[fty])]
let env' = funInsert name fty env1
return (env', fun, nilOL, [top])
CmmPrim mop -> do
let name = cmmPrimOpFunctions mop
let lbl = mkForeignLabel name Nothing
- ForeignLabelInExternalPackage IsFunction
+ ForeignLabelInExternalPackage IsFunction
getFunPtr $ CmmCallee (CmmLit (CmmLabel lbl)) CCallConv
(env2, fptr, stmts2, top2) <- getFunPtr target
a -> panic $ "genCall: Can't cast llvmType to i8*! ("
++ show a ++ ")"
- (v2, s1) <- doExpr (pLift i8) $ Cast op v1 (pLift i8)
- arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, tops ++ top')
+ (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
+ arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
+ tops ++ top')
arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
= do (env', v1, stmts', top') <- exprToVar env e
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
in negate (widthToLlvmInt w) all0 LM_MO_Sub
MO_F_Neg w ->
- let all0 = LMLitVar $ LMFloatLit 0 (widthToLlvmFloat w)
- in negate (widthToLlvmFloat w) all0 LM_MO_Sub
+ let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
+ 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
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
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
--
= return (env, mkIntLit i (LMInt $ widthInBits w), nilOL, [])
genLit env (CmmFloat r w)
- = return (env, LMLitVar $ LMFloatLit r (widthToLlvmFloat w), nilOL, [])
+ = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
+ nilOL, [])
genLit env cmm@(CmmLabel l)
= let label = strCLabel_llvm l
-- Referenced data exists in this module, retrieve type and make
-- pointer to it.
Just ty' -> do
- let var = LMGlobalVar label (LMPointer ty') ExternallyVisible
+ let var = LMGlobalVar label (LMPointer ty')
+ ExternallyVisible Nothing Nothing False
(v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
return (env, v1, unitOL s1, [])
--
-- | 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)
-- 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)
+ 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
- (v1, s1) <- doExpr (pLift llvmFunTy) $ Cast LM_Bitcast fun (pLift llvmFunTy)
+ 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
+ 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])
projects / ghc-hetmet.git / blobdiff