X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FAsmCodeGen.lhs;h=6510b41886a1a8d696a0694faac7c64f2355fd4c;hb=9e6162f9d0102d1f5738bf78258b24ea5a647ea4;hp=e98648b2829ea7f7b942796e78d1219b0c14628a;hpb=5065561a7d020e9b97a86d6711532701f6c4c35a;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index e98648b..6510b41 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -8,33 +8,44 @@ module AsmCodeGen ( nativeCodeGen ) where #include "HsVersions.h" #include "NCG.h" -import List ( intersperse ) - import MachMisc import MachRegs import MachCode import PprMach import AbsCStixGen ( genCodeAbstractC ) -import AbsCSyn ( AbstractC ) -import AbsCUtils ( mkAbsCStmtList ) +import AbsCSyn ( AbstractC, MagicId(..) ) +import AbsCUtils ( mkAbsCStmtList, magicIdPrimRep ) import AsmRegAlloc ( runRegAllocate ) -import PrimOp ( commutableOp, PrimOp(..) ) +import MachOp ( MachOp(..), isCommutableMachOp, isComparisonMachOp ) import RegAllocInfo ( findReservedRegs ) -import Stix ( StixTree(..), StixReg(..), - pprStixTrees, pprStixTree, - stixCountTempUses, stixSubst, - initNat, mapNat, +import Stix ( StixReg(..), StixStmt(..), StixExpr(..), StixVReg(..), + pprStixStmts, pprStixStmt, + stixStmt_CountTempUses, stixStmt_Subst, + liftStrings, + initNat, mkNatM_State, - uniqOfNatM_State, deltaOfNatM_State ) + uniqOfNatM_State, deltaOfNatM_State, + importsOfNatM_State ) import UniqSupply ( returnUs, thenUs, initUs, UniqSM, UniqSupply, lazyMapUs ) import MachMisc ( IF_ARCH_i386(i386_insert_ffrees,) ) +#if darwin_TARGET_OS +import PprMach ( pprDyldSymbolStub ) +import List ( group, sort ) +#endif -import OrdList ( concatOL ) +import qualified Pretty import Outputable +import FastString +-- DEBUGGING ONLY +--import OrdList + +#ifdef NCG_DEBUG +import List ( intersperse ) +#endif \end{code} The 96/03 native-code generator has machine-independent and @@ -42,9 +53,9 @@ machine-dependent modules (those \tr{#include}'ing \tr{NCG.h}). This module (@AsmCodeGen@) is the top-level machine-independent module. It uses @AbsCStixGen.genCodeAbstractC@ to produce @StixTree@s -(defined in module @Stix@), using support code from @StixInfo@ (info -tables), @StixPrim@ (primitive operations), @StixMacro@ (Abstract C -macros), and @StixInteger@ (GMP arbitrary-precision operations). +(defined in module @Stix@), using support code from @StixPrim@ +(primitive operations), @StixMacro@ (Abstract C macros), and +@StixInteger@ (GMP arbitrary-precision operations). Before entering machine-dependent land, we do some machine-independent @genericOpt@imisations (defined below) on the @StixTree@s. @@ -85,41 +96,56 @@ The machine-dependent bits break down as follows: So, here we go: \begin{code} -nativeCodeGen :: AbstractC -> UniqSupply -> (SDoc, SDoc) +nativeCodeGen :: AbstractC -> UniqSupply -> (SDoc, Pretty.Doc) nativeCodeGen absC us = let absCstmts = mkAbsCStmtList absC - (sdoc_pairs, us1) = initUs us (lazyMapUs absCtoNat absCstmts) - stix_sdocs = map fst sdoc_pairs - insn_sdocs = map snd sdoc_pairs + (results, us1) = initUs us (lazyMapUs absCtoNat absCstmts) + stix_sdocs = [ stix | (stix, insn, imports) <- results ] + insn_sdocs = [ insn | (stix, insn, imports) <- results ] + imports = [ imports | (stix, insn, imports) <- results ] - insn_sdoc = my_vcat insn_sdocs + insn_sdoc = my_vcat insn_sdocs IF_OS_darwin(Pretty.$$ dyld_stubs,) stix_sdoc = vcat stix_sdocs +#if darwin_TARGET_OS + -- Generate "symbol stubs" for all external symbols that might + -- come from a dynamic library. + + dyld_stubs = Pretty.vcat $ map pprDyldSymbolStub $ + map head $ group $ sort $ concat imports +#endif + # ifdef NCG_DEBUG my_trace m x = trace m x - my_vcat sds = vcat (intersperse (char ' ' - $$ ptext SLIT("# ___ncg_debug_marker") - $$ char ' ') - sds) + my_vcat sds = Pretty.vcat ( + intersperse ( + Pretty.char ' ' + Pretty.$$ Pretty.ptext SLIT("# ___ncg_debug_marker") + Pretty.$$ Pretty.char ' ' + ) + sds + ) # else - my_vcat sds = vcat sds + my_vcat sds = Pretty.vcat sds my_trace m x = x # endif - in - my_trace "nativeGen: begin" + in + my_trace "nativeGen: begin" (stix_sdoc, insn_sdoc) -absCtoNat :: AbstractC -> UniqSM (SDoc, SDoc) +absCtoNat :: AbstractC -> UniqSM (SDoc, Pretty.Doc, [FastString]) absCtoNat absC = _scc_ "genCodeAbstractC" genCodeAbstractC absC `thenUs` \ stixRaw -> _scc_ "genericOpt" genericOpt stixRaw `bind` \ stixOpt -> - _scc_ "genMachCode" genMachCode stixOpt `thenUs` \ pre_regalloc -> + _scc_ "liftStrings" liftStrings stixOpt `thenUs` \ stixLifted -> + _scc_ "genMachCode" genMachCode stixLifted `thenUs` \ (pre_regalloc, imports) -> _scc_ "regAlloc" regAlloc pre_regalloc `bind` \ almost_final -> _scc_ "x86fp_kludge" x86fp_kludge almost_final `bind` \ final_mach_code -> - _scc_ "vcat" vcat (map pprInstr final_mach_code) `bind` \ final_sdoc -> - _scc_ "pprStixTrees" pprStixTrees stixOpt `bind` \ stix_sdoc -> - returnUs (stix_sdoc, final_sdoc) + _scc_ "vcat" Pretty.vcat (map pprInstr final_mach_code) `bind` \ final_sdoc -> + _scc_ "pprStixTrees" pprStixStmts stixOpt `bind` \ stix_sdoc -> + returnUs ({-\_ -> Pretty.vcat (map pprInstr almost_final),-} + stix_sdoc, final_sdoc, imports) where bind f x = x f @@ -147,16 +173,17 @@ Switching between the two monads whilst carrying along the same Unique supply breaks abstraction. Is that bad? \begin{code} -genMachCode :: [StixTree] -> UniqSM InstrBlock +genMachCode :: [StixStmt] -> UniqSM (InstrBlock, [FastString]) genMachCode stmts initial_us = let initial_st = mkNatM_State initial_us 0 (instr_list, final_st) = initNat initial_st (stmtsToInstrs stmts) final_us = uniqOfNatM_State final_st final_delta = deltaOfNatM_State final_st + final_imports = importsOfNatM_State final_st in if final_delta == 0 - then (instr_list, final_us) + then ((instr_list, final_imports), final_us) else pprPanic "genMachCode: nonzero final delta" (int final_delta) \end{code} @@ -178,12 +205,12 @@ have introduced some new opportunities for constant-folding wrt address manipulations. \begin{code} -genericOpt :: [StixTree] -> [StixTree] -genericOpt = map stixConFold . stixPeep +genericOpt :: [StixStmt] -> [StixStmt] +genericOpt = map stixStmt_ConFold . stixPeep -stixPeep :: [StixTree] -> [StixTree] +stixPeep :: [StixStmt] -> [StixStmt] -- This transformation assumes that the temp assigned to in t1 -- is not assigned to in t2; for otherwise the target of the @@ -191,111 +218,138 @@ stixPeep :: [StixTree] -> [StixTree] -- code. As far as I can see, StixTemps are only ever assigned -- to once. It would be nice to be sure! -stixPeep ( t1@(StAssign pka (StReg (StixTemp u pk)) rhs) +stixPeep ( t1@(StAssignReg pka (StixTemp (StixVReg u pk)) rhs) : t2 : ts ) - | stixCountTempUses u t2 == 1 - && sum (map (stixCountTempUses u) ts) == 0 + | stixStmt_CountTempUses u t2 == 1 + && sum (map (stixStmt_CountTempUses u) ts) == 0 = # ifdef NCG_DEBUG - trace ("nativeGen: inlining " ++ showSDoc (pprStixTree rhs)) + trace ("nativeGen: inlining " ++ showSDoc (pprStixExpr rhs)) # endif - (stixPeep (stixSubst u rhs t2 : ts)) + (stixPeep (stixStmt_Subst u rhs t2 : ts)) stixPeep (t1:t2:ts) = t1 : stixPeep (t2:ts) stixPeep [t1] = [t1] stixPeep [] = [] - --- disable stix inlining until we figure out how to fix the --- latent bugs in the register allocator which are exposed by --- the inliner. ---stixPeep = id \end{code} For most nodes, just optimize the children. \begin{code} -stixConFold :: StixTree -> StixTree - -stixConFold (StInd pk addr) = StInd pk (stixConFold addr) - -stixConFold (StAssign pk dst src) - = StAssign pk (stixConFold dst) (stixConFold src) - -stixConFold (StJump dsts addr) = StJump dsts (stixConFold addr) - -stixConFold (StCondJump addr test) - = StCondJump addr (stixConFold test) - -stixConFold (StCall fn cconv pk args) - = StCall fn cconv pk (map stixConFold args) -\end{code} - -Fold indices together when the types match: -\begin{code} -stixConFold (StIndex pk (StIndex pk' base off) off') - | pk == pk' - = StIndex pk (stixConFold base) - (stixConFold (StPrim IntAddOp [off, off'])) - -stixConFold (StIndex pk base off) - = StIndex pk (stixConFold base) (stixConFold off) -\end{code} - -For PrimOps, we first optimize the children, and then we try our hand -at some constant-folding. - -\begin{code} -stixConFold (StPrim op args) = stixPrimFold op (map stixConFold args) -\end{code} - -Replace register leaves with appropriate StixTrees for the given -target. - -\begin{code} -stixConFold leaf@(StReg (StixMagicId id)) - = case (stgReg id) of - Always tree -> stixConFold tree - Save _ -> leaf - -stixConFold other = other +stixExpr_ConFold :: StixExpr -> StixExpr +stixStmt_ConFold :: StixStmt -> StixStmt + +stixStmt_ConFold stmt + = case stmt of + StAssignReg pk reg@(StixTemp _) src + -> StAssignReg pk reg (stixExpr_ConFold src) + StAssignReg pk reg@(StixMagicId mid) src + -- Replace register leaves with appropriate StixTrees for + -- the given target. MagicIds which map to a reg on this arch are left unchanged. + -- Assigning to BaseReg is always illegal, so we check for that. + -> case mid of { + BaseReg -> panic "stixStmt_ConFold: assignment to BaseReg"; + other -> + case get_MagicId_reg_or_addr mid of + Left realreg + -> StAssignReg pk reg (stixExpr_ConFold src) + Right baseRegAddr + -> stixStmt_ConFold (StAssignMem pk baseRegAddr src) + } + StAssignMem pk addr src + -> StAssignMem pk (stixExpr_ConFold addr) (stixExpr_ConFold src) + StVoidable expr + -> StVoidable (stixExpr_ConFold expr) + StJump dsts addr + -> StJump dsts (stixExpr_ConFold addr) + StCondJump addr test + -> let test_opt = stixExpr_ConFold test + in + if manifestlyZero test_opt + then StComment (mkFastString ("deleted: " ++ showSDoc (pprStixStmt stmt))) + else StCondJump addr (stixExpr_ConFold test) + StData pk datas + -> StData pk (map stixExpr_ConFold datas) + other + -> other + where + manifestlyZero (StInt 0) = True + manifestlyZero other = False + +stixExpr_ConFold expr + = case expr of + StInd pk addr + -> StInd pk (stixExpr_ConFold addr) + StCall fn cconv pk args + -> StCall fn cconv pk (map stixExpr_ConFold args) + StIndex pk (StIndex pk' base off) off' + -- Fold indices together when the types match: + | pk == pk' + -> StIndex pk (stixExpr_ConFold base) + (stixExpr_ConFold (StMachOp MO_Nat_Add [off, off'])) + StIndex pk base off + -> StIndex pk (stixExpr_ConFold base) (stixExpr_ConFold off) + + StMachOp mop args + -- For PrimOps, we first optimize the children, and then we try + -- our hand at some constant-folding. + -> stixMachOpFold mop (map stixExpr_ConFold args) + StReg (StixMagicId mid) + -- Replace register leaves with appropriate StixTrees for + -- the given target. MagicIds which map to a reg on this arch are left unchanged. + -- For the rest, BaseReg is taken to mean the address of the reg table + -- in MainCapability, and for all others we generate an indirection to + -- its location in the register table. + -> case get_MagicId_reg_or_addr mid of + Left realreg -> expr + Right baseRegAddr + -> case mid of + BaseReg -> stixExpr_ConFold baseRegAddr + other -> stixExpr_ConFold (StInd (magicIdPrimRep mid) baseRegAddr) + other + -> other \end{code} Now, try to constant-fold the PrimOps. The arguments have already been optimized and folded. \begin{code} -stixPrimFold - :: PrimOp -- The operation from an StPrim - -> [StixTree] -- The optimized arguments - -> StixTree - -stixPrimFold op arg@[StInt x] - = case op of - IntNegOp -> StInt (-x) - _ -> StPrim op arg - -stixPrimFold op args@[StInt x, StInt y] - = case op of - CharGtOp -> StInt (if x > y then 1 else 0) - CharGeOp -> StInt (if x >= y then 1 else 0) - CharEqOp -> StInt (if x == y then 1 else 0) - CharNeOp -> StInt (if x /= y then 1 else 0) - CharLtOp -> StInt (if x < y then 1 else 0) - CharLeOp -> StInt (if x <= y then 1 else 0) - IntAddOp -> StInt (x + y) - IntSubOp -> StInt (x - y) - IntMulOp -> StInt (x * y) - IntQuotOp -> StInt (x `quot` y) - IntRemOp -> StInt (x `rem` y) - IntGtOp -> StInt (if x > y then 1 else 0) - IntGeOp -> StInt (if x >= y then 1 else 0) - IntEqOp -> StInt (if x == y then 1 else 0) - IntNeOp -> StInt (if x /= y then 1 else 0) - IntLtOp -> StInt (if x < y then 1 else 0) - IntLeOp -> StInt (if x <= y then 1 else 0) - -- ToDo: WordQuotOp, WordRemOp. - _ -> StPrim op args +stixMachOpFold + :: MachOp -- The operation from an StMachOp + -> [StixExpr] -- The optimized arguments + -> StixExpr + +stixMachOpFold mop arg@[StInt x] + = case mop of + MO_NatS_Neg -> StInt (-x) + other -> StMachOp mop arg + +stixMachOpFold mop args@[StInt x, StInt y] + = case mop of + MO_32U_Gt -> StInt (if x > y then 1 else 0) + MO_32U_Ge -> StInt (if x >= y then 1 else 0) + MO_32U_Eq -> StInt (if x == y then 1 else 0) + MO_32U_Ne -> StInt (if x /= y then 1 else 0) + MO_32U_Lt -> StInt (if x < y then 1 else 0) + MO_32U_Le -> StInt (if x <= y then 1 else 0) + MO_Nat_Add -> StInt (x + y) + MO_Nat_Sub -> StInt (x - y) + MO_NatS_Mul -> StInt (x * y) + MO_NatS_Quot | y /= 0 -> StInt (x `quot` y) + MO_NatS_Rem | y /= 0 -> StInt (x `rem` y) + MO_NatS_Gt -> StInt (if x > y then 1 else 0) + MO_NatS_Ge -> StInt (if x >= y then 1 else 0) + MO_Nat_Eq -> StInt (if x == y then 1 else 0) + MO_Nat_Ne -> StInt (if x /= y then 1 else 0) + MO_NatS_Lt -> StInt (if x < y then 1 else 0) + MO_NatS_Le -> StInt (if x <= y then 1 else 0) + MO_Nat_Shl | y >= 0 && y < 32 -> do_shl x y + other -> StMachOp mop args + where + do_shl :: Integer -> Integer -> StixExpr + do_shl v 0 = StInt v + do_shl v n | n > 0 = do_shl (v*2) (n-1) \end{code} When possible, shift the constants to the right-hand side, so that we @@ -304,68 +358,65 @@ also assume that constants have been shifted to the right when possible. \begin{code} -stixPrimFold op [x@(StInt _), y] | commutableOp op = stixPrimFold op [y, x] +stixMachOpFold op [x@(StInt _), y] | isCommutableMachOp op + = stixMachOpFold op [y, x] \end{code} We can often do something with constants of 0 and 1 ... \begin{code} -stixPrimFold op args@[x, y@(StInt 0)] - = case op of - IntAddOp -> x - IntSubOp -> x - IntMulOp -> y - AndOp -> y - OrOp -> x - XorOp -> x - SllOp -> x - SrlOp -> x - ISllOp -> x - ISraOp -> x - ISrlOp -> x - IntNeOp | is_comparison -> x - _ -> StPrim op args +stixMachOpFold mop args@[x, y@(StInt 0)] + = case mop of + MO_Nat_Add -> x + MO_Nat_Sub -> x + MO_NatS_Mul -> y + MO_NatU_Mul -> y + MO_Nat_And -> y + MO_Nat_Or -> x + MO_Nat_Xor -> x + MO_Nat_Shl -> x + MO_Nat_Shr -> x + MO_Nat_Sar -> x + MO_Nat_Ne | x_is_comparison -> x + other -> StMachOp mop args where - is_comparison + x_is_comparison = case x of - StPrim opp [_, _] -> opp `elem` comparison_ops - _ -> False - -stixPrimFold op args@[x, y@(StInt 1)] - = case op of - IntMulOp -> x - IntQuotOp -> x - IntRemOp -> StInt 0 - _ -> StPrim op args + StMachOp mopp [_, _] -> isComparisonMachOp mopp + _ -> False + +stixMachOpFold mop args@[x, y@(StInt 1)] + = case mop of + MO_NatS_Mul -> x + MO_NatU_Mul -> x + MO_NatS_Quot -> x + MO_NatU_Quot -> x + MO_NatS_Rem -> StInt 0 + MO_NatU_Rem -> StInt 0 + other -> StMachOp mop args \end{code} Now look for multiplication/division by powers of 2 (integers). \begin{code} -stixPrimFold op args@[x, y@(StInt n)] - = case op of - IntMulOp -> case exactLog2 n of - Nothing -> StPrim op args - Just p -> StPrim ISllOp [x, StInt p] - IntQuotOp -> case exactLog2 n of - Nothing -> StPrim op args - Just p -> StPrim ISrlOp [x, StInt p] - _ -> StPrim op args +stixMachOpFold mop args@[x, y@(StInt n)] + = case mop of + MO_NatS_Mul + -> case exactLog2 n of + Nothing -> unchanged + Just p -> StMachOp MO_Nat_Shl [x, StInt p] + MO_NatS_Quot + -> case exactLog2 n of + Nothing -> unchanged + Just p -> StMachOp MO_Nat_Shr [x, StInt p] + other + -> unchanged + where + unchanged = StMachOp mop args \end{code} Anything else is just too hard. \begin{code} -stixPrimFold op args = StPrim op args -\end{code} - -\begin{code} -comparison_ops - = [ CharGtOp , CharGeOp , CharEqOp , CharNeOp , CharLtOp , CharLeOp, - IntGtOp , IntGeOp , IntEqOp , IntNeOp , IntLtOp , IntLeOp, - WordGtOp , WordGeOp , WordEqOp , WordNeOp , WordLtOp , WordLeOp, - AddrGtOp , AddrGeOp , AddrEqOp , AddrNeOp , AddrLtOp , AddrLeOp, - FloatGtOp , FloatGeOp , FloatEqOp , FloatNeOp , FloatLtOp , FloatLeOp, - DoubleGtOp, DoubleGeOp, DoubleEqOp, DoubleNeOp, DoubleLtOp, DoubleLeOp - ] +stixMachOpFold mop args = StMachOp mop args \end{code}