X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FMachCodeGen.hs;h=eed63fb803d4cf79272cae88bfab940698db6dba;hb=c01eaa1d3eb3db5c8fd036aae7e3525909454c64;hp=e1ef465e98cae09f5e398f304ea2909aa246ed8d;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4;p=ghc-hetmet.git diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs index e1ef465..eed63fb 100644 --- a/compiler/nativeGen/MachCodeGen.hs +++ b/compiler/nativeGen/MachCodeGen.hs @@ -1,3 +1,10 @@ +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + ----------------------------------------------------------------------------- -- -- Generating machine code (instruction selection) @@ -11,13 +18,6 @@ -- (c) the #if blah_TARGET_ARCH} things, the -- structure should not be too overwhelming. -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module MachCodeGen ( cmmTopCodeGen, InstrBlock ) where #include "HsVersions.h" @@ -45,13 +45,9 @@ import OrdList import Pretty import Outputable import FastString -import FastTypes ( isFastTrue ) +import FastBool ( isFastTrue ) import Constants ( wORD_SIZE ) -#ifdef DEBUG -import Outputable ( assertPanic ) -import Debug.Trace ( trace ) -#endif import Debug.Trace ( trace ) import Control.Monad ( mapAndUnzipM ) @@ -71,10 +67,10 @@ import Data.Int type InstrBlock = OrdList Instr cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop] -cmmTopCodeGen (CmmProc info lab params blocks) = do +cmmTopCodeGen (CmmProc info lab params (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat - let proc = CmmProc info lab params (concat nat_blocks) + let proc = CmmProc info lab params (ListGraph $ concat nat_blocks) tops = proc : concat statics case picBaseMb of Just picBase -> initializePicBase picBase tops @@ -305,7 +301,7 @@ assignMem_I64Code addrTree valueTree = do mov_lo = ST I32 rlo (AddrRegImm src (ImmInt 4)) return (vcode `appOL` code `snocOL` mov_hi `snocOL` mov_lo) -assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do +assignReg_I64Code (CmmLocal (LocalReg u_dst pk _)) valueTree = do ChildCode64 vcode r_src_lo <- iselExpr64 valueTree let r_dst_lo = mkVReg u_dst pk @@ -335,7 +331,7 @@ iselExpr64 (CmmLoad addrTree I64) = do rlo ) -iselExpr64 (CmmReg (CmmLocal (LocalReg uq I64))) = do +iselExpr64 (CmmReg (CmmLocal (LocalReg uq I64 _))) = do r_dst_lo <- getNewRegNat I32 let r_dst_hi = getHiVRegFromLo r_dst_lo r_src_lo = mkVReg uq I32 @@ -1046,8 +1042,7 @@ getRegister (CmmMachOp mop [x]) -- unary MachOps getRegister e@(CmmMachOp mop [x, y]) -- dyadic MachOps - = ASSERT2(cmmExprRep x /= I8, pprExpr e) - case mop of + = case mop of MO_Eq F32 -> condFltReg EQQ x y MO_Ne F32 -> condFltReg NE x y MO_S_Gt F32 -> condFltReg GTT x y @@ -1751,8 +1746,8 @@ getRegister (CmmLit lit) = let rep = cmmLitRep lit imm = litToImm lit code dst = toOL [ - LIS dst (HI imm), - OR dst dst (RIImm (LO imm)) + LIS dst (HA imm), + ADD dst dst (RIImm (LO imm)) ] in return (Any rep code) @@ -2969,7 +2964,7 @@ genCondJump id bool = do genCCall :: CmmCallTarget -- function to call - -> CmmHintFormals -- where to put the result + -> CmmFormals -- where to put the result -> CmmActuals -- arguments (of mixed type) -> NatM InstrBlock @@ -3054,7 +3049,7 @@ genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL -- we keep it this long in order to prevent earlier optimisations. -- we only cope with a single result for foreign calls -genCCall (CmmPrim op) [(r,_)] args = do +genCCall (CmmPrim op) [CmmHinted r _] args = do case op of MO_F32_Sqrt -> actuallyInlineFloatOp F32 (GSQRT F32) args MO_F64_Sqrt -> actuallyInlineFloatOp F64 (GSQRT F64) args @@ -3070,14 +3065,14 @@ genCCall (CmmPrim op) [(r,_)] args = do other_op -> outOfLineFloatOp op r args where - actuallyInlineFloatOp rep instr [(x,_)] + actuallyInlineFloatOp rep instr [CmmHinted x _] = do res <- trivialUFCode rep instr x any <- anyReg res return (any (getRegisterReg (CmmLocal r))) genCCall target dest_regs args = do let - sizes = map (arg_size . cmmExprRep . fst) (reverse args) + sizes = map (arg_size . cmmExprRep . hintlessCmm) (reverse args) #if !darwin_TARGET_OS tot_arg_size = sum sizes #else @@ -3129,7 +3124,7 @@ genCCall target dest_regs args = do let -- assign the results, if necessary assign_code [] = nilOL - assign_code [(dest,_hint)] = + assign_code [CmmHinted dest _hint] = case rep of I64 -> toOL [MOV I32 (OpReg eax) (OpReg r_dest), MOV I32 (OpReg edx) (OpReg r_dest_hi)] @@ -3156,10 +3151,10 @@ genCCall target dest_regs args = do | otherwise = x + a - (x `mod` a) - push_arg :: (CmmExpr,MachHint){-current argument-} + push_arg :: (CmmHinted CmmExpr){-current argument-} -> NatM InstrBlock -- code - push_arg (arg,_hint) -- we don't need the hints on x86 + push_arg (CmmHinted arg _hint) -- we don't need the hints on x86 | arg_rep == I64 = do ChildCode64 code r_lo <- iselExpr64 arg delta <- getDeltaNat @@ -3203,7 +3198,7 @@ genCCall target dest_regs args = do #if i386_TARGET_ARCH || x86_64_TARGET_ARCH -outOfLineFloatOp :: CallishMachOp -> CmmFormal -> CmmActuals +outOfLineFloatOp :: CallishMachOp -> CmmFormalWithoutKind -> CmmActuals -> NatM InstrBlock outOfLineFloatOp mop res args = do @@ -3213,13 +3208,13 @@ outOfLineFloatOp mop res args if localRegRep res == F64 then - stmtToInstrs (CmmCall target [(res,FloatHint)] args CmmUnsafe CmmMayReturn) + stmtToInstrs (CmmCall target [CmmHinted res FloatHint] args CmmUnsafe CmmMayReturn) else do uq <- getUniqueNat let - tmp = LocalReg uq F64 KindNonPtr + tmp = LocalReg uq F64 GCKindNonPtr -- in - code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args CmmUnsafe CmmMayReturn) + code1 <- stmtToInstrs (CmmCall target [CmmHinted tmp FloatHint] args CmmUnsafe CmmMayReturn) code2 <- stmtToInstrs (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) return (code1 `appOL` code2) where @@ -3268,7 +3263,8 @@ genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL -- write barrier compiles to no code on x86/x86-64; -- we keep it this long in order to prevent earlier optimisations. -genCCall (CmmPrim op) [(r,_)] args = + +genCCall (CmmPrim op) [CmmHinted r _] args = outOfLineFloatOp op r args genCCall target dest_regs args = do @@ -3348,7 +3344,7 @@ genCCall target dest_regs args = do let -- assign the results, if necessary assign_code [] = nilOL - assign_code [(dest,_hint)] = + assign_code [CmmHinted dest _hint] = case rep of F32 -> unitOL (MOV rep (OpReg xmm0) (OpReg r_dest)) F64 -> unitOL (MOV rep (OpReg xmm0) (OpReg r_dest)) @@ -3368,16 +3364,16 @@ genCCall target dest_regs args = do where arg_size = 8 -- always, at the mo - load_args :: [(CmmExpr,MachHint)] + load_args :: [CmmHinted CmmExpr] -> [Reg] -- int regs avail for args -> [Reg] -- FP regs avail for args -> InstrBlock - -> NatM ([(CmmExpr,MachHint)],[Reg],[Reg],InstrBlock) + -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock) load_args args [] [] code = return (args, [], [], code) -- no more regs to use load_args [] aregs fregs code = return ([], aregs, fregs, code) -- no more args to push - load_args ((arg,hint) : rest) aregs fregs code + load_args ((CmmHinted arg hint) : rest) aregs fregs code | isFloatingRep arg_rep = case fregs of [] -> push_this_arg @@ -3395,10 +3391,10 @@ genCCall target dest_regs args = do push_this_arg = do (args',ars,frs,code') <- load_args rest aregs fregs code - return ((arg,hint):args', ars, frs, code') + return ((CmmHinted arg hint):args', ars, frs, code') push_args [] code = return code - push_args ((arg,hint):rest) code + push_args ((CmmHinted arg hint):rest) code | isFloatingRep arg_rep = do (arg_reg, arg_code) <- getSomeReg arg delta <- getDeltaNat @@ -3459,7 +3455,7 @@ genCCall target dest_regs args = do genCCall target dest_regs argsAndHints = do let - args = map fst argsAndHints + args = map hintlessCmm argsAndHints argcode_and_vregs <- mapM arg_to_int_vregs args let (argcodes, vregss) = unzip argcode_and_vregs @@ -3694,7 +3690,7 @@ genCCall target dest_regs argsAndHints initialStackOffset = 8 stackDelta finalStack = roundTo 16 finalStack #endif - args = map fst argsAndHints + args = map hintlessCmm argsAndHints argReps = map cmmExprRep args roundTo a x | x `mod` a == 0 = x @@ -3809,7 +3805,7 @@ genCCall target dest_regs argsAndHints moveResult reduceToF32 = case dest_regs of [] -> nilOL - [(dest, _hint)] + [CmmHinted dest _hint] | reduceToF32 && rep == F32 -> unitOL (FRSP r_dest f1) | rep == F32 || rep == F64 -> unitOL (MR r_dest f1) | rep == I64 -> toOL [MR (getHiVRegFromLo r_dest) r3, @@ -3896,7 +3892,8 @@ genSwitch expr ids op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg wORD_SIZE) (ImmInt 0)) -#if x86_64_TARGET_ARCH && darwin_TARGET_OS +#if x86_64_TARGET_ARCH +#if darwin_TARGET_OS -- on Mac OS X/x86_64, put the jump table in the text section -- to work around a limitation of the linker. -- ld64 is unable to handle the relocations for @@ -3909,6 +3906,23 @@ genSwitch expr ids LDATA Text (CmmDataLabel lbl : jumpTable) ] #else + -- HACK: On x86_64 binutils<2.17 is only able to generate PC32 + -- relocations, hence we only get 32-bit offsets in the jump + -- table. As these offsets are always negative we need to properly + -- sign extend them to 64-bit. This hack should be removed in + -- conjunction with the hack in PprMach.hs/pprDataItem once + -- binutils 2.17 is standard. + code = e_code `appOL` t_code `appOL` toOL [ + LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), + MOVSxL I32 + (OpAddr (AddrBaseIndex (EABaseReg tableReg) + (EAIndex reg wORD_SIZE) (ImmInt 0))) + (OpReg reg), + ADD wordRep (OpReg reg) (OpReg tableReg), + JMP_TBL (OpReg tableReg) [ id | Just id <- ids ] + ] +#endif +#else code = e_code `appOL` t_code `appOL` toOL [ LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), ADD wordRep op (OpReg tableReg), @@ -3975,7 +3989,7 @@ genSwitch expr ids ] return code #else -genSwitch expr ids = panic "ToDo: genSwitch" +#error "ToDo: genSwitch" #endif jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordRep)